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_Ch11
; use Exp_Ch11
;
35 with Exp_Util
; use Exp_Util
;
36 with Fname
; use Fname
;
37 with Freeze
; use Freeze
;
38 with Itypes
; use Itypes
;
40 with Lib
.Xref
; use Lib
.Xref
;
41 with Namet
.Sp
; use Namet
.Sp
;
42 with Nlists
; use Nlists
;
43 with Nmake
; use Nmake
;
44 with Output
; use Output
;
45 with Restrict
; use Restrict
;
46 with Rident
; use Rident
;
47 with Rtsfind
; use Rtsfind
;
49 with Sem_Aux
; use Sem_Aux
;
50 with Sem_Attr
; use Sem_Attr
;
51 with Sem_Cat
; use Sem_Cat
;
52 with Sem_Ch6
; use Sem_Ch6
;
53 with Sem_Ch8
; use Sem_Ch8
;
54 with Sem_Ch13
; use Sem_Ch13
;
55 with Sem_Disp
; use Sem_Disp
;
56 with Sem_Elab
; use Sem_Elab
;
57 with Sem_Eval
; use Sem_Eval
;
58 with Sem_Prag
; use Sem_Prag
;
59 with Sem_Res
; use Sem_Res
;
60 with Sem_Warn
; use Sem_Warn
;
61 with Sem_Type
; use Sem_Type
;
62 with Sinfo
; use Sinfo
;
63 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
64 with Sinfo
.Utils
; use Sinfo
.Utils
;
65 with Sinput
; use Sinput
;
66 with Stand
; use Stand
;
68 with Stringt
; use Stringt
;
69 with Targparm
; use Targparm
;
70 with Tbuild
; use Tbuild
;
71 with Ttypes
; use Ttypes
;
72 with Uname
; use Uname
;
74 with GNAT
.Heap_Sort_G
;
75 with GNAT
.HTable
; use GNAT
.HTable
;
77 package body Sem_Util
is
79 ---------------------------
80 -- Local Data Structures --
81 ---------------------------
83 Invalid_Binder_Values
: array (Scalar_Id
) of Entity_Id
:= (others => Empty
);
84 -- A collection to hold the entities of the variables declared in package
85 -- System.Scalar_Values which describe the invalid values of scalar types.
87 Invalid_Binder_Values_Set
: Boolean := False;
88 -- This flag prevents multiple attempts to initialize Invalid_Binder_Values
90 Invalid_Floats
: array (Float_Scalar_Id
) of Ureal
:= (others => No_Ureal
);
91 -- A collection to hold the invalid values of float types as specified by
92 -- pragma Initialize_Scalars.
94 Invalid_Integers
: array (Integer_Scalar_Id
) of Uint
:= (others => No_Uint
);
95 -- A collection to hold the invalid values of integer types as specified
96 -- by pragma Initialize_Scalars.
98 -----------------------
99 -- Local Subprograms --
100 -----------------------
102 function Build_Component_Subtype
105 T
: Entity_Id
) return Node_Id
;
106 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
107 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
108 -- Loc is the source location, T is the original subtype.
110 procedure Examine_Array_Bounds
112 All_Static
: out Boolean;
113 Has_Empty
: out Boolean);
114 -- Inspect the index constraints of array type Typ. Flag All_Static is set
115 -- when all ranges are static. Flag Has_Empty is set only when All_Static
116 -- is set and indicates that at least one range is empty.
118 function Has_Enabled_Property
119 (Item_Id
: Entity_Id
;
120 Property
: Name_Id
) return Boolean;
121 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
122 -- Determine whether the state abstraction, object, or type denoted by
123 -- entity Item_Id has enabled property Property.
125 function Has_Null_Extension
(T
: Entity_Id
) return Boolean;
126 -- T is a derived tagged type. Check whether the type extension is null.
127 -- If the parent type is fully initialized, T can be treated as such.
129 function Is_Atomic_Object_Entity
(Id
: Entity_Id
) return Boolean;
130 -- Determine whether arbitrary entity Id denotes an atomic object as per
133 function Is_Container_Aggregate
(Exp
: Node_Id
) return Boolean;
134 -- Is the given expression a container aggregate?
137 with function Is_Effectively_Volatile_Entity
138 (Id
: Entity_Id
) return Boolean;
139 -- Function to use on object and type entities
140 function Is_Effectively_Volatile_Object_Shared
141 (N
: Node_Id
) return Boolean;
142 -- Shared function used to detect effectively volatile objects and
143 -- effectively volatile objects for reading.
145 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean;
146 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
147 -- with discriminants whose default values are static, examine only the
148 -- components in the selected variant to determine whether all of them
151 function Is_Preelaborable_Function
(Id
: Entity_Id
) return Boolean;
152 -- Ada 2022: Determine whether the specified function is suitable as the
153 -- name of a call in a preelaborable construct (RM 10.2.1(7/5)).
155 type Null_Status_Kind
is
157 -- This value indicates that a subexpression is known to have a null
158 -- value at compile time.
161 -- This value indicates that a subexpression is known to have a non-null
162 -- value at compile time.
165 -- This value indicates that it cannot be determined at compile time
166 -- whether a subexpression yields a null or non-null value.
168 function Null_Status
(N
: Node_Id
) return Null_Status_Kind
;
169 -- Determine whether subexpression N of an access type yields a null value,
170 -- a non-null value, or the value cannot be determined at compile time. The
171 -- routine does not take simple flow diagnostics into account, it relies on
172 -- static facts such as the presence of null exclusions.
174 function Subprogram_Name
(N
: Node_Id
) return String;
175 -- Return the fully qualified name of the enclosing subprogram for the
176 -- given node N, with file:line:col information appended, e.g.
177 -- "subp:file:line:col", corresponding to the source location of the
178 -- body of the subprogram.
180 -----------------------------
181 -- Abstract_Interface_List --
182 -----------------------------
184 function Abstract_Interface_List
(Typ
: Entity_Id
) return List_Id
is
188 if Is_Concurrent_Type
(Typ
) then
190 -- If we are dealing with a synchronized subtype, go to the base
191 -- type, whose declaration has the interface list.
193 Nod
:= Declaration_Node
(Base_Type
(Typ
));
195 if Nkind
(Nod
) in N_Full_Type_Declaration | N_Private_Type_Declaration
200 elsif Ekind
(Typ
) = E_Record_Type_With_Private
then
201 if Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
then
202 Nod
:= Type_Definition
(Parent
(Typ
));
204 elsif Nkind
(Parent
(Typ
)) = N_Private_Type_Declaration
then
205 if Present
(Full_View
(Typ
))
207 Nkind
(Parent
(Full_View
(Typ
))) = N_Full_Type_Declaration
209 Nod
:= Type_Definition
(Parent
(Full_View
(Typ
)));
211 -- If the full-view is not available we cannot do anything else
212 -- here (the source has errors).
218 -- Support for generic formals with interfaces is still missing ???
220 elsif Nkind
(Parent
(Typ
)) = N_Formal_Type_Declaration
then
225 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
);
229 elsif Ekind
(Typ
) = E_Record_Subtype
then
230 Nod
:= Type_Definition
(Parent
(Etype
(Typ
)));
232 elsif Ekind
(Typ
) = E_Record_Subtype_With_Private
then
234 -- Recurse, because parent may still be a private extension. Also
235 -- note that the full view of the subtype or the full view of its
236 -- base type may (both) be unavailable.
238 return Abstract_Interface_List
(Etype
(Typ
));
240 elsif Ekind
(Typ
) = E_Record_Type
then
241 if Nkind
(Parent
(Typ
)) = N_Formal_Type_Declaration
then
242 Nod
:= Formal_Type_Definition
(Parent
(Typ
));
244 Nod
:= Type_Definition
(Parent
(Typ
));
247 -- Otherwise the type is of a kind which does not implement interfaces
253 return Interface_List
(Nod
);
254 end Abstract_Interface_List
;
256 -------------------------
257 -- Accessibility_Level --
258 -------------------------
260 function Accessibility_Level
262 Level
: Accessibility_Level_Kind
;
263 In_Return_Context
: Boolean := False;
264 Allow_Alt_Model
: Boolean := True) return Node_Id
266 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
268 function Accessibility_Level
(Expr
: Node_Id
) return Node_Id
269 is (Accessibility_Level
(Expr
, Level
, In_Return_Context
));
270 -- Renaming of the enclosing function to facilitate recursive calls
272 function Make_Level_Literal
(Level
: Uint
) return Node_Id
;
273 -- Construct an integer literal representing an accessibility level
274 -- with its type set to Natural.
276 function Innermost_Master_Scope_Depth
(N
: Node_Id
) return Uint
;
277 -- Returns the scope depth of the given node's innermost
278 -- enclosing dynamic scope (effectively the accessibility
279 -- level of the innermost enclosing master).
281 function Function_Call_Or_Allocator_Level
(N
: Node_Id
) return Node_Id
;
282 -- Centralized processing of subprogram calls which may appear in
285 function Typ_Access_Level
(Typ
: Entity_Id
) return Uint
286 is (Type_Access_Level
(Typ
, Allow_Alt_Model
));
287 -- Renaming of Type_Access_Level with Allow_Alt_Model specified to avoid
288 -- passing the parameter specifically in every call.
290 ----------------------------------
291 -- Innermost_Master_Scope_Depth --
292 ----------------------------------
294 function Innermost_Master_Scope_Depth
(N
: Node_Id
) return Uint
is
295 Encl_Scop
: Entity_Id
;
297 Node_Par
: Node_Id
:= Parent
(N
);
298 Master_Lvl_Modifier
: Int
:= 0;
301 -- Locate the nearest enclosing node (by traversing Parents)
302 -- that Defining_Entity can be applied to, and return the
303 -- depth of that entity's nearest enclosing dynamic scope.
305 -- The rules that define what a master are defined in
306 -- RM 7.6.1 (3), and include statements and conditions for loops
307 -- among other things. These cases are detected properly ???
309 while Present
(Node_Par
) loop
310 Ent
:= Defining_Entity_Or_Empty
(Node_Par
);
312 if Present
(Ent
) then
313 Encl_Scop
:= Nearest_Dynamic_Scope
(Ent
);
315 -- Ignore transient scopes made during expansion
317 if Comes_From_Source
(Node_Par
) then
319 Scope_Depth_Default_0
(Encl_Scop
) + Master_Lvl_Modifier
;
322 -- For a return statement within a function, return
323 -- the depth of the function itself. This is not just
324 -- a small optimization, but matters when analyzing
325 -- the expression in an expression function before
326 -- the body is created.
328 elsif Nkind
(Node_Par
) in N_Extended_Return_Statement
329 | N_Simple_Return_Statement
331 return Scope_Depth
(Enclosing_Subprogram
(Node_Par
));
333 -- Statements are counted as masters
335 elsif Is_Master
(Node_Par
) then
336 Master_Lvl_Modifier
:= Master_Lvl_Modifier
+ 1;
340 Node_Par
:= Parent
(Node_Par
);
343 -- Should never reach the following return
345 pragma Assert
(False);
347 return Scope_Depth
(Current_Scope
) + 1;
348 end Innermost_Master_Scope_Depth
;
350 ------------------------
351 -- Make_Level_Literal --
352 ------------------------
354 function Make_Level_Literal
(Level
: Uint
) return Node_Id
is
355 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Level
);
358 Set_Etype
(Result
, Standard_Natural
);
360 end Make_Level_Literal
;
362 --------------------------------------
363 -- Function_Call_Or_Allocator_Level --
364 --------------------------------------
366 function Function_Call_Or_Allocator_Level
(N
: Node_Id
) return Node_Id
is
370 -- Results of functions are objects, so we either get the
371 -- accessibility of the function or, in case of a call which is
372 -- indirect, the level of the access-to-subprogram type.
374 -- This code looks wrong ???
376 if Nkind
(N
) = N_Function_Call
377 and then Ada_Version
< Ada_2005
379 if Is_Entity_Name
(Name
(N
)) then
380 return Make_Level_Literal
381 (Subprogram_Access_Level
(Entity
(Name
(N
))));
383 return Make_Level_Literal
384 (Typ_Access_Level
(Etype
(Prefix
(Name
(N
)))));
387 -- We ignore coextensions as they cannot be implemented under the
388 -- "small-integer" model.
390 elsif Nkind
(N
) = N_Allocator
391 and then (Is_Static_Coextension
(N
)
392 or else Is_Dynamic_Coextension
(N
))
394 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
397 -- Named access types have a designated level
399 if Is_Named_Access_Type
(Etype
(N
)) then
400 return Make_Level_Literal
(Typ_Access_Level
(Etype
(N
)));
402 -- Otherwise, the level is dictated by RM 3.10.2 (10.7/3)
405 -- Check No_Dynamic_Accessibility_Checks restriction override for
406 -- alternative accessibility model.
409 and then No_Dynamic_Accessibility_Checks_Enabled
(N
)
410 and then Is_Anonymous_Access_Type
(Etype
(N
))
412 -- In the alternative model the level is that of the
415 if Debug_Flag_Underscore_B
then
416 return Make_Level_Literal
(Typ_Access_Level
(Etype
(N
)));
418 -- For function calls the level is that of the innermost
419 -- master, otherwise (for allocators etc.) we get the level
420 -- of the corresponding anonymous access type, which is
421 -- calculated through the normal path of execution.
423 elsif Nkind
(N
) = N_Function_Call
then
424 return Make_Level_Literal
425 (Innermost_Master_Scope_Depth
(Expr
));
429 if Nkind
(N
) = N_Function_Call
then
430 -- Dynamic checks are generated when we are within a return
431 -- value or we are in a function call within an anonymous
432 -- access discriminant constraint of a return object (signified
433 -- by In_Return_Context) on the side of the callee.
435 -- So, in this case, return accessibility level of the
436 -- enclosing subprogram.
438 if In_Return_Value
(N
)
439 or else In_Return_Context
441 return Make_Level_Literal
442 (Subprogram_Access_Level
(Current_Subprogram
));
446 -- When the call is being dereferenced the level is that of the
447 -- enclosing master of the dereferenced call.
449 if Nkind
(Parent
(N
)) in N_Explicit_Dereference
450 | N_Indexed_Component
451 | N_Selected_Component
453 return Make_Level_Literal
454 (Innermost_Master_Scope_Depth
(Expr
));
457 -- Find any relevant enclosing parent nodes that designate an
458 -- object being initialized.
460 -- Note: The above is only relevant if the result is used "in its
461 -- entirety" as RM 3.10.2 (10.2/3) states. However, this is
462 -- accounted for in the case statement in the main body of
463 -- Accessibility_Level for N_Selected_Component.
465 Par
:= Parent
(Expr
);
467 while Present
(Par
) loop
468 -- Detect an expanded implicit conversion, typically this
469 -- occurs on implicitly converted actuals in calls.
471 -- Does this catch all implicit conversions ???
473 if Nkind
(Par
) = N_Type_Conversion
474 and then Is_Named_Access_Type
(Etype
(Par
))
476 return Make_Level_Literal
477 (Typ_Access_Level
(Etype
(Par
)));
480 -- Jump out when we hit an object declaration or the right-hand
481 -- side of an assignment, or a construct such as an aggregate
482 -- subtype indication which would be the result is not used
483 -- "in its entirety."
485 exit when Nkind
(Par
) in N_Object_Declaration
486 or else (Nkind
(Par
) = N_Assignment_Statement
487 and then Name
(Par
) /= Prev_Par
);
493 -- Assignment statements are handled in a similar way in
494 -- accordance to the left-hand part. However, strictly speaking,
495 -- this is illegal according to the RM, but this change is needed
496 -- to pass an ACATS C-test and is useful in general ???
499 when N_Object_Declaration
=>
500 return Make_Level_Literal
502 (Scope
(Defining_Identifier
(Par
))));
504 when N_Assignment_Statement
=>
505 -- Return the accessibility level of the left-hand part
507 return Accessibility_Level
509 Level
=> Object_Decl_Level
,
510 In_Return_Context
=> In_Return_Context
);
513 return Make_Level_Literal
514 (Innermost_Master_Scope_Depth
(Expr
));
517 end Function_Call_Or_Allocator_Level
;
521 E
: Entity_Id
:= Original_Node
(Expr
);
524 -- Start of processing for Accessibility_Level
527 -- We could be looking at a reference to a formal due to the expansion
528 -- of entries and other cases, so obtain the renaming if necessary.
530 if Present
(Param_Entity
(Expr
)) then
531 E
:= Param_Entity
(Expr
);
534 -- Extract the entity
536 if Nkind
(E
) in N_Has_Entity
and then Present
(Entity
(E
)) then
539 -- Deal with a possible renaming of a private protected component
541 if Ekind
(E
) in E_Constant | E_Variable
and then Is_Prival
(E
) then
542 E
:= Prival_Link
(E
);
546 -- Perform the processing on the expression
549 -- The level of an aggregate is that of the innermost master that
550 -- evaluates it as defined in RM 3.10.2 (10/4).
553 return Make_Level_Literal
(Innermost_Master_Scope_Depth
(Expr
));
555 -- The accessibility level is that of the access type, except for an
556 -- anonymous allocators which have special rules defined in RM 3.10.2
560 return Function_Call_Or_Allocator_Level
(E
);
562 -- We could reach this point for two reasons. Either the expression
563 -- applies to a special attribute ('Loop_Entry, 'Result, or 'Old), or
564 -- we are looking at the access attributes directly ('Access,
565 -- 'Address, or 'Unchecked_Access).
567 when N_Attribute_Reference
=>
568 Pre
:= Original_Node
(Prefix
(E
));
570 -- Regular 'Access attribute presence means we have to look at the
573 if Attribute_Name
(E
) = Name_Access
then
574 return Accessibility_Level
(Prefix
(E
));
576 -- Unchecked or unrestricted attributes have unlimited depth
578 elsif Attribute_Name
(E
) in Name_Address
579 | Name_Unchecked_Access
580 | Name_Unrestricted_Access
582 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
584 -- 'Access can be taken further against other special attributes,
585 -- so handle these cases explicitly.
587 elsif Attribute_Name
(E
)
588 in Name_Old | Name_Loop_Entry | Name_Result
590 -- Named access types
592 if Is_Named_Access_Type
(Etype
(Pre
)) then
593 return Make_Level_Literal
594 (Typ_Access_Level
(Etype
(Pre
)));
596 -- Anonymous access types
598 elsif Nkind
(Pre
) in N_Has_Entity
599 and then Present
(Get_Dynamic_Accessibility
(Entity
(Pre
)))
600 and then Level
= Dynamic_Level
602 return New_Occurrence_Of
603 (Get_Dynamic_Accessibility
(Entity
(Pre
)), Loc
);
605 -- Otherwise the level is treated in a similar way as
606 -- aggregates according to RM 6.1.1 (35.1/4) which concerns
607 -- an implicit constant declaration - in turn defining the
608 -- accessibility level to be that of the implicit constant
612 return Make_Level_Literal
613 (Innermost_Master_Scope_Depth
(Expr
));
620 -- This is the "base case" for accessibility level calculations which
621 -- means we are near the end of our recursive traversal.
623 when N_Defining_Identifier
=>
624 -- A dynamic check is performed on the side of the callee when we
625 -- are within a return statement, so return a library-level
626 -- accessibility level to null out checks on the side of the
629 if Is_Explicitly_Aliased
(E
)
630 and then (In_Return_Context
631 or else (Level
/= Dynamic_Level
632 and then In_Return_Value
(Expr
)))
634 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
636 -- Something went wrong and an extra accessibility formal has not
637 -- been generated when one should have ???
640 and then not Present
(Get_Dynamic_Accessibility
(E
))
641 and then Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
643 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
645 -- Stand-alone object of an anonymous access type "SAOAAT"
648 or else Ekind
(E
) in E_Variable
650 and then Present
(Get_Dynamic_Accessibility
(E
))
651 and then (Level
= Dynamic_Level
652 or else Level
= Zero_On_Dynamic_Level
)
654 if Level
= Zero_On_Dynamic_Level
then
655 return Make_Level_Literal
656 (Scope_Depth
(Standard_Standard
));
659 -- No_Dynamic_Accessibility_Checks restriction override for
660 -- alternative accessibility model.
663 and then No_Dynamic_Accessibility_Checks_Enabled
(E
)
665 -- In the alternative model the level is that of the
666 -- designated type entity's context.
668 if Debug_Flag_Underscore_B
then
669 return Make_Level_Literal
(Typ_Access_Level
(Etype
(E
)));
671 -- Otherwise the level depends on the entity's context
673 elsif Is_Formal
(E
) then
674 return Make_Level_Literal
675 (Subprogram_Access_Level
676 (Enclosing_Subprogram
(E
)));
678 return Make_Level_Literal
679 (Scope_Depth
(Enclosing_Dynamic_Scope
(E
)));
683 -- Return the dynamic level in the normal case
685 return New_Occurrence_Of
686 (Get_Dynamic_Accessibility
(E
), Loc
);
688 -- Initialization procedures have a special extra accessibility
689 -- parameter associated with the level at which the object
690 -- being initialized exists
692 elsif Ekind
(E
) = E_Record_Type
693 and then Is_Limited_Record
(E
)
694 and then Current_Scope
= Init_Proc
(E
)
695 and then Present
(Init_Proc_Level_Formal
(Current_Scope
))
697 return New_Occurrence_Of
698 (Init_Proc_Level_Formal
(Current_Scope
), Loc
);
700 -- Current instance of the type is deeper than that of the type
701 -- according to RM 3.10.2 (21).
703 elsif Is_Type
(E
) then
704 -- When restriction No_Dynamic_Accessibility_Checks is active
705 -- along with -gnatd_b.
708 and then No_Dynamic_Accessibility_Checks_Enabled
(E
)
709 and then Debug_Flag_Underscore_B
711 return Make_Level_Literal
(Typ_Access_Level
(E
));
716 return Make_Level_Literal
(Typ_Access_Level
(E
) + 1);
718 -- Move up the renamed entity or object if it came from source
719 -- since expansion may have created a dummy renaming under
720 -- certain circumstances.
722 -- Note: We check if the original node of the renaming comes
723 -- from source because the node may have been rewritten.
725 elsif Present
(Renamed_Entity_Or_Object
(E
))
726 and then Comes_From_Source
727 (Original_Node
(Renamed_Entity_Or_Object
(E
)))
729 return Accessibility_Level
(Renamed_Entity_Or_Object
(E
));
731 -- Named access types get their level from their associated type
733 elsif Is_Named_Access_Type
(Etype
(E
)) then
734 return Make_Level_Literal
735 (Typ_Access_Level
(Etype
(E
)));
737 -- Check if E is an expansion-generated renaming of an iterator
738 -- by examining Related_Expression. If so, determine the
739 -- accessibility level based on the original expression.
741 elsif Ekind
(E
) in E_Constant | E_Variable
742 and then Present
(Related_Expression
(E
))
744 return Accessibility_Level
(Related_Expression
(E
));
746 elsif Level
= Dynamic_Level
747 and then Ekind
(E
) in E_In_Parameter | E_In_Out_Parameter
748 and then Present
(Init_Proc_Level_Formal
(Scope
(E
)))
750 return New_Occurrence_Of
751 (Init_Proc_Level_Formal
(Scope
(E
)), Loc
);
753 -- Normal object - get the level of the enclosing scope
756 return Make_Level_Literal
757 (Scope_Depth
(Enclosing_Dynamic_Scope
(E
)));
760 -- Handle indexed and selected components including the special cases
761 -- whereby there is an implicit dereference, a component of a
762 -- composite type, or a function call in prefix notation.
764 -- We don't handle function calls in prefix notation correctly ???
766 when N_Indexed_Component | N_Selected_Component
=>
767 Pre
:= Original_Node
(Prefix
(E
));
769 -- When E is an indexed component or selected component and
770 -- the current Expr is a function call, we know that we are
771 -- looking at an expanded call in prefix notation.
773 if Nkind
(Expr
) = N_Function_Call
then
774 return Function_Call_Or_Allocator_Level
(Expr
);
776 -- If the prefix is a named access type, then we are dealing
777 -- with an implicit deferences. In that case the level is that
778 -- of the named access type in the prefix.
780 elsif Is_Named_Access_Type
(Etype
(Pre
)) then
781 return Make_Level_Literal
782 (Typ_Access_Level
(Etype
(Pre
)));
784 -- The current expression is a named access type, so there is no
785 -- reason to look at the prefix. Instead obtain the level of E's
786 -- named access type.
788 elsif Is_Named_Access_Type
(Etype
(E
)) then
789 return Make_Level_Literal
790 (Typ_Access_Level
(Etype
(E
)));
792 -- A nondiscriminant selected component where the component
793 -- is an anonymous access type means that its associated
794 -- level is that of the containing type - see RM 3.10.2 (16).
796 -- Note that when restriction No_Dynamic_Accessibility_Checks is
797 -- in effect we treat discriminant components as regular
800 elsif Nkind
(E
) = N_Selected_Component
801 and then Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
802 and then Ekind
(Etype
(Pre
)) /= E_Anonymous_Access_Type
803 and then (not (Nkind
(Selector_Name
(E
)) in N_Has_Entity
804 and then Ekind
(Entity
(Selector_Name
(E
)))
807 -- The alternative accessibility models both treat
808 -- discriminants as regular components.
810 or else (No_Dynamic_Accessibility_Checks_Enabled
(E
)
811 and then Allow_Alt_Model
))
813 -- When restriction No_Dynamic_Accessibility_Checks is active
814 -- and -gnatd_b set, the level is that of the designated type.
817 and then No_Dynamic_Accessibility_Checks_Enabled
(E
)
818 and then Debug_Flag_Underscore_B
820 return Make_Level_Literal
821 (Typ_Access_Level
(Etype
(E
)));
824 -- Otherwise proceed normally
826 return Make_Level_Literal
827 (Typ_Access_Level
(Etype
(Prefix
(E
))));
829 -- Similar to the previous case - arrays featuring components of
830 -- anonymous access components get their corresponding level from
831 -- their containing type's declaration.
833 elsif Nkind
(E
) = N_Indexed_Component
834 and then Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
835 and then Ekind
(Etype
(Pre
)) in Array_Kind
836 and then Ekind
(Component_Type
(Base_Type
(Etype
(Pre
))))
837 = E_Anonymous_Access_Type
839 -- When restriction No_Dynamic_Accessibility_Checks is active
840 -- and -gnatd_b set, the level is that of the designated type.
843 and then No_Dynamic_Accessibility_Checks_Enabled
(E
)
844 and then Debug_Flag_Underscore_B
846 return Make_Level_Literal
847 (Typ_Access_Level
(Etype
(E
)));
850 -- Otherwise proceed normally
852 return Make_Level_Literal
853 (Typ_Access_Level
(Etype
(Prefix
(E
))));
855 -- The accessibility calculation routine that handles function
856 -- calls (Function_Call_Level) assumes, in the case the
857 -- result is of an anonymous access type, that the result will be
858 -- used "in its entirety" when the call is present within an
859 -- assignment or object declaration.
861 -- To properly handle cases where the result is not used in its
862 -- entirety, we test if the prefix of the component in question is
863 -- a function call, which tells us that one of its components has
864 -- been identified and is being accessed. Therefore we can
865 -- conclude that the result is not used "in its entirety"
866 -- according to RM 3.10.2 (10.2/3).
868 elsif Nkind
(Pre
) = N_Function_Call
869 and then not Is_Named_Access_Type
(Etype
(Pre
))
871 -- Dynamic checks are generated when we are within a return
872 -- value or we are in a function call within an anonymous
873 -- access discriminant constraint of a return object (signified
874 -- by In_Return_Context) on the side of the callee.
876 -- So, in this case, return a library accessibility level to
877 -- null out the check on the side of the caller.
879 if (In_Return_Value
(E
)
880 or else In_Return_Context
)
881 and then Level
/= Dynamic_Level
883 return Make_Level_Literal
884 (Scope_Depth
(Standard_Standard
));
887 return Make_Level_Literal
888 (Innermost_Master_Scope_Depth
(Expr
));
890 -- Otherwise, continue recursing over the expression prefixes
893 return Accessibility_Level
(Prefix
(E
));
896 -- Qualified expressions
898 when N_Qualified_Expression
=>
899 if Is_Named_Access_Type
(Etype
(E
)) then
900 return Make_Level_Literal
901 (Typ_Access_Level
(Etype
(E
)));
903 return Accessibility_Level
(Expression
(E
));
906 -- Handle function calls
908 when N_Function_Call
=>
909 return Function_Call_Or_Allocator_Level
(E
);
911 -- Explicit dereference accessibility level calculation
913 when N_Explicit_Dereference
=>
914 Pre
:= Original_Node
(Prefix
(E
));
916 -- The prefix is a named access type so the level is taken from
919 if Is_Named_Access_Type
(Etype
(Pre
)) then
920 return Make_Level_Literal
(Typ_Access_Level
(Etype
(Pre
)));
922 -- Otherwise, recurse deeper
925 return Accessibility_Level
(Prefix
(E
));
930 when N_Type_Conversion | N_Unchecked_Type_Conversion
=>
931 -- View conversions are special in that they require use to
932 -- inspect the expression of the type conversion.
934 -- Allocators of anonymous access types are internally generated,
935 -- so recurse deeper in that case as well.
937 if Is_View_Conversion
(E
)
938 or else Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
940 return Accessibility_Level
(Expression
(E
));
942 -- We don't care about the master if we are looking at a named
945 elsif Is_Named_Access_Type
(Etype
(E
)) then
946 return Make_Level_Literal
947 (Typ_Access_Level
(Etype
(E
)));
949 -- In section RM 3.10.2 (10/4) the accessibility rules for
950 -- aggregates and value conversions are outlined. Are these
951 -- followed in the case of initialization of an object ???
953 -- Should use Innermost_Master_Scope_Depth ???
956 return Accessibility_Level
(Current_Scope
);
959 -- Default to the type accessibility level for the type of the
960 -- expression's entity.
963 return Make_Level_Literal
(Typ_Access_Level
(Etype
(E
)));
965 end Accessibility_Level
;
967 --------------------------------
968 -- Static_Accessibility_Level --
969 --------------------------------
971 function Static_Accessibility_Level
973 Level
: Static_Accessibility_Level_Kind
;
974 In_Return_Context
: Boolean := False) return Uint
978 (Accessibility_Level
(Expr
, Level
, In_Return_Context
));
979 end Static_Accessibility_Level
;
981 ----------------------------------
982 -- Acquire_Warning_Match_String --
983 ----------------------------------
985 function Acquire_Warning_Match_String
(Str_Lit
: Node_Id
) return String is
986 S
: constant String := To_String
(Strval
(Str_Lit
));
991 -- Put "*" before or after or both, if it's not already there
994 F
: constant Boolean := S
(S
'First) = '*';
995 L
: constant Boolean := S
(S
'Last) = '*';
1007 return "*" & S
& "*";
1012 end Acquire_Warning_Match_String
;
1014 --------------------------------
1015 -- Add_Access_Type_To_Process --
1016 --------------------------------
1018 procedure Add_Access_Type_To_Process
(E
: Entity_Id
; A
: Entity_Id
) is
1022 Ensure_Freeze_Node
(E
);
1023 L
:= Access_Types_To_Process
(Freeze_Node
(E
));
1027 Set_Access_Types_To_Process
(Freeze_Node
(E
), L
);
1031 end Add_Access_Type_To_Process
;
1033 --------------------------
1034 -- Add_Block_Identifier --
1035 --------------------------
1037 procedure Add_Block_Identifier
(N
: Node_Id
; Id
: out Entity_Id
) is
1038 Loc
: constant Source_Ptr
:= Sloc
(N
);
1040 pragma Assert
(Nkind
(N
) = N_Block_Statement
);
1042 -- The block already has a label, return its entity
1044 if Present
(Identifier
(N
)) then
1045 Id
:= Entity
(Identifier
(N
));
1047 -- Create a new block label and set its attributes
1050 Id
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
1051 Set_Etype
(Id
, Standard_Void_Type
);
1054 Set_Identifier
(N
, New_Occurrence_Of
(Id
, Loc
));
1055 Set_Block_Node
(Id
, Identifier
(N
));
1057 end Add_Block_Identifier
;
1059 ----------------------------
1060 -- Add_Global_Declaration --
1061 ----------------------------
1063 procedure Add_Global_Declaration
(N
: Node_Id
) is
1064 Aux_Node
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Current_Sem_Unit
));
1067 if No
(Declarations
(Aux_Node
)) then
1068 Set_Declarations
(Aux_Node
, New_List
);
1071 Append_To
(Declarations
(Aux_Node
), N
);
1073 end Add_Global_Declaration
;
1075 --------------------------------
1076 -- Address_Integer_Convert_OK --
1077 --------------------------------
1079 function Address_Integer_Convert_OK
(T1
, T2
: Entity_Id
) return Boolean is
1081 if Allow_Integer_Address
1082 and then ((Is_Descendant_Of_Address
(T1
)
1083 and then Is_Private_Type
(T1
)
1084 and then Is_Integer_Type
(T2
))
1086 (Is_Descendant_Of_Address
(T2
)
1087 and then Is_Private_Type
(T2
)
1088 and then Is_Integer_Type
(T1
)))
1094 end Address_Integer_Convert_OK
;
1100 function Address_Value
(N
: Node_Id
) return Node_Id
is
1101 Expr
: Node_Id
:= N
;
1105 -- For constant, get constant expression
1107 if Is_Entity_Name
(Expr
)
1108 and then Ekind
(Entity
(Expr
)) = E_Constant
1110 Expr
:= Constant_Value
(Entity
(Expr
));
1112 -- For unchecked conversion, get result to convert
1114 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
1115 Expr
:= Expression
(Expr
);
1117 -- For (common case) of To_Address call, get argument
1119 elsif Nkind
(Expr
) = N_Function_Call
1120 and then Is_Entity_Name
(Name
(Expr
))
1121 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
1123 Expr
:= First_Actual
(Expr
);
1125 -- We finally have the real expression
1139 function Addressable
(V
: Uint
) return Boolean is
1145 return V
= Uint_8
or else
1149 (V
= Uint_128
and then System_Max_Integer_Size
= 128);
1152 function Addressable
(V
: Int
) return Boolean is
1154 return V
= 8 or else
1158 V
= System_Max_Integer_Size
;
1161 ---------------------------------
1162 -- Aggregate_Constraint_Checks --
1163 ---------------------------------
1165 procedure Aggregate_Constraint_Checks
1167 Check_Typ
: Entity_Id
)
1169 Exp_Typ
: constant Entity_Id
:= Etype
(Exp
);
1172 if Raises_Constraint_Error
(Exp
) then
1176 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access
1177 -- component's type to force the appropriate accessibility checks.
1179 -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to
1180 -- force the corresponding run-time check
1182 if Is_Access_Type
(Check_Typ
)
1183 and then Is_Local_Anonymous_Access
(Check_Typ
)
1185 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
1186 Analyze_And_Resolve
(Exp
, Check_Typ
);
1187 Check_Unset_Reference
(Exp
);
1190 -- What follows is really expansion activity, so check that expansion
1191 -- is on and is allowed. In GNATprove mode, we also want check flags to
1192 -- be added in the tree, so that the formal verification can rely on
1193 -- those to be present. In GNATprove mode for formal verification, some
1194 -- treatment typically only done during expansion needs to be performed
1195 -- on the tree, but it should not be applied inside generics. Otherwise,
1196 -- this breaks the name resolution mechanism for generic instances.
1198 if not Expander_Active
1199 and (Inside_A_Generic
or not Full_Analysis
or not GNATprove_Mode
)
1204 if Is_Access_Type
(Check_Typ
)
1205 and then Can_Never_Be_Null
(Check_Typ
)
1206 and then not Can_Never_Be_Null
(Exp_Typ
)
1208 Install_Null_Excluding_Check
(Exp
);
1211 -- First check if we have to insert discriminant checks
1213 if Has_Discriminants
(Exp_Typ
) then
1214 Apply_Discriminant_Check
(Exp
, Check_Typ
);
1216 -- Next emit length checks for array aggregates
1218 elsif Is_Array_Type
(Exp_Typ
) then
1219 Apply_Length_Check
(Exp
, Check_Typ
);
1221 -- Finally emit scalar and string checks. If we are dealing with a
1222 -- scalar literal we need to check by hand because the Etype of
1223 -- literals is not necessarily correct.
1225 elsif Is_Scalar_Type
(Exp_Typ
)
1226 and then Compile_Time_Known_Value
(Exp
)
1228 if Is_Out_Of_Range
(Exp
, Base_Type
(Check_Typ
)) then
1229 Apply_Compile_Time_Constraint_Error
1230 (Exp
, "value not in range of}??", CE_Range_Check_Failed
,
1231 Ent
=> Base_Type
(Check_Typ
),
1232 Typ
=> Base_Type
(Check_Typ
));
1234 elsif Is_Out_Of_Range
(Exp
, Check_Typ
) then
1235 Apply_Compile_Time_Constraint_Error
1236 (Exp
, "value not in range of}??", CE_Range_Check_Failed
,
1240 elsif not Range_Checks_Suppressed
(Check_Typ
) then
1241 Apply_Scalar_Range_Check
(Exp
, Check_Typ
);
1244 -- Verify that target type is also scalar, to prevent view anomalies
1245 -- in instantiations.
1247 elsif (Is_Scalar_Type
(Exp_Typ
)
1248 or else Nkind
(Exp
) = N_String_Literal
)
1249 and then Is_Scalar_Type
(Check_Typ
)
1250 and then Exp_Typ
/= Check_Typ
1252 if Is_Entity_Name
(Exp
)
1253 and then Ekind
(Entity
(Exp
)) = E_Constant
1255 -- If expression is a constant, it is worthwhile checking whether
1256 -- it is a bound of the type.
1258 if (Is_Entity_Name
(Type_Low_Bound
(Check_Typ
))
1259 and then Entity
(Exp
) = Entity
(Type_Low_Bound
(Check_Typ
)))
1261 (Is_Entity_Name
(Type_High_Bound
(Check_Typ
))
1262 and then Entity
(Exp
) = Entity
(Type_High_Bound
(Check_Typ
)))
1267 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
1268 Analyze_And_Resolve
(Exp
, Check_Typ
);
1269 Check_Unset_Reference
(Exp
);
1272 -- Could use a comment on this case ???
1275 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
1276 Analyze_And_Resolve
(Exp
, Check_Typ
);
1277 Check_Unset_Reference
(Exp
);
1281 end Aggregate_Constraint_Checks
;
1283 -----------------------
1284 -- Alignment_In_Bits --
1285 -----------------------
1287 function Alignment_In_Bits
(E
: Entity_Id
) return Uint
is
1289 return Alignment
(E
) * System_Storage_Unit
;
1290 end Alignment_In_Bits
;
1292 --------------------------------------
1293 -- All_Composite_Constraints_Static --
1294 --------------------------------------
1296 function All_Composite_Constraints_Static
1297 (Constr
: Node_Id
) return Boolean
1300 if No
(Constr
) or else Error_Posted
(Constr
) then
1304 case Nkind
(Constr
) is
1306 if Nkind
(Constr
) in N_Has_Entity
1307 and then Present
(Entity
(Constr
))
1309 if Is_Type
(Entity
(Constr
)) then
1311 not Is_Discrete_Type
(Entity
(Constr
))
1312 or else Is_OK_Static_Subtype
(Entity
(Constr
));
1315 elsif Nkind
(Constr
) = N_Range
then
1317 Is_OK_Static_Expression
(Low_Bound
(Constr
))
1319 Is_OK_Static_Expression
(High_Bound
(Constr
));
1321 elsif Nkind
(Constr
) = N_Attribute_Reference
1322 and then Attribute_Name
(Constr
) = Name_Range
1325 Is_OK_Static_Expression
1326 (Type_Low_Bound
(Etype
(Prefix
(Constr
))))
1328 Is_OK_Static_Expression
1329 (Type_High_Bound
(Etype
(Prefix
(Constr
))));
1333 not Present
(Etype
(Constr
)) -- previous error
1334 or else not Is_Discrete_Type
(Etype
(Constr
))
1335 or else Is_OK_Static_Expression
(Constr
);
1337 when N_Discriminant_Association
=>
1338 return All_Composite_Constraints_Static
(Expression
(Constr
));
1340 when N_Range_Constraint
=>
1342 All_Composite_Constraints_Static
(Range_Expression
(Constr
));
1344 when N_Index_Or_Discriminant_Constraint
=>
1346 One_Cstr
: Entity_Id
;
1348 One_Cstr
:= First
(Constraints
(Constr
));
1349 while Present
(One_Cstr
) loop
1350 if not All_Composite_Constraints_Static
(One_Cstr
) then
1360 when N_Subtype_Indication
=>
1362 All_Composite_Constraints_Static
(Subtype_Mark
(Constr
))
1364 All_Composite_Constraints_Static
(Constraint
(Constr
));
1367 raise Program_Error
;
1369 end All_Composite_Constraints_Static
;
1371 ------------------------
1372 -- Append_Entity_Name --
1373 ------------------------
1375 procedure Append_Entity_Name
(Buf
: in out Bounded_String
; E
: Entity_Id
) is
1376 Temp
: Bounded_String
;
1378 procedure Inner
(E
: Entity_Id
);
1379 -- Inner recursive routine, keep outer routine nonrecursive to ease
1380 -- debugging when we get strange results from this routine.
1386 procedure Inner
(E
: Entity_Id
) is
1390 -- If entity has an internal name, skip by it, and print its scope.
1391 -- Note that we strip a final R from the name before the test; this
1392 -- is needed for some cases of instantiations.
1395 E_Name
: Bounded_String
;
1398 Append
(E_Name
, Chars
(E
));
1400 if E_Name
.Chars
(E_Name
.Length
) = 'R' then
1401 E_Name
.Length
:= E_Name
.Length
- 1;
1404 if Is_Internal_Name
(E_Name
) then
1412 -- Just print entity name if its scope is at the outer level
1414 if Scop
= Standard_Standard
then
1417 -- If scope comes from source, write scope and entity
1419 elsif Comes_From_Source
(Scop
) then
1420 Append_Entity_Name
(Temp
, Scop
);
1423 -- If in wrapper package skip past it
1425 elsif Present
(Scop
) and then Is_Wrapper_Package
(Scop
) then
1426 Append_Entity_Name
(Temp
, Scope
(Scop
));
1429 -- Otherwise nothing to output (happens in unnamed block statements)
1438 E_Name
: Bounded_String
;
1441 Append_Unqualified_Decoded
(E_Name
, Chars
(E
));
1443 -- Remove trailing upper-case letters from the name (useful for
1444 -- dealing with some cases of internal names generated in the case
1445 -- of references from within a generic).
1447 while E_Name
.Length
> 1
1448 and then E_Name
.Chars
(E_Name
.Length
) in 'A' .. 'Z'
1450 E_Name
.Length
:= E_Name
.Length
- 1;
1453 -- Adjust casing appropriately (gets name from source if possible)
1455 Adjust_Name_Case
(E_Name
, Sloc
(E
));
1456 Append
(Temp
, E_Name
);
1460 -- Start of processing for Append_Entity_Name
1465 end Append_Entity_Name
;
1467 ---------------------------------
1468 -- Append_Inherited_Subprogram --
1469 ---------------------------------
1471 procedure Append_Inherited_Subprogram
(S
: Entity_Id
) is
1472 Par
: constant Entity_Id
:= Alias
(S
);
1473 -- The parent subprogram
1475 Scop
: constant Entity_Id
:= Scope
(Par
);
1476 -- The scope of definition of the parent subprogram
1478 Typ
: constant Entity_Id
:= Defining_Entity
(Parent
(S
));
1479 -- The derived type of which S is a primitive operation
1485 if Ekind
(Current_Scope
) = E_Package
1486 and then In_Private_Part
(Current_Scope
)
1487 and then Has_Private_Declaration
(Typ
)
1488 and then Is_Tagged_Type
(Typ
)
1489 and then Scop
= Current_Scope
1491 -- The inherited operation is available at the earliest place after
1492 -- the derived type declaration (RM 7.3.1 (6/1)). This is only
1493 -- relevant for type extensions. If the parent operation appears
1494 -- after the type extension, the operation is not visible.
1497 (Visible_Declarations
1498 (Package_Specification
(Current_Scope
)));
1499 while Present
(Decl
) loop
1500 if Nkind
(Decl
) = N_Private_Extension_Declaration
1501 and then Defining_Entity
(Decl
) = Typ
1503 if Sloc
(Decl
) > Sloc
(Par
) then
1504 Next_E
:= Next_Entity
(Par
);
1505 Link_Entities
(Par
, S
);
1506 Link_Entities
(S
, Next_E
);
1518 -- If partial view is not a type extension, or it appears before the
1519 -- subprogram declaration, insert normally at end of entity list.
1521 Append_Entity
(S
, Current_Scope
);
1522 end Append_Inherited_Subprogram
;
1524 -----------------------------------------
1525 -- Apply_Compile_Time_Constraint_Error --
1526 -----------------------------------------
1528 procedure Apply_Compile_Time_Constraint_Error
1531 Reason
: RT_Exception_Code
;
1532 Ent
: Entity_Id
:= Empty
;
1533 Typ
: Entity_Id
:= Empty
;
1534 Loc
: Source_Ptr
:= No_Location
;
1535 Warn
: Boolean := False;
1536 Emit_Message
: Boolean := True)
1538 Stat
: constant Boolean := Is_Static_Expression
(N
);
1539 R_Stat
: constant Node_Id
:=
1540 Make_Raise_Constraint_Error
(Sloc
(N
), Reason
=> Reason
);
1550 if Emit_Message
then
1552 (Compile_Time_Constraint_Error
(N
, Msg
, Ent
, Loc
, Warn
=> Warn
));
1555 -- Now we replace the node by an N_Raise_Constraint_Error node
1556 -- This does not need reanalyzing, so set it as analyzed now.
1558 Rewrite
(N
, R_Stat
);
1559 Set_Analyzed
(N
, True);
1561 Set_Etype
(N
, Rtyp
);
1562 Set_Raises_Constraint_Error
(N
);
1564 -- Now deal with possible local raise handling
1566 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
1568 -- If the original expression was marked as static, the result is
1569 -- still marked as static, but the Raises_Constraint_Error flag is
1570 -- always set so that further static evaluation is not attempted.
1573 Set_Is_Static_Expression
(N
);
1575 end Apply_Compile_Time_Constraint_Error
;
1577 ---------------------------
1578 -- Async_Readers_Enabled --
1579 ---------------------------
1581 function Async_Readers_Enabled
(Id
: Entity_Id
) return Boolean is
1583 return Has_Enabled_Property
(Id
, Name_Async_Readers
);
1584 end Async_Readers_Enabled
;
1586 ---------------------------
1587 -- Async_Writers_Enabled --
1588 ---------------------------
1590 function Async_Writers_Enabled
(Id
: Entity_Id
) return Boolean is
1592 return Has_Enabled_Property
(Id
, Name_Async_Writers
);
1593 end Async_Writers_Enabled
;
1595 --------------------------------------
1596 -- Available_Full_View_Of_Component --
1597 --------------------------------------
1599 function Available_Full_View_Of_Component
(T
: Entity_Id
) return Boolean is
1600 ST
: constant Entity_Id
:= Scope
(T
);
1601 SCT
: constant Entity_Id
:= Scope
(Component_Type
(T
));
1603 return In_Open_Scopes
(ST
)
1604 and then In_Open_Scopes
(SCT
)
1605 and then Scope_Depth
(ST
) >= Scope_Depth
(SCT
);
1606 end Available_Full_View_Of_Component
;
1612 procedure Bad_Aspect
1615 Warn
: Boolean := False)
1618 Error_Msg_Warn
:= Warn
;
1619 Error_Msg_N
("<<& is not a valid aspect identifier", N
);
1621 -- Check bad spelling
1622 Error_Msg_Name_1
:= Aspect_Spell_Check
(Nam
);
1623 if Error_Msg_Name_1
/= No_Name
then
1624 Error_Msg_N
-- CODEFIX
1625 ("\<<possible misspelling of %", N
);
1633 procedure Bad_Attribute
1636 Warn
: Boolean := False)
1639 Error_Msg_Warn
:= Warn
;
1640 Error_Msg_N
("<<unrecognized attribute&", N
);
1642 -- Check for possible misspelling
1644 Error_Msg_Name_1
:= Attribute_Spell_Check
(Nam
);
1645 if Error_Msg_Name_1
/= No_Name
then
1646 Error_Msg_N
-- CODEFIX
1647 ("\<<possible misspelling of %", N
);
1651 --------------------------------
1652 -- Bad_Predicated_Subtype_Use --
1653 --------------------------------
1655 procedure Bad_Predicated_Subtype_Use
1659 Suggest_Static
: Boolean := False)
1664 -- Avoid cascaded errors
1666 if Error_Posted
(N
) then
1670 if Inside_A_Generic
then
1671 Gen
:= Current_Scope
;
1672 while Present
(Gen
) and then Ekind
(Gen
) /= E_Generic_Package
loop
1680 if Is_Generic_Formal
(Typ
) and then Is_Discrete_Type
(Typ
) then
1681 Set_No_Predicate_On_Actual
(Typ
);
1684 elsif Has_Predicates
(Typ
) then
1685 if Is_Generic_Actual_Type
(Typ
) then
1687 -- The restriction on loop parameters is only that the type
1688 -- should have no dynamic predicates.
1690 if Nkind
(Parent
(N
)) = N_Loop_Parameter_Specification
1691 and then not Has_Dynamic_Predicate_Aspect
(Typ
)
1692 and then Is_OK_Static_Subtype
(Typ
)
1697 Gen
:= Current_Scope
;
1698 while not Is_Generic_Instance
(Gen
) loop
1702 pragma Assert
(Present
(Gen
));
1704 if Ekind
(Gen
) = E_Package
and then In_Package_Body
(Gen
) then
1705 Error_Msg_Warn
:= SPARK_Mode
/= On
;
1706 Error_Msg_FE
(Msg
& "<<", N
, Typ
);
1707 Error_Msg_F
("\Program_Error [<<", N
);
1710 Make_Raise_Program_Error
(Sloc
(N
),
1711 Reason
=> PE_Bad_Predicated_Generic_Type
));
1714 Error_Msg_FE
(Msg
, N
, Typ
);
1718 Error_Msg_FE
(Msg
, N
, Typ
);
1721 -- Suggest to use First_Valid/Last_Valid instead of First/Last/Range
1722 -- if the predicate is static.
1724 if not Has_Dynamic_Predicate_Aspect
(Typ
)
1725 and then Has_Static_Predicate
(Typ
)
1726 and then Nkind
(N
) = N_Attribute_Reference
1729 Aname
: constant Name_Id
:= Attribute_Name
(N
);
1730 Attr_Id
: constant Attribute_Id
:= Get_Attribute_Id
(Aname
);
1733 when Attribute_First
=>
1734 Error_Msg_F
("\use attribute First_Valid instead", N
);
1735 when Attribute_Last
=>
1736 Error_Msg_F
("\use attribute Last_Valid instead", N
);
1737 when Attribute_Range
=>
1738 Error_Msg_F
("\use attributes First_Valid and "
1739 & "Last_Valid instead", N
);
1746 -- Emit an optional suggestion on how to remedy the error if the
1747 -- context warrants it.
1749 if Suggest_Static
and then Has_Static_Predicate
(Typ
) then
1750 Error_Msg_FE
("\predicate of & should be marked static", N
, Typ
);
1753 end Bad_Predicated_Subtype_Use
;
1755 -----------------------------------------
1756 -- Bad_Unordered_Enumeration_Reference --
1757 -----------------------------------------
1759 function Bad_Unordered_Enumeration_Reference
1761 T
: Entity_Id
) return Boolean
1764 return Is_Enumeration_Type
(T
)
1765 and then Warn_On_Unordered_Enumeration_Type
1766 and then not Is_Generic_Type
(T
)
1767 and then Comes_From_Source
(N
)
1768 and then not Has_Pragma_Ordered
(T
)
1769 and then not In_Same_Extended_Unit
(N
, T
);
1770 end Bad_Unordered_Enumeration_Reference
;
1772 ----------------------------
1773 -- Begin_Keyword_Location --
1774 ----------------------------
1776 function Begin_Keyword_Location
(N
: Node_Id
) return Source_Ptr
is
1788 HSS
:= Handled_Statement_Sequence
(N
);
1790 -- When the handled sequence of statements comes from source, the
1791 -- location of the "begin" keyword is that of the sequence itself.
1792 -- Note that an internal construct may inherit a source sequence.
1794 if Comes_From_Source
(HSS
) then
1797 -- The parser generates an internal handled sequence of statements to
1798 -- capture the location of the "begin" keyword if present in the source.
1799 -- Since there are no source statements, the location of the "begin"
1800 -- keyword is effectively that of the "end" keyword.
1802 elsif Comes_From_Source
(N
) then
1805 -- Otherwise the construct is internal and should carry the location of
1806 -- the original construct which prompted its creation.
1811 end Begin_Keyword_Location
;
1813 --------------------------
1814 -- Build_Actual_Subtype --
1815 --------------------------
1817 function Build_Actual_Subtype
1819 N
: Node_Or_Entity_Id
) return Node_Id
1822 -- Normally Sloc (N), but may point to corresponding body in some cases
1824 Constraints
: List_Id
;
1830 Disc_Type
: Entity_Id
;
1837 if Nkind
(N
) = N_Defining_Identifier
then
1838 Obj
:= New_Occurrence_Of
(N
, Loc
);
1840 -- If this is a formal parameter of a subprogram declaration, and
1841 -- we are compiling the body, we want the declaration for the
1842 -- actual subtype to carry the source position of the body, to
1843 -- prevent anomalies in gdb when stepping through the code.
1845 if Is_Formal
(N
) then
1847 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(N
));
1849 if Nkind
(Decl
) = N_Subprogram_Declaration
1850 and then Present
(Corresponding_Body
(Decl
))
1852 Loc
:= Sloc
(Corresponding_Body
(Decl
));
1861 if Is_Array_Type
(T
) then
1862 Constraints
:= New_List
;
1863 Index
:= First_Index
(T
);
1865 for J
in 1 .. Number_Dimensions
(T
) loop
1867 -- Build an array subtype declaration with the nominal subtype and
1868 -- the bounds of the actual. Add the declaration in front of the
1869 -- local declarations for the subprogram, for analysis before any
1870 -- reference to the formal in the body.
1872 -- If this is for an index with a fixed lower bound, then use
1873 -- the fixed lower bound as the lower bound of the actual
1874 -- subtype's corresponding index.
1876 if not Is_Constrained
(T
)
1877 and then Is_Fixed_Lower_Bound_Index_Subtype
(Etype
(Index
))
1879 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Etype
(Index
)));
1883 Make_Attribute_Reference
(Loc
,
1885 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
1886 Attribute_Name
=> Name_First
,
1887 Expressions
=> New_List
(
1888 Make_Integer_Literal
(Loc
, J
)));
1892 Make_Attribute_Reference
(Loc
,
1894 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
1895 Attribute_Name
=> Name_Last
,
1896 Expressions
=> New_List
(
1897 Make_Integer_Literal
(Loc
, J
)));
1899 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
1904 -- If the type has unknown discriminants there is no constrained
1905 -- subtype to build. This is never called for a formal or for a
1906 -- lhs, so returning the type is ok ???
1908 elsif Has_Unknown_Discriminants
(T
) then
1912 Constraints
:= New_List
;
1914 -- Type T is a generic derived type, inherit the discriminants from
1917 if Is_Private_Type
(T
)
1918 and then No
(Full_View
(T
))
1920 -- T was flagged as an error if it was declared as a formal
1921 -- derived type with known discriminants. In this case there
1922 -- is no need to look at the parent type since T already carries
1923 -- its own discriminants.
1925 and then not Error_Posted
(T
)
1927 Disc_Type
:= Etype
(Base_Type
(T
));
1932 Discr
:= First_Discriminant
(Disc_Type
);
1933 while Present
(Discr
) loop
1934 Append_To
(Constraints
,
1935 Make_Selected_Component
(Loc
,
1937 Duplicate_Subexpr_No_Checks
(Obj
),
1938 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)));
1939 Next_Discriminant
(Discr
);
1943 Subt
:= Make_Temporary
(Loc
, 'S', Related_Node
=> N
);
1944 Set_Is_Internal
(Subt
);
1947 Make_Subtype_Declaration
(Loc
,
1948 Defining_Identifier
=> Subt
,
1949 Subtype_Indication
=>
1950 Make_Subtype_Indication
(Loc
,
1951 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
1953 Make_Index_Or_Discriminant_Constraint
(Loc
,
1954 Constraints
=> Constraints
)));
1956 Mark_Rewrite_Insertion
(Decl
);
1958 end Build_Actual_Subtype
;
1960 ---------------------------------------
1961 -- Build_Actual_Subtype_Of_Component --
1962 ---------------------------------------
1964 function Build_Actual_Subtype_Of_Component
1966 N
: Node_Id
) return Node_Id
1968 Loc
: constant Source_Ptr
:= Sloc
(N
);
1969 P
: constant Node_Id
:= Prefix
(N
);
1973 Index_Typ
: Entity_Id
;
1974 Sel
: Entity_Id
:= Empty
;
1976 Desig_Typ
: Entity_Id
;
1977 -- This is either a copy of T, or if T is an access type, then it is
1978 -- the directly designated type of this access type.
1980 function Build_Access_Record_Constraint
(C
: List_Id
) return List_Id
;
1981 -- If the record component is a constrained access to the current
1982 -- record, the subtype has not been constructed during analysis of
1983 -- the enclosing record type (see Analyze_Access). In that case, build
1984 -- a constrained access subtype after replacing references to the
1985 -- enclosing discriminants with the corresponding discriminant values
1988 function Build_Actual_Array_Constraint
return List_Id
;
1989 -- If one or more of the bounds of the component depends on
1990 -- discriminants, build actual constraint using the discriminants
1991 -- of the prefix, as above.
1993 function Build_Actual_Record_Constraint
return List_Id
;
1994 -- Similar to previous one, for discriminated components constrained
1995 -- by the discriminant of the enclosing object.
1997 function Build_Discriminant_Reference
1998 (Discrim_Name
: Node_Id
; Obj
: Node_Id
:= P
) return Node_Id
;
1999 -- Build a reference to the discriminant denoted by Discrim_Name.
2000 -- The prefix of the result is usually Obj, but it could be
2001 -- a prefix of Obj in some corner cases.
2003 function Copy_And_Maybe_Dereference
(N
: Node_Id
) return Node_Id
;
2004 -- Copy the subtree rooted at N and insert an explicit dereference if it
2005 -- is of an access type.
2007 -----------------------------------
2008 -- Build_Actual_Array_Constraint --
2009 -----------------------------------
2011 function Build_Actual_Array_Constraint
return List_Id
is
2012 Constraints
: constant List_Id
:= New_List
;
2020 Indx
:= First_Index
(Desig_Typ
);
2021 while Present
(Indx
) loop
2022 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
2023 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
2025 if Denotes_Discriminant
(Old_Lo
) then
2026 Lo
:= Build_Discriminant_Reference
(Old_Lo
);
2028 Lo
:= New_Copy_Tree
(Old_Lo
);
2030 -- The new bound will be reanalyzed in the enclosing
2031 -- declaration. For literal bounds that come from a type
2032 -- declaration, the type of the context must be imposed, so
2033 -- insure that analysis will take place. For non-universal
2034 -- types this is not strictly necessary.
2036 Set_Analyzed
(Lo
, False);
2039 if Denotes_Discriminant
(Old_Hi
) then
2040 Hi
:= Build_Discriminant_Reference
(Old_Hi
);
2042 Hi
:= New_Copy_Tree
(Old_Hi
);
2043 Set_Analyzed
(Hi
, False);
2046 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
2051 end Build_Actual_Array_Constraint
;
2053 ------------------------------------
2054 -- Build_Actual_Record_Constraint --
2055 ------------------------------------
2057 function Build_Actual_Record_Constraint
return List_Id
is
2058 Constraints
: constant List_Id
:= New_List
;
2063 D
:= First_Elmt
(Discriminant_Constraint
(Desig_Typ
));
2064 while Present
(D
) loop
2065 if Denotes_Discriminant
(Node
(D
)) then
2066 D_Val
:= Build_Discriminant_Reference
(Node
(D
));
2068 D_Val
:= New_Copy_Tree
(Node
(D
));
2071 Append
(D_Val
, Constraints
);
2076 end Build_Actual_Record_Constraint
;
2078 ----------------------------------
2079 -- Build_Discriminant_Reference --
2080 ----------------------------------
2082 function Build_Discriminant_Reference
2083 (Discrim_Name
: Node_Id
; Obj
: Node_Id
:= P
) return Node_Id
2085 Discrim
: constant Entity_Id
:= Entity
(Discrim_Name
);
2087 function Obj_Is_Good_Prefix
return Boolean;
2088 -- Returns True if Obj.Discrim makes sense; that is, if
2089 -- Obj has Discrim as one of its discriminants (or is an
2090 -- access value that designates such an object).
2092 ------------------------
2093 -- Obj_Is_Good_Prefix --
2094 ------------------------
2096 function Obj_Is_Good_Prefix
return Boolean is
2097 Obj_Type
: Entity_Id
:=
2098 Implementation_Base_Type
(Etype
(Obj
));
2100 Discriminated_Type
: constant Entity_Id
:=
2101 Implementation_Base_Type
2102 (Scope
(Original_Record_Component
(Discrim
)));
2104 -- The order of the following two tests matters in the
2105 -- access-to-class-wide case.
2107 if Is_Access_Type
(Obj_Type
) then
2108 Obj_Type
:= Implementation_Base_Type
2109 (Designated_Type
(Obj_Type
));
2112 if Is_Class_Wide_Type
(Obj_Type
) then
2113 Obj_Type
:= Implementation_Base_Type
2114 (Find_Specific_Type
(Obj_Type
));
2117 -- If a type T1 defines a discriminant D1, then Obj.D1 is ok (for
2118 -- our purposes here) if T1 is an ancestor of the type of Obj.
2119 -- So that's what we would like to test for here.
2120 -- The bad news: Is_Ancestor is only defined in the tagged case.
2121 -- The good news: in the untagged case, Implementation_Base_Type
2122 -- looks through derived types so we can use a simpler test.
2124 if Is_Tagged_Type
(Discriminated_Type
) then
2125 return Is_Ancestor
(Discriminated_Type
, Obj_Type
);
2127 return Discriminated_Type
= Obj_Type
;
2129 end Obj_Is_Good_Prefix
;
2131 -- Start of processing for Build_Discriminant_Reference
2134 if not Obj_Is_Good_Prefix
then
2135 -- If the given discriminant is not a component of the given
2136 -- object, then try the enclosing object.
2138 if Nkind
(Obj
) = N_Selected_Component
then
2139 return Build_Discriminant_Reference
2140 (Discrim_Name
=> Discrim_Name
,
2141 Obj
=> Prefix
(Obj
));
2142 elsif Nkind
(Obj
) in N_Has_Entity
2143 and then Nkind
(Parent
(Entity
(Obj
))) =
2144 N_Object_Renaming_Declaration
2146 -- Look through a renaming (a corner case of a corner case).
2147 return Build_Discriminant_Reference
2148 (Discrim_Name
=> Discrim_Name
,
2149 Obj
=> Name
(Parent
(Entity
(Obj
))));
2151 -- We are in some unexpected case here, so revert to the
2152 -- old behavior (by falling through to it).
2157 return Make_Selected_Component
(Loc
,
2158 Prefix
=> Copy_And_Maybe_Dereference
(Obj
),
2159 Selector_Name
=> New_Occurrence_Of
(Discrim
, Loc
));
2160 end Build_Discriminant_Reference
;
2162 ------------------------------------
2163 -- Build_Access_Record_Constraint --
2164 ------------------------------------
2166 function Build_Access_Record_Constraint
(C
: List_Id
) return List_Id
is
2167 Constraints
: constant List_Id
:= New_List
;
2172 -- Retrieve the constraint from the component declaration, because
2173 -- the component subtype has not been constructed and the component
2174 -- type is an unconstrained access.
2177 while Present
(D
) loop
2178 if Nkind
(D
) = N_Discriminant_Association
2179 and then Denotes_Discriminant
(Expression
(D
))
2181 D_Val
:= New_Copy_Tree
(D
);
2182 Set_Expression
(D_Val
,
2183 Make_Selected_Component
(Loc
,
2184 Prefix
=> Copy_And_Maybe_Dereference
(P
),
2186 New_Occurrence_Of
(Entity
(Expression
(D
)), Loc
)));
2188 elsif Denotes_Discriminant
(D
) then
2189 D_Val
:= Make_Selected_Component
(Loc
,
2190 Prefix
=> Copy_And_Maybe_Dereference
(P
),
2191 Selector_Name
=> New_Occurrence_Of
(Entity
(D
), Loc
));
2194 D_Val
:= New_Copy_Tree
(D
);
2197 Append
(D_Val
, Constraints
);
2202 end Build_Access_Record_Constraint
;
2204 --------------------------------
2205 -- Copy_And_Maybe_Dereference --
2206 --------------------------------
2208 function Copy_And_Maybe_Dereference
(N
: Node_Id
) return Node_Id
is
2209 New_N
: constant Node_Id
:= New_Copy_Tree
(N
);
2212 if Is_Access_Type
(Etype
(N
)) then
2213 return Make_Explicit_Dereference
(Sloc
(Parent
(N
)), New_N
);
2218 end Copy_And_Maybe_Dereference
;
2220 -- Start of processing for Build_Actual_Subtype_Of_Component
2223 -- The subtype does not need to be created for a selected component
2224 -- in a Spec_Expression.
2226 if In_Spec_Expression
then
2229 -- More comments for the rest of this body would be good ???
2231 elsif Nkind
(N
) = N_Explicit_Dereference
then
2232 if Is_Composite_Type
(T
)
2233 and then not Is_Constrained
(T
)
2234 and then not (Is_Class_Wide_Type
(T
)
2235 and then Is_Constrained
(Root_Type
(T
)))
2236 and then not Has_Unknown_Discriminants
(T
)
2238 -- If the type of the dereference is already constrained, it is an
2241 if Is_Array_Type
(Etype
(N
))
2242 and then Is_Constrained
(Etype
(N
))
2246 Remove_Side_Effects
(P
);
2247 return Build_Actual_Subtype
(T
, N
);
2254 elsif Nkind
(N
) = N_Selected_Component
then
2255 -- The entity of the selected component allows us to retrieve
2256 -- the original constraint from its component declaration.
2258 Sel
:= Entity
(Selector_Name
(N
));
2259 if Parent_Kind
(Sel
) /= N_Component_Declaration
then
2264 if Is_Access_Type
(T
) then
2265 Desig_Typ
:= Designated_Type
(T
);
2271 if Ekind
(Desig_Typ
) = E_Array_Subtype
then
2272 Id
:= First_Index
(Desig_Typ
);
2274 -- Check whether an index bound is constrained by a discriminant
2276 while Present
(Id
) loop
2277 Index_Typ
:= Underlying_Type
(Etype
(Id
));
2279 if Denotes_Discriminant
(Type_Low_Bound
(Index_Typ
))
2281 Denotes_Discriminant
(Type_High_Bound
(Index_Typ
))
2283 Remove_Side_Effects
(P
);
2285 Build_Component_Subtype
2286 (Build_Actual_Array_Constraint
, Loc
, Base_Type
(T
));
2292 elsif Is_Composite_Type
(Desig_Typ
)
2293 and then Has_Discriminants
(Desig_Typ
)
2294 and then not Is_Empty_Elmt_List
(Discriminant_Constraint
(Desig_Typ
))
2295 and then not Has_Unknown_Discriminants
(Desig_Typ
)
2297 if Is_Private_Type
(Desig_Typ
)
2298 and then No
(Discriminant_Constraint
(Desig_Typ
))
2300 Desig_Typ
:= Full_View
(Desig_Typ
);
2303 D
:= First_Elmt
(Discriminant_Constraint
(Desig_Typ
));
2304 while Present
(D
) loop
2305 if Denotes_Discriminant
(Node
(D
)) then
2306 Remove_Side_Effects
(P
);
2308 Build_Component_Subtype
(
2309 Build_Actual_Record_Constraint
, Loc
, Base_Type
(T
));
2315 -- Special processing for an access record component that is
2316 -- the target of an assignment. If the designated type is an
2317 -- unconstrained discriminated record we create its actual
2320 elsif Ekind
(T
) = E_Access_Type
2321 and then Present
(Sel
)
2322 and then Has_Per_Object_Constraint
(Sel
)
2323 and then Nkind
(Parent
(N
)) = N_Assignment_Statement
2324 and then N
= Name
(Parent
(N
))
2325 -- and then not Inside_Init_Proc
2326 -- and then Has_Discriminants (Desig_Typ)
2327 -- and then not Is_Constrained (Desig_Typ)
2330 S_Indic
: constant Node_Id
:=
2332 (Component_Definition
(Parent
(Sel
))));
2335 if Nkind
(S_Indic
) = N_Subtype_Indication
then
2336 Discs
:= Constraints
(Constraint
(S_Indic
));
2338 Remove_Side_Effects
(P
);
2339 return Build_Component_Subtype
2340 (Build_Access_Record_Constraint
(Discs
), Loc
, T
);
2347 -- If none of the above, the actual and nominal subtypes are the same
2350 end Build_Actual_Subtype_Of_Component
;
2352 -----------------------------
2353 -- Build_Component_Subtype --
2354 -----------------------------
2356 function Build_Component_Subtype
2359 T
: Entity_Id
) return Node_Id
2365 -- Unchecked_Union components do not require component subtypes
2367 if Is_Unchecked_Union
(T
) then
2371 Subt
:= Make_Temporary
(Loc
, 'S');
2372 Set_Is_Internal
(Subt
);
2375 Make_Subtype_Declaration
(Loc
,
2376 Defining_Identifier
=> Subt
,
2377 Subtype_Indication
=>
2378 Make_Subtype_Indication
(Loc
,
2379 Subtype_Mark
=> New_Occurrence_Of
(Base_Type
(T
), Loc
),
2381 Make_Index_Or_Discriminant_Constraint
(Loc
,
2382 Constraints
=> C
)));
2384 Mark_Rewrite_Insertion
(Decl
);
2386 end Build_Component_Subtype
;
2388 -----------------------------
2389 -- Build_Constrained_Itype --
2390 -----------------------------
2392 procedure Build_Constrained_Itype
2395 New_Assoc_List
: List_Id
)
2397 Constrs
: constant List_Id
:= New_List
;
2398 Loc
: constant Source_Ptr
:= Sloc
(N
);
2401 New_Assoc
: Node_Id
;
2402 Subtyp_Decl
: Node_Id
;
2405 New_Assoc
:= First
(New_Assoc_List
);
2406 while Present
(New_Assoc
) loop
2408 -- There is exactly one choice in the component association (and
2409 -- it is either a discriminant, a component or the others clause).
2410 pragma Assert
(List_Length
(Choices
(New_Assoc
)) = 1);
2412 -- Duplicate expression for the discriminant and put it on the
2413 -- list of constraints for the itype declaration.
2415 if Is_Entity_Name
(First
(Choices
(New_Assoc
)))
2417 Ekind
(Entity
(First
(Choices
(New_Assoc
)))) = E_Discriminant
2419 Append_To
(Constrs
, Duplicate_Subexpr
(Expression
(New_Assoc
)));
2425 if Has_Unknown_Discriminants
(Typ
)
2426 and then Present
(Underlying_Record_View
(Typ
))
2429 Make_Subtype_Indication
(Loc
,
2431 New_Occurrence_Of
(Underlying_Record_View
(Typ
), Loc
),
2433 Make_Index_Or_Discriminant_Constraint
(Loc
,
2434 Constraints
=> Constrs
));
2437 Make_Subtype_Indication
(Loc
,
2439 New_Occurrence_Of
(Base_Type
(Typ
), Loc
),
2441 Make_Index_Or_Discriminant_Constraint
(Loc
,
2442 Constraints
=> Constrs
));
2445 Def_Id
:= Create_Itype
(Ekind
(Typ
), N
);
2448 Make_Subtype_Declaration
(Loc
,
2449 Defining_Identifier
=> Def_Id
,
2450 Subtype_Indication
=> Indic
);
2451 Set_Parent
(Subtyp_Decl
, Parent
(N
));
2453 -- Itypes must be analyzed with checks off (see itypes.ads)
2455 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
2457 Set_Etype
(N
, Def_Id
);
2458 end Build_Constrained_Itype
;
2460 ---------------------------
2461 -- Build_Default_Subtype --
2462 ---------------------------
2464 function Build_Default_Subtype
2466 N
: Node_Id
) return Entity_Id
2468 Loc
: constant Source_Ptr
:= Sloc
(N
);
2472 -- The base type that is to be constrained by the defaults
2475 if not Has_Discriminants
(T
) or else Is_Constrained
(T
) then
2479 Bas
:= Base_Type
(T
);
2481 -- If T is non-private but its base type is private, this is the
2482 -- completion of a subtype declaration whose parent type is private
2483 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
2484 -- are to be found in the full view of the base. Check that the private
2485 -- status of T and its base differ.
2487 if Is_Private_Type
(Bas
)
2488 and then not Is_Private_Type
(T
)
2489 and then Present
(Full_View
(Bas
))
2491 Bas
:= Full_View
(Bas
);
2494 Disc
:= First_Discriminant
(T
);
2496 if No
(Discriminant_Default_Value
(Disc
)) then
2501 Act
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
2502 Constraints
: constant List_Id
:= New_List
;
2506 while Present
(Disc
) loop
2507 Append_To
(Constraints
,
2508 New_Copy_Tree
(Discriminant_Default_Value
(Disc
)));
2509 Next_Discriminant
(Disc
);
2513 Make_Subtype_Declaration
(Loc
,
2514 Defining_Identifier
=> Act
,
2515 Subtype_Indication
=>
2516 Make_Subtype_Indication
(Loc
,
2517 Subtype_Mark
=> New_Occurrence_Of
(Bas
, Loc
),
2519 Make_Index_Or_Discriminant_Constraint
(Loc
,
2520 Constraints
=> Constraints
)));
2522 Insert_Action
(N
, Decl
);
2524 -- If the context is a component declaration the subtype declaration
2525 -- will be analyzed when the enclosing type is frozen, otherwise do
2528 if Ekind
(Current_Scope
) /= E_Record_Type
then
2534 end Build_Default_Subtype
;
2536 --------------------------------------------
2537 -- Build_Discriminal_Subtype_Of_Component --
2538 --------------------------------------------
2540 function Build_Discriminal_Subtype_Of_Component
2541 (T
: Entity_Id
) return Node_Id
2543 Loc
: constant Source_Ptr
:= Sloc
(T
);
2547 function Build_Discriminal_Array_Constraint
return List_Id
;
2548 -- If one or more of the bounds of the component depends on
2549 -- discriminants, build actual constraint using the discriminants
2552 function Build_Discriminal_Record_Constraint
return List_Id
;
2553 -- Similar to previous one, for discriminated components constrained by
2554 -- the discriminant of the enclosing object.
2556 ----------------------------------------
2557 -- Build_Discriminal_Array_Constraint --
2558 ----------------------------------------
2560 function Build_Discriminal_Array_Constraint
return List_Id
is
2561 Constraints
: constant List_Id
:= New_List
;
2569 Indx
:= First_Index
(T
);
2570 while Present
(Indx
) loop
2571 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
2572 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
2574 if Denotes_Discriminant
(Old_Lo
) then
2575 Lo
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Lo
)), Loc
);
2578 Lo
:= New_Copy_Tree
(Old_Lo
);
2581 if Denotes_Discriminant
(Old_Hi
) then
2582 Hi
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Hi
)), Loc
);
2585 Hi
:= New_Copy_Tree
(Old_Hi
);
2588 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
2593 end Build_Discriminal_Array_Constraint
;
2595 -----------------------------------------
2596 -- Build_Discriminal_Record_Constraint --
2597 -----------------------------------------
2599 function Build_Discriminal_Record_Constraint
return List_Id
is
2600 Constraints
: constant List_Id
:= New_List
;
2605 D
:= First_Elmt
(Discriminant_Constraint
(T
));
2606 while Present
(D
) loop
2607 if Denotes_Discriminant
(Node
(D
)) then
2609 New_Occurrence_Of
(Discriminal
(Entity
(Node
(D
))), Loc
);
2611 D_Val
:= New_Copy_Tree
(Node
(D
));
2614 Append
(D_Val
, Constraints
);
2619 end Build_Discriminal_Record_Constraint
;
2621 -- Start of processing for Build_Discriminal_Subtype_Of_Component
2624 if Ekind
(T
) = E_Array_Subtype
then
2625 Id
:= First_Index
(T
);
2626 while Present
(Id
) loop
2627 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(Id
)))
2629 Denotes_Discriminant
(Type_High_Bound
(Etype
(Id
)))
2631 return Build_Component_Subtype
2632 (Build_Discriminal_Array_Constraint
, Loc
, T
);
2638 elsif Ekind
(T
) = E_Record_Subtype
2639 and then Has_Discriminants
(T
)
2640 and then not Has_Unknown_Discriminants
(T
)
2642 D
:= First_Elmt
(Discriminant_Constraint
(T
));
2643 while Present
(D
) loop
2644 if Denotes_Discriminant
(Node
(D
)) then
2645 return Build_Component_Subtype
2646 (Build_Discriminal_Record_Constraint
, Loc
, T
);
2653 -- If none of the above, the actual and nominal subtypes are the same
2656 end Build_Discriminal_Subtype_Of_Component
;
2658 ------------------------------
2659 -- Build_Elaboration_Entity --
2660 ------------------------------
2662 procedure Build_Elaboration_Entity
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
2663 Loc
: constant Source_Ptr
:= Sloc
(N
);
2665 Elab_Ent
: Entity_Id
;
2667 procedure Set_Package_Name
(Ent
: Entity_Id
);
2668 -- Given an entity, sets the fully qualified name of the entity in
2669 -- Name_Buffer, with components separated by double underscores. This
2670 -- is a recursive routine that climbs the scope chain to Standard.
2672 ----------------------
2673 -- Set_Package_Name --
2674 ----------------------
2676 procedure Set_Package_Name
(Ent
: Entity_Id
) is
2678 if Scope
(Ent
) /= Standard_Standard
then
2679 Set_Package_Name
(Scope
(Ent
));
2682 Nam
: constant String := Get_Name_String
(Chars
(Ent
));
2684 Name_Buffer
(Name_Len
+ 1) := '_';
2685 Name_Buffer
(Name_Len
+ 2) := '_';
2686 Name_Buffer
(Name_Len
+ 3 .. Name_Len
+ Nam
'Length + 2) := Nam
;
2687 Name_Len
:= Name_Len
+ Nam
'Length + 2;
2691 Get_Name_String
(Chars
(Ent
));
2693 end Set_Package_Name
;
2695 -- Start of processing for Build_Elaboration_Entity
2698 -- Ignore call if already constructed
2700 if Present
(Elaboration_Entity
(Spec_Id
)) then
2703 -- Do not generate an elaboration entity in GNATprove move because the
2704 -- elaboration counter is a form of expansion.
2706 elsif GNATprove_Mode
then
2709 -- See if we need elaboration entity
2711 -- We always need an elaboration entity when preserving control flow, as
2712 -- we want to remain explicit about the unit's elaboration order.
2714 elsif Opt
.Suppress_Control_Flow_Optimizations
then
2717 -- We always need an elaboration entity for the dynamic elaboration
2718 -- model, since it is needed to properly generate the PE exception for
2719 -- access before elaboration.
2721 elsif Dynamic_Elaboration_Checks
then
2724 -- For the static model, we don't need the elaboration counter if this
2725 -- unit is sure to have no elaboration code, since that means there
2726 -- is no elaboration unit to be called. Note that we can't just decide
2727 -- after the fact by looking to see whether there was elaboration code,
2728 -- because that's too late to make this decision.
2730 elsif Restriction_Active
(No_Elaboration_Code
) then
2733 -- Similarly, for the static model, we can skip the elaboration counter
2734 -- if we have the No_Multiple_Elaboration restriction, since for the
2735 -- static model, that's the only purpose of the counter (to avoid
2736 -- multiple elaboration).
2738 elsif Restriction_Active
(No_Multiple_Elaboration
) then
2742 -- Here we need the elaboration entity
2744 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
2745 -- name with dots replaced by double underscore. We have to manually
2746 -- construct this name, since it will be elaborated in the outer scope,
2747 -- and thus will not have the unit name automatically prepended.
2749 Set_Package_Name
(Spec_Id
);
2750 Add_Str_To_Name_Buffer
("_E");
2752 -- Create elaboration counter
2754 Elab_Ent
:= Make_Defining_Identifier
(Loc
, Chars
=> Name_Find
);
2755 Set_Elaboration_Entity
(Spec_Id
, Elab_Ent
);
2758 Make_Object_Declaration
(Loc
,
2759 Defining_Identifier
=> Elab_Ent
,
2760 Object_Definition
=>
2761 New_Occurrence_Of
(Standard_Short_Integer
, Loc
),
2762 Expression
=> Make_Integer_Literal
(Loc
, Uint_0
));
2764 Push_Scope
(Standard_Standard
);
2765 Add_Global_Declaration
(Decl
);
2768 -- Reset True_Constant indication, since we will indeed assign a value
2769 -- to the variable in the binder main. We also kill the Current_Value
2770 -- and Last_Assignment fields for the same reason.
2772 Set_Is_True_Constant
(Elab_Ent
, False);
2773 Set_Current_Value
(Elab_Ent
, Empty
);
2774 Set_Last_Assignment
(Elab_Ent
, Empty
);
2776 -- We do not want any further qualification of the name (if we did not
2777 -- do this, we would pick up the name of the generic package in the case
2778 -- of a library level generic instantiation).
2780 Set_Has_Qualified_Name
(Elab_Ent
);
2781 Set_Has_Fully_Qualified_Name
(Elab_Ent
);
2782 end Build_Elaboration_Entity
;
2784 --------------------------------
2785 -- Build_Explicit_Dereference --
2786 --------------------------------
2788 procedure Build_Explicit_Dereference
2792 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
2797 -- An entity of a type with a reference aspect is overloaded with
2798 -- both interpretations: with and without the dereference. Now that
2799 -- the dereference is made explicit, set the type of the node properly,
2800 -- to prevent anomalies in the backend. Same if the expression is an
2801 -- overloaded function call whose return type has a reference aspect.
2803 if Is_Entity_Name
(Expr
) then
2804 Set_Etype
(Expr
, Etype
(Entity
(Expr
)));
2806 -- The designated entity will not be examined again when resolving
2807 -- the dereference, so generate a reference to it now.
2809 Generate_Reference
(Entity
(Expr
), Expr
);
2811 elsif Nkind
(Expr
) = N_Function_Call
then
2813 -- If the name of the indexing function is overloaded, locate the one
2814 -- whose return type has an implicit dereference on the desired
2815 -- discriminant, and set entity and type of function call.
2817 if Is_Overloaded
(Name
(Expr
)) then
2818 Get_First_Interp
(Name
(Expr
), I
, It
);
2820 while Present
(It
.Nam
) loop
2821 if Ekind
((It
.Typ
)) = E_Record_Type
2822 and then First_Entity
((It
.Typ
)) = Disc
2824 Set_Entity
(Name
(Expr
), It
.Nam
);
2825 Set_Etype
(Name
(Expr
), Etype
(It
.Nam
));
2829 Get_Next_Interp
(I
, It
);
2833 -- Set type of call from resolved function name.
2835 Set_Etype
(Expr
, Etype
(Name
(Expr
)));
2838 Set_Is_Overloaded
(Expr
, False);
2840 -- The expression will often be a generalized indexing that yields a
2841 -- container element that is then dereferenced, in which case the
2842 -- generalized indexing call is also non-overloaded.
2844 if Nkind
(Expr
) = N_Indexed_Component
2845 and then Present
(Generalized_Indexing
(Expr
))
2847 Set_Is_Overloaded
(Generalized_Indexing
(Expr
), False);
2851 Make_Explicit_Dereference
(Loc
,
2853 Make_Selected_Component
(Loc
,
2854 Prefix
=> Relocate_Node
(Expr
),
2855 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
))));
2856 Set_Etype
(Prefix
(Expr
), Etype
(Disc
));
2857 Set_Etype
(Expr
, Designated_Type
(Etype
(Disc
)));
2858 end Build_Explicit_Dereference
;
2860 ---------------------------
2861 -- Build_Overriding_Spec --
2862 ---------------------------
2864 function Build_Overriding_Spec
2866 Typ
: Entity_Id
) return Node_Id
2868 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2869 Par_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Op
);
2870 Spec
: constant Node_Id
:= Specification
(Unit_Declaration_Node
(Op
));
2872 Formal_Spec
: Node_Id
;
2873 Formal_Type
: Node_Id
;
2877 New_Spec
:= Copy_Subprogram_Spec
(Spec
);
2879 Formal_Spec
:= First
(Parameter_Specifications
(New_Spec
));
2880 while Present
(Formal_Spec
) loop
2881 Formal_Type
:= Parameter_Type
(Formal_Spec
);
2883 if Is_Entity_Name
(Formal_Type
)
2884 and then Entity
(Formal_Type
) = Par_Typ
2886 Rewrite
(Formal_Type
, New_Occurrence_Of
(Typ
, Loc
));
2889 -- Nothing needs to be done for access parameters
2895 end Build_Overriding_Spec
;
2901 function Build_Subtype
2902 (Related_Node
: Node_Id
;
2905 Constraints
: List_Id
)
2909 Subtyp_Decl
: Node_Id
;
2911 Btyp
: Entity_Id
:= Base_Type
(Typ
);
2914 -- The Related_Node better be here or else we won't be able to
2915 -- attach new itypes to a node in the tree.
2917 pragma Assert
(Present
(Related_Node
));
2919 -- If the view of the component's type is incomplete or private
2920 -- with unknown discriminants, then the constraint must be applied
2921 -- to the full type.
2923 if Has_Unknown_Discriminants
(Btyp
)
2924 and then Present
(Underlying_Type
(Btyp
))
2926 Btyp
:= Underlying_Type
(Btyp
);
2930 Make_Subtype_Indication
(Loc
,
2931 Subtype_Mark
=> New_Occurrence_Of
(Btyp
, Loc
),
2933 Make_Index_Or_Discriminant_Constraint
(Loc
, Constraints
));
2935 Def_Id
:= Create_Itype
(Ekind
(Typ
), Related_Node
);
2938 Make_Subtype_Declaration
(Loc
,
2939 Defining_Identifier
=> Def_Id
,
2940 Subtype_Indication
=> Indic
);
2942 Set_Parent
(Subtyp_Decl
, Parent
(Related_Node
));
2944 -- Itypes must be analyzed with checks off (see package Itypes)
2946 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
2948 if Is_Itype
(Def_Id
) and then Has_Predicates
(Typ
) then
2949 Inherit_Predicate_Flags
(Def_Id
, Typ
);
2951 -- Indicate where the predicate function may be found
2953 if Is_Itype
(Typ
) then
2954 if Present
(Predicate_Function
(Def_Id
)) then
2957 elsif Present
(Predicate_Function
(Typ
)) then
2958 Set_Predicate_Function
(Def_Id
, Predicate_Function
(Typ
));
2961 Set_Predicated_Parent
(Def_Id
, Predicated_Parent
(Typ
));
2964 elsif No
(Predicate_Function
(Def_Id
)) then
2965 Set_Predicated_Parent
(Def_Id
, Typ
);
2972 -----------------------------------
2973 -- Cannot_Raise_Constraint_Error --
2974 -----------------------------------
2976 function Cannot_Raise_Constraint_Error
(Expr
: Node_Id
) return Boolean is
2978 function List_Cannot_Raise_CE
(L
: List_Id
) return Boolean;
2979 -- Returns True if none of the list members cannot possibly raise
2980 -- Constraint_Error.
2982 --------------------------
2983 -- List_Cannot_Raise_CE --
2984 --------------------------
2986 function List_Cannot_Raise_CE
(L
: List_Id
) return Boolean is
2990 while Present
(N
) loop
2991 if Cannot_Raise_Constraint_Error
(N
) then
2999 end List_Cannot_Raise_CE
;
3001 -- Start of processing for Cannot_Raise_Constraint_Error
3004 if Compile_Time_Known_Value
(Expr
) then
3007 elsif Do_Range_Check
(Expr
) then
3010 elsif Raises_Constraint_Error
(Expr
) then
3014 case Nkind
(Expr
) is
3015 when N_Identifier
=>
3018 when N_Expanded_Name
=>
3021 when N_Indexed_Component
=>
3022 return not Do_Range_Check
(Expr
)
3023 and then Cannot_Raise_Constraint_Error
(Prefix
(Expr
))
3024 and then List_Cannot_Raise_CE
(Expressions
(Expr
));
3026 when N_Selected_Component
=>
3027 return not Do_Discriminant_Check
(Expr
)
3028 and then Cannot_Raise_Constraint_Error
(Prefix
(Expr
));
3030 when N_Attribute_Reference
=>
3031 if Do_Overflow_Check
(Expr
) then
3034 elsif No
(Expressions
(Expr
)) then
3038 return List_Cannot_Raise_CE
(Expressions
(Expr
));
3041 when N_Type_Conversion
=>
3042 if Do_Overflow_Check
(Expr
)
3043 or else Do_Length_Check
(Expr
)
3047 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
3050 when N_Unchecked_Type_Conversion
=>
3051 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
3054 if Do_Overflow_Check
(Expr
) then
3057 return Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
3064 if Do_Division_Check
(Expr
)
3066 Do_Overflow_Check
(Expr
)
3071 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
3073 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
3092 | N_Op_Shift_Right_Arithmetic
3096 if Do_Overflow_Check
(Expr
) then
3100 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
3102 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
3109 end Cannot_Raise_Constraint_Error
;
3111 -------------------------------
3112 -- Check_Ambiguous_Aggregate --
3113 -------------------------------
3115 procedure Check_Ambiguous_Aggregate
(Call
: Node_Id
) is
3119 if Extensions_Allowed
then
3120 Actual
:= First_Actual
(Call
);
3121 while Present
(Actual
) loop
3122 if Nkind
(Actual
) = N_Aggregate
then
3124 ("\add type qualification to aggregate actual", Actual
);
3127 Next_Actual
(Actual
);
3130 end Check_Ambiguous_Aggregate
;
3132 -----------------------------------------
3133 -- Check_Dynamically_Tagged_Expression --
3134 -----------------------------------------
3136 procedure Check_Dynamically_Tagged_Expression
3139 Related_Nod
: Node_Id
)
3142 pragma Assert
(Is_Tagged_Type
(Typ
));
3144 -- In order to avoid spurious errors when analyzing the expanded code,
3145 -- this check is done only for nodes that come from source and for
3146 -- actuals of generic instantiations.
3148 if (Comes_From_Source
(Related_Nod
)
3149 or else In_Generic_Actual
(Expr
))
3150 and then (Is_Class_Wide_Type
(Etype
(Expr
))
3151 or else Is_Dynamically_Tagged
(Expr
))
3152 and then not Is_Class_Wide_Type
(Typ
)
3154 Error_Msg_N
("dynamically tagged expression not allowed!", Expr
);
3156 end Check_Dynamically_Tagged_Expression
;
3158 --------------------------
3159 -- Check_Fully_Declared --
3160 --------------------------
3162 procedure Check_Fully_Declared
(T
: Entity_Id
; N
: Node_Id
) is
3164 if Ekind
(T
) = E_Incomplete_Type
then
3166 -- Ada 2005 (AI-50217): If the type is available through a limited
3167 -- with_clause, verify that its full view has been analyzed.
3169 if From_Limited_With
(T
)
3170 and then Present
(Non_Limited_View
(T
))
3171 and then Ekind
(Non_Limited_View
(T
)) /= E_Incomplete_Type
3173 -- The non-limited view is fully declared
3179 ("premature usage of incomplete}", N
, First_Subtype
(T
));
3182 -- Need comments for these tests ???
3184 elsif Has_Private_Component
(T
)
3185 and then not Is_Generic_Type
(Root_Type
(T
))
3186 and then not In_Spec_Expression
3188 -- Special case: if T is the anonymous type created for a single
3189 -- task or protected object, use the name of the source object.
3191 if Is_Concurrent_Type
(T
)
3192 and then not Comes_From_Source
(T
)
3193 and then Nkind
(N
) = N_Object_Declaration
3196 ("type of& has incomplete component",
3197 N
, Defining_Identifier
(N
));
3200 ("premature usage of incomplete}",
3201 N
, First_Subtype
(T
));
3204 end Check_Fully_Declared
;
3206 -------------------------------------------
3207 -- Check_Function_With_Address_Parameter --
3208 -------------------------------------------
3210 procedure Check_Function_With_Address_Parameter
(Subp_Id
: Entity_Id
) is
3215 F
:= First_Formal
(Subp_Id
);
3216 while Present
(F
) loop
3219 if Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
3223 if Is_Descendant_Of_Address
(T
) or else Is_Limited_Type
(T
) then
3224 Set_Is_Pure
(Subp_Id
, False);
3230 end Check_Function_With_Address_Parameter
;
3232 -------------------------------------
3233 -- Check_Function_Writable_Actuals --
3234 -------------------------------------
3236 procedure Check_Function_Writable_Actuals
(N
: Node_Id
) is
3237 Writable_Actuals_List
: Elist_Id
:= No_Elist
;
3238 Identifiers_List
: Elist_Id
:= No_Elist
;
3239 Aggr_Error_Node
: Node_Id
:= Empty
;
3240 Error_Node
: Node_Id
:= Empty
;
3242 procedure Collect_Identifiers
(N
: Node_Id
);
3243 -- In a single traversal of subtree N collect in Writable_Actuals_List
3244 -- all the actuals of functions with writable actuals, and in the list
3245 -- Identifiers_List collect all the identifiers that are not actuals of
3246 -- functions with writable actuals. If a writable actual is referenced
3247 -- twice as writable actual then Error_Node is set to reference its
3248 -- second occurrence, the error is reported, and the tree traversal
3251 -------------------------
3252 -- Collect_Identifiers --
3253 -------------------------
3255 procedure Collect_Identifiers
(N
: Node_Id
) is
3257 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
3258 -- Process a single node during the tree traversal to collect the
3259 -- writable actuals of functions and all the identifiers which are
3260 -- not writable actuals of functions.
3262 function Contains
(List
: Elist_Id
; N
: Node_Id
) return Boolean;
3263 -- Returns True if List has a node whose Entity is Entity (N)
3269 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
3270 Is_Writable_Actual
: Boolean := False;
3274 if Nkind
(N
) = N_Identifier
then
3276 -- No analysis possible if the entity is not decorated
3278 if No
(Entity
(N
)) then
3281 -- Don't collect identifiers of packages, called functions, etc
3283 elsif Ekind
(Entity
(N
)) in
3284 E_Package | E_Function | E_Procedure | E_Entry
3288 -- For rewritten nodes, continue the traversal in the original
3289 -- subtree. Needed to handle aggregates in original expressions
3290 -- extracted from the tree by Remove_Side_Effects.
3292 elsif Is_Rewrite_Substitution
(N
) then
3293 Collect_Identifiers
(Original_Node
(N
));
3296 -- For now we skip aggregate discriminants, since they require
3297 -- performing the analysis in two phases to identify conflicts:
3298 -- first one analyzing discriminants and second one analyzing
3299 -- the rest of components (since at run time, discriminants are
3300 -- evaluated prior to components): too much computation cost
3301 -- to identify a corner case???
3303 elsif Nkind
(Parent
(N
)) = N_Component_Association
3304 and then Nkind
(Parent
(Parent
(N
))) in
3305 N_Aggregate | N_Extension_Aggregate
3308 Choice
: constant Node_Id
:= First
(Choices
(Parent
(N
)));
3311 if Ekind
(Entity
(N
)) = E_Discriminant
then
3314 elsif Expression
(Parent
(N
)) = N
3315 and then Nkind
(Choice
) = N_Identifier
3316 and then Ekind
(Entity
(Choice
)) = E_Discriminant
3322 -- Analyze if N is a writable actual of a function
3324 elsif Nkind
(Parent
(N
)) = N_Function_Call
then
3326 Call
: constant Node_Id
:= Parent
(N
);
3331 Id
:= Get_Called_Entity
(Call
);
3333 -- In case of previous error, no check is possible
3339 if Ekind
(Id
) in E_Function | E_Generic_Function
3340 and then Has_Out_Or_In_Out_Parameter
(Id
)
3342 Formal
:= First_Formal
(Id
);
3343 Actual
:= First_Actual
(Call
);
3344 while Present
(Actual
) and then Present
(Formal
) loop
3346 if Ekind
(Formal
) in E_Out_Parameter
3347 | E_In_Out_Parameter
3349 Is_Writable_Actual
:= True;
3355 Next_Formal
(Formal
);
3356 Next_Actual
(Actual
);
3362 if Is_Writable_Actual
then
3364 -- Skip checking the error in non-elementary types since
3365 -- RM 6.4.1(6.15/3) is restricted to elementary types, but
3366 -- store this actual in Writable_Actuals_List since it is
3367 -- needed to perform checks on other constructs that have
3368 -- arbitrary order of evaluation (for example, aggregates).
3370 if not Is_Elementary_Type
(Etype
(N
)) then
3371 if not Contains
(Writable_Actuals_List
, N
) then
3372 Append_New_Elmt
(N
, To
=> Writable_Actuals_List
);
3375 -- Second occurrence of an elementary type writable actual
3377 elsif Contains
(Writable_Actuals_List
, N
) then
3379 -- Report the error on the second occurrence of the
3380 -- identifier. We cannot assume that N is the second
3381 -- occurrence (according to their location in the
3382 -- sources), since Traverse_Func walks through Field2
3383 -- last (see comment in the body of Traverse_Func).
3389 Elmt
:= First_Elmt
(Writable_Actuals_List
);
3390 while Present
(Elmt
)
3391 and then Entity
(Node
(Elmt
)) /= Entity
(N
)
3396 if Sloc
(N
) > Sloc
(Node
(Elmt
)) then
3399 Error_Node
:= Node
(Elmt
);
3403 ("value may be affected by call to & "
3404 & "because order of evaluation is arbitrary",
3409 -- First occurrence of a elementary type writable actual
3412 Append_New_Elmt
(N
, To
=> Writable_Actuals_List
);
3416 if No
(Identifiers_List
) then
3417 Identifiers_List
:= New_Elmt_List
;
3420 Append_Unique_Elmt
(N
, Identifiers_List
);
3433 N
: Node_Id
) return Boolean
3435 pragma Assert
(Nkind
(N
) in N_Has_Entity
);
3444 Elmt
:= First_Elmt
(List
);
3445 while Present
(Elmt
) loop
3446 if Entity
(Node
(Elmt
)) = Entity
(N
) then
3460 procedure Do_Traversal
is new Traverse_Proc
(Check_Node
);
3461 -- The traversal procedure
3463 -- Start of processing for Collect_Identifiers
3466 if Present
(Error_Node
) then
3470 if Nkind
(N
) in N_Subexpr
and then Is_OK_Static_Expression
(N
) then
3475 end Collect_Identifiers
;
3477 -- Start of processing for Check_Function_Writable_Actuals
3480 -- The check only applies to Ada 2012 code on which Check_Actuals has
3481 -- been set, and only to constructs that have multiple constituents
3482 -- whose order of evaluation is not specified by the language.
3484 if Ada_Version
< Ada_2012
3485 or else not Check_Actuals
(N
)
3486 or else Nkind
(N
) not in N_Op
3490 | N_Extension_Aggregate
3491 | N_Full_Type_Declaration
3493 | N_Procedure_Call_Statement
3494 | N_Entry_Call_Statement
3495 or else (Nkind
(N
) = N_Full_Type_Declaration
3496 and then not Is_Record_Type
(Defining_Identifier
(N
)))
3498 -- In addition, this check only applies to source code, not to code
3499 -- generated by constraint checks.
3501 or else not Comes_From_Source
(N
)
3506 -- If a construct C has two or more direct constituents that are names
3507 -- or expressions whose evaluation may occur in an arbitrary order, at
3508 -- least one of which contains a function call with an in out or out
3509 -- parameter, then the construct is legal only if: for each name N that
3510 -- is passed as a parameter of mode in out or out to some inner function
3511 -- call C2 (not including the construct C itself), there is no other
3512 -- name anywhere within a direct constituent of the construct C other
3513 -- than the one containing C2, that is known to refer to the same
3514 -- object (RM 6.4.1(6.17/3)).
3518 Collect_Identifiers
(Low_Bound
(N
));
3519 Collect_Identifiers
(High_Bound
(N
));
3521 when N_Membership_Test
3528 Collect_Identifiers
(Left_Opnd
(N
));
3530 if Present
(Right_Opnd
(N
)) then
3531 Collect_Identifiers
(Right_Opnd
(N
));
3534 if Nkind
(N
) in N_In | N_Not_In
3535 and then Present
(Alternatives
(N
))
3537 Expr
:= First
(Alternatives
(N
));
3538 while Present
(Expr
) loop
3539 Collect_Identifiers
(Expr
);
3546 when N_Full_Type_Declaration
=>
3548 function Get_Record_Part
(N
: Node_Id
) return Node_Id
;
3549 -- Return the record part of this record type definition
3551 function Get_Record_Part
(N
: Node_Id
) return Node_Id
is
3552 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
3554 if Nkind
(Type_Def
) = N_Derived_Type_Definition
then
3555 return Record_Extension_Part
(Type_Def
);
3559 end Get_Record_Part
;
3562 Def_Id
: Entity_Id
:= Defining_Identifier
(N
);
3563 Rec
: Node_Id
:= Get_Record_Part
(N
);
3566 -- No need to perform any analysis if the record has no
3569 if No
(Rec
) or else No
(Component_List
(Rec
)) then
3573 -- Collect the identifiers starting from the deepest
3574 -- derivation. Done to report the error in the deepest
3578 if Present
(Component_List
(Rec
)) then
3579 Comp
:= First
(Component_Items
(Component_List
(Rec
)));
3580 while Present
(Comp
) loop
3581 if Nkind
(Comp
) = N_Component_Declaration
3582 and then Present
(Expression
(Comp
))
3584 Collect_Identifiers
(Expression
(Comp
));
3591 exit when No
(Underlying_Type
(Etype
(Def_Id
)))
3592 or else Base_Type
(Underlying_Type
(Etype
(Def_Id
)))
3595 Def_Id
:= Base_Type
(Underlying_Type
(Etype
(Def_Id
)));
3596 Rec
:= Get_Record_Part
(Parent
(Def_Id
));
3600 when N_Entry_Call_Statement
3604 Id
: constant Entity_Id
:= Get_Called_Entity
(N
);
3609 Formal
:= First_Formal
(Id
);
3610 Actual
:= First_Actual
(N
);
3611 while Present
(Actual
) and then Present
(Formal
) loop
3612 if Ekind
(Formal
) in E_Out_Parameter | E_In_Out_Parameter
3614 Collect_Identifiers
(Actual
);
3617 Next_Formal
(Formal
);
3618 Next_Actual
(Actual
);
3623 | N_Extension_Aggregate
3628 Comp_Expr
: Node_Id
;
3631 -- Handle the N_Others_Choice of array aggregates with static
3632 -- bounds. There is no need to perform this analysis in
3633 -- aggregates without static bounds since we cannot evaluate
3634 -- if the N_Others_Choice covers several elements. There is
3635 -- no need to handle the N_Others choice of record aggregates
3636 -- since at this stage it has been already expanded by
3637 -- Resolve_Record_Aggregate.
3639 if Is_Array_Type
(Etype
(N
))
3640 and then Nkind
(N
) = N_Aggregate
3641 and then Present
(Aggregate_Bounds
(N
))
3642 and then Compile_Time_Known_Bounds
(Etype
(N
))
3643 and then Expr_Value
(High_Bound
(Aggregate_Bounds
(N
)))
3645 Expr_Value
(Low_Bound
(Aggregate_Bounds
(N
)))
3648 Count_Components
: Uint
:= Uint_0
;
3649 Num_Components
: Uint
;
3650 Others_Assoc
: Node_Id
:= Empty
;
3651 Others_Choice
: Node_Id
:= Empty
;
3652 Others_Box_Present
: Boolean := False;
3655 -- Count positional associations
3657 if Present
(Expressions
(N
)) then
3658 Comp_Expr
:= First
(Expressions
(N
));
3659 while Present
(Comp_Expr
) loop
3660 Count_Components
:= Count_Components
+ 1;
3665 -- Count the rest of elements and locate the N_Others
3668 Assoc
:= First
(Component_Associations
(N
));
3669 while Present
(Assoc
) loop
3670 Choice
:= First
(Choices
(Assoc
));
3671 while Present
(Choice
) loop
3672 if Nkind
(Choice
) = N_Others_Choice
then
3673 Others_Assoc
:= Assoc
;
3674 Others_Choice
:= Choice
;
3675 Others_Box_Present
:= Box_Present
(Assoc
);
3677 -- Count several components
3679 elsif Nkind
(Choice
) in
3680 N_Range | N_Subtype_Indication
3681 or else (Is_Entity_Name
(Choice
)
3682 and then Is_Type
(Entity
(Choice
)))
3687 Get_Index_Bounds
(Choice
, L
, H
);
3689 (Compile_Time_Known_Value
(L
)
3690 and then Compile_Time_Known_Value
(H
));
3693 + Expr_Value
(H
) - Expr_Value
(L
) + 1;
3696 -- Count single component. No other case available
3697 -- since we are handling an aggregate with static
3701 pragma Assert
(Is_OK_Static_Expression
(Choice
)
3702 or else Nkind
(Choice
) = N_Identifier
3703 or else Nkind
(Choice
) = N_Integer_Literal
);
3705 Count_Components
:= Count_Components
+ 1;
3715 Expr_Value
(High_Bound
(Aggregate_Bounds
(N
))) -
3716 Expr_Value
(Low_Bound
(Aggregate_Bounds
(N
))) + 1;
3718 pragma Assert
(Count_Components
<= Num_Components
);
3720 -- Handle the N_Others choice if it covers several
3723 if Present
(Others_Choice
)
3724 and then (Num_Components
- Count_Components
) > 1
3726 if not Others_Box_Present
then
3728 -- At this stage, if expansion is active, the
3729 -- expression of the others choice has not been
3730 -- analyzed. Hence we generate a duplicate and
3731 -- we analyze it silently to have available the
3732 -- minimum decoration required to collect the
3735 pragma Assert
(Present
(Others_Assoc
));
3737 if not Expander_Active
then
3738 Comp_Expr
:= Expression
(Others_Assoc
);
3741 New_Copy_Tree
(Expression
(Others_Assoc
));
3742 Preanalyze_Without_Errors
(Comp_Expr
);
3745 Collect_Identifiers
(Comp_Expr
);
3747 if Present
(Writable_Actuals_List
) then
3749 -- As suggested by Robert, at current stage we
3750 -- report occurrences of this case as warnings.
3753 ("writable function parameter may affect "
3754 & "value in other component because order "
3755 & "of evaluation is unspecified??",
3756 Node
(First_Elmt
(Writable_Actuals_List
)));
3762 -- For an array aggregate, a discrete_choice_list that has
3763 -- a nonstatic range is considered as two or more separate
3764 -- occurrences of the expression (RM 6.4.1(20/3)).
3766 elsif Is_Array_Type
(Etype
(N
))
3767 and then Nkind
(N
) = N_Aggregate
3768 and then Present
(Aggregate_Bounds
(N
))
3769 and then not Compile_Time_Known_Bounds
(Etype
(N
))
3771 -- Collect identifiers found in the dynamic bounds
3774 Count_Components
: Natural := 0;
3775 Low
, High
: Node_Id
;
3778 Assoc
:= First
(Component_Associations
(N
));
3779 while Present
(Assoc
) loop
3780 Choice
:= First
(Choices
(Assoc
));
3781 while Present
(Choice
) loop
3782 if Nkind
(Choice
) in
3783 N_Range | N_Subtype_Indication
3784 or else (Is_Entity_Name
(Choice
)
3785 and then Is_Type
(Entity
(Choice
)))
3787 Get_Index_Bounds
(Choice
, Low
, High
);
3789 if not Compile_Time_Known_Value
(Low
) then
3790 Collect_Identifiers
(Low
);
3792 if No
(Aggr_Error_Node
) then
3793 Aggr_Error_Node
:= Low
;
3797 if not Compile_Time_Known_Value
(High
) then
3798 Collect_Identifiers
(High
);
3800 if No
(Aggr_Error_Node
) then
3801 Aggr_Error_Node
:= High
;
3805 -- The RM rule is violated if there is more than
3806 -- a single choice in a component association.
3809 Count_Components
:= Count_Components
+ 1;
3811 if No
(Aggr_Error_Node
)
3812 and then Count_Components
> 1
3814 Aggr_Error_Node
:= Choice
;
3817 if not Compile_Time_Known_Value
(Choice
) then
3818 Collect_Identifiers
(Choice
);
3830 -- Handle ancestor part of extension aggregates
3832 if Nkind
(N
) = N_Extension_Aggregate
then
3833 Collect_Identifiers
(Ancestor_Part
(N
));
3836 -- Handle positional associations
3838 if Present
(Expressions
(N
)) then
3839 Comp_Expr
:= First
(Expressions
(N
));
3840 while Present
(Comp_Expr
) loop
3841 if not Is_OK_Static_Expression
(Comp_Expr
) then
3842 Collect_Identifiers
(Comp_Expr
);
3849 -- Handle discrete associations
3851 if Present
(Component_Associations
(N
)) then
3852 Assoc
:= First
(Component_Associations
(N
));
3853 while Present
(Assoc
) loop
3855 if not Box_Present
(Assoc
) then
3856 Choice
:= First
(Choices
(Assoc
));
3857 while Present
(Choice
) loop
3859 -- For now we skip discriminants since it requires
3860 -- performing the analysis in two phases: first one
3861 -- analyzing discriminants and second one analyzing
3862 -- the rest of components since discriminants are
3863 -- evaluated prior to components: too much extra
3864 -- work to detect a corner case???
3866 if Nkind
(Choice
) in N_Has_Entity
3867 and then Present
(Entity
(Choice
))
3868 and then Ekind
(Entity
(Choice
)) = E_Discriminant
3872 elsif Box_Present
(Assoc
) then
3876 if not Analyzed
(Expression
(Assoc
)) then
3878 New_Copy_Tree
(Expression
(Assoc
));
3879 Set_Parent
(Comp_Expr
, Parent
(N
));
3880 Preanalyze_Without_Errors
(Comp_Expr
);
3882 Comp_Expr
:= Expression
(Assoc
);
3885 Collect_Identifiers
(Comp_Expr
);
3901 -- No further action needed if we already reported an error
3903 if Present
(Error_Node
) then
3907 -- Check violation of RM 6.20/3 in aggregates
3909 if Present
(Aggr_Error_Node
)
3910 and then Present
(Writable_Actuals_List
)
3913 ("value may be affected by call in other component because they "
3914 & "are evaluated in unspecified order",
3915 Node
(First_Elmt
(Writable_Actuals_List
)));
3919 -- Check if some writable argument of a function is referenced
3921 if Present
(Writable_Actuals_List
)
3922 and then Present
(Identifiers_List
)
3929 Elmt_1
:= First_Elmt
(Writable_Actuals_List
);
3930 while Present
(Elmt_1
) loop
3931 Elmt_2
:= First_Elmt
(Identifiers_List
);
3932 while Present
(Elmt_2
) loop
3933 if Entity
(Node
(Elmt_1
)) = Entity
(Node
(Elmt_2
)) then
3934 case Nkind
(Parent
(Node
(Elmt_2
))) is
3936 | N_Component_Association
3937 | N_Component_Declaration
3940 ("value may be affected by call in other "
3941 & "component because they are evaluated "
3942 & "in unspecified order",
3949 ("value may be affected by call in other "
3950 & "alternative because they are evaluated "
3951 & "in unspecified order",
3956 ("value of actual may be affected by call in "
3957 & "other actual because they are evaluated "
3958 & "in unspecified order",
3970 end Check_Function_Writable_Actuals
;
3972 --------------------------------
3973 -- Check_Implicit_Dereference --
3974 --------------------------------
3976 procedure Check_Implicit_Dereference
(N
: Node_Id
; Typ
: Entity_Id
) is
3982 if Nkind
(N
) = N_Indexed_Component
3983 and then Present
(Generalized_Indexing
(N
))
3985 Nam
:= Generalized_Indexing
(N
);
3990 if Ada_Version
< Ada_2012
3991 or else not Has_Implicit_Dereference
(Base_Type
(Typ
))
3995 elsif not Comes_From_Source
(N
)
3996 and then Nkind
(N
) /= N_Indexed_Component
4000 elsif Is_Entity_Name
(Nam
) and then Is_Type
(Entity
(Nam
)) then
4004 Disc
:= First_Discriminant
(Typ
);
4005 while Present
(Disc
) loop
4006 if Has_Implicit_Dereference
(Disc
) then
4007 Desig
:= Designated_Type
(Etype
(Disc
));
4008 Add_One_Interp
(Nam
, Disc
, Desig
);
4010 -- If the node is a generalized indexing, add interpretation
4011 -- to that node as well, for subsequent resolution.
4013 if Nkind
(N
) = N_Indexed_Component
then
4014 Add_One_Interp
(N
, Disc
, Desig
);
4017 -- If the operation comes from a generic unit and the context
4018 -- is a selected component, the selector name may be global
4019 -- and set in the instance already. Remove the entity to
4020 -- force resolution of the selected component, and the
4021 -- generation of an explicit dereference if needed.
4024 and then Nkind
(Parent
(Nam
)) = N_Selected_Component
4026 Set_Entity
(Selector_Name
(Parent
(Nam
)), Empty
);
4032 Next_Discriminant
(Disc
);
4035 end Check_Implicit_Dereference
;
4037 ----------------------------------
4038 -- Check_Internal_Protected_Use --
4039 ----------------------------------
4041 procedure Check_Internal_Protected_Use
(N
: Node_Id
; Nam
: Entity_Id
) is
4049 while Present
(S
) loop
4050 if S
= Standard_Standard
then
4053 elsif Ekind
(S
) = E_Function
4054 and then Ekind
(Scope
(S
)) = E_Protected_Type
4064 and then Scope
(Nam
) = Prot
4065 and then Ekind
(Nam
) /= E_Function
4067 -- An indirect function call (e.g. a callback within a protected
4068 -- function body) is not statically illegal. If the access type is
4069 -- anonymous and is the type of an access parameter, the scope of Nam
4070 -- will be the protected type, but it is not a protected operation.
4072 if Ekind
(Nam
) = E_Subprogram_Type
4073 and then Nkind
(Associated_Node_For_Itype
(Nam
)) =
4074 N_Function_Specification
4078 elsif Nkind
(N
) = N_Subprogram_Renaming_Declaration
then
4080 ("within protected function cannot use protected procedure in "
4081 & "renaming or as generic actual", N
);
4083 elsif Nkind
(N
) = N_Attribute_Reference
then
4085 ("within protected function cannot take access of protected "
4090 ("within protected function, protected object is constant", N
);
4092 ("\cannot call operation that may modify it", N
);
4096 -- Verify that an internal call does not appear within a precondition
4097 -- of a protected operation. This implements AI12-0166.
4098 -- The precondition aspect has been rewritten as a pragma Precondition
4099 -- and we check whether the scope of the called subprogram is the same
4100 -- as that of the entity to which the aspect applies.
4102 if Convention
(Nam
) = Convention_Protected
then
4108 while Present
(P
) loop
4109 if Nkind
(P
) = N_Pragma
4110 and then Chars
(Pragma_Identifier
(P
)) = Name_Precondition
4111 and then From_Aspect_Specification
(P
)
4113 Scope
(Entity
(Corresponding_Aspect
(P
))) = Scope
(Nam
)
4116 ("internal call cannot appear in precondition of "
4117 & "protected operation", N
);
4120 elsif Nkind
(P
) = N_Pragma
4121 and then Chars
(Pragma_Identifier
(P
)) = Name_Contract_Cases
4123 -- Check whether call is in a case guard. It is legal in a
4127 while Present
(P
) loop
4128 if Nkind
(Parent
(P
)) = N_Component_Association
4129 and then P
/= Expression
(Parent
(P
))
4132 ("internal call cannot appear in case guard in a "
4133 & "contract case", N
);
4141 elsif Nkind
(P
) = N_Parameter_Specification
4142 and then Scope
(Current_Scope
) = Scope
(Nam
)
4143 and then Nkind
(Parent
(P
)) in
4144 N_Entry_Declaration | N_Subprogram_Declaration
4147 ("internal call cannot appear in default for formal of "
4148 & "protected operation", N
);
4156 end Check_Internal_Protected_Use
;
4158 ---------------------------------------
4159 -- Check_Later_Vs_Basic_Declarations --
4160 ---------------------------------------
4162 procedure Check_Later_Vs_Basic_Declarations
4164 During_Parsing
: Boolean)
4166 Body_Sloc
: Source_Ptr
;
4169 function Is_Later_Declarative_Item
(Decl
: Node_Id
) return Boolean;
4170 -- Return whether Decl is considered as a declarative item.
4171 -- When During_Parsing is True, the semantics of Ada 83 is followed.
4172 -- When During_Parsing is False, the semantics of SPARK is followed.
4174 -------------------------------
4175 -- Is_Later_Declarative_Item --
4176 -------------------------------
4178 function Is_Later_Declarative_Item
(Decl
: Node_Id
) return Boolean is
4180 if Nkind
(Decl
) in N_Later_Decl_Item
then
4183 elsif Nkind
(Decl
) = N_Pragma
then
4186 elsif During_Parsing
then
4189 -- In SPARK, a package declaration is not considered as a later
4190 -- declarative item.
4192 elsif Nkind
(Decl
) = N_Package_Declaration
then
4195 -- In SPARK, a renaming is considered as a later declarative item
4197 elsif Nkind
(Decl
) in N_Renaming_Declaration
then
4203 end Is_Later_Declarative_Item
;
4205 -- Start of processing for Check_Later_Vs_Basic_Declarations
4208 Decl
:= First
(Decls
);
4210 -- Loop through sequence of basic declarative items
4212 Outer
: while Present
(Decl
) loop
4213 if Nkind
(Decl
) not in
4214 N_Subprogram_Body | N_Package_Body | N_Task_Body
4215 and then Nkind
(Decl
) not in N_Body_Stub
4219 -- Once a body is encountered, we only allow later declarative
4220 -- items. The inner loop checks the rest of the list.
4223 Body_Sloc
:= Sloc
(Decl
);
4225 Inner
: while Present
(Decl
) loop
4226 if not Is_Later_Declarative_Item
(Decl
) then
4227 if During_Parsing
then
4228 if Ada_Version
= Ada_83
then
4229 Error_Msg_Sloc
:= Body_Sloc
;
4231 ("(Ada 83) decl cannot appear after body#", Decl
);
4240 end Check_Later_Vs_Basic_Declarations
;
4242 ---------------------------
4243 -- Check_No_Hidden_State --
4244 ---------------------------
4246 procedure Check_No_Hidden_State
(Id
: Entity_Id
) is
4247 Context
: Entity_Id
:= Empty
;
4248 Not_Visible
: Boolean := False;
4252 pragma Assert
(Ekind
(Id
) in E_Abstract_State | E_Variable
);
4254 -- Nothing to do for internally-generated abstract states and variables
4255 -- because they do not represent the hidden state of the source unit.
4257 if not Comes_From_Source
(Id
) then
4261 -- Find the proper context where the object or state appears
4264 while Present
(Scop
) loop
4267 -- Keep track of the context's visibility
4269 Not_Visible
:= Not_Visible
or else In_Private_Part
(Context
);
4271 -- Prevent the search from going too far
4273 if Context
= Standard_Standard
then
4276 -- Objects and states that appear immediately within a subprogram or
4277 -- entry inside a construct nested within a subprogram do not
4278 -- introduce a hidden state. They behave as local variable
4279 -- declarations. The same is true for elaboration code inside a block
4282 elsif Is_Subprogram_Or_Entry
(Context
)
4283 or else Ekind
(Context
) in E_Block | E_Task_Type
4288 -- Stop the traversal when a package subject to a null abstract state
4291 if Is_Package_Or_Generic_Package
(Context
)
4292 and then Has_Null_Abstract_State
(Context
)
4297 Scop
:= Scope
(Scop
);
4300 -- At this point we know that there is at least one package with a null
4301 -- abstract state in visibility. Emit an error message unconditionally
4302 -- if the entity being processed is a state because the placement of the
4303 -- related package is irrelevant. This is not the case for objects as
4304 -- the intermediate context matters.
4306 if Present
(Context
)
4307 and then (Ekind
(Id
) = E_Abstract_State
or else Not_Visible
)
4309 Error_Msg_N
("cannot introduce hidden state &", Id
);
4310 Error_Msg_NE
("\package & has null abstract state", Id
, Context
);
4312 end Check_No_Hidden_State
;
4314 ---------------------------------------------
4315 -- Check_Nonoverridable_Aspect_Consistency --
4316 ---------------------------------------------
4318 procedure Check_Inherited_Nonoverridable_Aspects
4319 (Inheritor
: Entity_Id
;
4320 Interface_List
: List_Id
;
4321 Parent_Type
: Entity_Id
) is
4323 -- array needed for iterating over subtype values
4324 Nonoverridable_Aspects
: constant array (Positive range <>) of
4325 Nonoverridable_Aspect_Id
:=
4326 (Aspect_Default_Iterator
,
4327 Aspect_Iterator_Element
,
4328 Aspect_Implicit_Dereference
,
4329 Aspect_Constant_Indexing
,
4330 Aspect_Variable_Indexing
,
4332 Aspect_Max_Entry_Queue_Length
4333 -- , Aspect_No_Controlled_Parts
4336 -- Note that none of these 8 aspects can be specified (for a type)
4337 -- via a pragma. For 7 of them, the corresponding pragma does not
4338 -- exist. The Pragma_Id enumeration type does include
4339 -- Pragma_Max_Entry_Queue_Length, but that pragma is only use to
4340 -- specify the aspect for a protected entry or entry family, not for
4341 -- a type, and therefore cannot introduce the sorts of inheritance
4342 -- issues that we are concerned with in this procedure.
4344 type Entity_Array
is array (Nat
range <>) of Entity_Id
;
4346 function Ancestor_Entities
return Entity_Array
;
4347 -- Returns all progenitors (including parent type, if present)
4349 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors
4350 (Aspect
: Nonoverridable_Aspect_Id
;
4351 Ancestor_1
: Entity_Id
;
4352 Aspect_Spec_1
: Node_Id
;
4353 Ancestor_2
: Entity_Id
;
4354 Aspect_Spec_2
: Node_Id
);
4355 -- A given aspect has been specified for each of two ancestors;
4356 -- check that the two aspect specifications are compatible (see
4357 -- RM 13.1.1(18.5) and AI12-0211).
4359 -----------------------
4360 -- Ancestor_Entities --
4361 -----------------------
4363 function Ancestor_Entities
return Entity_Array
is
4364 Ifc_Count
: constant Nat
:= List_Length
(Interface_List
);
4365 Ifc_Ancestors
: Entity_Array
(1 .. Ifc_Count
);
4366 Ifc
: Node_Id
:= First
(Interface_List
);
4368 for Idx
in Ifc_Ancestors
'Range loop
4369 Ifc_Ancestors
(Idx
) := Entity
(Ifc
);
4370 pragma Assert
(Present
(Ifc_Ancestors
(Idx
)));
4373 pragma Assert
(not Present
(Ifc
));
4374 if Present
(Parent_Type
) then
4375 return Parent_Type
& Ifc_Ancestors
;
4377 return Ifc_Ancestors
;
4379 end Ancestor_Entities
;
4381 -------------------------------------------------------
4382 -- Check_Consistency_For_One_Aspect_Of_Two_Ancestors --
4383 -------------------------------------------------------
4385 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors
4386 (Aspect
: Nonoverridable_Aspect_Id
;
4387 Ancestor_1
: Entity_Id
;
4388 Aspect_Spec_1
: Node_Id
;
4389 Ancestor_2
: Entity_Id
;
4390 Aspect_Spec_2
: Node_Id
) is
4392 if not Is_Confirming
(Aspect
, Aspect_Spec_1
, Aspect_Spec_2
) then
4393 Error_Msg_Name_1
:= Aspect_Names
(Aspect
);
4394 Error_Msg_Name_2
:= Chars
(Ancestor_1
);
4395 Error_Msg_Name_3
:= Chars
(Ancestor_2
);
4398 "incompatible % aspects inherited from ancestors % and %",
4401 end Check_Consistency_For_One_Aspect_Of_Two_Ancestors
;
4403 Ancestors
: constant Entity_Array
:= Ancestor_Entities
;
4405 -- start of processing for Check_Inherited_Nonoverridable_Aspects
4407 -- No Ada_Version check here; AI12-0211 is a binding interpretation.
4409 if Ancestors
'Length < 2 then
4410 return; -- Inconsistency impossible; it takes 2 to disagree.
4411 elsif In_Instance_Body
then
4412 return; -- No legality checking in an instance body.
4415 for Aspect
of Nonoverridable_Aspects
loop
4417 First_Ancestor_With_Aspect
: Entity_Id
:= Empty
;
4418 First_Aspect_Spec
, Current_Aspect_Spec
: Node_Id
:= Empty
;
4420 for Ancestor
of Ancestors
loop
4421 Current_Aspect_Spec
:= Find_Aspect
(Ancestor
, Aspect
);
4422 if Present
(Current_Aspect_Spec
) then
4423 if Present
(First_Ancestor_With_Aspect
) then
4424 Check_Consistency_For_One_Aspect_Of_Two_Ancestors
4426 Ancestor_1
=> First_Ancestor_With_Aspect
,
4427 Aspect_Spec_1
=> First_Aspect_Spec
,
4428 Ancestor_2
=> Ancestor
,
4429 Aspect_Spec_2
=> Current_Aspect_Spec
);
4431 First_Ancestor_With_Aspect
:= Ancestor
;
4432 First_Aspect_Spec
:= Current_Aspect_Spec
;
4438 end Check_Inherited_Nonoverridable_Aspects
;
4440 ----------------------------------------
4441 -- Check_Nonvolatile_Function_Profile --
4442 ----------------------------------------
4444 procedure Check_Nonvolatile_Function_Profile
(Func_Id
: Entity_Id
) is
4448 -- Inspect all formal parameters
4450 Formal
:= First_Formal
(Func_Id
);
4451 while Present
(Formal
) loop
4452 if Is_Effectively_Volatile_For_Reading
(Etype
(Formal
)) then
4454 ("nonvolatile function & cannot have a volatile parameter",
4458 Next_Formal
(Formal
);
4461 -- Inspect the return type
4463 if Is_Effectively_Volatile_For_Reading
(Etype
(Func_Id
)) then
4465 ("nonvolatile function & cannot have a volatile return type",
4466 Result_Definition
(Parent
(Func_Id
)), Func_Id
);
4468 end Check_Nonvolatile_Function_Profile
;
4474 function Check_Parents
(N
: Node_Id
; List
: Elist_Id
) return Boolean is
4477 (Parent_Node
: Node_Id
;
4478 N
: Node_Id
) return Traverse_Result
;
4479 -- Process a single node.
4486 (Parent_Node
: Node_Id
;
4487 N
: Node_Id
) return Traverse_Result
is
4489 if Nkind
(N
) = N_Identifier
4490 and then Parent
(N
) /= Parent_Node
4491 and then Present
(Entity
(N
))
4492 and then Contains
(List
, Entity
(N
))
4500 function Traverse
is new Traverse_Func_With_Parent
(Check_Node
);
4502 -- Start of processing for Check_Parents
4505 return Traverse
(N
) = OK
;
4508 -----------------------------
4509 -- Check_Part_Of_Reference --
4510 -----------------------------
4512 procedure Check_Part_Of_Reference
(Var_Id
: Entity_Id
; Ref
: Node_Id
) is
4513 function Is_Enclosing_Package_Body
4514 (Body_Decl
: Node_Id
;
4515 Obj_Id
: Entity_Id
) return Boolean;
4516 pragma Inline
(Is_Enclosing_Package_Body
);
4517 -- Determine whether package body Body_Decl or its corresponding spec
4518 -- immediately encloses the declaration of object Obj_Id.
4520 function Is_Internal_Declaration_Or_Body
4521 (Decl
: Node_Id
) return Boolean;
4522 pragma Inline
(Is_Internal_Declaration_Or_Body
);
4523 -- Determine whether declaration or body denoted by Decl is internal
4525 function Is_Single_Declaration_Or_Body
4527 Conc_Typ
: Entity_Id
) return Boolean;
4528 pragma Inline
(Is_Single_Declaration_Or_Body
);
4529 -- Determine whether protected/task declaration or body denoted by Decl
4530 -- belongs to single concurrent type Conc_Typ.
4532 function Is_Single_Task_Pragma
4534 Task_Typ
: Entity_Id
) return Boolean;
4535 pragma Inline
(Is_Single_Task_Pragma
);
4536 -- Determine whether pragma Prag belongs to single task type Task_Typ
4538 -------------------------------
4539 -- Is_Enclosing_Package_Body --
4540 -------------------------------
4542 function Is_Enclosing_Package_Body
4543 (Body_Decl
: Node_Id
;
4544 Obj_Id
: Entity_Id
) return Boolean
4546 Obj_Context
: Node_Id
;
4549 -- Find the context of the object declaration
4551 Obj_Context
:= Parent
(Declaration_Node
(Obj_Id
));
4553 if Nkind
(Obj_Context
) = N_Package_Specification
then
4554 Obj_Context
:= Parent
(Obj_Context
);
4557 -- The object appears immediately within the package body
4559 if Obj_Context
= Body_Decl
then
4562 -- The object appears immediately within the corresponding spec
4564 elsif Nkind
(Obj_Context
) = N_Package_Declaration
4565 and then Unit_Declaration_Node
(Corresponding_Spec
(Body_Decl
)) =
4572 end Is_Enclosing_Package_Body
;
4574 -------------------------------------
4575 -- Is_Internal_Declaration_Or_Body --
4576 -------------------------------------
4578 function Is_Internal_Declaration_Or_Body
4579 (Decl
: Node_Id
) return Boolean
4582 if Comes_From_Source
(Decl
) then
4585 -- A body generated for an expression function which has not been
4586 -- inserted into the tree yet (In_Spec_Expression is True) is not
4587 -- considered internal.
4589 elsif Nkind
(Decl
) = N_Subprogram_Body
4590 and then Was_Expression_Function
(Decl
)
4591 and then not In_Spec_Expression
4597 end Is_Internal_Declaration_Or_Body
;
4599 -----------------------------------
4600 -- Is_Single_Declaration_Or_Body --
4601 -----------------------------------
4603 function Is_Single_Declaration_Or_Body
4605 Conc_Typ
: Entity_Id
) return Boolean
4607 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
4611 Present
(Anonymous_Object
(Spec_Id
))
4612 and then Anonymous_Object
(Spec_Id
) = Conc_Typ
;
4613 end Is_Single_Declaration_Or_Body
;
4615 ---------------------------
4616 -- Is_Single_Task_Pragma --
4617 ---------------------------
4619 function Is_Single_Task_Pragma
4621 Task_Typ
: Entity_Id
) return Boolean
4623 Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(Prag
);
4626 -- To qualify, the pragma must be associated with single task type
4630 Is_Single_Task_Object
(Task_Typ
)
4631 and then Nkind
(Decl
) = N_Object_Declaration
4632 and then Defining_Entity
(Decl
) = Task_Typ
;
4633 end Is_Single_Task_Pragma
;
4637 Conc_Obj
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
4642 -- Start of processing for Check_Part_Of_Reference
4645 -- Nothing to do when the variable was recorded, but did not become a
4646 -- constituent of a single concurrent type.
4648 if No
(Conc_Obj
) then
4652 -- Traverse the parent chain looking for a suitable context for the
4653 -- reference to the concurrent constituent.
4656 Par
:= Parent
(Prev
);
4657 while Present
(Par
) loop
4658 if Nkind
(Par
) = N_Pragma
then
4659 Prag_Nam
:= Pragma_Name
(Par
);
4661 -- A concurrent constituent is allowed to appear in pragmas
4662 -- Initial_Condition and Initializes as this is part of the
4663 -- elaboration checks for the constituent (SPARK RM 9(3)).
4665 if Prag_Nam
in Name_Initial_Condition | Name_Initializes
then
4668 -- When the reference appears within pragma Depends or Global,
4669 -- check whether the pragma applies to a single task type. Note
4670 -- that the pragma may not encapsulated by the type definition,
4671 -- but this is still a valid context.
4673 elsif Prag_Nam
in Name_Depends | Name_Global
4674 and then Is_Single_Task_Pragma
(Par
, Conc_Obj
)
4679 -- The reference appears somewhere in the definition of a single
4680 -- concurrent type (SPARK RM 9(3)).
4682 elsif Nkind
(Par
) in
4683 N_Single_Protected_Declaration | N_Single_Task_Declaration
4684 and then Defining_Entity
(Par
) = Conc_Obj
4688 -- The reference appears within the declaration or body of a single
4689 -- concurrent type (SPARK RM 9(3)).
4691 elsif Nkind
(Par
) in N_Protected_Body
4692 | N_Protected_Type_Declaration
4694 | N_Task_Type_Declaration
4695 and then Is_Single_Declaration_Or_Body
(Par
, Conc_Obj
)
4699 -- The reference appears within the statement list of the object's
4700 -- immediately enclosing package (SPARK RM 9(3)).
4702 elsif Nkind
(Par
) = N_Package_Body
4703 and then Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
4704 and then Is_Enclosing_Package_Body
(Par
, Var_Id
)
4708 -- The reference has been relocated within an internally generated
4709 -- package or subprogram. Assume that the reference is legal as the
4710 -- real check was already performed in the original context of the
4713 elsif Nkind
(Par
) in N_Package_Body
4714 | N_Package_Declaration
4716 | N_Subprogram_Declaration
4717 and then Is_Internal_Declaration_Or_Body
(Par
)
4721 -- The reference has been relocated to an inlined body for GNATprove.
4722 -- Assume that the reference is legal as the real check was already
4723 -- performed in the original context of the reference.
4725 elsif GNATprove_Mode
4726 and then Nkind
(Par
) = N_Subprogram_Body
4727 and then Chars
(Defining_Entity
(Par
)) = Name_uParent
4733 Par
:= Parent
(Prev
);
4736 -- At this point it is known that the reference does not appear within a
4740 ("reference to variable & cannot appear in this context", Ref
, Var_Id
);
4741 Error_Msg_Name_1
:= Chars
(Var_Id
);
4743 if Is_Single_Protected_Object
(Conc_Obj
) then
4745 ("\% is constituent of single protected type &", Ref
, Conc_Obj
);
4749 ("\% is constituent of single task type &", Ref
, Conc_Obj
);
4751 end Check_Part_Of_Reference
;
4753 ------------------------------------------
4754 -- Check_Potentially_Blocking_Operation --
4755 ------------------------------------------
4757 procedure Check_Potentially_Blocking_Operation
(N
: Node_Id
) is
4761 -- N is one of the potentially blocking operations listed in 9.5.1(8).
4762 -- When pragma Detect_Blocking is active, the run time will raise
4763 -- Program_Error. Here we only issue a warning, since we generally
4764 -- support the use of potentially blocking operations in the absence
4767 -- Indirect blocking through a subprogram call cannot be diagnosed
4768 -- statically without interprocedural analysis, so we do not attempt
4771 S
:= Scope
(Current_Scope
);
4772 while Present
(S
) and then S
/= Standard_Standard
loop
4773 if Is_Protected_Type
(S
) then
4775 ("potentially blocking operation in protected operation??", N
);
4781 end Check_Potentially_Blocking_Operation
;
4783 ------------------------------------
4784 -- Check_Previous_Null_Procedure --
4785 ------------------------------------
4787 procedure Check_Previous_Null_Procedure
4792 if Ekind
(Prev
) = E_Procedure
4793 and then Nkind
(Parent
(Prev
)) = N_Procedure_Specification
4794 and then Null_Present
(Parent
(Prev
))
4796 Error_Msg_Sloc
:= Sloc
(Prev
);
4798 ("declaration cannot complete previous null procedure#", Decl
);
4800 end Check_Previous_Null_Procedure
;
4802 ---------------------------------
4803 -- Check_Result_And_Post_State --
4804 ---------------------------------
4806 procedure Check_Result_And_Post_State
(Subp_Id
: Entity_Id
) is
4807 procedure Check_Result_And_Post_State_In_Pragma
4809 Result_Seen
: in out Boolean);
4810 -- Determine whether pragma Prag mentions attribute 'Result and whether
4811 -- the pragma contains an expression that evaluates differently in pre-
4812 -- and post-state. Prag is a [refined] postcondition or a contract-cases
4813 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result
4815 function Is_Trivial_Boolean
(N
: Node_Id
) return Boolean;
4816 -- Determine whether source node N denotes "True" or "False"
4818 -------------------------------------------
4819 -- Check_Result_And_Post_State_In_Pragma --
4820 -------------------------------------------
4822 procedure Check_Result_And_Post_State_In_Pragma
4824 Result_Seen
: in out Boolean)
4826 procedure Check_Conjunct
(Expr
: Node_Id
);
4827 -- Check an individual conjunct in a conjunction of Boolean
4828 -- expressions, connected by "and" or "and then" operators.
4830 procedure Check_Conjuncts
(Expr
: Node_Id
);
4831 -- Apply the post-state check to every conjunct in an expression, in
4832 -- case this is a conjunction of Boolean expressions. Otherwise apply
4833 -- it to the expression as a whole.
4835 procedure Check_Expression
(Expr
: Node_Id
);
4836 -- Perform the 'Result and post-state checks on a given expression
4838 function Is_Function_Result
(N
: Node_Id
) return Traverse_Result
;
4839 -- Attempt to find attribute 'Result in a subtree denoted by N
4841 function Mentions_Post_State
(N
: Node_Id
) return Boolean;
4842 -- Determine whether a subtree denoted by N mentions any construct
4843 -- that denotes a post-state.
4845 procedure Check_Function_Result
is
4846 new Traverse_Proc
(Is_Function_Result
);
4848 --------------------
4849 -- Check_Conjunct --
4850 --------------------
4852 procedure Check_Conjunct
(Expr
: Node_Id
) is
4853 function Adjust_Message
(Msg
: String) return String;
4854 -- Prepend a prefix to the input message Msg denoting that the
4855 -- message applies to a conjunct in the expression, when this
4858 function Applied_On_Conjunct
return Boolean;
4859 -- Returns True if the message applies to a conjunct in the
4860 -- expression, instead of the whole expression.
4862 function Has_Global_Output
(Subp
: Entity_Id
) return Boolean;
4863 -- Returns True if Subp has an output in its Global contract
4865 function Has_No_Output
(Subp
: Entity_Id
) return Boolean;
4866 -- Returns True if Subp has no declared output: no function
4867 -- result, no output parameter, and no output in its Global
4870 --------------------
4871 -- Adjust_Message --
4872 --------------------
4874 function Adjust_Message
(Msg
: String) return String is
4876 if Applied_On_Conjunct
then
4877 return "conjunct in " & Msg
;
4883 -------------------------
4884 -- Applied_On_Conjunct --
4885 -------------------------
4887 function Applied_On_Conjunct
return Boolean is
4889 -- Expr is the conjunct of an enclosing "and" expression
4891 return Nkind
(Parent
(Expr
)) in N_Subexpr
4893 -- or Expr is a conjunct of an enclosing "and then"
4894 -- expression in a postcondition aspect that was split into
4895 -- multiple pragmas. The first conjunct has the "and then"
4896 -- expression as Original_Node, and other conjuncts have
4897 -- Split_PCC set to True.
4899 or else Nkind
(Original_Node
(Expr
)) = N_And_Then
4900 or else Split_PPC
(Prag
);
4901 end Applied_On_Conjunct
;
4903 -----------------------
4904 -- Has_Global_Output --
4905 -----------------------
4907 function Has_Global_Output
(Subp
: Entity_Id
) return Boolean is
4908 Global
: constant Node_Id
:= Get_Pragma
(Subp
, Pragma_Global
);
4917 List
:= Expression
(Get_Argument
(Global
, Subp
));
4919 -- Empty list (no global items) or single global item
4920 -- declaration (only input items).
4922 if Nkind
(List
) in N_Null
4925 | N_Selected_Component
4929 -- Simple global list (only input items) or moded global list
4932 elsif Nkind
(List
) = N_Aggregate
then
4933 if Present
(Expressions
(List
)) then
4937 Assoc
:= First
(Component_Associations
(List
));
4938 while Present
(Assoc
) loop
4939 if Chars
(First
(Choices
(Assoc
))) /= Name_Input
then
4949 -- To accommodate partial decoration of disabled SPARK
4950 -- features, this routine may be called with illegal input.
4951 -- If this is the case, do not raise Program_Error.
4956 end Has_Global_Output
;
4962 function Has_No_Output
(Subp
: Entity_Id
) return Boolean is
4966 -- A function has its result as output
4968 if Ekind
(Subp
) = E_Function
then
4972 -- An OUT or IN OUT parameter is an output
4974 Param
:= First_Formal
(Subp
);
4975 while Present
(Param
) loop
4976 if Ekind
(Param
) in E_Out_Parameter | E_In_Out_Parameter
then
4980 Next_Formal
(Param
);
4983 -- An item of mode Output or In_Out in the Global contract is
4986 if Has_Global_Output
(Subp
) then
4996 -- Error node when reporting a warning on a (refined)
4999 -- Start of processing for Check_Conjunct
5002 if Applied_On_Conjunct
then
5008 -- Do not report missing reference to outcome in postcondition if
5009 -- either the postcondition is trivially True or False, or if the
5010 -- subprogram is ghost and has no declared output.
5012 if not Is_Trivial_Boolean
(Expr
)
5013 and then not Mentions_Post_State
(Expr
)
5014 and then not (Is_Ghost_Entity
(Subp_Id
)
5015 and then Has_No_Output
(Subp_Id
))
5016 and then not Is_Wrapper
(Subp_Id
)
5018 if Pragma_Name
(Prag
) = Name_Contract_Cases
then
5019 Error_Msg_NE
(Adjust_Message
5020 ("contract case does not check the outcome of calling "
5021 & "&?.t?"), Expr
, Subp_Id
);
5023 elsif Pragma_Name
(Prag
) = Name_Refined_Post
then
5024 Error_Msg_NE
(Adjust_Message
5025 ("refined postcondition does not check the outcome of "
5026 & "calling &?.t?"), Err_Node
, Subp_Id
);
5029 Error_Msg_NE
(Adjust_Message
5030 ("postcondition does not check the outcome of calling "
5031 & "&?.t?"), Err_Node
, Subp_Id
);
5036 ---------------------
5037 -- Check_Conjuncts --
5038 ---------------------
5040 procedure Check_Conjuncts
(Expr
: Node_Id
) is
5042 if Nkind
(Expr
) in N_Op_And | N_And_Then
then
5043 Check_Conjuncts
(Left_Opnd
(Expr
));
5044 Check_Conjuncts
(Right_Opnd
(Expr
));
5046 Check_Conjunct
(Expr
);
5048 end Check_Conjuncts
;
5050 ----------------------
5051 -- Check_Expression --
5052 ----------------------
5054 procedure Check_Expression
(Expr
: Node_Id
) is
5056 if not Is_Trivial_Boolean
(Expr
) then
5057 Check_Function_Result
(Expr
);
5058 Check_Conjuncts
(Expr
);
5060 end Check_Expression
;
5062 ------------------------
5063 -- Is_Function_Result --
5064 ------------------------
5066 function Is_Function_Result
(N
: Node_Id
) return Traverse_Result
is
5068 if Is_Attribute_Result
(N
) then
5069 Result_Seen
:= True;
5072 -- Warn on infinite recursion if call is to current function
5074 elsif Nkind
(N
) = N_Function_Call
5075 and then Is_Entity_Name
(Name
(N
))
5076 and then Entity
(Name
(N
)) = Subp_Id
5077 and then not Is_Potentially_Unevaluated
(N
)
5080 ("call to & within its postcondition will lead to infinite "
5081 & "recursion?", N
, Subp_Id
);
5084 -- Continue the traversal
5089 end Is_Function_Result
;
5091 -------------------------
5092 -- Mentions_Post_State --
5093 -------------------------
5095 function Mentions_Post_State
(N
: Node_Id
) return Boolean is
5096 Post_State_Seen
: Boolean := False;
5098 function Is_Post_State
(N
: Node_Id
) return Traverse_Result
;
5099 -- Attempt to find a construct that denotes a post-state. If this
5100 -- is the case, set flag Post_State_Seen.
5106 function Is_Post_State
(N
: Node_Id
) return Traverse_Result
is
5110 if Nkind
(N
) in N_Explicit_Dereference | N_Function_Call
then
5111 Post_State_Seen
:= True;
5114 elsif Nkind
(N
) in N_Expanded_Name | N_Identifier
then
5117 -- Treat an undecorated reference as OK
5121 -- A reference to an assignable entity is considered a
5122 -- change in the post-state of a subprogram.
5124 or else Ekind
(Ent
) in E_Generic_In_Out_Parameter
5125 | E_In_Out_Parameter
5129 -- The reference may be modified through a dereference
5131 or else (Is_Access_Type
(Etype
(Ent
))
5132 and then Nkind
(Parent
(N
)) =
5133 N_Selected_Component
)
5135 Post_State_Seen
:= True;
5139 elsif Nkind
(N
) = N_Attribute_Reference
then
5140 if Attribute_Name
(N
) = Name_Old
then
5143 elsif Attribute_Name
(N
) = Name_Result
then
5144 Post_State_Seen
:= True;
5152 procedure Find_Post_State
is new Traverse_Proc
(Is_Post_State
);
5154 -- Start of processing for Mentions_Post_State
5157 Find_Post_State
(N
);
5159 return Post_State_Seen
;
5160 end Mentions_Post_State
;
5164 Expr
: constant Node_Id
:=
5166 (First
(Pragma_Argument_Associations
(Prag
)));
5167 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
5170 -- Start of processing for Check_Result_And_Post_State_In_Pragma
5173 -- Examine all consequences
5175 if Nam
= Name_Contract_Cases
then
5176 CCase
:= First
(Component_Associations
(Expr
));
5177 while Present
(CCase
) loop
5178 Check_Expression
(Expression
(CCase
));
5183 -- Examine the expression of a postcondition
5185 else pragma Assert
(Nam
in Name_Postcondition | Name_Refined_Post
);
5186 Check_Expression
(Expr
);
5188 end Check_Result_And_Post_State_In_Pragma
;
5190 ------------------------
5191 -- Is_Trivial_Boolean --
5192 ------------------------
5194 function Is_Trivial_Boolean
(N
: Node_Id
) return Boolean is
5197 Comes_From_Source
(N
)
5198 and then Is_Entity_Name
(N
)
5199 and then (Entity
(N
) = Standard_True
5201 Entity
(N
) = Standard_False
);
5202 end Is_Trivial_Boolean
;
5206 Items
: constant Node_Id
:= Contract
(Subp_Id
);
5207 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
5208 Case_Prag
: Node_Id
:= Empty
;
5209 Post_Prag
: Node_Id
:= Empty
;
5211 Seen_In_Case
: Boolean := False;
5212 Seen_In_Post
: Boolean := False;
5213 Spec_Id
: Entity_Id
;
5215 -- Start of processing for Check_Result_And_Post_State
5218 -- The lack of attribute 'Result or a post-state is classified as a
5219 -- suspicious contract. Do not perform the check if the corresponding
5220 -- swich is not set.
5222 if not Warn_On_Suspicious_Contract
then
5225 -- Nothing to do if there is no contract
5227 elsif No
(Items
) then
5231 -- Retrieve the entity of the subprogram spec (if any)
5233 if Nkind
(Subp_Decl
) = N_Subprogram_Body
5234 and then Present
(Corresponding_Spec
(Subp_Decl
))
5236 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
5238 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
5239 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
5241 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
5247 -- Examine all postconditions for attribute 'Result and a post-state
5249 Prag
:= Pre_Post_Conditions
(Items
);
5250 while Present
(Prag
) loop
5251 if Pragma_Name_Unmapped
(Prag
)
5252 in Name_Postcondition | Name_Refined_Post
5253 and then not Error_Posted
(Prag
)
5256 Check_Result_And_Post_State_In_Pragma
(Prag
, Seen_In_Post
);
5259 Prag
:= Next_Pragma
(Prag
);
5262 -- Examine the contract cases of the subprogram for attribute 'Result
5263 -- and a post-state.
5265 Prag
:= Contract_Test_Cases
(Items
);
5266 while Present
(Prag
) loop
5267 if Pragma_Name
(Prag
) = Name_Contract_Cases
5268 and then not Error_Posted
(Prag
)
5271 Check_Result_And_Post_State_In_Pragma
(Prag
, Seen_In_Case
);
5274 Prag
:= Next_Pragma
(Prag
);
5277 -- Do not emit any errors if the subprogram is not a function
5279 if Ekind
(Spec_Id
) not in E_Function | E_Generic_Function
then
5282 -- Regardless of whether the function has postconditions or contract
5283 -- cases, or whether they mention attribute 'Result, an [IN] OUT formal
5284 -- parameter is always treated as a result.
5286 elsif Has_Out_Or_In_Out_Parameter
(Spec_Id
) then
5289 -- The function has both a postcondition and contract cases and they do
5290 -- not mention attribute 'Result.
5292 elsif Present
(Case_Prag
)
5293 and then not Seen_In_Case
5294 and then Present
(Post_Prag
)
5295 and then not Seen_In_Post
5298 ("neither postcondition nor contract cases mention function "
5299 & "result?.t?", Post_Prag
);
5301 -- The function has contract cases only and they do not mention
5302 -- attribute 'Result.
5304 elsif Present
(Case_Prag
) and then not Seen_In_Case
then
5305 Error_Msg_N
("contract cases do not mention result?.t?", Case_Prag
);
5307 -- The function has non-trivial postconditions only and they do not
5308 -- mention attribute 'Result.
5310 elsif Present
(Post_Prag
)
5311 and then not Seen_In_Post
5312 and then not Is_Trivial_Boolean
5313 (Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Post_Prag
))))
5316 ("postcondition does not mention function result?.t?", Post_Prag
);
5318 end Check_Result_And_Post_State
;
5320 -----------------------------
5321 -- Check_State_Refinements --
5322 -----------------------------
5324 procedure Check_State_Refinements
5326 Is_Main_Unit
: Boolean := False)
5328 procedure Check_Package
(Pack
: Node_Id
);
5329 -- Verify that all abstract states of a [generic] package denoted by its
5330 -- declarative node Pack have proper refinement. Recursively verify the
5331 -- visible and private declarations of the [generic] package for other
5334 procedure Check_Packages_In
(Decls
: List_Id
);
5335 -- Seek out [generic] package declarations within declarative list Decls
5336 -- and verify the status of their abstract state refinement.
5338 function SPARK_Mode_Is_Off
(N
: Node_Id
) return Boolean;
5339 -- Determine whether construct N is subject to pragma SPARK_Mode Off
5345 procedure Check_Package
(Pack
: Node_Id
) is
5346 Body_Id
: constant Entity_Id
:= Corresponding_Body
(Pack
);
5347 Spec
: constant Node_Id
:= Specification
(Pack
);
5348 States
: constant Elist_Id
:=
5349 Abstract_States
(Defining_Entity
(Pack
));
5351 State_Elmt
: Elmt_Id
;
5352 State_Id
: Entity_Id
;
5355 -- Do not verify proper state refinement when the package is subject
5356 -- to pragma SPARK_Mode Off because this disables the requirement for
5357 -- state refinement.
5359 if SPARK_Mode_Is_Off
(Pack
) then
5362 -- State refinement can only occur in a completing package body. Do
5363 -- not verify proper state refinement when the body is subject to
5364 -- pragma SPARK_Mode Off because this disables the requirement for
5365 -- state refinement.
5367 elsif Present
(Body_Id
)
5368 and then SPARK_Mode_Is_Off
(Unit_Declaration_Node
(Body_Id
))
5372 -- Do not verify proper state refinement when the package is an
5373 -- instance as this check was already performed in the generic.
5375 elsif Present
(Generic_Parent
(Spec
)) then
5378 -- Otherwise examine the contents of the package
5381 if Present
(States
) then
5382 State_Elmt
:= First_Elmt
(States
);
5383 while Present
(State_Elmt
) loop
5384 State_Id
:= Node
(State_Elmt
);
5386 -- Emit an error when a non-null state lacks any form of
5389 if not Is_Null_State
(State_Id
)
5390 and then not Has_Null_Refinement
(State_Id
)
5391 and then not Has_Non_Null_Refinement
(State_Id
)
5393 Error_Msg_N
("state & requires refinement", State_Id
);
5394 Error_Msg_N
("\package body should have Refined_State "
5395 & "for state & with constituents", State_Id
);
5398 Next_Elmt
(State_Elmt
);
5402 Check_Packages_In
(Visible_Declarations
(Spec
));
5403 Check_Packages_In
(Private_Declarations
(Spec
));
5407 -----------------------
5408 -- Check_Packages_In --
5409 -----------------------
5411 procedure Check_Packages_In
(Decls
: List_Id
) is
5415 if Present
(Decls
) then
5416 Decl
:= First
(Decls
);
5417 while Present
(Decl
) loop
5418 if Nkind
(Decl
) in N_Generic_Package_Declaration
5419 | N_Package_Declaration
5421 Check_Package
(Decl
);
5427 end Check_Packages_In
;
5429 -----------------------
5430 -- SPARK_Mode_Is_Off --
5431 -----------------------
5433 function SPARK_Mode_Is_Off
(N
: Node_Id
) return Boolean is
5434 Id
: constant Entity_Id
:= Defining_Entity
(N
);
5435 Prag
: constant Node_Id
:= SPARK_Pragma
(Id
);
5438 -- Default the mode to "off" when the context is an instance and all
5439 -- SPARK_Mode pragmas found within are to be ignored.
5441 if Ignore_SPARK_Mode_Pragmas
(Id
) then
5447 and then Get_SPARK_Mode_From_Annotation
(Prag
) = Off
;
5449 end SPARK_Mode_Is_Off
;
5451 -- Start of processing for Check_State_Refinements
5454 -- A block may declare a nested package
5456 if Nkind
(Context
) = N_Block_Statement
then
5457 Check_Packages_In
(Declarations
(Context
));
5459 -- An entry, protected, subprogram, or task body may declare a nested
5462 elsif Nkind
(Context
) in N_Entry_Body
5467 -- Do not verify proper state refinement when the body is subject to
5468 -- pragma SPARK_Mode Off because this disables the requirement for
5469 -- state refinement.
5471 if not SPARK_Mode_Is_Off
(Context
) then
5472 Check_Packages_In
(Declarations
(Context
));
5475 -- A package body may declare a nested package
5477 elsif Nkind
(Context
) = N_Package_Body
then
5478 Check_Package
(Unit_Declaration_Node
(Corresponding_Spec
(Context
)));
5480 -- Do not verify proper state refinement when the body is subject to
5481 -- pragma SPARK_Mode Off because this disables the requirement for
5482 -- state refinement.
5484 if not SPARK_Mode_Is_Off
(Context
) then
5485 Check_Packages_In
(Declarations
(Context
));
5488 -- A library level [generic] package may declare a nested package
5490 elsif Nkind
(Context
) in
5491 N_Generic_Package_Declaration | N_Package_Declaration
5492 and then Is_Main_Unit
5494 Check_Package
(Context
);
5496 end Check_State_Refinements
;
5498 ------------------------------
5499 -- Check_Unprotected_Access --
5500 ------------------------------
5502 procedure Check_Unprotected_Access
5506 Cont_Encl_Typ
: Entity_Id
;
5507 Pref_Encl_Typ
: Entity_Id
;
5509 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
;
5510 -- Check whether Obj is a private component of a protected object.
5511 -- Return the protected type where the component resides, Empty
5514 function Is_Public_Operation
return Boolean;
5515 -- Verify that the enclosing operation is callable from outside the
5516 -- protected object, to minimize false positives.
5518 ------------------------------
5519 -- Enclosing_Protected_Type --
5520 ------------------------------
5522 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
is
5524 if Is_Entity_Name
(Obj
) then
5526 Ent
: Entity_Id
:= Entity
(Obj
);
5529 -- The object can be a renaming of a private component, use
5530 -- the original record component.
5532 if Is_Prival
(Ent
) then
5533 Ent
:= Prival_Link
(Ent
);
5536 if Is_Protected_Type
(Scope
(Ent
)) then
5542 -- For indexed and selected components, recursively check the prefix
5544 if Nkind
(Obj
) in N_Indexed_Component | N_Selected_Component
then
5545 return Enclosing_Protected_Type
(Prefix
(Obj
));
5547 -- The object does not denote a protected component
5552 end Enclosing_Protected_Type
;
5554 -------------------------
5555 -- Is_Public_Operation --
5556 -------------------------
5558 function Is_Public_Operation
return Boolean is
5564 while Present
(S
) and then S
/= Pref_Encl_Typ
loop
5565 if Scope
(S
) = Pref_Encl_Typ
then
5566 E
:= First_Entity
(Pref_Encl_Typ
);
5568 and then E
/= First_Private_Entity
(Pref_Encl_Typ
)
5582 end Is_Public_Operation
;
5584 -- Start of processing for Check_Unprotected_Access
5587 if Nkind
(Expr
) = N_Attribute_Reference
5588 and then Attribute_Name
(Expr
) = Name_Unchecked_Access
5590 Cont_Encl_Typ
:= Enclosing_Protected_Type
(Context
);
5591 Pref_Encl_Typ
:= Enclosing_Protected_Type
(Prefix
(Expr
));
5593 -- Check whether we are trying to export a protected component to a
5594 -- context with an equal or lower access level.
5596 if Present
(Pref_Encl_Typ
)
5597 and then No
(Cont_Encl_Typ
)
5598 and then Is_Public_Operation
5599 and then Scope_Depth
(Pref_Encl_Typ
)
5600 >= Static_Accessibility_Level
5601 (Context
, Object_Decl_Level
)
5604 ("??possible unprotected access to protected data", Expr
);
5607 end Check_Unprotected_Access
;
5609 ------------------------------
5610 -- Check_Unused_Body_States --
5611 ------------------------------
5613 procedure Check_Unused_Body_States
(Body_Id
: Entity_Id
) is
5614 procedure Process_Refinement_Clause
5617 -- Inspect all constituents of refinement clause Clause and remove any
5618 -- matches from body state list States.
5620 procedure Report_Unused_Body_States
(States
: Elist_Id
);
5621 -- Emit errors for each abstract state or object found in list States
5623 -------------------------------
5624 -- Process_Refinement_Clause --
5625 -------------------------------
5627 procedure Process_Refinement_Clause
5631 procedure Process_Constituent
(Constit
: Node_Id
);
5632 -- Remove constituent Constit from body state list States
5634 -------------------------
5635 -- Process_Constituent --
5636 -------------------------
5638 procedure Process_Constituent
(Constit
: Node_Id
) is
5639 Constit_Id
: Entity_Id
;
5642 -- Guard against illegal constituents. Only abstract states and
5643 -- objects can appear on the right hand side of a refinement.
5645 if Is_Entity_Name
(Constit
) then
5646 Constit_Id
:= Entity_Of
(Constit
);
5648 if Present
(Constit_Id
)
5649 and then Ekind
(Constit_Id
) in
5650 E_Abstract_State | E_Constant | E_Variable
5652 Remove
(States
, Constit_Id
);
5655 end Process_Constituent
;
5661 -- Start of processing for Process_Refinement_Clause
5664 if Nkind
(Clause
) = N_Component_Association
then
5665 Constit
:= Expression
(Clause
);
5667 -- Multiple constituents appear as an aggregate
5669 if Nkind
(Constit
) = N_Aggregate
then
5670 Constit
:= First
(Expressions
(Constit
));
5671 while Present
(Constit
) loop
5672 Process_Constituent
(Constit
);
5676 -- Various forms of a single constituent
5679 Process_Constituent
(Constit
);
5682 end Process_Refinement_Clause
;
5684 -------------------------------
5685 -- Report_Unused_Body_States --
5686 -------------------------------
5688 procedure Report_Unused_Body_States
(States
: Elist_Id
) is
5689 Posted
: Boolean := False;
5690 State_Elmt
: Elmt_Id
;
5691 State_Id
: Entity_Id
;
5694 if Present
(States
) then
5695 State_Elmt
:= First_Elmt
(States
);
5696 while Present
(State_Elmt
) loop
5697 State_Id
:= Node
(State_Elmt
);
5699 -- Constants are part of the hidden state of a package, but the
5700 -- compiler cannot determine whether they have variable input
5701 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a
5702 -- hidden state. Do not emit an error when a constant does not
5703 -- participate in a state refinement, even though it acts as a
5706 if Ekind
(State_Id
) = E_Constant
then
5709 -- Overlays do not contribute to package state
5711 elsif Ekind
(State_Id
) = E_Variable
5712 and then Present
(Ultimate_Overlaid_Entity
(State_Id
))
5716 -- Generate an error message of the form:
5718 -- body of package ... has unused hidden states
5719 -- abstract state ... defined at ...
5720 -- variable ... defined at ...
5726 ("body of package & has unused hidden states", Body_Id
);
5729 Error_Msg_Sloc
:= Sloc
(State_Id
);
5731 if Ekind
(State_Id
) = E_Abstract_State
then
5733 ("\abstract state & defined #", Body_Id
, State_Id
);
5736 SPARK_Msg_NE
("\variable & defined #", Body_Id
, State_Id
);
5740 Next_Elmt
(State_Elmt
);
5743 end Report_Unused_Body_States
;
5747 Prag
: constant Node_Id
:= Get_Pragma
(Body_Id
, Pragma_Refined_State
);
5748 Spec_Id
: constant Entity_Id
:= Spec_Entity
(Body_Id
);
5752 -- Start of processing for Check_Unused_Body_States
5755 -- Inspect the clauses of pragma Refined_State and determine whether all
5756 -- visible states declared within the package body participate in the
5759 if Present
(Prag
) then
5760 Clause
:= Expression
(Get_Argument
(Prag
, Spec_Id
));
5761 States
:= Collect_Body_States
(Body_Id
);
5763 -- Multiple non-null state refinements appear as an aggregate
5765 if Nkind
(Clause
) = N_Aggregate
then
5766 Clause
:= First
(Component_Associations
(Clause
));
5767 while Present
(Clause
) loop
5768 Process_Refinement_Clause
(Clause
, States
);
5772 -- Various forms of a single state refinement
5775 Process_Refinement_Clause
(Clause
, States
);
5778 -- Ensure that all abstract states and objects declared in the
5779 -- package body state space are utilized as constituents.
5781 Report_Unused_Body_States
(States
);
5783 end Check_Unused_Body_States
;
5785 ------------------------------------
5786 -- Check_Volatility_Compatibility --
5787 ------------------------------------
5789 procedure Check_Volatility_Compatibility
5790 (Id1
, Id2
: Entity_Id
;
5791 Description_1
, Description_2
: String;
5792 Srcpos_Bearer
: Node_Id
) is
5795 if SPARK_Mode
/= On
then
5800 AR1
: constant Boolean := Async_Readers_Enabled
(Id1
);
5801 AW1
: constant Boolean := Async_Writers_Enabled
(Id1
);
5802 ER1
: constant Boolean := Effective_Reads_Enabled
(Id1
);
5803 EW1
: constant Boolean := Effective_Writes_Enabled
(Id1
);
5804 AR2
: constant Boolean := Async_Readers_Enabled
(Id2
);
5805 AW2
: constant Boolean := Async_Writers_Enabled
(Id2
);
5806 ER2
: constant Boolean := Effective_Reads_Enabled
(Id2
);
5807 EW2
: constant Boolean := Effective_Writes_Enabled
(Id2
);
5809 AR_Check_Failed
: constant Boolean := AR1
and not AR2
;
5810 AW_Check_Failed
: constant Boolean := AW1
and not AW2
;
5811 ER_Check_Failed
: constant Boolean := ER1
and not ER2
;
5812 EW_Check_Failed
: constant Boolean := EW1
and not EW2
;
5814 package Failure_Description
is
5815 procedure Note_If_Failure
5816 (Failed
: Boolean; Aspect_Name
: String);
5817 -- If Failed is False, do nothing.
5818 -- If Failed is True, add Aspect_Name to the failure description.
5820 function Failure_Text
return String;
5821 -- returns accumulated list of failing aspects
5822 end Failure_Description
;
5824 package body Failure_Description
is
5825 Description_Buffer
: Bounded_String
;
5827 ---------------------
5828 -- Note_If_Failure --
5829 ---------------------
5831 procedure Note_If_Failure
5832 (Failed
: Boolean; Aspect_Name
: String) is
5835 if Description_Buffer
.Length
/= 0 then
5836 Append
(Description_Buffer
, ", ");
5838 Append
(Description_Buffer
, Aspect_Name
);
5840 end Note_If_Failure
;
5846 function Failure_Text
return String is
5848 return +Description_Buffer
;
5850 end Failure_Description
;
5852 use Failure_Description
;
5859 Note_If_Failure
(AR_Check_Failed
, "Async_Readers");
5860 Note_If_Failure
(AW_Check_Failed
, "Async_Writers");
5861 Note_If_Failure
(ER_Check_Failed
, "Effective_Reads");
5862 Note_If_Failure
(EW_Check_Failed
, "Effective_Writes");
5868 & " are not compatible with respect to volatility due to "
5873 end Check_Volatility_Compatibility
;
5879 function Choice_List
(N
: Node_Id
) return List_Id
is
5881 if Nkind
(N
) = N_Iterated_Component_Association
then
5882 return Discrete_Choices
(N
);
5888 ---------------------
5889 -- Class_Condition --
5890 ---------------------
5892 function Class_Condition
5893 (Kind
: Condition_Kind
;
5894 Subp
: Entity_Id
) return Node_Id
is
5898 when Class_Postcondition
=>
5899 return Class_Postconditions
(Subp
);
5901 when Class_Precondition
=>
5902 return Class_Preconditions
(Subp
);
5904 when Ignored_Class_Postcondition
=>
5905 return Ignored_Class_Postconditions
(Subp
);
5907 when Ignored_Class_Precondition
=>
5908 return Ignored_Class_Preconditions
(Subp
);
5910 end Class_Condition
;
5912 -------------------------
5913 -- Collect_Body_States --
5914 -------------------------
5916 function Collect_Body_States
(Body_Id
: Entity_Id
) return Elist_Id
is
5917 function Is_Visible_Object
(Obj_Id
: Entity_Id
) return Boolean;
5918 -- Determine whether object Obj_Id is a suitable visible state of a
5921 procedure Collect_Visible_States
5922 (Pack_Id
: Entity_Id
;
5923 States
: in out Elist_Id
);
5924 -- Gather the entities of all abstract states and objects declared in
5925 -- the visible state space of package Pack_Id.
5927 ----------------------------
5928 -- Collect_Visible_States --
5929 ----------------------------
5931 procedure Collect_Visible_States
5932 (Pack_Id
: Entity_Id
;
5933 States
: in out Elist_Id
)
5935 Item_Id
: Entity_Id
;
5938 -- Traverse the entity chain of the package and inspect all visible
5941 Item_Id
:= First_Entity
(Pack_Id
);
5942 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
5944 -- Do not consider internally generated items as those cannot be
5945 -- named and participate in refinement.
5947 if not Comes_From_Source
(Item_Id
) then
5950 elsif Ekind
(Item_Id
) = E_Abstract_State
then
5951 Append_New_Elmt
(Item_Id
, States
);
5953 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
5954 and then Is_Visible_Object
(Item_Id
)
5956 Append_New_Elmt
(Item_Id
, States
);
5958 -- Recursively gather the visible states of a nested package
5960 elsif Ekind
(Item_Id
) = E_Package
then
5961 Collect_Visible_States
(Item_Id
, States
);
5964 Next_Entity
(Item_Id
);
5966 end Collect_Visible_States
;
5968 -----------------------
5969 -- Is_Visible_Object --
5970 -----------------------
5972 function Is_Visible_Object
(Obj_Id
: Entity_Id
) return Boolean is
5974 -- Objects that map generic formals to their actuals are not visible
5975 -- from outside the generic instantiation.
5977 if Present
(Corresponding_Generic_Association
5978 (Declaration_Node
(Obj_Id
)))
5982 -- Constituents of a single protected/task type act as components of
5983 -- the type and are not visible from outside the type.
5985 elsif Ekind
(Obj_Id
) = E_Variable
5986 and then Present
(Encapsulating_State
(Obj_Id
))
5987 and then Is_Single_Concurrent_Object
(Encapsulating_State
(Obj_Id
))
5994 end Is_Visible_Object
;
5998 Body_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Body_Id
);
6000 Item_Id
: Entity_Id
;
6001 States
: Elist_Id
:= No_Elist
;
6003 -- Start of processing for Collect_Body_States
6006 -- Inspect the declarations of the body looking for source objects,
6007 -- packages and package instantiations. Note that even though this
6008 -- processing is very similar to Collect_Visible_States, a package
6009 -- body does not have a First/Next_Entity list.
6011 Decl
:= First
(Declarations
(Body_Decl
));
6012 while Present
(Decl
) loop
6014 -- Capture source objects as internally generated temporaries cannot
6015 -- be named and participate in refinement.
6017 if Nkind
(Decl
) = N_Object_Declaration
then
6018 Item_Id
:= Defining_Entity
(Decl
);
6020 if Comes_From_Source
(Item_Id
)
6021 and then Is_Visible_Object
(Item_Id
)
6023 Append_New_Elmt
(Item_Id
, States
);
6026 -- Capture the visible abstract states and objects of a source
6027 -- package [instantiation].
6029 elsif Nkind
(Decl
) = N_Package_Declaration
then
6030 Item_Id
:= Defining_Entity
(Decl
);
6032 if Comes_From_Source
(Item_Id
) then
6033 Collect_Visible_States
(Item_Id
, States
);
6041 end Collect_Body_States
;
6043 ------------------------
6044 -- Collect_Interfaces --
6045 ------------------------
6047 procedure Collect_Interfaces
6049 Ifaces_List
: out Elist_Id
;
6050 Exclude_Parents
: Boolean := False;
6051 Use_Full_View
: Boolean := True)
6053 procedure Collect
(Typ
: Entity_Id
);
6054 -- Subsidiary subprogram used to traverse the whole list
6055 -- of directly and indirectly implemented interfaces
6061 procedure Collect
(Typ
: Entity_Id
) is
6062 Ancestor
: Entity_Id
;
6070 -- Handle private types and subtypes
6073 and then Is_Private_Type
(Typ
)
6074 and then Present
(Full_View
(Typ
))
6076 Full_T
:= Full_View
(Typ
);
6078 if Ekind
(Full_T
) = E_Record_Subtype
then
6079 Full_T
:= Etype
(Typ
);
6081 if Present
(Full_View
(Full_T
)) then
6082 Full_T
:= Full_View
(Full_T
);
6087 -- Include the ancestor if we are generating the whole list of
6088 -- abstract interfaces.
6090 if Etype
(Full_T
) /= Typ
6092 -- Protect the frontend against wrong sources. For example:
6095 -- type A is tagged null record;
6096 -- type B is new A with private;
6097 -- type C is new A with private;
6099 -- type B is new C with null record;
6100 -- type C is new B with null record;
6103 and then Etype
(Full_T
) /= T
6105 Ancestor
:= Etype
(Full_T
);
6108 if Is_Interface
(Ancestor
) and then not Exclude_Parents
then
6109 Append_Unique_Elmt
(Ancestor
, Ifaces_List
);
6113 -- Traverse the graph of ancestor interfaces
6115 Id
:= First
(Abstract_Interface_List
(Full_T
));
6116 while Present
(Id
) loop
6117 Iface
:= Etype
(Id
);
6119 -- Protect against wrong uses. For example:
6120 -- type I is interface;
6121 -- type O is tagged null record;
6122 -- type Wrong is new I and O with null record; -- ERROR
6124 if Is_Interface
(Iface
) then
6126 and then Etype
(T
) /= T
6127 and then Interface_Present_In_Ancestor
(Etype
(T
), Iface
)
6132 Append_Unique_Elmt
(Iface
, Ifaces_List
);
6140 -- Start of processing for Collect_Interfaces
6143 pragma Assert
(Is_Tagged_Type
(T
) or else Is_Concurrent_Type
(T
));
6144 Ifaces_List
:= New_Elmt_List
;
6146 end Collect_Interfaces
;
6148 ----------------------------------
6149 -- Collect_Interface_Components --
6150 ----------------------------------
6152 procedure Collect_Interface_Components
6153 (Tagged_Type
: Entity_Id
;
6154 Components_List
: out Elist_Id
)
6156 procedure Collect
(Typ
: Entity_Id
);
6157 -- Subsidiary subprogram used to climb to the parents
6163 procedure Collect
(Typ
: Entity_Id
) is
6164 Tag_Comp
: Entity_Id
;
6165 Parent_Typ
: Entity_Id
;
6168 -- Handle private types
6170 if Present
(Full_View
(Etype
(Typ
))) then
6171 Parent_Typ
:= Full_View
(Etype
(Typ
));
6173 Parent_Typ
:= Etype
(Typ
);
6176 if Parent_Typ
/= Typ
6178 -- Protect the frontend against wrong sources. For example:
6181 -- type A is tagged null record;
6182 -- type B is new A with private;
6183 -- type C is new A with private;
6185 -- type B is new C with null record;
6186 -- type C is new B with null record;
6189 and then Parent_Typ
/= Tagged_Type
6191 Collect
(Parent_Typ
);
6194 -- Collect the components containing tags of secondary dispatch
6197 Tag_Comp
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
6198 while Present
(Tag_Comp
) loop
6199 pragma Assert
(Present
(Related_Type
(Tag_Comp
)));
6200 Append_Elmt
(Tag_Comp
, Components_List
);
6202 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
6206 -- Start of processing for Collect_Interface_Components
6209 pragma Assert
(Ekind
(Tagged_Type
) = E_Record_Type
6210 and then Is_Tagged_Type
(Tagged_Type
));
6212 Components_List
:= New_Elmt_List
;
6213 Collect
(Tagged_Type
);
6214 end Collect_Interface_Components
;
6216 -----------------------------
6217 -- Collect_Interfaces_Info --
6218 -----------------------------
6220 procedure Collect_Interfaces_Info
6222 Ifaces_List
: out Elist_Id
;
6223 Components_List
: out Elist_Id
;
6224 Tags_List
: out Elist_Id
)
6226 Comps_List
: Elist_Id
;
6227 Comp_Elmt
: Elmt_Id
;
6228 Comp_Iface
: Entity_Id
;
6229 Iface_Elmt
: Elmt_Id
;
6232 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
;
6233 -- Search for the secondary tag associated with the interface type
6234 -- Iface that is implemented by T.
6240 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
is
6243 if not Is_CPP_Class
(T
) then
6244 ADT
:= Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
))));
6246 ADT
:= Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
)));
6250 and then Is_Tag
(Node
(ADT
))
6251 and then Related_Type
(Node
(ADT
)) /= Iface
6253 -- Skip secondary dispatch table referencing thunks to user
6254 -- defined primitives covered by this interface.
6256 pragma Assert
(Has_Suffix
(Node
(ADT
), 'P'));
6259 -- Skip secondary dispatch tables of Ada types
6261 if not Is_CPP_Class
(T
) then
6263 -- Skip secondary dispatch table referencing thunks to
6264 -- predefined primitives.
6266 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Y'));
6269 -- Skip secondary dispatch table referencing user-defined
6270 -- primitives covered by this interface.
6272 pragma Assert
(Has_Suffix
(Node
(ADT
), 'D'));
6275 -- Skip secondary dispatch table referencing predefined
6278 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Z'));
6283 pragma Assert
(Is_Tag
(Node
(ADT
)));
6287 -- Start of processing for Collect_Interfaces_Info
6290 Collect_Interfaces
(T
, Ifaces_List
);
6291 Collect_Interface_Components
(T
, Comps_List
);
6293 -- Search for the record component and tag associated with each
6294 -- interface type of T.
6296 Components_List
:= New_Elmt_List
;
6297 Tags_List
:= New_Elmt_List
;
6299 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
6300 while Present
(Iface_Elmt
) loop
6301 Iface
:= Node
(Iface_Elmt
);
6303 -- Associate the primary tag component and the primary dispatch table
6304 -- with all the interfaces that are parents of T
6306 if Is_Ancestor
(Iface
, T
, Use_Full_View
=> True) then
6307 Append_Elmt
(First_Tag_Component
(T
), Components_List
);
6308 Append_Elmt
(Node
(First_Elmt
(Access_Disp_Table
(T
))), Tags_List
);
6310 -- Otherwise search for the tag component and secondary dispatch
6314 Comp_Elmt
:= First_Elmt
(Comps_List
);
6315 while Present
(Comp_Elmt
) loop
6316 Comp_Iface
:= Related_Type
(Node
(Comp_Elmt
));
6318 if Comp_Iface
= Iface
6319 or else Is_Ancestor
(Iface
, Comp_Iface
, Use_Full_View
=> True)
6321 Append_Elmt
(Node
(Comp_Elmt
), Components_List
);
6322 Append_Elmt
(Search_Tag
(Comp_Iface
), Tags_List
);
6326 Next_Elmt
(Comp_Elmt
);
6328 pragma Assert
(Present
(Comp_Elmt
));
6331 Next_Elmt
(Iface_Elmt
);
6333 end Collect_Interfaces_Info
;
6335 ---------------------
6336 -- Collect_Parents --
6337 ---------------------
6339 procedure Collect_Parents
6341 List
: out Elist_Id
;
6342 Use_Full_View
: Boolean := True)
6344 Current_Typ
: Entity_Id
:= T
;
6345 Parent_Typ
: Entity_Id
;
6348 List
:= New_Elmt_List
;
6350 -- No action if the if the type has no parents
6352 if T
= Etype
(T
) then
6357 Parent_Typ
:= Etype
(Current_Typ
);
6359 if Is_Private_Type
(Parent_Typ
)
6360 and then Present
(Full_View
(Parent_Typ
))
6361 and then Use_Full_View
6363 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
6366 Append_Elmt
(Parent_Typ
, List
);
6368 exit when Parent_Typ
= Current_Typ
;
6369 Current_Typ
:= Parent_Typ
;
6371 end Collect_Parents
;
6373 ----------------------------------
6374 -- Collect_Primitive_Operations --
6375 ----------------------------------
6377 function Collect_Primitive_Operations
(T
: Entity_Id
) return Elist_Id
is
6378 B_Type
: constant Entity_Id
:= Base_Type
(T
);
6380 function Match
(E
: Entity_Id
) return Boolean;
6381 -- True if E's base type is B_Type, or E is of an anonymous access type
6382 -- and the base type of its designated type is B_Type.
6388 function Match
(E
: Entity_Id
) return Boolean is
6389 Etyp
: Entity_Id
:= Etype
(E
);
6392 if Ekind
(Etyp
) = E_Anonymous_Access_Type
then
6393 Etyp
:= Designated_Type
(Etyp
);
6396 -- In Ada 2012 a primitive operation may have a formal of an
6397 -- incomplete view of the parent type.
6399 return Base_Type
(Etyp
) = B_Type
6401 (Ada_Version
>= Ada_2012
6402 and then Ekind
(Etyp
) = E_Incomplete_Type
6403 and then Full_View
(Etyp
) = B_Type
);
6408 B_Decl
: constant Node_Id
:= Original_Node
(Parent
(B_Type
));
6409 B_Scope
: Entity_Id
:= Scope
(B_Type
);
6411 Eq_Prims_List
: Elist_Id
:= No_Elist
;
6414 Is_Type_In_Pkg
: Boolean;
6415 Formal_Derived
: Boolean := False;
6418 -- Start of processing for Collect_Primitive_Operations
6421 -- For tagged types, the primitive operations are collected as they
6422 -- are declared, and held in an explicit list which is simply returned.
6424 if Is_Tagged_Type
(B_Type
) then
6425 return Primitive_Operations
(B_Type
);
6427 -- An untagged generic type that is a derived type inherits the
6428 -- primitive operations of its parent type. Other formal types only
6429 -- have predefined operators, which are not explicitly represented.
6431 elsif Is_Generic_Type
(B_Type
) then
6432 if Nkind
(B_Decl
) = N_Formal_Type_Declaration
6433 and then Nkind
(Formal_Type_Definition
(B_Decl
)) =
6434 N_Formal_Derived_Type_Definition
6436 Formal_Derived
:= True;
6438 return New_Elmt_List
;
6442 Op_List
:= New_Elmt_List
;
6444 if B_Scope
= Standard_Standard
then
6445 if B_Type
= Standard_String
then
6446 Append_Elmt
(Standard_Op_Concat
, Op_List
);
6448 elsif B_Type
= Standard_Wide_String
then
6449 Append_Elmt
(Standard_Op_Concatw
, Op_List
);
6455 -- Locate the primitive subprograms of the type
6458 -- The primitive operations appear after the base type, except if the
6459 -- derivation happens within the private part of B_Scope and the type
6460 -- is a private type, in which case both the type and some primitive
6461 -- operations may appear before the base type, and the list of
6462 -- candidates starts after the type.
6464 if In_Open_Scopes
(B_Scope
)
6465 and then Scope
(T
) = B_Scope
6466 and then In_Private_Part
(B_Scope
)
6468 Id
:= Next_Entity
(T
);
6470 -- In Ada 2012, If the type has an incomplete partial view, there may
6471 -- be primitive operations declared before the full view, so we need
6472 -- to start scanning from the incomplete view, which is earlier on
6473 -- the entity chain.
6475 elsif Nkind
(Parent
(B_Type
)) = N_Full_Type_Declaration
6476 and then Present
(Incomplete_View
(Parent
(B_Type
)))
6478 Id
:= Incomplete_View
(Parent
(B_Type
));
6480 -- If T is a derived from a type with an incomplete view declared
6481 -- elsewhere, that incomplete view is irrelevant, we want the
6482 -- operations in the scope of T.
6484 if Scope
(Id
) /= Scope
(B_Type
) then
6485 Id
:= Next_Entity
(B_Type
);
6489 Id
:= Next_Entity
(B_Type
);
6492 -- Set flag if this is a type in a package spec
6495 Is_Package_Or_Generic_Package
(B_Scope
)
6497 Parent_Kind
(Declaration_Node
(First_Subtype
(T
))) /=
6500 while Present
(Id
) loop
6502 -- Test whether the result type or any of the parameter types of
6503 -- each subprogram following the type match that type when the
6504 -- type is declared in a package spec, is a derived type, or the
6505 -- subprogram is marked as primitive. (The Is_Primitive test is
6506 -- needed to find primitives of nonderived types in declarative
6507 -- parts that happen to override the predefined "=" operator.)
6509 -- Note that generic formal subprograms are not considered to be
6510 -- primitive operations and thus are never inherited.
6512 if Is_Overloadable
(Id
)
6513 and then (Is_Type_In_Pkg
6514 or else Is_Derived_Type
(B_Type
)
6515 or else Is_Primitive
(Id
))
6516 and then Parent_Kind
(Parent
(Id
))
6517 not in N_Formal_Subprogram_Declaration
6525 Formal
:= First_Formal
(Id
);
6526 while Present
(Formal
) loop
6527 if Match
(Formal
) then
6532 Next_Formal
(Formal
);
6536 -- For a formal derived type, the only primitives are the ones
6537 -- inherited from the parent type. Operations appearing in the
6538 -- package declaration are not primitive for it.
6541 and then (not Formal_Derived
or else Present
(Alias
(Id
)))
6543 -- In the special case of an equality operator aliased to
6544 -- an overriding dispatching equality belonging to the same
6545 -- type, we don't include it in the list of primitives.
6546 -- This avoids inheriting multiple equality operators when
6547 -- deriving from untagged private types whose full type is
6548 -- tagged, which can otherwise cause ambiguities. Note that
6549 -- this should only happen for this kind of untagged parent
6550 -- type, since normally dispatching operations are inherited
6551 -- using the type's Primitive_Operations list.
6553 if Chars
(Id
) = Name_Op_Eq
6554 and then Is_Dispatching_Operation
(Id
)
6555 and then Present
(Alias
(Id
))
6556 and then Present
(Overridden_Operation
(Alias
(Id
)))
6557 and then Base_Type
(Etype
(First_Entity
(Id
))) =
6558 Base_Type
(Etype
(First_Entity
(Alias
(Id
))))
6562 -- Include the subprogram in the list of primitives
6565 Append_Elmt
(Id
, Op_List
);
6567 -- Save collected equality primitives for later filtering
6568 -- (if we are processing a private type for which we can
6569 -- collect several candidates).
6571 if Inherits_From_Tagged_Full_View
(T
)
6572 and then Chars
(Id
) = Name_Op_Eq
6573 and then Etype
(First_Formal
(Id
)) =
6574 Etype
(Next_Formal
(First_Formal
(Id
)))
6576 Append_New_Elmt
(Id
, Eq_Prims_List
);
6584 -- For a type declared in System, some of its operations may
6585 -- appear in the target-specific extension to System.
6588 and then Is_RTU
(B_Scope
, System
)
6589 and then Present_System_Aux
6591 B_Scope
:= System_Aux_Id
;
6592 Id
:= First_Entity
(System_Aux_Id
);
6596 -- Filter collected equality primitives
6598 if Inherits_From_Tagged_Full_View
(T
)
6599 and then Present
(Eq_Prims_List
)
6602 First
: constant Elmt_Id
:= First_Elmt
(Eq_Prims_List
);
6606 pragma Assert
(No
(Next_Elmt
(First
))
6607 or else No
(Next_Elmt
(Next_Elmt
(First
))));
6609 -- No action needed if we have collected a single equality
6612 if Present
(Next_Elmt
(First
)) then
6613 Second
:= Next_Elmt
(First
);
6615 if Is_Dispatching_Operation
6616 (Ultimate_Alias
(Node
(First
)))
6618 Remove
(Op_List
, Node
(First
));
6620 elsif Is_Dispatching_Operation
6621 (Ultimate_Alias
(Node
(Second
)))
6623 Remove
(Op_List
, Node
(Second
));
6626 raise Program_Error
;
6634 end Collect_Primitive_Operations
;
6636 -----------------------------------
6637 -- Compile_Time_Constraint_Error --
6638 -----------------------------------
6640 function Compile_Time_Constraint_Error
6643 Ent
: Entity_Id
:= Empty
;
6644 Loc
: Source_Ptr
:= No_Location
;
6645 Warn
: Boolean := False;
6646 Extra_Msg
: String := "") return Node_Id
6648 Msgc
: String (1 .. Msg
'Length + 3);
6649 -- Copy of message, with room for possible ?? or << and ! at end
6655 -- Start of processing for Compile_Time_Constraint_Error
6658 -- If this is a warning, convert it into an error if we are in code
6659 -- subject to SPARK_Mode being set On, unless Warn is True to force a
6660 -- warning. The rationale is that a compile-time constraint error should
6661 -- lead to an error instead of a warning when SPARK_Mode is On, but in
6662 -- a few cases we prefer to issue a warning and generate both a suitable
6663 -- run-time error in GNAT and a suitable check message in GNATprove.
6664 -- Those cases are those that likely correspond to deactivated SPARK
6665 -- code, so that this kind of code can be compiled and analyzed instead
6666 -- of being rejected.
6668 Error_Msg_Warn
:= Warn
or SPARK_Mode
/= On
;
6670 -- A static constraint error in an instance body is not a fatal error.
6671 -- We choose to inhibit the message altogether, because there is no
6672 -- obvious node (for now) on which to post it. On the other hand the
6673 -- offending node must be replaced with a constraint_error in any case.
6675 -- No messages are generated if we already posted an error on this node
6677 if not Error_Posted
(N
) then
6678 if Loc
/= No_Location
then
6684 -- Copy message to Msgc, converting any ? in the message into <
6685 -- instead, so that we have an error in GNATprove mode.
6689 for J
in 1 .. Msgl
loop
6690 if Msg
(J
) = '?' and then (J
= 1 or else Msg
(J
- 1) /= ''') then
6693 Msgc
(J
) := Msg
(J
);
6697 -- Message is a warning, even in Ada 95 case
6699 if Msg
(Msg
'Last) = '?' or else Msg
(Msg
'Last) = '<' then
6702 -- In Ada 83, all messages are warnings. In the private part and the
6703 -- body of an instance, constraint_checks are only warnings. We also
6704 -- make this a warning if the Warn parameter is set.
6707 or else (Ada_Version
= Ada_83
and then Comes_From_Source
(N
))
6708 or else In_Instance_Not_Visible
6716 -- Otherwise we have a real error message (Ada 95 static case) and we
6717 -- make this an unconditional message. Note that in the warning case
6718 -- we do not make the message unconditional, it seems reasonable to
6719 -- delete messages like this (about exceptions that will be raised)
6728 -- One more test, skip the warning if the related expression is
6729 -- statically unevaluated, since we don't want to warn about what
6730 -- will happen when something is evaluated if it never will be
6733 -- Suppress error reporting when checking that the expression of a
6734 -- static expression function is a potentially static expression,
6735 -- because we don't want additional errors being reported during the
6736 -- preanalysis of the expression (see Analyze_Expression_Function).
6738 if not Is_Statically_Unevaluated
(N
)
6739 and then not Checking_Potentially_Static_Expression
6741 if Present
(Ent
) then
6742 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Ent
, Eloc
);
6744 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Etype
(N
), Eloc
);
6747 -- Emit any extra message as a continuation
6749 if Extra_Msg
/= "" then
6750 Error_Msg_N
('\' & Extra_Msg
, N
);
6755 -- Check whether the context is an Init_Proc
6757 if Inside_Init_Proc
then
6759 Init_Proc_Type
: constant Entity_Id
:=
6760 Etype
(First_Formal
(Current_Scope_No_Loops
));
6762 Conc_Typ
: constant Entity_Id
:=
6763 (if Present
(Init_Proc_Type
)
6764 and then Init_Proc_Type
in E_Record_Type_Id
6765 then Corresponding_Concurrent_Type
(Init_Proc_Type
)
6769 -- Don't complain if the corresponding concurrent type
6770 -- doesn't come from source (i.e. a single task/protected
6773 if Present
(Conc_Typ
)
6774 and then not Comes_From_Source
(Conc_Typ
)
6776 Error_Msg
("\& [<<", Eloc
, N
);
6779 if GNATprove_Mode
then
6781 ("\Constraint_Error would have been raised"
6782 & " for objects of this type", Eloc
, N
);
6785 ("\Constraint_Error will be raised"
6786 & " for objects of this type??", Eloc
, N
);
6792 Error_Msg
("\Constraint_Error [<<", Eloc
, N
);
6796 Error_Msg
("\static expression fails Constraint_Check", Eloc
);
6797 Set_Error_Posted
(N
);
6803 end Compile_Time_Constraint_Error
;
6805 ----------------------------
6806 -- Compute_Returns_By_Ref --
6807 ----------------------------
6809 procedure Compute_Returns_By_Ref
(Func
: Entity_Id
) is
6810 Typ
: constant Entity_Id
:= Etype
(Func
);
6813 if Is_Limited_View
(Typ
) then
6814 Set_Returns_By_Ref
(Func
);
6816 -- For class-wide types and types which both need finalization and are
6817 -- returned on the secondary stack, the secondary stack allocation is
6818 -- done by the front end, see Expand_Simple_Function_Return.
6820 elsif Returns_On_Secondary_Stack
(Typ
)
6821 and then CW_Or_Needs_Finalization
(Underlying_Type
(Typ
))
6823 Set_Returns_By_Ref
(Func
);
6825 end Compute_Returns_By_Ref
;
6827 --------------------------------
6828 -- Collect_Types_In_Hierarchy --
6829 --------------------------------
6831 function Collect_Types_In_Hierarchy
6833 Examine_Components
: Boolean := False) return Elist_Id
6837 procedure Process_Type
(Typ
: Entity_Id
);
6838 -- Collect type Typ if it satisfies function Predicate. Do so for its
6839 -- parent type, base type, progenitor types, and any component types.
6845 procedure Process_Type
(Typ
: Entity_Id
) is
6847 Iface_Elmt
: Elmt_Id
;
6850 if not Is_Type
(Typ
) or else Error_Posted
(Typ
) then
6854 -- Collect the current type if it satisfies the predicate
6856 if Predicate
(Typ
) then
6857 Append_Elmt
(Typ
, Results
);
6860 -- Process component types
6862 if Examine_Components
then
6864 -- Examine components and discriminants
6866 if Is_Concurrent_Type
(Typ
)
6867 or else Is_Incomplete_Or_Private_Type
(Typ
)
6868 or else Is_Record_Type
(Typ
)
6869 or else Has_Discriminants
(Typ
)
6871 Comp
:= First_Component_Or_Discriminant
(Typ
);
6873 while Present
(Comp
) loop
6874 Process_Type
(Etype
(Comp
));
6876 Next_Component_Or_Discriminant
(Comp
);
6879 -- Examine array components
6881 elsif Ekind
(Typ
) = E_Array_Type
then
6882 Process_Type
(Component_Type
(Typ
));
6886 -- Examine parent type
6888 if Etype
(Typ
) /= Typ
then
6889 Process_Type
(Etype
(Typ
));
6892 -- Examine base type
6894 if Base_Type
(Typ
) /= Typ
then
6895 Process_Type
(Base_Type
(Typ
));
6898 -- Examine interfaces
6900 if Is_Record_Type
(Typ
)
6901 and then Present
(Interfaces
(Typ
))
6903 Iface_Elmt
:= First_Elmt
(Interfaces
(Typ
));
6904 while Present
(Iface_Elmt
) loop
6905 Process_Type
(Node
(Iface_Elmt
));
6907 Next_Elmt
(Iface_Elmt
);
6912 -- Start of processing for Collect_Types_In_Hierarchy
6915 Results
:= New_Elmt_List
;
6918 end Collect_Types_In_Hierarchy
;
6920 -----------------------
6921 -- Conditional_Delay --
6922 -----------------------
6924 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
6926 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
6927 Set_Has_Delayed_Freeze
(New_Ent
);
6929 end Conditional_Delay
;
6931 -------------------------
6932 -- Copy_Component_List --
6933 -------------------------
6935 function Copy_Component_List
6937 Loc
: Source_Ptr
) return List_Id
6940 Comps
: constant List_Id
:= New_List
;
6943 Comp
:= First_Component
(Underlying_Type
(R_Typ
));
6944 while Present
(Comp
) loop
6945 if Comes_From_Source
(Comp
) then
6947 Comp_Decl
: constant Node_Id
:= Declaration_Node
(Comp
);
6950 Make_Component_Declaration
(Loc
,
6951 Defining_Identifier
=>
6952 Make_Defining_Identifier
(Loc
, Chars
(Comp
)),
6953 Component_Definition
=>
6955 (Component_Definition
(Comp_Decl
), New_Sloc
=> Loc
)));
6959 Next_Component
(Comp
);
6963 end Copy_Component_List
;
6965 -------------------------
6966 -- Copy_Parameter_List --
6967 -------------------------
6969 function Copy_Parameter_List
(Subp_Id
: Entity_Id
) return List_Id
is
6970 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
6972 Formal
: Entity_Id
:= First_Formal
(Subp_Id
);
6975 if Present
(Formal
) then
6977 while Present
(Formal
) loop
6979 Make_Parameter_Specification
(Loc
,
6980 Defining_Identifier
=>
6981 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
6982 In_Present
=> In_Present
(Parent
(Formal
)),
6983 Out_Present
=> Out_Present
(Parent
(Formal
)),
6985 New_Occurrence_Of
(Etype
(Formal
), Loc
),
6987 New_Copy_Tree
(Expression
(Parent
(Formal
)))));
6989 Next_Formal
(Formal
);
6996 end Copy_Parameter_List
;
6998 ----------------------------
6999 -- Copy_SPARK_Mode_Aspect --
7000 ----------------------------
7002 procedure Copy_SPARK_Mode_Aspect
(From
: Node_Id
; To
: Node_Id
) is
7003 pragma Assert
(not Has_Aspects
(To
));
7007 if Has_Aspects
(From
) then
7008 Asp
:= Find_Aspect
(Defining_Entity
(From
), Aspect_SPARK_Mode
);
7010 if Present
(Asp
) then
7011 Set_Aspect_Specifications
(To
, New_List
(New_Copy_Tree
(Asp
)));
7012 Set_Has_Aspects
(To
, True);
7015 end Copy_SPARK_Mode_Aspect
;
7017 --------------------------
7018 -- Copy_Subprogram_Spec --
7019 --------------------------
7021 function Copy_Subprogram_Spec
7023 New_Sloc
: Source_Ptr
:= No_Location
) return Node_Id
7026 Formal_Spec
: Node_Id
;
7030 -- The structure of the original tree must be replicated without any
7031 -- alterations. Use New_Copy_Tree for this purpose.
7033 Result
:= New_Copy_Tree
(Spec
, New_Sloc
=> New_Sloc
);
7035 -- However, the spec of a null procedure carries the corresponding null
7036 -- statement of the body (created by the parser), and this cannot be
7037 -- shared with the new subprogram spec.
7039 if Nkind
(Result
) = N_Procedure_Specification
then
7040 Set_Null_Statement
(Result
, Empty
);
7043 -- Create a new entity for the defining unit name
7045 Def_Id
:= Defining_Unit_Name
(Result
);
7046 Set_Defining_Unit_Name
(Result
,
7047 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
7049 -- Create new entities for the formal parameters
7051 if Present
(Parameter_Specifications
(Result
)) then
7052 Formal_Spec
:= First
(Parameter_Specifications
(Result
));
7053 while Present
(Formal_Spec
) loop
7054 Def_Id
:= Defining_Identifier
(Formal_Spec
);
7055 Set_Defining_Identifier
(Formal_Spec
,
7056 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
7063 end Copy_Subprogram_Spec
;
7065 --------------------------------
7066 -- Corresponding_Generic_Type --
7067 --------------------------------
7069 function Corresponding_Generic_Type
(T
: Entity_Id
) return Entity_Id
is
7075 if not Is_Generic_Actual_Type
(T
) then
7078 -- If the actual is the actual of an enclosing instance, resolution
7079 -- was correct in the generic.
7081 elsif Nkind
(Parent
(T
)) = N_Subtype_Declaration
7082 and then Is_Entity_Name
(Subtype_Indication
(Parent
(T
)))
7084 Is_Generic_Actual_Type
(Entity
(Subtype_Indication
(Parent
(T
))))
7091 if Is_Wrapper_Package
(Inst
) then
7092 Inst
:= Related_Instance
(Inst
);
7097 (Specification
(Unit_Declaration_Node
(Inst
)));
7099 -- Generic actual has the same name as the corresponding formal
7101 Typ
:= First_Entity
(Gen
);
7102 while Present
(Typ
) loop
7103 if Chars
(Typ
) = Chars
(T
) then
7112 end Corresponding_Generic_Type
;
7114 --------------------------------
7115 -- Corresponding_Primitive_Op --
7116 --------------------------------
7118 function Corresponding_Primitive_Op
7119 (Ancestor_Op
: Entity_Id
;
7120 Descendant_Type
: Entity_Id
) return Entity_Id
7122 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Ancestor_Op
);
7127 pragma Assert
(Is_Dispatching_Operation
(Ancestor_Op
));
7128 pragma Assert
(Is_Ancestor
(Typ
, Descendant_Type
)
7129 or else Is_Progenitor
(Typ
, Descendant_Type
));
7131 Elmt
:= First_Elmt
(Primitive_Operations
(Descendant_Type
));
7133 while Present
(Elmt
) loop
7134 Subp
:= Node
(Elmt
);
7136 -- For regular primitives we only need to traverse the chain of
7137 -- ancestors when the name matches the name of Ancestor_Op, but
7138 -- for predefined dispatching operations we cannot rely on the
7139 -- name of the primitive to identify a candidate since their name
7140 -- is internally built adding a suffix to the name of the tagged
7143 if Chars
(Subp
) = Chars
(Ancestor_Op
)
7144 or else Is_Predefined_Dispatching_Operation
(Subp
)
7146 -- Handle case where Ancestor_Op is a primitive of a progenitor.
7147 -- We rely on internal entities that map interface primitives:
7148 -- their attribute Interface_Alias references the interface
7149 -- primitive, and their Alias attribute references the primitive
7150 -- of Descendant_Type implementing that interface primitive.
7152 if Present
(Interface_Alias
(Subp
)) then
7153 if Interface_Alias
(Subp
) = Ancestor_Op
then
7154 return Alias
(Subp
);
7157 -- Traverse the chain of ancestors searching for Ancestor_Op.
7158 -- Overridden primitives have attribute Overridden_Operation;
7159 -- inherited primitives have attribute Alias.
7164 while Present
(Overridden_Operation
(Prim
))
7165 or else Present
(Alias
(Prim
))
7167 if Present
(Overridden_Operation
(Prim
)) then
7168 Prim
:= Overridden_Operation
(Prim
);
7170 Prim
:= Alias
(Prim
);
7173 if Prim
= Ancestor_Op
then
7183 pragma Assert
(False);
7185 end Corresponding_Primitive_Op
;
7187 --------------------
7188 -- Current_Entity --
7189 --------------------
7191 -- The currently visible definition for a given identifier is the
7192 -- one most chained at the start of the visibility chain, i.e. the
7193 -- one that is referenced by the Node_Id value of the name of the
7194 -- given identifier.
7196 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
7198 return Get_Name_Entity_Id
(Chars
(N
));
7201 -----------------------------
7202 -- Current_Entity_In_Scope --
7203 -----------------------------
7205 function Current_Entity_In_Scope
(N
: Name_Id
) return Entity_Id
is
7206 CS
: constant Entity_Id
:= Current_Scope
;
7211 E
:= Get_Name_Entity_Id
(N
);
7216 elsif Scope_Is_Transient
then
7217 while Present
(E
) loop
7218 exit when Scope
(E
) = CS
or else Scope
(E
) = Scope
(CS
);
7224 while Present
(E
) loop
7225 exit when Scope
(E
) = CS
;
7232 end Current_Entity_In_Scope
;
7234 -----------------------------
7235 -- Current_Entity_In_Scope --
7236 -----------------------------
7238 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
7240 return Current_Entity_In_Scope
(Chars
(N
));
7241 end Current_Entity_In_Scope
;
7247 function Current_Scope
return Entity_Id
is
7249 if Scope_Stack
.Last
= -1 then
7250 return Standard_Standard
;
7253 C
: constant Entity_Id
:=
7254 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
7259 return Standard_Standard
;
7265 ----------------------------
7266 -- Current_Scope_No_Loops --
7267 ----------------------------
7269 function Current_Scope_No_Loops
return Entity_Id
is
7273 -- Examine the scope stack starting from the current scope and skip any
7274 -- internally generated loops.
7277 while Present
(S
) and then S
/= Standard_Standard
loop
7278 if Ekind
(S
) = E_Loop
and then not Comes_From_Source
(S
) then
7286 end Current_Scope_No_Loops
;
7288 ------------------------
7289 -- Current_Subprogram --
7290 ------------------------
7292 function Current_Subprogram
return Entity_Id
is
7293 Scop
: constant Entity_Id
:= Current_Scope
;
7295 if Is_Subprogram_Or_Generic_Subprogram
(Scop
) then
7298 return Enclosing_Subprogram
(Scop
);
7300 end Current_Subprogram
;
7302 ------------------------------
7303 -- CW_Or_Needs_Finalization --
7304 ------------------------------
7306 function CW_Or_Needs_Finalization
(Typ
: Entity_Id
) return Boolean is
7308 return Is_Class_Wide_Type
(Typ
) or else Needs_Finalization
(Typ
);
7309 end CW_Or_Needs_Finalization
;
7311 -------------------------------
7312 -- Deepest_Type_Access_Level --
7313 -------------------------------
7315 function Deepest_Type_Access_Level
7317 Allow_Alt_Model
: Boolean := True) return Uint
7320 if Ekind
(Typ
) = E_Anonymous_Access_Type
7321 and then not Is_Local_Anonymous_Access
(Typ
)
7322 and then Nkind
(Associated_Node_For_Itype
(Typ
)) = N_Object_Declaration
7324 -- No_Dynamic_Accessibility_Checks override for alternative
7325 -- accessibility model.
7328 and then No_Dynamic_Accessibility_Checks_Enabled
(Typ
)
7330 return Type_Access_Level
(Typ
, Allow_Alt_Model
);
7333 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
7337 Scope_Depth
(Enclosing_Dynamic_Scope
7338 (Defining_Identifier
7339 (Associated_Node_For_Itype
(Typ
))));
7341 -- For generic formal type, return Int'Last (infinite).
7342 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
7344 elsif Is_Generic_Type
(Root_Type
(Typ
)) then
7345 return UI_From_Int
(Int
'Last);
7348 return Type_Access_Level
(Typ
, Allow_Alt_Model
);
7350 end Deepest_Type_Access_Level
;
7352 ---------------------
7353 -- Defining_Entity --
7354 ---------------------
7356 function Defining_Entity
(N
: Node_Id
) return Entity_Id
is
7357 Ent
: constant Entity_Id
:= Defining_Entity_Or_Empty
(N
);
7360 if Present
(Ent
) then
7364 raise Program_Error
;
7366 end Defining_Entity
;
7368 ------------------------------
7369 -- Defining_Entity_Or_Empty --
7370 ------------------------------
7372 function Defining_Entity_Or_Empty
(N
: Node_Id
) return Entity_Id
is
7375 when N_Abstract_Subprogram_Declaration
7376 | N_Expression_Function
7377 | N_Formal_Subprogram_Declaration
7378 | N_Generic_Package_Declaration
7379 | N_Generic_Subprogram_Declaration
7380 | N_Package_Declaration
7382 | N_Subprogram_Body_Stub
7383 | N_Subprogram_Declaration
7384 | N_Subprogram_Renaming_Declaration
7386 return Defining_Entity
(Specification
(N
));
7388 when N_Component_Declaration
7389 | N_Defining_Program_Unit_Name
7390 | N_Discriminant_Specification
7392 | N_Entry_Declaration
7393 | N_Entry_Index_Specification
7394 | N_Exception_Declaration
7395 | N_Exception_Renaming_Declaration
7396 | N_Formal_Object_Declaration
7397 | N_Formal_Package_Declaration
7398 | N_Formal_Type_Declaration
7399 | N_Full_Type_Declaration
7400 | N_Implicit_Label_Declaration
7401 | N_Incomplete_Type_Declaration
7402 | N_Iterator_Specification
7403 | N_Loop_Parameter_Specification
7404 | N_Number_Declaration
7405 | N_Object_Declaration
7406 | N_Object_Renaming_Declaration
7407 | N_Package_Body_Stub
7408 | N_Parameter_Specification
7409 | N_Private_Extension_Declaration
7410 | N_Private_Type_Declaration
7412 | N_Protected_Body_Stub
7413 | N_Protected_Type_Declaration
7414 | N_Single_Protected_Declaration
7415 | N_Single_Task_Declaration
7416 | N_Subtype_Declaration
7419 | N_Task_Type_Declaration
7421 return Defining_Identifier
(N
);
7423 when N_Compilation_Unit
=>
7424 return Defining_Entity
(Unit
(N
));
7427 return Defining_Entity
(Proper_Body
(N
));
7429 when N_Function_Instantiation
7430 | N_Function_Specification
7431 | N_Generic_Function_Renaming_Declaration
7432 | N_Generic_Package_Renaming_Declaration
7433 | N_Generic_Procedure_Renaming_Declaration
7435 | N_Package_Instantiation
7436 | N_Package_Renaming_Declaration
7437 | N_Package_Specification
7438 | N_Procedure_Instantiation
7439 | N_Procedure_Specification
7442 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
7443 Err
: Entity_Id
:= Empty
;
7446 if Nkind
(Nam
) in N_Entity
then
7449 -- For Error, make up a name and attach to declaration so we
7450 -- can continue semantic analysis.
7452 elsif Nam
= Error
then
7453 Err
:= Make_Temporary
(Sloc
(N
), 'T');
7454 Set_Defining_Unit_Name
(N
, Err
);
7458 -- If not an entity, get defining identifier
7461 return Defining_Identifier
(Nam
);
7465 when N_Block_Statement
7468 return Entity
(Identifier
(N
));
7473 end Defining_Entity_Or_Empty
;
7475 --------------------------
7476 -- Denotes_Discriminant --
7477 --------------------------
7479 function Denotes_Discriminant
7481 Check_Concurrent
: Boolean := False) return Boolean
7486 if not Is_Entity_Name
(N
) or else No
(Entity
(N
)) then
7492 -- If we are checking for a protected type, the discriminant may have
7493 -- been rewritten as the corresponding discriminal of the original type
7494 -- or of the corresponding concurrent record, depending on whether we
7495 -- are in the spec or body of the protected type.
7497 return Ekind
(E
) = E_Discriminant
7500 and then Ekind
(E
) = E_In_Parameter
7501 and then Present
(Discriminal_Link
(E
))
7503 (Is_Concurrent_Type
(Scope
(Discriminal_Link
(E
)))
7505 Is_Concurrent_Record_Type
(Scope
(Discriminal_Link
(E
)))));
7506 end Denotes_Discriminant
;
7508 -------------------------
7509 -- Denotes_Same_Object --
7510 -------------------------
7512 function Denotes_Same_Object
(A1
, A2
: Node_Id
) return Boolean is
7513 function Is_Object_Renaming
(N
: Node_Id
) return Boolean;
7514 -- Return true if N names an object renaming entity
7516 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean;
7517 -- For renamings, return False if the prefix of any dereference within
7518 -- the renamed object_name is a variable, or any expression within the
7519 -- renamed object_name contains references to variables or calls on
7520 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
7522 ------------------------
7523 -- Is_Object_Renaming --
7524 ------------------------
7526 function Is_Object_Renaming
(N
: Node_Id
) return Boolean is
7528 return Is_Entity_Name
(N
)
7529 and then Ekind
(Entity
(N
)) in E_Variable | E_Constant
7530 and then Present
(Renamed_Object
(Entity
(N
)));
7531 end Is_Object_Renaming
;
7533 -----------------------
7534 -- Is_Valid_Renaming --
7535 -----------------------
7537 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean is
7539 if Is_Object_Renaming
(N
)
7540 and then not Is_Valid_Renaming
(Renamed_Object
(Entity
(N
)))
7545 -- Check if any expression within the renamed object_name contains no
7546 -- references to variables nor calls on nonstatic functions.
7548 if Nkind
(N
) = N_Indexed_Component
then
7553 Indx
:= First
(Expressions
(N
));
7554 while Present
(Indx
) loop
7555 if not Is_OK_Static_Expression
(Indx
) then
7563 elsif Nkind
(N
) = N_Slice
then
7565 Rng
: constant Node_Id
:= Discrete_Range
(N
);
7567 -- Bounds specified as a range
7569 if Nkind
(Rng
) = N_Range
then
7570 if not Is_OK_Static_Range
(Rng
) then
7574 -- Bounds specified as a constrained subtype indication
7576 elsif Nkind
(Rng
) = N_Subtype_Indication
then
7577 if not Is_OK_Static_Range
7578 (Range_Expression
(Constraint
(Rng
)))
7583 -- Bounds specified as a subtype name
7585 elsif not Is_OK_Static_Expression
(Rng
) then
7591 if Has_Prefix
(N
) then
7593 P
: constant Node_Id
:= Prefix
(N
);
7596 if Nkind
(N
) = N_Explicit_Dereference
7597 and then Is_Variable
(P
)
7601 elsif Is_Entity_Name
(P
)
7602 and then Ekind
(Entity
(P
)) = E_Function
7606 elsif Nkind
(P
) = N_Function_Call
then
7610 -- Recursion to continue traversing the prefix of the
7611 -- renaming expression
7613 return Is_Valid_Renaming
(P
);
7618 end Is_Valid_Renaming
;
7620 -- Start of processing for Denotes_Same_Object
7623 -- Both names statically denote the same stand-alone object or
7624 -- parameter (RM 6.4.1(6.6/3)).
7626 if Is_Entity_Name
(A1
)
7627 and then Is_Entity_Name
(A2
)
7628 and then Entity
(A1
) = Entity
(A2
)
7632 -- Both names are selected_components, their prefixes are known to
7633 -- denote the same object, and their selector_names denote the same
7634 -- component (RM 6.4.1(6.7/3)).
7636 elsif Nkind
(A1
) = N_Selected_Component
7637 and then Nkind
(A2
) = N_Selected_Component
7639 return Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
))
7641 Entity
(Selector_Name
(A1
)) = Entity
(Selector_Name
(A2
));
7643 -- Both names are dereferences and the dereferenced names are known to
7644 -- denote the same object (RM 6.4.1(6.8/3)).
7646 elsif Nkind
(A1
) = N_Explicit_Dereference
7647 and then Nkind
(A2
) = N_Explicit_Dereference
7649 return Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
));
7651 -- Both names are indexed_components, their prefixes are known to denote
7652 -- the same object, and each of the pairs of corresponding index values
7653 -- are either both static expressions with the same static value or both
7654 -- names that are known to denote the same object (RM 6.4.1(6.9/3)).
7656 elsif Nkind
(A1
) = N_Indexed_Component
7657 and then Nkind
(A2
) = N_Indexed_Component
7659 if not Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
)) then
7667 Indx1
:= First
(Expressions
(A1
));
7668 Indx2
:= First
(Expressions
(A2
));
7669 while Present
(Indx1
) loop
7671 -- Indexes must denote the same static value or same object
7673 if Is_OK_Static_Expression
(Indx1
) then
7674 if not Is_OK_Static_Expression
(Indx2
) then
7677 elsif Expr_Value
(Indx1
) /= Expr_Value
(Indx2
) then
7681 elsif not Denotes_Same_Object
(Indx1
, Indx2
) then
7693 -- Both names are slices, their prefixes are known to denote the same
7694 -- object, and the two slices have statically matching index constraints
7695 -- (RM 6.4.1(6.10/3)).
7697 elsif Nkind
(A1
) = N_Slice
7698 and then Nkind
(A2
) = N_Slice
7700 if not Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
)) then
7704 Lo1
, Lo2
, Hi1
, Hi2
: Node_Id
;
7707 Get_Index_Bounds
(Discrete_Range
(A1
), Lo1
, Hi1
);
7708 Get_Index_Bounds
(Discrete_Range
(A2
), Lo2
, Hi2
);
7710 -- Check whether bounds are statically identical. There is no
7711 -- attempt to detect partial overlap of slices.
7713 return Is_OK_Static_Expression
(Lo1
)
7714 and then Is_OK_Static_Expression
(Lo2
)
7715 and then Is_OK_Static_Expression
(Hi1
)
7716 and then Is_OK_Static_Expression
(Hi2
)
7717 and then Expr_Value
(Lo1
) = Expr_Value
(Lo2
)
7718 and then Expr_Value
(Hi1
) = Expr_Value
(Hi2
);
7722 -- One of the two names statically denotes a renaming declaration whose
7723 -- renamed object_name is known to denote the same object as the other;
7724 -- the prefix of any dereference within the renamed object_name is not a
7725 -- variable, and any expression within the renamed object_name contains
7726 -- no references to variables nor calls on nonstatic functions (RM
7729 elsif Is_Object_Renaming
(A1
)
7730 and then Is_Valid_Renaming
(A1
)
7732 return Denotes_Same_Object
(Renamed_Object
(Entity
(A1
)), A2
);
7734 elsif Is_Object_Renaming
(A2
)
7735 and then Is_Valid_Renaming
(A2
)
7737 return Denotes_Same_Object
(A1
, Renamed_Object
(Entity
(A2
)));
7742 end Denotes_Same_Object
;
7744 -------------------------
7745 -- Denotes_Same_Prefix --
7746 -------------------------
7748 function Denotes_Same_Prefix
(A1
, A2
: Node_Id
) return Boolean is
7750 if Is_Entity_Name
(A1
) then
7751 if Nkind
(A2
) in N_Selected_Component | N_Indexed_Component
7752 and then not Is_Access_Type
(Etype
(A1
))
7754 return Denotes_Same_Object
(A1
, Prefix
(A2
))
7755 or else Denotes_Same_Prefix
(A1
, Prefix
(A2
));
7760 elsif Is_Entity_Name
(A2
) then
7761 return Denotes_Same_Prefix
(A1
=> A2
, A2
=> A1
);
7763 elsif Nkind
(A1
) in N_Selected_Component | N_Indexed_Component | N_Slice
7765 Nkind
(A2
) in N_Selected_Component | N_Indexed_Component | N_Slice
7768 Root1
, Root2
: Node_Id
;
7769 Depth1
, Depth2
: Nat
:= 0;
7772 Root1
:= Prefix
(A1
);
7773 while not Is_Entity_Name
(Root1
) loop
7774 if Nkind
(Root1
) not in
7775 N_Selected_Component | N_Indexed_Component
7779 Root1
:= Prefix
(Root1
);
7782 Depth1
:= Depth1
+ 1;
7785 Root2
:= Prefix
(A2
);
7786 while not Is_Entity_Name
(Root2
) loop
7787 if Nkind
(Root2
) not in
7788 N_Selected_Component | N_Indexed_Component
7792 Root2
:= Prefix
(Root2
);
7795 Depth2
:= Depth2
+ 1;
7798 -- If both have the same depth and they do not denote the same
7799 -- object, they are disjoint and no warning is needed.
7801 if Depth1
= Depth2
then
7804 elsif Depth1
> Depth2
then
7805 Root1
:= Prefix
(A1
);
7806 for J
in 1 .. Depth1
- Depth2
- 1 loop
7807 Root1
:= Prefix
(Root1
);
7810 return Denotes_Same_Object
(Root1
, A2
);
7813 Root2
:= Prefix
(A2
);
7814 for J
in 1 .. Depth2
- Depth1
- 1 loop
7815 Root2
:= Prefix
(Root2
);
7818 return Denotes_Same_Object
(A1
, Root2
);
7825 end Denotes_Same_Prefix
;
7827 ----------------------
7828 -- Denotes_Variable --
7829 ----------------------
7831 function Denotes_Variable
(N
: Node_Id
) return Boolean is
7833 return Is_Variable
(N
) and then Paren_Count
(N
) = 0;
7834 end Denotes_Variable
;
7836 -----------------------------
7837 -- Depends_On_Discriminant --
7838 -----------------------------
7840 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
7845 Get_Index_Bounds
(N
, L
, H
);
7846 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
7847 end Depends_On_Discriminant
;
7849 -------------------------------------
7850 -- Derivation_Too_Early_To_Inherit --
7851 -------------------------------------
7853 function Derivation_Too_Early_To_Inherit
7854 (Typ
: Entity_Id
; Streaming_Op
: TSS_Name_Type
) return Boolean is
7856 Btyp
: constant Entity_Id
:= Implementation_Base_Type
(Typ
);
7857 Parent_Type
: Entity_Id
;
7861 -- Start of processing for Derivation_Too_Early_To_Inherit
7864 if Is_Derived_Type
(Btyp
) then
7865 Parent_Type
:= Implementation_Base_Type
(Etype
(Btyp
));
7866 pragma Assert
(Parent_Type
/= Btyp
);
7868 if Has_Stream_Attribute_Definition
7869 (Parent_Type
, Streaming_Op
, Real_Rep
=> Real_Rep
)
7871 and then In_Same_Extended_Unit
(Btyp
, Parent_Type
)
7872 and then Instantiation
(Get_Source_File_Index
(Sloc
(Btyp
))) =
7873 Instantiation
(Get_Source_File_Index
(Sloc
(Parent_Type
)))
7875 return Earlier_In_Extended_Unit
(Btyp
, Real_Rep
);
7880 end Derivation_Too_Early_To_Inherit
;
7882 -------------------------
7883 -- Designate_Same_Unit --
7884 -------------------------
7886 function Designate_Same_Unit
7888 Name2
: Node_Id
) return Boolean
7890 K1
: constant Node_Kind
:= Nkind
(Name1
);
7891 K2
: constant Node_Kind
:= Nkind
(Name2
);
7893 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
7894 -- Returns the parent unit name node of a defining program unit name
7895 -- or the prefix if N is a selected component or an expanded name.
7897 function Select_Node
(N
: Node_Id
) return Node_Id
;
7898 -- Returns the defining identifier node of a defining program unit
7899 -- name or the selector node if N is a selected component or an
7906 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
7908 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
7919 function Select_Node
(N
: Node_Id
) return Node_Id
is
7921 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
7922 return Defining_Identifier
(N
);
7924 return Selector_Name
(N
);
7928 -- Start of processing for Designate_Same_Unit
7931 if K1
in N_Identifier | N_Defining_Identifier
7933 K2
in N_Identifier | N_Defining_Identifier
7935 return Chars
(Name1
) = Chars
(Name2
);
7937 elsif K1
in N_Expanded_Name
7938 | N_Selected_Component
7939 | N_Defining_Program_Unit_Name
7941 K2
in N_Expanded_Name
7942 | N_Selected_Component
7943 | N_Defining_Program_Unit_Name
7946 (Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
)))
7948 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
7953 end Designate_Same_Unit
;
7955 ---------------------------------------------
7956 -- Diagnose_Iterated_Component_Association --
7957 ---------------------------------------------
7959 procedure Diagnose_Iterated_Component_Association
(N
: Node_Id
) is
7960 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
7964 -- Determine whether the iterated component association appears within
7965 -- an aggregate. If this is the case, raise Program_Error because the
7966 -- iterated component association cannot be left in the tree as is and
7967 -- must always be processed by the related aggregate.
7970 while Present
(Aggr
) loop
7971 if Nkind
(Aggr
) = N_Aggregate
then
7972 raise Program_Error
;
7974 -- Prevent the search from going too far
7976 elsif Is_Body_Or_Package_Declaration
(Aggr
) then
7980 Aggr
:= Parent
(Aggr
);
7983 -- At this point it is known that the iterated component association is
7984 -- not within an aggregate. This is really a quantified expression with
7985 -- a missing "all" or "some" quantifier.
7987 Error_Msg_N
("missing quantifier", Def_Id
);
7989 -- Rewrite the iterated component association as True to prevent any
7992 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Sloc
(N
)));
7994 end Diagnose_Iterated_Component_Association
;
7996 ------------------------
7997 -- Discriminated_Size --
7998 ------------------------
8000 function Discriminated_Size
(Comp
: Entity_Id
) return Boolean is
8001 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean;
8002 -- Check whether the bound of an index is non-static and does denote
8003 -- a discriminant, in which case any object of the type (protected or
8004 -- otherwise) will have a non-static size.
8006 ----------------------
8007 -- Non_Static_Bound --
8008 ----------------------
8010 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean is
8012 if Is_OK_Static_Expression
(Bound
) then
8015 -- If the bound is given by a discriminant it is non-static
8016 -- (A static constraint replaces the reference with the value).
8017 -- In an protected object the discriminant has been replaced by
8018 -- the corresponding discriminal within the protected operation.
8020 elsif Is_Entity_Name
(Bound
)
8022 (Ekind
(Entity
(Bound
)) = E_Discriminant
8023 or else Present
(Discriminal_Link
(Entity
(Bound
))))
8030 end Non_Static_Bound
;
8034 Typ
: constant Entity_Id
:= Etype
(Comp
);
8037 -- Start of processing for Discriminated_Size
8040 if not Is_Array_Type
(Typ
) then
8044 if Ekind
(Typ
) = E_Array_Subtype
then
8045 Index
:= First_Index
(Typ
);
8046 while Present
(Index
) loop
8047 if Non_Static_Bound
(Low_Bound
(Index
))
8048 or else Non_Static_Bound
(High_Bound
(Index
))
8060 end Discriminated_Size
;
8062 -----------------------------------
8063 -- Effective_Extra_Accessibility --
8064 -----------------------------------
8066 function Effective_Extra_Accessibility
(Id
: Entity_Id
) return Entity_Id
is
8068 if Present
(Renamed_Object
(Id
))
8069 and then Is_Entity_Name
(Renamed_Object
(Id
))
8071 return Effective_Extra_Accessibility
(Entity
(Renamed_Object
(Id
)));
8073 return Extra_Accessibility
(Id
);
8075 end Effective_Extra_Accessibility
;
8077 -----------------------------
8078 -- Effective_Reads_Enabled --
8079 -----------------------------
8081 function Effective_Reads_Enabled
(Id
: Entity_Id
) return Boolean is
8083 return Has_Enabled_Property
(Id
, Name_Effective_Reads
);
8084 end Effective_Reads_Enabled
;
8086 ------------------------------
8087 -- Effective_Writes_Enabled --
8088 ------------------------------
8090 function Effective_Writes_Enabled
(Id
: Entity_Id
) return Boolean is
8092 return Has_Enabled_Property
(Id
, Name_Effective_Writes
);
8093 end Effective_Writes_Enabled
;
8095 ------------------------------
8096 -- Enclosing_Comp_Unit_Node --
8097 ------------------------------
8099 function Enclosing_Comp_Unit_Node
(N
: Node_Id
) return Node_Id
is
8100 Current_Node
: Node_Id
;
8104 while Present
(Current_Node
)
8105 and then Nkind
(Current_Node
) /= N_Compilation_Unit
8107 Current_Node
:= Parent
(Current_Node
);
8110 return Current_Node
;
8111 end Enclosing_Comp_Unit_Node
;
8113 --------------------------
8114 -- Enclosing_CPP_Parent --
8115 --------------------------
8117 function Enclosing_CPP_Parent
(Typ
: Entity_Id
) return Entity_Id
is
8118 Parent_Typ
: Entity_Id
:= Typ
;
8121 while not Is_CPP_Class
(Parent_Typ
)
8122 and then Etype
(Parent_Typ
) /= Parent_Typ
8124 Parent_Typ
:= Etype
(Parent_Typ
);
8126 if Is_Private_Type
(Parent_Typ
) then
8127 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
8131 pragma Assert
(Is_CPP_Class
(Parent_Typ
));
8133 end Enclosing_CPP_Parent
;
8135 ---------------------------
8136 -- Enclosing_Declaration --
8137 ---------------------------
8139 function Enclosing_Declaration
(N
: Node_Id
) return Node_Id
is
8140 Decl
: Node_Id
:= N
;
8143 while Present
(Decl
)
8144 and then not (Nkind
(Decl
) in N_Declaration
8146 Nkind
(Decl
) in N_Later_Decl_Item
8148 Nkind
(Decl
) in N_Renaming_Declaration
8150 Nkind
(Decl
) = N_Number_Declaration
)
8152 Decl
:= Parent
(Decl
);
8156 end Enclosing_Declaration
;
8158 ----------------------------
8159 -- Enclosing_Generic_Body --
8160 ----------------------------
8162 function Enclosing_Generic_Body
(N
: Node_Id
) return Node_Id
is
8164 Spec_Id
: Entity_Id
;
8168 while Present
(Par
) loop
8169 if Nkind
(Par
) in N_Package_Body | N_Subprogram_Body
then
8170 Spec_Id
:= Corresponding_Spec
(Par
);
8172 if Present
(Spec_Id
)
8173 and then Nkind
(Unit_Declaration_Node
(Spec_Id
)) in
8174 N_Generic_Declaration
8180 Par
:= Parent
(Par
);
8184 end Enclosing_Generic_Body
;
8186 ----------------------------
8187 -- Enclosing_Generic_Unit --
8188 ----------------------------
8190 function Enclosing_Generic_Unit
(N
: Node_Id
) return Node_Id
is
8192 Spec_Decl
: Node_Id
;
8193 Spec_Id
: Entity_Id
;
8197 while Present
(Par
) loop
8198 if Nkind
(Par
) in N_Generic_Declaration
then
8201 elsif Nkind
(Par
) in N_Package_Body | N_Subprogram_Body
then
8202 Spec_Id
:= Corresponding_Spec
(Par
);
8204 if Present
(Spec_Id
) then
8205 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
8207 if Nkind
(Spec_Decl
) in N_Generic_Declaration
then
8213 Par
:= Parent
(Par
);
8217 end Enclosing_Generic_Unit
;
8223 function Enclosing_HSS
(Stmt
: Node_Id
) return Node_Id
is
8226 pragma Assert
(Is_Statement
(Stmt
));
8228 Par
:= Parent
(Stmt
);
8229 while Present
(Par
) loop
8231 if Nkind
(Par
) = N_Handled_Sequence_Of_Statements
then
8234 -- Prevent the search from going too far
8236 elsif Is_Body_Or_Package_Declaration
(Par
) then
8241 Par
:= Parent
(Par
);
8247 -------------------------------
8248 -- Enclosing_Lib_Unit_Entity --
8249 -------------------------------
8251 function Enclosing_Lib_Unit_Entity
8252 (E
: Entity_Id
:= Current_Scope
) return Entity_Id
8254 Unit_Entity
: Entity_Id
;
8257 -- Look for enclosing library unit entity by following scope links.
8258 -- Equivalent to, but faster than indexing through the scope stack.
8261 while (Present
(Scope
(Unit_Entity
))
8262 and then Scope
(Unit_Entity
) /= Standard_Standard
)
8263 and not Is_Child_Unit
(Unit_Entity
)
8265 Unit_Entity
:= Scope
(Unit_Entity
);
8269 end Enclosing_Lib_Unit_Entity
;
8271 -----------------------------
8272 -- Enclosing_Lib_Unit_Node --
8273 -----------------------------
8275 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
8276 Encl_Unit
: Node_Id
;
8279 Encl_Unit
:= Enclosing_Comp_Unit_Node
(N
);
8280 while Present
(Encl_Unit
)
8281 and then Nkind
(Unit
(Encl_Unit
)) = N_Subunit
8283 Encl_Unit
:= Library_Unit
(Encl_Unit
);
8286 pragma Assert
(Nkind
(Encl_Unit
) = N_Compilation_Unit
);
8288 end Enclosing_Lib_Unit_Node
;
8290 -----------------------
8291 -- Enclosing_Package --
8292 -----------------------
8294 function Enclosing_Package
(N
: Node_Or_Entity_Id
) return Entity_Id
is
8295 Dynamic_Scope
: Entity_Id
;
8298 -- Obtain the enclosing scope when N is a Node_Id - taking care to
8299 -- handle the case when the enclosing scope is already a package.
8301 if Nkind
(N
) not in N_Entity
then
8303 Encl_Scop
: constant Entity_Id
:= Find_Enclosing_Scope
(N
);
8305 if No
(Encl_Scop
) then
8307 elsif Ekind
(Encl_Scop
) in
8308 E_Generic_Package | E_Package | E_Package_Body
8313 return Enclosing_Package
(Encl_Scop
);
8317 -- When N is already an Entity_Id proceed
8319 Dynamic_Scope
:= Enclosing_Dynamic_Scope
(N
);
8320 if Dynamic_Scope
= Standard_Standard
then
8321 return Standard_Standard
;
8323 elsif Dynamic_Scope
= Empty
then
8326 elsif Ekind
(Dynamic_Scope
) in
8327 E_Generic_Package | E_Package | E_Package_Body
8329 return Dynamic_Scope
;
8332 return Enclosing_Package
(Dynamic_Scope
);
8334 end Enclosing_Package
;
8336 -------------------------------------
8337 -- Enclosing_Package_Or_Subprogram --
8338 -------------------------------------
8340 function Enclosing_Package_Or_Subprogram
(E
: Entity_Id
) return Entity_Id
is
8345 while Present
(S
) loop
8346 if Is_Package_Or_Generic_Package
(S
)
8347 or else Is_Subprogram_Or_Generic_Subprogram
(S
)
8357 end Enclosing_Package_Or_Subprogram
;
8359 --------------------------
8360 -- Enclosing_Subprogram --
8361 --------------------------
8363 function Enclosing_Subprogram
(N
: Node_Or_Entity_Id
) return Entity_Id
is
8364 Dyn_Scop
: Entity_Id
;
8365 Encl_Scop
: Entity_Id
;
8368 -- Obtain the enclosing scope when N is a Node_Id - taking care to
8369 -- handle the case when the enclosing scope is already a subprogram.
8371 if Nkind
(N
) not in N_Entity
then
8372 Encl_Scop
:= Find_Enclosing_Scope
(N
);
8374 if No
(Encl_Scop
) then
8376 elsif Ekind
(Encl_Scop
) in Subprogram_Kind
then
8380 return Enclosing_Subprogram
(Encl_Scop
);
8383 -- When N is already an Entity_Id proceed
8385 Dyn_Scop
:= Enclosing_Dynamic_Scope
(N
);
8386 if Dyn_Scop
= Standard_Standard
then
8389 elsif Dyn_Scop
= Empty
then
8392 elsif Ekind
(Dyn_Scop
) = E_Subprogram_Body
then
8393 return Corresponding_Spec
(Parent
(Parent
(Dyn_Scop
)));
8395 elsif Ekind
(Dyn_Scop
) in E_Block | E_Loop | E_Return_Statement
then
8396 return Enclosing_Subprogram
(Dyn_Scop
);
8398 elsif Ekind
(Dyn_Scop
) in E_Entry | E_Entry_Family
then
8400 -- For a task entry or entry family, return the enclosing subprogram
8401 -- of the task itself.
8403 if Ekind
(Scope
(Dyn_Scop
)) = E_Task_Type
then
8404 return Enclosing_Subprogram
(Dyn_Scop
);
8406 -- A protected entry or entry family is rewritten as a protected
8407 -- procedure which is the desired enclosing subprogram. This is
8408 -- relevant when unnesting a procedure local to an entry body.
8411 return Protected_Body_Subprogram
(Dyn_Scop
);
8414 elsif Ekind
(Dyn_Scop
) = E_Task_Type
then
8415 return Get_Task_Body_Procedure
(Dyn_Scop
);
8417 -- The scope may appear as a private type or as a private extension
8418 -- whose completion is a task or protected type.
8420 elsif Ekind
(Dyn_Scop
) in
8421 E_Limited_Private_Type | E_Record_Type_With_Private
8422 and then Present
(Full_View
(Dyn_Scop
))
8423 and then Ekind
(Full_View
(Dyn_Scop
)) in E_Task_Type | E_Protected_Type
8425 return Get_Task_Body_Procedure
(Full_View
(Dyn_Scop
));
8427 -- No body is generated if the protected operation is eliminated
8429 elsif not Is_Eliminated
(Dyn_Scop
)
8430 and then Present
(Protected_Body_Subprogram
(Dyn_Scop
))
8432 return Protected_Body_Subprogram
(Dyn_Scop
);
8437 end Enclosing_Subprogram
;
8439 --------------------------
8440 -- End_Keyword_Location --
8441 --------------------------
8443 function End_Keyword_Location
(N
: Node_Id
) return Source_Ptr
is
8444 function End_Label_Loc
(Nod
: Node_Id
) return Source_Ptr
;
8445 -- Return the source location of Nod's end label according to the
8446 -- following precedence rules:
8448 -- 1) If the end label exists, return its location
8449 -- 2) If Nod exists, return its location
8450 -- 3) Return the location of N
8456 function End_Label_Loc
(Nod
: Node_Id
) return Source_Ptr
is
8460 if Present
(Nod
) then
8461 Label
:= End_Label
(Nod
);
8463 if Present
(Label
) then
8464 return Sloc
(Label
);
8476 Owner
: Node_Id
:= Empty
;
8478 -- Start of processing for End_Keyword_Location
8481 if Nkind
(N
) in N_Block_Statement
8487 Owner
:= Handled_Statement_Sequence
(N
);
8489 elsif Nkind
(N
) = N_Package_Declaration
then
8490 Owner
:= Specification
(N
);
8492 elsif Nkind
(N
) = N_Protected_Body
then
8495 elsif Nkind
(N
) in N_Protected_Type_Declaration
8496 | N_Single_Protected_Declaration
8498 Owner
:= Protected_Definition
(N
);
8500 elsif Nkind
(N
) in N_Single_Task_Declaration | N_Task_Type_Declaration
8502 Owner
:= Task_Definition
(N
);
8504 -- This routine should not be called with other contexts
8507 pragma Assert
(False);
8511 return End_Label_Loc
(Owner
);
8512 end End_Keyword_Location
;
8514 ------------------------
8515 -- Ensure_Freeze_Node --
8516 ------------------------
8518 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
8521 if No
(Freeze_Node
(E
)) then
8522 FN
:= Make_Freeze_Entity
(Sloc
(E
));
8523 Set_Has_Delayed_Freeze
(E
);
8524 Set_Freeze_Node
(E
, FN
);
8525 Set_Access_Types_To_Process
(FN
, No_Elist
);
8526 Set_TSS_Elist
(FN
, No_Elist
);
8529 end Ensure_Freeze_Node
;
8535 procedure Enter_Name
(Def_Id
: Entity_Id
) is
8536 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
8537 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
8538 S
: constant Entity_Id
:= Current_Scope
;
8541 Generate_Definition
(Def_Id
);
8543 -- Add new name to current scope declarations. Check for duplicate
8544 -- declaration, which may or may not be a genuine error.
8548 -- Case of previous entity entered because of a missing declaration
8549 -- or else a bad subtype indication. Best is to use the new entity,
8550 -- and make the previous one invisible.
8552 if Etype
(E
) = Any_Type
then
8553 Set_Is_Immediately_Visible
(E
, False);
8555 -- Case of renaming declaration constructed for package instances.
8556 -- if there is an explicit declaration with the same identifier,
8557 -- the renaming is not immediately visible any longer, but remains
8558 -- visible through selected component notation.
8560 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
8561 and then not Comes_From_Source
(E
)
8563 Set_Is_Immediately_Visible
(E
, False);
8565 -- The new entity may be the package renaming, which has the same
8566 -- same name as a generic formal which has been seen already.
8568 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
8569 and then not Comes_From_Source
(Def_Id
)
8571 Set_Is_Immediately_Visible
(E
, False);
8573 -- For a fat pointer corresponding to a remote access to subprogram,
8574 -- we use the same identifier as the RAS type, so that the proper
8575 -- name appears in the stub. This type is only retrieved through
8576 -- the RAS type and never by visibility, and is not added to the
8577 -- visibility list (see below).
8579 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
8580 and then Ekind
(Def_Id
) = E_Record_Type
8581 and then Present
(Corresponding_Remote_Type
(Def_Id
))
8585 -- Case of an implicit operation or derived literal. The new entity
8586 -- hides the implicit one, which is removed from all visibility,
8587 -- i.e. the entity list of its scope, and homonym chain of its name.
8589 elsif (Is_Overloadable
(E
) and then Is_Inherited_Operation
(E
))
8590 or else Is_Internal
(E
)
8593 Decl
: constant Node_Id
:= Parent
(E
);
8595 Prev_Vis
: Entity_Id
;
8598 -- If E is an implicit declaration, it cannot be the first
8599 -- entity in the scope.
8601 Prev
:= First_Entity
(Current_Scope
);
8602 while Present
(Prev
) and then Next_Entity
(Prev
) /= E
loop
8608 -- If E is not on the entity chain of the current scope,
8609 -- it is an implicit declaration in the generic formal
8610 -- part of a generic subprogram. When analyzing the body,
8611 -- the generic formals are visible but not on the entity
8612 -- chain of the subprogram. The new entity will become
8613 -- the visible one in the body.
8616 (Nkind
(Parent
(Decl
)) = N_Generic_Subprogram_Declaration
);
8620 Link_Entities
(Prev
, Next_Entity
(E
));
8622 if No
(Next_Entity
(Prev
)) then
8623 Set_Last_Entity
(Current_Scope
, Prev
);
8626 if E
= Current_Entity
(E
) then
8630 Prev_Vis
:= Current_Entity
(E
);
8631 while Homonym
(Prev_Vis
) /= E
loop
8632 Prev_Vis
:= Homonym
(Prev_Vis
);
8636 if Present
(Prev_Vis
) then
8638 -- Skip E in the visibility chain
8640 Set_Homonym
(Prev_Vis
, Homonym
(E
));
8643 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
8646 -- The inherited operation cannot be retrieved
8647 -- by name, even though it may remain accesssible
8648 -- in some cases involving subprogram bodies without
8649 -- specs appearing in with_clauses..
8651 Set_Is_Immediately_Visible
(E
, False);
8655 -- This section of code could use a comment ???
8657 elsif Present
(Etype
(E
))
8658 and then Is_Concurrent_Type
(Etype
(E
))
8663 -- If the homograph is a protected component renaming, it should not
8664 -- be hiding the current entity. Such renamings are treated as weak
8667 elsif Is_Prival
(E
) then
8668 Set_Is_Immediately_Visible
(E
, False);
8670 -- In this case the current entity is a protected component renaming.
8671 -- Perform minimal decoration by setting the scope and return since
8672 -- the prival should not be hiding other visible entities.
8674 elsif Is_Prival
(Def_Id
) then
8675 Set_Scope
(Def_Id
, Current_Scope
);
8678 -- Analogous to privals, the discriminal generated for an entry index
8679 -- parameter acts as a weak declaration. Perform minimal decoration
8680 -- to avoid bogus errors.
8682 elsif Is_Discriminal
(Def_Id
)
8683 and then Ekind
(Discriminal_Link
(Def_Id
)) = E_Entry_Index_Parameter
8685 Set_Scope
(Def_Id
, Current_Scope
);
8688 -- In the body or private part of an instance, a type extension may
8689 -- introduce a component with the same name as that of an actual. The
8690 -- legality rule is not enforced, but the semantics of the full type
8691 -- with two components of same name are not clear at this point???
8693 elsif In_Instance_Not_Visible
then
8696 -- When compiling a package body, some child units may have become
8697 -- visible. They cannot conflict with local entities that hide them.
8699 elsif Is_Child_Unit
(E
)
8700 and then In_Open_Scopes
(Scope
(E
))
8701 and then not Is_Immediately_Visible
(E
)
8705 -- Conversely, with front-end inlining we may compile the parent body
8706 -- first, and a child unit subsequently. The context is now the
8707 -- parent spec, and body entities are not visible.
8709 elsif Is_Child_Unit
(Def_Id
)
8710 and then Is_Package_Body_Entity
(E
)
8711 and then not In_Package_Body
(Current_Scope
)
8715 -- Case of genuine duplicate declaration
8718 Error_Msg_Sloc
:= Sloc
(E
);
8720 -- If the previous declaration is an incomplete type declaration
8721 -- this may be an attempt to complete it with a private type. The
8722 -- following avoids confusing cascaded errors.
8724 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
8725 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
8728 ("incomplete type cannot be completed with a private " &
8729 "declaration", Parent
(Def_Id
));
8730 Set_Is_Immediately_Visible
(E
, False);
8731 Set_Full_View
(E
, Def_Id
);
8733 -- An inherited component of a record conflicts with a new
8734 -- discriminant. The discriminant is inserted first in the scope,
8735 -- but the error should be posted on it, not on the component.
8737 elsif Ekind
(E
) = E_Discriminant
8738 and then Present
(Scope
(Def_Id
))
8739 and then Scope
(Def_Id
) /= Current_Scope
8741 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8742 Error_Msg_N
("& conflicts with declaration#", E
);
8745 -- If the name of the unit appears in its own context clause, a
8746 -- dummy package with the name has already been created, and the
8747 -- error emitted. Try to continue quietly.
8749 elsif Error_Posted
(E
)
8750 and then Sloc
(E
) = No_Location
8751 and then Nkind
(Parent
(E
)) = N_Package_Specification
8752 and then Current_Scope
= Standard_Standard
8754 Set_Scope
(Def_Id
, Current_Scope
);
8758 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
8760 -- Avoid cascaded messages with duplicate components in
8763 if Ekind
(E
) in E_Component | E_Discriminant
then
8768 if Nkind
(Parent
(Parent
(Def_Id
))) =
8769 N_Generic_Subprogram_Declaration
8771 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
8773 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
8776 -- If entity is in standard, then we are in trouble, because it
8777 -- means that we have a library package with a duplicated name.
8778 -- That's hard to recover from, so abort.
8780 if S
= Standard_Standard
then
8781 raise Unrecoverable_Error
;
8783 -- Otherwise we continue with the declaration. Having two
8784 -- identical declarations should not cause us too much trouble.
8792 -- If we fall through, declaration is OK, at least OK enough to continue
8794 -- If Def_Id is a discriminant or a record component we are in the midst
8795 -- of inheriting components in a derived record definition. Preserve
8796 -- their Ekind and Etype.
8798 if Ekind
(Def_Id
) in E_Discriminant | E_Component
then
8801 -- If a type is already set, leave it alone (happens when a type
8802 -- declaration is reanalyzed following a call to the optimizer).
8804 elsif Present
(Etype
(Def_Id
)) then
8807 -- Otherwise, the kind E_Void insures that premature uses of the entity
8808 -- will be detected. Any_Type insures that no cascaded errors will occur
8811 Mutate_Ekind
(Def_Id
, E_Void
);
8812 Set_Etype
(Def_Id
, Any_Type
);
8815 -- All entities except Itypes are immediately visible
8817 if not Is_Itype
(Def_Id
) then
8818 Set_Is_Immediately_Visible
(Def_Id
);
8819 Set_Current_Entity
(Def_Id
);
8822 Set_Homonym
(Def_Id
, C
);
8823 Append_Entity
(Def_Id
, S
);
8824 Set_Public_Status
(Def_Id
);
8826 -- Warn if new entity hides an old one
8828 if Warn_On_Hiding
and then Present
(C
) then
8829 Warn_On_Hiding_Entity
(Def_Id
, Hidden
=> C
, Visible
=> Def_Id
,
8830 On_Use_Clause
=> False);
8838 function Entity_Of
(N
: Node_Id
) return Entity_Id
is
8843 -- Assume that the arbitrary node does not have an entity
8847 if Is_Entity_Name
(N
) then
8850 -- Follow a possible chain of renamings to reach the earliest renamed
8854 and then Is_Object
(Id
)
8855 and then Present
(Renamed_Object
(Id
))
8857 Ren
:= Renamed_Object
(Id
);
8859 -- The reference renames an abstract state or a whole object
8862 -- Ren : ... renames Obj;
8864 if Is_Entity_Name
(Ren
) then
8866 -- Do not follow a renaming that goes through a generic formal,
8867 -- because these entities are hidden and must not be referenced
8868 -- from outside the generic.
8870 if Is_Hidden
(Entity
(Ren
)) then
8877 -- The reference renames a function result. Check the original
8878 -- node in case expansion relocates the function call.
8880 -- Ren : ... renames Func_Call;
8882 elsif Nkind
(Original_Node
(Ren
)) = N_Function_Call
then
8885 -- Otherwise the reference renames something which does not yield
8886 -- an abstract state or a whole object. Treat the reference as not
8887 -- having a proper entity for SPARK legality purposes.
8899 --------------------------
8900 -- Examine_Array_Bounds --
8901 --------------------------
8903 procedure Examine_Array_Bounds
8905 All_Static
: out Boolean;
8906 Has_Empty
: out Boolean)
8908 function Is_OK_Static_Bound
(Bound
: Node_Id
) return Boolean;
8909 -- Determine whether bound Bound is a suitable static bound
8911 ------------------------
8912 -- Is_OK_Static_Bound --
8913 ------------------------
8915 function Is_OK_Static_Bound
(Bound
: Node_Id
) return Boolean is
8918 not Error_Posted
(Bound
)
8919 and then Is_OK_Static_Expression
(Bound
);
8920 end Is_OK_Static_Bound
;
8928 -- Start of processing for Examine_Array_Bounds
8931 -- An unconstrained array type does not have static bounds, and it is
8932 -- not known whether they are empty or not.
8934 if not Is_Constrained
(Typ
) then
8935 All_Static
:= False;
8938 -- A string literal has static bounds, and is not empty as long as it
8939 -- contains at least one character.
8941 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
8943 Has_Empty
:= String_Literal_Length
(Typ
) > 0;
8946 -- Assume that all bounds are static and not empty
8951 -- Examine each index
8953 Index
:= First_Index
(Typ
);
8954 while Present
(Index
) loop
8955 if Is_Discrete_Type
(Etype
(Index
)) then
8956 Get_Index_Bounds
(Index
, Lo_Bound
, Hi_Bound
);
8958 if Is_OK_Static_Bound
(Lo_Bound
)
8960 Is_OK_Static_Bound
(Hi_Bound
)
8962 -- The static bounds produce an empty range
8964 if Is_Null_Range
(Lo_Bound
, Hi_Bound
) then
8968 -- Otherwise at least one of the bounds is not static
8971 All_Static
:= False;
8974 -- Otherwise the index is non-discrete, therefore not static
8977 All_Static
:= False;
8982 end Examine_Array_Bounds
;
8988 function Exceptions_OK
return Boolean is
8991 not (Restriction_Active
(No_Exception_Handlers
) or else
8992 Restriction_Active
(No_Exception_Propagation
) or else
8993 Restriction_Active
(No_Exceptions
));
8996 --------------------------
8997 -- Explain_Limited_Type --
8998 --------------------------
9000 procedure Explain_Limited_Type
(T
: Entity_Id
; N
: Node_Id
) is
9004 -- For array, component type must be limited
9006 if Is_Array_Type
(T
) then
9007 Error_Msg_Node_2
:= T
;
9009 ("\component type& of type& is limited", N
, Component_Type
(T
));
9010 Explain_Limited_Type
(Component_Type
(T
), N
);
9012 elsif Is_Record_Type
(T
) then
9014 -- No need for extra messages if explicit limited record
9016 if Is_Limited_Record
(Base_Type
(T
)) then
9020 -- Otherwise find a limited component. Check only components that
9021 -- come from source, or inherited components that appear in the
9022 -- source of the ancestor.
9024 C
:= First_Component
(T
);
9025 while Present
(C
) loop
9026 if Is_Limited_Type
(Etype
(C
))
9028 (Comes_From_Source
(C
)
9030 (Present
(Original_Record_Component
(C
))
9032 Comes_From_Source
(Original_Record_Component
(C
))))
9034 Error_Msg_Node_2
:= T
;
9035 Error_Msg_NE
("\component& of type& has limited type", N
, C
);
9036 Explain_Limited_Type
(Etype
(C
), N
);
9043 -- The type may be declared explicitly limited, even if no component
9044 -- of it is limited, in which case we fall out of the loop.
9047 end Explain_Limited_Type
;
9049 ---------------------------------------
9050 -- Expression_Of_Expression_Function --
9051 ---------------------------------------
9053 function Expression_Of_Expression_Function
9054 (Subp
: Entity_Id
) return Node_Id
9056 Expr_Func
: Node_Id
:= Empty
;
9059 pragma Assert
(Is_Expression_Function_Or_Completion
(Subp
));
9061 if Nkind
(Original_Node
(Subprogram_Spec
(Subp
))) =
9062 N_Expression_Function
9064 Expr_Func
:= Original_Node
(Subprogram_Spec
(Subp
));
9066 elsif Nkind
(Original_Node
(Subprogram_Body
(Subp
))) =
9067 N_Expression_Function
9069 Expr_Func
:= Original_Node
(Subprogram_Body
(Subp
));
9072 pragma Assert
(False);
9076 return Original_Node
(Expression
(Expr_Func
));
9077 end Expression_Of_Expression_Function
;
9079 -------------------------------
9080 -- Extensions_Visible_Status --
9081 -------------------------------
9083 function Extensions_Visible_Status
9084 (Id
: Entity_Id
) return Extensions_Visible_Mode
9093 -- When a formal parameter is subject to Extensions_Visible, the pragma
9094 -- is stored in the contract of related subprogram.
9096 if Is_Formal
(Id
) then
9099 elsif Is_Subprogram_Or_Generic_Subprogram
(Id
) then
9102 -- No other construct carries this pragma
9105 return Extensions_Visible_None
;
9108 Prag
:= Get_Pragma
(Subp
, Pragma_Extensions_Visible
);
9110 -- In certain cases analysis may request the Extensions_Visible status
9111 -- of an expression function before the pragma has been analyzed yet.
9112 -- Inspect the declarative items after the expression function looking
9113 -- for the pragma (if any).
9115 if No
(Prag
) and then Is_Expression_Function
(Subp
) then
9116 Decl
:= Next
(Unit_Declaration_Node
(Subp
));
9117 while Present
(Decl
) loop
9118 if Nkind
(Decl
) = N_Pragma
9119 and then Pragma_Name
(Decl
) = Name_Extensions_Visible
9124 -- A source construct ends the region where Extensions_Visible may
9125 -- appear, stop the traversal. An expanded expression function is
9126 -- no longer a source construct, but it must still be recognized.
9128 elsif Comes_From_Source
(Decl
)
9130 (Nkind
(Decl
) in N_Subprogram_Body | N_Subprogram_Declaration
9131 and then Is_Expression_Function
(Defining_Entity
(Decl
)))
9140 -- Extract the value from the Boolean expression (if any)
9142 if Present
(Prag
) then
9143 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
9145 if Present
(Arg
) then
9146 Expr
:= Get_Pragma_Arg
(Arg
);
9148 -- When the associated subprogram is an expression function, the
9149 -- argument of the pragma may not have been analyzed.
9151 if not Analyzed
(Expr
) then
9152 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
9155 -- Guard against cascading errors when the argument of pragma
9156 -- Extensions_Visible is not a valid static Boolean expression.
9158 if Error_Posted
(Expr
) then
9159 return Extensions_Visible_None
;
9161 elsif Is_True
(Expr_Value
(Expr
)) then
9162 return Extensions_Visible_True
;
9165 return Extensions_Visible_False
;
9168 -- Otherwise the aspect or pragma defaults to True
9171 return Extensions_Visible_True
;
9174 -- Otherwise aspect or pragma Extensions_Visible is not inherited or
9175 -- directly specified. In SPARK code, its value defaults to "False".
9177 elsif SPARK_Mode
= On
then
9178 return Extensions_Visible_False
;
9180 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to
9184 return Extensions_Visible_True
;
9186 end Extensions_Visible_Status
;
9192 procedure Find_Actual
9194 Formal
: out Entity_Id
;
9197 Context
: constant Node_Id
:= Parent
(N
);
9202 if Nkind
(Context
) in N_Indexed_Component | N_Selected_Component
9203 and then N
= Prefix
(Context
)
9205 Find_Actual
(Context
, Formal
, Call
);
9208 elsif Nkind
(Context
) = N_Parameter_Association
9209 and then N
= Explicit_Actual_Parameter
(Context
)
9211 Call
:= Parent
(Context
);
9213 elsif Nkind
(Context
) in N_Entry_Call_Statement
9215 | N_Procedure_Call_Statement
9225 -- If we have a call to a subprogram look for the parameter. Note that
9226 -- we exclude overloaded calls, since we don't know enough to be sure
9227 -- of giving the right answer in this case.
9229 if Nkind
(Call
) in N_Entry_Call_Statement
9231 | N_Procedure_Call_Statement
9233 Call_Nam
:= Name
(Call
);
9235 -- A call to an entry family may appear as an indexed component
9237 if Nkind
(Call_Nam
) = N_Indexed_Component
then
9238 Call_Nam
:= Prefix
(Call_Nam
);
9241 -- A call to a protected or task entry appears as a selected
9242 -- component rather than an expanded name.
9244 if Nkind
(Call_Nam
) = N_Selected_Component
then
9245 Call_Nam
:= Selector_Name
(Call_Nam
);
9248 if Is_Entity_Name
(Call_Nam
)
9249 and then Present
(Entity
(Call_Nam
))
9250 and then (Is_Generic_Subprogram
(Entity
(Call_Nam
))
9251 or else Is_Overloadable
(Entity
(Call_Nam
))
9252 or else Ekind
(Entity
(Call_Nam
)) in E_Entry_Family
9254 | E_Subprogram_Type
)
9255 and then not Is_Overloaded
(Call_Nam
)
9257 -- If node is name in call it is not an actual
9259 if N
= Call_Nam
then
9265 -- Fall here if we are definitely a parameter
9267 Actual
:= First_Actual
(Call
);
9268 Formal
:= First_Formal
(Entity
(Call_Nam
));
9269 while Present
(Formal
) and then Present
(Actual
) loop
9273 -- An actual that is the prefix in a prefixed call may have
9274 -- been rewritten in the call. Check if sloc and kinds and
9277 elsif Sloc
(Actual
) = Sloc
(N
)
9278 and then Nkind
(Actual
) = N_Identifier
9279 and then Nkind
(Actual
) = Nkind
(N
)
9280 and then Chars
(Actual
) = Chars
(N
)
9285 Next_Actual
(Actual
);
9286 Next_Formal
(Formal
);
9292 -- Fall through here if we did not find matching actual
9298 ---------------------------
9299 -- Find_Body_Discriminal --
9300 ---------------------------
9302 function Find_Body_Discriminal
9303 (Spec_Discriminant
: Entity_Id
) return Entity_Id
9309 -- If expansion is suppressed, then the scope can be the concurrent type
9310 -- itself rather than a corresponding concurrent record type.
9312 if Is_Concurrent_Type
(Scope
(Spec_Discriminant
)) then
9313 Tsk
:= Scope
(Spec_Discriminant
);
9316 pragma Assert
(Is_Concurrent_Record_Type
(Scope
(Spec_Discriminant
)));
9318 Tsk
:= Corresponding_Concurrent_Type
(Scope
(Spec_Discriminant
));
9321 -- Find discriminant of original concurrent type, and use its current
9322 -- discriminal, which is the renaming within the task/protected body.
9324 Disc
:= First_Discriminant
(Tsk
);
9325 while Present
(Disc
) loop
9326 if Chars
(Disc
) = Chars
(Spec_Discriminant
) then
9327 return Discriminal
(Disc
);
9330 Next_Discriminant
(Disc
);
9333 -- That loop should always succeed in finding a matching entry and
9334 -- returning. Fatal error if not.
9336 raise Program_Error
;
9337 end Find_Body_Discriminal
;
9339 -------------------------------------
9340 -- Find_Corresponding_Discriminant --
9341 -------------------------------------
9343 function Find_Corresponding_Discriminant
9345 Typ
: Entity_Id
) return Entity_Id
9347 Par_Disc
: Entity_Id
;
9348 Old_Disc
: Entity_Id
;
9349 New_Disc
: Entity_Id
;
9352 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
9354 -- The original type may currently be private, and the discriminant
9355 -- only appear on its full view.
9357 if Is_Private_Type
(Scope
(Par_Disc
))
9358 and then not Has_Discriminants
(Scope
(Par_Disc
))
9359 and then Present
(Full_View
(Scope
(Par_Disc
)))
9361 Old_Disc
:= First_Discriminant
(Full_View
(Scope
(Par_Disc
)));
9363 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
9366 if Is_Class_Wide_Type
(Typ
) then
9367 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
9369 New_Disc
:= First_Discriminant
(Typ
);
9372 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
9373 if Old_Disc
= Par_Disc
then
9377 Next_Discriminant
(Old_Disc
);
9378 Next_Discriminant
(New_Disc
);
9381 -- Should always find it
9383 raise Program_Error
;
9384 end Find_Corresponding_Discriminant
;
9390 function Find_DIC_Type
(Typ
: Entity_Id
) return Entity_Id
is
9391 Curr_Typ
: Entity_Id
;
9392 -- The current type being examined in the parent hierarchy traversal
9394 DIC_Typ
: Entity_Id
;
9395 -- The type which carries the DIC pragma. This variable denotes the
9396 -- partial view when private types are involved.
9398 Par_Typ
: Entity_Id
;
9399 -- The parent type of the current type. This variable denotes the full
9400 -- view when private types are involved.
9403 -- The input type defines its own DIC pragma, therefore it is the owner
9405 if Has_Own_DIC
(Typ
) then
9408 -- Otherwise the DIC pragma is inherited from a parent type
9411 pragma Assert
(Has_Inherited_DIC
(Typ
));
9413 -- Climb the parent chain
9417 -- Inspect the parent type. Do not consider subtypes as they
9418 -- inherit the DIC attributes from their base types.
9420 DIC_Typ
:= Base_Type
(Etype
(Curr_Typ
));
9422 -- Look at the full view of a private type because the type may
9423 -- have a hidden parent introduced in the full view.
9427 if Is_Private_Type
(Par_Typ
)
9428 and then Present
(Full_View
(Par_Typ
))
9430 Par_Typ
:= Full_View
(Par_Typ
);
9433 -- Stop the climb once the nearest parent type which defines a DIC
9434 -- pragma of its own is encountered or when the root of the parent
9435 -- chain is reached.
9437 exit when Has_Own_DIC
(DIC_Typ
) or else Curr_Typ
= Par_Typ
;
9439 Curr_Typ
:= Par_Typ
;
9446 ----------------------------------
9447 -- Find_Enclosing_Iterator_Loop --
9448 ----------------------------------
9450 function Find_Enclosing_Iterator_Loop
(Id
: Entity_Id
) return Entity_Id
is
9455 -- Traverse the scope chain looking for an iterator loop. Such loops are
9456 -- usually transformed into blocks, hence the use of Original_Node.
9459 while Present
(S
) and then S
/= Standard_Standard
loop
9460 if Ekind
(S
) = E_Loop
9461 and then Nkind
(Parent
(S
)) = N_Implicit_Label_Declaration
9463 Constr
:= Original_Node
(Label_Construct
(Parent
(S
)));
9465 if Nkind
(Constr
) = N_Loop_Statement
9466 and then Present
(Iteration_Scheme
(Constr
))
9467 and then Nkind
(Iterator_Specification
9468 (Iteration_Scheme
(Constr
))) =
9469 N_Iterator_Specification
9479 end Find_Enclosing_Iterator_Loop
;
9481 --------------------------
9482 -- Find_Enclosing_Scope --
9483 --------------------------
9485 function Find_Enclosing_Scope
(N
: Node_Id
) return Entity_Id
is
9489 -- Examine the parent chain looking for a construct which defines a
9493 while Present
(Par
) loop
9496 -- The construct denotes a declaration, the proper scope is its
9499 when N_Entry_Declaration
9500 | N_Expression_Function
9501 | N_Full_Type_Declaration
9502 | N_Generic_Package_Declaration
9503 | N_Generic_Subprogram_Declaration
9504 | N_Package_Declaration
9505 | N_Private_Extension_Declaration
9506 | N_Protected_Type_Declaration
9507 | N_Single_Protected_Declaration
9508 | N_Single_Task_Declaration
9509 | N_Subprogram_Declaration
9510 | N_Task_Type_Declaration
9512 return Defining_Entity
(Par
);
9514 -- The construct denotes a body, the proper scope is the entity of
9515 -- the corresponding spec or that of the body if the body does not
9516 -- complete a previous declaration.
9524 return Unique_Defining_Entity
(Par
);
9528 -- Blocks carry either a source or an internally-generated scope,
9529 -- unless the block is a byproduct of exception handling.
9531 when N_Block_Statement
=>
9532 if not Exception_Junk
(Par
) then
9533 return Entity
(Identifier
(Par
));
9536 -- Loops carry an internally-generated scope
9538 when N_Loop_Statement
=>
9539 return Entity
(Identifier
(Par
));
9541 -- Extended return statements carry an internally-generated scope
9543 when N_Extended_Return_Statement
=>
9544 return Return_Statement_Entity
(Par
);
9546 -- A traversal from a subunit continues via the corresponding stub
9549 Par
:= Corresponding_Stub
(Par
);
9555 Par
:= Parent
(Par
);
9558 return Standard_Standard
;
9559 end Find_Enclosing_Scope
;
9561 ------------------------------------
9562 -- Find_Loop_In_Conditional_Block --
9563 ------------------------------------
9565 function Find_Loop_In_Conditional_Block
(N
: Node_Id
) return Node_Id
is
9571 if Nkind
(Stmt
) = N_If_Statement
then
9572 Stmt
:= First
(Then_Statements
(Stmt
));
9575 pragma Assert
(Nkind
(Stmt
) = N_Block_Statement
);
9577 -- Inspect the statements of the conditional block. In general the loop
9578 -- should be the first statement in the statement sequence of the block,
9579 -- but the finalization machinery may have introduced extra object
9582 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Stmt
)));
9583 while Present
(Stmt
) loop
9584 if Nkind
(Stmt
) = N_Loop_Statement
then
9591 -- The expansion of attribute 'Loop_Entry produced a malformed block
9593 raise Program_Error
;
9594 end Find_Loop_In_Conditional_Block
;
9596 --------------------------
9597 -- Find_Overlaid_Entity --
9598 --------------------------
9600 procedure Find_Overlaid_Entity
9602 Ent
: out Entity_Id
;
9606 (Nkind
(N
) = N_Attribute_Definition_Clause
9607 and then Chars
(N
) = Name_Address
);
9612 -- We are looking for one of the two following forms:
9614 -- for X'Address use Y'Address
9618 -- Const : constant Address := expr;
9620 -- for X'Address use Const;
9622 -- In the second case, the expr is either Y'Address, or recursively a
9623 -- constant that eventually references Y'Address.
9628 Expr
:= Expression
(N
);
9630 -- This loop checks the form of the expression for Y'Address, using
9631 -- recursion to deal with intermediate constants.
9634 -- Check for Y'Address
9636 if Nkind
(Expr
) = N_Attribute_Reference
9637 and then Attribute_Name
(Expr
) = Name_Address
9639 Expr
:= Prefix
(Expr
);
9642 -- Check for Const where Const is a constant entity
9644 elsif Is_Entity_Name
(Expr
)
9645 and then Ekind
(Entity
(Expr
)) = E_Constant
9647 Expr
:= Constant_Value
(Entity
(Expr
));
9649 -- Anything else does not need checking
9656 -- This loop checks the form of the prefix for an entity, using
9657 -- recursion to deal with intermediate components.
9660 -- Check for Y where Y is an entity
9662 if Is_Entity_Name
(Expr
) then
9663 Ent
:= Entity
(Expr
);
9665 -- If expansion is disabled, then we might see an entity of a
9666 -- protected component or of a discriminant of a concurrent unit.
9667 -- Ignore such entities, because further warnings for overlays
9668 -- expect this routine to only collect entities of entire objects.
9670 if Ekind
(Ent
) in E_Component | E_Discriminant
then
9672 (not Expander_Active
9673 and then Is_Concurrent_Type
(Scope
(Ent
)));
9678 -- Check for components
9680 elsif Nkind
(Expr
) in N_Selected_Component | N_Indexed_Component
then
9681 Expr
:= Prefix
(Expr
);
9684 -- Anything else does not need checking
9690 end Find_Overlaid_Entity
;
9692 -------------------------
9693 -- Find_Parameter_Type --
9694 -------------------------
9696 function Find_Parameter_Type
(Param
: Node_Id
) return Entity_Id
is
9698 if Nkind
(Param
) /= N_Parameter_Specification
then
9701 -- For an access parameter, obtain the type from the formal entity
9702 -- itself, because access to subprogram nodes do not carry a type.
9703 -- Shouldn't we always use the formal entity ???
9705 elsif Nkind
(Parameter_Type
(Param
)) = N_Access_Definition
then
9706 return Etype
(Defining_Identifier
(Param
));
9709 return Etype
(Parameter_Type
(Param
));
9711 end Find_Parameter_Type
;
9713 -----------------------------------
9714 -- Find_Placement_In_State_Space --
9715 -----------------------------------
9717 procedure Find_Placement_In_State_Space
9718 (Item_Id
: Entity_Id
;
9719 Placement
: out State_Space_Kind
;
9720 Pack_Id
: out Entity_Id
)
9722 function Inside_Package_Body
(Id
: Entity_Id
) return Boolean;
9723 function Inside_Private_Part
(Id
: Entity_Id
) return Boolean;
9724 -- Return True if Id is declared directly within the package body
9725 -- and the package private parts, respectively. We cannot use
9726 -- In_Private_Part/In_Body_Part flags, as these are only set during the
9727 -- analysis of the package itself, while Find_Placement_In_State_Space
9728 -- can be called on an entity of another package.
9730 ------------------------
9731 -- Inside_Package_Body --
9732 ------------------------
9734 function Inside_Package_Body
(Id
: Entity_Id
) return Boolean is
9735 Spec_Id
: constant Entity_Id
:= Scope
(Id
);
9736 Body_Decl
: constant Opt_N_Package_Body_Id
:= Package_Body
(Spec_Id
);
9737 Decl
: constant Node_Id
:= Enclosing_Declaration
(Id
);
9739 if Present
(Body_Decl
)
9740 and then Is_List_Member
(Decl
)
9741 and then List_Containing
(Decl
) = Declarations
(Body_Decl
)
9747 end Inside_Package_Body
;
9749 -------------------------
9750 -- Inside_Private_Part --
9751 -------------------------
9753 function Inside_Private_Part
(Id
: Entity_Id
) return Boolean is
9754 Spec_Id
: constant Entity_Id
:= Scope
(Id
);
9755 Private_Decls
: constant List_Id
:=
9756 Private_Declarations
(Package_Specification
(Spec_Id
));
9757 Decl
: constant Node_Id
:= Enclosing_Declaration
(Id
);
9759 if Is_List_Member
(Decl
)
9760 and then List_Containing
(Decl
) = Private_Decls
9764 elsif Ekind
(Id
) = E_Package
9765 and then Is_Private_Library_Unit
(Id
)
9772 end Inside_Private_Part
;
9776 Context
: Entity_Id
;
9778 -- Start of processing for Find_Placement_In_State_Space
9781 -- Assume that the item does not appear in the state space of a package
9783 Placement
:= Not_In_Package
;
9785 -- Climb the scope stack and examine the enclosing context
9788 Pack_Id
:= Scope
(Context
);
9789 while Present
(Pack_Id
) and then Pack_Id
/= Standard_Standard
loop
9790 if Is_Package_Or_Generic_Package
(Pack_Id
) then
9792 -- A package body is a cut off point for the traversal as the
9793 -- item cannot be visible to the outside from this point on.
9795 if Inside_Package_Body
(Context
) then
9796 Placement
:= Body_State_Space
;
9799 -- The private part of a package is a cut off point for the
9800 -- traversal as the item cannot be visible to the outside
9801 -- from this point on.
9803 elsif Inside_Private_Part
(Context
) then
9804 Placement
:= Private_State_Space
;
9807 -- When the item appears in the visible state space of a package,
9808 -- continue to climb the scope stack as this may not be the final
9812 Placement
:= Visible_State_Space
;
9814 -- The visible state space of a child unit acts as the proper
9815 -- placement of an item, unless this is a private child unit.
9817 if Is_Child_Unit
(Pack_Id
)
9818 and then not Is_Private_Library_Unit
(Pack_Id
)
9824 -- The item or its enclosing package appear in a construct that has
9828 Placement
:= Not_In_Package
;
9833 Context
:= Scope
(Context
);
9834 Pack_Id
:= Scope
(Context
);
9836 end Find_Placement_In_State_Space
;
9838 -----------------------
9839 -- Find_Primitive_Eq --
9840 -----------------------
9842 function Find_Primitive_Eq
(Typ
: Entity_Id
) return Entity_Id
is
9843 function Find_Eq_Prim
(Prims_List
: Elist_Id
) return Entity_Id
;
9844 -- Search for the equality primitive; return Empty if the primitive is
9851 function Find_Eq_Prim
(Prims_List
: Elist_Id
) return Entity_Id
is
9853 Prim_Elmt
: Elmt_Id
;
9856 Prim_Elmt
:= First_Elmt
(Prims_List
);
9857 while Present
(Prim_Elmt
) loop
9858 Prim
:= Node
(Prim_Elmt
);
9860 -- Locate primitive equality with the right signature
9862 if Chars
(Prim
) = Name_Op_Eq
9863 and then Etype
(First_Formal
(Prim
)) =
9864 Etype
(Next_Formal
(First_Formal
(Prim
)))
9865 and then Base_Type
(Etype
(Prim
)) = Standard_Boolean
9870 Next_Elmt
(Prim_Elmt
);
9878 Eq_Prim
: Entity_Id
;
9879 Full_Type
: Entity_Id
;
9881 -- Start of processing for Find_Primitive_Eq
9884 if Is_Private_Type
(Typ
) then
9885 Full_Type
:= Underlying_Type
(Typ
);
9890 if No
(Full_Type
) then
9894 Full_Type
:= Base_Type
(Full_Type
);
9896 -- When the base type itself is private, use the full view
9898 if Is_Private_Type
(Full_Type
) then
9899 Full_Type
:= Underlying_Type
(Full_Type
);
9902 if Is_Class_Wide_Type
(Full_Type
) then
9903 Full_Type
:= Root_Type
(Full_Type
);
9906 if not Is_Tagged_Type
(Full_Type
) then
9907 Eq_Prim
:= Find_Eq_Prim
(Collect_Primitive_Operations
(Typ
));
9909 -- If this is an untagged private type completed with a derivation of
9910 -- an untagged private type whose full view is a tagged type, we use
9911 -- the primitive operations of the private parent type (since it does
9912 -- not have a full view, and also because its equality primitive may
9913 -- have been overridden in its untagged full view). If no equality was
9914 -- defined for it then take its dispatching equality primitive.
9916 elsif Inherits_From_Tagged_Full_View
(Typ
) then
9917 Eq_Prim
:= Find_Eq_Prim
(Collect_Primitive_Operations
(Typ
));
9919 if No
(Eq_Prim
) then
9920 Eq_Prim
:= Find_Eq_Prim
(Primitive_Operations
(Full_Type
));
9924 Eq_Prim
:= Find_Eq_Prim
(Primitive_Operations
(Full_Type
));
9928 end Find_Primitive_Eq
;
9930 ------------------------
9931 -- Find_Specific_Type --
9932 ------------------------
9934 function Find_Specific_Type
(CW
: Entity_Id
) return Entity_Id
is
9935 Typ
: Entity_Id
:= Root_Type
(CW
);
9938 if Ekind
(Typ
) = E_Incomplete_Type
then
9939 if From_Limited_With
(Typ
) then
9940 Typ
:= Non_Limited_View
(Typ
);
9942 Typ
:= Full_View
(Typ
);
9946 if Is_Private_Type
(Typ
)
9947 and then not Is_Tagged_Type
(Typ
)
9948 and then Present
(Full_View
(Typ
))
9950 return Full_View
(Typ
);
9954 end Find_Specific_Type
;
9956 -----------------------------
9957 -- Find_Static_Alternative --
9958 -----------------------------
9960 function Find_Static_Alternative
(N
: Node_Id
) return Node_Id
is
9961 Expr
: constant Node_Id
:= Expression
(N
);
9962 Val
: constant Uint
:= Expr_Value
(Expr
);
9967 Alt
:= First
(Alternatives
(N
));
9970 if Nkind
(Alt
) /= N_Pragma
then
9971 Choice
:= First
(Discrete_Choices
(Alt
));
9972 while Present
(Choice
) loop
9974 -- Others choice, always matches
9976 if Nkind
(Choice
) = N_Others_Choice
then
9979 -- Range, check if value is in the range
9981 elsif Nkind
(Choice
) = N_Range
then
9983 Val
>= Expr_Value
(Low_Bound
(Choice
))
9985 Val
<= Expr_Value
(High_Bound
(Choice
));
9987 -- Choice is a subtype name. Note that we know it must
9988 -- be a static subtype, since otherwise it would have
9989 -- been diagnosed as illegal.
9991 elsif Is_Entity_Name
(Choice
)
9992 and then Is_Type
(Entity
(Choice
))
9994 exit Search
when Is_In_Range
(Expr
, Etype
(Choice
),
9995 Assume_Valid
=> False);
9997 -- Choice is a subtype indication
9999 elsif Nkind
(Choice
) = N_Subtype_Indication
then
10001 C
: constant Node_Id
:= Constraint
(Choice
);
10002 R
: constant Node_Id
:= Range_Expression
(C
);
10006 Val
>= Expr_Value
(Low_Bound
(R
))
10008 Val
<= Expr_Value
(High_Bound
(R
));
10011 -- Choice is a simple expression
10014 exit Search
when Val
= Expr_Value
(Choice
);
10022 pragma Assert
(Present
(Alt
));
10025 -- The above loop *must* terminate by finding a match, since we know the
10026 -- case statement is valid, and the value of the expression is known at
10027 -- compile time. When we fall out of the loop, Alt points to the
10028 -- alternative that we know will be selected at run time.
10031 end Find_Static_Alternative
;
10037 function First_Actual
(Node
: Node_Id
) return Node_Id
is
10041 if No
(Parameter_Associations
(Node
)) then
10045 N
:= First
(Parameter_Associations
(Node
));
10047 if Nkind
(N
) = N_Parameter_Association
then
10048 return First_Named_Actual
(Node
);
10058 function First_Global
10060 Global_Mode
: Name_Id
;
10061 Refined
: Boolean := False) return Node_Id
10063 function First_From_Global_List
10065 Global_Mode
: Name_Id
:= Name_Input
) return Entity_Id
;
10066 -- Get the first item with suitable mode from List
10068 ----------------------------
10069 -- First_From_Global_List --
10070 ----------------------------
10072 function First_From_Global_List
10074 Global_Mode
: Name_Id
:= Name_Input
) return Entity_Id
10079 -- Empty list (no global items)
10081 if Nkind
(List
) = N_Null
then
10084 -- Single global item declaration (only input items)
10086 elsif Nkind
(List
) in N_Expanded_Name | N_Identifier
then
10087 if Global_Mode
= Name_Input
then
10093 -- Simple global list (only input items) or moded global list
10096 elsif Nkind
(List
) = N_Aggregate
then
10097 if Present
(Expressions
(List
)) then
10098 if Global_Mode
= Name_Input
then
10099 return First
(Expressions
(List
));
10105 Assoc
:= First
(Component_Associations
(List
));
10106 while Present
(Assoc
) loop
10108 -- When we find the desired mode in an association, call
10109 -- recursively First_From_Global_List as if the mode was
10110 -- Name_Input, in order to reuse the existing machinery
10111 -- for the other cases.
10113 if Chars
(First
(Choices
(Assoc
))) = Global_Mode
then
10114 return First_From_Global_List
(Expression
(Assoc
));
10123 -- To accommodate partial decoration of disabled SPARK features,
10124 -- this routine may be called with illegal input. If this is the
10125 -- case, do not raise Program_Error.
10130 end First_From_Global_List
;
10134 Global
: Node_Id
:= Empty
;
10135 Body_Id
: Entity_Id
;
10137 -- Start of processing for First_Global
10140 pragma Assert
(Global_Mode
in Name_In_Out
10145 -- Retrieve the suitable pragma Global or Refined_Global. In the second
10146 -- case, it can only be located on the body entity.
10149 if Is_Subprogram_Or_Generic_Subprogram
(Subp
) then
10150 Body_Id
:= Subprogram_Body_Entity
(Subp
);
10152 elsif Is_Entry
(Subp
) or else Is_Task_Type
(Subp
) then
10153 Body_Id
:= Corresponding_Body
(Parent
(Subp
));
10155 -- ??? It should be possible to retrieve the Refined_Global on the
10156 -- task body associated to the task object. This is not yet possible.
10158 elsif Is_Single_Task_Object
(Subp
) then
10165 if Present
(Body_Id
) then
10166 Global
:= Get_Pragma
(Body_Id
, Pragma_Refined_Global
);
10169 Global
:= Get_Pragma
(Subp
, Pragma_Global
);
10172 -- No corresponding global if pragma is not present
10174 if No
(Global
) then
10177 -- Otherwise retrieve the corresponding list of items depending on the
10181 return First_From_Global_List
10182 (Expression
(Get_Argument
(Global
, Subp
)), Global_Mode
);
10190 function Fix_Msg
(Id
: Entity_Id
; Msg
: String) return String is
10191 Is_Task
: constant Boolean :=
10192 Ekind
(Id
) in E_Task_Body | E_Task_Type
10193 or else Is_Single_Task_Object
(Id
);
10194 Msg_Last
: constant Natural := Msg
'Last;
10195 Msg_Index
: Natural;
10196 Res
: String (Msg
'Range) := (others => ' ');
10197 Res_Index
: Natural;
10200 -- Copy all characters from the input message Msg to result Res with
10201 -- suitable replacements.
10203 Msg_Index
:= Msg
'First;
10204 Res_Index
:= Res
'First;
10205 while Msg_Index
<= Msg_Last
loop
10207 -- Replace "subprogram" with a different word
10209 if Msg_Index
<= Msg_Last
- 10
10210 and then Msg
(Msg_Index
.. Msg_Index
+ 9) = "subprogram"
10212 if Is_Entry
(Id
) then
10213 Res
(Res_Index
.. Res_Index
+ 4) := "entry";
10214 Res_Index
:= Res_Index
+ 5;
10217 Res
(Res_Index
.. Res_Index
+ 8) := "task type";
10218 Res_Index
:= Res_Index
+ 9;
10221 Res
(Res_Index
.. Res_Index
+ 9) := "subprogram";
10222 Res_Index
:= Res_Index
+ 10;
10225 Msg_Index
:= Msg_Index
+ 10;
10227 -- Replace "protected" with a different word
10229 elsif Msg_Index
<= Msg_Last
- 9
10230 and then Msg
(Msg_Index
.. Msg_Index
+ 8) = "protected"
10233 Res
(Res_Index
.. Res_Index
+ 3) := "task";
10234 Res_Index
:= Res_Index
+ 4;
10235 Msg_Index
:= Msg_Index
+ 9;
10237 -- Otherwise copy the character
10240 Res
(Res_Index
) := Msg
(Msg_Index
);
10241 Msg_Index
:= Msg_Index
+ 1;
10242 Res_Index
:= Res_Index
+ 1;
10246 return Res
(Res
'First .. Res_Index
- 1);
10249 -------------------------
10250 -- From_Nested_Package --
10251 -------------------------
10253 function From_Nested_Package
(T
: Entity_Id
) return Boolean is
10254 Pack
: constant Entity_Id
:= Scope
(T
);
10258 Ekind
(Pack
) = E_Package
10259 and then not Is_Frozen
(Pack
)
10260 and then not Scope_Within_Or_Same
(Current_Scope
, Pack
)
10261 and then In_Open_Scopes
(Scope
(Pack
));
10262 end From_Nested_Package
;
10264 -----------------------
10265 -- Gather_Components --
10266 -----------------------
10268 procedure Gather_Components
10270 Comp_List
: Node_Id
;
10271 Governed_By
: List_Id
;
10273 Report_Errors
: out Boolean;
10274 Allow_Compile_Time
: Boolean := False;
10275 Include_Interface_Tag
: Boolean := False)
10279 Discrete_Choice
: Node_Id
;
10280 Comp_Item
: Node_Id
;
10281 Discrim
: Entity_Id
;
10282 Discrim_Name
: Node_Id
;
10284 type Discriminant_Value_Status
is
10285 (Static_Expr
, Static_Subtype
, Bad
);
10286 subtype Good_Discrim_Value_Status
is Discriminant_Value_Status
10287 range Static_Expr
.. Static_Subtype
; -- range excludes Bad
10289 Discrim_Value
: Node_Id
;
10290 Discrim_Value_Subtype
: Node_Id
;
10291 Discrim_Value_Status
: Discriminant_Value_Status
:= Bad
;
10293 function OK_Scope_For_Discrim_Value_Error_Messages
return Boolean is
10294 (Scope
(Original_Record_Component
10295 (Entity
(First
(Choices
(Assoc
))))) = Typ
);
10296 -- Used to avoid generating error messages having a source position
10297 -- which refers to somewhere (e.g., a discriminant value in a derived
10298 -- tagged type declaration) unrelated to the offending construct. This
10299 -- is required for correctness - clients of Gather_Components such as
10300 -- Sem_Ch3.Create_Constrained_Components depend on this function
10301 -- returning True while processing semantically correct examples;
10302 -- generating an error message in this case would be wrong.
10305 Report_Errors
:= False;
10307 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
10310 elsif Present
(Component_Items
(Comp_List
)) then
10311 Comp_Item
:= First
(Component_Items
(Comp_List
));
10314 Comp_Item
:= Empty
;
10317 while Present
(Comp_Item
) loop
10319 -- Skip the tag of a tagged record, as well as all items that are not
10320 -- user components (anonymous types, rep clauses, Parent field,
10321 -- controller field).
10323 if Nkind
(Comp_Item
) = N_Component_Declaration
then
10325 Comp
: constant Entity_Id
:= Defining_Identifier
(Comp_Item
);
10327 if not (Is_Tag
(Comp
)
10329 (Include_Interface_Tag
10330 and then Etype
(Comp
) = RTE
(RE_Interface_Tag
)))
10331 and then Chars
(Comp
) /= Name_uParent
10333 Append_Elmt
(Comp
, Into
);
10341 if No
(Variant_Part
(Comp_List
)) then
10344 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
10345 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
10348 -- Look for the discriminant that governs this variant part.
10349 -- The discriminant *must* be in the Governed_By List
10351 Assoc
:= First
(Governed_By
);
10352 Find_Constraint
: loop
10353 Discrim
:= First
(Choices
(Assoc
));
10354 exit Find_Constraint
when
10355 Chars
(Discrim_Name
) = Chars
(Discrim
)
10357 (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
10358 and then Chars
(Corresponding_Discriminant
10359 (Entity
(Discrim
))) = Chars
(Discrim_Name
))
10361 Chars
(Original_Record_Component
(Entity
(Discrim
))) =
10362 Chars
(Discrim_Name
);
10364 if No
(Next
(Assoc
)) then
10365 if not Is_Constrained
(Typ
) and then Is_Derived_Type
(Typ
) then
10367 -- If the type is a tagged type with inherited discriminants,
10368 -- use the stored constraint on the parent in order to find
10369 -- the values of discriminants that are otherwise hidden by an
10370 -- explicit constraint. Renamed discriminants are handled in
10373 -- If several parent discriminants are renamed by a single
10374 -- discriminant of the derived type, the call to obtain the
10375 -- Corresponding_Discriminant field only retrieves the last
10376 -- of them. We recover the constraint on the others from the
10377 -- Stored_Constraint as well.
10379 -- An inherited discriminant may have been constrained in a
10380 -- later ancestor (not the immediate parent) so we must examine
10381 -- the stored constraint of all of them to locate the inherited
10387 T
: Entity_Id
:= Typ
;
10390 while Is_Derived_Type
(T
) loop
10391 if Present
(Stored_Constraint
(T
)) then
10392 D
:= First_Discriminant
(Etype
(T
));
10393 C
:= First_Elmt
(Stored_Constraint
(T
));
10394 while Present
(D
) and then Present
(C
) loop
10395 if Chars
(Discrim_Name
) = Chars
(D
) then
10396 if Is_Entity_Name
(Node
(C
))
10397 and then Entity
(Node
(C
)) = Entity
(Discrim
)
10399 -- D is renamed by Discrim, whose value is
10406 Make_Component_Association
(Sloc
(Typ
),
10408 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
10409 Duplicate_Subexpr_No_Checks
(Node
(C
)));
10412 exit Find_Constraint
;
10415 Next_Discriminant
(D
);
10420 -- Discriminant may be inherited from ancestor
10428 if No
(Next
(Assoc
)) then
10430 (" missing value for discriminant&",
10431 First
(Governed_By
), Discrim_Name
);
10433 Report_Errors
:= True;
10438 end loop Find_Constraint
;
10440 Discrim_Value
:= Expression
(Assoc
);
10442 if Is_OK_Static_Expression
(Discrim_Value
)
10443 or else (Allow_Compile_Time
10444 and then Compile_Time_Known_Value
(Discrim_Value
))
10446 Discrim_Value_Status
:= Static_Expr
;
10448 if Ada_Version
>= Ada_2022
then
10449 if Is_Rewrite_Substitution
(Discrim_Value
)
10450 and then Nkind
(Discrim_Value
) = N_Type_Conversion
10451 and then Etype
(Original_Node
(Discrim_Value
))
10452 = Etype
(Expression
(Discrim_Value
))
10454 Discrim_Value_Subtype
:= Etype
(Original_Node
(Discrim_Value
));
10455 -- An unhelpful (for this code) type conversion may be
10456 -- introduced in some cases; deal with it.
10458 Discrim_Value_Subtype
:= Etype
(Discrim_Value
);
10461 if Is_OK_Static_Subtype
(Discrim_Value_Subtype
) and then
10462 not Is_Null_Range
(Type_Low_Bound
(Discrim_Value_Subtype
),
10463 Type_High_Bound
(Discrim_Value_Subtype
))
10465 -- Is_Null_Range test doesn't account for predicates, as in
10466 -- subtype Null_By_Predicate is Natural
10467 -- with Static_Predicate => Null_By_Predicate < 0;
10468 -- so test for that null case separately.
10470 if (not Has_Static_Predicate
(Discrim_Value_Subtype
))
10471 or else Present
(First
(Static_Discrete_Predicate
10472 (Discrim_Value_Subtype
)))
10474 Discrim_Value_Status
:= Static_Subtype
;
10479 if Discrim_Value_Status
= Bad
then
10481 -- If the variant part is governed by a discriminant of the type
10482 -- this is an error. If the variant part and the discriminant are
10483 -- inherited from an ancestor this is legal (AI05-220) unless the
10484 -- components are being gathered for an aggregate, in which case
10485 -- the caller must check Report_Errors.
10487 -- In Ada 2022 the above rules are relaxed. A nonstatic governing
10488 -- discriminant is OK as long as it has a static subtype and
10489 -- every value of that subtype (and there must be at least one)
10490 -- selects the same variant.
10492 if OK_Scope_For_Discrim_Value_Error_Messages
then
10493 if Ada_Version
>= Ada_2022
then
10495 ("value for discriminant & must be static or " &
10496 "discriminant's nominal subtype must be static " &
10498 Discrim_Value
, Discrim
);
10501 ("value for discriminant & must be static!",
10502 Discrim_Value
, Discrim
);
10504 Why_Not_Static
(Discrim_Value
);
10507 Report_Errors
:= True;
10512 Search_For_Discriminant_Value
: declare
10518 UI_Discrim_Value
: Uint
;
10521 case Good_Discrim_Value_Status
'(Discrim_Value_Status) is
10522 when Static_Expr =>
10523 UI_Discrim_Value := Expr_Value (Discrim_Value);
10524 when Static_Subtype =>
10525 -- Arbitrarily pick one value of the subtype and look
10526 -- for the variant associated with that value; we will
10527 -- check later that the same variant is associated with
10528 -- all of the other values of the subtype.
10529 if Has_Static_Predicate (Discrim_Value_Subtype) then
10531 Range_Or_Expr : constant Node_Id :=
10532 First (Static_Discrete_Predicate
10533 (Discrim_Value_Subtype));
10535 if Nkind (Range_Or_Expr) = N_Range then
10536 UI_Discrim_Value :=
10537 Expr_Value (Low_Bound (Range_Or_Expr));
10539 UI_Discrim_Value := Expr_Value (Range_Or_Expr);
10544 := Expr_Value (Type_Low_Bound (Discrim_Value_Subtype));
10548 Find_Discrete_Value : while Present (Variant) loop
10550 -- If a choice is a subtype with a static predicate, it must
10551 -- be rewritten as an explicit list of non-predicated choices.
10553 Expand_Static_Predicates_In_Choices (Variant);
10555 Discrete_Choice := First (Discrete_Choices (Variant));
10556 while Present (Discrete_Choice) loop
10557 exit Find_Discrete_Value when
10558 Nkind (Discrete_Choice) = N_Others_Choice;
10560 Get_Index_Bounds (Discrete_Choice, Low, High);
10562 UI_Low := Expr_Value (Low);
10563 UI_High := Expr_Value (High);
10565 exit Find_Discrete_Value when
10566 UI_Low <= UI_Discrim_Value
10568 UI_High >= UI_Discrim_Value;
10570 Next (Discrete_Choice);
10573 Next_Non_Pragma (Variant);
10574 end loop Find_Discrete_Value;
10575 end Search_For_Discriminant_Value;
10577 -- The case statement must include a variant that corresponds to the
10578 -- value of the discriminant, unless the discriminant type has a
10579 -- static predicate. In that case the absence of an others_choice that
10580 -- would cover this value becomes a run-time error (3.8.1 (21.1/2)).
10583 and then not Has_Static_Predicate (Etype (Discrim_Name))
10586 ("value of discriminant & is out of range", Discrim_Value, Discrim);
10587 Report_Errors := True;
10591 -- If we have found the corresponding choice, recursively add its
10592 -- components to the Into list. The nested components are part of
10593 -- the same record type.
10595 if Present (Variant) then
10596 if Discrim_Value_Status = Static_Subtype then
10598 Discrim_Value_Subtype_Intervals
10599 : constant Interval_Lists.Discrete_Interval_List
10600 := Interval_Lists.Type_Intervals (Discrim_Value_Subtype);
10603 : constant Interval_Lists.Discrete_Interval_List
10604 := Interval_Lists.Choice_List_Intervals
10605 (Discrete_Choices => Discrete_Choices (Variant));
10607 if not Interval_Lists.Is_Subset
10608 (Subset => Discrim_Value_Subtype_Intervals,
10609 Of_Set => Variant_Intervals)
10611 if OK_Scope_For_Discrim_Value_Error_Messages then
10613 ("no single variant is associated with all values of " &
10614 "the subtype of discriminant value &",
10615 Discrim_Value, Discrim);
10617 Report_Errors := True;
10624 (Typ, Component_List (Variant), Governed_By, Into,
10625 Report_Errors, Allow_Compile_Time);
10627 end Gather_Components;
10629 -------------------------------
10630 -- Get_Dynamic_Accessibility --
10631 -------------------------------
10633 function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id is
10635 -- When minimum accessibility is set for E then we utilize it - except
10636 -- in a few edge cases like the expansion of select statements where
10637 -- generated subprogram may attempt to unnecessarily use a minimum
10638 -- accessibility object declared outside of scope.
10640 -- To avoid these situations where expansion may get complex we verify
10641 -- that the minimum accessibility object is within scope.
10644 and then Present (Minimum_Accessibility (E))
10645 and then In_Open_Scopes (Scope (Minimum_Accessibility (E)))
10647 return Minimum_Accessibility (E);
10650 return Extra_Accessibility (E);
10651 end Get_Dynamic_Accessibility;
10653 ------------------------
10654 -- Get_Actual_Subtype --
10655 ------------------------
10657 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
10658 Typ : constant Entity_Id := Etype (N);
10659 Utyp : Entity_Id := Underlying_Type (Typ);
10668 -- If what we have is an identifier that references a subprogram
10669 -- formal, or a variable or constant object, then we get the actual
10670 -- subtype from the referenced entity if one has been built.
10672 if Nkind (N) = N_Identifier
10674 (Is_Formal (Entity (N))
10675 or else Ekind (Entity (N)) = E_Constant
10676 or else Ekind (Entity (N)) = E_Variable)
10677 and then Present (Actual_Subtype (Entity (N)))
10679 return Actual_Subtype (Entity (N));
10681 -- Actual subtype of unchecked union is always itself. We never need
10682 -- the "real" actual subtype. If we did, we couldn't get it anyway
10683 -- because the discriminant is not available. The restrictions on
10684 -- Unchecked_Union are designed to make sure that this is OK.
10686 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
10689 -- Here for the unconstrained case, we must find actual subtype
10690 -- No actual subtype is available, so we must build it on the fly.
10692 -- Checking the type, not the underlying type, for constrainedness
10693 -- seems to be necessary. Maybe all the tests should be on the type???
10695 elsif (not Is_Constrained (Typ))
10696 and then (Is_Array_Type (Utyp)
10697 or else (Is_Record_Type (Utyp)
10698 and then Has_Discriminants (Utyp)))
10699 and then not Has_Unknown_Discriminants (Utyp)
10700 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
10702 -- Nothing to do if in spec expression (why not???)
10704 if In_Spec_Expression then
10707 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then
10709 -- If the type has no discriminants, there is no subtype to
10710 -- build, even if the underlying type is discriminated.
10714 -- Else build the actual subtype
10717 Decl := Build_Actual_Subtype (Typ, N);
10719 -- The call may yield a declaration, or just return the entity
10725 Atyp := Defining_Identifier (Decl);
10727 -- If Build_Actual_Subtype generated a new declaration then use it
10729 if Atyp /= Typ then
10731 -- The actual subtype is an Itype, so analyze the declaration,
10732 -- but do not attach it to the tree, to get the type defined.
10734 Set_Parent (Decl, N);
10735 Set_Is_Itype (Atyp);
10736 Analyze (Decl, Suppress => All_Checks);
10737 Set_Associated_Node_For_Itype (Atyp, N);
10738 if Expander_Active then
10739 Set_Has_Delayed_Freeze (Atyp, False);
10741 -- We need to freeze the actual subtype immediately. This is
10742 -- needed because otherwise this Itype will not get frozen
10743 -- at all; it is always safe to freeze on creation because
10744 -- any associated types must be frozen at this point.
10746 -- On the other hand, if we are performing preanalysis on
10747 -- a conjured-up copy of a name (see calls to
10748 -- Preanalyze_Range in sem_ch5.adb) then we don't want
10749 -- to freeze Atyp, now or ever. In this case, the tree
10750 -- we eventually pass to the back end should contain no
10751 -- references to Atyp (and a freeze node would contain
10752 -- such a reference). That's why Expander_Active is tested.
10754 Freeze_Itype (Atyp, N);
10758 -- Otherwise we did not build a declaration, so return original
10765 -- For all remaining cases, the actual subtype is the same as
10766 -- the nominal type.
10771 end Get_Actual_Subtype;
10773 -------------------------------------
10774 -- Get_Actual_Subtype_If_Available --
10775 -------------------------------------
10777 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
10778 Typ : constant Entity_Id := Etype (N);
10781 -- If what we have is an identifier that references a subprogram
10782 -- formal, or a variable or constant object, then we get the actual
10783 -- subtype from the referenced entity if one has been built.
10785 if Nkind (N) = N_Identifier
10787 (Is_Formal (Entity (N))
10788 or else Ekind (Entity (N)) = E_Constant
10789 or else Ekind (Entity (N)) = E_Variable)
10790 and then Present (Actual_Subtype (Entity (N)))
10792 return Actual_Subtype (Entity (N));
10794 -- Otherwise the Etype of N is returned unchanged
10799 end Get_Actual_Subtype_If_Available;
10801 ------------------------
10802 -- Get_Body_From_Stub --
10803 ------------------------
10805 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
10807 return Proper_Body (Unit (Library_Unit (N)));
10808 end Get_Body_From_Stub;
10810 ---------------------
10811 -- Get_Cursor_Type --
10812 ---------------------
10814 function Get_Cursor_Type
10816 Typ : Entity_Id) return Entity_Id
10820 First_Op : Entity_Id;
10821 Cursor : Entity_Id;
10824 -- If error already detected, return
10826 if Error_Posted (Aspect) then
10830 -- The cursor type for an Iterable aspect is the return type of a
10831 -- non-overloaded First primitive operation. Locate association for
10834 Assoc := First (Component_Associations (Expression (Aspect)));
10835 First_Op := Any_Id;
10836 while Present (Assoc) loop
10837 if Chars (First (Choices (Assoc))) = Name_First then
10838 First_Op := Expression (Assoc);
10845 if First_Op = Any_Id then
10846 Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
10849 elsif not Analyzed (First_Op) then
10850 Analyze (First_Op);
10853 Cursor := Any_Type;
10855 -- Locate function with desired name and profile in scope of type
10856 -- In the rare case where the type is an integer type, a base type
10857 -- is created for it, check that the base type of the first formal
10858 -- of First matches the base type of the domain.
10860 Func := First_Entity (Scope (Typ));
10861 while Present (Func) loop
10862 if Chars (Func) = Chars (First_Op)
10863 and then Ekind (Func) = E_Function
10864 and then Present (First_Formal (Func))
10865 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ)
10866 and then No (Next_Formal (First_Formal (Func)))
10868 if Cursor /= Any_Type then
10870 ("operation First for iterable type must be unique", Aspect);
10873 Cursor := Etype (Func);
10877 Next_Entity (Func);
10880 -- If not found, no way to resolve remaining primitives
10882 if Cursor = Any_Type then
10884 ("primitive operation for Iterable type must appear in the same "
10885 & "list of declarations as the type", Aspect);
10889 end Get_Cursor_Type;
10891 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is
10893 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First));
10894 end Get_Cursor_Type;
10896 -------------------------------
10897 -- Get_Default_External_Name --
10898 -------------------------------
10900 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
10902 Get_Decoded_Name_String (Chars (E));
10904 if Opt.External_Name_Imp_Casing = Uppercase then
10905 Set_Casing (All_Upper_Case);
10907 Set_Casing (All_Lower_Case);
10911 Make_String_Literal (Sloc (E),
10912 Strval => String_From_Name_Buffer);
10913 end Get_Default_External_Name;
10915 --------------------------
10916 -- Get_Enclosing_Object --
10917 --------------------------
10919 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
10921 if Is_Entity_Name (N) then
10925 when N_Indexed_Component
10926 | N_Selected_Component
10929 -- If not generating code, a dereference may be left implicit.
10930 -- In thoses cases, return Empty.
10932 if Is_Access_Type (Etype (Prefix (N))) then
10935 return Get_Enclosing_Object (Prefix (N));
10938 when N_Type_Conversion =>
10939 return Get_Enclosing_Object (Expression (N));
10945 end Get_Enclosing_Object;
10947 ---------------------------
10948 -- Get_Enum_Lit_From_Pos --
10949 ---------------------------
10951 function Get_Enum_Lit_From_Pos
10954 Loc : Source_Ptr) return Node_Id
10956 Btyp : Entity_Id := Base_Type (T);
10961 -- In the case where the literal is of type Character, Wide_Character
10962 -- or Wide_Wide_Character or of a type derived from them, there needs
10963 -- to be some special handling since there is no explicit chain of
10964 -- literals to search. Instead, an N_Character_Literal node is created
10965 -- with the appropriate Char_Code and Chars fields.
10967 if Is_Standard_Character_Type (T) then
10968 Set_Character_Literal_Name (UI_To_CC (Pos));
10971 Make_Character_Literal (Loc,
10972 Chars => Name_Find,
10973 Char_Literal_Value => Pos);
10975 -- For all other cases, we have a complete table of literals, and
10976 -- we simply iterate through the chain of literal until the one
10977 -- with the desired position value is found.
10980 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
10981 Btyp := Full_View (Btyp);
10984 Lit := First_Literal (Btyp);
10986 -- Position in the enumeration type starts at 0
10989 raise Constraint_Error;
10992 for J in 1 .. UI_To_Int (Pos) loop
10993 Next_Literal (Lit);
10995 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error
10996 -- inside the loop to avoid calling Next_Literal on Empty.
10999 raise Constraint_Error;
11003 -- Create a new node from Lit, with source location provided by Loc
11004 -- if not equal to No_Location, or by copying the source location of
11009 if LLoc = No_Location then
11010 LLoc := Sloc (Lit);
11013 return New_Occurrence_Of (Lit, LLoc);
11015 end Get_Enum_Lit_From_Pos;
11017 ----------------------
11018 -- Get_Fullest_View --
11019 ----------------------
11021 function Get_Fullest_View
11023 Include_PAT : Boolean := True;
11024 Recurse : Boolean := True) return Entity_Id
11026 New_E : Entity_Id := Empty;
11029 -- Prevent cascaded errors
11035 -- Look at each kind of entity to see where we may need to go deeper.
11038 when Incomplete_Kind =>
11039 if From_Limited_With (E) then
11040 New_E := Non_Limited_View (E);
11041 elsif Present (Full_View (E)) then
11042 New_E := Full_View (E);
11043 elsif Ekind (E) = E_Incomplete_Subtype then
11044 New_E := Etype (E);
11047 when Private_Kind =>
11048 if Present (Underlying_Full_View (E)) then
11049 New_E := Underlying_Full_View (E);
11050 elsif Present (Full_View (E)) then
11051 New_E := Full_View (E);
11052 elsif Etype (E) /= E then
11053 New_E := Etype (E);
11057 if Include_PAT and then Present (Packed_Array_Impl_Type (E)) then
11058 New_E := Packed_Array_Impl_Type (E);
11061 when E_Record_Subtype =>
11062 if Present (Cloned_Subtype (E)) then
11063 New_E := Cloned_Subtype (E);
11066 when E_Class_Wide_Type =>
11067 New_E := Root_Type (E);
11069 when E_Class_Wide_Subtype =>
11070 if Present (Equivalent_Type (E)) then
11071 New_E := Equivalent_Type (E);
11072 elsif Present (Cloned_Subtype (E)) then
11073 New_E := Cloned_Subtype (E);
11076 when E_Protected_Subtype
11081 if Present (Corresponding_Record_Type (E)) then
11082 New_E := Corresponding_Record_Type (E);
11085 when E_Access_Protected_Subprogram_Type
11086 | E_Anonymous_Access_Protected_Subprogram_Type
11088 if Present (Equivalent_Type (E)) then
11089 New_E := Equivalent_Type (E);
11092 when E_Access_Subtype =>
11093 New_E := Base_Type (E);
11099 -- If we found a fuller view, either return it or recurse. Otherwise,
11100 -- return our input.
11102 return (if No (New_E) then E
11103 elsif Recurse then Get_Fullest_View (New_E, Include_PAT, Recurse)
11105 end Get_Fullest_View;
11107 ------------------------
11108 -- Get_Generic_Entity --
11109 ------------------------
11111 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
11112 Ent : constant Entity_Id := Entity (Name (N));
11114 if Present (Renamed_Entity (Ent)) then
11115 return Renamed_Entity (Ent);
11119 end Get_Generic_Entity;
11121 -------------------------------------
11122 -- Get_Incomplete_View_Of_Ancestor --
11123 -------------------------------------
11125 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
11126 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
11127 Par_Scope : Entity_Id;
11128 Par_Type : Entity_Id;
11131 -- The incomplete view of an ancestor is only relevant for private
11132 -- derived types in child units.
11134 if not Is_Derived_Type (E)
11135 or else not Is_Child_Unit (Cur_Unit)
11140 Par_Scope := Scope (Cur_Unit);
11141 if No (Par_Scope) then
11145 Par_Type := Etype (Base_Type (E));
11147 -- Traverse list of ancestor types until we find one declared in
11148 -- a parent or grandparent unit (two levels seem sufficient).
11150 while Present (Par_Type) loop
11151 if Scope (Par_Type) = Par_Scope
11152 or else Scope (Par_Type) = Scope (Par_Scope)
11156 elsif not Is_Derived_Type (Par_Type) then
11160 Par_Type := Etype (Base_Type (Par_Type));
11164 -- If none found, there is no relevant ancestor type.
11168 end Get_Incomplete_View_Of_Ancestor;
11170 ----------------------
11171 -- Get_Index_Bounds --
11172 ----------------------
11174 procedure Get_Index_Bounds
11178 Use_Full_View : Boolean := False)
11180 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id;
11181 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and
11182 -- Typ qualifies, the scalar range is obtained from the full view of the
11185 --------------------------
11186 -- Scalar_Range_Of_Type --
11187 --------------------------
11189 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is
11190 T : Entity_Id := Typ;
11193 if Use_Full_View and then Present (Full_View (T)) then
11194 T := Full_View (T);
11197 return Scalar_Range (T);
11198 end Scalar_Range_Of_Type;
11202 Kind : constant Node_Kind := Nkind (N);
11205 -- Start of processing for Get_Index_Bounds
11208 if Kind = N_Range then
11209 L := Low_Bound (N);
11210 H := High_Bound (N);
11212 elsif Kind = N_Subtype_Indication then
11213 Rng := Range_Expression (Constraint (N));
11215 if Rng = Error then
11221 L := Low_Bound (Range_Expression (Constraint (N)));
11222 H := High_Bound (Range_Expression (Constraint (N)));
11225 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
11226 Rng := Scalar_Range_Of_Type (Entity (N));
11228 if Error_Posted (Rng) then
11232 elsif Nkind (Rng) = N_Subtype_Indication then
11233 Get_Index_Bounds (Rng, L, H);
11236 L := Low_Bound (Rng);
11237 H := High_Bound (Rng);
11241 -- N is an expression, indicating a range with one value
11246 end Get_Index_Bounds;
11248 function Get_Index_Bounds
11250 Use_Full_View : Boolean := False) return Range_Nodes is
11251 Result : Range_Nodes;
11253 Get_Index_Bounds (N, Result.First, Result.Last, Use_Full_View);
11255 end Get_Index_Bounds;
11257 function Get_Index_Bounds
11259 Use_Full_View : Boolean := False) return Range_Values is
11260 Nodes : constant Range_Nodes := Get_Index_Bounds (N, Use_Full_View);
11262 return (Expr_Value (Nodes.First), Expr_Value (Nodes.Last));
11263 end Get_Index_Bounds;
11265 -----------------------------
11266 -- Get_Interfacing_Aspects --
11267 -----------------------------
11269 procedure Get_Interfacing_Aspects
11270 (Iface_Asp : Node_Id;
11271 Conv_Asp : out Node_Id;
11272 EN_Asp : out Node_Id;
11273 Expo_Asp : out Node_Id;
11274 Imp_Asp : out Node_Id;
11275 LN_Asp : out Node_Id;
11276 Do_Checks : Boolean := False)
11278 procedure Save_Or_Duplication_Error
11280 To : in out Node_Id);
11281 -- Save the value of aspect Asp in node To. If To already has a value,
11282 -- then this is considered a duplicate use of aspect. Emit an error if
11283 -- flag Do_Checks is set.
11285 -------------------------------
11286 -- Save_Or_Duplication_Error --
11287 -------------------------------
11289 procedure Save_Or_Duplication_Error
11291 To : in out Node_Id)
11294 -- Detect an extra aspect and issue an error
11296 if Present (To) then
11298 Error_Msg_Name_1 := Chars (Identifier (Asp));
11299 Error_Msg_Sloc := Sloc (To);
11300 Error_Msg_N ("aspect % previously given #", Asp);
11303 -- Otherwise capture the aspect
11308 end Save_Or_Duplication_Error;
11313 Asp_Id : Aspect_Id;
11315 -- The following variables capture each individual aspect
11317 Conv : Node_Id := Empty;
11318 EN : Node_Id := Empty;
11319 Expo : Node_Id := Empty;
11320 Imp : Node_Id := Empty;
11321 LN : Node_Id := Empty;
11323 -- Start of processing for Get_Interfacing_Aspects
11326 -- The input interfacing aspect should reside in an aspect specification
11329 pragma Assert (Is_List_Member (Iface_Asp));
11331 -- Examine the aspect specifications of the related entity. Find and
11332 -- capture all interfacing aspects. Detect duplicates and emit errors
11335 Asp := First (List_Containing (Iface_Asp));
11336 while Present (Asp) loop
11337 Asp_Id := Get_Aspect_Id (Asp);
11339 if Asp_Id = Aspect_Convention then
11340 Save_Or_Duplication_Error (Asp, Conv);
11342 elsif Asp_Id = Aspect_External_Name then
11343 Save_Or_Duplication_Error (Asp, EN);
11345 elsif Asp_Id = Aspect_Export then
11346 Save_Or_Duplication_Error (Asp, Expo);
11348 elsif Asp_Id = Aspect_Import then
11349 Save_Or_Duplication_Error (Asp, Imp);
11351 elsif Asp_Id = Aspect_Link_Name then
11352 Save_Or_Duplication_Error (Asp, LN);
11363 end Get_Interfacing_Aspects;
11365 ---------------------------------
11366 -- Get_Iterable_Type_Primitive --
11367 ---------------------------------
11369 function Get_Iterable_Type_Primitive
11371 Nam : Name_Id) return Entity_Id
11376 Nam in Name_Element
11383 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
11391 Assoc := First (Component_Associations (Funcs));
11392 while Present (Assoc) loop
11393 if Chars (First (Choices (Assoc))) = Nam then
11394 return Entity (Expression (Assoc));
11402 end Get_Iterable_Type_Primitive;
11404 ---------------------------
11405 -- Get_Library_Unit_Name --
11406 ---------------------------
11408 function Get_Library_Unit_Name (Decl_Node : Node_Id) return String_Id is
11409 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
11410 Buf : Bounded_String;
11412 Get_Unit_Name_String (Buf, Unit_Name_Id);
11414 -- Remove the last seven characters (" (spec)" or " (body)")
11416 Buf.Length := Buf.Length - 7;
11417 pragma Assert (Buf.Chars (Buf.Length + 1) = ' ');
11419 return String_From_Name_Buffer (Buf);
11420 end Get_Library_Unit_Name;
11422 --------------------------
11423 -- Get_Max_Queue_Length --
11424 --------------------------
11426 function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
11427 pragma Assert (Is_Entry (Id));
11428 Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
11432 -- A value of 0 or -1 represents no maximum specified, and entries and
11433 -- entry families with no Max_Queue_Length aspect or pragma default to
11436 if not Present (Prag) then
11441 (Expression (First (Pragma_Argument_Associations (Prag))));
11443 -- Since -1 and 0 are equivalent, return 0 for instances of -1 for
11451 end Get_Max_Queue_Length;
11453 ------------------------
11454 -- Get_Name_Entity_Id --
11455 ------------------------
11457 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
11459 return Entity_Id (Get_Name_Table_Int (Id));
11460 end Get_Name_Entity_Id;
11462 ------------------------------
11463 -- Get_Name_From_CTC_Pragma --
11464 ------------------------------
11466 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
11467 Arg : constant Node_Id :=
11468 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
11470 return Strval (Expr_Value_S (Arg));
11471 end Get_Name_From_CTC_Pragma;
11473 -----------------------
11474 -- Get_Parent_Entity --
11475 -----------------------
11477 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
11479 if Nkind (Unit) = N_Package_Body
11480 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
11482 return Defining_Entity
11483 (Specification (Instance_Spec (Original_Node (Unit))));
11484 elsif Nkind (Unit) = N_Package_Instantiation then
11485 return Defining_Entity (Specification (Instance_Spec (Unit)));
11487 return Defining_Entity (Unit);
11489 end Get_Parent_Entity;
11491 -------------------
11492 -- Get_Pragma_Id --
11493 -------------------
11495 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
11497 return Get_Pragma_Id (Pragma_Name_Unmapped (N));
11500 ------------------------
11501 -- Get_Qualified_Name --
11502 ------------------------
11504 function Get_Qualified_Name
11506 Suffix : Entity_Id := Empty) return Name_Id
11508 Suffix_Nam : Name_Id := No_Name;
11511 if Present (Suffix) then
11512 Suffix_Nam := Chars (Suffix);
11515 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id));
11516 end Get_Qualified_Name;
11518 function Get_Qualified_Name
11520 Suffix : Name_Id := No_Name;
11521 Scop : Entity_Id := Current_Scope) return Name_Id
11523 procedure Add_Scope (S : Entity_Id);
11524 -- Add the fully qualified form of scope S to the name buffer. The
11532 procedure Add_Scope (S : Entity_Id) is
11537 elsif S = Standard_Standard then
11541 Add_Scope (Scope (S));
11542 Get_Name_String_And_Append (Chars (S));
11543 Add_Str_To_Name_Buffer ("__");
11547 -- Start of processing for Get_Qualified_Name
11553 -- Append the base name after all scopes have been chained
11555 Get_Name_String_And_Append (Nam);
11557 -- Append the suffix (if present)
11559 if Suffix /= No_Name then
11560 Add_Str_To_Name_Buffer ("__");
11561 Get_Name_String_And_Append (Suffix);
11565 end Get_Qualified_Name;
11567 -----------------------
11568 -- Get_Reason_String --
11569 -----------------------
11571 procedure Get_Reason_String (N : Node_Id) is
11573 if Nkind (N) = N_String_Literal then
11574 Store_String_Chars (Strval (N));
11576 elsif Nkind (N) = N_Op_Concat then
11577 Get_Reason_String (Left_Opnd (N));
11578 Get_Reason_String (Right_Opnd (N));
11580 -- If not of required form, error
11584 ("Reason for pragma Warnings has wrong form", N);
11586 ("\must be string literal or concatenation of string literals", N);
11589 end Get_Reason_String;
11591 --------------------------------
11592 -- Get_Reference_Discriminant --
11593 --------------------------------
11595 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is
11599 D := First_Discriminant (Typ);
11600 while Present (D) loop
11601 if Has_Implicit_Dereference (D) then
11604 Next_Discriminant (D);
11608 end Get_Reference_Discriminant;
11610 ---------------------------
11611 -- Get_Referenced_Object --
11612 ---------------------------
11614 function Get_Referenced_Object (N : Node_Id) return Node_Id is
11619 while Is_Entity_Name (R)
11620 and then Is_Object (Entity (R))
11621 and then Present (Renamed_Object (Entity (R)))
11623 R := Renamed_Object (Entity (R));
11627 end Get_Referenced_Object;
11629 ------------------------
11630 -- Get_Renamed_Entity --
11631 ------------------------
11633 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
11634 R : Entity_Id := E;
11636 while Present (Renamed_Entity (R)) loop
11637 R := Renamed_Entity (R);
11641 end Get_Renamed_Entity;
11643 -----------------------
11644 -- Get_Return_Object --
11645 -----------------------
11647 function Get_Return_Object (N : Node_Id) return Entity_Id is
11651 Decl := First (Return_Object_Declarations (N));
11652 while Present (Decl) loop
11653 exit when Nkind (Decl) = N_Object_Declaration
11654 and then Is_Return_Object (Defining_Identifier (Decl));
11658 pragma Assert (Present (Decl));
11659 return Defining_Identifier (Decl);
11660 end Get_Return_Object;
11662 ---------------------------
11663 -- Get_Subprogram_Entity --
11664 ---------------------------
11666 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
11668 Subp_Id : Entity_Id;
11671 if Nkind (Nod) = N_Accept_Statement then
11672 Subp := Entry_Direct_Name (Nod);
11674 elsif Nkind (Nod) = N_Slice then
11675 Subp := Prefix (Nod);
11678 Subp := Name (Nod);
11681 -- Strip the subprogram call
11684 if Nkind (Subp) in N_Explicit_Dereference
11685 | N_Indexed_Component
11686 | N_Selected_Component
11688 Subp := Prefix (Subp);
11690 elsif Nkind (Subp) in N_Type_Conversion
11691 | N_Unchecked_Type_Conversion
11693 Subp := Expression (Subp);
11700 -- Extract the entity of the subprogram call
11702 if Is_Entity_Name (Subp) then
11703 Subp_Id := Entity (Subp);
11705 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
11706 Subp_Id := Directly_Designated_Type (Subp_Id);
11709 if Is_Subprogram (Subp_Id) then
11715 -- The search did not find a construct that denotes a subprogram
11720 end Get_Subprogram_Entity;
11722 -----------------------------
11723 -- Get_Task_Body_Procedure --
11724 -----------------------------
11726 function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is
11728 -- Note: A task type may be the completion of a private type with
11729 -- discriminants. When performing elaboration checks on a task
11730 -- declaration, the current view of the type may be the private one,
11731 -- and the procedure that holds the body of the task is held in its
11732 -- underlying type.
11734 -- This is an odd function, why not have Task_Body_Procedure do
11735 -- the following digging???
11737 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
11738 end Get_Task_Body_Procedure;
11740 -------------------------------
11741 -- Get_User_Defined_Equality --
11742 -------------------------------
11744 function Get_User_Defined_Equality (E : Entity_Id) return Entity_Id is
11748 Prim := First_Elmt (Collect_Primitive_Operations (E));
11749 while Present (Prim) loop
11750 if Is_User_Defined_Equality (Node (Prim)) then
11751 return Node (Prim);
11758 end Get_User_Defined_Equality;
11764 procedure Get_Views
11766 Priv_Typ : out Entity_Id;
11767 Full_Typ : out Entity_Id;
11768 UFull_Typ : out Entity_Id;
11769 CRec_Typ : out Entity_Id)
11771 IP_View : Entity_Id;
11774 -- Assume that none of the views can be recovered
11778 UFull_Typ := Empty;
11781 -- The input type is the corresponding record type of a protected or a
11784 if Ekind (Typ) = E_Record_Type
11785 and then Is_Concurrent_Record_Type (Typ)
11788 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
11789 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
11791 -- Otherwise the input type denotes an arbitrary type
11794 IP_View := Incomplete_Or_Partial_View (Typ);
11796 -- The input type denotes the full view of a private type
11798 if Present (IP_View) then
11799 Priv_Typ := IP_View;
11802 -- The input type is a private type
11804 elsif Is_Private_Type (Typ) then
11806 Full_Typ := Full_View (Priv_Typ);
11808 -- Otherwise the input type does not have any views
11814 if Present (Full_Typ) and then Is_Private_Type (Full_Typ) then
11815 UFull_Typ := Underlying_Full_View (Full_Typ);
11817 if Present (UFull_Typ)
11818 and then Ekind (UFull_Typ) in E_Protected_Type | E_Task_Type
11820 CRec_Typ := Corresponding_Record_Type (UFull_Typ);
11824 if Present (Full_Typ)
11825 and then Ekind (Full_Typ) in E_Protected_Type | E_Task_Type
11827 CRec_Typ := Corresponding_Record_Type (Full_Typ);
11833 -----------------------
11834 -- Has_Access_Values --
11835 -----------------------
11837 function Has_Access_Values (T : Entity_Id) return Boolean
11839 Typ : constant Entity_Id := Underlying_Type (T);
11842 -- Case of a private type which is not completed yet. This can only
11843 -- happen in the case of a generic formal type appearing directly, or
11844 -- as a component of the type to which this function is being applied
11845 -- at the top level. Return False in this case, since we certainly do
11846 -- not know that the type contains access types.
11851 elsif Is_Access_Type (Typ) then
11854 elsif Is_Array_Type (Typ) then
11855 return Has_Access_Values (Component_Type (Typ));
11857 elsif Is_Record_Type (Typ) then
11862 -- Loop to check components
11864 Comp := First_Component_Or_Discriminant (Typ);
11865 while Present (Comp) loop
11867 -- Check for access component, tag field does not count, even
11868 -- though it is implemented internally using an access type.
11870 if Has_Access_Values (Etype (Comp))
11871 and then Chars (Comp) /= Name_uTag
11876 Next_Component_Or_Discriminant (Comp);
11885 end Has_Access_Values;
11887 ---------------------------------------
11888 -- Has_Anonymous_Access_Discriminant --
11889 ---------------------------------------
11891 function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean
11896 if not Has_Discriminants (Typ) then
11900 Disc := First_Discriminant (Typ);
11901 while Present (Disc) loop
11902 if Ekind (Etype (Disc)) = E_Anonymous_Access_Type then
11906 Next_Discriminant (Disc);
11910 end Has_Anonymous_Access_Discriminant;
11912 ------------------------------
11913 -- Has_Compatible_Alignment --
11914 ------------------------------
11916 function Has_Compatible_Alignment
11919 Layout_Done : Boolean) return Alignment_Result
11921 function Has_Compatible_Alignment_Internal
11924 Layout_Done : Boolean;
11925 Default : Alignment_Result) return Alignment_Result;
11926 -- This is the internal recursive function that actually does the work.
11927 -- There is one additional parameter, which says what the result should
11928 -- be if no alignment information is found, and there is no definite
11929 -- indication of compatible alignments. At the outer level, this is set
11930 -- to Unknown, but for internal recursive calls in the case where types
11931 -- are known to be correct, it is set to Known_Compatible.
11933 ---------------------------------------
11934 -- Has_Compatible_Alignment_Internal --
11935 ---------------------------------------
11937 function Has_Compatible_Alignment_Internal
11940 Layout_Done : Boolean;
11941 Default : Alignment_Result) return Alignment_Result
11943 Result : Alignment_Result := Known_Compatible;
11944 -- Holds the current status of the result. Note that once a value of
11945 -- Known_Incompatible is set, it is sticky and does not get changed
11946 -- to Unknown (the value in Result only gets worse as we go along,
11949 Offs : Uint := No_Uint;
11950 -- Set to a factor of the offset from the base object when Expr is a
11951 -- selected or indexed component, based on Component_Bit_Offset and
11952 -- Component_Size respectively. A negative value is used to represent
11953 -- a value that is not known at compile time.
11955 procedure Check_Prefix;
11956 -- Checks the prefix recursively in the case where the expression
11957 -- is an indexed or selected component.
11959 procedure Set_Result (R : Alignment_Result);
11960 -- If R represents a worse outcome (unknown instead of known
11961 -- compatible, or known incompatible), then set Result to R.
11967 procedure Check_Prefix is
11969 -- The subtlety here is that in doing a recursive call to check
11970 -- the prefix, we have to decide what to do in the case where we
11971 -- don't find any specific indication of an alignment problem.
11973 -- At the outer level, we normally set Unknown as the result in
11974 -- this case, since we can only set Known_Compatible if we really
11975 -- know that the alignment value is OK, but for the recursive
11976 -- call, in the case where the types match, and we have not
11977 -- specified a peculiar alignment for the object, we are only
11978 -- concerned about suspicious rep clauses, the default case does
11979 -- not affect us, since the compiler will, in the absence of such
11980 -- rep clauses, ensure that the alignment is correct.
11982 if Default = Known_Compatible
11984 (Etype (Obj) = Etype (Expr)
11985 and then (not Known_Alignment (Obj)
11987 Alignment (Obj) = Alignment (Etype (Obj))))
11990 (Has_Compatible_Alignment_Internal
11991 (Obj, Prefix (Expr), Layout_Done, Known_Compatible));
11993 -- In all other cases, we need a full check on the prefix
11997 (Has_Compatible_Alignment_Internal
11998 (Obj, Prefix (Expr), Layout_Done, Unknown));
12006 procedure Set_Result (R : Alignment_Result) is
12013 -- Start of processing for Has_Compatible_Alignment_Internal
12016 -- If Expr is a selected component, we must make sure there is no
12017 -- potentially troublesome component clause and that the record is
12018 -- not packed if the layout is not done.
12020 if Nkind (Expr) = N_Selected_Component then
12022 -- Packing generates unknown alignment if layout is not done
12024 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then
12025 Set_Result (Unknown);
12028 -- Check prefix and component offset
12031 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
12033 -- If Expr is an indexed component, we must make sure there is no
12034 -- potentially troublesome Component_Size clause and that the array
12035 -- is not bit-packed if the layout is not done.
12037 elsif Nkind (Expr) = N_Indexed_Component then
12039 Typ : constant Entity_Id := Etype (Prefix (Expr));
12042 -- Packing generates unknown alignment if layout is not done
12044 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then
12045 Set_Result (Unknown);
12048 -- Check prefix and component offset (or at least size)
12051 Offs := Indexed_Component_Bit_Offset (Expr);
12053 Offs := Component_Size (Typ);
12058 -- If we have a null offset, the result is entirely determined by
12059 -- the base object and has already been computed recursively.
12061 if Present (Offs) and then Offs = Uint_0 then
12064 -- Case where we know the alignment of the object
12066 elsif Known_Alignment (Obj) then
12068 ObjA : constant Uint := Alignment (Obj);
12069 ExpA : Uint := No_Uint;
12070 SizA : Uint := No_Uint;
12073 -- If alignment of Obj is 1, then we are always OK
12076 Set_Result (Known_Compatible);
12078 -- Alignment of Obj is greater than 1, so we need to check
12081 -- If we have an offset, see if it is compatible
12083 if Present (Offs) and then Offs > Uint_0 then
12084 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
12085 Set_Result (Known_Incompatible);
12088 -- See if Expr is an object with known alignment
12090 elsif Is_Entity_Name (Expr)
12091 and then Known_Alignment (Entity (Expr))
12094 ExpA := Alignment (Entity (Expr));
12096 -- Otherwise, we can use the alignment of the type of Expr
12097 -- given that we already checked for discombobulating rep
12098 -- clauses for the cases of indexed and selected components
12101 elsif Known_Alignment (Etype (Expr)) then
12102 ExpA := Alignment (Etype (Expr));
12104 -- Otherwise the alignment is unknown
12107 Set_Result (Default);
12110 -- If we got an alignment, see if it is acceptable
12112 if Present (ExpA) and then ExpA < ObjA then
12113 Set_Result (Known_Incompatible);
12116 -- If Expr is a component or an entire object with a known
12117 -- alignment, then we are fine. Otherwise, if its size is
12118 -- known, it must be big enough for the required alignment.
12120 if Present (Offs) then
12123 -- See if Expr is an object with known size
12125 elsif Is_Entity_Name (Expr)
12126 and then Known_Static_Esize (Entity (Expr))
12128 SizA := Esize (Entity (Expr));
12130 -- Otherwise, we check the object size of the Expr type
12132 elsif Known_Static_Esize (Etype (Expr)) then
12133 SizA := Esize (Etype (Expr));
12136 -- If we got a size, see if it is a multiple of the Obj
12137 -- alignment; if not, then the alignment cannot be
12138 -- acceptable, since the size is always a multiple of the
12141 if Present (SizA) then
12142 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
12143 Set_Result (Known_Incompatible);
12149 -- If we do not know required alignment, any non-zero offset is a
12150 -- potential problem (but certainly may be OK, so result is unknown).
12152 elsif Present (Offs) then
12153 Set_Result (Unknown);
12155 -- If we can't find the result by direct comparison of alignment
12156 -- values, then there is still one case that we can determine known
12157 -- result, and that is when we can determine that the types are the
12158 -- same, and no alignments are specified. Then we known that the
12159 -- alignments are compatible, even if we don't know the alignment
12160 -- value in the front end.
12162 elsif Etype (Obj) = Etype (Expr) then
12164 -- Types are the same, but we have to check for possible size
12165 -- and alignments on the Expr object that may make the alignment
12166 -- different, even though the types are the same.
12168 if Is_Entity_Name (Expr) then
12170 -- First check alignment of the Expr object. Any alignment less
12171 -- than Maximum_Alignment is worrisome since this is the case
12172 -- where we do not know the alignment of Obj.
12174 if Known_Alignment (Entity (Expr))
12175 and then Alignment (Entity (Expr)) < Ttypes.Maximum_Alignment
12177 Set_Result (Unknown);
12179 -- Now check size of Expr object. Any size that is not an even
12180 -- multiple of Maximum_Alignment is also worrisome since it
12181 -- may cause the alignment of the object to be less than the
12182 -- alignment of the type.
12184 elsif Known_Static_Esize (Entity (Expr))
12186 Esize (Entity (Expr)) mod
12187 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)
12190 Set_Result (Unknown);
12192 -- Otherwise same type is decisive
12195 Set_Result (Known_Compatible);
12199 -- Another case to deal with is when there is an explicit size or
12200 -- alignment clause when the types are not the same. If so, then the
12201 -- result is Unknown. We don't need to do this test if the Default is
12202 -- Unknown, since that result will be set in any case.
12204 elsif Default /= Unknown
12205 and then (Has_Size_Clause (Etype (Expr))
12207 Has_Alignment_Clause (Etype (Expr)))
12209 Set_Result (Unknown);
12211 -- If no indication found, set default
12214 Set_Result (Default);
12217 -- Return worst result found
12220 end Has_Compatible_Alignment_Internal;
12222 -- Start of processing for Has_Compatible_Alignment
12225 -- If Obj has no specified alignment, then set alignment from the type
12226 -- alignment. Perhaps we should always do this, but for sure we should
12227 -- do it when there is an address clause since we can do more if the
12228 -- alignment is known.
12230 if not Known_Alignment (Obj) and then Known_Alignment (Etype (Obj)) then
12231 Set_Alignment (Obj, Alignment (Etype (Obj)));
12234 -- Now do the internal call that does all the work
12237 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown);
12238 end Has_Compatible_Alignment;
12240 ----------------------
12241 -- Has_Declarations --
12242 ----------------------
12244 function Has_Declarations (N : Node_Id) return Boolean is
12246 return Nkind (N) in N_Accept_Statement
12247 | N_Block_Statement
12248 | N_Compilation_Unit_Aux
12252 | N_Subprogram_Body
12254 | N_Package_Specification;
12255 end Has_Declarations;
12257 ---------------------------------
12258 -- Has_Defaulted_Discriminants --
12259 ---------------------------------
12261 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
12263 return Has_Discriminants (Typ)
12264 and then Present (Discriminant_Default_Value
12265 (First_Discriminant (Typ)));
12266 end Has_Defaulted_Discriminants;
12268 -------------------
12269 -- Has_Denormals --
12270 -------------------
12272 function Has_Denormals (E : Entity_Id) return Boolean is
12274 return Is_Floating_Point_Type (E) and then Denorm_On_Target;
12277 -------------------------------------------
12278 -- Has_Discriminant_Dependent_Constraint --
12279 -------------------------------------------
12281 function Has_Discriminant_Dependent_Constraint
12282 (Comp : Entity_Id) return Boolean
12284 Comp_Decl : constant Node_Id := Parent (Comp);
12285 Subt_Indic : Node_Id;
12290 -- Discriminants can't depend on discriminants
12292 if Ekind (Comp) = E_Discriminant then
12296 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
12298 if Nkind (Subt_Indic) = N_Subtype_Indication then
12299 Constr := Constraint (Subt_Indic);
12301 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
12302 Assn := First (Constraints (Constr));
12303 while Present (Assn) loop
12304 case Nkind (Assn) is
12307 | N_Subtype_Indication
12309 if Depends_On_Discriminant (Assn) then
12313 when N_Discriminant_Association =>
12314 if Depends_On_Discriminant (Expression (Assn)) then
12329 end Has_Discriminant_Dependent_Constraint;
12331 --------------------------------------
12332 -- Has_Effectively_Volatile_Profile --
12333 --------------------------------------
12335 function Has_Effectively_Volatile_Profile
12336 (Subp_Id : Entity_Id) return Boolean
12338 Formal : Entity_Id;
12341 -- Inspect the formal parameters looking for an effectively volatile
12342 -- type for reading.
12344 Formal := First_Formal (Subp_Id);
12345 while Present (Formal) loop
12346 if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then
12350 Next_Formal (Formal);
12353 -- Inspect the return type of functions
12355 if Ekind (Subp_Id) in E_Function | E_Generic_Function
12356 and then Is_Effectively_Volatile_For_Reading (Etype (Subp_Id))
12362 end Has_Effectively_Volatile_Profile;
12364 --------------------------
12365 -- Has_Enabled_Property --
12366 --------------------------
12368 function Has_Enabled_Property
12369 (Item_Id : Entity_Id;
12370 Property : Name_Id) return Boolean
12372 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean;
12373 -- Determine whether a protected type or variable denoted by Item_Id
12374 -- has the property enabled.
12376 function State_Has_Enabled_Property return Boolean;
12377 -- Determine whether a state denoted by Item_Id has the property enabled
12379 function Type_Or_Variable_Has_Enabled_Property
12380 (Item_Id : Entity_Id) return Boolean;
12381 -- Determine whether type or variable denoted by Item_Id has the
12382 -- property enabled.
12384 -----------------------------------------------------
12385 -- Protected_Type_Or_Variable_Has_Enabled_Property --
12386 -----------------------------------------------------
12388 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean
12391 -- Protected entities always have the properties Async_Readers and
12392 -- Async_Writers (SPARK RM 7.1.2(16)).
12394 if Property = Name_Async_Readers
12395 or else Property = Name_Async_Writers
12399 -- Protected objects that have Part_Of components also inherit their
12400 -- properties Effective_Reads and Effective_Writes
12401 -- (SPARK RM 7.1.2(16)).
12403 elsif Is_Single_Protected_Object (Item_Id) then
12405 Constit_Elmt : Elmt_Id;
12406 Constit_Id : Entity_Id;
12407 Constits : constant Elist_Id
12408 := Part_Of_Constituents (Item_Id);
12410 if Present (Constits) then
12411 Constit_Elmt := First_Elmt (Constits);
12412 while Present (Constit_Elmt) loop
12413 Constit_Id := Node (Constit_Elmt);
12415 if Has_Enabled_Property (Constit_Id, Property) then
12419 Next_Elmt (Constit_Elmt);
12426 end Protected_Type_Or_Variable_Has_Enabled_Property;
12428 --------------------------------
12429 -- State_Has_Enabled_Property --
12430 --------------------------------
12432 function State_Has_Enabled_Property return Boolean is
12433 Decl : constant Node_Id := Parent (Item_Id);
12435 procedure Find_Simple_Properties
12436 (Has_External : out Boolean;
12437 Has_Synchronous : out Boolean);
12438 -- Extract the simple properties associated with declaration Decl
12440 function Is_Enabled_External_Property return Boolean;
12441 -- Determine whether property Property appears within the external
12442 -- property list of declaration Decl, and return its status.
12444 ----------------------------
12445 -- Find_Simple_Properties --
12446 ----------------------------
12448 procedure Find_Simple_Properties
12449 (Has_External : out Boolean;
12450 Has_Synchronous : out Boolean)
12455 -- Assume that none of the properties are available
12457 Has_External := False;
12458 Has_Synchronous := False;
12460 Opt := First (Expressions (Decl));
12461 while Present (Opt) loop
12462 if Nkind (Opt) = N_Identifier then
12463 if Chars (Opt) = Name_External then
12464 Has_External := True;
12466 elsif Chars (Opt) = Name_Synchronous then
12467 Has_Synchronous := True;
12473 end Find_Simple_Properties;
12475 ----------------------------------
12476 -- Is_Enabled_External_Property --
12477 ----------------------------------
12479 function Is_Enabled_External_Property return Boolean is
12483 Prop_Nam : Node_Id;
12487 Opt := First (Component_Associations (Decl));
12488 while Present (Opt) loop
12489 Opt_Nam := First (Choices (Opt));
12491 if Nkind (Opt_Nam) = N_Identifier
12492 and then Chars (Opt_Nam) = Name_External
12494 Props := Expression (Opt);
12496 -- Multiple properties appear as an aggregate
12498 if Nkind (Props) = N_Aggregate then
12500 -- Simple property form
12502 Prop := First (Expressions (Props));
12503 while Present (Prop) loop
12504 if Chars (Prop) = Property then
12511 -- Property with expression form
12513 Prop := First (Component_Associations (Props));
12514 while Present (Prop) loop
12515 Prop_Nam := First (Choices (Prop));
12517 -- The property can be represented in two ways:
12518 -- others => <value>
12519 -- <property> => <value>
12521 if Nkind (Prop_Nam) = N_Others_Choice
12522 or else (Nkind (Prop_Nam) = N_Identifier
12523 and then Chars (Prop_Nam) = Property)
12525 return Is_True (Expr_Value (Expression (Prop)));
12534 return Chars (Props) = Property;
12542 end Is_Enabled_External_Property;
12546 Has_External : Boolean;
12547 Has_Synchronous : Boolean;
12549 -- Start of processing for State_Has_Enabled_Property
12552 -- The declaration of an external abstract state appears as an
12553 -- extension aggregate. If this is not the case, properties can
12556 if Nkind (Decl) /= N_Extension_Aggregate then
12560 Find_Simple_Properties (Has_External, Has_Synchronous);
12562 -- Simple option External enables all properties (SPARK RM 7.1.2(2))
12564 if Has_External then
12567 -- Option External may enable or disable specific properties
12569 elsif Is_Enabled_External_Property then
12572 -- Simple option Synchronous
12574 -- enables disables
12575 -- Async_Readers Effective_Reads
12576 -- Async_Writers Effective_Writes
12578 -- Note that both forms of External have higher precedence than
12579 -- Synchronous (SPARK RM 7.1.4(9)).
12581 elsif Has_Synchronous then
12582 return Property in Name_Async_Readers | Name_Async_Writers;
12586 end State_Has_Enabled_Property;
12588 -------------------------------------------
12589 -- Type_Or_Variable_Has_Enabled_Property --
12590 -------------------------------------------
12592 function Type_Or_Variable_Has_Enabled_Property
12593 (Item_Id : Entity_Id) return Boolean
12595 AR : constant Node_Id :=
12596 Get_Pragma (Item_Id, Pragma_Async_Readers);
12597 AW : constant Node_Id :=
12598 Get_Pragma (Item_Id, Pragma_Async_Writers);
12599 ER : constant Node_Id :=
12600 Get_Pragma (Item_Id, Pragma_Effective_Reads);
12601 EW : constant Node_Id :=
12602 Get_Pragma (Item_Id, Pragma_Effective_Writes);
12604 Is_Derived_Type_With_Volatile_Parent_Type : constant Boolean :=
12605 Is_Derived_Type (Item_Id)
12606 and then Is_Effectively_Volatile (Etype (Base_Type (Item_Id)));
12609 -- A non-effectively volatile object can never possess external
12612 if not Is_Effectively_Volatile (Item_Id) then
12615 -- External properties related to variables come in two flavors -
12616 -- explicit and implicit. The explicit case is characterized by the
12617 -- presence of a property pragma with an optional Boolean flag. The
12618 -- property is enabled when the flag evaluates to True or the flag is
12619 -- missing altogether.
12621 elsif Property = Name_Async_Readers and then Present (AR) then
12622 return Is_Enabled_Pragma (AR);
12624 elsif Property = Name_Async_Writers and then Present (AW) then
12625 return Is_Enabled_Pragma (AW);
12627 elsif Property = Name_Effective_Reads and then Present (ER) then
12628 return Is_Enabled_Pragma (ER);
12630 elsif Property = Name_Effective_Writes and then Present (EW) then
12631 return Is_Enabled_Pragma (EW);
12633 -- If other properties are set explicitly, then this one is set
12634 -- implicitly to False, except in the case of a derived type
12635 -- whose parent type is volatile (in that case, we will inherit
12636 -- from the parent type, below).
12638 elsif (Present (AR)
12639 or else Present (AW)
12640 or else Present (ER)
12641 or else Present (EW))
12642 and then not Is_Derived_Type_With_Volatile_Parent_Type
12646 -- For a private type (including subtype of a private types), look at
12649 elsif Is_Private_Type (Item_Id) and then Present (Full_View (Item_Id))
12651 return Type_Or_Variable_Has_Enabled_Property (Full_View (Item_Id));
12653 -- For a derived type whose parent type is volatile, the
12654 -- property may be inherited (but ignore a non-volatile parent).
12656 elsif Is_Derived_Type_With_Volatile_Parent_Type then
12657 return Type_Or_Variable_Has_Enabled_Property
12658 (First_Subtype (Etype (Base_Type (Item_Id))));
12660 -- For a subtype, the property will be inherited from its base type.
12662 elsif Is_Type (Item_Id)
12663 and then not Is_Base_Type (Item_Id)
12665 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id));
12667 -- If not specified explicitly for an object and its type
12668 -- is effectively volatile, then take result from the type.
12670 elsif Is_Object (Item_Id)
12671 and then Is_Effectively_Volatile (Etype (Item_Id))
12673 return Has_Enabled_Property (Etype (Item_Id), Property);
12675 -- The implicit case lacks all property pragmas
12677 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
12678 if Is_Protected_Type (Etype (Item_Id)) then
12679 return Protected_Type_Or_Variable_Has_Enabled_Property;
12687 end Type_Or_Variable_Has_Enabled_Property;
12689 -- Start of processing for Has_Enabled_Property
12692 -- Abstract states and variables have a flexible scheme of specifying
12693 -- external properties.
12695 if Ekind (Item_Id) = E_Abstract_State then
12696 return State_Has_Enabled_Property;
12698 elsif Ekind (Item_Id) in E_Variable | E_Constant then
12699 return Type_Or_Variable_Has_Enabled_Property (Item_Id);
12701 -- Other objects can only inherit properties through their type. We
12702 -- cannot call directly Type_Or_Variable_Has_Enabled_Property on
12703 -- these as they don't have contracts attached, which is expected by
12706 elsif Is_Object (Item_Id) then
12707 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id));
12709 elsif Is_Type (Item_Id) then
12710 return Type_Or_Variable_Has_Enabled_Property
12711 (Item_Id => First_Subtype (Item_Id));
12713 -- Otherwise a property is enabled when the related item is effectively
12717 return Is_Effectively_Volatile (Item_Id);
12719 end Has_Enabled_Property;
12721 -------------------------------------
12722 -- Has_Full_Default_Initialization --
12723 -------------------------------------
12725 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
12729 -- A type subject to pragma Default_Initial_Condition may be fully
12730 -- default initialized depending on inheritance and the argument of
12731 -- the pragma. Since any type may act as the full view of a private
12732 -- type, this check must be performed prior to the specialized tests
12735 if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then
12739 -- A scalar type is fully default initialized if it is subject to aspect
12742 if Is_Scalar_Type (Typ) then
12743 return Has_Default_Aspect (Typ);
12745 -- An access type is fully default initialized by default
12747 elsif Is_Access_Type (Typ) then
12750 -- An array type is fully default initialized if its element type is
12751 -- scalar and the array type carries aspect Default_Component_Value or
12752 -- the element type is fully default initialized.
12754 elsif Is_Array_Type (Typ) then
12756 Has_Default_Aspect (Typ)
12757 or else Has_Full_Default_Initialization (Component_Type (Typ));
12759 -- A protected type, record type, or type extension is fully default
12760 -- initialized if all its components either carry an initialization
12761 -- expression or have a type that is fully default initialized. The
12762 -- parent type of a type extension must be fully default initialized.
12764 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
12766 -- Inspect all entities defined in the scope of the type, looking for
12767 -- uninitialized components.
12769 Comp := First_Component (Typ);
12770 while Present (Comp) loop
12771 if Comes_From_Source (Comp)
12772 and then No (Expression (Parent (Comp)))
12773 and then not Has_Full_Default_Initialization (Etype (Comp))
12778 Next_Component (Comp);
12781 -- Ensure that the parent type of a type extension is fully default
12784 if Etype (Typ) /= Typ
12785 and then not Has_Full_Default_Initialization (Etype (Typ))
12790 -- If we get here, then all components and parent portion are fully
12791 -- default initialized.
12795 -- A task type is fully default initialized by default
12797 elsif Is_Task_Type (Typ) then
12800 -- Otherwise the type is not fully default initialized
12805 end Has_Full_Default_Initialization;
12807 -----------------------------------------------
12808 -- Has_Fully_Default_Initializing_DIC_Pragma --
12809 -----------------------------------------------
12811 function Has_Fully_Default_Initializing_DIC_Pragma
12812 (Typ : Entity_Id) return Boolean
12818 -- A type that inherits pragma Default_Initial_Condition from a parent
12819 -- type is automatically fully default initialized.
12821 if Has_Inherited_DIC (Typ) then
12824 -- Otherwise the type is fully default initialized only when the pragma
12825 -- appears without an argument, or the argument is non-null.
12827 elsif Has_Own_DIC (Typ) then
12828 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
12829 pragma Assert (Present (Prag));
12830 Args := Pragma_Argument_Associations (Prag);
12832 -- The pragma appears without an argument in which case it defaults
12838 -- The pragma appears with a non-null expression
12840 elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then
12846 end Has_Fully_Default_Initializing_DIC_Pragma;
12848 ---------------------------------
12849 -- Has_Inferable_Discriminants --
12850 ---------------------------------
12852 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
12854 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
12855 -- Determines whether the left-most prefix of a selected component is a
12856 -- formal parameter in a subprogram. Assumes N is a selected component.
12858 --------------------------------
12859 -- Prefix_Is_Formal_Parameter --
12860 --------------------------------
12862 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
12863 Sel_Comp : Node_Id;
12866 -- Move to the left-most prefix by climbing up the tree
12869 while Present (Parent (Sel_Comp))
12870 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
12872 Sel_Comp := Parent (Sel_Comp);
12875 return Is_Formal (Entity (Prefix (Sel_Comp)));
12876 end Prefix_Is_Formal_Parameter;
12878 -- Start of processing for Has_Inferable_Discriminants
12881 -- For selected components, the subtype of the selector must be a
12882 -- constrained Unchecked_Union. If the component is subject to a
12883 -- per-object constraint, then the enclosing object must have inferable
12886 if Nkind (N) = N_Selected_Component then
12887 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
12889 -- A small hack. If we have a per-object constrained selected
12890 -- component of a formal parameter, return True since we do not
12891 -- know the actual parameter association yet.
12893 if Prefix_Is_Formal_Parameter (N) then
12896 -- Otherwise, check the enclosing object and the selector
12899 return Has_Inferable_Discriminants (Prefix (N))
12900 and then Has_Inferable_Discriminants (Selector_Name (N));
12903 -- The call to Has_Inferable_Discriminants will determine whether
12904 -- the selector has a constrained Unchecked_Union nominal type.
12907 return Has_Inferable_Discriminants (Selector_Name (N));
12910 -- A qualified expression has inferable discriminants if its subtype
12911 -- mark is a constrained Unchecked_Union subtype.
12913 elsif Nkind (N) = N_Qualified_Expression then
12914 return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
12915 and then Is_Constrained (Etype (Subtype_Mark (N)));
12917 -- For all other names, it is sufficient to have a constrained
12918 -- Unchecked_Union nominal subtype.
12921 return Is_Unchecked_Union (Base_Type (Etype (N)))
12922 and then Is_Constrained (Etype (N));
12924 end Has_Inferable_Discriminants;
12926 --------------------
12927 -- Has_Infinities --
12928 --------------------
12930 function Has_Infinities (E : Entity_Id) return Boolean is
12933 Is_Floating_Point_Type (E)
12934 and then Nkind (Scalar_Range (E)) = N_Range
12935 and then Includes_Infinities (Scalar_Range (E));
12936 end Has_Infinities;
12938 --------------------
12939 -- Has_Interfaces --
12940 --------------------
12942 function Has_Interfaces
12944 Use_Full_View : Boolean := True) return Boolean
12946 Typ : Entity_Id := Base_Type (T);
12949 -- Handle concurrent types
12951 if Is_Concurrent_Type (Typ) then
12952 Typ := Corresponding_Record_Type (Typ);
12955 if not Present (Typ)
12956 or else not Is_Record_Type (Typ)
12957 or else not Is_Tagged_Type (Typ)
12962 -- Handle private types
12964 if Use_Full_View and then Present (Full_View (Typ)) then
12965 Typ := Full_View (Typ);
12968 -- Handle concurrent record types
12970 if Is_Concurrent_Record_Type (Typ)
12971 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
12977 if Is_Interface (Typ)
12979 (Is_Record_Type (Typ)
12980 and then Present (Interfaces (Typ))
12981 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
12986 exit when Etype (Typ) = Typ
12988 -- Handle private types
12990 or else (Present (Full_View (Etype (Typ)))
12991 and then Full_View (Etype (Typ)) = Typ)
12993 -- Protect frontend against wrong sources with cyclic derivations
12995 or else Etype (Typ) = T;
12997 -- Climb to the ancestor type handling private types
12999 if Present (Full_View (Etype (Typ))) then
13000 Typ := Full_View (Etype (Typ));
13002 Typ := Etype (Typ);
13007 end Has_Interfaces;
13009 --------------------------
13010 -- Has_Max_Queue_Length --
13011 --------------------------
13013 function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is
13016 Ekind (Id) = E_Entry
13017 and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length));
13018 end Has_Max_Queue_Length;
13020 ---------------------------------
13021 -- Has_No_Obvious_Side_Effects --
13022 ---------------------------------
13024 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
13026 -- For now handle literals, constants, and non-volatile variables and
13027 -- expressions combining these with operators or short circuit forms.
13029 if Nkind (N) in N_Numeric_Or_String_Literal then
13032 elsif Nkind (N) = N_Character_Literal then
13035 elsif Nkind (N) in N_Unary_Op then
13036 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
13038 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
13039 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
13041 Has_No_Obvious_Side_Effects (Right_Opnd (N));
13043 elsif Nkind (N) = N_Expression_With_Actions
13044 and then Is_Empty_List (Actions (N))
13046 return Has_No_Obvious_Side_Effects (Expression (N));
13048 elsif Nkind (N) in N_Has_Entity then
13049 return Present (Entity (N))
13051 Ekind (Entity (N)) in
13052 E_Variable | E_Constant | E_Enumeration_Literal |
13053 E_In_Parameter | E_Out_Parameter | E_In_Out_Parameter
13054 and then not Is_Volatile (Entity (N));
13059 end Has_No_Obvious_Side_Effects;
13061 -----------------------------
13062 -- Has_Non_Null_Refinement --
13063 -----------------------------
13065 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is
13066 Constits : Elist_Id;
13069 pragma Assert (Ekind (Id) = E_Abstract_State);
13070 Constits := Refinement_Constituents (Id);
13072 -- For a refinement to be non-null, the first constituent must be
13073 -- anything other than null.
13077 and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
13078 end Has_Non_Null_Refinement;
13080 -----------------------------
13081 -- Has_Non_Null_Statements --
13082 -----------------------------
13084 function Has_Non_Null_Statements (L : List_Id) return Boolean is
13090 while Present (Node) loop
13091 if Nkind (Node) not in N_Null_Statement | N_Call_Marker then
13099 end Has_Non_Null_Statements;
13101 ----------------------------------
13102 -- Is_Access_Subprogram_Wrapper --
13103 ----------------------------------
13105 function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean is
13106 Formal : constant Entity_Id := Last_Formal (E);
13108 return Present (Formal)
13109 and then Ekind (Etype (Formal)) in Access_Subprogram_Kind
13110 and then Access_Subprogram_Wrapper
13111 (Directly_Designated_Type (Etype (Formal))) = E;
13112 end Is_Access_Subprogram_Wrapper;
13114 ---------------------------
13115 -- Is_Explicitly_Aliased --
13116 ---------------------------
13118 function Is_Explicitly_Aliased (N : Node_Id) return Boolean is
13120 return Is_Formal (N)
13121 and then Present (Parent (N))
13122 and then Nkind (Parent (N)) = N_Parameter_Specification
13123 and then Aliased_Present (Parent (N));
13124 end Is_Explicitly_Aliased;
13126 ----------------------------
13127 -- Is_Container_Aggregate --
13128 ----------------------------
13130 function Is_Container_Aggregate (Exp : Node_Id) return Boolean is
13132 function Is_Record_Aggregate return Boolean is (False);
13133 -- ??? Unimplemented. Given an aggregate whose type is a
13134 -- record type with specified Aggregate aspect, how do we
13135 -- determine whether it is a record aggregate or a container
13136 -- aggregate? If the code where the aggregate occurs can see only
13137 -- a partial view of the aggregate's type then the aggregate
13138 -- cannot be a record type; an aggregate of a private type has to
13139 -- be a container aggregate.
13142 return Nkind (Exp) = N_Aggregate
13143 and then Present (Find_Aspect (Etype (Exp), Aspect_Aggregate))
13144 and then not Is_Record_Aggregate;
13145 end Is_Container_Aggregate;
13147 ---------------------------------
13148 -- Side_Effect_Free_Statements --
13149 ---------------------------------
13151 function Side_Effect_Free_Statements (L : List_Id) return Boolean is
13157 while Present (Node) loop
13158 case Nkind (Node) is
13159 when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error =>
13162 when N_Object_Declaration =>
13163 if Present (Expression (Node))
13164 and then not Side_Effect_Free (Expression (Node))
13177 end Side_Effect_Free_Statements;
13179 ---------------------------
13180 -- Side_Effect_Free_Loop --
13181 ---------------------------
13183 function Side_Effect_Free_Loop (N : Node_Id) return Boolean is
13189 -- If this is not a loop (e.g. because the loop has been rewritten),
13190 -- then return false.
13192 if Nkind (N) /= N_Loop_Statement then
13196 -- First check the statements
13198 if Side_Effect_Free_Statements (Statements (N)) then
13200 -- Then check the loop condition/indexes
13202 if Present (Iteration_Scheme (N)) then
13203 Scheme := Iteration_Scheme (N);
13205 if Present (Condition (Scheme))
13206 or else Present (Iterator_Specification (Scheme))
13209 elsif Present (Loop_Parameter_Specification (Scheme)) then
13210 Spec := Loop_Parameter_Specification (Scheme);
13211 Subt := Discrete_Subtype_Definition (Spec);
13213 if Present (Subt) then
13214 if Nkind (Subt) = N_Range then
13215 return Side_Effect_Free (Low_Bound (Subt))
13216 and then Side_Effect_Free (High_Bound (Subt));
13218 -- subtype indication
13228 end Side_Effect_Free_Loop;
13230 ----------------------------------
13231 -- Has_Non_Trivial_Precondition --
13232 ----------------------------------
13234 function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is
13235 Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre,
13236 Class_Present => True);
13240 and then not Is_Entity_Name (Expression (Pre));
13241 end Has_Non_Trivial_Precondition;
13243 -------------------
13244 -- Has_Null_Body --
13245 -------------------
13247 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is
13248 Body_Id : Entity_Id;
13255 Spec := Parent (Proc_Id);
13256 Decl := Parent (Spec);
13258 -- Retrieve the entity of the procedure body (e.g. invariant proc).
13260 if Nkind (Spec) = N_Procedure_Specification
13261 and then Nkind (Decl) = N_Subprogram_Declaration
13263 Body_Id := Corresponding_Body (Decl);
13265 -- The body acts as a spec
13268 Body_Id := Proc_Id;
13271 -- The body will be generated later
13273 if No (Body_Id) then
13277 Spec := Parent (Body_Id);
13278 Decl := Parent (Spec);
13281 (Nkind (Spec) = N_Procedure_Specification
13282 and then Nkind (Decl) = N_Subprogram_Body);
13284 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl)));
13286 -- Look for a null statement followed by an optional return
13289 if Nkind (Stmt1) = N_Null_Statement then
13290 Stmt2 := Next (Stmt1);
13292 if Present (Stmt2) then
13293 return Nkind (Stmt2) = N_Simple_Return_Statement;
13302 ------------------------
13303 -- Has_Null_Exclusion --
13304 ------------------------
13306 function Has_Null_Exclusion (N : Node_Id) return Boolean is
13309 when N_Access_Definition
13310 | N_Access_Function_Definition
13311 | N_Access_Procedure_Definition
13312 | N_Access_To_Object_Definition
13314 | N_Derived_Type_Definition
13315 | N_Function_Specification
13316 | N_Subtype_Declaration
13318 return Null_Exclusion_Present (N);
13320 when N_Component_Definition
13321 | N_Formal_Object_Declaration
13323 if Present (Subtype_Mark (N)) then
13324 return Null_Exclusion_Present (N);
13325 else pragma Assert (Present (Access_Definition (N)));
13326 return Null_Exclusion_Present (Access_Definition (N));
13329 when N_Object_Renaming_Declaration =>
13330 if Present (Subtype_Mark (N)) then
13331 return Null_Exclusion_Present (N);
13332 elsif Present (Access_Definition (N)) then
13333 return Null_Exclusion_Present (Access_Definition (N));
13335 return False; -- Case of no subtype in renaming (AI12-0275)
13338 when N_Discriminant_Specification =>
13339 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
13340 return Null_Exclusion_Present (Discriminant_Type (N));
13342 return Null_Exclusion_Present (N);
13345 when N_Object_Declaration =>
13346 if Nkind (Object_Definition (N)) = N_Access_Definition then
13347 return Null_Exclusion_Present (Object_Definition (N));
13349 return Null_Exclusion_Present (N);
13352 when N_Parameter_Specification =>
13353 if Nkind (Parameter_Type (N)) = N_Access_Definition then
13354 return Null_Exclusion_Present (Parameter_Type (N))
13355 or else Null_Exclusion_Present (N);
13357 return Null_Exclusion_Present (N);
13363 end Has_Null_Exclusion;
13365 ------------------------
13366 -- Has_Null_Extension --
13367 ------------------------
13369 function Has_Null_Extension (T : Entity_Id) return Boolean is
13370 B : constant Entity_Id := Base_Type (T);
13375 if Nkind (Parent (B)) = N_Full_Type_Declaration
13376 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
13378 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
13380 if Present (Ext) then
13381 if Null_Present (Ext) then
13384 Comps := Component_List (Ext);
13386 -- The null component list is rewritten during analysis to
13387 -- include the parent component. Any other component indicates
13388 -- that the extension was not originally null.
13390 return Null_Present (Comps)
13391 or else No (Next (First (Component_Items (Comps))));
13400 end Has_Null_Extension;
13402 -------------------------
13403 -- Has_Null_Refinement --
13404 -------------------------
13406 function Has_Null_Refinement (Id : Entity_Id) return Boolean is
13407 Constits : Elist_Id;
13410 pragma Assert (Ekind (Id) = E_Abstract_State);
13411 Constits := Refinement_Constituents (Id);
13413 -- For a refinement to be null, the state's sole constituent must be a
13418 and then Nkind (Node (First_Elmt (Constits))) = N_Null;
13419 end Has_Null_Refinement;
13421 ------------------------------------------
13422 -- Has_Nonstatic_Class_Wide_Pre_Or_Post --
13423 ------------------------------------------
13425 function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
13426 (Subp : Entity_Id) return Boolean
13428 Disp_Type : constant Entity_Id := Find_Dispatching_Type (Subp);
13430 Pragma_Arg : Node_Id;
13433 if Present (Disp_Type)
13434 and then Is_Abstract_Type (Disp_Type)
13435 and then Present (Contract (Subp))
13437 Prag := Pre_Post_Conditions (Contract (Subp));
13439 while Present (Prag) loop
13440 if Pragma_Name (Prag) in Name_Precondition | Name_Postcondition
13441 and then Class_Present (Prag)
13445 (Pragma_Argument_Associations (Prag));
13447 if not Is_Static_Expression (Expression (Pragma_Arg)) then
13452 Prag := Next_Pragma (Prag);
13457 end Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post;
13459 -------------------------------
13460 -- Has_Overriding_Initialize --
13461 -------------------------------
13463 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
13464 BT : constant Entity_Id := Base_Type (T);
13468 if Is_Controlled (BT) then
13469 if Is_RTU (Scope (BT), Ada_Finalization) then
13472 elsif Present (Primitive_Operations (BT)) then
13473 P := First_Elmt (Primitive_Operations (BT));
13474 while Present (P) loop
13476 Init : constant Entity_Id := Node (P);
13477 Formal : constant Entity_Id := First_Formal (Init);
13479 if Ekind (Init) = E_Procedure
13480 and then Chars (Init) = Name_Initialize
13481 and then Comes_From_Source (Init)
13482 and then Present (Formal)
13483 and then Etype (Formal) = BT
13484 and then No (Next_Formal (Formal))
13485 and then (Ada_Version < Ada_2012
13486 or else not Null_Present (Parent (Init)))
13496 -- Here if type itself does not have a non-null Initialize operation:
13497 -- check immediate ancestor.
13499 if Is_Derived_Type (BT)
13500 and then Has_Overriding_Initialize (Etype (BT))
13507 end Has_Overriding_Initialize;
13509 --------------------------------------
13510 -- Has_Preelaborable_Initialization --
13511 --------------------------------------
13513 function Has_Preelaborable_Initialization
13515 Preelab_Init_Expr : Node_Id := Empty) return Boolean
13519 procedure Check_Components (E : Entity_Id);
13520 -- Check component/discriminant chain, sets Has_PE False if a component
13521 -- or discriminant does not meet the preelaborable initialization rules.
13523 function Type_Named_In_Preelab_Init_Expression
13525 Expr : Node_Id) return Boolean;
13526 -- Returns True iff Typ'Preelaborable_Initialization occurs in Expr
13527 -- (where Expr may be a conjunction of one or more P_I attributes).
13529 ----------------------
13530 -- Check_Components --
13531 ----------------------
13533 procedure Check_Components (E : Entity_Id) is
13538 -- Loop through entities of record or protected type
13541 while Present (Ent) loop
13543 -- We are interested only in components and discriminants
13547 case Ekind (Ent) is
13548 when E_Component =>
13550 -- Get default expression if any. If there is no declaration
13551 -- node, it means we have an internal entity. The parent and
13552 -- tag fields are examples of such entities. For such cases,
13553 -- we just test the type of the entity.
13555 if Present (Declaration_Node (Ent)) then
13556 Exp := Expression (Declaration_Node (Ent));
13559 when E_Discriminant =>
13561 -- Note: for a renamed discriminant, the Declaration_Node
13562 -- may point to the one from the ancestor, and have a
13563 -- different expression, so use the proper attribute to
13564 -- retrieve the expression from the derived constraint.
13566 Exp := Discriminant_Default_Value (Ent);
13569 goto Check_Next_Entity;
13572 -- A component has PI if it has no default expression and the
13573 -- component type has PI.
13576 if not Has_Preelaborable_Initialization
13577 (Etype (Ent), Preelab_Init_Expr)
13583 -- Require the default expression to be preelaborable
13585 elsif not Is_Preelaborable_Construct (Exp) then
13590 <<Check_Next_Entity>>
13593 end Check_Components;
13595 --------------------------------------
13596 -- Type_Named_In_Preelab_Expression --
13597 --------------------------------------
13599 function Type_Named_In_Preelab_Init_Expression
13601 Expr : Node_Id) return Boolean
13604 -- Return True if Expr is a Preelaborable_Initialization attribute
13605 -- and the prefix is a subtype that has the same type as Typ.
13607 if Nkind (Expr) = N_Attribute_Reference
13608 and then Attribute_Name (Expr) = Name_Preelaborable_Initialization
13609 and then Is_Entity_Name (Prefix (Expr))
13610 and then Base_Type (Entity (Prefix (Expr))) = Base_Type (Typ)
13614 -- In the case where Expr is a conjunction, test whether either
13615 -- operand is a Preelaborable_Initialization attribute whose prefix
13616 -- has the same type as Typ, and return True if so.
13618 elsif Nkind (Expr) = N_Op_And
13620 (Type_Named_In_Preelab_Init_Expression (Typ, Left_Opnd (Expr))
13622 Type_Named_In_Preelab_Init_Expression (Typ, Right_Opnd (Expr)))
13626 -- Typ not named in a Preelaborable_Initialization attribute of Expr
13631 end Type_Named_In_Preelab_Init_Expression;
13633 -- Start of processing for Has_Preelaborable_Initialization
13636 -- Immediate return if already marked as known preelaborable init. This
13637 -- covers types for which this function has already been called once
13638 -- and returned True (in which case the result is cached), and also
13639 -- types to which a pragma Preelaborable_Initialization applies.
13641 if Known_To_Have_Preelab_Init (E) then
13645 -- If the type is a subtype representing a generic actual type, then
13646 -- test whether its base type has preelaborable initialization since
13647 -- the subtype representing the actual does not inherit this attribute
13648 -- from the actual or formal. (but maybe it should???)
13650 if Is_Generic_Actual_Type (E) then
13651 return Has_Preelaborable_Initialization (Base_Type (E));
13654 -- All elementary types have preelaborable initialization
13656 if Is_Elementary_Type (E) then
13659 -- Array types have PI if the component type has PI
13661 elsif Is_Array_Type (E) then
13662 Has_PE := Has_Preelaborable_Initialization
13663 (Component_Type (E), Preelab_Init_Expr);
13665 -- A derived type has preelaborable initialization if its parent type
13666 -- has preelaborable initialization and (in the case of a derived record
13667 -- extension) if the non-inherited components all have preelaborable
13668 -- initialization. However, a user-defined controlled type with an
13669 -- overriding Initialize procedure does not have preelaborable
13672 elsif Is_Derived_Type (E) then
13674 -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component
13675 -- of a generic formal derived type has preelaborable initialization.
13676 -- (See comment on spec of Has_Preelaborable_Initialization.)
13678 if Is_Generic_Type (E)
13679 and then Present (Preelab_Init_Expr)
13681 Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr)
13686 -- If the derived type is a private extension then it doesn't have
13687 -- preelaborable initialization.
13689 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
13693 -- First check whether ancestor type has preelaborable initialization
13695 Has_PE := Has_Preelaborable_Initialization
13696 (Etype (Base_Type (E)), Preelab_Init_Expr);
13698 -- If OK, check extension components (if any)
13700 if Has_PE and then Is_Record_Type (E) then
13701 Check_Components (First_Entity (E));
13704 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
13705 -- with a user defined Initialize procedure does not have PI. If
13706 -- the type is untagged, the control primitives come from a component
13707 -- that has already been checked.
13710 and then Is_Controlled (E)
13711 and then Is_Tagged_Type (E)
13712 and then Has_Overriding_Initialize (E)
13717 -- Private types not derived from a type having preelaborable init and
13718 -- that are not marked with pragma Preelaborable_Initialization do not
13719 -- have preelaborable initialization.
13721 elsif Is_Private_Type (E) then
13723 -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component
13724 -- of a generic formal private type has preelaborable initialization.
13725 -- (See comment on spec of Has_Preelaborable_Initialization.)
13727 if Is_Generic_Type (E)
13728 and then Present (Preelab_Init_Expr)
13730 Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr)
13737 -- Record type has PI if it is non private and all components have PI
13739 elsif Is_Record_Type (E) then
13741 Check_Components (First_Entity (E));
13743 -- Protected types must not have entries, and components must meet
13744 -- same set of rules as for record components.
13746 elsif Is_Protected_Type (E) then
13747 if Has_Entries (E) then
13751 Check_Components (First_Entity (E));
13752 Check_Components (First_Private_Entity (E));
13755 -- Type System.Address always has preelaborable initialization
13757 elsif Is_RTE (E, RE_Address) then
13760 -- In all other cases, type does not have preelaborable initialization
13766 -- If type has preelaborable initialization, cache result
13769 Set_Known_To_Have_Preelab_Init (E);
13773 end Has_Preelaborable_Initialization;
13779 function Has_Prefix (N : Node_Id) return Boolean is
13781 return Nkind (N) in
13782 N_Attribute_Reference | N_Expanded_Name | N_Explicit_Dereference |
13783 N_Indexed_Component | N_Reference | N_Selected_Component |
13787 ---------------------------
13788 -- Has_Private_Component --
13789 ---------------------------
13791 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
13792 Btype : Entity_Id := Base_Type (Type_Id);
13793 Component : Entity_Id;
13796 if Error_Posted (Type_Id)
13797 or else Error_Posted (Btype)
13802 if Is_Class_Wide_Type (Btype) then
13803 Btype := Root_Type (Btype);
13806 if Is_Private_Type (Btype) then
13808 UT : constant Entity_Id := Underlying_Type (Btype);
13811 if No (Full_View (Btype)) then
13812 return not Is_Generic_Type (Btype)
13814 not Is_Generic_Type (Root_Type (Btype));
13816 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
13819 return not Is_Frozen (UT) and then Has_Private_Component (UT);
13823 elsif Is_Array_Type (Btype) then
13824 return Has_Private_Component (Component_Type (Btype));
13826 elsif Is_Record_Type (Btype) then
13827 Component := First_Component (Btype);
13828 while Present (Component) loop
13829 if Has_Private_Component (Etype (Component)) then
13833 Next_Component (Component);
13838 elsif Is_Protected_Type (Btype)
13839 and then Present (Corresponding_Record_Type (Btype))
13841 return Has_Private_Component (Corresponding_Record_Type (Btype));
13846 end Has_Private_Component;
13848 --------------------------------
13849 -- Has_Relaxed_Initialization --
13850 --------------------------------
13852 function Has_Relaxed_Initialization (E : Entity_Id) return Boolean is
13854 function Denotes_Relaxed_Parameter
13858 -- Returns True iff expression Expr denotes a formal parameter or
13859 -- function Param (through its attribute Result).
13861 -------------------------------
13862 -- Denotes_Relaxed_Parameter --
13863 -------------------------------
13865 function Denotes_Relaxed_Parameter
13867 Param : Entity_Id) return Boolean is
13869 if Nkind (Expr) in N_Identifier | N_Expanded_Name then
13870 return Entity (Expr) = Param;
13872 pragma Assert (Is_Attribute_Result (Expr));
13873 return Entity (Prefix (Expr)) = Param;
13875 end Denotes_Relaxed_Parameter;
13877 -- Start of processing for Has_Relaxed_Initialization
13880 -- When analyzing, we checked all syntax legality rules for the aspect
13881 -- Relaxed_Initialization, but didn't store the property anywhere (e.g.
13882 -- as an Einfo flag). To query the property we look directly at the AST,
13883 -- but now without any syntactic checks.
13886 -- Abstract states have option Relaxed_Initialization
13888 when E_Abstract_State =>
13889 return Is_Relaxed_Initialization_State (E);
13891 -- Constants have this aspect attached directly; for deferred
13892 -- constants, the aspect is attached to the partial view.
13895 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13897 -- Variables have this aspect attached directly
13900 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13902 -- Types have this aspect attached directly (though we only allow it
13903 -- to be specified for the first subtype). For private types, the
13904 -- aspect is attached to the partial view.
13907 pragma Assert (Is_First_Subtype (E));
13908 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13910 -- Formal parameters and functions have the Relaxed_Initialization
13911 -- aspect attached to the subprogram entity and must be listed in
13912 -- the aspect expression.
13918 Subp_Id : Entity_Id;
13919 Aspect_Expr : Node_Id;
13920 Param_Expr : Node_Id;
13924 if Is_Formal (E) then
13925 Subp_Id := Scope (E);
13930 if Has_Aspect (Subp_Id, Aspect_Relaxed_Initialization) then
13932 Find_Value_Of_Aspect
13933 (Subp_Id, Aspect_Relaxed_Initialization);
13935 -- Aspect expression is either an aggregate with an optional
13936 -- Boolean expression (which defaults to True), e.g.:
13938 -- function F (X : Integer) return Integer
13939 -- with Relaxed_Initialization => (X => True, F'Result);
13941 if Nkind (Aspect_Expr) = N_Aggregate then
13943 if Present (Component_Associations (Aspect_Expr)) then
13944 Assoc := First (Component_Associations (Aspect_Expr));
13946 while Present (Assoc) loop
13947 if Denotes_Relaxed_Parameter
13948 (First (Choices (Assoc)), E)
13952 (Static_Boolean (Expression (Assoc)));
13959 Param_Expr := First (Expressions (Aspect_Expr));
13961 while Present (Param_Expr) loop
13962 if Denotes_Relaxed_Parameter (Param_Expr, E) then
13971 -- or it is a single identifier, e.g.:
13973 -- function F (X : Integer) return Integer
13974 -- with Relaxed_Initialization => X;
13977 return Denotes_Relaxed_Parameter (Aspect_Expr, E);
13985 raise Program_Error;
13987 end Has_Relaxed_Initialization;
13989 ----------------------
13990 -- Has_Signed_Zeros --
13991 ----------------------
13993 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
13995 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target;
13996 end Has_Signed_Zeros;
13998 ------------------------------
13999 -- Has_Significant_Contract --
14000 ------------------------------
14002 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is
14003 Subp_Nam : constant Name_Id := Chars (Subp_Id);
14006 -- _Finalizer procedure
14008 if Subp_Nam = Name_uFinalizer then
14011 -- _Postconditions procedure
14013 elsif Subp_Nam = Name_uPostconditions then
14016 -- Predicate function
14018 elsif Ekind (Subp_Id) = E_Function
14019 and then Is_Predicate_Function (Subp_Id)
14025 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then
14031 end Has_Significant_Contract;
14033 -----------------------------
14034 -- Has_Static_Array_Bounds --
14035 -----------------------------
14037 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
14038 All_Static : Boolean;
14042 Examine_Array_Bounds (Typ, All_Static, Dummy);
14045 end Has_Static_Array_Bounds;
14047 ---------------------------------------
14048 -- Has_Static_Non_Empty_Array_Bounds --
14049 ---------------------------------------
14051 function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is
14052 All_Static : Boolean;
14053 Has_Empty : Boolean;
14056 Examine_Array_Bounds (Typ, All_Static, Has_Empty);
14058 return All_Static and not Has_Empty;
14059 end Has_Static_Non_Empty_Array_Bounds;
14065 function Has_Stream (T : Entity_Id) return Boolean is
14072 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
14075 elsif Is_Array_Type (T) then
14076 return Has_Stream (Component_Type (T));
14078 elsif Is_Record_Type (T) then
14079 E := First_Component (T);
14080 while Present (E) loop
14081 if Has_Stream (Etype (E)) then
14084 Next_Component (E);
14090 elsif Is_Private_Type (T) then
14091 return Has_Stream (Underlying_Type (T));
14102 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
14104 Get_Name_String (Chars (E));
14105 return Name_Buffer (Name_Len) = Suffix;
14112 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
14114 Get_Name_String (Chars (E));
14115 Add_Char_To_Name_Buffer (Suffix);
14119 -------------------
14120 -- Remove_Suffix --
14121 -------------------
14123 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
14125 pragma Assert (Has_Suffix (E, Suffix));
14126 Get_Name_String (Chars (E));
14127 Name_Len := Name_Len - 1;
14131 ----------------------------------
14132 -- Replace_Null_By_Null_Address --
14133 ----------------------------------
14135 procedure Replace_Null_By_Null_Address (N : Node_Id) is
14136 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id);
14137 -- Replace operand Op with a reference to Null_Address when the operand
14138 -- denotes a null Address. Other_Op denotes the other operand.
14140 --------------------------
14141 -- Replace_Null_Operand --
14142 --------------------------
14144 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is
14146 -- Check the type of the complementary operand since the N_Null node
14147 -- has not been decorated yet.
14149 if Nkind (Op) = N_Null
14150 and then Is_Descendant_Of_Address (Etype (Other_Op))
14152 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op)));
14154 end Replace_Null_Operand;
14156 -- Start of processing for Replace_Null_By_Null_Address
14159 pragma Assert (Relaxed_RM_Semantics);
14160 pragma Assert (Nkind (N) in N_Null | N_Op_Compare);
14162 if Nkind (N) = N_Null then
14163 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
14167 L : constant Node_Id := Left_Opnd (N);
14168 R : constant Node_Id := Right_Opnd (N);
14171 Replace_Null_Operand (L, Other_Op => R);
14172 Replace_Null_Operand (R, Other_Op => L);
14175 end Replace_Null_By_Null_Address;
14177 --------------------------
14178 -- Has_Tagged_Component --
14179 --------------------------
14181 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
14185 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then
14186 return Has_Tagged_Component (Underlying_Type (Typ));
14188 elsif Is_Array_Type (Typ) then
14189 return Has_Tagged_Component (Component_Type (Typ));
14191 elsif Is_Tagged_Type (Typ) then
14194 elsif Is_Record_Type (Typ) then
14195 Comp := First_Component (Typ);
14196 while Present (Comp) loop
14197 if Has_Tagged_Component (Etype (Comp)) then
14201 Next_Component (Comp);
14209 end Has_Tagged_Component;
14211 --------------------------------------------
14212 -- Has_Unconstrained_Access_Discriminants --
14213 --------------------------------------------
14215 function Has_Unconstrained_Access_Discriminants
14216 (Subtyp : Entity_Id) return Boolean
14221 if Has_Discriminants (Subtyp)
14222 and then not Is_Constrained (Subtyp)
14224 Discr := First_Discriminant (Subtyp);
14225 while Present (Discr) loop
14226 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
14230 Next_Discriminant (Discr);
14235 end Has_Unconstrained_Access_Discriminants;
14237 -----------------------------
14238 -- Has_Undefined_Reference --
14239 -----------------------------
14241 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is
14242 Has_Undef_Ref : Boolean := False;
14243 -- Flag set when expression Expr contains at least one undefined
14246 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result;
14247 -- Determine whether N denotes a reference and if it does, whether it is
14250 ----------------------------
14251 -- Is_Undefined_Reference --
14252 ----------------------------
14254 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is
14256 if Is_Entity_Name (N)
14257 and then Present (Entity (N))
14258 and then Entity (N) = Any_Id
14260 Has_Undef_Ref := True;
14265 end Is_Undefined_Reference;
14267 procedure Find_Undefined_References is
14268 new Traverse_Proc (Is_Undefined_Reference);
14270 -- Start of processing for Has_Undefined_Reference
14273 Find_Undefined_References (Expr);
14275 return Has_Undef_Ref;
14276 end Has_Undefined_Reference;
14278 ----------------------------
14279 -- Has_Volatile_Component --
14280 ----------------------------
14282 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is
14286 if Has_Volatile_Components (Typ) then
14289 elsif Is_Array_Type (Typ) then
14290 return Is_Volatile (Component_Type (Typ));
14292 elsif Is_Record_Type (Typ) then
14293 Comp := First_Component (Typ);
14294 while Present (Comp) loop
14295 if Is_Volatile_Object_Ref (Comp) then
14299 Next_Component (Comp);
14304 end Has_Volatile_Component;
14306 -------------------------
14307 -- Implementation_Kind --
14308 -------------------------
14310 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
14311 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
14314 pragma Assert (Present (Impl_Prag));
14315 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
14316 return Chars (Get_Pragma_Arg (Arg));
14317 end Implementation_Kind;
14319 --------------------------
14320 -- Implements_Interface --
14321 --------------------------
14323 function Implements_Interface
14324 (Typ_Ent : Entity_Id;
14325 Iface_Ent : Entity_Id;
14326 Exclude_Parents : Boolean := False) return Boolean
14328 Ifaces_List : Elist_Id;
14330 Iface : Entity_Id := Base_Type (Iface_Ent);
14331 Typ : Entity_Id := Base_Type (Typ_Ent);
14334 if Is_Class_Wide_Type (Typ) then
14335 Typ := Root_Type (Typ);
14338 if not Has_Interfaces (Typ) then
14342 if Is_Class_Wide_Type (Iface) then
14343 Iface := Root_Type (Iface);
14346 Collect_Interfaces (Typ, Ifaces_List);
14348 Elmt := First_Elmt (Ifaces_List);
14349 while Present (Elmt) loop
14350 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
14351 and then Exclude_Parents
14355 elsif Node (Elmt) = Iface then
14363 end Implements_Interface;
14365 --------------------------------
14366 -- Implicitly_Designated_Type --
14367 --------------------------------
14369 function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id is
14370 Desig : constant Entity_Id := Designated_Type (Typ);
14373 -- An implicit dereference is a legal occurrence of an incomplete type
14374 -- imported through a limited_with clause, if the full view is visible.
14376 if Is_Incomplete_Type (Desig)
14377 and then From_Limited_With (Desig)
14378 and then not From_Limited_With (Scope (Desig))
14380 (Is_Immediately_Visible (Scope (Desig))
14382 (Is_Child_Unit (Scope (Desig))
14383 and then Is_Visible_Lib_Unit (Scope (Desig))))
14385 return Available_View (Desig);
14389 end Implicitly_Designated_Type;
14391 ------------------------------------
14392 -- In_Assertion_Expression_Pragma --
14393 ------------------------------------
14395 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is
14397 Prag : Node_Id := Empty;
14400 -- Climb the parent chain looking for an enclosing pragma
14403 while Present (Par) loop
14404 if Nkind (Par) = N_Pragma then
14408 -- Precondition-like pragmas are expanded into if statements, check
14409 -- the original node instead.
14411 elsif Nkind (Original_Node (Par)) = N_Pragma then
14412 Prag := Original_Node (Par);
14415 -- The expansion of attribute 'Old generates a
constant to capture
14416 -- the result of the prefix. If the parent traversal reaches
14417 -- one of these constants, then the node technically came from a
14418 -- postcondition-like pragma. Note that the Ekind is not tested here
14419 -- because N may be the expression of an object declaration which is
14420 -- currently being analyzed. Such objects carry Ekind of E_Void.
14422 elsif Nkind
(Par
) = N_Object_Declaration
14423 and then Constant_Present
(Par
)
14424 and then Stores_Attribute_Old_Prefix
(Defining_Entity
(Par
))
14428 -- Prevent the search from going too far
14430 elsif Is_Body_Or_Package_Declaration
(Par
) then
14434 Par
:= Parent
(Par
);
14439 and then Assertion_Expression_Pragma
(Get_Pragma_Id
(Prag
));
14440 end In_Assertion_Expression_Pragma
;
14442 -------------------
14443 -- In_Check_Node --
14444 -------------------
14446 function In_Check_Node
(N
: Node_Id
) return Boolean is
14447 Par
: Node_Id
:= Parent
(N
);
14449 while Present
(Par
) loop
14450 if Nkind
(Par
) in N_Raise_xxx_Error
then
14453 -- Prevent the search from going too far
14455 elsif Is_Body_Or_Package_Declaration
(Par
) then
14459 Par
:= Parent
(Par
);
14466 -------------------------------
14467 -- In_Generic_Formal_Package --
14468 -------------------------------
14470 function In_Generic_Formal_Package
(E
: Entity_Id
) return Boolean is
14475 while Present
(Par
) loop
14476 if Nkind
(Par
) = N_Formal_Package_Declaration
14477 or else Nkind
(Original_Node
(Par
)) = N_Formal_Package_Declaration
14482 Par
:= Parent
(Par
);
14486 end In_Generic_Formal_Package
;
14488 ----------------------
14489 -- In_Generic_Scope --
14490 ----------------------
14492 function In_Generic_Scope
(E
: Entity_Id
) return Boolean is
14497 while Present
(S
) and then S
/= Standard_Standard
loop
14498 if Is_Generic_Unit
(S
) then
14506 end In_Generic_Scope
;
14512 function In_Instance
return Boolean is
14513 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
14517 S
:= Current_Scope
;
14518 while Present
(S
) and then S
/= Standard_Standard
loop
14519 if Is_Generic_Instance
(S
) then
14521 -- A child instance is always compiled in the context of a parent
14522 -- instance. Nevertheless, its actuals must not be analyzed in an
14523 -- instance context. We detect this case by examining the current
14524 -- compilation unit, which must be a child instance, and checking
14525 -- that it has not been analyzed yet.
14527 if Is_Child_Unit
(Curr_Unit
)
14528 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
14529 N_Package_Instantiation
14530 and then Ekind
(Curr_Unit
) = E_Void
14544 ----------------------
14545 -- In_Instance_Body --
14546 ----------------------
14548 function In_Instance_Body
return Boolean is
14552 S
:= Current_Scope
;
14553 while Present
(S
) and then S
/= Standard_Standard
loop
14554 if Ekind
(S
) in E_Function | E_Procedure
14555 and then Is_Generic_Instance
(S
)
14559 elsif Ekind
(S
) = E_Package
14560 and then In_Package_Body
(S
)
14561 and then Is_Generic_Instance
(S
)
14570 end In_Instance_Body
;
14572 -----------------------------
14573 -- In_Instance_Not_Visible --
14574 -----------------------------
14576 function In_Instance_Not_Visible
return Boolean is
14580 S
:= Current_Scope
;
14581 while Present
(S
) and then S
/= Standard_Standard
loop
14582 if Ekind
(S
) in E_Function | E_Procedure
14583 and then Is_Generic_Instance
(S
)
14587 elsif Ekind
(S
) = E_Package
14588 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
14589 and then Is_Generic_Instance
(S
)
14598 end In_Instance_Not_Visible
;
14600 ------------------------------
14601 -- In_Instance_Visible_Part --
14602 ------------------------------
14604 function In_Instance_Visible_Part
14605 (Id
: Entity_Id
:= Current_Scope
) return Boolean
14611 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
14612 if Ekind
(Inst
) = E_Package
14613 and then Is_Generic_Instance
(Inst
)
14614 and then not In_Package_Body
(Inst
)
14615 and then not In_Private_Part
(Inst
)
14620 Inst
:= Scope
(Inst
);
14624 end In_Instance_Visible_Part
;
14626 ---------------------
14627 -- In_Package_Body --
14628 ---------------------
14630 function In_Package_Body
return Boolean is
14634 S
:= Current_Scope
;
14635 while Present
(S
) and then S
/= Standard_Standard
loop
14636 if Ekind
(S
) = E_Package
and then In_Package_Body
(S
) then
14644 end In_Package_Body
;
14646 --------------------------
14647 -- In_Pragma_Expression --
14648 --------------------------
14650 function In_Pragma_Expression
(N
: Node_Id
; Nam
: Name_Id
) return Boolean is
14657 elsif Nkind
(P
) = N_Pragma
and then Pragma_Name
(P
) = Nam
then
14663 end In_Pragma_Expression
;
14665 ---------------------------
14666 -- In_Pre_Post_Condition --
14667 ---------------------------
14669 function In_Pre_Post_Condition
14670 (N
: Node_Id
; Class_Wide_Only
: Boolean := False) return Boolean
14673 Prag
: Node_Id
:= Empty
;
14674 Prag_Id
: Pragma_Id
;
14677 -- Climb the parent chain looking for an enclosing pragma
14680 while Present
(Par
) loop
14681 if Nkind
(Par
) = N_Pragma
then
14685 -- Prevent the search from going too far
14687 elsif Is_Body_Or_Package_Declaration
(Par
) then
14691 Par
:= Parent
(Par
);
14694 if Present
(Prag
) then
14695 Prag_Id
:= Get_Pragma_Id
(Prag
);
14697 if Class_Wide_Only
then
14699 Prag_Id
= Pragma_Post_Class
14700 or else Prag_Id
= Pragma_Pre_Class
14701 or else (Class_Present
(Prag
)
14702 and then (Prag_Id
= Pragma_Post
14703 or else Prag_Id
= Pragma_Postcondition
14704 or else Prag_Id
= Pragma_Pre
14705 or else Prag_Id
= Pragma_Precondition
));
14708 Prag_Id
= Pragma_Post
14709 or else Prag_Id
= Pragma_Post_Class
14710 or else Prag_Id
= Pragma_Postcondition
14711 or else Prag_Id
= Pragma_Pre
14712 or else Prag_Id
= Pragma_Pre_Class
14713 or else Prag_Id
= Pragma_Precondition
;
14716 -- Otherwise the node is not enclosed by a pre/postcondition pragma
14721 end In_Pre_Post_Condition
;
14723 ------------------------------
14724 -- In_Quantified_Expression --
14725 ------------------------------
14727 function In_Quantified_Expression
(N
: Node_Id
) return Boolean is
14734 elsif Nkind
(P
) = N_Quantified_Expression
then
14740 end In_Quantified_Expression
;
14742 -------------------------------------
14743 -- In_Reverse_Storage_Order_Object --
14744 -------------------------------------
14746 function In_Reverse_Storage_Order_Object
(N
: Node_Id
) return Boolean is
14748 Btyp
: Entity_Id
:= Empty
;
14751 -- Climb up indexed components
14755 case Nkind
(Pref
) is
14756 when N_Selected_Component
=>
14757 Pref
:= Prefix
(Pref
);
14760 when N_Indexed_Component
=>
14761 Pref
:= Prefix
(Pref
);
14769 if Present
(Pref
) then
14770 Btyp
:= Base_Type
(Etype
(Pref
));
14773 return Present
(Btyp
)
14774 and then (Is_Record_Type
(Btyp
) or else Is_Array_Type
(Btyp
))
14775 and then Reverse_Storage_Order
(Btyp
);
14776 end In_Reverse_Storage_Order_Object
;
14778 ------------------------------
14779 -- In_Same_Declarative_Part --
14780 ------------------------------
14782 function In_Same_Declarative_Part
14783 (Context
: Node_Id
;
14784 N
: Node_Id
) return Boolean
14786 Cont
: Node_Id
:= Context
;
14790 if Nkind
(Cont
) = N_Compilation_Unit_Aux
then
14791 Cont
:= Parent
(Cont
);
14795 while Present
(Nod
) loop
14799 elsif Nkind
(Nod
) in N_Accept_Statement
14800 | N_Block_Statement
14801 | N_Compilation_Unit
14804 | N_Package_Declaration
14806 | N_Subprogram_Body
14811 elsif Nkind
(Nod
) = N_Subunit
then
14812 Nod
:= Corresponding_Stub
(Nod
);
14815 Nod
:= Parent
(Nod
);
14820 end In_Same_Declarative_Part
;
14822 --------------------------------------
14823 -- In_Subprogram_Or_Concurrent_Unit --
14824 --------------------------------------
14826 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
14831 -- Use scope chain to check successively outer scopes
14833 E
:= Current_Scope
;
14837 if K
in Subprogram_Kind
14838 or else K
in Concurrent_Kind
14839 or else K
in Generic_Subprogram_Kind
14843 elsif E
= Standard_Standard
then
14849 end In_Subprogram_Or_Concurrent_Unit
;
14855 function In_Subtree
(N
: Node_Id
; Root
: Node_Id
) return Boolean is
14860 while Present
(Curr
) loop
14861 if Curr
= Root
then
14865 Curr
:= Parent
(Curr
);
14875 function In_Subtree
14878 Root2
: Node_Id
) return Boolean
14884 while Present
(Curr
) loop
14885 if Curr
= Root1
or else Curr
= Root2
then
14889 Curr
:= Parent
(Curr
);
14895 ---------------------
14896 -- In_Return_Value --
14897 ---------------------
14899 function In_Return_Value
(Expr
: Node_Id
) return Boolean is
14901 Prev_Par
: Node_Id
;
14903 In_Function_Call
: Boolean := False;
14906 -- Move through parent nodes to determine if Expr contributes to the
14907 -- return value of the current subprogram.
14911 while Present
(Par
) loop
14913 case Nkind
(Par
) is
14914 -- Ignore ranges and they don't contribute to the result
14919 -- An object declaration whose parent is an extended return
14920 -- statement is a return object.
14922 when N_Object_Declaration
=>
14923 if Present
(Parent
(Par
))
14924 and then Nkind
(Parent
(Par
)) = N_Extended_Return_Statement
14929 -- We hit a simple return statement, so we know we are in one
14931 when N_Simple_Return_Statement
=>
14934 -- Only include one nexting level of function calls
14936 when N_Function_Call
=>
14937 if not In_Function_Call
then
14938 In_Function_Call
:= True;
14940 -- When the function return type has implicit dereference
14941 -- specified we know it cannot directly contribute to the
14944 if Present
(Etype
(Par
))
14945 and then Has_Implicit_Dereference
14946 (Get_Full_View
(Etype
(Par
)))
14954 -- Check if we are on the right-hand side of an assignment
14955 -- statement to a return object.
14957 -- This is not specified in the RM ???
14959 when N_Assignment_Statement
=>
14960 if Prev_Par
= Name
(Par
) then
14965 while Present
(Pre
) loop
14966 if Is_Entity_Name
(Pre
)
14967 and then Is_Return_Object
(Entity
(Pre
))
14972 exit when Nkind
(Pre
) not in N_Selected_Component
14973 | N_Indexed_Component
14976 Pre
:= Prefix
(Pre
);
14979 -- Otherwise, we hit a master which was not relevant
14982 if Is_Master
(Par
) then
14987 -- Iterate up to the next parent, keeping track of the previous one
14990 Par
:= Parent
(Par
);
14994 end In_Return_Value
;
14996 -----------------------------------------
14997 -- In_Statement_Condition_With_Actions --
14998 -----------------------------------------
15000 function In_Statement_Condition_With_Actions
(N
: Node_Id
) return Boolean is
15001 Prev
: Node_Id
:= N
;
15002 P
: Node_Id
:= Parent
(N
);
15003 -- P and Prev will be used for traversing the AST, while maintaining an
15004 -- invariant that P = Parent (Prev).
15006 while Present
(P
) loop
15007 if Nkind
(P
) = N_Iteration_Scheme
15008 and then Prev
= Condition
(P
)
15012 elsif Nkind
(P
) = N_Elsif_Part
15013 and then Prev
= Condition
(P
)
15017 -- No point in going beyond statements
15019 elsif Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
15020 | N_Procedure_Call_Statement
15024 -- Prevent the search from going too far
15026 elsif Is_Body_Or_Package_Declaration
(P
) then
15035 end In_Statement_Condition_With_Actions
;
15037 ---------------------
15038 -- In_Visible_Part --
15039 ---------------------
15041 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
15043 return Is_Package_Or_Generic_Package
(Scope_Id
)
15044 and then In_Open_Scopes
(Scope_Id
)
15045 and then not In_Package_Body
(Scope_Id
)
15046 and then not In_Private_Part
(Scope_Id
);
15047 end In_Visible_Part
;
15049 --------------------------------
15050 -- Incomplete_Or_Partial_View --
15051 --------------------------------
15053 function Incomplete_Or_Partial_View
(Id
: Entity_Id
) return Entity_Id
is
15054 S
: constant Entity_Id
:= Scope
(Id
);
15056 function Inspect_Decls
15058 Taft
: Boolean := False) return Entity_Id
;
15059 -- Check whether a declarative region contains the incomplete or partial
15062 -------------------
15063 -- Inspect_Decls --
15064 -------------------
15066 function Inspect_Decls
15068 Taft
: Boolean := False) return Entity_Id
15074 Decl
:= First
(Decls
);
15075 while Present
(Decl
) loop
15078 -- The partial view of a Taft-amendment type is an incomplete
15082 if Nkind
(Decl
) = N_Incomplete_Type_Declaration
then
15083 Match
:= Defining_Identifier
(Decl
);
15086 -- Otherwise look for a private type whose full view matches the
15087 -- input type. Note that this checks full_type_declaration nodes
15088 -- to account for derivations from a private type where the type
15089 -- declaration hold the partial view and the full view is an
15092 elsif Nkind
(Decl
) in N_Full_Type_Declaration
15093 | N_Private_Extension_Declaration
15094 | N_Private_Type_Declaration
15096 Match
:= Defining_Identifier
(Decl
);
15099 -- Guard against unanalyzed entities
15102 and then Is_Type
(Match
)
15103 and then Present
(Full_View
(Match
))
15104 and then Full_View
(Match
) = Id
15119 -- Start of processing for Incomplete_Or_Partial_View
15122 -- Deferred constant or incomplete type case
15124 Prev
:= Current_Entity
(Id
);
15126 while Present
(Prev
) loop
15127 exit when Scope
(Prev
) = S
;
15129 Prev
:= Homonym
(Prev
);
15133 and then (Is_Incomplete_Type
(Prev
) or else Ekind
(Prev
) = E_Constant
)
15134 and then Present
(Full_View
(Prev
))
15135 and then Full_View
(Prev
) = Id
15140 -- Private or Taft amendment type case
15142 if Present
(S
) and then Is_Package_Or_Generic_Package
(S
) then
15144 Pkg_Decl
: constant Node_Id
:= Package_Specification
(S
);
15147 -- It is knows that Typ has a private view, look for it in the
15148 -- visible declarations of the enclosing scope. A special case
15149 -- of this is when the two views have been exchanged - the full
15150 -- appears earlier than the private.
15152 if Has_Private_Declaration
(Id
) then
15153 Prev
:= Inspect_Decls
(Visible_Declarations
(Pkg_Decl
));
15155 -- Exchanged view case, look in the private declarations
15158 Prev
:= Inspect_Decls
(Private_Declarations
(Pkg_Decl
));
15163 -- Otherwise if this is the package body, then Typ is a potential
15164 -- Taft amendment type. The incomplete view should be located in
15165 -- the private declarations of the enclosing scope.
15167 elsif In_Package_Body
(S
) then
15168 return Inspect_Decls
(Private_Declarations
(Pkg_Decl
), True);
15173 -- The type has no incomplete or private view
15176 end Incomplete_Or_Partial_View
;
15178 ---------------------------------------
15179 -- Incomplete_View_From_Limited_With --
15180 ---------------------------------------
15182 function Incomplete_View_From_Limited_With
15183 (Typ
: Entity_Id
) return Entity_Id
15186 -- It might make sense to make this an attribute in Einfo, and set it
15187 -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on
15188 -- slots for new attributes, and it seems a bit simpler to just search
15189 -- the Limited_View (if it exists) for an incomplete type whose
15190 -- Non_Limited_View is Typ.
15192 if Ekind
(Scope
(Typ
)) = E_Package
15193 and then Present
(Limited_View
(Scope
(Typ
)))
15196 Ent
: Entity_Id
:= First_Entity
(Limited_View
(Scope
(Typ
)));
15198 while Present
(Ent
) loop
15199 if Is_Incomplete_Type
(Ent
)
15200 and then Non_Limited_View
(Ent
) = Typ
15211 end Incomplete_View_From_Limited_With
;
15213 ----------------------------------
15214 -- Indexed_Component_Bit_Offset --
15215 ----------------------------------
15217 function Indexed_Component_Bit_Offset
(N
: Node_Id
) return Uint
is
15218 Exp
: constant Node_Id
:= First
(Expressions
(N
));
15219 Typ
: constant Entity_Id
:= Etype
(Prefix
(N
));
15220 Off
: constant Uint
:= Component_Size
(Typ
);
15224 -- Return early if the component size is not known or variable
15226 if No
(Off
) or else Off
< Uint_0
then
15230 -- Deal with the degenerate case of an empty component
15232 if Off
= Uint_0
then
15236 -- Check that both the index value and the low bound are known
15238 if not Compile_Time_Known_Value
(Exp
) then
15242 Ind
:= First_Index
(Typ
);
15247 -- Do not attempt to compute offsets within multi-dimensional arrays
15249 if Present
(Next_Index
(Ind
)) then
15253 if Nkind
(Ind
) = N_Subtype_Indication
then
15254 Ind
:= Constraint
(Ind
);
15256 if Nkind
(Ind
) = N_Range_Constraint
then
15257 Ind
:= Range_Expression
(Ind
);
15261 if Nkind
(Ind
) /= N_Range
15262 or else not Compile_Time_Known_Value
(Low_Bound
(Ind
))
15267 -- Return the scaled offset
15269 return Off
* (Expr_Value
(Exp
) - Expr_Value
(Low_Bound
(Ind
)));
15270 end Indexed_Component_Bit_Offset
;
15272 -----------------------------
15273 -- Inherit_Predicate_Flags --
15274 -----------------------------
15276 procedure Inherit_Predicate_Flags
(Subt
, Par
: Entity_Id
) is
15278 if Ada_Version
< Ada_2012
15279 or else Present
(Predicate_Function
(Subt
))
15284 Set_Has_Predicates
(Subt
, Has_Predicates
(Par
));
15285 Set_Has_Static_Predicate_Aspect
15286 (Subt
, Has_Static_Predicate_Aspect
(Par
));
15287 Set_Has_Dynamic_Predicate_Aspect
15288 (Subt
, Has_Dynamic_Predicate_Aspect
(Par
));
15290 -- A named subtype does not inherit the predicate function of its
15291 -- parent but an itype declared for a loop index needs the discrete
15292 -- predicate information of its parent to execute the loop properly.
15293 -- A non-discrete type may has a static predicate (for example True)
15294 -- but has no static_discrete_predicate.
15296 if Is_Itype
(Subt
) and then Present
(Predicate_Function
(Par
)) then
15297 Set_Subprograms_For_Type
(Subt
, Subprograms_For_Type
(Par
));
15299 if Has_Static_Predicate
(Par
) and then Is_Discrete_Type
(Par
) then
15300 Set_Static_Discrete_Predicate
15301 (Subt
, Static_Discrete_Predicate
(Par
));
15304 end Inherit_Predicate_Flags
;
15306 ----------------------------
15307 -- Inherit_Rep_Item_Chain --
15308 ----------------------------
15310 procedure Inherit_Rep_Item_Chain
(Typ
: Entity_Id
; From_Typ
: Entity_Id
) is
15312 Next_Item
: Node_Id
;
15315 -- There are several inheritance scenarios to consider depending on
15316 -- whether both types have rep item chains and whether the destination
15317 -- type already inherits part of the source type's rep item chain.
15319 -- 1) The source type lacks a rep item chain
15320 -- From_Typ ---> Empty
15322 -- Typ --------> Item (or Empty)
15324 -- In this case inheritance cannot take place because there are no items
15327 -- 2) The destination type lacks a rep item chain
15328 -- From_Typ ---> Item ---> ...
15330 -- Typ --------> Empty
15332 -- Inheritance takes place by setting the First_Rep_Item of the
15333 -- destination type to the First_Rep_Item of the source type.
15334 -- From_Typ ---> Item ---> ...
15336 -- Typ -----------+
15338 -- 3.1) Both source and destination types have at least one rep item.
15339 -- The destination type does NOT inherit a rep item from the source
15341 -- From_Typ ---> Item ---> Item
15343 -- Typ --------> Item ---> Item
15345 -- Inheritance takes place by setting the Next_Rep_Item of the last item
15346 -- of the destination type to the First_Rep_Item of the source type.
15347 -- From_Typ -------------------> Item ---> Item
15349 -- Typ --------> Item ---> Item --+
15351 -- 3.2) Both source and destination types have at least one rep item.
15352 -- The destination type DOES inherit part of the rep item chain of the
15354 -- From_Typ ---> Item ---> Item ---> Item
15356 -- Typ --------> Item ------+
15358 -- This rare case arises when the full view of a private extension must
15359 -- inherit the rep item chain from the full view of its parent type and
15360 -- the full view of the parent type contains extra rep items. Currently
15361 -- only invariants may lead to such form of inheritance.
15363 -- type From_Typ is tagged private
15364 -- with Type_Invariant'Class => Item_2;
15366 -- type Typ is new From_Typ with private
15367 -- with Type_Invariant => Item_4;
15369 -- At this point the rep item chains contain the following items
15371 -- From_Typ -----------> Item_2 ---> Item_3
15373 -- Typ --------> Item_4 --+
15375 -- The full views of both types may introduce extra invariants
15377 -- type From_Typ is tagged null record
15378 -- with Type_Invariant => Item_1;
15380 -- type Typ is new From_Typ with null record;
15382 -- The full view of Typ would have to inherit any new rep items added to
15383 -- the full view of From_Typ.
15385 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
15387 -- Typ --------> Item_4 --+
15389 -- To achieve this form of inheritance, the destination type must first
15390 -- sever the link between its own rep chain and that of the source type,
15391 -- then inheritance 3.1 takes place.
15393 -- Case 1: The source type lacks a rep item chain
15395 if No
(First_Rep_Item
(From_Typ
)) then
15398 -- Case 2: The destination type lacks a rep item chain
15400 elsif No
(First_Rep_Item
(Typ
)) then
15401 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
15403 -- Case 3: Both the source and destination types have at least one rep
15404 -- item. Traverse the rep item chain of the destination type to find the
15409 Next_Item
:= First_Rep_Item
(Typ
);
15410 while Present
(Next_Item
) loop
15412 -- Detect a link between the destination type's rep chain and that
15413 -- of the source type. There are two possibilities:
15418 -- From_Typ ---> Item_1 --->
15420 -- Typ -----------+
15427 -- From_Typ ---> Item_1 ---> Item_2 --->
15429 -- Typ --------> Item_3 ------+
15433 if Present_In_Rep_Item
(From_Typ
, Next_Item
) then
15438 Next_Item
:= Next_Rep_Item
(Next_Item
);
15441 -- Inherit the source type's rep item chain
15443 if Present
(Item
) then
15444 Set_Next_Rep_Item
(Item
, First_Rep_Item
(From_Typ
));
15446 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
15449 end Inherit_Rep_Item_Chain
;
15451 ------------------------------------
15452 -- Inherits_From_Tagged_Full_View --
15453 ------------------------------------
15455 function Inherits_From_Tagged_Full_View
(Typ
: Entity_Id
) return Boolean is
15457 return Is_Private_Type
(Typ
)
15458 and then Present
(Full_View
(Typ
))
15459 and then Is_Private_Type
(Full_View
(Typ
))
15460 and then not Is_Tagged_Type
(Full_View
(Typ
))
15461 and then Present
(Underlying_Type
(Full_View
(Typ
)))
15462 and then Is_Tagged_Type
(Underlying_Type
(Full_View
(Typ
)));
15463 end Inherits_From_Tagged_Full_View
;
15465 ---------------------------------
15466 -- Insert_Explicit_Dereference --
15467 ---------------------------------
15469 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
15470 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
15471 Ent
: Entity_Id
:= Empty
;
15472 Pref
: Node_Id
:= Empty
;
15478 Save_Interps
(N
, New_Prefix
);
15481 Make_Explicit_Dereference
(Sloc
(Parent
(N
)),
15482 Prefix
=> New_Prefix
));
15484 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
15486 if Is_Overloaded
(New_Prefix
) then
15488 -- The dereference is also overloaded, and its interpretations are
15489 -- the designated types of the interpretations of the original node.
15491 Set_Etype
(N
, Any_Type
);
15493 Get_First_Interp
(New_Prefix
, I
, It
);
15494 while Present
(It
.Nam
) loop
15497 if Is_Access_Type
(T
) then
15498 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
15501 Get_Next_Interp
(I
, It
);
15505 -- Prefix is unambiguous: mark the original prefix (which might
15506 -- Come_From_Source) as a reference, since the new (relocated) one
15507 -- won't be taken into account.
15509 if Is_Entity_Name
(New_Prefix
) then
15510 Ent
:= Entity
(New_Prefix
);
15511 Pref
:= New_Prefix
;
15513 -- For a retrieval of a subcomponent of some composite object,
15514 -- retrieve the ultimate entity if there is one.
15516 elsif Nkind
(New_Prefix
) in N_Selected_Component | N_Indexed_Component
15518 Pref
:= Prefix
(New_Prefix
);
15519 while Present
(Pref
)
15520 and then Nkind
(Pref
) in
15521 N_Selected_Component | N_Indexed_Component
15523 Pref
:= Prefix
(Pref
);
15526 if Present
(Pref
) and then Is_Entity_Name
(Pref
) then
15527 Ent
:= Entity
(Pref
);
15531 -- Place the reference on the entity node
15533 if Present
(Ent
) then
15534 Generate_Reference
(Ent
, Pref
);
15537 end Insert_Explicit_Dereference
;
15539 ------------------------------------------
15540 -- Inspect_Deferred_Constant_Completion --
15541 ------------------------------------------
15543 procedure Inspect_Deferred_Constant_Completion
(Decls
: List_Id
) is
15547 Decl
:= First
(Decls
);
15548 while Present
(Decl
) loop
15550 -- Deferred constant signature
15552 if Nkind
(Decl
) = N_Object_Declaration
15553 and then Constant_Present
(Decl
)
15554 and then No
(Expression
(Decl
))
15556 -- No need to check internally generated constants
15558 and then Comes_From_Source
(Decl
)
15560 -- The constant is not completed. A full object declaration or a
15561 -- pragma Import complete a deferred constant.
15563 and then not Has_Completion
(Defining_Identifier
(Decl
))
15566 ("constant declaration requires initialization expression",
15567 Defining_Identifier
(Decl
));
15572 end Inspect_Deferred_Constant_Completion
;
15574 -------------------------------
15575 -- Install_Elaboration_Model --
15576 -------------------------------
15578 procedure Install_Elaboration_Model
(Unit_Id
: Entity_Id
) is
15579 function Find_Elaboration_Checks_Pragma
(L
: List_Id
) return Node_Id
;
15580 -- Try to find pragma Elaboration_Checks in arbitrary list L. Return
15581 -- Empty if there is no such pragma.
15583 ------------------------------------
15584 -- Find_Elaboration_Checks_Pragma --
15585 ------------------------------------
15587 function Find_Elaboration_Checks_Pragma
(L
: List_Id
) return Node_Id
is
15592 while Present
(Item
) loop
15593 if Nkind
(Item
) = N_Pragma
15594 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
15603 end Find_Elaboration_Checks_Pragma
;
15612 -- Start of processing for Install_Elaboration_Model
15615 -- Nothing to do when the unit does not exist
15617 if No
(Unit_Id
) then
15621 Unit
:= Parent
(Unit_Declaration_Node
(Unit_Id
));
15623 -- Nothing to do when the unit is not a library unit
15625 if Nkind
(Unit
) /= N_Compilation_Unit
then
15629 Prag
:= Find_Elaboration_Checks_Pragma
(Context_Items
(Unit
));
15631 -- The compilation unit is subject to pragma Elaboration_Checks. Set the
15632 -- elaboration model as specified by the pragma.
15634 if Present
(Prag
) then
15635 Args
:= Pragma_Argument_Associations
(Prag
);
15637 -- Guard against an illegal pragma. The sole argument must be an
15638 -- identifier which specifies either Dynamic or Static model.
15640 if Present
(Args
) then
15641 Model
:= Get_Pragma_Arg
(First
(Args
));
15643 if Nkind
(Model
) = N_Identifier
then
15644 Dynamic_Elaboration_Checks
:= Chars
(Model
) = Name_Dynamic
;
15648 end Install_Elaboration_Model
;
15650 -----------------------------
15651 -- Install_Generic_Formals --
15652 -----------------------------
15654 procedure Install_Generic_Formals
(Subp_Id
: Entity_Id
) is
15658 pragma Assert
(Is_Generic_Subprogram
(Subp_Id
));
15660 E
:= First_Entity
(Subp_Id
);
15661 while Present
(E
) loop
15662 Install_Entity
(E
);
15665 end Install_Generic_Formals
;
15667 ------------------------
15668 -- Install_SPARK_Mode --
15669 ------------------------
15671 procedure Install_SPARK_Mode
(Mode
: SPARK_Mode_Type
; Prag
: Node_Id
) is
15673 SPARK_Mode
:= Mode
;
15674 SPARK_Mode_Pragma
:= Prag
;
15675 end Install_SPARK_Mode
;
15677 --------------------------
15678 -- Invalid_Scalar_Value --
15679 --------------------------
15681 function Invalid_Scalar_Value
15683 Scal_Typ
: Scalar_Id
) return Node_Id
15685 function Invalid_Binder_Value
return Node_Id
;
15686 -- Return a reference to the corresponding invalid value for type
15687 -- Scal_Typ as defined in unit System.Scalar_Values.
15689 function Invalid_Float_Value
return Node_Id
;
15690 -- Return the invalid value of float type Scal_Typ
15692 function Invalid_Integer_Value
return Node_Id
;
15693 -- Return the invalid value of integer type Scal_Typ
15695 procedure Set_Invalid_Binder_Values
;
15696 -- Set the contents of collection Invalid_Binder_Values
15698 --------------------------
15699 -- Invalid_Binder_Value --
15700 --------------------------
15702 function Invalid_Binder_Value
return Node_Id
is
15703 Val_Id
: Entity_Id
;
15706 -- Initialize the collection of invalid binder values the first time
15709 Set_Invalid_Binder_Values
;
15711 -- Obtain the corresponding variable from System.Scalar_Values which
15712 -- holds the invalid value for this type.
15714 Val_Id
:= Invalid_Binder_Values
(Scal_Typ
);
15715 pragma Assert
(Present
(Val_Id
));
15717 return New_Occurrence_Of
(Val_Id
, Loc
);
15718 end Invalid_Binder_Value
;
15720 -------------------------
15721 -- Invalid_Float_Value --
15722 -------------------------
15724 function Invalid_Float_Value
return Node_Id
is
15725 Value
: constant Ureal
:= Invalid_Floats
(Scal_Typ
);
15728 -- Pragma Invalid_Scalars did not specify an invalid value for this
15729 -- type. Fall back to the value provided by the binder.
15731 if Value
= No_Ureal
then
15732 return Invalid_Binder_Value
;
15734 return Make_Real_Literal
(Loc
, Realval
=> Value
);
15736 end Invalid_Float_Value
;
15738 ---------------------------
15739 -- Invalid_Integer_Value --
15740 ---------------------------
15742 function Invalid_Integer_Value
return Node_Id
is
15743 Value
: constant Uint
:= Invalid_Integers
(Scal_Typ
);
15746 -- Pragma Invalid_Scalars did not specify an invalid value for this
15747 -- type. Fall back to the value provided by the binder.
15750 return Invalid_Binder_Value
;
15752 return Make_Integer_Literal
(Loc
, Intval
=> Value
);
15754 end Invalid_Integer_Value
;
15756 -------------------------------
15757 -- Set_Invalid_Binder_Values --
15758 -------------------------------
15760 procedure Set_Invalid_Binder_Values
is
15762 if not Invalid_Binder_Values_Set
then
15763 Invalid_Binder_Values_Set
:= True;
15765 -- Initialize the contents of the collection once since RTE calls
15768 Invalid_Binder_Values
:=
15769 (Name_Short_Float
=> RTE
(RE_IS_Isf
),
15770 Name_Float
=> RTE
(RE_IS_Ifl
),
15771 Name_Long_Float
=> RTE
(RE_IS_Ilf
),
15772 Name_Long_Long_Float
=> RTE
(RE_IS_Ill
),
15773 Name_Signed_8
=> RTE
(RE_IS_Is1
),
15774 Name_Signed_16
=> RTE
(RE_IS_Is2
),
15775 Name_Signed_32
=> RTE
(RE_IS_Is4
),
15776 Name_Signed_64
=> RTE
(RE_IS_Is8
),
15777 Name_Signed_128
=> Empty
,
15778 Name_Unsigned_8
=> RTE
(RE_IS_Iu1
),
15779 Name_Unsigned_16
=> RTE
(RE_IS_Iu2
),
15780 Name_Unsigned_32
=> RTE
(RE_IS_Iu4
),
15781 Name_Unsigned_64
=> RTE
(RE_IS_Iu8
),
15782 Name_Unsigned_128
=> Empty
);
15784 if System_Max_Integer_Size
< 128 then
15785 Invalid_Binder_Values
(Name_Signed_128
) := RTE
(RE_IS_Is8
);
15786 Invalid_Binder_Values
(Name_Unsigned_128
) := RTE
(RE_IS_Iu8
);
15788 Invalid_Binder_Values
(Name_Signed_128
) := RTE
(RE_IS_Is16
);
15789 Invalid_Binder_Values
(Name_Unsigned_128
) := RTE
(RE_IS_Iu16
);
15792 end Set_Invalid_Binder_Values
;
15794 -- Start of processing for Invalid_Scalar_Value
15797 if Scal_Typ
in Float_Scalar_Id
then
15798 return Invalid_Float_Value
;
15800 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
15801 return Invalid_Integer_Value
;
15803 end Invalid_Scalar_Value
;
15805 --------------------------------
15806 -- Is_Anonymous_Access_Actual --
15807 --------------------------------
15809 function Is_Anonymous_Access_Actual
(N
: Node_Id
) return Boolean is
15812 if Ekind
(Etype
(N
)) /= E_Anonymous_Access_Type
then
15817 while Present
(Par
)
15818 and then Nkind
(Par
) in N_Case_Expression
15820 | N_Parameter_Association
15822 Par
:= Parent
(Par
);
15824 return Nkind
(Par
) in N_Subprogram_Call
;
15825 end Is_Anonymous_Access_Actual
;
15827 ------------------------
15828 -- Is_Access_Variable --
15829 ------------------------
15831 function Is_Access_Variable
(E
: Entity_Id
) return Boolean is
15833 return Is_Access_Type
(E
)
15834 and then not Is_Access_Constant
(E
)
15835 and then Ekind
(Directly_Designated_Type
(E
)) /= E_Subprogram_Type
;
15836 end Is_Access_Variable
;
15838 -----------------------------
15839 -- Is_Actual_Out_Parameter --
15840 -----------------------------
15842 function Is_Actual_Out_Parameter
(N
: Node_Id
) return Boolean is
15843 Formal
: Entity_Id
;
15846 Find_Actual
(N
, Formal
, Call
);
15847 return Present
(Formal
) and then Ekind
(Formal
) = E_Out_Parameter
;
15848 end Is_Actual_Out_Parameter
;
15850 --------------------------------
15851 -- Is_Actual_In_Out_Parameter --
15852 --------------------------------
15854 function Is_Actual_In_Out_Parameter
(N
: Node_Id
) return Boolean is
15855 Formal
: Entity_Id
;
15858 Find_Actual
(N
, Formal
, Call
);
15859 return Present
(Formal
) and then Ekind
(Formal
) = E_In_Out_Parameter
;
15860 end Is_Actual_In_Out_Parameter
;
15862 ---------------------------------------
15863 -- Is_Actual_Out_Or_In_Out_Parameter --
15864 ---------------------------------------
15866 function Is_Actual_Out_Or_In_Out_Parameter
(N
: Node_Id
) return Boolean is
15867 Formal
: Entity_Id
;
15870 Find_Actual
(N
, Formal
, Call
);
15871 return Present
(Formal
)
15872 and then Ekind
(Formal
) in E_Out_Parameter | E_In_Out_Parameter
;
15873 end Is_Actual_Out_Or_In_Out_Parameter
;
15875 -------------------------
15876 -- Is_Actual_Parameter --
15877 -------------------------
15879 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
15880 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
15884 when N_Parameter_Association
=>
15885 return N
= Explicit_Actual_Parameter
(Parent
(N
));
15887 when N_Entry_Call_Statement
15888 | N_Subprogram_Call
15890 return Is_List_Member
(N
)
15892 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
15897 end Is_Actual_Parameter
;
15899 --------------------------------
15900 -- Is_Actual_Tagged_Parameter --
15901 --------------------------------
15903 function Is_Actual_Tagged_Parameter
(N
: Node_Id
) return Boolean is
15904 Formal
: Entity_Id
;
15907 Find_Actual
(N
, Formal
, Call
);
15908 return Present
(Formal
) and then Is_Tagged_Type
(Etype
(Formal
));
15909 end Is_Actual_Tagged_Parameter
;
15911 ---------------------
15912 -- Is_Aliased_View --
15913 ---------------------
15915 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
15919 if Is_Entity_Name
(Obj
) then
15926 or else (Present
(Renamed_Object
(E
))
15927 and then Is_Aliased_View
(Renamed_Object
(E
)))))
15929 or else ((Is_Formal
(E
) or else Is_Formal_Object
(E
))
15930 and then Is_Tagged_Type
(Etype
(E
)))
15932 or else (Is_Concurrent_Type
(E
) and then In_Open_Scopes
(E
))
15934 -- Current instance of type, either directly or as rewritten
15935 -- reference to the current object.
15937 or else (Is_Entity_Name
(Original_Node
(Obj
))
15938 and then Present
(Entity
(Original_Node
(Obj
)))
15939 and then Is_Type
(Entity
(Original_Node
(Obj
))))
15941 or else (Is_Type
(E
) and then E
= Current_Scope
)
15943 or else (Is_Incomplete_Or_Private_Type
(E
)
15944 and then Full_View
(E
) = Current_Scope
)
15946 -- Ada 2012 AI05-0053: the return object of an extended return
15947 -- statement is aliased if its type is immutably limited.
15949 or else (Is_Return_Object
(E
)
15950 and then Is_Limited_View
(Etype
(E
)))
15952 -- The current instance of a limited type is aliased, so
15953 -- we want to allow uses of T'Access in the init proc for
15954 -- a limited type T. However, we don't want to mark the formal
15955 -- parameter as being aliased since that could impact callers.
15957 or else (Is_Formal
(E
)
15958 and then Chars
(E
) = Name_uInit
15959 and then Is_Limited_View
(Etype
(E
)));
15961 elsif Nkind
(Obj
) = N_Selected_Component
then
15962 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
15964 elsif Nkind
(Obj
) = N_Indexed_Component
then
15965 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
15967 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
15968 and then Has_Aliased_Components
15969 (Designated_Type
(Etype
(Prefix
(Obj
)))));
15971 elsif Nkind
(Obj
) in N_Unchecked_Type_Conversion | N_Type_Conversion
then
15972 return Is_Tagged_Type
(Etype
(Obj
))
15973 and then Is_Aliased_View
(Expression
(Obj
));
15975 -- Ada 2022 AI12-0228
15977 elsif Nkind
(Obj
) = N_Qualified_Expression
15978 and then Ada_Version
>= Ada_2012
15980 return Is_Aliased_View
(Expression
(Obj
));
15982 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
15983 return Nkind
(Original_Node
(Obj
)) /= N_Function_Call
;
15988 end Is_Aliased_View
;
15990 -------------------------
15991 -- Is_Ancestor_Package --
15992 -------------------------
15994 function Is_Ancestor_Package
15996 E2
: Entity_Id
) return Boolean
16002 while Present
(Par
) and then Par
/= Standard_Standard
loop
16007 Par
:= Scope
(Par
);
16011 end Is_Ancestor_Package
;
16013 ----------------------
16014 -- Is_Atomic_Object --
16015 ----------------------
16017 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
16018 function Prefix_Has_Atomic_Components
(P
: Node_Id
) return Boolean;
16019 -- Determine whether prefix P has atomic components. This requires the
16020 -- presence of an Atomic_Components aspect/pragma.
16022 ---------------------------------
16023 -- Prefix_Has_Atomic_Components --
16024 ---------------------------------
16026 function Prefix_Has_Atomic_Components
(P
: Node_Id
) return Boolean is
16027 Typ
: constant Entity_Id
:= Etype
(P
);
16030 if Is_Access_Type
(Typ
) then
16031 return Has_Atomic_Components
(Designated_Type
(Typ
));
16033 elsif Has_Atomic_Components
(Typ
) then
16036 elsif Is_Entity_Name
(P
)
16037 and then Has_Atomic_Components
(Entity
(P
))
16044 end Prefix_Has_Atomic_Components
;
16046 -- Start of processing for Is_Atomic_Object
16049 if Is_Entity_Name
(N
) then
16050 return Is_Atomic_Object_Entity
(Entity
(N
));
16052 elsif Is_Atomic
(Etype
(N
)) then
16055 elsif Nkind
(N
) = N_Indexed_Component
then
16056 return Prefix_Has_Atomic_Components
(Prefix
(N
));
16058 elsif Nkind
(N
) = N_Selected_Component
then
16059 return Is_Atomic
(Entity
(Selector_Name
(N
)));
16064 end Is_Atomic_Object
;
16066 -----------------------------
16067 -- Is_Atomic_Object_Entity --
16068 -----------------------------
16070 function Is_Atomic_Object_Entity
(Id
: Entity_Id
) return Boolean is
16074 and then (Is_Atomic
(Id
) or else Is_Atomic
(Etype
(Id
)));
16075 end Is_Atomic_Object_Entity
;
16077 -----------------------------
16078 -- Is_Attribute_Loop_Entry --
16079 -----------------------------
16081 function Is_Attribute_Loop_Entry
(N
: Node_Id
) return Boolean is
16083 return Nkind
(N
) = N_Attribute_Reference
16084 and then Attribute_Name
(N
) = Name_Loop_Entry
;
16085 end Is_Attribute_Loop_Entry
;
16087 ----------------------
16088 -- Is_Attribute_Old --
16089 ----------------------
16091 function Is_Attribute_Old
(N
: Node_Id
) return Boolean is
16093 return Nkind
(N
) = N_Attribute_Reference
16094 and then Attribute_Name
(N
) = Name_Old
;
16095 end Is_Attribute_Old
;
16097 -------------------------
16098 -- Is_Attribute_Result --
16099 -------------------------
16101 function Is_Attribute_Result
(N
: Node_Id
) return Boolean is
16103 return Nkind
(N
) = N_Attribute_Reference
16104 and then Attribute_Name
(N
) = Name_Result
;
16105 end Is_Attribute_Result
;
16107 -------------------------
16108 -- Is_Attribute_Update --
16109 -------------------------
16111 function Is_Attribute_Update
(N
: Node_Id
) return Boolean is
16113 return Nkind
(N
) = N_Attribute_Reference
16114 and then Attribute_Name
(N
) = Name_Update
;
16115 end Is_Attribute_Update
;
16117 ------------------------------------
16118 -- Is_Body_Or_Package_Declaration --
16119 ------------------------------------
16121 function Is_Body_Or_Package_Declaration
(N
: Node_Id
) return Boolean is
16123 return Is_Body
(N
) or else Nkind
(N
) = N_Package_Declaration
;
16124 end Is_Body_Or_Package_Declaration
;
16126 -----------------------
16127 -- Is_Bounded_String --
16128 -----------------------
16130 function Is_Bounded_String
(T
: Entity_Id
) return Boolean is
16131 Under
: constant Entity_Id
:= Underlying_Type
(Root_Type
(T
));
16134 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
16135 -- Super_String, or one of the [Wide_]Wide_ versions. This will
16136 -- be True for all the Bounded_String types in instances of the
16137 -- Generic_Bounded_Length generics, and for types derived from those.
16139 return Present
(Under
)
16140 and then (Is_RTE
(Root_Type
(Under
), RO_SU_Super_String
) or else
16141 Is_RTE
(Root_Type
(Under
), RO_WI_Super_String
) or else
16142 Is_RTE
(Root_Type
(Under
), RO_WW_Super_String
));
16143 end Is_Bounded_String
;
16145 -------------------------------
16146 -- Is_By_Protected_Procedure --
16147 -------------------------------
16149 function Is_By_Protected_Procedure
(Id
: Entity_Id
) return Boolean is
16151 return Ekind
(Id
) = E_Procedure
16152 and then Present
(Get_Rep_Pragma
(Id
, Name_Implemented
))
16153 and then Implementation_Kind
(Id
) = Name_By_Protected_Procedure
;
16154 end Is_By_Protected_Procedure
;
16156 ---------------------
16157 -- Is_CCT_Instance --
16158 ---------------------
16160 function Is_CCT_Instance
16161 (Ref_Id
: Entity_Id
;
16162 Context_Id
: Entity_Id
) return Boolean
16165 pragma Assert
(Ekind
(Ref_Id
) in E_Protected_Type | E_Task_Type
);
16167 if Is_Single_Task_Object
(Context_Id
) then
16168 return Scope_Within_Or_Same
(Etype
(Context_Id
), Ref_Id
);
16172 (Ekind
(Context_Id
) in
16173 E_Entry | E_Entry_Family | E_Function | E_Package |
16174 E_Procedure | E_Protected_Type | E_Task_Type
16175 or else Is_Record_Type
(Context_Id
));
16176 return Scope_Within_Or_Same
(Context_Id
, Ref_Id
);
16178 end Is_CCT_Instance
;
16180 -------------------------
16181 -- Is_Child_Or_Sibling --
16182 -------------------------
16184 function Is_Child_Or_Sibling
16185 (Pack_1
: Entity_Id
;
16186 Pack_2
: Entity_Id
) return Boolean
16188 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
;
16189 -- Given an arbitrary package, return the number of "climbs" necessary
16190 -- to reach scope Standard_Standard.
16192 procedure Equalize_Depths
16193 (Pack
: in out Entity_Id
;
16194 Depth
: in out Nat
;
16195 Depth_To_Reach
: Nat
);
16196 -- Given an arbitrary package, its depth and a target depth to reach,
16197 -- climb the scope chain until the said depth is reached. The pointer
16198 -- to the package and its depth a modified during the climb.
16200 ----------------------------
16201 -- Distance_From_Standard --
16202 ----------------------------
16204 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
is
16211 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
16213 Scop
:= Scope
(Scop
);
16217 end Distance_From_Standard
;
16219 ---------------------
16220 -- Equalize_Depths --
16221 ---------------------
16223 procedure Equalize_Depths
16224 (Pack
: in out Entity_Id
;
16225 Depth
: in out Nat
;
16226 Depth_To_Reach
: Nat
)
16229 -- The package must be at a greater or equal depth
16231 if Depth
< Depth_To_Reach
then
16232 raise Program_Error
;
16235 -- Climb the scope chain until the desired depth is reached
16237 while Present
(Pack
) and then Depth
/= Depth_To_Reach
loop
16238 Pack
:= Scope
(Pack
);
16239 Depth
:= Depth
- 1;
16241 end Equalize_Depths
;
16245 P_1
: Entity_Id
:= Pack_1
;
16246 P_1_Child
: Boolean := False;
16247 P_1_Depth
: Nat
:= Distance_From_Standard
(P_1
);
16248 P_2
: Entity_Id
:= Pack_2
;
16249 P_2_Child
: Boolean := False;
16250 P_2_Depth
: Nat
:= Distance_From_Standard
(P_2
);
16252 -- Start of processing for Is_Child_Or_Sibling
16256 (Ekind
(Pack_1
) = E_Package
and then Ekind
(Pack_2
) = E_Package
);
16258 -- Both packages denote the same entity, therefore they cannot be
16259 -- children or siblings.
16264 -- One of the packages is at a deeper level than the other. Note that
16265 -- both may still come from different hierarchies.
16273 elsif P_1_Depth
> P_2_Depth
then
16276 Depth
=> P_1_Depth
,
16277 Depth_To_Reach
=> P_2_Depth
);
16286 elsif P_2_Depth
> P_1_Depth
then
16289 Depth
=> P_2_Depth
,
16290 Depth_To_Reach
=> P_1_Depth
);
16294 -- At this stage the package pointers have been elevated to the same
16295 -- depth. If the related entities are the same, then one package is a
16296 -- potential child of the other:
16300 -- X became P_1 P_2 or vice versa
16306 return Is_Child_Unit
(Pack_1
);
16308 else pragma Assert
(P_2_Child
);
16309 return Is_Child_Unit
(Pack_2
);
16312 -- The packages may come from the same package chain or from entirely
16313 -- different hierarchies. To determine this, climb the scope stack until
16314 -- a common root is found.
16316 -- (root) (root 1) (root 2)
16321 while Present
(P_1
) and then Present
(P_2
) loop
16323 -- The two packages may be siblings
16326 return Is_Child_Unit
(Pack_1
) and then Is_Child_Unit
(Pack_2
);
16329 P_1
:= Scope
(P_1
);
16330 P_2
:= Scope
(P_2
);
16335 end Is_Child_Or_Sibling
;
16337 -------------------
16338 -- Is_Confirming --
16339 -------------------
16341 function Is_Confirming
(Aspect
: Nonoverridable_Aspect_Id
;
16342 Aspect_Spec_1
, Aspect_Spec_2
: Node_Id
)
16344 function Names_Match
(Nm1
, Nm2
: Node_Id
) return Boolean;
16350 function Names_Match
(Nm1
, Nm2
: Node_Id
) return Boolean is
16352 if Nkind
(Nm1
) /= Nkind
(Nm2
) then
16354 -- This may be too restrictive given that visibility
16355 -- may allow an identifier in one case and an expanded
16356 -- name in the other.
16358 case Nkind
(Nm1
) is
16359 when N_Identifier
=>
16360 return Name_Equals
(Chars
(Nm1
), Chars
(Nm2
));
16362 when N_Expanded_Name
=>
16363 -- An inherited operation has the same name as its
16364 -- ancestor, but they may have different scopes.
16365 -- This may be too permissive for Iterator_Element, which
16366 -- is intended to be identical in parent and derived type.
16368 return Names_Match
(Selector_Name
(Nm1
),
16369 Selector_Name
(Nm2
));
16372 return True; -- needed for Aggregate aspect checking
16375 -- e.g., 'Class attribute references
16376 if Is_Entity_Name
(Nm1
) and Is_Entity_Name
(Nm2
) then
16377 return Entity
(Nm1
) = Entity
(Nm2
);
16380 raise Program_Error
;
16384 -- allow users to disable "shall be confirming" check, at least for now
16385 if Relaxed_RM_Semantics
then
16389 -- ??? Type conversion here (along with "when others =>" below) is a
16390 -- workaround for a bootstrapping problem related to casing on a
16391 -- static-predicate-bearing subtype.
16393 case Aspect_Id
(Aspect
) is
16394 -- name-valued aspects; compare text of names, not resolution.
16395 when Aspect_Default_Iterator
16396 | Aspect_Iterator_Element
16397 | Aspect_Constant_Indexing
16398 | Aspect_Variable_Indexing
=>
16400 Item_1
: constant Node_Id
:= Aspect_Rep_Item
(Aspect_Spec_1
);
16401 Item_2
: constant Node_Id
:= Aspect_Rep_Item
(Aspect_Spec_2
);
16403 if (Nkind
(Item_1
) /= N_Attribute_Definition_Clause
)
16404 or (Nkind
(Item_2
) /= N_Attribute_Definition_Clause
)
16406 pragma Assert
(Serious_Errors_Detected
> 0);
16410 return Names_Match
(Expression
(Item_1
),
16411 Expression
(Item_2
));
16414 -- A confirming aspect for Implicit_Derenfence on a derived type
16415 -- has already been checked in Analyze_Aspect_Implicit_Dereference,
16416 -- including the presence of renamed discriminants.
16418 when Aspect_Implicit_Dereference
=>
16422 when Aspect_Aggregate
=>
16433 Assign_Indexed_2
: Node_Id
:= Empty
;
16435 Parse_Aspect_Aggregate
16436 (N
=> Expression
(Aspect_Spec_1
),
16437 Empty_Subp
=> Empty_1
,
16438 Add_Named_Subp
=> Add_Named_1
,
16439 Add_Unnamed_Subp
=> Add_Unnamed_1
,
16440 New_Indexed_Subp
=> New_Indexed_1
,
16441 Assign_Indexed_Subp
=> Assign_Indexed_1
);
16442 Parse_Aspect_Aggregate
16443 (N
=> Expression
(Aspect_Spec_2
),
16444 Empty_Subp
=> Empty_2
,
16445 Add_Named_Subp
=> Add_Named_2
,
16446 Add_Unnamed_Subp
=> Add_Unnamed_2
,
16447 New_Indexed_Subp
=> New_Indexed_2
,
16448 Assign_Indexed_Subp
=> Assign_Indexed_2
);
16450 Names_Match
(Empty_1
, Empty_2
) and then
16451 Names_Match
(Add_Named_1
, Add_Named_2
) and then
16452 Names_Match
(Add_Unnamed_1
, Add_Unnamed_2
) and then
16453 Names_Match
(New_Indexed_1
, New_Indexed_2
) and then
16454 Names_Match
(Assign_Indexed_1
, Assign_Indexed_2
);
16457 -- Checking for this aspect is performed elsewhere during freezing
16458 when Aspect_No_Controlled_Parts
=>
16461 -- scalar-valued aspects; compare (static) values.
16462 when Aspect_Max_Entry_Queue_Length
=>
16463 -- This should be unreachable. Max_Entry_Queue_Length is
16464 -- supported only for protected entries, not for types.
16465 pragma Assert
(Serious_Errors_Detected
/= 0);
16469 raise Program_Error
;
16473 -----------------------------
16474 -- Is_Concurrent_Interface --
16475 -----------------------------
16477 function Is_Concurrent_Interface
(T
: Entity_Id
) return Boolean is
16479 return Is_Protected_Interface
(T
)
16480 or else Is_Synchronized_Interface
(T
)
16481 or else Is_Task_Interface
(T
);
16482 end Is_Concurrent_Interface
;
16484 ------------------------------------------------------
16485 -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes --
16486 ------------------------------------------------------
16488 function Is_Conjunction_Of_Formal_Preelab_Init_Attributes
16489 (Expr
: Node_Id
) return Boolean
16492 function Is_Formal_Preelab_Init_Attribute
16493 (N
: Node_Id
) return Boolean;
16494 -- Returns True if N is a Preelaborable_Initialization attribute
16495 -- applied to a generic formal type, or N's Original_Node is such
16498 --------------------------------------
16499 -- Is_Formal_Preelab_Init_Attribute --
16500 --------------------------------------
16502 function Is_Formal_Preelab_Init_Attribute
16503 (N
: Node_Id
) return Boolean
16505 Orig_N
: constant Node_Id
:= Original_Node
(N
);
16508 return Nkind
(Orig_N
) = N_Attribute_Reference
16509 and then Attribute_Name
(Orig_N
) = Name_Preelaborable_Initialization
16510 and then Is_Entity_Name
(Prefix
(Orig_N
))
16511 and then Is_Generic_Type
(Entity
(Prefix
(Orig_N
)));
16512 end Is_Formal_Preelab_Init_Attribute
;
16514 -- Start of Is_Conjunction_Of_Formal_Preelab_Init_Attributes
16517 return Is_Formal_Preelab_Init_Attribute
(Expr
)
16518 or else (Nkind
(Expr
) = N_Op_And
16520 Is_Conjunction_Of_Formal_Preelab_Init_Attributes
16523 Is_Conjunction_Of_Formal_Preelab_Init_Attributes
16524 (Right_Opnd
(Expr
)));
16525 end Is_Conjunction_Of_Formal_Preelab_Init_Attributes
;
16527 -----------------------
16528 -- Is_Constant_Bound --
16529 -----------------------
16531 function Is_Constant_Bound
(Exp
: Node_Id
) return Boolean is
16533 if Compile_Time_Known_Value
(Exp
) then
16536 elsif Is_Entity_Name
(Exp
) and then Present
(Entity
(Exp
)) then
16537 return Is_Constant_Object
(Entity
(Exp
))
16538 or else Ekind
(Entity
(Exp
)) = E_Enumeration_Literal
;
16540 elsif Nkind
(Exp
) in N_Binary_Op
then
16541 return Is_Constant_Bound
(Left_Opnd
(Exp
))
16542 and then Is_Constant_Bound
(Right_Opnd
(Exp
))
16543 and then Scope
(Entity
(Exp
)) = Standard_Standard
;
16548 end Is_Constant_Bound
;
16550 ---------------------------
16551 -- Is_Container_Element --
16552 ---------------------------
16554 function Is_Container_Element
(Exp
: Node_Id
) return Boolean is
16555 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
16556 Pref
: constant Node_Id
:= Prefix
(Exp
);
16559 -- Call to an indexing aspect
16561 Cont_Typ
: Entity_Id
;
16562 -- The type of the container being accessed
16564 Elem_Typ
: Entity_Id
;
16565 -- Its element type
16567 Indexing
: Entity_Id
;
16568 Is_Const
: Boolean;
16569 -- Indicates that constant indexing is used, and the element is thus
16572 Ref_Typ
: Entity_Id
;
16573 -- The reference type returned by the indexing operation
16576 -- If C is a container, in a context that imposes the element type of
16577 -- that container, the indexing notation C (X) is rewritten as:
16579 -- Indexing (C, X).Discr.all
16581 -- where Indexing is one of the indexing aspects of the container.
16582 -- If the context does not require a reference, the construct can be
16587 -- First, verify that the construct has the proper form
16589 if not Expander_Active
then
16592 elsif Nkind
(Pref
) /= N_Selected_Component
then
16595 elsif Nkind
(Prefix
(Pref
)) /= N_Function_Call
then
16599 Call
:= Prefix
(Pref
);
16600 Ref_Typ
:= Etype
(Call
);
16603 if not Has_Implicit_Dereference
(Ref_Typ
)
16604 or else No
(First
(Parameter_Associations
(Call
)))
16605 or else not Is_Entity_Name
(Name
(Call
))
16610 -- Retrieve type of container object, and its iterator aspects
16612 Cont_Typ
:= Etype
(First
(Parameter_Associations
(Call
)));
16613 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Constant_Indexing
);
16616 if No
(Indexing
) then
16618 -- Container should have at least one indexing operation
16622 elsif Entity
(Name
(Call
)) /= Entity
(Indexing
) then
16624 -- This may be a variable indexing operation
16626 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Variable_Indexing
);
16629 or else Entity
(Name
(Call
)) /= Entity
(Indexing
)
16638 Elem_Typ
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Iterator_Element
);
16640 if No
(Elem_Typ
) or else Entity
(Elem_Typ
) /= Etype
(Exp
) then
16644 -- Check that the expression is not the target of an assignment, in
16645 -- which case the rewriting is not possible.
16647 if not Is_Const
then
16653 while Present
(Par
)
16655 if Nkind
(Parent
(Par
)) = N_Assignment_Statement
16656 and then Par
= Name
(Parent
(Par
))
16660 -- A renaming produces a reference, and the transformation
16663 elsif Nkind
(Parent
(Par
)) = N_Object_Renaming_Declaration
then
16666 elsif Nkind
(Parent
(Par
)) in
16668 N_Procedure_Call_Statement |
16669 N_Entry_Call_Statement
16671 -- Check that the element is not part of an actual for an
16672 -- in-out parameter.
16679 F
:= First_Formal
(Entity
(Name
(Parent
(Par
))));
16680 A
:= First
(Parameter_Associations
(Parent
(Par
)));
16681 while Present
(F
) loop
16682 if A
= Par
and then Ekind
(F
) /= E_In_Parameter
then
16691 -- E_In_Parameter in a call: element is not modified.
16696 Par
:= Parent
(Par
);
16701 -- The expression has the proper form and the context requires the
16702 -- element type. Retrieve the Element function of the container and
16703 -- rewrite the construct as a call to it.
16709 Op
:= First_Elmt
(Primitive_Operations
(Cont_Typ
));
16710 while Present
(Op
) loop
16711 exit when Chars
(Node
(Op
)) = Name_Element
;
16720 Make_Function_Call
(Loc
,
16721 Name
=> New_Occurrence_Of
(Node
(Op
), Loc
),
16722 Parameter_Associations
=> Parameter_Associations
(Call
)));
16723 Analyze_And_Resolve
(Exp
, Entity
(Elem_Typ
));
16727 end Is_Container_Element
;
16729 ----------------------------
16730 -- Is_Contract_Annotation --
16731 ----------------------------
16733 function Is_Contract_Annotation
(Item
: Node_Id
) return Boolean is
16735 return Is_Package_Contract_Annotation
(Item
)
16737 Is_Subprogram_Contract_Annotation
(Item
);
16738 end Is_Contract_Annotation
;
16740 --------------------------------------
16741 -- Is_Controlling_Limited_Procedure --
16742 --------------------------------------
16744 function Is_Controlling_Limited_Procedure
16745 (Proc_Nam
: Entity_Id
) return Boolean
16748 Param_Typ
: Entity_Id
:= Empty
;
16751 if Ekind
(Proc_Nam
) = E_Procedure
16752 and then Present
(Parameter_Specifications
(Parent
(Proc_Nam
)))
16756 (First
(Parameter_Specifications
(Parent
(Proc_Nam
))));
16758 -- The formal may be an anonymous access type
16760 if Nkind
(Param
) = N_Access_Definition
then
16761 Param_Typ
:= Entity
(Subtype_Mark
(Param
));
16763 Param_Typ
:= Etype
(Param
);
16766 -- In the case where an Itype was created for a dispatchin call, the
16767 -- procedure call has been rewritten. The actual may be an access to
16768 -- interface type in which case it is the designated type that is the
16769 -- controlling type.
16771 elsif Present
(Associated_Node_For_Itype
(Proc_Nam
))
16772 and then Present
(Original_Node
(Associated_Node_For_Itype
(Proc_Nam
)))
16774 Present
(Parameter_Associations
16775 (Associated_Node_For_Itype
(Proc_Nam
)))
16778 Etype
(First
(Parameter_Associations
16779 (Associated_Node_For_Itype
(Proc_Nam
))));
16781 if Ekind
(Param_Typ
) = E_Anonymous_Access_Type
then
16782 Param_Typ
:= Directly_Designated_Type
(Param_Typ
);
16786 if Present
(Param_Typ
) then
16788 Is_Interface
(Param_Typ
)
16789 and then Is_Limited_Record
(Param_Typ
);
16793 end Is_Controlling_Limited_Procedure
;
16795 -----------------------------
16796 -- Is_CPP_Constructor_Call --
16797 -----------------------------
16799 function Is_CPP_Constructor_Call
(N
: Node_Id
) return Boolean is
16801 return Nkind
(N
) = N_Function_Call
16802 and then Is_CPP_Class
(Etype
(Etype
(N
)))
16803 and then Is_Constructor
(Entity
(Name
(N
)))
16804 and then Is_Imported
(Entity
(Name
(N
)));
16805 end Is_CPP_Constructor_Call
;
16807 -------------------------
16808 -- Is_Current_Instance --
16809 -------------------------
16811 function Is_Current_Instance
(N
: Node_Id
) return Boolean is
16812 Typ
: constant Entity_Id
:= Entity
(N
);
16816 -- Simplest case: entity is a concurrent type and we are currently
16817 -- inside the body. This will eventually be expanded into a call to
16818 -- Self (for tasks) or _object (for protected objects).
16820 if Is_Concurrent_Type
(Typ
) and then In_Open_Scopes
(Typ
) then
16824 -- Check whether the context is a (sub)type declaration for the
16828 while Present
(P
) loop
16829 if Nkind
(P
) in N_Full_Type_Declaration
16830 | N_Private_Type_Declaration
16831 | N_Subtype_Declaration
16832 and then Comes_From_Source
(P
)
16834 -- If the type has a previous incomplete declaration, the
16835 -- reference in the type definition may have the incomplete
16836 -- view. So, here we detect if this incomplete view is a current
16837 -- instance by checking if its full view is the entity of the
16838 -- full declaration begin analyzed.
16841 (Defining_Entity
(P
) = Typ
16843 (Ekind
(Typ
) = E_Incomplete_Type
16844 and then Full_View
(Typ
) = Defining_Entity
(P
)))
16848 -- A subtype name may appear in an aspect specification for a
16849 -- Predicate_Failure aspect, for which we do not construct a
16850 -- wrapper procedure. The subtype will be replaced by the
16851 -- expression being tested when the corresponding predicate
16852 -- check is expanded. It may also appear in the pragma Predicate
16853 -- expression during legality checking.
16855 elsif Nkind
(P
) = N_Aspect_Specification
16856 and then Nkind
(Parent
(P
)) = N_Subtype_Declaration
16857 and then Underlying_Type
(Defining_Identifier
(Parent
(P
))) =
16858 Underlying_Type
(Typ
)
16862 elsif Nkind
(P
) = N_Pragma
16863 and then Get_Pragma_Id
(P
) in Pragma_Predicate
16864 | Pragma_Predicate_Failure
16867 Arg
: constant Entity_Id
:=
16868 Entity
(Expression
(Get_Argument
(P
)));
16870 if Underlying_Type
(Arg
) = Underlying_Type
(Typ
) then
16880 -- In any other context this is not a current occurrence
16883 end Is_Current_Instance
;
16885 --------------------------------------------------
16886 -- Is_Current_Instance_Reference_In_Type_Aspect --
16887 --------------------------------------------------
16889 function Is_Current_Instance_Reference_In_Type_Aspect
16890 (N
: Node_Id
) return Boolean
16893 -- When a current_instance is referenced within an aspect_specification
16894 -- of a type or subtype, it will show up as a reference to the formal
16895 -- parameter of the aspect's associated subprogram rather than as a
16896 -- reference to the type or subtype itself (in fact, the original name
16897 -- is never even analyzed). We check for predicate, invariant, and
16898 -- Default_Initial_Condition subprograms (in theory there could be
16899 -- other cases added, in which case this function will need updating).
16901 if Is_Entity_Name
(N
) then
16902 return Present
(Entity
(N
))
16903 and then Ekind
(Entity
(N
)) = E_In_Parameter
16904 and then Ekind
(Scope
(Entity
(N
))) in E_Function | E_Procedure
16906 (Is_Predicate_Function
(Scope
(Entity
(N
)))
16907 or else Is_Invariant_Procedure
(Scope
(Entity
(N
)))
16908 or else Is_Partial_Invariant_Procedure
(Scope
(Entity
(N
)))
16909 or else Is_DIC_Procedure
(Scope
(Entity
(N
))));
16913 when N_Indexed_Component
16917 Is_Current_Instance_Reference_In_Type_Aspect
(Prefix
(N
));
16919 when N_Selected_Component
=>
16921 Is_Current_Instance_Reference_In_Type_Aspect
(Prefix
(N
));
16923 when N_Type_Conversion
=>
16924 return Is_Current_Instance_Reference_In_Type_Aspect
16927 when N_Qualified_Expression
=>
16928 return Is_Current_Instance_Reference_In_Type_Aspect
16935 end Is_Current_Instance_Reference_In_Type_Aspect
;
16937 --------------------
16938 -- Is_Declaration --
16939 --------------------
16941 function Is_Declaration
16943 Body_OK
: Boolean := True;
16944 Concurrent_OK
: Boolean := True;
16945 Formal_OK
: Boolean := True;
16946 Generic_OK
: Boolean := True;
16947 Instantiation_OK
: Boolean := True;
16948 Renaming_OK
: Boolean := True;
16949 Stub_OK
: Boolean := True;
16950 Subprogram_OK
: Boolean := True;
16951 Type_OK
: Boolean := True) return Boolean
16956 -- Body declarations
16958 when N_Proper_Body
=>
16961 -- Concurrent type declarations
16963 when N_Protected_Type_Declaration
16964 | N_Single_Protected_Declaration
16965 | N_Single_Task_Declaration
16966 | N_Task_Type_Declaration
16968 return Concurrent_OK
or Type_OK
;
16970 -- Formal declarations
16972 when N_Formal_Abstract_Subprogram_Declaration
16973 | N_Formal_Concrete_Subprogram_Declaration
16974 | N_Formal_Object_Declaration
16975 | N_Formal_Package_Declaration
16976 | N_Formal_Type_Declaration
16980 -- Generic declarations
16982 when N_Generic_Package_Declaration
16983 | N_Generic_Subprogram_Declaration
16987 -- Generic instantiations
16989 when N_Function_Instantiation
16990 | N_Package_Instantiation
16991 | N_Procedure_Instantiation
16993 return Instantiation_OK
;
16995 -- Generic renaming declarations
16997 when N_Generic_Renaming_Declaration
=>
16998 return Generic_OK
or Renaming_OK
;
17000 -- Renaming declarations
17002 when N_Exception_Renaming_Declaration
17003 | N_Object_Renaming_Declaration
17004 | N_Package_Renaming_Declaration
17005 | N_Subprogram_Renaming_Declaration
17007 return Renaming_OK
;
17009 -- Stub declarations
17011 when N_Body_Stub
=>
17014 -- Subprogram declarations
17016 when N_Abstract_Subprogram_Declaration
17017 | N_Entry_Declaration
17018 | N_Expression_Function
17019 | N_Subprogram_Declaration
17021 return Subprogram_OK
;
17023 -- Type declarations
17025 when N_Full_Type_Declaration
17026 | N_Incomplete_Type_Declaration
17027 | N_Private_Extension_Declaration
17028 | N_Private_Type_Declaration
17029 | N_Subtype_Declaration
17035 when N_Component_Declaration
17036 | N_Exception_Declaration
17037 | N_Implicit_Label_Declaration
17038 | N_Number_Declaration
17039 | N_Object_Declaration
17040 | N_Package_Declaration
17047 end Is_Declaration
;
17049 --------------------------------
17050 -- Is_Declared_Within_Variant --
17051 --------------------------------
17053 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
17054 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
17055 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
17057 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
17058 end Is_Declared_Within_Variant
;
17060 ----------------------------------------------
17061 -- Is_Dependent_Component_Of_Mutable_Object --
17062 ----------------------------------------------
17064 function Is_Dependent_Component_Of_Mutable_Object
17065 (Object
: Node_Id
) return Boolean
17068 Prefix_Type
: Entity_Id
;
17069 P_Aliased
: Boolean := False;
17072 Deref
: Node_Id
:= Original_Node
(Object
);
17073 -- Dereference node, in something like X.all.Y(2)
17075 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
17078 -- Find the dereference node if any
17080 while Nkind
(Deref
) in
17081 N_Indexed_Component | N_Selected_Component | N_Slice
17083 Deref
:= Original_Node
(Prefix
(Deref
));
17086 -- If the prefix is a qualified expression of a variable, then function
17087 -- Is_Variable will return False for that because a qualified expression
17088 -- denotes a constant view, so we need to get the name being qualified
17089 -- so we can test below whether that's a variable (or a dereference).
17091 if Nkind
(Deref
) = N_Qualified_Expression
then
17092 Deref
:= Expression
(Deref
);
17095 -- Ada 2005: If we have a component or slice of a dereference, something
17096 -- like X.all.Y (2) and the type of X is access-to-constant, Is_Variable
17097 -- will return False, because it is indeed a constant view. But it might
17098 -- be a view of a variable object, so we want the following condition to
17099 -- be True in that case.
17101 if Is_Variable
(Object
)
17102 or else Is_Variable
(Deref
)
17104 (Ada_Version
>= Ada_2005
17105 and then (Nkind
(Deref
) = N_Explicit_Dereference
17106 or else (Present
(Etype
(Deref
))
17107 and then Is_Access_Type
(Etype
(Deref
)))))
17109 if Nkind
(Object
) = N_Selected_Component
then
17111 -- If the selector is not a component, then we definitely return
17112 -- False (it could be a function selector in a prefix form call
17113 -- occurring in an iterator specification).
17115 if Ekind
(Entity
(Selector_Name
(Object
))) not in
17116 E_Component | E_Discriminant
17121 -- Get the original node of the prefix in case it has been
17122 -- rewritten, which can occur, for example, in qualified
17123 -- expression cases. Also, a discriminant check on a selected
17124 -- component may be expanded into a dereference when removing
17125 -- side effects, and the subtype of the original node may be
17128 P
:= Original_Node
(Prefix
(Object
));
17129 Prefix_Type
:= Etype
(P
);
17131 -- If the prefix is a qualified expression, we want to look at its
17134 if Nkind
(P
) = N_Qualified_Expression
then
17135 P
:= Expression
(P
);
17136 Prefix_Type
:= Etype
(P
);
17139 if Is_Entity_Name
(P
) then
17140 -- The Etype may not be set on P (which is wrong) in certain
17141 -- corner cases involving the deprecated front-end inlining of
17142 -- subprograms (via -gnatN), so use the Etype set on the
17143 -- the entity for these instances since we know it is present.
17145 if No
(Prefix_Type
) then
17146 Prefix_Type
:= Etype
(Entity
(P
));
17149 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
17150 Prefix_Type
:= Base_Type
(Prefix_Type
);
17153 if Is_Aliased
(Entity
(P
)) then
17157 -- For explicit dereferences we get the access prefix so we can
17158 -- treat this similarly to implicit dereferences and examine the
17159 -- kind of the access type and its designated subtype further
17162 elsif Nkind
(P
) = N_Explicit_Dereference
then
17164 Prefix_Type
:= Etype
(P
);
17167 -- Check for prefix being an aliased component???
17172 -- A heap object is constrained by its initial value
17174 -- Ada 2005 (AI-363): Always assume the object could be mutable in
17175 -- the dereferenced case, since the access value might denote an
17176 -- unconstrained aliased object, whereas in Ada 95 the designated
17177 -- object is guaranteed to be constrained. A worst-case assumption
17178 -- has to apply in Ada 2005 because we can't tell at compile
17179 -- time whether the object is "constrained by its initial value",
17180 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
17181 -- rules (these rules are acknowledged to need fixing). We don't
17182 -- impose this more stringent checking for earlier Ada versions or
17183 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's
17184 -- benefit, though it's unclear on why using -gnat95 would not be
17187 if Ada_Version
< Ada_2005
or else Relaxed_RM_Semantics
then
17188 if Is_Access_Type
(Prefix_Type
)
17189 or else Nkind
(P
) = N_Explicit_Dereference
17194 else pragma Assert
(Ada_Version
>= Ada_2005
);
17195 if Is_Access_Type
(Prefix_Type
) then
17196 -- We need to make sure we have the base subtype, in case
17197 -- this is actually an access subtype (whose Ekind will be
17198 -- E_Access_Subtype).
17200 Prefix_Type
:= Etype
(Prefix_Type
);
17202 -- If the access type is pool-specific, and there is no
17203 -- constrained partial view of the designated type, then the
17204 -- designated object is known to be constrained. If it's a
17205 -- formal access type and the renaming is in the generic
17206 -- spec, we also treat it as pool-specific (known to be
17207 -- constrained), but assume the worst if in the generic body
17208 -- (see RM 3.3(23.3/3)).
17210 if Ekind
(Prefix_Type
) = E_Access_Type
17211 and then (not Is_Generic_Type
(Prefix_Type
)
17212 or else not In_Generic_Body
(Current_Scope
))
17213 and then not Object_Type_Has_Constrained_Partial_View
17214 (Typ
=> Designated_Type
(Prefix_Type
),
17215 Scop
=> Current_Scope
)
17219 -- Otherwise (general access type, or there is a constrained
17220 -- partial view of the designated type), we need to check
17221 -- based on the designated type.
17224 Prefix_Type
:= Designated_Type
(Prefix_Type
);
17230 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
17232 -- As per AI-0017, the renaming is illegal in a generic body, even
17233 -- if the subtype is indefinite (only applies to prefixes of an
17234 -- untagged formal type, see RM 3.3 (23.11/3)).
17236 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
17238 if not Is_Constrained
(Prefix_Type
)
17239 and then (Is_Definite_Subtype
(Prefix_Type
)
17241 (not Is_Tagged_Type
(Prefix_Type
)
17242 and then Is_Generic_Type
(Prefix_Type
)
17243 and then In_Generic_Body
(Current_Scope
)))
17245 and then (Is_Declared_Within_Variant
(Comp
)
17246 or else Has_Discriminant_Dependent_Constraint
(Comp
))
17247 and then (not P_Aliased
or else Ada_Version
>= Ada_2005
)
17251 -- If the prefix is of an access type at this point, then we want
17252 -- to return False, rather than calling this function recursively
17253 -- on the access object (which itself might be a discriminant-
17254 -- dependent component of some other object, but that isn't
17255 -- relevant to checking the object passed to us). This avoids
17256 -- issuing wrong errors when compiling with -gnatc, where there
17257 -- can be implicit dereferences that have not been expanded.
17259 elsif Is_Access_Type
(Etype
(Prefix
(Object
))) then
17264 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
17267 elsif Nkind
(Object
) = N_Indexed_Component
17268 or else Nkind
(Object
) = N_Slice
17270 return Is_Dependent_Component_Of_Mutable_Object
17271 (Original_Node
(Prefix
(Object
)));
17273 -- A type conversion that Is_Variable is a view conversion:
17274 -- go back to the denoted object.
17276 elsif Nkind
(Object
) = N_Type_Conversion
then
17278 Is_Dependent_Component_Of_Mutable_Object
17279 (Original_Node
(Expression
(Object
)));
17284 end Is_Dependent_Component_Of_Mutable_Object
;
17286 ---------------------
17287 -- Is_Dereferenced --
17288 ---------------------
17290 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
17291 P
: constant Node_Id
:= Parent
(N
);
17293 return Nkind
(P
) in N_Selected_Component
17294 | N_Explicit_Dereference
17295 | N_Indexed_Component
17297 and then Prefix
(P
) = N
;
17298 end Is_Dereferenced
;
17300 ----------------------
17301 -- Is_Descendant_Of --
17302 ----------------------
17304 function Is_Descendant_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
17309 pragma Assert
(Nkind
(T1
) in N_Entity
);
17310 pragma Assert
(Nkind
(T2
) in N_Entity
);
17312 T
:= Base_Type
(T1
);
17314 -- Immediate return if the types match
17319 -- Comment needed here ???
17321 elsif Ekind
(T
) = E_Class_Wide_Type
then
17322 return Etype
(T
) = T2
;
17330 -- Done if we found the type we are looking for
17335 -- Done if no more derivations to check
17342 -- Following test catches error cases resulting from prev errors
17344 elsif No
(Etyp
) then
17347 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
17350 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
17354 T
:= Base_Type
(Etyp
);
17357 end Is_Descendant_Of
;
17359 ----------------------------------------
17360 -- Is_Descendant_Of_Suspension_Object --
17361 ----------------------------------------
17363 function Is_Descendant_Of_Suspension_Object
17364 (Typ
: Entity_Id
) return Boolean
17366 Cur_Typ
: Entity_Id
;
17367 Par_Typ
: Entity_Id
;
17370 -- Climb the type derivation chain checking each parent type against
17371 -- Suspension_Object.
17373 Cur_Typ
:= Base_Type
(Typ
);
17374 while Present
(Cur_Typ
) loop
17375 Par_Typ
:= Etype
(Cur_Typ
);
17377 -- The current type is a match
17379 if Is_RTE
(Cur_Typ
, RE_Suspension_Object
) then
17382 -- Stop the traversal once the root of the derivation chain has been
17383 -- reached. In that case the current type is its own base type.
17385 elsif Cur_Typ
= Par_Typ
then
17389 Cur_Typ
:= Base_Type
(Par_Typ
);
17393 end Is_Descendant_Of_Suspension_Object
;
17395 ---------------------------------------------
17396 -- Is_Double_Precision_Floating_Point_Type --
17397 ---------------------------------------------
17399 function Is_Double_Precision_Floating_Point_Type
17400 (E
: Entity_Id
) return Boolean is
17402 return Is_Floating_Point_Type
(E
)
17403 and then Machine_Radix_Value
(E
) = Uint_2
17404 and then Machine_Mantissa_Value
(E
) = UI_From_Int
(53)
17405 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_10
17406 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_10
);
17407 end Is_Double_Precision_Floating_Point_Type
;
17409 -----------------------------
17410 -- Is_Effectively_Volatile --
17411 -----------------------------
17413 function Is_Effectively_Volatile
17415 Ignore_Protected
: Boolean := False) return Boolean is
17417 if Is_Type
(Id
) then
17419 -- An arbitrary type is effectively volatile when it is subject to
17420 -- pragma Atomic or Volatile.
17422 if Is_Volatile
(Id
) then
17425 -- An array type is effectively volatile when it is subject to pragma
17426 -- Atomic_Components or Volatile_Components or its component type is
17427 -- effectively volatile.
17429 elsif Is_Array_Type
(Id
) then
17430 if Has_Volatile_Components
(Id
) then
17434 Anc
: Entity_Id
:= Base_Type
(Id
);
17436 if Is_Private_Type
(Anc
) then
17437 Anc
:= Full_View
(Anc
);
17440 -- Test for presence of ancestor, as the full view of a
17441 -- private type may be missing in case of error.
17443 return Present
(Anc
)
17444 and then Is_Effectively_Volatile
17445 (Component_Type
(Anc
), Ignore_Protected
);
17449 -- A protected type is always volatile unless Ignore_Protected is
17452 elsif Is_Protected_Type
(Id
) and then not Ignore_Protected
then
17455 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is
17456 -- automatically volatile.
17458 elsif Is_Descendant_Of_Suspension_Object
(Id
) then
17461 -- Otherwise the type is not effectively volatile
17467 -- Otherwise Id denotes an object
17469 else pragma Assert
(Is_Object
(Id
));
17470 -- A volatile object for which No_Caching is enabled is not
17471 -- effectively volatile.
17476 (Ekind
(Id
) = E_Variable
and then No_Caching_Enabled
(Id
)))
17477 or else Has_Volatile_Components
(Id
)
17478 or else Is_Effectively_Volatile
(Etype
(Id
), Ignore_Protected
);
17480 end Is_Effectively_Volatile
;
17482 -----------------------------------------
17483 -- Is_Effectively_Volatile_For_Reading --
17484 -----------------------------------------
17486 function Is_Effectively_Volatile_For_Reading
17488 Ignore_Protected
: Boolean := False) return Boolean
17491 -- A concurrent type is effectively volatile for reading, except for a
17492 -- protected type when Ignore_Protected is True.
17494 if Is_Task_Type
(Id
)
17495 or else (Is_Protected_Type
(Id
) and then not Ignore_Protected
)
17499 elsif Is_Effectively_Volatile
(Id
, Ignore_Protected
) then
17501 -- Other volatile types and objects are effectively volatile for
17502 -- reading when they have property Async_Writers or Effective_Reads
17503 -- set to True. This includes the case of an array type whose
17504 -- Volatile_Components aspect is True (hence it is effectively
17505 -- volatile) which does not have the properties Async_Writers
17506 -- and Effective_Reads set to False.
17508 if Async_Writers_Enabled
(Id
)
17509 or else Effective_Reads_Enabled
(Id
)
17513 -- In addition, an array type is effectively volatile for reading
17514 -- when its component type is effectively volatile for reading.
17516 elsif Is_Array_Type
(Id
) then
17518 Anc
: Entity_Id
:= Base_Type
(Id
);
17520 if Is_Private_Type
(Anc
) then
17521 Anc
:= Full_View
(Anc
);
17524 -- Test for presence of ancestor, as the full view of a
17525 -- private type may be missing in case of error.
17527 return Present
(Anc
)
17528 and then Is_Effectively_Volatile_For_Reading
17529 (Component_Type
(Anc
), Ignore_Protected
);
17536 end Is_Effectively_Volatile_For_Reading
;
17538 ------------------------------------
17539 -- Is_Effectively_Volatile_Object --
17540 ------------------------------------
17542 function Is_Effectively_Volatile_Object
(N
: Node_Id
) return Boolean is
17543 function Is_Effectively_Volatile
(E
: Entity_Id
) return Boolean is
17544 (Is_Effectively_Volatile
(E
, Ignore_Protected
=> False));
17546 function Is_Effectively_Volatile_Object_Inst
17547 is new Is_Effectively_Volatile_Object_Shared
(Is_Effectively_Volatile
);
17549 return Is_Effectively_Volatile_Object_Inst
(N
);
17550 end Is_Effectively_Volatile_Object
;
17552 ------------------------------------------------
17553 -- Is_Effectively_Volatile_Object_For_Reading --
17554 ------------------------------------------------
17556 function Is_Effectively_Volatile_Object_For_Reading
17557 (N
: Node_Id
) return Boolean
17559 function Is_Effectively_Volatile_For_Reading
17560 (E
: Entity_Id
) return Boolean
17561 is (Is_Effectively_Volatile_For_Reading
(E
, Ignore_Protected
=> False));
17563 function Is_Effectively_Volatile_Object_For_Reading_Inst
17564 is new Is_Effectively_Volatile_Object_Shared
17565 (Is_Effectively_Volatile_For_Reading
);
17567 return Is_Effectively_Volatile_Object_For_Reading_Inst
(N
);
17568 end Is_Effectively_Volatile_Object_For_Reading
;
17570 -------------------------------------------
17571 -- Is_Effectively_Volatile_Object_Shared --
17572 -------------------------------------------
17574 function Is_Effectively_Volatile_Object_Shared
17575 (N
: Node_Id
) return Boolean
17578 if Is_Entity_Name
(N
) then
17579 return Is_Object
(Entity
(N
))
17580 and then Is_Effectively_Volatile_Entity
(Entity
(N
));
17582 elsif Nkind
(N
) in N_Indexed_Component | N_Slice
then
17583 return Is_Effectively_Volatile_Object_Shared
(Prefix
(N
));
17585 elsif Nkind
(N
) = N_Selected_Component
then
17587 Is_Effectively_Volatile_Object_Shared
(Prefix
(N
))
17589 Is_Effectively_Volatile_Object_Shared
(Selector_Name
(N
));
17591 elsif Nkind
(N
) in N_Qualified_Expression
17592 | N_Unchecked_Type_Conversion
17593 | N_Type_Conversion
17595 return Is_Effectively_Volatile_Object_Shared
(Expression
(N
));
17600 end Is_Effectively_Volatile_Object_Shared
;
17602 ----------------------------------------
17603 -- Is_Entity_Of_Quantified_Expression --
17604 ----------------------------------------
17606 function Is_Entity_Of_Quantified_Expression
(Id
: Entity_Id
) return Boolean
17608 Par
: constant Node_Id
:= Parent
(Id
);
17611 return (Nkind
(Par
) = N_Loop_Parameter_Specification
17612 or else Nkind
(Par
) = N_Iterator_Specification
)
17613 and then Defining_Identifier
(Par
) = Id
17614 and then Nkind
(Parent
(Par
)) = N_Quantified_Expression
;
17615 end Is_Entity_Of_Quantified_Expression
;
17617 -------------------
17618 -- Is_Entry_Body --
17619 -------------------
17621 function Is_Entry_Body
(Id
: Entity_Id
) return Boolean is
17625 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Body
;
17628 --------------------------
17629 -- Is_Entry_Declaration --
17630 --------------------------
17632 function Is_Entry_Declaration
(Id
: Entity_Id
) return Boolean is
17636 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Declaration
;
17637 end Is_Entry_Declaration
;
17639 ------------------------------------
17640 -- Is_Expanded_Priority_Attribute --
17641 ------------------------------------
17643 function Is_Expanded_Priority_Attribute
(E
: Entity_Id
) return Boolean is
17646 Nkind
(E
) = N_Function_Call
17647 and then not Configurable_Run_Time_Mode
17648 and then Nkind
(Original_Node
(E
)) = N_Attribute_Reference
17649 and then (Is_RTE
(Entity
(Name
(E
)), RE_Get_Ceiling
)
17650 or else Is_RTE
(Entity
(Name
(E
)), RO_PE_Get_Ceiling
));
17651 end Is_Expanded_Priority_Attribute
;
17653 ----------------------------
17654 -- Is_Expression_Function --
17655 ----------------------------
17657 function Is_Expression_Function
(Subp
: Entity_Id
) return Boolean is
17659 if Ekind
(Subp
) in E_Function | E_Subprogram_Body
then
17661 Nkind
(Original_Node
(Unit_Declaration_Node
(Subp
))) =
17662 N_Expression_Function
;
17666 end Is_Expression_Function
;
17668 ------------------------------------------
17669 -- Is_Expression_Function_Or_Completion --
17670 ------------------------------------------
17672 function Is_Expression_Function_Or_Completion
17673 (Subp
: Entity_Id
) return Boolean
17675 Subp_Decl
: Node_Id
;
17678 if Ekind
(Subp
) = E_Function
then
17679 Subp_Decl
:= Unit_Declaration_Node
(Subp
);
17681 -- The function declaration is either an expression function or is
17682 -- completed by an expression function body.
17685 Is_Expression_Function
(Subp
)
17686 or else (Nkind
(Subp_Decl
) = N_Subprogram_Declaration
17687 and then Present
(Corresponding_Body
(Subp_Decl
))
17688 and then Is_Expression_Function
17689 (Corresponding_Body
(Subp_Decl
)));
17691 elsif Ekind
(Subp
) = E_Subprogram_Body
then
17692 return Is_Expression_Function
(Subp
);
17697 end Is_Expression_Function_Or_Completion
;
17699 -----------------------------------------------
17700 -- Is_Extended_Precision_Floating_Point_Type --
17701 -----------------------------------------------
17703 function Is_Extended_Precision_Floating_Point_Type
17704 (E
: Entity_Id
) return Boolean is
17706 return Is_Floating_Point_Type
(E
)
17707 and then Machine_Radix_Value
(E
) = Uint_2
17708 and then Machine_Mantissa_Value
(E
) = Uint_64
17709 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_14
17710 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_14
);
17711 end Is_Extended_Precision_Floating_Point_Type
;
17713 -----------------------
17714 -- Is_EVF_Expression --
17715 -----------------------
17717 function Is_EVF_Expression
(N
: Node_Id
) return Boolean is
17718 Orig_N
: constant Node_Id
:= Original_Node
(N
);
17724 -- Detect a reference to a formal parameter of a specific tagged type
17725 -- whose related subprogram is subject to pragma Expresions_Visible with
17728 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
17733 and then Is_Specific_Tagged_Type
(Etype
(Id
))
17734 and then Extensions_Visible_Status
(Id
) =
17735 Extensions_Visible_False
;
17737 -- A case expression is an EVF expression when it contains at least one
17738 -- EVF dependent_expression. Note that a case expression may have been
17739 -- expanded, hence the use of Original_Node.
17741 elsif Nkind
(Orig_N
) = N_Case_Expression
then
17742 Alt
:= First
(Alternatives
(Orig_N
));
17743 while Present
(Alt
) loop
17744 if Is_EVF_Expression
(Expression
(Alt
)) then
17751 -- An if expression is an EVF expression when it contains at least one
17752 -- EVF dependent_expression. Note that an if expression may have been
17753 -- expanded, hence the use of Original_Node.
17755 elsif Nkind
(Orig_N
) = N_If_Expression
then
17756 Expr
:= Next
(First
(Expressions
(Orig_N
)));
17757 while Present
(Expr
) loop
17758 if Is_EVF_Expression
(Expr
) then
17765 -- A qualified expression or a type conversion is an EVF expression when
17766 -- its operand is an EVF expression.
17768 elsif Nkind
(N
) in N_Qualified_Expression
17769 | N_Unchecked_Type_Conversion
17770 | N_Type_Conversion
17772 return Is_EVF_Expression
(Expression
(N
));
17774 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when
17775 -- their prefix denotes an EVF expression.
17777 elsif Nkind
(N
) = N_Attribute_Reference
17778 and then Attribute_Name
(N
) in Name_Loop_Entry
17782 return Is_EVF_Expression
(Prefix
(N
));
17786 end Is_EVF_Expression
;
17792 function Is_False
(U
: Opt_Ubool
) return Boolean is
17794 return not Is_True
(U
);
17797 ---------------------------
17798 -- Is_Fixed_Model_Number --
17799 ---------------------------
17801 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
17802 S
: constant Ureal
:= Small_Value
(T
);
17803 M
: Urealp
.Save_Mark
;
17808 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
17809 Urealp
.Release
(M
);
17811 end Is_Fixed_Model_Number
;
17813 -----------------------------
17814 -- Is_Full_Access_Object --
17815 -----------------------------
17817 function Is_Full_Access_Object
(N
: Node_Id
) return Boolean is
17819 return Is_Atomic_Object
(N
)
17820 or else Is_Volatile_Full_Access_Object_Ref
(N
);
17821 end Is_Full_Access_Object
;
17823 -------------------------------
17824 -- Is_Fully_Initialized_Type --
17825 -------------------------------
17827 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
17831 if Is_Scalar_Type
(Typ
) then
17833 -- A scalar type with an aspect Default_Value is fully initialized
17835 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization
17836 -- of a scalar type, but we don't take that into account here, since
17837 -- we don't want these to affect warnings.
17839 return Has_Default_Aspect
(Typ
);
17841 elsif Is_Access_Type
(Typ
) then
17844 elsif Is_Array_Type
(Typ
) then
17845 if Is_Fully_Initialized_Type
(Component_Type
(Typ
))
17846 or else (Ada_Version
>= Ada_2012
and then Has_Default_Aspect
(Typ
))
17851 -- An interesting case, if we have a constrained type one of whose
17852 -- bounds is known to be null, then there are no elements to be
17853 -- initialized, so all the elements are initialized.
17855 if Is_Constrained
(Typ
) then
17858 Indx_Typ
: Entity_Id
;
17859 Lbd
, Hbd
: Node_Id
;
17862 Indx
:= First_Index
(Typ
);
17863 while Present
(Indx
) loop
17864 if Etype
(Indx
) = Any_Type
then
17867 -- If index is a range, use directly
17869 elsif Nkind
(Indx
) = N_Range
then
17870 Lbd
:= Low_Bound
(Indx
);
17871 Hbd
:= High_Bound
(Indx
);
17874 Indx_Typ
:= Etype
(Indx
);
17876 if Is_Private_Type
(Indx_Typ
) then
17877 Indx_Typ
:= Full_View
(Indx_Typ
);
17880 if No
(Indx_Typ
) or else Etype
(Indx_Typ
) = Any_Type
then
17883 Lbd
:= Type_Low_Bound
(Indx_Typ
);
17884 Hbd
:= Type_High_Bound
(Indx_Typ
);
17888 if Compile_Time_Known_Value
(Lbd
)
17890 Compile_Time_Known_Value
(Hbd
)
17892 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
17902 -- If no null indexes, then type is not fully initialized
17908 elsif Is_Record_Type
(Typ
) then
17909 if Has_Defaulted_Discriminants
(Typ
)
17910 and then Is_Fully_Initialized_Variant
(Typ
)
17915 -- We consider bounded string types to be fully initialized, because
17916 -- otherwise we get false alarms when the Data component is not
17917 -- default-initialized.
17919 if Is_Bounded_String
(Typ
) then
17923 -- Controlled records are considered to be fully initialized if
17924 -- there is a user defined Initialize routine. This may not be
17925 -- entirely correct, but as the spec notes, we are guessing here
17926 -- what is best from the point of view of issuing warnings.
17928 if Is_Controlled
(Typ
) then
17930 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
17933 if Present
(Utyp
) then
17935 Init
: constant Entity_Id
:=
17936 (Find_Optional_Prim_Op
17937 (Underlying_Type
(Typ
), Name_Initialize
));
17941 and then Comes_From_Source
(Init
)
17942 and then not In_Predefined_Unit
(Init
)
17946 elsif Has_Null_Extension
(Typ
)
17948 Is_Fully_Initialized_Type
17949 (Etype
(Base_Type
(Typ
)))
17958 -- Otherwise see if all record components are initialized
17964 Comp
:= First_Component
(Typ
);
17965 while Present
(Comp
) loop
17966 if (No
(Parent
(Comp
))
17967 or else No
(Expression
(Parent
(Comp
))))
17968 and then not Is_Fully_Initialized_Type
(Etype
(Comp
))
17970 -- Special VM case for tag components, which need to be
17971 -- defined in this case, but are never initialized as VMs
17972 -- are using other dispatching mechanisms. Ignore this
17973 -- uninitialized case. Note that this applies both to the
17974 -- uTag entry and the main vtable pointer (CPP_Class case).
17976 and then (Tagged_Type_Expansion
or else not Is_Tag
(Comp
))
17981 Next_Component
(Comp
);
17985 -- No uninitialized components, so type is fully initialized.
17986 -- Note that this catches the case of no components as well.
17990 elsif Is_Concurrent_Type
(Typ
) then
17993 elsif Is_Private_Type
(Typ
) then
17995 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
18001 return Is_Fully_Initialized_Type
(U
);
18008 end Is_Fully_Initialized_Type
;
18010 ----------------------------------
18011 -- Is_Fully_Initialized_Variant --
18012 ----------------------------------
18014 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
18015 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
18016 Constraints
: constant List_Id
:= New_List
;
18017 Components
: constant Elist_Id
:= New_Elmt_List
;
18018 Comp_Elmt
: Elmt_Id
;
18020 Comp_List
: Node_Id
;
18022 Discr_Val
: Node_Id
;
18024 Report_Errors
: Boolean;
18025 pragma Warnings
(Off
, Report_Errors
);
18028 if Serious_Errors_Detected
> 0 then
18032 if Is_Record_Type
(Typ
)
18033 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
18034 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
18036 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
18038 Discr
:= First_Discriminant
(Typ
);
18039 while Present
(Discr
) loop
18040 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
18041 Discr_Val
:= Expression
(Parent
(Discr
));
18043 if Present
(Discr_Val
)
18044 and then Is_OK_Static_Expression
(Discr_Val
)
18046 Append_To
(Constraints
,
18047 Make_Component_Association
(Loc
,
18048 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
18049 Expression
=> New_Copy
(Discr_Val
)));
18057 Next_Discriminant
(Discr
);
18062 Comp_List
=> Comp_List
,
18063 Governed_By
=> Constraints
,
18064 Into
=> Components
,
18065 Report_Errors
=> Report_Errors
);
18067 -- Check that each component present is fully initialized
18069 Comp_Elmt
:= First_Elmt
(Components
);
18070 while Present
(Comp_Elmt
) loop
18071 Comp_Id
:= Node
(Comp_Elmt
);
18073 if Ekind
(Comp_Id
) = E_Component
18074 and then (No
(Parent
(Comp_Id
))
18075 or else No
(Expression
(Parent
(Comp_Id
))))
18076 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
18081 Next_Elmt
(Comp_Elmt
);
18086 elsif Is_Private_Type
(Typ
) then
18088 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
18094 return Is_Fully_Initialized_Variant
(U
);
18101 end Is_Fully_Initialized_Variant
;
18103 ------------------------------------
18104 -- Is_Generic_Declaration_Or_Body --
18105 ------------------------------------
18107 function Is_Generic_Declaration_Or_Body
(Decl
: Node_Id
) return Boolean is
18108 Spec_Decl
: Node_Id
;
18111 -- Package/subprogram body
18113 if Nkind
(Decl
) in N_Package_Body | N_Subprogram_Body
18114 and then Present
(Corresponding_Spec
(Decl
))
18116 Spec_Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(Decl
));
18118 -- Package/subprogram body stub
18120 elsif Nkind
(Decl
) in N_Package_Body_Stub | N_Subprogram_Body_Stub
18121 and then Present
(Corresponding_Spec_Of_Stub
(Decl
))
18124 Unit_Declaration_Node
(Corresponding_Spec_Of_Stub
(Decl
));
18132 -- Rather than inspecting the defining entity of the spec declaration,
18133 -- look at its Nkind. This takes care of the case where the analysis of
18134 -- a generic body modifies the Ekind of its spec to allow for recursive
18137 return Nkind
(Spec_Decl
) in N_Generic_Declaration
;
18138 end Is_Generic_Declaration_Or_Body
;
18140 ---------------------------
18141 -- Is_Independent_Object --
18142 ---------------------------
18144 function Is_Independent_Object
(N
: Node_Id
) return Boolean is
18145 function Is_Independent_Object_Entity
(Id
: Entity_Id
) return Boolean;
18146 -- Determine whether arbitrary entity Id denotes an object that is
18149 function Prefix_Has_Independent_Components
(P
: Node_Id
) return Boolean;
18150 -- Determine whether prefix P has independent components. This requires
18151 -- the presence of an Independent_Components aspect/pragma.
18153 ------------------------------------
18154 -- Is_Independent_Object_Entity --
18155 ------------------------------------
18157 function Is_Independent_Object_Entity
(Id
: Entity_Id
) return Boolean is
18161 and then (Is_Independent
(Id
)
18163 Is_Independent
(Etype
(Id
)));
18164 end Is_Independent_Object_Entity
;
18166 -------------------------------------
18167 -- Prefix_Has_Independent_Components --
18168 -------------------------------------
18170 function Prefix_Has_Independent_Components
(P
: Node_Id
) return Boolean
18172 Typ
: constant Entity_Id
:= Etype
(P
);
18175 if Is_Access_Type
(Typ
) then
18176 return Has_Independent_Components
(Designated_Type
(Typ
));
18178 elsif Has_Independent_Components
(Typ
) then
18181 elsif Is_Entity_Name
(P
)
18182 and then Has_Independent_Components
(Entity
(P
))
18189 end Prefix_Has_Independent_Components
;
18191 -- Start of processing for Is_Independent_Object
18194 if Is_Entity_Name
(N
) then
18195 return Is_Independent_Object_Entity
(Entity
(N
));
18197 elsif Is_Independent
(Etype
(N
)) then
18200 elsif Nkind
(N
) = N_Indexed_Component
then
18201 return Prefix_Has_Independent_Components
(Prefix
(N
));
18203 elsif Nkind
(N
) = N_Selected_Component
then
18204 return Prefix_Has_Independent_Components
(Prefix
(N
))
18205 or else Is_Independent
(Entity
(Selector_Name
(N
)));
18210 end Is_Independent_Object
;
18212 ----------------------------
18213 -- Is_Inherited_Operation --
18214 ----------------------------
18216 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
18217 pragma Assert
(Is_Overloadable
(E
));
18218 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
18220 return Kind
= N_Full_Type_Declaration
18221 or else Kind
= N_Private_Extension_Declaration
18222 or else Kind
= N_Subtype_Declaration
18223 or else (Ekind
(E
) = E_Enumeration_Literal
18224 and then Is_Derived_Type
(Etype
(E
)));
18225 end Is_Inherited_Operation
;
18227 -------------------------------------
18228 -- Is_Inherited_Operation_For_Type --
18229 -------------------------------------
18231 function Is_Inherited_Operation_For_Type
18233 Typ
: Entity_Id
) return Boolean
18236 -- Check that the operation has been created by the type declaration
18238 return Is_Inherited_Operation
(E
)
18239 and then Defining_Identifier
(Parent
(E
)) = Typ
;
18240 end Is_Inherited_Operation_For_Type
;
18242 --------------------------------------
18243 -- Is_Inlinable_Expression_Function --
18244 --------------------------------------
18246 function Is_Inlinable_Expression_Function
18247 (Subp
: Entity_Id
) return Boolean
18249 Return_Expr
: Node_Id
;
18252 if Is_Expression_Function_Or_Completion
(Subp
)
18253 and then Has_Pragma_Inline_Always
(Subp
)
18254 and then Needs_No_Actuals
(Subp
)
18255 and then No
(Contract
(Subp
))
18256 and then not Is_Dispatching_Operation
(Subp
)
18257 and then Needs_Finalization
(Etype
(Subp
))
18258 and then not Is_Class_Wide_Type
(Etype
(Subp
))
18259 and then not Has_Invariants
(Etype
(Subp
))
18260 and then Present
(Subprogram_Body
(Subp
))
18261 and then Was_Expression_Function
(Subprogram_Body
(Subp
))
18263 Return_Expr
:= Expression_Of_Expression_Function
(Subp
);
18265 -- The returned object must not have a qualified expression and its
18266 -- nominal subtype must be statically compatible with the result
18267 -- subtype of the expression function.
18270 Nkind
(Return_Expr
) = N_Identifier
18271 and then Etype
(Return_Expr
) = Etype
(Subp
);
18275 end Is_Inlinable_Expression_Function
;
18281 function Is_Iterator
(Typ
: Entity_Id
) return Boolean is
18282 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean;
18283 -- Determine whether type Iter_Typ is a predefined forward or reversible
18286 ----------------------
18287 -- Denotes_Iterator --
18288 ----------------------
18290 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean is
18292 -- Check that the name matches, and that the ultimate ancestor is in
18293 -- a predefined unit, i.e the one that declares iterator interfaces.
18296 Chars
(Iter_Typ
) in Name_Forward_Iterator | Name_Reversible_Iterator
18297 and then In_Predefined_Unit
(Root_Type
(Iter_Typ
));
18298 end Denotes_Iterator
;
18302 Iface_Elmt
: Elmt_Id
;
18305 -- Start of processing for Is_Iterator
18308 -- The type may be a subtype of a descendant of the proper instance of
18309 -- the predefined interface type, so we must use the root type of the
18310 -- given type. The same is done for Is_Reversible_Iterator.
18312 if Is_Class_Wide_Type
(Typ
)
18313 and then Denotes_Iterator
(Root_Type
(Typ
))
18317 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
18320 elsif Present
(Find_Value_Of_Aspect
(Typ
, Aspect_Iterable
)) then
18324 Collect_Interfaces
(Typ
, Ifaces
);
18326 Iface_Elmt
:= First_Elmt
(Ifaces
);
18327 while Present
(Iface_Elmt
) loop
18328 if Denotes_Iterator
(Node
(Iface_Elmt
)) then
18332 Next_Elmt
(Iface_Elmt
);
18339 ----------------------------
18340 -- Is_Iterator_Over_Array --
18341 ----------------------------
18343 function Is_Iterator_Over_Array
(N
: Node_Id
) return Boolean is
18344 Container
: constant Node_Id
:= Name
(N
);
18345 Container_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Container
));
18347 return Is_Array_Type
(Container_Typ
);
18348 end Is_Iterator_Over_Array
;
18350 --------------------------
18351 -- Known_To_Be_Assigned --
18352 --------------------------
18354 function Known_To_Be_Assigned
18356 Only_LHS
: Boolean := False) return Boolean
18358 function Known_Assn
(N
: Node_Id
) return Boolean is
18359 (Known_To_Be_Assigned
(N
, Only_LHS
));
18360 -- Local function to simplify the passing of parameters for recursive
18363 P
: constant Node_Id
:= Parent
(N
);
18364 Form
: Entity_Id
:= Empty
;
18365 Call
: Node_Id
:= Empty
;
18367 -- Start of processing for Known_To_Be_Assigned
18370 -- Check for out parameters
18372 Find_Actual
(N
, Form
, Call
);
18374 if Present
(Form
) then
18375 return Ekind
(Form
) /= E_In_Parameter
and then not Only_LHS
;
18378 -- Otherwise look at the parent
18382 -- Test left side of assignment
18384 when N_Assignment_Statement
=>
18385 return N
= Name
(P
);
18387 -- Test prefix of component or attribute. Note that the prefix of an
18388 -- explicit or implicit dereference cannot be an l-value. In the case
18389 -- of a 'Read attribute, the reference can be an actual in the
18390 -- argument list of the attribute.
18392 when N_Attribute_Reference
=>
18394 not Only_LHS
and then
18396 and then Name_Implies_Lvalue_Prefix
(Attribute_Name
(P
)))
18398 Attribute_Name
(P
) = Name_Read
);
18400 -- For an expanded name, the name is an lvalue if the expanded name
18401 -- is an lvalue, but the prefix is never an lvalue, since it is just
18402 -- the scope where the name is found.
18404 when N_Expanded_Name
=>
18405 if N
= Prefix
(P
) then
18406 return Known_Assn
(P
);
18411 -- For a selected component A.B, A is certainly an lvalue if A.B is.
18412 -- B is a little interesting, if we have A.B := 3, there is some
18413 -- discussion as to whether B is an lvalue or not, we choose to say
18414 -- it is. Note however that A is not an lvalue if it is of an access
18415 -- type since this is an implicit dereference.
18417 when N_Selected_Component
=>
18419 and then Present
(Etype
(N
))
18420 and then Is_Access_Type
(Etype
(N
))
18424 return Known_Assn
(P
);
18427 -- For an indexed component or slice, the index or slice bounds is
18428 -- never an lvalue. The prefix is an lvalue if the indexed component
18429 -- or slice is an lvalue, except if it is an access type, where we
18430 -- have an implicit dereference.
18432 when N_Indexed_Component | N_Slice
=>
18434 or else (Present
(Etype
(N
)) and then Is_Access_Type
(Etype
(N
)))
18438 return Known_Assn
(P
);
18441 -- Prefix of a reference is an lvalue if the reference is an lvalue
18443 when N_Reference
=>
18444 return Known_Assn
(P
);
18446 -- Prefix of explicit dereference is never an lvalue
18448 when N_Explicit_Dereference
=>
18451 -- Test for appearing in a conversion that itself appears in an
18452 -- lvalue context, since this should be an lvalue.
18454 when N_Type_Conversion
=>
18455 return Known_Assn
(P
);
18457 -- Test for appearance in object renaming declaration
18459 when N_Object_Renaming_Declaration
=>
18460 return not Only_LHS
;
18462 -- All other references are definitely not lvalues
18467 end Known_To_Be_Assigned
;
18469 -----------------------------
18470 -- Is_Library_Level_Entity --
18471 -----------------------------
18473 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
18475 -- The following is a small optimization, and it also properly handles
18476 -- discriminals, which in task bodies might appear in expressions before
18477 -- the corresponding procedure has been created, and which therefore do
18478 -- not have an assigned scope.
18480 if Is_Formal
(E
) then
18483 -- If we somehow got an empty value for Scope, the tree must be
18484 -- malformed. Rather than blow up we return True in this case.
18486 elsif No
(Scope
(E
)) then
18489 -- Handle loops since Enclosing_Dynamic_Scope skips them; required to
18490 -- properly handle entities local to quantified expressions in library
18491 -- level specifications.
18493 elsif Ekind
(Scope
(E
)) = E_Loop
then
18497 -- Normal test is simply that the enclosing dynamic scope is Standard
18499 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
18500 end Is_Library_Level_Entity
;
18502 --------------------------------
18503 -- Is_Limited_Class_Wide_Type --
18504 --------------------------------
18506 function Is_Limited_Class_Wide_Type
(Typ
: Entity_Id
) return Boolean is
18509 Is_Class_Wide_Type
(Typ
)
18510 and then (Is_Limited_Type
(Typ
) or else From_Limited_With
(Typ
));
18511 end Is_Limited_Class_Wide_Type
;
18513 ---------------------------------
18514 -- Is_Local_Variable_Reference --
18515 ---------------------------------
18517 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
18519 if not Is_Entity_Name
(Expr
) then
18524 Ent
: constant Entity_Id
:= Entity
(Expr
);
18525 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
18528 not in E_Variable | E_In_Out_Parameter | E_Out_Parameter
18532 return Present
(Sub
) and then Sub
= Current_Subprogram
;
18536 end Is_Local_Variable_Reference
;
18542 function Is_Master
(N
: Node_Id
) return Boolean is
18543 Disable_Subexpression_Masters
: constant Boolean := True;
18546 if Nkind
(N
) in N_Subprogram_Body | N_Task_Body | N_Entry_Body
18547 or else Is_Statement
(N
)
18552 -- We avoid returning True when the master is a subexpression described
18553 -- in RM 7.6.1(3/2) for the proposes of accessibility level calculation
18554 -- in Accessibility_Level_Helper.Innermost_Master_Scope_Depth ???
18556 if not Disable_Subexpression_Masters
18557 and then Nkind
(N
) in N_Subexpr
18560 Par
: Node_Id
:= N
;
18562 subtype N_Simple_Statement_Other_Than_Simple_Return
18563 is Node_Kind
with Static_Predicate
=>
18564 N_Simple_Statement_Other_Than_Simple_Return
18565 in N_Abort_Statement
18566 | N_Assignment_Statement
18568 | N_Delay_Statement
18569 | N_Entry_Call_Statement
18573 | N_Raise_Statement
18574 | N_Requeue_Statement
18576 | N_Procedure_Call_Statement
;
18578 while Present
(Par
) loop
18579 Par
:= Parent
(Par
);
18580 if Nkind
(Par
) in N_Subexpr |
18581 N_Simple_Statement_Other_Than_Simple_Return
18594 -----------------------
18595 -- Is_Name_Reference --
18596 -----------------------
18598 function Is_Name_Reference
(N
: Node_Id
) return Boolean is
18600 if Is_Entity_Name
(N
) then
18601 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
));
18605 when N_Indexed_Component
18609 Is_Name_Reference
(Prefix
(N
))
18610 or else Is_Access_Type
(Etype
(Prefix
(N
)));
18612 -- Attributes 'Input, 'Old and 'Result produce objects
18614 when N_Attribute_Reference
=>
18615 return Attribute_Name
(N
) in Name_Input | Name_Old | Name_Result
;
18617 when N_Selected_Component
=>
18619 Is_Name_Reference
(Selector_Name
(N
))
18621 (Is_Name_Reference
(Prefix
(N
))
18622 or else Is_Access_Type
(Etype
(Prefix
(N
))));
18624 when N_Explicit_Dereference
=>
18627 -- A view conversion of a tagged name is a name reference
18629 when N_Type_Conversion
=>
18631 Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
18632 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
18633 and then Is_Name_Reference
(Expression
(N
));
18635 -- An unchecked type conversion is considered to be a name if the
18636 -- operand is a name (this construction arises only as a result of
18637 -- expansion activities).
18639 when N_Unchecked_Type_Conversion
=>
18640 return Is_Name_Reference
(Expression
(N
));
18645 end Is_Name_Reference
;
18647 --------------------------
18648 -- Is_Newly_Constructed --
18649 --------------------------
18651 function Is_Newly_Constructed
18652 (Exp
: Node_Id
; Context_Requires_NC
: Boolean) return Boolean
18654 Original_Exp
: constant Node_Id
:= Original_Node
(Exp
);
18656 function Is_NC
(Exp
: Node_Id
) return Boolean is
18657 (Is_Newly_Constructed
(Exp
, Context_Requires_NC
));
18659 -- If the context requires that the expression shall be newly
18660 -- constructed, then "True" is a good result in the sense that the
18661 -- expression satisfies the requirements of the context (and "False"
18662 -- is analogously a bad result). If the context requires that the
18663 -- expression shall *not* be newly constructed, then things are
18664 -- reversed: "False" is the good value and "True" is the bad value.
18666 Good_Result
: constant Boolean := Context_Requires_NC
;
18667 Bad_Result
: constant Boolean := not Good_Result
;
18669 case Nkind
(Original_Exp
) is
18671 | N_Extension_Aggregate
18677 when N_Identifier
=>
18678 return Present
(Entity
(Original_Exp
))
18679 and then Ekind
(Entity
(Original_Exp
)) = E_Function
;
18681 when N_Qualified_Expression
=>
18682 return Is_NC
(Expression
(Original_Exp
));
18684 when N_Type_Conversion
18685 | N_Unchecked_Type_Conversion
18687 if Is_View_Conversion
(Original_Exp
) then
18688 return Is_NC
(Expression
(Original_Exp
));
18689 elsif not Comes_From_Source
(Exp
) then
18690 if Exp
/= Original_Exp
then
18691 return Is_NC
(Original_Exp
);
18693 return Is_NC
(Expression
(Original_Exp
));
18699 when N_Explicit_Dereference
18700 | N_Indexed_Component
18701 | N_Selected_Component
18703 return Nkind
(Exp
) = N_Function_Call
;
18705 -- A use of 'Input is a function call, hence allowed. Normally the
18706 -- attribute will be changed to a call, but the attribute by itself
18707 -- can occur with -gnatc.
18709 when N_Attribute_Reference
=>
18710 return Attribute_Name
(Original_Exp
) = Name_Input
;
18712 -- "return raise ..." is OK
18714 when N_Raise_Expression
=>
18715 return Good_Result
;
18717 -- For a case expression, all dependent expressions must be legal
18719 when N_Case_Expression
=>
18724 Alt
:= First
(Alternatives
(Original_Exp
));
18725 while Present
(Alt
) loop
18726 if Is_NC
(Expression
(Alt
)) = Bad_Result
then
18733 return Good_Result
;
18736 -- For an if expression, all dependent expressions must be legal
18738 when N_If_Expression
=>
18740 Then_Expr
: constant Node_Id
:=
18741 Next
(First
(Expressions
(Original_Exp
)));
18742 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
18744 if (Is_NC
(Then_Expr
) = Bad_Result
)
18745 or else (Is_NC
(Else_Expr
) = Bad_Result
)
18749 return Good_Result
;
18756 end Is_Newly_Constructed
;
18758 ------------------------------------
18759 -- Is_Non_Preelaborable_Construct --
18760 ------------------------------------
18762 function Is_Non_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
18764 -- NOTE: the routines within Is_Non_Preelaborable_Construct are
18765 -- intentionally unnested to avoid deep indentation of code.
18767 Non_Preelaborable
: exception;
18768 -- This exception is raised when the construct violates preelaborability
18769 -- to terminate the recursion.
18771 procedure Visit
(Nod
: Node_Id
);
18772 -- Semantically inspect construct Nod to determine whether it violates
18773 -- preelaborability. This routine raises Non_Preelaborable.
18775 procedure Visit_List
(List
: List_Id
);
18776 pragma Inline
(Visit_List
);
18777 -- Invoke Visit on each element of list List. This routine raises
18778 -- Non_Preelaborable.
18780 procedure Visit_Pragma
(Prag
: Node_Id
);
18781 pragma Inline
(Visit_Pragma
);
18782 -- Semantically inspect pragma Prag to determine whether it violates
18783 -- preelaborability. This routine raises Non_Preelaborable.
18785 procedure Visit_Subexpression
(Expr
: Node_Id
);
18786 pragma Inline
(Visit_Subexpression
);
18787 -- Semantically inspect expression Expr to determine whether it violates
18788 -- preelaborability. This routine raises Non_Preelaborable.
18794 procedure Visit
(Nod
: Node_Id
) is
18796 case Nkind
(Nod
) is
18800 when N_Component_Declaration
=>
18802 -- Defining_Identifier is left out because it is not relevant
18803 -- for preelaborability.
18805 Visit
(Component_Definition
(Nod
));
18806 Visit
(Expression
(Nod
));
18808 when N_Derived_Type_Definition
=>
18810 -- Interface_List is left out because it is not relevant for
18811 -- preelaborability.
18813 Visit
(Record_Extension_Part
(Nod
));
18814 Visit
(Subtype_Indication
(Nod
));
18816 when N_Entry_Declaration
=>
18818 -- A protected type with at leat one entry is not preelaborable
18819 -- while task types are never preelaborable. This renders entry
18820 -- declarations non-preelaborable.
18822 raise Non_Preelaborable
;
18824 when N_Full_Type_Declaration
=>
18826 -- Defining_Identifier and Discriminant_Specifications are left
18827 -- out because they are not relevant for preelaborability.
18829 Visit
(Type_Definition
(Nod
));
18831 when N_Function_Instantiation
18832 | N_Package_Instantiation
18833 | N_Procedure_Instantiation
18835 -- Defining_Unit_Name and Name are left out because they are
18836 -- not relevant for preelaborability.
18838 Visit_List
(Generic_Associations
(Nod
));
18840 when N_Object_Declaration
=>
18842 -- Defining_Identifier is left out because it is not relevant
18843 -- for preelaborability.
18845 Visit
(Object_Definition
(Nod
));
18847 if Has_Init_Expression
(Nod
) then
18848 Visit
(Expression
(Nod
));
18850 elsif not Has_Preelaborable_Initialization
18851 (Etype
(Defining_Entity
(Nod
)))
18853 raise Non_Preelaborable
;
18856 when N_Private_Extension_Declaration
18857 | N_Subtype_Declaration
18859 -- Defining_Identifier, Discriminant_Specifications, and
18860 -- Interface_List are left out because they are not relevant
18861 -- for preelaborability.
18863 Visit
(Subtype_Indication
(Nod
));
18865 when N_Protected_Type_Declaration
18866 | N_Single_Protected_Declaration
18868 -- Defining_Identifier, Discriminant_Specifications, and
18869 -- Interface_List are left out because they are not relevant
18870 -- for preelaborability.
18872 Visit
(Protected_Definition
(Nod
));
18874 -- A [single] task type is never preelaborable
18876 when N_Single_Task_Declaration
18877 | N_Task_Type_Declaration
18879 raise Non_Preelaborable
;
18884 Visit_Pragma
(Nod
);
18888 when N_Statement_Other_Than_Procedure_Call
=>
18889 if Nkind
(Nod
) /= N_Null_Statement
then
18890 raise Non_Preelaborable
;
18896 Visit_Subexpression
(Nod
);
18900 when N_Access_To_Object_Definition
=>
18901 Visit
(Subtype_Indication
(Nod
));
18903 when N_Case_Expression_Alternative
=>
18904 Visit
(Expression
(Nod
));
18905 Visit_List
(Discrete_Choices
(Nod
));
18907 when N_Component_Definition
=>
18908 Visit
(Access_Definition
(Nod
));
18909 Visit
(Subtype_Indication
(Nod
));
18911 when N_Component_List
=>
18912 Visit_List
(Component_Items
(Nod
));
18913 Visit
(Variant_Part
(Nod
));
18915 when N_Constrained_Array_Definition
=>
18916 Visit_List
(Discrete_Subtype_Definitions
(Nod
));
18917 Visit
(Component_Definition
(Nod
));
18919 when N_Delta_Constraint
18920 | N_Digits_Constraint
18922 -- Delta_Expression and Digits_Expression are left out because
18923 -- they are not relevant for preelaborability.
18925 Visit
(Range_Constraint
(Nod
));
18927 when N_Discriminant_Specification
=>
18929 -- Defining_Identifier and Expression are left out because they
18930 -- are not relevant for preelaborability.
18932 Visit
(Discriminant_Type
(Nod
));
18934 when N_Generic_Association
=>
18936 -- Selector_Name is left out because it is not relevant for
18937 -- preelaborability.
18939 Visit
(Explicit_Generic_Actual_Parameter
(Nod
));
18941 when N_Index_Or_Discriminant_Constraint
=>
18942 Visit_List
(Constraints
(Nod
));
18944 when N_Iterator_Specification
=>
18946 -- Defining_Identifier is left out because it is not relevant
18947 -- for preelaborability.
18949 Visit
(Name
(Nod
));
18950 Visit
(Subtype_Indication
(Nod
));
18952 when N_Loop_Parameter_Specification
=>
18954 -- Defining_Identifier is left out because it is not relevant
18955 -- for preelaborability.
18957 Visit
(Discrete_Subtype_Definition
(Nod
));
18959 when N_Parameter_Association
=>
18960 Visit
(Explicit_Actual_Parameter
(N
));
18962 when N_Protected_Definition
=>
18964 -- End_Label is left out because it is not relevant for
18965 -- preelaborability.
18967 Visit_List
(Private_Declarations
(Nod
));
18968 Visit_List
(Visible_Declarations
(Nod
));
18970 when N_Range_Constraint
=>
18971 Visit
(Range_Expression
(Nod
));
18973 when N_Record_Definition
18976 -- End_Label, Discrete_Choices, and Interface_List are left out
18977 -- because they are not relevant for preelaborability.
18979 Visit
(Component_List
(Nod
));
18981 when N_Subtype_Indication
=>
18983 -- Subtype_Mark is left out because it is not relevant for
18984 -- preelaborability.
18986 Visit
(Constraint
(Nod
));
18988 when N_Unconstrained_Array_Definition
=>
18990 -- Subtype_Marks is left out because it is not relevant for
18991 -- preelaborability.
18993 Visit
(Component_Definition
(Nod
));
18995 when N_Variant_Part
=>
18997 -- Name is left out because it is not relevant for
18998 -- preelaborability.
19000 Visit_List
(Variants
(Nod
));
19013 procedure Visit_List
(List
: List_Id
) is
19017 if Present
(List
) then
19018 Nod
:= First
(List
);
19019 while Present
(Nod
) loop
19030 procedure Visit_Pragma
(Prag
: Node_Id
) is
19032 case Get_Pragma_Id
(Prag
) is
19034 | Pragma_Assert_And_Cut
19036 | Pragma_Async_Readers
19037 | Pragma_Async_Writers
19038 | Pragma_Attribute_Definition
19040 | Pragma_Constant_After_Elaboration
19042 | Pragma_Deadline_Floor
19043 | Pragma_Dispatching_Domain
19044 | Pragma_Effective_Reads
19045 | Pragma_Effective_Writes
19046 | Pragma_Extensions_Visible
19048 | Pragma_Secondary_Stack_Size
19050 | Pragma_Volatile_Function
19052 Visit_List
(Pragma_Argument_Associations
(Prag
));
19061 -------------------------
19062 -- Visit_Subexpression --
19063 -------------------------
19065 procedure Visit_Subexpression
(Expr
: Node_Id
) is
19066 procedure Visit_Aggregate
(Aggr
: Node_Id
);
19067 pragma Inline
(Visit_Aggregate
);
19068 -- Semantically inspect aggregate Aggr to determine whether it
19069 -- violates preelaborability.
19071 ---------------------
19072 -- Visit_Aggregate --
19073 ---------------------
19075 procedure Visit_Aggregate
(Aggr
: Node_Id
) is
19077 if not Is_Preelaborable_Aggregate
(Aggr
) then
19078 raise Non_Preelaborable
;
19080 end Visit_Aggregate
;
19082 -- Start of processing for Visit_Subexpression
19085 case Nkind
(Expr
) is
19087 | N_Qualified_Expression
19088 | N_Type_Conversion
19089 | N_Unchecked_Expression
19090 | N_Unchecked_Type_Conversion
19092 -- Subpool_Handle_Name and Subtype_Mark are left out because
19093 -- they are not relevant for preelaborability.
19095 Visit
(Expression
(Expr
));
19098 | N_Extension_Aggregate
19100 Visit_Aggregate
(Expr
);
19102 when N_Attribute_Reference
19103 | N_Explicit_Dereference
19106 -- Attribute_Name and Expressions are left out because they are
19107 -- not relevant for preelaborability.
19109 Visit
(Prefix
(Expr
));
19111 when N_Case_Expression
=>
19113 -- End_Span is left out because it is not relevant for
19114 -- preelaborability.
19116 Visit_List
(Alternatives
(Expr
));
19117 Visit
(Expression
(Expr
));
19119 when N_Delta_Aggregate
=>
19120 Visit_Aggregate
(Expr
);
19121 Visit
(Expression
(Expr
));
19123 when N_Expression_With_Actions
=>
19124 Visit_List
(Actions
(Expr
));
19125 Visit
(Expression
(Expr
));
19127 when N_Function_Call
=>
19129 -- Ada 2022 (AI12-0175): Calls to certain functions that are
19130 -- essentially unchecked conversions are preelaborable.
19132 if Ada_Version
>= Ada_2022
19133 and then Nkind
(Expr
) = N_Function_Call
19134 and then Is_Entity_Name
(Name
(Expr
))
19135 and then Is_Preelaborable_Function
(Entity
(Name
(Expr
)))
19137 Visit_List
(Parameter_Associations
(Expr
));
19139 raise Non_Preelaborable
;
19142 when N_If_Expression
=>
19143 Visit_List
(Expressions
(Expr
));
19145 when N_Quantified_Expression
=>
19146 Visit
(Condition
(Expr
));
19147 Visit
(Iterator_Specification
(Expr
));
19148 Visit
(Loop_Parameter_Specification
(Expr
));
19151 Visit
(High_Bound
(Expr
));
19152 Visit
(Low_Bound
(Expr
));
19155 Visit
(Discrete_Range
(Expr
));
19156 Visit
(Prefix
(Expr
));
19162 -- The evaluation of an object name is not preelaborable,
19163 -- unless the name is a static expression (checked further
19164 -- below), or statically denotes a discriminant.
19166 if Is_Entity_Name
(Expr
) then
19167 Object_Name
: declare
19168 Id
: constant Entity_Id
:= Entity
(Expr
);
19171 if Is_Object
(Id
) then
19172 if Ekind
(Id
) = E_Discriminant
then
19175 elsif Ekind
(Id
) in E_Constant | E_In_Parameter
19176 and then Present
(Discriminal_Link
(Id
))
19181 raise Non_Preelaborable
;
19186 -- A non-static expression is not preelaborable
19188 elsif not Is_OK_Static_Expression
(Expr
) then
19189 raise Non_Preelaborable
;
19192 end Visit_Subexpression
;
19194 -- Start of processing for Is_Non_Preelaborable_Construct
19199 -- At this point it is known that the construct is preelaborable
19205 -- The elaboration of the construct performs an action which violates
19206 -- preelaborability.
19208 when Non_Preelaborable
=>
19210 end Is_Non_Preelaborable_Construct
;
19212 ---------------------------------
19213 -- Is_Nontrivial_DIC_Procedure --
19214 ---------------------------------
19216 function Is_Nontrivial_DIC_Procedure
(Id
: Entity_Id
) return Boolean is
19217 Body_Decl
: Node_Id
;
19221 if Ekind
(Id
) = E_Procedure
and then Is_DIC_Procedure
(Id
) then
19223 Unit_Declaration_Node
19224 (Corresponding_Body
(Unit_Declaration_Node
(Id
)));
19226 -- The body of the Default_Initial_Condition procedure must contain
19227 -- at least one statement, otherwise the generation of the subprogram
19230 pragma Assert
(Present
(Handled_Statement_Sequence
(Body_Decl
)));
19232 -- To qualify as nontrivial, the first statement of the procedure
19233 -- must be a check in the form of an if statement. If the original
19234 -- Default_Initial_Condition expression was folded, then the first
19235 -- statement is not a check.
19237 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Body_Decl
)));
19240 Nkind
(Stmt
) = N_If_Statement
19241 and then Nkind
(Original_Node
(Stmt
)) = N_Pragma
;
19245 end Is_Nontrivial_DIC_Procedure
;
19247 -----------------------
19248 -- Is_Null_Extension --
19249 -----------------------
19251 function Is_Null_Extension
19252 (T
: Entity_Id
; Ignore_Privacy
: Boolean := False) return Boolean
19254 Type_Decl
: Node_Id
;
19255 Type_Def
: Node_Id
;
19257 pragma Assert
(not Is_Class_Wide_Type
(T
));
19259 if Ignore_Privacy
then
19260 Type_Decl
:= Parent
(Underlying_Type
(Base_Type
(T
)));
19262 Type_Decl
:= Parent
(Base_Type
(T
));
19263 if Nkind
(Type_Decl
) /= N_Full_Type_Declaration
then
19267 pragma Assert
(Nkind
(Type_Decl
) = N_Full_Type_Declaration
);
19268 Type_Def
:= Type_Definition
(Type_Decl
);
19269 if Present
(Discriminant_Specifications
(Type_Decl
))
19270 or else Nkind
(Type_Def
) /= N_Derived_Type_Definition
19271 or else not Is_Tagged_Type
(T
)
19272 or else No
(Record_Extension_Part
(Type_Def
))
19277 return Is_Null_Record_Definition
(Record_Extension_Part
(Type_Def
));
19278 end Is_Null_Extension
;
19280 --------------------------
19281 -- Is_Null_Extension_Of --
19282 --------------------------
19284 function Is_Null_Extension_Of
19285 (Descendant
, Ancestor
: Entity_Id
) return Boolean
19287 Ancestor_Type
: constant Entity_Id
19288 := Underlying_Type
(Base_Type
(Ancestor
));
19289 Descendant_Type
: Entity_Id
:= Underlying_Type
(Base_Type
(Descendant
));
19291 pragma Assert
(not Is_Class_Wide_Type
(Descendant
));
19292 pragma Assert
(not Is_Class_Wide_Type
(Ancestor
));
19293 pragma Assert
(Descendant_Type
/= Ancestor_Type
);
19295 while Descendant_Type
/= Ancestor_Type
loop
19296 if not Is_Null_Extension
19297 (Descendant_Type
, Ignore_Privacy
=> True)
19301 Descendant_Type
:= Etype
(Subtype_Indication
19302 (Type_Definition
(Parent
(Descendant_Type
))));
19303 Descendant_Type
:= Underlying_Type
(Base_Type
(Descendant_Type
));
19306 end Is_Null_Extension_Of
;
19308 -------------------------------
19309 -- Is_Null_Record_Definition --
19310 -------------------------------
19312 function Is_Null_Record_Definition
(Record_Def
: Node_Id
) return Boolean is
19315 -- Testing Null_Present is just an optimization, not required.
19317 if Null_Present
(Record_Def
) then
19319 elsif Present
(Variant_Part
(Component_List
(Record_Def
))) then
19321 elsif not Present
(Component_List
(Record_Def
)) then
19325 Item
:= First
(Component_Items
(Component_List
(Record_Def
)));
19327 while Present
(Item
) loop
19328 if Nkind
(Item
) = N_Component_Declaration
19329 and then Is_Internal_Name
(Chars
(Defining_Identifier
(Item
)))
19332 elsif Nkind
(Item
) = N_Pragma
then
19337 Item
:= Next
(Item
);
19341 end Is_Null_Record_Definition
;
19343 -------------------------
19344 -- Is_Null_Record_Type --
19345 -------------------------
19347 function Is_Null_Record_Type
19348 (T
: Entity_Id
; Ignore_Privacy
: Boolean := False) return Boolean
19351 Type_Def
: Node_Id
;
19353 if not Is_Record_Type
(T
) then
19357 if Ignore_Privacy
then
19358 Decl
:= Parent
(Underlying_Type
(Base_Type
(T
)));
19360 Decl
:= Parent
(Base_Type
(T
));
19361 if Nkind
(Decl
) /= N_Full_Type_Declaration
then
19365 pragma Assert
(Nkind
(Decl
) = N_Full_Type_Declaration
);
19366 Type_Def
:= Type_Definition
(Decl
);
19368 if Has_Discriminants
(Defining_Identifier
(Decl
)) then
19372 case Nkind
(Type_Def
) is
19373 when N_Record_Definition
=>
19374 return Is_Null_Record_Definition
(Type_Def
);
19375 when N_Derived_Type_Definition
=>
19376 if not Is_Null_Record_Type
19377 (Etype
(Subtype_Indication
(Type_Def
)),
19378 Ignore_Privacy
=> Ignore_Privacy
)
19381 elsif not Is_Tagged_Type
(T
) then
19384 return Is_Null_Extension
(T
, Ignore_Privacy
=> Ignore_Privacy
);
19389 end Is_Null_Record_Type
;
19391 ---------------------
19392 -- Is_Object_Image --
19393 ---------------------
19395 function Is_Object_Image
(Prefix
: Node_Id
) return Boolean is
19397 -- Here we test for the case that the prefix is not a type and assume
19398 -- if it is not then it must be a named value or an object reference.
19399 -- This is because the parser always checks that prefixes of attributes
19402 return not (Is_Entity_Name
(Prefix
)
19403 and then Is_Type
(Entity
(Prefix
))
19404 and then not Is_Current_Instance
(Prefix
));
19405 end Is_Object_Image
;
19407 -------------------------
19408 -- Is_Object_Reference --
19409 -------------------------
19411 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
19412 function Safe_Prefix
(N
: Node_Id
) return Node_Id
;
19413 -- Return Prefix (N) unless it has been rewritten as an
19414 -- N_Raise_xxx_Error node, in which case return its original node.
19420 function Safe_Prefix
(N
: Node_Id
) return Node_Id
is
19422 if Nkind
(Prefix
(N
)) in N_Raise_xxx_Error
then
19423 return Original_Node
(Prefix
(N
));
19430 -- AI12-0068: Note that a current instance reference in a type or
19431 -- subtype's aspect_specification is considered a value, not an object
19432 -- (see RM 8.6(18/5)).
19434 if Is_Entity_Name
(N
) then
19435 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
))
19436 and then not Is_Current_Instance_Reference_In_Type_Aspect
(N
);
19440 when N_Indexed_Component
19444 Is_Object_Reference
(Safe_Prefix
(N
))
19445 or else Is_Access_Type
(Etype
(Safe_Prefix
(N
)));
19447 -- In Ada 95, a function call is a constant object; a procedure
19450 -- Note that predefined operators are functions as well, and so
19451 -- are attributes that are (can be renamed as) functions.
19453 when N_Function_Call
19456 return Etype
(N
) /= Standard_Void_Type
;
19458 -- Attributes references 'Loop_Entry, 'Old, 'Priority and 'Result
19459 -- yield objects, even though they are not functions.
19461 when N_Attribute_Reference
=>
19463 Attribute_Name
(N
) in Name_Loop_Entry
19467 or else Is_Function_Attribute_Name
(Attribute_Name
(N
));
19469 when N_Selected_Component
=>
19471 Is_Object_Reference
(Selector_Name
(N
))
19473 (Is_Object_Reference
(Safe_Prefix
(N
))
19474 or else Is_Access_Type
(Etype
(Safe_Prefix
(N
))));
19476 -- An explicit dereference denotes an object, except that a
19477 -- conditional expression gets turned into an explicit dereference
19478 -- in some cases, and conditional expressions are not object
19481 when N_Explicit_Dereference
=>
19482 return Nkind
(Original_Node
(N
)) not in
19483 N_Case_Expression | N_If_Expression
;
19485 -- A view conversion of a tagged object is an object reference
19487 when N_Type_Conversion
=>
19488 if Ada_Version
<= Ada_2012
then
19489 -- A view conversion of a tagged object is an object
19491 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
19492 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
19493 and then Is_Object_Reference
(Expression
(N
));
19496 -- AI12-0226: In Ada 2022 a value conversion of an object is
19499 return Is_Object_Reference
(Expression
(N
));
19502 -- An unchecked type conversion is considered to be an object if
19503 -- the operand is an object (this construction arises only as a
19504 -- result of expansion activities).
19506 when N_Unchecked_Type_Conversion
=>
19509 -- AI05-0003: In Ada 2012 a qualified expression is a name.
19510 -- This allows disambiguation of function calls and the use
19511 -- of aggregates in more contexts.
19513 when N_Qualified_Expression
=>
19514 return Ada_Version
>= Ada_2012
19515 and then Is_Object_Reference
(Expression
(N
));
19517 -- In Ada 95 an aggregate is an object reference
19520 | N_Delta_Aggregate
19521 | N_Extension_Aggregate
19523 return Ada_Version
>= Ada_95
;
19525 -- A string literal is not an object reference, but it might come
19526 -- from rewriting of an object reference, e.g. from folding of an
19529 when N_String_Literal
=>
19530 return Is_Rewrite_Substitution
(N
)
19531 and then Is_Object_Reference
(Original_Node
(N
));
19533 -- AI12-0125: Target name represents a constant object
19535 when N_Target_Name
=>
19542 end Is_Object_Reference
;
19544 -----------------------------------
19545 -- Is_OK_Variable_For_Out_Formal --
19546 -----------------------------------
19548 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
19550 Note_Possible_Modification
(AV
, Sure
=> True);
19552 -- We must reject parenthesized variable names. Comes_From_Source is
19553 -- checked because there are currently cases where the compiler violates
19554 -- this rule (e.g. passing a task object to its controlled Initialize
19555 -- routine). This should be properly documented in sinfo???
19557 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
19560 -- A variable is always allowed
19562 elsif Is_Variable
(AV
) then
19565 -- Generalized indexing operations are rewritten as explicit
19566 -- dereferences, and it is only during resolution that we can
19567 -- check whether the context requires an access_to_variable type.
19569 elsif Nkind
(AV
) = N_Explicit_Dereference
19570 and then Present
(Etype
(Original_Node
(AV
)))
19571 and then Has_Implicit_Dereference
(Etype
(Original_Node
(AV
)))
19572 and then Ada_Version
>= Ada_2012
19574 return not Is_Access_Constant
(Etype
(Prefix
(AV
)));
19576 -- Unchecked conversions are allowed only if they come from the
19577 -- generated code, which sometimes uses unchecked conversions for out
19578 -- parameters in cases where code generation is unaffected. We tell
19579 -- source unchecked conversions by seeing if they are rewrites of
19580 -- an original Unchecked_Conversion function call, or of an explicit
19581 -- conversion of a function call or an aggregate (as may happen in the
19582 -- expansion of a packed array aggregate).
19584 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
19585 if Nkind
(Original_Node
(AV
)) in N_Function_Call | N_Aggregate
then
19588 elsif Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
then
19591 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
19592 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
19598 -- Normal type conversions are allowed if argument is a variable
19600 elsif Nkind
(AV
) = N_Type_Conversion
then
19601 if Is_Variable
(Expression
(AV
))
19602 and then Paren_Count
(Expression
(AV
)) = 0
19604 Note_Possible_Modification
(Expression
(AV
), Sure
=> True);
19607 -- We also allow a non-parenthesized expression that raises
19608 -- constraint error if it rewrites what used to be a variable
19610 elsif Raises_Constraint_Error
(Expression
(AV
))
19611 and then Paren_Count
(Expression
(AV
)) = 0
19612 and then Is_Variable
(Original_Node
(Expression
(AV
)))
19616 -- Type conversion of something other than a variable
19622 -- If this node is rewritten, then test the original form, if that is
19623 -- OK, then we consider the rewritten node OK (for example, if the
19624 -- original node is a conversion, then Is_Variable will not be true
19625 -- but we still want to allow the conversion if it converts a variable).
19627 elsif Is_Rewrite_Substitution
(AV
) then
19628 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
19630 -- All other non-variables are rejected
19635 end Is_OK_Variable_For_Out_Formal
;
19637 ----------------------------
19638 -- Is_OK_Volatile_Context --
19639 ----------------------------
19641 function Is_OK_Volatile_Context
19642 (Context
: Node_Id
;
19644 Check_Actuals
: Boolean) return Boolean
19646 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean;
19647 -- Determine whether an arbitrary node denotes a call to a protected
19648 -- entry, function, or procedure in prefixed form where the prefix is
19651 function Within_Check
(Nod
: Node_Id
) return Boolean;
19652 -- Determine whether an arbitrary node appears in a check node
19654 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean;
19655 -- Determine whether an arbitrary entity appears in a volatile function
19657 ---------------------------------
19658 -- Is_Protected_Operation_Call --
19659 ---------------------------------
19661 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean is
19666 -- A call to a protected operations retains its selected component
19667 -- form as opposed to other prefixed calls that are transformed in
19670 if Nkind
(Nod
) = N_Selected_Component
then
19671 Pref
:= Prefix
(Nod
);
19672 Subp
:= Selector_Name
(Nod
);
19676 and then Present
(Etype
(Pref
))
19677 and then Is_Protected_Type
(Etype
(Pref
))
19678 and then Is_Entity_Name
(Subp
)
19679 and then Present
(Entity
(Subp
))
19680 and then Ekind
(Entity
(Subp
)) in
19681 E_Entry | E_Entry_Family | E_Function | E_Procedure
;
19685 end Is_Protected_Operation_Call
;
19691 function Within_Check
(Nod
: Node_Id
) return Boolean is
19695 -- Climb the parent chain looking for a check node
19698 while Present
(Par
) loop
19699 if Nkind
(Par
) in N_Raise_xxx_Error
then
19702 -- Prevent the search from going too far
19704 elsif Is_Body_Or_Package_Declaration
(Par
) then
19708 Par
:= Parent
(Par
);
19714 ------------------------------
19715 -- Within_Volatile_Function --
19716 ------------------------------
19718 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean is
19719 pragma Assert
(Ekind
(Id
) = E_Return_Statement
);
19721 Func_Id
: constant Entity_Id
:= Return_Applies_To
(Id
);
19724 pragma Assert
(Ekind
(Func_Id
) in E_Function | E_Generic_Function
);
19726 return Is_Volatile_Function
(Func_Id
);
19727 end Within_Volatile_Function
;
19731 Obj_Id
: Entity_Id
;
19733 -- Start of processing for Is_OK_Volatile_Context
19736 -- Ignore context restriction when doing preanalysis, e.g. on a copy of
19737 -- an expression function, because this copy is not fully decorated and
19738 -- it is not possible to reliably decide the legality of the context.
19739 -- Any violations will be reported anyway when doing the full analysis.
19741 if not Full_Analysis
then
19745 -- For actual parameters within explicit parameter associations switch
19746 -- the context to the corresponding subprogram call.
19748 if Nkind
(Context
) = N_Parameter_Association
then
19749 return Is_OK_Volatile_Context
(Context
=> Parent
(Context
),
19750 Obj_Ref
=> Obj_Ref
,
19751 Check_Actuals
=> Check_Actuals
);
19753 -- The volatile object appears on either side of an assignment
19755 elsif Nkind
(Context
) = N_Assignment_Statement
then
19758 -- The volatile object is part of the initialization expression of
19761 elsif Nkind
(Context
) = N_Object_Declaration
19762 and then Present
(Expression
(Context
))
19763 and then Expression
(Context
) = Obj_Ref
19764 and then Nkind
(Parent
(Context
)) /= N_Expression_With_Actions
19766 Obj_Id
:= Defining_Entity
(Context
);
19768 -- The volatile object acts as the initialization expression of an
19769 -- extended return statement. This is valid context as long as the
19770 -- function is volatile.
19772 if Is_Return_Object
(Obj_Id
) then
19773 return Within_Volatile_Function
(Scope
(Obj_Id
));
19775 -- Otherwise this is a normal object initialization
19781 -- The volatile object acts as the name of a renaming declaration
19783 elsif Nkind
(Context
) = N_Object_Renaming_Declaration
19784 and then Name
(Context
) = Obj_Ref
19788 -- The volatile object appears as an actual parameter in a call to an
19789 -- instance of Unchecked_Conversion whose result is renamed.
19791 elsif Nkind
(Context
) = N_Function_Call
19792 and then Is_Entity_Name
(Name
(Context
))
19793 and then Is_Unchecked_Conversion_Instance
(Entity
(Name
(Context
)))
19794 and then Nkind
(Parent
(Context
)) = N_Object_Renaming_Declaration
19798 -- The volatile object is actually the prefix in a protected entry,
19799 -- function, or procedure call.
19801 elsif Is_Protected_Operation_Call
(Context
) then
19804 -- The volatile object appears as the expression of a simple return
19805 -- statement that applies to a volatile function.
19807 elsif Nkind
(Context
) = N_Simple_Return_Statement
19808 and then Expression
(Context
) = Obj_Ref
19811 Within_Volatile_Function
(Return_Statement_Entity
(Context
));
19813 -- The volatile object appears as the prefix of a name occurring in a
19814 -- non-interfering context.
19816 elsif Nkind
(Context
) in
19817 N_Attribute_Reference |
19818 N_Explicit_Dereference |
19819 N_Indexed_Component |
19820 N_Selected_Component |
19822 and then Prefix
(Context
) = Obj_Ref
19823 and then Is_OK_Volatile_Context
19824 (Context
=> Parent
(Context
),
19825 Obj_Ref
=> Context
,
19826 Check_Actuals
=> Check_Actuals
)
19830 -- The volatile object appears as the prefix of attributes Address,
19831 -- Alignment, Component_Size, First, First_Bit, Last, Last_Bit, Length,
19832 -- Position, Size, Storage_Size.
19834 elsif Nkind
(Context
) = N_Attribute_Reference
19835 and then Prefix
(Context
) = Obj_Ref
19836 and then Attribute_Name
(Context
) in Name_Address
19838 | Name_Component_Size
19846 | Name_Storage_Size
19850 -- The volatile object appears as the expression of a type conversion
19851 -- occurring in a non-interfering context.
19853 elsif Nkind
(Context
) in N_Qualified_Expression
19854 | N_Type_Conversion
19855 | N_Unchecked_Type_Conversion
19856 and then Expression
(Context
) = Obj_Ref
19857 and then Is_OK_Volatile_Context
19858 (Context
=> Parent
(Context
),
19859 Obj_Ref
=> Context
,
19860 Check_Actuals
=> Check_Actuals
)
19864 -- The volatile object appears as the expression in a delay statement
19866 elsif Nkind
(Context
) in N_Delay_Statement
then
19869 -- Allow references to volatile objects in various checks. This is not a
19870 -- direct SPARK 2014 requirement.
19872 elsif Within_Check
(Context
) then
19875 -- References to effectively volatile objects that appear as actual
19876 -- parameters in subprogram calls can be examined only after call itself
19877 -- has been resolved. Before that, assume such references to be legal.
19879 elsif Nkind
(Context
) in N_Subprogram_Call | N_Entry_Call_Statement
then
19880 if Check_Actuals
then
19883 Formal
: Entity_Id
;
19884 Subp
: constant Entity_Id
:= Get_Called_Entity
(Context
);
19886 Find_Actual
(Obj_Ref
, Formal
, Call
);
19887 pragma Assert
(Call
= Context
);
19889 -- An effectively volatile object may act as an actual when the
19890 -- corresponding formal is of a non-scalar effectively volatile
19891 -- type (SPARK RM 7.1.3(10)).
19893 if not Is_Scalar_Type
(Etype
(Formal
))
19894 and then Is_Effectively_Volatile_For_Reading
(Etype
(Formal
))
19898 -- An effectively volatile object may act as an actual in a
19899 -- call to an instance of Unchecked_Conversion. (SPARK RM
19902 elsif Is_Unchecked_Conversion_Instance
(Subp
) then
19915 end Is_OK_Volatile_Context
;
19917 ------------------------------------
19918 -- Is_Package_Contract_Annotation --
19919 ------------------------------------
19921 function Is_Package_Contract_Annotation
(Item
: Node_Id
) return Boolean is
19925 if Nkind
(Item
) = N_Aspect_Specification
then
19926 Nam
:= Chars
(Identifier
(Item
));
19928 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
19929 Nam
:= Pragma_Name
(Item
);
19932 return Nam
= Name_Abstract_State
19933 or else Nam
= Name_Initial_Condition
19934 or else Nam
= Name_Initializes
19935 or else Nam
= Name_Refined_State
;
19936 end Is_Package_Contract_Annotation
;
19938 -----------------------------------
19939 -- Is_Partially_Initialized_Type --
19940 -----------------------------------
19942 function Is_Partially_Initialized_Type
19944 Include_Implicit
: Boolean := True) return Boolean
19947 if Is_Scalar_Type
(Typ
) then
19948 return Has_Default_Aspect
(Base_Type
(Typ
));
19950 elsif Is_Access_Type
(Typ
) then
19951 return Include_Implicit
;
19953 elsif Is_Array_Type
(Typ
) then
19955 -- If component type is partially initialized, so is array type
19957 if Has_Default_Aspect
(Base_Type
(Typ
))
19958 or else Is_Partially_Initialized_Type
19959 (Component_Type
(Typ
), Include_Implicit
)
19963 -- Otherwise we are only partially initialized if we are fully
19964 -- initialized (this is the empty array case, no point in us
19965 -- duplicating that code here).
19968 return Is_Fully_Initialized_Type
(Typ
);
19971 elsif Is_Record_Type
(Typ
) then
19973 -- A discriminated type is always partially initialized if in
19976 if Has_Discriminants
(Typ
) and then Include_Implicit
then
19979 -- A tagged type is always partially initialized
19981 elsif Is_Tagged_Type
(Typ
) then
19984 -- Case of nondiscriminated record
19990 Component_Present
: Boolean := False;
19991 -- Set True if at least one component is present. If no
19992 -- components are present, then record type is fully
19993 -- initialized (another odd case, like the null array).
19996 -- Loop through components
19998 Comp
:= First_Component
(Typ
);
19999 while Present
(Comp
) loop
20000 Component_Present
:= True;
20002 -- If a component has an initialization expression then the
20003 -- enclosing record type is partially initialized
20005 if Present
(Parent
(Comp
))
20006 and then Present
(Expression
(Parent
(Comp
)))
20010 -- If a component is of a type which is itself partially
20011 -- initialized, then the enclosing record type is also.
20013 elsif Is_Partially_Initialized_Type
20014 (Etype
(Comp
), Include_Implicit
)
20019 Next_Component
(Comp
);
20022 -- No initialized components found. If we found any components
20023 -- they were all uninitialized so the result is false.
20025 if Component_Present
then
20028 -- But if we found no components, then all the components are
20029 -- initialized so we consider the type to be initialized.
20037 -- Concurrent types are always fully initialized
20039 elsif Is_Concurrent_Type
(Typ
) then
20042 -- For a private type, go to underlying type. If there is no underlying
20043 -- type then just assume this partially initialized. Not clear if this
20044 -- can happen in a non-error case, but no harm in testing for this.
20046 elsif Is_Private_Type
(Typ
) then
20048 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
20053 return Is_Partially_Initialized_Type
(U
, Include_Implicit
);
20057 -- For any other type (are there any?) assume partially initialized
20062 end Is_Partially_Initialized_Type
;
20064 ------------------------------------
20065 -- Is_Potentially_Persistent_Type --
20066 ------------------------------------
20068 function Is_Potentially_Persistent_Type
(T
: Entity_Id
) return Boolean is
20073 -- For private type, test corresponding full type
20075 if Is_Private_Type
(T
) then
20076 return Is_Potentially_Persistent_Type
(Full_View
(T
));
20078 -- Scalar types are potentially persistent
20080 elsif Is_Scalar_Type
(T
) then
20083 -- Record type is potentially persistent if not tagged and the types of
20084 -- all it components are potentially persistent, and no component has
20085 -- an initialization expression.
20087 elsif Is_Record_Type
(T
)
20088 and then not Is_Tagged_Type
(T
)
20089 and then not Is_Partially_Initialized_Type
(T
)
20091 Comp
:= First_Component
(T
);
20092 while Present
(Comp
) loop
20093 if not Is_Potentially_Persistent_Type
(Etype
(Comp
)) then
20096 Next_Entity
(Comp
);
20102 -- Array type is potentially persistent if its component type is
20103 -- potentially persistent and if all its constraints are static.
20105 elsif Is_Array_Type
(T
) then
20106 if not Is_Potentially_Persistent_Type
(Component_Type
(T
)) then
20110 Indx
:= First_Index
(T
);
20111 while Present
(Indx
) loop
20112 if not Is_OK_Static_Subtype
(Etype
(Indx
)) then
20121 -- All other types are not potentially persistent
20126 end Is_Potentially_Persistent_Type
;
20128 --------------------------------
20129 -- Is_Potentially_Unevaluated --
20130 --------------------------------
20132 function Is_Potentially_Unevaluated
(N
: Node_Id
) return Boolean is
20133 function Has_Null_Others_Choice
(Aggr
: Node_Id
) return Boolean;
20134 -- Aggr is an array aggregate with static bounds and an others clause;
20135 -- return True if the others choice of the given array aggregate does
20136 -- not cover any component (i.e. is null).
20138 function Immediate_Context_Implies_Is_Potentially_Unevaluated
20139 (Expr
: Node_Id
) return Boolean;
20140 -- Return True if the *immediate* context of this expression tells us
20141 -- that it is potentially unevaluated; return False if the *immediate*
20142 -- context doesn't provide an answer to this question and we need to
20145 function Non_Static_Or_Null_Range
(N
: Node_Id
) return Boolean;
20146 -- Return True if the given range is nonstatic or null
20148 ----------------------------
20149 -- Has_Null_Others_Choice --
20150 ----------------------------
20152 function Has_Null_Others_Choice
(Aggr
: Node_Id
) return Boolean is
20153 Idx
: constant Node_Id
:= First_Index
(Etype
(Aggr
));
20154 Hiv
: constant Uint
:= Expr_Value
(Type_High_Bound
(Etype
(Idx
)));
20155 Lov
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Etype
(Idx
)));
20159 Intervals
: constant Interval_Lists
.Discrete_Interval_List
:=
20160 Interval_Lists
.Aggregate_Intervals
(Aggr
);
20163 -- The others choice is null if, after normalization, we
20164 -- have a single interval covering the whole aggregate.
20166 return Intervals
'Length = 1
20168 Intervals
(Intervals
'First).Low
= Lov
20170 Intervals
(Intervals
'First).High
= Hiv
;
20173 -- If the aggregate is malformed (that is, indexes are not disjoint)
20174 -- then no action is needed at this stage; the error will be reported
20175 -- later by the frontend.
20178 when Interval_Lists
.Intervals_Error
=>
20180 end Has_Null_Others_Choice
;
20182 ----------------------------------------------------------
20183 -- Immediate_Context_Implies_Is_Potentially_Unevaluated --
20184 ----------------------------------------------------------
20186 function Immediate_Context_Implies_Is_Potentially_Unevaluated
20187 (Expr
: Node_Id
) return Boolean
20189 Par
: constant Node_Id
:= Parent
(Expr
);
20191 function Aggregate_Type
return Node_Id
is (Etype
(Parent
(Par
)));
20193 if Nkind
(Par
) = N_If_Expression
then
20194 return Is_Elsif
(Par
) or else Expr
/= First
(Expressions
(Par
));
20196 elsif Nkind
(Par
) = N_Case_Expression
then
20197 return Expr
/= Expression
(Par
);
20199 elsif Nkind
(Par
) in N_And_Then | N_Or_Else
then
20200 return Expr
= Right_Opnd
(Par
);
20202 elsif Nkind
(Par
) in N_In | N_Not_In
then
20204 -- If the membership includes several alternatives, only the first
20205 -- is definitely evaluated.
20207 if Present
(Alternatives
(Par
)) then
20208 return Expr
/= First
(Alternatives
(Par
));
20210 -- If this is a range membership both bounds are evaluated
20216 elsif Nkind
(Par
) = N_Quantified_Expression
then
20217 return Expr
= Condition
(Par
);
20219 elsif Nkind
(Par
) = N_Component_Association
20220 and then Expr
= Expression
(Par
)
20221 and then Nkind
(Parent
(Par
))
20222 in N_Aggregate | N_Delta_Aggregate | N_Extension_Aggregate
20223 and then Present
(Aggregate_Type
)
20224 and then Aggregate_Type
/= Any_Composite
20226 if Is_Array_Type
(Aggregate_Type
) then
20227 if Ada_Version
>= Ada_2022
then
20228 -- For Ada 2022, this predicate returns True for
20229 -- any "repeatedly evaluated" expression.
20235 In_Others_Choice
: Boolean := False;
20236 Array_Agg
: constant Node_Id
:= Parent
(Par
);
20238 -- The expression of an array_component_association is
20239 -- potentially unevaluated if the associated choice is a
20240 -- subtype_indication or range that defines a nonstatic or
20243 Choice
:= First
(Choices
(Par
));
20244 while Present
(Choice
) loop
20245 if Nkind
(Choice
) = N_Range
20246 and then Non_Static_Or_Null_Range
(Choice
)
20250 elsif Nkind
(Choice
) = N_Identifier
20251 and then Present
(Scalar_Range
(Etype
(Choice
)))
20253 Non_Static_Or_Null_Range
20254 (Scalar_Range
(Etype
(Choice
)))
20258 elsif Nkind
(Choice
) = N_Others_Choice
then
20259 In_Others_Choice
:= True;
20265 -- It is also potentially unevaluated if the associated
20266 -- choice is an others choice and the applicable index
20267 -- constraint is nonstatic or null.
20269 if In_Others_Choice
then
20270 if not Compile_Time_Known_Bounds
(Aggregate_Type
) then
20273 return Has_Null_Others_Choice
(Array_Agg
);
20278 elsif Is_Container_Aggregate
(Parent
(Par
)) then
20279 -- a component of a container aggregate
20288 end Immediate_Context_Implies_Is_Potentially_Unevaluated
;
20290 ------------------------------
20291 -- Non_Static_Or_Null_Range --
20292 ------------------------------
20294 function Non_Static_Or_Null_Range
(N
: Node_Id
) return Boolean is
20295 Low
, High
: Node_Id
;
20298 Get_Index_Bounds
(N
, Low
, High
);
20300 -- Check static bounds
20302 if not Compile_Time_Known_Value
(Low
)
20303 or else not Compile_Time_Known_Value
(High
)
20307 -- Check null range
20309 elsif Expr_Value
(High
) < Expr_Value
(Low
) then
20314 end Non_Static_Or_Null_Range
;
20321 -- Start of processing for Is_Potentially_Unevaluated
20327 -- A postcondition whose expression is a short-circuit is broken down
20328 -- into individual aspects for better exception reporting. The original
20329 -- short-circuit expression is rewritten as the second operand, and an
20330 -- occurrence of 'Old in that operand is potentially unevaluated.
20331 -- See sem_ch13.adb for details of this transformation. The reference
20332 -- to 'Old may appear within an expression, so we must look for the
20333 -- enclosing pragma argument in the tree that contains the reference.
20335 while Present
(Par
)
20336 and then Nkind
(Par
) /= N_Pragma_Argument_Association
20338 if Is_Rewrite_Substitution
(Par
)
20339 and then Nkind
(Original_Node
(Par
)) = N_And_Then
20344 Par
:= Parent
(Par
);
20347 -- Other cases; 'Old appears within other expression (not the top-level
20348 -- conjunct in a postcondition) with a potentially unevaluated operand.
20350 Par
:= Parent
(Expr
);
20352 while Present
(Par
)
20353 and then Nkind
(Par
) /= N_Pragma_Argument_Association
20355 if Comes_From_Source
(Par
)
20357 Immediate_Context_Implies_Is_Potentially_Unevaluated
(Expr
)
20361 -- For component associations continue climbing; it may be part of
20362 -- an array aggregate.
20364 elsif Nkind
(Par
) = N_Component_Association
then
20367 -- If the context is not an expression, or if is the result of
20368 -- expansion of an enclosing construct (such as another attribute)
20369 -- the predicate does not apply.
20371 elsif Nkind
(Par
) = N_Case_Expression_Alternative
then
20374 elsif Nkind
(Par
) not in N_Subexpr
20375 or else not Comes_From_Source
(Par
)
20381 Par
:= Parent
(Par
);
20385 end Is_Potentially_Unevaluated
;
20387 -----------------------------------------
20388 -- Is_Predefined_Dispatching_Operation --
20389 -----------------------------------------
20391 function Is_Predefined_Dispatching_Operation
20392 (E
: Entity_Id
) return Boolean
20394 TSS_Name
: TSS_Name_Type
;
20397 if not Is_Dispatching_Operation
(E
) then
20401 Get_Name_String
(Chars
(E
));
20403 -- Most predefined primitives have internally generated names. Equality
20404 -- must be treated differently; the predefined operation is recognized
20405 -- as a homogeneous binary operator that returns Boolean.
20407 if Name_Len
> TSS_Name_Type
'Last then
20410 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
20412 if Chars
(E
) in Name_uAssign | Name_uSize
20414 (Chars
(E
) = Name_Op_Eq
20415 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
20416 or else TSS_Name
= TSS_Deep_Adjust
20417 or else TSS_Name
= TSS_Deep_Finalize
20418 or else TSS_Name
= TSS_Stream_Input
20419 or else TSS_Name
= TSS_Stream_Output
20420 or else TSS_Name
= TSS_Stream_Read
20421 or else TSS_Name
= TSS_Stream_Write
20422 or else TSS_Name
= TSS_Put_Image
20423 or else Is_Predefined_Interface_Primitive
(E
)
20430 end Is_Predefined_Dispatching_Operation
;
20432 ---------------------------------------
20433 -- Is_Predefined_Interface_Primitive --
20434 ---------------------------------------
20436 function Is_Predefined_Interface_Primitive
(E
: Entity_Id
) return Boolean is
20438 -- In VM targets we don't restrict the functionality of this test to
20439 -- compiling in Ada 2005 mode since in VM targets any tagged type has
20440 -- these primitives.
20442 return (Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
)
20443 and then Chars
(E
) in Name_uDisp_Asynchronous_Select
20444 | Name_uDisp_Conditional_Select
20445 | Name_uDisp_Get_Prim_Op_Kind
20446 | Name_uDisp_Get_Task_Id
20447 | Name_uDisp_Requeue
20448 | Name_uDisp_Timed_Select
;
20449 end Is_Predefined_Interface_Primitive
;
20451 ---------------------------------------
20452 -- Is_Predefined_Internal_Operation --
20453 ---------------------------------------
20455 function Is_Predefined_Internal_Operation
20456 (E
: Entity_Id
) return Boolean
20458 TSS_Name
: TSS_Name_Type
;
20461 if not Is_Dispatching_Operation
(E
) then
20465 Get_Name_String
(Chars
(E
));
20467 -- Most predefined primitives have internally generated names. Equality
20468 -- must be treated differently; the predefined operation is recognized
20469 -- as a homogeneous binary operator that returns Boolean.
20471 if Name_Len
> TSS_Name_Type
'Last then
20474 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
20476 if Chars
(E
) in Name_uSize | Name_uAssign
20478 (Chars
(E
) = Name_Op_Eq
20479 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
20480 or else TSS_Name
= TSS_Deep_Adjust
20481 or else TSS_Name
= TSS_Deep_Finalize
20482 or else Is_Predefined_Interface_Primitive
(E
)
20489 end Is_Predefined_Internal_Operation
;
20491 --------------------------------
20492 -- Is_Preelaborable_Aggregate --
20493 --------------------------------
20495 function Is_Preelaborable_Aggregate
(Aggr
: Node_Id
) return Boolean is
20496 Aggr_Typ
: constant Entity_Id
:= Etype
(Aggr
);
20497 Array_Aggr
: constant Boolean := Is_Array_Type
(Aggr_Typ
);
20499 Anc_Part
: Node_Id
;
20502 Comp_Typ
: Entity_Id
:= Empty
; -- init to avoid warning
20507 Comp_Typ
:= Component_Type
(Aggr_Typ
);
20510 -- Inspect the ancestor part
20512 if Nkind
(Aggr
) = N_Extension_Aggregate
then
20513 Anc_Part
:= Ancestor_Part
(Aggr
);
20515 -- The ancestor denotes a subtype mark
20517 if Is_Entity_Name
(Anc_Part
)
20518 and then Is_Type
(Entity
(Anc_Part
))
20520 if not Has_Preelaborable_Initialization
(Entity
(Anc_Part
)) then
20524 -- Otherwise the ancestor denotes an expression
20526 elsif not Is_Preelaborable_Construct
(Anc_Part
) then
20531 -- Inspect the positional associations
20533 Expr
:= First
(Expressions
(Aggr
));
20534 while Present
(Expr
) loop
20535 if not Is_Preelaborable_Construct
(Expr
) then
20542 -- Inspect the named associations
20544 Assoc
:= First
(Component_Associations
(Aggr
));
20545 while Present
(Assoc
) loop
20547 -- Inspect the choices of the current named association
20549 Choice
:= First
(Choices
(Assoc
));
20550 while Present
(Choice
) loop
20553 -- For a choice to be preelaborable, it must denote either a
20554 -- static range or a static expression.
20556 if Nkind
(Choice
) = N_Others_Choice
then
20559 elsif Nkind
(Choice
) = N_Range
then
20560 if not Is_OK_Static_Range
(Choice
) then
20564 elsif not Is_OK_Static_Expression
(Choice
) then
20569 Comp_Typ
:= Etype
(Choice
);
20575 -- The type of the choice must have preelaborable initialization if
20576 -- the association carries a <>.
20578 pragma Assert
(Present
(Comp_Typ
));
20579 if Box_Present
(Assoc
) then
20580 if not Has_Preelaborable_Initialization
(Comp_Typ
) then
20584 -- The type of the expression must have preelaborable initialization
20586 elsif not Is_Preelaborable_Construct
(Expression
(Assoc
)) then
20593 -- At this point the aggregate is preelaborable
20596 end Is_Preelaborable_Aggregate
;
20598 --------------------------------
20599 -- Is_Preelaborable_Construct --
20600 --------------------------------
20602 function Is_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
20606 if Nkind
(N
) in N_Aggregate | N_Extension_Aggregate
then
20607 return Is_Preelaborable_Aggregate
(N
);
20609 -- Attributes are allowed in general, even if their prefix is a formal
20610 -- type. It seems that certain attributes known not to be static might
20611 -- not be allowed, but there are no rules to prevent them.
20613 elsif Nkind
(N
) = N_Attribute_Reference
then
20618 elsif Nkind
(N
) in N_Subexpr
and then Is_OK_Static_Expression
(N
) then
20621 elsif Nkind
(N
) = N_Qualified_Expression
then
20622 return Is_Preelaborable_Construct
(Expression
(N
));
20624 -- Names are preelaborable when they denote a discriminant of an
20625 -- enclosing type. Discriminals are also considered for this check.
20627 elsif Is_Entity_Name
(N
)
20628 and then Present
(Entity
(N
))
20630 (Ekind
(Entity
(N
)) = E_Discriminant
20631 or else (Ekind
(Entity
(N
)) in E_Constant | E_In_Parameter
20632 and then Present
(Discriminal_Link
(Entity
(N
)))))
20638 elsif Nkind
(N
) = N_Null
then
20641 -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially
20642 -- unchecked conversions are preelaborable.
20644 elsif Ada_Version
>= Ada_2022
20645 and then Nkind
(N
) = N_Function_Call
20646 and then Is_Entity_Name
(Name
(N
))
20647 and then Is_Preelaborable_Function
(Entity
(Name
(N
)))
20652 A
:= First_Actual
(N
);
20654 while Present
(A
) loop
20655 if not Is_Preelaborable_Construct
(A
) then
20665 -- Otherwise the construct is not preelaborable
20670 end Is_Preelaborable_Construct
;
20672 -------------------------------
20673 -- Is_Preelaborable_Function --
20674 -------------------------------
20676 function Is_Preelaborable_Function
(Id
: Entity_Id
) return Boolean is
20677 SATAC
: constant Rtsfind
.RTU_Id
:= System_Address_To_Access_Conversions
;
20678 Scop
: constant Entity_Id
:= Scope
(Id
);
20681 -- Small optimization: every allowed function has convention Intrinsic
20682 -- (see Analyze_Subprogram_Instantiation for the subtlety in the test).
20684 if not Is_Intrinsic_Subprogram
(Id
)
20685 and then Convention
(Id
) /= Convention_Intrinsic
20690 -- An instance of Unchecked_Conversion
20692 if Is_Unchecked_Conversion_Instance
(Id
) then
20696 -- A function declared in System.Storage_Elements
20698 if Is_RTU
(Scop
, System_Storage_Elements
) then
20702 -- The functions To_Pointer and To_Address declared in an instance of
20703 -- System.Address_To_Access_Conversions (they are the only ones).
20705 if Ekind
(Scop
) = E_Package
20706 and then Nkind
(Parent
(Scop
)) = N_Package_Specification
20707 and then Present
(Generic_Parent
(Parent
(Scop
)))
20708 and then Is_RTU
(Generic_Parent
(Parent
(Scop
)), SATAC
)
20714 end Is_Preelaborable_Function
;
20716 -----------------------------
20717 -- Is_Private_Library_Unit --
20718 -----------------------------
20720 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean is
20721 Comp_Unit
: constant Node_Id
:= Parent
(Unit_Declaration_Node
(Unit
));
20723 return Nkind
(Comp_Unit
) = N_Compilation_Unit
20724 and then Private_Present
(Comp_Unit
);
20725 end Is_Private_Library_Unit
;
20727 ---------------------------------
20728 -- Is_Protected_Self_Reference --
20729 ---------------------------------
20731 function Is_Protected_Self_Reference
(N
: Node_Id
) return Boolean is
20733 function In_Access_Definition
(N
: Node_Id
) return Boolean;
20734 -- Returns true if N belongs to an access definition
20736 --------------------------
20737 -- In_Access_Definition --
20738 --------------------------
20740 function In_Access_Definition
(N
: Node_Id
) return Boolean is
20745 while Present
(P
) loop
20746 if Nkind
(P
) = N_Access_Definition
then
20754 end In_Access_Definition
;
20756 -- Start of processing for Is_Protected_Self_Reference
20759 -- Verify that prefix is analyzed and has the proper form. Note that
20760 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also
20761 -- produce the address of an entity, do not analyze their prefix
20762 -- because they denote entities that are not necessarily visible.
20763 -- Neither of them can apply to a protected type.
20765 return Ada_Version
>= Ada_2005
20766 and then Is_Entity_Name
(N
)
20767 and then Present
(Entity
(N
))
20768 and then Is_Protected_Type
(Entity
(N
))
20769 and then In_Open_Scopes
(Entity
(N
))
20770 and then not In_Access_Definition
(N
);
20771 end Is_Protected_Self_Reference
;
20773 -----------------------------
20774 -- Is_RCI_Pkg_Spec_Or_Body --
20775 -----------------------------
20777 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
20779 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
20780 -- Return True if the unit of Cunit is an RCI package declaration
20782 ---------------------------
20783 -- Is_RCI_Pkg_Decl_Cunit --
20784 ---------------------------
20786 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
20787 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
20790 if Nkind
(The_Unit
) /= N_Package_Declaration
then
20794 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
20795 end Is_RCI_Pkg_Decl_Cunit
;
20797 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
20800 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
20802 (Nkind
(Unit
(Cunit
)) = N_Package_Body
20803 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
20804 end Is_RCI_Pkg_Spec_Or_Body
;
20806 -----------------------------------------
20807 -- Is_Remote_Access_To_Class_Wide_Type --
20808 -----------------------------------------
20810 function Is_Remote_Access_To_Class_Wide_Type
20811 (E
: Entity_Id
) return Boolean
20814 -- A remote access to class-wide type is a general access to object type
20815 -- declared in the visible part of a Remote_Types or Remote_Call_
20818 return Ekind
(E
) = E_General_Access_Type
20819 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
20820 end Is_Remote_Access_To_Class_Wide_Type
;
20822 -----------------------------------------
20823 -- Is_Remote_Access_To_Subprogram_Type --
20824 -----------------------------------------
20826 function Is_Remote_Access_To_Subprogram_Type
20827 (E
: Entity_Id
) return Boolean
20830 return (Ekind
(E
) = E_Access_Subprogram_Type
20831 or else (Ekind
(E
) = E_Record_Type
20832 and then Present
(Corresponding_Remote_Type
(E
))))
20833 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
20834 end Is_Remote_Access_To_Subprogram_Type
;
20836 --------------------
20837 -- Is_Remote_Call --
20838 --------------------
20840 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
20842 if Nkind
(N
) not in N_Subprogram_Call
then
20844 -- An entry call cannot be remote
20848 elsif Nkind
(Name
(N
)) in N_Has_Entity
20849 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
20851 -- A subprogram declared in the spec of a RCI package is remote
20855 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
20856 and then Is_Remote_Access_To_Subprogram_Type
20857 (Etype
(Prefix
(Name
(N
))))
20859 -- The dereference of a RAS is a remote call
20863 elsif Present
(Controlling_Argument
(N
))
20864 and then Is_Remote_Access_To_Class_Wide_Type
20865 (Etype
(Controlling_Argument
(N
)))
20867 -- Any primitive operation call with a controlling argument of
20868 -- a RACW type is a remote call.
20873 -- All other calls are local calls
20876 end Is_Remote_Call
;
20878 ----------------------
20879 -- Is_Renamed_Entry --
20880 ----------------------
20882 function Is_Renamed_Entry
(Proc_Nam
: Entity_Id
) return Boolean is
20883 Orig_Node
: Node_Id
:= Empty
;
20884 Subp_Decl
: Node_Id
:=
20885 (if No
(Parent
(Proc_Nam
)) then Empty
else Parent
(Parent
(Proc_Nam
)));
20887 function Is_Entry
(Nam
: Node_Id
) return Boolean;
20888 -- Determine whether Nam is an entry. Traverse selectors if there are
20889 -- nested selected components.
20895 function Is_Entry
(Nam
: Node_Id
) return Boolean is
20897 if Nkind
(Nam
) = N_Selected_Component
then
20898 return Is_Entry
(Selector_Name
(Nam
));
20901 return Ekind
(Entity
(Nam
)) = E_Entry
;
20904 -- Start of processing for Is_Renamed_Entry
20907 if Present
(Alias
(Proc_Nam
)) then
20908 Subp_Decl
:= Parent
(Parent
(Alias
(Proc_Nam
)));
20911 -- Look for a rewritten subprogram renaming declaration
20913 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
20914 and then Present
(Original_Node
(Subp_Decl
))
20916 Orig_Node
:= Original_Node
(Subp_Decl
);
20919 -- The rewritten subprogram is actually an entry
20921 if Present
(Orig_Node
)
20922 and then Nkind
(Orig_Node
) = N_Subprogram_Renaming_Declaration
20923 and then Is_Entry
(Name
(Orig_Node
))
20929 end Is_Renamed_Entry
;
20931 ----------------------------
20932 -- Is_Reversible_Iterator --
20933 ----------------------------
20935 function Is_Reversible_Iterator
(Typ
: Entity_Id
) return Boolean is
20936 Ifaces_List
: Elist_Id
;
20937 Iface_Elmt
: Elmt_Id
;
20941 if Is_Class_Wide_Type
(Typ
)
20942 and then Chars
(Root_Type
(Typ
)) = Name_Reversible_Iterator
20943 and then In_Predefined_Unit
(Root_Type
(Typ
))
20947 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
20951 Collect_Interfaces
(Typ
, Ifaces_List
);
20953 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
20954 while Present
(Iface_Elmt
) loop
20955 Iface
:= Node
(Iface_Elmt
);
20956 if Chars
(Iface
) = Name_Reversible_Iterator
20957 and then In_Predefined_Unit
(Iface
)
20962 Next_Elmt
(Iface_Elmt
);
20967 end Is_Reversible_Iterator
;
20969 ---------------------------------
20970 -- Is_Single_Concurrent_Object --
20971 ---------------------------------
20973 function Is_Single_Concurrent_Object
(Id
: Entity_Id
) return Boolean is
20976 Is_Single_Protected_Object
(Id
) or else Is_Single_Task_Object
(Id
);
20977 end Is_Single_Concurrent_Object
;
20979 -------------------------------
20980 -- Is_Single_Concurrent_Type --
20981 -------------------------------
20983 function Is_Single_Concurrent_Type
(Id
: Entity_Id
) return Boolean is
20986 Ekind
(Id
) in E_Protected_Type | E_Task_Type
20987 and then Is_Single_Concurrent_Type_Declaration
20988 (Declaration_Node
(Id
));
20989 end Is_Single_Concurrent_Type
;
20991 -------------------------------------------
20992 -- Is_Single_Concurrent_Type_Declaration --
20993 -------------------------------------------
20995 function Is_Single_Concurrent_Type_Declaration
20996 (N
: Node_Id
) return Boolean
20999 return Nkind
(Original_Node
(N
)) in
21000 N_Single_Protected_Declaration | N_Single_Task_Declaration
;
21001 end Is_Single_Concurrent_Type_Declaration
;
21003 ---------------------------------------------
21004 -- Is_Single_Precision_Floating_Point_Type --
21005 ---------------------------------------------
21007 function Is_Single_Precision_Floating_Point_Type
21008 (E
: Entity_Id
) return Boolean is
21010 return Is_Floating_Point_Type
(E
)
21011 and then Machine_Radix_Value
(E
) = Uint_2
21012 and then Machine_Mantissa_Value
(E
) = Uint_24
21013 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_7
21014 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_7
);
21015 end Is_Single_Precision_Floating_Point_Type
;
21017 --------------------------------
21018 -- Is_Single_Protected_Object --
21019 --------------------------------
21021 function Is_Single_Protected_Object
(Id
: Entity_Id
) return Boolean is
21024 Ekind
(Id
) = E_Variable
21025 and then Ekind
(Etype
(Id
)) = E_Protected_Type
21026 and then Is_Single_Concurrent_Type
(Etype
(Id
));
21027 end Is_Single_Protected_Object
;
21029 ---------------------------
21030 -- Is_Single_Task_Object --
21031 ---------------------------
21033 function Is_Single_Task_Object
(Id
: Entity_Id
) return Boolean is
21036 Ekind
(Id
) = E_Variable
21037 and then Ekind
(Etype
(Id
)) = E_Task_Type
21038 and then Is_Single_Concurrent_Type
(Etype
(Id
));
21039 end Is_Single_Task_Object
;
21041 --------------------------------------
21042 -- Is_Special_Aliased_Formal_Access --
21043 --------------------------------------
21045 function Is_Special_Aliased_Formal_Access
21047 In_Return_Context
: Boolean := False) return Boolean
21049 Scop
: constant Entity_Id
:= Current_Subprogram
;
21051 -- Verify the expression is an access reference to 'Access within a
21052 -- return statement as this is the only time an explicitly aliased
21053 -- formal has different semantics.
21055 if Nkind
(Exp
) /= N_Attribute_Reference
21056 or else Get_Attribute_Id
(Attribute_Name
(Exp
)) /= Attribute_Access
21057 or else not (In_Return_Value
(Exp
)
21058 or else In_Return_Context
)
21059 or else not Needs_Result_Accessibility_Level
(Scop
)
21064 -- Check if the prefix of the reference is indeed an explicitly aliased
21065 -- formal parameter for the function Scop. Additionally, we must check
21066 -- that Scop returns an anonymous access type, otherwise the special
21067 -- rules dictating a need for a dynamic check are not in effect.
21069 return Is_Entity_Name
(Prefix
(Exp
))
21070 and then Is_Explicitly_Aliased
(Entity
(Prefix
(Exp
)));
21071 end Is_Special_Aliased_Formal_Access
;
21073 -----------------------------
21074 -- Is_Specific_Tagged_Type --
21075 -----------------------------
21077 function Is_Specific_Tagged_Type
(Typ
: Entity_Id
) return Boolean is
21078 Full_Typ
: Entity_Id
;
21081 -- Handle private types
21083 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
21084 Full_Typ
:= Full_View
(Typ
);
21089 -- A specific tagged type is a non-class-wide tagged type
21091 return Is_Tagged_Type
(Full_Typ
) and not Is_Class_Wide_Type
(Full_Typ
);
21092 end Is_Specific_Tagged_Type
;
21098 function Is_Statement
(N
: Node_Id
) return Boolean is
21101 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
21102 or else Nkind
(N
) = N_Procedure_Call_Statement
;
21105 --------------------------------------
21106 -- Is_Static_Discriminant_Component --
21107 --------------------------------------
21109 function Is_Static_Discriminant_Component
(N
: Node_Id
) return Boolean is
21111 return Nkind
(N
) = N_Selected_Component
21112 and then not Is_In_Discriminant_Check
(N
)
21113 and then Present
(Etype
(Prefix
(N
)))
21114 and then Ekind
(Etype
(Prefix
(N
))) = E_Record_Subtype
21115 and then Has_Static_Discriminants
(Etype
(Prefix
(N
)))
21116 and then Present
(Entity
(Selector_Name
(N
)))
21117 and then Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
21118 and then not In_Check_Node
(N
);
21119 end Is_Static_Discriminant_Component
;
21121 ------------------------
21122 -- Is_Static_Function --
21123 ------------------------
21125 function Is_Static_Function
(Subp
: Entity_Id
) return Boolean is
21127 -- Always return False for pre Ada 2022 to e.g. ignore the Static
21128 -- aspect in package Interfaces for Ada_Version < 2022 and also
21131 return Ada_Version
>= Ada_2022
21132 and then Has_Aspect
(Subp
, Aspect_Static
)
21134 (No
(Find_Value_Of_Aspect
(Subp
, Aspect_Static
))
21135 or else Is_True
(Static_Boolean
21136 (Find_Value_Of_Aspect
(Subp
, Aspect_Static
))));
21137 end Is_Static_Function
;
21139 -----------------------------
21140 -- Is_Static_Function_Call --
21141 -----------------------------
21143 function Is_Static_Function_Call
(Call
: Node_Id
) return Boolean is
21144 function Has_All_Static_Actuals
(Call
: Node_Id
) return Boolean;
21145 -- Return whether all actual parameters of Call are static expressions
21147 ----------------------------
21148 -- Has_All_Static_Actuals --
21149 ----------------------------
21151 function Has_All_Static_Actuals
(Call
: Node_Id
) return Boolean is
21152 Actual
: Node_Id
:= First_Actual
(Call
);
21153 String_Result
: constant Boolean :=
21154 Is_String_Type
(Etype
(Entity
(Name
(Call
))));
21157 while Present
(Actual
) loop
21158 if not Is_Static_Expression
(Actual
) then
21160 -- ??? In the string-returning case we want to avoid a call
21161 -- being made to Establish_Transient_Scope in Resolve_Call,
21162 -- but at the point where that's tested for (which now includes
21163 -- a call to test Is_Static_Function_Call), the actuals of the
21164 -- call haven't been resolved, so expressions of the actuals
21165 -- may not have been marked Is_Static_Expression yet, so we
21166 -- force them to be resolved here, so we can tell if they're
21167 -- static. Calling Resolve here is admittedly a kludge, and we
21168 -- limit this call to string-returning cases.
21170 if String_Result
then
21174 -- Test flag again in case it's now True due to above Resolve
21176 if not Is_Static_Expression
(Actual
) then
21181 Next_Actual
(Actual
);
21185 end Has_All_Static_Actuals
;
21188 return Nkind
(Call
) = N_Function_Call
21189 and then Is_Entity_Name
(Name
(Call
))
21190 and then Is_Static_Function
(Entity
(Name
(Call
)))
21191 and then Has_All_Static_Actuals
(Call
);
21192 end Is_Static_Function_Call
;
21194 -------------------------------------------
21195 -- Is_Subcomponent_Of_Full_Access_Object --
21196 -------------------------------------------
21198 function Is_Subcomponent_Of_Full_Access_Object
(N
: Node_Id
) return Boolean
21203 R
:= Get_Referenced_Object
(N
);
21205 while Nkind
(R
) in N_Indexed_Component | N_Selected_Component | N_Slice
21207 R
:= Get_Referenced_Object
(Prefix
(R
));
21209 -- If the prefix is an access value, only the designated type matters
21211 if Is_Access_Type
(Etype
(R
)) then
21212 if Is_Full_Access
(Designated_Type
(Etype
(R
))) then
21217 if Is_Full_Access_Object
(R
) then
21224 end Is_Subcomponent_Of_Full_Access_Object
;
21226 ---------------------------------------
21227 -- Is_Subprogram_Contract_Annotation --
21228 ---------------------------------------
21230 function Is_Subprogram_Contract_Annotation
21231 (Item
: Node_Id
) return Boolean
21236 if Nkind
(Item
) = N_Aspect_Specification
then
21237 Nam
:= Chars
(Identifier
(Item
));
21239 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
21240 Nam
:= Pragma_Name
(Item
);
21243 return Nam
= Name_Contract_Cases
21244 or else Nam
= Name_Depends
21245 or else Nam
= Name_Extensions_Visible
21246 or else Nam
= Name_Global
21247 or else Nam
= Name_Post
21248 or else Nam
= Name_Post_Class
21249 or else Nam
= Name_Postcondition
21250 or else Nam
= Name_Pre
21251 or else Nam
= Name_Pre_Class
21252 or else Nam
= Name_Precondition
21253 or else Nam
= Name_Refined_Depends
21254 or else Nam
= Name_Refined_Global
21255 or else Nam
= Name_Refined_Post
21256 or else Nam
= Name_Subprogram_Variant
21257 or else Nam
= Name_Test_Case
;
21258 end Is_Subprogram_Contract_Annotation
;
21260 --------------------------------------------------
21261 -- Is_Subprogram_Stub_Without_Prior_Declaration --
21262 --------------------------------------------------
21264 function Is_Subprogram_Stub_Without_Prior_Declaration
21265 (N
: Node_Id
) return Boolean
21268 pragma Assert
(Nkind
(N
) = N_Subprogram_Body_Stub
);
21270 case Ekind
(Defining_Entity
(N
)) is
21272 -- A subprogram stub without prior declaration serves as declaration
21273 -- for the actual subprogram body. As such, it has an attached
21274 -- defining entity of E_Function or E_Procedure.
21281 -- Otherwise, it is completes a [generic] subprogram declaration
21283 when E_Generic_Function
21284 | E_Generic_Procedure
21285 | E_Subprogram_Body
21290 raise Program_Error
;
21292 end Is_Subprogram_Stub_Without_Prior_Declaration
;
21294 ---------------------------
21295 -- Is_Suitable_Primitive --
21296 ---------------------------
21298 function Is_Suitable_Primitive
(Subp_Id
: Entity_Id
) return Boolean is
21300 -- The Default_Initial_Condition and invariant procedures must not be
21301 -- treated as primitive operations even when they apply to a tagged
21302 -- type. These routines must not act as targets of dispatching calls
21303 -- because they already utilize class-wide-precondition semantics to
21304 -- handle inheritance and overriding.
21306 if Ekind
(Subp_Id
) = E_Procedure
21307 and then (Is_DIC_Procedure
(Subp_Id
)
21309 Is_Invariant_Procedure
(Subp_Id
))
21315 end Is_Suitable_Primitive
;
21317 ----------------------------
21318 -- Is_Synchronized_Object --
21319 ----------------------------
21321 function Is_Synchronized_Object
(Id
: Entity_Id
) return Boolean is
21325 if Is_Object
(Id
) then
21327 -- The object is synchronized if it is of a type that yields a
21328 -- synchronized object.
21330 if Yields_Synchronized_Object
(Etype
(Id
)) then
21333 -- The object is synchronized if it is atomic and Async_Writers is
21336 elsif Is_Atomic_Object_Entity
(Id
)
21337 and then Async_Writers_Enabled
(Id
)
21341 -- A constant is a synchronized object by default, unless its type is
21342 -- access-to-variable type.
21344 elsif Ekind
(Id
) = E_Constant
21345 and then not Is_Access_Variable
(Etype
(Id
))
21349 -- A variable is a synchronized object if it is subject to pragma
21350 -- Constant_After_Elaboration.
21352 elsif Ekind
(Id
) = E_Variable
then
21353 Prag
:= Get_Pragma
(Id
, Pragma_Constant_After_Elaboration
);
21355 return Present
(Prag
) and then Is_Enabled_Pragma
(Prag
);
21359 -- Otherwise the input is not an object or it does not qualify as a
21360 -- synchronized object.
21363 end Is_Synchronized_Object
;
21365 ---------------------------------
21366 -- Is_Synchronized_Tagged_Type --
21367 ---------------------------------
21369 function Is_Synchronized_Tagged_Type
(E
: Entity_Id
) return Boolean is
21370 Kind
: constant Entity_Kind
:= Ekind
(Base_Type
(E
));
21373 -- A task or protected type derived from an interface is a tagged type.
21374 -- Such a tagged type is called a synchronized tagged type, as are
21375 -- synchronized interfaces and private extensions whose declaration
21376 -- includes the reserved word synchronized.
21378 return (Is_Tagged_Type
(E
)
21379 and then (Kind
= E_Task_Type
21381 Kind
= E_Protected_Type
))
21384 and then Is_Synchronized_Interface
(E
))
21386 (Ekind
(E
) = E_Record_Type_With_Private
21387 and then Nkind
(Parent
(E
)) = N_Private_Extension_Declaration
21388 and then (Synchronized_Present
(Parent
(E
))
21389 or else Is_Synchronized_Interface
(Etype
(E
))));
21390 end Is_Synchronized_Tagged_Type
;
21396 function Is_Transfer
(N
: Node_Id
) return Boolean is
21397 Kind
: constant Node_Kind
:= Nkind
(N
);
21400 if Kind
= N_Simple_Return_Statement
21402 Kind
= N_Extended_Return_Statement
21404 Kind
= N_Goto_Statement
21406 Kind
= N_Raise_Statement
21408 Kind
= N_Requeue_Statement
21412 elsif (Kind
= N_Exit_Statement
or else Kind
in N_Raise_xxx_Error
)
21413 and then No
(Condition
(N
))
21417 elsif Kind
= N_Procedure_Call_Statement
21418 and then Is_Entity_Name
(Name
(N
))
21419 and then Present
(Entity
(Name
(N
)))
21420 and then No_Return
(Entity
(Name
(N
)))
21424 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
21436 function Is_True
(U
: Opt_Ubool
) return Boolean is
21438 return No
(U
) or else U
= Uint_1
;
21441 --------------------------------------
21442 -- Is_Unchecked_Conversion_Instance --
21443 --------------------------------------
21445 function Is_Unchecked_Conversion_Instance
(Id
: Entity_Id
) return Boolean is
21449 -- Look for a function whose generic parent is the predefined intrinsic
21450 -- function Unchecked_Conversion, or for one that renames such an
21453 if Ekind
(Id
) = E_Function
then
21454 Par
:= Parent
(Id
);
21456 if Nkind
(Par
) = N_Function_Specification
then
21457 Par
:= Generic_Parent
(Par
);
21459 if Present
(Par
) then
21461 Chars
(Par
) = Name_Unchecked_Conversion
21462 and then Is_Intrinsic_Subprogram
(Par
)
21463 and then In_Predefined_Unit
(Par
);
21466 Present
(Alias
(Id
))
21467 and then Is_Unchecked_Conversion_Instance
(Alias
(Id
));
21473 end Is_Unchecked_Conversion_Instance
;
21475 -------------------------------
21476 -- Is_Universal_Numeric_Type --
21477 -------------------------------
21479 function Is_Universal_Numeric_Type
(T
: Entity_Id
) return Boolean is
21481 return T
= Universal_Integer
or else T
= Universal_Real
;
21482 end Is_Universal_Numeric_Type
;
21484 ------------------------------
21485 -- Is_User_Defined_Equality --
21486 ------------------------------
21488 function Is_User_Defined_Equality
(Id
: Entity_Id
) return Boolean is
21489 F1
, F2
: Entity_Id
;
21492 -- An equality operator is a function that carries the name "=", returns
21493 -- Boolean, and has exactly two formal parameters of an identical type.
21495 if Ekind
(Id
) = E_Function
21496 and then Chars
(Id
) = Name_Op_Eq
21497 and then Base_Type
(Etype
(Id
)) = Standard_Boolean
21499 F1
:= First_Formal
(Id
);
21505 F2
:= Next_Formal
(F1
);
21507 return Present
(F2
)
21508 and then No
(Next_Formal
(F2
))
21509 and then Base_Type
(Etype
(F1
)) = Base_Type
(Etype
(F2
));
21514 end Is_User_Defined_Equality
;
21516 -----------------------------
21517 -- Is_User_Defined_Literal --
21518 -----------------------------
21520 function Is_User_Defined_Literal
21522 Typ
: Entity_Id
) return Boolean
21524 Literal_Aspect_Map
:
21525 constant array (N_Numeric_Or_String_Literal
) of Aspect_Id
:=
21526 (N_Integer_Literal
=> Aspect_Integer_Literal
,
21527 N_Real_Literal
=> Aspect_Real_Literal
,
21528 N_String_Literal
=> Aspect_String_Literal
);
21531 return Nkind
(N
) in N_Numeric_Or_String_Literal
21532 and then Present
(Find_Aspect
(Typ
, Literal_Aspect_Map
(Nkind
(N
))));
21533 end Is_User_Defined_Literal
;
21535 --------------------------------------
21536 -- Is_Validation_Variable_Reference --
21537 --------------------------------------
21539 function Is_Validation_Variable_Reference
(N
: Node_Id
) return Boolean is
21540 Var
: constant Node_Id
:= Unqual_Conv
(N
);
21541 Var_Id
: Entity_Id
;
21546 if Is_Entity_Name
(Var
) then
21547 Var_Id
:= Entity
(Var
);
21552 and then Ekind
(Var_Id
) = E_Variable
21553 and then Present
(Validated_Object
(Var_Id
));
21554 end Is_Validation_Variable_Reference
;
21556 ----------------------------
21557 -- Is_Variable_Size_Array --
21558 ----------------------------
21560 function Is_Variable_Size_Array
(E
: Entity_Id
) return Boolean is
21564 pragma Assert
(Is_Array_Type
(E
));
21566 -- Check if some index is initialized with a non-constant value
21568 Idx
:= First_Index
(E
);
21569 while Present
(Idx
) loop
21570 if Nkind
(Idx
) = N_Range
then
21571 if not Is_Constant_Bound
(Low_Bound
(Idx
))
21572 or else not Is_Constant_Bound
(High_Bound
(Idx
))
21582 end Is_Variable_Size_Array
;
21584 -----------------------------
21585 -- Is_Variable_Size_Record --
21586 -----------------------------
21588 function Is_Variable_Size_Record
(E
: Entity_Id
) return Boolean is
21590 Comp_Typ
: Entity_Id
;
21593 pragma Assert
(Is_Record_Type
(E
));
21595 Comp
:= First_Component
(E
);
21596 while Present
(Comp
) loop
21597 Comp_Typ
:= Underlying_Type
(Etype
(Comp
));
21599 -- Recursive call if the record type has discriminants
21601 if Is_Record_Type
(Comp_Typ
)
21602 and then Has_Discriminants
(Comp_Typ
)
21603 and then Is_Variable_Size_Record
(Comp_Typ
)
21607 elsif Is_Array_Type
(Comp_Typ
)
21608 and then Is_Variable_Size_Array
(Comp_Typ
)
21613 Next_Component
(Comp
);
21617 end Is_Variable_Size_Record
;
21623 -- Should Is_Variable be refactored to better handle dereferences and
21624 -- technical debt ???
21626 function Is_Variable
21628 Use_Original_Node
: Boolean := True) return Boolean
21630 Orig_Node
: Node_Id
;
21632 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
21633 -- Within a protected function, the private components of the enclosing
21634 -- protected type are constants. A function nested within a (protected)
21635 -- procedure is not itself protected. Within the body of a protected
21636 -- function the current instance of the protected type is a constant.
21638 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
21639 -- Prefixes can involve implicit dereferences, in which case we must
21640 -- test for the case of a reference of a constant access type, which can
21641 -- can never be a variable.
21643 ---------------------------
21644 -- In_Protected_Function --
21645 ---------------------------
21647 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
21652 -- E is the current instance of a type
21654 if Is_Type
(E
) then
21663 if not Is_Protected_Type
(Prot
) then
21667 S
:= Current_Scope
;
21668 while Present
(S
) and then S
/= Prot
loop
21669 if Ekind
(S
) = E_Function
and then Scope
(S
) = Prot
then
21678 end In_Protected_Function
;
21680 ------------------------
21681 -- Is_Variable_Prefix --
21682 ------------------------
21684 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
21686 if Is_Access_Type
(Etype
(P
)) then
21687 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
21689 -- For the case of an indexed component whose prefix has a packed
21690 -- array type, the prefix has been rewritten into a type conversion.
21691 -- Determine variable-ness from the converted expression.
21693 elsif Nkind
(P
) = N_Type_Conversion
21694 and then not Comes_From_Source
(P
)
21695 and then Is_Packed_Array
(Etype
(P
))
21697 return Is_Variable
(Expression
(P
));
21700 return Is_Variable
(P
);
21702 end Is_Variable_Prefix
;
21704 -- Start of processing for Is_Variable
21707 -- Special check, allow x'Deref(expr) as a variable
21709 if Nkind
(N
) = N_Attribute_Reference
21710 and then Attribute_Name
(N
) = Name_Deref
21715 -- Check if we perform the test on the original node since this may be a
21716 -- test of syntactic categories which must not be disturbed by whatever
21717 -- rewriting might have occurred. For example, an aggregate, which is
21718 -- certainly NOT a variable, could be turned into a variable by
21721 if Use_Original_Node
then
21722 Orig_Node
:= Original_Node
(N
);
21727 -- Definitely OK if Assignment_OK is set. Since this is something that
21728 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
21730 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
21733 -- Normally we go to the original node, but there is one exception where
21734 -- we use the rewritten node, namely when it is an explicit dereference.
21735 -- The generated code may rewrite a prefix which is an access type with
21736 -- an explicit dereference. The dereference is a variable, even though
21737 -- the original node may not be (since it could be a constant of the
21740 -- In Ada 2005 we have a further case to consider: the prefix may be a
21741 -- function call given in prefix notation. The original node appears to
21742 -- be a selected component, but we need to examine the call.
21744 elsif Nkind
(N
) = N_Explicit_Dereference
21745 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
21746 and then Present
(Etype
(Orig_Node
))
21747 and then Is_Access_Type
(Etype
(Orig_Node
))
21749 -- Note that if the prefix is an explicit dereference that does not
21750 -- come from source, we must check for a rewritten function call in
21751 -- prefixed notation before other forms of rewriting, to prevent a
21755 (Nkind
(Orig_Node
) = N_Function_Call
21756 and then not Is_Access_Constant
(Etype
(Prefix
(N
))))
21758 Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
21760 -- Generalized indexing operations are rewritten as explicit
21761 -- dereferences, and it is only during resolution that we can
21762 -- check whether the context requires an access_to_variable type.
21764 elsif Nkind
(N
) = N_Explicit_Dereference
21765 and then Present
(Etype
(Orig_Node
))
21766 and then Has_Implicit_Dereference
(Etype
(Orig_Node
))
21767 and then Ada_Version
>= Ada_2012
21769 return not Is_Access_Constant
(Etype
(Prefix
(N
)));
21771 -- A function call is never a variable
21773 elsif Nkind
(N
) = N_Function_Call
then
21776 -- All remaining checks use the original node
21778 elsif Is_Entity_Name
(Orig_Node
)
21779 and then Present
(Entity
(Orig_Node
))
21782 E
: constant Entity_Id
:= Entity
(Orig_Node
);
21783 K
: constant Entity_Kind
:= Ekind
(E
);
21786 if Is_Loop_Parameter
(E
) then
21790 return (K
= E_Variable
21791 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
21792 or else (K
= E_Component
21793 and then not In_Protected_Function
(E
))
21794 or else (Present
(Etype
(E
))
21795 and then Is_Access_Object_Type
(Etype
(E
))
21796 and then Is_Access_Variable
(Etype
(E
))
21797 and then Is_Dereferenced
(N
))
21798 or else K
= E_Out_Parameter
21799 or else K
= E_In_Out_Parameter
21800 or else K
= E_Generic_In_Out_Parameter
21802 -- Current instance of type. If this is a protected type, check
21803 -- we are not within the body of one of its protected functions.
21805 or else (Is_Type
(E
)
21806 and then In_Open_Scopes
(E
)
21807 and then not In_Protected_Function
(E
))
21809 or else (Is_Incomplete_Or_Private_Type
(E
)
21810 and then In_Open_Scopes
(Full_View
(E
)));
21814 case Nkind
(Orig_Node
) is
21815 when N_Indexed_Component
21818 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
21820 when N_Selected_Component
=>
21821 return (Is_Variable
(Selector_Name
(Orig_Node
))
21822 and then Is_Variable_Prefix
(Prefix
(Orig_Node
)))
21824 (Nkind
(N
) = N_Expanded_Name
21825 and then Scope
(Entity
(N
)) = Entity
(Prefix
(N
)));
21827 -- For an explicit dereference, the type of the prefix cannot
21828 -- be an access to constant or an access to subprogram.
21830 when N_Explicit_Dereference
=>
21832 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
21834 return Is_Access_Type
(Typ
)
21835 and then not Is_Access_Constant
(Root_Type
(Typ
))
21836 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
21839 -- The type conversion is the case where we do not deal with the
21840 -- context dependent special case of an actual parameter. Thus
21841 -- the type conversion is only considered a variable for the
21842 -- purposes of this routine if the target type is tagged. However,
21843 -- a type conversion is considered to be a variable if it does not
21844 -- come from source (this deals for example with the conversions
21845 -- of expressions to their actual subtypes).
21847 when N_Type_Conversion
=>
21848 return Is_Variable
(Expression
(Orig_Node
))
21850 (not Comes_From_Source
(Orig_Node
)
21852 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
21854 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
21856 -- GNAT allows an unchecked type conversion as a variable. This
21857 -- only affects the generation of internal expanded code, since
21858 -- calls to instantiations of Unchecked_Conversion are never
21859 -- considered variables (since they are function calls).
21861 when N_Unchecked_Type_Conversion
=>
21862 return Is_Variable
(Expression
(Orig_Node
));
21870 ------------------------
21871 -- Is_View_Conversion --
21872 ------------------------
21874 function Is_View_Conversion
(N
: Node_Id
) return Boolean is
21876 if Nkind
(N
) = N_Type_Conversion
21877 and then Nkind
(Unqual_Conv
(N
)) in N_Has_Etype
21879 if Is_Tagged_Type
(Etype
(N
))
21880 and then Is_Tagged_Type
(Etype
(Unqual_Conv
(N
)))
21884 elsif Is_Actual_Parameter
(N
)
21885 and then (Is_Actual_Out_Parameter
(N
)
21886 or else Is_Actual_In_Out_Parameter
(N
))
21893 end Is_View_Conversion
;
21895 ---------------------------
21896 -- Is_Visibly_Controlled --
21897 ---------------------------
21899 function Is_Visibly_Controlled
(T
: Entity_Id
) return Boolean is
21900 Root
: constant Entity_Id
:= Root_Type
(T
);
21902 return Chars
(Scope
(Root
)) = Name_Finalization
21903 and then Chars
(Scope
(Scope
(Root
))) = Name_Ada
21904 and then Scope
(Scope
(Scope
(Root
))) = Standard_Standard
;
21905 end Is_Visibly_Controlled
;
21907 ----------------------------------------
21908 -- Is_Volatile_Full_Access_Object_Ref --
21909 ----------------------------------------
21911 function Is_Volatile_Full_Access_Object_Ref
(N
: Node_Id
) return Boolean is
21912 function Is_VFA_Object_Entity
(Id
: Entity_Id
) return Boolean;
21913 -- Determine whether arbitrary entity Id denotes an object that is
21914 -- Volatile_Full_Access.
21916 ----------------------------
21917 -- Is_VFA_Object_Entity --
21918 ----------------------------
21920 function Is_VFA_Object_Entity
(Id
: Entity_Id
) return Boolean is
21924 and then (Is_Volatile_Full_Access
(Id
)
21926 Is_Volatile_Full_Access
(Etype
(Id
)));
21927 end Is_VFA_Object_Entity
;
21929 -- Start of processing for Is_Volatile_Full_Access_Object_Ref
21932 if Is_Entity_Name
(N
) then
21933 return Is_VFA_Object_Entity
(Entity
(N
));
21935 elsif Is_Volatile_Full_Access
(Etype
(N
)) then
21938 elsif Nkind
(N
) = N_Selected_Component
then
21939 return Is_Volatile_Full_Access
(Entity
(Selector_Name
(N
)));
21944 end Is_Volatile_Full_Access_Object_Ref
;
21946 --------------------------
21947 -- Is_Volatile_Function --
21948 --------------------------
21950 function Is_Volatile_Function
(Func_Id
: Entity_Id
) return Boolean is
21952 pragma Assert
(Ekind
(Func_Id
) in E_Function | E_Generic_Function
);
21954 -- A protected function is volatile
21956 if Nkind
(Parent
(Unit_Declaration_Node
(Func_Id
))) =
21957 N_Protected_Definition
21961 -- An instance of Ada.Unchecked_Conversion is a volatile function if
21962 -- either the source or the target are effectively volatile.
21964 elsif Is_Unchecked_Conversion_Instance
(Func_Id
)
21965 and then Has_Effectively_Volatile_Profile
(Func_Id
)
21969 -- Otherwise the function is treated as volatile if it is subject to
21970 -- enabled pragma Volatile_Function.
21974 Is_Enabled_Pragma
(Get_Pragma
(Func_Id
, Pragma_Volatile_Function
));
21976 end Is_Volatile_Function
;
21978 ----------------------------
21979 -- Is_Volatile_Object_Ref --
21980 ----------------------------
21982 function Is_Volatile_Object_Ref
(N
: Node_Id
) return Boolean is
21983 function Is_Volatile_Object_Entity
(Id
: Entity_Id
) return Boolean;
21984 -- Determine whether arbitrary entity Id denotes an object that is
21987 function Prefix_Has_Volatile_Components
(P
: Node_Id
) return Boolean;
21988 -- Determine whether prefix P has volatile components. This requires
21989 -- the presence of a Volatile_Components aspect/pragma or that P be
21990 -- itself a volatile object as per RM C.6(8).
21992 ---------------------------------
21993 -- Is_Volatile_Object_Entity --
21994 ---------------------------------
21996 function Is_Volatile_Object_Entity
(Id
: Entity_Id
) return Boolean is
22000 and then (Is_Volatile
(Id
) or else Is_Volatile
(Etype
(Id
)));
22001 end Is_Volatile_Object_Entity
;
22003 ------------------------------------
22004 -- Prefix_Has_Volatile_Components --
22005 ------------------------------------
22007 function Prefix_Has_Volatile_Components
(P
: Node_Id
) return Boolean is
22008 Typ
: constant Entity_Id
:= Etype
(P
);
22011 if Is_Access_Type
(Typ
) then
22013 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
22016 return Has_Volatile_Components
(Dtyp
)
22017 or else Is_Volatile
(Dtyp
);
22020 elsif Has_Volatile_Components
(Typ
) then
22023 elsif Is_Entity_Name
(P
)
22024 and then Has_Volatile_Component
(Entity
(P
))
22028 elsif Is_Volatile_Object_Ref
(P
) then
22034 end Prefix_Has_Volatile_Components
;
22036 -- Start of processing for Is_Volatile_Object_Ref
22039 if Is_Entity_Name
(N
) then
22040 return Is_Volatile_Object_Entity
(Entity
(N
));
22042 elsif Is_Volatile
(Etype
(N
)) then
22045 elsif Nkind
(N
) = N_Indexed_Component
then
22046 return Prefix_Has_Volatile_Components
(Prefix
(N
));
22048 elsif Nkind
(N
) = N_Selected_Component
then
22049 return Prefix_Has_Volatile_Components
(Prefix
(N
))
22050 or else Is_Volatile
(Entity
(Selector_Name
(N
)));
22055 end Is_Volatile_Object_Ref
;
22057 -----------------------------
22058 -- Iterate_Call_Parameters --
22059 -----------------------------
22061 procedure Iterate_Call_Parameters
(Call
: Node_Id
) is
22062 Actual
: Node_Id
:= First_Actual
(Call
);
22063 Formal
: Entity_Id
:= First_Formal
(Get_Called_Entity
(Call
));
22066 while Present
(Formal
) and then Present
(Actual
) loop
22067 Handle_Parameter
(Formal
, Actual
);
22069 Next_Formal
(Formal
);
22070 Next_Actual
(Actual
);
22073 pragma Assert
(No
(Formal
));
22074 pragma Assert
(No
(Actual
));
22075 end Iterate_Call_Parameters
;
22077 ---------------------------
22078 -- Itype_Has_Declaration --
22079 ---------------------------
22081 function Itype_Has_Declaration
(Id
: Entity_Id
) return Boolean is
22083 pragma Assert
(Is_Itype
(Id
));
22084 return Present
(Parent
(Id
))
22085 and then Nkind
(Parent
(Id
)) in
22086 N_Full_Type_Declaration | N_Subtype_Declaration
22087 and then Defining_Entity
(Parent
(Id
)) = Id
;
22088 end Itype_Has_Declaration
;
22090 -------------------------
22091 -- Kill_Current_Values --
22092 -------------------------
22094 procedure Kill_Current_Values
22096 Last_Assignment_Only
: Boolean := False)
22099 if Is_Assignable
(Ent
) then
22100 Set_Last_Assignment
(Ent
, Empty
);
22103 if Is_Object
(Ent
) then
22104 if not Last_Assignment_Only
then
22106 Set_Current_Value
(Ent
, Empty
);
22108 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags
22109 -- for a constant. Once the constant is elaborated, its value is
22110 -- not changed, therefore the associated flags that describe the
22111 -- value should not be modified either.
22113 if Ekind
(Ent
) = E_Constant
then
22116 -- Non-constant entities
22119 if not Can_Never_Be_Null
(Ent
) then
22120 Set_Is_Known_Non_Null
(Ent
, False);
22123 Set_Is_Known_Null
(Ent
, False);
22125 -- Reset the Is_Known_Valid flag unless the type is always
22126 -- valid. This does not apply to a loop parameter because its
22127 -- bounds are defined by the loop header and therefore always
22130 if not Is_Known_Valid
(Etype
(Ent
))
22131 and then Ekind
(Ent
) /= E_Loop_Parameter
22133 Set_Is_Known_Valid
(Ent
, False);
22138 end Kill_Current_Values
;
22140 procedure Kill_Current_Values
(Last_Assignment_Only
: Boolean := False) is
22143 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
);
22144 -- Clear current value for entity E and all entities chained to E
22146 ------------------------------------------
22147 -- Kill_Current_Values_For_Entity_Chain --
22148 ------------------------------------------
22150 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
) is
22154 while Present
(Ent
) loop
22155 Kill_Current_Values
(Ent
, Last_Assignment_Only
);
22158 end Kill_Current_Values_For_Entity_Chain
;
22160 -- Start of processing for Kill_Current_Values
22163 -- Kill all saved checks, a special case of killing saved values
22165 if not Last_Assignment_Only
then
22169 -- Loop through relevant scopes, which includes the current scope and
22170 -- any parent scopes if the current scope is a block or a package.
22172 S
:= Current_Scope
;
22175 -- Clear current values of all entities in current scope
22177 Kill_Current_Values_For_Entity_Chain
(First_Entity
(S
));
22179 -- If scope is a package, also clear current values of all private
22180 -- entities in the scope.
22182 if Is_Package_Or_Generic_Package
(S
)
22183 or else Is_Concurrent_Type
(S
)
22185 Kill_Current_Values_For_Entity_Chain
(First_Private_Entity
(S
));
22188 -- If this is a not a subprogram, deal with parents
22190 if not Is_Subprogram
(S
) then
22192 exit Scope_Loop
when S
= Standard_Standard
;
22196 end loop Scope_Loop
;
22197 end Kill_Current_Values
;
22199 --------------------------
22200 -- Kill_Size_Check_Code --
22201 --------------------------
22203 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
22205 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
22206 and then Present
(Size_Check_Code
(E
))
22208 Remove
(Size_Check_Code
(E
));
22209 Set_Size_Check_Code
(E
, Empty
);
22211 end Kill_Size_Check_Code
;
22213 --------------------
22214 -- Known_Non_Null --
22215 --------------------
22217 function Known_Non_Null
(N
: Node_Id
) return Boolean is
22218 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
22225 -- The expression yields a non-null value ignoring simple flow analysis
22227 if Status
= Is_Non_Null
then
22230 -- Otherwise check whether N is a reference to an entity that appears
22231 -- within a conditional construct.
22233 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
22235 -- First check if we are in decisive conditional
22237 Get_Current_Value_Condition
(N
, Op
, Val
);
22239 if Known_Null
(Val
) then
22240 if Op
= N_Op_Eq
then
22242 elsif Op
= N_Op_Ne
then
22247 -- If OK to do replacement, test Is_Known_Non_Null flag
22251 if OK_To_Do_Constant_Replacement
(Id
) then
22252 return Is_Known_Non_Null
(Id
);
22256 -- Otherwise it is not possible to determine whether N yields a non-null
22260 end Known_Non_Null
;
22266 function Known_Null
(N
: Node_Id
) return Boolean is
22267 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
22274 -- The expression yields a null value ignoring simple flow analysis
22276 if Status
= Is_Null
then
22279 -- Otherwise check whether N is a reference to an entity that appears
22280 -- within a conditional construct.
22282 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
22284 -- First check if we are in decisive conditional
22286 Get_Current_Value_Condition
(N
, Op
, Val
);
22288 -- If Get_Current_Value_Condition were to return Val = N, then the
22289 -- recursion below could be infinite.
22292 raise Program_Error
;
22295 if Known_Null
(Val
) then
22296 if Op
= N_Op_Eq
then
22298 elsif Op
= N_Op_Ne
then
22303 -- If OK to do replacement, test Is_Known_Null flag
22307 if OK_To_Do_Constant_Replacement
(Id
) then
22308 return Is_Known_Null
(Id
);
22312 -- Otherwise it is not possible to determine whether N yields a null
22318 ---------------------------
22319 -- Last_Source_Statement --
22320 ---------------------------
22322 function Last_Source_Statement
(HSS
: Node_Id
) return Node_Id
is
22326 N
:= Last
(Statements
(HSS
));
22327 while Present
(N
) loop
22328 exit when Comes_From_Source
(N
);
22333 end Last_Source_Statement
;
22335 -----------------------
22336 -- Mark_Coextensions --
22337 -----------------------
22339 procedure Mark_Coextensions
(Context_Nod
: Node_Id
; Root_Nod
: Node_Id
) is
22340 Is_Dynamic
: Boolean;
22341 -- Indicates whether the context causes nested coextensions to be
22342 -- dynamic or static
22344 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
;
22345 -- Recognize an allocator node and label it as a dynamic coextension
22347 --------------------
22348 -- Mark_Allocator --
22349 --------------------
22351 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
is
22353 if Nkind
(N
) = N_Allocator
then
22355 Set_Is_Static_Coextension
(N
, False);
22356 Set_Is_Dynamic_Coextension
(N
);
22358 -- If the allocator expression is potentially dynamic, it may
22359 -- be expanded out of order and require dynamic allocation
22360 -- anyway, so we treat the coextension itself as dynamic.
22361 -- Potential optimization ???
22363 elsif Nkind
(Expression
(N
)) = N_Qualified_Expression
22364 and then Nkind
(Expression
(Expression
(N
))) = N_Op_Concat
22366 Set_Is_Static_Coextension
(N
, False);
22367 Set_Is_Dynamic_Coextension
(N
);
22369 Set_Is_Dynamic_Coextension
(N
, False);
22370 Set_Is_Static_Coextension
(N
);
22375 end Mark_Allocator
;
22377 procedure Mark_Allocators
is new Traverse_Proc
(Mark_Allocator
);
22379 -- Start of processing for Mark_Coextensions
22382 -- An allocator that appears on the right-hand side of an assignment is
22383 -- treated as a potentially dynamic coextension when the right-hand side
22384 -- is an allocator or a qualified expression.
22386 -- Obj := new ...'(new Coextension ...);
22388 if Nkind
(Context_Nod
) = N_Assignment_Statement
then
22389 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) in
22390 N_Allocator | N_Qualified_Expression
;
22392 -- An allocator that appears within the expression of a simple return
22393 -- statement is treated as a potentially dynamic coextension when the
22394 -- expression is either aggregate, allocator, or qualified expression.
22396 -- return (new Coextension ...);
22397 -- return new ...'(new Coextension ...);
22399 elsif Nkind
(Context_Nod
) = N_Simple_Return_Statement
then
22400 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) in
22401 N_Aggregate | N_Allocator | N_Qualified_Expression
;
22403 -- An alloctor that appears within the initialization expression of an
22404 -- object declaration is considered a potentially dynamic coextension
22405 -- when the initialization expression is an allocator or a qualified
22408 -- Obj : ... := new ...'(new Coextension ...);
22410 -- A similar case arises when the object declaration is part of an
22411 -- extended return statement.
22413 -- return Obj : ... := new ...'(new Coextension ...);
22414 -- return Obj : ... := (new Coextension ...);
22416 elsif Nkind
(Context_Nod
) = N_Object_Declaration
then
22417 Is_Dynamic
:= Nkind
(Root_Nod
) in N_Allocator | N_Qualified_Expression
22418 or else Nkind
(Parent
(Context_Nod
)) = N_Extended_Return_Statement
;
22420 -- This routine should not be called with constructs that cannot contain
22424 raise Program_Error
;
22427 Mark_Allocators
(Root_Nod
);
22428 end Mark_Coextensions
;
22430 ---------------------------------
22431 -- Mark_Elaboration_Attributes --
22432 ---------------------------------
22434 procedure Mark_Elaboration_Attributes
22435 (N_Id
: Node_Or_Entity_Id
;
22436 Checks
: Boolean := False;
22437 Level
: Boolean := False;
22438 Modes
: Boolean := False;
22439 Warnings
: Boolean := False)
22441 function Elaboration_Checks_OK
22442 (Target_Id
: Entity_Id
;
22443 Context_Id
: Entity_Id
) return Boolean;
22444 -- Determine whether elaboration checks are enabled for target Target_Id
22445 -- which resides within context Context_Id.
22447 procedure Mark_Elaboration_Attributes_Id
(Id
: Entity_Id
);
22448 -- Preserve relevant attributes of the context in arbitrary entity Id
22450 procedure Mark_Elaboration_Attributes_Node
(N
: Node_Id
);
22451 -- Preserve relevant attributes of the context in arbitrary node N
22453 ---------------------------
22454 -- Elaboration_Checks_OK --
22455 ---------------------------
22457 function Elaboration_Checks_OK
22458 (Target_Id
: Entity_Id
;
22459 Context_Id
: Entity_Id
) return Boolean
22461 Encl_Scop
: Entity_Id
;
22464 -- Elaboration checks are suppressed for the target
22466 if Elaboration_Checks_Suppressed
(Target_Id
) then
22470 -- Otherwise elaboration checks are OK for the target, but may be
22471 -- suppressed for the context where the target is declared.
22473 Encl_Scop
:= Context_Id
;
22474 while Present
(Encl_Scop
) and then Encl_Scop
/= Standard_Standard
loop
22475 if Elaboration_Checks_Suppressed
(Encl_Scop
) then
22479 Encl_Scop
:= Scope
(Encl_Scop
);
22482 -- Neither the target nor its declarative context have elaboration
22483 -- checks suppressed.
22486 end Elaboration_Checks_OK
;
22488 ------------------------------------
22489 -- Mark_Elaboration_Attributes_Id --
22490 ------------------------------------
22492 procedure Mark_Elaboration_Attributes_Id
(Id
: Entity_Id
) is
22494 -- Mark the status of elaboration checks in effect. Do not reset the
22495 -- status in case the entity is reanalyzed with checks suppressed.
22497 if Checks
and then not Is_Elaboration_Checks_OK_Id
(Id
) then
22498 Set_Is_Elaboration_Checks_OK_Id
(Id
,
22499 Elaboration_Checks_OK
22501 Context_Id
=> Scope
(Id
)));
22504 -- Mark the status of elaboration warnings in effect. Do not reset
22505 -- the status in case the entity is reanalyzed with warnings off.
22507 if Warnings
and then not Is_Elaboration_Warnings_OK_Id
(Id
) then
22508 Set_Is_Elaboration_Warnings_OK_Id
(Id
, Elab_Warnings
);
22510 end Mark_Elaboration_Attributes_Id
;
22512 --------------------------------------
22513 -- Mark_Elaboration_Attributes_Node --
22514 --------------------------------------
22516 procedure Mark_Elaboration_Attributes_Node
(N
: Node_Id
) is
22517 function Extract_Name
(N
: Node_Id
) return Node_Id
;
22518 -- Obtain the Name attribute of call or instantiation N
22524 function Extract_Name
(N
: Node_Id
) return Node_Id
is
22530 -- A call to an entry family appears in indexed form
22532 if Nkind
(Nam
) = N_Indexed_Component
then
22533 Nam
:= Prefix
(Nam
);
22536 -- The name may also appear in qualified form
22538 if Nkind
(Nam
) = N_Selected_Component
then
22539 Nam
:= Selector_Name
(Nam
);
22547 Context_Id
: Entity_Id
;
22550 -- Start of processing for Mark_Elaboration_Attributes_Node
22553 -- Mark the status of elaboration checks in effect. Do not reset the
22554 -- status in case the node is reanalyzed with checks suppressed.
22556 if Checks
and then not Is_Elaboration_Checks_OK_Node
(N
) then
22558 -- Assignments, attribute references, and variable references do
22559 -- not have a "declarative" context.
22561 Context_Id
:= Empty
;
22563 -- The status of elaboration checks for calls and instantiations
22564 -- depends on the most recent pragma Suppress/Unsuppress, as well
22565 -- as the suppression status of the context where the target is
22569 -- function Func ...;
22573 -- procedure Main is
22574 -- pragma Suppress (Elaboration_Checks, Pack);
22575 -- X : ... := Pack.Func;
22578 -- In the example above, the call to Func has elaboration checks
22579 -- enabled because there is no active general purpose suppression
22580 -- pragma, however the elaboration checks of Pack are explicitly
22581 -- suppressed. As a result the elaboration checks of the call must
22582 -- be disabled in order to preserve this dependency.
22584 if Nkind
(N
) in N_Entry_Call_Statement
22586 | N_Function_Instantiation
22587 | N_Package_Instantiation
22588 | N_Procedure_Call_Statement
22589 | N_Procedure_Instantiation
22591 Nam
:= Extract_Name
(N
);
22593 if Is_Entity_Name
(Nam
) and then Present
(Entity
(Nam
)) then
22594 Context_Id
:= Scope
(Entity
(Nam
));
22598 Set_Is_Elaboration_Checks_OK_Node
(N
,
22599 Elaboration_Checks_OK
22600 (Target_Id
=> Empty
,
22601 Context_Id
=> Context_Id
));
22604 -- Mark the enclosing level of the node. Do not reset the status in
22605 -- case the node is relocated and reanalyzed.
22607 if Level
and then not Is_Declaration_Level_Node
(N
) then
22608 Set_Is_Declaration_Level_Node
(N
,
22609 Find_Enclosing_Level
(N
) = Declaration_Level
);
22612 -- Mark the Ghost and SPARK mode in effect
22615 if Ghost_Mode
= Ignore
then
22616 Set_Is_Ignored_Ghost_Node
(N
);
22619 if SPARK_Mode
= On
then
22620 Set_Is_SPARK_Mode_On_Node
(N
);
22624 -- Mark the status of elaboration warnings in effect. Do not reset
22625 -- the status in case the node is reanalyzed with warnings off.
22627 if Warnings
and then not Is_Elaboration_Warnings_OK_Node
(N
) then
22628 Set_Is_Elaboration_Warnings_OK_Node
(N
, Elab_Warnings
);
22630 end Mark_Elaboration_Attributes_Node
;
22632 -- Start of processing for Mark_Elaboration_Attributes
22635 -- Do not capture any elaboration-related attributes when switch -gnatH
22636 -- (legacy elaboration checking mode enabled) is in effect because the
22637 -- attributes are useless to the legacy model.
22639 if Legacy_Elaboration_Checks
then
22643 if Nkind
(N_Id
) in N_Entity
then
22644 Mark_Elaboration_Attributes_Id
(N_Id
);
22646 Mark_Elaboration_Attributes_Node
(N_Id
);
22648 end Mark_Elaboration_Attributes
;
22650 ----------------------------------------
22651 -- Mark_Save_Invocation_Graph_Of_Body --
22652 ----------------------------------------
22654 procedure Mark_Save_Invocation_Graph_Of_Body
is
22655 Main
: constant Node_Id
:= Cunit
(Main_Unit
);
22656 Main_Unit
: constant Node_Id
:= Unit
(Main
);
22657 Aux_Id
: Entity_Id
;
22660 Set_Save_Invocation_Graph_Of_Body
(Main
);
22662 -- Assume that the main unit does not have a complimentary unit
22666 -- Obtain the complimentary unit of the main unit
22668 if Nkind
(Main_Unit
) in N_Generic_Package_Declaration
22669 | N_Generic_Subprogram_Declaration
22670 | N_Package_Declaration
22671 | N_Subprogram_Declaration
22673 Aux_Id
:= Corresponding_Body
(Main_Unit
);
22675 elsif Nkind
(Main_Unit
) in N_Package_Body
22676 | N_Subprogram_Body
22677 | N_Subprogram_Renaming_Declaration
22679 Aux_Id
:= Corresponding_Spec
(Main_Unit
);
22682 if Present
(Aux_Id
) then
22683 Set_Save_Invocation_Graph_Of_Body
22684 (Parent
(Unit_Declaration_Node
(Aux_Id
)));
22686 end Mark_Save_Invocation_Graph_Of_Body
;
22688 ----------------------------------
22689 -- Matching_Static_Array_Bounds --
22690 ----------------------------------
22692 function Matching_Static_Array_Bounds
22694 R_Typ
: Node_Id
) return Boolean
22696 L_Ndims
: constant Nat
:= Number_Dimensions
(L_Typ
);
22697 R_Ndims
: constant Nat
:= Number_Dimensions
(R_Typ
);
22699 L_Index
: Node_Id
:= Empty
; -- init to ...
22700 R_Index
: Node_Id
:= Empty
; -- ...avoid warnings
22709 if L_Ndims
/= R_Ndims
then
22713 -- Unconstrained types do not have static bounds
22715 if not Is_Constrained
(L_Typ
) or else not Is_Constrained
(R_Typ
) then
22719 -- First treat specially the first dimension, as the lower bound and
22720 -- length of string literals are not stored like those of arrays.
22722 if Ekind
(L_Typ
) = E_String_Literal_Subtype
then
22723 L_Low
:= String_Literal_Low_Bound
(L_Typ
);
22724 L_Len
:= String_Literal_Length
(L_Typ
);
22726 L_Index
:= First_Index
(L_Typ
);
22727 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
22729 if Is_OK_Static_Expression
(L_Low
)
22731 Is_OK_Static_Expression
(L_High
)
22733 if Expr_Value
(L_High
) < Expr_Value
(L_Low
) then
22736 L_Len
:= (Expr_Value
(L_High
) - Expr_Value
(L_Low
)) + 1;
22743 if Ekind
(R_Typ
) = E_String_Literal_Subtype
then
22744 R_Low
:= String_Literal_Low_Bound
(R_Typ
);
22745 R_Len
:= String_Literal_Length
(R_Typ
);
22747 R_Index
:= First_Index
(R_Typ
);
22748 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
22750 if Is_OK_Static_Expression
(R_Low
)
22752 Is_OK_Static_Expression
(R_High
)
22754 if Expr_Value
(R_High
) < Expr_Value
(R_Low
) then
22757 R_Len
:= (Expr_Value
(R_High
) - Expr_Value
(R_Low
)) + 1;
22764 if (Is_OK_Static_Expression
(L_Low
)
22766 Is_OK_Static_Expression
(R_Low
))
22767 and then Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
22768 and then L_Len
= R_Len
22775 -- Then treat all other dimensions
22777 for Indx
in 2 .. L_Ndims
loop
22781 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
22782 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
22784 if (Is_OK_Static_Expression
(L_Low
) and then
22785 Is_OK_Static_Expression
(L_High
) and then
22786 Is_OK_Static_Expression
(R_Low
) and then
22787 Is_OK_Static_Expression
(R_High
))
22788 and then (Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
22790 Expr_Value
(L_High
) = Expr_Value
(R_High
))
22798 -- If we fall through the loop, all indexes matched
22801 end Matching_Static_Array_Bounds
;
22807 function Might_Raise
(N
: Node_Id
) return Boolean is
22808 Result
: Boolean := False;
22810 function Process
(N
: Node_Id
) return Traverse_Result
;
22811 -- Set Result to True if we find something that could raise an exception
22817 function Process
(N
: Node_Id
) return Traverse_Result
is
22819 if Nkind
(N
) in N_Procedure_Call_Statement
22821 | N_Raise_Statement
22822 | N_Raise_xxx_Error
22831 procedure Set_Result
is new Traverse_Proc
(Process
);
22833 -- Start of processing for Might_Raise
22836 -- False if exceptions can't be propagated
22838 if No_Exception_Handlers_Set
then
22842 -- If the checks handled by the back end are not disabled, we cannot
22843 -- ensure that no exception will be raised.
22845 if not Access_Checks_Suppressed
(Empty
)
22846 or else not Discriminant_Checks_Suppressed
(Empty
)
22847 or else not Range_Checks_Suppressed
(Empty
)
22848 or else not Index_Checks_Suppressed
(Empty
)
22849 or else Opt
.Stack_Checking_Enabled
22858 ----------------------------------------
22859 -- Nearest_Class_Condition_Subprogram --
22860 ----------------------------------------
22862 function Nearest_Class_Condition_Subprogram
22863 (Kind
: Condition_Kind
;
22864 Spec_Id
: Entity_Id
) return Entity_Id
22866 Subp_Id
: constant Entity_Id
:= Ultimate_Alias
(Spec_Id
);
22869 -- Prevent cascaded errors
22871 if not Is_Dispatching_Operation
(Subp_Id
) then
22874 -- No need to search if this subprogram has class-wide postconditions
22876 elsif Present
(Class_Condition
(Kind
, Subp_Id
)) then
22880 -- Process the contracts of inherited subprograms, looking for
22881 -- class-wide pre/postconditions.
22884 Subps
: constant Subprogram_List
:= Inherited_Subprograms
(Subp_Id
);
22885 Subp_Id
: Entity_Id
;
22888 for Index
in Subps
'Range loop
22889 Subp_Id
:= Subps
(Index
);
22891 if Present
(Alias
(Subp_Id
)) then
22892 Subp_Id
:= Ultimate_Alias
(Subp_Id
);
22895 -- Wrappers of class-wide pre/postconditions reference the
22896 -- parent primitive that has the inherited contract.
22898 if Is_Wrapper
(Subp_Id
)
22899 and then Present
(LSP_Subprogram
(Subp_Id
))
22901 Subp_Id
:= LSP_Subprogram
(Subp_Id
);
22904 if Present
(Class_Condition
(Kind
, Subp_Id
)) then
22911 end Nearest_Class_Condition_Subprogram
;
22913 --------------------------------
22914 -- Nearest_Enclosing_Instance --
22915 --------------------------------
22917 function Nearest_Enclosing_Instance
(E
: Entity_Id
) return Entity_Id
is
22922 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
22923 if Is_Generic_Instance
(Inst
) then
22927 Inst
:= Scope
(Inst
);
22931 end Nearest_Enclosing_Instance
;
22933 ------------------------
22934 -- Needs_Finalization --
22935 ------------------------
22937 function Needs_Finalization
(Typ
: Entity_Id
) return Boolean is
22938 function Has_Some_Controlled_Component
22939 (Input_Typ
: Entity_Id
) return Boolean;
22940 -- Determine whether type Input_Typ has at least one controlled
22943 -----------------------------------
22944 -- Has_Some_Controlled_Component --
22945 -----------------------------------
22947 function Has_Some_Controlled_Component
22948 (Input_Typ
: Entity_Id
) return Boolean
22953 -- When a type is already frozen and has at least one controlled
22954 -- component, or is manually decorated, it is sufficient to inspect
22955 -- flag Has_Controlled_Component.
22957 if Has_Controlled_Component
(Input_Typ
) then
22960 -- Otherwise inspect the internals of the type
22962 elsif not Is_Frozen
(Input_Typ
) then
22963 if Is_Array_Type
(Input_Typ
) then
22964 return Needs_Finalization
(Component_Type
(Input_Typ
));
22966 elsif Is_Record_Type
(Input_Typ
) then
22967 Comp
:= First_Component
(Input_Typ
);
22968 while Present
(Comp
) loop
22969 if Needs_Finalization
(Etype
(Comp
)) then
22973 Next_Component
(Comp
);
22979 end Has_Some_Controlled_Component
;
22981 -- Start of processing for Needs_Finalization
22984 -- Certain run-time configurations and targets do not provide support
22985 -- for controlled types.
22987 if Restriction_Active
(No_Finalization
) then
22990 -- C++ types are not considered controlled. It is assumed that the non-
22991 -- Ada side will handle their clean up.
22993 elsif Convention
(Typ
) = Convention_CPP
then
22996 -- Class-wide types are treated as controlled because derivations from
22997 -- the root type may introduce controlled components.
22999 elsif Is_Class_Wide_Type
(Typ
) then
23002 -- Concurrent types are controlled as long as their corresponding record
23005 elsif Is_Concurrent_Type
(Typ
)
23006 and then Present
(Corresponding_Record_Type
(Typ
))
23007 and then Needs_Finalization
(Corresponding_Record_Type
(Typ
))
23011 -- Otherwise the type is controlled when it is either derived from type
23012 -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or
23013 -- contains at least one controlled component.
23017 Is_Controlled
(Typ
) or else Has_Some_Controlled_Component
(Typ
);
23019 end Needs_Finalization
;
23021 ----------------------
23022 -- Needs_One_Actual --
23023 ----------------------
23025 function Needs_One_Actual
(E
: Entity_Id
) return Boolean is
23026 Formal
: Entity_Id
;
23029 -- Ada 2005 or later, and formals present. The first formal must be
23030 -- of a type that supports prefix notation: a controlling argument,
23031 -- a class-wide type, or an access to such.
23033 if Ada_Version
>= Ada_2005
23034 and then Present
(First_Formal
(E
))
23035 and then No
(Default_Value
(First_Formal
(E
)))
23037 (Is_Controlling_Formal
(First_Formal
(E
))
23038 or else Is_Class_Wide_Type
(Etype
(First_Formal
(E
)))
23039 or else Is_Anonymous_Access_Type
(Etype
(First_Formal
(E
))))
23041 Formal
:= Next_Formal
(First_Formal
(E
));
23042 while Present
(Formal
) loop
23043 if No
(Default_Value
(Formal
)) then
23047 Next_Formal
(Formal
);
23052 -- Ada 83/95 or no formals
23057 end Needs_One_Actual
;
23059 --------------------------------------
23060 -- Needs_Result_Accessibility_Level --
23061 --------------------------------------
23063 function Needs_Result_Accessibility_Level
23064 (Func_Id
: Entity_Id
) return Boolean
23066 Func_Typ
: constant Entity_Id
:= Underlying_Type
(Etype
(Func_Id
));
23068 function Has_Unconstrained_Access_Discriminant_Component
23069 (Comp_Typ
: Entity_Id
) return Boolean;
23070 -- Returns True if any component of the type has an unconstrained access
23073 -----------------------------------------------------
23074 -- Has_Unconstrained_Access_Discriminant_Component --
23075 -----------------------------------------------------
23077 function Has_Unconstrained_Access_Discriminant_Component
23078 (Comp_Typ
: Entity_Id
) return Boolean
23081 if not Is_Limited_Type
(Comp_Typ
) then
23084 -- Only limited types can have access discriminants with
23087 elsif Has_Unconstrained_Access_Discriminants
(Comp_Typ
) then
23090 elsif Is_Array_Type
(Comp_Typ
) then
23091 return Has_Unconstrained_Access_Discriminant_Component
23092 (Underlying_Type
(Component_Type
(Comp_Typ
)));
23094 elsif Is_Record_Type
(Comp_Typ
) then
23099 Comp
:= First_Component
(Comp_Typ
);
23100 while Present
(Comp
) loop
23101 if Has_Unconstrained_Access_Discriminant_Component
23102 (Underlying_Type
(Etype
(Comp
)))
23107 Next_Component
(Comp
);
23113 end Has_Unconstrained_Access_Discriminant_Component
;
23115 Disable_Tagged_Cases
: constant Boolean := True;
23116 -- Flag used to temporarily disable a "True" result for tagged types.
23117 -- See comments further below for details.
23119 -- Start of processing for Needs_Result_Accessibility_Level
23122 -- False if completion unavailable, which can happen when we are
23123 -- analyzing an abstract subprogram or if the subprogram has
23124 -- delayed freezing.
23126 if No
(Func_Typ
) then
23129 -- False if not a function, also handle enum-lit renames case
23131 elsif Func_Typ
= Standard_Void_Type
23132 or else Is_Scalar_Type
(Func_Typ
)
23136 -- Handle a corner case, a cross-dialect subp renaming. For example,
23137 -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
23138 -- an Ada 2005 (or earlier) unit references predefined run-time units.
23140 elsif Present
(Alias
(Func_Id
)) then
23142 -- Unimplemented: a cross-dialect subp renaming which does not set
23143 -- the Alias attribute (e.g., a rename of a dereference of an access
23144 -- to subprogram value). ???
23146 return Present
(Extra_Accessibility_Of_Result
(Alias
(Func_Id
)));
23148 -- Remaining cases require Ada 2012 mode
23150 elsif Ada_Version
< Ada_2012
then
23153 -- Handle the situation where a result is an anonymous access type
23154 -- RM 3.10.2 (10.3/3).
23156 elsif Ekind
(Func_Typ
) = E_Anonymous_Access_Type
then
23159 -- In the case of, say, a null tagged record result type, the need for
23160 -- this extra parameter might not be obvious so this function returns
23161 -- True for all tagged types for compatibility reasons.
23163 -- A function with, say, a tagged null controlling result type might
23164 -- be overridden by a primitive of an extension having an access
23165 -- discriminant and the overrider and overridden must have compatible
23166 -- calling conventions (including implicitly declared parameters).
23168 -- Similarly, values of one access-to-subprogram type might designate
23169 -- both a primitive subprogram of a given type and a function which is,
23170 -- for example, not a primitive subprogram of any type. Again, this
23171 -- requires calling convention compatibility. It might be possible to
23172 -- solve these issues by introducing wrappers, but that is not the
23173 -- approach that was chosen.
23175 -- Note: Despite the reasoning noted above, the extra accessibility
23176 -- parameter for tagged types is disabled for performance reasons.
23178 elsif Is_Tagged_Type
(Func_Typ
) then
23179 return not Disable_Tagged_Cases
;
23181 elsif Has_Unconstrained_Access_Discriminants
(Func_Typ
) then
23184 elsif Has_Unconstrained_Access_Discriminant_Component
(Func_Typ
) then
23187 -- False for all other cases
23192 end Needs_Result_Accessibility_Level
;
23194 ---------------------------------
23195 -- Needs_Simple_Initialization --
23196 ---------------------------------
23198 function Needs_Simple_Initialization
23200 Consider_IS
: Boolean := True) return Boolean
23202 Consider_IS_NS
: constant Boolean :=
23203 Normalize_Scalars
or (Initialize_Scalars
and Consider_IS
);
23206 -- Never need initialization if it is suppressed
23208 if Initialization_Suppressed
(Typ
) then
23212 -- Check for private type, in which case test applies to the underlying
23213 -- type of the private type.
23215 if Is_Private_Type
(Typ
) then
23217 RT
: constant Entity_Id
:= Underlying_Type
(Typ
);
23219 if Present
(RT
) then
23220 return Needs_Simple_Initialization
(RT
);
23226 -- Scalar type with Default_Value aspect requires initialization
23228 elsif Is_Scalar_Type
(Typ
) and then Has_Default_Aspect
(Typ
) then
23231 -- Cases needing simple initialization are access types, and, if pragma
23232 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
23235 elsif Is_Access_Type
(Typ
)
23236 or else (Consider_IS_NS
and then Is_Scalar_Type
(Typ
))
23240 -- If Initialize/Normalize_Scalars is in effect, string objects also
23241 -- need initialization, unless they are created in the course of
23242 -- expanding an aggregate (since in the latter case they will be
23243 -- filled with appropriate initializing values before they are used).
23245 elsif Consider_IS_NS
23246 and then Is_Standard_String_Type
(Typ
)
23248 (not Is_Itype
(Typ
)
23249 or else Nkind
(Associated_Node_For_Itype
(Typ
)) /= N_Aggregate
)
23256 end Needs_Simple_Initialization
;
23258 -------------------------------------
23259 -- Needs_Variable_Reference_Marker --
23260 -------------------------------------
23262 function Needs_Variable_Reference_Marker
23264 Calls_OK
: Boolean) return Boolean
23266 function Within_Suitable_Context
(Ref
: Node_Id
) return Boolean;
23267 -- Deteremine whether variable reference Ref appears within a suitable
23268 -- context that allows the creation of a marker.
23270 -----------------------------
23271 -- Within_Suitable_Context --
23272 -----------------------------
23274 function Within_Suitable_Context
(Ref
: Node_Id
) return Boolean is
23279 while Present
(Par
) loop
23281 -- The context is not suitable when the reference appears within
23282 -- the formal part of an instantiation which acts as compilation
23283 -- unit because there is no proper list for the insertion of the
23286 if Nkind
(Par
) = N_Generic_Association
23287 and then Nkind
(Parent
(Par
)) in N_Generic_Instantiation
23288 and then Nkind
(Parent
(Parent
(Par
))) = N_Compilation_Unit
23292 -- The context is not suitable when the reference appears within
23293 -- a pragma. If the pragma has run-time semantics, the reference
23294 -- will be reconsidered once the pragma is expanded.
23296 elsif Nkind
(Par
) = N_Pragma
then
23299 -- The context is not suitable when the reference appears within a
23300 -- subprogram call, and the caller requests this behavior.
23303 and then Nkind
(Par
) in N_Entry_Call_Statement
23305 | N_Procedure_Call_Statement
23309 -- Prevent the search from going too far
23311 elsif Is_Body_Or_Package_Declaration
(Par
) then
23315 Par
:= Parent
(Par
);
23319 end Within_Suitable_Context
;
23324 Var_Id
: Entity_Id
;
23326 -- Start of processing for Needs_Variable_Reference_Marker
23329 -- No marker needs to be created when switch -gnatH (legacy elaboration
23330 -- checking mode enabled) is in effect because the legacy ABE mechanism
23331 -- does not use markers.
23333 if Legacy_Elaboration_Checks
then
23336 -- No marker needs to be created when the reference is preanalyzed
23337 -- because the marker will be inserted in the wrong place.
23339 elsif Preanalysis_Active
then
23342 -- Only references warrant a marker
23344 elsif Nkind
(N
) not in N_Expanded_Name | N_Identifier
then
23347 -- Only source references warrant a marker
23349 elsif not Comes_From_Source
(N
) then
23352 -- No marker needs to be created when the reference is erroneous, left
23353 -- in a bad state, or does not denote a variable.
23355 elsif not (Present
(Entity
(N
))
23356 and then Ekind
(Entity
(N
)) = E_Variable
23357 and then Entity
(N
) /= Any_Id
)
23362 Var_Id
:= Entity
(N
);
23363 Prag
:= SPARK_Pragma
(Var_Id
);
23365 -- Both the variable and reference must appear in SPARK_Mode On regions
23366 -- because this elaboration scenario falls under the SPARK rules.
23368 if not (Comes_From_Source
(Var_Id
)
23369 and then Present
(Prag
)
23370 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
23371 and then Is_SPARK_Mode_On_Node
(N
))
23375 -- No marker needs to be created when the reference does not appear
23376 -- within a suitable context (see body for details).
23378 -- Performance note: parent traversal
23380 elsif not Within_Suitable_Context
(N
) then
23384 -- At this point it is known that the variable reference will play a
23385 -- role in ABE diagnostics and requires a marker.
23388 end Needs_Variable_Reference_Marker
;
23390 ------------------------
23391 -- New_Copy_List_Tree --
23392 ------------------------
23394 function New_Copy_List_Tree
(List
: List_Id
) return List_Id
is
23399 if List
= No_List
then
23406 while Present
(E
) loop
23407 Append
(New_Copy_Tree
(E
), NL
);
23413 end New_Copy_List_Tree
;
23415 ----------------------------
23416 -- New_Copy_Separate_List --
23417 ----------------------------
23419 function New_Copy_Separate_List
(List
: List_Id
) return List_Id
is
23421 if List
= No_List
then
23426 List_Copy
: constant List_Id
:= New_List
;
23427 N
: Node_Id
:= First
(List
);
23430 while Present
(N
) loop
23431 Append
(New_Copy_Separate_Tree
(N
), List_Copy
);
23438 end New_Copy_Separate_List
;
23440 ----------------------------
23441 -- New_Copy_Separate_Tree --
23442 ----------------------------
23444 function New_Copy_Separate_Tree
(Source
: Node_Id
) return Node_Id
is
23445 function Search_Decl
(N
: Node_Id
) return Traverse_Result
;
23446 -- Subtree visitor which collects declarations
23448 procedure Search_Declarations
is new Traverse_Proc
(Search_Decl
);
23449 -- Subtree visitor instantiation
23457 function Search_Decl
(N
: Node_Id
) return Traverse_Result
is
23459 if Nkind
(N
) in N_Declaration
then
23460 Append_New_Elmt
(N
, Decls
);
23468 Source_Copy
: constant Node_Id
:= New_Copy_Tree
(Source
);
23470 -- Start of processing for New_Copy_Separate_Tree
23474 Search_Declarations
(Source_Copy
);
23476 -- Associate a new Entity with all the subtree declarations (keeping
23477 -- their original name).
23479 if Present
(Decls
) then
23486 Elmt
:= First_Elmt
(Decls
);
23487 while Present
(Elmt
) loop
23488 Decl
:= Node
(Elmt
);
23489 New_E
:= Make_Temporary
(Sloc
(Decl
), 'P');
23491 if Nkind
(Decl
) = N_Expression_Function
then
23492 Decl
:= Specification
(Decl
);
23495 if Nkind
(Decl
) in N_Function_Instantiation
23496 | N_Function_Specification
23497 | N_Generic_Function_Renaming_Declaration
23498 | N_Generic_Package_Renaming_Declaration
23499 | N_Generic_Procedure_Renaming_Declaration
23501 | N_Package_Instantiation
23502 | N_Package_Renaming_Declaration
23503 | N_Package_Specification
23504 | N_Procedure_Instantiation
23505 | N_Procedure_Specification
23507 Set_Chars
(New_E
, Chars
(Defining_Unit_Name
(Decl
)));
23508 Set_Defining_Unit_Name
(Decl
, New_E
);
23510 Set_Chars
(New_E
, Chars
(Defining_Identifier
(Decl
)));
23511 Set_Defining_Identifier
(Decl
, New_E
);
23519 return Source_Copy
;
23520 end New_Copy_Separate_Tree
;
23522 -------------------
23523 -- New_Copy_Tree --
23524 -------------------
23526 -- The following tables play a key role in replicating entities and Itypes.
23527 -- They are intentionally declared at the library level rather than within
23528 -- New_Copy_Tree to avoid elaborating them on each call. This performance
23529 -- optimization saves up to 2% of the entire compilation time spent in the
23530 -- front end. Care should be taken to reset the tables on each new call to
23533 NCT_Table_Max
: constant := 511;
23535 subtype NCT_Table_Index
is Nat
range 0 .. NCT_Table_Max
- 1;
23537 function NCT_Table_Hash
(Key
: Node_Or_Entity_Id
) return NCT_Table_Index
;
23538 -- Obtain the hash value of node or entity Key
23540 --------------------
23541 -- NCT_Table_Hash --
23542 --------------------
23544 function NCT_Table_Hash
(Key
: Node_Or_Entity_Id
) return NCT_Table_Index
is
23546 return NCT_Table_Index
(Key
mod NCT_Table_Max
);
23547 end NCT_Table_Hash
;
23549 ----------------------
23550 -- NCT_New_Entities --
23551 ----------------------
23553 -- The following table maps old entities and Itypes to their corresponding
23554 -- new entities and Itypes.
23558 package NCT_New_Entities
is new Simple_HTable
(
23559 Header_Num
=> NCT_Table_Index
,
23560 Element
=> Entity_Id
,
23561 No_Element
=> Empty
,
23563 Hash
=> NCT_Table_Hash
,
23566 ------------------------
23567 -- NCT_Pending_Itypes --
23568 ------------------------
23570 -- The following table maps old Associated_Node_For_Itype nodes to a set of
23571 -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three
23572 -- have the same Associated_Node_For_Itype Ppp, and their corresponding new
23573 -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping:
23575 -- Ppp -> (Xxx, Yyy, Zzz)
23577 -- The set is expressed as an Elist
23579 package NCT_Pending_Itypes
is new Simple_HTable
(
23580 Header_Num
=> NCT_Table_Index
,
23581 Element
=> Elist_Id
,
23582 No_Element
=> No_Elist
,
23584 Hash
=> NCT_Table_Hash
,
23587 NCT_Tables_In_Use
: Boolean := False;
23588 -- This flag keeps track of whether the two tables NCT_New_Entities and
23589 -- NCT_Pending_Itypes are in use. The flag is part of an optimization
23590 -- where certain operations are not performed if the tables are not in
23591 -- use. This saves up to 8% of the entire compilation time spent in the
23594 -------------------
23595 -- New_Copy_Tree --
23596 -------------------
23598 function New_Copy_Tree
23600 Map
: Elist_Id
:= No_Elist
;
23601 New_Sloc
: Source_Ptr
:= No_Location
;
23602 New_Scope
: Entity_Id
:= Empty
;
23603 Scopes_In_EWA_OK
: Boolean := False) return Node_Id
23605 -- This routine performs low-level tree manipulations and needs access
23606 -- to the internals of the tree.
23608 EWA_Level
: Nat
:= 0;
23609 -- This counter keeps track of how many N_Expression_With_Actions nodes
23610 -- are encountered during a depth-first traversal of the subtree. These
23611 -- nodes may define new entities in their Actions lists and thus require
23612 -- special processing.
23614 EWA_Inner_Scope_Level
: Nat
:= 0;
23615 -- This counter keeps track of how many scoping constructs appear within
23616 -- an N_Expression_With_Actions node.
23618 procedure Add_New_Entity
(Old_Id
: Entity_Id
; New_Id
: Entity_Id
);
23619 pragma Inline
(Add_New_Entity
);
23620 -- Add an entry in the NCT_New_Entities table which maps key Old_Id to
23621 -- value New_Id. Old_Id is an entity which appears within the Actions
23622 -- list of an N_Expression_With_Actions node, or within an entity map.
23623 -- New_Id is the corresponding new entity generated during Phase 1.
23625 procedure Add_Pending_Itype
(Assoc_Nod
: Node_Id
; Itype
: Entity_Id
);
23626 pragma Inline
(Add_Pending_Itype
);
23627 -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to
23628 -- value Itype. Assoc_Nod is the associated node of an itype. Itype is
23631 procedure Build_NCT_Tables
(Entity_Map
: Elist_Id
);
23632 pragma Inline
(Build_NCT_Tables
);
23633 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the
23634 -- information supplied in entity map Entity_Map. The format of the
23635 -- entity map must be as follows:
23637 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
23639 function Copy_Any_Node_With_Replacement
23640 (N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
;
23641 pragma Inline
(Copy_Any_Node_With_Replacement
);
23642 -- Replicate entity or node N by invoking one of the following routines:
23644 -- Copy_Node_With_Replacement
23645 -- Corresponding_Entity
23647 function Copy_Elist_With_Replacement
(List
: Elist_Id
) return Elist_Id
;
23648 -- Replicate the elements of entity list List
23650 function Copy_Field_With_Replacement
23652 Old_Par
: Node_Id
:= Empty
;
23653 New_Par
: Node_Id
:= Empty
;
23654 Semantic
: Boolean := False) return Union_Id
;
23655 -- Replicate field Field by invoking one of the following routines:
23657 -- Copy_Elist_With_Replacement
23658 -- Copy_List_With_Replacement
23659 -- Copy_Node_With_Replacement
23660 -- Corresponding_Entity
23662 -- If the field is not an entity list, entity, itype, syntactic list,
23663 -- or node, then the field is returned unchanged. The routine always
23664 -- replicates entities, itypes, and valid syntactic fields. Old_Par is
23665 -- the expected parent of a syntactic field. New_Par is the new parent
23666 -- associated with a replicated syntactic field. Flag Semantic should
23667 -- be set when the input is a semantic field.
23669 function Copy_List_With_Replacement
(List
: List_Id
) return List_Id
;
23670 -- Replicate the elements of syntactic list List
23672 function Copy_Node_With_Replacement
(N
: Node_Id
) return Node_Id
;
23673 -- Replicate node N
23675 function Corresponding_Entity
(Id
: Entity_Id
) return Entity_Id
;
23676 pragma Inline
(Corresponding_Entity
);
23677 -- Return the corresponding new entity of Id generated during Phase 1.
23678 -- If there is no such entity, return Id.
23680 function In_Entity_Map
23682 Entity_Map
: Elist_Id
) return Boolean;
23683 pragma Inline
(In_Entity_Map
);
23684 -- Determine whether entity Id is one of the old ids specified in entity
23685 -- map Entity_Map. The format of the entity map must be as follows:
23687 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
23689 procedure Update_CFS_Sloc
(N
: Node_Or_Entity_Id
);
23690 pragma Inline
(Update_CFS_Sloc
);
23691 -- Update the Comes_From_Source and Sloc attributes of node or entity N
23693 procedure Update_First_Real_Statement
23694 (Old_HSS
: Node_Id
;
23695 New_HSS
: Node_Id
);
23696 pragma Inline
(Update_First_Real_Statement
);
23697 -- Update semantic attribute First_Real_Statement of handled sequence of
23698 -- statements New_HSS based on handled sequence of statements Old_HSS.
23700 procedure Update_Named_Associations
23701 (Old_Call
: Node_Id
;
23702 New_Call
: Node_Id
);
23703 pragma Inline
(Update_Named_Associations
);
23704 -- Update semantic chain First/Next_Named_Association of call New_call
23705 -- based on call Old_Call.
23707 procedure Update_New_Entities
(Entity_Map
: Elist_Id
);
23708 pragma Inline
(Update_New_Entities
);
23709 -- Update the semantic attributes of all new entities generated during
23710 -- Phase 1 that do not appear in entity map Entity_Map. The format of
23711 -- the entity map must be as follows:
23713 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
23715 procedure Update_Pending_Itypes
23716 (Old_Assoc
: Node_Id
;
23717 New_Assoc
: Node_Id
);
23718 pragma Inline
(Update_Pending_Itypes
);
23719 -- Update semantic attribute Associated_Node_For_Itype to refer to node
23720 -- New_Assoc for all itypes whose associated node is Old_Assoc.
23722 procedure Update_Semantic_Fields
(Id
: Entity_Id
);
23723 pragma Inline
(Update_Semantic_Fields
);
23724 -- Subsidiary to Update_New_Entities. Update semantic fields of entity
23727 procedure Visit_Any_Node
(N
: Node_Or_Entity_Id
);
23728 pragma Inline
(Visit_Any_Node
);
23729 -- Visit entity of node N by invoking one of the following routines:
23735 procedure Visit_Elist
(List
: Elist_Id
);
23736 -- Visit the elements of entity list List
23738 procedure Visit_Entity
(Id
: Entity_Id
);
23739 -- Visit entity Id. This action may create a new entity of Id and save
23740 -- it in table NCT_New_Entities.
23742 procedure Visit_Field
23744 Par_Nod
: Node_Id
:= Empty
;
23745 Semantic
: Boolean := False);
23746 -- Visit field Field by invoking one of the following routines:
23754 -- If the field is not an entity list, entity, itype, syntactic list,
23755 -- or node, then the field is not visited. The routine always visits
23756 -- valid syntactic fields. Par_Nod is the expected parent of the
23757 -- syntactic field. Flag Semantic should be set when the input is a
23760 procedure Visit_Itype
(Itype
: Entity_Id
);
23761 -- Visit itype Itype. This action may create a new entity for Itype and
23762 -- save it in table NCT_New_Entities. In addition, the routine may map
23763 -- the associated node of Itype to the new itype in NCT_Pending_Itypes.
23765 procedure Visit_List
(List
: List_Id
);
23766 -- Visit the elements of syntactic list List
23768 procedure Visit_Node
(N
: Node_Id
);
23771 procedure Visit_Semantic_Fields
(Id
: Entity_Id
);
23772 pragma Inline
(Visit_Semantic_Fields
);
23773 -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic
23774 -- fields of entity or itype Id.
23776 --------------------
23777 -- Add_New_Entity --
23778 --------------------
23780 procedure Add_New_Entity
(Old_Id
: Entity_Id
; New_Id
: Entity_Id
) is
23782 pragma Assert
(Present
(Old_Id
));
23783 pragma Assert
(Present
(New_Id
));
23784 pragma Assert
(Nkind
(Old_Id
) in N_Entity
);
23785 pragma Assert
(Nkind
(New_Id
) in N_Entity
);
23787 NCT_Tables_In_Use
:= True;
23789 -- Sanity check the NCT_New_Entities table. No previous mapping with
23790 -- key Old_Id should exist.
23792 pragma Assert
(No
(NCT_New_Entities
.Get
(Old_Id
)));
23794 -- Establish the mapping
23796 -- Old_Id -> New_Id
23798 NCT_New_Entities
.Set
(Old_Id
, New_Id
);
23799 end Add_New_Entity
;
23801 -----------------------
23802 -- Add_Pending_Itype --
23803 -----------------------
23805 procedure Add_Pending_Itype
(Assoc_Nod
: Node_Id
; Itype
: Entity_Id
) is
23809 pragma Assert
(Present
(Assoc_Nod
));
23810 pragma Assert
(Present
(Itype
));
23811 pragma Assert
(Nkind
(Itype
) in N_Entity
);
23812 pragma Assert
(Is_Itype
(Itype
));
23814 NCT_Tables_In_Use
:= True;
23816 -- It is not possible to sanity check the NCT_Pendint_Itypes table
23817 -- directly because a single node may act as the associated node for
23818 -- multiple itypes.
23820 Itypes
:= NCT_Pending_Itypes
.Get
(Assoc_Nod
);
23822 if No
(Itypes
) then
23823 Itypes
:= New_Elmt_List
;
23824 NCT_Pending_Itypes
.Set
(Assoc_Nod
, Itypes
);
23827 -- Establish the mapping
23829 -- Assoc_Nod -> (Itype, ...)
23831 -- Avoid inserting the same itype multiple times. This involves a
23832 -- linear search, however the set of itypes with the same associated
23833 -- node is very small.
23835 Append_Unique_Elmt
(Itype
, Itypes
);
23836 end Add_Pending_Itype
;
23838 ----------------------
23839 -- Build_NCT_Tables --
23840 ----------------------
23842 procedure Build_NCT_Tables
(Entity_Map
: Elist_Id
) is
23844 Old_Id
: Entity_Id
;
23845 New_Id
: Entity_Id
;
23848 -- Nothing to do when there is no entity map
23850 if No
(Entity_Map
) then
23854 Elmt
:= First_Elmt
(Entity_Map
);
23855 while Present
(Elmt
) loop
23857 -- Extract the (Old_Id, New_Id) pair from the entity map
23859 Old_Id
:= Node
(Elmt
);
23862 New_Id
:= Node
(Elmt
);
23865 -- Establish the following mapping within table NCT_New_Entities
23867 -- Old_Id -> New_Id
23869 Add_New_Entity
(Old_Id
, New_Id
);
23871 -- Establish the following mapping within table NCT_Pending_Itypes
23872 -- when the new entity is an itype.
23874 -- Assoc_Nod -> (New_Id, ...)
23876 -- IMPORTANT: the associated node is that of the old itype because
23877 -- the node will be replicated in Phase 2.
23879 if Is_Itype
(Old_Id
) then
23881 (Assoc_Nod
=> Associated_Node_For_Itype
(Old_Id
),
23885 end Build_NCT_Tables
;
23887 ------------------------------------
23888 -- Copy_Any_Node_With_Replacement --
23889 ------------------------------------
23891 function Copy_Any_Node_With_Replacement
23892 (N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
23895 if Nkind
(N
) in N_Entity
then
23896 return Corresponding_Entity
(N
);
23898 return Copy_Node_With_Replacement
(N
);
23900 end Copy_Any_Node_With_Replacement
;
23902 ---------------------------------
23903 -- Copy_Elist_With_Replacement --
23904 ---------------------------------
23906 function Copy_Elist_With_Replacement
(List
: Elist_Id
) return Elist_Id
is
23911 -- Copy the contents of the old list. Note that the list itself may
23912 -- be empty, in which case the routine returns a new empty list. This
23913 -- avoids sharing lists between subtrees. The element of an entity
23914 -- list could be an entity or a node, hence the invocation of routine
23915 -- Copy_Any_Node_With_Replacement.
23917 if Present
(List
) then
23918 Result
:= New_Elmt_List
;
23920 Elmt
:= First_Elmt
(List
);
23921 while Present
(Elmt
) loop
23923 (Copy_Any_Node_With_Replacement
(Node
(Elmt
)), Result
);
23928 -- Otherwise the list does not exist
23931 Result
:= No_Elist
;
23935 end Copy_Elist_With_Replacement
;
23937 ---------------------------------
23938 -- Copy_Field_With_Replacement --
23939 ---------------------------------
23941 function Copy_Field_With_Replacement
23943 Old_Par
: Node_Id
:= Empty
;
23944 New_Par
: Node_Id
:= Empty
;
23945 Semantic
: Boolean := False) return Union_Id
23947 function Has_More_Ids
(N
: Node_Id
) return Boolean;
23948 -- Return True when N has attribute More_Ids set to True
23950 function Is_Syntactic_Node
return Boolean;
23951 -- Return True when Field is a syntactic node
23957 function Has_More_Ids
(N
: Node_Id
) return Boolean is
23959 if Nkind
(N
) in N_Component_Declaration
23960 | N_Discriminant_Specification
23961 | N_Exception_Declaration
23962 | N_Formal_Object_Declaration
23963 | N_Number_Declaration
23964 | N_Object_Declaration
23965 | N_Parameter_Specification
23966 | N_Use_Package_Clause
23967 | N_Use_Type_Clause
23969 return More_Ids
(N
);
23975 -----------------------
23976 -- Is_Syntactic_Node --
23977 -----------------------
23979 function Is_Syntactic_Node
return Boolean is
23980 Old_N
: constant Node_Id
:= Node_Id
(Field
);
23983 if Parent
(Old_N
) = Old_Par
then
23986 elsif not Has_More_Ids
(Old_Par
) then
23989 -- Perform the check using the last last id in the syntactic chain
23993 N
: Node_Id
:= Old_Par
;
23996 while Present
(N
) and then More_Ids
(N
) loop
24000 pragma Assert
(Prev_Ids
(N
));
24001 return Parent
(Old_N
) = N
;
24004 end Is_Syntactic_Node
;
24007 -- The field is empty
24009 if Field
= Union_Id
(Empty
) then
24012 -- The field is an entity/itype/node
24014 elsif Field
in Node_Range
then
24016 Old_N
: constant Node_Id
:= Node_Id
(Field
);
24017 Syntactic
: constant Boolean := Is_Syntactic_Node
;
24022 -- The field is an entity/itype
24024 if Nkind
(Old_N
) in N_Entity
then
24026 -- An entity/itype is always replicated
24028 New_N
:= Corresponding_Entity
(Old_N
);
24030 -- Update the parent pointer when the entity is a syntactic
24031 -- field. Note that itypes do not have parent pointers.
24033 if Syntactic
and then New_N
/= Old_N
then
24034 Set_Parent
(New_N
, New_Par
);
24037 -- The field is a node
24040 -- A node is replicated when it is either a syntactic field
24041 -- or when the caller treats it as a semantic attribute.
24043 if Syntactic
or else Semantic
then
24044 New_N
:= Copy_Node_With_Replacement
(Old_N
);
24046 -- Update the parent pointer when the node is a syntactic
24049 if Syntactic
and then New_N
/= Old_N
then
24050 Set_Parent
(New_N
, New_Par
);
24053 -- Otherwise the node is returned unchanged
24060 return Union_Id
(New_N
);
24063 -- The field is an entity list
24065 elsif Field
in Elist_Range
then
24066 return Union_Id
(Copy_Elist_With_Replacement
(Elist_Id
(Field
)));
24068 -- The field is a syntactic list
24070 elsif Field
in List_Range
then
24072 Old_List
: constant List_Id
:= List_Id
(Field
);
24073 Syntactic
: constant Boolean := Parent
(Old_List
) = Old_Par
;
24075 New_List
: List_Id
;
24078 -- A list is replicated when it is either a syntactic field or
24079 -- when the caller treats it as a semantic attribute.
24081 if Syntactic
or else Semantic
then
24082 New_List
:= Copy_List_With_Replacement
(Old_List
);
24084 -- Update the parent pointer when the list is a syntactic
24087 if Syntactic
and then New_List
/= Old_List
then
24088 Set_Parent
(New_List
, New_Par
);
24091 -- Otherwise the list is returned unchanged
24094 New_List
:= Old_List
;
24097 return Union_Id
(New_List
);
24100 -- Otherwise the field denotes an attribute that does not need to be
24101 -- replicated (Chars, literals, etc).
24106 end Copy_Field_With_Replacement
;
24108 --------------------------------
24109 -- Copy_List_With_Replacement --
24110 --------------------------------
24112 function Copy_List_With_Replacement
(List
: List_Id
) return List_Id
is
24117 -- Copy the contents of the old list. Note that the list itself may
24118 -- be empty, in which case the routine returns a new empty list. This
24119 -- avoids sharing lists between subtrees. The element of a syntactic
24120 -- list is always a node, never an entity or itype, hence the call to
24121 -- routine Copy_Node_With_Replacement.
24123 if Present
(List
) then
24124 Result
:= New_List
;
24126 Elmt
:= First
(List
);
24127 while Present
(Elmt
) loop
24128 Append
(Copy_Node_With_Replacement
(Elmt
), Result
);
24133 -- Otherwise the list does not exist
24140 end Copy_List_With_Replacement
;
24142 --------------------------------
24143 -- Copy_Node_With_Replacement --
24144 --------------------------------
24146 function Copy_Node_With_Replacement
(N
: Node_Id
) return Node_Id
is
24149 function Transform
(U
: Union_Id
) return Union_Id
;
24150 -- Copies one field, replacing N with Result
24156 function Transform
(U
: Union_Id
) return Union_Id
is
24158 return Copy_Field_With_Replacement
24161 New_Par
=> Result
);
24164 procedure Walk
is new Walk_Sinfo_Fields_Pairwise
(Transform
);
24166 -- Start of processing for Copy_Node_With_Replacement
24169 -- Assume that the node must be returned unchanged
24173 if N
> Empty_Or_Error
then
24174 pragma Assert
(Nkind
(N
) not in N_Entity
);
24176 Result
:= New_Copy
(N
);
24178 Walk
(Result
, Result
);
24180 -- Update the Comes_From_Source and Sloc attributes of the node
24181 -- in case the caller has supplied new values.
24183 Update_CFS_Sloc
(Result
);
24185 -- Update the Associated_Node_For_Itype attribute of all itypes
24186 -- created during Phase 1 whose associated node is N. As a result
24187 -- the Associated_Node_For_Itype refers to the replicated node.
24188 -- No action needs to be taken when the Associated_Node_For_Itype
24189 -- refers to an entity because this was already handled during
24190 -- Phase 1, in Visit_Itype.
24192 Update_Pending_Itypes
24194 New_Assoc
=> Result
);
24196 -- Update the First/Next_Named_Association chain for a replicated
24199 if Nkind
(N
) in N_Entry_Call_Statement
24201 | N_Procedure_Call_Statement
24203 Update_Named_Associations
24205 New_Call
=> Result
);
24207 -- Update the Renamed_Object attribute of a replicated object
24210 elsif Nkind
(N
) = N_Object_Renaming_Declaration
then
24211 Set_Renamed_Object_Of_Possibly_Void
24212 (Defining_Entity
(Result
), Name
(Result
));
24214 -- Update the First_Real_Statement attribute of a replicated
24215 -- handled sequence of statements.
24217 elsif Nkind
(N
) = N_Handled_Sequence_Of_Statements
then
24218 Update_First_Real_Statement
24220 New_HSS
=> Result
);
24222 -- Update the Chars attribute of identifiers
24224 elsif Nkind
(N
) = N_Identifier
then
24226 -- The Entity field of identifiers that denote aspects is used
24227 -- to store arbitrary expressions (and hence we must check that
24228 -- they reference an actual entity before copying their Chars
24231 if Present
(Entity
(Result
))
24232 and then Nkind
(Entity
(Result
)) in N_Entity
24234 Set_Chars
(Result
, Chars
(Entity
(Result
)));
24238 if Has_Aspects
(N
) then
24239 Set_Aspect_Specifications
(Result
,
24240 Copy_List_With_Replacement
(Aspect_Specifications
(N
)));
24245 end Copy_Node_With_Replacement
;
24247 --------------------------
24248 -- Corresponding_Entity --
24249 --------------------------
24251 function Corresponding_Entity
(Id
: Entity_Id
) return Entity_Id
is
24252 New_Id
: Entity_Id
;
24253 Result
: Entity_Id
;
24256 -- Assume that the entity must be returned unchanged
24260 if Id
> Empty_Or_Error
then
24261 pragma Assert
(Nkind
(Id
) in N_Entity
);
24263 -- Determine whether the entity has a corresponding new entity
24264 -- generated during Phase 1 and if it does, use it.
24266 if NCT_Tables_In_Use
then
24267 New_Id
:= NCT_New_Entities
.Get
(Id
);
24269 if Present
(New_Id
) then
24276 end Corresponding_Entity
;
24278 -------------------
24279 -- In_Entity_Map --
24280 -------------------
24282 function In_Entity_Map
24284 Entity_Map
: Elist_Id
) return Boolean
24287 Old_Id
: Entity_Id
;
24290 -- The entity map contains pairs (Old_Id, New_Id). The advancement
24291 -- step always skips the New_Id portion of the pair.
24293 if Present
(Entity_Map
) then
24294 Elmt
:= First_Elmt
(Entity_Map
);
24295 while Present
(Elmt
) loop
24296 Old_Id
:= Node
(Elmt
);
24298 if Old_Id
= Id
then
24310 ---------------------
24311 -- Update_CFS_Sloc --
24312 ---------------------
24314 procedure Update_CFS_Sloc
(N
: Node_Or_Entity_Id
) is
24316 -- A new source location defaults the Comes_From_Source attribute
24318 if New_Sloc
/= No_Location
then
24319 Set_Comes_From_Source
(N
, Get_Comes_From_Source_Default
);
24320 Set_Sloc
(N
, New_Sloc
);
24322 end Update_CFS_Sloc
;
24324 ---------------------------------
24325 -- Update_First_Real_Statement --
24326 ---------------------------------
24328 procedure Update_First_Real_Statement
24329 (Old_HSS
: Node_Id
;
24332 Old_First_Stmt
: constant Node_Id
:= First_Real_Statement
(Old_HSS
);
24334 New_Stmt
: Node_Id
;
24335 Old_Stmt
: Node_Id
;
24338 -- Recreate the First_Real_Statement attribute of a handled sequence
24339 -- of statements by traversing the statement lists of both sequences
24342 if Present
(Old_First_Stmt
) then
24343 New_Stmt
:= First
(Statements
(New_HSS
));
24344 Old_Stmt
:= First
(Statements
(Old_HSS
));
24345 while Present
(Old_Stmt
) and then Old_Stmt
/= Old_First_Stmt
loop
24350 pragma Assert
(Present
(New_Stmt
));
24351 pragma Assert
(Present
(Old_Stmt
));
24353 Set_First_Real_Statement
(New_HSS
, New_Stmt
);
24355 end Update_First_Real_Statement
;
24357 -------------------------------
24358 -- Update_Named_Associations --
24359 -------------------------------
24361 procedure Update_Named_Associations
24362 (Old_Call
: Node_Id
;
24363 New_Call
: Node_Id
)
24366 New_Next
: Node_Id
;
24368 Old_Next
: Node_Id
;
24371 if No
(First_Named_Actual
(Old_Call
)) then
24375 -- Recreate the First/Next_Named_Actual chain of a call by traversing
24376 -- the chains of both the old and new calls in parallel.
24378 New_Act
:= First
(Parameter_Associations
(New_Call
));
24379 Old_Act
:= First
(Parameter_Associations
(Old_Call
));
24380 while Present
(Old_Act
) loop
24381 if Nkind
(Old_Act
) = N_Parameter_Association
24382 and then Explicit_Actual_Parameter
(Old_Act
)
24383 = First_Named_Actual
(Old_Call
)
24385 Set_First_Named_Actual
(New_Call
,
24386 Explicit_Actual_Parameter
(New_Act
));
24389 if Nkind
(Old_Act
) = N_Parameter_Association
24390 and then Present
(Next_Named_Actual
(Old_Act
))
24392 -- Scan the actual parameter list to find the next suitable
24393 -- named actual. Note that the list may be out of order.
24395 New_Next
:= First
(Parameter_Associations
(New_Call
));
24396 Old_Next
:= First
(Parameter_Associations
(Old_Call
));
24397 while Nkind
(Old_Next
) /= N_Parameter_Association
24398 or else Explicit_Actual_Parameter
(Old_Next
) /=
24399 Next_Named_Actual
(Old_Act
)
24405 Set_Next_Named_Actual
(New_Act
,
24406 Explicit_Actual_Parameter
(New_Next
));
24412 end Update_Named_Associations
;
24414 -------------------------
24415 -- Update_New_Entities --
24416 -------------------------
24418 procedure Update_New_Entities
(Entity_Map
: Elist_Id
) is
24419 New_Id
: Entity_Id
:= Empty
;
24420 Old_Id
: Entity_Id
:= Empty
;
24423 if NCT_Tables_In_Use
then
24424 NCT_New_Entities
.Get_First
(Old_Id
, New_Id
);
24426 -- Update the semantic fields of all new entities created during
24427 -- Phase 1 which were not supplied via an entity map.
24428 -- ??? Is there a better way of distinguishing those?
24430 while Present
(Old_Id
) and then Present
(New_Id
) loop
24431 if not (Present
(Entity_Map
)
24432 and then In_Entity_Map
(Old_Id
, Entity_Map
))
24434 Update_Semantic_Fields
(New_Id
);
24437 NCT_New_Entities
.Get_Next
(Old_Id
, New_Id
);
24440 end Update_New_Entities
;
24442 ---------------------------
24443 -- Update_Pending_Itypes --
24444 ---------------------------
24446 procedure Update_Pending_Itypes
24447 (Old_Assoc
: Node_Id
;
24448 New_Assoc
: Node_Id
)
24454 if NCT_Tables_In_Use
then
24455 Itypes
:= NCT_Pending_Itypes
.Get
(Old_Assoc
);
24457 -- Update the Associated_Node_For_Itype attribute for all itypes
24458 -- which originally refer to Old_Assoc to designate New_Assoc.
24460 if Present
(Itypes
) then
24461 Item
:= First_Elmt
(Itypes
);
24462 while Present
(Item
) loop
24463 Set_Associated_Node_For_Itype
(Node
(Item
), New_Assoc
);
24469 end Update_Pending_Itypes
;
24471 ----------------------------
24472 -- Update_Semantic_Fields --
24473 ----------------------------
24475 procedure Update_Semantic_Fields
(Id
: Entity_Id
) is
24477 -- Discriminant_Constraint
24479 if Is_Type
(Id
) and then Has_Discriminants
(Base_Type
(Id
)) then
24480 Set_Discriminant_Constraint
(Id
, Elist_Id
(
24481 Copy_Field_With_Replacement
24482 (Field
=> Union_Id
(Discriminant_Constraint
(Id
)),
24483 Semantic
=> True)));
24488 Set_Etype
(Id
, Node_Id
(
24489 Copy_Field_With_Replacement
24490 (Field
=> Union_Id
(Etype
(Id
)),
24491 Semantic
=> True)));
24494 -- Packed_Array_Impl_Type
24496 if Is_Array_Type
(Id
) then
24497 if Present
(First_Index
(Id
)) then
24498 Set_First_Index
(Id
, First
(List_Id
(
24499 Copy_Field_With_Replacement
24500 (Field
=> Union_Id
(List_Containing
(First_Index
(Id
))),
24501 Semantic
=> True))));
24504 if Is_Packed
(Id
) then
24505 Set_Packed_Array_Impl_Type
(Id
, Node_Id
(
24506 Copy_Field_With_Replacement
24507 (Field
=> Union_Id
(Packed_Array_Impl_Type
(Id
)),
24508 Semantic
=> True)));
24514 Set_Prev_Entity
(Id
, Node_Id
(
24515 Copy_Field_With_Replacement
24516 (Field
=> Union_Id
(Prev_Entity
(Id
)),
24517 Semantic
=> True)));
24521 Set_Next_Entity
(Id
, Node_Id
(
24522 Copy_Field_With_Replacement
24523 (Field
=> Union_Id
(Next_Entity
(Id
)),
24524 Semantic
=> True)));
24528 if Is_Discrete_Type
(Id
) then
24529 Set_Scalar_Range
(Id
, Node_Id
(
24530 Copy_Field_With_Replacement
24531 (Field
=> Union_Id
(Scalar_Range
(Id
)),
24532 Semantic
=> True)));
24537 -- Update the scope when the caller specified an explicit one
24539 if Present
(New_Scope
) then
24540 Set_Scope
(Id
, New_Scope
);
24542 Set_Scope
(Id
, Node_Id
(
24543 Copy_Field_With_Replacement
24544 (Field
=> Union_Id
(Scope
(Id
)),
24545 Semantic
=> True)));
24547 end Update_Semantic_Fields
;
24549 --------------------
24550 -- Visit_Any_Node --
24551 --------------------
24553 procedure Visit_Any_Node
(N
: Node_Or_Entity_Id
) is
24555 if Nkind
(N
) in N_Entity
then
24556 if Is_Itype
(N
) then
24564 end Visit_Any_Node
;
24570 procedure Visit_Elist
(List
: Elist_Id
) is
24574 -- The element of an entity list could be an entity, itype, or a
24575 -- node, hence the call to Visit_Any_Node.
24577 if Present
(List
) then
24578 Elmt
:= First_Elmt
(List
);
24579 while Present
(Elmt
) loop
24580 Visit_Any_Node
(Node
(Elmt
));
24591 procedure Visit_Entity
(Id
: Entity_Id
) is
24592 New_Id
: Entity_Id
;
24595 pragma Assert
(Nkind
(Id
) in N_Entity
);
24596 pragma Assert
(not Is_Itype
(Id
));
24598 -- Nothing to do when the entity is not defined in the Actions list
24599 -- of an N_Expression_With_Actions node.
24601 if EWA_Level
= 0 then
24604 -- Nothing to do when the entity is defined in a scoping construct
24605 -- within an N_Expression_With_Actions node, unless the caller has
24606 -- requested their replication.
24608 -- ??? should this restriction be eliminated?
24610 elsif EWA_Inner_Scope_Level
> 0 and then not Scopes_In_EWA_OK
then
24613 -- Nothing to do when the entity does not denote a construct that
24614 -- may appear within an N_Expression_With_Actions node. Relaxing
24615 -- this restriction leads to a performance penalty.
24617 -- ??? this list is flaky, and may hide dormant bugs
24618 -- Should functions be included???
24620 -- Quantified expressions contain an entity declaration that must
24621 -- always be replaced when the expander is active, even if it has
24622 -- not been analyzed yet like e.g. in predicates.
24624 elsif Ekind
(Id
) not in E_Block
24629 and then not Is_Entity_Of_Quantified_Expression
(Id
)
24630 and then not Is_Type
(Id
)
24634 -- Nothing to do when the entity was already visited
24636 elsif NCT_Tables_In_Use
24637 and then Present
(NCT_New_Entities
.Get
(Id
))
24641 -- Nothing to do when the declaration node of the entity is not in
24642 -- the subtree being replicated.
24644 elsif not In_Subtree
24645 (N
=> Declaration_Node
(Id
),
24651 -- Create a new entity by directly copying the old entity. This
24652 -- action causes all attributes of the old entity to be inherited.
24654 New_Id
:= New_Copy
(Id
);
24656 -- Create a new name for the new entity because the back end needs
24657 -- distinct names for debugging purposes, provided that the entity
24658 -- has already been analyzed.
24660 if Ekind
(Id
) /= E_Void
then
24661 Set_Chars
(New_Id
, New_Internal_Name
('T'));
24664 -- Update the Comes_From_Source and Sloc attributes of the entity in
24665 -- case the caller has supplied new values.
24667 Update_CFS_Sloc
(New_Id
);
24669 -- Establish the following mapping within table NCT_New_Entities:
24673 Add_New_Entity
(Id
, New_Id
);
24675 -- Deal with the semantic fields of entities. The fields are visited
24676 -- because they may mention entities which reside within the subtree
24679 Visit_Semantic_Fields
(Id
);
24686 procedure Visit_Field
24688 Par_Nod
: Node_Id
:= Empty
;
24689 Semantic
: Boolean := False)
24692 -- The field is empty
24694 if Field
= Union_Id
(Empty
) then
24697 -- The field is an entity/itype/node
24699 elsif Field
in Node_Range
then
24701 N
: constant Node_Id
:= Node_Id
(Field
);
24704 -- The field is an entity/itype
24706 if Nkind
(N
) in N_Entity
then
24708 -- Itypes are always visited
24710 if Is_Itype
(N
) then
24713 -- An entity is visited when it is either a syntactic field
24714 -- or when the caller treats it as a semantic attribute.
24716 elsif Parent
(N
) = Par_Nod
or else Semantic
then
24720 -- The field is a node
24723 -- A node is visited when it is either a syntactic field or
24724 -- when the caller treats it as a semantic attribute.
24726 if Parent
(N
) = Par_Nod
or else Semantic
then
24732 -- The field is an entity list
24734 elsif Field
in Elist_Range
then
24735 Visit_Elist
(Elist_Id
(Field
));
24737 -- The field is a syntax list
24739 elsif Field
in List_Range
then
24741 List
: constant List_Id
:= List_Id
(Field
);
24744 -- A syntax list is visited when it is either a syntactic field
24745 -- or when the caller treats it as a semantic attribute.
24747 if Parent
(List
) = Par_Nod
or else Semantic
then
24752 -- Otherwise the field denotes information which does not need to be
24753 -- visited (chars, literals, etc.).
24764 procedure Visit_Itype
(Itype
: Entity_Id
) is
24765 New_Assoc
: Node_Id
;
24766 New_Itype
: Entity_Id
;
24767 Old_Assoc
: Node_Id
;
24770 pragma Assert
(Nkind
(Itype
) in N_Entity
);
24771 pragma Assert
(Is_Itype
(Itype
));
24773 -- Itypes that describe the designated type of access to subprograms
24774 -- have the structure of subprogram declarations, with signatures,
24775 -- etc. Either we duplicate the signatures completely, or choose to
24776 -- share such itypes, which is fine because their elaboration will
24777 -- have no side effects.
24779 if Ekind
(Itype
) = E_Subprogram_Type
then
24782 -- Nothing to do if the itype was already visited
24784 elsif NCT_Tables_In_Use
24785 and then Present
(NCT_New_Entities
.Get
(Itype
))
24789 -- Nothing to do if the associated node of the itype is not within
24790 -- the subtree being replicated.
24792 elsif not In_Subtree
24793 (N
=> Associated_Node_For_Itype
(Itype
),
24799 -- Create a new itype by directly copying the old itype. This action
24800 -- causes all attributes of the old itype to be inherited.
24802 New_Itype
:= New_Copy
(Itype
);
24804 -- Create a new name for the new itype because the back end requires
24805 -- distinct names for debugging purposes.
24807 Set_Chars
(New_Itype
, New_Internal_Name
('T'));
24809 -- Update the Comes_From_Source and Sloc attributes of the itype in
24810 -- case the caller has supplied new values.
24812 Update_CFS_Sloc
(New_Itype
);
24814 -- Establish the following mapping within table NCT_New_Entities:
24816 -- Itype -> New_Itype
24818 Add_New_Entity
(Itype
, New_Itype
);
24820 -- The new itype must be unfrozen because the resulting subtree may
24821 -- be inserted anywhere and cause an earlier or later freezing.
24823 if Present
(Freeze_Node
(New_Itype
)) then
24824 Set_Freeze_Node
(New_Itype
, Empty
);
24825 Set_Is_Frozen
(New_Itype
, False);
24828 -- If a record subtype is simply copied, the entity list will be
24829 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
24830 -- ??? What does this do?
24832 if Ekind
(Itype
) in E_Class_Wide_Subtype | E_Record_Subtype
then
24833 Set_Cloned_Subtype
(New_Itype
, Itype
);
24836 -- The associated node may denote an entity, in which case it may
24837 -- already have a new corresponding entity created during a prior
24838 -- call to Visit_Entity or Visit_Itype for the same subtree.
24841 -- Old_Assoc ---------> New_Assoc
24843 -- Created by Visit_Itype
24844 -- Itype -------------> New_Itype
24845 -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated
24847 -- In the example above, Old_Assoc is an arbitrary entity that was
24848 -- already visited for the same subtree and has a corresponding new
24849 -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue
24850 -- of copying entities, however it must be updated to New_Assoc.
24852 Old_Assoc
:= Associated_Node_For_Itype
(Itype
);
24854 if Nkind
(Old_Assoc
) in N_Entity
then
24855 if NCT_Tables_In_Use
then
24856 New_Assoc
:= NCT_New_Entities
.Get
(Old_Assoc
);
24858 if Present
(New_Assoc
) then
24859 Set_Associated_Node_For_Itype
(New_Itype
, New_Assoc
);
24863 -- Otherwise the associated node denotes a node. Postpone the update
24864 -- until Phase 2 when the node is replicated. Establish the following
24865 -- mapping within table NCT_Pending_Itypes:
24867 -- Old_Assoc -> (New_Type, ...)
24870 Add_Pending_Itype
(Old_Assoc
, New_Itype
);
24873 -- Deal with the semantic fields of itypes. The fields are visited
24874 -- because they may mention entities that reside within the subtree
24877 Visit_Semantic_Fields
(Itype
);
24884 procedure Visit_List
(List
: List_Id
) is
24888 -- Note that the element of a syntactic list is always a node, never
24889 -- an entity or itype, hence the call to Visit_Node.
24891 if Present
(List
) then
24892 Elmt
:= First
(List
);
24893 while Present
(Elmt
) loop
24905 procedure Visit_Node
(N
: Node_Id
) is
24907 pragma Assert
(Nkind
(N
) not in N_Entity
);
24909 -- If the node is a quantified expression and expander is active,
24910 -- it contains an implicit declaration that may require a new entity
24911 -- when the condition has already been (pre)analyzed.
24913 if Nkind
(N
) = N_Expression_With_Actions
24915 (Nkind
(N
) = N_Quantified_Expression
and then Expander_Active
)
24917 EWA_Level
:= EWA_Level
+ 1;
24919 elsif EWA_Level
> 0
24920 and then Nkind
(N
) in N_Block_Statement
24921 | N_Subprogram_Body
24922 | N_Subprogram_Declaration
24924 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
+ 1;
24927 -- If the node is a block, we need to process all declarations
24928 -- in the block and make new entities for each.
24930 if Nkind
(N
) = N_Block_Statement
and then Present
(Declarations
(N
))
24933 Decl
: Node_Id
:= First
(Declarations
(N
));
24936 while Present
(Decl
) loop
24937 if Nkind
(Decl
) = N_Object_Declaration
then
24938 Add_New_Entity
(Defining_Identifier
(Decl
),
24939 New_Copy
(Defining_Identifier
(Decl
)));
24948 procedure Action
(U
: Union_Id
);
24949 procedure Action
(U
: Union_Id
) is
24951 Visit_Field
(Field
=> U
, Par_Nod
=> N
);
24954 procedure Walk
is new Walk_Sinfo_Fields
(Action
);
24960 and then Nkind
(N
) in N_Block_Statement
24961 | N_Subprogram_Body
24962 | N_Subprogram_Declaration
24964 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
- 1;
24966 elsif Nkind
(N
) = N_Expression_With_Actions
then
24967 EWA_Level
:= EWA_Level
- 1;
24971 ---------------------------
24972 -- Visit_Semantic_Fields --
24973 ---------------------------
24975 procedure Visit_Semantic_Fields
(Id
: Entity_Id
) is
24977 pragma Assert
(Nkind
(Id
) in N_Entity
);
24979 -- Discriminant_Constraint
24981 if Is_Type
(Id
) and then Has_Discriminants
(Base_Type
(Id
)) then
24983 (Field
=> Union_Id
(Discriminant_Constraint
(Id
)),
24990 (Field
=> Union_Id
(Etype
(Id
)),
24994 -- Packed_Array_Impl_Type
24996 if Is_Array_Type
(Id
) then
24997 if Present
(First_Index
(Id
)) then
24999 (Field
=> Union_Id
(List_Containing
(First_Index
(Id
))),
25003 if Is_Packed
(Id
) then
25005 (Field
=> Union_Id
(Packed_Array_Impl_Type
(Id
)),
25012 if Is_Discrete_Type
(Id
) then
25014 (Field
=> Union_Id
(Scalar_Range
(Id
)),
25017 end Visit_Semantic_Fields
;
25019 -- Start of processing for New_Copy_Tree
25022 -- Routine New_Copy_Tree performs a deep copy of a subtree by creating
25023 -- shallow copies for each node within, and then updating the child and
25024 -- parent pointers accordingly. This process is straightforward, however
25025 -- the routine must deal with the following complications:
25027 -- * Entities defined within N_Expression_With_Actions nodes must be
25028 -- replicated rather than shared to avoid introducing two identical
25029 -- symbols within the same scope. Note that no other expression can
25030 -- currently define entities.
25033 -- Source_Low : ...;
25034 -- Source_High : ...;
25036 -- <reference to Source_Low>
25037 -- <reference to Source_High>
25040 -- New_Copy_Tree handles this case by first creating new entities
25041 -- and then updating all existing references to point to these new
25048 -- <reference to New_Low>
25049 -- <reference to New_High>
25052 -- * Itypes defined within the subtree must be replicated to avoid any
25053 -- dependencies on invalid or inaccessible data.
25055 -- subtype Source_Itype is ... range Source_Low .. Source_High;
25057 -- New_Copy_Tree handles this case by first creating a new itype in
25058 -- the same fashion as entities, and then updating various relevant
25061 -- subtype New_Itype is ... range New_Low .. New_High;
25063 -- * The Associated_Node_For_Itype field of itypes must be updated to
25064 -- reference the proper replicated entity or node.
25066 -- * Semantic fields of entities such as Etype and Scope must be
25067 -- updated to reference the proper replicated entities.
25069 -- * Semantic fields of nodes such as First_Real_Statement must be
25070 -- updated to reference the proper replicated nodes.
25072 -- Finally, quantified expressions contain an implicit declaration for
25073 -- the bound variable. Given that quantified expressions appearing
25074 -- in contracts are copied to create pragmas and eventually checking
25075 -- procedures, a new bound variable must be created for each copy, to
25076 -- prevent multiple declarations of the same symbol.
25078 -- To meet all these demands, routine New_Copy_Tree is split into two
25081 -- Phase 1 traverses the tree in order to locate entities and itypes
25082 -- defined within the subtree. New entities are generated and saved in
25083 -- table NCT_New_Entities. The semantic fields of all new entities and
25084 -- itypes are then updated accordingly.
25086 -- Phase 2 traverses the tree in order to replicate each node. Various
25087 -- semantic fields of nodes and entities are updated accordingly.
25089 -- Preparatory phase. Clear the contents of tables NCT_New_Entities and
25090 -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some
25093 if NCT_Tables_In_Use
then
25094 NCT_Tables_In_Use
:= False;
25096 NCT_New_Entities
.Reset
;
25097 NCT_Pending_Itypes
.Reset
;
25100 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data
25101 -- supplied by a linear entity map. The tables offer faster access to
25104 Build_NCT_Tables
(Map
);
25106 -- Execute Phase 1. Traverse the subtree and generate new entities for
25107 -- the following cases:
25109 -- * An entity defined within an N_Expression_With_Actions node
25111 -- * An itype referenced within the subtree where the associated node
25112 -- is also in the subtree.
25114 -- All new entities are accessible via table NCT_New_Entities, which
25115 -- contains mappings of the form:
25117 -- Old_Entity -> New_Entity
25118 -- Old_Itype -> New_Itype
25120 -- In addition, the associated nodes of all new itypes are mapped in
25121 -- table NCT_Pending_Itypes:
25123 -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN)
25125 Visit_Any_Node
(Source
);
25127 -- Update the semantic attributes of all new entities generated during
25128 -- Phase 1 before starting Phase 2. The updates could be performed in
25129 -- routine Corresponding_Entity, however this may cause the same entity
25130 -- to be updated multiple times, effectively generating useless nodes.
25131 -- Keeping the updates separates from Phase 2 ensures that only one set
25132 -- of attributes is generated for an entity at any one time.
25134 Update_New_Entities
(Map
);
25136 -- Execute Phase 2. Replicate the source subtree one node at a time.
25137 -- The following transformations take place:
25139 -- * References to entities and itypes are updated to refer to the
25140 -- new entities and itypes generated during Phase 1.
25142 -- * All Associated_Node_For_Itype attributes of itypes are updated
25143 -- to refer to the new replicated Associated_Node_For_Itype.
25145 return Copy_Node_With_Replacement
(Source
);
25148 -------------------------
25149 -- New_External_Entity --
25150 -------------------------
25152 function New_External_Entity
25153 (Kind
: Entity_Kind
;
25154 Scope_Id
: Entity_Id
;
25155 Sloc_Value
: Source_Ptr
;
25156 Related_Id
: Entity_Id
;
25157 Suffix
: Character;
25158 Suffix_Index
: Int
:= 0;
25159 Prefix
: Character := ' ') return Entity_Id
25161 N
: constant Entity_Id
:=
25162 Make_Defining_Identifier
(Sloc_Value
,
25164 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
25167 Mutate_Ekind
(N
, Kind
);
25168 Set_Is_Internal
(N
, True);
25169 Append_Entity
(N
, Scope_Id
);
25170 Set_Public_Status
(N
);
25172 if Kind
in Type_Kind
then
25173 Reinit_Size_Align
(N
);
25177 end New_External_Entity
;
25179 -------------------------
25180 -- New_Internal_Entity --
25181 -------------------------
25183 function New_Internal_Entity
25184 (Kind
: Entity_Kind
;
25185 Scope_Id
: Entity_Id
;
25186 Sloc_Value
: Source_Ptr
;
25187 Id_Char
: Character) return Entity_Id
25189 N
: constant Entity_Id
:= Make_Temporary
(Sloc_Value
, Id_Char
);
25192 Mutate_Ekind
(N
, Kind
);
25193 Set_Is_Internal
(N
, True);
25194 Append_Entity
(N
, Scope_Id
);
25196 if Kind
in Type_Kind
then
25197 Reinit_Size_Align
(N
);
25201 end New_Internal_Entity
;
25207 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
25208 Par
: constant Node_Id
:= Parent
(Actual_Id
);
25212 -- If we are pointing at a positional parameter, it is a member of a
25213 -- node list (the list of parameters), and the next parameter is the
25214 -- next node on the list, unless we hit a parameter association, then
25215 -- we shift to using the chain whose head is the First_Named_Actual in
25216 -- the parent, and then is threaded using the Next_Named_Actual of the
25217 -- Parameter_Association. All this fiddling is because the original node
25218 -- list is in the textual call order, and what we need is the
25219 -- declaration order.
25221 if Is_List_Member
(Actual_Id
) then
25222 N
:= Next
(Actual_Id
);
25224 if Nkind
(N
) = N_Parameter_Association
then
25226 -- In case of a build-in-place call, the call will no longer be a
25227 -- call; it will have been rewritten.
25229 if Nkind
(Par
) in N_Entry_Call_Statement
25231 | N_Procedure_Call_Statement
25233 return First_Named_Actual
(Par
);
25235 -- In case of a call rewritten in GNATprove mode while "inlining
25236 -- for proof" go to the original call.
25238 elsif Nkind
(Par
) = N_Null_Statement
then
25242 Nkind
(Original_Node
(Par
)) in N_Subprogram_Call
);
25244 return First_Named_Actual
(Original_Node
(Par
));
25253 return Next_Named_Actual
(Parent
(Actual_Id
));
25257 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
25259 Actual_Id
:= Next_Actual
(Actual_Id
);
25266 function Next_Global
(Node
: Node_Id
) return Node_Id
is
25268 -- The global item may either be in a list, or by itself, in which case
25269 -- there is no next global item with the same mode.
25271 if Is_List_Member
(Node
) then
25272 return Next
(Node
);
25278 procedure Next_Global
(Node
: in out Node_Id
) is
25280 Node
:= Next_Global
(Node
);
25283 ------------------------
25284 -- No_Caching_Enabled --
25285 ------------------------
25287 function No_Caching_Enabled
(Id
: Entity_Id
) return Boolean is
25288 pragma Assert
(Ekind
(Id
) = E_Variable
);
25289 Prag
: constant Node_Id
:= Get_Pragma
(Id
, Pragma_No_Caching
);
25293 if Present
(Prag
) then
25294 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
25296 -- The pragma has an optional Boolean expression, the related
25297 -- property is enabled only when the expression evaluates to True.
25299 if Present
(Arg1
) then
25300 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
)));
25302 -- Otherwise the lack of expression enables the property by
25309 -- The property was never set in the first place
25314 end No_Caching_Enabled
;
25316 --------------------------
25317 -- No_Heap_Finalization --
25318 --------------------------
25320 function No_Heap_Finalization
(Typ
: Entity_Id
) return Boolean is
25322 if Ekind
(Typ
) in E_Access_Type | E_General_Access_Type
25323 and then Is_Library_Level_Entity
(Typ
)
25325 -- A global No_Heap_Finalization pragma applies to all library-level
25326 -- named access-to-object types.
25328 if Present
(No_Heap_Finalization_Pragma
) then
25331 -- The library-level named access-to-object type itself is subject to
25332 -- pragma No_Heap_Finalization.
25334 elsif Present
(Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
)) then
25340 end No_Heap_Finalization
;
25342 -----------------------
25343 -- Normalize_Actuals --
25344 -----------------------
25346 -- Chain actuals according to formals of subprogram. If there are no named
25347 -- associations, the chain is simply the list of Parameter Associations,
25348 -- since the order is the same as the declaration order. If there are named
25349 -- associations, then the First_Named_Actual field in the N_Function_Call
25350 -- or N_Procedure_Call_Statement node points to the Parameter_Association
25351 -- node for the parameter that comes first in declaration order. The
25352 -- remaining named parameters are then chained in declaration order using
25353 -- Next_Named_Actual.
25355 -- This routine also verifies that the number of actuals is compatible with
25356 -- the number and default values of formals, but performs no type checking
25357 -- (type checking is done by the caller).
25359 -- If the matching succeeds, Success is set to True and the caller proceeds
25360 -- with type-checking. If the match is unsuccessful, then Success is set to
25361 -- False, and the caller attempts a different interpretation, if there is
25364 -- If the flag Report is on, the call is not overloaded, and a failure to
25365 -- match can be reported here, rather than in the caller.
25367 procedure Normalize_Actuals
25371 Success
: out Boolean)
25373 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
25374 Actual
: Node_Id
:= Empty
;
25375 Formal
: Entity_Id
;
25376 Last
: Node_Id
:= Empty
;
25377 First_Named
: Node_Id
:= Empty
;
25380 Formals_To_Match
: Integer := 0;
25381 Actuals_To_Match
: Integer := 0;
25383 procedure Chain
(A
: Node_Id
);
25384 -- Add named actual at the proper place in the list, using the
25385 -- Next_Named_Actual link.
25387 function Reporting
return Boolean;
25388 -- Determines if an error is to be reported. To report an error, we
25389 -- need Report to be True, and also we do not report errors caused
25390 -- by calls to init procs that occur within other init procs. Such
25391 -- errors must always be cascaded errors, since if all the types are
25392 -- declared correctly, the compiler will certainly build decent calls.
25398 procedure Chain
(A
: Node_Id
) is
25402 -- Call node points to first actual in list
25404 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
25407 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
25411 Set_Next_Named_Actual
(Last
, Empty
);
25418 function Reporting
return Boolean is
25423 elsif not Within_Init_Proc
then
25426 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
25434 -- Start of processing for Normalize_Actuals
25437 if Is_Access_Type
(S
) then
25439 -- The name in the call is a function call that returns an access
25440 -- to subprogram. The designated type has the list of formals.
25442 Formal
:= First_Formal
(Designated_Type
(S
));
25444 Formal
:= First_Formal
(S
);
25447 while Present
(Formal
) loop
25448 Formals_To_Match
:= Formals_To_Match
+ 1;
25449 Next_Formal
(Formal
);
25452 -- Find if there is a named association, and verify that no positional
25453 -- associations appear after named ones.
25455 if Present
(Actuals
) then
25456 Actual
:= First
(Actuals
);
25459 while Present
(Actual
)
25460 and then Nkind
(Actual
) /= N_Parameter_Association
25462 Actuals_To_Match
:= Actuals_To_Match
+ 1;
25466 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
25468 -- Most common case: positional notation, no defaults
25473 elsif Actuals_To_Match
> Formals_To_Match
then
25475 -- Too many actuals: will not work
25478 if Is_Entity_Name
(Name
(N
)) then
25479 Error_Msg_N
("too many arguments in call to&", Name
(N
));
25481 Error_Msg_N
("too many arguments in call", N
);
25489 First_Named
:= Actual
;
25491 while Present
(Actual
) loop
25492 if Nkind
(Actual
) /= N_Parameter_Association
then
25494 ("positional parameters not allowed after named ones", Actual
);
25499 Actuals_To_Match
:= Actuals_To_Match
+ 1;
25505 if Present
(Actuals
) then
25506 Actual
:= First
(Actuals
);
25509 Formal
:= First_Formal
(S
);
25510 while Present
(Formal
) loop
25512 -- Match the formals in order. If the corresponding actual is
25513 -- positional, nothing to do. Else scan the list of named actuals
25514 -- to find the one with the right name.
25516 if Present
(Actual
)
25517 and then Nkind
(Actual
) /= N_Parameter_Association
25520 Actuals_To_Match
:= Actuals_To_Match
- 1;
25521 Formals_To_Match
:= Formals_To_Match
- 1;
25524 -- For named parameters, search the list of actuals to find
25525 -- one that matches the next formal name.
25527 Actual
:= First_Named
;
25529 while Present
(Actual
) loop
25530 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
25533 Actuals_To_Match
:= Actuals_To_Match
- 1;
25534 Formals_To_Match
:= Formals_To_Match
- 1;
25542 if Ekind
(Formal
) /= E_In_Parameter
25543 or else No
(Default_Value
(Formal
))
25546 if (Comes_From_Source
(S
)
25547 or else Sloc
(S
) = Standard_Location
)
25548 and then Is_Overloadable
(S
)
25552 Nkind
(Parent
(N
)) in N_Procedure_Call_Statement
25554 | N_Parameter_Association
25555 and then Ekind
(S
) /= E_Function
25557 Set_Etype
(N
, Etype
(S
));
25560 Error_Msg_Name_1
:= Chars
(S
);
25561 Error_Msg_Sloc
:= Sloc
(S
);
25563 ("missing argument for parameter & "
25564 & "in call to % declared #", N
, Formal
);
25567 elsif Is_Overloadable
(S
) then
25568 Error_Msg_Name_1
:= Chars
(S
);
25570 -- Point to type derivation that generated the
25573 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
25576 ("missing argument for parameter & "
25577 & "in call to % (inherited) #", N
, Formal
);
25581 ("missing argument for parameter &", N
, Formal
);
25589 Formals_To_Match
:= Formals_To_Match
- 1;
25594 Next_Formal
(Formal
);
25597 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
25604 -- Find some superfluous named actual that did not get
25605 -- attached to the list of associations.
25607 Actual
:= First
(Actuals
);
25608 while Present
(Actual
) loop
25609 if Nkind
(Actual
) = N_Parameter_Association
25610 and then Actual
/= Last
25611 and then No
(Next_Named_Actual
(Actual
))
25613 -- A validity check may introduce a copy of a call that
25614 -- includes an extra actual (for example for an unrelated
25615 -- accessibility check). Check that the extra actual matches
25616 -- some extra formal, which must exist already because
25617 -- subprogram must be frozen at this point.
25619 if Present
(Extra_Formals
(S
))
25620 and then not Comes_From_Source
(Actual
)
25621 and then Nkind
(Actual
) = N_Parameter_Association
25622 and then Chars
(Extra_Formals
(S
)) =
25623 Chars
(Selector_Name
(Actual
))
25628 ("unmatched actual & in call", Selector_Name
(Actual
));
25640 end Normalize_Actuals
;
25642 --------------------------------
25643 -- Note_Possible_Modification --
25644 --------------------------------
25646 procedure Note_Possible_Modification
(N
: Node_Id
; Sure
: Boolean) is
25647 Modification_Comes_From_Source
: constant Boolean :=
25648 Comes_From_Source
(Parent
(N
));
25654 -- Loop to find referenced entity, if there is one
25660 if Is_Entity_Name
(Exp
) then
25661 Ent
:= Entity
(Exp
);
25663 -- If the entity is missing, it is an undeclared identifier,
25664 -- and there is nothing to annotate.
25670 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
25672 P
: constant Node_Id
:= Prefix
(Exp
);
25675 -- In formal verification mode, keep track of all reads and
25676 -- writes through explicit dereferences.
25678 if GNATprove_Mode
then
25679 SPARK_Specific
.Generate_Dereference
(N
, 'm');
25682 if Nkind
(P
) = N_Selected_Component
25683 and then Present
(Entry_Formal
(Entity
(Selector_Name
(P
))))
25685 -- Case of a reference to an entry formal
25687 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
25689 elsif Nkind
(P
) = N_Identifier
25690 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
25691 and then Present
(Expression
(Parent
(Entity
(P
))))
25692 and then Nkind
(Expression
(Parent
(Entity
(P
)))) =
25695 -- Case of a reference to a value on which side effects have
25698 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
25706 elsif Nkind
(Exp
) in N_Type_Conversion | N_Unchecked_Type_Conversion
25708 Exp
:= Expression
(Exp
);
25711 elsif Nkind
(Exp
) in
25712 N_Slice | N_Indexed_Component | N_Selected_Component
25714 -- Special check, if the prefix is an access type, then return
25715 -- since we are modifying the thing pointed to, not the prefix.
25716 -- When we are expanding, most usually the prefix is replaced
25717 -- by an explicit dereference, and this test is not needed, but
25718 -- in some cases (notably -gnatc mode and generics) when we do
25719 -- not do full expansion, we need this special test.
25721 if Is_Access_Type
(Etype
(Prefix
(Exp
))) then
25724 -- Otherwise go to prefix and keep going
25727 Exp
:= Prefix
(Exp
);
25731 -- All other cases, not a modification
25737 -- Now look for entity being referenced
25739 if Present
(Ent
) then
25740 if Is_Object
(Ent
) then
25741 if Comes_From_Source
(Exp
)
25742 or else Modification_Comes_From_Source
25744 -- Give warning if pragma unmodified is given and we are
25745 -- sure this is a modification.
25747 if Has_Pragma_Unmodified
(Ent
) and then Sure
then
25749 -- Note that the entity may be present only as a result
25750 -- of pragma Unused.
25752 if Has_Pragma_Unused
(Ent
) then
25754 ("??aspect Unused specified for &!", N
, Ent
);
25757 ("??aspect Unmodified specified for &!", N
, Ent
);
25761 Set_Never_Set_In_Source
(Ent
, False);
25764 Set_Is_True_Constant
(Ent
, False);
25765 Set_Current_Value
(Ent
, Empty
);
25766 Set_Is_Known_Null
(Ent
, False);
25768 if not Can_Never_Be_Null
(Ent
) then
25769 Set_Is_Known_Non_Null
(Ent
, False);
25772 -- Follow renaming chain
25774 if Ekind
(Ent
) in E_Variable | E_Constant
25775 and then Present
(Renamed_Object
(Ent
))
25777 Exp
:= Renamed_Object
(Ent
);
25779 -- If the entity is the loop variable in an iteration over
25780 -- a container, retrieve container expression to indicate
25781 -- possible modification.
25783 if Present
(Related_Expression
(Ent
))
25784 and then Nkind
(Parent
(Related_Expression
(Ent
))) =
25785 N_Iterator_Specification
25787 Exp
:= Original_Node
(Related_Expression
(Ent
));
25792 -- The expression may be the renaming of a subcomponent of an
25793 -- array or container. The assignment to the subcomponent is
25794 -- a modification of the container.
25796 elsif Comes_From_Source
(Original_Node
(Exp
))
25797 and then Nkind
(Original_Node
(Exp
)) in
25798 N_Selected_Component | N_Indexed_Component
25800 Exp
:= Prefix
(Original_Node
(Exp
));
25804 -- Generate a reference only if the assignment comes from
25805 -- source. This excludes, for example, calls to a dispatching
25806 -- assignment operation when the left-hand side is tagged. In
25807 -- GNATprove mode, we need those references also on generated
25808 -- code, as these are used to compute the local effects of
25811 if Modification_Comes_From_Source
or GNATprove_Mode
then
25812 Generate_Reference
(Ent
, Exp
, 'm');
25814 -- If the target of the assignment is the bound variable
25815 -- in an iterator, indicate that the corresponding array
25816 -- or container is also modified.
25818 if Ada_Version
>= Ada_2012
25819 and then Nkind
(Parent
(Ent
)) = N_Iterator_Specification
25822 Domain
: constant Node_Id
:= Name
(Parent
(Ent
));
25825 -- ??? In the full version of the construct, the
25826 -- domain of iteration can be given by an expression.
25828 if Is_Entity_Name
(Domain
) then
25829 Generate_Reference
(Entity
(Domain
), Exp
, 'm');
25830 Set_Is_True_Constant
(Entity
(Domain
), False);
25831 Set_Never_Set_In_Source
(Entity
(Domain
), False);
25840 -- If we are sure this is a modification from source, and we know
25841 -- this modifies a constant, then give an appropriate warning.
25844 and then Modification_Comes_From_Source
25845 and then Overlays_Constant
(Ent
)
25846 and then Address_Clause_Overlay_Warnings
25849 Addr
: constant Node_Id
:= Address_Clause
(Ent
);
25854 Find_Overlaid_Entity
(Addr
, O_Ent
, Off
);
25856 Error_Msg_Sloc
:= Sloc
(Addr
);
25858 ("?o?constant& may be modified via address clause#",
25869 end Note_Possible_Modification
;
25875 function Null_Status
(N
: Node_Id
) return Null_Status_Kind
is
25876 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean;
25877 -- Determine whether definition Def carries a null exclusion
25879 function Null_Status_Of_Entity
(Id
: Entity_Id
) return Null_Status_Kind
;
25880 -- Determine the null status of arbitrary entity Id
25882 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
;
25883 -- Determine the null status of type Typ
25885 ---------------------------
25886 -- Is_Null_Excluding_Def --
25887 ---------------------------
25889 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean is
25891 return Nkind
(Def
) in N_Access_Definition
25892 | N_Access_Function_Definition
25893 | N_Access_Procedure_Definition
25894 | N_Access_To_Object_Definition
25895 | N_Component_Definition
25896 | N_Derived_Type_Definition
25897 and then Null_Exclusion_Present
(Def
);
25898 end Is_Null_Excluding_Def
;
25900 ---------------------------
25901 -- Null_Status_Of_Entity --
25902 ---------------------------
25904 function Null_Status_Of_Entity
25905 (Id
: Entity_Id
) return Null_Status_Kind
25907 Decl
: constant Node_Id
:= Declaration_Node
(Id
);
25911 -- The value of an imported or exported entity may be set externally
25912 -- regardless of a null exclusion. As a result, the value cannot be
25913 -- determined statically.
25915 if Is_Imported
(Id
) or else Is_Exported
(Id
) then
25918 elsif Nkind
(Decl
) in N_Component_Declaration
25919 | N_Discriminant_Specification
25920 | N_Formal_Object_Declaration
25921 | N_Object_Declaration
25922 | N_Object_Renaming_Declaration
25923 | N_Parameter_Specification
25925 -- A component declaration yields a non-null value when either
25926 -- its component definition or access definition carries a null
25929 if Nkind
(Decl
) = N_Component_Declaration
then
25930 Def
:= Component_Definition
(Decl
);
25932 if Is_Null_Excluding_Def
(Def
) then
25933 return Is_Non_Null
;
25936 Def
:= Access_Definition
(Def
);
25938 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25939 return Is_Non_Null
;
25942 -- A formal object declaration yields a non-null value if its
25943 -- access definition carries a null exclusion. If the object is
25944 -- default initialized, then the value depends on the expression.
25946 elsif Nkind
(Decl
) = N_Formal_Object_Declaration
then
25947 Def
:= Access_Definition
(Decl
);
25949 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25950 return Is_Non_Null
;
25953 -- A constant may yield a null or non-null value depending on its
25954 -- initialization expression.
25956 elsif Ekind
(Id
) = E_Constant
then
25957 return Null_Status
(Constant_Value
(Id
));
25959 -- The construct yields a non-null value when it has a null
25962 elsif Null_Exclusion_Present
(Decl
) then
25963 return Is_Non_Null
;
25965 -- An object renaming declaration yields a non-null value if its
25966 -- access definition carries a null exclusion. Otherwise the value
25967 -- depends on the renamed name.
25969 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
25970 Def
:= Access_Definition
(Decl
);
25972 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25973 return Is_Non_Null
;
25976 return Null_Status
(Name
(Decl
));
25981 -- At this point the declaration of the entity does not carry a null
25982 -- exclusion and lacks an initialization expression. Check the status
25985 return Null_Status_Of_Type
(Etype
(Id
));
25986 end Null_Status_Of_Entity
;
25988 -------------------------
25989 -- Null_Status_Of_Type --
25990 -------------------------
25992 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
is
25997 -- Traverse the type chain looking for types with null exclusion
26000 while Present
(Curr
) and then Etype
(Curr
) /= Curr
loop
26001 Decl
:= Parent
(Curr
);
26003 -- Guard against itypes which do not always have declarations. A
26004 -- type yields a non-null value if it carries a null exclusion.
26006 if Present
(Decl
) then
26007 if Nkind
(Decl
) = N_Full_Type_Declaration
26008 and then Is_Null_Excluding_Def
(Type_Definition
(Decl
))
26010 return Is_Non_Null
;
26012 elsif Nkind
(Decl
) = N_Subtype_Declaration
26013 and then Null_Exclusion_Present
(Decl
)
26015 return Is_Non_Null
;
26019 Curr
:= Etype
(Curr
);
26022 -- The type chain does not contain any null excluding types
26025 end Null_Status_Of_Type
;
26027 -- Start of processing for Null_Status
26030 -- Prevent cascaded errors or infinite loops when trying to determine
26031 -- the null status of an erroneous construct.
26033 if Error_Posted
(N
) then
26036 -- An allocator always creates a non-null value
26038 elsif Nkind
(N
) = N_Allocator
then
26039 return Is_Non_Null
;
26041 -- Taking the 'Access of something yields a non-null value
26043 elsif Nkind
(N
) = N_Attribute_Reference
26044 and then Attribute_Name
(N
) in Name_Access
26045 | Name_Unchecked_Access
26046 | Name_Unrestricted_Access
26048 return Is_Non_Null
;
26050 -- "null" yields null
26052 elsif Nkind
(N
) = N_Null
then
26055 -- Check the status of the operand of a type conversion
26057 elsif Nkind
(N
) = N_Type_Conversion
then
26058 return Null_Status
(Expression
(N
));
26060 -- The input denotes a reference to an entity. Determine whether the
26061 -- entity or its type yields a null or non-null value.
26063 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26064 return Null_Status_Of_Entity
(Entity
(N
));
26067 -- Otherwise it is not possible to determine the null status of the
26068 -- subexpression at compile time without resorting to simple flow
26074 --------------------------------------
26075 -- Null_To_Null_Address_Convert_OK --
26076 --------------------------------------
26078 function Null_To_Null_Address_Convert_OK
26080 Typ
: Entity_Id
:= Empty
) return Boolean
26083 if not Relaxed_RM_Semantics
then
26087 if Nkind
(N
) = N_Null
then
26088 return Present
(Typ
) and then Is_Descendant_Of_Address
(Typ
);
26090 elsif Nkind
(N
) in N_Op_Compare
then
26092 L
: constant Node_Id
:= Left_Opnd
(N
);
26093 R
: constant Node_Id
:= Right_Opnd
(N
);
26096 -- We check the Etype of the complementary operand since the
26097 -- N_Null node is not decorated at this stage.
26100 ((Nkind
(L
) = N_Null
26101 and then Is_Descendant_Of_Address
(Etype
(R
)))
26103 (Nkind
(R
) = N_Null
26104 and then Is_Descendant_Of_Address
(Etype
(L
))));
26109 end Null_To_Null_Address_Convert_OK
;
26111 ---------------------------------
26112 -- Number_Of_Elements_In_Array --
26113 ---------------------------------
26115 function Number_Of_Elements_In_Array
(T
: Entity_Id
) return Int
is
26123 pragma Assert
(Is_Array_Type
(T
));
26125 Indx
:= First_Index
(T
);
26126 while Present
(Indx
) loop
26127 Typ
:= Underlying_Type
(Etype
(Indx
));
26129 -- Never look at junk bounds of a generic type
26131 if Is_Generic_Type
(Typ
) then
26135 -- Check the array bounds are known at compile time and return zero
26136 -- if they are not.
26138 Low
:= Type_Low_Bound
(Typ
);
26139 High
:= Type_High_Bound
(Typ
);
26141 if not Compile_Time_Known_Value
(Low
) then
26143 elsif not Compile_Time_Known_Value
(High
) then
26147 Num
* UI_To_Int
((Expr_Value
(High
) - Expr_Value
(Low
) + 1));
26154 end Number_Of_Elements_In_Array
;
26156 ---------------------------------
26157 -- Original_Aspect_Pragma_Name --
26158 ---------------------------------
26160 function Original_Aspect_Pragma_Name
(N
: Node_Id
) return Name_Id
is
26162 Item_Nam
: Name_Id
;
26165 pragma Assert
(Nkind
(N
) in N_Aspect_Specification | N_Pragma
);
26169 -- The pragma was generated to emulate an aspect, use the original
26170 -- aspect specification.
26172 if Nkind
(Item
) = N_Pragma
and then From_Aspect_Specification
(Item
) then
26173 Item
:= Corresponding_Aspect
(Item
);
26176 -- Retrieve the name of the aspect/pragma. As assertion pragmas from
26177 -- a generic instantiation might have been rewritten into pragma Check,
26178 -- we look at the original node for Item. Note also that Pre, Pre_Class,
26179 -- Post and Post_Class rewrite their pragma identifier to preserve the
26180 -- original name, so we look at the original node for the identifier.
26181 -- ??? this is kludgey
26183 if Nkind
(Item
) = N_Pragma
then
26185 Chars
(Original_Node
(Pragma_Identifier
(Original_Node
(Item
))));
26188 pragma Assert
(Nkind
(Item
) = N_Aspect_Specification
);
26189 Item_Nam
:= Chars
(Identifier
(Item
));
26192 -- Deal with 'Class by converting the name to its _XXX form
26194 if Class_Present
(Item
) then
26195 if Item_Nam
= Name_Invariant
then
26196 Item_Nam
:= Name_uInvariant
;
26198 elsif Item_Nam
= Name_Post
then
26199 Item_Nam
:= Name_uPost
;
26201 elsif Item_Nam
= Name_Pre
then
26202 Item_Nam
:= Name_uPre
;
26204 elsif Item_Nam
in Name_Type_Invariant | Name_Type_Invariant_Class
26206 Item_Nam
:= Name_uType_Invariant
;
26208 -- Nothing to do for other cases (e.g. a Check that derived from
26209 -- Pre_Class and has the flag set). Also we do nothing if the name
26210 -- is already in special _xxx form.
26216 end Original_Aspect_Pragma_Name
;
26218 --------------------------------------
26219 -- Original_Corresponding_Operation --
26220 --------------------------------------
26222 function Original_Corresponding_Operation
(S
: Entity_Id
) return Entity_Id
26224 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
26227 -- If S is an inherited primitive S2 the original corresponding
26228 -- operation of S is the original corresponding operation of S2
26230 if Present
(Alias
(S
))
26231 and then Find_Dispatching_Type
(Alias
(S
)) /= Typ
26233 return Original_Corresponding_Operation
(Alias
(S
));
26235 -- If S overrides an inherited subprogram S2 the original corresponding
26236 -- operation of S is the original corresponding operation of S2
26238 elsif Present
(Overridden_Operation
(S
)) then
26239 return Original_Corresponding_Operation
(Overridden_Operation
(S
));
26241 -- otherwise it is S itself
26246 end Original_Corresponding_Operation
;
26248 -----------------------------------
26249 -- Original_View_In_Visible_Part --
26250 -----------------------------------
26252 function Original_View_In_Visible_Part
26253 (Typ
: Entity_Id
) return Boolean
26255 Scop
: constant Entity_Id
:= Scope
(Typ
);
26258 -- The scope must be a package
26260 if not Is_Package_Or_Generic_Package
(Scop
) then
26264 -- A type with a private declaration has a private view declared in
26265 -- the visible part.
26267 if Has_Private_Declaration
(Typ
) then
26271 return List_Containing
(Parent
(Typ
)) =
26272 Visible_Declarations
(Package_Specification
(Scop
));
26273 end Original_View_In_Visible_Part
;
26275 -------------------
26276 -- Output_Entity --
26277 -------------------
26279 procedure Output_Entity
(Id
: Entity_Id
) is
26283 Scop
:= Scope
(Id
);
26285 -- The entity may lack a scope when it is in the process of being
26286 -- analyzed. Use the current scope as an approximation.
26289 Scop
:= Current_Scope
;
26292 Output_Name
(Chars
(Id
), Scop
);
26299 procedure Output_Name
(Nam
: Name_Id
; Scop
: Entity_Id
:= Current_Scope
) is
26303 (Get_Qualified_Name
26314 -- This would be trivial, simply a test for an identifier that was a
26315 -- reference to a formal, if it were not for the fact that a previous call
26316 -- to Expand_Entry_Parameter will have modified the reference to the
26317 -- identifier. A formal of a protected entity is rewritten as
26319 -- typ!(recobj).rec.all'Constrained
26321 -- where rec is a selector whose Entry_Formal link points to the formal
26323 -- If the type of the entry parameter has a representation clause, then an
26324 -- extra temp is involved (see below).
26326 -- For a formal of a task entity, the formal is rewritten as a local
26329 -- In addition, a formal that is marked volatile because it is aliased
26330 -- through an address clause is rewritten as dereference as well.
26332 function Param_Entity
(N
: Node_Id
) return Entity_Id
is
26333 Renamed_Obj
: Node_Id
;
26336 -- Simple reference case
26338 if Nkind
(N
) in N_Identifier | N_Expanded_Name
then
26339 if Is_Formal
(Entity
(N
)) then
26342 -- Handle renamings of formal parameters and formals of tasks that
26343 -- are rewritten as renamings.
26345 elsif Nkind
(Parent
(Entity
(N
))) = N_Object_Renaming_Declaration
then
26346 Renamed_Obj
:= Get_Referenced_Object
(Renamed_Object
(Entity
(N
)));
26348 if Is_Entity_Name
(Renamed_Obj
)
26349 and then Is_Formal
(Entity
(Renamed_Obj
))
26351 return Entity
(Renamed_Obj
);
26354 Nkind
(Parent
(Parent
(Entity
(N
)))) = N_Accept_Statement
26361 if Nkind
(N
) = N_Explicit_Dereference
then
26363 P
: Node_Id
:= Prefix
(N
);
26369 -- If the type of an entry parameter has a representation
26370 -- clause, then the prefix is not a selected component, but
26371 -- instead a reference to a temp pointing at the selected
26372 -- component. In this case, set P to be the initial value of
26375 if Nkind
(P
) = N_Identifier
then
26378 if Ekind
(E
) = E_Constant
then
26379 Decl
:= Parent
(E
);
26381 if Nkind
(Decl
) = N_Object_Declaration
then
26382 P
:= Expression
(Decl
);
26387 if Nkind
(P
) = N_Selected_Component
then
26388 S
:= Selector_Name
(P
);
26390 if Present
(Entry_Formal
(Entity
(S
))) then
26391 return Entry_Formal
(Entity
(S
));
26394 elsif Nkind
(Original_Node
(N
)) = N_Identifier
then
26395 return Param_Entity
(Original_Node
(N
));
26404 ----------------------
26405 -- Policy_In_Effect --
26406 ----------------------
26408 function Policy_In_Effect
(Policy
: Name_Id
) return Name_Id
is
26409 function Policy_In_List
(List
: Node_Id
) return Name_Id
;
26410 -- Determine the mode of a policy in a N_Pragma list
26412 --------------------
26413 -- Policy_In_List --
26414 --------------------
26416 function Policy_In_List
(List
: Node_Id
) return Name_Id
is
26423 while Present
(Prag
) loop
26424 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
26425 Arg2
:= Next
(Arg1
);
26427 Arg1
:= Get_Pragma_Arg
(Arg1
);
26428 Arg2
:= Get_Pragma_Arg
(Arg2
);
26430 -- The current Check_Policy pragma matches the requested policy or
26431 -- appears in the single argument form (Assertion, policy_id).
26433 if Chars
(Arg1
) in Name_Assertion | Policy
then
26434 return Chars
(Arg2
);
26437 Prag
:= Next_Pragma
(Prag
);
26441 end Policy_In_List
;
26447 -- Start of processing for Policy_In_Effect
26450 if not Is_Valid_Assertion_Kind
(Policy
) then
26451 raise Program_Error
;
26454 -- Inspect all policy pragmas that appear within scopes (if any)
26456 Kind
:= Policy_In_List
(Check_Policy_List
);
26458 -- Inspect all configuration policy pragmas (if any)
26460 if Kind
= No_Name
then
26461 Kind
:= Policy_In_List
(Check_Policy_List_Config
);
26464 -- The context lacks policy pragmas, determine the mode based on whether
26465 -- assertions are enabled at the configuration level. This ensures that
26466 -- the policy is preserved when analyzing generics.
26468 if Kind
= No_Name
then
26469 if Assertions_Enabled_Config
then
26470 Kind
:= Name_Check
;
26472 Kind
:= Name_Ignore
;
26476 -- In CodePeer mode and GNATprove mode, we need to consider all
26477 -- assertions, unless they are disabled. Force Name_Check on
26478 -- ignored assertions.
26480 if Kind
in Name_Ignore | Name_Off
26481 and then (CodePeer_Mode
or GNATprove_Mode
)
26483 Kind
:= Name_Check
;
26487 end Policy_In_Effect
;
26489 -------------------------------
26490 -- Preanalyze_Without_Errors --
26491 -------------------------------
26493 procedure Preanalyze_Without_Errors
(N
: Node_Id
) is
26494 Status
: constant Boolean := Get_Ignore_Errors
;
26496 Set_Ignore_Errors
(True);
26498 Set_Ignore_Errors
(Status
);
26499 end Preanalyze_Without_Errors
;
26501 -----------------------
26502 -- Predicate_Enabled --
26503 -----------------------
26505 function Predicate_Enabled
(Typ
: Entity_Id
) return Boolean is
26507 return Present
(Predicate_Function
(Typ
))
26508 and then not Predicates_Ignored
(Typ
)
26509 and then not Predicate_Checks_Suppressed
(Empty
);
26510 end Predicate_Enabled
;
26512 ----------------------------------
26513 -- Predicate_Failure_Expression --
26514 ----------------------------------
26516 function Predicate_Failure_Expression
26517 (Typ
: Entity_Id
; Inherited_OK
: Boolean) return Node_Id
26519 PF_Aspect
: constant Node_Id
:=
26520 Find_Aspect
(Typ
, Aspect_Predicate_Failure
);
26522 -- Check for Predicate_Failure aspect specification via an
26523 -- aspect_specification (as opposed to via a pragma).
26525 if Present
(PF_Aspect
) then
26526 if Inherited_OK
or else Entity
(PF_Aspect
) = Typ
then
26527 return Expression
(PF_Aspect
);
26533 -- Check for Predicate_Failure aspect specification via a pragma.
26536 Rep_Item
: Node_Id
:= First_Rep_Item
(Typ
);
26538 while Present
(Rep_Item
) loop
26539 if Nkind
(Rep_Item
) = N_Pragma
26540 and then Get_Pragma_Id
(Rep_Item
) = Pragma_Predicate_Failure
26543 Arg1
: constant Node_Id
:=
26545 (First
(Pragma_Argument_Associations
(Rep_Item
)));
26546 Arg2
: constant Node_Id
:=
26548 (Next
(First
(Pragma_Argument_Associations
(Rep_Item
))));
26550 if Inherited_OK
or else
26551 (Nkind
(Arg1
) in N_Has_Entity
26552 and then Entity
(Arg1
) = Typ
)
26559 Next_Rep_Item
(Rep_Item
);
26563 -- If we are interested in an inherited Predicate_Failure aspect
26564 -- and we have an ancestor to inherit from, then recursively check
26567 if Inherited_OK
and then Present
(Nearest_Ancestor
(Typ
)) then
26568 return Predicate_Failure_Expression
(Nearest_Ancestor
(Typ
),
26569 Inherited_OK
=> True);
26573 end Predicate_Failure_Expression
;
26575 ----------------------------------
26576 -- Predicate_Tests_On_Arguments --
26577 ----------------------------------
26579 function Predicate_Tests_On_Arguments
(Subp
: Entity_Id
) return Boolean is
26581 -- Always test predicates on indirect call
26583 if Ekind
(Subp
) = E_Subprogram_Type
then
26586 -- Do not test predicates on call to generated default Finalize, since
26587 -- we are not interested in whether something we are finalizing (and
26588 -- typically destroying) satisfies its predicates.
26590 elsif Chars
(Subp
) = Name_Finalize
26591 and then not Comes_From_Source
(Subp
)
26595 -- Do not test predicates on any internally generated routines
26597 elsif Is_Internal_Name
(Chars
(Subp
)) then
26600 -- Do not test predicates on call to Init_Proc, since if needed the
26601 -- predicate test will occur at some other point.
26603 elsif Is_Init_Proc
(Subp
) then
26606 -- Do not test predicates on call to predicate function, since this
26607 -- would cause infinite recursion.
26609 elsif Ekind
(Subp
) = E_Function
26610 and then Is_Predicate_Function
(Subp
)
26614 -- For now, no other exceptions
26619 end Predicate_Tests_On_Arguments
;
26621 -----------------------
26622 -- Private_Component --
26623 -----------------------
26625 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
26626 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
26628 function Trace_Components
26630 Check
: Boolean) return Entity_Id
;
26631 -- Recursive function that does the work, and checks against circular
26632 -- definition for each subcomponent type.
26634 ----------------------
26635 -- Trace_Components --
26636 ----------------------
26638 function Trace_Components
26640 Check
: Boolean) return Entity_Id
26642 Btype
: constant Entity_Id
:= Base_Type
(T
);
26643 Component
: Entity_Id
;
26645 Candidate
: Entity_Id
:= Empty
;
26648 if Check
and then Btype
= Ancestor
then
26649 Error_Msg_N
("circular type definition", Type_Id
);
26653 if Is_Private_Type
(Btype
) and then not Is_Generic_Type
(Btype
) then
26654 if Present
(Full_View
(Btype
))
26655 and then Is_Record_Type
(Full_View
(Btype
))
26656 and then not Is_Frozen
(Btype
)
26658 -- To indicate that the ancestor depends on a private type, the
26659 -- current Btype is sufficient. However, to check for circular
26660 -- definition we must recurse on the full view.
26662 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
26664 if Candidate
= Any_Type
then
26674 elsif Is_Array_Type
(Btype
) then
26675 return Trace_Components
(Component_Type
(Btype
), True);
26677 elsif Is_Record_Type
(Btype
) then
26678 Component
:= First_Entity
(Btype
);
26679 while Present
(Component
)
26680 and then Comes_From_Source
(Component
)
26682 -- Skip anonymous types generated by constrained components
26684 if not Is_Type
(Component
) then
26685 P
:= Trace_Components
(Etype
(Component
), True);
26687 if Present
(P
) then
26688 if P
= Any_Type
then
26696 Next_Entity
(Component
);
26704 end Trace_Components
;
26706 -- Start of processing for Private_Component
26709 return Trace_Components
(Type_Id
, False);
26710 end Private_Component
;
26712 ---------------------------
26713 -- Primitive_Names_Match --
26714 ---------------------------
26716 function Primitive_Names_Match
(E1
, E2
: Entity_Id
) return Boolean is
26717 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
;
26718 -- Given an internal name, returns the corresponding non-internal name
26720 ------------------------
26721 -- Non_Internal_Name --
26722 ------------------------
26724 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
is
26726 Get_Name_String
(Chars
(E
));
26727 Name_Len
:= Name_Len
- 1;
26729 end Non_Internal_Name
;
26731 -- Start of processing for Primitive_Names_Match
26734 pragma Assert
(Present
(E1
) and then Present
(E2
));
26736 return Chars
(E1
) = Chars
(E2
)
26738 (not Is_Internal_Name
(Chars
(E1
))
26739 and then Is_Internal_Name
(Chars
(E2
))
26740 and then Non_Internal_Name
(E2
) = Chars
(E1
))
26742 (not Is_Internal_Name
(Chars
(E2
))
26743 and then Is_Internal_Name
(Chars
(E1
))
26744 and then Non_Internal_Name
(E1
) = Chars
(E2
))
26746 (Is_Predefined_Dispatching_Operation
(E1
)
26747 and then Is_Predefined_Dispatching_Operation
(E2
)
26748 and then Same_TSS
(E1
, E2
))
26750 (Is_Init_Proc
(E1
) and then Is_Init_Proc
(E2
));
26751 end Primitive_Names_Match
;
26753 -----------------------
26754 -- Process_End_Label --
26755 -----------------------
26757 procedure Process_End_Label
26766 Label_Ref
: Boolean;
26767 -- Set True if reference to end label itself is required
26770 -- Gets set to the operator symbol or identifier that references the
26771 -- entity Ent. For the child unit case, this is the identifier from the
26772 -- designator. For other cases, this is simply Endl.
26774 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
);
26775 -- N is an identifier node that appears as a parent unit reference in
26776 -- the case where Ent is a child unit. This procedure generates an
26777 -- appropriate cross-reference entry. E is the corresponding entity.
26779 -------------------------
26780 -- Generate_Parent_Ref --
26781 -------------------------
26783 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
) is
26785 -- If names do not match, something weird, skip reference
26787 if Chars
(E
) = Chars
(N
) then
26789 -- Generate the reference. We do NOT consider this as a reference
26790 -- for unreferenced symbol purposes.
26792 Generate_Reference
(E
, N
, 'r', Set_Ref
=> False, Force
=> True);
26794 if Style_Check
then
26795 Style
.Check_Identifier
(N
, E
);
26798 end Generate_Parent_Ref
;
26800 -- Start of processing for Process_End_Label
26803 -- If no node, ignore. This happens in some error situations, and
26804 -- also for some internally generated structures where no end label
26805 -- references are required in any case.
26811 -- Nothing to do if no End_Label, happens for internally generated
26812 -- constructs where we don't want an end label reference anyway. Also
26813 -- nothing to do if Endl is a string literal, which means there was
26814 -- some prior error (bad operator symbol)
26816 Endl
:= End_Label
(N
);
26818 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
26822 -- Reference node is not in extended main source unit
26824 if not In_Extended_Main_Source_Unit
(N
) then
26826 -- Generally we do not collect references except for the extended
26827 -- main source unit. The one exception is the 'e' entry for a
26828 -- package spec, where it is useful for a client to have the
26829 -- ending information to define scopes.
26835 Label_Ref
:= False;
26837 -- For this case, we can ignore any parent references, but we
26838 -- need the package name itself for the 'e' entry.
26840 if Nkind
(Endl
) = N_Designator
then
26841 Endl
:= Identifier
(Endl
);
26845 -- Reference is in extended main source unit
26850 -- For designator, generate references for the parent entries
26852 if Nkind
(Endl
) = N_Designator
then
26854 -- Generate references for the prefix if the END line comes from
26855 -- source (otherwise we do not need these references) We climb the
26856 -- scope stack to find the expected entities.
26858 if Comes_From_Source
(Endl
) then
26859 Nam
:= Name
(Endl
);
26860 Scop
:= Current_Scope
;
26861 while Nkind
(Nam
) = N_Selected_Component
loop
26862 Scop
:= Scope
(Scop
);
26863 exit when No
(Scop
);
26864 Generate_Parent_Ref
(Selector_Name
(Nam
), Scop
);
26865 Nam
:= Prefix
(Nam
);
26868 if Present
(Scop
) then
26869 Generate_Parent_Ref
(Nam
, Scope
(Scop
));
26873 Endl
:= Identifier
(Endl
);
26877 -- If the end label is not for the given entity, then either we have
26878 -- some previous error, or this is a generic instantiation for which
26879 -- we do not need to make a cross-reference in this case anyway. In
26880 -- either case we simply ignore the call.
26882 if Chars
(Ent
) /= Chars
(Endl
) then
26886 -- If label was really there, then generate a normal reference and then
26887 -- adjust the location in the end label to point past the name (which
26888 -- should almost always be the semicolon).
26890 Loc
:= Sloc
(Endl
);
26892 if Comes_From_Source
(Endl
) then
26894 -- If a label reference is required, then do the style check and
26895 -- generate an l-type cross-reference entry for the label
26898 if Style_Check
then
26899 Style
.Check_Identifier
(Endl
, Ent
);
26902 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
26905 -- Set the location to point past the label (normally this will
26906 -- mean the semicolon immediately following the label). This is
26907 -- done for the sake of the 'e' or 't' entry generated below.
26909 Get_Decoded_Name_String
(Chars
(Endl
));
26910 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
26913 -- Now generate the e/t reference
26915 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
26917 -- Restore Sloc, in case modified above, since we have an identifier
26918 -- and the normal Sloc should be left set in the tree.
26920 Set_Sloc
(Endl
, Loc
);
26921 end Process_End_Label
;
26923 --------------------------------
26924 -- Propagate_Concurrent_Flags --
26925 --------------------------------
26927 procedure Propagate_Concurrent_Flags
26929 Comp_Typ
: Entity_Id
)
26932 if Has_Task
(Comp_Typ
) then
26933 Set_Has_Task
(Typ
);
26936 if Has_Protected
(Comp_Typ
) then
26937 Set_Has_Protected
(Typ
);
26940 if Has_Timing_Event
(Comp_Typ
) then
26941 Set_Has_Timing_Event
(Typ
);
26943 end Propagate_Concurrent_Flags
;
26945 ------------------------------
26946 -- Propagate_DIC_Attributes --
26947 ------------------------------
26949 procedure Propagate_DIC_Attributes
26951 From_Typ
: Entity_Id
)
26953 DIC_Proc
: Entity_Id
;
26954 Partial_DIC_Proc
: Entity_Id
;
26957 if Present
(Typ
) and then Present
(From_Typ
) then
26958 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26960 -- Nothing to do if both the source and the destination denote the
26963 if From_Typ
= Typ
then
26966 -- Nothing to do when the destination denotes an incomplete type
26967 -- because the DIC is associated with the current instance of a
26968 -- private type, thus it can never apply to an incomplete type.
26970 elsif Is_Incomplete_Type
(Typ
) then
26974 DIC_Proc
:= DIC_Procedure
(From_Typ
);
26975 Partial_DIC_Proc
:= Partial_DIC_Procedure
(From_Typ
);
26977 -- The setting of the attributes is intentionally conservative. This
26978 -- prevents accidental clobbering of enabled attributes. We need to
26979 -- call Base_Type twice, because it is sometimes not set to an actual
26982 if Has_Inherited_DIC
(From_Typ
) then
26983 Set_Has_Inherited_DIC
(Base_Type
(Base_Type
(Typ
)));
26986 if Has_Own_DIC
(From_Typ
) then
26987 Set_Has_Own_DIC
(Base_Type
(Base_Type
(Typ
)));
26990 if Present
(DIC_Proc
) and then No
(DIC_Procedure
(Typ
)) then
26991 Set_DIC_Procedure
(Typ
, DIC_Proc
);
26994 if Present
(Partial_DIC_Proc
)
26995 and then No
(Partial_DIC_Procedure
(Typ
))
26997 Set_Partial_DIC_Procedure
(Typ
, Partial_DIC_Proc
);
27000 end Propagate_DIC_Attributes
;
27002 ------------------------------------
27003 -- Propagate_Invariant_Attributes --
27004 ------------------------------------
27006 procedure Propagate_Invariant_Attributes
27008 From_Typ
: Entity_Id
)
27010 Full_IP
: Entity_Id
;
27011 Part_IP
: Entity_Id
;
27014 if Present
(Typ
) and then Present
(From_Typ
) then
27015 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
27017 -- Nothing to do if both the source and the destination denote the
27020 if From_Typ
= Typ
then
27024 Full_IP
:= Invariant_Procedure
(From_Typ
);
27025 Part_IP
:= Partial_Invariant_Procedure
(From_Typ
);
27027 -- The setting of the attributes is intentionally conservative. This
27028 -- prevents accidental clobbering of enabled attributes. We need to
27029 -- call Base_Type twice, because it is sometimes not set to an actual
27032 if Has_Inheritable_Invariants
(From_Typ
) then
27033 Set_Has_Inheritable_Invariants
(Typ
);
27036 if Has_Inherited_Invariants
(From_Typ
) then
27037 Set_Has_Inherited_Invariants
(Typ
);
27040 if Has_Own_Invariants
(From_Typ
) then
27041 Set_Has_Own_Invariants
(Base_Type
(Base_Type
(Typ
)));
27044 if Present
(Full_IP
) and then No
(Invariant_Procedure
(Typ
)) then
27045 Set_Invariant_Procedure
(Typ
, Full_IP
);
27048 if Present
(Part_IP
) and then No
(Partial_Invariant_Procedure
(Typ
))
27050 Set_Partial_Invariant_Procedure
(Typ
, Part_IP
);
27053 end Propagate_Invariant_Attributes
;
27055 ------------------------------------
27056 -- Propagate_Predicate_Attributes --
27057 ------------------------------------
27059 procedure Propagate_Predicate_Attributes
27061 From_Typ
: Entity_Id
)
27063 Pred_Func
: Entity_Id
;
27065 if Present
(Typ
) and then Present
(From_Typ
) then
27066 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
27068 -- Nothing to do if both the source and the destination denote the
27071 if From_Typ
= Typ
then
27075 Pred_Func
:= Predicate_Function
(From_Typ
);
27077 -- The setting of the attributes is intentionally conservative. This
27078 -- prevents accidental clobbering of enabled attributes.
27080 if Has_Predicates
(From_Typ
) then
27081 Set_Has_Predicates
(Typ
);
27084 if Present
(Pred_Func
) and then No
(Predicate_Function
(Typ
)) then
27085 Set_Predicate_Function
(Typ
, Pred_Func
);
27088 end Propagate_Predicate_Attributes
;
27090 ---------------------------------------
27091 -- Record_Possible_Part_Of_Reference --
27092 ---------------------------------------
27094 procedure Record_Possible_Part_Of_Reference
27095 (Var_Id
: Entity_Id
;
27098 Encap
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
27102 -- The variable is a constituent of a single protected/task type. Such
27103 -- a variable acts as a component of the type and must appear within a
27104 -- specific region (SPARK RM 9(3)). Instead of recording the reference,
27105 -- verify its legality now.
27107 if Present
(Encap
) and then Is_Single_Concurrent_Object
(Encap
) then
27108 Check_Part_Of_Reference
(Var_Id
, Ref
);
27110 -- The variable is subject to pragma Part_Of and may eventually become a
27111 -- constituent of a single protected/task type. Record the reference to
27112 -- verify its placement when the contract of the variable is analyzed.
27114 elsif Present
(Get_Pragma
(Var_Id
, Pragma_Part_Of
)) then
27115 Refs
:= Part_Of_References
(Var_Id
);
27118 Refs
:= New_Elmt_List
;
27119 Set_Part_Of_References
(Var_Id
, Refs
);
27122 Append_Elmt
(Ref
, Refs
);
27124 end Record_Possible_Part_Of_Reference
;
27130 function Referenced
(Id
: Entity_Id
; Expr
: Node_Id
) return Boolean is
27131 Seen
: Boolean := False;
27133 function Is_Reference
(N
: Node_Id
) return Traverse_Result
;
27134 -- Determine whether node N denotes a reference to Id. If this is the
27135 -- case, set global flag Seen to True and stop the traversal.
27141 function Is_Reference
(N
: Node_Id
) return Traverse_Result
is
27143 if Is_Entity_Name
(N
)
27144 and then Present
(Entity
(N
))
27145 and then Entity
(N
) = Id
27154 procedure Inspect_Expression
is new Traverse_Proc
(Is_Reference
);
27156 -- Start of processing for Referenced
27159 Inspect_Expression
(Expr
);
27163 ------------------------------------
27164 -- References_Generic_Formal_Type --
27165 ------------------------------------
27167 function References_Generic_Formal_Type
(N
: Node_Id
) return Boolean is
27169 function Process
(N
: Node_Id
) return Traverse_Result
;
27170 -- Process one node in search for generic formal type
27176 function Process
(N
: Node_Id
) return Traverse_Result
is
27178 if Nkind
(N
) in N_Has_Entity
then
27180 E
: constant Entity_Id
:= Entity
(N
);
27182 if Present
(E
) then
27183 if Is_Generic_Type
(E
) then
27185 elsif Present
(Etype
(E
))
27186 and then Is_Generic_Type
(Etype
(E
))
27197 function Traverse
is new Traverse_Func
(Process
);
27198 -- Traverse tree to look for generic type
27201 if Inside_A_Generic
then
27202 return Traverse
(N
) = Abandon
;
27206 end References_Generic_Formal_Type
;
27208 -------------------------------
27209 -- Remove_Entity_And_Homonym --
27210 -------------------------------
27212 procedure Remove_Entity_And_Homonym
(Id
: Entity_Id
) is
27214 Remove_Entity
(Id
);
27215 Remove_Homonym
(Id
);
27216 end Remove_Entity_And_Homonym
;
27218 --------------------
27219 -- Remove_Homonym --
27220 --------------------
27222 procedure Remove_Homonym
(Id
: Entity_Id
) is
27224 Prev
: Entity_Id
:= Empty
;
27227 if Id
= Current_Entity
(Id
) then
27228 if Present
(Homonym
(Id
)) then
27229 Set_Current_Entity
(Homonym
(Id
));
27231 Set_Name_Entity_Id
(Chars
(Id
), Empty
);
27235 Hom
:= Current_Entity
(Id
);
27236 while Present
(Hom
) and then Hom
/= Id
loop
27238 Hom
:= Homonym
(Hom
);
27241 -- If Id is not on the homonym chain, nothing to do
27243 if Present
(Hom
) then
27244 Set_Homonym
(Prev
, Homonym
(Id
));
27247 end Remove_Homonym
;
27249 ------------------------------
27250 -- Remove_Overloaded_Entity --
27251 ------------------------------
27253 procedure Remove_Overloaded_Entity
(Id
: Entity_Id
) is
27254 procedure Remove_Primitive_Of
(Typ
: Entity_Id
);
27255 -- Remove primitive subprogram Id from the list of primitives that
27256 -- belong to type Typ.
27258 -------------------------
27259 -- Remove_Primitive_Of --
27260 -------------------------
27262 procedure Remove_Primitive_Of
(Typ
: Entity_Id
) is
27266 if Is_Tagged_Type
(Typ
) then
27267 Prims
:= Direct_Primitive_Operations
(Typ
);
27269 if Present
(Prims
) then
27270 Remove
(Prims
, Id
);
27273 end Remove_Primitive_Of
;
27277 Formal
: Entity_Id
;
27279 -- Start of processing for Remove_Overloaded_Entity
27282 Remove_Entity_And_Homonym
(Id
);
27284 -- The entity denotes a primitive subprogram. Remove it from the list of
27285 -- primitives of the associated controlling type.
27287 if Ekind
(Id
) in E_Function | E_Procedure
and then Is_Primitive
(Id
) then
27288 Formal
:= First_Formal
(Id
);
27289 while Present
(Formal
) loop
27290 if Is_Controlling_Formal
(Formal
) then
27291 Remove_Primitive_Of
(Etype
(Formal
));
27295 Next_Formal
(Formal
);
27298 if Ekind
(Id
) = E_Function
and then Has_Controlling_Result
(Id
) then
27299 Remove_Primitive_Of
(Etype
(Id
));
27302 end Remove_Overloaded_Entity
;
27304 ---------------------
27305 -- Rep_To_Pos_Flag --
27306 ---------------------
27308 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
27310 return New_Occurrence_Of
27311 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
27312 end Rep_To_Pos_Flag
;
27314 --------------------
27315 -- Require_Entity --
27316 --------------------
27318 procedure Require_Entity
(N
: Node_Id
) is
27320 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
27321 if Total_Errors_Detected
/= 0 then
27322 Set_Entity
(N
, Any_Id
);
27324 raise Program_Error
;
27327 end Require_Entity
;
27329 ------------------------------
27330 -- Requires_Transient_Scope --
27331 ------------------------------
27333 function Requires_Transient_Scope
(Typ
: Entity_Id
) return Boolean is
27335 return Returns_On_Secondary_Stack
(Typ
) or else Needs_Finalization
(Typ
);
27336 end Requires_Transient_Scope
;
27338 --------------------------
27339 -- Reset_Analyzed_Flags --
27340 --------------------------
27342 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
27343 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
;
27344 -- Function used to reset Analyzed flags in tree. Note that we do
27345 -- not reset Analyzed flags in entities, since there is no need to
27346 -- reanalyze entities, and indeed, it is wrong to do so, since it
27347 -- can result in generating auxiliary stuff more than once.
27349 --------------------
27350 -- Clear_Analyzed --
27351 --------------------
27353 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
is
27355 if Nkind
(N
) not in N_Entity
then
27356 Set_Analyzed
(N
, False);
27360 end Clear_Analyzed
;
27362 procedure Reset_Analyzed
is new Traverse_Proc
(Clear_Analyzed
);
27364 -- Start of processing for Reset_Analyzed_Flags
27367 Reset_Analyzed
(N
);
27368 end Reset_Analyzed_Flags
;
27370 ------------------------
27371 -- Restore_SPARK_Mode --
27372 ------------------------
27374 procedure Restore_SPARK_Mode
27375 (Mode
: SPARK_Mode_Type
;
27379 SPARK_Mode
:= Mode
;
27380 SPARK_Mode_Pragma
:= Prag
;
27381 end Restore_SPARK_Mode
;
27383 ---------------------------------
27384 -- Returns_On_Secondary_Stack --
27385 ---------------------------------
27387 function Returns_On_Secondary_Stack
(Id
: Entity_Id
) return Boolean is
27388 pragma Assert
(if Present
(Id
) then Ekind
(Id
) in E_Void | Type_Kind
);
27390 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean;
27391 -- Called for untagged record and protected types. Return True if the
27392 -- size of function results is known in the caller for Typ.
27394 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean;
27395 -- Returns True if Typ is a nonlimited record with defaulted
27396 -- discriminants whose max size makes it unsuitable for allocating on
27397 -- the primary stack.
27399 ------------------------------
27400 -- Caller_Known_Size_Record --
27401 ------------------------------
27403 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean is
27404 pragma Assert
(Typ
= Underlying_Type
(Typ
));
27406 function Depends_On_Discriminant
(Typ
: Entity_Id
) return Boolean;
27407 -- Called for untagged record and protected types. Return True if Typ
27408 -- depends on discriminants, either directly when it is unconstrained
27409 -- or indirectly when it is constrained by uplevel discriminants.
27411 -----------------------------
27412 -- Depends_On_Discriminant --
27413 -----------------------------
27415 function Depends_On_Discriminant
(Typ
: Entity_Id
) return Boolean is
27419 if Has_Discriminants
(Typ
) then
27420 if not Is_Constrained
(Typ
) then
27424 Cons
:= First_Elmt
(Discriminant_Constraint
(Typ
));
27425 while Present
(Cons
) loop
27426 if Nkind
(Node
(Cons
)) = N_Identifier
27427 and then Ekind
(Entity
(Node
(Cons
))) = E_Discriminant
27438 end Depends_On_Discriminant
;
27441 -- First see if we have a variant part and return False if it depends
27442 -- on discriminants.
27444 if Has_Variant_Part
(Typ
) and then Depends_On_Discriminant
(Typ
) then
27448 -- Then loop over components and return False if their subtype has a
27449 -- caller-unknown size, possibly recursively.
27451 -- ??? This is overly conservative, an array could be nested inside
27452 -- some other record that is constrained by nondiscriminants. That
27453 -- is, the recursive calls are too conservative.
27459 Comp
:= First_Component
(Typ
);
27460 while Present
(Comp
) loop
27462 Comp_Type
: constant Entity_Id
:=
27463 Underlying_Type
(Etype
(Comp
));
27466 if Is_Record_Type
(Comp_Type
)
27468 Is_Protected_Type
(Comp_Type
)
27470 if not Caller_Known_Size_Record
(Comp_Type
) then
27474 elsif Is_Array_Type
(Comp_Type
) then
27475 if Size_Depends_On_Discriminant
(Comp_Type
) then
27481 Next_Component
(Comp
);
27486 end Caller_Known_Size_Record
;
27488 ------------------------------
27489 -- Large_Max_Size_Mutable --
27490 ------------------------------
27492 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean is
27493 pragma Assert
(Typ
= Underlying_Type
(Typ
));
27495 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean;
27496 -- Returns true if the discrete type T has a large range
27498 ----------------------------
27499 -- Is_Large_Discrete_Type --
27500 ----------------------------
27502 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean is
27503 Threshold
: constant Int
:= 16;
27504 -- Arbitrary threshold above which we consider it "large". We want
27505 -- a fairly large threshold, because these large types really
27506 -- shouldn't have default discriminants in the first place, in
27510 return UI_To_Int
(RM_Size
(T
)) > Threshold
;
27511 end Is_Large_Discrete_Type
;
27513 -- Start of processing for Large_Max_Size_Mutable
27516 if Is_Record_Type
(Typ
)
27517 and then not Is_Limited_View
(Typ
)
27518 and then Has_Defaulted_Discriminants
(Typ
)
27520 -- Loop through the components, looking for an array whose upper
27521 -- bound(s) depends on discriminants, where both the subtype of
27522 -- the discriminant and the index subtype are too large.
27528 Comp
:= First_Component
(Typ
);
27529 while Present
(Comp
) loop
27531 Comp_Type
: constant Entity_Id
:=
27532 Underlying_Type
(Etype
(Comp
));
27539 if Is_Array_Type
(Comp_Type
) then
27540 Indx
:= First_Index
(Comp_Type
);
27542 while Present
(Indx
) loop
27543 Ityp
:= Etype
(Indx
);
27544 Hi
:= Type_High_Bound
(Ityp
);
27546 if Nkind
(Hi
) = N_Identifier
27547 and then Ekind
(Entity
(Hi
)) = E_Discriminant
27548 and then Is_Large_Discrete_Type
(Ityp
)
27549 and then Is_Large_Discrete_Type
27550 (Etype
(Entity
(Hi
)))
27560 Next_Component
(Comp
);
27566 end Large_Max_Size_Mutable
;
27568 -- Local declarations
27570 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
27572 -- Start of processing for Returns_On_Secondary_Stack
27575 -- This is a private type which is not completed yet. This can only
27576 -- happen in a default expression (of a formal parameter or of a
27577 -- record component). Do not expand transient scope in this case.
27583 -- Do not expand transient scope for non-existent procedure return or
27584 -- string literal types.
27586 if Typ
= Standard_Void_Type
27587 or else Ekind
(Typ
) = E_String_Literal_Subtype
27591 -- If Typ is a generic formal incomplete type, then we want to look at
27592 -- the actual type.
27594 elsif Ekind
(Typ
) = E_Record_Subtype
27595 and then Present
(Cloned_Subtype
(Typ
))
27597 return Returns_On_Secondary_Stack
(Cloned_Subtype
(Typ
));
27599 -- Functions returning specific tagged types may dispatch on result, so
27600 -- their returned value is allocated on the secondary stack, even in the
27601 -- definite case. We must treat nondispatching functions the same way,
27602 -- because access-to-function types can point at both, so the calling
27603 -- conventions must be compatible.
27605 elsif Is_Tagged_Type
(Typ
) then
27608 -- If the return slot of the back end cannot be accessed, then there
27609 -- is no way to call Adjust at the right time for the return object if
27610 -- the type needs finalization, so the return object must be allocated
27611 -- on the secondary stack.
27613 elsif not Back_End_Return_Slot
and then Needs_Finalization
(Typ
) then
27616 -- Untagged definite subtypes are known size. This includes all
27617 -- elementary [sub]types. Tasks are known size even if they have
27618 -- discriminants. So we return False here, with one exception:
27619 -- For a type like:
27620 -- type T (Last : Natural := 0) is
27621 -- X : String (1 .. Last);
27623 -- we return True. That's because for "P(F(...));", where F returns T,
27624 -- we don't know the size of the result at the call site, so if we
27625 -- allocated it on the primary stack, we would have to allocate the
27626 -- maximum size, which is way too big.
27628 elsif Is_Definite_Subtype
(Typ
) or else Is_Task_Type
(Typ
) then
27629 return Large_Max_Size_Mutable
(Typ
);
27631 -- Indefinite (discriminated) untagged record or protected type
27633 elsif Is_Record_Type
(Typ
) or else Is_Protected_Type
(Typ
) then
27634 return not Caller_Known_Size_Record
(Typ
);
27636 -- Unconstrained array
27639 pragma Assert
(Is_Array_Type
(Typ
) and not Is_Definite_Subtype
(Typ
));
27642 end Returns_On_Secondary_Stack
;
27644 --------------------------------
27645 -- Returns_Unconstrained_Type --
27646 --------------------------------
27648 function Returns_Unconstrained_Type
(Subp
: Entity_Id
) return Boolean is
27650 return Ekind
(Subp
) = E_Function
27651 and then not Is_Scalar_Type
(Etype
(Subp
))
27652 and then not Is_Access_Type
(Etype
(Subp
))
27653 and then not Is_Constrained
(Etype
(Subp
));
27654 end Returns_Unconstrained_Type
;
27656 ----------------------------
27657 -- Root_Type_Of_Full_View --
27658 ----------------------------
27660 function Root_Type_Of_Full_View
(T
: Entity_Id
) return Entity_Id
is
27661 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
27664 -- The root type of the full view may itself be a private type. Keep
27665 -- looking for the ultimate derivation parent.
27667 if Is_Private_Type
(Rtyp
) and then Present
(Full_View
(Rtyp
)) then
27668 return Root_Type_Of_Full_View
(Full_View
(Rtyp
));
27672 end Root_Type_Of_Full_View
;
27674 ---------------------------
27675 -- Safe_To_Capture_Value --
27676 ---------------------------
27678 function Safe_To_Capture_Value
27681 Cond
: Boolean := False) return Boolean
27684 -- The only entities for which we track constant values are variables
27685 -- that are not renamings, constants and formal parameters, so check
27686 -- if we have this case.
27688 -- Note: it may seem odd to track constant values for constants, but in
27689 -- fact this routine is used for other purposes than simply capturing
27690 -- the value. In particular, the setting of Known[_Non]_Null and
27693 if (Ekind
(Ent
) = E_Variable
and then No
(Renamed_Object
(Ent
)))
27695 Ekind
(Ent
) = E_Constant
27701 -- For conditionals, we also allow loop parameters
27703 elsif Cond
and then Ekind
(Ent
) = E_Loop_Parameter
then
27706 -- For all other cases, not just unsafe, but impossible to capture
27707 -- Current_Value, since the above are the only entities which have
27708 -- Current_Value fields.
27714 -- Skip if volatile or aliased, since funny things might be going on in
27715 -- these cases which we cannot necessarily track. Also skip any variable
27716 -- for which an address clause is given, or whose address is taken. Also
27717 -- never capture value of library level variables (an attempt to do so
27718 -- can occur in the case of package elaboration code).
27720 if Treat_As_Volatile
(Ent
)
27721 or else Is_Aliased
(Ent
)
27722 or else Present
(Address_Clause
(Ent
))
27723 or else Address_Taken
(Ent
)
27724 or else (Is_Library_Level_Entity
(Ent
)
27725 and then Ekind
(Ent
) = E_Variable
)
27730 -- OK, all above conditions are met. We also require that the scope of
27731 -- the reference be the same as the scope of the entity, not counting
27732 -- packages and blocks and loops.
27735 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
27736 R_Scope
: Entity_Id
;
27739 R_Scope
:= Current_Scope
;
27740 while R_Scope
/= Standard_Standard
loop
27741 exit when R_Scope
= E_Scope
;
27743 if Ekind
(R_Scope
) not in E_Package | E_Block | E_Loop
then
27746 R_Scope
:= Scope
(R_Scope
);
27751 -- We also require that the reference does not appear in a context
27752 -- where it is not sure to be executed (i.e. a conditional context
27753 -- or an exception handler). We skip this if Cond is True, since the
27754 -- capturing of values from conditional tests handles this ok.
27756 if Cond
or else No
(N
) then
27767 -- Seems dubious that case expressions are not handled here ???
27770 while Present
(P
) loop
27771 if Nkind
(P
) = N_If_Statement
27772 or else Nkind
(P
) = N_Case_Statement
27773 or else (Nkind
(P
) in N_Short_Circuit
27774 and then Desc
= Right_Opnd
(P
))
27775 or else (Nkind
(P
) = N_If_Expression
27776 and then Desc
/= First
(Expressions
(P
)))
27777 or else Nkind
(P
) = N_Exception_Handler
27778 or else Nkind
(P
) = N_Selective_Accept
27779 or else Nkind
(P
) = N_Conditional_Entry_Call
27780 or else Nkind
(P
) = N_Timed_Entry_Call
27781 or else Nkind
(P
) = N_Asynchronous_Select
27789 -- A special Ada 2012 case: the original node may be part
27790 -- of the else_actions of a conditional expression, in which
27791 -- case it might not have been expanded yet, and appears in
27792 -- a non-syntactic list of actions. In that case it is clearly
27793 -- not safe to save a value.
27796 and then Is_List_Member
(Desc
)
27797 and then No
(Parent
(List_Containing
(Desc
)))
27805 -- OK, looks safe to set value
27808 end Safe_To_Capture_Value
;
27814 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
27815 K1
: constant Node_Kind
:= Nkind
(N1
);
27816 K2
: constant Node_Kind
:= Nkind
(N2
);
27819 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
27820 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
27822 return Chars
(N1
) = Chars
(N2
);
27824 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
27825 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
27827 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
27828 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
27839 function Same_Object
(Node1
, Node2
: Node_Id
) return Boolean is
27840 N1
: constant Node_Id
:= Original_Node
(Node1
);
27841 N2
: constant Node_Id
:= Original_Node
(Node2
);
27842 -- We do the tests on original nodes, since we are most interested
27843 -- in the original source, not any expansion that got in the way.
27845 K1
: constant Node_Kind
:= Nkind
(N1
);
27846 K2
: constant Node_Kind
:= Nkind
(N2
);
27849 -- First case, both are entities with same entity
27851 if K1
in N_Has_Entity
and then K2
in N_Has_Entity
then
27853 EN1
: constant Entity_Id
:= Entity
(N1
);
27854 EN2
: constant Entity_Id
:= Entity
(N2
);
27856 if Present
(EN1
) and then Present
(EN2
)
27857 and then (Ekind
(EN1
) in E_Variable | E_Constant
27858 or else Is_Formal
(EN1
))
27866 -- Second case, selected component with same selector, same record
27868 if K1
= N_Selected_Component
27869 and then K2
= N_Selected_Component
27870 and then Chars
(Selector_Name
(N1
)) = Chars
(Selector_Name
(N2
))
27872 return Same_Object
(Prefix
(N1
), Prefix
(N2
));
27874 -- Third case, indexed component with same subscripts, same array
27876 elsif K1
= N_Indexed_Component
27877 and then K2
= N_Indexed_Component
27878 and then Same_Object
(Prefix
(N1
), Prefix
(N2
))
27883 E1
:= First
(Expressions
(N1
));
27884 E2
:= First
(Expressions
(N2
));
27885 while Present
(E1
) loop
27886 if not Same_Value
(E1
, E2
) then
27897 -- Fourth case, slice of same array with same bounds
27900 and then K2
= N_Slice
27901 and then Nkind
(Discrete_Range
(N1
)) = N_Range
27902 and then Nkind
(Discrete_Range
(N2
)) = N_Range
27903 and then Same_Value
(Low_Bound
(Discrete_Range
(N1
)),
27904 Low_Bound
(Discrete_Range
(N2
)))
27905 and then Same_Value
(High_Bound
(Discrete_Range
(N1
)),
27906 High_Bound
(Discrete_Range
(N2
)))
27908 return Same_Name
(Prefix
(N1
), Prefix
(N2
));
27910 -- All other cases, not clearly the same object
27917 ---------------------------------
27918 -- Same_Or_Aliased_Subprograms --
27919 ---------------------------------
27921 function Same_Or_Aliased_Subprograms
27923 E
: Entity_Id
) return Boolean
27925 Subp_Alias
: constant Entity_Id
:= Alias
(S
);
27927 return S
= E
or else (Present
(Subp_Alias
) and then Subp_Alias
= E
);
27928 end Same_Or_Aliased_Subprograms
;
27934 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
27939 elsif not Is_Constrained
(T1
)
27940 and then not Is_Constrained
(T2
)
27941 and then Base_Type
(T1
) = Base_Type
(T2
)
27945 -- For now don't bother with case of identical constraints, to be
27946 -- fiddled with later on perhaps (this is only used for optimization
27947 -- purposes, so it is not critical to do a best possible job)
27958 function Same_Value
(Node1
, Node2
: Node_Id
) return Boolean is
27960 if Compile_Time_Known_Value
(Node1
)
27961 and then Compile_Time_Known_Value
(Node2
)
27963 -- Handle properly compile-time expressions that are not
27966 if Is_String_Type
(Etype
(Node1
)) then
27967 return Expr_Value_S
(Node1
) = Expr_Value_S
(Node2
);
27970 return Expr_Value
(Node1
) = Expr_Value
(Node2
);
27973 elsif Same_Object
(Node1
, Node2
) then
27980 --------------------
27981 -- Set_SPARK_Mode --
27982 --------------------
27984 procedure Set_SPARK_Mode
(Context
: Entity_Id
) is
27986 -- Do not consider illegal or partially decorated constructs
27988 if Ekind
(Context
) = E_Void
or else Error_Posted
(Context
) then
27991 elsif Present
(SPARK_Pragma
(Context
)) then
27993 (Mode
=> Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Context
)),
27994 Prag
=> SPARK_Pragma
(Context
));
27996 end Set_SPARK_Mode
;
27998 -------------------------
27999 -- Scalar_Part_Present --
28000 -------------------------
28002 function Scalar_Part_Present
(Typ
: Entity_Id
) return Boolean is
28003 Val_Typ
: constant Entity_Id
:= Validated_View
(Typ
);
28007 if Is_Scalar_Type
(Val_Typ
) then
28010 elsif Is_Array_Type
(Val_Typ
) then
28011 return Scalar_Part_Present
(Component_Type
(Val_Typ
));
28013 elsif Is_Record_Type
(Val_Typ
) then
28014 Field
:= First_Component_Or_Discriminant
(Val_Typ
);
28015 while Present
(Field
) loop
28016 if Scalar_Part_Present
(Etype
(Field
)) then
28020 Next_Component_Or_Discriminant
(Field
);
28025 end Scalar_Part_Present
;
28027 ------------------------
28028 -- Scope_Is_Transient --
28029 ------------------------
28031 function Scope_Is_Transient
return Boolean is
28033 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
28034 end Scope_Is_Transient
;
28040 function Scope_Within
28041 (Inner
: Entity_Id
;
28042 Outer
: Entity_Id
) return Boolean
28048 while Present
(Curr
) and then Curr
/= Standard_Standard
loop
28049 Curr
:= Scope
(Curr
);
28051 if Curr
= Outer
then
28054 -- A selective accept body appears within a task type, but the
28055 -- enclosing subprogram is the procedure of the task body.
28057 elsif Ekind
(Implementation_Base_Type
(Curr
)) = E_Task_Type
28059 Outer
= Task_Body_Procedure
(Implementation_Base_Type
(Curr
))
28063 -- Ditto for the body of a protected operation
28065 elsif Is_Subprogram
(Curr
)
28066 and then Outer
= Protected_Body_Subprogram
(Curr
)
28070 -- Outside of its scope, a synchronized type may just be private
28072 elsif Is_Private_Type
(Curr
)
28073 and then Present
(Full_View
(Curr
))
28074 and then Is_Concurrent_Type
(Full_View
(Curr
))
28076 return Scope_Within
(Full_View
(Curr
), Outer
);
28083 --------------------------
28084 -- Scope_Within_Or_Same --
28085 --------------------------
28087 function Scope_Within_Or_Same
28088 (Inner
: Entity_Id
;
28089 Outer
: Entity_Id
) return Boolean
28091 Curr
: Entity_Id
:= Inner
;
28094 -- Similar to the above, but check for scope identity first
28096 while Present
(Curr
) and then Curr
/= Standard_Standard
loop
28097 if Curr
= Outer
then
28100 elsif Ekind
(Implementation_Base_Type
(Curr
)) = E_Task_Type
28102 Outer
= Task_Body_Procedure
(Implementation_Base_Type
(Curr
))
28106 elsif Is_Subprogram
(Curr
)
28107 and then Outer
= Protected_Body_Subprogram
(Curr
)
28111 elsif Is_Private_Type
(Curr
)
28112 and then Present
(Full_View
(Curr
))
28114 if Full_View
(Curr
) = Outer
then
28117 return Scope_Within
(Full_View
(Curr
), Outer
);
28121 Curr
:= Scope
(Curr
);
28125 end Scope_Within_Or_Same
;
28127 ------------------------
28128 -- Set_Current_Entity --
28129 ------------------------
28131 -- The given entity is to be set as the currently visible definition of its
28132 -- associated name (i.e. the Node_Id associated with its name). All we have
28133 -- to do is to get the name from the identifier, and then set the
28134 -- associated Node_Id to point to the given entity.
28136 procedure Set_Current_Entity
(E
: Entity_Id
) is
28138 Set_Name_Entity_Id
(Chars
(E
), E
);
28139 end Set_Current_Entity
;
28141 ---------------------------
28142 -- Set_Debug_Info_Needed --
28143 ---------------------------
28145 procedure Set_Debug_Info_Needed
(T
: Entity_Id
) is
28147 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
);
28148 pragma Inline
(Set_Debug_Info_Needed_If_Not_Set
);
28149 -- Used to set debug info in a related node if not set already
28151 --------------------------------------
28152 -- Set_Debug_Info_Needed_If_Not_Set --
28153 --------------------------------------
28155 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
) is
28157 if Present
(E
) and then not Needs_Debug_Info
(E
) then
28158 Set_Debug_Info_Needed
(E
);
28160 -- For a private type, indicate that the full view also needs
28161 -- debug information.
28164 and then Is_Private_Type
(E
)
28165 and then Present
(Full_View
(E
))
28167 Set_Debug_Info_Needed
(Full_View
(E
));
28170 end Set_Debug_Info_Needed_If_Not_Set
;
28172 -- Start of processing for Set_Debug_Info_Needed
28175 -- Nothing to do if there is no available entity
28180 -- Nothing to do for an entity with suppressed debug information
28182 elsif Debug_Info_Off
(T
) then
28185 -- Nothing to do for an ignored Ghost entity because the entity will be
28186 -- eliminated from the tree.
28188 elsif Is_Ignored_Ghost_Entity
(T
) then
28191 -- Nothing to do if entity comes from a predefined file. Library files
28192 -- are compiled without debug information, but inlined bodies of these
28193 -- routines may appear in user code, and debug information on them ends
28194 -- up complicating debugging the user code.
28196 elsif In_Inlined_Body
and then In_Predefined_Unit
(T
) then
28197 Set_Needs_Debug_Info
(T
, False);
28200 -- Set flag in entity itself. Note that we will go through the following
28201 -- circuitry even if the flag is already set on T. That's intentional,
28202 -- it makes sure that the flag will be set in subsidiary entities.
28204 Set_Needs_Debug_Info
(T
);
28206 -- Set flag on subsidiary entities if not set already
28208 if Is_Object
(T
) then
28209 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
28211 elsif Is_Type
(T
) then
28212 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
28214 if Is_Record_Type
(T
) then
28216 Ent
: Entity_Id
:= First_Entity
(T
);
28218 while Present
(Ent
) loop
28219 Set_Debug_Info_Needed_If_Not_Set
(Ent
);
28224 -- For a class wide subtype, we also need debug information
28225 -- for the equivalent type.
28227 if Ekind
(T
) = E_Class_Wide_Subtype
then
28228 Set_Debug_Info_Needed_If_Not_Set
(Equivalent_Type
(T
));
28231 elsif Is_Array_Type
(T
) then
28232 Set_Debug_Info_Needed_If_Not_Set
(Component_Type
(T
));
28235 Indx
: Node_Id
:= First_Index
(T
);
28237 while Present
(Indx
) loop
28238 Set_Debug_Info_Needed_If_Not_Set
(Etype
(Indx
));
28243 -- For a packed array type, we also need debug information for
28244 -- the type used to represent the packed array. Conversely, we
28245 -- also need it for the former if we need it for the latter.
28247 if Is_Packed
(T
) then
28248 Set_Debug_Info_Needed_If_Not_Set
(Packed_Array_Impl_Type
(T
));
28251 if Is_Packed_Array_Impl_Type
(T
) then
28252 Set_Debug_Info_Needed_If_Not_Set
(Original_Array_Type
(T
));
28255 elsif Is_Access_Type
(T
) then
28256 Set_Debug_Info_Needed_If_Not_Set
(Directly_Designated_Type
(T
));
28258 elsif Is_Private_Type
(T
) then
28260 FV
: constant Entity_Id
:= Full_View
(T
);
28263 Set_Debug_Info_Needed_If_Not_Set
(FV
);
28265 -- If the full view is itself a derived private type, we need
28266 -- debug information on its underlying type.
28269 and then Is_Private_Type
(FV
)
28270 and then Present
(Underlying_Full_View
(FV
))
28272 Set_Needs_Debug_Info
(Underlying_Full_View
(FV
));
28276 elsif Is_Protected_Type
(T
) then
28277 Set_Debug_Info_Needed_If_Not_Set
(Corresponding_Record_Type
(T
));
28279 elsif Is_Scalar_Type
(T
) then
28281 -- If the subrange bounds are materialized by dedicated constant
28282 -- objects, also include them in the debug info to make sure the
28283 -- debugger can properly use them.
28285 if Present
(Scalar_Range
(T
))
28286 and then Nkind
(Scalar_Range
(T
)) = N_Range
28289 Low_Bnd
: constant Node_Id
:= Type_Low_Bound
(T
);
28290 High_Bnd
: constant Node_Id
:= Type_High_Bound
(T
);
28293 if Is_Entity_Name
(Low_Bnd
) then
28294 Set_Debug_Info_Needed_If_Not_Set
(Entity
(Low_Bnd
));
28297 if Is_Entity_Name
(High_Bnd
) then
28298 Set_Debug_Info_Needed_If_Not_Set
(Entity
(High_Bnd
));
28304 end Set_Debug_Info_Needed
;
28306 --------------------------------
28307 -- Set_Debug_Info_Defining_Id --
28308 --------------------------------
28310 procedure Set_Debug_Info_Defining_Id
(N
: Node_Id
) is
28312 if Comes_From_Source
(Defining_Identifier
(N
)) then
28313 Set_Debug_Info_Needed
(Defining_Identifier
(N
));
28315 end Set_Debug_Info_Defining_Id
;
28317 ----------------------------
28318 -- Set_Entity_With_Checks --
28319 ----------------------------
28321 procedure Set_Entity_With_Checks
(N
: Node_Id
; Val
: Entity_Id
) is
28322 Val_Actual
: Entity_Id
;
28324 Post_Node
: Node_Id
;
28327 -- Unconditionally set the entity
28329 Set_Entity
(N
, Val
);
28331 -- The node to post on is the selector in the case of an expanded name,
28332 -- and otherwise the node itself.
28334 if Nkind
(N
) = N_Expanded_Name
then
28335 Post_Node
:= Selector_Name
(N
);
28340 -- Check for violation of No_Fixed_IO
28342 if Restriction_Check_Required
(No_Fixed_IO
)
28344 ((RTU_Loaded
(Ada_Text_IO
)
28345 and then (Is_RTE
(Val
, RE_Decimal_IO
)
28347 Is_RTE
(Val
, RE_Fixed_IO
)))
28350 (RTU_Loaded
(Ada_Wide_Text_IO
)
28351 and then (Is_RTE
(Val
, RO_WT_Decimal_IO
)
28353 Is_RTE
(Val
, RO_WT_Fixed_IO
)))
28356 (RTU_Loaded
(Ada_Wide_Wide_Text_IO
)
28357 and then (Is_RTE
(Val
, RO_WW_Decimal_IO
)
28359 Is_RTE
(Val
, RO_WW_Fixed_IO
))))
28361 -- A special extra check, don't complain about a reference from within
28362 -- the Ada.Interrupts package itself!
28364 and then not In_Same_Extended_Unit
(N
, Val
)
28366 Check_Restriction
(No_Fixed_IO
, Post_Node
);
28369 -- Remaining checks are only done on source nodes. Note that we test
28370 -- for violation of No_Fixed_IO even on non-source nodes, because the
28371 -- cases for checking violations of this restriction are instantiations
28372 -- where the reference in the instance has Comes_From_Source False.
28374 if not Comes_From_Source
(N
) then
28378 -- Check for violation of No_Abort_Statements, which is triggered by
28379 -- call to Ada.Task_Identification.Abort_Task.
28381 if Restriction_Check_Required
(No_Abort_Statements
)
28382 and then (Is_RTE
(Val
, RE_Abort_Task
))
28384 -- A special extra check, don't complain about a reference from within
28385 -- the Ada.Task_Identification package itself!
28387 and then not In_Same_Extended_Unit
(N
, Val
)
28389 Check_Restriction
(No_Abort_Statements
, Post_Node
);
28392 if Val
= Standard_Long_Long_Integer
then
28393 Check_Restriction
(No_Long_Long_Integers
, Post_Node
);
28396 -- Check for violation of No_Dynamic_Attachment
28398 if Restriction_Check_Required
(No_Dynamic_Attachment
)
28399 and then RTU_Loaded
(Ada_Interrupts
)
28400 and then (Is_RTE
(Val
, RE_Is_Reserved
) or else
28401 Is_RTE
(Val
, RE_Is_Attached
) or else
28402 Is_RTE
(Val
, RE_Current_Handler
) or else
28403 Is_RTE
(Val
, RE_Attach_Handler
) or else
28404 Is_RTE
(Val
, RE_Exchange_Handler
) or else
28405 Is_RTE
(Val
, RE_Detach_Handler
) or else
28406 Is_RTE
(Val
, RE_Reference
))
28408 -- A special extra check, don't complain about a reference from within
28409 -- the Ada.Interrupts package itself!
28411 and then not In_Same_Extended_Unit
(N
, Val
)
28413 Check_Restriction
(No_Dynamic_Attachment
, Post_Node
);
28416 -- Check for No_Implementation_Identifiers
28418 if Restriction_Check_Required
(No_Implementation_Identifiers
) then
28420 -- We have an implementation defined entity if it is marked as
28421 -- implementation defined, or is defined in a package marked as
28422 -- implementation defined. However, library packages themselves
28423 -- are excluded (we don't want to flag Interfaces itself, just
28424 -- the entities within it).
28426 if (Is_Implementation_Defined
(Val
)
28428 (Present
(Scope
(Val
))
28429 and then Is_Implementation_Defined
(Scope
(Val
))))
28430 and then not (Is_Package_Or_Generic_Package
(Val
)
28431 and then Is_Library_Level_Entity
(Val
))
28433 Check_Restriction
(No_Implementation_Identifiers
, Post_Node
);
28437 -- Do the style check
28440 and then not Suppress_Style_Checks
(Val
)
28441 and then not In_Instance
28443 if Nkind
(N
) = N_Identifier
then
28445 elsif Nkind
(N
) = N_Expanded_Name
then
28446 Nod
:= Selector_Name
(N
);
28451 -- A special situation arises for derived operations, where we want
28452 -- to do the check against the parent (since the Sloc of the derived
28453 -- operation points to the derived type declaration itself).
28456 while not Comes_From_Source
(Val_Actual
)
28457 and then Nkind
(Val_Actual
) in N_Entity
28458 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
28459 or else Is_Subprogram_Or_Generic_Subprogram
(Val_Actual
))
28460 and then Present
(Alias
(Val_Actual
))
28462 Val_Actual
:= Alias
(Val_Actual
);
28465 -- Renaming declarations for generic actuals do not come from source,
28466 -- and have a different name from that of the entity they rename, so
28467 -- there is no style check to perform here.
28469 if Chars
(Nod
) = Chars
(Val_Actual
) then
28470 Style
.Check_Identifier
(Nod
, Val_Actual
);
28473 end Set_Entity_With_Checks
;
28475 ------------------------------
28476 -- Set_Invalid_Scalar_Value --
28477 ------------------------------
28479 procedure Set_Invalid_Scalar_Value
28480 (Scal_Typ
: Float_Scalar_Id
;
28483 Slot
: Ureal
renames Invalid_Floats
(Scal_Typ
);
28486 -- Detect an attempt to set a different value for the same scalar type
28488 pragma Assert
(Slot
= No_Ureal
);
28490 end Set_Invalid_Scalar_Value
;
28492 ------------------------------
28493 -- Set_Invalid_Scalar_Value --
28494 ------------------------------
28496 procedure Set_Invalid_Scalar_Value
28497 (Scal_Typ
: Integer_Scalar_Id
;
28500 Slot
: Uint
renames Invalid_Integers
(Scal_Typ
);
28503 -- Detect an attempt to set a different value for the same scalar type
28505 pragma Assert
(No
(Slot
));
28507 end Set_Invalid_Scalar_Value
;
28509 ------------------------
28510 -- Set_Name_Entity_Id --
28511 ------------------------
28513 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
28515 Set_Name_Table_Int
(Id
, Int
(Val
));
28516 end Set_Name_Entity_Id
;
28518 ---------------------
28519 -- Set_Next_Actual --
28520 ---------------------
28522 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
28524 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
28525 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
28527 end Set_Next_Actual
;
28529 ----------------------------------
28530 -- Set_Optimize_Alignment_Flags --
28531 ----------------------------------
28533 procedure Set_Optimize_Alignment_Flags
(E
: Entity_Id
) is
28535 if Optimize_Alignment
= 'S' then
28536 Set_Optimize_Alignment_Space
(E
);
28537 elsif Optimize_Alignment
= 'T' then
28538 Set_Optimize_Alignment_Time
(E
);
28540 end Set_Optimize_Alignment_Flags
;
28542 -----------------------
28543 -- Set_Public_Status --
28544 -----------------------
28546 procedure Set_Public_Status
(Id
: Entity_Id
) is
28547 S
: constant Entity_Id
:= Current_Scope
;
28549 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean;
28550 -- Determines if E is defined within handled statement sequence or
28551 -- an if statement, returns True if so, False otherwise.
28553 ----------------------
28554 -- Within_HSS_Or_If --
28555 ----------------------
28557 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean is
28560 N
:= Declaration_Node
(E
);
28568 N_Handled_Sequence_Of_Statements | N_If_Statement
28573 end Within_HSS_Or_If
;
28575 -- Start of processing for Set_Public_Status
28578 -- Everything in the scope of Standard is public
28580 if S
= Standard_Standard
then
28581 Set_Is_Public
(Id
);
28583 -- Entity is definitely not public if enclosing scope is not public
28585 elsif not Is_Public
(S
) then
28588 -- An object or function declaration that occurs in a handled sequence
28589 -- of statements or within an if statement is the declaration for a
28590 -- temporary object or local subprogram generated by the expander. It
28591 -- never needs to be made public and furthermore, making it public can
28592 -- cause back end problems.
28594 elsif Nkind
(Parent
(Id
)) in
28595 N_Object_Declaration | N_Function_Specification
28596 and then Within_HSS_Or_If
(Id
)
28600 -- Entities in public packages or records are public
28602 elsif Ekind
(S
) = E_Package
or Is_Record_Type
(S
) then
28603 Set_Is_Public
(Id
);
28605 -- The bounds of an entry family declaration can generate object
28606 -- declarations that are visible to the back-end, e.g. in the
28607 -- the declaration of a composite type that contains tasks.
28609 elsif Is_Concurrent_Type
(S
)
28610 and then not Has_Completion
(S
)
28611 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
28613 Set_Is_Public
(Id
);
28615 end Set_Public_Status
;
28617 -----------------------------
28618 -- Set_Referenced_Modified --
28619 -----------------------------
28621 procedure Set_Referenced_Modified
(N
: Node_Id
; Out_Param
: Boolean) is
28625 -- Deal with indexed or selected component where prefix is modified
28627 if Nkind
(N
) in N_Indexed_Component | N_Selected_Component
then
28628 Pref
:= Prefix
(N
);
28630 -- If prefix is access type, then it is the designated object that is
28631 -- being modified, which means we have no entity to set the flag on.
28633 if No
(Etype
(Pref
)) or else Is_Access_Type
(Etype
(Pref
)) then
28636 -- Otherwise chase the prefix
28639 Set_Referenced_Modified
(Pref
, Out_Param
);
28642 -- Otherwise see if we have an entity name (only other case to process)
28644 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
28645 Set_Referenced_As_LHS
(Entity
(N
), not Out_Param
);
28646 Set_Referenced_As_Out_Parameter
(Entity
(N
), Out_Param
);
28648 end Set_Referenced_Modified
;
28654 procedure Set_Rep_Info
(T1
: Entity_Id
; T2
: Entity_Id
) is
28656 Set_Is_Atomic
(T1
, Is_Atomic
(T2
));
28657 Set_Is_Independent
(T1
, Is_Independent
(T2
));
28658 Set_Is_Volatile_Full_Access
(T1
, Is_Volatile_Full_Access
(T2
));
28660 if Is_Base_Type
(T1
) then
28661 Set_Is_Volatile
(T1
, Is_Volatile
(T2
));
28665 ----------------------------
28666 -- Set_Scope_Is_Transient --
28667 ----------------------------
28669 procedure Set_Scope_Is_Transient
(V
: Boolean := True) is
28671 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= V
;
28672 end Set_Scope_Is_Transient
;
28674 -------------------
28675 -- Set_Size_Info --
28676 -------------------
28678 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
28680 -- We copy Esize, but not RM_Size, since in general RM_Size is
28681 -- subtype specific and does not get inherited by all subtypes.
28683 Copy_Esize
(To
=> T1
, From
=> T2
);
28684 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
28686 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
28688 Is_Discrete_Or_Fixed_Point_Type
(T2
)
28690 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
28693 Copy_Alignment
(To
=> T1
, From
=> T2
);
28696 ------------------------------
28697 -- Should_Ignore_Pragma_Par --
28698 ------------------------------
28700 function Should_Ignore_Pragma_Par
(Prag_Name
: Name_Id
) return Boolean is
28701 pragma Assert
(Compiler_State
= Parsing
);
28702 -- This one can't work during semantic analysis, because we don't have a
28703 -- correct Current_Source_File.
28705 Result
: constant Boolean :=
28706 Get_Name_Table_Boolean3
(Prag_Name
)
28707 and then not Is_Internal_File_Name
28708 (File_Name
(Current_Source_File
));
28711 end Should_Ignore_Pragma_Par
;
28713 ------------------------------
28714 -- Should_Ignore_Pragma_Sem --
28715 ------------------------------
28717 function Should_Ignore_Pragma_Sem
(N
: Node_Id
) return Boolean is
28718 pragma Assert
(Compiler_State
= Analyzing
);
28719 Prag_Name
: constant Name_Id
:= Pragma_Name
(N
);
28720 Result
: constant Boolean :=
28721 Get_Name_Table_Boolean3
(Prag_Name
)
28722 and then not In_Internal_Unit
(N
);
28726 end Should_Ignore_Pragma_Sem
;
28728 --------------------
28729 -- Static_Boolean --
28730 --------------------
28732 function Static_Boolean
(N
: Node_Id
) return Opt_Ubool
is
28734 Analyze_And_Resolve
(N
, Standard_Boolean
);
28737 or else Error_Posted
(N
)
28738 or else Etype
(N
) = Any_Type
28743 if Is_OK_Static_Expression
(N
) then
28744 if not Raises_Constraint_Error
(N
) then
28745 return Expr_Value
(N
);
28750 elsif Etype
(N
) = Any_Type
then
28754 Flag_Non_Static_Expr
28755 ("static boolean expression required here", N
);
28758 end Static_Boolean
;
28760 --------------------
28761 -- Static_Integer --
28762 --------------------
28764 function Static_Integer
(N
: Node_Id
) return Uint
is
28766 Analyze_And_Resolve
(N
, Any_Integer
);
28769 or else Error_Posted
(N
)
28770 or else Etype
(N
) = Any_Type
28775 if Is_OK_Static_Expression
(N
) then
28776 if not Raises_Constraint_Error
(N
) then
28777 return Expr_Value
(N
);
28782 elsif Etype
(N
) = Any_Type
then
28786 Flag_Non_Static_Expr
28787 ("static integer expression required here", N
);
28790 end Static_Integer
;
28792 -------------------------------
28793 -- Statically_Denotes_Entity --
28794 -------------------------------
28796 function Statically_Denotes_Entity
(N
: Node_Id
) return Boolean is
28799 if not Is_Entity_Name
(N
) then
28806 Nkind
(Parent
(E
)) /= N_Object_Renaming_Declaration
28807 or else Is_Prival
(E
)
28808 or else Statically_Denotes_Entity
(Renamed_Object
(E
));
28809 end Statically_Denotes_Entity
;
28811 -------------------------------
28812 -- Statically_Denotes_Object --
28813 -------------------------------
28815 function Statically_Denotes_Object
(N
: Node_Id
) return Boolean is
28817 return Statically_Denotes_Entity
(N
)
28818 and then Is_Object_Reference
(N
);
28819 end Statically_Denotes_Object
;
28821 --------------------------
28822 -- Statically_Different --
28823 --------------------------
28825 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
28826 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
28827 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
28829 return Is_Entity_Name
(R1
)
28830 and then Is_Entity_Name
(R2
)
28831 and then Entity
(R1
) /= Entity
(R2
)
28832 and then not Is_Formal
(Entity
(R1
))
28833 and then not Is_Formal
(Entity
(R2
));
28834 end Statically_Different
;
28836 -----------------------------
28837 -- Statically_Names_Object --
28838 -----------------------------
28840 function Statically_Names_Object
(N
: Node_Id
) return Boolean is
28842 if Statically_Denotes_Object
(N
) then
28844 elsif Is_Entity_Name
(N
) then
28846 E
: constant Entity_Id
:= Entity
(N
);
28848 return Nkind
(Parent
(E
)) = N_Object_Renaming_Declaration
28849 and then Statically_Names_Object
(Renamed_Object
(E
));
28854 when N_Indexed_Component
=>
28855 if Is_Access_Type
(Etype
(Prefix
(N
))) then
28856 -- treat implicit dereference same as explicit
28860 if not Is_Constrained
(Etype
(Prefix
(N
))) then
28865 Indx
: Node_Id
:= First_Index
(Etype
(Prefix
(N
)));
28866 Expr
: Node_Id
:= First
(Expressions
(N
));
28867 Index_Subtype
: Node_Id
;
28870 Index_Subtype
:= Etype
(Indx
);
28872 if not Is_Static_Subtype
(Index_Subtype
) then
28875 if not Is_OK_Static_Expression
(Expr
) then
28880 Index_Value
: constant Uint
:= Expr_Value
(Expr
);
28881 Low_Value
: constant Uint
:=
28882 Expr_Value
(Type_Low_Bound
(Index_Subtype
));
28883 High_Value
: constant Uint
:=
28884 Expr_Value
(Type_High_Bound
(Index_Subtype
));
28886 if (Index_Value
< Low_Value
)
28887 or (Index_Value
> High_Value
)
28894 Expr
:= Next
(Expr
);
28895 pragma Assert
((Present
(Indx
) = Present
(Expr
))
28896 or else (Serious_Errors_Detected
> 0));
28897 exit when not (Present
(Indx
) and Present
(Expr
));
28901 when N_Selected_Component
=>
28902 if Is_Access_Type
(Etype
(Prefix
(N
))) then
28903 -- treat implicit dereference same as explicit
28907 if Ekind
(Entity
(Selector_Name
(N
))) not in
28908 E_Component | E_Discriminant
28914 Comp
: constant Entity_Id
:=
28915 Original_Record_Component
(Entity
(Selector_Name
(N
)));
28917 -- AI12-0373 confirms that we should not call
28918 -- Has_Discriminant_Dependent_Constraint here which would be
28921 if Is_Declared_Within_Variant
(Comp
) then
28926 when others => -- includes N_Slice, N_Explicit_Dereference
28930 pragma Assert
(Present
(Prefix
(N
)));
28932 return Statically_Names_Object
(Prefix
(N
));
28933 end Statically_Names_Object
;
28935 ---------------------------------
28936 -- String_From_Numeric_Literal --
28937 ---------------------------------
28939 function String_From_Numeric_Literal
(N
: Node_Id
) return String_Id
is
28940 Loc
: constant Source_Ptr
:= Sloc
(N
);
28941 Sbuffer
: constant Source_Buffer_Ptr
:=
28942 Source_Text
(Get_Source_File_Index
(Loc
));
28943 Src_Ptr
: Source_Ptr
:= Loc
;
28945 C
: Character := Sbuffer
(Src_Ptr
);
28946 -- Current source program character
28948 function Belongs_To_Numeric_Literal
(C
: Character) return Boolean;
28949 -- Return True if C belongs to the numeric literal
28951 --------------------------------
28952 -- Belongs_To_Numeric_Literal --
28953 --------------------------------
28955 function Belongs_To_Numeric_Literal
(C
: Character) return Boolean is
28958 when '0' .. '9' |
'_' |
'.' |
'e' |
'#' |
'A' .. 'F' =>
28961 -- Make sure '+' or '-' is part of an exponent
28965 Prev_C
: constant Character := Sbuffer
(Src_Ptr
- 1);
28967 return Prev_C
in 'e' |
'E';
28970 -- Other characters cannot belong to a numeric literal
28975 end Belongs_To_Numeric_Literal
;
28977 -- Start of processing for String_From_Numeric_Literal
28981 while Belongs_To_Numeric_Literal
(C
) loop
28982 Store_String_Char
(C
);
28983 Src_Ptr
:= Src_Ptr
+ 1;
28984 C
:= Sbuffer
(Src_Ptr
);
28988 end String_From_Numeric_Literal
;
28990 --------------------------------------
28991 -- Subject_To_Loop_Entry_Attributes --
28992 --------------------------------------
28994 function Subject_To_Loop_Entry_Attributes
(N
: Node_Id
) return Boolean is
29000 -- The expansion mechanism transform a loop subject to at least one
29001 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
29002 -- the conditional part.
29004 if Nkind
(Stmt
) in N_Block_Statement | N_If_Statement
29005 and then Nkind
(Original_Node
(N
)) = N_Loop_Statement
29007 Stmt
:= Original_Node
(N
);
29011 Nkind
(Stmt
) = N_Loop_Statement
29012 and then Present
(Identifier
(Stmt
))
29013 and then Present
(Entity
(Identifier
(Stmt
)))
29014 and then Has_Loop_Entry_Attributes
(Entity
(Identifier
(Stmt
)));
29015 end Subject_To_Loop_Entry_Attributes
;
29017 -----------------------------
29018 -- Subprogram_Access_Level --
29019 -----------------------------
29021 function Subprogram_Access_Level
(Subp
: Entity_Id
) return Uint
is
29023 if Present
(Alias
(Subp
)) then
29024 return Subprogram_Access_Level
(Alias
(Subp
));
29026 return Scope_Depth
(Enclosing_Dynamic_Scope
(Subp
));
29028 end Subprogram_Access_Level
;
29030 ---------------------
29031 -- Subprogram_Name --
29032 ---------------------
29034 function Subprogram_Name
(N
: Node_Id
) return String is
29035 Buf
: Bounded_String
;
29036 Ent
: Node_Id
:= N
;
29040 while Present
(Ent
) loop
29041 case Nkind
(Ent
) is
29042 when N_Subprogram_Body
=>
29043 Ent
:= Defining_Unit_Name
(Specification
(Ent
));
29046 when N_Subprogram_Declaration
=>
29047 Nod
:= Corresponding_Body
(Ent
);
29049 if Present
(Nod
) then
29052 Ent
:= Defining_Unit_Name
(Specification
(Ent
));
29057 when N_Subprogram_Instantiation
29059 | N_Package_Specification
29061 Ent
:= Defining_Unit_Name
(Ent
);
29064 when N_Protected_Type_Declaration
=>
29065 Ent
:= Corresponding_Body
(Ent
);
29068 when N_Protected_Body
29071 Ent
:= Defining_Identifier
(Ent
);
29078 Ent
:= Parent
(Ent
);
29082 return "unknown subprogram:unknown file:0:0";
29085 -- If the subprogram is a child unit, use its simple name to start the
29086 -- construction of the fully qualified name.
29088 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
29089 Ent
:= Defining_Identifier
(Ent
);
29092 Append_Entity_Name
(Buf
, Ent
);
29094 -- Append homonym number if needed
29096 if Nkind
(N
) in N_Entity
and then Has_Homonym
(N
) then
29098 H
: Entity_Id
:= Homonym
(N
);
29102 while Present
(H
) loop
29103 if Scope
(H
) = Scope
(N
) then
29117 -- Append source location of Ent to Buf so that the string will
29118 -- look like "subp:file:line:col".
29121 Loc
: constant Source_Ptr
:= Sloc
(Ent
);
29124 Append
(Buf
, Reference_Name
(Get_Source_File_Index
(Loc
)));
29126 Append
(Buf
, Nat
(Get_Logical_Line_Number
(Loc
)));
29128 Append
(Buf
, Nat
(Get_Column_Number
(Loc
)));
29132 end Subprogram_Name
;
29134 -------------------------------
29135 -- Support_Atomic_Primitives --
29136 -------------------------------
29138 function Support_Atomic_Primitives
(Typ
: Entity_Id
) return Boolean is
29142 -- Verify the alignment of Typ is known
29144 if not Known_Alignment
(Typ
) then
29148 if Known_Static_Esize
(Typ
) then
29149 Size
:= UI_To_Int
(Esize
(Typ
));
29151 -- If the Esize (Object_Size) is unknown at compile time, look at the
29152 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
29154 elsif Known_Static_RM_Size
(Typ
) then
29155 Size
:= UI_To_Int
(RM_Size
(Typ
));
29157 -- Otherwise, the size is considered to be unknown.
29163 -- Check that the size of the component is 8, 16, 32, or 64 bits and
29164 -- that Typ is properly aligned.
29167 when 8 |
16 |
32 |
64 =>
29168 return Size
= UI_To_Int
(Alignment
(Typ
)) * 8;
29173 end Support_Atomic_Primitives
;
29179 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
29181 if Debug_Flag_W
then
29182 for J
in 0 .. Scope_Stack
.Last
loop
29187 Write_Name
(Chars
(E
));
29188 Write_Str
(" from ");
29189 Write_Location
(Sloc
(N
));
29194 -----------------------
29195 -- Transfer_Entities --
29196 -----------------------
29198 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
29199 procedure Set_Public_Status_Of
(Id
: Entity_Id
);
29200 -- Set the Is_Public attribute of arbitrary entity Id by calling routine
29201 -- Set_Public_Status. If successful and Id denotes a record type, set
29202 -- the Is_Public attribute of its fields.
29204 --------------------------
29205 -- Set_Public_Status_Of --
29206 --------------------------
29208 procedure Set_Public_Status_Of
(Id
: Entity_Id
) is
29212 if not Is_Public
(Id
) then
29213 Set_Public_Status
(Id
);
29215 -- When the input entity is a public record type, ensure that all
29216 -- its internal fields are also exposed to the linker. The fields
29217 -- of a class-wide type are never made public.
29220 and then Is_Record_Type
(Id
)
29221 and then not Is_Class_Wide_Type
(Id
)
29223 Field
:= First_Entity
(Id
);
29224 while Present
(Field
) loop
29225 Set_Is_Public
(Field
);
29226 Next_Entity
(Field
);
29230 end Set_Public_Status_Of
;
29234 Full_Id
: Entity_Id
;
29237 -- Start of processing for Transfer_Entities
29240 Id
:= First_Entity
(From
);
29242 if Present
(Id
) then
29244 -- Merge the entity chain of the source scope with that of the
29245 -- destination scope.
29247 if Present
(Last_Entity
(To
)) then
29248 Link_Entities
(Last_Entity
(To
), Id
);
29250 Set_First_Entity
(To
, Id
);
29253 Set_Last_Entity
(To
, Last_Entity
(From
));
29255 -- Inspect the entities of the source scope and update their Scope
29258 while Present
(Id
) loop
29259 Set_Scope
(Id
, To
);
29260 Set_Public_Status_Of
(Id
);
29262 -- Handle an internally generated full view for a private type
29264 if Is_Private_Type
(Id
)
29265 and then Present
(Full_View
(Id
))
29266 and then Is_Itype
(Full_View
(Id
))
29268 Full_Id
:= Full_View
(Id
);
29270 Set_Scope
(Full_Id
, To
);
29271 Set_Public_Status_Of
(Full_Id
);
29277 Set_First_Entity
(From
, Empty
);
29278 Set_Last_Entity
(From
, Empty
);
29280 end Transfer_Entities
;
29282 ------------------------
29283 -- Traverse_More_Func --
29284 ------------------------
29286 function Traverse_More_Func
(Node
: Node_Id
) return Traverse_Final_Result
is
29288 Processing_Itype
: Boolean := False;
29289 -- Set to True while traversing the nodes under an Itype, to prevent
29290 -- looping on Itype handling during that traversal.
29292 function Process_More
(N
: Node_Id
) return Traverse_Result
;
29293 -- Wrapper over the Process callback to handle parts of the AST that
29294 -- are not normally traversed as syntactic children.
29296 function Traverse_Rec
(N
: Node_Id
) return Traverse_Final_Result
;
29297 -- Main recursive traversal implemented as an instantiation of
29298 -- Traverse_Func over a modified Process callback.
29304 function Process_More
(N
: Node_Id
) return Traverse_Result
is
29306 procedure Traverse_More
(N
: Node_Id
;
29307 Res
: in out Traverse_Result
);
29308 procedure Traverse_More
(L
: List_Id
;
29309 Res
: in out Traverse_Result
);
29310 -- Traverse a node or list and update the traversal result to value
29311 -- Abandon when needed.
29313 -------------------
29314 -- Traverse_More --
29315 -------------------
29317 procedure Traverse_More
(N
: Node_Id
;
29318 Res
: in out Traverse_Result
)
29321 -- Do not process any more nodes if Abandon was reached
29323 if Res
= Abandon
then
29327 if Traverse_Rec
(N
) = Abandon
then
29332 procedure Traverse_More
(L
: List_Id
;
29333 Res
: in out Traverse_Result
)
29335 N
: Node_Id
:= First
(L
);
29338 -- Do not process any more nodes if Abandon was reached
29340 if Res
= Abandon
then
29344 while Present
(N
) loop
29345 Traverse_More
(N
, Res
);
29353 Result
: Traverse_Result
;
29355 -- Start of processing for Process_More
29358 -- Initial callback to Process. Return immediately on Skip/Abandon.
29359 -- Otherwise update the value of Node for further processing of
29360 -- non-syntactic children.
29362 Result
:= Process
(N
);
29365 when OK
=> Node
:= N
;
29366 when OK_Orig
=> Node
:= Original_Node
(N
);
29367 when Skip
=> return Skip
;
29368 when Abandon
=> return Abandon
;
29371 -- Process the relevant semantic children which are a logical part of
29372 -- the AST under this node before returning for the processing of
29373 -- syntactic children.
29375 -- Start with all non-syntactic lists of action nodes
29377 case Nkind
(Node
) is
29378 when N_Component_Association
=>
29379 Traverse_More
(Loop_Actions
(Node
), Result
);
29381 when N_Elsif_Part
=>
29382 Traverse_More
(Condition_Actions
(Node
), Result
);
29384 when N_Short_Circuit
=>
29385 Traverse_More
(Actions
(Node
), Result
);
29387 when N_Case_Expression_Alternative
=>
29388 Traverse_More
(Actions
(Node
), Result
);
29390 when N_Iterated_Component_Association
=>
29391 Traverse_More
(Loop_Actions
(Node
), Result
);
29393 when N_Iteration_Scheme
=>
29394 Traverse_More
(Condition_Actions
(Node
), Result
);
29396 when N_If_Expression
=>
29397 Traverse_More
(Then_Actions
(Node
), Result
);
29398 Traverse_More
(Else_Actions
(Node
), Result
);
29400 -- Various nodes have a field Actions as a syntactic node,
29401 -- so it will be traversed in the regular syntactic traversal.
29403 when N_Compilation_Unit_Aux
29404 | N_Compound_Statement
29405 | N_Expression_With_Actions
29414 -- If Process_Itypes is True, process unattached nodes which come
29415 -- from Itypes. This only concerns currently ranges of scalar
29416 -- (possibly as index) types. This traversal is protected against
29417 -- looping with Processing_Itype.
29420 and then not Processing_Itype
29421 and then Nkind
(Node
) in N_Has_Etype
29422 and then Present
(Etype
(Node
))
29423 and then Is_Itype
(Etype
(Node
))
29426 Typ
: constant Entity_Id
:= Etype
(Node
);
29428 Processing_Itype
:= True;
29430 case Ekind
(Typ
) is
29431 when Scalar_Kind
=>
29432 Traverse_More
(Scalar_Range
(Typ
), Result
);
29436 Index
: Node_Id
:= First_Index
(Typ
);
29439 while Present
(Index
) loop
29440 if Nkind
(Index
) in N_Has_Entity
then
29441 Rng
:= Scalar_Range
(Entity
(Index
));
29446 Traverse_More
(Rng
, Result
);
29447 Next_Index
(Index
);
29454 Processing_Itype
:= False;
29461 -- Define Traverse_Rec as a renaming of the instantiation, as an
29462 -- instantiation cannot complete a previous spec.
29464 function Traverse_Recursive
is new Traverse_Func
(Process_More
);
29465 function Traverse_Rec
(N
: Node_Id
) return Traverse_Final_Result
29466 renames Traverse_Recursive
;
29468 -- Start of processing for Traverse_More_Func
29471 return Traverse_Rec
(Node
);
29472 end Traverse_More_Func
;
29474 ------------------------
29475 -- Traverse_More_Proc --
29476 ------------------------
29478 procedure Traverse_More_Proc
(Node
: Node_Id
) is
29479 function Traverse
is new Traverse_More_Func
(Process
, Process_Itypes
);
29480 Discard
: Traverse_Final_Result
;
29481 pragma Warnings
(Off
, Discard
);
29483 Discard
:= Traverse
(Node
);
29484 end Traverse_More_Proc
;
29486 -----------------------
29487 -- Type_Access_Level --
29488 -----------------------
29490 function Type_Access_Level
29492 Allow_Alt_Model
: Boolean := True;
29493 Assoc_Ent
: Entity_Id
:= Empty
) return Uint
29495 Btyp
: Entity_Id
:= Base_Type
(Typ
);
29496 Def_Ent
: Entity_Id
;
29499 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
29500 -- simply use the level where the type is declared. This is true for
29501 -- stand-alone object declarations, and for anonymous access types
29502 -- associated with components the level is the same as that of the
29503 -- enclosing composite type. However, special treatment is needed for
29504 -- the cases of access parameters, return objects of an anonymous access
29505 -- type, and, in Ada 95, access discriminants of limited types.
29507 if Is_Access_Type
(Btyp
) then
29508 if Ekind
(Btyp
) = E_Anonymous_Access_Type
then
29509 -- No_Dynamic_Accessibility_Checks restriction override for
29510 -- alternative accessibility model.
29513 and then No_Dynamic_Accessibility_Checks_Enabled
(Btyp
)
29515 -- In the -gnatd_b model, the level of an anonymous access
29516 -- type is always that of the designated type.
29518 if Debug_Flag_Underscore_B
then
29519 return Type_Access_Level
29520 (Designated_Type
(Btyp
), Allow_Alt_Model
);
29523 -- When an anonymous access type's Assoc_Ent is specified,
29524 -- calculate the result based on the general accessibility
29527 -- We would like to use Associated_Node_For_Itype here instead,
29528 -- but in some cases it is not fine grained enough ???
29530 if Present
(Assoc_Ent
) then
29531 return Static_Accessibility_Level
29532 (Assoc_Ent
, Object_Decl_Level
);
29535 -- Otherwise take the context of the anonymous access type into
29538 -- Obtain the defining entity for the internally generated
29539 -- anonymous access type.
29541 Def_Ent
:= Defining_Entity_Or_Empty
29542 (Associated_Node_For_Itype
(Typ
));
29544 if Present
(Def_Ent
) then
29545 -- When the defining entity is a subprogram then we know the
29546 -- anonymous access type Typ has been generated to either
29547 -- describe an anonymous access type formal or an anonymous
29548 -- access result type.
29550 -- Since we are only interested in the formal case, avoid
29551 -- the anonymous access result type.
29553 if Is_Subprogram
(Def_Ent
)
29554 and then not (Ekind
(Def_Ent
) = E_Function
29555 and then Etype
(Def_Ent
) = Typ
)
29557 -- When the type comes from an anonymous access
29558 -- parameter, the level is that of the subprogram
29561 return Scope_Depth
(Def_Ent
);
29563 -- When the type is an access discriminant, the level is
29564 -- that of the type.
29566 elsif Ekind
(Def_Ent
) = E_Discriminant
then
29567 return Scope_Depth
(Scope
(Def_Ent
));
29571 -- If the type is a nonlocal anonymous access type (such as for
29572 -- an access parameter) we treat it as being declared at the
29573 -- library level to ensure that names such as X.all'access don't
29574 -- fail static accessibility checks.
29576 elsif not Is_Local_Anonymous_Access
(Typ
) then
29577 return Scope_Depth
(Standard_Standard
);
29579 -- If this is a return object, the accessibility level is that of
29580 -- the result subtype of the enclosing function. The test here is
29581 -- little complicated, because we have to account for extended
29582 -- return statements that have been rewritten as blocks, in which
29583 -- case we have to find and the Is_Return_Object attribute of the
29584 -- itype's associated object. It would be nice to find a way to
29585 -- simplify this test, but it doesn't seem worthwhile to add a new
29586 -- flag just for purposes of this test. ???
29588 elsif Ekind
(Scope
(Btyp
)) = E_Return_Statement
29591 and then Nkind
(Associated_Node_For_Itype
(Btyp
)) =
29592 N_Object_Declaration
29593 and then Is_Return_Object
29594 (Defining_Identifier
29595 (Associated_Node_For_Itype
(Btyp
))))
29601 Scop
:= Scope
(Scope
(Btyp
));
29602 while Present
(Scop
) loop
29603 exit when Ekind
(Scop
) = E_Function
;
29604 Scop
:= Scope
(Scop
);
29607 -- Treat the return object's type as having the level of the
29608 -- function's result subtype (as per RM05-6.5(5.3/2)).
29610 return Type_Access_Level
(Etype
(Scop
), Allow_Alt_Model
);
29615 Btyp
:= Root_Type
(Btyp
);
29617 -- The accessibility level of anonymous access types associated with
29618 -- discriminants is that of the current instance of the type, and
29619 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
29621 -- AI-402: access discriminants have accessibility based on the
29622 -- object rather than the type in Ada 2005, so the above paragraph
29625 -- ??? Needs completion with rules from AI-416
29627 if Ada_Version
<= Ada_95
29628 and then Ekind
(Typ
) = E_Anonymous_Access_Type
29629 and then Present
(Associated_Node_For_Itype
(Typ
))
29630 and then Nkind
(Associated_Node_For_Itype
(Typ
)) =
29631 N_Discriminant_Specification
29633 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
)) + 1;
29637 -- Return library level for a generic formal type. This is done because
29638 -- RM(10.3.2) says that "The statically deeper relationship does not
29639 -- apply to ... a descendant of a generic formal type". Rather than
29640 -- checking at each point where a static accessibility check is
29641 -- performed to see if we are dealing with a formal type, this rule is
29642 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
29643 -- return extreme values for a formal type; Deepest_Type_Access_Level
29644 -- returns Int'Last. By calling the appropriate function from among the
29645 -- two, we ensure that the static accessibility check will pass if we
29646 -- happen to run into a formal type. More specifically, we should call
29647 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
29648 -- call occurs as part of a static accessibility check and the error
29649 -- case is the case where the type's level is too shallow (as opposed
29652 if Is_Generic_Type
(Root_Type
(Btyp
)) then
29653 return Scope_Depth
(Standard_Standard
);
29656 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
));
29657 end Type_Access_Level
;
29659 ------------------------------------
29660 -- Type_Without_Stream_Operation --
29661 ------------------------------------
29663 function Type_Without_Stream_Operation
29665 Op
: TSS_Name_Type
:= TSS_Null
) return Entity_Id
29667 BT
: constant Entity_Id
:= Base_Type
(T
);
29668 Op_Missing
: Boolean;
29671 if not Restriction_Active
(No_Default_Stream_Attributes
) then
29675 if Is_Elementary_Type
(T
) then
29676 if Op
= TSS_Null
then
29678 No
(TSS
(BT
, TSS_Stream_Read
))
29679 or else No
(TSS
(BT
, TSS_Stream_Write
));
29682 Op_Missing
:= No
(TSS
(BT
, Op
));
29691 elsif Is_Array_Type
(T
) then
29692 return Type_Without_Stream_Operation
(Component_Type
(T
), Op
);
29694 elsif Is_Record_Type
(T
) then
29700 Comp
:= First_Component
(T
);
29701 while Present
(Comp
) loop
29702 C_Typ
:= Type_Without_Stream_Operation
(Etype
(Comp
), Op
);
29704 if Present
(C_Typ
) then
29708 Next_Component
(Comp
);
29714 elsif Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
29715 return Type_Without_Stream_Operation
(Full_View
(T
), Op
);
29719 end Type_Without_Stream_Operation
;
29721 ------------------------------
29722 -- Ultimate_Overlaid_Entity --
29723 ------------------------------
29725 function Ultimate_Overlaid_Entity
(E
: Entity_Id
) return Entity_Id
is
29727 Alias
: Entity_Id
:= E
;
29731 -- Currently this routine is only called for stand-alone objects that
29732 -- have been analysed, since the analysis of the Address aspect is often
29735 pragma Assert
(Ekind
(E
) in E_Constant | E_Variable
);
29738 Address
:= Address_Clause
(Alias
);
29739 if Present
(Address
) then
29740 Find_Overlaid_Entity
(Address
, Alias
, Offset
);
29741 if Present
(Alias
) then
29746 elsif Alias
= E
then
29752 end Ultimate_Overlaid_Entity
;
29754 ---------------------
29755 -- Ultimate_Prefix --
29756 ---------------------
29758 function Ultimate_Prefix
(N
: Node_Id
) return Node_Id
is
29763 while Nkind
(Pref
) in N_Explicit_Dereference
29764 | N_Indexed_Component
29765 | N_Selected_Component
29768 Pref
:= Prefix
(Pref
);
29772 end Ultimate_Prefix
;
29774 ----------------------------
29775 -- Unique_Defining_Entity --
29776 ----------------------------
29778 function Unique_Defining_Entity
(N
: Node_Id
) return Entity_Id
is
29780 return Unique_Entity
(Defining_Entity
(N
));
29781 end Unique_Defining_Entity
;
29783 -------------------
29784 -- Unique_Entity --
29785 -------------------
29787 function Unique_Entity
(E
: Entity_Id
) return Entity_Id
is
29788 U
: Entity_Id
:= E
;
29794 if Present
(Full_View
(E
)) then
29795 U
:= Full_View
(E
);
29799 if Nkind
(Parent
(E
)) = N_Entry_Body
then
29801 Prot_Item
: Entity_Id
;
29802 Prot_Type
: Entity_Id
;
29805 if Ekind
(E
) = E_Entry
then
29806 Prot_Type
:= Scope
(E
);
29808 -- Bodies of entry families are nested within an extra scope
29809 -- that contains an entry index declaration.
29812 Prot_Type
:= Scope
(Scope
(E
));
29815 -- A protected type may be declared as a private type, in
29816 -- which case we need to get its full view.
29818 if Is_Private_Type
(Prot_Type
) then
29819 Prot_Type
:= Full_View
(Prot_Type
);
29822 -- Full view may not be present on error, in which case
29823 -- return E by default.
29825 if Present
(Prot_Type
) then
29826 pragma Assert
(Ekind
(Prot_Type
) = E_Protected_Type
);
29828 -- Traverse the entity list of the protected type and
29829 -- locate an entry declaration which matches the entry
29832 Prot_Item
:= First_Entity
(Prot_Type
);
29833 while Present
(Prot_Item
) loop
29834 if Ekind
(Prot_Item
) in Entry_Kind
29835 and then Corresponding_Body
(Parent
(Prot_Item
)) = E
29841 Next_Entity
(Prot_Item
);
29847 when Formal_Kind
=>
29848 if Present
(Spec_Entity
(E
)) then
29849 U
:= Spec_Entity
(E
);
29852 when E_Package_Body
=>
29855 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
29859 if Nkind
(P
) = N_Package_Body
29860 and then Present
(Corresponding_Spec
(P
))
29862 U
:= Corresponding_Spec
(P
);
29864 elsif Nkind
(P
) = N_Package_Body_Stub
29865 and then Present
(Corresponding_Spec_Of_Stub
(P
))
29867 U
:= Corresponding_Spec_Of_Stub
(P
);
29870 when E_Protected_Body
=>
29873 if Nkind
(P
) = N_Protected_Body
29874 and then Present
(Corresponding_Spec
(P
))
29876 U
:= Corresponding_Spec
(P
);
29878 elsif Nkind
(P
) = N_Protected_Body_Stub
29879 and then Present
(Corresponding_Spec_Of_Stub
(P
))
29881 U
:= Corresponding_Spec_Of_Stub
(P
);
29883 if Is_Single_Protected_Object
(U
) then
29888 if Is_Private_Type
(U
) then
29889 U
:= Full_View
(U
);
29892 when E_Subprogram_Body
=>
29895 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
29901 if Nkind
(P
) = N_Subprogram_Body
29902 and then Present
(Corresponding_Spec
(P
))
29904 U
:= Corresponding_Spec
(P
);
29906 elsif Nkind
(P
) = N_Subprogram_Body_Stub
29907 and then Present
(Corresponding_Spec_Of_Stub
(P
))
29909 U
:= Corresponding_Spec_Of_Stub
(P
);
29911 elsif Nkind
(P
) = N_Subprogram_Renaming_Declaration
then
29912 U
:= Corresponding_Spec
(P
);
29915 when E_Task_Body
=>
29918 if Nkind
(P
) = N_Task_Body
29919 and then Present
(Corresponding_Spec
(P
))
29921 U
:= Corresponding_Spec
(P
);
29923 elsif Nkind
(P
) = N_Task_Body_Stub
29924 and then Present
(Corresponding_Spec_Of_Stub
(P
))
29926 U
:= Corresponding_Spec_Of_Stub
(P
);
29928 if Is_Single_Task_Object
(U
) then
29933 if Is_Private_Type
(U
) then
29934 U
:= Full_View
(U
);
29938 if Present
(Full_View
(E
)) then
29939 U
:= Full_View
(E
);
29953 function Unique_Name
(E
: Entity_Id
) return String is
29955 -- Local subprograms
29957 function Add_Homonym_Suffix
(E
: Entity_Id
) return String;
29959 function This_Name
return String;
29961 ------------------------
29962 -- Add_Homonym_Suffix --
29963 ------------------------
29965 function Add_Homonym_Suffix
(E
: Entity_Id
) return String is
29967 -- Names in E_Subprogram_Body or E_Package_Body entities are not
29968 -- reliable, as they may not include the overloading suffix.
29969 -- Instead, when looking for the name of E or one of its enclosing
29970 -- scope, we get the name of the corresponding Unique_Entity.
29972 U
: constant Entity_Id
:= Unique_Entity
(E
);
29973 Nam
: constant String := Get_Name_String
(Chars
(U
));
29976 -- If E has homonyms but is not fully qualified, as done in
29977 -- GNATprove mode, append the homonym number on the fly. Strip the
29978 -- leading space character in the image of natural numbers. Also do
29979 -- not print the homonym value of 1.
29981 if Has_Homonym
(U
) then
29983 N
: constant Pos
:= Homonym_Number
(U
);
29984 S
: constant String := N
'Img;
29987 return Nam
& "__" & S
(2 .. S
'Last);
29993 end Add_Homonym_Suffix
;
29999 function This_Name
return String is
30001 return Add_Homonym_Suffix
(E
);
30006 U
: constant Entity_Id
:= Unique_Entity
(E
);
30008 -- Start of processing for Unique_Name
30011 if E
= Standard_Standard
30012 or else Has_Fully_Qualified_Name
(E
)
30016 elsif Ekind
(E
) = E_Enumeration_Literal
then
30017 return Unique_Name
(Etype
(E
)) & "__" & This_Name
;
30021 S
: constant Entity_Id
:= Scope
(U
);
30022 pragma Assert
(Present
(S
));
30025 -- Prefix names of predefined types with standard__, but leave
30026 -- names of user-defined packages and subprograms without prefix
30027 -- (even if technically they are nested in the Standard package).
30029 if S
= Standard_Standard
then
30030 if Ekind
(U
) = E_Package
or else Is_Subprogram
(U
) then
30033 return Unique_Name
(S
) & "__" & This_Name
;
30036 -- For intances of generic subprograms use the name of the related
30037 -- instance and skip the scope of its wrapper package.
30039 elsif Is_Wrapper_Package
(S
) then
30040 pragma Assert
(Scope
(S
) = Scope
(Related_Instance
(S
)));
30041 -- Wrapper package and the instantiation are in the same scope
30044 Related_Name
: constant String :=
30045 Add_Homonym_Suffix
(Related_Instance
(S
));
30046 Enclosing_Name
: constant String :=
30047 Unique_Name
(Scope
(S
)) & "__" & Related_Name
;
30050 if Is_Subprogram
(U
)
30051 and then not Is_Generic_Actual_Subprogram
(U
)
30053 return Enclosing_Name
;
30055 return Enclosing_Name
& "__" & This_Name
;
30059 elsif Is_Child_Unit
(U
) then
30060 return Child_Prefix
& Unique_Name
(S
) & "__" & This_Name
;
30062 return Unique_Name
(S
) & "__" & This_Name
;
30068 ---------------------
30069 -- Unit_Is_Visible --
30070 ---------------------
30072 function Unit_Is_Visible
(U
: Entity_Id
) return Boolean is
30073 Curr
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
30074 Curr_Entity
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
30076 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean;
30077 -- For a child unit, check whether unit appears in a with_clause
30080 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean;
30081 -- Scan the context clause of one compilation unit looking for a
30082 -- with_clause for the unit in question.
30084 ----------------------------
30085 -- Unit_In_Parent_Context --
30086 ----------------------------
30088 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean is
30090 if Unit_In_Context
(Par_Unit
) then
30093 elsif Is_Child_Unit
(Defining_Entity
(Unit
(Par_Unit
))) then
30094 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Par_Unit
)));
30099 end Unit_In_Parent_Context
;
30101 ---------------------
30102 -- Unit_In_Context --
30103 ---------------------
30105 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean is
30109 Clause
:= First
(Context_Items
(Comp_Unit
));
30110 while Present
(Clause
) loop
30111 if Nkind
(Clause
) = N_With_Clause
then
30112 if Library_Unit
(Clause
) = U
then
30115 -- The with_clause may denote a renaming of the unit we are
30116 -- looking for, eg. Text_IO which renames Ada.Text_IO.
30119 Renamed_Entity
(Entity
(Name
(Clause
))) =
30120 Defining_Entity
(Unit
(U
))
30130 end Unit_In_Context
;
30132 -- Start of processing for Unit_Is_Visible
30135 -- The currrent unit is directly visible
30140 elsif Unit_In_Context
(Curr
) then
30143 -- If the current unit is a body, check the context of the spec
30145 elsif Nkind
(Unit
(Curr
)) = N_Package_Body
30147 (Nkind
(Unit
(Curr
)) = N_Subprogram_Body
30148 and then not Acts_As_Spec
(Unit
(Curr
)))
30150 if Unit_In_Context
(Library_Unit
(Curr
)) then
30155 -- If the spec is a child unit, examine the parents
30157 if Is_Child_Unit
(Curr_Entity
) then
30158 if Nkind
(Unit
(Curr
)) in N_Unit_Body
then
30160 Unit_In_Parent_Context
30161 (Parent_Spec
(Unit
(Library_Unit
(Curr
))));
30163 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Curr
)));
30169 end Unit_Is_Visible
;
30171 ------------------------------
30172 -- Universal_Interpretation --
30173 ------------------------------
30175 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
30176 Index
: Interp_Index
;
30180 -- The argument may be a formal parameter of an operator or subprogram
30181 -- with multiple interpretations, or else an expression for an actual.
30183 if Nkind
(Opnd
) = N_Defining_Identifier
30184 or else not Is_Overloaded
(Opnd
)
30186 if Is_Universal_Numeric_Type
(Etype
(Opnd
)) then
30187 return Etype
(Opnd
);
30193 Get_First_Interp
(Opnd
, Index
, It
);
30194 while Present
(It
.Typ
) loop
30195 if Is_Universal_Numeric_Type
(It
.Typ
) then
30199 Get_Next_Interp
(Index
, It
);
30204 end Universal_Interpretation
;
30210 function Unqualify
(Expr
: Node_Id
) return Node_Id
is
30212 -- Recurse to handle unlikely case of multiple levels of qualification
30214 if Nkind
(Expr
) = N_Qualified_Expression
then
30215 return Unqualify
(Expression
(Expr
));
30217 -- Normal case, not a qualified expression
30228 function Unqual_Conv
(Expr
: Node_Id
) return Node_Id
is
30230 -- Recurse to handle unlikely case of multiple levels of qualification
30231 -- and/or conversion.
30233 if Nkind
(Expr
) in N_Qualified_Expression
30234 | N_Type_Conversion
30235 | N_Unchecked_Type_Conversion
30237 return Unqual_Conv
(Expression
(Expr
));
30239 -- Normal case, not a qualified expression
30246 --------------------
30247 -- Validated_View --
30248 --------------------
30250 function Validated_View
(Typ
: Entity_Id
) return Entity_Id
is
30252 -- Scalar types can be always validated. In fast, switiching to the base
30253 -- type would drop the range constraints and force validation to use a
30254 -- larger type than necessary.
30256 if Is_Scalar_Type
(Typ
) then
30259 -- Array types can be validated even when they are derived, because
30260 -- validation only requires their bounds and component types to be
30261 -- accessible. In fact, switching to the parent type would pollute
30262 -- expansion of attribute Valid_Scalars with unnecessary conversion
30263 -- that might not be eliminated by the frontend.
30265 elsif Is_Array_Type
(Typ
) then
30268 -- For other types, in particular for record subtypes, we switch to the
30271 elsif not Is_Base_Type
(Typ
) then
30272 return Validated_View
(Base_Type
(Typ
));
30274 -- Obtain the full view of the input type by stripping away concurrency,
30275 -- derivations, and privacy.
30277 elsif Is_Concurrent_Type
(Typ
) then
30278 if Present
(Corresponding_Record_Type
(Typ
)) then
30279 return Corresponding_Record_Type
(Typ
);
30284 elsif Is_Derived_Type
(Typ
) then
30285 return Validated_View
(Etype
(Typ
));
30287 elsif Is_Private_Type
(Typ
) then
30288 if Present
(Underlying_Full_View
(Typ
)) then
30289 return Validated_View
(Underlying_Full_View
(Typ
));
30291 elsif Present
(Full_View
(Typ
)) then
30292 return Validated_View
(Full_View
(Typ
));
30300 end Validated_View
;
30302 -----------------------
30303 -- Visible_Ancestors --
30304 -----------------------
30306 function Visible_Ancestors
(Typ
: Entity_Id
) return Elist_Id
is
30312 pragma Assert
(Is_Record_Type
(Typ
) and then Is_Tagged_Type
(Typ
));
30314 -- Collect all the parents and progenitors of Typ. If the full-view of
30315 -- private parents and progenitors is available then it is used to
30316 -- generate the list of visible ancestors; otherwise their partial
30317 -- view is added to the resulting list.
30322 Use_Full_View
=> True);
30326 Ifaces_List
=> List_2
,
30327 Exclude_Parents
=> True,
30328 Use_Full_View
=> True);
30330 -- Join the two lists. Avoid duplications because an interface may
30331 -- simultaneously be parent and progenitor of a type.
30333 Elmt
:= First_Elmt
(List_2
);
30334 while Present
(Elmt
) loop
30335 Append_Unique_Elmt
(Node
(Elmt
), List_1
);
30340 end Visible_Ancestors
;
30342 ---------------------------
30343 -- Warn_On_Hiding_Entity --
30344 ---------------------------
30346 procedure Warn_On_Hiding_Entity
30348 Hidden
, Visible
: Entity_Id
;
30349 On_Use_Clause
: Boolean)
30352 -- Don't warn for record components since they always have a well
30353 -- defined scope which does not confuse other uses. Note that in
30354 -- some cases, Ekind has not been set yet.
30356 if Ekind
(Hidden
) /= E_Component
30357 and then Ekind
(Hidden
) /= E_Discriminant
30358 and then Nkind
(Parent
(Hidden
)) /= N_Component_Declaration
30359 and then Ekind
(Visible
) /= E_Component
30360 and then Ekind
(Visible
) /= E_Discriminant
30361 and then Nkind
(Parent
(Visible
)) /= N_Component_Declaration
30363 -- Don't warn for one character variables. It is too common to use
30364 -- such variables as locals and will just cause too many false hits.
30366 and then Length_Of_Name
(Chars
(Hidden
)) /= 1
30368 -- Don't warn for non-source entities
30370 and then Comes_From_Source
(Hidden
)
30371 and then Comes_From_Source
(Visible
)
30373 -- Don't warn within a generic instantiation
30375 and then not In_Instance
30377 -- Don't warn unless entity in question is in extended main source
30379 and then In_Extended_Main_Source_Unit
(Visible
)
30381 -- Finally, in the case of a declaration, the hidden entity must
30382 -- be either immediately visible or use visible (i.e. from a used
30383 -- package). In the case of a use clause, the visible entity must
30384 -- be immediately visible.
30387 (if On_Use_Clause
then
30388 Is_Immediately_Visible
(Visible
)
30390 (Is_Immediately_Visible
(Hidden
)
30392 Is_Potentially_Use_Visible
(Hidden
)))
30394 if On_Use_Clause
then
30395 Error_Msg_Sloc
:= Sloc
(Visible
);
30396 Error_Msg_NE
("visible declaration of&# hides homonym "
30397 & "from use clause?h?", N
, Hidden
);
30399 Error_Msg_Sloc
:= Sloc
(Hidden
);
30400 Error_Msg_NE
("declaration hides &#?h?", N
, Visible
);
30403 end Warn_On_Hiding_Entity
;
30405 ----------------------
30406 -- Within_Init_Proc --
30407 ----------------------
30409 function Within_Init_Proc
return Boolean is
30413 S
:= Current_Scope
;
30414 while not Is_Overloadable
(S
) loop
30415 if S
= Standard_Standard
then
30422 return Is_Init_Proc
(S
);
30423 end Within_Init_Proc
;
30425 ---------------------------
30426 -- Within_Protected_Type --
30427 ---------------------------
30429 function Within_Protected_Type
(E
: Entity_Id
) return Boolean is
30430 Scop
: Entity_Id
:= Scope
(E
);
30433 while Present
(Scop
) loop
30434 if Ekind
(Scop
) = E_Protected_Type
then
30438 Scop
:= Scope
(Scop
);
30442 end Within_Protected_Type
;
30448 function Within_Scope
(E
: Entity_Id
; S
: Entity_Id
) return Boolean is
30450 return Scope_Within_Or_Same
(Scope
(E
), S
);
30457 procedure Wrong_Type
(Expr
: Node_Id
; Expected_Type
: Entity_Id
) is
30458 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
30459 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
30461 Err_Msg_Exp_Typ
: Entity_Id
:= Expected_Type
;
30462 -- Type entity used when printing errors concerning the expected type
30464 Matching_Field
: Entity_Id
;
30465 -- Entity to give a more precise suggestion on how to write a one-
30466 -- element positional aggregate.
30468 function Has_One_Matching_Field
return Boolean;
30469 -- Determines if Expec_Type is a record type with a single component or
30470 -- discriminant whose type matches the found type or is one dimensional
30471 -- array whose component type matches the found type. In the case of
30472 -- one discriminant, we ignore the variant parts. That's not accurate,
30473 -- but good enough for the warning.
30475 ----------------------------
30476 -- Has_One_Matching_Field --
30477 ----------------------------
30479 function Has_One_Matching_Field
return Boolean is
30483 Matching_Field
:= Empty
;
30485 if Is_Array_Type
(Expec_Type
)
30486 and then Number_Dimensions
(Expec_Type
) = 1
30487 and then Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
30489 -- Use type name if available. This excludes multidimensional
30490 -- arrays and anonymous arrays.
30492 if Comes_From_Source
(Expec_Type
) then
30493 Matching_Field
:= Expec_Type
;
30495 -- For an assignment, use name of target
30497 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
30498 and then Is_Entity_Name
(Name
(Parent
(Expr
)))
30500 Matching_Field
:= Entity
(Name
(Parent
(Expr
)));
30505 elsif not Is_Record_Type
(Expec_Type
) then
30509 E
:= First_Entity
(Expec_Type
);
30514 elsif Ekind
(E
) not in E_Discriminant | E_Component
30515 or else Chars
(E
) in Name_uTag | Name_uParent
30524 if not Covers
(Etype
(E
), Found_Type
) then
30527 elsif Present
(Next_Entity
(E
))
30528 and then (Ekind
(E
) = E_Component
30529 or else Ekind
(Next_Entity
(E
)) = E_Discriminant
)
30534 Matching_Field
:= E
;
30538 end Has_One_Matching_Field
;
30540 -- Start of processing for Wrong_Type
30543 -- Don't output message if either type is Any_Type, or if a message
30544 -- has already been posted for this node. We need to do the latter
30545 -- check explicitly (it is ordinarily done in Errout), because we
30546 -- are using ! to force the output of the error messages.
30548 if Expec_Type
= Any_Type
30549 or else Found_Type
= Any_Type
30550 or else Error_Posted
(Expr
)
30554 -- If one of the types is a Taft-Amendment type and the other it its
30555 -- completion, it must be an illegal use of a TAT in the spec, for
30556 -- which an error was already emitted. Avoid cascaded errors.
30558 elsif Is_Incomplete_Type
(Expec_Type
)
30559 and then Has_Completion_In_Body
(Expec_Type
)
30560 and then Full_View
(Expec_Type
) = Etype
(Expr
)
30564 elsif Is_Incomplete_Type
(Etype
(Expr
))
30565 and then Has_Completion_In_Body
(Etype
(Expr
))
30566 and then Full_View
(Etype
(Expr
)) = Expec_Type
30570 -- In an instance, there is an ongoing problem with completion of
30571 -- types derived from private types. Their structure is what Gigi
30572 -- expects, but the Etype is the parent type rather than the derived
30573 -- private type itself. Do not flag error in this case. The private
30574 -- completion is an entity without a parent, like an Itype. Similarly,
30575 -- full and partial views may be incorrect in the instance.
30576 -- There is no simple way to insure that it is consistent ???
30578 -- A similar view discrepancy can happen in an inlined body, for the
30579 -- same reason: inserted body may be outside of the original package
30580 -- and only partial views are visible at the point of insertion.
30582 -- If In_Generic_Actual (Expr) is True then we cannot assume that
30583 -- the successful semantic analysis of the generic guarantees anything
30584 -- useful about type checking of this instance, so we ignore
30585 -- In_Instance in that case. There may be cases where this is not
30586 -- right (the symptom would probably be rejecting something
30587 -- that ought to be accepted) but we don't currently have any
30588 -- concrete examples of this.
30590 elsif (In_Instance
and then not In_Generic_Actual
(Expr
))
30591 or else In_Inlined_Body
30593 if Etype
(Etype
(Expr
)) = Etype
(Expected_Type
)
30595 (Has_Private_Declaration
(Expected_Type
)
30596 or else Has_Private_Declaration
(Etype
(Expr
)))
30597 and then No
(Parent
(Expected_Type
))
30601 elsif Nkind
(Parent
(Expr
)) = N_Qualified_Expression
30602 and then Entity
(Subtype_Mark
(Parent
(Expr
))) = Expected_Type
30606 elsif Is_Private_Type
(Expected_Type
)
30607 and then Present
(Full_View
(Expected_Type
))
30608 and then Covers
(Full_View
(Expected_Type
), Etype
(Expr
))
30612 -- Conversely, type of expression may be the private one
30614 elsif Is_Private_Type
(Base_Type
(Etype
(Expr
)))
30615 and then Full_View
(Base_Type
(Etype
(Expr
))) = Expected_Type
30621 -- Avoid printing internally generated subtypes in error messages and
30622 -- instead use the corresponding first subtype in such cases.
30624 if not Comes_From_Source
(Err_Msg_Exp_Typ
)
30625 or else not Comes_From_Source
(Declaration_Node
(Err_Msg_Exp_Typ
))
30627 Err_Msg_Exp_Typ
:= First_Subtype
(Err_Msg_Exp_Typ
);
30630 -- An interesting special check. If the expression is parenthesized
30631 -- and its type corresponds to the type of the sole component of the
30632 -- expected record type, or to the component type of the expected one
30633 -- dimensional array type, then assume we have a bad aggregate attempt.
30635 if Nkind
(Expr
) in N_Subexpr
30636 and then Paren_Count
(Expr
) /= 0
30637 and then Has_One_Matching_Field
30639 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
30641 if Present
(Matching_Field
) then
30642 if Is_Array_Type
(Expec_Type
) then
30644 ("\write instead `&''First ='> ...`", Expr
, Matching_Field
);
30647 ("\write instead `& ='> ...`", Expr
, Matching_Field
);
30651 -- Another special check, if we are looking for a pool-specific access
30652 -- type and we found an E_Access_Attribute_Type, then we have the case
30653 -- of an Access attribute being used in a context which needs a pool-
30654 -- specific type, which is never allowed. The one extra check we make
30655 -- is that the expected designated type covers the Found_Type.
30657 elsif Is_Access_Type
(Expec_Type
)
30658 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
30659 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
30660 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
30662 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
30665 ("result must be general access type!", Expr
);
30666 Error_Msg_NE
-- CODEFIX
30667 ("\add ALL to }!", Expr
, Err_Msg_Exp_Typ
);
30669 -- Another special check, if the expected type is an integer type,
30670 -- but the expression is of type System.Address, and the parent is
30671 -- an addition or subtraction operation whose left operand is the
30672 -- expression in question and whose right operand is of an integral
30673 -- type, then this is an attempt at address arithmetic, so give
30674 -- appropriate message.
30676 elsif Is_Integer_Type
(Expec_Type
)
30677 and then Is_RTE
(Found_Type
, RE_Address
)
30678 and then Nkind
(Parent
(Expr
)) in N_Op_Add | N_Op_Subtract
30679 and then Expr
= Left_Opnd
(Parent
(Expr
))
30680 and then Is_Integer_Type
(Etype
(Right_Opnd
(Parent
(Expr
))))
30683 ("address arithmetic not predefined in package System",
30686 ("\possible missing with/use of System.Storage_Elements",
30690 -- If the expected type is an anonymous access type, as for access
30691 -- parameters and discriminants, the error is on the designated types.
30693 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
30694 if Comes_From_Source
(Expec_Type
) then
30695 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
30698 ("expected an access type with designated}",
30699 Expr
, Designated_Type
(Expec_Type
));
30702 if Is_Access_Type
(Found_Type
)
30703 and then not Comes_From_Source
(Found_Type
)
30706 ("\\found an access type with designated}!",
30707 Expr
, Designated_Type
(Found_Type
));
30709 if From_Limited_With
(Found_Type
) then
30710 Error_Msg_NE
("\\found incomplete}!", Expr
, Found_Type
);
30711 Error_Msg_Qual_Level
:= 99;
30712 Error_Msg_NE
-- CODEFIX
30713 ("\\missing `WITH &;", Expr
, Scope
(Found_Type
));
30714 Error_Msg_Qual_Level
:= 0;
30716 Error_Msg_NE
("found}!", Expr
, Found_Type
);
30720 -- Normal case of one type found, some other type expected
30723 -- If the names of the two types are the same, see if some number
30724 -- of levels of qualification will help. Don't try more than three
30725 -- levels, and if we get to standard, it's no use (and probably
30726 -- represents an error in the compiler) Also do not bother with
30727 -- internal scope names.
30730 Expec_Scope
: Entity_Id
;
30731 Found_Scope
: Entity_Id
;
30734 Expec_Scope
:= Expec_Type
;
30735 Found_Scope
:= Found_Type
;
30737 for Levels
in Nat
range 0 .. 3 loop
30738 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
30739 Error_Msg_Qual_Level
:= Levels
;
30743 Expec_Scope
:= Scope
(Expec_Scope
);
30744 Found_Scope
:= Scope
(Found_Scope
);
30746 exit when Expec_Scope
= Standard_Standard
30747 or else Found_Scope
= Standard_Standard
30748 or else not Comes_From_Source
(Expec_Scope
)
30749 or else not Comes_From_Source
(Found_Scope
);
30753 if Is_Record_Type
(Expec_Type
)
30754 and then Present
(Corresponding_Remote_Type
(Expec_Type
))
30756 Error_Msg_NE
("expected}!", Expr
,
30757 Corresponding_Remote_Type
(Expec_Type
));
30759 Error_Msg_NE
("expected}!", Expr
, Err_Msg_Exp_Typ
);
30762 if Is_Entity_Name
(Expr
)
30763 and then Is_Package_Or_Generic_Package
(Entity
(Expr
))
30765 Error_Msg_N
("\\found package name!", Expr
);
30767 elsif Is_Entity_Name
(Expr
)
30768 and then Ekind
(Entity
(Expr
)) in E_Procedure | E_Generic_Procedure
30770 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
30772 ("found procedure name, possibly missing Access attribute!",
30776 ("\\found procedure name instead of function!", Expr
);
30779 elsif Nkind
(Expr
) = N_Function_Call
30780 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
30781 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
30782 and then No
(Parameter_Associations
(Expr
))
30785 ("found function name, possibly missing Access attribute!",
30788 -- Catch common error: a prefix or infix operator which is not
30789 -- directly visible because the type isn't.
30791 elsif Nkind
(Expr
) in N_Op
30792 and then Is_Overloaded
(Expr
)
30793 and then not Is_Immediately_Visible
(Expec_Type
)
30794 and then not Is_Potentially_Use_Visible
(Expec_Type
)
30795 and then not In_Use
(Expec_Type
)
30796 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
30799 ("operator of the type is not directly visible!", Expr
);
30801 elsif Ekind
(Found_Type
) = E_Void
30802 and then Present
(Parent
(Found_Type
))
30803 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
30805 Error_Msg_NE
("\\found premature usage of}!", Expr
, Found_Type
);
30808 Error_Msg_NE
("\\found}!", Expr
, Found_Type
);
30811 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
30812 -- of the same modular type, and (M1 and M2) = 0 was intended.
30814 if Expec_Type
= Standard_Boolean
30815 and then Is_Modular_Integer_Type
(Found_Type
)
30816 and then Nkind
(Parent
(Expr
)) in N_Op_And | N_Op_Or | N_Op_Xor
30817 and then Nkind
(Right_Opnd
(Parent
(Expr
))) in N_Op_Compare
30820 Op
: constant Node_Id
:= Right_Opnd
(Parent
(Expr
));
30821 L
: constant Node_Id
:= Left_Opnd
(Op
);
30822 R
: constant Node_Id
:= Right_Opnd
(Op
);
30825 -- The case for the message is when the left operand of the
30826 -- comparison is the same modular type, or when it is an
30827 -- integer literal (or other universal integer expression),
30828 -- which would have been typed as the modular type if the
30829 -- parens had been there.
30831 if (Etype
(L
) = Found_Type
30833 Etype
(L
) = Universal_Integer
)
30834 and then Is_Integer_Type
(Etype
(R
))
30837 ("\\possible missing parens for modular operation", Expr
);
30842 -- Reset error message qualification indication
30844 Error_Msg_Qual_Level
:= 0;
30848 --------------------------------
30849 -- Yields_Synchronized_Object --
30850 --------------------------------
30852 function Yields_Synchronized_Object
(Typ
: Entity_Id
) return Boolean is
30853 Has_Sync_Comp
: Boolean := False;
30857 -- An array type yields a synchronized object if its component type
30858 -- yields a synchronized object.
30860 if Is_Array_Type
(Typ
) then
30861 return Yields_Synchronized_Object
(Component_Type
(Typ
));
30863 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object
30864 -- yields a synchronized object by default.
30866 elsif Is_Descendant_Of_Suspension_Object
(Typ
) then
30869 -- A protected type yields a synchronized object by default
30871 elsif Is_Protected_Type
(Typ
) then
30874 -- A record type or type extension yields a synchronized object when its
30875 -- discriminants (if any) lack default values and all components are of
30876 -- a type that yields a synchronized object.
30878 elsif Is_Record_Type
(Typ
) then
30880 -- Inspect all entities defined in the scope of the type, looking for
30881 -- components of a type that does not yield a synchronized object or
30882 -- for discriminants with default values.
30884 Id
:= First_Entity
(Typ
);
30885 while Present
(Id
) loop
30886 if Comes_From_Source
(Id
) then
30887 if Ekind
(Id
) = E_Component
then
30888 if Yields_Synchronized_Object
(Etype
(Id
)) then
30889 Has_Sync_Comp
:= True;
30891 -- The component does not yield a synchronized object
30897 elsif Ekind
(Id
) = E_Discriminant
30898 and then Present
(Expression
(Parent
(Id
)))
30907 -- Ensure that the parent type of a type extension yields a
30908 -- synchronized object.
30910 if Etype
(Typ
) /= Typ
30911 and then not Is_Private_Type
(Etype
(Typ
))
30912 and then not Yields_Synchronized_Object
(Etype
(Typ
))
30917 -- If we get here, then all discriminants lack default values and all
30918 -- components are of a type that yields a synchronized object.
30920 return Has_Sync_Comp
;
30922 -- A synchronized interface type yields a synchronized object by default
30924 elsif Is_Synchronized_Interface
(Typ
) then
30927 -- A task type yields a synchronized object by default
30929 elsif Is_Task_Type
(Typ
) then
30932 -- A private type yields a synchronized object if its underlying type
30935 elsif Is_Private_Type
(Typ
)
30936 and then Present
(Underlying_Type
(Typ
))
30938 return Yields_Synchronized_Object
(Underlying_Type
(Typ
));
30940 -- Otherwise the type does not yield a synchronized object
30945 end Yields_Synchronized_Object
;
30947 ---------------------------
30948 -- Yields_Universal_Type --
30949 ---------------------------
30951 function Yields_Universal_Type
(N
: Node_Id
) return Boolean is
30953 -- Integer and real literals are of a universal type
30955 if Nkind
(N
) in N_Integer_Literal | N_Real_Literal
then
30958 -- The values of certain attributes are of a universal type
30960 elsif Nkind
(N
) = N_Attribute_Reference
then
30962 Universal_Type_Attribute
(Get_Attribute_Id
(Attribute_Name
(N
)));
30964 -- ??? There are possibly other cases to consider
30969 end Yields_Universal_Type
;
30971 package body Interval_Lists
is
30973 procedure Check_Consistency
(Intervals
: Discrete_Interval_List
);
30974 -- Check that list is sorted, lacks null intervals, and has gaps
30975 -- between intervals.
30977 function Chosen_Interval
(Choice
: Node_Id
) return Discrete_Interval
;
30978 -- Given an element of a Discrete_Choices list, a
30979 -- Static_Discrete_Predicate list, or an Others_Discrete_Choices
30980 -- list (but not an N_Others_Choice node) return the corresponding
30981 -- interval. If an element that does not represent a single
30982 -- contiguous interval due to a static predicate (or which
30983 -- represents a single contiguous interval whose bounds depend on
30984 -- a static predicate) is encountered, then that is an error on the
30985 -- part of whoever built the list in question.
30987 function In_Interval
30988 (Value
: Uint
; Interval
: Discrete_Interval
) return Boolean;
30989 -- Does the given value lie within the given interval?
30991 procedure Normalize_Interval_List
30992 (List
: in out Discrete_Interval_List
; Last
: out Nat
);
30993 -- Perform sorting and merging as required by Check_Consistency
30995 -------------------------
30996 -- Aggregate_Intervals --
30997 -------------------------
30999 function Aggregate_Intervals
(N
: Node_Id
) return Discrete_Interval_List
31001 pragma Assert
(Nkind
(N
) = N_Aggregate
31002 and then Is_Array_Type
(Etype
(N
)));
31004 function Unmerged_Intervals_Count
return Nat
;
31005 -- Count the number of intervals given in the aggregate N; the others
31006 -- choice (if present) is not taken into account.
31008 ------------------------------
31009 -- Unmerged_Intervals_Count --
31010 ------------------------------
31012 function Unmerged_Intervals_Count
return Nat
is
31017 Comp
:= First
(Component_Associations
(N
));
31018 while Present
(Comp
) loop
31019 Choice
:= First
(Choices
(Comp
));
31021 while Present
(Choice
) loop
31022 if Nkind
(Choice
) /= N_Others_Choice
then
31023 Count
:= Count
+ 1;
31033 end Unmerged_Intervals_Count
;
31038 Max_I
: constant Nat
:= Unmerged_Intervals_Count
;
31039 Intervals
: Discrete_Interval_List
(1 .. Max_I
);
31042 -- Start of processing for Aggregate_Intervals
31045 -- No action needed if there are no intervals
31051 -- Internally store all the unsorted intervals
31053 Comp
:= First
(Component_Associations
(N
));
31054 while Present
(Comp
) loop
31056 Choice_Intervals
: constant Discrete_Interval_List
31057 := Choice_List_Intervals
(Choices
(Comp
));
31059 for J
in Choice_Intervals
'Range loop
31060 Num_I
:= Num_I
+ 1;
31061 Intervals
(Num_I
) := Choice_Intervals
(J
);
31068 -- Normalize the lists sorting and merging the intervals
31071 Aggr_Intervals
: Discrete_Interval_List
(1 .. Num_I
)
31072 := Intervals
(1 .. Num_I
);
31074 Normalize_Interval_List
(Aggr_Intervals
, Num_I
);
31075 Check_Consistency
(Aggr_Intervals
(1 .. Num_I
));
31076 return Aggr_Intervals
(1 .. Num_I
);
31078 end Aggregate_Intervals
;
31080 ------------------------
31081 -- Check_Consistency --
31082 ------------------------
31084 procedure Check_Consistency
(Intervals
: Discrete_Interval_List
) is
31086 if Serious_Errors_Detected
> 0 then
31090 -- low bound is 1 and high bound equals length
31091 pragma Assert
(Intervals
'First = 1 and Intervals
'Last >= 0);
31092 for Idx
in Intervals
'Range loop
31093 -- each interval is non-null
31094 pragma Assert
(Intervals
(Idx
).Low
<= Intervals
(Idx
).High
);
31095 if Idx
/= Intervals
'First then
31096 -- intervals are sorted with non-empty gaps between them
31098 (Intervals
(Idx
- 1).High
< (Intervals
(Idx
).Low
- 1));
31102 end Check_Consistency
;
31104 ---------------------------
31105 -- Choice_List_Intervals --
31106 ---------------------------
31108 function Choice_List_Intervals
31109 (Discrete_Choices
: List_Id
) return Discrete_Interval_List
31111 function Unmerged_Choice_Count
return Nat
;
31112 -- The number of intervals before adjacent intervals are merged
31114 ---------------------------
31115 -- Unmerged_Choice_Count --
31116 ---------------------------
31118 function Unmerged_Choice_Count
return Nat
is
31119 Choice
: Node_Id
:= First
(Discrete_Choices
);
31122 while Present
(Choice
) loop
31123 -- Non-contiguous choices involving static predicates
31124 -- have already been normalized away.
31126 if Nkind
(Choice
) = N_Others_Choice
then
31128 Count
+ List_Length
(Others_Discrete_Choices
(Choice
));
31130 Count
:= Count
+ 1; -- an ordinary expression or range
31136 end Unmerged_Choice_Count
;
31140 Choice
: Node_Id
:= First
(Discrete_Choices
);
31141 Result
: Discrete_Interval_List
(1 .. Unmerged_Choice_Count
);
31144 -- Start of processing for Choice_List_Intervals
31147 while Present
(Choice
) loop
31148 if Nkind
(Choice
) = N_Others_Choice
then
31150 Others_Choice
: Node_Id
31151 := First
(Others_Discrete_Choices
(Choice
));
31153 while Present
(Others_Choice
) loop
31154 Count
:= Count
+ 1;
31155 Result
(Count
) := Chosen_Interval
(Others_Choice
);
31156 Next
(Others_Choice
);
31160 Count
:= Count
+ 1;
31161 Result
(Count
) := Chosen_Interval
(Choice
);
31167 pragma Assert
(Count
= Result
'Last);
31168 Normalize_Interval_List
(Result
, Count
);
31169 Check_Consistency
(Result
(1 .. Count
));
31170 return Result
(1 .. Count
);
31171 end Choice_List_Intervals
;
31173 ---------------------
31174 -- Chosen_Interval --
31175 ---------------------
31177 function Chosen_Interval
(Choice
: Node_Id
) return Discrete_Interval
is
31179 case Nkind
(Choice
) is
31181 return (Low
=> Expr_Value
(Low_Bound
(Choice
)),
31182 High
=> Expr_Value
(High_Bound
(Choice
)));
31184 when N_Subtype_Indication
=>
31186 Range_Exp
: constant Node_Id
31187 := Range_Expression
(Constraint
(Choice
));
31189 return (Low
=> Expr_Value
(Low_Bound
(Range_Exp
)),
31190 High
=> Expr_Value
(High_Bound
(Range_Exp
)));
31193 when N_Others_Choice
=>
31194 raise Program_Error
;
31197 if Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
))
31200 (Low
=> Expr_Value
(Type_Low_Bound
(Entity
(Choice
))),
31201 High
=> Expr_Value
(Type_High_Bound
(Entity
(Choice
))));
31204 return (Low | High
=> Expr_Value
(Choice
));
31207 end Chosen_Interval
;
31213 function In_Interval
31214 (Value
: Uint
; Interval
: Discrete_Interval
) return Boolean is
31216 return Value
>= Interval
.Low
and then Value
<= Interval
.High
;
31224 (Subset
, Of_Set
: Discrete_Interval_List
) return Boolean
31226 -- Returns True iff for each interval of Subset we can find
31227 -- a single interval of Of_Set which contains the Subset interval.
31229 if Of_Set
'Length = 0 then
31230 return Subset
'Length = 0;
31234 Set_Index
: Pos
range Of_Set
'Range := Of_Set
'First;
31237 for Ss_Idx
in Subset
'Range loop
31238 while not In_Interval
31239 (Value
=> Subset
(Ss_Idx
).Low
,
31240 Interval
=> Of_Set
(Set_Index
))
31242 if Set_Index
= Of_Set
'Last then
31246 Set_Index
:= Set_Index
+ 1;
31250 (Value
=> Subset
(Ss_Idx
).High
,
31251 Interval
=> Of_Set
(Set_Index
))
31261 -----------------------------
31262 -- Normalize_Interval_List --
31263 -----------------------------
31265 procedure Normalize_Interval_List
31266 (List
: in out Discrete_Interval_List
; Last
: out Nat
)
31268 Temp_0
: Discrete_Interval
:= (others => Uint_0
);
31269 -- Cope with Heap_Sort_G idiosyncrasies.
31271 function Is_Null
(Idx
: Pos
) return Boolean;
31272 -- True iff List (Idx) defines a null range
31274 function Lt_Interval
(Idx1
, Idx2
: Natural) return Boolean;
31275 -- Compare two list elements
31277 procedure Merge_Intervals
(Null_Interval_Count
: out Nat
);
31278 -- Merge contiguous ranges by replacing one with merged range and
31279 -- the other with a null value. Return a count of the null intervals,
31280 -- both preexisting and those introduced by merging.
31282 procedure Move_Interval
(From
, To
: Natural);
31283 -- Copy interval from one location to another
31285 function Read_Interval
(From
: Natural) return Discrete_Interval
;
31286 -- Normal array indexing unless From = 0
31288 ----------------------
31289 -- Interval_Sorting --
31290 ----------------------
31292 package Interval_Sorting
is
31293 new Gnat
.Heap_Sort_G
(Move_Interval
, Lt_Interval
);
31299 function Is_Null
(Idx
: Pos
) return Boolean is
31301 return List
(Idx
).Low
> List
(Idx
).High
;
31308 function Lt_Interval
(Idx1
, Idx2
: Natural) return Boolean is
31309 Elem1
: constant Discrete_Interval
:= Read_Interval
(Idx1
);
31310 Elem2
: constant Discrete_Interval
:= Read_Interval
(Idx2
);
31311 Null_1
: constant Boolean := Elem1
.Low
> Elem1
.High
;
31312 Null_2
: constant Boolean := Elem2
.Low
> Elem2
.High
;
31314 if Null_1
/= Null_2
then
31315 -- So that sorting moves null intervals to high end
31318 elsif Elem1
.Low
/= Elem2
.Low
then
31319 return Elem1
.Low
< Elem2
.Low
;
31322 return Elem1
.High
< Elem2
.High
;
31326 ---------------------
31327 -- Merge_Intervals --
31328 ---------------------
31330 procedure Merge_Intervals
(Null_Interval_Count
: out Nat
) is
31331 Not_Null
: Pos
range List
'Range;
31332 -- Index of the most recently examined non-null interval
31334 Null_Interval
: constant Discrete_Interval
31335 := (Low
=> Uint_1
, High
=> Uint_0
); -- any null range ok here
31337 if List
'Length = 0 or else Is_Null
(List
'First) then
31338 Null_Interval_Count
:= List
'Length;
31339 -- no non-null elements, so no merge candidates
31343 Null_Interval_Count
:= 0;
31344 Not_Null
:= List
'First;
31346 for Idx
in List
'First + 1 .. List
'Last loop
31347 if Is_Null
(Idx
) then
31349 -- all remaining elements are null
31351 Null_Interval_Count
:=
31352 Null_Interval_Count
+ List
(Idx
.. List
'Last)'Length;
31355 elsif List
(Idx
).Low
= List
(Not_Null
).High
+ 1 then
31357 -- Merge the two intervals into one; discard the other
31359 List
(Not_Null
).High
:= List
(Idx
).High
;
31360 List
(Idx
) := Null_Interval
;
31361 Null_Interval_Count
:= Null_Interval_Count
+ 1;
31364 if List
(Idx
).Low
<= List
(Not_Null
).High
then
31365 raise Intervals_Error
;
31368 pragma Assert
(List
(Idx
).Low
> List
(Not_Null
).High
);
31372 end Merge_Intervals
;
31374 -------------------
31375 -- Move_Interval --
31376 -------------------
31378 procedure Move_Interval
(From
, To
: Natural) is
31379 Rhs
: constant Discrete_Interval
:= Read_Interval
(From
);
31384 List
(Pos
(To
)) := Rhs
;
31388 -------------------
31389 -- Read_Interval --
31390 -------------------
31392 function Read_Interval
(From
: Natural) return Discrete_Interval
is
31397 return List
(Pos
(From
));
31401 -- Start of processing for Normalize_Interval_Lists
31404 Interval_Sorting
.Sort
(Natural (List
'Last));
31407 Null_Interval_Count
: Nat
;
31410 Merge_Intervals
(Null_Interval_Count
);
31411 Last
:= List
'Last - Null_Interval_Count
;
31413 if Null_Interval_Count
/= 0 then
31414 -- Move null intervals introduced during merging to high end
31415 Interval_Sorting
.Sort
(Natural (List
'Last));
31418 end Normalize_Interval_List
;
31420 --------------------
31421 -- Type_Intervals --
31422 --------------------
31424 function Type_Intervals
(Typ
: Entity_Id
) return Discrete_Interval_List
31427 if Has_Static_Predicate
(Typ
) then
31429 -- No sorting or merging needed
31430 SDP_List
: constant List_Id
:= Static_Discrete_Predicate
(Typ
);
31431 Range_Or_Expr
: Node_Id
:= First
(SDP_List
);
31432 Result
: Discrete_Interval_List
(1 .. List_Length
(SDP_List
));
31435 for Idx
in Result
'Range loop
31436 Result
(Idx
) := Chosen_Interval
(Range_Or_Expr
);
31437 Next
(Range_Or_Expr
);
31440 pragma Assert
(not Present
(Range_Or_Expr
));
31441 Check_Consistency
(Result
);
31446 Low
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Typ
));
31447 High
: constant Uint
:= Expr_Value
(Type_High_Bound
(Typ
));
31451 Null_Array
: Discrete_Interval_List
(1 .. 0);
31456 return (1 => (Low
=> Low
, High
=> High
));
31460 end Type_Intervals
;
31462 end Interval_Lists
;
31464 package body Old_Attr_Util
is
31465 package body Conditional_Evaluation
is
31466 type Determining_Expr_Context
is
31467 (No_Context
, If_Expr
, Case_Expr
, Short_Circuit_Op
, Membership_Test
);
31469 -- Determining_Expr_Context enumeration elements (except for
31470 -- No_Context) correspond to the list items in RM 6.1.1 definition
31471 -- of "determining expression".
31473 type Determining_Expr
31474 (Context
: Determining_Expr_Context
:= No_Context
)
31476 Expr
: Node_Id
:= Empty
;
31478 when Short_Circuit_Op
=>
31479 Is_And_Then
: Boolean;
31481 Is_Then_Part
: Boolean;
31483 Alternatives
: Node_Id
;
31484 when Membership_Test
=>
31485 -- Given a subexpression of <exp4> in a membership test
31486 -- <exp1> in <exp2> | <exp3> | <exp4> | <exp5>
31487 -- the corresponding determining expression value would
31488 -- have First_Non_Preceding = <exp4> (See RM 6.1.1).
31489 First_Non_Preceding
: Node_Id
;
31495 type Determining_Expression_List
is
31496 array (Positive range <>) of Determining_Expr
;
31498 function Determining_Condition
(Det
: Determining_Expr
)
31500 -- Given a determining expression, build a Boolean-valued
31501 -- condition that incorporates that expression into condition
31502 -- suitable for deciding whether to initialize a 'Old constant.
31503 -- Polarity is "True => initialize the constant".
31505 function Determining_Expressions
31506 (Expr
: Node_Id
; Expr_Trailer
: Node_Id
:= Empty
)
31507 return Determining_Expression_List
;
31508 -- Given a conditionally evaluated expression, return its
31509 -- determining expressions.
31510 -- See RM 6.1.1 for definition of term "determining expressions".
31511 -- Tests should be performed in the order they occur in the
31512 -- array, with short circuiting.
31513 -- A determining expression need not be of a boolean type (e.g.,
31514 -- it might be the determining expression of a case expression).
31515 -- The Expr_Trailer parameter should be defaulted for nonrecursive
31518 function Is_Conditionally_Evaluated
(Expr
: Node_Id
) return Boolean;
31519 -- See RM 6.1.1 for definition of term "conditionally evaluated".
31521 function Is_Known_On_Entry
(Expr
: Node_Id
) return Boolean;
31522 -- See RM 6.1.1 for definition of term "known on entry".
31524 --------------------------------------
31525 -- Conditional_Evaluation_Condition --
31526 --------------------------------------
31528 function Conditional_Evaluation_Condition
31529 (Expr
: Node_Id
) return Node_Id
31531 Determiners
: constant Determining_Expression_List
:=
31532 Determining_Expressions
(Expr
);
31533 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
31534 Result
: Node_Id
:=
31535 New_Occurrence_Of
(Standard_True
, Loc
);
31537 pragma Assert
(Determiners
'Length > 0 or else
31538 Is_Anonymous_Access_Type
(Etype
(Expr
)));
31540 for I
in Determiners
'Range loop
31541 Result
:= Make_And_Then
31543 Left_Opnd
=> Result
,
31545 Determining_Condition
(Determiners
(I
)));
31548 end Conditional_Evaluation_Condition
;
31550 ---------------------------
31551 -- Determining_Condition --
31552 ---------------------------
31554 function Determining_Condition
(Det
: Determining_Expr
) return Node_Id
31556 Loc
: constant Source_Ptr
:= Sloc
(Det
.Expr
);
31558 case Det
.Context
is
31559 when Short_Circuit_Op
=>
31560 if Det
.Is_And_Then
then
31561 return New_Copy_Tree
(Det
.Expr
);
31563 return Make_Op_Not
(Loc
, New_Copy_Tree
(Det
.Expr
));
31567 if Det
.Is_Then_Part
then
31568 return New_Copy_Tree
(Det
.Expr
);
31570 return Make_Op_Not
(Loc
, New_Copy_Tree
(Det
.Expr
));
31575 Alts
: List_Id
:= Discrete_Choices
(Det
.Alternatives
);
31577 if Nkind
(First
(Alts
)) = N_Others_Choice
then
31578 Alts
:= Others_Discrete_Choices
(First
(Alts
));
31581 return Make_In
(Loc
,
31582 Left_Opnd
=> New_Copy_Tree
(Det
.Expr
),
31583 Right_Opnd
=> Empty
,
31584 Alternatives
=> New_Copy_List
(Alts
));
31587 when Membership_Test
=>
31589 function Copy_Prefix
31590 (List
: List_Id
; Suffix_Start
: Node_Id
)
31592 -- Given a list and a member of that list, returns
31593 -- a copy (similar to Nlists.New_Copy_List) of the
31594 -- prefix of the list up to but not including
31601 function Copy_Prefix
31602 (List
: List_Id
; Suffix_Start
: Node_Id
)
31605 Result
: constant List_Id
:= New_List
;
31606 Elem
: Node_Id
:= First
(List
);
31608 while Elem
/= Suffix_Start
loop
31609 Append
(New_Copy
(Elem
), Result
);
31611 pragma Assert
(Present
(Elem
));
31617 return Make_In
(Loc
,
31618 Left_Opnd
=> New_Copy_Tree
(Left_Opnd
(Det
.Expr
)),
31619 Right_Opnd
=> Empty
,
31620 Alternatives
=> Copy_Prefix
31621 (Alternatives
(Det
.Expr
),
31622 Det
.First_Non_Preceding
));
31626 raise Program_Error
;
31628 end Determining_Condition
;
31630 -----------------------------
31631 -- Determining_Expressions --
31632 -----------------------------
31634 function Determining_Expressions
31635 (Expr
: Node_Id
; Expr_Trailer
: Node_Id
:= Empty
)
31636 return Determining_Expression_List
31638 Par
: Node_Id
:= Expr
;
31639 Trailer
: Node_Id
:= Expr_Trailer
;
31640 Next_Element
: Determining_Expr
;
31642 -- We want to stop climbing up the tree when we reach the
31643 -- postcondition expression. An aspect_specification is
31644 -- transformed into a pragma, so reaching a pragma is our
31645 -- termination condition. This relies on the fact that
31646 -- pragmas are not allowed in declare expressions (or any
31647 -- other kind of expression).
31650 Next_Element
.Expr
:= Empty
;
31652 case Nkind
(Par
) is
31653 when N_Short_Circuit
=>
31654 if Trailer
= Right_Opnd
(Par
) then
31656 (Expr
=> Left_Opnd
(Par
),
31657 Context
=> Short_Circuit_Op
,
31658 Is_And_Then
=> Nkind
(Par
) = N_And_Then
);
31661 when N_If_Expression
=>
31662 -- For an expression like
31663 -- (if C1 then ... elsif C2 then ... else Foo'Old)
31664 -- the RM says are two determining expressions,
31665 -- C1 and C2. Our treatment here (where we only add
31666 -- one determining expression to the list) is ok because
31667 -- we will see two if-expressions, one within the other.
31669 if Trailer
/= First
(Expressions
(Par
)) then
31671 (Expr
=> First
(Expressions
(Par
)),
31672 Context
=> If_Expr
,
31674 Trailer
= Next
(First
(Expressions
(Par
))));
31677 when N_Case_Expression_Alternative
=>
31678 pragma Assert
(Nkind
(Parent
(Par
)) = N_Case_Expression
);
31681 (Expr
=> Expression
(Parent
(Par
)),
31682 Context
=> Case_Expr
,
31683 Alternatives
=> Par
);
31685 when N_Membership_Test
=>
31686 if Trailer
/= Left_Opnd
(Par
)
31687 and then Is_Non_Empty_List
(Alternatives
(Par
))
31688 and then Trailer
/= First
(Alternatives
(Par
))
31690 pragma Assert
(not Present
(Right_Opnd
(Par
)));
31692 (Is_List_Member
(Trailer
)
31693 and then List_Containing
(Trailer
)
31694 = Alternatives
(Par
));
31696 -- This one is different than the others
31697 -- because one element in the array result
31698 -- may represent multiple determining
31699 -- expressions (i.e. every member of the list
31700 -- Alternatives (Par)
31701 -- up to but not including Trailer).
31705 Context
=> Membership_Test
,
31706 First_Non_Preceding
=> Trailer
);
31711 Previous
: constant Node_Id
:= Prev
(Par
);
31712 Prev_Expr
: Node_Id
;
31714 if Nkind
(Previous
) = N_Pragma
and then
31715 Split_PPC
(Previous
)
31717 -- A source-level postcondition of
31718 -- A and then B and then C
31720 -- pragma Postcondition (A);
31721 -- pragma Postcondition (B);
31722 -- pragma Postcondition (C);
31723 -- with Split_PPC set to True on all but the
31724 -- last pragma. We account for that here.
31728 (Pragma_Argument_Associations
(Previous
)));
31730 -- This Analyze call is needed in the case when
31731 -- Sem_Attr.Analyze_Attribute calls
31732 -- Eligible_For_Conditional_Evaluation. Without
31733 -- it, we end up passing an unanalyzed expression
31734 -- to Is_Known_On_Entry and that doesn't work.
31736 Analyze
(Prev_Expr
);
31739 (Expr
=> Prev_Expr
,
31740 Context
=> Short_Circuit_Op
,
31741 Is_And_Then
=> True);
31743 return Determining_Expressions
(Prev_Expr
)
31747 (Get_Pragma_Id
(Pragma_Name
(Par
)) in
31748 Pragma_Post | Pragma_Postcondition
31749 | Pragma_Post_Class | Pragma_Refined_Post
31750 | Pragma_Check | Pragma_Contract_Cases
);
31752 return (1 .. 0 => <>); -- recursion terminates here
31757 -- This case should be impossible, but if it does
31758 -- happen somehow then we don't want an infinite loop.
31759 raise Program_Error
;
31766 Par
:= Parent
(Par
);
31768 if Present
(Next_Element
.Expr
) then
31769 return Determining_Expressions
31770 (Expr
=> Par
, Expr_Trailer
=> Trailer
)
31774 end Determining_Expressions
;
31776 -----------------------------------------
31777 -- Eligible_For_Conditional_Evaluation --
31778 -----------------------------------------
31780 function Eligible_For_Conditional_Evaluation
31781 (Expr
: Node_Id
) return Boolean
31784 if Is_Anonymous_Access_Type
(Etype
(Expr
)) then
31785 -- The code in exp_attr.adb that also builds declarations
31786 -- for 'Old constants doesn't handle the anonymous access
31787 -- type case correctly, so we avoid that problem by
31788 -- returning True here.
31791 elsif Ada_Version
< Ada_2022
then
31794 elsif Inside_Class_Condition_Preanalysis
then
31795 -- No need to evaluate it during preanalysis of a class-wide
31796 -- pre/postcondition since the expression is not installed yet
31797 -- on its definite context.
31800 elsif not Is_Conditionally_Evaluated
(Expr
) then
31804 Determiners
: constant Determining_Expression_List
:=
31805 Determining_Expressions
(Expr
);
31807 pragma Assert
(Determiners
'Length > 0);
31809 for Idx
in Determiners
'Range loop
31810 if not Is_Known_On_Entry
(Determiners
(Idx
).Expr
) then
31817 end Eligible_For_Conditional_Evaluation
;
31819 --------------------------------
31820 -- Is_Conditionally_Evaluated --
31821 --------------------------------
31823 function Is_Conditionally_Evaluated
(Expr
: Node_Id
) return Boolean
31825 -- There are three possibilities - the expression is
31826 -- unconditionally evaluated, repeatedly evaluated, or
31827 -- conditionally evaluated (see RM 6.1.1). So we implement
31828 -- this test by testing for the other two.
31830 function Is_Repeatedly_Evaluated
(Expr
: Node_Id
) return Boolean;
31831 -- See RM 6.1.1 for definition of "repeatedly evaluated".
31833 -----------------------------
31834 -- Is_Repeatedly_Evaluated --
31835 -----------------------------
31837 function Is_Repeatedly_Evaluated
(Expr
: Node_Id
) return Boolean is
31838 Par
: Node_Id
:= Expr
;
31839 Trailer
: Node_Id
:= Empty
;
31841 -- There are three ways that an expression can be repeatedly
31844 -- An aspect_specification is transformed into a pragma, so
31845 -- reaching a pragma is our termination condition. We want to
31846 -- stop when we reach the postcondition expression.
31848 while Nkind
(Par
) /= N_Pragma
loop
31849 pragma Assert
(Present
(Par
));
31851 -- test for case 1:
31852 -- A subexpression of a predicate of a
31853 -- quantified_expression.
31855 if Nkind
(Par
) = N_Quantified_Expression
31856 and then Trailer
= Condition
(Par
)
31859 elsif Nkind
(Par
) = N_Expression_With_Actions
31861 Nkind
(Original_Node
(Par
)) = N_Quantified_Expression
31866 -- test for cases 2 and 3:
31867 -- A subexpression of the expression of an
31868 -- array_component_association or of
31869 -- a container_element_associatiation.
31871 if Nkind
(Par
) = N_Component_Association
31872 and then Trailer
= Expression
(Par
)
31874 -- determine whether Par is part of an array aggregate
31875 -- or a container aggregate
31877 Rover
: Node_Id
:= Par
;
31879 while Nkind
(Rover
) not in N_Has_Etype
loop
31880 pragma Assert
(Present
(Rover
));
31881 Rover
:= Parent
(Rover
);
31883 if Present
(Etype
(Rover
)) then
31884 if Is_Array_Type
(Etype
(Rover
))
31885 or else Is_Container_Aggregate
(Rover
)
31894 Par
:= Parent
(Par
);
31898 end Is_Repeatedly_Evaluated
;
31901 if not Is_Potentially_Unevaluated
(Expr
) then
31902 -- the expression is unconditionally evaluated
31904 elsif Is_Repeatedly_Evaluated
(Expr
) then
31909 end Is_Conditionally_Evaluated
;
31911 -----------------------
31912 -- Is_Known_On_Entry --
31913 -----------------------
31915 function Is_Known_On_Entry
(Expr
: Node_Id
) return Boolean is
31916 -- ??? This implementation is incomplete. See RM 6.1.1
31917 -- for details. In particular, this function *should* return
31918 -- True for a function call (or a user-defined literal, which
31919 -- is equivalent to a function call) if all actual parameters
31920 -- (including defaulted params) are known on entry and the
31921 -- function has "Globals => null" specified; the current
31922 -- implementation will incorrectly return False in this case.
31924 function All_Exps_Known_On_Entry
31925 (Expr_List
: List_Id
) return Boolean;
31926 -- Given a list of expressions, returns False iff
31927 -- Is_Known_On_Entry is False for at least one list element.
31929 -----------------------------
31930 -- All_Exps_Known_On_Entry --
31931 -----------------------------
31933 function All_Exps_Known_On_Entry
31934 (Expr_List
: List_Id
) return Boolean
31936 Expr
: Node_Id
:= First
(Expr_List
);
31938 while Present
(Expr
) loop
31939 if not Is_Known_On_Entry
(Expr
) then
31945 end All_Exps_Known_On_Entry
;
31948 if Is_Static_Expression
(Expr
) then
31952 if Is_Attribute_Old
(Expr
) then
31957 Pref
: Node_Id
:= Expr
;
31960 case Nkind
(Pref
) is
31961 when N_Selected_Component
=>
31964 when N_Indexed_Component
=>
31965 if not All_Exps_Known_On_Entry
(Expressions
(Pref
))
31971 return False; -- just to be clear about this case
31977 Pref
:= Prefix
(Pref
);
31980 if Is_Entity_Name
(Pref
)
31981 and then Is_Constant_Object
(Entity
(Pref
))
31984 Obj
: constant Entity_Id
:= Entity
(Pref
);
31985 Obj_Typ
: constant Entity_Id
:= Etype
(Obj
);
31987 case Ekind
(Obj
) is
31988 when E_In_Parameter
=>
31989 if not Is_Elementary_Type
(Obj_Typ
) then
31991 elsif Is_Aliased
(Obj
) then
31996 -- return False for a deferred constant
31997 if Present
(Full_View
(Obj
)) then
32001 -- return False if not "all views are constant".
32002 if Is_Immutably_Limited_Type
(Obj_Typ
)
32003 or Needs_Finalization
(Obj_Typ
)
32016 -- ??? Cope with a malformed tree. Code to cope with a
32017 -- nonstatic use of an enumeration literal should not be
32019 if Is_Entity_Name
(Pref
)
32020 and then Ekind
(Entity
(Pref
)) = E_Enumeration_Literal
32026 case Nkind
(Expr
) is
32028 return Is_Known_On_Entry
(Right_Opnd
(Expr
));
32030 when N_Binary_Op
=>
32031 return Is_Known_On_Entry
(Left_Opnd
(Expr
))
32032 and then Is_Known_On_Entry
(Right_Opnd
(Expr
));
32034 when N_Type_Conversion | N_Qualified_Expression
=>
32035 return Is_Known_On_Entry
(Expression
(Expr
));
32037 when N_If_Expression
=>
32038 if not All_Exps_Known_On_Entry
(Expressions
(Expr
)) then
32042 when N_Case_Expression
=>
32043 if not Is_Known_On_Entry
(Expression
(Expr
)) then
32048 Alt
: Node_Id
:= First
(Alternatives
(Expr
));
32050 while Present
(Alt
) loop
32051 if not Is_Known_On_Entry
(Expression
(Alt
)) then
32065 end Is_Known_On_Entry
;
32067 end Conditional_Evaluation
;
32069 package body Indirect_Temps
is
32071 Indirect_Temp_Access_Type_Char
: constant Character := 'K';
32072 -- The character passed to Make_Temporary when declaring
32073 -- the access type that is used in the implementation of an
32074 -- indirect temporary.
32076 --------------------------
32077 -- Indirect_Temp_Needed --
32078 --------------------------
32080 function Indirect_Temp_Needed
(Typ
: Entity_Id
) return Boolean is
32082 -- There should be no correctness issues if the only cases where
32083 -- this function returns False are cases where Typ is an
32084 -- anonymous access type and we need to generate a saooaaat (a
32085 -- stand-alone object of an anonymous access type) in order get
32086 -- accessibility right. In other cases where this function
32087 -- returns False, there would be no correctness problems with
32088 -- returning True instead; however, returning False when we can
32089 -- generally results in simpler code.
32093 -- If Typ is not definite, then we cannot generate
32096 or else not Is_Definite_Subtype
(Typ
)
32098 -- If Typ is tagged, then generating
32100 -- might generate an object with the wrong tag. If we had
32101 -- a predicate that indicated whether the nominal tag is
32102 -- trustworthy, we could use that predicate here.
32104 or else Is_Tagged_Type
(Typ
)
32106 -- If Typ needs finalization, then generating an implicit
32108 -- declaration could have user-visible side effects.
32110 or else Needs_Finalization
(Typ
)
32112 -- In the anonymous access type case, we need to
32113 -- generate a saooaaat. We don't want the code in
32114 -- in exp_attr.adb that deals with the case where this
32115 -- function returns False to have to deal with that case
32116 -- (just to avoid code duplication). So we cheat a little
32117 -- bit and return True here for an anonymous access type.
32119 or else Is_Anonymous_Access_Type
(Typ
);
32121 -- ??? Unimplemented - spec description says:
32122 -- For an unconstrained-but-definite discriminated subtype,
32123 -- returns True if the potential difference in size between an
32124 -- unconstrained object and a constrained object is large.
32127 -- type Typ (Len : Natural := 0) is
32128 -- record F : String (1 .. Len); end record;
32130 -- See Large_Max_Size_Mutable function elsewhere in this
32131 -- file (currently declared inside of
32132 -- Returns_On_Secondary_Stack, so it would have to be
32133 -- moved if we want it to be callable from here).
32135 end Indirect_Temp_Needed
;
32137 ---------------------------
32138 -- Declare_Indirect_Temp --
32139 ---------------------------
32141 procedure Declare_Indirect_Temp
32142 (Attr_Prefix
: Node_Id
; Indirect_Temp
: out Entity_Id
)
32144 Loc
: constant Source_Ptr
:= Sloc
(Attr_Prefix
);
32145 Prefix_Type
: constant Entity_Id
:= Etype
(Attr_Prefix
);
32146 Temp_Id
: constant Entity_Id
:=
32147 Make_Temporary
(Loc
, 'P', Attr_Prefix
);
32149 procedure Declare_Indirect_Temp_Via_Allocation
;
32150 -- Handle the usual case.
32152 -------------------------------------------
32153 -- Declare_Indirect_Temp_Via_Allocation --
32154 -------------------------------------------
32156 procedure Declare_Indirect_Temp_Via_Allocation
is
32157 Access_Type_Id
: constant Entity_Id
32159 (Loc
, Indirect_Temp_Access_Type_Char
, Attr_Prefix
);
32161 Temp_Decl
: constant Node_Id
:=
32162 Make_Object_Declaration
(Loc
,
32163 Defining_Identifier
=> Temp_Id
,
32164 Object_Definition
=>
32165 New_Occurrence_Of
(Access_Type_Id
, Loc
));
32167 Allocate_Class_Wide
: constant Boolean :=
32168 Is_Specific_Tagged_Type
(Prefix_Type
);
32169 -- If True then access type designates the class-wide type in
32170 -- order to preserve (at run time) the value of the underlying
32172 -- ??? We could do better here (in the case where Prefix_Type
32173 -- is tagged and specific) if we had a predicate which takes an
32174 -- expression and returns True iff the expression is of
32175 -- a specific tagged type and the underlying tag (at run time)
32176 -- is statically known to match that of the specific type.
32177 -- In that case, Allocate_Class_Wide could safely be False.
32179 function Designated_Subtype_Mark
return Node_Id
;
32180 -- Usually, a subtype mark indicating the subtype of the
32181 -- attribute prefix. If that subtype is a specific tagged
32182 -- type, then returns the corresponding class-wide type.
32183 -- If the prefix is of an anonymous access type, then returns
32184 -- the designated type of that type.
32186 -----------------------------
32187 -- Designated_Subtype_Mark --
32188 -----------------------------
32190 function Designated_Subtype_Mark
return Node_Id
is
32191 Typ
: Entity_Id
:= Prefix_Type
;
32193 if Allocate_Class_Wide
then
32194 if Is_Private_Type
(Typ
)
32195 and then Present
(Full_View
(Typ
))
32197 Typ
:= Full_View
(Typ
);
32199 Typ
:= Class_Wide_Type
(Typ
);
32202 return New_Occurrence_Of
(Typ
, Loc
);
32203 end Designated_Subtype_Mark
;
32205 Access_Type_Def
: constant Node_Id
32206 := Make_Access_To_Object_Definition
32207 (Loc
, Subtype_Indication
=> Designated_Subtype_Mark
);
32209 Access_Type_Decl
: constant Node_Id
32210 := Make_Full_Type_Declaration
32211 (Loc
, Access_Type_Id
,
32212 Type_Definition
=> Access_Type_Def
);
32214 Mutate_Ekind
(Temp_Id
, E_Variable
);
32215 Set_Etype
(Temp_Id
, Access_Type_Id
);
32216 Mutate_Ekind
(Access_Type_Id
, E_Access_Type
);
32218 if Append_Decls_In_Reverse_Order
then
32219 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
32220 Append_Item
(Access_Type_Decl
, Is_Eval_Stmt
=> False);
32222 Append_Item
(Access_Type_Decl
, Is_Eval_Stmt
=> False);
32223 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
32226 -- When a type associated with an indirect temporary gets
32227 -- created for a 'Old attribute reference we need to mark
32228 -- the type as such. This allows, for example, finalization
32229 -- masters associated with them to be finalized in the correct
32230 -- order after postcondition checks.
32232 if Attribute_Name
(Parent
(Attr_Prefix
)) = Name_Old
then
32233 Set_Stores_Attribute_Old_Prefix
(Access_Type_Id
);
32236 Analyze
(Access_Type_Decl
);
32237 Analyze
(Temp_Decl
);
32240 (Is_Access_Type_For_Indirect_Temp
(Access_Type_Id
));
32243 Expression
: Node_Id
:= Attr_Prefix
;
32244 Allocator
: Node_Id
;
32246 if Allocate_Class_Wide
then
32247 -- generate T'Class'(T'Class (<prefix>))
32249 Make_Type_Conversion
(Loc
,
32250 Subtype_Mark
=> Designated_Subtype_Mark
,
32251 Expression
=> Expression
);
32255 Make_Allocator
(Loc
,
32256 Make_Qualified_Expression
32258 Subtype_Mark
=> Designated_Subtype_Mark
,
32259 Expression
=> Expression
));
32261 -- Allocate saved prefix value on the secondary stack
32262 -- in order to avoid introducing a storage leak. This
32263 -- allocated object is never explicitly reclaimed.
32265 -- ??? Emit storage leak warning if RE_SS_Pool
32268 if RTE_Available
(RE_SS_Pool
) then
32269 Set_Storage_Pool
(Allocator
, RTE
(RE_SS_Pool
));
32270 Set_Procedure_To_Call
32271 (Allocator
, RTE
(RE_SS_Allocate
));
32272 Set_Uses_Sec_Stack
(Current_Scope
);
32276 (Make_Assignment_Statement
(Loc
,
32277 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
32278 Expression
=> Allocator
),
32279 Is_Eval_Stmt
=> True);
32281 end Declare_Indirect_Temp_Via_Allocation
;
32284 Indirect_Temp
:= Temp_Id
;
32286 if Is_Anonymous_Access_Type
(Prefix_Type
) then
32287 -- In the anonymous access type case, we do not want a level
32288 -- indirection (which would result in declaring an
32289 -- access-to-access type); that would result in correctness
32290 -- problems - the accessibility level of the type of the
32291 -- 'Old constant would be wrong (See 6.1.1.). So in that case,
32292 -- we do not generate an allocator. Instead we generate
32293 -- Temp : access Designated := null;
32294 -- which is unconditionally elaborated and then
32295 -- Temp := <attribute prefix>;
32296 -- which is conditionally executed.
32299 Temp_Decl
: constant Node_Id
:=
32300 Make_Object_Declaration
(Loc
,
32301 Defining_Identifier
=> Temp_Id
,
32302 Object_Definition
=>
32303 Make_Access_Definition
32305 Constant_Present
=>
32306 Is_Access_Constant
(Prefix_Type
),
32309 (Designated_Type
(Prefix_Type
), Loc
)));
32311 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
32312 Analyze
(Temp_Decl
);
32314 (Make_Assignment_Statement
(Loc
,
32315 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
32316 Expression
=> Attr_Prefix
),
32317 Is_Eval_Stmt
=> True);
32321 Declare_Indirect_Temp_Via_Allocation
;
32323 end Declare_Indirect_Temp
;
32325 -------------------------
32326 -- Indirect_Temp_Value --
32327 -------------------------
32329 function Indirect_Temp_Value
32332 Loc
: Source_Ptr
) return Node_Id
32336 if Is_Anonymous_Access_Type
(Typ
) then
32337 -- No indirection in this case; just evaluate the temp.
32338 Result
:= New_Occurrence_Of
(Temp
, Loc
);
32339 Set_Etype
(Result
, Etype
(Temp
));
32342 Result
:= Make_Explicit_Dereference
(Loc
,
32343 New_Occurrence_Of
(Temp
, Loc
));
32345 Set_Etype
(Result
, Designated_Type
(Etype
(Temp
)));
32347 if Is_Specific_Tagged_Type
(Typ
) then
32348 -- The designated type of the access type is class-wide, so
32349 -- convert to the specific type.
32352 Make_Type_Conversion
(Loc
,
32353 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
32354 Expression
=> Result
);
32356 Set_Etype
(Result
, Typ
);
32361 end Indirect_Temp_Value
;
32363 function Is_Access_Type_For_Indirect_Temp
32364 (T
: Entity_Id
) return Boolean is
32366 if Is_Access_Type
(T
)
32367 and then not Comes_From_Source
(T
)
32368 and then Is_Internal_Name
(Chars
(T
))
32369 and then Nkind
(Scope
(T
)) in N_Entity
32370 and then Ekind
(Scope
(T
))
32371 in E_Entry | E_Entry_Family | E_Function | E_Procedure
32373 (Present
(Postconditions_Proc
(Scope
(T
)))
32374 or else Present
(Contract
(Scope
(T
))))
32376 -- ??? Should define a flag for this. We could incorrectly
32377 -- return True if other clients of Make_Temporary happen to
32378 -- pass in the same character.
32380 Name
: constant String := Get_Name_String
(Chars
(T
));
32382 if Name
(Name
'First) = Indirect_Temp_Access_Type_Char
then
32389 end Is_Access_Type_For_Indirect_Temp
;
32391 end Indirect_Temps
;
32394 package body Storage_Model_Support
is
32396 -----------------------------------------
32397 -- Has_Designated_Storage_Model_Aspect --
32398 -----------------------------------------
32400 function Has_Designated_Storage_Model_Aspect
32401 (Typ
: Entity_Id
) return Boolean
32404 return Present
(Find_Aspect
(Typ
, Aspect_Designated_Storage_Model
));
32405 end Has_Designated_Storage_Model_Aspect
;
32407 -----------------------------------
32408 -- Has_Storage_Model_Type_Aspect --
32409 -----------------------------------
32411 function Has_Storage_Model_Type_Aspect
(Typ
: Entity_Id
) return Boolean
32414 return Present
(Find_Aspect
(Typ
, Aspect_Storage_Model_Type
));
32415 end Has_Storage_Model_Type_Aspect
;
32417 --------------------------
32418 -- Storage_Model_Object --
32419 --------------------------
32421 function Storage_Model_Object
(Typ
: Entity_Id
) return Entity_Id
is
32423 pragma Assert
(Has_Designated_Storage_Model_Aspect
(Typ
));
32427 (Find_Value_Of_Aspect
(Typ
, Aspect_Designated_Storage_Model
));
32428 end Storage_Model_Object
;
32430 ------------------------
32431 -- Storage_Model_Type --
32432 ------------------------
32434 function Storage_Model_Type
(Obj
: Entity_Id
) return Entity_Id
is
32436 pragma Assert
(Has_Storage_Model_Type_Aspect
(Etype
(Obj
)));
32438 return Etype
(Obj
);
32439 end Storage_Model_Type
;
32441 -----------------------------------
32442 -- Get_Storage_Model_Type_Entity --
32443 -----------------------------------
32445 function Get_Storage_Model_Type_Entity
32446 (SM_Obj_Or_Type
: Entity_Id
;
32447 Nam
: Name_Id
) return Entity_Id
32449 Typ
: constant Entity_Id
:= (if Is_Object
(SM_Obj_Or_Type
) then
32450 Storage_Model_Type
(SM_Obj_Or_Type
)
32456 Nam
in Name_Address_Type
32457 | Name_Null_Address
32462 | Name_Storage_Size
);
32465 SMT_Aspect_Value
: constant Node_Id
:=
32466 Find_Value_Of_Aspect
(Typ
, Aspect_Storage_Model_Type
);
32469 pragma Assert
(Present
(SMT_Aspect_Value
));
32471 Assoc
:= First
(Component_Associations
(SMT_Aspect_Value
));
32472 while Present
(Assoc
) loop
32473 if Chars
(First
(Choices
(Assoc
))) = Nam
then
32474 return Entity
(Expression
(Assoc
));
32481 end Get_Storage_Model_Type_Entity
;
32483 --------------------------------
32484 -- Storage_Model_Address_Type --
32485 --------------------------------
32487 function Storage_Model_Address_Type
32488 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
32492 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Address_Type
);
32493 end Storage_Model_Address_Type
;
32495 --------------------------------
32496 -- Storage_Model_Null_Address --
32497 --------------------------------
32499 function Storage_Model_Null_Address
32500 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
32504 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Null_Address
);
32505 end Storage_Model_Null_Address
;
32507 ----------------------------
32508 -- Storage_Model_Allocate --
32509 ----------------------------
32511 function Storage_Model_Allocate
32512 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
32515 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Allocate
);
32516 end Storage_Model_Allocate
;
32518 ------------------------------
32519 -- Storage_Model_Deallocate --
32520 ------------------------------
32522 function Storage_Model_Deallocate
32523 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
32527 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Deallocate
);
32528 end Storage_Model_Deallocate
;
32530 -----------------------------
32531 -- Storage_Model_Copy_From --
32532 -----------------------------
32534 function Storage_Model_Copy_From
32535 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
32538 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Copy_From
);
32539 end Storage_Model_Copy_From
;
32541 ---------------------------
32542 -- Storage_Model_Copy_To --
32543 ---------------------------
32545 function Storage_Model_Copy_To
32546 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
32549 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Copy_To
);
32550 end Storage_Model_Copy_To
;
32552 --------------------------------
32553 -- Storage_Model_Storage_Size --
32554 --------------------------------
32556 function Storage_Model_Storage_Size
32557 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
32561 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Storage_Size
);
32562 end Storage_Model_Storage_Size
;
32564 end Storage_Model_Support
;
32567 Erroutc
.Subprogram_Name_Ptr
:= Subprogram_Name
'Access;