1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, 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 Elists
; use Elists
;
30 with Errout
; use Errout
;
31 with Erroutc
; use Erroutc
;
32 with Exp_Ch3
; use Exp_Ch3
;
33 with Exp_Ch11
; use Exp_Ch11
;
34 with Exp_Util
; use Exp_Util
;
35 with Fname
; use Fname
;
36 with Freeze
; use Freeze
;
37 with Itypes
; use Itypes
;
39 with Lib
.Xref
; use Lib
.Xref
;
40 with Namet
.Sp
; use Namet
.Sp
;
41 with Nlists
; use Nlists
;
42 with Nmake
; use Nmake
;
43 with Output
; use Output
;
44 with Restrict
; use Restrict
;
45 with Rident
; use Rident
;
46 with Rtsfind
; use Rtsfind
;
48 with Sem_Aux
; use Sem_Aux
;
49 with Sem_Attr
; use Sem_Attr
;
50 with Sem_Cat
; use Sem_Cat
;
51 with Sem_Ch6
; use Sem_Ch6
;
52 with Sem_Ch8
; use Sem_Ch8
;
53 with Sem_Ch13
; use Sem_Ch13
;
54 with Sem_Disp
; use Sem_Disp
;
55 with Sem_Elab
; use Sem_Elab
;
56 with Sem_Eval
; use Sem_Eval
;
57 with Sem_Prag
; use Sem_Prag
;
58 with Sem_Res
; use Sem_Res
;
59 with Sem_Warn
; use Sem_Warn
;
60 with Sem_Type
; use Sem_Type
;
61 with Sinfo
; use Sinfo
;
62 with Sinput
; use Sinput
;
63 with Stand
; use Stand
;
65 with Stringt
; use Stringt
;
66 with Targparm
; use Targparm
;
67 with Tbuild
; use Tbuild
;
68 with Ttypes
; use Ttypes
;
69 with Uname
; use Uname
;
71 with GNAT
.Heap_Sort_G
;
72 with GNAT
.HTable
; use GNAT
.HTable
;
74 package body Sem_Util
is
76 ---------------------------
77 -- Local Data Structures --
78 ---------------------------
80 Invalid_Binder_Values
: array (Scalar_Id
) of Entity_Id
:= (others => Empty
);
81 -- A collection to hold the entities of the variables declared in package
82 -- System.Scalar_Values which describe the invalid values of scalar types.
84 Invalid_Binder_Values_Set
: Boolean := False;
85 -- This flag prevents multiple attempts to initialize Invalid_Binder_Values
87 Invalid_Floats
: array (Float_Scalar_Id
) of Ureal
:= (others => No_Ureal
);
88 -- A collection to hold the invalid values of float types as specified by
89 -- pragma Initialize_Scalars.
91 Invalid_Integers
: array (Integer_Scalar_Id
) of Uint
:= (others => No_Uint
);
92 -- A collection to hold the invalid values of integer types as specified
93 -- by pragma Initialize_Scalars.
95 -----------------------
96 -- Local Subprograms --
97 -----------------------
99 function Build_Component_Subtype
102 T
: Entity_Id
) return Node_Id
;
103 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
104 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
105 -- Loc is the source location, T is the original subtype.
107 procedure Examine_Array_Bounds
109 All_Static
: out Boolean;
110 Has_Empty
: out Boolean);
111 -- Inspect the index constraints of array type Typ. Flag All_Static is set
112 -- when all ranges are static. Flag Has_Empty is set only when All_Static
113 -- is set and indicates that at least one range is empty.
115 function Has_Enabled_Property
116 (Item_Id
: Entity_Id
;
117 Property
: Name_Id
) return Boolean;
118 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
119 -- Determine whether the state abstraction, object, or type denoted by
120 -- entity Item_Id has enabled property Property.
122 function Has_Null_Extension
(T
: Entity_Id
) return Boolean;
123 -- T is a derived tagged type. Check whether the type extension is null.
124 -- If the parent type is fully initialized, T can be treated as such.
126 function Is_Atomic_Object_Entity
(Id
: Entity_Id
) return Boolean;
127 -- Determine whether arbitrary entity Id denotes an atomic object as per
130 function Is_Container_Aggregate
(Exp
: Node_Id
) return Boolean;
131 -- Is the given expression a container aggregate?
134 with function Is_Effectively_Volatile_Entity
135 (Id
: Entity_Id
) return Boolean;
136 -- Function to use on object and type entities
137 function Is_Effectively_Volatile_Object_Shared
138 (N
: Node_Id
) return Boolean;
139 -- Shared function used to detect effectively volatile objects and
140 -- effectively volatile objects for reading.
142 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean;
143 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
144 -- with discriminants whose default values are static, examine only the
145 -- components in the selected variant to determine whether all of them
148 function Is_Preelaborable_Function
(Id
: Entity_Id
) return Boolean;
149 -- Ada 2020: Determine whether the specified function is suitable as the
150 -- name of a call in a preelaborable construct (RM 10.2.1(7/5)).
152 type Null_Status_Kind
is
154 -- This value indicates that a subexpression is known to have a null
155 -- value at compile time.
158 -- This value indicates that a subexpression is known to have a non-null
159 -- value at compile time.
162 -- This value indicates that it cannot be determined at compile time
163 -- whether a subexpression yields a null or non-null value.
165 function Null_Status
(N
: Node_Id
) return Null_Status_Kind
;
166 -- Determine whether subexpression N of an access type yields a null value,
167 -- a non-null value, or the value cannot be determined at compile time. The
168 -- routine does not take simple flow diagnostics into account, it relies on
169 -- static facts such as the presence of null exclusions.
171 function Subprogram_Name
(N
: Node_Id
) return String;
172 -- Return the fully qualified name of the enclosing subprogram for the
173 -- given node N, with file:line:col information appended, e.g.
174 -- "subp:file:line:col", corresponding to the source location of the
175 -- body of the subprogram.
177 ------------------------------
178 -- Abstract_Interface_List --
179 ------------------------------
181 function Abstract_Interface_List
(Typ
: Entity_Id
) return List_Id
is
185 if Is_Concurrent_Type
(Typ
) then
187 -- If we are dealing with a synchronized subtype, go to the base
188 -- type, whose declaration has the interface list.
190 Nod
:= Declaration_Node
(Base_Type
(Typ
));
192 if Nkind
(Nod
) in N_Full_Type_Declaration | N_Private_Type_Declaration
197 elsif Ekind
(Typ
) = E_Record_Type_With_Private
then
198 if Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
then
199 Nod
:= Type_Definition
(Parent
(Typ
));
201 elsif Nkind
(Parent
(Typ
)) = N_Private_Type_Declaration
then
202 if Present
(Full_View
(Typ
))
204 Nkind
(Parent
(Full_View
(Typ
))) = N_Full_Type_Declaration
206 Nod
:= Type_Definition
(Parent
(Full_View
(Typ
)));
208 -- If the full-view is not available we cannot do anything else
209 -- here (the source has errors).
215 -- Support for generic formals with interfaces is still missing ???
217 elsif Nkind
(Parent
(Typ
)) = N_Formal_Type_Declaration
then
222 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
);
226 elsif Ekind
(Typ
) = E_Record_Subtype
then
227 Nod
:= Type_Definition
(Parent
(Etype
(Typ
)));
229 elsif Ekind
(Typ
) = E_Record_Subtype_With_Private
then
231 -- Recurse, because parent may still be a private extension. Also
232 -- note that the full view of the subtype or the full view of its
233 -- base type may (both) be unavailable.
235 return Abstract_Interface_List
(Etype
(Typ
));
237 elsif Ekind
(Typ
) = E_Record_Type
then
238 if Nkind
(Parent
(Typ
)) = N_Formal_Type_Declaration
then
239 Nod
:= Formal_Type_Definition
(Parent
(Typ
));
241 Nod
:= Type_Definition
(Parent
(Typ
));
244 -- Otherwise the type is of a kind which does not implement interfaces
250 return Interface_List
(Nod
);
251 end Abstract_Interface_List
;
253 -------------------------
254 -- Accessibility_Level --
255 -------------------------
257 function Accessibility_Level
259 Level
: Accessibility_Level_Kind
;
260 In_Return_Context
: Boolean := False) return Node_Id
262 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
264 function Accessibility_Level
(Expr
: Node_Id
) return Node_Id
265 is (Accessibility_Level
(Expr
, Level
, In_Return_Context
));
266 -- Renaming of the enclosing function to facilitate recursive calls
268 function Make_Level_Literal
(Level
: Uint
) return Node_Id
;
269 -- Construct an integer literal representing an accessibility level
270 -- with its type set to Natural.
272 function Innermost_Master_Scope_Depth
273 (N
: Node_Id
) return Uint
;
274 -- Returns the scope depth of the given node's innermost
275 -- enclosing dynamic scope (effectively the accessibility
276 -- level of the innermost enclosing master).
278 function Function_Call_Or_Allocator_Level
279 (N
: Node_Id
) return Node_Id
;
280 -- Centralized processing of subprogram calls which may appear in
283 ----------------------------------
284 -- Innermost_Master_Scope_Depth --
285 ----------------------------------
287 function Innermost_Master_Scope_Depth
288 (N
: Node_Id
) return Uint
290 Encl_Scop
: Entity_Id
;
291 Node_Par
: Node_Id
:= Parent
(N
);
292 Master_Lvl_Modifier
: Int
:= 0;
295 -- Locate the nearest enclosing node (by traversing Parents)
296 -- that Defining_Entity can be applied to, and return the
297 -- depth of that entity's nearest enclosing dynamic scope.
299 -- The rules that define what a master are defined in
300 -- RM 7.6.1 (3), and include statements and conditions for loops
301 -- among other things. These cases are detected properly ???
303 while Present
(Node_Par
) loop
305 if Present
(Defining_Entity
306 (Node_Par
, Empty_On_Errors
=> True))
308 Encl_Scop
:= Nearest_Dynamic_Scope
309 (Defining_Entity
(Node_Par
));
311 -- Ignore transient scopes made during expansion
313 if Comes_From_Source
(Node_Par
) then
314 return Scope_Depth
(Encl_Scop
) + Master_Lvl_Modifier
;
317 -- For a return statement within a function, return
318 -- the depth of the function itself. This is not just
319 -- a small optimization, but matters when analyzing
320 -- the expression in an expression function before
321 -- the body is created.
323 elsif Nkind
(Node_Par
) in N_Extended_Return_Statement
324 | N_Simple_Return_Statement
325 and then Ekind
(Current_Scope
) = E_Function
327 return Scope_Depth
(Current_Scope
);
329 -- Statements are counted as masters
331 elsif Is_Master
(Node_Par
) then
332 Master_Lvl_Modifier
:= Master_Lvl_Modifier
+ 1;
336 Node_Par
:= Parent
(Node_Par
);
339 -- Should never reach the following return
341 pragma Assert
(False);
343 return Scope_Depth
(Current_Scope
) + 1;
344 end Innermost_Master_Scope_Depth
;
346 ------------------------
347 -- Make_Level_Literal --
348 ------------------------
350 function Make_Level_Literal
(Level
: Uint
) return Node_Id
is
351 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Level
);
354 Set_Etype
(Result
, Standard_Natural
);
356 end Make_Level_Literal
;
358 --------------------------------------
359 -- Function_Call_Or_Allocator_Level --
360 --------------------------------------
362 function Function_Call_Or_Allocator_Level
(N
: Node_Id
) return Node_Id
is
366 -- Results of functions are objects, so we either get the
367 -- accessibility of the function or, in case of a call which is
368 -- indirect, the level of the access-to-subprogram type.
370 -- This code looks wrong ???
372 if Nkind
(N
) = N_Function_Call
373 and then Ada_Version
< Ada_2005
375 if Is_Entity_Name
(Name
(N
)) then
376 return Make_Level_Literal
377 (Subprogram_Access_Level
(Entity
(Name
(N
))));
379 return Make_Level_Literal
380 (Type_Access_Level
(Etype
(Prefix
(Name
(N
)))));
383 -- We ignore coextensions as they cannot be implemented under the
384 -- "small-integer" model.
386 elsif Nkind
(N
) = N_Allocator
387 and then (Is_Static_Coextension
(N
)
388 or else Is_Dynamic_Coextension
(N
))
390 return Make_Level_Literal
391 (Scope_Depth
(Standard_Standard
));
394 -- Named access types have a designated level
396 if Is_Named_Access_Type
(Etype
(N
)) then
397 return Make_Level_Literal
(Type_Access_Level
(Etype
(N
)));
399 -- Otherwise, the level is dictated by RM 3.10.2 (10.7/3)
402 if Nkind
(N
) = N_Function_Call
then
403 -- Dynamic checks are generated when we are within a return
404 -- value or we are in a function call within an anonymous
405 -- access discriminant constraint of a return object (signified
406 -- by In_Return_Context) on the side of the callee.
408 -- So, in this case, return library accessibility level to null
409 -- out the check on the side of the caller.
411 if In_Return_Value
(N
)
412 or else In_Return_Context
414 return Make_Level_Literal
415 (Subprogram_Access_Level
(Current_Subprogram
));
419 -- Find any relevant enclosing parent nodes that designate an
420 -- object being initialized.
422 -- Note: The above is only relevant if the result is used "in its
423 -- entirety" as RM 3.10.2 (10.2/3) states. However, this is
424 -- accounted for in the case statement in the main body of
425 -- Accessibility_Level for N_Selected_Component.
427 Par
:= Parent
(Expr
);
429 while Present
(Par
) loop
430 -- Detect an expanded implicit conversion, typically this
431 -- occurs on implicitly converted actuals in calls.
433 -- Does this catch all implicit conversions ???
435 if Nkind
(Par
) = N_Type_Conversion
436 and then Is_Named_Access_Type
(Etype
(Par
))
438 return Make_Level_Literal
439 (Type_Access_Level
(Etype
(Par
)));
442 -- Jump out when we hit an object declaration or the right-hand
443 -- side of an assignment, or a construct such as an aggregate
444 -- subtype indication which would be the result is not used
445 -- "in its entirety."
447 exit when Nkind
(Par
) in N_Object_Declaration
448 or else (Nkind
(Par
) = N_Assignment_Statement
449 and then Name
(Par
) /= Prev_Par
);
455 -- Assignment statements are handled in a similar way in
456 -- accordance to the left-hand part. However, strictly speaking,
457 -- this is illegal according to the RM, but this change is needed
458 -- to pass an ACATS C-test and is useful in general ???
461 when N_Object_Declaration
=>
462 return Make_Level_Literal
464 (Scope
(Defining_Identifier
(Par
))));
466 when N_Assignment_Statement
=>
467 -- Return the accessiblity level of the left-hand part
469 return Accessibility_Level
471 Level
=> Object_Decl_Level
,
472 In_Return_Context
=> In_Return_Context
);
475 return Make_Level_Literal
476 (Innermost_Master_Scope_Depth
(Expr
));
479 end Function_Call_Or_Allocator_Level
;
483 E
: Entity_Id
:= Original_Node
(Expr
);
486 -- Start of processing for Accessibility_Level
489 -- We could be looking at a reference to a formal due to the expansion
490 -- of entries and other cases, so obtain the renaming if necessary.
492 if Present
(Param_Entity
(Expr
)) then
493 E
:= Param_Entity
(Expr
);
496 -- Extract the entity
498 if Nkind
(E
) in N_Has_Entity
and then Present
(Entity
(E
)) then
501 -- Deal with a possible renaming of a private protected component
503 if Ekind
(E
) in E_Constant | E_Variable
and then Is_Prival
(E
) then
504 E
:= Prival_Link
(E
);
508 -- Perform the processing on the expression
511 -- The level of an aggregate is that of the innermost master that
512 -- evaluates it as defined in RM 3.10.2 (10/4).
515 return Make_Level_Literal
(Innermost_Master_Scope_Depth
(Expr
));
517 -- The accessibility level is that of the access type, except for an
518 -- anonymous allocators which have special rules defined in RM 3.10.2
522 return Function_Call_Or_Allocator_Level
(E
);
524 -- We could reach this point for two reasons. Either the expression
525 -- applies to a special attribute ('Loop_Entry, 'Result, or 'Old), or
526 -- we are looking at the access attributes directly ('Access,
527 -- 'Address, or 'Unchecked_Access).
529 when N_Attribute_Reference
=>
530 Pre
:= Original_Node
(Prefix
(E
));
532 -- Regular 'Access attribute presence means we have to look at the
535 if Attribute_Name
(E
) = Name_Access
then
536 return Accessibility_Level
(Prefix
(E
));
538 -- Unchecked or unrestricted attributes have unlimited depth
540 elsif Attribute_Name
(E
) in Name_Address
541 | Name_Unchecked_Access
542 | Name_Unrestricted_Access
544 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
546 -- 'Access can be taken further against other special attributes,
547 -- so handle these cases explicitly.
549 elsif Attribute_Name
(E
)
550 in Name_Old | Name_Loop_Entry | Name_Result
552 -- Named access types
554 if Is_Named_Access_Type
(Etype
(Pre
)) then
555 return Make_Level_Literal
556 (Type_Access_Level
(Etype
(Pre
)));
558 -- Anonymous access types
560 elsif Nkind
(Pre
) in N_Has_Entity
561 and then Present
(Get_Dynamic_Accessibility
(Entity
(Pre
)))
562 and then Level
= Dynamic_Level
564 return New_Occurrence_Of
565 (Get_Dynamic_Accessibility
(Entity
(Pre
)), Loc
);
567 -- Otherwise the level is treated in a similar way as
568 -- aggregates according to RM 6.1.1 (35.1/4) which concerns
569 -- an implicit constant declaration - in turn defining the
570 -- accessibility level to be that of the implicit constant
574 return Make_Level_Literal
575 (Innermost_Master_Scope_Depth
(Expr
));
582 -- This is the "base case" for accessibility level calculations which
583 -- means we are near the end of our recursive traversal.
585 when N_Defining_Identifier
=>
586 -- A dynamic check is performed on the side of the callee when we
587 -- are within a return statement, so return a library-level
588 -- accessibility level to null out checks on the side of the
591 if Is_Explicitly_Aliased
(E
)
592 and then Level
/= Dynamic_Level
593 and then (In_Return_Value
(Expr
)
594 or else In_Return_Context
)
596 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
598 -- Something went wrong and an extra accessibility formal has not
599 -- been generated when one should have ???
602 and then not Present
(Get_Dynamic_Accessibility
(E
))
603 and then Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
605 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
607 -- Stand-alone object of an anonymous access type "SAOAAT"
610 or else Ekind
(E
) in E_Variable
612 and then Present
(Get_Dynamic_Accessibility
(E
))
613 and then (Level
= Dynamic_Level
614 or else Level
= Zero_On_Dynamic_Level
)
616 if Level
= Zero_On_Dynamic_Level
then
617 return Make_Level_Literal
618 (Scope_Depth
(Standard_Standard
));
622 New_Occurrence_Of
(Get_Dynamic_Accessibility
(E
), Loc
);
624 -- Initialization procedures have a special extra accessitility
625 -- parameter associated with the level at which the object
626 -- begin initialized exists
628 elsif Ekind
(E
) = E_Record_Type
629 and then Is_Limited_Record
(E
)
630 and then Current_Scope
= Init_Proc
(E
)
631 and then Present
(Init_Proc_Level_Formal
(Current_Scope
))
633 return New_Occurrence_Of
634 (Init_Proc_Level_Formal
(Current_Scope
), Loc
);
636 -- Current instance of the type is deeper than that of the type
637 -- according to RM 3.10.2 (21).
639 elsif Is_Type
(E
) then
640 return Make_Level_Literal
641 (Type_Access_Level
(E
) + 1);
643 -- Move up the renamed entity if it came from source since
644 -- expansion may have created a dummy renaming under certain
647 elsif Present
(Renamed_Object
(E
))
648 and then Comes_From_Source
(Renamed_Object
(E
))
650 return Accessibility_Level
(Renamed_Object
(E
));
652 -- Named access types get their level from their associated type
654 elsif Is_Named_Access_Type
(Etype
(E
)) then
655 return Make_Level_Literal
656 (Type_Access_Level
(Etype
(E
)));
658 -- When E is a component of the current instance of a
659 -- protected type, we assume the level to be deeper than that of
662 elsif not Is_Overloadable
(E
)
663 and then Ekind
(Scope
(E
)) = E_Protected_Type
664 and then Comes_From_Source
(Scope
(E
))
666 return Make_Level_Literal
667 (Scope_Depth
(Enclosing_Dynamic_Scope
(E
)) + 1);
669 -- Normal object - get the level of the enclosing scope
672 return Make_Level_Literal
673 (Scope_Depth
(Enclosing_Dynamic_Scope
(E
)));
676 -- Handle indexed and selected components including the special cases
677 -- whereby there is an implicit dereference, a component of a
678 -- composite type, or a function call in prefix notation.
680 -- We don't handle function calls in prefix notation correctly ???
682 when N_Indexed_Component | N_Selected_Component
=>
683 Pre
:= Original_Node
(Prefix
(E
));
685 -- When E is an indexed component or selected component and
686 -- the current Expr is a function call, we know that we are
687 -- looking at an expanded call in prefix notation.
689 if Nkind
(Expr
) = N_Function_Call
then
690 return Function_Call_Or_Allocator_Level
(Expr
);
692 -- If the prefix is a named access type, then we are dealing
693 -- with an implicit deferences. In that case the level is that
694 -- of the named access type in the prefix.
696 elsif Is_Named_Access_Type
(Etype
(Pre
)) then
697 return Make_Level_Literal
698 (Type_Access_Level
(Etype
(Pre
)));
700 -- The current expression is a named access type, so there is no
701 -- reason to look at the prefix. Instead obtain the level of E's
702 -- named access type.
704 elsif Is_Named_Access_Type
(Etype
(E
)) then
705 return Make_Level_Literal
706 (Type_Access_Level
(Etype
(E
)));
708 -- A non-discriminant selected component where the component
709 -- is an anonymous access type means that its associated
710 -- level is that of the containing type - see RM 3.10.2 (16).
712 elsif Nkind
(E
) = N_Selected_Component
713 and then Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
714 and then Ekind
(Etype
(Pre
)) /= E_Anonymous_Access_Type
715 and then not (Nkind
(Selector_Name
(E
)) in N_Has_Entity
716 and then Ekind
(Entity
(Selector_Name
(E
)))
719 return Make_Level_Literal
720 (Type_Access_Level
(Etype
(Prefix
(E
))));
722 -- Similar to the previous case - arrays featuring components of
723 -- anonymous access components get their corresponding level from
724 -- their containing type's declaration.
726 elsif Nkind
(E
) = N_Indexed_Component
727 and then Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
728 and then Ekind
(Etype
(Pre
)) in Array_Kind
729 and then Ekind
(Component_Type
(Base_Type
(Etype
(Pre
))))
730 = E_Anonymous_Access_Type
732 return Make_Level_Literal
733 (Type_Access_Level
(Etype
(Prefix
(E
))));
735 -- The accessibility calculation routine that handles function
736 -- calls (Function_Call_Level) assumes, in the case the
737 -- result is of an anonymous access type, that the result will be
738 -- used "in its entirety" when the call is present within an
739 -- assignment or object declaration.
741 -- To properly handle cases where the result is not used in its
742 -- entirety, we test if the prefix of the component in question is
743 -- a function call, which tells us that one of its components has
744 -- been identified and is being accessed. Therefore we can
745 -- conclude that the result is not used "in its entirety"
746 -- according to RM 3.10.2 (10.2/3).
748 elsif Nkind
(Pre
) = N_Function_Call
749 and then not Is_Named_Access_Type
(Etype
(Pre
))
751 -- Dynamic checks are generated when we are within a return
752 -- value or we are in a function call within an anonymous
753 -- access discriminant constraint of a return object (signified
754 -- by In_Return_Context) on the side of the callee.
756 -- So, in this case, return a library accessibility level to
757 -- null out the check on the side of the caller.
759 if (In_Return_Value
(E
)
760 or else In_Return_Context
)
761 and then Level
/= Dynamic_Level
763 return Make_Level_Literal
764 (Scope_Depth
(Standard_Standard
));
767 return Make_Level_Literal
768 (Innermost_Master_Scope_Depth
(Expr
));
770 -- Otherwise, continue recursing over the expression prefixes
773 return Accessibility_Level
(Prefix
(E
));
776 -- Qualified expressions
778 when N_Qualified_Expression
=>
779 if Is_Named_Access_Type
(Etype
(E
)) then
780 return Make_Level_Literal
781 (Type_Access_Level
(Etype
(E
)));
783 return Accessibility_Level
(Expression
(E
));
786 -- Handle function calls
788 when N_Function_Call
=>
789 return Function_Call_Or_Allocator_Level
(E
);
791 -- Explicit dereference accessibility level calculation
793 when N_Explicit_Dereference
=>
794 Pre
:= Original_Node
(Prefix
(E
));
796 -- The prefix is a named access type so the level is taken from
799 if Is_Named_Access_Type
(Etype
(Pre
)) then
800 return Make_Level_Literal
(Type_Access_Level
(Etype
(Pre
)));
802 -- Otherwise, recurse deeper
805 return Accessibility_Level
(Prefix
(E
));
810 when N_Type_Conversion | N_Unchecked_Type_Conversion
=>
811 -- View conversions are special in that they require use to
812 -- inspect the expression of the type conversion.
814 -- Allocators of anonymous access types are internally generated,
815 -- so recurse deeper in that case as well.
817 if Is_View_Conversion
(E
)
818 or else Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
820 return Accessibility_Level
(Expression
(E
));
822 -- We don't care about the master if we are looking at a named
825 elsif Is_Named_Access_Type
(Etype
(E
)) then
826 return Make_Level_Literal
827 (Type_Access_Level
(Etype
(E
)));
829 -- In section RM 3.10.2 (10/4) the accessibility rules for
830 -- aggregates and value conversions are outlined. Are these
831 -- followed in the case of initialization of an object ???
833 -- Should use Innermost_Master_Scope_Depth ???
836 return Accessibility_Level
(Current_Scope
);
839 -- Default to the type accessibility level for the type of the
840 -- expression's entity.
843 return Make_Level_Literal
(Type_Access_Level
(Etype
(E
)));
845 end Accessibility_Level
;
847 --------------------------------
848 -- Static_Accessibility_Level --
849 --------------------------------
851 function Static_Accessibility_Level
853 Level
: Static_Accessibility_Level_Kind
;
854 In_Return_Context
: Boolean := False) return Uint
858 (Accessibility_Level
(Expr
, Level
, In_Return_Context
));
859 end Static_Accessibility_Level
;
861 ----------------------------------
862 -- Acquire_Warning_Match_String --
863 ----------------------------------
865 function Acquire_Warning_Match_String
(Str_Lit
: Node_Id
) return String is
866 S
: constant String := To_String
(Strval
(Str_Lit
));
871 -- Put "*" before or after or both, if it's not already there
874 F
: constant Boolean := S
(S
'First) = '*';
875 L
: constant Boolean := S
(S
'Last) = '*';
887 return "*" & S
& "*";
892 end Acquire_Warning_Match_String
;
894 --------------------------------
895 -- Add_Access_Type_To_Process --
896 --------------------------------
898 procedure Add_Access_Type_To_Process
(E
: Entity_Id
; A
: Entity_Id
) is
902 Ensure_Freeze_Node
(E
);
903 L
:= Access_Types_To_Process
(Freeze_Node
(E
));
907 Set_Access_Types_To_Process
(Freeze_Node
(E
), L
);
911 end Add_Access_Type_To_Process
;
913 --------------------------
914 -- Add_Block_Identifier --
915 --------------------------
917 procedure Add_Block_Identifier
(N
: Node_Id
; Id
: out Entity_Id
) is
918 Loc
: constant Source_Ptr
:= Sloc
(N
);
920 pragma Assert
(Nkind
(N
) = N_Block_Statement
);
922 -- The block already has a label, return its entity
924 if Present
(Identifier
(N
)) then
925 Id
:= Entity
(Identifier
(N
));
927 -- Create a new block label and set its attributes
930 Id
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
931 Set_Etype
(Id
, Standard_Void_Type
);
934 Set_Identifier
(N
, New_Occurrence_Of
(Id
, Loc
));
935 Set_Block_Node
(Id
, Identifier
(N
));
937 end Add_Block_Identifier
;
939 ----------------------------
940 -- Add_Global_Declaration --
941 ----------------------------
943 procedure Add_Global_Declaration
(N
: Node_Id
) is
944 Aux_Node
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Current_Sem_Unit
));
947 if No
(Declarations
(Aux_Node
)) then
948 Set_Declarations
(Aux_Node
, New_List
);
951 Append_To
(Declarations
(Aux_Node
), N
);
953 end Add_Global_Declaration
;
955 --------------------------------
956 -- Address_Integer_Convert_OK --
957 --------------------------------
959 function Address_Integer_Convert_OK
(T1
, T2
: Entity_Id
) return Boolean is
961 if Allow_Integer_Address
962 and then ((Is_Descendant_Of_Address
(T1
)
963 and then Is_Private_Type
(T1
)
964 and then Is_Integer_Type
(T2
))
966 (Is_Descendant_Of_Address
(T2
)
967 and then Is_Private_Type
(T2
)
968 and then Is_Integer_Type
(T1
)))
974 end Address_Integer_Convert_OK
;
980 function Address_Value
(N
: Node_Id
) return Node_Id
is
985 -- For constant, get constant expression
987 if Is_Entity_Name
(Expr
)
988 and then Ekind
(Entity
(Expr
)) = E_Constant
990 Expr
:= Constant_Value
(Entity
(Expr
));
992 -- For unchecked conversion, get result to convert
994 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
995 Expr
:= Expression
(Expr
);
997 -- For (common case) of To_Address call, get argument
999 elsif Nkind
(Expr
) = N_Function_Call
1000 and then Is_Entity_Name
(Name
(Expr
))
1001 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
1003 Expr
:= First
(Parameter_Associations
(Expr
));
1005 if Nkind
(Expr
) = N_Parameter_Association
then
1006 Expr
:= Explicit_Actual_Parameter
(Expr
);
1009 -- We finally have the real expression
1023 function Addressable
(V
: Uint
) return Boolean is
1025 return V
= Uint_8
or else
1029 (V
= Uint_128
and then System_Max_Integer_Size
= 128);
1032 function Addressable
(V
: Int
) return Boolean is
1034 return V
= 8 or else
1038 V
= System_Max_Integer_Size
;
1041 ---------------------------------
1042 -- Aggregate_Constraint_Checks --
1043 ---------------------------------
1045 procedure Aggregate_Constraint_Checks
1047 Check_Typ
: Entity_Id
)
1049 Exp_Typ
: constant Entity_Id
:= Etype
(Exp
);
1052 if Raises_Constraint_Error
(Exp
) then
1056 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access
1057 -- component's type to force the appropriate accessibility checks.
1059 -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to
1060 -- force the corresponding run-time check
1062 if Is_Access_Type
(Check_Typ
)
1063 and then Is_Local_Anonymous_Access
(Check_Typ
)
1065 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
1066 Analyze_And_Resolve
(Exp
, Check_Typ
);
1067 Check_Unset_Reference
(Exp
);
1070 -- What follows is really expansion activity, so check that expansion
1071 -- is on and is allowed. In GNATprove mode, we also want check flags to
1072 -- be added in the tree, so that the formal verification can rely on
1073 -- those to be present. In GNATprove mode for formal verification, some
1074 -- treatment typically only done during expansion needs to be performed
1075 -- on the tree, but it should not be applied inside generics. Otherwise,
1076 -- this breaks the name resolution mechanism for generic instances.
1078 if not Expander_Active
1079 and (Inside_A_Generic
or not Full_Analysis
or not GNATprove_Mode
)
1084 if Is_Access_Type
(Check_Typ
)
1085 and then Can_Never_Be_Null
(Check_Typ
)
1086 and then not Can_Never_Be_Null
(Exp_Typ
)
1088 Install_Null_Excluding_Check
(Exp
);
1091 -- First check if we have to insert discriminant checks
1093 if Has_Discriminants
(Exp_Typ
) then
1094 Apply_Discriminant_Check
(Exp
, Check_Typ
);
1096 -- Next emit length checks for array aggregates
1098 elsif Is_Array_Type
(Exp_Typ
) then
1099 Apply_Length_Check
(Exp
, Check_Typ
);
1101 -- Finally emit scalar and string checks. If we are dealing with a
1102 -- scalar literal we need to check by hand because the Etype of
1103 -- literals is not necessarily correct.
1105 elsif Is_Scalar_Type
(Exp_Typ
)
1106 and then Compile_Time_Known_Value
(Exp
)
1108 if Is_Out_Of_Range
(Exp
, Base_Type
(Check_Typ
)) then
1109 Apply_Compile_Time_Constraint_Error
1110 (Exp
, "value not in range of}??", CE_Range_Check_Failed
,
1111 Ent
=> Base_Type
(Check_Typ
),
1112 Typ
=> Base_Type
(Check_Typ
));
1114 elsif Is_Out_Of_Range
(Exp
, Check_Typ
) then
1115 Apply_Compile_Time_Constraint_Error
1116 (Exp
, "value not in range of}??", CE_Range_Check_Failed
,
1120 elsif not Range_Checks_Suppressed
(Check_Typ
) then
1121 Apply_Scalar_Range_Check
(Exp
, Check_Typ
);
1124 -- Verify that target type is also scalar, to prevent view anomalies
1125 -- in instantiations.
1127 elsif (Is_Scalar_Type
(Exp_Typ
)
1128 or else Nkind
(Exp
) = N_String_Literal
)
1129 and then Is_Scalar_Type
(Check_Typ
)
1130 and then Exp_Typ
/= Check_Typ
1132 if Is_Entity_Name
(Exp
)
1133 and then Ekind
(Entity
(Exp
)) = E_Constant
1135 -- If expression is a constant, it is worthwhile checking whether
1136 -- it is a bound of the type.
1138 if (Is_Entity_Name
(Type_Low_Bound
(Check_Typ
))
1139 and then Entity
(Exp
) = Entity
(Type_Low_Bound
(Check_Typ
)))
1141 (Is_Entity_Name
(Type_High_Bound
(Check_Typ
))
1142 and then Entity
(Exp
) = Entity
(Type_High_Bound
(Check_Typ
)))
1147 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
1148 Analyze_And_Resolve
(Exp
, Check_Typ
);
1149 Check_Unset_Reference
(Exp
);
1152 -- Could use a comment on this case ???
1155 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
1156 Analyze_And_Resolve
(Exp
, Check_Typ
);
1157 Check_Unset_Reference
(Exp
);
1161 end Aggregate_Constraint_Checks
;
1163 -----------------------
1164 -- Alignment_In_Bits --
1165 -----------------------
1167 function Alignment_In_Bits
(E
: Entity_Id
) return Uint
is
1169 return Alignment
(E
) * System_Storage_Unit
;
1170 end Alignment_In_Bits
;
1172 --------------------------------------
1173 -- All_Composite_Constraints_Static --
1174 --------------------------------------
1176 function All_Composite_Constraints_Static
1177 (Constr
: Node_Id
) return Boolean
1180 if No
(Constr
) or else Error_Posted
(Constr
) then
1184 case Nkind
(Constr
) is
1186 if Nkind
(Constr
) in N_Has_Entity
1187 and then Present
(Entity
(Constr
))
1189 if Is_Type
(Entity
(Constr
)) then
1191 not Is_Discrete_Type
(Entity
(Constr
))
1192 or else Is_OK_Static_Subtype
(Entity
(Constr
));
1195 elsif Nkind
(Constr
) = N_Range
then
1197 Is_OK_Static_Expression
(Low_Bound
(Constr
))
1199 Is_OK_Static_Expression
(High_Bound
(Constr
));
1201 elsif Nkind
(Constr
) = N_Attribute_Reference
1202 and then Attribute_Name
(Constr
) = Name_Range
1205 Is_OK_Static_Expression
1206 (Type_Low_Bound
(Etype
(Prefix
(Constr
))))
1208 Is_OK_Static_Expression
1209 (Type_High_Bound
(Etype
(Prefix
(Constr
))));
1213 not Present
(Etype
(Constr
)) -- previous error
1214 or else not Is_Discrete_Type
(Etype
(Constr
))
1215 or else Is_OK_Static_Expression
(Constr
);
1217 when N_Discriminant_Association
=>
1218 return All_Composite_Constraints_Static
(Expression
(Constr
));
1220 when N_Range_Constraint
=>
1222 All_Composite_Constraints_Static
(Range_Expression
(Constr
));
1224 when N_Index_Or_Discriminant_Constraint
=>
1226 One_Cstr
: Entity_Id
;
1228 One_Cstr
:= First
(Constraints
(Constr
));
1229 while Present
(One_Cstr
) loop
1230 if not All_Composite_Constraints_Static
(One_Cstr
) then
1240 when N_Subtype_Indication
=>
1242 All_Composite_Constraints_Static
(Subtype_Mark
(Constr
))
1244 All_Composite_Constraints_Static
(Constraint
(Constr
));
1247 raise Program_Error
;
1249 end All_Composite_Constraints_Static
;
1251 ------------------------
1252 -- Append_Entity_Name --
1253 ------------------------
1255 procedure Append_Entity_Name
(Buf
: in out Bounded_String
; E
: Entity_Id
) is
1256 Temp
: Bounded_String
;
1258 procedure Inner
(E
: Entity_Id
);
1259 -- Inner recursive routine, keep outer routine nonrecursive to ease
1260 -- debugging when we get strange results from this routine.
1266 procedure Inner
(E
: Entity_Id
) is
1270 -- If entity has an internal name, skip by it, and print its scope.
1271 -- Note that we strip a final R from the name before the test; this
1272 -- is needed for some cases of instantiations.
1275 E_Name
: Bounded_String
;
1278 Append
(E_Name
, Chars
(E
));
1280 if E_Name
.Chars
(E_Name
.Length
) = 'R' then
1281 E_Name
.Length
:= E_Name
.Length
- 1;
1284 if Is_Internal_Name
(E_Name
) then
1292 -- Just print entity name if its scope is at the outer level
1294 if Scop
= Standard_Standard
then
1297 -- If scope comes from source, write scope and entity
1299 elsif Comes_From_Source
(Scop
) then
1300 Append_Entity_Name
(Temp
, Scop
);
1303 -- If in wrapper package skip past it
1305 elsif Present
(Scop
) and then Is_Wrapper_Package
(Scop
) then
1306 Append_Entity_Name
(Temp
, Scope
(Scop
));
1309 -- Otherwise nothing to output (happens in unnamed block statements)
1318 E_Name
: Bounded_String
;
1321 Append_Unqualified_Decoded
(E_Name
, Chars
(E
));
1323 -- Remove trailing upper-case letters from the name (useful for
1324 -- dealing with some cases of internal names generated in the case
1325 -- of references from within a generic).
1327 while E_Name
.Length
> 1
1328 and then E_Name
.Chars
(E_Name
.Length
) in 'A' .. 'Z'
1330 E_Name
.Length
:= E_Name
.Length
- 1;
1333 -- Adjust casing appropriately (gets name from source if possible)
1335 Adjust_Name_Case
(E_Name
, Sloc
(E
));
1336 Append
(Temp
, E_Name
);
1340 -- Start of processing for Append_Entity_Name
1345 end Append_Entity_Name
;
1347 ---------------------------------
1348 -- Append_Inherited_Subprogram --
1349 ---------------------------------
1351 procedure Append_Inherited_Subprogram
(S
: Entity_Id
) is
1352 Par
: constant Entity_Id
:= Alias
(S
);
1353 -- The parent subprogram
1355 Scop
: constant Entity_Id
:= Scope
(Par
);
1356 -- The scope of definition of the parent subprogram
1358 Typ
: constant Entity_Id
:= Defining_Entity
(Parent
(S
));
1359 -- The derived type of which S is a primitive operation
1365 if Ekind
(Current_Scope
) = E_Package
1366 and then In_Private_Part
(Current_Scope
)
1367 and then Has_Private_Declaration
(Typ
)
1368 and then Is_Tagged_Type
(Typ
)
1369 and then Scop
= Current_Scope
1371 -- The inherited operation is available at the earliest place after
1372 -- the derived type declaration (RM 7.3.1 (6/1)). This is only
1373 -- relevant for type extensions. If the parent operation appears
1374 -- after the type extension, the operation is not visible.
1377 (Visible_Declarations
1378 (Package_Specification
(Current_Scope
)));
1379 while Present
(Decl
) loop
1380 if Nkind
(Decl
) = N_Private_Extension_Declaration
1381 and then Defining_Entity
(Decl
) = Typ
1383 if Sloc
(Decl
) > Sloc
(Par
) then
1384 Next_E
:= Next_Entity
(Par
);
1385 Link_Entities
(Par
, S
);
1386 Link_Entities
(S
, Next_E
);
1398 -- If partial view is not a type extension, or it appears before the
1399 -- subprogram declaration, insert normally at end of entity list.
1401 Append_Entity
(S
, Current_Scope
);
1402 end Append_Inherited_Subprogram
;
1404 -----------------------------------------
1405 -- Apply_Compile_Time_Constraint_Error --
1406 -----------------------------------------
1408 procedure Apply_Compile_Time_Constraint_Error
1411 Reason
: RT_Exception_Code
;
1412 Ent
: Entity_Id
:= Empty
;
1413 Typ
: Entity_Id
:= Empty
;
1414 Loc
: Source_Ptr
:= No_Location
;
1415 Rep
: Boolean := True;
1416 Warn
: Boolean := False)
1418 Stat
: constant Boolean := Is_Static_Expression
(N
);
1419 R_Stat
: constant Node_Id
:=
1420 Make_Raise_Constraint_Error
(Sloc
(N
), Reason
=> Reason
);
1431 (Compile_Time_Constraint_Error
(N
, Msg
, Ent
, Loc
, Warn
=> Warn
));
1433 -- In GNATprove mode, do not replace the node with an exception raised.
1434 -- In such a case, either the call to Compile_Time_Constraint_Error
1435 -- issues an error which stops analysis, or it issues a warning in
1436 -- a few cases where a suitable check flag is set for GNATprove to
1437 -- generate a check message.
1439 if not Rep
or GNATprove_Mode
then
1443 -- Now we replace the node by an N_Raise_Constraint_Error node
1444 -- This does not need reanalyzing, so set it as analyzed now.
1446 Rewrite
(N
, R_Stat
);
1447 Set_Analyzed
(N
, True);
1449 Set_Etype
(N
, Rtyp
);
1450 Set_Raises_Constraint_Error
(N
);
1452 -- Now deal with possible local raise handling
1454 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
1456 -- If the original expression was marked as static, the result is
1457 -- still marked as static, but the Raises_Constraint_Error flag is
1458 -- always set so that further static evaluation is not attempted.
1461 Set_Is_Static_Expression
(N
);
1463 end Apply_Compile_Time_Constraint_Error
;
1465 ---------------------------
1466 -- Async_Readers_Enabled --
1467 ---------------------------
1469 function Async_Readers_Enabled
(Id
: Entity_Id
) return Boolean is
1471 return Has_Enabled_Property
(Id
, Name_Async_Readers
);
1472 end Async_Readers_Enabled
;
1474 ---------------------------
1475 -- Async_Writers_Enabled --
1476 ---------------------------
1478 function Async_Writers_Enabled
(Id
: Entity_Id
) return Boolean is
1480 return Has_Enabled_Property
(Id
, Name_Async_Writers
);
1481 end Async_Writers_Enabled
;
1483 --------------------------------------
1484 -- Available_Full_View_Of_Component --
1485 --------------------------------------
1487 function Available_Full_View_Of_Component
(T
: Entity_Id
) return Boolean is
1488 ST
: constant Entity_Id
:= Scope
(T
);
1489 SCT
: constant Entity_Id
:= Scope
(Component_Type
(T
));
1491 return In_Open_Scopes
(ST
)
1492 and then In_Open_Scopes
(SCT
)
1493 and then Scope_Depth
(ST
) >= Scope_Depth
(SCT
);
1494 end Available_Full_View_Of_Component
;
1500 procedure Bad_Attribute
1503 Warn
: Boolean := False)
1506 Error_Msg_Warn
:= Warn
;
1507 Error_Msg_N
("unrecognized attribute&<<", N
);
1509 -- Check for possible misspelling
1511 Error_Msg_Name_1
:= First_Attribute_Name
;
1512 while Error_Msg_Name_1
<= Last_Attribute_Name
loop
1513 if Is_Bad_Spelling_Of
(Nam
, Error_Msg_Name_1
) then
1514 Error_Msg_N
-- CODEFIX
1515 ("\possible misspelling of %<<", N
);
1519 Error_Msg_Name_1
:= Error_Msg_Name_1
+ 1;
1523 --------------------------------
1524 -- Bad_Predicated_Subtype_Use --
1525 --------------------------------
1527 procedure Bad_Predicated_Subtype_Use
1531 Suggest_Static
: Boolean := False)
1536 -- Avoid cascaded errors
1538 if Error_Posted
(N
) then
1542 if Inside_A_Generic
then
1543 Gen
:= Current_Scope
;
1544 while Present
(Gen
) and then Ekind
(Gen
) /= E_Generic_Package
loop
1552 if Is_Generic_Formal
(Typ
) and then Is_Discrete_Type
(Typ
) then
1553 Set_No_Predicate_On_Actual
(Typ
);
1556 elsif Has_Predicates
(Typ
) then
1557 if Is_Generic_Actual_Type
(Typ
) then
1559 -- The restriction on loop parameters is only that the type
1560 -- should have no dynamic predicates.
1562 if Nkind
(Parent
(N
)) = N_Loop_Parameter_Specification
1563 and then not Has_Dynamic_Predicate_Aspect
(Typ
)
1564 and then Is_OK_Static_Subtype
(Typ
)
1569 Gen
:= Current_Scope
;
1570 while not Is_Generic_Instance
(Gen
) loop
1574 pragma Assert
(Present
(Gen
));
1576 if Ekind
(Gen
) = E_Package
and then In_Package_Body
(Gen
) then
1577 Error_Msg_Warn
:= SPARK_Mode
/= On
;
1578 Error_Msg_FE
(Msg
& "<<", N
, Typ
);
1579 Error_Msg_F
("\Program_Error [<<", N
);
1582 Make_Raise_Program_Error
(Sloc
(N
),
1583 Reason
=> PE_Bad_Predicated_Generic_Type
));
1586 Error_Msg_FE
(Msg
, N
, Typ
);
1590 Error_Msg_FE
(Msg
, N
, Typ
);
1593 -- Emit an optional suggestion on how to remedy the error if the
1594 -- context warrants it.
1596 if Suggest_Static
and then Has_Static_Predicate
(Typ
) then
1597 Error_Msg_FE
("\predicate of & should be marked static", N
, Typ
);
1600 end Bad_Predicated_Subtype_Use
;
1602 -----------------------------------------
1603 -- Bad_Unordered_Enumeration_Reference --
1604 -----------------------------------------
1606 function Bad_Unordered_Enumeration_Reference
1608 T
: Entity_Id
) return Boolean
1611 return Is_Enumeration_Type
(T
)
1612 and then Warn_On_Unordered_Enumeration_Type
1613 and then not Is_Generic_Type
(T
)
1614 and then Comes_From_Source
(N
)
1615 and then not Has_Pragma_Ordered
(T
)
1616 and then not In_Same_Extended_Unit
(N
, T
);
1617 end Bad_Unordered_Enumeration_Reference
;
1619 ----------------------------
1620 -- Begin_Keyword_Location --
1621 ----------------------------
1623 function Begin_Keyword_Location
(N
: Node_Id
) return Source_Ptr
is
1635 HSS
:= Handled_Statement_Sequence
(N
);
1637 -- When the handled sequence of statements comes from source, the
1638 -- location of the "begin" keyword is that of the sequence itself.
1639 -- Note that an internal construct may inherit a source sequence.
1641 if Comes_From_Source
(HSS
) then
1644 -- The parser generates an internal handled sequence of statements to
1645 -- capture the location of the "begin" keyword if present in the source.
1646 -- Since there are no source statements, the location of the "begin"
1647 -- keyword is effectively that of the "end" keyword.
1649 elsif Comes_From_Source
(N
) then
1652 -- Otherwise the construct is internal and should carry the location of
1653 -- the original construct which prompted its creation.
1658 end Begin_Keyword_Location
;
1660 --------------------------
1661 -- Build_Actual_Subtype --
1662 --------------------------
1664 function Build_Actual_Subtype
1666 N
: Node_Or_Entity_Id
) return Node_Id
1669 -- Normally Sloc (N), but may point to corresponding body in some cases
1671 Constraints
: List_Id
;
1677 Disc_Type
: Entity_Id
;
1683 if Nkind
(N
) = N_Defining_Identifier
then
1684 Obj
:= New_Occurrence_Of
(N
, Loc
);
1686 -- If this is a formal parameter of a subprogram declaration, and
1687 -- we are compiling the body, we want the declaration for the
1688 -- actual subtype to carry the source position of the body, to
1689 -- prevent anomalies in gdb when stepping through the code.
1691 if Is_Formal
(N
) then
1693 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(N
));
1695 if Nkind
(Decl
) = N_Subprogram_Declaration
1696 and then Present
(Corresponding_Body
(Decl
))
1698 Loc
:= Sloc
(Corresponding_Body
(Decl
));
1707 if Is_Array_Type
(T
) then
1708 Constraints
:= New_List
;
1709 for J
in 1 .. Number_Dimensions
(T
) loop
1711 -- Build an array subtype declaration with the nominal subtype and
1712 -- the bounds of the actual. Add the declaration in front of the
1713 -- local declarations for the subprogram, for analysis before any
1714 -- reference to the formal in the body.
1717 Make_Attribute_Reference
(Loc
,
1719 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
1720 Attribute_Name
=> Name_First
,
1721 Expressions
=> New_List
(
1722 Make_Integer_Literal
(Loc
, J
)));
1725 Make_Attribute_Reference
(Loc
,
1727 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
1728 Attribute_Name
=> Name_Last
,
1729 Expressions
=> New_List
(
1730 Make_Integer_Literal
(Loc
, J
)));
1732 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
1735 -- If the type has unknown discriminants there is no constrained
1736 -- subtype to build. This is never called for a formal or for a
1737 -- lhs, so returning the type is ok ???
1739 elsif Has_Unknown_Discriminants
(T
) then
1743 Constraints
:= New_List
;
1745 -- Type T is a generic derived type, inherit the discriminants from
1748 if Is_Private_Type
(T
)
1749 and then No
(Full_View
(T
))
1751 -- T was flagged as an error if it was declared as a formal
1752 -- derived type with known discriminants. In this case there
1753 -- is no need to look at the parent type since T already carries
1754 -- its own discriminants.
1756 and then not Error_Posted
(T
)
1758 Disc_Type
:= Etype
(Base_Type
(T
));
1763 Discr
:= First_Discriminant
(Disc_Type
);
1764 while Present
(Discr
) loop
1765 Append_To
(Constraints
,
1766 Make_Selected_Component
(Loc
,
1768 Duplicate_Subexpr_No_Checks
(Obj
),
1769 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)));
1770 Next_Discriminant
(Discr
);
1774 Subt
:= Make_Temporary
(Loc
, 'S', Related_Node
=> N
);
1775 Set_Is_Internal
(Subt
);
1778 Make_Subtype_Declaration
(Loc
,
1779 Defining_Identifier
=> Subt
,
1780 Subtype_Indication
=>
1781 Make_Subtype_Indication
(Loc
,
1782 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
1784 Make_Index_Or_Discriminant_Constraint
(Loc
,
1785 Constraints
=> Constraints
)));
1787 Mark_Rewrite_Insertion
(Decl
);
1789 end Build_Actual_Subtype
;
1791 ---------------------------------------
1792 -- Build_Actual_Subtype_Of_Component --
1793 ---------------------------------------
1795 function Build_Actual_Subtype_Of_Component
1797 N
: Node_Id
) return Node_Id
1799 Loc
: constant Source_Ptr
:= Sloc
(N
);
1800 P
: constant Node_Id
:= Prefix
(N
);
1804 Index_Typ
: Entity_Id
;
1805 Sel
: Entity_Id
:= Empty
;
1807 Desig_Typ
: Entity_Id
;
1808 -- This is either a copy of T, or if T is an access type, then it is
1809 -- the directly designated type of this access type.
1811 function Build_Access_Record_Constraint
(C
: List_Id
) return List_Id
;
1812 -- If the record component is a constrained access to the current
1813 -- record, the subtype has not been constructed during analysis of
1814 -- the enclosing record type (see Analyze_Access). In that case, build
1815 -- a constrained access subtype after replacing references to the
1816 -- enclosing discriminants with the corresponding discriminant values
1819 function Build_Actual_Array_Constraint
return List_Id
;
1820 -- If one or more of the bounds of the component depends on
1821 -- discriminants, build actual constraint using the discriminants
1822 -- of the prefix, as above.
1824 function Build_Actual_Record_Constraint
return List_Id
;
1825 -- Similar to previous one, for discriminated components constrained
1826 -- by the discriminant of the enclosing object.
1828 function Copy_And_Maybe_Dereference
(N
: Node_Id
) return Node_Id
;
1829 -- Copy the subtree rooted at N and insert an explicit dereference if it
1830 -- is of an access type.
1832 -----------------------------------
1833 -- Build_Actual_Array_Constraint --
1834 -----------------------------------
1836 function Build_Actual_Array_Constraint
return List_Id
is
1837 Constraints
: constant List_Id
:= New_List
;
1845 Indx
:= First_Index
(Desig_Typ
);
1846 while Present
(Indx
) loop
1847 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
1848 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
1850 if Denotes_Discriminant
(Old_Lo
) then
1852 Make_Selected_Component
(Loc
,
1853 Prefix
=> Copy_And_Maybe_Dereference
(P
),
1854 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Lo
), Loc
));
1857 Lo
:= New_Copy_Tree
(Old_Lo
);
1859 -- The new bound will be reanalyzed in the enclosing
1860 -- declaration. For literal bounds that come from a type
1861 -- declaration, the type of the context must be imposed, so
1862 -- insure that analysis will take place. For non-universal
1863 -- types this is not strictly necessary.
1865 Set_Analyzed
(Lo
, False);
1868 if Denotes_Discriminant
(Old_Hi
) then
1870 Make_Selected_Component
(Loc
,
1871 Prefix
=> Copy_And_Maybe_Dereference
(P
),
1872 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Hi
), Loc
));
1875 Hi
:= New_Copy_Tree
(Old_Hi
);
1876 Set_Analyzed
(Hi
, False);
1879 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
1884 end Build_Actual_Array_Constraint
;
1886 ------------------------------------
1887 -- Build_Actual_Record_Constraint --
1888 ------------------------------------
1890 function Build_Actual_Record_Constraint
return List_Id
is
1891 Constraints
: constant List_Id
:= New_List
;
1896 D
:= First_Elmt
(Discriminant_Constraint
(Desig_Typ
));
1897 while Present
(D
) loop
1898 if Denotes_Discriminant
(Node
(D
)) then
1899 D_Val
:= Make_Selected_Component
(Loc
,
1900 Prefix
=> Copy_And_Maybe_Dereference
(P
),
1901 Selector_Name
=> New_Occurrence_Of
(Entity
(Node
(D
)), Loc
));
1904 D_Val
:= New_Copy_Tree
(Node
(D
));
1907 Append
(D_Val
, Constraints
);
1912 end Build_Actual_Record_Constraint
;
1914 ------------------------------------
1915 -- Build_Access_Record_Constraint --
1916 ------------------------------------
1918 function Build_Access_Record_Constraint
(C
: List_Id
) return List_Id
is
1919 Constraints
: constant List_Id
:= New_List
;
1924 -- Retrieve the constraint from the component declaration, because
1925 -- the component subtype has not been constructed and the component
1926 -- type is an unconstrained access.
1929 while Present
(D
) loop
1930 if Nkind
(D
) = N_Discriminant_Association
1931 and then Denotes_Discriminant
(Expression
(D
))
1933 D_Val
:= New_Copy_Tree
(D
);
1934 Set_Expression
(D_Val
,
1935 Make_Selected_Component
(Loc
,
1936 Prefix
=> Copy_And_Maybe_Dereference
(P
),
1938 New_Occurrence_Of
(Entity
(Expression
(D
)), Loc
)));
1940 elsif Denotes_Discriminant
(D
) then
1941 D_Val
:= Make_Selected_Component
(Loc
,
1942 Prefix
=> Copy_And_Maybe_Dereference
(P
),
1943 Selector_Name
=> New_Occurrence_Of
(Entity
(D
), Loc
));
1946 D_Val
:= New_Copy_Tree
(D
);
1949 Append
(D_Val
, Constraints
);
1954 end Build_Access_Record_Constraint
;
1956 --------------------------------
1957 -- Copy_And_Maybe_Dereference --
1958 --------------------------------
1960 function Copy_And_Maybe_Dereference
(N
: Node_Id
) return Node_Id
is
1961 New_N
: constant Node_Id
:= New_Copy_Tree
(N
);
1964 if Is_Access_Type
(Etype
(N
)) then
1965 return Make_Explicit_Dereference
(Sloc
(Parent
(N
)), New_N
);
1970 end Copy_And_Maybe_Dereference
;
1972 -- Start of processing for Build_Actual_Subtype_Of_Component
1975 -- The subtype does not need to be created for a selected component
1976 -- in a Spec_Expression.
1978 if In_Spec_Expression
then
1981 -- More comments for the rest of this body would be good ???
1983 elsif Nkind
(N
) = N_Explicit_Dereference
then
1984 if Is_Composite_Type
(T
)
1985 and then not Is_Constrained
(T
)
1986 and then not (Is_Class_Wide_Type
(T
)
1987 and then Is_Constrained
(Root_Type
(T
)))
1988 and then not Has_Unknown_Discriminants
(T
)
1990 -- If the type of the dereference is already constrained, it is an
1993 if Is_Array_Type
(Etype
(N
))
1994 and then Is_Constrained
(Etype
(N
))
1998 Remove_Side_Effects
(P
);
1999 return Build_Actual_Subtype
(T
, N
);
2006 elsif Nkind
(N
) = N_Selected_Component
then
2007 -- The entity of the selected component allows us to retrieve
2008 -- the original constraint from its component declaration.
2010 Sel
:= Entity
(Selector_Name
(N
));
2011 if Nkind
(Parent
(Sel
)) /= N_Component_Declaration
then
2016 if Is_Access_Type
(T
) then
2017 Desig_Typ
:= Designated_Type
(T
);
2023 if Ekind
(Desig_Typ
) = E_Array_Subtype
then
2024 Id
:= First_Index
(Desig_Typ
);
2026 -- Check whether an index bound is constrained by a discriminant
2028 while Present
(Id
) loop
2029 Index_Typ
:= Underlying_Type
(Etype
(Id
));
2031 if Denotes_Discriminant
(Type_Low_Bound
(Index_Typ
))
2033 Denotes_Discriminant
(Type_High_Bound
(Index_Typ
))
2035 Remove_Side_Effects
(P
);
2037 Build_Component_Subtype
2038 (Build_Actual_Array_Constraint
, Loc
, Base_Type
(T
));
2044 elsif Is_Composite_Type
(Desig_Typ
)
2045 and then Has_Discriminants
(Desig_Typ
)
2046 and then not Is_Empty_Elmt_List
(Discriminant_Constraint
(Desig_Typ
))
2047 and then not Has_Unknown_Discriminants
(Desig_Typ
)
2049 if Is_Private_Type
(Desig_Typ
)
2050 and then No
(Discriminant_Constraint
(Desig_Typ
))
2052 Desig_Typ
:= Full_View
(Desig_Typ
);
2055 D
:= First_Elmt
(Discriminant_Constraint
(Desig_Typ
));
2056 while Present
(D
) loop
2057 if Denotes_Discriminant
(Node
(D
)) then
2058 Remove_Side_Effects
(P
);
2060 Build_Component_Subtype
(
2061 Build_Actual_Record_Constraint
, Loc
, Base_Type
(T
));
2067 -- Special processing for an access record component that is
2068 -- the target of an assignment. If the designated type is an
2069 -- unconstrained discriminated record we create its actual
2072 elsif Ekind
(T
) = E_Access_Type
2073 and then Present
(Sel
)
2074 and then Has_Per_Object_Constraint
(Sel
)
2075 and then Nkind
(Parent
(N
)) = N_Assignment_Statement
2076 and then N
= Name
(Parent
(N
))
2077 -- and then not Inside_Init_Proc
2078 -- and then Has_Discriminants (Desig_Typ)
2079 -- and then not Is_Constrained (Desig_Typ)
2082 S_Indic
: constant Node_Id
:=
2084 (Component_Definition
(Parent
(Sel
))));
2087 if Nkind
(S_Indic
) = N_Subtype_Indication
then
2088 Discs
:= Constraints
(Constraint
(S_Indic
));
2090 Remove_Side_Effects
(P
);
2091 return Build_Component_Subtype
2092 (Build_Access_Record_Constraint
(Discs
), Loc
, T
);
2099 -- If none of the above, the actual and nominal subtypes are the same
2102 end Build_Actual_Subtype_Of_Component
;
2104 ---------------------------------
2105 -- Build_Class_Wide_Clone_Body --
2106 ---------------------------------
2108 procedure Build_Class_Wide_Clone_Body
2109 (Spec_Id
: Entity_Id
;
2112 Loc
: constant Source_Ptr
:= Sloc
(Bod
);
2113 Clone_Id
: constant Entity_Id
:= Class_Wide_Clone
(Spec_Id
);
2114 Clone_Body
: Node_Id
;
2115 Assoc_List
: constant Elist_Id
:= New_Elmt_List
;
2118 -- The declaration of the class-wide clone was created when the
2119 -- corresponding class-wide condition was analyzed.
2121 -- The body of the original condition may contain references to
2122 -- the formals of Spec_Id. In the body of the class-wide clone,
2123 -- these must be replaced with the corresponding formals of
2127 Spec_Formal_Id
: Entity_Id
:= First_Formal
(Spec_Id
);
2128 Clone_Formal_Id
: Entity_Id
:= First_Formal
(Clone_Id
);
2130 while Present
(Spec_Formal_Id
) loop
2131 Append_Elmt
(Spec_Formal_Id
, Assoc_List
);
2132 Append_Elmt
(Clone_Formal_Id
, Assoc_List
);
2134 Next_Formal
(Spec_Formal_Id
);
2135 Next_Formal
(Clone_Formal_Id
);
2140 Make_Subprogram_Body
(Loc
,
2142 Copy_Subprogram_Spec
(Parent
(Clone_Id
)),
2143 Declarations
=> Declarations
(Bod
),
2144 Handled_Statement_Sequence
=>
2145 New_Copy_Tree
(Handled_Statement_Sequence
(Bod
),
2146 Map
=> Assoc_List
));
2148 -- The new operation is internal and overriding indicators do not apply
2149 -- (the original primitive may have carried one).
2151 Set_Must_Override
(Specification
(Clone_Body
), False);
2153 -- If the subprogram body is the proper body of a stub, insert the
2154 -- subprogram after the stub, i.e. the same declarative region as
2155 -- the original sugprogram.
2157 if Nkind
(Parent
(Bod
)) = N_Subunit
then
2158 Insert_After
(Corresponding_Stub
(Parent
(Bod
)), Clone_Body
);
2161 Insert_Before
(Bod
, Clone_Body
);
2164 Analyze
(Clone_Body
);
2165 end Build_Class_Wide_Clone_Body
;
2167 ---------------------------------
2168 -- Build_Class_Wide_Clone_Call --
2169 ---------------------------------
2171 function Build_Class_Wide_Clone_Call
2174 Spec_Id
: Entity_Id
;
2175 Spec
: Node_Id
) return Node_Id
2177 Clone_Id
: constant Entity_Id
:= Class_Wide_Clone
(Spec_Id
);
2178 Par_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Spec_Id
);
2184 New_F_Spec
: Entity_Id
;
2185 New_Formal
: Entity_Id
;
2188 Actuals
:= Empty_List
;
2189 Formal
:= First_Formal
(Spec_Id
);
2190 New_F_Spec
:= First
(Parameter_Specifications
(Spec
));
2192 -- Build parameter association for call to class-wide clone.
2194 while Present
(Formal
) loop
2195 New_Formal
:= Defining_Identifier
(New_F_Spec
);
2197 -- If controlling argument and operation is inherited, add conversion
2198 -- to parent type for the call.
2200 if Etype
(Formal
) = Par_Type
2201 and then not Is_Empty_List
(Decls
)
2204 Make_Type_Conversion
(Loc
,
2205 New_Occurrence_Of
(Par_Type
, Loc
),
2206 New_Occurrence_Of
(New_Formal
, Loc
)));
2209 Append_To
(Actuals
, New_Occurrence_Of
(New_Formal
, Loc
));
2212 Next_Formal
(Formal
);
2216 if Ekind
(Spec_Id
) = E_Procedure
then
2218 Make_Procedure_Call_Statement
(Loc
,
2219 Name
=> New_Occurrence_Of
(Clone_Id
, Loc
),
2220 Parameter_Associations
=> Actuals
);
2223 Make_Simple_Return_Statement
(Loc
,
2225 Make_Function_Call
(Loc
,
2226 Name
=> New_Occurrence_Of
(Clone_Id
, Loc
),
2227 Parameter_Associations
=> Actuals
));
2231 Make_Subprogram_Body
(Loc
,
2233 Copy_Subprogram_Spec
(Spec
),
2234 Declarations
=> Decls
,
2235 Handled_Statement_Sequence
=>
2236 Make_Handled_Sequence_Of_Statements
(Loc
,
2237 Statements
=> New_List
(Call
),
2238 End_Label
=> Make_Identifier
(Loc
, Chars
(Spec_Id
))));
2241 end Build_Class_Wide_Clone_Call
;
2243 ---------------------------------
2244 -- Build_Class_Wide_Clone_Decl --
2245 ---------------------------------
2247 procedure Build_Class_Wide_Clone_Decl
(Spec_Id
: Entity_Id
) is
2248 Loc
: constant Source_Ptr
:= Sloc
(Spec_Id
);
2249 Clone_Id
: constant Entity_Id
:=
2250 Make_Defining_Identifier
(Loc
,
2251 New_External_Name
(Chars
(Spec_Id
), Suffix
=> "CL"));
2257 Spec
:= Copy_Subprogram_Spec
(Parent
(Spec_Id
));
2258 Set_Must_Override
(Spec
, False);
2259 Set_Must_Not_Override
(Spec
, False);
2260 Set_Defining_Unit_Name
(Spec
, Clone_Id
);
2262 Decl
:= Make_Subprogram_Declaration
(Loc
, Spec
);
2263 Append
(Decl
, List_Containing
(Unit_Declaration_Node
(Spec_Id
)));
2265 -- Link clone to original subprogram, for use when building body and
2266 -- wrapper call to inherited operation.
2268 Set_Class_Wide_Clone
(Spec_Id
, Clone_Id
);
2270 -- Inherit debug info flag from Spec_Id to Clone_Id to allow debugging
2271 -- of the class-wide clone subprogram.
2273 if Needs_Debug_Info
(Spec_Id
) then
2274 Set_Debug_Info_Needed
(Clone_Id
);
2276 end Build_Class_Wide_Clone_Decl
;
2278 -----------------------------
2279 -- Build_Component_Subtype --
2280 -----------------------------
2282 function Build_Component_Subtype
2285 T
: Entity_Id
) return Node_Id
2291 -- Unchecked_Union components do not require component subtypes
2293 if Is_Unchecked_Union
(T
) then
2297 Subt
:= Make_Temporary
(Loc
, 'S');
2298 Set_Is_Internal
(Subt
);
2301 Make_Subtype_Declaration
(Loc
,
2302 Defining_Identifier
=> Subt
,
2303 Subtype_Indication
=>
2304 Make_Subtype_Indication
(Loc
,
2305 Subtype_Mark
=> New_Occurrence_Of
(Base_Type
(T
), Loc
),
2307 Make_Index_Or_Discriminant_Constraint
(Loc
,
2308 Constraints
=> C
)));
2310 Mark_Rewrite_Insertion
(Decl
);
2312 end Build_Component_Subtype
;
2314 -----------------------------
2315 -- Build_Constrained_Itype --
2316 -----------------------------
2318 procedure Build_Constrained_Itype
2321 New_Assoc_List
: List_Id
)
2323 Constrs
: constant List_Id
:= New_List
;
2324 Loc
: constant Source_Ptr
:= Sloc
(N
);
2327 New_Assoc
: Node_Id
;
2328 Subtyp_Decl
: Node_Id
;
2331 New_Assoc
:= First
(New_Assoc_List
);
2332 while Present
(New_Assoc
) loop
2334 -- There is exactly one choice in the component association (and
2335 -- it is either a discriminant, a component or the others clause).
2336 pragma Assert
(List_Length
(Choices
(New_Assoc
)) = 1);
2338 -- Duplicate expression for the discriminant and put it on the
2339 -- list of constraints for the itype declaration.
2341 if Is_Entity_Name
(First
(Choices
(New_Assoc
)))
2343 Ekind
(Entity
(First
(Choices
(New_Assoc
)))) = E_Discriminant
2345 Append_To
(Constrs
, Duplicate_Subexpr
(Expression
(New_Assoc
)));
2351 if Has_Unknown_Discriminants
(Typ
)
2352 and then Present
(Underlying_Record_View
(Typ
))
2355 Make_Subtype_Indication
(Loc
,
2357 New_Occurrence_Of
(Underlying_Record_View
(Typ
), Loc
),
2359 Make_Index_Or_Discriminant_Constraint
(Loc
,
2360 Constraints
=> Constrs
));
2363 Make_Subtype_Indication
(Loc
,
2365 New_Occurrence_Of
(Base_Type
(Typ
), Loc
),
2367 Make_Index_Or_Discriminant_Constraint
(Loc
,
2368 Constraints
=> Constrs
));
2371 Def_Id
:= Create_Itype
(Ekind
(Typ
), N
);
2374 Make_Subtype_Declaration
(Loc
,
2375 Defining_Identifier
=> Def_Id
,
2376 Subtype_Indication
=> Indic
);
2377 Set_Parent
(Subtyp_Decl
, Parent
(N
));
2379 -- Itypes must be analyzed with checks off (see itypes.ads)
2381 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
2383 Set_Etype
(N
, Def_Id
);
2384 end Build_Constrained_Itype
;
2386 ---------------------------
2387 -- Build_Default_Subtype --
2388 ---------------------------
2390 function Build_Default_Subtype
2392 N
: Node_Id
) return Entity_Id
2394 Loc
: constant Source_Ptr
:= Sloc
(N
);
2398 -- The base type that is to be constrained by the defaults
2401 if not Has_Discriminants
(T
) or else Is_Constrained
(T
) then
2405 Bas
:= Base_Type
(T
);
2407 -- If T is non-private but its base type is private, this is the
2408 -- completion of a subtype declaration whose parent type is private
2409 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
2410 -- are to be found in the full view of the base. Check that the private
2411 -- status of T and its base differ.
2413 if Is_Private_Type
(Bas
)
2414 and then not Is_Private_Type
(T
)
2415 and then Present
(Full_View
(Bas
))
2417 Bas
:= Full_View
(Bas
);
2420 Disc
:= First_Discriminant
(T
);
2422 if No
(Discriminant_Default_Value
(Disc
)) then
2427 Act
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
2428 Constraints
: constant List_Id
:= New_List
;
2432 while Present
(Disc
) loop
2433 Append_To
(Constraints
,
2434 New_Copy_Tree
(Discriminant_Default_Value
(Disc
)));
2435 Next_Discriminant
(Disc
);
2439 Make_Subtype_Declaration
(Loc
,
2440 Defining_Identifier
=> Act
,
2441 Subtype_Indication
=>
2442 Make_Subtype_Indication
(Loc
,
2443 Subtype_Mark
=> New_Occurrence_Of
(Bas
, Loc
),
2445 Make_Index_Or_Discriminant_Constraint
(Loc
,
2446 Constraints
=> Constraints
)));
2448 Insert_Action
(N
, Decl
);
2450 -- If the context is a component declaration the subtype declaration
2451 -- will be analyzed when the enclosing type is frozen, otherwise do
2454 if Ekind
(Current_Scope
) /= E_Record_Type
then
2460 end Build_Default_Subtype
;
2462 --------------------------------------------
2463 -- Build_Discriminal_Subtype_Of_Component --
2464 --------------------------------------------
2466 function Build_Discriminal_Subtype_Of_Component
2467 (T
: Entity_Id
) return Node_Id
2469 Loc
: constant Source_Ptr
:= Sloc
(T
);
2473 function Build_Discriminal_Array_Constraint
return List_Id
;
2474 -- If one or more of the bounds of the component depends on
2475 -- discriminants, build actual constraint using the discriminants
2478 function Build_Discriminal_Record_Constraint
return List_Id
;
2479 -- Similar to previous one, for discriminated components constrained by
2480 -- the discriminant of the enclosing object.
2482 ----------------------------------------
2483 -- Build_Discriminal_Array_Constraint --
2484 ----------------------------------------
2486 function Build_Discriminal_Array_Constraint
return List_Id
is
2487 Constraints
: constant List_Id
:= New_List
;
2495 Indx
:= First_Index
(T
);
2496 while Present
(Indx
) loop
2497 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
2498 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
2500 if Denotes_Discriminant
(Old_Lo
) then
2501 Lo
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Lo
)), Loc
);
2504 Lo
:= New_Copy_Tree
(Old_Lo
);
2507 if Denotes_Discriminant
(Old_Hi
) then
2508 Hi
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Hi
)), Loc
);
2511 Hi
:= New_Copy_Tree
(Old_Hi
);
2514 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
2519 end Build_Discriminal_Array_Constraint
;
2521 -----------------------------------------
2522 -- Build_Discriminal_Record_Constraint --
2523 -----------------------------------------
2525 function Build_Discriminal_Record_Constraint
return List_Id
is
2526 Constraints
: constant List_Id
:= New_List
;
2531 D
:= First_Elmt
(Discriminant_Constraint
(T
));
2532 while Present
(D
) loop
2533 if Denotes_Discriminant
(Node
(D
)) then
2535 New_Occurrence_Of
(Discriminal
(Entity
(Node
(D
))), Loc
);
2537 D_Val
:= New_Copy_Tree
(Node
(D
));
2540 Append
(D_Val
, Constraints
);
2545 end Build_Discriminal_Record_Constraint
;
2547 -- Start of processing for Build_Discriminal_Subtype_Of_Component
2550 if Ekind
(T
) = E_Array_Subtype
then
2551 Id
:= First_Index
(T
);
2552 while Present
(Id
) loop
2553 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(Id
)))
2555 Denotes_Discriminant
(Type_High_Bound
(Etype
(Id
)))
2557 return Build_Component_Subtype
2558 (Build_Discriminal_Array_Constraint
, Loc
, T
);
2564 elsif Ekind
(T
) = E_Record_Subtype
2565 and then Has_Discriminants
(T
)
2566 and then not Has_Unknown_Discriminants
(T
)
2568 D
:= First_Elmt
(Discriminant_Constraint
(T
));
2569 while Present
(D
) loop
2570 if Denotes_Discriminant
(Node
(D
)) then
2571 return Build_Component_Subtype
2572 (Build_Discriminal_Record_Constraint
, Loc
, T
);
2579 -- If none of the above, the actual and nominal subtypes are the same
2582 end Build_Discriminal_Subtype_Of_Component
;
2584 ------------------------------
2585 -- Build_Elaboration_Entity --
2586 ------------------------------
2588 procedure Build_Elaboration_Entity
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
2589 Loc
: constant Source_Ptr
:= Sloc
(N
);
2591 Elab_Ent
: Entity_Id
;
2593 procedure Set_Package_Name
(Ent
: Entity_Id
);
2594 -- Given an entity, sets the fully qualified name of the entity in
2595 -- Name_Buffer, with components separated by double underscores. This
2596 -- is a recursive routine that climbs the scope chain to Standard.
2598 ----------------------
2599 -- Set_Package_Name --
2600 ----------------------
2602 procedure Set_Package_Name
(Ent
: Entity_Id
) is
2604 if Scope
(Ent
) /= Standard_Standard
then
2605 Set_Package_Name
(Scope
(Ent
));
2608 Nam
: constant String := Get_Name_String
(Chars
(Ent
));
2610 Name_Buffer
(Name_Len
+ 1) := '_';
2611 Name_Buffer
(Name_Len
+ 2) := '_';
2612 Name_Buffer
(Name_Len
+ 3 .. Name_Len
+ Nam
'Length + 2) := Nam
;
2613 Name_Len
:= Name_Len
+ Nam
'Length + 2;
2617 Get_Name_String
(Chars
(Ent
));
2619 end Set_Package_Name
;
2621 -- Start of processing for Build_Elaboration_Entity
2624 -- Ignore call if already constructed
2626 if Present
(Elaboration_Entity
(Spec_Id
)) then
2629 -- Do not generate an elaboration entity in GNATprove move because the
2630 -- elaboration counter is a form of expansion.
2632 elsif GNATprove_Mode
then
2635 -- See if we need elaboration entity
2637 -- We always need an elaboration entity when preserving control flow, as
2638 -- we want to remain explicit about the unit's elaboration order.
2640 elsif Opt
.Suppress_Control_Flow_Optimizations
then
2643 -- We always need an elaboration entity for the dynamic elaboration
2644 -- model, since it is needed to properly generate the PE exception for
2645 -- access before elaboration.
2647 elsif Dynamic_Elaboration_Checks
then
2650 -- For the static model, we don't need the elaboration counter if this
2651 -- unit is sure to have no elaboration code, since that means there
2652 -- is no elaboration unit to be called. Note that we can't just decide
2653 -- after the fact by looking to see whether there was elaboration code,
2654 -- because that's too late to make this decision.
2656 elsif Restriction_Active
(No_Elaboration_Code
) then
2659 -- Similarly, for the static model, we can skip the elaboration counter
2660 -- if we have the No_Multiple_Elaboration restriction, since for the
2661 -- static model, that's the only purpose of the counter (to avoid
2662 -- multiple elaboration).
2664 elsif Restriction_Active
(No_Multiple_Elaboration
) then
2668 -- Here we need the elaboration entity
2670 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
2671 -- name with dots replaced by double underscore. We have to manually
2672 -- construct this name, since it will be elaborated in the outer scope,
2673 -- and thus will not have the unit name automatically prepended.
2675 Set_Package_Name
(Spec_Id
);
2676 Add_Str_To_Name_Buffer
("_E");
2678 -- Create elaboration counter
2680 Elab_Ent
:= Make_Defining_Identifier
(Loc
, Chars
=> Name_Find
);
2681 Set_Elaboration_Entity
(Spec_Id
, Elab_Ent
);
2684 Make_Object_Declaration
(Loc
,
2685 Defining_Identifier
=> Elab_Ent
,
2686 Object_Definition
=>
2687 New_Occurrence_Of
(Standard_Short_Integer
, Loc
),
2688 Expression
=> Make_Integer_Literal
(Loc
, Uint_0
));
2690 Push_Scope
(Standard_Standard
);
2691 Add_Global_Declaration
(Decl
);
2694 -- Reset True_Constant indication, since we will indeed assign a value
2695 -- to the variable in the binder main. We also kill the Current_Value
2696 -- and Last_Assignment fields for the same reason.
2698 Set_Is_True_Constant
(Elab_Ent
, False);
2699 Set_Current_Value
(Elab_Ent
, Empty
);
2700 Set_Last_Assignment
(Elab_Ent
, Empty
);
2702 -- We do not want any further qualification of the name (if we did not
2703 -- do this, we would pick up the name of the generic package in the case
2704 -- of a library level generic instantiation).
2706 Set_Has_Qualified_Name
(Elab_Ent
);
2707 Set_Has_Fully_Qualified_Name
(Elab_Ent
);
2708 end Build_Elaboration_Entity
;
2710 --------------------------------
2711 -- Build_Explicit_Dereference --
2712 --------------------------------
2714 procedure Build_Explicit_Dereference
2718 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
2723 -- An entity of a type with a reference aspect is overloaded with
2724 -- both interpretations: with and without the dereference. Now that
2725 -- the dereference is made explicit, set the type of the node properly,
2726 -- to prevent anomalies in the backend. Same if the expression is an
2727 -- overloaded function call whose return type has a reference aspect.
2729 if Is_Entity_Name
(Expr
) then
2730 Set_Etype
(Expr
, Etype
(Entity
(Expr
)));
2732 -- The designated entity will not be examined again when resolving
2733 -- the dereference, so generate a reference to it now.
2735 Generate_Reference
(Entity
(Expr
), Expr
);
2737 elsif Nkind
(Expr
) = N_Function_Call
then
2739 -- If the name of the indexing function is overloaded, locate the one
2740 -- whose return type has an implicit dereference on the desired
2741 -- discriminant, and set entity and type of function call.
2743 if Is_Overloaded
(Name
(Expr
)) then
2744 Get_First_Interp
(Name
(Expr
), I
, It
);
2746 while Present
(It
.Nam
) loop
2747 if Ekind
((It
.Typ
)) = E_Record_Type
2748 and then First_Entity
((It
.Typ
)) = Disc
2750 Set_Entity
(Name
(Expr
), It
.Nam
);
2751 Set_Etype
(Name
(Expr
), Etype
(It
.Nam
));
2755 Get_Next_Interp
(I
, It
);
2759 -- Set type of call from resolved function name.
2761 Set_Etype
(Expr
, Etype
(Name
(Expr
)));
2764 Set_Is_Overloaded
(Expr
, False);
2766 -- The expression will often be a generalized indexing that yields a
2767 -- container element that is then dereferenced, in which case the
2768 -- generalized indexing call is also non-overloaded.
2770 if Nkind
(Expr
) = N_Indexed_Component
2771 and then Present
(Generalized_Indexing
(Expr
))
2773 Set_Is_Overloaded
(Generalized_Indexing
(Expr
), False);
2777 Make_Explicit_Dereference
(Loc
,
2779 Make_Selected_Component
(Loc
,
2780 Prefix
=> Relocate_Node
(Expr
),
2781 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
))));
2782 Set_Etype
(Prefix
(Expr
), Etype
(Disc
));
2783 Set_Etype
(Expr
, Designated_Type
(Etype
(Disc
)));
2784 end Build_Explicit_Dereference
;
2786 ---------------------------
2787 -- Build_Overriding_Spec --
2788 ---------------------------
2790 function Build_Overriding_Spec
2792 Typ
: Entity_Id
) return Node_Id
2794 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2795 Par_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Op
);
2796 Spec
: constant Node_Id
:= Specification
(Unit_Declaration_Node
(Op
));
2798 Formal_Spec
: Node_Id
;
2799 Formal_Type
: Node_Id
;
2803 New_Spec
:= Copy_Subprogram_Spec
(Spec
);
2805 Formal_Spec
:= First
(Parameter_Specifications
(New_Spec
));
2806 while Present
(Formal_Spec
) loop
2807 Formal_Type
:= Parameter_Type
(Formal_Spec
);
2809 if Is_Entity_Name
(Formal_Type
)
2810 and then Entity
(Formal_Type
) = Par_Typ
2812 Rewrite
(Formal_Type
, New_Occurrence_Of
(Typ
, Loc
));
2815 -- Nothing needs to be done for access parameters
2821 end Build_Overriding_Spec
;
2827 function Build_Subtype
2828 (Related_Node
: Node_Id
;
2831 Constraints
: List_Id
)
2835 Subtyp_Decl
: Node_Id
;
2837 Btyp
: Entity_Id
:= Base_Type
(Typ
);
2840 -- The Related_Node better be here or else we won't be able to
2841 -- attach new itypes to a node in the tree.
2843 pragma Assert
(Present
(Related_Node
));
2845 -- If the view of the component's type is incomplete or private
2846 -- with unknown discriminants, then the constraint must be applied
2847 -- to the full type.
2849 if Has_Unknown_Discriminants
(Btyp
)
2850 and then Present
(Underlying_Type
(Btyp
))
2852 Btyp
:= Underlying_Type
(Btyp
);
2856 Make_Subtype_Indication
(Loc
,
2857 Subtype_Mark
=> New_Occurrence_Of
(Btyp
, Loc
),
2859 Make_Index_Or_Discriminant_Constraint
(Loc
, Constraints
));
2861 Def_Id
:= Create_Itype
(Ekind
(Typ
), Related_Node
);
2864 Make_Subtype_Declaration
(Loc
,
2865 Defining_Identifier
=> Def_Id
,
2866 Subtype_Indication
=> Indic
);
2868 Set_Parent
(Subtyp_Decl
, Parent
(Related_Node
));
2870 -- Itypes must be analyzed with checks off (see package Itypes)
2872 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
2874 if Is_Itype
(Def_Id
) and then Has_Predicates
(Typ
) then
2875 Inherit_Predicate_Flags
(Def_Id
, Typ
);
2877 -- Indicate where the predicate function may be found
2879 if Is_Itype
(Typ
) then
2880 if Present
(Predicate_Function
(Def_Id
)) then
2883 elsif Present
(Predicate_Function
(Typ
)) then
2884 Set_Predicate_Function
(Def_Id
, Predicate_Function
(Typ
));
2887 Set_Predicated_Parent
(Def_Id
, Predicated_Parent
(Typ
));
2890 elsif No
(Predicate_Function
(Def_Id
)) then
2891 Set_Predicated_Parent
(Def_Id
, Typ
);
2898 -----------------------------------
2899 -- Cannot_Raise_Constraint_Error --
2900 -----------------------------------
2902 function Cannot_Raise_Constraint_Error
(Expr
: Node_Id
) return Boolean is
2904 if Compile_Time_Known_Value
(Expr
) then
2907 elsif Do_Range_Check
(Expr
) then
2910 elsif Raises_Constraint_Error
(Expr
) then
2914 case Nkind
(Expr
) is
2915 when N_Identifier
=>
2918 when N_Expanded_Name
=>
2921 when N_Selected_Component
=>
2922 return not Do_Discriminant_Check
(Expr
);
2924 when N_Attribute_Reference
=>
2925 if Do_Overflow_Check
(Expr
) then
2928 elsif No
(Expressions
(Expr
)) then
2936 N
:= First
(Expressions
(Expr
));
2937 while Present
(N
) loop
2938 if Cannot_Raise_Constraint_Error
(N
) then
2949 when N_Type_Conversion
=>
2950 if Do_Overflow_Check
(Expr
)
2951 or else Do_Length_Check
(Expr
)
2952 or else Do_Tag_Check
(Expr
)
2956 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
2959 when N_Unchecked_Type_Conversion
=>
2960 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
2963 if Do_Overflow_Check
(Expr
) then
2966 return Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
2973 if Do_Division_Check
(Expr
)
2975 Do_Overflow_Check
(Expr
)
2980 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
2982 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
3001 | N_Op_Shift_Right_Arithmetic
3005 if Do_Overflow_Check
(Expr
) then
3009 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
3011 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
3018 end Cannot_Raise_Constraint_Error
;
3020 -------------------------------
3021 -- Check_Ambiguous_Aggregate --
3022 -------------------------------
3024 procedure Check_Ambiguous_Aggregate
(Call
: Node_Id
) is
3028 if Extensions_Allowed
then
3029 Actual
:= First_Actual
(Call
);
3030 while Present
(Actual
) loop
3031 if Nkind
(Actual
) = N_Aggregate
then
3033 ("\add type qualification to aggregate actual", Actual
);
3036 Next_Actual
(Actual
);
3039 end Check_Ambiguous_Aggregate
;
3041 -----------------------------------------
3042 -- Check_Dynamically_Tagged_Expression --
3043 -----------------------------------------
3045 procedure Check_Dynamically_Tagged_Expression
3048 Related_Nod
: Node_Id
)
3051 pragma Assert
(Is_Tagged_Type
(Typ
));
3053 -- In order to avoid spurious errors when analyzing the expanded code,
3054 -- this check is done only for nodes that come from source and for
3055 -- actuals of generic instantiations.
3057 if (Comes_From_Source
(Related_Nod
)
3058 or else In_Generic_Actual
(Expr
))
3059 and then (Is_Class_Wide_Type
(Etype
(Expr
))
3060 or else Is_Dynamically_Tagged
(Expr
))
3061 and then not Is_Class_Wide_Type
(Typ
)
3063 Error_Msg_N
("dynamically tagged expression not allowed!", Expr
);
3065 end Check_Dynamically_Tagged_Expression
;
3067 --------------------------
3068 -- Check_Fully_Declared --
3069 --------------------------
3071 procedure Check_Fully_Declared
(T
: Entity_Id
; N
: Node_Id
) is
3073 if Ekind
(T
) = E_Incomplete_Type
then
3075 -- Ada 2005 (AI-50217): If the type is available through a limited
3076 -- with_clause, verify that its full view has been analyzed.
3078 if From_Limited_With
(T
)
3079 and then Present
(Non_Limited_View
(T
))
3080 and then Ekind
(Non_Limited_View
(T
)) /= E_Incomplete_Type
3082 -- The non-limited view is fully declared
3088 ("premature usage of incomplete}", N
, First_Subtype
(T
));
3091 -- Need comments for these tests ???
3093 elsif Has_Private_Component
(T
)
3094 and then not Is_Generic_Type
(Root_Type
(T
))
3095 and then not In_Spec_Expression
3097 -- Special case: if T is the anonymous type created for a single
3098 -- task or protected object, use the name of the source object.
3100 if Is_Concurrent_Type
(T
)
3101 and then not Comes_From_Source
(T
)
3102 and then Nkind
(N
) = N_Object_Declaration
3105 ("type of& has incomplete component",
3106 N
, Defining_Identifier
(N
));
3109 ("premature usage of incomplete}",
3110 N
, First_Subtype
(T
));
3113 end Check_Fully_Declared
;
3115 -------------------------------------------
3116 -- Check_Function_With_Address_Parameter --
3117 -------------------------------------------
3119 procedure Check_Function_With_Address_Parameter
(Subp_Id
: Entity_Id
) is
3124 F
:= First_Formal
(Subp_Id
);
3125 while Present
(F
) loop
3128 if Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
3132 if Is_Descendant_Of_Address
(T
) or else Is_Limited_Type
(T
) then
3133 Set_Is_Pure
(Subp_Id
, False);
3139 end Check_Function_With_Address_Parameter
;
3141 -------------------------------------
3142 -- Check_Function_Writable_Actuals --
3143 -------------------------------------
3145 procedure Check_Function_Writable_Actuals
(N
: Node_Id
) is
3146 Writable_Actuals_List
: Elist_Id
:= No_Elist
;
3147 Identifiers_List
: Elist_Id
:= No_Elist
;
3148 Aggr_Error_Node
: Node_Id
:= Empty
;
3149 Error_Node
: Node_Id
:= Empty
;
3151 procedure Collect_Identifiers
(N
: Node_Id
);
3152 -- In a single traversal of subtree N collect in Writable_Actuals_List
3153 -- all the actuals of functions with writable actuals, and in the list
3154 -- Identifiers_List collect all the identifiers that are not actuals of
3155 -- functions with writable actuals. If a writable actual is referenced
3156 -- twice as writable actual then Error_Node is set to reference its
3157 -- second occurrence, the error is reported, and the tree traversal
3160 -------------------------
3161 -- Collect_Identifiers --
3162 -------------------------
3164 procedure Collect_Identifiers
(N
: Node_Id
) is
3166 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
3167 -- Process a single node during the tree traversal to collect the
3168 -- writable actuals of functions and all the identifiers which are
3169 -- not writable actuals of functions.
3171 function Contains
(List
: Elist_Id
; N
: Node_Id
) return Boolean;
3172 -- Returns True if List has a node whose Entity is Entity (N)
3178 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
3179 Is_Writable_Actual
: Boolean := False;
3183 if Nkind
(N
) = N_Identifier
then
3185 -- No analysis possible if the entity is not decorated
3187 if No
(Entity
(N
)) then
3190 -- Don't collect identifiers of packages, called functions, etc
3192 elsif Ekind
(Entity
(N
)) in
3193 E_Package | E_Function | E_Procedure | E_Entry
3197 -- For rewritten nodes, continue the traversal in the original
3198 -- subtree. Needed to handle aggregates in original expressions
3199 -- extracted from the tree by Remove_Side_Effects.
3201 elsif Is_Rewrite_Substitution
(N
) then
3202 Collect_Identifiers
(Original_Node
(N
));
3205 -- For now we skip aggregate discriminants, since they require
3206 -- performing the analysis in two phases to identify conflicts:
3207 -- first one analyzing discriminants and second one analyzing
3208 -- the rest of components (since at run time, discriminants are
3209 -- evaluated prior to components): too much computation cost
3210 -- to identify a corner case???
3212 elsif Nkind
(Parent
(N
)) = N_Component_Association
3213 and then Nkind
(Parent
(Parent
(N
))) in
3214 N_Aggregate | N_Extension_Aggregate
3217 Choice
: constant Node_Id
:= First
(Choices
(Parent
(N
)));
3220 if Ekind
(Entity
(N
)) = E_Discriminant
then
3223 elsif Expression
(Parent
(N
)) = N
3224 and then Nkind
(Choice
) = N_Identifier
3225 and then Ekind
(Entity
(Choice
)) = E_Discriminant
3231 -- Analyze if N is a writable actual of a function
3233 elsif Nkind
(Parent
(N
)) = N_Function_Call
then
3235 Call
: constant Node_Id
:= Parent
(N
);
3240 Id
:= Get_Called_Entity
(Call
);
3242 -- In case of previous error, no check is possible
3248 if Ekind
(Id
) in E_Function | E_Generic_Function
3249 and then Has_Out_Or_In_Out_Parameter
(Id
)
3251 Formal
:= First_Formal
(Id
);
3252 Actual
:= First_Actual
(Call
);
3253 while Present
(Actual
) and then Present
(Formal
) loop
3255 if Ekind
(Formal
) in E_Out_Parameter
3256 | E_In_Out_Parameter
3258 Is_Writable_Actual
:= True;
3264 Next_Formal
(Formal
);
3265 Next_Actual
(Actual
);
3271 if Is_Writable_Actual
then
3273 -- Skip checking the error in non-elementary types since
3274 -- RM 6.4.1(6.15/3) is restricted to elementary types, but
3275 -- store this actual in Writable_Actuals_List since it is
3276 -- needed to perform checks on other constructs that have
3277 -- arbitrary order of evaluation (for example, aggregates).
3279 if not Is_Elementary_Type
(Etype
(N
)) then
3280 if not Contains
(Writable_Actuals_List
, N
) then
3281 Append_New_Elmt
(N
, To
=> Writable_Actuals_List
);
3284 -- Second occurrence of an elementary type writable actual
3286 elsif Contains
(Writable_Actuals_List
, N
) then
3288 -- Report the error on the second occurrence of the
3289 -- identifier. We cannot assume that N is the second
3290 -- occurrence (according to their location in the
3291 -- sources), since Traverse_Func walks through Field2
3292 -- last (see comment in the body of Traverse_Func).
3298 Elmt
:= First_Elmt
(Writable_Actuals_List
);
3299 while Present
(Elmt
)
3300 and then Entity
(Node
(Elmt
)) /= Entity
(N
)
3305 if Sloc
(N
) > Sloc
(Node
(Elmt
)) then
3308 Error_Node
:= Node
(Elmt
);
3312 ("value may be affected by call to & "
3313 & "because order of evaluation is arbitrary",
3318 -- First occurrence of a elementary type writable actual
3321 Append_New_Elmt
(N
, To
=> Writable_Actuals_List
);
3325 if Identifiers_List
= No_Elist
then
3326 Identifiers_List
:= New_Elmt_List
;
3329 Append_Unique_Elmt
(N
, Identifiers_List
);
3342 N
: Node_Id
) return Boolean
3344 pragma Assert
(Nkind
(N
) in N_Has_Entity
);
3349 if List
= No_Elist
then
3353 Elmt
:= First_Elmt
(List
);
3354 while Present
(Elmt
) loop
3355 if Entity
(Node
(Elmt
)) = Entity
(N
) then
3369 procedure Do_Traversal
is new Traverse_Proc
(Check_Node
);
3370 -- The traversal procedure
3372 -- Start of processing for Collect_Identifiers
3375 if Present
(Error_Node
) then
3379 if Nkind
(N
) in N_Subexpr
and then Is_OK_Static_Expression
(N
) then
3384 end Collect_Identifiers
;
3386 -- Start of processing for Check_Function_Writable_Actuals
3389 -- The check only applies to Ada 2012 code on which Check_Actuals has
3390 -- been set, and only to constructs that have multiple constituents
3391 -- whose order of evaluation is not specified by the language.
3393 if Ada_Version
< Ada_2012
3394 or else not Check_Actuals
(N
)
3395 or else Nkind
(N
) not in N_Op
3399 | N_Extension_Aggregate
3400 | N_Full_Type_Declaration
3402 | N_Procedure_Call_Statement
3403 | N_Entry_Call_Statement
3404 or else (Nkind
(N
) = N_Full_Type_Declaration
3405 and then not Is_Record_Type
(Defining_Identifier
(N
)))
3407 -- In addition, this check only applies to source code, not to code
3408 -- generated by constraint checks.
3410 or else not Comes_From_Source
(N
)
3415 -- If a construct C has two or more direct constituents that are names
3416 -- or expressions whose evaluation may occur in an arbitrary order, at
3417 -- least one of which contains a function call with an in out or out
3418 -- parameter, then the construct is legal only if: for each name N that
3419 -- is passed as a parameter of mode in out or out to some inner function
3420 -- call C2 (not including the construct C itself), there is no other
3421 -- name anywhere within a direct constituent of the construct C other
3422 -- than the one containing C2, that is known to refer to the same
3423 -- object (RM 6.4.1(6.17/3)).
3427 Collect_Identifiers
(Low_Bound
(N
));
3428 Collect_Identifiers
(High_Bound
(N
));
3430 when N_Membership_Test
3437 Collect_Identifiers
(Left_Opnd
(N
));
3439 if Present
(Right_Opnd
(N
)) then
3440 Collect_Identifiers
(Right_Opnd
(N
));
3443 if Nkind
(N
) in N_In | N_Not_In
3444 and then Present
(Alternatives
(N
))
3446 Expr
:= First
(Alternatives
(N
));
3447 while Present
(Expr
) loop
3448 Collect_Identifiers
(Expr
);
3455 when N_Full_Type_Declaration
=>
3457 function Get_Record_Part
(N
: Node_Id
) return Node_Id
;
3458 -- Return the record part of this record type definition
3460 function Get_Record_Part
(N
: Node_Id
) return Node_Id
is
3461 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
3463 if Nkind
(Type_Def
) = N_Derived_Type_Definition
then
3464 return Record_Extension_Part
(Type_Def
);
3468 end Get_Record_Part
;
3471 Def_Id
: Entity_Id
:= Defining_Identifier
(N
);
3472 Rec
: Node_Id
:= Get_Record_Part
(N
);
3475 -- No need to perform any analysis if the record has no
3478 if No
(Rec
) or else No
(Component_List
(Rec
)) then
3482 -- Collect the identifiers starting from the deepest
3483 -- derivation. Done to report the error in the deepest
3487 if Present
(Component_List
(Rec
)) then
3488 Comp
:= First
(Component_Items
(Component_List
(Rec
)));
3489 while Present
(Comp
) loop
3490 if Nkind
(Comp
) = N_Component_Declaration
3491 and then Present
(Expression
(Comp
))
3493 Collect_Identifiers
(Expression
(Comp
));
3500 exit when No
(Underlying_Type
(Etype
(Def_Id
)))
3501 or else Base_Type
(Underlying_Type
(Etype
(Def_Id
)))
3504 Def_Id
:= Base_Type
(Underlying_Type
(Etype
(Def_Id
)));
3505 Rec
:= Get_Record_Part
(Parent
(Def_Id
));
3509 when N_Entry_Call_Statement
3513 Id
: constant Entity_Id
:= Get_Called_Entity
(N
);
3518 Formal
:= First_Formal
(Id
);
3519 Actual
:= First_Actual
(N
);
3520 while Present
(Actual
) and then Present
(Formal
) loop
3521 if Ekind
(Formal
) in E_Out_Parameter | E_In_Out_Parameter
3523 Collect_Identifiers
(Actual
);
3526 Next_Formal
(Formal
);
3527 Next_Actual
(Actual
);
3532 | N_Extension_Aggregate
3537 Comp_Expr
: Node_Id
;
3540 -- Handle the N_Others_Choice of array aggregates with static
3541 -- bounds. There is no need to perform this analysis in
3542 -- aggregates without static bounds since we cannot evaluate
3543 -- if the N_Others_Choice covers several elements. There is
3544 -- no need to handle the N_Others choice of record aggregates
3545 -- since at this stage it has been already expanded by
3546 -- Resolve_Record_Aggregate.
3548 if Is_Array_Type
(Etype
(N
))
3549 and then Nkind
(N
) = N_Aggregate
3550 and then Present
(Aggregate_Bounds
(N
))
3551 and then Compile_Time_Known_Bounds
(Etype
(N
))
3552 and then Expr_Value
(High_Bound
(Aggregate_Bounds
(N
)))
3554 Expr_Value
(Low_Bound
(Aggregate_Bounds
(N
)))
3557 Count_Components
: Uint
:= Uint_0
;
3558 Num_Components
: Uint
;
3559 Others_Assoc
: Node_Id
:= Empty
;
3560 Others_Choice
: Node_Id
:= Empty
;
3561 Others_Box_Present
: Boolean := False;
3564 -- Count positional associations
3566 if Present
(Expressions
(N
)) then
3567 Comp_Expr
:= First
(Expressions
(N
));
3568 while Present
(Comp_Expr
) loop
3569 Count_Components
:= Count_Components
+ 1;
3574 -- Count the rest of elements and locate the N_Others
3577 Assoc
:= First
(Component_Associations
(N
));
3578 while Present
(Assoc
) loop
3579 Choice
:= First
(Choices
(Assoc
));
3580 while Present
(Choice
) loop
3581 if Nkind
(Choice
) = N_Others_Choice
then
3582 Others_Assoc
:= Assoc
;
3583 Others_Choice
:= Choice
;
3584 Others_Box_Present
:= Box_Present
(Assoc
);
3586 -- Count several components
3588 elsif Nkind
(Choice
) in
3589 N_Range | N_Subtype_Indication
3590 or else (Is_Entity_Name
(Choice
)
3591 and then Is_Type
(Entity
(Choice
)))
3596 Get_Index_Bounds
(Choice
, L
, H
);
3598 (Compile_Time_Known_Value
(L
)
3599 and then Compile_Time_Known_Value
(H
));
3602 + Expr_Value
(H
) - Expr_Value
(L
) + 1;
3605 -- Count single component. No other case available
3606 -- since we are handling an aggregate with static
3610 pragma Assert
(Is_OK_Static_Expression
(Choice
)
3611 or else Nkind
(Choice
) = N_Identifier
3612 or else Nkind
(Choice
) = N_Integer_Literal
);
3614 Count_Components
:= Count_Components
+ 1;
3624 Expr_Value
(High_Bound
(Aggregate_Bounds
(N
))) -
3625 Expr_Value
(Low_Bound
(Aggregate_Bounds
(N
))) + 1;
3627 pragma Assert
(Count_Components
<= Num_Components
);
3629 -- Handle the N_Others choice if it covers several
3632 if Present
(Others_Choice
)
3633 and then (Num_Components
- Count_Components
) > 1
3635 if not Others_Box_Present
then
3637 -- At this stage, if expansion is active, the
3638 -- expression of the others choice has not been
3639 -- analyzed. Hence we generate a duplicate and
3640 -- we analyze it silently to have available the
3641 -- minimum decoration required to collect the
3644 pragma Assert
(Present
(Others_Assoc
));
3646 if not Expander_Active
then
3647 Comp_Expr
:= Expression
(Others_Assoc
);
3650 New_Copy_Tree
(Expression
(Others_Assoc
));
3651 Preanalyze_Without_Errors
(Comp_Expr
);
3654 Collect_Identifiers
(Comp_Expr
);
3656 if Writable_Actuals_List
/= No_Elist
then
3658 -- As suggested by Robert, at current stage we
3659 -- report occurrences of this case as warnings.
3662 ("writable function parameter may affect "
3663 & "value in other component because order "
3664 & "of evaluation is unspecified??",
3665 Node
(First_Elmt
(Writable_Actuals_List
)));
3671 -- For an array aggregate, a discrete_choice_list that has
3672 -- a nonstatic range is considered as two or more separate
3673 -- occurrences of the expression (RM 6.4.1(20/3)).
3675 elsif Is_Array_Type
(Etype
(N
))
3676 and then Nkind
(N
) = N_Aggregate
3677 and then Present
(Aggregate_Bounds
(N
))
3678 and then not Compile_Time_Known_Bounds
(Etype
(N
))
3680 -- Collect identifiers found in the dynamic bounds
3683 Count_Components
: Natural := 0;
3684 Low
, High
: Node_Id
;
3687 Assoc
:= First
(Component_Associations
(N
));
3688 while Present
(Assoc
) loop
3689 Choice
:= First
(Choices
(Assoc
));
3690 while Present
(Choice
) loop
3691 if Nkind
(Choice
) in
3692 N_Range | N_Subtype_Indication
3693 or else (Is_Entity_Name
(Choice
)
3694 and then Is_Type
(Entity
(Choice
)))
3696 Get_Index_Bounds
(Choice
, Low
, High
);
3698 if not Compile_Time_Known_Value
(Low
) then
3699 Collect_Identifiers
(Low
);
3701 if No
(Aggr_Error_Node
) then
3702 Aggr_Error_Node
:= Low
;
3706 if not Compile_Time_Known_Value
(High
) then
3707 Collect_Identifiers
(High
);
3709 if No
(Aggr_Error_Node
) then
3710 Aggr_Error_Node
:= High
;
3714 -- The RM rule is violated if there is more than
3715 -- a single choice in a component association.
3718 Count_Components
:= Count_Components
+ 1;
3720 if No
(Aggr_Error_Node
)
3721 and then Count_Components
> 1
3723 Aggr_Error_Node
:= Choice
;
3726 if not Compile_Time_Known_Value
(Choice
) then
3727 Collect_Identifiers
(Choice
);
3739 -- Handle ancestor part of extension aggregates
3741 if Nkind
(N
) = N_Extension_Aggregate
then
3742 Collect_Identifiers
(Ancestor_Part
(N
));
3745 -- Handle positional associations
3747 if Present
(Expressions
(N
)) then
3748 Comp_Expr
:= First
(Expressions
(N
));
3749 while Present
(Comp_Expr
) loop
3750 if not Is_OK_Static_Expression
(Comp_Expr
) then
3751 Collect_Identifiers
(Comp_Expr
);
3758 -- Handle discrete associations
3760 if Present
(Component_Associations
(N
)) then
3761 Assoc
:= First
(Component_Associations
(N
));
3762 while Present
(Assoc
) loop
3764 if not Box_Present
(Assoc
) then
3765 Choice
:= First
(Choices
(Assoc
));
3766 while Present
(Choice
) loop
3768 -- For now we skip discriminants since it requires
3769 -- performing the analysis in two phases: first one
3770 -- analyzing discriminants and second one analyzing
3771 -- the rest of components since discriminants are
3772 -- evaluated prior to components: too much extra
3773 -- work to detect a corner case???
3775 if Nkind
(Choice
) in N_Has_Entity
3776 and then Present
(Entity
(Choice
))
3777 and then Ekind
(Entity
(Choice
)) = E_Discriminant
3781 elsif Box_Present
(Assoc
) then
3785 if not Analyzed
(Expression
(Assoc
)) then
3787 New_Copy_Tree
(Expression
(Assoc
));
3788 Set_Parent
(Comp_Expr
, Parent
(N
));
3789 Preanalyze_Without_Errors
(Comp_Expr
);
3791 Comp_Expr
:= Expression
(Assoc
);
3794 Collect_Identifiers
(Comp_Expr
);
3810 -- No further action needed if we already reported an error
3812 if Present
(Error_Node
) then
3816 -- Check violation of RM 6.20/3 in aggregates
3818 if Present
(Aggr_Error_Node
)
3819 and then Writable_Actuals_List
/= No_Elist
3822 ("value may be affected by call in other component because they "
3823 & "are evaluated in unspecified order",
3824 Node
(First_Elmt
(Writable_Actuals_List
)));
3828 -- Check if some writable argument of a function is referenced
3830 if Writable_Actuals_List
/= No_Elist
3831 and then Identifiers_List
/= No_Elist
3838 Elmt_1
:= First_Elmt
(Writable_Actuals_List
);
3839 while Present
(Elmt_1
) loop
3840 Elmt_2
:= First_Elmt
(Identifiers_List
);
3841 while Present
(Elmt_2
) loop
3842 if Entity
(Node
(Elmt_1
)) = Entity
(Node
(Elmt_2
)) then
3843 case Nkind
(Parent
(Node
(Elmt_2
))) is
3845 | N_Component_Association
3846 | N_Component_Declaration
3849 ("value may be affected by call in other "
3850 & "component because they are evaluated "
3851 & "in unspecified order",
3858 ("value may be affected by call in other "
3859 & "alternative because they are evaluated "
3860 & "in unspecified order",
3865 ("value of actual may be affected by call in "
3866 & "other actual because they are evaluated "
3867 & "in unspecified order",
3879 end Check_Function_Writable_Actuals
;
3881 --------------------------------
3882 -- Check_Implicit_Dereference --
3883 --------------------------------
3885 procedure Check_Implicit_Dereference
(N
: Node_Id
; Typ
: Entity_Id
) is
3891 if Nkind
(N
) = N_Indexed_Component
3892 and then Present
(Generalized_Indexing
(N
))
3894 Nam
:= Generalized_Indexing
(N
);
3899 if Ada_Version
< Ada_2012
3900 or else not Has_Implicit_Dereference
(Base_Type
(Typ
))
3904 elsif not Comes_From_Source
(N
)
3905 and then Nkind
(N
) /= N_Indexed_Component
3909 elsif Is_Entity_Name
(Nam
) and then Is_Type
(Entity
(Nam
)) then
3913 Disc
:= First_Discriminant
(Typ
);
3914 while Present
(Disc
) loop
3915 if Has_Implicit_Dereference
(Disc
) then
3916 Desig
:= Designated_Type
(Etype
(Disc
));
3917 Add_One_Interp
(Nam
, Disc
, Desig
);
3919 -- If the node is a generalized indexing, add interpretation
3920 -- to that node as well, for subsequent resolution.
3922 if Nkind
(N
) = N_Indexed_Component
then
3923 Add_One_Interp
(N
, Disc
, Desig
);
3926 -- If the operation comes from a generic unit and the context
3927 -- is a selected component, the selector name may be global
3928 -- and set in the instance already. Remove the entity to
3929 -- force resolution of the selected component, and the
3930 -- generation of an explicit dereference if needed.
3933 and then Nkind
(Parent
(Nam
)) = N_Selected_Component
3935 Set_Entity
(Selector_Name
(Parent
(Nam
)), Empty
);
3941 Next_Discriminant
(Disc
);
3944 end Check_Implicit_Dereference
;
3946 ----------------------------------
3947 -- Check_Internal_Protected_Use --
3948 ----------------------------------
3950 procedure Check_Internal_Protected_Use
(N
: Node_Id
; Nam
: Entity_Id
) is
3958 while Present
(S
) loop
3959 if S
= Standard_Standard
then
3962 elsif Ekind
(S
) = E_Function
3963 and then Ekind
(Scope
(S
)) = E_Protected_Type
3973 and then Scope
(Nam
) = Prot
3974 and then Ekind
(Nam
) /= E_Function
3976 -- An indirect function call (e.g. a callback within a protected
3977 -- function body) is not statically illegal. If the access type is
3978 -- anonymous and is the type of an access parameter, the scope of Nam
3979 -- will be the protected type, but it is not a protected operation.
3981 if Ekind
(Nam
) = E_Subprogram_Type
3982 and then Nkind
(Associated_Node_For_Itype
(Nam
)) =
3983 N_Function_Specification
3987 elsif Nkind
(N
) = N_Subprogram_Renaming_Declaration
then
3989 ("within protected function cannot use protected procedure in "
3990 & "renaming or as generic actual", N
);
3992 elsif Nkind
(N
) = N_Attribute_Reference
then
3994 ("within protected function cannot take access of protected "
3999 ("within protected function, protected object is constant", N
);
4001 ("\cannot call operation that may modify it", N
);
4005 -- Verify that an internal call does not appear within a precondition
4006 -- of a protected operation. This implements AI12-0166.
4007 -- The precondition aspect has been rewritten as a pragma Precondition
4008 -- and we check whether the scope of the called subprogram is the same
4009 -- as that of the entity to which the aspect applies.
4011 if Convention
(Nam
) = Convention_Protected
then
4017 while Present
(P
) loop
4018 if Nkind
(P
) = N_Pragma
4019 and then Chars
(Pragma_Identifier
(P
)) = Name_Precondition
4020 and then From_Aspect_Specification
(P
)
4022 Scope
(Entity
(Corresponding_Aspect
(P
))) = Scope
(Nam
)
4025 ("internal call cannot appear in precondition of "
4026 & "protected operation", N
);
4029 elsif Nkind
(P
) = N_Pragma
4030 and then Chars
(Pragma_Identifier
(P
)) = Name_Contract_Cases
4032 -- Check whether call is in a case guard. It is legal in a
4036 while Present
(P
) loop
4037 if Nkind
(Parent
(P
)) = N_Component_Association
4038 and then P
/= Expression
(Parent
(P
))
4041 ("internal call cannot appear in case guard in a "
4042 & "contract case", N
);
4050 elsif Nkind
(P
) = N_Parameter_Specification
4051 and then Scope
(Current_Scope
) = Scope
(Nam
)
4052 and then Nkind
(Parent
(P
)) in
4053 N_Entry_Declaration | N_Subprogram_Declaration
4056 ("internal call cannot appear in default for formal of "
4057 & "protected operation", N
);
4065 end Check_Internal_Protected_Use
;
4067 ---------------------------------------
4068 -- Check_Later_Vs_Basic_Declarations --
4069 ---------------------------------------
4071 procedure Check_Later_Vs_Basic_Declarations
4073 During_Parsing
: Boolean)
4075 Body_Sloc
: Source_Ptr
;
4078 function Is_Later_Declarative_Item
(Decl
: Node_Id
) return Boolean;
4079 -- Return whether Decl is considered as a declarative item.
4080 -- When During_Parsing is True, the semantics of Ada 83 is followed.
4081 -- When During_Parsing is False, the semantics of SPARK is followed.
4083 -------------------------------
4084 -- Is_Later_Declarative_Item --
4085 -------------------------------
4087 function Is_Later_Declarative_Item
(Decl
: Node_Id
) return Boolean is
4089 if Nkind
(Decl
) in N_Later_Decl_Item
then
4092 elsif Nkind
(Decl
) = N_Pragma
then
4095 elsif During_Parsing
then
4098 -- In SPARK, a package declaration is not considered as a later
4099 -- declarative item.
4101 elsif Nkind
(Decl
) = N_Package_Declaration
then
4104 -- In SPARK, a renaming is considered as a later declarative item
4106 elsif Nkind
(Decl
) in N_Renaming_Declaration
then
4112 end Is_Later_Declarative_Item
;
4114 -- Start of processing for Check_Later_Vs_Basic_Declarations
4117 Decl
:= First
(Decls
);
4119 -- Loop through sequence of basic declarative items
4121 Outer
: while Present
(Decl
) loop
4122 if Nkind
(Decl
) not in
4123 N_Subprogram_Body | N_Package_Body | N_Task_Body
4124 and then Nkind
(Decl
) not in N_Body_Stub
4128 -- Once a body is encountered, we only allow later declarative
4129 -- items. The inner loop checks the rest of the list.
4132 Body_Sloc
:= Sloc
(Decl
);
4134 Inner
: while Present
(Decl
) loop
4135 if not Is_Later_Declarative_Item
(Decl
) then
4136 if During_Parsing
then
4137 if Ada_Version
= Ada_83
then
4138 Error_Msg_Sloc
:= Body_Sloc
;
4140 ("(Ada 83) decl cannot appear after body#", Decl
);
4149 end Check_Later_Vs_Basic_Declarations
;
4151 ---------------------------
4152 -- Check_No_Hidden_State --
4153 ---------------------------
4155 procedure Check_No_Hidden_State
(Id
: Entity_Id
) is
4156 Context
: Entity_Id
:= Empty
;
4157 Not_Visible
: Boolean := False;
4161 pragma Assert
(Ekind
(Id
) in E_Abstract_State | E_Variable
);
4163 -- Nothing to do for internally-generated abstract states and variables
4164 -- because they do not represent the hidden state of the source unit.
4166 if not Comes_From_Source
(Id
) then
4170 -- Find the proper context where the object or state appears
4173 while Present
(Scop
) loop
4176 -- Keep track of the context's visibility
4178 Not_Visible
:= Not_Visible
or else In_Private_Part
(Context
);
4180 -- Prevent the search from going too far
4182 if Context
= Standard_Standard
then
4185 -- Objects and states that appear immediately within a subprogram or
4186 -- entry inside a construct nested within a subprogram do not
4187 -- introduce a hidden state. They behave as local variable
4188 -- declarations. The same is true for elaboration code inside a block
4191 elsif Is_Subprogram_Or_Entry
(Context
)
4192 or else Ekind
(Context
) in E_Block | E_Task_Type
4197 -- Stop the traversal when a package subject to a null abstract state
4200 if Is_Package_Or_Generic_Package
(Context
)
4201 and then Has_Null_Abstract_State
(Context
)
4206 Scop
:= Scope
(Scop
);
4209 -- At this point we know that there is at least one package with a null
4210 -- abstract state in visibility. Emit an error message unconditionally
4211 -- if the entity being processed is a state because the placement of the
4212 -- related package is irrelevant. This is not the case for objects as
4213 -- the intermediate context matters.
4215 if Present
(Context
)
4216 and then (Ekind
(Id
) = E_Abstract_State
or else Not_Visible
)
4218 Error_Msg_N
("cannot introduce hidden state &", Id
);
4219 Error_Msg_NE
("\package & has null abstract state", Id
, Context
);
4221 end Check_No_Hidden_State
;
4223 ---------------------------------------------
4224 -- Check_Nonoverridable_Aspect_Consistency --
4225 ---------------------------------------------
4227 procedure Check_Inherited_Nonoverridable_Aspects
4228 (Inheritor
: Entity_Id
;
4229 Interface_List
: List_Id
;
4230 Parent_Type
: Entity_Id
) is
4232 -- array needed for iterating over subtype values
4233 Nonoverridable_Aspects
: constant array (Positive range <>) of
4234 Nonoverridable_Aspect_Id
:=
4235 (Aspect_Default_Iterator
,
4236 Aspect_Iterator_Element
,
4237 Aspect_Implicit_Dereference
,
4238 Aspect_Constant_Indexing
,
4239 Aspect_Variable_Indexing
,
4241 Aspect_Max_Entry_Queue_Length
4242 -- , Aspect_No_Controlled_Parts
4245 -- Note that none of these 8 aspects can be specified (for a type)
4246 -- via a pragma. For 7 of them, the corresponding pragma does not
4247 -- exist. The Pragma_Id enumeration type does include
4248 -- Pragma_Max_Entry_Queue_Length, but that pragma is only use to
4249 -- specify the aspect for a protected entry or entry family, not for
4250 -- a type, and therefore cannot introduce the sorts of inheritance
4251 -- issues that we are concerned with in this procedure.
4253 type Entity_Array
is array (Nat
range <>) of Entity_Id
;
4255 function Ancestor_Entities
return Entity_Array
;
4256 -- Returns all progenitors (including parent type, if present)
4258 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors
4259 (Aspect
: Nonoverridable_Aspect_Id
;
4260 Ancestor_1
: Entity_Id
;
4261 Aspect_Spec_1
: Node_Id
;
4262 Ancestor_2
: Entity_Id
;
4263 Aspect_Spec_2
: Node_Id
);
4264 -- A given aspect has been specified for each of two ancestors;
4265 -- check that the two aspect specifications are compatible (see
4266 -- RM 13.1.1(18.5) and AI12-0211).
4268 -----------------------
4269 -- Ancestor_Entities --
4270 -----------------------
4272 function Ancestor_Entities
return Entity_Array
is
4273 Ifc_Count
: constant Nat
:= List_Length
(Interface_List
);
4274 Ifc_Ancestors
: Entity_Array
(1 .. Ifc_Count
);
4275 Ifc
: Node_Id
:= First
(Interface_List
);
4277 for Idx
in Ifc_Ancestors
'Range loop
4278 Ifc_Ancestors
(Idx
) := Entity
(Ifc
);
4279 pragma Assert
(Present
(Ifc_Ancestors
(Idx
)));
4282 pragma Assert
(not Present
(Ifc
));
4283 if Present
(Parent_Type
) then
4284 return Parent_Type
& Ifc_Ancestors
;
4286 return Ifc_Ancestors
;
4288 end Ancestor_Entities
;
4290 -------------------------------------------------------
4291 -- Check_Consistency_For_One_Aspect_Of_Two_Ancestors --
4292 -------------------------------------------------------
4294 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors
4295 (Aspect
: Nonoverridable_Aspect_Id
;
4296 Ancestor_1
: Entity_Id
;
4297 Aspect_Spec_1
: Node_Id
;
4298 Ancestor_2
: Entity_Id
;
4299 Aspect_Spec_2
: Node_Id
) is
4301 if not Is_Confirming
(Aspect
, Aspect_Spec_1
, Aspect_Spec_2
) then
4302 Error_Msg_Name_1
:= Aspect_Names
(Aspect
);
4303 Error_Msg_Name_2
:= Chars
(Ancestor_1
);
4304 Error_Msg_Name_3
:= Chars
(Ancestor_2
);
4307 "incompatible % aspects inherited from ancestors % and %",
4310 end Check_Consistency_For_One_Aspect_Of_Two_Ancestors
;
4312 Ancestors
: constant Entity_Array
:= Ancestor_Entities
;
4314 -- start of processing for Check_Inherited_Nonoverridable_Aspects
4316 -- No Ada_Version check here; AI12-0211 is a binding interpretation.
4318 if Ancestors
'Length < 2 then
4319 return; -- Inconsistency impossible; it takes 2 to disagree.
4320 elsif In_Instance_Body
then
4321 return; -- No legality checking in an instance body.
4324 for Aspect
of Nonoverridable_Aspects
loop
4326 First_Ancestor_With_Aspect
: Entity_Id
:= Empty
;
4327 First_Aspect_Spec
, Current_Aspect_Spec
: Node_Id
:= Empty
;
4329 for Ancestor
of Ancestors
loop
4330 Current_Aspect_Spec
:= Find_Aspect
(Ancestor
, Aspect
);
4331 if Present
(Current_Aspect_Spec
) then
4332 if Present
(First_Ancestor_With_Aspect
) then
4333 Check_Consistency_For_One_Aspect_Of_Two_Ancestors
4335 Ancestor_1
=> First_Ancestor_With_Aspect
,
4336 Aspect_Spec_1
=> First_Aspect_Spec
,
4337 Ancestor_2
=> Ancestor
,
4338 Aspect_Spec_2
=> Current_Aspect_Spec
);
4340 First_Ancestor_With_Aspect
:= Ancestor
;
4341 First_Aspect_Spec
:= Current_Aspect_Spec
;
4347 end Check_Inherited_Nonoverridable_Aspects
;
4349 ----------------------------------------
4350 -- Check_Nonvolatile_Function_Profile --
4351 ----------------------------------------
4353 procedure Check_Nonvolatile_Function_Profile
(Func_Id
: Entity_Id
) is
4357 -- Inspect all formal parameters
4359 Formal
:= First_Formal
(Func_Id
);
4360 while Present
(Formal
) loop
4361 if Is_Effectively_Volatile_For_Reading
(Etype
(Formal
)) then
4363 ("nonvolatile function & cannot have a volatile parameter",
4367 Next_Formal
(Formal
);
4370 -- Inspect the return type
4372 if Is_Effectively_Volatile_For_Reading
(Etype
(Func_Id
)) then
4374 ("nonvolatile function & cannot have a volatile return type",
4375 Result_Definition
(Parent
(Func_Id
)), Func_Id
);
4377 end Check_Nonvolatile_Function_Profile
;
4379 -----------------------------
4380 -- Check_Part_Of_Reference --
4381 -----------------------------
4383 procedure Check_Part_Of_Reference
(Var_Id
: Entity_Id
; Ref
: Node_Id
) is
4384 function Is_Enclosing_Package_Body
4385 (Body_Decl
: Node_Id
;
4386 Obj_Id
: Entity_Id
) return Boolean;
4387 pragma Inline
(Is_Enclosing_Package_Body
);
4388 -- Determine whether package body Body_Decl or its corresponding spec
4389 -- immediately encloses the declaration of object Obj_Id.
4391 function Is_Internal_Declaration_Or_Body
4392 (Decl
: Node_Id
) return Boolean;
4393 pragma Inline
(Is_Internal_Declaration_Or_Body
);
4394 -- Determine whether declaration or body denoted by Decl is internal
4396 function Is_Single_Declaration_Or_Body
4398 Conc_Typ
: Entity_Id
) return Boolean;
4399 pragma Inline
(Is_Single_Declaration_Or_Body
);
4400 -- Determine whether protected/task declaration or body denoted by Decl
4401 -- belongs to single concurrent type Conc_Typ.
4403 function Is_Single_Task_Pragma
4405 Task_Typ
: Entity_Id
) return Boolean;
4406 pragma Inline
(Is_Single_Task_Pragma
);
4407 -- Determine whether pragma Prag belongs to single task type Task_Typ
4409 -------------------------------
4410 -- Is_Enclosing_Package_Body --
4411 -------------------------------
4413 function Is_Enclosing_Package_Body
4414 (Body_Decl
: Node_Id
;
4415 Obj_Id
: Entity_Id
) return Boolean
4417 Obj_Context
: Node_Id
;
4420 -- Find the context of the object declaration
4422 Obj_Context
:= Parent
(Declaration_Node
(Obj_Id
));
4424 if Nkind
(Obj_Context
) = N_Package_Specification
then
4425 Obj_Context
:= Parent
(Obj_Context
);
4428 -- The object appears immediately within the package body
4430 if Obj_Context
= Body_Decl
then
4433 -- The object appears immediately within the corresponding spec
4435 elsif Nkind
(Obj_Context
) = N_Package_Declaration
4436 and then Unit_Declaration_Node
(Corresponding_Spec
(Body_Decl
)) =
4443 end Is_Enclosing_Package_Body
;
4445 -------------------------------------
4446 -- Is_Internal_Declaration_Or_Body --
4447 -------------------------------------
4449 function Is_Internal_Declaration_Or_Body
4450 (Decl
: Node_Id
) return Boolean
4453 if Comes_From_Source
(Decl
) then
4456 -- A body generated for an expression function which has not been
4457 -- inserted into the tree yet (In_Spec_Expression is True) is not
4458 -- considered internal.
4460 elsif Nkind
(Decl
) = N_Subprogram_Body
4461 and then Was_Expression_Function
(Decl
)
4462 and then not In_Spec_Expression
4468 end Is_Internal_Declaration_Or_Body
;
4470 -----------------------------------
4471 -- Is_Single_Declaration_Or_Body --
4472 -----------------------------------
4474 function Is_Single_Declaration_Or_Body
4476 Conc_Typ
: Entity_Id
) return Boolean
4478 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
4482 Present
(Anonymous_Object
(Spec_Id
))
4483 and then Anonymous_Object
(Spec_Id
) = Conc_Typ
;
4484 end Is_Single_Declaration_Or_Body
;
4486 ---------------------------
4487 -- Is_Single_Task_Pragma --
4488 ---------------------------
4490 function Is_Single_Task_Pragma
4492 Task_Typ
: Entity_Id
) return Boolean
4494 Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(Prag
);
4497 -- To qualify, the pragma must be associated with single task type
4501 Is_Single_Task_Object
(Task_Typ
)
4502 and then Nkind
(Decl
) = N_Object_Declaration
4503 and then Defining_Entity
(Decl
) = Task_Typ
;
4504 end Is_Single_Task_Pragma
;
4508 Conc_Obj
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
4513 -- Start of processing for Check_Part_Of_Reference
4516 -- Nothing to do when the variable was recorded, but did not become a
4517 -- constituent of a single concurrent type.
4519 if No
(Conc_Obj
) then
4523 -- Traverse the parent chain looking for a suitable context for the
4524 -- reference to the concurrent constituent.
4527 Par
:= Parent
(Prev
);
4528 while Present
(Par
) loop
4529 if Nkind
(Par
) = N_Pragma
then
4530 Prag_Nam
:= Pragma_Name
(Par
);
4532 -- A concurrent constituent is allowed to appear in pragmas
4533 -- Initial_Condition and Initializes as this is part of the
4534 -- elaboration checks for the constituent (SPARK RM 9(3)).
4536 if Prag_Nam
in Name_Initial_Condition | Name_Initializes
then
4539 -- When the reference appears within pragma Depends or Global,
4540 -- check whether the pragma applies to a single task type. Note
4541 -- that the pragma may not encapsulated by the type definition,
4542 -- but this is still a valid context.
4544 elsif Prag_Nam
in Name_Depends | Name_Global
4545 and then Is_Single_Task_Pragma
(Par
, Conc_Obj
)
4550 -- The reference appears somewhere in the definition of a single
4551 -- concurrent type (SPARK RM 9(3)).
4553 elsif Nkind
(Par
) in
4554 N_Single_Protected_Declaration | N_Single_Task_Declaration
4555 and then Defining_Entity
(Par
) = Conc_Obj
4559 -- The reference appears within the declaration or body of a single
4560 -- concurrent type (SPARK RM 9(3)).
4562 elsif Nkind
(Par
) in N_Protected_Body
4563 | N_Protected_Type_Declaration
4565 | N_Task_Type_Declaration
4566 and then Is_Single_Declaration_Or_Body
(Par
, Conc_Obj
)
4570 -- The reference appears within the statement list of the object's
4571 -- immediately enclosing package (SPARK RM 9(3)).
4573 elsif Nkind
(Par
) = N_Package_Body
4574 and then Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
4575 and then Is_Enclosing_Package_Body
(Par
, Var_Id
)
4579 -- The reference has been relocated within an internally generated
4580 -- package or subprogram. Assume that the reference is legal as the
4581 -- real check was already performed in the original context of the
4584 elsif Nkind
(Par
) in N_Package_Body
4585 | N_Package_Declaration
4587 | N_Subprogram_Declaration
4588 and then Is_Internal_Declaration_Or_Body
(Par
)
4592 -- The reference has been relocated to an inlined body for GNATprove.
4593 -- Assume that the reference is legal as the real check was already
4594 -- performed in the original context of the reference.
4596 elsif GNATprove_Mode
4597 and then Nkind
(Par
) = N_Subprogram_Body
4598 and then Chars
(Defining_Entity
(Par
)) = Name_uParent
4604 Par
:= Parent
(Prev
);
4607 -- At this point it is known that the reference does not appear within a
4611 ("reference to variable & cannot appear in this context", Ref
, Var_Id
);
4612 Error_Msg_Name_1
:= Chars
(Var_Id
);
4614 if Is_Single_Protected_Object
(Conc_Obj
) then
4616 ("\% is constituent of single protected type &", Ref
, Conc_Obj
);
4620 ("\% is constituent of single task type &", Ref
, Conc_Obj
);
4622 end Check_Part_Of_Reference
;
4624 ------------------------------------------
4625 -- Check_Potentially_Blocking_Operation --
4626 ------------------------------------------
4628 procedure Check_Potentially_Blocking_Operation
(N
: Node_Id
) is
4632 -- N is one of the potentially blocking operations listed in 9.5.1(8).
4633 -- When pragma Detect_Blocking is active, the run time will raise
4634 -- Program_Error. Here we only issue a warning, since we generally
4635 -- support the use of potentially blocking operations in the absence
4638 -- Indirect blocking through a subprogram call cannot be diagnosed
4639 -- statically without interprocedural analysis, so we do not attempt
4642 S
:= Scope
(Current_Scope
);
4643 while Present
(S
) and then S
/= Standard_Standard
loop
4644 if Is_Protected_Type
(S
) then
4646 ("potentially blocking operation in protected operation??", N
);
4652 end Check_Potentially_Blocking_Operation
;
4654 ------------------------------------
4655 -- Check_Previous_Null_Procedure --
4656 ------------------------------------
4658 procedure Check_Previous_Null_Procedure
4663 if Ekind
(Prev
) = E_Procedure
4664 and then Nkind
(Parent
(Prev
)) = N_Procedure_Specification
4665 and then Null_Present
(Parent
(Prev
))
4667 Error_Msg_Sloc
:= Sloc
(Prev
);
4669 ("declaration cannot complete previous null procedure#", Decl
);
4671 end Check_Previous_Null_Procedure
;
4673 ---------------------------------
4674 -- Check_Result_And_Post_State --
4675 ---------------------------------
4677 procedure Check_Result_And_Post_State
(Subp_Id
: Entity_Id
) is
4678 procedure Check_Result_And_Post_State_In_Pragma
4680 Result_Seen
: in out Boolean);
4681 -- Determine whether pragma Prag mentions attribute 'Result and whether
4682 -- the pragma contains an expression that evaluates differently in pre-
4683 -- and post-state. Prag is a [refined] postcondition or a contract-cases
4684 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result
4686 function Has_In_Out_Parameter
(Subp_Id
: Entity_Id
) return Boolean;
4687 -- Determine whether subprogram Subp_Id contains at least one IN OUT
4688 -- formal parameter.
4690 -------------------------------------------
4691 -- Check_Result_And_Post_State_In_Pragma --
4692 -------------------------------------------
4694 procedure Check_Result_And_Post_State_In_Pragma
4696 Result_Seen
: in out Boolean)
4698 procedure Check_Conjunct
(Expr
: Node_Id
);
4699 -- Check an individual conjunct in a conjunction of Boolean
4700 -- expressions, connected by "and" or "and then" operators.
4702 procedure Check_Conjuncts
(Expr
: Node_Id
);
4703 -- Apply the post-state check to every conjunct in an expression, in
4704 -- case this is a conjunction of Boolean expressions. Otherwise apply
4705 -- it to the expression as a whole.
4707 procedure Check_Expression
(Expr
: Node_Id
);
4708 -- Perform the 'Result and post-state checks on a given expression
4710 function Is_Function_Result
(N
: Node_Id
) return Traverse_Result
;
4711 -- Attempt to find attribute 'Result in a subtree denoted by N
4713 function Is_Trivial_Boolean
(N
: Node_Id
) return Boolean;
4714 -- Determine whether source node N denotes "True" or "False"
4716 function Mentions_Post_State
(N
: Node_Id
) return Boolean;
4717 -- Determine whether a subtree denoted by N mentions any construct
4718 -- that denotes a post-state.
4720 procedure Check_Function_Result
is
4721 new Traverse_Proc
(Is_Function_Result
);
4723 --------------------
4724 -- Check_Conjunct --
4725 --------------------
4727 procedure Check_Conjunct
(Expr
: Node_Id
) is
4728 function Adjust_Message
(Msg
: String) return String;
4729 -- Prepend a prefix to the input message Msg denoting that the
4730 -- message applies to a conjunct in the expression, when this
4733 function Applied_On_Conjunct
return Boolean;
4734 -- Returns True if the message applies to a conjunct in the
4735 -- expression, instead of the whole expression.
4737 function Has_Global_Output
(Subp
: Entity_Id
) return Boolean;
4738 -- Returns True if Subp has an output in its Global contract
4740 function Has_No_Output
(Subp
: Entity_Id
) return Boolean;
4741 -- Returns True if Subp has no declared output: no function
4742 -- result, no output parameter, and no output in its Global
4745 --------------------
4746 -- Adjust_Message --
4747 --------------------
4749 function Adjust_Message
(Msg
: String) return String is
4751 if Applied_On_Conjunct
then
4752 return "conjunct in " & Msg
;
4758 -------------------------
4759 -- Applied_On_Conjunct --
4760 -------------------------
4762 function Applied_On_Conjunct
return Boolean is
4764 -- Expr is the conjunct of an enclosing "and" expression
4766 return Nkind
(Parent
(Expr
)) in N_Subexpr
4768 -- or Expr is a conjunct of an enclosing "and then"
4769 -- expression in a postcondition aspect that was split into
4770 -- multiple pragmas. The first conjunct has the "and then"
4771 -- expression as Original_Node, and other conjuncts have
4772 -- Split_PCC set to True.
4774 or else Nkind
(Original_Node
(Expr
)) = N_And_Then
4775 or else Split_PPC
(Prag
);
4776 end Applied_On_Conjunct
;
4778 -----------------------
4779 -- Has_Global_Output --
4780 -----------------------
4782 function Has_Global_Output
(Subp
: Entity_Id
) return Boolean is
4783 Global
: constant Node_Id
:= Get_Pragma
(Subp
, Pragma_Global
);
4792 List
:= Expression
(Get_Argument
(Global
, Subp
));
4794 -- Empty list (no global items) or single global item
4795 -- declaration (only input items).
4797 if Nkind
(List
) in N_Null
4800 | N_Selected_Component
4804 -- Simple global list (only input items) or moded global list
4807 elsif Nkind
(List
) = N_Aggregate
then
4808 if Present
(Expressions
(List
)) then
4812 Assoc
:= First
(Component_Associations
(List
));
4813 while Present
(Assoc
) loop
4814 if Chars
(First
(Choices
(Assoc
))) /= Name_Input
then
4824 -- To accommodate partial decoration of disabled SPARK
4825 -- features, this routine may be called with illegal input.
4826 -- If this is the case, do not raise Program_Error.
4831 end Has_Global_Output
;
4837 function Has_No_Output
(Subp
: Entity_Id
) return Boolean is
4841 -- A function has its result as output
4843 if Ekind
(Subp
) = E_Function
then
4847 -- An OUT or IN OUT parameter is an output
4849 Param
:= First_Formal
(Subp
);
4850 while Present
(Param
) loop
4851 if Ekind
(Param
) in E_Out_Parameter | E_In_Out_Parameter
then
4855 Next_Formal
(Param
);
4858 -- An item of mode Output or In_Out in the Global contract is
4861 if Has_Global_Output
(Subp
) then
4871 -- Error node when reporting a warning on a (refined)
4874 -- Start of processing for Check_Conjunct
4877 if Applied_On_Conjunct
then
4883 -- Do not report missing reference to outcome in postcondition if
4884 -- either the postcondition is trivially True or False, or if the
4885 -- subprogram is ghost and has no declared output.
4887 if not Is_Trivial_Boolean
(Expr
)
4888 and then not Mentions_Post_State
(Expr
)
4889 and then not (Is_Ghost_Entity
(Subp_Id
)
4890 and then Has_No_Output
(Subp_Id
))
4892 if Pragma_Name
(Prag
) = Name_Contract_Cases
then
4893 Error_Msg_NE
(Adjust_Message
4894 ("contract case does not check the outcome of calling "
4895 & "&?T?"), Expr
, Subp_Id
);
4897 elsif Pragma_Name
(Prag
) = Name_Refined_Post
then
4898 Error_Msg_NE
(Adjust_Message
4899 ("refined postcondition does not check the outcome of "
4900 & "calling &?T?"), Err_Node
, Subp_Id
);
4903 Error_Msg_NE
(Adjust_Message
4904 ("postcondition does not check the outcome of calling "
4905 & "&?T?"), Err_Node
, Subp_Id
);
4910 ---------------------
4911 -- Check_Conjuncts --
4912 ---------------------
4914 procedure Check_Conjuncts
(Expr
: Node_Id
) is
4916 if Nkind
(Expr
) in N_Op_And | N_And_Then
then
4917 Check_Conjuncts
(Left_Opnd
(Expr
));
4918 Check_Conjuncts
(Right_Opnd
(Expr
));
4920 Check_Conjunct
(Expr
);
4922 end Check_Conjuncts
;
4924 ----------------------
4925 -- Check_Expression --
4926 ----------------------
4928 procedure Check_Expression
(Expr
: Node_Id
) is
4930 if not Is_Trivial_Boolean
(Expr
) then
4931 Check_Function_Result
(Expr
);
4932 Check_Conjuncts
(Expr
);
4934 end Check_Expression
;
4936 ------------------------
4937 -- Is_Function_Result --
4938 ------------------------
4940 function Is_Function_Result
(N
: Node_Id
) return Traverse_Result
is
4942 if Is_Attribute_Result
(N
) then
4943 Result_Seen
:= True;
4946 -- Warn on infinite recursion if call is to current function
4948 elsif Nkind
(N
) = N_Function_Call
4949 and then Is_Entity_Name
(Name
(N
))
4950 and then Entity
(Name
(N
)) = Subp_Id
4951 and then not Is_Potentially_Unevaluated
(N
)
4954 ("call to & within its postcondition will lead to infinite "
4955 & "recursion?", N
, Subp_Id
);
4958 -- Continue the traversal
4963 end Is_Function_Result
;
4965 ------------------------
4966 -- Is_Trivial_Boolean --
4967 ------------------------
4969 function Is_Trivial_Boolean
(N
: Node_Id
) return Boolean is
4972 Comes_From_Source
(N
)
4973 and then Is_Entity_Name
(N
)
4974 and then (Entity
(N
) = Standard_True
4976 Entity
(N
) = Standard_False
);
4977 end Is_Trivial_Boolean
;
4979 -------------------------
4980 -- Mentions_Post_State --
4981 -------------------------
4983 function Mentions_Post_State
(N
: Node_Id
) return Boolean is
4984 Post_State_Seen
: Boolean := False;
4986 function Is_Post_State
(N
: Node_Id
) return Traverse_Result
;
4987 -- Attempt to find a construct that denotes a post-state. If this
4988 -- is the case, set flag Post_State_Seen.
4994 function Is_Post_State
(N
: Node_Id
) return Traverse_Result
is
4998 if Nkind
(N
) in N_Explicit_Dereference | N_Function_Call
then
4999 Post_State_Seen
:= True;
5002 elsif Nkind
(N
) in N_Expanded_Name | N_Identifier
then
5005 -- Treat an undecorated reference as OK
5009 -- A reference to an assignable entity is considered a
5010 -- change in the post-state of a subprogram.
5012 or else Ekind
(Ent
) in E_Generic_In_Out_Parameter
5013 | E_In_Out_Parameter
5017 -- The reference may be modified through a dereference
5019 or else (Is_Access_Type
(Etype
(Ent
))
5020 and then Nkind
(Parent
(N
)) =
5021 N_Selected_Component
)
5023 Post_State_Seen
:= True;
5027 elsif Nkind
(N
) = N_Attribute_Reference
then
5028 if Attribute_Name
(N
) = Name_Old
then
5031 elsif Attribute_Name
(N
) = Name_Result
then
5032 Post_State_Seen
:= True;
5040 procedure Find_Post_State
is new Traverse_Proc
(Is_Post_State
);
5042 -- Start of processing for Mentions_Post_State
5045 Find_Post_State
(N
);
5047 return Post_State_Seen
;
5048 end Mentions_Post_State
;
5052 Expr
: constant Node_Id
:=
5054 (First
(Pragma_Argument_Associations
(Prag
)));
5055 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
5058 -- Start of processing for Check_Result_And_Post_State_In_Pragma
5061 -- Examine all consequences
5063 if Nam
= Name_Contract_Cases
then
5064 CCase
:= First
(Component_Associations
(Expr
));
5065 while Present
(CCase
) loop
5066 Check_Expression
(Expression
(CCase
));
5071 -- Examine the expression of a postcondition
5073 else pragma Assert
(Nam
in Name_Postcondition | Name_Refined_Post
);
5074 Check_Expression
(Expr
);
5076 end Check_Result_And_Post_State_In_Pragma
;
5078 --------------------------
5079 -- Has_In_Out_Parameter --
5080 --------------------------
5082 function Has_In_Out_Parameter
(Subp_Id
: Entity_Id
) return Boolean is
5086 -- Traverse the formals looking for an IN OUT parameter
5088 Formal
:= First_Formal
(Subp_Id
);
5089 while Present
(Formal
) loop
5090 if Ekind
(Formal
) = E_In_Out_Parameter
then
5094 Next_Formal
(Formal
);
5098 end Has_In_Out_Parameter
;
5102 Items
: constant Node_Id
:= Contract
(Subp_Id
);
5103 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
5104 Case_Prag
: Node_Id
:= Empty
;
5105 Post_Prag
: Node_Id
:= Empty
;
5107 Seen_In_Case
: Boolean := False;
5108 Seen_In_Post
: Boolean := False;
5109 Spec_Id
: Entity_Id
;
5111 -- Start of processing for Check_Result_And_Post_State
5114 -- The lack of attribute 'Result or a post-state is classified as a
5115 -- suspicious contract. Do not perform the check if the corresponding
5116 -- swich is not set.
5118 if not Warn_On_Suspicious_Contract
then
5121 -- Nothing to do if there is no contract
5123 elsif No
(Items
) then
5127 -- Retrieve the entity of the subprogram spec (if any)
5129 if Nkind
(Subp_Decl
) = N_Subprogram_Body
5130 and then Present
(Corresponding_Spec
(Subp_Decl
))
5132 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
5134 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
5135 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
5137 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
5143 -- Examine all postconditions for attribute 'Result and a post-state
5145 Prag
:= Pre_Post_Conditions
(Items
);
5146 while Present
(Prag
) loop
5147 if Pragma_Name_Unmapped
(Prag
)
5148 in Name_Postcondition | Name_Refined_Post
5149 and then not Error_Posted
(Prag
)
5152 Check_Result_And_Post_State_In_Pragma
(Prag
, Seen_In_Post
);
5155 Prag
:= Next_Pragma
(Prag
);
5158 -- Examine the contract cases of the subprogram for attribute 'Result
5159 -- and a post-state.
5161 Prag
:= Contract_Test_Cases
(Items
);
5162 while Present
(Prag
) loop
5163 if Pragma_Name
(Prag
) = Name_Contract_Cases
5164 and then not Error_Posted
(Prag
)
5167 Check_Result_And_Post_State_In_Pragma
(Prag
, Seen_In_Case
);
5170 Prag
:= Next_Pragma
(Prag
);
5173 -- Do not emit any errors if the subprogram is not a function
5175 if Ekind
(Spec_Id
) not in E_Function | E_Generic_Function
then
5178 -- Regardless of whether the function has postconditions or contract
5179 -- cases, or whether they mention attribute 'Result, an IN OUT formal
5180 -- parameter is always treated as a result.
5182 elsif Has_In_Out_Parameter
(Spec_Id
) then
5185 -- The function has both a postcondition and contract cases and they do
5186 -- not mention attribute 'Result.
5188 elsif Present
(Case_Prag
)
5189 and then not Seen_In_Case
5190 and then Present
(Post_Prag
)
5191 and then not Seen_In_Post
5194 ("neither postcondition nor contract cases mention function "
5195 & "result?T?", Post_Prag
);
5197 -- The function has contract cases only and they do not mention
5198 -- attribute 'Result.
5200 elsif Present
(Case_Prag
) and then not Seen_In_Case
then
5201 Error_Msg_N
("contract cases do not mention result?T?", Case_Prag
);
5203 -- The function has postconditions only and they do not mention
5204 -- attribute 'Result.
5206 elsif Present
(Post_Prag
) and then not Seen_In_Post
then
5208 ("postcondition does not mention function result?T?", Post_Prag
);
5210 end Check_Result_And_Post_State
;
5212 -----------------------------
5213 -- Check_State_Refinements --
5214 -----------------------------
5216 procedure Check_State_Refinements
5218 Is_Main_Unit
: Boolean := False)
5220 procedure Check_Package
(Pack
: Node_Id
);
5221 -- Verify that all abstract states of a [generic] package denoted by its
5222 -- declarative node Pack have proper refinement. Recursively verify the
5223 -- visible and private declarations of the [generic] package for other
5226 procedure Check_Packages_In
(Decls
: List_Id
);
5227 -- Seek out [generic] package declarations within declarative list Decls
5228 -- and verify the status of their abstract state refinement.
5230 function SPARK_Mode_Is_Off
(N
: Node_Id
) return Boolean;
5231 -- Determine whether construct N is subject to pragma SPARK_Mode Off
5237 procedure Check_Package
(Pack
: Node_Id
) is
5238 Body_Id
: constant Entity_Id
:= Corresponding_Body
(Pack
);
5239 Spec
: constant Node_Id
:= Specification
(Pack
);
5240 States
: constant Elist_Id
:=
5241 Abstract_States
(Defining_Entity
(Pack
));
5243 State_Elmt
: Elmt_Id
;
5244 State_Id
: Entity_Id
;
5247 -- Do not verify proper state refinement when the package is subject
5248 -- to pragma SPARK_Mode Off because this disables the requirement for
5249 -- state refinement.
5251 if SPARK_Mode_Is_Off
(Pack
) then
5254 -- State refinement can only occur in a completing package body. Do
5255 -- not verify proper state refinement when the body is subject to
5256 -- pragma SPARK_Mode Off because this disables the requirement for
5257 -- state refinement.
5259 elsif Present
(Body_Id
)
5260 and then SPARK_Mode_Is_Off
(Unit_Declaration_Node
(Body_Id
))
5264 -- Do not verify proper state refinement when the package is an
5265 -- instance as this check was already performed in the generic.
5267 elsif Present
(Generic_Parent
(Spec
)) then
5270 -- Otherwise examine the contents of the package
5273 if Present
(States
) then
5274 State_Elmt
:= First_Elmt
(States
);
5275 while Present
(State_Elmt
) loop
5276 State_Id
:= Node
(State_Elmt
);
5278 -- Emit an error when a non-null state lacks any form of
5281 if not Is_Null_State
(State_Id
)
5282 and then not Has_Null_Refinement
(State_Id
)
5283 and then not Has_Non_Null_Refinement
(State_Id
)
5285 Error_Msg_N
("state & requires refinement", State_Id
);
5288 Next_Elmt
(State_Elmt
);
5292 Check_Packages_In
(Visible_Declarations
(Spec
));
5293 Check_Packages_In
(Private_Declarations
(Spec
));
5297 -----------------------
5298 -- Check_Packages_In --
5299 -----------------------
5301 procedure Check_Packages_In
(Decls
: List_Id
) is
5305 if Present
(Decls
) then
5306 Decl
:= First
(Decls
);
5307 while Present
(Decl
) loop
5308 if Nkind
(Decl
) in N_Generic_Package_Declaration
5309 | N_Package_Declaration
5311 Check_Package
(Decl
);
5317 end Check_Packages_In
;
5319 -----------------------
5320 -- SPARK_Mode_Is_Off --
5321 -----------------------
5323 function SPARK_Mode_Is_Off
(N
: Node_Id
) return Boolean is
5324 Id
: constant Entity_Id
:= Defining_Entity
(N
);
5325 Prag
: constant Node_Id
:= SPARK_Pragma
(Id
);
5328 -- Default the mode to "off" when the context is an instance and all
5329 -- SPARK_Mode pragmas found within are to be ignored.
5331 if Ignore_SPARK_Mode_Pragmas
(Id
) then
5337 and then Get_SPARK_Mode_From_Annotation
(Prag
) = Off
;
5339 end SPARK_Mode_Is_Off
;
5341 -- Start of processing for Check_State_Refinements
5344 -- A block may declare a nested package
5346 if Nkind
(Context
) = N_Block_Statement
then
5347 Check_Packages_In
(Declarations
(Context
));
5349 -- An entry, protected, subprogram, or task body may declare a nested
5352 elsif Nkind
(Context
) in N_Entry_Body
5357 -- Do not verify proper state refinement when the body is subject to
5358 -- pragma SPARK_Mode Off because this disables the requirement for
5359 -- state refinement.
5361 if not SPARK_Mode_Is_Off
(Context
) then
5362 Check_Packages_In
(Declarations
(Context
));
5365 -- A package body may declare a nested package
5367 elsif Nkind
(Context
) = N_Package_Body
then
5368 Check_Package
(Unit_Declaration_Node
(Corresponding_Spec
(Context
)));
5370 -- Do not verify proper state refinement when the body is subject to
5371 -- pragma SPARK_Mode Off because this disables the requirement for
5372 -- state refinement.
5374 if not SPARK_Mode_Is_Off
(Context
) then
5375 Check_Packages_In
(Declarations
(Context
));
5378 -- A library level [generic] package may declare a nested package
5380 elsif Nkind
(Context
) in
5381 N_Generic_Package_Declaration | N_Package_Declaration
5382 and then Is_Main_Unit
5384 Check_Package
(Context
);
5386 end Check_State_Refinements
;
5388 ------------------------------
5389 -- Check_Unprotected_Access --
5390 ------------------------------
5392 procedure Check_Unprotected_Access
5396 Cont_Encl_Typ
: Entity_Id
;
5397 Pref_Encl_Typ
: Entity_Id
;
5399 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
;
5400 -- Check whether Obj is a private component of a protected object.
5401 -- Return the protected type where the component resides, Empty
5404 function Is_Public_Operation
return Boolean;
5405 -- Verify that the enclosing operation is callable from outside the
5406 -- protected object, to minimize false positives.
5408 ------------------------------
5409 -- Enclosing_Protected_Type --
5410 ------------------------------
5412 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
is
5414 if Is_Entity_Name
(Obj
) then
5416 Ent
: Entity_Id
:= Entity
(Obj
);
5419 -- The object can be a renaming of a private component, use
5420 -- the original record component.
5422 if Is_Prival
(Ent
) then
5423 Ent
:= Prival_Link
(Ent
);
5426 if Is_Protected_Type
(Scope
(Ent
)) then
5432 -- For indexed and selected components, recursively check the prefix
5434 if Nkind
(Obj
) in N_Indexed_Component | N_Selected_Component
then
5435 return Enclosing_Protected_Type
(Prefix
(Obj
));
5437 -- The object does not denote a protected component
5442 end Enclosing_Protected_Type
;
5444 -------------------------
5445 -- Is_Public_Operation --
5446 -------------------------
5448 function Is_Public_Operation
return Boolean is
5454 while Present
(S
) and then S
/= Pref_Encl_Typ
loop
5455 if Scope
(S
) = Pref_Encl_Typ
then
5456 E
:= First_Entity
(Pref_Encl_Typ
);
5458 and then E
/= First_Private_Entity
(Pref_Encl_Typ
)
5472 end Is_Public_Operation
;
5474 -- Start of processing for Check_Unprotected_Access
5477 if Nkind
(Expr
) = N_Attribute_Reference
5478 and then Attribute_Name
(Expr
) = Name_Unchecked_Access
5480 Cont_Encl_Typ
:= Enclosing_Protected_Type
(Context
);
5481 Pref_Encl_Typ
:= Enclosing_Protected_Type
(Prefix
(Expr
));
5483 -- Check whether we are trying to export a protected component to a
5484 -- context with an equal or lower access level.
5486 if Present
(Pref_Encl_Typ
)
5487 and then No
(Cont_Encl_Typ
)
5488 and then Is_Public_Operation
5489 and then Scope_Depth
(Pref_Encl_Typ
)
5490 >= Static_Accessibility_Level
5491 (Context
, Object_Decl_Level
)
5494 ("??possible unprotected access to protected data", Expr
);
5497 end Check_Unprotected_Access
;
5499 ------------------------------
5500 -- Check_Unused_Body_States --
5501 ------------------------------
5503 procedure Check_Unused_Body_States
(Body_Id
: Entity_Id
) is
5504 procedure Process_Refinement_Clause
5507 -- Inspect all constituents of refinement clause Clause and remove any
5508 -- matches from body state list States.
5510 procedure Report_Unused_Body_States
(States
: Elist_Id
);
5511 -- Emit errors for each abstract state or object found in list States
5513 -------------------------------
5514 -- Process_Refinement_Clause --
5515 -------------------------------
5517 procedure Process_Refinement_Clause
5521 procedure Process_Constituent
(Constit
: Node_Id
);
5522 -- Remove constituent Constit from body state list States
5524 -------------------------
5525 -- Process_Constituent --
5526 -------------------------
5528 procedure Process_Constituent
(Constit
: Node_Id
) is
5529 Constit_Id
: Entity_Id
;
5532 -- Guard against illegal constituents. Only abstract states and
5533 -- objects can appear on the right hand side of a refinement.
5535 if Is_Entity_Name
(Constit
) then
5536 Constit_Id
:= Entity_Of
(Constit
);
5538 if Present
(Constit_Id
)
5539 and then Ekind
(Constit_Id
) in
5540 E_Abstract_State | E_Constant | E_Variable
5542 Remove
(States
, Constit_Id
);
5545 end Process_Constituent
;
5551 -- Start of processing for Process_Refinement_Clause
5554 if Nkind
(Clause
) = N_Component_Association
then
5555 Constit
:= Expression
(Clause
);
5557 -- Multiple constituents appear as an aggregate
5559 if Nkind
(Constit
) = N_Aggregate
then
5560 Constit
:= First
(Expressions
(Constit
));
5561 while Present
(Constit
) loop
5562 Process_Constituent
(Constit
);
5566 -- Various forms of a single constituent
5569 Process_Constituent
(Constit
);
5572 end Process_Refinement_Clause
;
5574 -------------------------------
5575 -- Report_Unused_Body_States --
5576 -------------------------------
5578 procedure Report_Unused_Body_States
(States
: Elist_Id
) is
5579 Posted
: Boolean := False;
5580 State_Elmt
: Elmt_Id
;
5581 State_Id
: Entity_Id
;
5584 if Present
(States
) then
5585 State_Elmt
:= First_Elmt
(States
);
5586 while Present
(State_Elmt
) loop
5587 State_Id
:= Node
(State_Elmt
);
5589 -- Constants are part of the hidden state of a package, but the
5590 -- compiler cannot determine whether they have variable input
5591 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a
5592 -- hidden state. Do not emit an error when a constant does not
5593 -- participate in a state refinement, even though it acts as a
5596 if Ekind
(State_Id
) = E_Constant
then
5599 -- Generate an error message of the form:
5601 -- body of package ... has unused hidden states
5602 -- abstract state ... defined at ...
5603 -- variable ... defined at ...
5609 ("body of package & has unused hidden states", Body_Id
);
5612 Error_Msg_Sloc
:= Sloc
(State_Id
);
5614 if Ekind
(State_Id
) = E_Abstract_State
then
5616 ("\abstract state & defined #", Body_Id
, State_Id
);
5619 SPARK_Msg_NE
("\variable & defined #", Body_Id
, State_Id
);
5623 Next_Elmt
(State_Elmt
);
5626 end Report_Unused_Body_States
;
5630 Prag
: constant Node_Id
:= Get_Pragma
(Body_Id
, Pragma_Refined_State
);
5631 Spec_Id
: constant Entity_Id
:= Spec_Entity
(Body_Id
);
5635 -- Start of processing for Check_Unused_Body_States
5638 -- Inspect the clauses of pragma Refined_State and determine whether all
5639 -- visible states declared within the package body participate in the
5642 if Present
(Prag
) then
5643 Clause
:= Expression
(Get_Argument
(Prag
, Spec_Id
));
5644 States
:= Collect_Body_States
(Body_Id
);
5646 -- Multiple non-null state refinements appear as an aggregate
5648 if Nkind
(Clause
) = N_Aggregate
then
5649 Clause
:= First
(Component_Associations
(Clause
));
5650 while Present
(Clause
) loop
5651 Process_Refinement_Clause
(Clause
, States
);
5655 -- Various forms of a single state refinement
5658 Process_Refinement_Clause
(Clause
, States
);
5661 -- Ensure that all abstract states and objects declared in the
5662 -- package body state space are utilized as constituents.
5664 Report_Unused_Body_States
(States
);
5666 end Check_Unused_Body_States
;
5668 ------------------------------------
5669 -- Check_Volatility_Compatibility --
5670 ------------------------------------
5672 procedure Check_Volatility_Compatibility
5673 (Id1
, Id2
: Entity_Id
;
5674 Description_1
, Description_2
: String;
5675 Srcpos_Bearer
: Node_Id
) is
5678 if SPARK_Mode
/= On
then
5683 AR1
: constant Boolean := Async_Readers_Enabled
(Id1
);
5684 AW1
: constant Boolean := Async_Writers_Enabled
(Id1
);
5685 ER1
: constant Boolean := Effective_Reads_Enabled
(Id1
);
5686 EW1
: constant Boolean := Effective_Writes_Enabled
(Id1
);
5687 AR2
: constant Boolean := Async_Readers_Enabled
(Id2
);
5688 AW2
: constant Boolean := Async_Writers_Enabled
(Id2
);
5689 ER2
: constant Boolean := Effective_Reads_Enabled
(Id2
);
5690 EW2
: constant Boolean := Effective_Writes_Enabled
(Id2
);
5692 AR_Check_Failed
: constant Boolean := AR1
and not AR2
;
5693 AW_Check_Failed
: constant Boolean := AW1
and not AW2
;
5694 ER_Check_Failed
: constant Boolean := ER1
and not ER2
;
5695 EW_Check_Failed
: constant Boolean := EW1
and not EW2
;
5697 package Failure_Description
is
5698 procedure Note_If_Failure
5699 (Failed
: Boolean; Aspect_Name
: String);
5700 -- If Failed is False, do nothing.
5701 -- If Failed is True, add Aspect_Name to the failure description.
5703 function Failure_Text
return String;
5704 -- returns accumulated list of failing aspects
5705 end Failure_Description
;
5707 package body Failure_Description
is
5708 Description_Buffer
: Bounded_String
;
5710 ---------------------
5711 -- Note_If_Failure --
5712 ---------------------
5714 procedure Note_If_Failure
5715 (Failed
: Boolean; Aspect_Name
: String) is
5718 if Description_Buffer
.Length
/= 0 then
5719 Append
(Description_Buffer
, ", ");
5721 Append
(Description_Buffer
, Aspect_Name
);
5723 end Note_If_Failure
;
5729 function Failure_Text
return String is
5731 return +Description_Buffer
;
5733 end Failure_Description
;
5735 use Failure_Description
;
5742 Note_If_Failure
(AR_Check_Failed
, "Async_Readers");
5743 Note_If_Failure
(AW_Check_Failed
, "Async_Writers");
5744 Note_If_Failure
(ER_Check_Failed
, "Effective_Reads");
5745 Note_If_Failure
(EW_Check_Failed
, "Effective_Writes");
5751 & " are not compatible with respect to volatility due to "
5756 end Check_Volatility_Compatibility
;
5762 function Choice_List
(N
: Node_Id
) return List_Id
is
5764 if Nkind
(N
) = N_Iterated_Component_Association
then
5765 return Discrete_Choices
(N
);
5771 -------------------------
5772 -- Collect_Body_States --
5773 -------------------------
5775 function Collect_Body_States
(Body_Id
: Entity_Id
) return Elist_Id
is
5776 function Is_Visible_Object
(Obj_Id
: Entity_Id
) return Boolean;
5777 -- Determine whether object Obj_Id is a suitable visible state of a
5780 procedure Collect_Visible_States
5781 (Pack_Id
: Entity_Id
;
5782 States
: in out Elist_Id
);
5783 -- Gather the entities of all abstract states and objects declared in
5784 -- the visible state space of package Pack_Id.
5786 ----------------------------
5787 -- Collect_Visible_States --
5788 ----------------------------
5790 procedure Collect_Visible_States
5791 (Pack_Id
: Entity_Id
;
5792 States
: in out Elist_Id
)
5794 Item_Id
: Entity_Id
;
5797 -- Traverse the entity chain of the package and inspect all visible
5800 Item_Id
:= First_Entity
(Pack_Id
);
5801 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
5803 -- Do not consider internally generated items as those cannot be
5804 -- named and participate in refinement.
5806 if not Comes_From_Source
(Item_Id
) then
5809 elsif Ekind
(Item_Id
) = E_Abstract_State
then
5810 Append_New_Elmt
(Item_Id
, States
);
5812 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
5813 and then Is_Visible_Object
(Item_Id
)
5815 Append_New_Elmt
(Item_Id
, States
);
5817 -- Recursively gather the visible states of a nested package
5819 elsif Ekind
(Item_Id
) = E_Package
then
5820 Collect_Visible_States
(Item_Id
, States
);
5823 Next_Entity
(Item_Id
);
5825 end Collect_Visible_States
;
5827 -----------------------
5828 -- Is_Visible_Object --
5829 -----------------------
5831 function Is_Visible_Object
(Obj_Id
: Entity_Id
) return Boolean is
5833 -- Objects that map generic formals to their actuals are not visible
5834 -- from outside the generic instantiation.
5836 if Present
(Corresponding_Generic_Association
5837 (Declaration_Node
(Obj_Id
)))
5841 -- Constituents of a single protected/task type act as components of
5842 -- the type and are not visible from outside the type.
5844 elsif Ekind
(Obj_Id
) = E_Variable
5845 and then Present
(Encapsulating_State
(Obj_Id
))
5846 and then Is_Single_Concurrent_Object
(Encapsulating_State
(Obj_Id
))
5853 end Is_Visible_Object
;
5857 Body_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Body_Id
);
5859 Item_Id
: Entity_Id
;
5860 States
: Elist_Id
:= No_Elist
;
5862 -- Start of processing for Collect_Body_States
5865 -- Inspect the declarations of the body looking for source objects,
5866 -- packages and package instantiations. Note that even though this
5867 -- processing is very similar to Collect_Visible_States, a package
5868 -- body does not have a First/Next_Entity list.
5870 Decl
:= First
(Declarations
(Body_Decl
));
5871 while Present
(Decl
) loop
5873 -- Capture source objects as internally generated temporaries cannot
5874 -- be named and participate in refinement.
5876 if Nkind
(Decl
) = N_Object_Declaration
then
5877 Item_Id
:= Defining_Entity
(Decl
);
5879 if Comes_From_Source
(Item_Id
)
5880 and then Is_Visible_Object
(Item_Id
)
5882 Append_New_Elmt
(Item_Id
, States
);
5885 -- Capture the visible abstract states and objects of a source
5886 -- package [instantiation].
5888 elsif Nkind
(Decl
) = N_Package_Declaration
then
5889 Item_Id
:= Defining_Entity
(Decl
);
5891 if Comes_From_Source
(Item_Id
) then
5892 Collect_Visible_States
(Item_Id
, States
);
5900 end Collect_Body_States
;
5902 ------------------------
5903 -- Collect_Interfaces --
5904 ------------------------
5906 procedure Collect_Interfaces
5908 Ifaces_List
: out Elist_Id
;
5909 Exclude_Parents
: Boolean := False;
5910 Use_Full_View
: Boolean := True)
5912 procedure Collect
(Typ
: Entity_Id
);
5913 -- Subsidiary subprogram used to traverse the whole list
5914 -- of directly and indirectly implemented interfaces
5920 procedure Collect
(Typ
: Entity_Id
) is
5921 Ancestor
: Entity_Id
;
5929 -- Handle private types and subtypes
5932 and then Is_Private_Type
(Typ
)
5933 and then Present
(Full_View
(Typ
))
5935 Full_T
:= Full_View
(Typ
);
5937 if Ekind
(Full_T
) = E_Record_Subtype
then
5938 Full_T
:= Etype
(Typ
);
5940 if Present
(Full_View
(Full_T
)) then
5941 Full_T
:= Full_View
(Full_T
);
5946 -- Include the ancestor if we are generating the whole list of
5947 -- abstract interfaces.
5949 if Etype
(Full_T
) /= Typ
5951 -- Protect the frontend against wrong sources. For example:
5954 -- type A is tagged null record;
5955 -- type B is new A with private;
5956 -- type C is new A with private;
5958 -- type B is new C with null record;
5959 -- type C is new B with null record;
5962 and then Etype
(Full_T
) /= T
5964 Ancestor
:= Etype
(Full_T
);
5967 if Is_Interface
(Ancestor
) and then not Exclude_Parents
then
5968 Append_Unique_Elmt
(Ancestor
, Ifaces_List
);
5972 -- Traverse the graph of ancestor interfaces
5974 if Is_Non_Empty_List
(Abstract_Interface_List
(Full_T
)) then
5975 Id
:= First
(Abstract_Interface_List
(Full_T
));
5976 while Present
(Id
) loop
5977 Iface
:= Etype
(Id
);
5979 -- Protect against wrong uses. For example:
5980 -- type I is interface;
5981 -- type O is tagged null record;
5982 -- type Wrong is new I and O with null record; -- ERROR
5984 if Is_Interface
(Iface
) then
5986 and then Etype
(T
) /= T
5987 and then Interface_Present_In_Ancestor
(Etype
(T
), Iface
)
5992 Append_Unique_Elmt
(Iface
, Ifaces_List
);
6001 -- Start of processing for Collect_Interfaces
6004 pragma Assert
(Is_Tagged_Type
(T
) or else Is_Concurrent_Type
(T
));
6005 Ifaces_List
:= New_Elmt_List
;
6007 end Collect_Interfaces
;
6009 ----------------------------------
6010 -- Collect_Interface_Components --
6011 ----------------------------------
6013 procedure Collect_Interface_Components
6014 (Tagged_Type
: Entity_Id
;
6015 Components_List
: out Elist_Id
)
6017 procedure Collect
(Typ
: Entity_Id
);
6018 -- Subsidiary subprogram used to climb to the parents
6024 procedure Collect
(Typ
: Entity_Id
) is
6025 Tag_Comp
: Entity_Id
;
6026 Parent_Typ
: Entity_Id
;
6029 -- Handle private types
6031 if Present
(Full_View
(Etype
(Typ
))) then
6032 Parent_Typ
:= Full_View
(Etype
(Typ
));
6034 Parent_Typ
:= Etype
(Typ
);
6037 if Parent_Typ
/= Typ
6039 -- Protect the frontend against wrong sources. For example:
6042 -- type A is tagged null record;
6043 -- type B is new A with private;
6044 -- type C is new A with private;
6046 -- type B is new C with null record;
6047 -- type C is new B with null record;
6050 and then Parent_Typ
/= Tagged_Type
6052 Collect
(Parent_Typ
);
6055 -- Collect the components containing tags of secondary dispatch
6058 Tag_Comp
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
6059 while Present
(Tag_Comp
) loop
6060 pragma Assert
(Present
(Related_Type
(Tag_Comp
)));
6061 Append_Elmt
(Tag_Comp
, Components_List
);
6063 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
6067 -- Start of processing for Collect_Interface_Components
6070 pragma Assert
(Ekind
(Tagged_Type
) = E_Record_Type
6071 and then Is_Tagged_Type
(Tagged_Type
));
6073 Components_List
:= New_Elmt_List
;
6074 Collect
(Tagged_Type
);
6075 end Collect_Interface_Components
;
6077 -----------------------------
6078 -- Collect_Interfaces_Info --
6079 -----------------------------
6081 procedure Collect_Interfaces_Info
6083 Ifaces_List
: out Elist_Id
;
6084 Components_List
: out Elist_Id
;
6085 Tags_List
: out Elist_Id
)
6087 Comps_List
: Elist_Id
;
6088 Comp_Elmt
: Elmt_Id
;
6089 Comp_Iface
: Entity_Id
;
6090 Iface_Elmt
: Elmt_Id
;
6093 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
;
6094 -- Search for the secondary tag associated with the interface type
6095 -- Iface that is implemented by T.
6101 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
is
6104 if not Is_CPP_Class
(T
) then
6105 ADT
:= Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
))));
6107 ADT
:= Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
)));
6111 and then Is_Tag
(Node
(ADT
))
6112 and then Related_Type
(Node
(ADT
)) /= Iface
6114 -- Skip secondary dispatch table referencing thunks to user
6115 -- defined primitives covered by this interface.
6117 pragma Assert
(Has_Suffix
(Node
(ADT
), 'P'));
6120 -- Skip secondary dispatch tables of Ada types
6122 if not Is_CPP_Class
(T
) then
6124 -- Skip secondary dispatch table referencing thunks to
6125 -- predefined primitives.
6127 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Y'));
6130 -- Skip secondary dispatch table referencing user-defined
6131 -- primitives covered by this interface.
6133 pragma Assert
(Has_Suffix
(Node
(ADT
), 'D'));
6136 -- Skip secondary dispatch table referencing predefined
6139 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Z'));
6144 pragma Assert
(Is_Tag
(Node
(ADT
)));
6148 -- Start of processing for Collect_Interfaces_Info
6151 Collect_Interfaces
(T
, Ifaces_List
);
6152 Collect_Interface_Components
(T
, Comps_List
);
6154 -- Search for the record component and tag associated with each
6155 -- interface type of T.
6157 Components_List
:= New_Elmt_List
;
6158 Tags_List
:= New_Elmt_List
;
6160 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
6161 while Present
(Iface_Elmt
) loop
6162 Iface
:= Node
(Iface_Elmt
);
6164 -- Associate the primary tag component and the primary dispatch table
6165 -- with all the interfaces that are parents of T
6167 if Is_Ancestor
(Iface
, T
, Use_Full_View
=> True) then
6168 Append_Elmt
(First_Tag_Component
(T
), Components_List
);
6169 Append_Elmt
(Node
(First_Elmt
(Access_Disp_Table
(T
))), Tags_List
);
6171 -- Otherwise search for the tag component and secondary dispatch
6175 Comp_Elmt
:= First_Elmt
(Comps_List
);
6176 while Present
(Comp_Elmt
) loop
6177 Comp_Iface
:= Related_Type
(Node
(Comp_Elmt
));
6179 if Comp_Iface
= Iface
6180 or else Is_Ancestor
(Iface
, Comp_Iface
, Use_Full_View
=> True)
6182 Append_Elmt
(Node
(Comp_Elmt
), Components_List
);
6183 Append_Elmt
(Search_Tag
(Comp_Iface
), Tags_List
);
6187 Next_Elmt
(Comp_Elmt
);
6189 pragma Assert
(Present
(Comp_Elmt
));
6192 Next_Elmt
(Iface_Elmt
);
6194 end Collect_Interfaces_Info
;
6196 ---------------------
6197 -- Collect_Parents --
6198 ---------------------
6200 procedure Collect_Parents
6202 List
: out Elist_Id
;
6203 Use_Full_View
: Boolean := True)
6205 Current_Typ
: Entity_Id
:= T
;
6206 Parent_Typ
: Entity_Id
;
6209 List
:= New_Elmt_List
;
6211 -- No action if the if the type has no parents
6213 if T
= Etype
(T
) then
6218 Parent_Typ
:= Etype
(Current_Typ
);
6220 if Is_Private_Type
(Parent_Typ
)
6221 and then Present
(Full_View
(Parent_Typ
))
6222 and then Use_Full_View
6224 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
6227 Append_Elmt
(Parent_Typ
, List
);
6229 exit when Parent_Typ
= Current_Typ
;
6230 Current_Typ
:= Parent_Typ
;
6232 end Collect_Parents
;
6234 ----------------------------------
6235 -- Collect_Primitive_Operations --
6236 ----------------------------------
6238 function Collect_Primitive_Operations
(T
: Entity_Id
) return Elist_Id
is
6239 B_Type
: constant Entity_Id
:= Base_Type
(T
);
6241 function Match
(E
: Entity_Id
) return Boolean;
6242 -- True if E's base type is B_Type, or E is of an anonymous access type
6243 -- and the base type of its designated type is B_Type.
6249 function Match
(E
: Entity_Id
) return Boolean is
6250 Etyp
: Entity_Id
:= Etype
(E
);
6253 if Ekind
(Etyp
) = E_Anonymous_Access_Type
then
6254 Etyp
:= Designated_Type
(Etyp
);
6257 -- In Ada 2012 a primitive operation may have a formal of an
6258 -- incomplete view of the parent type.
6260 return Base_Type
(Etyp
) = B_Type
6262 (Ada_Version
>= Ada_2012
6263 and then Ekind
(Etyp
) = E_Incomplete_Type
6264 and then Full_View
(Etyp
) = B_Type
);
6269 B_Decl
: constant Node_Id
:= Original_Node
(Parent
(B_Type
));
6270 B_Scope
: Entity_Id
:= Scope
(B_Type
);
6272 Eq_Prims_List
: Elist_Id
:= No_Elist
;
6275 Is_Type_In_Pkg
: Boolean;
6276 Formal_Derived
: Boolean := False;
6279 -- Start of processing for Collect_Primitive_Operations
6282 -- For tagged types, the primitive operations are collected as they
6283 -- are declared, and held in an explicit list which is simply returned.
6285 if Is_Tagged_Type
(B_Type
) then
6286 return Primitive_Operations
(B_Type
);
6288 -- An untagged generic type that is a derived type inherits the
6289 -- primitive operations of its parent type. Other formal types only
6290 -- have predefined operators, which are not explicitly represented.
6292 elsif Is_Generic_Type
(B_Type
) then
6293 if Nkind
(B_Decl
) = N_Formal_Type_Declaration
6294 and then Nkind
(Formal_Type_Definition
(B_Decl
)) =
6295 N_Formal_Derived_Type_Definition
6297 Formal_Derived
:= True;
6299 return New_Elmt_List
;
6303 Op_List
:= New_Elmt_List
;
6305 if B_Scope
= Standard_Standard
then
6306 if B_Type
= Standard_String
then
6307 Append_Elmt
(Standard_Op_Concat
, Op_List
);
6309 elsif B_Type
= Standard_Wide_String
then
6310 Append_Elmt
(Standard_Op_Concatw
, Op_List
);
6316 -- Locate the primitive subprograms of the type
6319 -- The primitive operations appear after the base type, except if the
6320 -- derivation happens within the private part of B_Scope and the type
6321 -- is a private type, in which case both the type and some primitive
6322 -- operations may appear before the base type, and the list of
6323 -- candidates starts after the type.
6325 if In_Open_Scopes
(B_Scope
)
6326 and then Scope
(T
) = B_Scope
6327 and then In_Private_Part
(B_Scope
)
6329 Id
:= Next_Entity
(T
);
6331 -- In Ada 2012, If the type has an incomplete partial view, there may
6332 -- be primitive operations declared before the full view, so we need
6333 -- to start scanning from the incomplete view, which is earlier on
6334 -- the entity chain.
6336 elsif Nkind
(Parent
(B_Type
)) = N_Full_Type_Declaration
6337 and then Present
(Incomplete_View
(Parent
(B_Type
)))
6339 Id
:= Defining_Entity
(Incomplete_View
(Parent
(B_Type
)));
6341 -- If T is a derived from a type with an incomplete view declared
6342 -- elsewhere, that incomplete view is irrelevant, we want the
6343 -- operations in the scope of T.
6345 if Scope
(Id
) /= Scope
(B_Type
) then
6346 Id
:= Next_Entity
(B_Type
);
6350 Id
:= Next_Entity
(B_Type
);
6353 -- Set flag if this is a type in a package spec
6356 Is_Package_Or_Generic_Package
(B_Scope
)
6358 Nkind
(Parent
(Declaration_Node
(First_Subtype
(T
)))) /=
6361 while Present
(Id
) loop
6363 -- Test whether the result type or any of the parameter types of
6364 -- each subprogram following the type match that type when the
6365 -- type is declared in a package spec, is a derived type, or the
6366 -- subprogram is marked as primitive. (The Is_Primitive test is
6367 -- needed to find primitives of nonderived types in declarative
6368 -- parts that happen to override the predefined "=" operator.)
6370 -- Note that generic formal subprograms are not considered to be
6371 -- primitive operations and thus are never inherited.
6373 if Is_Overloadable
(Id
)
6374 and then (Is_Type_In_Pkg
6375 or else Is_Derived_Type
(B_Type
)
6376 or else Is_Primitive
(Id
))
6377 and then Nkind
(Parent
(Parent
(Id
)))
6378 not in N_Formal_Subprogram_Declaration
6386 Formal
:= First_Formal
(Id
);
6387 while Present
(Formal
) loop
6388 if Match
(Formal
) then
6393 Next_Formal
(Formal
);
6397 -- For a formal derived type, the only primitives are the ones
6398 -- inherited from the parent type. Operations appearing in the
6399 -- package declaration are not primitive for it.
6402 and then (not Formal_Derived
or else Present
(Alias
(Id
)))
6404 -- In the special case of an equality operator aliased to
6405 -- an overriding dispatching equality belonging to the same
6406 -- type, we don't include it in the list of primitives.
6407 -- This avoids inheriting multiple equality operators when
6408 -- deriving from untagged private types whose full type is
6409 -- tagged, which can otherwise cause ambiguities. Note that
6410 -- this should only happen for this kind of untagged parent
6411 -- type, since normally dispatching operations are inherited
6412 -- using the type's Primitive_Operations list.
6414 if Chars
(Id
) = Name_Op_Eq
6415 and then Is_Dispatching_Operation
(Id
)
6416 and then Present
(Alias
(Id
))
6417 and then Present
(Overridden_Operation
(Alias
(Id
)))
6418 and then Base_Type
(Etype
(First_Entity
(Id
))) =
6419 Base_Type
(Etype
(First_Entity
(Alias
(Id
))))
6423 -- Include the subprogram in the list of primitives
6426 Append_Elmt
(Id
, Op_List
);
6428 -- Save collected equality primitives for later filtering
6429 -- (if we are processing a private type for which we can
6430 -- collect several candidates).
6432 if Inherits_From_Tagged_Full_View
(T
)
6433 and then Chars
(Id
) = Name_Op_Eq
6434 and then Etype
(First_Formal
(Id
)) =
6435 Etype
(Next_Formal
(First_Formal
(Id
)))
6437 Append_New_Elmt
(Id
, Eq_Prims_List
);
6445 -- For a type declared in System, some of its operations may
6446 -- appear in the target-specific extension to System.
6449 and then B_Scope
= RTU_Entity
(System
)
6450 and then Present_System_Aux
6452 B_Scope
:= System_Aux_Id
;
6453 Id
:= First_Entity
(System_Aux_Id
);
6457 -- Filter collected equality primitives
6459 if Inherits_From_Tagged_Full_View
(T
)
6460 and then Present
(Eq_Prims_List
)
6463 First
: constant Elmt_Id
:= First_Elmt
(Eq_Prims_List
);
6467 pragma Assert
(No
(Next_Elmt
(First
))
6468 or else No
(Next_Elmt
(Next_Elmt
(First
))));
6470 -- No action needed if we have collected a single equality
6473 if Present
(Next_Elmt
(First
)) then
6474 Second
:= Next_Elmt
(First
);
6476 if Is_Dispatching_Operation
6477 (Ultimate_Alias
(Node
(First
)))
6479 Remove
(Op_List
, Node
(First
));
6481 elsif Is_Dispatching_Operation
6482 (Ultimate_Alias
(Node
(Second
)))
6484 Remove
(Op_List
, Node
(Second
));
6487 pragma Assert
(False);
6488 raise Program_Error
;
6496 end Collect_Primitive_Operations
;
6498 -----------------------------------
6499 -- Compile_Time_Constraint_Error --
6500 -----------------------------------
6502 function Compile_Time_Constraint_Error
6505 Ent
: Entity_Id
:= Empty
;
6506 Loc
: Source_Ptr
:= No_Location
;
6507 Warn
: Boolean := False;
6508 Extra_Msg
: String := "") return Node_Id
6510 Msgc
: String (1 .. Msg
'Length + 3);
6511 -- Copy of message, with room for possible ?? or << and ! at end
6517 -- Start of processing for Compile_Time_Constraint_Error
6520 -- If this is a warning, convert it into an error if we are in code
6521 -- subject to SPARK_Mode being set On, unless Warn is True to force a
6522 -- warning. The rationale is that a compile-time constraint error should
6523 -- lead to an error instead of a warning when SPARK_Mode is On, but in
6524 -- a few cases we prefer to issue a warning and generate both a suitable
6525 -- run-time error in GNAT and a suitable check message in GNATprove.
6526 -- Those cases are those that likely correspond to deactivated SPARK
6527 -- code, so that this kind of code can be compiled and analyzed instead
6528 -- of being rejected.
6530 Error_Msg_Warn
:= Warn
or SPARK_Mode
/= On
;
6532 -- A static constraint error in an instance body is not a fatal error.
6533 -- we choose to inhibit the message altogether, because there is no
6534 -- obvious node (for now) on which to post it. On the other hand the
6535 -- offending node must be replaced with a constraint_error in any case.
6537 -- No messages are generated if we already posted an error on this node
6539 if not Error_Posted
(N
) then
6540 if Loc
/= No_Location
then
6546 -- Copy message to Msgc, converting any ? in the message into <
6547 -- instead, so that we have an error in GNATprove mode.
6551 for J
in 1 .. Msgl
loop
6552 if Msg
(J
) = '?' and then (J
= 1 or else Msg
(J
- 1) /= ''') then
6555 Msgc
(J
) := Msg
(J
);
6559 -- Message is a warning, even in Ada 95 case
6561 if Msg
(Msg
'Last) = '?' or else Msg
(Msg
'Last) = '<' then
6564 -- In Ada 83, all messages are warnings. In the private part and the
6565 -- body of an instance, constraint_checks are only warnings. We also
6566 -- make this a warning if the Warn parameter is set.
6569 or else (Ada_Version
= Ada_83
and then Comes_From_Source
(N
))
6570 or else In_Instance_Not_Visible
6578 -- Otherwise we have a real error message (Ada 95 static case) and we
6579 -- make this an unconditional message. Note that in the warning case
6580 -- we do not make the message unconditional, it seems reasonable to
6581 -- delete messages like this (about exceptions that will be raised)
6590 -- One more test, skip the warning if the related expression is
6591 -- statically unevaluated, since we don't want to warn about what
6592 -- will happen when something is evaluated if it never will be
6595 -- Suppress error reporting when checking that the expression of a
6596 -- static expression function is a potentially static expression,
6597 -- because we don't want additional errors being reported during the
6598 -- preanalysis of the expression (see Analyze_Expression_Function).
6600 if not Is_Statically_Unevaluated
(N
)
6601 and then not Checking_Potentially_Static_Expression
6603 if Present
(Ent
) then
6604 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Ent
, Eloc
);
6606 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Etype
(N
), Eloc
);
6609 -- Emit any extra message as a continuation
6611 if Extra_Msg
/= "" then
6612 Error_Msg_N
('\' & Extra_Msg
, N
);
6617 -- Check whether the context is an Init_Proc
6619 if Inside_Init_Proc
then
6621 Conc_Typ
: constant Entity_Id
:=
6622 Corresponding_Concurrent_Type
6623 (Entity
(Parameter_Type
(First
6624 (Parameter_Specifications
6625 (Parent
(Current_Scope
))))));
6628 -- Don't complain if the corresponding concurrent type
6629 -- doesn't come from source (i.e. a single task/protected
6632 if Present
(Conc_Typ
)
6633 and then not Comes_From_Source
(Conc_Typ
)
6636 ("\& [<<", N
, Standard_Constraint_Error
, Eloc
);
6639 if GNATprove_Mode
then
6641 ("\& would have been raised for objects of this "
6642 & "type", N
, Standard_Constraint_Error
, Eloc
);
6645 ("\& will be raised for objects of this type??",
6646 N
, Standard_Constraint_Error
, Eloc
);
6652 Error_Msg_NEL
("\& [<<", N
, Standard_Constraint_Error
, Eloc
);
6656 Error_Msg
("\static expression fails Constraint_Check", Eloc
);
6657 Set_Error_Posted
(N
);
6663 end Compile_Time_Constraint_Error
;
6665 -----------------------
6666 -- Conditional_Delay --
6667 -----------------------
6669 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
6671 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
6672 Set_Has_Delayed_Freeze
(New_Ent
);
6674 end Conditional_Delay
;
6676 -------------------------
6677 -- Copy_Component_List --
6678 -------------------------
6680 function Copy_Component_List
6682 Loc
: Source_Ptr
) return List_Id
6685 Comps
: constant List_Id
:= New_List
;
6688 Comp
:= First_Component
(Underlying_Type
(R_Typ
));
6689 while Present
(Comp
) loop
6690 if Comes_From_Source
(Comp
) then
6692 Comp_Decl
: constant Node_Id
:= Declaration_Node
(Comp
);
6695 Make_Component_Declaration
(Loc
,
6696 Defining_Identifier
=>
6697 Make_Defining_Identifier
(Loc
, Chars
(Comp
)),
6698 Component_Definition
=>
6700 (Component_Definition
(Comp_Decl
), New_Sloc
=> Loc
)));
6704 Next_Component
(Comp
);
6708 end Copy_Component_List
;
6710 -------------------------
6711 -- Copy_Parameter_List --
6712 -------------------------
6714 function Copy_Parameter_List
(Subp_Id
: Entity_Id
) return List_Id
is
6715 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
6720 if No
(First_Formal
(Subp_Id
)) then
6724 Formal
:= First_Formal
(Subp_Id
);
6725 while Present
(Formal
) loop
6727 Make_Parameter_Specification
(Loc
,
6728 Defining_Identifier
=>
6729 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
6730 In_Present
=> In_Present
(Parent
(Formal
)),
6731 Out_Present
=> Out_Present
(Parent
(Formal
)),
6733 New_Occurrence_Of
(Etype
(Formal
), Loc
),
6735 New_Copy_Tree
(Expression
(Parent
(Formal
)))));
6737 Next_Formal
(Formal
);
6742 end Copy_Parameter_List
;
6744 ----------------------------
6745 -- Copy_SPARK_Mode_Aspect --
6746 ----------------------------
6748 procedure Copy_SPARK_Mode_Aspect
(From
: Node_Id
; To
: Node_Id
) is
6749 pragma Assert
(not Has_Aspects
(To
));
6753 if Has_Aspects
(From
) then
6754 Asp
:= Find_Aspect
(Defining_Entity
(From
), Aspect_SPARK_Mode
);
6756 if Present
(Asp
) then
6757 Set_Aspect_Specifications
(To
, New_List
(New_Copy_Tree
(Asp
)));
6758 Set_Has_Aspects
(To
, True);
6761 end Copy_SPARK_Mode_Aspect
;
6763 --------------------------
6764 -- Copy_Subprogram_Spec --
6765 --------------------------
6767 function Copy_Subprogram_Spec
(Spec
: Node_Id
) return Node_Id
is
6769 Formal_Spec
: Node_Id
;
6773 -- The structure of the original tree must be replicated without any
6774 -- alterations. Use New_Copy_Tree for this purpose.
6776 Result
:= New_Copy_Tree
(Spec
);
6778 -- However, the spec of a null procedure carries the corresponding null
6779 -- statement of the body (created by the parser), and this cannot be
6780 -- shared with the new subprogram spec.
6782 if Nkind
(Result
) = N_Procedure_Specification
then
6783 Set_Null_Statement
(Result
, Empty
);
6786 -- Create a new entity for the defining unit name
6788 Def_Id
:= Defining_Unit_Name
(Result
);
6789 Set_Defining_Unit_Name
(Result
,
6790 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
6792 -- Create new entities for the formal parameters
6794 if Present
(Parameter_Specifications
(Result
)) then
6795 Formal_Spec
:= First
(Parameter_Specifications
(Result
));
6796 while Present
(Formal_Spec
) loop
6797 Def_Id
:= Defining_Identifier
(Formal_Spec
);
6798 Set_Defining_Identifier
(Formal_Spec
,
6799 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
6806 end Copy_Subprogram_Spec
;
6808 --------------------------------
6809 -- Corresponding_Generic_Type --
6810 --------------------------------
6812 function Corresponding_Generic_Type
(T
: Entity_Id
) return Entity_Id
is
6818 if not Is_Generic_Actual_Type
(T
) then
6821 -- If the actual is the actual of an enclosing instance, resolution
6822 -- was correct in the generic.
6824 elsif Nkind
(Parent
(T
)) = N_Subtype_Declaration
6825 and then Is_Entity_Name
(Subtype_Indication
(Parent
(T
)))
6827 Is_Generic_Actual_Type
(Entity
(Subtype_Indication
(Parent
(T
))))
6834 if Is_Wrapper_Package
(Inst
) then
6835 Inst
:= Related_Instance
(Inst
);
6840 (Specification
(Unit_Declaration_Node
(Inst
)));
6842 -- Generic actual has the same name as the corresponding formal
6844 Typ
:= First_Entity
(Gen
);
6845 while Present
(Typ
) loop
6846 if Chars
(Typ
) = Chars
(T
) then
6855 end Corresponding_Generic_Type
;
6857 --------------------
6858 -- Current_Entity --
6859 --------------------
6861 -- The currently visible definition for a given identifier is the
6862 -- one most chained at the start of the visibility chain, i.e. the
6863 -- one that is referenced by the Node_Id value of the name of the
6864 -- given identifier.
6866 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
6868 return Get_Name_Entity_Id
(Chars
(N
));
6871 -----------------------------
6872 -- Current_Entity_In_Scope --
6873 -----------------------------
6875 function Current_Entity_In_Scope
(N
: Name_Id
) return Entity_Id
is
6877 CS
: constant Entity_Id
:= Current_Scope
;
6879 Transient_Case
: constant Boolean := Scope_Is_Transient
;
6882 E
:= Get_Name_Entity_Id
(N
);
6884 and then Scope
(E
) /= CS
6885 and then (not Transient_Case
or else Scope
(E
) /= Scope
(CS
))
6891 end Current_Entity_In_Scope
;
6893 -----------------------------
6894 -- Current_Entity_In_Scope --
6895 -----------------------------
6897 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
6899 return Current_Entity_In_Scope
(Chars
(N
));
6900 end Current_Entity_In_Scope
;
6906 function Current_Scope
return Entity_Id
is
6908 if Scope_Stack
.Last
= -1 then
6909 return Standard_Standard
;
6912 C
: constant Entity_Id
:=
6913 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
6918 return Standard_Standard
;
6924 ----------------------------
6925 -- Current_Scope_No_Loops --
6926 ----------------------------
6928 function Current_Scope_No_Loops
return Entity_Id
is
6932 -- Examine the scope stack starting from the current scope and skip any
6933 -- internally generated loops.
6936 while Present
(S
) and then S
/= Standard_Standard
loop
6937 if Ekind
(S
) = E_Loop
and then not Comes_From_Source
(S
) then
6945 end Current_Scope_No_Loops
;
6947 ------------------------
6948 -- Current_Subprogram --
6949 ------------------------
6951 function Current_Subprogram
return Entity_Id
is
6952 Scop
: constant Entity_Id
:= Current_Scope
;
6954 if Is_Subprogram_Or_Generic_Subprogram
(Scop
) then
6957 return Enclosing_Subprogram
(Scop
);
6959 end Current_Subprogram
;
6961 -------------------------------
6962 -- Deepest_Type_Access_Level --
6963 -------------------------------
6965 function Deepest_Type_Access_Level
(Typ
: Entity_Id
) return Uint
is
6967 if Ekind
(Typ
) = E_Anonymous_Access_Type
6968 and then not Is_Local_Anonymous_Access
(Typ
)
6969 and then Nkind
(Associated_Node_For_Itype
(Typ
)) = N_Object_Declaration
6971 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
6975 Scope_Depth
(Enclosing_Dynamic_Scope
6976 (Defining_Identifier
6977 (Associated_Node_For_Itype
(Typ
))));
6979 -- For generic formal type, return Int'Last (infinite).
6980 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
6982 elsif Is_Generic_Type
(Root_Type
(Typ
)) then
6983 return UI_From_Int
(Int
'Last);
6986 return Type_Access_Level
(Typ
);
6988 end Deepest_Type_Access_Level
;
6990 ---------------------
6991 -- Defining_Entity --
6992 ---------------------
6994 function Defining_Entity
6996 Empty_On_Errors
: Boolean := False) return Entity_Id
7000 when N_Abstract_Subprogram_Declaration
7001 | N_Expression_Function
7002 | N_Formal_Subprogram_Declaration
7003 | N_Generic_Package_Declaration
7004 | N_Generic_Subprogram_Declaration
7005 | N_Package_Declaration
7007 | N_Subprogram_Body_Stub
7008 | N_Subprogram_Declaration
7009 | N_Subprogram_Renaming_Declaration
7011 return Defining_Entity
(Specification
(N
));
7013 when N_Component_Declaration
7014 | N_Defining_Program_Unit_Name
7015 | N_Discriminant_Specification
7017 | N_Entry_Declaration
7018 | N_Entry_Index_Specification
7019 | N_Exception_Declaration
7020 | N_Exception_Renaming_Declaration
7021 | N_Formal_Object_Declaration
7022 | N_Formal_Package_Declaration
7023 | N_Formal_Type_Declaration
7024 | N_Full_Type_Declaration
7025 | N_Implicit_Label_Declaration
7026 | N_Incomplete_Type_Declaration
7027 | N_Iterator_Specification
7028 | N_Loop_Parameter_Specification
7029 | N_Number_Declaration
7030 | N_Object_Declaration
7031 | N_Object_Renaming_Declaration
7032 | N_Package_Body_Stub
7033 | N_Parameter_Specification
7034 | N_Private_Extension_Declaration
7035 | N_Private_Type_Declaration
7037 | N_Protected_Body_Stub
7038 | N_Protected_Type_Declaration
7039 | N_Single_Protected_Declaration
7040 | N_Single_Task_Declaration
7041 | N_Subtype_Declaration
7044 | N_Task_Type_Declaration
7046 return Defining_Identifier
(N
);
7048 when N_Compilation_Unit
=>
7049 return Defining_Entity
(Unit
(N
));
7052 return Defining_Entity
(Proper_Body
(N
));
7054 when N_Function_Instantiation
7055 | N_Function_Specification
7056 | N_Generic_Function_Renaming_Declaration
7057 | N_Generic_Package_Renaming_Declaration
7058 | N_Generic_Procedure_Renaming_Declaration
7060 | N_Package_Instantiation
7061 | N_Package_Renaming_Declaration
7062 | N_Package_Specification
7063 | N_Procedure_Instantiation
7064 | N_Procedure_Specification
7067 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
7068 Err
: Entity_Id
:= Empty
;
7071 if Nkind
(Nam
) in N_Entity
then
7074 -- For Error, make up a name and attach to declaration so we
7075 -- can continue semantic analysis.
7077 elsif Nam
= Error
then
7078 Err
:= Make_Temporary
(Sloc
(N
), 'T');
7079 Set_Defining_Unit_Name
(N
, Err
);
7083 -- If not an entity, get defining identifier
7086 return Defining_Identifier
(Nam
);
7090 when N_Block_Statement
7093 return Entity
(Identifier
(N
));
7096 if Empty_On_Errors
then
7100 raise Program_Error
;
7102 end Defining_Entity
;
7104 --------------------------
7105 -- Denotes_Discriminant --
7106 --------------------------
7108 function Denotes_Discriminant
7110 Check_Concurrent
: Boolean := False) return Boolean
7115 if not Is_Entity_Name
(N
) or else No
(Entity
(N
)) then
7121 -- If we are checking for a protected type, the discriminant may have
7122 -- been rewritten as the corresponding discriminal of the original type
7123 -- or of the corresponding concurrent record, depending on whether we
7124 -- are in the spec or body of the protected type.
7126 return Ekind
(E
) = E_Discriminant
7129 and then Ekind
(E
) = E_In_Parameter
7130 and then Present
(Discriminal_Link
(E
))
7132 (Is_Concurrent_Type
(Scope
(Discriminal_Link
(E
)))
7134 Is_Concurrent_Record_Type
(Scope
(Discriminal_Link
(E
)))));
7135 end Denotes_Discriminant
;
7137 -------------------------
7138 -- Denotes_Same_Object --
7139 -------------------------
7141 function Denotes_Same_Object
(A1
, A2
: Node_Id
) return Boolean is
7142 function Is_Renaming
(N
: Node_Id
) return Boolean;
7143 -- Return true if N names a renaming entity
7145 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean;
7146 -- For renamings, return False if the prefix of any dereference within
7147 -- the renamed object_name is a variable, or any expression within the
7148 -- renamed object_name contains references to variables or calls on
7149 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
7155 function Is_Renaming
(N
: Node_Id
) return Boolean is
7157 if not Is_Entity_Name
(N
) then
7161 case Ekind
(Entity
(N
)) is
7162 when E_Variable | E_Constant
=>
7163 return Present
(Renamed_Object
(Entity
(N
)));
7167 | E_Generic_Function
7169 | E_Generic_Procedure
7174 return Present
(Renamed_Entity
(Entity
(N
)));
7181 -----------------------
7182 -- Is_Valid_Renaming --
7183 -----------------------
7185 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean is
7186 function Check_Renaming
(N
: Node_Id
) return Boolean;
7187 -- Recursive function used to traverse all the prefixes of N
7189 --------------------
7190 -- Check_Renaming --
7191 --------------------
7193 function Check_Renaming
(N
: Node_Id
) return Boolean is
7196 and then not Check_Renaming
(Renamed_Entity
(Entity
(N
)))
7201 if Nkind
(N
) = N_Indexed_Component
then
7206 Indx
:= First
(Expressions
(N
));
7207 while Present
(Indx
) loop
7208 if not Is_OK_Static_Expression
(Indx
) then
7217 if Has_Prefix
(N
) then
7219 P
: constant Node_Id
:= Prefix
(N
);
7222 if Nkind
(N
) = N_Explicit_Dereference
7223 and then Is_Variable
(P
)
7227 elsif Is_Entity_Name
(P
)
7228 and then Ekind
(Entity
(P
)) = E_Function
7232 elsif Nkind
(P
) = N_Function_Call
then
7236 -- Recursion to continue traversing the prefix of the
7237 -- renaming expression
7239 return Check_Renaming
(P
);
7246 -- Start of processing for Is_Valid_Renaming
7249 return Check_Renaming
(N
);
7250 end Is_Valid_Renaming
;
7254 Obj1
: Node_Id
:= A1
;
7255 Obj2
: Node_Id
:= A2
;
7257 -- Start of processing for Denotes_Same_Object
7260 -- Both names statically denote the same stand-alone object or parameter
7261 -- (RM 6.4.1(6.5/3))
7263 if Is_Entity_Name
(Obj1
)
7264 and then Is_Entity_Name
(Obj2
)
7265 and then Entity
(Obj1
) = Entity
(Obj2
)
7270 -- For renamings, the prefix of any dereference within the renamed
7271 -- object_name is not a variable, and any expression within the
7272 -- renamed object_name contains no references to variables nor
7273 -- calls on nonstatic functions (RM 6.4.1(6.10/3)).
7275 if Is_Renaming
(Obj1
) then
7276 if Is_Valid_Renaming
(Obj1
) then
7277 Obj1
:= Renamed_Entity
(Entity
(Obj1
));
7283 if Is_Renaming
(Obj2
) then
7284 if Is_Valid_Renaming
(Obj2
) then
7285 Obj2
:= Renamed_Entity
(Entity
(Obj2
));
7291 -- No match if not same node kind (such cases are handled by
7292 -- Denotes_Same_Prefix)
7294 if Nkind
(Obj1
) /= Nkind
(Obj2
) then
7297 -- After handling valid renamings, one of the two names statically
7298 -- denoted a renaming declaration whose renamed object_name is known
7299 -- to denote the same object as the other (RM 6.4.1(6.10/3))
7301 elsif Is_Entity_Name
(Obj1
) then
7302 if Is_Entity_Name
(Obj2
) then
7303 return Entity
(Obj1
) = Entity
(Obj2
);
7308 -- Both names are selected_components, their prefixes are known to
7309 -- denote the same object, and their selector_names denote the same
7310 -- component (RM 6.4.1(6.6/3)).
7312 elsif Nkind
(Obj1
) = N_Selected_Component
then
7313 return Denotes_Same_Object
(Prefix
(Obj1
), Prefix
(Obj2
))
7315 Entity
(Selector_Name
(Obj1
)) = Entity
(Selector_Name
(Obj2
));
7317 -- Both names are dereferences and the dereferenced names are known to
7318 -- denote the same object (RM 6.4.1(6.7/3))
7320 elsif Nkind
(Obj1
) = N_Explicit_Dereference
then
7321 return Denotes_Same_Object
(Prefix
(Obj1
), Prefix
(Obj2
));
7323 -- Both names are indexed_components, their prefixes are known to denote
7324 -- the same object, and each of the pairs of corresponding index values
7325 -- are either both static expressions with the same static value or both
7326 -- names that are known to denote the same object (RM 6.4.1(6.8/3))
7328 elsif Nkind
(Obj1
) = N_Indexed_Component
then
7329 if not Denotes_Same_Object
(Prefix
(Obj1
), Prefix
(Obj2
)) then
7337 Indx1
:= First
(Expressions
(Obj1
));
7338 Indx2
:= First
(Expressions
(Obj2
));
7339 while Present
(Indx1
) loop
7341 -- Indexes must denote the same static value or same object
7343 if Is_OK_Static_Expression
(Indx1
) then
7344 if not Is_OK_Static_Expression
(Indx2
) then
7347 elsif Expr_Value
(Indx1
) /= Expr_Value
(Indx2
) then
7351 elsif not Denotes_Same_Object
(Indx1
, Indx2
) then
7363 -- Both names are slices, their prefixes are known to denote the same
7364 -- object, and the two slices have statically matching index constraints
7365 -- (RM 6.4.1(6.9/3))
7367 elsif Nkind
(Obj1
) = N_Slice
7368 and then Denotes_Same_Object
(Prefix
(Obj1
), Prefix
(Obj2
))
7371 Lo1
, Lo2
, Hi1
, Hi2
: Node_Id
;
7374 Get_Index_Bounds
(Etype
(Obj1
), Lo1
, Hi1
);
7375 Get_Index_Bounds
(Etype
(Obj2
), Lo2
, Hi2
);
7377 -- Check whether bounds are statically identical. There is no
7378 -- attempt to detect partial overlap of slices.
7380 return Denotes_Same_Object
(Lo1
, Lo2
)
7382 Denotes_Same_Object
(Hi1
, Hi2
);
7385 -- In the recursion, literals appear as indexes
7387 elsif Nkind
(Obj1
) = N_Integer_Literal
7389 Nkind
(Obj2
) = N_Integer_Literal
7391 return Intval
(Obj1
) = Intval
(Obj2
);
7396 end Denotes_Same_Object
;
7398 -------------------------
7399 -- Denotes_Same_Prefix --
7400 -------------------------
7402 function Denotes_Same_Prefix
(A1
, A2
: Node_Id
) return Boolean is
7404 if Is_Entity_Name
(A1
) then
7405 if Nkind
(A2
) in N_Selected_Component | N_Indexed_Component
7406 and then not Is_Access_Type
(Etype
(A1
))
7408 return Denotes_Same_Object
(A1
, Prefix
(A2
))
7409 or else Denotes_Same_Prefix
(A1
, Prefix
(A2
));
7414 elsif Is_Entity_Name
(A2
) then
7415 return Denotes_Same_Prefix
(A1
=> A2
, A2
=> A1
);
7417 elsif Nkind
(A1
) in N_Selected_Component | N_Indexed_Component | N_Slice
7419 Nkind
(A2
) in N_Selected_Component | N_Indexed_Component | N_Slice
7422 Root1
, Root2
: Node_Id
;
7423 Depth1
, Depth2
: Nat
:= 0;
7426 Root1
:= Prefix
(A1
);
7427 while not Is_Entity_Name
(Root1
) loop
7428 if Nkind
(Root1
) not in
7429 N_Selected_Component | N_Indexed_Component
7433 Root1
:= Prefix
(Root1
);
7436 Depth1
:= Depth1
+ 1;
7439 Root2
:= Prefix
(A2
);
7440 while not Is_Entity_Name
(Root2
) loop
7441 if Nkind
(Root2
) not in
7442 N_Selected_Component | N_Indexed_Component
7446 Root2
:= Prefix
(Root2
);
7449 Depth2
:= Depth2
+ 1;
7452 -- If both have the same depth and they do not denote the same
7453 -- object, they are disjoint and no warning is needed.
7455 if Depth1
= Depth2
then
7458 elsif Depth1
> Depth2
then
7459 Root1
:= Prefix
(A1
);
7460 for J
in 1 .. Depth1
- Depth2
- 1 loop
7461 Root1
:= Prefix
(Root1
);
7464 return Denotes_Same_Object
(Root1
, A2
);
7467 Root2
:= Prefix
(A2
);
7468 for J
in 1 .. Depth2
- Depth1
- 1 loop
7469 Root2
:= Prefix
(Root2
);
7472 return Denotes_Same_Object
(A1
, Root2
);
7479 end Denotes_Same_Prefix
;
7481 ----------------------
7482 -- Denotes_Variable --
7483 ----------------------
7485 function Denotes_Variable
(N
: Node_Id
) return Boolean is
7487 return Is_Variable
(N
) and then Paren_Count
(N
) = 0;
7488 end Denotes_Variable
;
7490 -----------------------------
7491 -- Depends_On_Discriminant --
7492 -----------------------------
7494 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
7499 Get_Index_Bounds
(N
, L
, H
);
7500 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
7501 end Depends_On_Discriminant
;
7503 -------------------------------------
7504 -- Derivation_Too_Early_To_Inherit --
7505 -------------------------------------
7507 function Derivation_Too_Early_To_Inherit
7508 (Typ
: Entity_Id
; Streaming_Op
: TSS_Name_Type
) return Boolean is
7509 Btyp
: constant Entity_Id
:= Implementation_Base_Type
(Typ
);
7510 Parent_Type
: Entity_Id
;
7512 if Is_Derived_Type
(Btyp
) then
7513 Parent_Type
:= Implementation_Base_Type
(Etype
(Btyp
));
7514 pragma Assert
(Parent_Type
/= Btyp
);
7515 if Has_Stream_Attribute_Definition
7516 (Parent_Type
, Streaming_Op
)
7517 and then In_Same_Extended_Unit
(Btyp
, Parent_Type
)
7518 and then Instantiation
(Get_Source_File_Index
(Sloc
(Btyp
))) =
7519 Instantiation
(Get_Source_File_Index
(Sloc
(Parent_Type
)))
7522 -- ??? Avoid code duplication here with
7523 -- Sem_Cat.Has_Stream_Attribute_Definition by introducing a
7524 -- new function to be called from both places?
7526 Rep_Item
: Node_Id
:= First_Rep_Item
(Parent_Type
);
7528 Found
: Boolean := False;
7530 while Present
(Rep_Item
) loop
7531 Real_Rep
:= Rep_Item
;
7533 if Nkind
(Rep_Item
) = N_Aspect_Specification
then
7534 Real_Rep
:= Aspect_Rep_Item
(Rep_Item
);
7537 if Nkind
(Real_Rep
) = N_Attribute_Definition_Clause
then
7538 case Chars
(Real_Rep
) is
7540 Found
:= Streaming_Op
= TSS_Stream_Read
;
7543 Found
:= Streaming_Op
= TSS_Stream_Write
;
7546 Found
:= Streaming_Op
= TSS_Stream_Input
;
7549 Found
:= Streaming_Op
= TSS_Stream_Output
;
7557 return Earlier_In_Extended_Unit
(Btyp
, Real_Rep
);
7560 Next_Rep_Item
(Rep_Item
);
7566 end Derivation_Too_Early_To_Inherit
;
7568 -------------------------
7569 -- Designate_Same_Unit --
7570 -------------------------
7572 function Designate_Same_Unit
7574 Name2
: Node_Id
) return Boolean
7576 K1
: constant Node_Kind
:= Nkind
(Name1
);
7577 K2
: constant Node_Kind
:= Nkind
(Name2
);
7579 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
7580 -- Returns the parent unit name node of a defining program unit name
7581 -- or the prefix if N is a selected component or an expanded name.
7583 function Select_Node
(N
: Node_Id
) return Node_Id
;
7584 -- Returns the defining identifier node of a defining program unit
7585 -- name or the selector node if N is a selected component or an
7592 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
7594 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
7605 function Select_Node
(N
: Node_Id
) return Node_Id
is
7607 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
7608 return Defining_Identifier
(N
);
7610 return Selector_Name
(N
);
7614 -- Start of processing for Designate_Same_Unit
7617 if K1
in N_Identifier | N_Defining_Identifier
7619 K2
in N_Identifier | N_Defining_Identifier
7621 return Chars
(Name1
) = Chars
(Name2
);
7623 elsif K1
in N_Expanded_Name
7624 | N_Selected_Component
7625 | N_Defining_Program_Unit_Name
7627 K2
in N_Expanded_Name
7628 | N_Selected_Component
7629 | N_Defining_Program_Unit_Name
7632 (Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
)))
7634 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
7639 end Designate_Same_Unit
;
7641 ---------------------------------------------
7642 -- Diagnose_Iterated_Component_Association --
7643 ---------------------------------------------
7645 procedure Diagnose_Iterated_Component_Association
(N
: Node_Id
) is
7646 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
7650 -- Determine whether the iterated component association appears within
7651 -- an aggregate. If this is the case, raise Program_Error because the
7652 -- iterated component association cannot be left in the tree as is and
7653 -- must always be processed by the related aggregate.
7656 while Present
(Aggr
) loop
7657 if Nkind
(Aggr
) = N_Aggregate
then
7658 raise Program_Error
;
7660 -- Prevent the search from going too far
7662 elsif Is_Body_Or_Package_Declaration
(Aggr
) then
7666 Aggr
:= Parent
(Aggr
);
7669 -- At this point it is known that the iterated component association is
7670 -- not within an aggregate. This is really a quantified expression with
7671 -- a missing "all" or "some" quantifier.
7673 Error_Msg_N
("missing quantifier", Def_Id
);
7675 -- Rewrite the iterated component association as True to prevent any
7678 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Sloc
(N
)));
7680 end Diagnose_Iterated_Component_Association
;
7682 ------------------------
7683 -- Discriminated_Size --
7684 ------------------------
7686 function Discriminated_Size
(Comp
: Entity_Id
) return Boolean is
7687 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean;
7688 -- Check whether the bound of an index is non-static and does denote
7689 -- a discriminant, in which case any object of the type (protected or
7690 -- otherwise) will have a non-static size.
7692 ----------------------
7693 -- Non_Static_Bound --
7694 ----------------------
7696 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean is
7698 if Is_OK_Static_Expression
(Bound
) then
7701 -- If the bound is given by a discriminant it is non-static
7702 -- (A static constraint replaces the reference with the value).
7703 -- In an protected object the discriminant has been replaced by
7704 -- the corresponding discriminal within the protected operation.
7706 elsif Is_Entity_Name
(Bound
)
7708 (Ekind
(Entity
(Bound
)) = E_Discriminant
7709 or else Present
(Discriminal_Link
(Entity
(Bound
))))
7716 end Non_Static_Bound
;
7720 Typ
: constant Entity_Id
:= Etype
(Comp
);
7723 -- Start of processing for Discriminated_Size
7726 if not Is_Array_Type
(Typ
) then
7730 if Ekind
(Typ
) = E_Array_Subtype
then
7731 Index
:= First_Index
(Typ
);
7732 while Present
(Index
) loop
7733 if Non_Static_Bound
(Low_Bound
(Index
))
7734 or else Non_Static_Bound
(High_Bound
(Index
))
7746 end Discriminated_Size
;
7748 -----------------------------------
7749 -- Effective_Extra_Accessibility --
7750 -----------------------------------
7752 function Effective_Extra_Accessibility
(Id
: Entity_Id
) return Entity_Id
is
7754 if Present
(Renamed_Object
(Id
))
7755 and then Is_Entity_Name
(Renamed_Object
(Id
))
7757 return Effective_Extra_Accessibility
(Entity
(Renamed_Object
(Id
)));
7759 return Extra_Accessibility
(Id
);
7761 end Effective_Extra_Accessibility
;
7763 -----------------------------
7764 -- Effective_Reads_Enabled --
7765 -----------------------------
7767 function Effective_Reads_Enabled
(Id
: Entity_Id
) return Boolean is
7769 return Has_Enabled_Property
(Id
, Name_Effective_Reads
);
7770 end Effective_Reads_Enabled
;
7772 ------------------------------
7773 -- Effective_Writes_Enabled --
7774 ------------------------------
7776 function Effective_Writes_Enabled
(Id
: Entity_Id
) return Boolean is
7778 return Has_Enabled_Property
(Id
, Name_Effective_Writes
);
7779 end Effective_Writes_Enabled
;
7781 ------------------------------
7782 -- Enclosing_Comp_Unit_Node --
7783 ------------------------------
7785 function Enclosing_Comp_Unit_Node
(N
: Node_Id
) return Node_Id
is
7786 Current_Node
: Node_Id
;
7790 while Present
(Current_Node
)
7791 and then Nkind
(Current_Node
) /= N_Compilation_Unit
7793 Current_Node
:= Parent
(Current_Node
);
7796 if Nkind
(Current_Node
) /= N_Compilation_Unit
then
7799 return Current_Node
;
7801 end Enclosing_Comp_Unit_Node
;
7803 --------------------------
7804 -- Enclosing_CPP_Parent --
7805 --------------------------
7807 function Enclosing_CPP_Parent
(Typ
: Entity_Id
) return Entity_Id
is
7808 Parent_Typ
: Entity_Id
:= Typ
;
7811 while not Is_CPP_Class
(Parent_Typ
)
7812 and then Etype
(Parent_Typ
) /= Parent_Typ
7814 Parent_Typ
:= Etype
(Parent_Typ
);
7816 if Is_Private_Type
(Parent_Typ
) then
7817 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
7821 pragma Assert
(Is_CPP_Class
(Parent_Typ
));
7823 end Enclosing_CPP_Parent
;
7825 ---------------------------
7826 -- Enclosing_Declaration --
7827 ---------------------------
7829 function Enclosing_Declaration
(N
: Node_Id
) return Node_Id
is
7830 Decl
: Node_Id
:= N
;
7833 while Present
(Decl
)
7834 and then not (Nkind
(Decl
) in N_Declaration
7836 Nkind
(Decl
) in N_Later_Decl_Item
7838 Nkind
(Decl
) in N_Renaming_Declaration
7840 Nkind
(Decl
) = N_Number_Declaration
)
7842 Decl
:= Parent
(Decl
);
7846 end Enclosing_Declaration
;
7848 ----------------------------
7849 -- Enclosing_Generic_Body --
7850 ----------------------------
7852 function Enclosing_Generic_Body
(N
: Node_Id
) return Node_Id
is
7854 Spec_Id
: Entity_Id
;
7858 while Present
(Par
) loop
7859 if Nkind
(Par
) in N_Package_Body | N_Subprogram_Body
then
7860 Spec_Id
:= Corresponding_Spec
(Par
);
7862 if Present
(Spec_Id
)
7863 and then Nkind
(Unit_Declaration_Node
(Spec_Id
)) in
7864 N_Generic_Package_Declaration |
7865 N_Generic_Subprogram_Declaration
7871 Par
:= Parent
(Par
);
7875 end Enclosing_Generic_Body
;
7877 ----------------------------
7878 -- Enclosing_Generic_Unit --
7879 ----------------------------
7881 function Enclosing_Generic_Unit
(N
: Node_Id
) return Node_Id
is
7883 Spec_Decl
: Node_Id
;
7884 Spec_Id
: Entity_Id
;
7888 while Present
(Par
) loop
7889 if Nkind
(Par
) in N_Generic_Package_Declaration
7890 | N_Generic_Subprogram_Declaration
7894 elsif Nkind
(Par
) in N_Package_Body | N_Subprogram_Body
then
7895 Spec_Id
:= Corresponding_Spec
(Par
);
7897 if Present
(Spec_Id
) then
7898 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
7900 if Nkind
(Spec_Decl
) in N_Generic_Package_Declaration
7901 | N_Generic_Subprogram_Declaration
7908 Par
:= Parent
(Par
);
7912 end Enclosing_Generic_Unit
;
7918 function Enclosing_HSS
(Stmt
: Node_Id
) return Node_Id
is
7921 pragma Assert
(Is_Statement
(Stmt
));
7923 Par
:= Parent
(Stmt
);
7924 while Present
(Par
) loop
7926 if Nkind
(Par
) = N_Handled_Sequence_Of_Statements
then
7929 -- Prevent the search from going too far
7931 elsif Is_Body_Or_Package_Declaration
(Par
) then
7936 Par
:= Parent
(Par
);
7942 -------------------------------
7943 -- Enclosing_Lib_Unit_Entity --
7944 -------------------------------
7946 function Enclosing_Lib_Unit_Entity
7947 (E
: Entity_Id
:= Current_Scope
) return Entity_Id
7949 Unit_Entity
: Entity_Id
;
7952 -- Look for enclosing library unit entity by following scope links.
7953 -- Equivalent to, but faster than indexing through the scope stack.
7956 while (Present
(Scope
(Unit_Entity
))
7957 and then Scope
(Unit_Entity
) /= Standard_Standard
)
7958 and not Is_Child_Unit
(Unit_Entity
)
7960 Unit_Entity
:= Scope
(Unit_Entity
);
7964 end Enclosing_Lib_Unit_Entity
;
7966 -----------------------------
7967 -- Enclosing_Lib_Unit_Node --
7968 -----------------------------
7970 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
7971 Encl_Unit
: Node_Id
;
7974 Encl_Unit
:= Enclosing_Comp_Unit_Node
(N
);
7975 while Present
(Encl_Unit
)
7976 and then Nkind
(Unit
(Encl_Unit
)) = N_Subunit
7978 Encl_Unit
:= Library_Unit
(Encl_Unit
);
7981 pragma Assert
(Nkind
(Encl_Unit
) = N_Compilation_Unit
);
7983 end Enclosing_Lib_Unit_Node
;
7985 -----------------------
7986 -- Enclosing_Package --
7987 -----------------------
7989 function Enclosing_Package
(E
: Entity_Id
) return Entity_Id
is
7990 Dynamic_Scope
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(E
);
7993 if Dynamic_Scope
= Standard_Standard
then
7994 return Standard_Standard
;
7996 elsif Dynamic_Scope
= Empty
then
7999 elsif Ekind
(Dynamic_Scope
) in
8000 E_Generic_Package | E_Package | E_Package_Body
8002 return Dynamic_Scope
;
8005 return Enclosing_Package
(Dynamic_Scope
);
8007 end Enclosing_Package
;
8009 -------------------------------------
8010 -- Enclosing_Package_Or_Subprogram --
8011 -------------------------------------
8013 function Enclosing_Package_Or_Subprogram
(E
: Entity_Id
) return Entity_Id
is
8018 while Present
(S
) loop
8019 if Is_Package_Or_Generic_Package
(S
)
8020 or else Is_Subprogram_Or_Generic_Subprogram
(S
)
8030 end Enclosing_Package_Or_Subprogram
;
8032 --------------------------
8033 -- Enclosing_Subprogram --
8034 --------------------------
8036 function Enclosing_Subprogram
(E
: Entity_Id
) return Entity_Id
is
8037 Dyn_Scop
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(E
);
8040 if Dyn_Scop
= Standard_Standard
then
8043 elsif Dyn_Scop
= Empty
then
8046 elsif Ekind
(Dyn_Scop
) = E_Subprogram_Body
then
8047 return Corresponding_Spec
(Parent
(Parent
(Dyn_Scop
)));
8049 elsif Ekind
(Dyn_Scop
) in E_Block | E_Loop | E_Return_Statement
then
8050 return Enclosing_Subprogram
(Dyn_Scop
);
8052 elsif Ekind
(Dyn_Scop
) in E_Entry | E_Entry_Family
then
8054 -- For a task entry or entry family, return the enclosing subprogram
8055 -- of the task itself.
8057 if Ekind
(Scope
(Dyn_Scop
)) = E_Task_Type
then
8058 return Enclosing_Subprogram
(Dyn_Scop
);
8060 -- A protected entry or entry family is rewritten as a protected
8061 -- procedure which is the desired enclosing subprogram. This is
8062 -- relevant when unnesting a procedure local to an entry body.
8065 return Protected_Body_Subprogram
(Dyn_Scop
);
8068 elsif Ekind
(Dyn_Scop
) = E_Task_Type
then
8069 return Get_Task_Body_Procedure
(Dyn_Scop
);
8071 -- The scope may appear as a private type or as a private extension
8072 -- whose completion is a task or protected type.
8074 elsif Ekind
(Dyn_Scop
) in
8075 E_Limited_Private_Type | E_Record_Type_With_Private
8076 and then Present
(Full_View
(Dyn_Scop
))
8077 and then Ekind
(Full_View
(Dyn_Scop
)) in E_Task_Type | E_Protected_Type
8079 return Get_Task_Body_Procedure
(Full_View
(Dyn_Scop
));
8081 -- No body is generated if the protected operation is eliminated
8083 elsif not Is_Eliminated
(Dyn_Scop
)
8084 and then Present
(Protected_Body_Subprogram
(Dyn_Scop
))
8086 return Protected_Body_Subprogram
(Dyn_Scop
);
8091 end Enclosing_Subprogram
;
8093 --------------------------
8094 -- End_Keyword_Location --
8095 --------------------------
8097 function End_Keyword_Location
(N
: Node_Id
) return Source_Ptr
is
8098 function End_Label_Loc
(Nod
: Node_Id
) return Source_Ptr
;
8099 -- Return the source location of Nod's end label according to the
8100 -- following precedence rules:
8102 -- 1) If the end label exists, return its location
8103 -- 2) If Nod exists, return its location
8104 -- 3) Return the location of N
8110 function End_Label_Loc
(Nod
: Node_Id
) return Source_Ptr
is
8114 if Present
(Nod
) then
8115 Label
:= End_Label
(Nod
);
8117 if Present
(Label
) then
8118 return Sloc
(Label
);
8132 -- Start of processing for End_Keyword_Location
8135 if Nkind
(N
) in N_Block_Statement
8141 Owner
:= Handled_Statement_Sequence
(N
);
8143 elsif Nkind
(N
) = N_Package_Declaration
then
8144 Owner
:= Specification
(N
);
8146 elsif Nkind
(N
) = N_Protected_Body
then
8149 elsif Nkind
(N
) in N_Protected_Type_Declaration
8150 | N_Single_Protected_Declaration
8152 Owner
:= Protected_Definition
(N
);
8154 elsif Nkind
(N
) in N_Single_Task_Declaration | N_Task_Type_Declaration
8156 Owner
:= Task_Definition
(N
);
8158 -- This routine should not be called with other contexts
8161 pragma Assert
(False);
8165 return End_Label_Loc
(Owner
);
8166 end End_Keyword_Location
;
8168 ------------------------
8169 -- Ensure_Freeze_Node --
8170 ------------------------
8172 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
8175 if No
(Freeze_Node
(E
)) then
8176 FN
:= Make_Freeze_Entity
(Sloc
(E
));
8177 Set_Has_Delayed_Freeze
(E
);
8178 Set_Freeze_Node
(E
, FN
);
8179 Set_Access_Types_To_Process
(FN
, No_Elist
);
8180 Set_TSS_Elist
(FN
, No_Elist
);
8183 end Ensure_Freeze_Node
;
8189 procedure Enter_Name
(Def_Id
: Entity_Id
) is
8190 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
8191 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
8192 S
: constant Entity_Id
:= Current_Scope
;
8195 Generate_Definition
(Def_Id
);
8197 -- Add new name to current scope declarations. Check for duplicate
8198 -- declaration, which may or may not be a genuine error.
8202 -- Case of previous entity entered because of a missing declaration
8203 -- or else a bad subtype indication. Best is to use the new entity,
8204 -- and make the previous one invisible.
8206 if Etype
(E
) = Any_Type
then
8207 Set_Is_Immediately_Visible
(E
, False);
8209 -- Case of renaming declaration constructed for package instances.
8210 -- if there is an explicit declaration with the same identifier,
8211 -- the renaming is not immediately visible any longer, but remains
8212 -- visible through selected component notation.
8214 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
8215 and then not Comes_From_Source
(E
)
8217 Set_Is_Immediately_Visible
(E
, False);
8219 -- The new entity may be the package renaming, which has the same
8220 -- same name as a generic formal which has been seen already.
8222 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
8223 and then not Comes_From_Source
(Def_Id
)
8225 Set_Is_Immediately_Visible
(E
, False);
8227 -- For a fat pointer corresponding to a remote access to subprogram,
8228 -- we use the same identifier as the RAS type, so that the proper
8229 -- name appears in the stub. This type is only retrieved through
8230 -- the RAS type and never by visibility, and is not added to the
8231 -- visibility list (see below).
8233 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
8234 and then Ekind
(Def_Id
) = E_Record_Type
8235 and then Present
(Corresponding_Remote_Type
(Def_Id
))
8239 -- Case of an implicit operation or derived literal. The new entity
8240 -- hides the implicit one, which is removed from all visibility,
8241 -- i.e. the entity list of its scope, and homonym chain of its name.
8243 elsif (Is_Overloadable
(E
) and then Is_Inherited_Operation
(E
))
8244 or else Is_Internal
(E
)
8247 Decl
: constant Node_Id
:= Parent
(E
);
8249 Prev_Vis
: Entity_Id
;
8252 -- If E is an implicit declaration, it cannot be the first
8253 -- entity in the scope.
8255 Prev
:= First_Entity
(Current_Scope
);
8256 while Present
(Prev
) and then Next_Entity
(Prev
) /= E
loop
8262 -- If E is not on the entity chain of the current scope,
8263 -- it is an implicit declaration in the generic formal
8264 -- part of a generic subprogram. When analyzing the body,
8265 -- the generic formals are visible but not on the entity
8266 -- chain of the subprogram. The new entity will become
8267 -- the visible one in the body.
8270 (Nkind
(Parent
(Decl
)) = N_Generic_Subprogram_Declaration
);
8274 Link_Entities
(Prev
, Next_Entity
(E
));
8276 if No
(Next_Entity
(Prev
)) then
8277 Set_Last_Entity
(Current_Scope
, Prev
);
8280 if E
= Current_Entity
(E
) then
8284 Prev_Vis
:= Current_Entity
(E
);
8285 while Homonym
(Prev_Vis
) /= E
loop
8286 Prev_Vis
:= Homonym
(Prev_Vis
);
8290 if Present
(Prev_Vis
) then
8292 -- Skip E in the visibility chain
8294 Set_Homonym
(Prev_Vis
, Homonym
(E
));
8297 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
8300 -- The inherited operation cannot be retrieved
8301 -- by name, even though it may remain accesssible
8302 -- in some cases involving subprogram bodies without
8303 -- specs appearing in with_clauses..
8305 Set_Is_Immediately_Visible
(E
, False);
8309 -- This section of code could use a comment ???
8311 elsif Present
(Etype
(E
))
8312 and then Is_Concurrent_Type
(Etype
(E
))
8317 -- If the homograph is a protected component renaming, it should not
8318 -- be hiding the current entity. Such renamings are treated as weak
8321 elsif Is_Prival
(E
) then
8322 Set_Is_Immediately_Visible
(E
, False);
8324 -- In this case the current entity is a protected component renaming.
8325 -- Perform minimal decoration by setting the scope and return since
8326 -- the prival should not be hiding other visible entities.
8328 elsif Is_Prival
(Def_Id
) then
8329 Set_Scope
(Def_Id
, Current_Scope
);
8332 -- Analogous to privals, the discriminal generated for an entry index
8333 -- parameter acts as a weak declaration. Perform minimal decoration
8334 -- to avoid bogus errors.
8336 elsif Is_Discriminal
(Def_Id
)
8337 and then Ekind
(Discriminal_Link
(Def_Id
)) = E_Entry_Index_Parameter
8339 Set_Scope
(Def_Id
, Current_Scope
);
8342 -- In the body or private part of an instance, a type extension may
8343 -- introduce a component with the same name as that of an actual. The
8344 -- legality rule is not enforced, but the semantics of the full type
8345 -- with two components of same name are not clear at this point???
8347 elsif In_Instance_Not_Visible
then
8350 -- When compiling a package body, some child units may have become
8351 -- visible. They cannot conflict with local entities that hide them.
8353 elsif Is_Child_Unit
(E
)
8354 and then In_Open_Scopes
(Scope
(E
))
8355 and then not Is_Immediately_Visible
(E
)
8359 -- Conversely, with front-end inlining we may compile the parent body
8360 -- first, and a child unit subsequently. The context is now the
8361 -- parent spec, and body entities are not visible.
8363 elsif Is_Child_Unit
(Def_Id
)
8364 and then Is_Package_Body_Entity
(E
)
8365 and then not In_Package_Body
(Current_Scope
)
8369 -- Case of genuine duplicate declaration
8372 Error_Msg_Sloc
:= Sloc
(E
);
8374 -- If the previous declaration is an incomplete type declaration
8375 -- this may be an attempt to complete it with a private type. The
8376 -- following avoids confusing cascaded errors.
8378 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
8379 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
8382 ("incomplete type cannot be completed with a private " &
8383 "declaration", Parent
(Def_Id
));
8384 Set_Is_Immediately_Visible
(E
, False);
8385 Set_Full_View
(E
, Def_Id
);
8387 -- An inherited component of a record conflicts with a new
8388 -- discriminant. The discriminant is inserted first in the scope,
8389 -- but the error should be posted on it, not on the component.
8391 elsif Ekind
(E
) = E_Discriminant
8392 and then Present
(Scope
(Def_Id
))
8393 and then Scope
(Def_Id
) /= Current_Scope
8395 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8396 Error_Msg_N
("& conflicts with declaration#", E
);
8399 -- If the name of the unit appears in its own context clause, a
8400 -- dummy package with the name has already been created, and the
8401 -- error emitted. Try to continue quietly.
8403 elsif Error_Posted
(E
)
8404 and then Sloc
(E
) = No_Location
8405 and then Nkind
(Parent
(E
)) = N_Package_Specification
8406 and then Current_Scope
= Standard_Standard
8408 Set_Scope
(Def_Id
, Current_Scope
);
8412 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
8414 -- Avoid cascaded messages with duplicate components in
8417 if Ekind
(E
) in E_Component | E_Discriminant
then
8422 if Nkind
(Parent
(Parent
(Def_Id
))) =
8423 N_Generic_Subprogram_Declaration
8425 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
8427 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
8430 -- If entity is in standard, then we are in trouble, because it
8431 -- means that we have a library package with a duplicated name.
8432 -- That's hard to recover from, so abort.
8434 if S
= Standard_Standard
then
8435 raise Unrecoverable_Error
;
8437 -- Otherwise we continue with the declaration. Having two
8438 -- identical declarations should not cause us too much trouble.
8446 -- If we fall through, declaration is OK, at least OK enough to continue
8448 -- If Def_Id is a discriminant or a record component we are in the midst
8449 -- of inheriting components in a derived record definition. Preserve
8450 -- their Ekind and Etype.
8452 if Ekind
(Def_Id
) in E_Discriminant | E_Component
then
8455 -- If a type is already set, leave it alone (happens when a type
8456 -- declaration is reanalyzed following a call to the optimizer).
8458 elsif Present
(Etype
(Def_Id
)) then
8461 -- Otherwise, the kind E_Void insures that premature uses of the entity
8462 -- will be detected. Any_Type insures that no cascaded errors will occur
8465 Set_Ekind
(Def_Id
, E_Void
);
8466 Set_Etype
(Def_Id
, Any_Type
);
8469 -- All entities except Itypes are immediately visible
8471 if not Is_Itype
(Def_Id
) then
8472 Set_Is_Immediately_Visible
(Def_Id
);
8473 Set_Current_Entity
(Def_Id
);
8476 Set_Homonym
(Def_Id
, C
);
8477 Append_Entity
(Def_Id
, S
);
8478 Set_Public_Status
(Def_Id
);
8480 -- Warn if new entity hides an old one
8482 if Warn_On_Hiding
and then Present
(C
)
8484 -- Don't warn for record components since they always have a well
8485 -- defined scope which does not confuse other uses. Note that in
8486 -- some cases, Ekind has not been set yet.
8488 and then Ekind
(C
) /= E_Component
8489 and then Ekind
(C
) /= E_Discriminant
8490 and then Nkind
(Parent
(C
)) /= N_Component_Declaration
8491 and then Ekind
(Def_Id
) /= E_Component
8492 and then Ekind
(Def_Id
) /= E_Discriminant
8493 and then Nkind
(Parent
(Def_Id
)) /= N_Component_Declaration
8495 -- Don't warn for one character variables. It is too common to use
8496 -- such variables as locals and will just cause too many false hits.
8498 and then Length_Of_Name
(Chars
(C
)) /= 1
8500 -- Don't warn for non-source entities
8502 and then Comes_From_Source
(C
)
8503 and then Comes_From_Source
(Def_Id
)
8505 -- Don't warn unless entity in question is in extended main source
8507 and then In_Extended_Main_Source_Unit
(Def_Id
)
8509 -- Finally, the hidden entity must be either immediately visible or
8510 -- use visible (i.e. from a used package).
8513 (Is_Immediately_Visible
(C
)
8515 Is_Potentially_Use_Visible
(C
))
8517 Error_Msg_Sloc
:= Sloc
(C
);
8518 Error_Msg_N
("declaration hides &#?h?", Def_Id
);
8526 function Entity_Of
(N
: Node_Id
) return Entity_Id
is
8531 -- Assume that the arbitrary node does not have an entity
8535 if Is_Entity_Name
(N
) then
8538 -- Follow a possible chain of renamings to reach the earliest renamed
8542 and then Is_Object
(Id
)
8543 and then Present
(Renamed_Object
(Id
))
8545 Ren
:= Renamed_Object
(Id
);
8547 -- The reference renames an abstract state or a whole object
8550 -- Ren : ... renames Obj;
8552 if Is_Entity_Name
(Ren
) then
8554 -- Do not follow a renaming that goes through a generic formal,
8555 -- because these entities are hidden and must not be referenced
8556 -- from outside the generic.
8558 if Is_Hidden
(Entity
(Ren
)) then
8565 -- The reference renames a function result. Check the original
8566 -- node in case expansion relocates the function call.
8568 -- Ren : ... renames Func_Call;
8570 elsif Nkind
(Original_Node
(Ren
)) = N_Function_Call
then
8573 -- Otherwise the reference renames something which does not yield
8574 -- an abstract state or a whole object. Treat the reference as not
8575 -- having a proper entity for SPARK legality purposes.
8587 --------------------------
8588 -- Examine_Array_Bounds --
8589 --------------------------
8591 procedure Examine_Array_Bounds
8593 All_Static
: out Boolean;
8594 Has_Empty
: out Boolean)
8596 function Is_OK_Static_Bound
(Bound
: Node_Id
) return Boolean;
8597 -- Determine whether bound Bound is a suitable static bound
8599 ------------------------
8600 -- Is_OK_Static_Bound --
8601 ------------------------
8603 function Is_OK_Static_Bound
(Bound
: Node_Id
) return Boolean is
8606 not Error_Posted
(Bound
)
8607 and then Is_OK_Static_Expression
(Bound
);
8608 end Is_OK_Static_Bound
;
8616 -- Start of processing for Examine_Array_Bounds
8619 -- An unconstrained array type does not have static bounds, and it is
8620 -- not known whether they are empty or not.
8622 if not Is_Constrained
(Typ
) then
8623 All_Static
:= False;
8626 -- A string literal has static bounds, and is not empty as long as it
8627 -- contains at least one character.
8629 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
8631 Has_Empty
:= String_Literal_Length
(Typ
) > 0;
8634 -- Assume that all bounds are static and not empty
8639 -- Examine each index
8641 Index
:= First_Index
(Typ
);
8642 while Present
(Index
) loop
8643 if Is_Discrete_Type
(Etype
(Index
)) then
8644 Get_Index_Bounds
(Index
, Lo_Bound
, Hi_Bound
);
8646 if Is_OK_Static_Bound
(Lo_Bound
)
8648 Is_OK_Static_Bound
(Hi_Bound
)
8650 -- The static bounds produce an empty range
8652 if Is_Null_Range
(Lo_Bound
, Hi_Bound
) then
8656 -- Otherwise at least one of the bounds is not static
8659 All_Static
:= False;
8662 -- Otherwise the index is non-discrete, therefore not static
8665 All_Static
:= False;
8670 end Examine_Array_Bounds
;
8676 function Exceptions_OK
return Boolean is
8679 not (Restriction_Active
(No_Exception_Handlers
) or else
8680 Restriction_Active
(No_Exception_Propagation
) or else
8681 Restriction_Active
(No_Exceptions
));
8684 --------------------------
8685 -- Explain_Limited_Type --
8686 --------------------------
8688 procedure Explain_Limited_Type
(T
: Entity_Id
; N
: Node_Id
) is
8692 -- For array, component type must be limited
8694 if Is_Array_Type
(T
) then
8695 Error_Msg_Node_2
:= T
;
8697 ("\component type& of type& is limited", N
, Component_Type
(T
));
8698 Explain_Limited_Type
(Component_Type
(T
), N
);
8700 elsif Is_Record_Type
(T
) then
8702 -- No need for extra messages if explicit limited record
8704 if Is_Limited_Record
(Base_Type
(T
)) then
8708 -- Otherwise find a limited component. Check only components that
8709 -- come from source, or inherited components that appear in the
8710 -- source of the ancestor.
8712 C
:= First_Component
(T
);
8713 while Present
(C
) loop
8714 if Is_Limited_Type
(Etype
(C
))
8716 (Comes_From_Source
(C
)
8718 (Present
(Original_Record_Component
(C
))
8720 Comes_From_Source
(Original_Record_Component
(C
))))
8722 Error_Msg_Node_2
:= T
;
8723 Error_Msg_NE
("\component& of type& has limited type", N
, C
);
8724 Explain_Limited_Type
(Etype
(C
), N
);
8731 -- The type may be declared explicitly limited, even if no component
8732 -- of it is limited, in which case we fall out of the loop.
8735 end Explain_Limited_Type
;
8737 ---------------------------------------
8738 -- Expression_Of_Expression_Function --
8739 ---------------------------------------
8741 function Expression_Of_Expression_Function
8742 (Subp
: Entity_Id
) return Node_Id
8744 Expr_Func
: Node_Id
;
8747 pragma Assert
(Is_Expression_Function_Or_Completion
(Subp
));
8749 if Nkind
(Original_Node
(Subprogram_Spec
(Subp
))) =
8750 N_Expression_Function
8752 Expr_Func
:= Original_Node
(Subprogram_Spec
(Subp
));
8754 elsif Nkind
(Original_Node
(Subprogram_Body
(Subp
))) =
8755 N_Expression_Function
8757 Expr_Func
:= Original_Node
(Subprogram_Body
(Subp
));
8760 pragma Assert
(False);
8764 return Original_Node
(Expression
(Expr_Func
));
8765 end Expression_Of_Expression_Function
;
8767 -------------------------------
8768 -- Extensions_Visible_Status --
8769 -------------------------------
8771 function Extensions_Visible_Status
8772 (Id
: Entity_Id
) return Extensions_Visible_Mode
8781 -- When a formal parameter is subject to Extensions_Visible, the pragma
8782 -- is stored in the contract of related subprogram.
8784 if Is_Formal
(Id
) then
8787 elsif Is_Subprogram_Or_Generic_Subprogram
(Id
) then
8790 -- No other construct carries this pragma
8793 return Extensions_Visible_None
;
8796 Prag
:= Get_Pragma
(Subp
, Pragma_Extensions_Visible
);
8798 -- In certain cases analysis may request the Extensions_Visible status
8799 -- of an expression function before the pragma has been analyzed yet.
8800 -- Inspect the declarative items after the expression function looking
8801 -- for the pragma (if any).
8803 if No
(Prag
) and then Is_Expression_Function
(Subp
) then
8804 Decl
:= Next
(Unit_Declaration_Node
(Subp
));
8805 while Present
(Decl
) loop
8806 if Nkind
(Decl
) = N_Pragma
8807 and then Pragma_Name
(Decl
) = Name_Extensions_Visible
8812 -- A source construct ends the region where Extensions_Visible may
8813 -- appear, stop the traversal. An expanded expression function is
8814 -- no longer a source construct, but it must still be recognized.
8816 elsif Comes_From_Source
(Decl
)
8818 (Nkind
(Decl
) in N_Subprogram_Body | N_Subprogram_Declaration
8819 and then Is_Expression_Function
(Defining_Entity
(Decl
)))
8828 -- Extract the value from the Boolean expression (if any)
8830 if Present
(Prag
) then
8831 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
8833 if Present
(Arg
) then
8834 Expr
:= Get_Pragma_Arg
(Arg
);
8836 -- When the associated subprogram is an expression function, the
8837 -- argument of the pragma may not have been analyzed.
8839 if not Analyzed
(Expr
) then
8840 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
8843 -- Guard against cascading errors when the argument of pragma
8844 -- Extensions_Visible is not a valid static Boolean expression.
8846 if Error_Posted
(Expr
) then
8847 return Extensions_Visible_None
;
8849 elsif Is_True
(Expr_Value
(Expr
)) then
8850 return Extensions_Visible_True
;
8853 return Extensions_Visible_False
;
8856 -- Otherwise the aspect or pragma defaults to True
8859 return Extensions_Visible_True
;
8862 -- Otherwise aspect or pragma Extensions_Visible is not inherited or
8863 -- directly specified. In SPARK code, its value defaults to "False".
8865 elsif SPARK_Mode
= On
then
8866 return Extensions_Visible_False
;
8868 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to
8872 return Extensions_Visible_True
;
8874 end Extensions_Visible_Status
;
8880 procedure Find_Actual
8882 Formal
: out Entity_Id
;
8885 Context
: constant Node_Id
:= Parent
(N
);
8890 if Nkind
(Context
) in N_Indexed_Component | N_Selected_Component
8891 and then N
= Prefix
(Context
)
8893 Find_Actual
(Context
, Formal
, Call
);
8896 elsif Nkind
(Context
) = N_Parameter_Association
8897 and then N
= Explicit_Actual_Parameter
(Context
)
8899 Call
:= Parent
(Context
);
8901 elsif Nkind
(Context
) in N_Entry_Call_Statement
8903 | N_Procedure_Call_Statement
8913 -- If we have a call to a subprogram look for the parameter. Note that
8914 -- we exclude overloaded calls, since we don't know enough to be sure
8915 -- of giving the right answer in this case.
8917 if Nkind
(Call
) in N_Entry_Call_Statement
8919 | N_Procedure_Call_Statement
8921 Call_Nam
:= Name
(Call
);
8923 -- A call to a protected or task entry appears as a selected
8924 -- component rather than an expanded name.
8926 if Nkind
(Call_Nam
) = N_Selected_Component
then
8927 Call_Nam
:= Selector_Name
(Call_Nam
);
8930 if Is_Entity_Name
(Call_Nam
)
8931 and then Present
(Entity
(Call_Nam
))
8932 and then Is_Overloadable
(Entity
(Call_Nam
))
8933 and then not Is_Overloaded
(Call_Nam
)
8935 -- If node is name in call it is not an actual
8937 if N
= Call_Nam
then
8943 -- Fall here if we are definitely a parameter
8945 Actual
:= First_Actual
(Call
);
8946 Formal
:= First_Formal
(Entity
(Call_Nam
));
8947 while Present
(Formal
) and then Present
(Actual
) loop
8951 -- An actual that is the prefix in a prefixed call may have
8952 -- been rewritten in the call, after the deferred reference
8953 -- was collected. Check if sloc and kinds and names match.
8955 elsif Sloc
(Actual
) = Sloc
(N
)
8956 and then Nkind
(Actual
) = N_Identifier
8957 and then Nkind
(Actual
) = Nkind
(N
)
8958 and then Chars
(Actual
) = Chars
(N
)
8963 Next_Actual
(Actual
);
8964 Next_Formal
(Formal
);
8970 -- Fall through here if we did not find matching actual
8976 ---------------------------
8977 -- Find_Body_Discriminal --
8978 ---------------------------
8980 function Find_Body_Discriminal
8981 (Spec_Discriminant
: Entity_Id
) return Entity_Id
8987 -- If expansion is suppressed, then the scope can be the concurrent type
8988 -- itself rather than a corresponding concurrent record type.
8990 if Is_Concurrent_Type
(Scope
(Spec_Discriminant
)) then
8991 Tsk
:= Scope
(Spec_Discriminant
);
8994 pragma Assert
(Is_Concurrent_Record_Type
(Scope
(Spec_Discriminant
)));
8996 Tsk
:= Corresponding_Concurrent_Type
(Scope
(Spec_Discriminant
));
8999 -- Find discriminant of original concurrent type, and use its current
9000 -- discriminal, which is the renaming within the task/protected body.
9002 Disc
:= First_Discriminant
(Tsk
);
9003 while Present
(Disc
) loop
9004 if Chars
(Disc
) = Chars
(Spec_Discriminant
) then
9005 return Discriminal
(Disc
);
9008 Next_Discriminant
(Disc
);
9011 -- That loop should always succeed in finding a matching entry and
9012 -- returning. Fatal error if not.
9014 raise Program_Error
;
9015 end Find_Body_Discriminal
;
9017 -------------------------------------
9018 -- Find_Corresponding_Discriminant --
9019 -------------------------------------
9021 function Find_Corresponding_Discriminant
9023 Typ
: Entity_Id
) return Entity_Id
9025 Par_Disc
: Entity_Id
;
9026 Old_Disc
: Entity_Id
;
9027 New_Disc
: Entity_Id
;
9030 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
9032 -- The original type may currently be private, and the discriminant
9033 -- only appear on its full view.
9035 if Is_Private_Type
(Scope
(Par_Disc
))
9036 and then not Has_Discriminants
(Scope
(Par_Disc
))
9037 and then Present
(Full_View
(Scope
(Par_Disc
)))
9039 Old_Disc
:= First_Discriminant
(Full_View
(Scope
(Par_Disc
)));
9041 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
9044 if Is_Class_Wide_Type
(Typ
) then
9045 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
9047 New_Disc
:= First_Discriminant
(Typ
);
9050 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
9051 if Old_Disc
= Par_Disc
then
9055 Next_Discriminant
(Old_Disc
);
9056 Next_Discriminant
(New_Disc
);
9059 -- Should always find it
9061 raise Program_Error
;
9062 end Find_Corresponding_Discriminant
;
9068 function Find_DIC_Type
(Typ
: Entity_Id
) return Entity_Id
is
9069 Curr_Typ
: Entity_Id
;
9070 -- The current type being examined in the parent hierarchy traversal
9072 DIC_Typ
: Entity_Id
;
9073 -- The type which carries the DIC pragma. This variable denotes the
9074 -- partial view when private types are involved.
9076 Par_Typ
: Entity_Id
;
9077 -- The parent type of the current type. This variable denotes the full
9078 -- view when private types are involved.
9081 -- The input type defines its own DIC pragma, therefore it is the owner
9083 if Has_Own_DIC
(Typ
) then
9086 -- Otherwise the DIC pragma is inherited from a parent type
9089 pragma Assert
(Has_Inherited_DIC
(Typ
));
9091 -- Climb the parent chain
9095 -- Inspect the parent type. Do not consider subtypes as they
9096 -- inherit the DIC attributes from their base types.
9098 DIC_Typ
:= Base_Type
(Etype
(Curr_Typ
));
9100 -- Look at the full view of a private type because the type may
9101 -- have a hidden parent introduced in the full view.
9105 if Is_Private_Type
(Par_Typ
)
9106 and then Present
(Full_View
(Par_Typ
))
9108 Par_Typ
:= Full_View
(Par_Typ
);
9111 -- Stop the climb once the nearest parent type which defines a DIC
9112 -- pragma of its own is encountered or when the root of the parent
9113 -- chain is reached.
9115 exit when Has_Own_DIC
(DIC_Typ
) or else Curr_Typ
= Par_Typ
;
9117 Curr_Typ
:= Par_Typ
;
9124 ----------------------------------
9125 -- Find_Enclosing_Iterator_Loop --
9126 ----------------------------------
9128 function Find_Enclosing_Iterator_Loop
(Id
: Entity_Id
) return Entity_Id
is
9133 -- Traverse the scope chain looking for an iterator loop. Such loops are
9134 -- usually transformed into blocks, hence the use of Original_Node.
9137 while Present
(S
) and then S
/= Standard_Standard
loop
9138 if Ekind
(S
) = E_Loop
9139 and then Nkind
(Parent
(S
)) = N_Implicit_Label_Declaration
9141 Constr
:= Original_Node
(Label_Construct
(Parent
(S
)));
9143 if Nkind
(Constr
) = N_Loop_Statement
9144 and then Present
(Iteration_Scheme
(Constr
))
9145 and then Nkind
(Iterator_Specification
9146 (Iteration_Scheme
(Constr
))) =
9147 N_Iterator_Specification
9157 end Find_Enclosing_Iterator_Loop
;
9159 --------------------------
9160 -- Find_Enclosing_Scope --
9161 --------------------------
9163 function Find_Enclosing_Scope
(N
: Node_Id
) return Entity_Id
is
9167 -- Examine the parent chain looking for a construct which defines a
9171 while Present
(Par
) loop
9174 -- The construct denotes a declaration, the proper scope is its
9177 when N_Entry_Declaration
9178 | N_Expression_Function
9179 | N_Full_Type_Declaration
9180 | N_Generic_Package_Declaration
9181 | N_Generic_Subprogram_Declaration
9182 | N_Package_Declaration
9183 | N_Private_Extension_Declaration
9184 | N_Protected_Type_Declaration
9185 | N_Single_Protected_Declaration
9186 | N_Single_Task_Declaration
9187 | N_Subprogram_Declaration
9188 | N_Task_Type_Declaration
9190 return Defining_Entity
(Par
);
9192 -- The construct denotes a body, the proper scope is the entity of
9193 -- the corresponding spec or that of the body if the body does not
9194 -- complete a previous declaration.
9202 return Unique_Defining_Entity
(Par
);
9206 -- Blocks carry either a source or an internally-generated scope,
9207 -- unless the block is a byproduct of exception handling.
9209 when N_Block_Statement
=>
9210 if not Exception_Junk
(Par
) then
9211 return Entity
(Identifier
(Par
));
9214 -- Loops carry an internally-generated scope
9216 when N_Loop_Statement
=>
9217 return Entity
(Identifier
(Par
));
9219 -- Extended return statements carry an internally-generated scope
9221 when N_Extended_Return_Statement
=>
9222 return Return_Statement_Entity
(Par
);
9224 -- A traversal from a subunit continues via the corresponding stub
9227 Par
:= Corresponding_Stub
(Par
);
9233 Par
:= Parent
(Par
);
9236 return Standard_Standard
;
9237 end Find_Enclosing_Scope
;
9239 ------------------------------------
9240 -- Find_Loop_In_Conditional_Block --
9241 ------------------------------------
9243 function Find_Loop_In_Conditional_Block
(N
: Node_Id
) return Node_Id
is
9249 if Nkind
(Stmt
) = N_If_Statement
then
9250 Stmt
:= First
(Then_Statements
(Stmt
));
9253 pragma Assert
(Nkind
(Stmt
) = N_Block_Statement
);
9255 -- Inspect the statements of the conditional block. In general the loop
9256 -- should be the first statement in the statement sequence of the block,
9257 -- but the finalization machinery may have introduced extra object
9260 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Stmt
)));
9261 while Present
(Stmt
) loop
9262 if Nkind
(Stmt
) = N_Loop_Statement
then
9269 -- The expansion of attribute 'Loop_Entry produced a malformed block
9271 raise Program_Error
;
9272 end Find_Loop_In_Conditional_Block
;
9274 --------------------------
9275 -- Find_Overlaid_Entity --
9276 --------------------------
9278 procedure Find_Overlaid_Entity
9280 Ent
: out Entity_Id
;
9286 -- We are looking for one of the two following forms:
9288 -- for X'Address use Y'Address
9292 -- Const : constant Address := expr;
9294 -- for X'Address use Const;
9296 -- In the second case, the expr is either Y'Address, or recursively a
9297 -- constant that eventually references Y'Address.
9302 if Nkind
(N
) = N_Attribute_Definition_Clause
9303 and then Chars
(N
) = Name_Address
9305 Expr
:= Expression
(N
);
9307 -- This loop checks the form of the expression for Y'Address,
9308 -- using recursion to deal with intermediate constants.
9311 -- Check for Y'Address
9313 if Nkind
(Expr
) = N_Attribute_Reference
9314 and then Attribute_Name
(Expr
) = Name_Address
9316 Expr
:= Prefix
(Expr
);
9319 -- Check for Const where Const is a constant entity
9321 elsif Is_Entity_Name
(Expr
)
9322 and then Ekind
(Entity
(Expr
)) = E_Constant
9324 Expr
:= Constant_Value
(Entity
(Expr
));
9326 -- Anything else does not need checking
9333 -- This loop checks the form of the prefix for an entity, using
9334 -- recursion to deal with intermediate components.
9337 -- Check for Y where Y is an entity
9339 if Is_Entity_Name
(Expr
) then
9340 Ent
:= Entity
(Expr
);
9343 -- Check for components
9345 elsif Nkind
(Expr
) in N_Selected_Component | N_Indexed_Component
9347 Expr
:= Prefix
(Expr
);
9350 -- Anything else does not need checking
9357 end Find_Overlaid_Entity
;
9359 -------------------------
9360 -- Find_Parameter_Type --
9361 -------------------------
9363 function Find_Parameter_Type
(Param
: Node_Id
) return Entity_Id
is
9365 if Nkind
(Param
) /= N_Parameter_Specification
then
9368 -- For an access parameter, obtain the type from the formal entity
9369 -- itself, because access to subprogram nodes do not carry a type.
9370 -- Shouldn't we always use the formal entity ???
9372 elsif Nkind
(Parameter_Type
(Param
)) = N_Access_Definition
then
9373 return Etype
(Defining_Identifier
(Param
));
9376 return Etype
(Parameter_Type
(Param
));
9378 end Find_Parameter_Type
;
9380 -----------------------------------
9381 -- Find_Placement_In_State_Space --
9382 -----------------------------------
9384 procedure Find_Placement_In_State_Space
9385 (Item_Id
: Entity_Id
;
9386 Placement
: out State_Space_Kind
;
9387 Pack_Id
: out Entity_Id
)
9389 Context
: Entity_Id
;
9392 -- Assume that the item does not appear in the state space of a package
9394 Placement
:= Not_In_Package
;
9397 -- Climb the scope stack and examine the enclosing context
9399 Context
:= Scope
(Item_Id
);
9400 while Present
(Context
) and then Context
/= Standard_Standard
loop
9401 if Is_Package_Or_Generic_Package
(Context
) then
9404 -- A package body is a cut off point for the traversal as the item
9405 -- cannot be visible to the outside from this point on. Note that
9406 -- this test must be done first as a body is also classified as a
9409 if In_Package_Body
(Context
) then
9410 Placement
:= Body_State_Space
;
9413 -- The private part of a package is a cut off point for the
9414 -- traversal as the item cannot be visible to the outside from
9417 elsif In_Private_Part
(Context
) then
9418 Placement
:= Private_State_Space
;
9421 -- When the item appears in the visible state space of a package,
9422 -- continue to climb the scope stack as this may not be the final
9426 Placement
:= Visible_State_Space
;
9428 -- The visible state space of a child unit acts as the proper
9429 -- placement of an item.
9431 if Is_Child_Unit
(Context
) then
9436 -- The item or its enclosing package appear in a construct that has
9440 Placement
:= Not_In_Package
;
9444 Context
:= Scope
(Context
);
9446 end Find_Placement_In_State_Space
;
9448 -----------------------
9449 -- Find_Primitive_Eq --
9450 -----------------------
9452 function Find_Primitive_Eq
(Typ
: Entity_Id
) return Entity_Id
is
9453 function Find_Eq_Prim
(Prims_List
: Elist_Id
) return Entity_Id
;
9454 -- Search for the equality primitive; return Empty if the primitive is
9461 function Find_Eq_Prim
(Prims_List
: Elist_Id
) return Entity_Id
is
9463 Prim_Elmt
: Elmt_Id
;
9466 Prim_Elmt
:= First_Elmt
(Prims_List
);
9467 while Present
(Prim_Elmt
) loop
9468 Prim
:= Node
(Prim_Elmt
);
9470 -- Locate primitive equality with the right signature
9472 if Chars
(Prim
) = Name_Op_Eq
9473 and then Etype
(First_Formal
(Prim
)) =
9474 Etype
(Next_Formal
(First_Formal
(Prim
)))
9475 and then Base_Type
(Etype
(Prim
)) = Standard_Boolean
9480 Next_Elmt
(Prim_Elmt
);
9488 Eq_Prim
: Entity_Id
;
9489 Full_Type
: Entity_Id
;
9491 -- Start of processing for Find_Primitive_Eq
9494 if Is_Private_Type
(Typ
) then
9495 Full_Type
:= Underlying_Type
(Typ
);
9500 if No
(Full_Type
) then
9504 Full_Type
:= Base_Type
(Full_Type
);
9506 -- When the base type itself is private, use the full view
9508 if Is_Private_Type
(Full_Type
) then
9509 Full_Type
:= Underlying_Type
(Full_Type
);
9512 if Is_Class_Wide_Type
(Full_Type
) then
9513 Full_Type
:= Root_Type
(Full_Type
);
9516 if not Is_Tagged_Type
(Full_Type
) then
9517 Eq_Prim
:= Find_Eq_Prim
(Collect_Primitive_Operations
(Typ
));
9519 -- If this is an untagged private type completed with a derivation of
9520 -- an untagged private type whose full view is a tagged type, we use
9521 -- the primitive operations of the private parent type (since it does
9522 -- not have a full view, and also because its equality primitive may
9523 -- have been overridden in its untagged full view). If no equality was
9524 -- defined for it then take its dispatching equality primitive.
9526 elsif Inherits_From_Tagged_Full_View
(Typ
) then
9527 Eq_Prim
:= Find_Eq_Prim
(Collect_Primitive_Operations
(Typ
));
9529 if No
(Eq_Prim
) then
9530 Eq_Prim
:= Find_Eq_Prim
(Primitive_Operations
(Full_Type
));
9534 Eq_Prim
:= Find_Eq_Prim
(Primitive_Operations
(Full_Type
));
9538 end Find_Primitive_Eq
;
9540 ------------------------
9541 -- Find_Specific_Type --
9542 ------------------------
9544 function Find_Specific_Type
(CW
: Entity_Id
) return Entity_Id
is
9545 Typ
: Entity_Id
:= Root_Type
(CW
);
9548 if Ekind
(Typ
) = E_Incomplete_Type
then
9549 if From_Limited_With
(Typ
) then
9550 Typ
:= Non_Limited_View
(Typ
);
9552 Typ
:= Full_View
(Typ
);
9556 if Is_Private_Type
(Typ
)
9557 and then not Is_Tagged_Type
(Typ
)
9558 and then Present
(Full_View
(Typ
))
9560 return Full_View
(Typ
);
9564 end Find_Specific_Type
;
9566 -----------------------------
9567 -- Find_Static_Alternative --
9568 -----------------------------
9570 function Find_Static_Alternative
(N
: Node_Id
) return Node_Id
is
9571 Expr
: constant Node_Id
:= Expression
(N
);
9572 Val
: constant Uint
:= Expr_Value
(Expr
);
9577 Alt
:= First
(Alternatives
(N
));
9580 if Nkind
(Alt
) /= N_Pragma
then
9581 Choice
:= First
(Discrete_Choices
(Alt
));
9582 while Present
(Choice
) loop
9584 -- Others choice, always matches
9586 if Nkind
(Choice
) = N_Others_Choice
then
9589 -- Range, check if value is in the range
9591 elsif Nkind
(Choice
) = N_Range
then
9593 Val
>= Expr_Value
(Low_Bound
(Choice
))
9595 Val
<= Expr_Value
(High_Bound
(Choice
));
9597 -- Choice is a subtype name. Note that we know it must
9598 -- be a static subtype, since otherwise it would have
9599 -- been diagnosed as illegal.
9601 elsif Is_Entity_Name
(Choice
)
9602 and then Is_Type
(Entity
(Choice
))
9604 exit Search
when Is_In_Range
(Expr
, Etype
(Choice
),
9605 Assume_Valid
=> False);
9607 -- Choice is a subtype indication
9609 elsif Nkind
(Choice
) = N_Subtype_Indication
then
9611 C
: constant Node_Id
:= Constraint
(Choice
);
9612 R
: constant Node_Id
:= Range_Expression
(C
);
9616 Val
>= Expr_Value
(Low_Bound
(R
))
9618 Val
<= Expr_Value
(High_Bound
(R
));
9621 -- Choice is a simple expression
9624 exit Search
when Val
= Expr_Value
(Choice
);
9632 pragma Assert
(Present
(Alt
));
9635 -- The above loop *must* terminate by finding a match, since we know the
9636 -- case statement is valid, and the value of the expression is known at
9637 -- compile time. When we fall out of the loop, Alt points to the
9638 -- alternative that we know will be selected at run time.
9641 end Find_Static_Alternative
;
9647 function First_Actual
(Node
: Node_Id
) return Node_Id
is
9651 if No
(Parameter_Associations
(Node
)) then
9655 N
:= First
(Parameter_Associations
(Node
));
9657 if Nkind
(N
) = N_Parameter_Association
then
9658 return First_Named_Actual
(Node
);
9668 function First_Global
9670 Global_Mode
: Name_Id
;
9671 Refined
: Boolean := False) return Node_Id
9673 function First_From_Global_List
9675 Global_Mode
: Name_Id
:= Name_Input
) return Entity_Id
;
9676 -- Get the first item with suitable mode from List
9678 ----------------------------
9679 -- First_From_Global_List --
9680 ----------------------------
9682 function First_From_Global_List
9684 Global_Mode
: Name_Id
:= Name_Input
) return Entity_Id
9689 -- Empty list (no global items)
9691 if Nkind
(List
) = N_Null
then
9694 -- Single global item declaration (only input items)
9696 elsif Nkind
(List
) in N_Expanded_Name | N_Identifier
then
9697 if Global_Mode
= Name_Input
then
9703 -- Simple global list (only input items) or moded global list
9706 elsif Nkind
(List
) = N_Aggregate
then
9707 if Present
(Expressions
(List
)) then
9708 if Global_Mode
= Name_Input
then
9709 return First
(Expressions
(List
));
9715 Assoc
:= First
(Component_Associations
(List
));
9716 while Present
(Assoc
) loop
9718 -- When we find the desired mode in an association, call
9719 -- recursively First_From_Global_List as if the mode was
9720 -- Name_Input, in order to reuse the existing machinery
9721 -- for the other cases.
9723 if Chars
(First
(Choices
(Assoc
))) = Global_Mode
then
9724 return First_From_Global_List
(Expression
(Assoc
));
9733 -- To accommodate partial decoration of disabled SPARK features,
9734 -- this routine may be called with illegal input. If this is the
9735 -- case, do not raise Program_Error.
9740 end First_From_Global_List
;
9744 Global
: Node_Id
:= Empty
;
9745 Body_Id
: Entity_Id
;
9747 -- Start of processing for First_Global
9750 pragma Assert
(Global_Mode
in Name_In_Out
9755 -- Retrieve the suitable pragma Global or Refined_Global. In the second
9756 -- case, it can only be located on the body entity.
9759 if Is_Subprogram_Or_Generic_Subprogram
(Subp
) then
9760 Body_Id
:= Subprogram_Body_Entity
(Subp
);
9762 elsif Is_Entry
(Subp
) or else Is_Task_Type
(Subp
) then
9763 Body_Id
:= Corresponding_Body
(Parent
(Subp
));
9765 -- ??? It should be possible to retrieve the Refined_Global on the
9766 -- task body associated to the task object. This is not yet possible.
9768 elsif Is_Single_Task_Object
(Subp
) then
9775 if Present
(Body_Id
) then
9776 Global
:= Get_Pragma
(Body_Id
, Pragma_Refined_Global
);
9779 Global
:= Get_Pragma
(Subp
, Pragma_Global
);
9782 -- No corresponding global if pragma is not present
9787 -- Otherwise retrieve the corresponding list of items depending on the
9791 return First_From_Global_List
9792 (Expression
(Get_Argument
(Global
, Subp
)), Global_Mode
);
9800 function Fix_Msg
(Id
: Entity_Id
; Msg
: String) return String is
9801 Is_Task
: constant Boolean :=
9802 Ekind
(Id
) in E_Task_Body | E_Task_Type
9803 or else Is_Single_Task_Object
(Id
);
9804 Msg_Last
: constant Natural := Msg
'Last;
9805 Msg_Index
: Natural;
9806 Res
: String (Msg
'Range) := (others => ' ');
9807 Res_Index
: Natural;
9810 -- Copy all characters from the input message Msg to result Res with
9811 -- suitable replacements.
9813 Msg_Index
:= Msg
'First;
9814 Res_Index
:= Res
'First;
9815 while Msg_Index
<= Msg_Last
loop
9817 -- Replace "subprogram" with a different word
9819 if Msg_Index
<= Msg_Last
- 10
9820 and then Msg
(Msg_Index
.. Msg_Index
+ 9) = "subprogram"
9822 if Is_Entry
(Id
) then
9823 Res
(Res_Index
.. Res_Index
+ 4) := "entry";
9824 Res_Index
:= Res_Index
+ 5;
9827 Res
(Res_Index
.. Res_Index
+ 8) := "task type";
9828 Res_Index
:= Res_Index
+ 9;
9831 Res
(Res_Index
.. Res_Index
+ 9) := "subprogram";
9832 Res_Index
:= Res_Index
+ 10;
9835 Msg_Index
:= Msg_Index
+ 10;
9837 -- Replace "protected" with a different word
9839 elsif Msg_Index
<= Msg_Last
- 9
9840 and then Msg
(Msg_Index
.. Msg_Index
+ 8) = "protected"
9843 Res
(Res_Index
.. Res_Index
+ 3) := "task";
9844 Res_Index
:= Res_Index
+ 4;
9845 Msg_Index
:= Msg_Index
+ 9;
9847 -- Otherwise copy the character
9850 Res
(Res_Index
) := Msg
(Msg_Index
);
9851 Msg_Index
:= Msg_Index
+ 1;
9852 Res_Index
:= Res_Index
+ 1;
9856 return Res
(Res
'First .. Res_Index
- 1);
9859 -------------------------
9860 -- From_Nested_Package --
9861 -------------------------
9863 function From_Nested_Package
(T
: Entity_Id
) return Boolean is
9864 Pack
: constant Entity_Id
:= Scope
(T
);
9868 Ekind
(Pack
) = E_Package
9869 and then not Is_Frozen
(Pack
)
9870 and then not Scope_Within_Or_Same
(Current_Scope
, Pack
)
9871 and then In_Open_Scopes
(Scope
(Pack
));
9872 end From_Nested_Package
;
9874 -----------------------
9875 -- Gather_Components --
9876 -----------------------
9878 procedure Gather_Components
9880 Comp_List
: Node_Id
;
9881 Governed_By
: List_Id
;
9883 Report_Errors
: out Boolean;
9884 Allow_Compile_Time
: Boolean := False;
9885 Include_Interface_Tag
: Boolean := False)
9889 Discrete_Choice
: Node_Id
;
9890 Comp_Item
: Node_Id
;
9891 Discrim
: Entity_Id
;
9892 Discrim_Name
: Node_Id
;
9894 type Discriminant_Value_Status
is
9895 (Static_Expr
, Static_Subtype
, Bad
);
9896 subtype Good_Discrim_Value_Status
is Discriminant_Value_Status
9897 range Static_Expr
.. Static_Subtype
; -- range excludes Bad
9899 Discrim_Value
: Node_Id
;
9900 Discrim_Value_Subtype
: Node_Id
;
9901 Discrim_Value_Status
: Discriminant_Value_Status
:= Bad
;
9903 Report_Errors
:= False;
9905 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
9908 elsif Present
(Component_Items
(Comp_List
)) then
9909 Comp_Item
:= First
(Component_Items
(Comp_List
));
9915 while Present
(Comp_Item
) loop
9917 -- Skip the tag of a tagged record, as well as all items that are not
9918 -- user components (anonymous types, rep clauses, Parent field,
9919 -- controller field).
9921 if Nkind
(Comp_Item
) = N_Component_Declaration
then
9923 Comp
: constant Entity_Id
:= Defining_Identifier
(Comp_Item
);
9925 if not (Is_Tag
(Comp
)
9927 (Include_Interface_Tag
9928 and then Etype
(Comp
) = RTE
(RE_Interface_Tag
)))
9929 and then Chars
(Comp
) /= Name_uParent
9931 Append_Elmt
(Comp
, Into
);
9939 if No
(Variant_Part
(Comp_List
)) then
9942 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
9943 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
9946 -- Look for the discriminant that governs this variant part.
9947 -- The discriminant *must* be in the Governed_By List
9949 Assoc
:= First
(Governed_By
);
9950 Find_Constraint
: loop
9951 Discrim
:= First
(Choices
(Assoc
));
9952 exit Find_Constraint
when
9953 Chars
(Discrim_Name
) = Chars
(Discrim
)
9955 (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
9956 and then Chars
(Corresponding_Discriminant
9957 (Entity
(Discrim
))) = Chars
(Discrim_Name
))
9959 Chars
(Original_Record_Component
(Entity
(Discrim
))) =
9960 Chars
(Discrim_Name
);
9962 if No
(Next
(Assoc
)) then
9963 if not Is_Constrained
(Typ
) and then Is_Derived_Type
(Typ
) then
9965 -- If the type is a tagged type with inherited discriminants,
9966 -- use the stored constraint on the parent in order to find
9967 -- the values of discriminants that are otherwise hidden by an
9968 -- explicit constraint. Renamed discriminants are handled in
9971 -- If several parent discriminants are renamed by a single
9972 -- discriminant of the derived type, the call to obtain the
9973 -- Corresponding_Discriminant field only retrieves the last
9974 -- of them. We recover the constraint on the others from the
9975 -- Stored_Constraint as well.
9977 -- An inherited discriminant may have been constrained in a
9978 -- later ancestor (not the immediate parent) so we must examine
9979 -- the stored constraint of all of them to locate the inherited
9985 T
: Entity_Id
:= Typ
;
9988 while Is_Derived_Type
(T
) loop
9989 if Present
(Stored_Constraint
(T
)) then
9990 D
:= First_Discriminant
(Etype
(T
));
9991 C
:= First_Elmt
(Stored_Constraint
(T
));
9992 while Present
(D
) and then Present
(C
) loop
9993 if Chars
(Discrim_Name
) = Chars
(D
) then
9994 if Is_Entity_Name
(Node
(C
))
9995 and then Entity
(Node
(C
)) = Entity
(Discrim
)
9997 -- D is renamed by Discrim, whose value is
10004 Make_Component_Association
(Sloc
(Typ
),
10006 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
10007 Duplicate_Subexpr_No_Checks
(Node
(C
)));
10010 exit Find_Constraint
;
10013 Next_Discriminant
(D
);
10018 -- Discriminant may be inherited from ancestor
10026 if No
(Next
(Assoc
)) then
10028 (" missing value for discriminant&",
10029 First
(Governed_By
), Discrim_Name
);
10031 Report_Errors
:= True;
10036 end loop Find_Constraint
;
10038 Discrim_Value
:= Expression
(Assoc
);
10040 if Is_OK_Static_Expression
(Discrim_Value
)
10041 or else (Allow_Compile_Time
10042 and then Compile_Time_Known_Value
(Discrim_Value
))
10044 Discrim_Value_Status
:= Static_Expr
;
10046 if Ada_Version
>= Ada_2020
then
10047 if Original_Node
(Discrim_Value
) /= Discrim_Value
10048 and then Nkind
(Discrim_Value
) = N_Type_Conversion
10049 and then Etype
(Original_Node
(Discrim_Value
))
10050 = Etype
(Expression
(Discrim_Value
))
10052 Discrim_Value_Subtype
:= Etype
(Original_Node
(Discrim_Value
));
10053 -- An unhelpful (for this code) type conversion may be
10054 -- introduced in some cases; deal with it.
10056 Discrim_Value_Subtype
:= Etype
(Discrim_Value
);
10059 if Is_OK_Static_Subtype
(Discrim_Value_Subtype
) and then
10060 not Is_Null_Range
(Type_Low_Bound
(Discrim_Value_Subtype
),
10061 Type_High_Bound
(Discrim_Value_Subtype
))
10063 -- Is_Null_Range test doesn't account for predicates, as in
10064 -- subtype Null_By_Predicate is Natural
10065 -- with Static_Predicate => Null_By_Predicate < 0;
10066 -- so test for that null case separately.
10068 if (not Has_Static_Predicate
(Discrim_Value_Subtype
))
10069 or else Present
(First
(Static_Discrete_Predicate
10070 (Discrim_Value_Subtype
)))
10072 Discrim_Value_Status
:= Static_Subtype
;
10077 if Discrim_Value_Status
= Bad
then
10079 -- If the variant part is governed by a discriminant of the type
10080 -- this is an error. If the variant part and the discriminant are
10081 -- inherited from an ancestor this is legal (AI05-220) unless the
10082 -- components are being gathered for an aggregate, in which case
10083 -- the caller must check Report_Errors.
10085 -- In Ada 2020 the above rules are relaxed. A nonstatic governing
10086 -- discriminant is OK as long as it has a static subtype and
10087 -- every value of that subtype (and there must be at least one)
10088 -- selects the same variant.
10090 if Scope
(Original_Record_Component
10091 ((Entity
(First
(Choices
(Assoc
)))))) = Typ
10093 if Ada_Version
>= Ada_2020
then
10095 ("value for discriminant & must be static or " &
10096 "discriminant's nominal subtype must be static " &
10098 Discrim_Value
, Discrim
);
10101 ("value for discriminant & must be static!",
10102 Discrim_Value
, Discrim
);
10104 Why_Not_Static
(Discrim_Value
);
10107 Report_Errors
:= True;
10112 Search_For_Discriminant_Value
: declare
10118 UI_Discrim_Value
: Uint
;
10121 case Good_Discrim_Value_Status
'(Discrim_Value_Status) is
10122 when Static_Expr =>
10123 UI_Discrim_Value := Expr_Value (Discrim_Value);
10124 when Static_Subtype =>
10125 -- Arbitrarily pick one value of the subtype and look
10126 -- for the variant associated with that value; we will
10127 -- check later that the same variant is associated with
10128 -- all of the other values of the subtype.
10129 if Has_Static_Predicate (Discrim_Value_Subtype) then
10131 Range_Or_Expr : constant Node_Id :=
10132 First (Static_Discrete_Predicate
10133 (Discrim_Value_Subtype));
10135 if Nkind (Range_Or_Expr) = N_Range then
10136 UI_Discrim_Value :=
10137 Expr_Value (Low_Bound (Range_Or_Expr));
10139 UI_Discrim_Value := Expr_Value (Range_Or_Expr);
10144 := Expr_Value (Type_Low_Bound (Discrim_Value_Subtype));
10148 Find_Discrete_Value : while Present (Variant) loop
10150 -- If a choice is a subtype with a static predicate, it must
10151 -- be rewritten as an explicit list of non-predicated choices.
10153 Expand_Static_Predicates_In_Choices (Variant);
10155 Discrete_Choice := First (Discrete_Choices (Variant));
10156 while Present (Discrete_Choice) loop
10157 exit Find_Discrete_Value when
10158 Nkind (Discrete_Choice) = N_Others_Choice;
10160 Get_Index_Bounds (Discrete_Choice, Low, High);
10162 UI_Low := Expr_Value (Low);
10163 UI_High := Expr_Value (High);
10165 exit Find_Discrete_Value when
10166 UI_Low <= UI_Discrim_Value
10168 UI_High >= UI_Discrim_Value;
10170 Next (Discrete_Choice);
10173 Next_Non_Pragma (Variant);
10174 end loop Find_Discrete_Value;
10175 end Search_For_Discriminant_Value;
10177 -- The case statement must include a variant that corresponds to the
10178 -- value of the discriminant, unless the discriminant type has a
10179 -- static predicate. In that case the absence of an others_choice that
10180 -- would cover this value becomes a run-time error (3.8.1 (21.1/2)).
10183 and then not Has_Static_Predicate (Etype (Discrim_Name))
10186 ("value of discriminant & is out of range", Discrim_Value, Discrim);
10187 Report_Errors := True;
10191 -- If we have found the corresponding choice, recursively add its
10192 -- components to the Into list. The nested components are part of
10193 -- the same record type.
10195 if Present (Variant) then
10196 if Discrim_Value_Status = Static_Subtype then
10198 Discrim_Value_Subtype_Intervals
10199 : constant Interval_Lists.Discrete_Interval_List
10200 := Interval_Lists.Type_Intervals (Discrim_Value_Subtype);
10203 : constant Interval_Lists.Discrete_Interval_List
10204 := Interval_Lists.Choice_List_Intervals
10205 (Discrete_Choices => Discrete_Choices (Variant));
10207 if not Interval_Lists.Is_Subset
10208 (Subset => Discrim_Value_Subtype_Intervals,
10209 Of_Set => Variant_Intervals)
10212 ("no single variant is associated with all values of " &
10213 "the subtype of discriminant value &",
10214 Discrim_Value, Discrim);
10215 Report_Errors := True;
10222 (Typ, Component_List (Variant), Governed_By, Into,
10223 Report_Errors, Allow_Compile_Time);
10225 end Gather_Components;
10227 -------------------------------
10228 -- Get_Dynamic_Accessibility --
10229 -------------------------------
10231 function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id is
10233 -- When minimum accessibility is set for E then we utilize it - except
10234 -- in a few edge cases like the expansion of select statements where
10235 -- generated subprogram may attempt to unnecessarily use a minimum
10236 -- accessibility object declared outside of scope.
10238 -- To avoid these situations where expansion may get complex we verify
10239 -- that the minimum accessibility object is within scope.
10242 and then Present (Minimum_Accessibility (E))
10243 and then In_Open_Scopes (Scope (Minimum_Accessibility (E)))
10245 return Minimum_Accessibility (E);
10248 return Extra_Accessibility (E);
10249 end Get_Dynamic_Accessibility;
10251 ------------------------
10252 -- Get_Actual_Subtype --
10253 ------------------------
10255 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
10256 Typ : constant Entity_Id := Etype (N);
10257 Utyp : Entity_Id := Underlying_Type (Typ);
10266 -- If what we have is an identifier that references a subprogram
10267 -- formal, or a variable or constant object, then we get the actual
10268 -- subtype from the referenced entity if one has been built.
10270 if Nkind (N) = N_Identifier
10272 (Is_Formal (Entity (N))
10273 or else Ekind (Entity (N)) = E_Constant
10274 or else Ekind (Entity (N)) = E_Variable)
10275 and then Present (Actual_Subtype (Entity (N)))
10277 return Actual_Subtype (Entity (N));
10279 -- Actual subtype of unchecked union is always itself. We never need
10280 -- the "real" actual subtype. If we did, we couldn't get it anyway
10281 -- because the discriminant is not available. The restrictions on
10282 -- Unchecked_Union are designed to make sure that this is OK.
10284 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
10287 -- Here for the unconstrained case, we must find actual subtype
10288 -- No actual subtype is available, so we must build it on the fly.
10290 -- Checking the type, not the underlying type, for constrainedness
10291 -- seems to be necessary. Maybe all the tests should be on the type???
10293 elsif (not Is_Constrained (Typ))
10294 and then (Is_Array_Type (Utyp)
10295 or else (Is_Record_Type (Utyp)
10296 and then Has_Discriminants (Utyp)))
10297 and then not Has_Unknown_Discriminants (Utyp)
10298 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
10300 -- Nothing to do if in spec expression (why not???)
10302 if In_Spec_Expression then
10305 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then
10307 -- If the type has no discriminants, there is no subtype to
10308 -- build, even if the underlying type is discriminated.
10312 -- Else build the actual subtype
10315 Decl := Build_Actual_Subtype (Typ, N);
10317 -- The call may yield a declaration, or just return the entity
10323 Atyp := Defining_Identifier (Decl);
10325 -- If Build_Actual_Subtype generated a new declaration then use it
10327 if Atyp /= Typ then
10329 -- The actual subtype is an Itype, so analyze the declaration,
10330 -- but do not attach it to the tree, to get the type defined.
10332 Set_Parent (Decl, N);
10333 Set_Is_Itype (Atyp);
10334 Analyze (Decl, Suppress => All_Checks);
10335 Set_Associated_Node_For_Itype (Atyp, N);
10336 Set_Has_Delayed_Freeze (Atyp, False);
10338 -- We need to freeze the actual subtype immediately. This is
10339 -- needed, because otherwise this Itype will not get frozen
10340 -- at all, and it is always safe to freeze on creation because
10341 -- any associated types must be frozen at this point.
10343 Freeze_Itype (Atyp, N);
10346 -- Otherwise we did not build a declaration, so return original
10353 -- For all remaining cases, the actual subtype is the same as
10354 -- the nominal type.
10359 end Get_Actual_Subtype;
10361 -------------------------------------
10362 -- Get_Actual_Subtype_If_Available --
10363 -------------------------------------
10365 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
10366 Typ : constant Entity_Id := Etype (N);
10369 -- If what we have is an identifier that references a subprogram
10370 -- formal, or a variable or constant object, then we get the actual
10371 -- subtype from the referenced entity if one has been built.
10373 if Nkind (N) = N_Identifier
10375 (Is_Formal (Entity (N))
10376 or else Ekind (Entity (N)) = E_Constant
10377 or else Ekind (Entity (N)) = E_Variable)
10378 and then Present (Actual_Subtype (Entity (N)))
10380 return Actual_Subtype (Entity (N));
10382 -- Otherwise the Etype of N is returned unchanged
10387 end Get_Actual_Subtype_If_Available;
10389 ------------------------
10390 -- Get_Body_From_Stub --
10391 ------------------------
10393 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
10395 return Proper_Body (Unit (Library_Unit (N)));
10396 end Get_Body_From_Stub;
10398 ---------------------
10399 -- Get_Cursor_Type --
10400 ---------------------
10402 function Get_Cursor_Type
10404 Typ : Entity_Id) return Entity_Id
10408 First_Op : Entity_Id;
10409 Cursor : Entity_Id;
10412 -- If error already detected, return
10414 if Error_Posted (Aspect) then
10418 -- The cursor type for an Iterable aspect is the return type of a
10419 -- non-overloaded First primitive operation. Locate association for
10422 Assoc := First (Component_Associations (Expression (Aspect)));
10423 First_Op := Any_Id;
10424 while Present (Assoc) loop
10425 if Chars (First (Choices (Assoc))) = Name_First then
10426 First_Op := Expression (Assoc);
10433 if First_Op = Any_Id then
10434 Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
10437 elsif not Analyzed (First_Op) then
10438 Analyze (First_Op);
10441 Cursor := Any_Type;
10443 -- Locate function with desired name and profile in scope of type
10444 -- In the rare case where the type is an integer type, a base type
10445 -- is created for it, check that the base type of the first formal
10446 -- of First matches the base type of the domain.
10448 Func := First_Entity (Scope (Typ));
10449 while Present (Func) loop
10450 if Chars (Func) = Chars (First_Op)
10451 and then Ekind (Func) = E_Function
10452 and then Present (First_Formal (Func))
10453 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ)
10454 and then No (Next_Formal (First_Formal (Func)))
10456 if Cursor /= Any_Type then
10458 ("operation First for iterable type must be unique", Aspect);
10461 Cursor := Etype (Func);
10465 Next_Entity (Func);
10468 -- If not found, no way to resolve remaining primitives
10470 if Cursor = Any_Type then
10472 ("primitive operation for Iterable type must appear in the same "
10473 & "list of declarations as the type", Aspect);
10477 end Get_Cursor_Type;
10479 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is
10481 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First));
10482 end Get_Cursor_Type;
10484 -------------------------------
10485 -- Get_Default_External_Name --
10486 -------------------------------
10488 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
10490 Get_Decoded_Name_String (Chars (E));
10492 if Opt.External_Name_Imp_Casing = Uppercase then
10493 Set_Casing (All_Upper_Case);
10495 Set_Casing (All_Lower_Case);
10499 Make_String_Literal (Sloc (E),
10500 Strval => String_From_Name_Buffer);
10501 end Get_Default_External_Name;
10503 --------------------------
10504 -- Get_Enclosing_Object --
10505 --------------------------
10507 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
10509 if Is_Entity_Name (N) then
10513 when N_Indexed_Component
10514 | N_Selected_Component
10517 -- If not generating code, a dereference may be left implicit.
10518 -- In thoses cases, return Empty.
10520 if Is_Access_Type (Etype (Prefix (N))) then
10523 return Get_Enclosing_Object (Prefix (N));
10526 when N_Type_Conversion =>
10527 return Get_Enclosing_Object (Expression (N));
10533 end Get_Enclosing_Object;
10535 ---------------------------
10536 -- Get_Enum_Lit_From_Pos --
10537 ---------------------------
10539 function Get_Enum_Lit_From_Pos
10542 Loc : Source_Ptr) return Node_Id
10544 Btyp : Entity_Id := Base_Type (T);
10549 -- In the case where the literal is of type Character, Wide_Character
10550 -- or Wide_Wide_Character or of a type derived from them, there needs
10551 -- to be some special handling since there is no explicit chain of
10552 -- literals to search. Instead, an N_Character_Literal node is created
10553 -- with the appropriate Char_Code and Chars fields.
10555 if Is_Standard_Character_Type (T) then
10556 Set_Character_Literal_Name (UI_To_CC (Pos));
10559 Make_Character_Literal (Loc,
10560 Chars => Name_Find,
10561 Char_Literal_Value => Pos);
10563 -- For all other cases, we have a complete table of literals, and
10564 -- we simply iterate through the chain of literal until the one
10565 -- with the desired position value is found.
10568 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
10569 Btyp := Full_View (Btyp);
10572 Lit := First_Literal (Btyp);
10574 -- Position in the enumeration type starts at 0
10577 raise Constraint_Error;
10580 for J in 1 .. UI_To_Int (Pos) loop
10581 Next_Literal (Lit);
10583 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error
10584 -- inside the loop to avoid calling Next_Literal on Empty.
10587 raise Constraint_Error;
10591 -- Create a new node from Lit, with source location provided by Loc
10592 -- if not equal to No_Location, or by copying the source location of
10597 if LLoc = No_Location then
10598 LLoc := Sloc (Lit);
10601 return New_Occurrence_Of (Lit, LLoc);
10603 end Get_Enum_Lit_From_Pos;
10605 ----------------------
10606 -- Get_Fullest_View --
10607 ----------------------
10609 function Get_Fullest_View
10610 (E : Entity_Id; Include_PAT : Boolean := True) return Entity_Id is
10612 -- Prevent cascaded errors
10618 -- Strictly speaking, the recursion below isn't necessary, but
10619 -- it's both simplest and safest.
10622 when Incomplete_Kind =>
10623 if From_Limited_With (E) then
10624 return Get_Fullest_View (Non_Limited_View (E), Include_PAT);
10625 elsif Present (Full_View (E)) then
10626 return Get_Fullest_View (Full_View (E), Include_PAT);
10627 elsif Ekind (E) = E_Incomplete_Subtype then
10628 return Get_Fullest_View (Etype (E));
10631 when Private_Kind =>
10632 if Present (Underlying_Full_View (E)) then
10634 Get_Fullest_View (Underlying_Full_View (E), Include_PAT);
10635 elsif Present (Full_View (E)) then
10636 return Get_Fullest_View (Full_View (E), Include_PAT);
10637 elsif Etype (E) /= E then
10638 return Get_Fullest_View (Etype (E), Include_PAT);
10642 if Include_PAT and then Present (Packed_Array_Impl_Type (E)) then
10643 return Get_Fullest_View (Packed_Array_Impl_Type (E));
10646 when E_Record_Subtype =>
10647 if Present (Cloned_Subtype (E)) then
10648 return Get_Fullest_View (Cloned_Subtype (E), Include_PAT);
10651 when E_Class_Wide_Type =>
10652 return Get_Fullest_View (Root_Type (E), Include_PAT);
10654 when E_Class_Wide_Subtype =>
10655 if Present (Equivalent_Type (E)) then
10656 return Get_Fullest_View (Equivalent_Type (E), Include_PAT);
10657 elsif Present (Cloned_Subtype (E)) then
10658 return Get_Fullest_View (Cloned_Subtype (E), Include_PAT);
10661 when E_Protected_Type | E_Protected_Subtype
10662 | E_Task_Type | E_Task_Subtype =>
10663 if Present (Corresponding_Record_Type (E)) then
10664 return Get_Fullest_View (Corresponding_Record_Type (E),
10668 when E_Access_Protected_Subprogram_Type
10669 | E_Anonymous_Access_Protected_Subprogram_Type =>
10670 if Present (Equivalent_Type (E)) then
10671 return Get_Fullest_View (Equivalent_Type (E), Include_PAT);
10674 when E_Access_Subtype =>
10675 return Get_Fullest_View (Base_Type (E), Include_PAT);
10682 end Get_Fullest_View;
10684 ------------------------
10685 -- Get_Generic_Entity --
10686 ------------------------
10688 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
10689 Ent : constant Entity_Id := Entity (Name (N));
10691 if Present (Renamed_Object (Ent)) then
10692 return Renamed_Object (Ent);
10696 end Get_Generic_Entity;
10698 -------------------------------------
10699 -- Get_Incomplete_View_Of_Ancestor --
10700 -------------------------------------
10702 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
10703 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
10704 Par_Scope : Entity_Id;
10705 Par_Type : Entity_Id;
10708 -- The incomplete view of an ancestor is only relevant for private
10709 -- derived types in child units.
10711 if not Is_Derived_Type (E)
10712 or else not Is_Child_Unit (Cur_Unit)
10717 Par_Scope := Scope (Cur_Unit);
10718 if No (Par_Scope) then
10722 Par_Type := Etype (Base_Type (E));
10724 -- Traverse list of ancestor types until we find one declared in
10725 -- a parent or grandparent unit (two levels seem sufficient).
10727 while Present (Par_Type) loop
10728 if Scope (Par_Type) = Par_Scope
10729 or else Scope (Par_Type) = Scope (Par_Scope)
10733 elsif not Is_Derived_Type (Par_Type) then
10737 Par_Type := Etype (Base_Type (Par_Type));
10741 -- If none found, there is no relevant ancestor type.
10745 end Get_Incomplete_View_Of_Ancestor;
10747 ----------------------
10748 -- Get_Index_Bounds --
10749 ----------------------
10751 procedure Get_Index_Bounds
10755 Use_Full_View : Boolean := False)
10757 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id;
10758 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and
10759 -- Typ qualifies, the scalar range is obtained from the full view of the
10762 --------------------------
10763 -- Scalar_Range_Of_Type --
10764 --------------------------
10766 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is
10767 T : Entity_Id := Typ;
10770 if Use_Full_View and then Present (Full_View (T)) then
10771 T := Full_View (T);
10774 return Scalar_Range (T);
10775 end Scalar_Range_Of_Type;
10779 Kind : constant Node_Kind := Nkind (N);
10782 -- Start of processing for Get_Index_Bounds
10785 if Kind = N_Range then
10786 L := Low_Bound (N);
10787 H := High_Bound (N);
10789 elsif Kind = N_Subtype_Indication then
10790 Rng := Range_Expression (Constraint (N));
10792 if Rng = Error then
10798 L := Low_Bound (Range_Expression (Constraint (N)));
10799 H := High_Bound (Range_Expression (Constraint (N)));
10802 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
10803 Rng := Scalar_Range_Of_Type (Entity (N));
10805 if Error_Posted (Rng) then
10809 elsif Nkind (Rng) = N_Subtype_Indication then
10810 Get_Index_Bounds (Rng, L, H);
10813 L := Low_Bound (Rng);
10814 H := High_Bound (Rng);
10818 -- N is an expression, indicating a range with one value
10823 end Get_Index_Bounds;
10825 -----------------------------
10826 -- Get_Interfacing_Aspects --
10827 -----------------------------
10829 procedure Get_Interfacing_Aspects
10830 (Iface_Asp : Node_Id;
10831 Conv_Asp : out Node_Id;
10832 EN_Asp : out Node_Id;
10833 Expo_Asp : out Node_Id;
10834 Imp_Asp : out Node_Id;
10835 LN_Asp : out Node_Id;
10836 Do_Checks : Boolean := False)
10838 procedure Save_Or_Duplication_Error
10840 To : in out Node_Id);
10841 -- Save the value of aspect Asp in node To. If To already has a value,
10842 -- then this is considered a duplicate use of aspect. Emit an error if
10843 -- flag Do_Checks is set.
10845 -------------------------------
10846 -- Save_Or_Duplication_Error --
10847 -------------------------------
10849 procedure Save_Or_Duplication_Error
10851 To : in out Node_Id)
10854 -- Detect an extra aspect and issue an error
10856 if Present (To) then
10858 Error_Msg_Name_1 := Chars (Identifier (Asp));
10859 Error_Msg_Sloc := Sloc (To);
10860 Error_Msg_N ("aspect % previously given #", Asp);
10863 -- Otherwise capture the aspect
10868 end Save_Or_Duplication_Error;
10873 Asp_Id : Aspect_Id;
10875 -- The following variables capture each individual aspect
10877 Conv : Node_Id := Empty;
10878 EN : Node_Id := Empty;
10879 Expo : Node_Id := Empty;
10880 Imp : Node_Id := Empty;
10881 LN : Node_Id := Empty;
10883 -- Start of processing for Get_Interfacing_Aspects
10886 -- The input interfacing aspect should reside in an aspect specification
10889 pragma Assert (Is_List_Member (Iface_Asp));
10891 -- Examine the aspect specifications of the related entity. Find and
10892 -- capture all interfacing aspects. Detect duplicates and emit errors
10895 Asp := First (List_Containing (Iface_Asp));
10896 while Present (Asp) loop
10897 Asp_Id := Get_Aspect_Id (Asp);
10899 if Asp_Id = Aspect_Convention then
10900 Save_Or_Duplication_Error (Asp, Conv);
10902 elsif Asp_Id = Aspect_External_Name then
10903 Save_Or_Duplication_Error (Asp, EN);
10905 elsif Asp_Id = Aspect_Export then
10906 Save_Or_Duplication_Error (Asp, Expo);
10908 elsif Asp_Id = Aspect_Import then
10909 Save_Or_Duplication_Error (Asp, Imp);
10911 elsif Asp_Id = Aspect_Link_Name then
10912 Save_Or_Duplication_Error (Asp, LN);
10923 end Get_Interfacing_Aspects;
10925 ---------------------------------
10926 -- Get_Iterable_Type_Primitive --
10927 ---------------------------------
10929 function Get_Iterable_Type_Primitive
10931 Nam : Name_Id) return Entity_Id
10936 Nam in Name_Element
10943 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
10951 Assoc := First (Component_Associations (Funcs));
10952 while Present (Assoc) loop
10953 if Chars (First (Choices (Assoc))) = Nam then
10954 return Entity (Expression (Assoc));
10962 end Get_Iterable_Type_Primitive;
10964 ----------------------------------
10965 -- Get_Library_Unit_Name_String --
10966 ----------------------------------
10968 procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is
10969 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
10972 Get_Unit_Name_String (Unit_Name_Id);
10974 -- Remove seven last character (" (spec)" or " (body)")
10976 Name_Len := Name_Len - 7;
10977 pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
10978 end Get_Library_Unit_Name_String;
10980 --------------------------
10981 -- Get_Max_Queue_Length --
10982 --------------------------
10984 function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
10985 pragma Assert (Is_Entry (Id));
10986 Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
10990 -- A value of 0 or -1 represents no maximum specified, and entries and
10991 -- entry families with no Max_Queue_Length aspect or pragma default to
10994 if not Present (Prag) then
10999 (Expression (First (Pragma_Argument_Associations (Prag))));
11001 -- Since -1 and 0 are equivalent, return 0 for instances of -1 for
11009 end Get_Max_Queue_Length;
11011 ------------------------
11012 -- Get_Name_Entity_Id --
11013 ------------------------
11015 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
11017 return Entity_Id (Get_Name_Table_Int (Id));
11018 end Get_Name_Entity_Id;
11020 ------------------------------
11021 -- Get_Name_From_CTC_Pragma --
11022 ------------------------------
11024 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
11025 Arg : constant Node_Id :=
11026 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
11028 return Strval (Expr_Value_S (Arg));
11029 end Get_Name_From_CTC_Pragma;
11031 -----------------------
11032 -- Get_Parent_Entity --
11033 -----------------------
11035 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
11037 if Nkind (Unit) = N_Package_Body
11038 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
11040 return Defining_Entity
11041 (Specification (Instance_Spec (Original_Node (Unit))));
11042 elsif Nkind (Unit) = N_Package_Instantiation then
11043 return Defining_Entity (Specification (Instance_Spec (Unit)));
11045 return Defining_Entity (Unit);
11047 end Get_Parent_Entity;
11049 -------------------
11050 -- Get_Pragma_Id --
11051 -------------------
11053 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
11055 return Get_Pragma_Id (Pragma_Name_Unmapped (N));
11058 ------------------------
11059 -- Get_Qualified_Name --
11060 ------------------------
11062 function Get_Qualified_Name
11064 Suffix : Entity_Id := Empty) return Name_Id
11066 Suffix_Nam : Name_Id := No_Name;
11069 if Present (Suffix) then
11070 Suffix_Nam := Chars (Suffix);
11073 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id));
11074 end Get_Qualified_Name;
11076 function Get_Qualified_Name
11078 Suffix : Name_Id := No_Name;
11079 Scop : Entity_Id := Current_Scope) return Name_Id
11081 procedure Add_Scope (S : Entity_Id);
11082 -- Add the fully qualified form of scope S to the name buffer. The
11090 procedure Add_Scope (S : Entity_Id) is
11095 elsif S = Standard_Standard then
11099 Add_Scope (Scope (S));
11100 Get_Name_String_And_Append (Chars (S));
11101 Add_Str_To_Name_Buffer ("__");
11105 -- Start of processing for Get_Qualified_Name
11111 -- Append the base name after all scopes have been chained
11113 Get_Name_String_And_Append (Nam);
11115 -- Append the suffix (if present)
11117 if Suffix /= No_Name then
11118 Add_Str_To_Name_Buffer ("__");
11119 Get_Name_String_And_Append (Suffix);
11123 end Get_Qualified_Name;
11125 -----------------------
11126 -- Get_Reason_String --
11127 -----------------------
11129 procedure Get_Reason_String (N : Node_Id) is
11131 if Nkind (N) = N_String_Literal then
11132 Store_String_Chars (Strval (N));
11134 elsif Nkind (N) = N_Op_Concat then
11135 Get_Reason_String (Left_Opnd (N));
11136 Get_Reason_String (Right_Opnd (N));
11138 -- If not of required form, error
11142 ("Reason for pragma Warnings has wrong form", N);
11144 ("\must be string literal or concatenation of string literals", N);
11147 end Get_Reason_String;
11149 --------------------------------
11150 -- Get_Reference_Discriminant --
11151 --------------------------------
11153 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is
11157 D := First_Discriminant (Typ);
11158 while Present (D) loop
11159 if Has_Implicit_Dereference (D) then
11162 Next_Discriminant (D);
11166 end Get_Reference_Discriminant;
11168 ---------------------------
11169 -- Get_Referenced_Object --
11170 ---------------------------
11172 function Get_Referenced_Object (N : Node_Id) return Node_Id is
11177 while Is_Entity_Name (R)
11178 and then Is_Object (Entity (R))
11179 and then Present (Renamed_Object (Entity (R)))
11181 R := Renamed_Object (Entity (R));
11185 end Get_Referenced_Object;
11187 ------------------------
11188 -- Get_Renamed_Entity --
11189 ------------------------
11191 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
11196 while Present (Renamed_Entity (R)) loop
11197 R := Renamed_Entity (R);
11201 end Get_Renamed_Entity;
11203 -----------------------
11204 -- Get_Return_Object --
11205 -----------------------
11207 function Get_Return_Object (N : Node_Id) return Entity_Id is
11211 Decl := First (Return_Object_Declarations (N));
11212 while Present (Decl) loop
11213 exit when Nkind (Decl) = N_Object_Declaration
11214 and then Is_Return_Object (Defining_Identifier (Decl));
11218 pragma Assert (Present (Decl));
11219 return Defining_Identifier (Decl);
11220 end Get_Return_Object;
11222 ---------------------------
11223 -- Get_Subprogram_Entity --
11224 ---------------------------
11226 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
11228 Subp_Id : Entity_Id;
11231 if Nkind (Nod) = N_Accept_Statement then
11232 Subp := Entry_Direct_Name (Nod);
11234 elsif Nkind (Nod) = N_Slice then
11235 Subp := Prefix (Nod);
11238 Subp := Name (Nod);
11241 -- Strip the subprogram call
11244 if Nkind (Subp) in N_Explicit_Dereference
11245 | N_Indexed_Component
11246 | N_Selected_Component
11248 Subp := Prefix (Subp);
11250 elsif Nkind (Subp) in N_Type_Conversion
11251 | N_Unchecked_Type_Conversion
11253 Subp := Expression (Subp);
11260 -- Extract the entity of the subprogram call
11262 if Is_Entity_Name (Subp) then
11263 Subp_Id := Entity (Subp);
11265 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
11266 Subp_Id := Directly_Designated_Type (Subp_Id);
11269 if Is_Subprogram (Subp_Id) then
11275 -- The search did not find a construct that denotes a subprogram
11280 end Get_Subprogram_Entity;
11282 -----------------------------
11283 -- Get_Task_Body_Procedure --
11284 -----------------------------
11286 function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is
11288 -- Note: A task type may be the completion of a private type with
11289 -- discriminants. When performing elaboration checks on a task
11290 -- declaration, the current view of the type may be the private one,
11291 -- and the procedure that holds the body of the task is held in its
11292 -- underlying type.
11294 -- This is an odd function, why not have Task_Body_Procedure do
11295 -- the following digging???
11297 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
11298 end Get_Task_Body_Procedure;
11300 -------------------------
11301 -- Get_User_Defined_Eq --
11302 -------------------------
11304 function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is
11309 Prim := First_Elmt (Collect_Primitive_Operations (E));
11310 while Present (Prim) loop
11313 if Chars (Op) = Name_Op_Eq
11314 and then Etype (Op) = Standard_Boolean
11315 and then Etype (First_Formal (Op)) = E
11316 and then Etype (Next_Formal (First_Formal (Op))) = E
11325 end Get_User_Defined_Eq;
11331 procedure Get_Views
11333 Priv_Typ : out Entity_Id;
11334 Full_Typ : out Entity_Id;
11335 UFull_Typ : out Entity_Id;
11336 CRec_Typ : out Entity_Id)
11338 IP_View : Entity_Id;
11341 -- Assume that none of the views can be recovered
11345 UFull_Typ := Empty;
11348 -- The input type is the corresponding record type of a protected or a
11351 if Ekind (Typ) = E_Record_Type
11352 and then Is_Concurrent_Record_Type (Typ)
11355 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
11356 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
11358 -- Otherwise the input type denotes an arbitrary type
11361 IP_View := Incomplete_Or_Partial_View (Typ);
11363 -- The input type denotes the full view of a private type
11365 if Present (IP_View) then
11366 Priv_Typ := IP_View;
11369 -- The input type is a private type
11371 elsif Is_Private_Type (Typ) then
11373 Full_Typ := Full_View (Priv_Typ);
11375 -- Otherwise the input type does not have any views
11381 if Present (Full_Typ) and then Is_Private_Type (Full_Typ) then
11382 UFull_Typ := Underlying_Full_View (Full_Typ);
11384 if Present (UFull_Typ)
11385 and then Ekind (UFull_Typ) in E_Protected_Type | E_Task_Type
11387 CRec_Typ := Corresponding_Record_Type (UFull_Typ);
11391 if Present (Full_Typ)
11392 and then Ekind (Full_Typ) in E_Protected_Type | E_Task_Type
11394 CRec_Typ := Corresponding_Record_Type (Full_Typ);
11400 -----------------------
11401 -- Has_Access_Values --
11402 -----------------------
11404 function Has_Access_Values (T : Entity_Id) return Boolean is
11405 Typ : constant Entity_Id := Underlying_Type (T);
11408 -- Case of a private type which is not completed yet. This can only
11409 -- happen in the case of a generic format type appearing directly, or
11410 -- as a component of the type to which this function is being applied
11411 -- at the top level. Return False in this case, since we certainly do
11412 -- not know that the type contains access types.
11417 elsif Is_Access_Type (Typ) then
11420 elsif Is_Array_Type (Typ) then
11421 return Has_Access_Values (Component_Type (Typ));
11423 elsif Is_Record_Type (Typ) then
11428 -- Loop to check components
11430 Comp := First_Component_Or_Discriminant (Typ);
11431 while Present (Comp) loop
11433 -- Check for access component, tag field does not count, even
11434 -- though it is implemented internally using an access type.
11436 if Has_Access_Values (Etype (Comp))
11437 and then Chars (Comp) /= Name_uTag
11442 Next_Component_Or_Discriminant (Comp);
11451 end Has_Access_Values;
11453 ---------------------------------------
11454 -- Has_Anonymous_Access_Discriminant --
11455 ---------------------------------------
11457 function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean
11462 if not Has_Discriminants (Typ) then
11466 Disc := First_Discriminant (Typ);
11467 while Present (Disc) loop
11468 if Ekind (Etype (Disc)) = E_Anonymous_Access_Type then
11472 Next_Discriminant (Disc);
11476 end Has_Anonymous_Access_Discriminant;
11478 ------------------------------
11479 -- Has_Compatible_Alignment --
11480 ------------------------------
11482 function Has_Compatible_Alignment
11485 Layout_Done : Boolean) return Alignment_Result
11487 function Has_Compatible_Alignment_Internal
11490 Layout_Done : Boolean;
11491 Default : Alignment_Result) return Alignment_Result;
11492 -- This is the internal recursive function that actually does the work.
11493 -- There is one additional parameter, which says what the result should
11494 -- be if no alignment information is found, and there is no definite
11495 -- indication of compatible alignments. At the outer level, this is set
11496 -- to Unknown, but for internal recursive calls in the case where types
11497 -- are known to be correct, it is set to Known_Compatible.
11499 ---------------------------------------
11500 -- Has_Compatible_Alignment_Internal --
11501 ---------------------------------------
11503 function Has_Compatible_Alignment_Internal
11506 Layout_Done : Boolean;
11507 Default : Alignment_Result) return Alignment_Result
11509 Result : Alignment_Result := Known_Compatible;
11510 -- Holds the current status of the result. Note that once a value of
11511 -- Known_Incompatible is set, it is sticky and does not get changed
11512 -- to Unknown (the value in Result only gets worse as we go along,
11515 Offs : Uint := No_Uint;
11516 -- Set to a factor of the offset from the base object when Expr is a
11517 -- selected or indexed component, based on Component_Bit_Offset and
11518 -- Component_Size respectively. A negative value is used to represent
11519 -- a value which is not known at compile time.
11521 procedure Check_Prefix;
11522 -- Checks the prefix recursively in the case where the expression
11523 -- is an indexed or selected component.
11525 procedure Set_Result (R : Alignment_Result);
11526 -- If R represents a worse outcome (unknown instead of known
11527 -- compatible, or known incompatible), then set Result to R.
11533 procedure Check_Prefix is
11535 -- The subtlety here is that in doing a recursive call to check
11536 -- the prefix, we have to decide what to do in the case where we
11537 -- don't find any specific indication of an alignment problem.
11539 -- At the outer level, we normally set Unknown as the result in
11540 -- this case, since we can only set Known_Compatible if we really
11541 -- know that the alignment value is OK, but for the recursive
11542 -- call, in the case where the types match, and we have not
11543 -- specified a peculiar alignment for the object, we are only
11544 -- concerned about suspicious rep clauses, the default case does
11545 -- not affect us, since the compiler will, in the absence of such
11546 -- rep clauses, ensure that the alignment is correct.
11548 if Default = Known_Compatible
11550 (Etype (Obj) = Etype (Expr)
11551 and then (Unknown_Alignment (Obj)
11553 Alignment (Obj) = Alignment (Etype (Obj))))
11556 (Has_Compatible_Alignment_Internal
11557 (Obj, Prefix (Expr), Layout_Done, Known_Compatible));
11559 -- In all other cases, we need a full check on the prefix
11563 (Has_Compatible_Alignment_Internal
11564 (Obj, Prefix (Expr), Layout_Done, Unknown));
11572 procedure Set_Result (R : Alignment_Result) is
11579 -- Start of processing for Has_Compatible_Alignment_Internal
11582 -- If Expr is a selected component, we must make sure there is no
11583 -- potentially troublesome component clause and that the record is
11584 -- not packed if the layout is not done.
11586 if Nkind (Expr) = N_Selected_Component then
11588 -- Packing generates unknown alignment if layout is not done
11590 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then
11591 Set_Result (Unknown);
11594 -- Check prefix and component offset
11597 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
11599 -- If Expr is an indexed component, we must make sure there is no
11600 -- potentially troublesome Component_Size clause and that the array
11601 -- is not bit-packed if the layout is not done.
11603 elsif Nkind (Expr) = N_Indexed_Component then
11605 Typ : constant Entity_Id := Etype (Prefix (Expr));
11608 -- Packing generates unknown alignment if layout is not done
11610 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then
11611 Set_Result (Unknown);
11614 -- Check prefix and component offset (or at least size)
11617 Offs := Indexed_Component_Bit_Offset (Expr);
11618 if Offs = No_Uint then
11619 Offs := Component_Size (Typ);
11624 -- If we have a null offset, the result is entirely determined by
11625 -- the base object and has already been computed recursively.
11627 if Offs = Uint_0 then
11630 -- Case where we know the alignment of the object
11632 elsif Known_Alignment (Obj) then
11634 ObjA : constant Uint := Alignment (Obj);
11635 ExpA : Uint := No_Uint;
11636 SizA : Uint := No_Uint;
11639 -- If alignment of Obj is 1, then we are always OK
11642 Set_Result (Known_Compatible);
11644 -- Alignment of Obj is greater than 1, so we need to check
11647 -- If we have an offset, see if it is compatible
11649 if Offs /= No_Uint and Offs > Uint_0 then
11650 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
11651 Set_Result (Known_Incompatible);
11654 -- See if Expr is an object with known alignment
11656 elsif Is_Entity_Name (Expr)
11657 and then Known_Alignment (Entity (Expr))
11659 ExpA := Alignment (Entity (Expr));
11661 -- Otherwise, we can use the alignment of the type of
11662 -- Expr given that we already checked for
11663 -- discombobulating rep clauses for the cases of indexed
11664 -- and selected components above.
11666 elsif Known_Alignment (Etype (Expr)) then
11667 ExpA := Alignment (Etype (Expr));
11669 -- Otherwise the alignment is unknown
11672 Set_Result (Default);
11675 -- If we got an alignment, see if it is acceptable
11677 if ExpA /= No_Uint and then ExpA < ObjA then
11678 Set_Result (Known_Incompatible);
11681 -- If Expr is not a piece of a larger object, see if size
11682 -- is given. If so, check that it is not too small for the
11683 -- required alignment.
11685 if Offs /= No_Uint then
11688 -- See if Expr is an object with known size
11690 elsif Is_Entity_Name (Expr)
11691 and then Known_Static_Esize (Entity (Expr))
11693 SizA := Esize (Entity (Expr));
11695 -- Otherwise, we check the object size of the Expr type
11697 elsif Known_Static_Esize (Etype (Expr)) then
11698 SizA := Esize (Etype (Expr));
11701 -- If we got a size, see if it is a multiple of the Obj
11702 -- alignment, if not, then the alignment cannot be
11703 -- acceptable, since the size is always a multiple of the
11706 if SizA /= No_Uint then
11707 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
11708 Set_Result (Known_Incompatible);
11714 -- If we do not know required alignment, any non-zero offset is a
11715 -- potential problem (but certainly may be OK, so result is unknown).
11717 elsif Offs /= No_Uint then
11718 Set_Result (Unknown);
11720 -- If we can't find the result by direct comparison of alignment
11721 -- values, then there is still one case that we can determine known
11722 -- result, and that is when we can determine that the types are the
11723 -- same, and no alignments are specified. Then we known that the
11724 -- alignments are compatible, even if we don't know the alignment
11725 -- value in the front end.
11727 elsif Etype (Obj) = Etype (Expr) then
11729 -- Types are the same, but we have to check for possible size
11730 -- and alignments on the Expr object that may make the alignment
11731 -- different, even though the types are the same.
11733 if Is_Entity_Name (Expr) then
11735 -- First check alignment of the Expr object. Any alignment less
11736 -- than Maximum_Alignment is worrisome since this is the case
11737 -- where we do not know the alignment of Obj.
11739 if Known_Alignment (Entity (Expr))
11740 and then UI_To_Int (Alignment (Entity (Expr))) <
11741 Ttypes.Maximum_Alignment
11743 Set_Result (Unknown);
11745 -- Now check size of Expr object. Any size that is not an
11746 -- even multiple of Maximum_Alignment is also worrisome
11747 -- since it may cause the alignment of the object to be less
11748 -- than the alignment of the type.
11750 elsif Known_Static_Esize (Entity (Expr))
11752 (UI_To_Int (Esize (Entity (Expr))) mod
11753 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit))
11756 Set_Result (Unknown);
11758 -- Otherwise same type is decisive
11761 Set_Result (Known_Compatible);
11765 -- Another case to deal with is when there is an explicit size or
11766 -- alignment clause when the types are not the same. If so, then the
11767 -- result is Unknown. We don't need to do this test if the Default is
11768 -- Unknown, since that result will be set in any case.
11770 elsif Default /= Unknown
11771 and then (Has_Size_Clause (Etype (Expr))
11773 Has_Alignment_Clause (Etype (Expr)))
11775 Set_Result (Unknown);
11777 -- If no indication found, set default
11780 Set_Result (Default);
11783 -- Return worst result found
11786 end Has_Compatible_Alignment_Internal;
11788 -- Start of processing for Has_Compatible_Alignment
11791 -- If Obj has no specified alignment, then set alignment from the type
11792 -- alignment. Perhaps we should always do this, but for sure we should
11793 -- do it when there is an address clause since we can do more if the
11794 -- alignment is known.
11796 if Unknown_Alignment (Obj) then
11797 Set_Alignment (Obj, Alignment (Etype (Obj)));
11800 -- Now do the internal call that does all the work
11803 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown);
11804 end Has_Compatible_Alignment;
11806 ----------------------
11807 -- Has_Declarations --
11808 ----------------------
11810 function Has_Declarations (N : Node_Id) return Boolean is
11812 return Nkind (N) in N_Accept_Statement
11813 | N_Block_Statement
11814 | N_Compilation_Unit_Aux
11818 | N_Subprogram_Body
11820 | N_Package_Specification;
11821 end Has_Declarations;
11823 ---------------------------------
11824 -- Has_Defaulted_Discriminants --
11825 ---------------------------------
11827 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
11829 return Has_Discriminants (Typ)
11830 and then Present (First_Discriminant (Typ))
11831 and then Present (Discriminant_Default_Value
11832 (First_Discriminant (Typ)));
11833 end Has_Defaulted_Discriminants;
11835 -------------------
11836 -- Has_Denormals --
11837 -------------------
11839 function Has_Denormals (E : Entity_Id) return Boolean is
11841 return Is_Floating_Point_Type (E) and then Denorm_On_Target;
11844 -------------------------------------------
11845 -- Has_Discriminant_Dependent_Constraint --
11846 -------------------------------------------
11848 function Has_Discriminant_Dependent_Constraint
11849 (Comp : Entity_Id) return Boolean
11851 Comp_Decl : constant Node_Id := Parent (Comp);
11852 Subt_Indic : Node_Id;
11857 -- Discriminants can't depend on discriminants
11859 if Ekind (Comp) = E_Discriminant then
11863 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
11865 if Nkind (Subt_Indic) = N_Subtype_Indication then
11866 Constr := Constraint (Subt_Indic);
11868 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
11869 Assn := First (Constraints (Constr));
11870 while Present (Assn) loop
11871 case Nkind (Assn) is
11874 | N_Subtype_Indication
11876 if Depends_On_Discriminant (Assn) then
11880 when N_Discriminant_Association =>
11881 if Depends_On_Discriminant (Expression (Assn)) then
11896 end Has_Discriminant_Dependent_Constraint;
11898 --------------------------------------
11899 -- Has_Effectively_Volatile_Profile --
11900 --------------------------------------
11902 function Has_Effectively_Volatile_Profile
11903 (Subp_Id : Entity_Id) return Boolean
11905 Formal : Entity_Id;
11908 -- Inspect the formal parameters looking for an effectively volatile
11909 -- type for reading.
11911 Formal := First_Formal (Subp_Id);
11912 while Present (Formal) loop
11913 if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then
11917 Next_Formal (Formal);
11920 -- Inspect the return type of functions
11922 if Ekind (Subp_Id) in E_Function | E_Generic_Function
11923 and then Is_Effectively_Volatile_For_Reading (Etype (Subp_Id))
11929 end Has_Effectively_Volatile_Profile;
11931 --------------------------
11932 -- Has_Enabled_Property --
11933 --------------------------
11935 function Has_Enabled_Property
11936 (Item_Id : Entity_Id;
11937 Property : Name_Id) return Boolean
11939 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean;
11940 -- Determine whether a protected type or variable denoted by Item_Id
11941 -- has the property enabled.
11943 function State_Has_Enabled_Property return Boolean;
11944 -- Determine whether a state denoted by Item_Id has the property enabled
11946 function Type_Or_Variable_Has_Enabled_Property
11947 (Item_Id : Entity_Id) return Boolean;
11948 -- Determine whether type or variable denoted by Item_Id has the
11949 -- property enabled.
11951 -----------------------------------------------------
11952 -- Protected_Type_Or_Variable_Has_Enabled_Property --
11953 -----------------------------------------------------
11955 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean
11958 -- Protected entities always have the properties Async_Readers and
11959 -- Async_Writers (SPARK RM 7.1.2(16)).
11961 if Property = Name_Async_Readers
11962 or else Property = Name_Async_Writers
11966 -- Protected objects that have Part_Of components also inherit their
11967 -- properties Effective_Reads and Effective_Writes
11968 -- (SPARK RM 7.1.2(16)).
11970 elsif Is_Single_Protected_Object (Item_Id) then
11972 Constit_Elmt : Elmt_Id;
11973 Constit_Id : Entity_Id;
11974 Constits : constant Elist_Id
11975 := Part_Of_Constituents (Item_Id);
11977 if Present (Constits) then
11978 Constit_Elmt := First_Elmt (Constits);
11979 while Present (Constit_Elmt) loop
11980 Constit_Id := Node (Constit_Elmt);
11982 if Has_Enabled_Property (Constit_Id, Property) then
11986 Next_Elmt (Constit_Elmt);
11993 end Protected_Type_Or_Variable_Has_Enabled_Property;
11995 --------------------------------
11996 -- State_Has_Enabled_Property --
11997 --------------------------------
11999 function State_Has_Enabled_Property return Boolean is
12000 Decl : constant Node_Id := Parent (Item_Id);
12002 procedure Find_Simple_Properties
12003 (Has_External : out Boolean;
12004 Has_Synchronous : out Boolean);
12005 -- Extract the simple properties associated with declaration Decl
12007 function Is_Enabled_External_Property return Boolean;
12008 -- Determine whether property Property appears within the external
12009 -- property list of declaration Decl, and return its status.
12011 ----------------------------
12012 -- Find_Simple_Properties --
12013 ----------------------------
12015 procedure Find_Simple_Properties
12016 (Has_External : out Boolean;
12017 Has_Synchronous : out Boolean)
12022 -- Assume that none of the properties are available
12024 Has_External := False;
12025 Has_Synchronous := False;
12027 Opt := First (Expressions (Decl));
12028 while Present (Opt) loop
12029 if Nkind (Opt) = N_Identifier then
12030 if Chars (Opt) = Name_External then
12031 Has_External := True;
12033 elsif Chars (Opt) = Name_Synchronous then
12034 Has_Synchronous := True;
12040 end Find_Simple_Properties;
12042 ----------------------------------
12043 -- Is_Enabled_External_Property --
12044 ----------------------------------
12046 function Is_Enabled_External_Property return Boolean is
12050 Prop_Nam : Node_Id;
12054 Opt := First (Component_Associations (Decl));
12055 while Present (Opt) loop
12056 Opt_Nam := First (Choices (Opt));
12058 if Nkind (Opt_Nam) = N_Identifier
12059 and then Chars (Opt_Nam) = Name_External
12061 Props := Expression (Opt);
12063 -- Multiple properties appear as an aggregate
12065 if Nkind (Props) = N_Aggregate then
12067 -- Simple property form
12069 Prop := First (Expressions (Props));
12070 while Present (Prop) loop
12071 if Chars (Prop) = Property then
12078 -- Property with expression form
12080 Prop := First (Component_Associations (Props));
12081 while Present (Prop) loop
12082 Prop_Nam := First (Choices (Prop));
12084 -- The property can be represented in two ways:
12085 -- others => <value>
12086 -- <property> => <value>
12088 if Nkind (Prop_Nam) = N_Others_Choice
12089 or else (Nkind (Prop_Nam) = N_Identifier
12090 and then Chars (Prop_Nam) = Property)
12092 return Is_True (Expr_Value (Expression (Prop)));
12101 return Chars (Props) = Property;
12109 end Is_Enabled_External_Property;
12113 Has_External : Boolean;
12114 Has_Synchronous : Boolean;
12116 -- Start of processing for State_Has_Enabled_Property
12119 -- The declaration of an external abstract state appears as an
12120 -- extension aggregate. If this is not the case, properties can
12123 if Nkind (Decl) /= N_Extension_Aggregate then
12127 Find_Simple_Properties (Has_External, Has_Synchronous);
12129 -- Simple option External enables all properties (SPARK RM 7.1.2(2))
12131 if Has_External then
12134 -- Option External may enable or disable specific properties
12136 elsif Is_Enabled_External_Property then
12139 -- Simple option Synchronous
12141 -- enables disables
12142 -- Async_Readers Effective_Reads
12143 -- Async_Writers Effective_Writes
12145 -- Note that both forms of External have higher precedence than
12146 -- Synchronous (SPARK RM 7.1.4(9)).
12148 elsif Has_Synchronous then
12149 return Property in Name_Async_Readers | Name_Async_Writers;
12153 end State_Has_Enabled_Property;
12155 -------------------------------------------
12156 -- Type_Or_Variable_Has_Enabled_Property --
12157 -------------------------------------------
12159 function Type_Or_Variable_Has_Enabled_Property
12160 (Item_Id : Entity_Id) return Boolean
12162 function Is_Enabled (Prag : Node_Id) return Boolean;
12163 -- Determine whether property pragma Prag (if present) denotes an
12164 -- enabled property.
12170 function Is_Enabled (Prag : Node_Id) return Boolean is
12174 if Present (Prag) then
12175 Arg1 := First (Pragma_Argument_Associations (Prag));
12177 -- The pragma has an optional Boolean expression, the related
12178 -- property is enabled only when the expression evaluates to
12181 if Present (Arg1) then
12182 return Is_True (Expr_Value (Get_Pragma_Arg (Arg1)));
12184 -- Otherwise the lack of expression enables the property by
12191 -- The property was never set in the first place
12200 AR : constant Node_Id :=
12201 Get_Pragma (Item_Id, Pragma_Async_Readers);
12202 AW : constant Node_Id :=
12203 Get_Pragma (Item_Id, Pragma_Async_Writers);
12204 ER : constant Node_Id :=
12205 Get_Pragma (Item_Id, Pragma_Effective_Reads);
12206 EW : constant Node_Id :=
12207 Get_Pragma (Item_Id, Pragma_Effective_Writes);
12209 Is_Derived_Type_With_Volatile_Parent_Type : constant Boolean :=
12210 Is_Derived_Type (Item_Id)
12211 and then Is_Effectively_Volatile (Etype (Base_Type (Item_Id)));
12213 -- Start of processing for Type_Or_Variable_Has_Enabled_Property
12216 -- A non-effectively volatile object can never possess external
12219 if not Is_Effectively_Volatile (Item_Id) then
12222 -- External properties related to variables come in two flavors -
12223 -- explicit and implicit. The explicit case is characterized by the
12224 -- presence of a property pragma with an optional Boolean flag. The
12225 -- property is enabled when the flag evaluates to True or the flag is
12226 -- missing altogether.
12228 elsif Property = Name_Async_Readers and then Present (AR) then
12229 return Is_Enabled (AR);
12231 elsif Property = Name_Async_Writers and then Present (AW) then
12232 return Is_Enabled (AW);
12234 elsif Property = Name_Effective_Reads and then Present (ER) then
12235 return Is_Enabled (ER);
12237 elsif Property = Name_Effective_Writes and then Present (EW) then
12238 return Is_Enabled (EW);
12240 -- If other properties are set explicitly, then this one is set
12241 -- implicitly to False, except in the case of a derived type
12242 -- whose parent type is volatile (in that case, we will inherit
12243 -- from the parent type, below).
12245 elsif (Present (AR)
12246 or else Present (AW)
12247 or else Present (ER)
12248 or else Present (EW))
12249 and then not Is_Derived_Type_With_Volatile_Parent_Type
12253 -- For a private type, may need to look at the full view
12255 elsif Is_Private_Type (Item_Id) and then Present (Full_View (Item_Id))
12257 return Type_Or_Variable_Has_Enabled_Property (Full_View (Item_Id));
12259 -- For a derived type whose parent type is volatile, the
12260 -- property may be inherited (but ignore a non-volatile parent).
12262 elsif Is_Derived_Type_With_Volatile_Parent_Type then
12263 return Type_Or_Variable_Has_Enabled_Property
12264 (First_Subtype (Etype (Base_Type (Item_Id))));
12266 -- If not specified explicitly for an object and the type
12267 -- is effectively volatile, then take result from the type.
12269 elsif not Is_Type (Item_Id)
12270 and then Is_Effectively_Volatile (Etype (Item_Id))
12272 return Has_Enabled_Property (Etype (Item_Id), Property);
12274 -- The implicit case lacks all property pragmas
12276 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
12277 if Is_Protected_Type (Etype (Item_Id)) then
12278 return Protected_Type_Or_Variable_Has_Enabled_Property;
12286 end Type_Or_Variable_Has_Enabled_Property;
12288 -- Start of processing for Has_Enabled_Property
12291 -- Abstract states and variables have a flexible scheme of specifying
12292 -- external properties.
12294 if Ekind (Item_Id) = E_Abstract_State then
12295 return State_Has_Enabled_Property;
12297 elsif Ekind (Item_Id) in E_Variable | E_Constant then
12298 return Type_Or_Variable_Has_Enabled_Property (Item_Id);
12300 -- Other objects can only inherit properties through their type. We
12301 -- cannot call directly Type_Or_Variable_Has_Enabled_Property on
12302 -- these as they don't have contracts attached, which is expected by
12305 elsif Is_Object (Item_Id) then
12306 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id));
12308 elsif Is_Type (Item_Id) then
12309 return Type_Or_Variable_Has_Enabled_Property
12310 (Item_Id => First_Subtype (Item_Id));
12312 -- Otherwise a property is enabled when the related item is effectively
12316 return Is_Effectively_Volatile (Item_Id);
12318 end Has_Enabled_Property;
12320 -------------------------------------
12321 -- Has_Full_Default_Initialization --
12322 -------------------------------------
12324 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
12328 -- A type subject to pragma Default_Initial_Condition may be fully
12329 -- default initialized depending on inheritance and the argument of
12330 -- the pragma. Since any type may act as the full view of a private
12331 -- type, this check must be performed prior to the specialized tests
12334 if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then
12338 -- A scalar type is fully default initialized if it is subject to aspect
12341 if Is_Scalar_Type (Typ) then
12342 return Has_Default_Aspect (Typ);
12344 -- An access type is fully default initialized by default
12346 elsif Is_Access_Type (Typ) then
12349 -- An array type is fully default initialized if its element type is
12350 -- scalar and the array type carries aspect Default_Component_Value or
12351 -- the element type is fully default initialized.
12353 elsif Is_Array_Type (Typ) then
12355 Has_Default_Aspect (Typ)
12356 or else Has_Full_Default_Initialization (Component_Type (Typ));
12358 -- A protected type, record type, or type extension is fully default
12359 -- initialized if all its components either carry an initialization
12360 -- expression or have a type that is fully default initialized. The
12361 -- parent type of a type extension must be fully default initialized.
12363 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
12365 -- Inspect all entities defined in the scope of the type, looking for
12366 -- uninitialized components.
12368 Comp := First_Component (Typ);
12369 while Present (Comp) loop
12370 if Comes_From_Source (Comp)
12371 and then No (Expression (Parent (Comp)))
12372 and then not Has_Full_Default_Initialization (Etype (Comp))
12377 Next_Component (Comp);
12380 -- Ensure that the parent type of a type extension is fully default
12383 if Etype (Typ) /= Typ
12384 and then not Has_Full_Default_Initialization (Etype (Typ))
12389 -- If we get here, then all components and parent portion are fully
12390 -- default initialized.
12394 -- A task type is fully default initialized by default
12396 elsif Is_Task_Type (Typ) then
12399 -- Otherwise the type is not fully default initialized
12404 end Has_Full_Default_Initialization;
12406 -----------------------------------------------
12407 -- Has_Fully_Default_Initializing_DIC_Pragma --
12408 -----------------------------------------------
12410 function Has_Fully_Default_Initializing_DIC_Pragma
12411 (Typ : Entity_Id) return Boolean
12417 -- A type that inherits pragma Default_Initial_Condition from a parent
12418 -- type is automatically fully default initialized.
12420 if Has_Inherited_DIC (Typ) then
12423 -- Otherwise the type is fully default initialized only when the pragma
12424 -- appears without an argument, or the argument is non-null.
12426 elsif Has_Own_DIC (Typ) then
12427 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
12428 pragma Assert (Present (Prag));
12429 Args := Pragma_Argument_Associations (Prag);
12431 -- The pragma appears without an argument in which case it defaults
12437 -- The pragma appears with a non-null expression
12439 elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then
12445 end Has_Fully_Default_Initializing_DIC_Pragma;
12447 --------------------
12448 -- Has_Infinities --
12449 --------------------
12451 function Has_Infinities (E : Entity_Id) return Boolean is
12454 Is_Floating_Point_Type (E)
12455 and then Nkind (Scalar_Range (E)) = N_Range
12456 and then Includes_Infinities (Scalar_Range (E));
12457 end Has_Infinities;
12459 --------------------
12460 -- Has_Interfaces --
12461 --------------------
12463 function Has_Interfaces
12465 Use_Full_View : Boolean := True) return Boolean
12467 Typ : Entity_Id := Base_Type (T);
12470 -- Handle concurrent types
12472 if Is_Concurrent_Type (Typ) then
12473 Typ := Corresponding_Record_Type (Typ);
12476 if not Present (Typ)
12477 or else not Is_Record_Type (Typ)
12478 or else not Is_Tagged_Type (Typ)
12483 -- Handle private types
12485 if Use_Full_View and then Present (Full_View (Typ)) then
12486 Typ := Full_View (Typ);
12489 -- Handle concurrent record types
12491 if Is_Concurrent_Record_Type (Typ)
12492 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
12498 if Is_Interface (Typ)
12500 (Is_Record_Type (Typ)
12501 and then Present (Interfaces (Typ))
12502 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
12507 exit when Etype (Typ) = Typ
12509 -- Handle private types
12511 or else (Present (Full_View (Etype (Typ)))
12512 and then Full_View (Etype (Typ)) = Typ)
12514 -- Protect frontend against wrong sources with cyclic derivations
12516 or else Etype (Typ) = T;
12518 -- Climb to the ancestor type handling private types
12520 if Present (Full_View (Etype (Typ))) then
12521 Typ := Full_View (Etype (Typ));
12523 Typ := Etype (Typ);
12528 end Has_Interfaces;
12530 --------------------------
12531 -- Has_Max_Queue_Length --
12532 --------------------------
12534 function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is
12537 Ekind (Id) = E_Entry
12538 and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length));
12539 end Has_Max_Queue_Length;
12541 ---------------------------------
12542 -- Has_No_Obvious_Side_Effects --
12543 ---------------------------------
12545 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
12547 -- For now handle literals, constants, and non-volatile variables and
12548 -- expressions combining these with operators or short circuit forms.
12550 if Nkind (N) in N_Numeric_Or_String_Literal then
12553 elsif Nkind (N) = N_Character_Literal then
12556 elsif Nkind (N) in N_Unary_Op then
12557 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
12559 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
12560 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
12562 Has_No_Obvious_Side_Effects (Right_Opnd (N));
12564 elsif Nkind (N) = N_Expression_With_Actions
12565 and then Is_Empty_List (Actions (N))
12567 return Has_No_Obvious_Side_Effects (Expression (N));
12569 elsif Nkind (N) in N_Has_Entity then
12570 return Present (Entity (N))
12572 Ekind (Entity (N)) in
12573 E_Variable | E_Constant | E_Enumeration_Literal |
12574 E_In_Parameter | E_Out_Parameter | E_In_Out_Parameter
12575 and then not Is_Volatile (Entity (N));
12580 end Has_No_Obvious_Side_Effects;
12582 -----------------------------
12583 -- Has_Non_Null_Refinement --
12584 -----------------------------
12586 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is
12587 Constits : Elist_Id;
12590 pragma Assert (Ekind (Id) = E_Abstract_State);
12591 Constits := Refinement_Constituents (Id);
12593 -- For a refinement to be non-null, the first constituent must be
12594 -- anything other than null.
12598 and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
12599 end Has_Non_Null_Refinement;
12601 -----------------------------
12602 -- Has_Non_Null_Statements --
12603 -----------------------------
12605 function Has_Non_Null_Statements (L : List_Id) return Boolean is
12609 if Is_Non_Empty_List (L) then
12613 if Nkind (Node) not in N_Null_Statement | N_Call_Marker then
12618 exit when Node = Empty;
12623 end Has_Non_Null_Statements;
12625 ----------------------------------
12626 -- Is_Access_Subprogram_Wrapper --
12627 ----------------------------------
12629 function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean is
12630 Formal : constant Entity_Id := Last_Formal (E);
12632 return Present (Formal)
12633 and then Ekind (Etype (Formal)) in Access_Subprogram_Kind
12634 and then Access_Subprogram_Wrapper
12635 (Directly_Designated_Type (Etype (Formal))) = E;
12636 end Is_Access_Subprogram_Wrapper;
12638 ---------------------------
12639 -- Is_Explicitly_Aliased --
12640 ---------------------------
12642 function Is_Explicitly_Aliased (N : Node_Id) return Boolean is
12644 return Is_Formal (N)
12645 and then Present (Parent (N))
12646 and then Nkind (Parent (N)) = N_Parameter_Specification
12647 and then Aliased_Present (Parent (N));
12648 end Is_Explicitly_Aliased;
12650 ----------------------------
12651 -- Is_Container_Aggregate --
12652 ----------------------------
12654 function Is_Container_Aggregate (Exp : Node_Id) return Boolean is
12656 function Is_Record_Aggregate return Boolean is (False);
12657 -- ??? Unimplemented. Given an aggregate whose type is a
12658 -- record type with specified Aggregate aspect, how do we
12659 -- determine whether it is a record aggregate or a container
12660 -- aggregate? If the code where the aggregate occurs can see only
12661 -- a partial view of the aggregate's type then the aggregate
12662 -- cannot be a record type; an aggregate of a private type has to
12663 -- be a container aggregate.
12666 return Nkind (Exp) = N_Aggregate
12667 and then Present (Find_Aspect (Etype (Exp), Aspect_Aggregate))
12668 and then not Is_Record_Aggregate;
12669 end Is_Container_Aggregate;
12671 ---------------------------------
12672 -- Side_Effect_Free_Statements --
12673 ---------------------------------
12675 function Side_Effect_Free_Statements (L : List_Id) return Boolean is
12679 if Is_Non_Empty_List (L) then
12683 case Nkind (Node) is
12684 when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error =>
12686 when N_Object_Declaration =>
12687 if Present (Expression (Node))
12688 and then not Side_Effect_Free (Expression (Node))
12698 exit when Node = Empty;
12703 end Side_Effect_Free_Statements;
12705 ---------------------------
12706 -- Side_Effect_Free_Loop --
12707 ---------------------------
12709 function Side_Effect_Free_Loop (N : Node_Id) return Boolean is
12715 -- If this is not a loop (e.g. because the loop has been rewritten),
12716 -- then return false.
12718 if Nkind (N) /= N_Loop_Statement then
12722 -- First check the statements
12724 if Side_Effect_Free_Statements (Statements (N)) then
12726 -- Then check the loop condition/indexes
12728 if Present (Iteration_Scheme (N)) then
12729 Scheme := Iteration_Scheme (N);
12731 if Present (Condition (Scheme))
12732 or else Present (Iterator_Specification (Scheme))
12735 elsif Present (Loop_Parameter_Specification (Scheme)) then
12736 Spec := Loop_Parameter_Specification (Scheme);
12737 Subt := Discrete_Subtype_Definition (Spec);
12739 if Present (Subt) then
12740 if Nkind (Subt) = N_Range then
12741 return Side_Effect_Free (Low_Bound (Subt))
12742 and then Side_Effect_Free (High_Bound (Subt));
12744 -- subtype indication
12754 end Side_Effect_Free_Loop;
12756 ----------------------------------
12757 -- Has_Non_Trivial_Precondition --
12758 ----------------------------------
12760 function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is
12761 Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre,
12762 Class_Present => True);
12766 and then not Is_Entity_Name (Expression (Pre));
12767 end Has_Non_Trivial_Precondition;
12769 -------------------
12770 -- Has_Null_Body --
12771 -------------------
12773 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is
12774 Body_Id : Entity_Id;
12781 Spec := Parent (Proc_Id);
12782 Decl := Parent (Spec);
12784 -- Retrieve the entity of the procedure body (e.g. invariant proc).
12786 if Nkind (Spec) = N_Procedure_Specification
12787 and then Nkind (Decl) = N_Subprogram_Declaration
12789 Body_Id := Corresponding_Body (Decl);
12791 -- The body acts as a spec
12794 Body_Id := Proc_Id;
12797 -- The body will be generated later
12799 if No (Body_Id) then
12803 Spec := Parent (Body_Id);
12804 Decl := Parent (Spec);
12807 (Nkind (Spec) = N_Procedure_Specification
12808 and then Nkind (Decl) = N_Subprogram_Body);
12810 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl)));
12812 -- Look for a null statement followed by an optional return
12815 if Nkind (Stmt1) = N_Null_Statement then
12816 Stmt2 := Next (Stmt1);
12818 if Present (Stmt2) then
12819 return Nkind (Stmt2) = N_Simple_Return_Statement;
12828 ------------------------
12829 -- Has_Null_Exclusion --
12830 ------------------------
12832 function Has_Null_Exclusion (N : Node_Id) return Boolean is
12835 when N_Access_Definition
12836 | N_Access_Function_Definition
12837 | N_Access_Procedure_Definition
12838 | N_Access_To_Object_Definition
12840 | N_Derived_Type_Definition
12841 | N_Function_Specification
12842 | N_Subtype_Declaration
12844 return Null_Exclusion_Present (N);
12846 when N_Component_Definition
12847 | N_Formal_Object_Declaration
12849 if Present (Subtype_Mark (N)) then
12850 return Null_Exclusion_Present (N);
12851 else pragma Assert (Present (Access_Definition (N)));
12852 return Null_Exclusion_Present (Access_Definition (N));
12855 when N_Object_Renaming_Declaration =>
12856 if Present (Subtype_Mark (N)) then
12857 return Null_Exclusion_Present (N);
12858 elsif Present (Access_Definition (N)) then
12859 return Null_Exclusion_Present (Access_Definition (N));
12861 return False; -- Case of no subtype in renaming (AI12-0275)
12864 when N_Discriminant_Specification =>
12865 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
12866 return Null_Exclusion_Present (Discriminant_Type (N));
12868 return Null_Exclusion_Present (N);
12871 when N_Object_Declaration =>
12872 if Nkind (Object_Definition (N)) = N_Access_Definition then
12873 return Null_Exclusion_Present (Object_Definition (N));
12875 return Null_Exclusion_Present (N);
12878 when N_Parameter_Specification =>
12879 if Nkind (Parameter_Type (N)) = N_Access_Definition then
12880 return Null_Exclusion_Present (Parameter_Type (N))
12881 or else Null_Exclusion_Present (N);
12883 return Null_Exclusion_Present (N);
12889 end Has_Null_Exclusion;
12891 ------------------------
12892 -- Has_Null_Extension --
12893 ------------------------
12895 function Has_Null_Extension (T : Entity_Id) return Boolean is
12896 B : constant Entity_Id := Base_Type (T);
12901 if Nkind (Parent (B)) = N_Full_Type_Declaration
12902 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
12904 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
12906 if Present (Ext) then
12907 if Null_Present (Ext) then
12910 Comps := Component_List (Ext);
12912 -- The null component list is rewritten during analysis to
12913 -- include the parent component. Any other component indicates
12914 -- that the extension was not originally null.
12916 return Null_Present (Comps)
12917 or else No (Next (First (Component_Items (Comps))));
12926 end Has_Null_Extension;
12928 -------------------------
12929 -- Has_Null_Refinement --
12930 -------------------------
12932 function Has_Null_Refinement (Id : Entity_Id) return Boolean is
12933 Constits : Elist_Id;
12936 pragma Assert (Ekind (Id) = E_Abstract_State);
12937 Constits := Refinement_Constituents (Id);
12939 -- For a refinement to be null, the state's sole constituent must be a
12944 and then Nkind (Node (First_Elmt (Constits))) = N_Null;
12945 end Has_Null_Refinement;
12947 -------------------------------
12948 -- Has_Overriding_Initialize --
12949 -------------------------------
12951 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
12952 BT : constant Entity_Id := Base_Type (T);
12956 if Is_Controlled (BT) then
12957 if Is_RTU (Scope (BT), Ada_Finalization) then
12960 elsif Present (Primitive_Operations (BT)) then
12961 P := First_Elmt (Primitive_Operations (BT));
12962 while Present (P) loop
12964 Init : constant Entity_Id := Node (P);
12965 Formal : constant Entity_Id := First_Formal (Init);
12967 if Ekind (Init) = E_Procedure
12968 and then Chars (Init) = Name_Initialize
12969 and then Comes_From_Source (Init)
12970 and then Present (Formal)
12971 and then Etype (Formal) = BT
12972 and then No (Next_Formal (Formal))
12973 and then (Ada_Version < Ada_2012
12974 or else not Null_Present (Parent (Init)))
12984 -- Here if type itself does not have a non-null Initialize operation:
12985 -- check immediate ancestor.
12987 if Is_Derived_Type (BT)
12988 and then Has_Overriding_Initialize (Etype (BT))
12995 end Has_Overriding_Initialize;
12997 --------------------------------------
12998 -- Has_Preelaborable_Initialization --
12999 --------------------------------------
13001 function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean is
13004 procedure Check_Components (E : Entity_Id);
13005 -- Check component/discriminant chain, sets Has_PE False if a component
13006 -- or discriminant does not meet the preelaborable initialization rules.
13008 ----------------------
13009 -- Check_Components --
13010 ----------------------
13012 procedure Check_Components (E : Entity_Id) is
13017 -- Loop through entities of record or protected type
13020 while Present (Ent) loop
13022 -- We are interested only in components and discriminants
13026 case Ekind (Ent) is
13027 when E_Component =>
13029 -- Get default expression if any. If there is no declaration
13030 -- node, it means we have an internal entity. The parent and
13031 -- tag fields are examples of such entities. For such cases,
13032 -- we just test the type of the entity.
13034 if Present (Declaration_Node (Ent)) then
13035 Exp := Expression (Declaration_Node (Ent));
13038 when E_Discriminant =>
13040 -- Note: for a renamed discriminant, the Declaration_Node
13041 -- may point to the one from the ancestor, and have a
13042 -- different expression, so use the proper attribute to
13043 -- retrieve the expression from the derived constraint.
13045 Exp := Discriminant_Default_Value (Ent);
13048 goto Check_Next_Entity;
13051 -- A component has PI if it has no default expression and the
13052 -- component type has PI.
13055 if not Has_Preelaborable_Initialization (Etype (Ent)) then
13060 -- Require the default expression to be preelaborable
13062 elsif not Is_Preelaborable_Construct (Exp) then
13067 <<Check_Next_Entity>>
13070 end Check_Components;
13072 -- Start of processing for Has_Preelaborable_Initialization
13075 -- Immediate return if already marked as known preelaborable init. This
13076 -- covers types for which this function has already been called once
13077 -- and returned True (in which case the result is cached), and also
13078 -- types to which a pragma Preelaborable_Initialization applies.
13080 if Known_To_Have_Preelab_Init (E) then
13084 -- If the type is a subtype representing a generic actual type, then
13085 -- test whether its base type has preelaborable initialization since
13086 -- the subtype representing the actual does not inherit this attribute
13087 -- from the actual or formal. (but maybe it should???)
13089 if Is_Generic_Actual_Type (E) then
13090 return Has_Preelaborable_Initialization (Base_Type (E));
13093 -- All elementary types have preelaborable initialization
13095 if Is_Elementary_Type (E) then
13098 -- Array types have PI if the component type has PI
13100 elsif Is_Array_Type (E) then
13101 Has_PE := Has_Preelaborable_Initialization (Component_Type (E));
13103 -- A derived type has preelaborable initialization if its parent type
13104 -- has preelaborable initialization and (in the case of a derived record
13105 -- extension) if the non-inherited components all have preelaborable
13106 -- initialization. However, a user-defined controlled type with an
13107 -- overriding Initialize procedure does not have preelaborable
13110 elsif Is_Derived_Type (E) then
13112 -- If the derived type is a private extension then it doesn't have
13113 -- preelaborable initialization.
13115 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
13119 -- First check whether ancestor type has preelaborable initialization
13121 Has_PE := Has_Preelaborable_Initialization (Etype (Base_Type (E)));
13123 -- If OK, check extension components (if any)
13125 if Has_PE and then Is_Record_Type (E) then
13126 Check_Components (First_Entity (E));
13129 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
13130 -- with a user defined Initialize procedure does not have PI. If
13131 -- the type is untagged, the control primitives come from a component
13132 -- that has already been checked.
13135 and then Is_Controlled (E)
13136 and then Is_Tagged_Type (E)
13137 and then Has_Overriding_Initialize (E)
13142 -- Private types not derived from a type having preelaborable init and
13143 -- that are not marked with pragma Preelaborable_Initialization do not
13144 -- have preelaborable initialization.
13146 elsif Is_Private_Type (E) then
13149 -- Record type has PI if it is non private and all components have PI
13151 elsif Is_Record_Type (E) then
13153 Check_Components (First_Entity (E));
13155 -- Protected types must not have entries, and components must meet
13156 -- same set of rules as for record components.
13158 elsif Is_Protected_Type (E) then
13159 if Has_Entries (E) then
13163 Check_Components (First_Entity (E));
13164 Check_Components (First_Private_Entity (E));
13167 -- Type System.Address always has preelaborable initialization
13169 elsif Is_RTE (E, RE_Address) then
13172 -- In all other cases, type does not have preelaborable initialization
13178 -- If type has preelaborable initialization, cache result
13181 Set_Known_To_Have_Preelab_Init (E);
13185 end Has_Preelaborable_Initialization;
13191 function Has_Prefix (N : Node_Id) return Boolean is
13193 return Nkind (N) in
13194 N_Attribute_Reference | N_Expanded_Name | N_Explicit_Dereference |
13195 N_Indexed_Component | N_Reference | N_Selected_Component |
13199 ---------------------------
13200 -- Has_Private_Component --
13201 ---------------------------
13203 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
13204 Btype : Entity_Id := Base_Type (Type_Id);
13205 Component : Entity_Id;
13208 if Error_Posted (Type_Id)
13209 or else Error_Posted (Btype)
13214 if Is_Class_Wide_Type (Btype) then
13215 Btype := Root_Type (Btype);
13218 if Is_Private_Type (Btype) then
13220 UT : constant Entity_Id := Underlying_Type (Btype);
13223 if No (Full_View (Btype)) then
13224 return not Is_Generic_Type (Btype)
13226 not Is_Generic_Type (Root_Type (Btype));
13228 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
13231 return not Is_Frozen (UT) and then Has_Private_Component (UT);
13235 elsif Is_Array_Type (Btype) then
13236 return Has_Private_Component (Component_Type (Btype));
13238 elsif Is_Record_Type (Btype) then
13239 Component := First_Component (Btype);
13240 while Present (Component) loop
13241 if Has_Private_Component (Etype (Component)) then
13245 Next_Component (Component);
13250 elsif Is_Protected_Type (Btype)
13251 and then Present (Corresponding_Record_Type (Btype))
13253 return Has_Private_Component (Corresponding_Record_Type (Btype));
13258 end Has_Private_Component;
13260 --------------------------------
13261 -- Has_Relaxed_Initialization --
13262 --------------------------------
13264 function Has_Relaxed_Initialization (E : Entity_Id) return Boolean is
13266 function Denotes_Relaxed_Parameter
13270 -- Returns True iff expression Expr denotes a formal parameter or
13271 -- function Param (through its attribute Result).
13273 -------------------------------
13274 -- Denotes_Relaxed_Parameter --
13275 -------------------------------
13277 function Denotes_Relaxed_Parameter
13279 Param : Entity_Id) return Boolean is
13281 if Nkind (Expr) in N_Identifier | N_Expanded_Name then
13282 return Entity (Expr) = Param;
13284 pragma Assert (Is_Attribute_Result (Expr));
13285 return Entity (Prefix (Expr)) = Param;
13287 end Denotes_Relaxed_Parameter;
13289 -- Start of processing for Has_Relaxed_Initialization
13292 -- When analyzing, we checked all syntax legality rules for the aspect
13293 -- Relaxed_Initialization, but didn't store the property anywhere (e.g.
13294 -- as an Einfo flag). To query the property we look directly at the AST,
13295 -- but now without any syntactic checks.
13298 -- Abstract states have option Relaxed_Initialization
13300 when E_Abstract_State =>
13301 return Is_Relaxed_Initialization_State (E);
13303 -- Constants have this aspect attached directly; for deferred
13304 -- constants, the aspect is attached to the partial view.
13307 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13309 -- Variables have this aspect attached directly
13312 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13314 -- Types have this aspect attached directly (though we only allow it
13315 -- to be specified for the first subtype). For private types, the
13316 -- aspect is attached to the partial view.
13319 pragma Assert (Is_First_Subtype (E));
13320 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13322 -- Formal parameters and functions have the Relaxed_Initialization
13323 -- aspect attached to the subprogram entity and must be listed in
13324 -- the aspect expression.
13330 Subp_Id : Entity_Id;
13331 Aspect_Expr : Node_Id;
13332 Param_Expr : Node_Id;
13336 if Is_Formal (E) then
13337 Subp_Id := Scope (E);
13342 if Has_Aspect (Subp_Id, Aspect_Relaxed_Initialization) then
13344 Find_Value_Of_Aspect
13345 (Subp_Id, Aspect_Relaxed_Initialization);
13347 -- Aspect expression is either an aggregate with an optional
13348 -- Boolean expression (which defaults to True), e.g.:
13350 -- function F (X : Integer) return Integer
13351 -- with Relaxed_Initialization => (X => True, F'Result);
13353 if Nkind (Aspect_Expr) = N_Aggregate then
13355 if Present (Component_Associations (Aspect_Expr)) then
13356 Assoc := First (Component_Associations (Aspect_Expr));
13358 while Present (Assoc) loop
13359 if Denotes_Relaxed_Parameter
13360 (First (Choices (Assoc)), E)
13364 (Static_Boolean (Expression (Assoc)));
13371 Param_Expr := First (Expressions (Aspect_Expr));
13373 while Present (Param_Expr) loop
13374 if Denotes_Relaxed_Parameter (Param_Expr, E) then
13383 -- or it is a single identifier, e.g.:
13385 -- function F (X : Integer) return Integer
13386 -- with Relaxed_Initialization => X;
13389 return Denotes_Relaxed_Parameter (Aspect_Expr, E);
13397 raise Program_Error;
13399 end Has_Relaxed_Initialization;
13401 ----------------------
13402 -- Has_Signed_Zeros --
13403 ----------------------
13405 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
13407 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target;
13408 end Has_Signed_Zeros;
13410 ------------------------------
13411 -- Has_Significant_Contract --
13412 ------------------------------
13414 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is
13415 Subp_Nam : constant Name_Id := Chars (Subp_Id);
13418 -- _Finalizer procedure
13420 if Subp_Nam = Name_uFinalizer then
13423 -- _Postconditions procedure
13425 elsif Subp_Nam = Name_uPostconditions then
13428 -- Predicate function
13430 elsif Ekind (Subp_Id) = E_Function
13431 and then Is_Predicate_Function (Subp_Id)
13437 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then
13443 end Has_Significant_Contract;
13445 -----------------------------
13446 -- Has_Static_Array_Bounds --
13447 -----------------------------
13449 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
13450 All_Static : Boolean;
13454 Examine_Array_Bounds (Typ, All_Static, Dummy);
13457 end Has_Static_Array_Bounds;
13459 ---------------------------------------
13460 -- Has_Static_Non_Empty_Array_Bounds --
13461 ---------------------------------------
13463 function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is
13464 All_Static : Boolean;
13465 Has_Empty : Boolean;
13468 Examine_Array_Bounds (Typ, All_Static, Has_Empty);
13470 return All_Static and not Has_Empty;
13471 end Has_Static_Non_Empty_Array_Bounds;
13477 function Has_Stream (T : Entity_Id) return Boolean is
13484 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
13487 elsif Is_Array_Type (T) then
13488 return Has_Stream (Component_Type (T));
13490 elsif Is_Record_Type (T) then
13491 E := First_Component (T);
13492 while Present (E) loop
13493 if Has_Stream (Etype (E)) then
13496 Next_Component (E);
13502 elsif Is_Private_Type (T) then
13503 return Has_Stream (Underlying_Type (T));
13514 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
13516 Get_Name_String (Chars (E));
13517 return Name_Buffer (Name_Len) = Suffix;
13524 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
13526 Get_Name_String (Chars (E));
13527 Add_Char_To_Name_Buffer (Suffix);
13531 -------------------
13532 -- Remove_Suffix --
13533 -------------------
13535 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
13537 pragma Assert (Has_Suffix (E, Suffix));
13538 Get_Name_String (Chars (E));
13539 Name_Len := Name_Len - 1;
13543 ----------------------------------
13544 -- Replace_Null_By_Null_Address --
13545 ----------------------------------
13547 procedure Replace_Null_By_Null_Address (N : Node_Id) is
13548 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id);
13549 -- Replace operand Op with a reference to Null_Address when the operand
13550 -- denotes a null Address. Other_Op denotes the other operand.
13552 --------------------------
13553 -- Replace_Null_Operand --
13554 --------------------------
13556 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is
13558 -- Check the type of the complementary operand since the N_Null node
13559 -- has not been decorated yet.
13561 if Nkind (Op) = N_Null
13562 and then Is_Descendant_Of_Address (Etype (Other_Op))
13564 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op)));
13566 end Replace_Null_Operand;
13568 -- Start of processing for Replace_Null_By_Null_Address
13571 pragma Assert (Relaxed_RM_Semantics);
13574 N_Null | N_Op_Eq | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Ne);
13576 if Nkind (N) = N_Null then
13577 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
13581 L : constant Node_Id := Left_Opnd (N);
13582 R : constant Node_Id := Right_Opnd (N);
13585 Replace_Null_Operand (L, Other_Op => R);
13586 Replace_Null_Operand (R, Other_Op => L);
13589 end Replace_Null_By_Null_Address;
13591 --------------------------
13592 -- Has_Tagged_Component --
13593 --------------------------
13595 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
13599 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then
13600 return Has_Tagged_Component (Underlying_Type (Typ));
13602 elsif Is_Array_Type (Typ) then
13603 return Has_Tagged_Component (Component_Type (Typ));
13605 elsif Is_Tagged_Type (Typ) then
13608 elsif Is_Record_Type (Typ) then
13609 Comp := First_Component (Typ);
13610 while Present (Comp) loop
13611 if Has_Tagged_Component (Etype (Comp)) then
13615 Next_Component (Comp);
13623 end Has_Tagged_Component;
13625 --------------------------------------------
13626 -- Has_Unconstrained_Access_Discriminants --
13627 --------------------------------------------
13629 function Has_Unconstrained_Access_Discriminants
13630 (Subtyp : Entity_Id) return Boolean
13635 if Has_Discriminants (Subtyp)
13636 and then not Is_Constrained (Subtyp)
13638 Discr := First_Discriminant (Subtyp);
13639 while Present (Discr) loop
13640 if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
13644 Next_Discriminant (Discr);
13649 end Has_Unconstrained_Access_Discriminants;
13651 -----------------------------
13652 -- Has_Undefined_Reference --
13653 -----------------------------
13655 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is
13656 Has_Undef_Ref : Boolean := False;
13657 -- Flag set when expression Expr contains at least one undefined
13660 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result;
13661 -- Determine whether N denotes a reference and if it does, whether it is
13664 ----------------------------
13665 -- Is_Undefined_Reference --
13666 ----------------------------
13668 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is
13670 if Is_Entity_Name (N)
13671 and then Present (Entity (N))
13672 and then Entity (N) = Any_Id
13674 Has_Undef_Ref := True;
13679 end Is_Undefined_Reference;
13681 procedure Find_Undefined_References is
13682 new Traverse_Proc (Is_Undefined_Reference);
13684 -- Start of processing for Has_Undefined_Reference
13687 Find_Undefined_References (Expr);
13689 return Has_Undef_Ref;
13690 end Has_Undefined_Reference;
13692 ----------------------------
13693 -- Has_Volatile_Component --
13694 ----------------------------
13696 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is
13700 if Has_Volatile_Components (Typ) then
13703 elsif Is_Array_Type (Typ) then
13704 return Is_Volatile (Component_Type (Typ));
13706 elsif Is_Record_Type (Typ) then
13707 Comp := First_Component (Typ);
13708 while Present (Comp) loop
13709 if Is_Volatile_Object (Comp) then
13713 Next_Component (Comp);
13718 end Has_Volatile_Component;
13720 -------------------------
13721 -- Implementation_Kind --
13722 -------------------------
13724 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
13725 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
13728 pragma Assert (Present (Impl_Prag));
13729 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
13730 return Chars (Get_Pragma_Arg (Arg));
13731 end Implementation_Kind;
13733 --------------------------
13734 -- Implements_Interface --
13735 --------------------------
13737 function Implements_Interface
13738 (Typ_Ent : Entity_Id;
13739 Iface_Ent : Entity_Id;
13740 Exclude_Parents : Boolean := False) return Boolean
13742 Ifaces_List : Elist_Id;
13744 Iface : Entity_Id := Base_Type (Iface_Ent);
13745 Typ : Entity_Id := Base_Type (Typ_Ent);
13748 if Is_Class_Wide_Type (Typ) then
13749 Typ := Root_Type (Typ);
13752 if not Has_Interfaces (Typ) then
13756 if Is_Class_Wide_Type (Iface) then
13757 Iface := Root_Type (Iface);
13760 Collect_Interfaces (Typ, Ifaces_List);
13762 Elmt := First_Elmt (Ifaces_List);
13763 while Present (Elmt) loop
13764 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
13765 and then Exclude_Parents
13769 elsif Node (Elmt) = Iface then
13777 end Implements_Interface;
13779 --------------------------------
13780 -- Implicitly_Designated_Type --
13781 --------------------------------
13783 function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id is
13784 Desig : constant Entity_Id := Designated_Type (Typ);
13787 -- An implicit dereference is a legal occurrence of an incomplete type
13788 -- imported through a limited_with clause, if the full view is visible.
13790 if Is_Incomplete_Type (Desig)
13791 and then From_Limited_With (Desig)
13792 and then not From_Limited_With (Scope (Desig))
13794 (Is_Immediately_Visible (Scope (Desig))
13796 (Is_Child_Unit (Scope (Desig))
13797 and then Is_Visible_Lib_Unit (Scope (Desig))))
13799 return Available_View (Desig);
13803 end Implicitly_Designated_Type;
13805 ------------------------------------
13806 -- In_Assertion_Expression_Pragma --
13807 ------------------------------------
13809 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is
13811 Prag : Node_Id := Empty;
13814 -- Climb the parent chain looking for an enclosing pragma
13817 while Present (Par) loop
13818 if Nkind (Par) = N_Pragma then
13822 -- Precondition-like pragmas are expanded into if statements, check
13823 -- the original node instead.
13825 elsif Nkind (Original_Node (Par)) = N_Pragma then
13826 Prag := Original_Node (Par);
13829 -- The expansion of attribute 'Old generates a
constant to capture
13830 -- the result of the prefix. If the parent traversal reaches
13831 -- one of these constants, then the node technically came from a
13832 -- postcondition-like pragma. Note that the Ekind is not tested here
13833 -- because N may be the expression of an object declaration which is
13834 -- currently being analyzed. Such objects carry Ekind of E_Void.
13836 elsif Nkind
(Par
) = N_Object_Declaration
13837 and then Constant_Present
(Par
)
13838 and then Stores_Attribute_Old_Prefix
(Defining_Entity
(Par
))
13842 -- Prevent the search from going too far
13844 elsif Is_Body_Or_Package_Declaration
(Par
) then
13848 Par
:= Parent
(Par
);
13853 and then Assertion_Expression_Pragma
(Get_Pragma_Id
(Prag
));
13854 end In_Assertion_Expression_Pragma
;
13856 -------------------
13857 -- In_Check_Node --
13858 -------------------
13860 function In_Check_Node
(N
: Node_Id
) return Boolean is
13861 Par
: Node_Id
:= Parent
(N
);
13863 while Present
(Par
) loop
13864 if Nkind
(Par
) in N_Raise_xxx_Error
then
13867 -- Prevent the search from going too far
13869 elsif Is_Body_Or_Package_Declaration
(Par
) then
13873 Par
:= Parent
(Par
);
13880 -------------------------------
13881 -- In_Generic_Formal_Package --
13882 -------------------------------
13884 function In_Generic_Formal_Package
(E
: Entity_Id
) return Boolean is
13889 while Present
(Par
) loop
13890 if Nkind
(Par
) = N_Formal_Package_Declaration
13891 or else Nkind
(Original_Node
(Par
)) = N_Formal_Package_Declaration
13896 Par
:= Parent
(Par
);
13900 end In_Generic_Formal_Package
;
13902 ----------------------
13903 -- In_Generic_Scope --
13904 ----------------------
13906 function In_Generic_Scope
(E
: Entity_Id
) return Boolean is
13911 while Present
(S
) and then S
/= Standard_Standard
loop
13912 if Is_Generic_Unit
(S
) then
13920 end In_Generic_Scope
;
13926 function In_Instance
return Boolean is
13927 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
13931 S
:= Current_Scope
;
13932 while Present
(S
) and then S
/= Standard_Standard
loop
13933 if Is_Generic_Instance
(S
) then
13935 -- A child instance is always compiled in the context of a parent
13936 -- instance. Nevertheless, its actuals must not be analyzed in an
13937 -- instance context. We detect this case by examining the current
13938 -- compilation unit, which must be a child instance, and checking
13939 -- that it has not been analyzed yet.
13941 if Is_Child_Unit
(Curr_Unit
)
13942 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
13943 N_Package_Instantiation
13944 and then Ekind
(Curr_Unit
) = E_Void
13958 ----------------------
13959 -- In_Instance_Body --
13960 ----------------------
13962 function In_Instance_Body
return Boolean is
13966 S
:= Current_Scope
;
13967 while Present
(S
) and then S
/= Standard_Standard
loop
13968 if Ekind
(S
) in E_Function | E_Procedure
13969 and then Is_Generic_Instance
(S
)
13973 elsif Ekind
(S
) = E_Package
13974 and then In_Package_Body
(S
)
13975 and then Is_Generic_Instance
(S
)
13984 end In_Instance_Body
;
13986 -----------------------------
13987 -- In_Instance_Not_Visible --
13988 -----------------------------
13990 function In_Instance_Not_Visible
return Boolean is
13994 S
:= Current_Scope
;
13995 while Present
(S
) and then S
/= Standard_Standard
loop
13996 if Ekind
(S
) in E_Function | E_Procedure
13997 and then Is_Generic_Instance
(S
)
14001 elsif Ekind
(S
) = E_Package
14002 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
14003 and then Is_Generic_Instance
(S
)
14012 end In_Instance_Not_Visible
;
14014 ------------------------------
14015 -- In_Instance_Visible_Part --
14016 ------------------------------
14018 function In_Instance_Visible_Part
14019 (Id
: Entity_Id
:= Current_Scope
) return Boolean
14025 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
14026 if Ekind
(Inst
) = E_Package
14027 and then Is_Generic_Instance
(Inst
)
14028 and then not In_Package_Body
(Inst
)
14029 and then not In_Private_Part
(Inst
)
14034 Inst
:= Scope
(Inst
);
14038 end In_Instance_Visible_Part
;
14040 ---------------------
14041 -- In_Package_Body --
14042 ---------------------
14044 function In_Package_Body
return Boolean is
14048 S
:= Current_Scope
;
14049 while Present
(S
) and then S
/= Standard_Standard
loop
14050 if Ekind
(S
) = E_Package
and then In_Package_Body
(S
) then
14058 end In_Package_Body
;
14060 --------------------------
14061 -- In_Pragma_Expression --
14062 --------------------------
14064 function In_Pragma_Expression
(N
: Node_Id
; Nam
: Name_Id
) return Boolean is
14071 elsif Nkind
(P
) = N_Pragma
and then Pragma_Name
(P
) = Nam
then
14077 end In_Pragma_Expression
;
14079 ---------------------------
14080 -- In_Pre_Post_Condition --
14081 ---------------------------
14083 function In_Pre_Post_Condition
(N
: Node_Id
) return Boolean is
14085 Prag
: Node_Id
:= Empty
;
14086 Prag_Id
: Pragma_Id
;
14089 -- Climb the parent chain looking for an enclosing pragma
14092 while Present
(Par
) loop
14093 if Nkind
(Par
) = N_Pragma
then
14097 -- Prevent the search from going too far
14099 elsif Is_Body_Or_Package_Declaration
(Par
) then
14103 Par
:= Parent
(Par
);
14106 if Present
(Prag
) then
14107 Prag_Id
:= Get_Pragma_Id
(Prag
);
14110 Prag_Id
= Pragma_Post
14111 or else Prag_Id
= Pragma_Post_Class
14112 or else Prag_Id
= Pragma_Postcondition
14113 or else Prag_Id
= Pragma_Pre
14114 or else Prag_Id
= Pragma_Pre_Class
14115 or else Prag_Id
= Pragma_Precondition
;
14117 -- Otherwise the node is not enclosed by a pre/postcondition pragma
14122 end In_Pre_Post_Condition
;
14124 ------------------------------
14125 -- In_Quantified_Expression --
14126 ------------------------------
14128 function In_Quantified_Expression
(N
: Node_Id
) return Boolean is
14135 elsif Nkind
(P
) = N_Quantified_Expression
then
14141 end In_Quantified_Expression
;
14143 -------------------------------------
14144 -- In_Reverse_Storage_Order_Object --
14145 -------------------------------------
14147 function In_Reverse_Storage_Order_Object
(N
: Node_Id
) return Boolean is
14149 Btyp
: Entity_Id
:= Empty
;
14152 -- Climb up indexed components
14156 case Nkind
(Pref
) is
14157 when N_Selected_Component
=>
14158 Pref
:= Prefix
(Pref
);
14161 when N_Indexed_Component
=>
14162 Pref
:= Prefix
(Pref
);
14170 if Present
(Pref
) then
14171 Btyp
:= Base_Type
(Etype
(Pref
));
14174 return Present
(Btyp
)
14175 and then (Is_Record_Type
(Btyp
) or else Is_Array_Type
(Btyp
))
14176 and then Reverse_Storage_Order
(Btyp
);
14177 end In_Reverse_Storage_Order_Object
;
14179 ------------------------------
14180 -- In_Same_Declarative_Part --
14181 ------------------------------
14183 function In_Same_Declarative_Part
14184 (Context
: Node_Id
;
14185 N
: Node_Id
) return Boolean
14187 Cont
: Node_Id
:= Context
;
14191 if Nkind
(Cont
) = N_Compilation_Unit_Aux
then
14192 Cont
:= Parent
(Cont
);
14196 while Present
(Nod
) loop
14200 elsif Nkind
(Nod
) in N_Accept_Statement
14201 | N_Block_Statement
14202 | N_Compilation_Unit
14205 | N_Package_Declaration
14207 | N_Subprogram_Body
14212 elsif Nkind
(Nod
) = N_Subunit
then
14213 Nod
:= Corresponding_Stub
(Nod
);
14216 Nod
:= Parent
(Nod
);
14221 end In_Same_Declarative_Part
;
14223 --------------------------------------
14224 -- In_Subprogram_Or_Concurrent_Unit --
14225 --------------------------------------
14227 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
14232 -- Use scope chain to check successively outer scopes
14234 E
:= Current_Scope
;
14238 if K
in Subprogram_Kind
14239 or else K
in Concurrent_Kind
14240 or else K
in Generic_Subprogram_Kind
14244 elsif E
= Standard_Standard
then
14250 end In_Subprogram_Or_Concurrent_Unit
;
14256 function In_Subtree
(N
: Node_Id
; Root
: Node_Id
) return Boolean is
14261 while Present
(Curr
) loop
14262 if Curr
= Root
then
14266 Curr
:= Parent
(Curr
);
14276 function In_Subtree
14279 Root2
: Node_Id
) return Boolean
14285 while Present
(Curr
) loop
14286 if Curr
= Root1
or else Curr
= Root2
then
14290 Curr
:= Parent
(Curr
);
14296 ---------------------
14297 -- In_Return_Value --
14298 ---------------------
14300 function In_Return_Value
(Expr
: Node_Id
) return Boolean is
14302 Prev_Par
: Node_Id
;
14304 In_Function_Call
: Boolean := False;
14307 -- Move through parent nodes to determine if Expr contributes to the
14308 -- return value of the current subprogram.
14312 while Present
(Par
) loop
14314 case Nkind
(Par
) is
14315 -- Ignore ranges and they don't contribute to the result
14320 -- An object declaration whose parent is an extended return
14321 -- statement is a return object.
14323 when N_Object_Declaration
=>
14324 if Present
(Parent
(Par
))
14325 and then Nkind
(Parent
(Par
)) = N_Extended_Return_Statement
14330 -- We hit a simple return statement, so we know we are in one
14332 when N_Simple_Return_Statement
=>
14335 -- Only include one nexting level of function calls
14337 when N_Function_Call
=>
14338 if not In_Function_Call
then
14339 In_Function_Call
:= True;
14344 -- Check if we are on the right-hand side of an assignment
14345 -- statement to a return object.
14347 -- This is not specified in the RM ???
14349 when N_Assignment_Statement
=>
14350 if Prev_Par
= Name
(Par
) then
14355 while Present
(Pre
) loop
14356 if Is_Entity_Name
(Pre
)
14357 and then Is_Return_Object
(Entity
(Pre
))
14362 exit when Nkind
(Pre
) not in N_Selected_Component
14363 | N_Indexed_Component
14366 Pre
:= Prefix
(Pre
);
14369 -- Otherwise, we hit a master which was not relevant
14372 if Is_Master
(Par
) then
14377 -- Iterate up to the next parent, keeping track of the previous one
14380 Par
:= Parent
(Par
);
14384 end In_Return_Value
;
14386 ---------------------
14387 -- In_Visible_Part --
14388 ---------------------
14390 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
14392 return Is_Package_Or_Generic_Package
(Scope_Id
)
14393 and then In_Open_Scopes
(Scope_Id
)
14394 and then not In_Package_Body
(Scope_Id
)
14395 and then not In_Private_Part
(Scope_Id
);
14396 end In_Visible_Part
;
14398 -----------------------------
14399 -- In_While_Loop_Condition --
14400 -----------------------------
14402 function In_While_Loop_Condition
(N
: Node_Id
) return Boolean is
14403 Prev
: Node_Id
:= N
;
14404 P
: Node_Id
:= Parent
(N
);
14405 -- P and Prev will be used for traversing the AST, while maintaining an
14406 -- invariant that P = Parent (Prev).
14411 elsif Nkind
(P
) = N_Iteration_Scheme
14412 and then Prev
= Condition
(P
)
14420 end In_While_Loop_Condition
;
14422 --------------------------------
14423 -- Incomplete_Or_Partial_View --
14424 --------------------------------
14426 function Incomplete_Or_Partial_View
(Id
: Entity_Id
) return Entity_Id
is
14427 function Inspect_Decls
14429 Taft
: Boolean := False) return Entity_Id
;
14430 -- Check whether a declarative region contains the incomplete or partial
14433 -------------------
14434 -- Inspect_Decls --
14435 -------------------
14437 function Inspect_Decls
14439 Taft
: Boolean := False) return Entity_Id
14445 Decl
:= First
(Decls
);
14446 while Present
(Decl
) loop
14449 -- The partial view of a Taft-amendment type is an incomplete
14453 if Nkind
(Decl
) = N_Incomplete_Type_Declaration
then
14454 Match
:= Defining_Identifier
(Decl
);
14457 -- Otherwise look for a private type whose full view matches the
14458 -- input type. Note that this checks full_type_declaration nodes
14459 -- to account for derivations from a private type where the type
14460 -- declaration hold the partial view and the full view is an
14463 elsif Nkind
(Decl
) in N_Full_Type_Declaration
14464 | N_Private_Extension_Declaration
14465 | N_Private_Type_Declaration
14467 Match
:= Defining_Identifier
(Decl
);
14470 -- Guard against unanalyzed entities
14473 and then Is_Type
(Match
)
14474 and then Present
(Full_View
(Match
))
14475 and then Full_View
(Match
) = Id
14490 -- Start of processing for Incomplete_Or_Partial_View
14493 -- Deferred constant or incomplete type case
14495 Prev
:= Current_Entity_In_Scope
(Id
);
14498 and then (Is_Incomplete_Type
(Prev
) or else Ekind
(Prev
) = E_Constant
)
14499 and then Present
(Full_View
(Prev
))
14500 and then Full_View
(Prev
) = Id
14505 -- Private or Taft amendment type case
14508 Pkg
: constant Entity_Id
:= Scope
(Id
);
14509 Pkg_Decl
: Node_Id
:= Pkg
;
14513 and then Is_Package_Or_Generic_Package
(Pkg
)
14515 while Nkind
(Pkg_Decl
) /= N_Package_Specification
loop
14516 Pkg_Decl
:= Parent
(Pkg_Decl
);
14519 -- It is knows that Typ has a private view, look for it in the
14520 -- visible declarations of the enclosing scope. A special case
14521 -- of this is when the two views have been exchanged - the full
14522 -- appears earlier than the private.
14524 if Has_Private_Declaration
(Id
) then
14525 Prev
:= Inspect_Decls
(Visible_Declarations
(Pkg_Decl
));
14527 -- Exchanged view case, look in the private declarations
14530 Prev
:= Inspect_Decls
(Private_Declarations
(Pkg_Decl
));
14535 -- Otherwise if this is the package body, then Typ is a potential
14536 -- Taft amendment type. The incomplete view should be located in
14537 -- the private declarations of the enclosing scope.
14539 elsif In_Package_Body
(Pkg
) then
14540 return Inspect_Decls
(Private_Declarations
(Pkg_Decl
), True);
14545 -- The type has no incomplete or private view
14548 end Incomplete_Or_Partial_View
;
14550 ---------------------------------------
14551 -- Incomplete_View_From_Limited_With --
14552 ---------------------------------------
14554 function Incomplete_View_From_Limited_With
14555 (Typ
: Entity_Id
) return Entity_Id
14558 -- It might make sense to make this an attribute in Einfo, and set it
14559 -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on
14560 -- slots for new attributes, and it seems a bit simpler to just search
14561 -- the Limited_View (if it exists) for an incomplete type whose
14562 -- Non_Limited_View is Typ.
14564 if Ekind
(Scope
(Typ
)) = E_Package
14565 and then Present
(Limited_View
(Scope
(Typ
)))
14568 Ent
: Entity_Id
:= First_Entity
(Limited_View
(Scope
(Typ
)));
14570 while Present
(Ent
) loop
14571 if Is_Incomplete_Type
(Ent
)
14572 and then Non_Limited_View
(Ent
) = Typ
14583 end Incomplete_View_From_Limited_With
;
14585 ----------------------------------
14586 -- Indexed_Component_Bit_Offset --
14587 ----------------------------------
14589 function Indexed_Component_Bit_Offset
(N
: Node_Id
) return Uint
is
14590 Exp
: constant Node_Id
:= First
(Expressions
(N
));
14591 Typ
: constant Entity_Id
:= Etype
(Prefix
(N
));
14592 Off
: constant Uint
:= Component_Size
(Typ
);
14596 -- Return early if the component size is not known or variable
14598 if Off
= No_Uint
or else Off
< Uint_0
then
14602 -- Deal with the degenerate case of an empty component
14604 if Off
= Uint_0
then
14608 -- Check that both the index value and the low bound are known
14610 if not Compile_Time_Known_Value
(Exp
) then
14614 Ind
:= First_Index
(Typ
);
14619 if Nkind
(Ind
) = N_Subtype_Indication
then
14620 Ind
:= Constraint
(Ind
);
14622 if Nkind
(Ind
) = N_Range_Constraint
then
14623 Ind
:= Range_Expression
(Ind
);
14627 if Nkind
(Ind
) /= N_Range
14628 or else not Compile_Time_Known_Value
(Low_Bound
(Ind
))
14633 -- Return the scaled offset
14635 return Off
* (Expr_Value
(Exp
) - Expr_Value
(Low_Bound
((Ind
))));
14636 end Indexed_Component_Bit_Offset
;
14638 -----------------------------
14639 -- Inherit_Predicate_Flags --
14640 -----------------------------
14642 procedure Inherit_Predicate_Flags
(Subt
, Par
: Entity_Id
) is
14644 if Ada_Version
< Ada_2012
14645 or else Present
(Predicate_Function
(Subt
))
14650 Set_Has_Predicates
(Subt
, Has_Predicates
(Par
));
14651 Set_Has_Static_Predicate_Aspect
14652 (Subt
, Has_Static_Predicate_Aspect
(Par
));
14653 Set_Has_Dynamic_Predicate_Aspect
14654 (Subt
, Has_Dynamic_Predicate_Aspect
(Par
));
14656 -- A named subtype does not inherit the predicate function of its
14657 -- parent but an itype declared for a loop index needs the discrete
14658 -- predicate information of its parent to execute the loop properly.
14659 -- A non-discrete type may has a static predicate (for example True)
14660 -- but has no static_discrete_predicate.
14662 if Is_Itype
(Subt
) and then Present
(Predicate_Function
(Par
)) then
14663 Set_Subprograms_For_Type
(Subt
, Subprograms_For_Type
(Par
));
14665 if Has_Static_Predicate
(Par
) and then Is_Discrete_Type
(Par
) then
14666 Set_Static_Discrete_Predicate
14667 (Subt
, Static_Discrete_Predicate
(Par
));
14670 end Inherit_Predicate_Flags
;
14672 ----------------------------
14673 -- Inherit_Rep_Item_Chain --
14674 ----------------------------
14676 procedure Inherit_Rep_Item_Chain
(Typ
: Entity_Id
; From_Typ
: Entity_Id
) is
14678 Next_Item
: Node_Id
;
14681 -- There are several inheritance scenarios to consider depending on
14682 -- whether both types have rep item chains and whether the destination
14683 -- type already inherits part of the source type's rep item chain.
14685 -- 1) The source type lacks a rep item chain
14686 -- From_Typ ---> Empty
14688 -- Typ --------> Item (or Empty)
14690 -- In this case inheritance cannot take place because there are no items
14693 -- 2) The destination type lacks a rep item chain
14694 -- From_Typ ---> Item ---> ...
14696 -- Typ --------> Empty
14698 -- Inheritance takes place by setting the First_Rep_Item of the
14699 -- destination type to the First_Rep_Item of the source type.
14700 -- From_Typ ---> Item ---> ...
14702 -- Typ -----------+
14704 -- 3.1) Both source and destination types have at least one rep item.
14705 -- The destination type does NOT inherit a rep item from the source
14707 -- From_Typ ---> Item ---> Item
14709 -- Typ --------> Item ---> Item
14711 -- Inheritance takes place by setting the Next_Rep_Item of the last item
14712 -- of the destination type to the First_Rep_Item of the source type.
14713 -- From_Typ -------------------> Item ---> Item
14715 -- Typ --------> Item ---> Item --+
14717 -- 3.2) Both source and destination types have at least one rep item.
14718 -- The destination type DOES inherit part of the rep item chain of the
14720 -- From_Typ ---> Item ---> Item ---> Item
14722 -- Typ --------> Item ------+
14724 -- This rare case arises when the full view of a private extension must
14725 -- inherit the rep item chain from the full view of its parent type and
14726 -- the full view of the parent type contains extra rep items. Currently
14727 -- only invariants may lead to such form of inheritance.
14729 -- type From_Typ is tagged private
14730 -- with Type_Invariant'Class => Item_2;
14732 -- type Typ is new From_Typ with private
14733 -- with Type_Invariant => Item_4;
14735 -- At this point the rep item chains contain the following items
14737 -- From_Typ -----------> Item_2 ---> Item_3
14739 -- Typ --------> Item_4 --+
14741 -- The full views of both types may introduce extra invariants
14743 -- type From_Typ is tagged null record
14744 -- with Type_Invariant => Item_1;
14746 -- type Typ is new From_Typ with null record;
14748 -- The full view of Typ would have to inherit any new rep items added to
14749 -- the full view of From_Typ.
14751 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
14753 -- Typ --------> Item_4 --+
14755 -- To achieve this form of inheritance, the destination type must first
14756 -- sever the link between its own rep chain and that of the source type,
14757 -- then inheritance 3.1 takes place.
14759 -- Case 1: The source type lacks a rep item chain
14761 if No
(First_Rep_Item
(From_Typ
)) then
14764 -- Case 2: The destination type lacks a rep item chain
14766 elsif No
(First_Rep_Item
(Typ
)) then
14767 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
14769 -- Case 3: Both the source and destination types have at least one rep
14770 -- item. Traverse the rep item chain of the destination type to find the
14775 Next_Item
:= First_Rep_Item
(Typ
);
14776 while Present
(Next_Item
) loop
14778 -- Detect a link between the destination type's rep chain and that
14779 -- of the source type. There are two possibilities:
14784 -- From_Typ ---> Item_1 --->
14786 -- Typ -----------+
14793 -- From_Typ ---> Item_1 ---> Item_2 --->
14795 -- Typ --------> Item_3 ------+
14799 if Present_In_Rep_Item
(From_Typ
, Next_Item
) then
14804 Next_Item
:= Next_Rep_Item
(Next_Item
);
14807 -- Inherit the source type's rep item chain
14809 if Present
(Item
) then
14810 Set_Next_Rep_Item
(Item
, First_Rep_Item
(From_Typ
));
14812 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
14815 end Inherit_Rep_Item_Chain
;
14817 ------------------------------------
14818 -- Inherits_From_Tagged_Full_View --
14819 ------------------------------------
14821 function Inherits_From_Tagged_Full_View
(Typ
: Entity_Id
) return Boolean is
14823 return Is_Private_Type
(Typ
)
14824 and then Present
(Full_View
(Typ
))
14825 and then Is_Private_Type
(Full_View
(Typ
))
14826 and then not Is_Tagged_Type
(Full_View
(Typ
))
14827 and then Present
(Underlying_Type
(Full_View
(Typ
)))
14828 and then Is_Tagged_Type
(Underlying_Type
(Full_View
(Typ
)));
14829 end Inherits_From_Tagged_Full_View
;
14831 ---------------------------------
14832 -- Insert_Explicit_Dereference --
14833 ---------------------------------
14835 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
14836 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
14837 Ent
: Entity_Id
:= Empty
;
14838 Pref
: Node_Id
:= Empty
;
14844 Save_Interps
(N
, New_Prefix
);
14847 Make_Explicit_Dereference
(Sloc
(Parent
(N
)),
14848 Prefix
=> New_Prefix
));
14850 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
14852 if Is_Overloaded
(New_Prefix
) then
14854 -- The dereference is also overloaded, and its interpretations are
14855 -- the designated types of the interpretations of the original node.
14857 Set_Etype
(N
, Any_Type
);
14859 Get_First_Interp
(New_Prefix
, I
, It
);
14860 while Present
(It
.Nam
) loop
14863 if Is_Access_Type
(T
) then
14864 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
14867 Get_Next_Interp
(I
, It
);
14873 -- Prefix is unambiguous: mark the original prefix (which might
14874 -- Come_From_Source) as a reference, since the new (relocated) one
14875 -- won't be taken into account.
14877 if Is_Entity_Name
(New_Prefix
) then
14878 Ent
:= Entity
(New_Prefix
);
14879 Pref
:= New_Prefix
;
14881 -- For a retrieval of a subcomponent of some composite object,
14882 -- retrieve the ultimate entity if there is one.
14884 elsif Nkind
(New_Prefix
) in N_Selected_Component | N_Indexed_Component
14886 Pref
:= Prefix
(New_Prefix
);
14887 while Present
(Pref
)
14888 and then Nkind
(Pref
) in
14889 N_Selected_Component | N_Indexed_Component
14891 Pref
:= Prefix
(Pref
);
14894 if Present
(Pref
) and then Is_Entity_Name
(Pref
) then
14895 Ent
:= Entity
(Pref
);
14899 -- Place the reference on the entity node
14901 if Present
(Ent
) then
14902 Generate_Reference
(Ent
, Pref
);
14905 end Insert_Explicit_Dereference
;
14907 ------------------------------------------
14908 -- Inspect_Deferred_Constant_Completion --
14909 ------------------------------------------
14911 procedure Inspect_Deferred_Constant_Completion
(Decls
: List_Id
) is
14915 Decl
:= First
(Decls
);
14916 while Present
(Decl
) loop
14918 -- Deferred constant signature
14920 if Nkind
(Decl
) = N_Object_Declaration
14921 and then Constant_Present
(Decl
)
14922 and then No
(Expression
(Decl
))
14924 -- No need to check internally generated constants
14926 and then Comes_From_Source
(Decl
)
14928 -- The constant is not completed. A full object declaration or a
14929 -- pragma Import complete a deferred constant.
14931 and then not Has_Completion
(Defining_Identifier
(Decl
))
14934 ("constant declaration requires initialization expression",
14935 Defining_Identifier
(Decl
));
14940 end Inspect_Deferred_Constant_Completion
;
14942 -------------------------------
14943 -- Install_Elaboration_Model --
14944 -------------------------------
14946 procedure Install_Elaboration_Model
(Unit_Id
: Entity_Id
) is
14947 function Find_Elaboration_Checks_Pragma
(L
: List_Id
) return Node_Id
;
14948 -- Try to find pragma Elaboration_Checks in arbitrary list L. Return
14949 -- Empty if there is no such pragma.
14951 ------------------------------------
14952 -- Find_Elaboration_Checks_Pragma --
14953 ------------------------------------
14955 function Find_Elaboration_Checks_Pragma
(L
: List_Id
) return Node_Id
is
14960 while Present
(Item
) loop
14961 if Nkind
(Item
) = N_Pragma
14962 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
14971 end Find_Elaboration_Checks_Pragma
;
14980 -- Start of processing for Install_Elaboration_Model
14983 -- Nothing to do when the unit does not exist
14985 if No
(Unit_Id
) then
14989 Unit
:= Parent
(Unit_Declaration_Node
(Unit_Id
));
14991 -- Nothing to do when the unit is not a library unit
14993 if Nkind
(Unit
) /= N_Compilation_Unit
then
14997 Prag
:= Find_Elaboration_Checks_Pragma
(Context_Items
(Unit
));
14999 -- The compilation unit is subject to pragma Elaboration_Checks. Set the
15000 -- elaboration model as specified by the pragma.
15002 if Present
(Prag
) then
15003 Args
:= Pragma_Argument_Associations
(Prag
);
15005 -- Guard against an illegal pragma. The sole argument must be an
15006 -- identifier which specifies either Dynamic or Static model.
15008 if Present
(Args
) then
15009 Model
:= Get_Pragma_Arg
(First
(Args
));
15011 if Nkind
(Model
) = N_Identifier
then
15012 Dynamic_Elaboration_Checks
:= Chars
(Model
) = Name_Dynamic
;
15016 end Install_Elaboration_Model
;
15018 -----------------------------
15019 -- Install_Generic_Formals --
15020 -----------------------------
15022 procedure Install_Generic_Formals
(Subp_Id
: Entity_Id
) is
15026 pragma Assert
(Is_Generic_Subprogram
(Subp_Id
));
15028 E
:= First_Entity
(Subp_Id
);
15029 while Present
(E
) loop
15030 Install_Entity
(E
);
15033 end Install_Generic_Formals
;
15035 ------------------------
15036 -- Install_SPARK_Mode --
15037 ------------------------
15039 procedure Install_SPARK_Mode
(Mode
: SPARK_Mode_Type
; Prag
: Node_Id
) is
15041 SPARK_Mode
:= Mode
;
15042 SPARK_Mode_Pragma
:= Prag
;
15043 end Install_SPARK_Mode
;
15045 --------------------------
15046 -- Invalid_Scalar_Value --
15047 --------------------------
15049 function Invalid_Scalar_Value
15051 Scal_Typ
: Scalar_Id
) return Node_Id
15053 function Invalid_Binder_Value
return Node_Id
;
15054 -- Return a reference to the corresponding invalid value for type
15055 -- Scal_Typ as defined in unit System.Scalar_Values.
15057 function Invalid_Float_Value
return Node_Id
;
15058 -- Return the invalid value of float type Scal_Typ
15060 function Invalid_Integer_Value
return Node_Id
;
15061 -- Return the invalid value of integer type Scal_Typ
15063 procedure Set_Invalid_Binder_Values
;
15064 -- Set the contents of collection Invalid_Binder_Values
15066 --------------------------
15067 -- Invalid_Binder_Value --
15068 --------------------------
15070 function Invalid_Binder_Value
return Node_Id
is
15071 Val_Id
: Entity_Id
;
15074 -- Initialize the collection of invalid binder values the first time
15077 Set_Invalid_Binder_Values
;
15079 -- Obtain the corresponding variable from System.Scalar_Values which
15080 -- holds the invalid value for this type.
15082 Val_Id
:= Invalid_Binder_Values
(Scal_Typ
);
15083 pragma Assert
(Present
(Val_Id
));
15085 return New_Occurrence_Of
(Val_Id
, Loc
);
15086 end Invalid_Binder_Value
;
15088 -------------------------
15089 -- Invalid_Float_Value --
15090 -------------------------
15092 function Invalid_Float_Value
return Node_Id
is
15093 Value
: constant Ureal
:= Invalid_Floats
(Scal_Typ
);
15096 -- Pragma Invalid_Scalars did not specify an invalid value for this
15097 -- type. Fall back to the value provided by the binder.
15099 if Value
= No_Ureal
then
15100 return Invalid_Binder_Value
;
15102 return Make_Real_Literal
(Loc
, Realval
=> Value
);
15104 end Invalid_Float_Value
;
15106 ---------------------------
15107 -- Invalid_Integer_Value --
15108 ---------------------------
15110 function Invalid_Integer_Value
return Node_Id
is
15111 Value
: constant Uint
:= Invalid_Integers
(Scal_Typ
);
15114 -- Pragma Invalid_Scalars did not specify an invalid value for this
15115 -- type. Fall back to the value provided by the binder.
15117 if Value
= No_Uint
then
15118 return Invalid_Binder_Value
;
15120 return Make_Integer_Literal
(Loc
, Intval
=> Value
);
15122 end Invalid_Integer_Value
;
15124 -------------------------------
15125 -- Set_Invalid_Binder_Values --
15126 -------------------------------
15128 procedure Set_Invalid_Binder_Values
is
15130 if not Invalid_Binder_Values_Set
then
15131 Invalid_Binder_Values_Set
:= True;
15133 -- Initialize the contents of the collection once since RTE calls
15136 Invalid_Binder_Values
:=
15137 (Name_Short_Float
=> RTE
(RE_IS_Isf
),
15138 Name_Float
=> RTE
(RE_IS_Ifl
),
15139 Name_Long_Float
=> RTE
(RE_IS_Ilf
),
15140 Name_Long_Long_Float
=> RTE
(RE_IS_Ill
),
15141 Name_Signed_8
=> RTE
(RE_IS_Is1
),
15142 Name_Signed_16
=> RTE
(RE_IS_Is2
),
15143 Name_Signed_32
=> RTE
(RE_IS_Is4
),
15144 Name_Signed_64
=> RTE
(RE_IS_Is8
),
15145 Name_Signed_128
=> Empty
,
15146 Name_Unsigned_8
=> RTE
(RE_IS_Iu1
),
15147 Name_Unsigned_16
=> RTE
(RE_IS_Iu2
),
15148 Name_Unsigned_32
=> RTE
(RE_IS_Iu4
),
15149 Name_Unsigned_64
=> RTE
(RE_IS_Iu8
),
15150 Name_Unsigned_128
=> Empty
);
15152 if System_Max_Integer_Size
< 128 then
15153 Invalid_Binder_Values
(Name_Signed_128
) := RTE
(RE_IS_Is8
);
15154 Invalid_Binder_Values
(Name_Unsigned_128
) := RTE
(RE_IS_Iu8
);
15156 Invalid_Binder_Values
(Name_Signed_128
) := RTE
(RE_IS_Is16
);
15157 Invalid_Binder_Values
(Name_Unsigned_128
) := RTE
(RE_IS_Iu16
);
15160 end Set_Invalid_Binder_Values
;
15162 -- Start of processing for Invalid_Scalar_Value
15165 if Scal_Typ
in Float_Scalar_Id
then
15166 return Invalid_Float_Value
;
15168 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
15169 return Invalid_Integer_Value
;
15171 end Invalid_Scalar_Value
;
15173 --------------------------------
15174 -- Is_Anonymous_Access_Actual --
15175 --------------------------------
15177 function Is_Anonymous_Access_Actual
(N
: Node_Id
) return Boolean is
15180 if Ekind
(Etype
(N
)) /= E_Anonymous_Access_Type
then
15185 while Present
(Par
)
15186 and then Nkind
(Par
) in N_Case_Expression
15188 | N_Parameter_Association
15190 Par
:= Parent
(Par
);
15192 return Nkind
(Par
) in N_Subprogram_Call
;
15193 end Is_Anonymous_Access_Actual
;
15195 ------------------------
15196 -- Is_Access_Variable --
15197 ------------------------
15199 function Is_Access_Variable
(E
: Entity_Id
) return Boolean is
15201 return Is_Access_Object_Type
(E
)
15202 and then not Is_Access_Constant
(E
);
15203 end Is_Access_Variable
;
15205 -----------------------------
15206 -- Is_Actual_Out_Parameter --
15207 -----------------------------
15209 function Is_Actual_Out_Parameter
(N
: Node_Id
) return Boolean is
15210 Formal
: Entity_Id
;
15213 Find_Actual
(N
, Formal
, Call
);
15214 return Present
(Formal
) and then Ekind
(Formal
) = E_Out_Parameter
;
15215 end Is_Actual_Out_Parameter
;
15217 --------------------------------
15218 -- Is_Actual_In_Out_Parameter --
15219 --------------------------------
15221 function Is_Actual_In_Out_Parameter
(N
: Node_Id
) return Boolean is
15222 Formal
: Entity_Id
;
15225 Find_Actual
(N
, Formal
, Call
);
15226 return Present
(Formal
) and then Ekind
(Formal
) = E_In_Out_Parameter
;
15227 end Is_Actual_In_Out_Parameter
;
15229 ---------------------------------------
15230 -- Is_Actual_Out_Or_In_Out_Parameter --
15231 ---------------------------------------
15233 function Is_Actual_Out_Or_In_Out_Parameter
(N
: Node_Id
) return Boolean is
15234 Formal
: Entity_Id
;
15237 Find_Actual
(N
, Formal
, Call
);
15238 return Present
(Formal
)
15239 and then Ekind
(Formal
) in E_Out_Parameter | E_In_Out_Parameter
;
15240 end Is_Actual_Out_Or_In_Out_Parameter
;
15242 -------------------------
15243 -- Is_Actual_Parameter --
15244 -------------------------
15246 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
15247 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
15251 when N_Parameter_Association
=>
15252 return N
= Explicit_Actual_Parameter
(Parent
(N
));
15254 when N_Subprogram_Call
=>
15255 return Is_List_Member
(N
)
15257 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
15262 end Is_Actual_Parameter
;
15264 --------------------------------
15265 -- Is_Actual_Tagged_Parameter --
15266 --------------------------------
15268 function Is_Actual_Tagged_Parameter
(N
: Node_Id
) return Boolean is
15269 Formal
: Entity_Id
;
15272 Find_Actual
(N
, Formal
, Call
);
15273 return Present
(Formal
) and then Is_Tagged_Type
(Etype
(Formal
));
15274 end Is_Actual_Tagged_Parameter
;
15276 ---------------------
15277 -- Is_Aliased_View --
15278 ---------------------
15280 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
15284 if Is_Entity_Name
(Obj
) then
15291 or else (Present
(Renamed_Object
(E
))
15292 and then Is_Aliased_View
(Renamed_Object
(E
)))))
15294 or else ((Is_Formal
(E
) or else Is_Formal_Object
(E
))
15295 and then Is_Tagged_Type
(Etype
(E
)))
15297 or else (Is_Concurrent_Type
(E
) and then In_Open_Scopes
(E
))
15299 -- Current instance of type, either directly or as rewritten
15300 -- reference to the current object.
15302 or else (Is_Entity_Name
(Original_Node
(Obj
))
15303 and then Present
(Entity
(Original_Node
(Obj
)))
15304 and then Is_Type
(Entity
(Original_Node
(Obj
))))
15306 or else (Is_Type
(E
) and then E
= Current_Scope
)
15308 or else (Is_Incomplete_Or_Private_Type
(E
)
15309 and then Full_View
(E
) = Current_Scope
)
15311 -- Ada 2012 AI05-0053: the return object of an extended return
15312 -- statement is aliased if its type is immutably limited.
15314 or else (Is_Return_Object
(E
)
15315 and then Is_Limited_View
(Etype
(E
)));
15317 elsif Nkind
(Obj
) = N_Selected_Component
then
15318 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
15320 elsif Nkind
(Obj
) = N_Indexed_Component
then
15321 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
15323 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
15324 and then Has_Aliased_Components
15325 (Designated_Type
(Etype
(Prefix
(Obj
)))));
15327 elsif Nkind
(Obj
) in N_Unchecked_Type_Conversion | N_Type_Conversion
then
15328 return Is_Tagged_Type
(Etype
(Obj
))
15329 and then Is_Aliased_View
(Expression
(Obj
));
15331 -- Ada 202x AI12-0228
15333 elsif Nkind
(Obj
) = N_Qualified_Expression
15334 and then Ada_Version
>= Ada_2012
15336 return Is_Aliased_View
(Expression
(Obj
));
15338 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
15339 return Nkind
(Original_Node
(Obj
)) /= N_Function_Call
;
15344 end Is_Aliased_View
;
15346 -------------------------
15347 -- Is_Ancestor_Package --
15348 -------------------------
15350 function Is_Ancestor_Package
15352 E2
: Entity_Id
) return Boolean
15358 while Present
(Par
) and then Par
/= Standard_Standard
loop
15363 Par
:= Scope
(Par
);
15367 end Is_Ancestor_Package
;
15369 ----------------------
15370 -- Is_Atomic_Object --
15371 ----------------------
15373 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
15374 function Prefix_Has_Atomic_Components
(P
: Node_Id
) return Boolean;
15375 -- Determine whether prefix P has atomic components. This requires the
15376 -- presence of an Atomic_Components aspect/pragma.
15378 ---------------------------------
15379 -- Prefix_Has_Atomic_Components --
15380 ---------------------------------
15382 function Prefix_Has_Atomic_Components
(P
: Node_Id
) return Boolean is
15383 Typ
: constant Entity_Id
:= Etype
(P
);
15386 if Is_Access_Type
(Typ
) then
15387 return Has_Atomic_Components
(Designated_Type
(Typ
));
15389 elsif Has_Atomic_Components
(Typ
) then
15392 elsif Is_Entity_Name
(P
)
15393 and then Has_Atomic_Components
(Entity
(P
))
15400 end Prefix_Has_Atomic_Components
;
15402 -- Start of processing for Is_Atomic_Object
15405 if Is_Entity_Name
(N
) then
15406 return Is_Atomic_Object_Entity
(Entity
(N
));
15408 elsif Is_Atomic
(Etype
(N
)) then
15411 elsif Nkind
(N
) = N_Indexed_Component
then
15412 return Prefix_Has_Atomic_Components
(Prefix
(N
));
15414 elsif Nkind
(N
) = N_Selected_Component
then
15415 return Is_Atomic
(Entity
(Selector_Name
(N
)));
15420 end Is_Atomic_Object
;
15422 -----------------------------
15423 -- Is_Atomic_Object_Entity --
15424 -----------------------------
15426 function Is_Atomic_Object_Entity
(Id
: Entity_Id
) return Boolean is
15430 and then (Is_Atomic
(Id
) or else Is_Atomic
(Etype
(Id
)));
15431 end Is_Atomic_Object_Entity
;
15433 -----------------------------
15434 -- Is_Attribute_Loop_Entry --
15435 -----------------------------
15437 function Is_Attribute_Loop_Entry
(N
: Node_Id
) return Boolean is
15439 return Nkind
(N
) = N_Attribute_Reference
15440 and then Attribute_Name
(N
) = Name_Loop_Entry
;
15441 end Is_Attribute_Loop_Entry
;
15443 ----------------------
15444 -- Is_Attribute_Old --
15445 ----------------------
15447 function Is_Attribute_Old
(N
: Node_Id
) return Boolean is
15449 return Nkind
(N
) = N_Attribute_Reference
15450 and then Attribute_Name
(N
) = Name_Old
;
15451 end Is_Attribute_Old
;
15453 -------------------------
15454 -- Is_Attribute_Result --
15455 -------------------------
15457 function Is_Attribute_Result
(N
: Node_Id
) return Boolean is
15459 return Nkind
(N
) = N_Attribute_Reference
15460 and then Attribute_Name
(N
) = Name_Result
;
15461 end Is_Attribute_Result
;
15463 -------------------------
15464 -- Is_Attribute_Update --
15465 -------------------------
15467 function Is_Attribute_Update
(N
: Node_Id
) return Boolean is
15469 return Nkind
(N
) = N_Attribute_Reference
15470 and then Attribute_Name
(N
) = Name_Update
;
15471 end Is_Attribute_Update
;
15473 ------------------------------------
15474 -- Is_Body_Or_Package_Declaration --
15475 ------------------------------------
15477 function Is_Body_Or_Package_Declaration
(N
: Node_Id
) return Boolean is
15479 return Is_Body
(N
) or else Nkind
(N
) = N_Package_Declaration
;
15480 end Is_Body_Or_Package_Declaration
;
15482 -----------------------
15483 -- Is_Bounded_String --
15484 -----------------------
15486 function Is_Bounded_String
(T
: Entity_Id
) return Boolean is
15487 Under
: constant Entity_Id
:= Underlying_Type
(Root_Type
(T
));
15490 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
15491 -- Super_String, or one of the [Wide_]Wide_ versions. This will
15492 -- be True for all the Bounded_String types in instances of the
15493 -- Generic_Bounded_Length generics, and for types derived from those.
15495 return Present
(Under
)
15496 and then (Is_RTE
(Root_Type
(Under
), RO_SU_Super_String
) or else
15497 Is_RTE
(Root_Type
(Under
), RO_WI_Super_String
) or else
15498 Is_RTE
(Root_Type
(Under
), RO_WW_Super_String
));
15499 end Is_Bounded_String
;
15501 -------------------------------
15502 -- Is_By_Protected_Procedure --
15503 -------------------------------
15505 function Is_By_Protected_Procedure
(Id
: Entity_Id
) return Boolean is
15507 return Ekind
(Id
) = E_Procedure
15508 and then Present
(Get_Rep_Pragma
(Id
, Name_Implemented
))
15509 and then Implementation_Kind
(Id
) = Name_By_Protected_Procedure
;
15510 end Is_By_Protected_Procedure
;
15512 ---------------------
15513 -- Is_CCT_Instance --
15514 ---------------------
15516 function Is_CCT_Instance
15517 (Ref_Id
: Entity_Id
;
15518 Context_Id
: Entity_Id
) return Boolean
15521 pragma Assert
(Ekind
(Ref_Id
) in E_Protected_Type | E_Task_Type
);
15523 if Is_Single_Task_Object
(Context_Id
) then
15524 return Scope_Within_Or_Same
(Etype
(Context_Id
), Ref_Id
);
15528 (Ekind
(Context_Id
) in
15529 E_Entry | E_Entry_Family | E_Function | E_Package |
15530 E_Procedure | E_Protected_Type | E_Task_Type
15531 or else Is_Record_Type
(Context_Id
));
15532 return Scope_Within_Or_Same
(Context_Id
, Ref_Id
);
15534 end Is_CCT_Instance
;
15536 -------------------------
15537 -- Is_Child_Or_Sibling --
15538 -------------------------
15540 function Is_Child_Or_Sibling
15541 (Pack_1
: Entity_Id
;
15542 Pack_2
: Entity_Id
) return Boolean
15544 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
;
15545 -- Given an arbitrary package, return the number of "climbs" necessary
15546 -- to reach scope Standard_Standard.
15548 procedure Equalize_Depths
15549 (Pack
: in out Entity_Id
;
15550 Depth
: in out Nat
;
15551 Depth_To_Reach
: Nat
);
15552 -- Given an arbitrary package, its depth and a target depth to reach,
15553 -- climb the scope chain until the said depth is reached. The pointer
15554 -- to the package and its depth a modified during the climb.
15556 ----------------------------
15557 -- Distance_From_Standard --
15558 ----------------------------
15560 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
is
15567 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
15569 Scop
:= Scope
(Scop
);
15573 end Distance_From_Standard
;
15575 ---------------------
15576 -- Equalize_Depths --
15577 ---------------------
15579 procedure Equalize_Depths
15580 (Pack
: in out Entity_Id
;
15581 Depth
: in out Nat
;
15582 Depth_To_Reach
: Nat
)
15585 -- The package must be at a greater or equal depth
15587 if Depth
< Depth_To_Reach
then
15588 raise Program_Error
;
15591 -- Climb the scope chain until the desired depth is reached
15593 while Present
(Pack
) and then Depth
/= Depth_To_Reach
loop
15594 Pack
:= Scope
(Pack
);
15595 Depth
:= Depth
- 1;
15597 end Equalize_Depths
;
15601 P_1
: Entity_Id
:= Pack_1
;
15602 P_1_Child
: Boolean := False;
15603 P_1_Depth
: Nat
:= Distance_From_Standard
(P_1
);
15604 P_2
: Entity_Id
:= Pack_2
;
15605 P_2_Child
: Boolean := False;
15606 P_2_Depth
: Nat
:= Distance_From_Standard
(P_2
);
15608 -- Start of processing for Is_Child_Or_Sibling
15612 (Ekind
(Pack_1
) = E_Package
and then Ekind
(Pack_2
) = E_Package
);
15614 -- Both packages denote the same entity, therefore they cannot be
15615 -- children or siblings.
15620 -- One of the packages is at a deeper level than the other. Note that
15621 -- both may still come from different hierarchies.
15629 elsif P_1_Depth
> P_2_Depth
then
15632 Depth
=> P_1_Depth
,
15633 Depth_To_Reach
=> P_2_Depth
);
15642 elsif P_2_Depth
> P_1_Depth
then
15645 Depth
=> P_2_Depth
,
15646 Depth_To_Reach
=> P_1_Depth
);
15650 -- At this stage the package pointers have been elevated to the same
15651 -- depth. If the related entities are the same, then one package is a
15652 -- potential child of the other:
15656 -- X became P_1 P_2 or vice versa
15662 return Is_Child_Unit
(Pack_1
);
15664 else pragma Assert
(P_2_Child
);
15665 return Is_Child_Unit
(Pack_2
);
15668 -- The packages may come from the same package chain or from entirely
15669 -- different hierarcies. To determine this, climb the scope stack until
15670 -- a common root is found.
15672 -- (root) (root 1) (root 2)
15677 while Present
(P_1
) and then Present
(P_2
) loop
15679 -- The two packages may be siblings
15682 return Is_Child_Unit
(Pack_1
) and then Is_Child_Unit
(Pack_2
);
15685 P_1
:= Scope
(P_1
);
15686 P_2
:= Scope
(P_2
);
15691 end Is_Child_Or_Sibling
;
15693 -------------------
15694 -- Is_Confirming --
15695 -------------------
15697 function Is_Confirming
(Aspect
: Nonoverridable_Aspect_Id
;
15698 Aspect_Spec_1
, Aspect_Spec_2
: Node_Id
)
15700 function Names_Match
(Nm1
, Nm2
: Node_Id
) return Boolean;
15701 function Names_Match
(Nm1
, Nm2
: Node_Id
) return Boolean is
15703 if Nkind
(Nm1
) /= Nkind
(Nm2
) then
15706 case Nkind
(Nm1
) is
15707 when N_Identifier
=>
15708 return Name_Equals
(Chars
(Nm1
), Chars
(Nm2
));
15709 when N_Expanded_Name
=>
15710 return Names_Match
(Prefix
(Nm1
), Prefix
(Nm2
))
15711 and then Names_Match
(Selector_Name
(Nm1
),
15712 Selector_Name
(Nm2
));
15714 return True; -- needed for Aggregate aspect checking
15717 -- e.g., 'Class attribute references
15718 if Is_Entity_Name
(Nm1
) and Is_Entity_Name
(Nm2
) then
15719 return Entity
(Nm1
) = Entity
(Nm2
);
15722 raise Program_Error
;
15726 -- allow users to disable "shall be confirming" check, at least for now
15727 if Relaxed_RM_Semantics
then
15731 -- ??? Type conversion here (along with "when others =>" below) is a
15732 -- workaround for a bootstrapping problem related to casing on a
15733 -- static-predicate-bearing subtype.
15735 case Aspect_Id
(Aspect
) is
15736 -- name-valued aspects; compare text of names, not resolution.
15737 when Aspect_Default_Iterator
15738 | Aspect_Iterator_Element
15739 | Aspect_Constant_Indexing
15740 | Aspect_Variable_Indexing
15741 | Aspect_Implicit_Dereference
=>
15743 Item_1
: constant Node_Id
:= Aspect_Rep_Item
(Aspect_Spec_1
);
15744 Item_2
: constant Node_Id
:= Aspect_Rep_Item
(Aspect_Spec_2
);
15746 if (Nkind
(Item_1
) /= N_Attribute_Definition_Clause
)
15747 or (Nkind
(Item_2
) /= N_Attribute_Definition_Clause
)
15749 pragma Assert
(Serious_Errors_Detected
> 0);
15753 return Names_Match
(Expression
(Item_1
),
15754 Expression
(Item_2
));
15758 when Aspect_Aggregate
=>
15769 Assign_Indexed_2
: Node_Id
:= Empty
;
15771 Parse_Aspect_Aggregate
15772 (N
=> Expression
(Aspect_Spec_1
),
15773 Empty_Subp
=> Empty_1
,
15774 Add_Named_Subp
=> Add_Named_1
,
15775 Add_Unnamed_Subp
=> Add_Unnamed_1
,
15776 New_Indexed_Subp
=> New_Indexed_1
,
15777 Assign_Indexed_Subp
=> Assign_Indexed_1
);
15778 Parse_Aspect_Aggregate
15779 (N
=> Expression
(Aspect_Spec_2
),
15780 Empty_Subp
=> Empty_2
,
15781 Add_Named_Subp
=> Add_Named_2
,
15782 Add_Unnamed_Subp
=> Add_Unnamed_2
,
15783 New_Indexed_Subp
=> New_Indexed_2
,
15784 Assign_Indexed_Subp
=> Assign_Indexed_2
);
15786 Names_Match
(Empty_1
, Empty_2
) and then
15787 Names_Match
(Add_Named_1
, Add_Named_2
) and then
15788 Names_Match
(Add_Unnamed_1
, Add_Unnamed_2
) and then
15789 Names_Match
(New_Indexed_1
, New_Indexed_2
) and then
15790 Names_Match
(Assign_Indexed_1
, Assign_Indexed_2
);
15793 -- scalar-valued aspects; compare (static) values.
15794 when Aspect_Max_Entry_Queue_Length
-- | Aspect_No_Controlled_Parts
15796 -- This should be unreachable. No_Controlled_Parts is
15797 -- not yet supported at all in GNAT and Max_Entry_Queue_Length
15798 -- is supported only for protected entries, not for types.
15799 pragma Assert
(Serious_Errors_Detected
/= 0);
15803 raise Program_Error
;
15807 -----------------------------
15808 -- Is_Concurrent_Interface --
15809 -----------------------------
15811 function Is_Concurrent_Interface
(T
: Entity_Id
) return Boolean is
15813 return Is_Interface
(T
)
15815 (Is_Protected_Interface
(T
)
15816 or else Is_Synchronized_Interface
(T
)
15817 or else Is_Task_Interface
(T
));
15818 end Is_Concurrent_Interface
;
15820 -----------------------
15821 -- Is_Constant_Bound --
15822 -----------------------
15824 function Is_Constant_Bound
(Exp
: Node_Id
) return Boolean is
15826 if Compile_Time_Known_Value
(Exp
) then
15829 elsif Is_Entity_Name
(Exp
) and then Present
(Entity
(Exp
)) then
15830 return Is_Constant_Object
(Entity
(Exp
))
15831 or else Ekind
(Entity
(Exp
)) = E_Enumeration_Literal
;
15833 elsif Nkind
(Exp
) in N_Binary_Op
then
15834 return Is_Constant_Bound
(Left_Opnd
(Exp
))
15835 and then Is_Constant_Bound
(Right_Opnd
(Exp
))
15836 and then Scope
(Entity
(Exp
)) = Standard_Standard
;
15841 end Is_Constant_Bound
;
15843 ---------------------------
15844 -- Is_Container_Element --
15845 ---------------------------
15847 function Is_Container_Element
(Exp
: Node_Id
) return Boolean is
15848 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
15849 Pref
: constant Node_Id
:= Prefix
(Exp
);
15852 -- Call to an indexing aspect
15854 Cont_Typ
: Entity_Id
;
15855 -- The type of the container being accessed
15857 Elem_Typ
: Entity_Id
;
15858 -- Its element type
15860 Indexing
: Entity_Id
;
15861 Is_Const
: Boolean;
15862 -- Indicates that constant indexing is used, and the element is thus
15865 Ref_Typ
: Entity_Id
;
15866 -- The reference type returned by the indexing operation
15869 -- If C is a container, in a context that imposes the element type of
15870 -- that container, the indexing notation C (X) is rewritten as:
15872 -- Indexing (C, X).Discr.all
15874 -- where Indexing is one of the indexing aspects of the container.
15875 -- If the context does not require a reference, the construct can be
15880 -- First, verify that the construct has the proper form
15882 if not Expander_Active
then
15885 elsif Nkind
(Pref
) /= N_Selected_Component
then
15888 elsif Nkind
(Prefix
(Pref
)) /= N_Function_Call
then
15892 Call
:= Prefix
(Pref
);
15893 Ref_Typ
:= Etype
(Call
);
15896 if not Has_Implicit_Dereference
(Ref_Typ
)
15897 or else No
(First
(Parameter_Associations
(Call
)))
15898 or else not Is_Entity_Name
(Name
(Call
))
15903 -- Retrieve type of container object, and its iterator aspects
15905 Cont_Typ
:= Etype
(First
(Parameter_Associations
(Call
)));
15906 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Constant_Indexing
);
15909 if No
(Indexing
) then
15911 -- Container should have at least one indexing operation
15915 elsif Entity
(Name
(Call
)) /= Entity
(Indexing
) then
15917 -- This may be a variable indexing operation
15919 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Variable_Indexing
);
15922 or else Entity
(Name
(Call
)) /= Entity
(Indexing
)
15931 Elem_Typ
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Iterator_Element
);
15933 if No
(Elem_Typ
) or else Entity
(Elem_Typ
) /= Etype
(Exp
) then
15937 -- Check that the expression is not the target of an assignment, in
15938 -- which case the rewriting is not possible.
15940 if not Is_Const
then
15946 while Present
(Par
)
15948 if Nkind
(Parent
(Par
)) = N_Assignment_Statement
15949 and then Par
= Name
(Parent
(Par
))
15953 -- A renaming produces a reference, and the transformation
15956 elsif Nkind
(Parent
(Par
)) = N_Object_Renaming_Declaration
then
15959 elsif Nkind
(Parent
(Par
)) in
15961 N_Procedure_Call_Statement |
15962 N_Entry_Call_Statement
15964 -- Check that the element is not part of an actual for an
15965 -- in-out parameter.
15972 F
:= First_Formal
(Entity
(Name
(Parent
(Par
))));
15973 A
:= First
(Parameter_Associations
(Parent
(Par
)));
15974 while Present
(F
) loop
15975 if A
= Par
and then Ekind
(F
) /= E_In_Parameter
then
15984 -- E_In_Parameter in a call: element is not modified.
15989 Par
:= Parent
(Par
);
15994 -- The expression has the proper form and the context requires the
15995 -- element type. Retrieve the Element function of the container and
15996 -- rewrite the construct as a call to it.
16002 Op
:= First_Elmt
(Primitive_Operations
(Cont_Typ
));
16003 while Present
(Op
) loop
16004 exit when Chars
(Node
(Op
)) = Name_Element
;
16013 Make_Function_Call
(Loc
,
16014 Name
=> New_Occurrence_Of
(Node
(Op
), Loc
),
16015 Parameter_Associations
=> Parameter_Associations
(Call
)));
16016 Analyze_And_Resolve
(Exp
, Entity
(Elem_Typ
));
16020 end Is_Container_Element
;
16022 ----------------------------
16023 -- Is_Contract_Annotation --
16024 ----------------------------
16026 function Is_Contract_Annotation
(Item
: Node_Id
) return Boolean is
16028 return Is_Package_Contract_Annotation
(Item
)
16030 Is_Subprogram_Contract_Annotation
(Item
);
16031 end Is_Contract_Annotation
;
16033 --------------------------------------
16034 -- Is_Controlling_Limited_Procedure --
16035 --------------------------------------
16037 function Is_Controlling_Limited_Procedure
16038 (Proc_Nam
: Entity_Id
) return Boolean
16041 Param_Typ
: Entity_Id
:= Empty
;
16044 if Ekind
(Proc_Nam
) = E_Procedure
16045 and then Present
(Parameter_Specifications
(Parent
(Proc_Nam
)))
16049 (First
(Parameter_Specifications
(Parent
(Proc_Nam
))));
16051 -- The formal may be an anonymous access type
16053 if Nkind
(Param
) = N_Access_Definition
then
16054 Param_Typ
:= Entity
(Subtype_Mark
(Param
));
16056 Param_Typ
:= Etype
(Param
);
16059 -- In the case where an Itype was created for a dispatchin call, the
16060 -- procedure call has been rewritten. The actual may be an access to
16061 -- interface type in which case it is the designated type that is the
16062 -- controlling type.
16064 elsif Present
(Associated_Node_For_Itype
(Proc_Nam
))
16065 and then Present
(Original_Node
(Associated_Node_For_Itype
(Proc_Nam
)))
16067 Present
(Parameter_Associations
16068 (Associated_Node_For_Itype
(Proc_Nam
)))
16071 Etype
(First
(Parameter_Associations
16072 (Associated_Node_For_Itype
(Proc_Nam
))));
16074 if Ekind
(Param_Typ
) = E_Anonymous_Access_Type
then
16075 Param_Typ
:= Directly_Designated_Type
(Param_Typ
);
16079 if Present
(Param_Typ
) then
16081 Is_Interface
(Param_Typ
)
16082 and then Is_Limited_Record
(Param_Typ
);
16086 end Is_Controlling_Limited_Procedure
;
16088 -----------------------------
16089 -- Is_CPP_Constructor_Call --
16090 -----------------------------
16092 function Is_CPP_Constructor_Call
(N
: Node_Id
) return Boolean is
16094 return Nkind
(N
) = N_Function_Call
16095 and then Is_CPP_Class
(Etype
(Etype
(N
)))
16096 and then Is_Constructor
(Entity
(Name
(N
)))
16097 and then Is_Imported
(Entity
(Name
(N
)));
16098 end Is_CPP_Constructor_Call
;
16100 -------------------------
16101 -- Is_Current_Instance --
16102 -------------------------
16104 function Is_Current_Instance
(N
: Node_Id
) return Boolean is
16105 Typ
: constant Entity_Id
:= Entity
(N
);
16109 -- Simplest case: entity is a concurrent type and we are currently
16110 -- inside the body. This will eventually be expanded into a call to
16111 -- Self (for tasks) or _object (for protected objects).
16113 if Is_Concurrent_Type
(Typ
) and then In_Open_Scopes
(Typ
) then
16117 -- Check whether the context is a (sub)type declaration for the
16121 while Present
(P
) loop
16122 if Nkind
(P
) in N_Full_Type_Declaration
16123 | N_Private_Type_Declaration
16124 | N_Subtype_Declaration
16125 and then Comes_From_Source
(P
)
16126 and then Defining_Entity
(P
) = Typ
16130 -- A subtype name may appear in an aspect specification for a
16131 -- Predicate_Failure aspect, for which we do not construct a
16132 -- wrapper procedure. The subtype will be replaced by the
16133 -- expression being tested when the corresponding predicate
16134 -- check is expanded.
16136 elsif Nkind
(P
) = N_Aspect_Specification
16137 and then Nkind
(Parent
(P
)) = N_Subtype_Declaration
16141 elsif Nkind
(P
) = N_Pragma
16142 and then Get_Pragma_Id
(P
) = Pragma_Predicate_Failure
16151 -- In any other context this is not a current occurrence
16154 end Is_Current_Instance
;
16156 --------------------------------------------------
16157 -- Is_Current_Instance_Reference_In_Type_Aspect --
16158 --------------------------------------------------
16160 function Is_Current_Instance_Reference_In_Type_Aspect
16161 (N
: Node_Id
) return Boolean
16164 -- When a current_instance is referenced within an aspect_specification
16165 -- of a type or subtype, it will show up as a reference to the formal
16166 -- parameter of the aspect's associated subprogram rather than as a
16167 -- reference to the type or subtype itself (in fact, the original name
16168 -- is never even analyzed). We check for predicate, invariant, and
16169 -- Default_Initial_Condition subprograms (in theory there could be
16170 -- other cases added, in which case this function will need updating).
16172 if Is_Entity_Name
(N
) then
16173 return Present
(Entity
(N
))
16174 and then Ekind
(Entity
(N
)) = E_In_Parameter
16175 and then Ekind
(Scope
(Entity
(N
))) in E_Function | E_Procedure
16177 (Is_Predicate_Function
(Scope
(Entity
(N
)))
16178 or else Is_Predicate_Function_M
(Scope
(Entity
(N
)))
16179 or else Is_Invariant_Procedure
(Scope
(Entity
(N
)))
16180 or else Is_Partial_Invariant_Procedure
(Scope
(Entity
(N
)))
16181 or else Is_DIC_Procedure
(Scope
(Entity
(N
))));
16185 when N_Indexed_Component
16189 Is_Current_Instance_Reference_In_Type_Aspect
(Prefix
(N
));
16191 when N_Selected_Component
=>
16193 Is_Current_Instance_Reference_In_Type_Aspect
(Prefix
(N
));
16195 when N_Type_Conversion
=>
16196 return Is_Current_Instance_Reference_In_Type_Aspect
16199 when N_Qualified_Expression
=>
16200 return Is_Current_Instance_Reference_In_Type_Aspect
16207 end Is_Current_Instance_Reference_In_Type_Aspect
;
16209 --------------------
16210 -- Is_Declaration --
16211 --------------------
16213 function Is_Declaration
16215 Body_OK
: Boolean := True;
16216 Concurrent_OK
: Boolean := True;
16217 Formal_OK
: Boolean := True;
16218 Generic_OK
: Boolean := True;
16219 Instantiation_OK
: Boolean := True;
16220 Renaming_OK
: Boolean := True;
16221 Stub_OK
: Boolean := True;
16222 Subprogram_OK
: Boolean := True;
16223 Type_OK
: Boolean := True) return Boolean
16228 -- Body declarations
16230 when N_Proper_Body
=>
16233 -- Concurrent type declarations
16235 when N_Protected_Type_Declaration
16236 | N_Single_Protected_Declaration
16237 | N_Single_Task_Declaration
16238 | N_Task_Type_Declaration
16240 return Concurrent_OK
or Type_OK
;
16242 -- Formal declarations
16244 when N_Formal_Abstract_Subprogram_Declaration
16245 | N_Formal_Concrete_Subprogram_Declaration
16246 | N_Formal_Object_Declaration
16247 | N_Formal_Package_Declaration
16248 | N_Formal_Type_Declaration
16252 -- Generic declarations
16254 when N_Generic_Package_Declaration
16255 | N_Generic_Subprogram_Declaration
16259 -- Generic instantiations
16261 when N_Function_Instantiation
16262 | N_Package_Instantiation
16263 | N_Procedure_Instantiation
16265 return Instantiation_OK
;
16267 -- Generic renaming declarations
16269 when N_Generic_Renaming_Declaration
=>
16270 return Generic_OK
or Renaming_OK
;
16272 -- Renaming declarations
16274 when N_Exception_Renaming_Declaration
16275 | N_Object_Renaming_Declaration
16276 | N_Package_Renaming_Declaration
16277 | N_Subprogram_Renaming_Declaration
16279 return Renaming_OK
;
16281 -- Stub declarations
16283 when N_Body_Stub
=>
16286 -- Subprogram declarations
16288 when N_Abstract_Subprogram_Declaration
16289 | N_Entry_Declaration
16290 | N_Expression_Function
16291 | N_Subprogram_Declaration
16293 return Subprogram_OK
;
16295 -- Type declarations
16297 when N_Full_Type_Declaration
16298 | N_Incomplete_Type_Declaration
16299 | N_Private_Extension_Declaration
16300 | N_Private_Type_Declaration
16301 | N_Subtype_Declaration
16307 when N_Component_Declaration
16308 | N_Exception_Declaration
16309 | N_Implicit_Label_Declaration
16310 | N_Number_Declaration
16311 | N_Object_Declaration
16312 | N_Package_Declaration
16319 end Is_Declaration
;
16321 --------------------------------
16322 -- Is_Declared_Within_Variant --
16323 --------------------------------
16325 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
16326 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
16327 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
16329 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
16330 end Is_Declared_Within_Variant
;
16332 ----------------------------------------------
16333 -- Is_Dependent_Component_Of_Mutable_Object --
16334 ----------------------------------------------
16336 function Is_Dependent_Component_Of_Mutable_Object
16337 (Object
: Node_Id
) return Boolean
16340 Prefix_Type
: Entity_Id
;
16341 P_Aliased
: Boolean := False;
16344 Deref
: Node_Id
:= Original_Node
(Object
);
16345 -- Dereference node, in something like X.all.Y(2)
16347 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
16350 -- Find the dereference node if any
16352 while Nkind
(Deref
) in
16353 N_Indexed_Component | N_Selected_Component | N_Slice
16355 Deref
:= Original_Node
(Prefix
(Deref
));
16358 -- If the prefix is a qualified expression of a variable, then function
16359 -- Is_Variable will return False for that because a qualified expression
16360 -- denotes a constant view, so we need to get the name being qualified
16361 -- so we can test below whether that's a variable (or a dereference).
16363 if Nkind
(Deref
) = N_Qualified_Expression
then
16364 Deref
:= Expression
(Deref
);
16367 -- Ada 2005: If we have a component or slice of a dereference, something
16368 -- like X.all.Y (2) and the type of X is access-to-constant, Is_Variable
16369 -- will return False, because it is indeed a constant view. But it might
16370 -- be a view of a variable object, so we want the following condition to
16371 -- be True in that case.
16373 if Is_Variable
(Object
)
16374 or else Is_Variable
(Deref
)
16376 (Ada_Version
>= Ada_2005
16377 and then (Nkind
(Deref
) = N_Explicit_Dereference
16378 or else (Present
(Etype
(Deref
))
16379 and then Is_Access_Type
(Etype
(Deref
)))))
16381 if Nkind
(Object
) = N_Selected_Component
then
16383 -- If the selector is not a component, then we definitely return
16384 -- False (it could be a function selector in a prefix form call
16385 -- occurring in an iterator specification).
16387 if Ekind
(Entity
(Selector_Name
(Object
))) not in
16388 E_Component | E_Discriminant
16393 -- Get the original node of the prefix in case it has been
16394 -- rewritten, which can occur, for example, in qualified
16395 -- expression cases. Also, a discriminant check on a selected
16396 -- component may be expanded into a dereference when removing
16397 -- side effects, and the subtype of the original node may be
16400 P
:= Original_Node
(Prefix
(Object
));
16401 Prefix_Type
:= Etype
(P
);
16403 -- If the prefix is a qualified expression, we want to look at its
16406 if Nkind
(P
) = N_Qualified_Expression
then
16407 P
:= Expression
(P
);
16408 Prefix_Type
:= Etype
(P
);
16411 if Is_Entity_Name
(P
) then
16412 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
16413 Prefix_Type
:= Base_Type
(Prefix_Type
);
16416 if Is_Aliased
(Entity
(P
)) then
16420 -- For explicit dereferences we get the access prefix so we can
16421 -- treat this similarly to implicit dereferences and examine the
16422 -- kind of the access type and its designated subtype further
16425 elsif Nkind
(P
) = N_Explicit_Dereference
then
16427 Prefix_Type
:= Etype
(P
);
16430 -- Check for prefix being an aliased component???
16435 -- A heap object is constrained by its initial value
16437 -- Ada 2005 (AI-363): Always assume the object could be mutable in
16438 -- the dereferenced case, since the access value might denote an
16439 -- unconstrained aliased object, whereas in Ada 95 the designated
16440 -- object is guaranteed to be constrained. A worst-case assumption
16441 -- has to apply in Ada 2005 because we can't tell at compile
16442 -- time whether the object is "constrained by its initial value",
16443 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
16444 -- rules (these rules are acknowledged to need fixing). We don't
16445 -- impose this more stringent checking for earlier Ada versions or
16446 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's
16447 -- benefit, though it's unclear on why using -gnat95 would not be
16450 if Ada_Version
< Ada_2005
or else Relaxed_RM_Semantics
then
16451 if Is_Access_Type
(Prefix_Type
)
16452 or else Nkind
(P
) = N_Explicit_Dereference
16457 else pragma Assert
(Ada_Version
>= Ada_2005
);
16458 if Is_Access_Type
(Prefix_Type
) then
16459 -- We need to make sure we have the base subtype, in case
16460 -- this is actually an access subtype (whose Ekind will be
16461 -- E_Access_Subtype).
16463 Prefix_Type
:= Etype
(Prefix_Type
);
16465 -- If the access type is pool-specific, and there is no
16466 -- constrained partial view of the designated type, then the
16467 -- designated object is known to be constrained. If it's a
16468 -- formal access type and the renaming is in the generic
16469 -- spec, we also treat it as pool-specific (known to be
16470 -- constrained), but assume the worst if in the generic body
16471 -- (see RM 3.3(23.3/3)).
16473 if Ekind
(Prefix_Type
) = E_Access_Type
16474 and then (not Is_Generic_Type
(Prefix_Type
)
16475 or else not In_Generic_Body
(Current_Scope
))
16476 and then not Object_Type_Has_Constrained_Partial_View
16477 (Typ
=> Designated_Type
(Prefix_Type
),
16478 Scop
=> Current_Scope
)
16482 -- Otherwise (general access type, or there is a constrained
16483 -- partial view of the designated type), we need to check
16484 -- based on the designated type.
16487 Prefix_Type
:= Designated_Type
(Prefix_Type
);
16493 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
16495 -- As per AI-0017, the renaming is illegal in a generic body, even
16496 -- if the subtype is indefinite (only applies to prefixes of an
16497 -- untagged formal type, see RM 3.3 (23.11/3)).
16499 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
16501 if not Is_Constrained
(Prefix_Type
)
16502 and then (Is_Definite_Subtype
(Prefix_Type
)
16504 (not Is_Tagged_Type
(Prefix_Type
)
16505 and then Is_Generic_Type
(Prefix_Type
)
16506 and then In_Generic_Body
(Current_Scope
)))
16508 and then (Is_Declared_Within_Variant
(Comp
)
16509 or else Has_Discriminant_Dependent_Constraint
(Comp
))
16510 and then (not P_Aliased
or else Ada_Version
>= Ada_2005
)
16514 -- If the prefix is of an access type at this point, then we want
16515 -- to return False, rather than calling this function recursively
16516 -- on the access object (which itself might be a discriminant-
16517 -- dependent component of some other object, but that isn't
16518 -- relevant to checking the object passed to us). This avoids
16519 -- issuing wrong errors when compiling with -gnatc, where there
16520 -- can be implicit dereferences that have not been expanded.
16522 elsif Is_Access_Type
(Etype
(Prefix
(Object
))) then
16527 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
16530 elsif Nkind
(Object
) = N_Indexed_Component
16531 or else Nkind
(Object
) = N_Slice
16533 return Is_Dependent_Component_Of_Mutable_Object
16534 (Original_Node
(Prefix
(Object
)));
16536 -- A type conversion that Is_Variable is a view conversion:
16537 -- go back to the denoted object.
16539 elsif Nkind
(Object
) = N_Type_Conversion
then
16541 Is_Dependent_Component_Of_Mutable_Object
16542 (Original_Node
(Expression
(Object
)));
16547 end Is_Dependent_Component_Of_Mutable_Object
;
16549 ---------------------
16550 -- Is_Dereferenced --
16551 ---------------------
16553 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
16554 P
: constant Node_Id
:= Parent
(N
);
16556 return Nkind
(P
) in N_Selected_Component
16557 | N_Explicit_Dereference
16558 | N_Indexed_Component
16560 and then Prefix
(P
) = N
;
16561 end Is_Dereferenced
;
16563 ----------------------
16564 -- Is_Descendant_Of --
16565 ----------------------
16567 function Is_Descendant_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
16572 pragma Assert
(Nkind
(T1
) in N_Entity
);
16573 pragma Assert
(Nkind
(T2
) in N_Entity
);
16575 T
:= Base_Type
(T1
);
16577 -- Immediate return if the types match
16582 -- Comment needed here ???
16584 elsif Ekind
(T
) = E_Class_Wide_Type
then
16585 return Etype
(T
) = T2
;
16593 -- Done if we found the type we are looking for
16598 -- Done if no more derivations to check
16605 -- Following test catches error cases resulting from prev errors
16607 elsif No
(Etyp
) then
16610 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
16613 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
16617 T
:= Base_Type
(Etyp
);
16620 end Is_Descendant_Of
;
16622 ----------------------------------------
16623 -- Is_Descendant_Of_Suspension_Object --
16624 ----------------------------------------
16626 function Is_Descendant_Of_Suspension_Object
16627 (Typ
: Entity_Id
) return Boolean
16629 Cur_Typ
: Entity_Id
;
16630 Par_Typ
: Entity_Id
;
16633 -- Climb the type derivation chain checking each parent type against
16634 -- Suspension_Object.
16636 Cur_Typ
:= Base_Type
(Typ
);
16637 while Present
(Cur_Typ
) loop
16638 Par_Typ
:= Etype
(Cur_Typ
);
16640 -- The current type is a match
16642 if Is_Suspension_Object
(Cur_Typ
) then
16645 -- Stop the traversal once the root of the derivation chain has been
16646 -- reached. In that case the current type is its own base type.
16648 elsif Cur_Typ
= Par_Typ
then
16652 Cur_Typ
:= Base_Type
(Par_Typ
);
16656 end Is_Descendant_Of_Suspension_Object
;
16658 ---------------------------------------------
16659 -- Is_Double_Precision_Floating_Point_Type --
16660 ---------------------------------------------
16662 function Is_Double_Precision_Floating_Point_Type
16663 (E
: Entity_Id
) return Boolean is
16665 return Is_Floating_Point_Type
(E
)
16666 and then Machine_Radix_Value
(E
) = Uint_2
16667 and then Machine_Mantissa_Value
(E
) = UI_From_Int
(53)
16668 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_10
16669 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_10
);
16670 end Is_Double_Precision_Floating_Point_Type
;
16672 -----------------------------
16673 -- Is_Effectively_Volatile --
16674 -----------------------------
16676 function Is_Effectively_Volatile
16678 Ignore_Protected
: Boolean := False) return Boolean is
16680 if Is_Type
(Id
) then
16682 -- An arbitrary type is effectively volatile when it is subject to
16683 -- pragma Atomic or Volatile.
16685 if Is_Volatile
(Id
) then
16688 -- An array type is effectively volatile when it is subject to pragma
16689 -- Atomic_Components or Volatile_Components or its component type is
16690 -- effectively volatile.
16692 elsif Is_Array_Type
(Id
) then
16693 if Has_Volatile_Components
(Id
) then
16697 Anc
: Entity_Id
:= Base_Type
(Id
);
16699 if Is_Private_Type
(Anc
) then
16700 Anc
:= Full_View
(Anc
);
16703 -- Test for presence of ancestor, as the full view of a
16704 -- private type may be missing in case of error.
16706 return Present
(Anc
)
16707 and then Is_Effectively_Volatile
16708 (Component_Type
(Anc
), Ignore_Protected
);
16712 -- A protected type is always volatile unless Ignore_Protected is
16715 elsif Is_Protected_Type
(Id
) and then not Ignore_Protected
then
16718 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is
16719 -- automatically volatile.
16721 elsif Is_Descendant_Of_Suspension_Object
(Id
) then
16724 -- Otherwise the type is not effectively volatile
16730 -- Otherwise Id denotes an object
16732 else pragma Assert
(Is_Object
(Id
));
16733 -- A volatile object for which No_Caching is enabled is not
16734 -- effectively volatile.
16739 (Ekind
(Id
) = E_Variable
and then No_Caching_Enabled
(Id
)))
16740 or else Has_Volatile_Components
(Id
)
16741 or else Is_Effectively_Volatile
(Etype
(Id
), Ignore_Protected
);
16743 end Is_Effectively_Volatile
;
16745 -----------------------------------------
16746 -- Is_Effectively_Volatile_For_Reading --
16747 -----------------------------------------
16749 function Is_Effectively_Volatile_For_Reading
16751 Ignore_Protected
: Boolean := False) return Boolean
16754 -- A concurrent type is effectively volatile for reading, except for a
16755 -- protected type when Ignore_Protected is True.
16757 if Is_Task_Type
(Id
)
16758 or else (Is_Protected_Type
(Id
) and then not Ignore_Protected
)
16762 elsif Is_Effectively_Volatile
(Id
, Ignore_Protected
) then
16764 -- Other volatile types and objects are effectively volatile for
16765 -- reading when they have property Async_Writers or Effective_Reads
16766 -- set to True. This includes the case of an array type whose
16767 -- Volatile_Components aspect is True (hence it is effectively
16768 -- volatile) which does not have the properties Async_Writers
16769 -- and Effective_Reads set to False.
16771 if Async_Writers_Enabled
(Id
)
16772 or else Effective_Reads_Enabled
(Id
)
16776 -- In addition, an array type is effectively volatile for reading
16777 -- when its component type is effectively volatile for reading.
16779 elsif Is_Array_Type
(Id
) then
16781 Anc
: Entity_Id
:= Base_Type
(Id
);
16783 if Is_Private_Type
(Anc
) then
16784 Anc
:= Full_View
(Anc
);
16787 -- Test for presence of ancestor, as the full view of a
16788 -- private type may be missing in case of error.
16790 return Present
(Anc
)
16791 and then Is_Effectively_Volatile_For_Reading
16792 (Component_Type
(Anc
), Ignore_Protected
);
16799 end Is_Effectively_Volatile_For_Reading
;
16801 ------------------------------------
16802 -- Is_Effectively_Volatile_Object --
16803 ------------------------------------
16805 function Is_Effectively_Volatile_Object
(N
: Node_Id
) return Boolean is
16806 function Is_Effectively_Volatile
(E
: Entity_Id
) return Boolean is
16807 (Is_Effectively_Volatile
(E
, Ignore_Protected
=> False));
16809 function Is_Effectively_Volatile_Object_Inst
16810 is new Is_Effectively_Volatile_Object_Shared
(Is_Effectively_Volatile
);
16812 return Is_Effectively_Volatile_Object_Inst
(N
);
16813 end Is_Effectively_Volatile_Object
;
16815 ------------------------------------------------
16816 -- Is_Effectively_Volatile_Object_For_Reading --
16817 ------------------------------------------------
16819 function Is_Effectively_Volatile_Object_For_Reading
16820 (N
: Node_Id
) return Boolean
16822 function Is_Effectively_Volatile_For_Reading
16823 (E
: Entity_Id
) return Boolean
16824 is (Is_Effectively_Volatile_For_Reading
(E
, Ignore_Protected
=> False));
16826 function Is_Effectively_Volatile_Object_For_Reading_Inst
16827 is new Is_Effectively_Volatile_Object_Shared
16828 (Is_Effectively_Volatile_For_Reading
);
16830 return Is_Effectively_Volatile_Object_For_Reading_Inst
(N
);
16831 end Is_Effectively_Volatile_Object_For_Reading
;
16833 -------------------------------------------
16834 -- Is_Effectively_Volatile_Object_Shared --
16835 -------------------------------------------
16837 function Is_Effectively_Volatile_Object_Shared
16838 (N
: Node_Id
) return Boolean
16841 if Is_Entity_Name
(N
) then
16842 return Is_Object
(Entity
(N
))
16843 and then Is_Effectively_Volatile_Entity
(Entity
(N
));
16845 elsif Nkind
(N
) in N_Indexed_Component | N_Slice
then
16846 return Is_Effectively_Volatile_Object_Shared
(Prefix
(N
));
16848 elsif Nkind
(N
) = N_Selected_Component
then
16850 Is_Effectively_Volatile_Object_Shared
(Prefix
(N
))
16852 Is_Effectively_Volatile_Object_Shared
(Selector_Name
(N
));
16854 elsif Nkind
(N
) in N_Qualified_Expression
16855 | N_Unchecked_Type_Conversion
16856 | N_Type_Conversion
16858 return Is_Effectively_Volatile_Object_Shared
(Expression
(N
));
16863 end Is_Effectively_Volatile_Object_Shared
;
16865 -------------------
16866 -- Is_Entry_Body --
16867 -------------------
16869 function Is_Entry_Body
(Id
: Entity_Id
) return Boolean is
16873 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Body
;
16876 --------------------------
16877 -- Is_Entry_Declaration --
16878 --------------------------
16880 function Is_Entry_Declaration
(Id
: Entity_Id
) return Boolean is
16884 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Declaration
;
16885 end Is_Entry_Declaration
;
16887 ------------------------------------
16888 -- Is_Expanded_Priority_Attribute --
16889 ------------------------------------
16891 function Is_Expanded_Priority_Attribute
(E
: Entity_Id
) return Boolean is
16894 Nkind
(E
) = N_Function_Call
16895 and then not Configurable_Run_Time_Mode
16896 and then Nkind
(Original_Node
(E
)) = N_Attribute_Reference
16897 and then (Entity
(Name
(E
)) = RTE
(RE_Get_Ceiling
)
16898 or else Entity
(Name
(E
)) = RTE
(RO_PE_Get_Ceiling
));
16899 end Is_Expanded_Priority_Attribute
;
16901 ----------------------------
16902 -- Is_Expression_Function --
16903 ----------------------------
16905 function Is_Expression_Function
(Subp
: Entity_Id
) return Boolean is
16907 if Ekind
(Subp
) in E_Function | E_Subprogram_Body
then
16909 Nkind
(Original_Node
(Unit_Declaration_Node
(Subp
))) =
16910 N_Expression_Function
;
16914 end Is_Expression_Function
;
16916 ------------------------------------------
16917 -- Is_Expression_Function_Or_Completion --
16918 ------------------------------------------
16920 function Is_Expression_Function_Or_Completion
16921 (Subp
: Entity_Id
) return Boolean
16923 Subp_Decl
: Node_Id
;
16926 if Ekind
(Subp
) = E_Function
then
16927 Subp_Decl
:= Unit_Declaration_Node
(Subp
);
16929 -- The function declaration is either an expression function or is
16930 -- completed by an expression function body.
16933 Is_Expression_Function
(Subp
)
16934 or else (Nkind
(Subp_Decl
) = N_Subprogram_Declaration
16935 and then Present
(Corresponding_Body
(Subp_Decl
))
16936 and then Is_Expression_Function
16937 (Corresponding_Body
(Subp_Decl
)));
16939 elsif Ekind
(Subp
) = E_Subprogram_Body
then
16940 return Is_Expression_Function
(Subp
);
16945 end Is_Expression_Function_Or_Completion
;
16947 -----------------------
16948 -- Is_EVF_Expression --
16949 -----------------------
16951 function Is_EVF_Expression
(N
: Node_Id
) return Boolean is
16952 Orig_N
: constant Node_Id
:= Original_Node
(N
);
16958 -- Detect a reference to a formal parameter of a specific tagged type
16959 -- whose related subprogram is subject to pragma Expresions_Visible with
16962 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
16967 and then Is_Specific_Tagged_Type
(Etype
(Id
))
16968 and then Extensions_Visible_Status
(Id
) =
16969 Extensions_Visible_False
;
16971 -- A case expression is an EVF expression when it contains at least one
16972 -- EVF dependent_expression. Note that a case expression may have been
16973 -- expanded, hence the use of Original_Node.
16975 elsif Nkind
(Orig_N
) = N_Case_Expression
then
16976 Alt
:= First
(Alternatives
(Orig_N
));
16977 while Present
(Alt
) loop
16978 if Is_EVF_Expression
(Expression
(Alt
)) then
16985 -- An if expression is an EVF expression when it contains at least one
16986 -- EVF dependent_expression. Note that an if expression may have been
16987 -- expanded, hence the use of Original_Node.
16989 elsif Nkind
(Orig_N
) = N_If_Expression
then
16990 Expr
:= Next
(First
(Expressions
(Orig_N
)));
16991 while Present
(Expr
) loop
16992 if Is_EVF_Expression
(Expr
) then
16999 -- A qualified expression or a type conversion is an EVF expression when
17000 -- its operand is an EVF expression.
17002 elsif Nkind
(N
) in N_Qualified_Expression
17003 | N_Unchecked_Type_Conversion
17004 | N_Type_Conversion
17006 return Is_EVF_Expression
(Expression
(N
));
17008 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when
17009 -- their prefix denotes an EVF expression.
17011 elsif Nkind
(N
) = N_Attribute_Reference
17012 and then Attribute_Name
(N
) in Name_Loop_Entry
17016 return Is_EVF_Expression
(Prefix
(N
));
17020 end Is_EVF_Expression
;
17026 function Is_False
(U
: Uint
) return Boolean is
17031 ---------------------------
17032 -- Is_Fixed_Model_Number --
17033 ---------------------------
17035 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
17036 S
: constant Ureal
:= Small_Value
(T
);
17037 M
: Urealp
.Save_Mark
;
17042 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
17043 Urealp
.Release
(M
);
17045 end Is_Fixed_Model_Number
;
17047 -----------------------------
17048 -- Is_Full_Access_Object --
17049 -----------------------------
17051 function Is_Full_Access_Object
(N
: Node_Id
) return Boolean is
17053 return Is_Atomic_Object
(N
) or else Is_Volatile_Full_Access_Object
(N
);
17054 end Is_Full_Access_Object
;
17056 -------------------------------
17057 -- Is_Fully_Initialized_Type --
17058 -------------------------------
17060 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
17064 if Is_Scalar_Type
(Typ
) then
17066 -- A scalar type with an aspect Default_Value is fully initialized
17068 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization
17069 -- of a scalar type, but we don't take that into account here, since
17070 -- we don't want these to affect warnings.
17072 return Has_Default_Aspect
(Typ
);
17074 elsif Is_Access_Type
(Typ
) then
17077 elsif Is_Array_Type
(Typ
) then
17078 if Is_Fully_Initialized_Type
(Component_Type
(Typ
))
17079 or else (Ada_Version
>= Ada_2012
and then Has_Default_Aspect
(Typ
))
17084 -- An interesting case, if we have a constrained type one of whose
17085 -- bounds is known to be null, then there are no elements to be
17086 -- initialized, so all the elements are initialized.
17088 if Is_Constrained
(Typ
) then
17091 Indx_Typ
: Entity_Id
;
17092 Lbd
, Hbd
: Node_Id
;
17095 Indx
:= First_Index
(Typ
);
17096 while Present
(Indx
) loop
17097 if Etype
(Indx
) = Any_Type
then
17100 -- If index is a range, use directly
17102 elsif Nkind
(Indx
) = N_Range
then
17103 Lbd
:= Low_Bound
(Indx
);
17104 Hbd
:= High_Bound
(Indx
);
17107 Indx_Typ
:= Etype
(Indx
);
17109 if Is_Private_Type
(Indx_Typ
) then
17110 Indx_Typ
:= Full_View
(Indx_Typ
);
17113 if No
(Indx_Typ
) or else Etype
(Indx_Typ
) = Any_Type
then
17116 Lbd
:= Type_Low_Bound
(Indx_Typ
);
17117 Hbd
:= Type_High_Bound
(Indx_Typ
);
17121 if Compile_Time_Known_Value
(Lbd
)
17123 Compile_Time_Known_Value
(Hbd
)
17125 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
17135 -- If no null indexes, then type is not fully initialized
17141 elsif Is_Record_Type
(Typ
) then
17142 if Has_Discriminants
(Typ
)
17144 Present
(Discriminant_Default_Value
(First_Discriminant
(Typ
)))
17145 and then Is_Fully_Initialized_Variant
(Typ
)
17150 -- We consider bounded string types to be fully initialized, because
17151 -- otherwise we get false alarms when the Data component is not
17152 -- default-initialized.
17154 if Is_Bounded_String
(Typ
) then
17158 -- Controlled records are considered to be fully initialized if
17159 -- there is a user defined Initialize routine. This may not be
17160 -- entirely correct, but as the spec notes, we are guessing here
17161 -- what is best from the point of view of issuing warnings.
17163 if Is_Controlled
(Typ
) then
17165 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
17168 if Present
(Utyp
) then
17170 Init
: constant Entity_Id
:=
17171 (Find_Optional_Prim_Op
17172 (Underlying_Type
(Typ
), Name_Initialize
));
17176 and then Comes_From_Source
(Init
)
17177 and then not In_Predefined_Unit
(Init
)
17181 elsif Has_Null_Extension
(Typ
)
17183 Is_Fully_Initialized_Type
17184 (Etype
(Base_Type
(Typ
)))
17193 -- Otherwise see if all record components are initialized
17199 Ent
:= First_Entity
(Typ
);
17200 while Present
(Ent
) loop
17201 if Ekind
(Ent
) = E_Component
17202 and then (No
(Parent
(Ent
))
17203 or else No
(Expression
(Parent
(Ent
))))
17204 and then not Is_Fully_Initialized_Type
(Etype
(Ent
))
17206 -- Special VM case for tag components, which need to be
17207 -- defined in this case, but are never initialized as VMs
17208 -- are using other dispatching mechanisms. Ignore this
17209 -- uninitialized case. Note that this applies both to the
17210 -- uTag entry and the main vtable pointer (CPP_Class case).
17212 and then (Tagged_Type_Expansion
or else not Is_Tag
(Ent
))
17221 -- No uninitialized components, so type is fully initialized.
17222 -- Note that this catches the case of no components as well.
17226 elsif Is_Concurrent_Type
(Typ
) then
17229 elsif Is_Private_Type
(Typ
) then
17231 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
17237 return Is_Fully_Initialized_Type
(U
);
17244 end Is_Fully_Initialized_Type
;
17246 ----------------------------------
17247 -- Is_Fully_Initialized_Variant --
17248 ----------------------------------
17250 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
17251 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
17252 Constraints
: constant List_Id
:= New_List
;
17253 Components
: constant Elist_Id
:= New_Elmt_List
;
17254 Comp_Elmt
: Elmt_Id
;
17256 Comp_List
: Node_Id
;
17258 Discr_Val
: Node_Id
;
17260 Report_Errors
: Boolean;
17261 pragma Warnings
(Off
, Report_Errors
);
17264 if Serious_Errors_Detected
> 0 then
17268 if Is_Record_Type
(Typ
)
17269 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
17270 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
17272 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
17274 Discr
:= First_Discriminant
(Typ
);
17275 while Present
(Discr
) loop
17276 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
17277 Discr_Val
:= Expression
(Parent
(Discr
));
17279 if Present
(Discr_Val
)
17280 and then Is_OK_Static_Expression
(Discr_Val
)
17282 Append_To
(Constraints
,
17283 Make_Component_Association
(Loc
,
17284 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
17285 Expression
=> New_Copy
(Discr_Val
)));
17293 Next_Discriminant
(Discr
);
17298 Comp_List
=> Comp_List
,
17299 Governed_By
=> Constraints
,
17300 Into
=> Components
,
17301 Report_Errors
=> Report_Errors
);
17303 -- Check that each component present is fully initialized
17305 Comp_Elmt
:= First_Elmt
(Components
);
17306 while Present
(Comp_Elmt
) loop
17307 Comp_Id
:= Node
(Comp_Elmt
);
17309 if Ekind
(Comp_Id
) = E_Component
17310 and then (No
(Parent
(Comp_Id
))
17311 or else No
(Expression
(Parent
(Comp_Id
))))
17312 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
17317 Next_Elmt
(Comp_Elmt
);
17322 elsif Is_Private_Type
(Typ
) then
17324 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
17330 return Is_Fully_Initialized_Variant
(U
);
17337 end Is_Fully_Initialized_Variant
;
17339 ------------------------------------
17340 -- Is_Generic_Declaration_Or_Body --
17341 ------------------------------------
17343 function Is_Generic_Declaration_Or_Body
(Decl
: Node_Id
) return Boolean is
17344 Spec_Decl
: Node_Id
;
17347 -- Package/subprogram body
17349 if Nkind
(Decl
) in N_Package_Body | N_Subprogram_Body
17350 and then Present
(Corresponding_Spec
(Decl
))
17352 Spec_Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(Decl
));
17354 -- Package/subprogram body stub
17356 elsif Nkind
(Decl
) in N_Package_Body_Stub | N_Subprogram_Body_Stub
17357 and then Present
(Corresponding_Spec_Of_Stub
(Decl
))
17360 Unit_Declaration_Node
(Corresponding_Spec_Of_Stub
(Decl
));
17368 -- Rather than inspecting the defining entity of the spec declaration,
17369 -- look at its Nkind. This takes care of the case where the analysis of
17370 -- a generic body modifies the Ekind of its spec to allow for recursive
17374 Nkind
(Spec_Decl
) in N_Generic_Package_Declaration
17375 | N_Generic_Subprogram_Declaration
;
17376 end Is_Generic_Declaration_Or_Body
;
17378 ---------------------------
17379 -- Is_Independent_Object --
17380 ---------------------------
17382 function Is_Independent_Object
(N
: Node_Id
) return Boolean is
17383 function Is_Independent_Object_Entity
(Id
: Entity_Id
) return Boolean;
17384 -- Determine whether arbitrary entity Id denotes an object that is
17387 function Prefix_Has_Independent_Components
(P
: Node_Id
) return Boolean;
17388 -- Determine whether prefix P has independent components. This requires
17389 -- the presence of an Independent_Components aspect/pragma.
17391 ------------------------------------
17392 -- Is_Independent_Object_Entity --
17393 ------------------------------------
17395 function Is_Independent_Object_Entity
(Id
: Entity_Id
) return Boolean is
17399 and then (Is_Independent
(Id
)
17401 Is_Independent
(Etype
(Id
)));
17402 end Is_Independent_Object_Entity
;
17404 -------------------------------------
17405 -- Prefix_Has_Independent_Components --
17406 -------------------------------------
17408 function Prefix_Has_Independent_Components
(P
: Node_Id
) return Boolean
17410 Typ
: constant Entity_Id
:= Etype
(P
);
17413 if Is_Access_Type
(Typ
) then
17414 return Has_Independent_Components
(Designated_Type
(Typ
));
17416 elsif Has_Independent_Components
(Typ
) then
17419 elsif Is_Entity_Name
(P
)
17420 and then Has_Independent_Components
(Entity
(P
))
17427 end Prefix_Has_Independent_Components
;
17429 -- Start of processing for Is_Independent_Object
17432 if Is_Entity_Name
(N
) then
17433 return Is_Independent_Object_Entity
(Entity
(N
));
17435 elsif Is_Independent
(Etype
(N
)) then
17438 elsif Nkind
(N
) = N_Indexed_Component
then
17439 return Prefix_Has_Independent_Components
(Prefix
(N
));
17441 elsif Nkind
(N
) = N_Selected_Component
then
17442 return Prefix_Has_Independent_Components
(Prefix
(N
))
17443 or else Is_Independent
(Entity
(Selector_Name
(N
)));
17448 end Is_Independent_Object
;
17450 ----------------------------
17451 -- Is_Inherited_Operation --
17452 ----------------------------
17454 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
17455 pragma Assert
(Is_Overloadable
(E
));
17456 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
17458 return Kind
= N_Full_Type_Declaration
17459 or else Kind
= N_Private_Extension_Declaration
17460 or else Kind
= N_Subtype_Declaration
17461 or else (Ekind
(E
) = E_Enumeration_Literal
17462 and then Is_Derived_Type
(Etype
(E
)));
17463 end Is_Inherited_Operation
;
17465 -------------------------------------
17466 -- Is_Inherited_Operation_For_Type --
17467 -------------------------------------
17469 function Is_Inherited_Operation_For_Type
17471 Typ
: Entity_Id
) return Boolean
17474 -- Check that the operation has been created by the type declaration
17476 return Is_Inherited_Operation
(E
)
17477 and then Defining_Identifier
(Parent
(E
)) = Typ
;
17478 end Is_Inherited_Operation_For_Type
;
17480 --------------------------------------
17481 -- Is_Inlinable_Expression_Function --
17482 --------------------------------------
17484 function Is_Inlinable_Expression_Function
17485 (Subp
: Entity_Id
) return Boolean
17487 Return_Expr
: Node_Id
;
17490 if Is_Expression_Function_Or_Completion
(Subp
)
17491 and then Has_Pragma_Inline_Always
(Subp
)
17492 and then Needs_No_Actuals
(Subp
)
17493 and then No
(Contract
(Subp
))
17494 and then not Is_Dispatching_Operation
(Subp
)
17495 and then Needs_Finalization
(Etype
(Subp
))
17496 and then not Is_Class_Wide_Type
(Etype
(Subp
))
17497 and then not Has_Invariants
(Etype
(Subp
))
17498 and then Present
(Subprogram_Body
(Subp
))
17499 and then Was_Expression_Function
(Subprogram_Body
(Subp
))
17501 Return_Expr
:= Expression_Of_Expression_Function
(Subp
);
17503 -- The returned object must not have a qualified expression and its
17504 -- nominal subtype must be statically compatible with the result
17505 -- subtype of the expression function.
17508 Nkind
(Return_Expr
) = N_Identifier
17509 and then Etype
(Return_Expr
) = Etype
(Subp
);
17513 end Is_Inlinable_Expression_Function
;
17519 function Is_Iterator
(Typ
: Entity_Id
) return Boolean is
17520 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean;
17521 -- Determine whether type Iter_Typ is a predefined forward or reversible
17524 ----------------------
17525 -- Denotes_Iterator --
17526 ----------------------
17528 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean is
17530 -- Check that the name matches, and that the ultimate ancestor is in
17531 -- a predefined unit, i.e the one that declares iterator interfaces.
17534 Chars
(Iter_Typ
) in Name_Forward_Iterator | Name_Reversible_Iterator
17535 and then In_Predefined_Unit
(Root_Type
(Iter_Typ
));
17536 end Denotes_Iterator
;
17540 Iface_Elmt
: Elmt_Id
;
17543 -- Start of processing for Is_Iterator
17546 -- The type may be a subtype of a descendant of the proper instance of
17547 -- the predefined interface type, so we must use the root type of the
17548 -- given type. The same is done for Is_Reversible_Iterator.
17550 if Is_Class_Wide_Type
(Typ
)
17551 and then Denotes_Iterator
(Root_Type
(Typ
))
17555 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
17558 elsif Present
(Find_Value_Of_Aspect
(Typ
, Aspect_Iterable
)) then
17562 Collect_Interfaces
(Typ
, Ifaces
);
17564 Iface_Elmt
:= First_Elmt
(Ifaces
);
17565 while Present
(Iface_Elmt
) loop
17566 if Denotes_Iterator
(Node
(Iface_Elmt
)) then
17570 Next_Elmt
(Iface_Elmt
);
17577 ----------------------------
17578 -- Is_Iterator_Over_Array --
17579 ----------------------------
17581 function Is_Iterator_Over_Array
(N
: Node_Id
) return Boolean is
17582 Container
: constant Node_Id
:= Name
(N
);
17583 Container_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Container
));
17585 return Is_Array_Type
(Container_Typ
);
17586 end Is_Iterator_Over_Array
;
17592 -- We seem to have a lot of overlapping functions that do similar things
17593 -- (testing for left hand sides or lvalues???).
17595 function Is_LHS
(N
: Node_Id
) return Is_LHS_Result
is
17596 P
: constant Node_Id
:= Parent
(N
);
17599 -- Return True if we are the left hand side of an assignment statement
17601 if Nkind
(P
) = N_Assignment_Statement
then
17602 if Name
(P
) = N
then
17608 -- Case of prefix of indexed or selected component or slice
17610 elsif Nkind
(P
) in N_Indexed_Component | N_Selected_Component | N_Slice
17611 and then N
= Prefix
(P
)
17613 -- Here we have the case where the parent P is N.Q or N(Q .. R).
17614 -- If P is an LHS, then N is also effectively an LHS, but there
17615 -- is an important exception. If N is of an access type, then
17616 -- what we really have is N.all.Q (or N.all(Q .. R)). In either
17617 -- case this makes N.all a left hand side but not N itself.
17619 -- If we don't know the type yet, this is the case where we return
17620 -- Unknown, since the answer depends on the type which is unknown.
17622 if No
(Etype
(N
)) then
17625 -- We have an Etype set, so we can check it
17627 elsif Is_Access_Type
(Etype
(N
)) then
17630 -- OK, not access type case, so just test whole expression
17636 -- All other cases are not left hand sides
17643 -----------------------------
17644 -- Is_Library_Level_Entity --
17645 -----------------------------
17647 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
17649 -- The following is a small optimization, and it also properly handles
17650 -- discriminals, which in task bodies might appear in expressions before
17651 -- the corresponding procedure has been created, and which therefore do
17652 -- not have an assigned scope.
17654 if Is_Formal
(E
) then
17658 -- Normal test is simply that the enclosing dynamic scope is Standard
17660 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
17661 end Is_Library_Level_Entity
;
17663 --------------------------------
17664 -- Is_Limited_Class_Wide_Type --
17665 --------------------------------
17667 function Is_Limited_Class_Wide_Type
(Typ
: Entity_Id
) return Boolean is
17670 Is_Class_Wide_Type
(Typ
)
17671 and then (Is_Limited_Type
(Typ
) or else From_Limited_With
(Typ
));
17672 end Is_Limited_Class_Wide_Type
;
17674 ---------------------------------
17675 -- Is_Local_Variable_Reference --
17676 ---------------------------------
17678 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
17680 if not Is_Entity_Name
(Expr
) then
17685 Ent
: constant Entity_Id
:= Entity
(Expr
);
17686 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
17688 if Ekind
(Ent
) not in E_Variable | E_In_Out_Parameter
then
17691 return Present
(Sub
) and then Sub
= Current_Subprogram
;
17695 end Is_Local_Variable_Reference
;
17701 function Is_Master
(N
: Node_Id
) return Boolean is
17702 Disable_Subexpression_Masters
: constant Boolean := True;
17705 if Nkind
(N
) in N_Subprogram_Body | N_Task_Body | N_Entry_Body
17706 or else Is_Statement
(N
)
17711 -- We avoid returning True when the master is a subexpression described
17712 -- in RM 7.6.1(3/2) for the proposes of accessibility level calculation
17713 -- in Accessibility_Level_Helper.Innermost_Master_Scope_Depth ???
17715 if not Disable_Subexpression_Masters
17716 and then Nkind
(N
) in N_Subexpr
17719 Par
: Node_Id
:= N
;
17721 subtype N_Simple_Statement_Other_Than_Simple_Return
17722 is Node_Kind
with Static_Predicate
=>
17723 N_Simple_Statement_Other_Than_Simple_Return
17724 in N_Abort_Statement
17725 | N_Assignment_Statement
17727 | N_Delay_Statement
17728 | N_Entry_Call_Statement
17732 | N_Raise_Statement
17733 | N_Requeue_Statement
17735 | N_Procedure_Call_Statement
;
17737 while Present
(Par
) loop
17738 Par
:= Parent
(Par
);
17739 if Nkind
(Par
) in N_Subexpr |
17740 N_Simple_Statement_Other_Than_Simple_Return
17753 -----------------------
17754 -- Is_Name_Reference --
17755 -----------------------
17757 function Is_Name_Reference
(N
: Node_Id
) return Boolean is
17759 if Is_Entity_Name
(N
) then
17760 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
));
17764 when N_Indexed_Component
17768 Is_Name_Reference
(Prefix
(N
))
17769 or else Is_Access_Type
(Etype
(Prefix
(N
)));
17771 -- Attributes 'Input, 'Old and 'Result produce objects
17773 when N_Attribute_Reference
=>
17774 return Attribute_Name
(N
) in Name_Input | Name_Old | Name_Result
;
17776 when N_Selected_Component
=>
17778 Is_Name_Reference
(Selector_Name
(N
))
17780 (Is_Name_Reference
(Prefix
(N
))
17781 or else Is_Access_Type
(Etype
(Prefix
(N
))));
17783 when N_Explicit_Dereference
=>
17786 -- A view conversion of a tagged name is a name reference
17788 when N_Type_Conversion
=>
17790 Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
17791 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
17792 and then Is_Name_Reference
(Expression
(N
));
17794 -- An unchecked type conversion is considered to be a name if the
17795 -- operand is a name (this construction arises only as a result of
17796 -- expansion activities).
17798 when N_Unchecked_Type_Conversion
=>
17799 return Is_Name_Reference
(Expression
(N
));
17804 end Is_Name_Reference
;
17806 ------------------------------------
17807 -- Is_Non_Preelaborable_Construct --
17808 ------------------------------------
17810 function Is_Non_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
17812 -- NOTE: the routines within Is_Non_Preelaborable_Construct are
17813 -- intentionally unnested to avoid deep indentation of code.
17815 Non_Preelaborable
: exception;
17816 -- This exception is raised when the construct violates preelaborability
17817 -- to terminate the recursion.
17819 procedure Visit
(Nod
: Node_Id
);
17820 -- Semantically inspect construct Nod to determine whether it violates
17821 -- preelaborability. This routine raises Non_Preelaborable.
17823 procedure Visit_List
(List
: List_Id
);
17824 pragma Inline
(Visit_List
);
17825 -- Invoke Visit on each element of list List. This routine raises
17826 -- Non_Preelaborable.
17828 procedure Visit_Pragma
(Prag
: Node_Id
);
17829 pragma Inline
(Visit_Pragma
);
17830 -- Semantically inspect pragma Prag to determine whether it violates
17831 -- preelaborability. This routine raises Non_Preelaborable.
17833 procedure Visit_Subexpression
(Expr
: Node_Id
);
17834 pragma Inline
(Visit_Subexpression
);
17835 -- Semantically inspect expression Expr to determine whether it violates
17836 -- preelaborability. This routine raises Non_Preelaborable.
17842 procedure Visit
(Nod
: Node_Id
) is
17844 case Nkind
(Nod
) is
17848 when N_Component_Declaration
=>
17850 -- Defining_Identifier is left out because it is not relevant
17851 -- for preelaborability.
17853 Visit
(Component_Definition
(Nod
));
17854 Visit
(Expression
(Nod
));
17856 when N_Derived_Type_Definition
=>
17858 -- Interface_List is left out because it is not relevant for
17859 -- preelaborability.
17861 Visit
(Record_Extension_Part
(Nod
));
17862 Visit
(Subtype_Indication
(Nod
));
17864 when N_Entry_Declaration
=>
17866 -- A protected type with at leat one entry is not preelaborable
17867 -- while task types are never preelaborable. This renders entry
17868 -- declarations non-preelaborable.
17870 raise Non_Preelaborable
;
17872 when N_Full_Type_Declaration
=>
17874 -- Defining_Identifier and Discriminant_Specifications are left
17875 -- out because they are not relevant for preelaborability.
17877 Visit
(Type_Definition
(Nod
));
17879 when N_Function_Instantiation
17880 | N_Package_Instantiation
17881 | N_Procedure_Instantiation
17883 -- Defining_Unit_Name and Name are left out because they are
17884 -- not relevant for preelaborability.
17886 Visit_List
(Generic_Associations
(Nod
));
17888 when N_Object_Declaration
=>
17890 -- Defining_Identifier is left out because it is not relevant
17891 -- for preelaborability.
17893 Visit
(Object_Definition
(Nod
));
17895 if Has_Init_Expression
(Nod
) then
17896 Visit
(Expression
(Nod
));
17898 elsif not Has_Preelaborable_Initialization
17899 (Etype
(Defining_Entity
(Nod
)))
17901 raise Non_Preelaborable
;
17904 when N_Private_Extension_Declaration
17905 | N_Subtype_Declaration
17907 -- Defining_Identifier, Discriminant_Specifications, and
17908 -- Interface_List are left out because they are not relevant
17909 -- for preelaborability.
17911 Visit
(Subtype_Indication
(Nod
));
17913 when N_Protected_Type_Declaration
17914 | N_Single_Protected_Declaration
17916 -- Defining_Identifier, Discriminant_Specifications, and
17917 -- Interface_List are left out because they are not relevant
17918 -- for preelaborability.
17920 Visit
(Protected_Definition
(Nod
));
17922 -- A [single] task type is never preelaborable
17924 when N_Single_Task_Declaration
17925 | N_Task_Type_Declaration
17927 raise Non_Preelaborable
;
17932 Visit_Pragma
(Nod
);
17936 when N_Statement_Other_Than_Procedure_Call
=>
17937 if Nkind
(Nod
) /= N_Null_Statement
then
17938 raise Non_Preelaborable
;
17944 Visit_Subexpression
(Nod
);
17948 when N_Access_To_Object_Definition
=>
17949 Visit
(Subtype_Indication
(Nod
));
17951 when N_Case_Expression_Alternative
=>
17952 Visit
(Expression
(Nod
));
17953 Visit_List
(Discrete_Choices
(Nod
));
17955 when N_Component_Definition
=>
17956 Visit
(Access_Definition
(Nod
));
17957 Visit
(Subtype_Indication
(Nod
));
17959 when N_Component_List
=>
17960 Visit_List
(Component_Items
(Nod
));
17961 Visit
(Variant_Part
(Nod
));
17963 when N_Constrained_Array_Definition
=>
17964 Visit_List
(Discrete_Subtype_Definitions
(Nod
));
17965 Visit
(Component_Definition
(Nod
));
17967 when N_Delta_Constraint
17968 | N_Digits_Constraint
17970 -- Delta_Expression and Digits_Expression are left out because
17971 -- they are not relevant for preelaborability.
17973 Visit
(Range_Constraint
(Nod
));
17975 when N_Discriminant_Specification
=>
17977 -- Defining_Identifier and Expression are left out because they
17978 -- are not relevant for preelaborability.
17980 Visit
(Discriminant_Type
(Nod
));
17982 when N_Generic_Association
=>
17984 -- Selector_Name is left out because it is not relevant for
17985 -- preelaborability.
17987 Visit
(Explicit_Generic_Actual_Parameter
(Nod
));
17989 when N_Index_Or_Discriminant_Constraint
=>
17990 Visit_List
(Constraints
(Nod
));
17992 when N_Iterator_Specification
=>
17994 -- Defining_Identifier is left out because it is not relevant
17995 -- for preelaborability.
17997 Visit
(Name
(Nod
));
17998 Visit
(Subtype_Indication
(Nod
));
18000 when N_Loop_Parameter_Specification
=>
18002 -- Defining_Identifier is left out because it is not relevant
18003 -- for preelaborability.
18005 Visit
(Discrete_Subtype_Definition
(Nod
));
18007 when N_Parameter_Association
=>
18008 Visit
(Explicit_Actual_Parameter
(N
));
18010 when N_Protected_Definition
=>
18012 -- End_Label is left out because it is not relevant for
18013 -- preelaborability.
18015 Visit_List
(Private_Declarations
(Nod
));
18016 Visit_List
(Visible_Declarations
(Nod
));
18018 when N_Range_Constraint
=>
18019 Visit
(Range_Expression
(Nod
));
18021 when N_Record_Definition
18024 -- End_Label, Discrete_Choices, and Interface_List are left out
18025 -- because they are not relevant for preelaborability.
18027 Visit
(Component_List
(Nod
));
18029 when N_Subtype_Indication
=>
18031 -- Subtype_Mark is left out because it is not relevant for
18032 -- preelaborability.
18034 Visit
(Constraint
(Nod
));
18036 when N_Unconstrained_Array_Definition
=>
18038 -- Subtype_Marks is left out because it is not relevant for
18039 -- preelaborability.
18041 Visit
(Component_Definition
(Nod
));
18043 when N_Variant_Part
=>
18045 -- Name is left out because it is not relevant for
18046 -- preelaborability.
18048 Visit_List
(Variants
(Nod
));
18061 procedure Visit_List
(List
: List_Id
) is
18065 if Present
(List
) then
18066 Nod
:= First
(List
);
18067 while Present
(Nod
) loop
18078 procedure Visit_Pragma
(Prag
: Node_Id
) is
18080 case Get_Pragma_Id
(Prag
) is
18082 | Pragma_Assert_And_Cut
18084 | Pragma_Async_Readers
18085 | Pragma_Async_Writers
18086 | Pragma_Attribute_Definition
18088 | Pragma_Constant_After_Elaboration
18090 | Pragma_Deadline_Floor
18091 | Pragma_Dispatching_Domain
18092 | Pragma_Effective_Reads
18093 | Pragma_Effective_Writes
18094 | Pragma_Extensions_Visible
18096 | Pragma_Secondary_Stack_Size
18098 | Pragma_Volatile_Function
18100 Visit_List
(Pragma_Argument_Associations
(Prag
));
18109 -------------------------
18110 -- Visit_Subexpression --
18111 -------------------------
18113 procedure Visit_Subexpression
(Expr
: Node_Id
) is
18114 procedure Visit_Aggregate
(Aggr
: Node_Id
);
18115 pragma Inline
(Visit_Aggregate
);
18116 -- Semantically inspect aggregate Aggr to determine whether it
18117 -- violates preelaborability.
18119 ---------------------
18120 -- Visit_Aggregate --
18121 ---------------------
18123 procedure Visit_Aggregate
(Aggr
: Node_Id
) is
18125 if not Is_Preelaborable_Aggregate
(Aggr
) then
18126 raise Non_Preelaborable
;
18128 end Visit_Aggregate
;
18130 -- Start of processing for Visit_Subexpression
18133 case Nkind
(Expr
) is
18135 | N_Qualified_Expression
18136 | N_Type_Conversion
18137 | N_Unchecked_Expression
18138 | N_Unchecked_Type_Conversion
18140 -- Subpool_Handle_Name and Subtype_Mark are left out because
18141 -- they are not relevant for preelaborability.
18143 Visit
(Expression
(Expr
));
18146 | N_Extension_Aggregate
18148 Visit_Aggregate
(Expr
);
18150 when N_Attribute_Reference
18151 | N_Explicit_Dereference
18154 -- Attribute_Name and Expressions are left out because they are
18155 -- not relevant for preelaborability.
18157 Visit
(Prefix
(Expr
));
18159 when N_Case_Expression
=>
18161 -- End_Span is left out because it is not relevant for
18162 -- preelaborability.
18164 Visit_List
(Alternatives
(Expr
));
18165 Visit
(Expression
(Expr
));
18167 when N_Delta_Aggregate
=>
18168 Visit_Aggregate
(Expr
);
18169 Visit
(Expression
(Expr
));
18171 when N_Expression_With_Actions
=>
18172 Visit_List
(Actions
(Expr
));
18173 Visit
(Expression
(Expr
));
18175 when N_Function_Call
=>
18177 -- Ada 2020 (AI12-0175): Calls to certain functions that are
18178 -- essentially unchecked conversions are preelaborable.
18180 if Ada_Version
>= Ada_2020
18181 and then Nkind
(Expr
) = N_Function_Call
18182 and then Is_Entity_Name
(Name
(Expr
))
18183 and then Is_Preelaborable_Function
(Entity
(Name
(Expr
)))
18185 Visit_List
(Parameter_Associations
(Expr
));
18187 raise Non_Preelaborable
;
18190 when N_If_Expression
=>
18191 Visit_List
(Expressions
(Expr
));
18193 when N_Quantified_Expression
=>
18194 Visit
(Condition
(Expr
));
18195 Visit
(Iterator_Specification
(Expr
));
18196 Visit
(Loop_Parameter_Specification
(Expr
));
18199 Visit
(High_Bound
(Expr
));
18200 Visit
(Low_Bound
(Expr
));
18203 Visit
(Discrete_Range
(Expr
));
18204 Visit
(Prefix
(Expr
));
18210 -- The evaluation of an object name is not preelaborable,
18211 -- unless the name is a static expression (checked further
18212 -- below), or statically denotes a discriminant.
18214 if Is_Entity_Name
(Expr
) then
18215 Object_Name
: declare
18216 Id
: constant Entity_Id
:= Entity
(Expr
);
18219 if Is_Object
(Id
) then
18220 if Ekind
(Id
) = E_Discriminant
then
18223 elsif Ekind
(Id
) in E_Constant | E_In_Parameter
18224 and then Present
(Discriminal_Link
(Id
))
18229 raise Non_Preelaborable
;
18234 -- A non-static expression is not preelaborable
18236 elsif not Is_OK_Static_Expression
(Expr
) then
18237 raise Non_Preelaborable
;
18240 end Visit_Subexpression
;
18242 -- Start of processing for Is_Non_Preelaborable_Construct
18247 -- At this point it is known that the construct is preelaborable
18253 -- The elaboration of the construct performs an action which violates
18254 -- preelaborability.
18256 when Non_Preelaborable
=>
18258 end Is_Non_Preelaborable_Construct
;
18260 ---------------------------------
18261 -- Is_Nontrivial_DIC_Procedure --
18262 ---------------------------------
18264 function Is_Nontrivial_DIC_Procedure
(Id
: Entity_Id
) return Boolean is
18265 Body_Decl
: Node_Id
;
18269 if Ekind
(Id
) = E_Procedure
and then Is_DIC_Procedure
(Id
) then
18271 Unit_Declaration_Node
18272 (Corresponding_Body
(Unit_Declaration_Node
(Id
)));
18274 -- The body of the Default_Initial_Condition procedure must contain
18275 -- at least one statement, otherwise the generation of the subprogram
18278 pragma Assert
(Present
(Handled_Statement_Sequence
(Body_Decl
)));
18280 -- To qualify as nontrivial, the first statement of the procedure
18281 -- must be a check in the form of an if statement. If the original
18282 -- Default_Initial_Condition expression was folded, then the first
18283 -- statement is not a check.
18285 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Body_Decl
)));
18288 Nkind
(Stmt
) = N_If_Statement
18289 and then Nkind
(Original_Node
(Stmt
)) = N_Pragma
;
18293 end Is_Nontrivial_DIC_Procedure
;
18295 -------------------------
18296 -- Is_Null_Record_Type --
18297 -------------------------
18299 function Is_Null_Record_Type
(T
: Entity_Id
) return Boolean is
18300 Decl
: constant Node_Id
:= Parent
(T
);
18302 return Nkind
(Decl
) = N_Full_Type_Declaration
18303 and then Nkind
(Type_Definition
(Decl
)) = N_Record_Definition
18305 (No
(Component_List
(Type_Definition
(Decl
)))
18306 or else Null_Present
(Component_List
(Type_Definition
(Decl
))));
18307 end Is_Null_Record_Type
;
18309 ---------------------
18310 -- Is_Object_Image --
18311 ---------------------
18313 function Is_Object_Image
(Prefix
: Node_Id
) return Boolean is
18315 -- Here we test for the case that the prefix is not a type and assume
18316 -- if it is not then it must be a named value or an object reference.
18317 -- This is because the parser always checks that prefixes of attributes
18320 return not (Is_Entity_Name
(Prefix
) and then Is_Type
(Entity
(Prefix
)));
18321 end Is_Object_Image
;
18323 -------------------------
18324 -- Is_Object_Reference --
18325 -------------------------
18327 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
18328 function Safe_Prefix
(N
: Node_Id
) return Node_Id
;
18329 -- Return Prefix (N) unless it has been rewritten as an
18330 -- N_Raise_xxx_Error node, in which case return its original node.
18336 function Safe_Prefix
(N
: Node_Id
) return Node_Id
is
18338 if Nkind
(Prefix
(N
)) in N_Raise_xxx_Error
then
18339 return Original_Node
(Prefix
(N
));
18346 -- AI12-0068: Note that a current instance reference in a type or
18347 -- subtype's aspect_specification is considered a value, not an object
18348 -- (see RM 8.6(18/5)).
18350 if Is_Entity_Name
(N
) then
18351 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
))
18352 and then not Is_Current_Instance_Reference_In_Type_Aspect
(N
);
18356 when N_Indexed_Component
18360 Is_Object_Reference
(Safe_Prefix
(N
))
18361 or else Is_Access_Type
(Etype
(Safe_Prefix
(N
)));
18363 -- In Ada 95, a function call is a constant object; a procedure
18366 -- Note that predefined operators are functions as well, and so
18367 -- are attributes that are (can be renamed as) functions.
18369 when N_Function_Call
18372 return Etype
(N
) /= Standard_Void_Type
;
18374 -- Attributes references 'Loop_Entry, 'Old, 'Priority and 'Result
18375 -- yield objects, even though they are not functions.
18377 when N_Attribute_Reference
=>
18379 Attribute_Name
(N
) in Name_Loop_Entry
18383 or else Is_Function_Attribute_Name
(Attribute_Name
(N
));
18385 when N_Selected_Component
=>
18387 Is_Object_Reference
(Selector_Name
(N
))
18389 (Is_Object_Reference
(Safe_Prefix
(N
))
18390 or else Is_Access_Type
(Etype
(Safe_Prefix
(N
))));
18392 -- An explicit dereference denotes an object, except that a
18393 -- conditional expression gets turned into an explicit dereference
18394 -- in some cases, and conditional expressions are not object
18397 when N_Explicit_Dereference
=>
18398 return Nkind
(Original_Node
(N
)) not in
18399 N_Case_Expression | N_If_Expression
;
18401 -- A view conversion of a tagged object is an object reference
18403 when N_Type_Conversion
=>
18404 if Ada_Version
<= Ada_2012
then
18405 -- A view conversion of a tagged object is an object
18407 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
18408 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
18409 and then Is_Object_Reference
(Expression
(N
));
18412 -- AI12-0226: In Ada 202x a value conversion of an object is
18415 return Is_Object_Reference
(Expression
(N
));
18418 -- An unchecked type conversion is considered to be an object if
18419 -- the operand is an object (this construction arises only as a
18420 -- result of expansion activities).
18422 when N_Unchecked_Type_Conversion
=>
18425 -- AI05-0003: In Ada 2012 a qualified expression is a name.
18426 -- This allows disambiguation of function calls and the use
18427 -- of aggregates in more contexts.
18429 when N_Qualified_Expression
=>
18430 return Ada_Version
>= Ada_2012
18431 and then Is_Object_Reference
(Expression
(N
));
18433 -- In Ada 95 an aggregate is an object reference
18436 | N_Delta_Aggregate
18437 | N_Extension_Aggregate
18439 return Ada_Version
>= Ada_95
;
18441 -- A string literal is not an object reference, but it might come
18442 -- from rewriting of an object reference, e.g. from folding of an
18445 when N_String_Literal
=>
18446 return Is_Rewrite_Substitution
(N
)
18447 and then Is_Object_Reference
(Original_Node
(N
));
18449 -- AI12-0125: Target name represents a constant object
18451 when N_Target_Name
=>
18458 end Is_Object_Reference
;
18460 -----------------------------------
18461 -- Is_OK_Variable_For_Out_Formal --
18462 -----------------------------------
18464 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
18466 Note_Possible_Modification
(AV
, Sure
=> True);
18468 -- We must reject parenthesized variable names. Comes_From_Source is
18469 -- checked because there are currently cases where the compiler violates
18470 -- this rule (e.g. passing a task object to its controlled Initialize
18471 -- routine). This should be properly documented in sinfo???
18473 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
18476 -- A variable is always allowed
18478 elsif Is_Variable
(AV
) then
18481 -- Generalized indexing operations are rewritten as explicit
18482 -- dereferences, and it is only during resolution that we can
18483 -- check whether the context requires an access_to_variable type.
18485 elsif Nkind
(AV
) = N_Explicit_Dereference
18486 and then Present
(Etype
(Original_Node
(AV
)))
18487 and then Has_Implicit_Dereference
(Etype
(Original_Node
(AV
)))
18488 and then Ada_Version
>= Ada_2012
18490 return not Is_Access_Constant
(Etype
(Prefix
(AV
)));
18492 -- Unchecked conversions are allowed only if they come from the
18493 -- generated code, which sometimes uses unchecked conversions for out
18494 -- parameters in cases where code generation is unaffected. We tell
18495 -- source unchecked conversions by seeing if they are rewrites of
18496 -- an original Unchecked_Conversion function call, or of an explicit
18497 -- conversion of a function call or an aggregate (as may happen in the
18498 -- expansion of a packed array aggregate).
18500 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
18501 if Nkind
(Original_Node
(AV
)) in N_Function_Call | N_Aggregate
then
18504 elsif Comes_From_Source
(AV
)
18505 and then Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
18509 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
18510 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
18516 -- Normal type conversions are allowed if argument is a variable
18518 elsif Nkind
(AV
) = N_Type_Conversion
then
18519 if Is_Variable
(Expression
(AV
))
18520 and then Paren_Count
(Expression
(AV
)) = 0
18522 Note_Possible_Modification
(Expression
(AV
), Sure
=> True);
18525 -- We also allow a non-parenthesized expression that raises
18526 -- constraint error if it rewrites what used to be a variable
18528 elsif Raises_Constraint_Error
(Expression
(AV
))
18529 and then Paren_Count
(Expression
(AV
)) = 0
18530 and then Is_Variable
(Original_Node
(Expression
(AV
)))
18534 -- Type conversion of something other than a variable
18540 -- If this node is rewritten, then test the original form, if that is
18541 -- OK, then we consider the rewritten node OK (for example, if the
18542 -- original node is a conversion, then Is_Variable will not be true
18543 -- but we still want to allow the conversion if it converts a variable).
18545 elsif Is_Rewrite_Substitution
(AV
) then
18546 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
18548 -- All other non-variables are rejected
18553 end Is_OK_Variable_For_Out_Formal
;
18555 ----------------------------
18556 -- Is_OK_Volatile_Context --
18557 ----------------------------
18559 function Is_OK_Volatile_Context
18560 (Context
: Node_Id
;
18561 Obj_Ref
: Node_Id
) return Boolean
18563 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean;
18564 -- Determine whether an arbitrary node denotes a call to a protected
18565 -- entry, function, or procedure in prefixed form where the prefix is
18568 function Within_Check
(Nod
: Node_Id
) return Boolean;
18569 -- Determine whether an arbitrary node appears in a check node
18571 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean;
18572 -- Determine whether an arbitrary entity appears in a volatile function
18574 ---------------------------------
18575 -- Is_Protected_Operation_Call --
18576 ---------------------------------
18578 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean is
18583 -- A call to a protected operations retains its selected component
18584 -- form as opposed to other prefixed calls that are transformed in
18587 if Nkind
(Nod
) = N_Selected_Component
then
18588 Pref
:= Prefix
(Nod
);
18589 Subp
:= Selector_Name
(Nod
);
18593 and then Present
(Etype
(Pref
))
18594 and then Is_Protected_Type
(Etype
(Pref
))
18595 and then Is_Entity_Name
(Subp
)
18596 and then Present
(Entity
(Subp
))
18597 and then Ekind
(Entity
(Subp
)) in
18598 E_Entry | E_Entry_Family | E_Function | E_Procedure
;
18602 end Is_Protected_Operation_Call
;
18608 function Within_Check
(Nod
: Node_Id
) return Boolean is
18612 -- Climb the parent chain looking for a check node
18615 while Present
(Par
) loop
18616 if Nkind
(Par
) in N_Raise_xxx_Error
then
18619 -- Prevent the search from going too far
18621 elsif Is_Body_Or_Package_Declaration
(Par
) then
18625 Par
:= Parent
(Par
);
18631 ------------------------------
18632 -- Within_Volatile_Function --
18633 ------------------------------
18635 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean is
18636 Func_Id
: Entity_Id
;
18639 -- Traverse the scope stack looking for a [generic] function
18642 while Present
(Func_Id
) and then Func_Id
/= Standard_Standard
loop
18643 if Ekind
(Func_Id
) in E_Function | E_Generic_Function
then
18644 return Is_Volatile_Function
(Func_Id
);
18647 Func_Id
:= Scope
(Func_Id
);
18651 end Within_Volatile_Function
;
18655 Obj_Id
: Entity_Id
;
18657 -- Start of processing for Is_OK_Volatile_Context
18660 -- The volatile object appears on either side of an assignment
18662 if Nkind
(Context
) = N_Assignment_Statement
then
18665 -- The volatile object is part of the initialization expression of
18668 elsif Nkind
(Context
) = N_Object_Declaration
18669 and then Present
(Expression
(Context
))
18670 and then Expression
(Context
) = Obj_Ref
18671 and then Nkind
(Parent
(Context
)) /= N_Expression_With_Actions
18673 Obj_Id
:= Defining_Entity
(Context
);
18675 -- The volatile object acts as the initialization expression of an
18676 -- extended return statement. This is valid context as long as the
18677 -- function is volatile.
18679 if Is_Return_Object
(Obj_Id
) then
18680 return Within_Volatile_Function
(Obj_Id
);
18682 -- Otherwise this is a normal object initialization
18688 -- The volatile object acts as the name of a renaming declaration
18690 elsif Nkind
(Context
) = N_Object_Renaming_Declaration
18691 and then Name
(Context
) = Obj_Ref
18695 -- The volatile object appears as an actual parameter in a call to an
18696 -- instance of Unchecked_Conversion whose result is renamed.
18698 elsif Nkind
(Context
) = N_Function_Call
18699 and then Is_Entity_Name
(Name
(Context
))
18700 and then Is_Unchecked_Conversion_Instance
(Entity
(Name
(Context
)))
18701 and then Nkind
(Parent
(Context
)) = N_Object_Renaming_Declaration
18705 -- The volatile object is actually the prefix in a protected entry,
18706 -- function, or procedure call.
18708 elsif Is_Protected_Operation_Call
(Context
) then
18711 -- The volatile object appears as the expression of a simple return
18712 -- statement that applies to a volatile function.
18714 elsif Nkind
(Context
) = N_Simple_Return_Statement
18715 and then Expression
(Context
) = Obj_Ref
18718 Within_Volatile_Function
(Return_Statement_Entity
(Context
));
18720 -- The volatile object appears as the prefix of a name occurring in a
18721 -- non-interfering context.
18723 elsif Nkind
(Context
) in
18724 N_Attribute_Reference |
18725 N_Explicit_Dereference |
18726 N_Indexed_Component |
18727 N_Selected_Component |
18729 and then Prefix
(Context
) = Obj_Ref
18730 and then Is_OK_Volatile_Context
18731 (Context
=> Parent
(Context
),
18732 Obj_Ref
=> Context
)
18736 -- The volatile object appears as the prefix of attributes Address,
18737 -- Alignment, Component_Size, First, First_Bit, Last, Last_Bit, Length,
18738 -- Position, Size, Storage_Size.
18740 elsif Nkind
(Context
) = N_Attribute_Reference
18741 and then Prefix
(Context
) = Obj_Ref
18742 and then Attribute_Name
(Context
) in Name_Address
18744 | Name_Component_Size
18752 | Name_Storage_Size
18756 -- The volatile object appears as the expression of a type conversion
18757 -- occurring in a non-interfering context.
18759 elsif Nkind
(Context
) in N_Qualified_Expression
18760 | N_Type_Conversion
18761 | N_Unchecked_Type_Conversion
18762 and then Expression
(Context
) = Obj_Ref
18763 and then Is_OK_Volatile_Context
18764 (Context
=> Parent
(Context
),
18765 Obj_Ref
=> Context
)
18769 -- The volatile object appears as the expression in a delay statement
18771 elsif Nkind
(Context
) in N_Delay_Statement
then
18774 -- Allow references to volatile objects in various checks. This is not a
18775 -- direct SPARK 2014 requirement.
18777 elsif Within_Check
(Context
) then
18780 -- Assume that references to effectively volatile objects that appear
18781 -- as actual parameters in a subprogram call are always legal. A full
18782 -- legality check is done when the actuals are resolved (see routine
18783 -- Resolve_Actuals).
18785 elsif Within_Subprogram_Call
(Context
) then
18788 -- Otherwise the context is not suitable for an effectively volatile
18794 end Is_OK_Volatile_Context
;
18796 ------------------------------------
18797 -- Is_Package_Contract_Annotation --
18798 ------------------------------------
18800 function Is_Package_Contract_Annotation
(Item
: Node_Id
) return Boolean is
18804 if Nkind
(Item
) = N_Aspect_Specification
then
18805 Nam
:= Chars
(Identifier
(Item
));
18807 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
18808 Nam
:= Pragma_Name
(Item
);
18811 return Nam
= Name_Abstract_State
18812 or else Nam
= Name_Initial_Condition
18813 or else Nam
= Name_Initializes
18814 or else Nam
= Name_Refined_State
;
18815 end Is_Package_Contract_Annotation
;
18817 -----------------------------------
18818 -- Is_Partially_Initialized_Type --
18819 -----------------------------------
18821 function Is_Partially_Initialized_Type
18823 Include_Implicit
: Boolean := True) return Boolean
18826 if Is_Scalar_Type
(Typ
) then
18827 return Has_Default_Aspect
(Base_Type
(Typ
));
18829 elsif Is_Access_Type
(Typ
) then
18830 return Include_Implicit
;
18832 elsif Is_Array_Type
(Typ
) then
18834 -- If component type is partially initialized, so is array type
18836 if Has_Default_Aspect
(Base_Type
(Typ
))
18837 or else Is_Partially_Initialized_Type
18838 (Component_Type
(Typ
), Include_Implicit
)
18842 -- Otherwise we are only partially initialized if we are fully
18843 -- initialized (this is the empty array case, no point in us
18844 -- duplicating that code here).
18847 return Is_Fully_Initialized_Type
(Typ
);
18850 elsif Is_Record_Type
(Typ
) then
18852 -- A discriminated type is always partially initialized if in
18855 if Has_Discriminants
(Typ
) and then Include_Implicit
then
18858 -- A tagged type is always partially initialized
18860 elsif Is_Tagged_Type
(Typ
) then
18863 -- Case of non-discriminated record
18869 Component_Present
: Boolean := False;
18870 -- Set True if at least one component is present. If no
18871 -- components are present, then record type is fully
18872 -- initialized (another odd case, like the null array).
18875 -- Loop through components
18877 Comp
:= First_Component
(Typ
);
18878 while Present
(Comp
) loop
18879 Component_Present
:= True;
18881 -- If a component has an initialization expression then the
18882 -- enclosing record type is partially initialized
18884 if Present
(Parent
(Comp
))
18885 and then Present
(Expression
(Parent
(Comp
)))
18889 -- If a component is of a type which is itself partially
18890 -- initialized, then the enclosing record type is also.
18892 elsif Is_Partially_Initialized_Type
18893 (Etype
(Comp
), Include_Implicit
)
18898 Next_Component
(Comp
);
18901 -- No initialized components found. If we found any components
18902 -- they were all uninitialized so the result is false.
18904 if Component_Present
then
18907 -- But if we found no components, then all the components are
18908 -- initialized so we consider the type to be initialized.
18916 -- Concurrent types are always fully initialized
18918 elsif Is_Concurrent_Type
(Typ
) then
18921 -- For a private type, go to underlying type. If there is no underlying
18922 -- type then just assume this partially initialized. Not clear if this
18923 -- can happen in a non-error case, but no harm in testing for this.
18925 elsif Is_Private_Type
(Typ
) then
18927 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
18932 return Is_Partially_Initialized_Type
(U
, Include_Implicit
);
18936 -- For any other type (are there any?) assume partially initialized
18941 end Is_Partially_Initialized_Type
;
18943 ------------------------------------
18944 -- Is_Potentially_Persistent_Type --
18945 ------------------------------------
18947 function Is_Potentially_Persistent_Type
(T
: Entity_Id
) return Boolean is
18952 -- For private type, test corresponding full type
18954 if Is_Private_Type
(T
) then
18955 return Is_Potentially_Persistent_Type
(Full_View
(T
));
18957 -- Scalar types are potentially persistent
18959 elsif Is_Scalar_Type
(T
) then
18962 -- Record type is potentially persistent if not tagged and the types of
18963 -- all it components are potentially persistent, and no component has
18964 -- an initialization expression.
18966 elsif Is_Record_Type
(T
)
18967 and then not Is_Tagged_Type
(T
)
18968 and then not Is_Partially_Initialized_Type
(T
)
18970 Comp
:= First_Component
(T
);
18971 while Present
(Comp
) loop
18972 if not Is_Potentially_Persistent_Type
(Etype
(Comp
)) then
18975 Next_Entity
(Comp
);
18981 -- Array type is potentially persistent if its component type is
18982 -- potentially persistent and if all its constraints are static.
18984 elsif Is_Array_Type
(T
) then
18985 if not Is_Potentially_Persistent_Type
(Component_Type
(T
)) then
18989 Indx
:= First_Index
(T
);
18990 while Present
(Indx
) loop
18991 if not Is_OK_Static_Subtype
(Etype
(Indx
)) then
19000 -- All other types are not potentially persistent
19005 end Is_Potentially_Persistent_Type
;
19007 --------------------------------
19008 -- Is_Potentially_Unevaluated --
19009 --------------------------------
19011 function Is_Potentially_Unevaluated
(N
: Node_Id
) return Boolean is
19012 function Has_Null_Others_Choice
(Aggr
: Node_Id
) return Boolean;
19013 -- Aggr is an array aggregate with static bounds and an others clause;
19014 -- return True if the others choice of the given array aggregate does
19015 -- not cover any component (i.e. is null).
19017 function Immediate_Context_Implies_Is_Potentially_Unevaluated
19018 (Expr
: Node_Id
) return Boolean;
19019 -- Return True if the *immediate* context of this expression tells us
19020 -- that it is potentially unevaluated; return False if the *immediate*
19021 -- context doesn't provide an answer to this question and we need to
19024 function Non_Static_Or_Null_Range
(N
: Node_Id
) return Boolean;
19025 -- Return True if the given range is nonstatic or null
19027 ----------------------------
19028 -- Has_Null_Others_Choice --
19029 ----------------------------
19031 function Has_Null_Others_Choice
(Aggr
: Node_Id
) return Boolean is
19032 Idx
: constant Node_Id
:= First_Index
(Etype
(Aggr
));
19033 Hiv
: constant Uint
:= Expr_Value
(Type_High_Bound
(Etype
(Idx
)));
19034 Lov
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Etype
(Idx
)));
19038 Intervals
: constant Interval_Lists
.Discrete_Interval_List
:=
19039 Interval_Lists
.Aggregate_Intervals
(Aggr
);
19042 -- The others choice is null if, after normalization, we
19043 -- have a single interval covering the whole aggregate.
19045 return Intervals
'Length = 1
19047 Intervals
(Intervals
'First).Low
= Lov
19049 Intervals
(Intervals
'First).High
= Hiv
;
19052 -- If the aggregate is malformed (that is, indexes are not disjoint)
19053 -- then no action is needed at this stage; the error will be reported
19054 -- later by the frontend.
19057 when Interval_Lists
.Intervals_Error
=>
19059 end Has_Null_Others_Choice
;
19061 ----------------------------------------------------------
19062 -- Immediate_Context_Implies_Is_Potentially_Unevaluated --
19063 ----------------------------------------------------------
19065 function Immediate_Context_Implies_Is_Potentially_Unevaluated
19066 (Expr
: Node_Id
) return Boolean
19068 Par
: constant Node_Id
:= Parent
(Expr
);
19070 function Aggregate_Type
return Node_Id
is (Etype
(Parent
(Par
)));
19072 if Nkind
(Par
) = N_If_Expression
then
19073 return Is_Elsif
(Par
) or else Expr
/= First
(Expressions
(Par
));
19075 elsif Nkind
(Par
) = N_Case_Expression
then
19076 return Expr
/= Expression
(Par
);
19078 elsif Nkind
(Par
) in N_And_Then | N_Or_Else
then
19079 return Expr
= Right_Opnd
(Par
);
19081 elsif Nkind
(Par
) in N_In | N_Not_In
then
19083 -- If the membership includes several alternatives, only the first
19084 -- is definitely evaluated.
19086 if Present
(Alternatives
(Par
)) then
19087 return Expr
/= First
(Alternatives
(Par
));
19089 -- If this is a range membership both bounds are evaluated
19095 elsif Nkind
(Par
) = N_Quantified_Expression
then
19096 return Expr
= Condition
(Par
);
19098 elsif Nkind
(Par
) = N_Component_Association
19099 and then Expr
= Expression
(Par
)
19100 and then Nkind
(Parent
(Par
))
19101 in N_Aggregate | N_Delta_Aggregate | N_Extension_Aggregate
19102 and then Present
(Aggregate_Type
)
19103 and then Aggregate_Type
/= Any_Composite
19105 if Is_Array_Type
(Aggregate_Type
) then
19106 if Ada_Version
>= Ada_2020
then
19107 -- For Ada_2020, this predicate returns True for
19108 -- any "repeatedly evaluated" expression.
19114 In_Others_Choice
: Boolean := False;
19115 Array_Agg
: constant Node_Id
:= Parent
(Par
);
19117 -- The expression of an array_component_association is
19118 -- potentially unevaluated if the associated choice is a
19119 -- subtype_indication or range that defines a nonstatic or
19122 Choice
:= First
(Choices
(Par
));
19123 while Present
(Choice
) loop
19124 if Nkind
(Choice
) = N_Range
19125 and then Non_Static_Or_Null_Range
(Choice
)
19129 elsif Nkind
(Choice
) = N_Identifier
19130 and then Present
(Scalar_Range
(Etype
(Choice
)))
19132 Non_Static_Or_Null_Range
19133 (Scalar_Range
(Etype
(Choice
)))
19137 elsif Nkind
(Choice
) = N_Others_Choice
then
19138 In_Others_Choice
:= True;
19144 -- It is also potentially unevaluated if the associated
19145 -- choice is an others choice and the applicable index
19146 -- constraint is nonstatic or null.
19148 if In_Others_Choice
then
19149 if not Compile_Time_Known_Bounds
(Aggregate_Type
) then
19152 return Has_Null_Others_Choice
(Array_Agg
);
19157 elsif Is_Container_Aggregate
(Parent
(Par
)) then
19158 -- a component of a container aggregate
19167 end Immediate_Context_Implies_Is_Potentially_Unevaluated
;
19169 ------------------------------
19170 -- Non_Static_Or_Null_Range --
19171 ------------------------------
19173 function Non_Static_Or_Null_Range
(N
: Node_Id
) return Boolean is
19174 Low
, High
: Node_Id
;
19177 Get_Index_Bounds
(N
, Low
, High
);
19179 -- Check static bounds
19181 if not Compile_Time_Known_Value
(Low
)
19182 or else not Compile_Time_Known_Value
(High
)
19186 -- Check null range
19188 elsif Expr_Value
(High
) < Expr_Value
(Low
) then
19193 end Non_Static_Or_Null_Range
;
19200 -- Start of processing for Is_Potentially_Unevaluated
19206 -- A postcondition whose expression is a short-circuit is broken down
19207 -- into individual aspects for better exception reporting. The original
19208 -- short-circuit expression is rewritten as the second operand, and an
19209 -- occurrence of 'Old in that operand is potentially unevaluated.
19210 -- See sem_ch13.adb for details of this transformation. The reference
19211 -- to 'Old may appear within an expression, so we must look for the
19212 -- enclosing pragma argument in the tree that contains the reference.
19214 while Present
(Par
)
19215 and then Nkind
(Par
) /= N_Pragma_Argument_Association
19217 if Is_Rewrite_Substitution
(Par
)
19218 and then Nkind
(Original_Node
(Par
)) = N_And_Then
19223 Par
:= Parent
(Par
);
19226 -- Other cases; 'Old appears within other expression (not the top-level
19227 -- conjunct in a postcondition) with a potentially unevaluated operand.
19229 Par
:= Parent
(Expr
);
19231 while Present
(Par
)
19232 and then Nkind
(Par
) /= N_Pragma_Argument_Association
19234 if Comes_From_Source
(Par
)
19236 Immediate_Context_Implies_Is_Potentially_Unevaluated
(Expr
)
19240 -- For component associations continue climbing; it may be part of
19241 -- an array aggregate.
19243 elsif Nkind
(Par
) = N_Component_Association
then
19246 -- If the context is not an expression, or if is the result of
19247 -- expansion of an enclosing construct (such as another attribute)
19248 -- the predicate does not apply.
19250 elsif Nkind
(Par
) = N_Case_Expression_Alternative
then
19253 elsif Nkind
(Par
) not in N_Subexpr
19254 or else not Comes_From_Source
(Par
)
19260 Par
:= Parent
(Par
);
19264 end Is_Potentially_Unevaluated
;
19266 -----------------------------------------
19267 -- Is_Predefined_Dispatching_Operation --
19268 -----------------------------------------
19270 function Is_Predefined_Dispatching_Operation
19271 (E
: Entity_Id
) return Boolean
19273 TSS_Name
: TSS_Name_Type
;
19276 if not Is_Dispatching_Operation
(E
) then
19280 Get_Name_String
(Chars
(E
));
19282 -- Most predefined primitives have internally generated names. Equality
19283 -- must be treated differently; the predefined operation is recognized
19284 -- as a homogeneous binary operator that returns Boolean.
19286 if Name_Len
> TSS_Name_Type
'Last then
19289 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
19291 if Chars
(E
) in Name_uAssign | Name_uSize
19293 (Chars
(E
) = Name_Op_Eq
19294 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
19295 or else TSS_Name
= TSS_Deep_Adjust
19296 or else TSS_Name
= TSS_Deep_Finalize
19297 or else TSS_Name
= TSS_Stream_Input
19298 or else TSS_Name
= TSS_Stream_Output
19299 or else TSS_Name
= TSS_Stream_Read
19300 or else TSS_Name
= TSS_Stream_Write
19301 or else TSS_Name
= TSS_Put_Image
19302 or else Is_Predefined_Interface_Primitive
(E
)
19309 end Is_Predefined_Dispatching_Operation
;
19311 ---------------------------------------
19312 -- Is_Predefined_Interface_Primitive --
19313 ---------------------------------------
19315 function Is_Predefined_Interface_Primitive
(E
: Entity_Id
) return Boolean is
19317 -- In VM targets we don't restrict the functionality of this test to
19318 -- compiling in Ada 2005 mode since in VM targets any tagged type has
19319 -- these primitives.
19321 return (Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
)
19322 and then Chars
(E
) in Name_uDisp_Asynchronous_Select
19323 | Name_uDisp_Conditional_Select
19324 | Name_uDisp_Get_Prim_Op_Kind
19325 | Name_uDisp_Get_Task_Id
19326 | Name_uDisp_Requeue
19327 | Name_uDisp_Timed_Select
;
19328 end Is_Predefined_Interface_Primitive
;
19330 ---------------------------------------
19331 -- Is_Predefined_Internal_Operation --
19332 ---------------------------------------
19334 function Is_Predefined_Internal_Operation
19335 (E
: Entity_Id
) return Boolean
19337 TSS_Name
: TSS_Name_Type
;
19340 if not Is_Dispatching_Operation
(E
) then
19344 Get_Name_String
(Chars
(E
));
19346 -- Most predefined primitives have internally generated names. Equality
19347 -- must be treated differently; the predefined operation is recognized
19348 -- as a homogeneous binary operator that returns Boolean.
19350 if Name_Len
> TSS_Name_Type
'Last then
19353 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
19355 if Chars
(E
) in Name_uSize | Name_uAssign
19357 (Chars
(E
) = Name_Op_Eq
19358 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
19359 or else TSS_Name
= TSS_Deep_Adjust
19360 or else TSS_Name
= TSS_Deep_Finalize
19361 or else Is_Predefined_Interface_Primitive
(E
)
19368 end Is_Predefined_Internal_Operation
;
19370 --------------------------------
19371 -- Is_Preelaborable_Aggregate --
19372 --------------------------------
19374 function Is_Preelaborable_Aggregate
(Aggr
: Node_Id
) return Boolean is
19375 Aggr_Typ
: constant Entity_Id
:= Etype
(Aggr
);
19376 Array_Aggr
: constant Boolean := Is_Array_Type
(Aggr_Typ
);
19378 Anc_Part
: Node_Id
;
19381 Comp_Typ
: Entity_Id
:= Empty
; -- init to avoid warning
19386 Comp_Typ
:= Component_Type
(Aggr_Typ
);
19389 -- Inspect the ancestor part
19391 if Nkind
(Aggr
) = N_Extension_Aggregate
then
19392 Anc_Part
:= Ancestor_Part
(Aggr
);
19394 -- The ancestor denotes a subtype mark
19396 if Is_Entity_Name
(Anc_Part
)
19397 and then Is_Type
(Entity
(Anc_Part
))
19399 if not Has_Preelaborable_Initialization
(Entity
(Anc_Part
)) then
19403 -- Otherwise the ancestor denotes an expression
19405 elsif not Is_Preelaborable_Construct
(Anc_Part
) then
19410 -- Inspect the positional associations
19412 Expr
:= First
(Expressions
(Aggr
));
19413 while Present
(Expr
) loop
19414 if not Is_Preelaborable_Construct
(Expr
) then
19421 -- Inspect the named associations
19423 Assoc
:= First
(Component_Associations
(Aggr
));
19424 while Present
(Assoc
) loop
19426 -- Inspect the choices of the current named association
19428 Choice
:= First
(Choices
(Assoc
));
19429 while Present
(Choice
) loop
19432 -- For a choice to be preelaborable, it must denote either a
19433 -- static range or a static expression.
19435 if Nkind
(Choice
) = N_Others_Choice
then
19438 elsif Nkind
(Choice
) = N_Range
then
19439 if not Is_OK_Static_Range
(Choice
) then
19443 elsif not Is_OK_Static_Expression
(Choice
) then
19448 Comp_Typ
:= Etype
(Choice
);
19454 -- The type of the choice must have preelaborable initialization if
19455 -- the association carries a <>.
19457 pragma Assert
(Present
(Comp_Typ
));
19458 if Box_Present
(Assoc
) then
19459 if not Has_Preelaborable_Initialization
(Comp_Typ
) then
19463 -- The type of the expression must have preelaborable initialization
19465 elsif not Is_Preelaborable_Construct
(Expression
(Assoc
)) then
19472 -- At this point the aggregate is preelaborable
19475 end Is_Preelaborable_Aggregate
;
19477 --------------------------------
19478 -- Is_Preelaborable_Construct --
19479 --------------------------------
19481 function Is_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
19485 if Nkind
(N
) in N_Aggregate | N_Extension_Aggregate
then
19486 return Is_Preelaborable_Aggregate
(N
);
19488 -- Attributes are allowed in general, even if their prefix is a formal
19489 -- type. It seems that certain attributes known not to be static might
19490 -- not be allowed, but there are no rules to prevent them.
19492 elsif Nkind
(N
) = N_Attribute_Reference
then
19497 elsif Nkind
(N
) in N_Subexpr
and then Is_OK_Static_Expression
(N
) then
19500 elsif Nkind
(N
) = N_Qualified_Expression
then
19501 return Is_Preelaborable_Construct
(Expression
(N
));
19503 -- Names are preelaborable when they denote a discriminant of an
19504 -- enclosing type. Discriminals are also considered for this check.
19506 elsif Is_Entity_Name
(N
)
19507 and then Present
(Entity
(N
))
19509 (Ekind
(Entity
(N
)) = E_Discriminant
19510 or else (Ekind
(Entity
(N
)) in E_Constant | E_In_Parameter
19511 and then Present
(Discriminal_Link
(Entity
(N
)))))
19517 elsif Nkind
(N
) = N_Null
then
19520 -- Ada 2020 (AI12-0175): Calls to certain functions that are essentially
19521 -- unchecked conversions are preelaborable.
19523 elsif Ada_Version
>= Ada_2020
19524 and then Nkind
(N
) = N_Function_Call
19525 and then Is_Entity_Name
(Name
(N
))
19526 and then Is_Preelaborable_Function
(Entity
(Name
(N
)))
19531 A
:= First_Actual
(N
);
19533 while Present
(A
) loop
19534 if not Is_Preelaborable_Construct
(A
) then
19544 -- Otherwise the construct is not preelaborable
19549 end Is_Preelaborable_Construct
;
19551 -------------------------------
19552 -- Is_Preelaborable_Function --
19553 -------------------------------
19555 function Is_Preelaborable_Function
(Id
: Entity_Id
) return Boolean is
19556 SATAC
: constant Rtsfind
.RTU_Id
:= System_Address_To_Access_Conversions
;
19557 Scop
: constant Entity_Id
:= Scope
(Id
);
19560 -- Small optimization: every allowed function has convention Intrinsic
19561 -- (see Analyze_Subprogram_Instantiation for the subtlety in the test).
19563 if not Is_Intrinsic_Subprogram
(Id
)
19564 and then Convention
(Id
) /= Convention_Intrinsic
19569 -- An instance of Unchecked_Conversion
19571 if Is_Unchecked_Conversion_Instance
(Id
) then
19575 -- A function declared in System.Storage_Elements
19577 if Is_RTU
(Scop
, System_Storage_Elements
) then
19581 -- The functions To_Pointer and To_Address declared in an instance of
19582 -- System.Address_To_Access_Conversions (they are the only ones).
19584 if Ekind
(Scop
) = E_Package
19585 and then Nkind
(Parent
(Scop
)) = N_Package_Specification
19586 and then Present
(Generic_Parent
(Parent
(Scop
)))
19587 and then Is_RTU
(Generic_Parent
(Parent
(Scop
)), SATAC
)
19593 end Is_Preelaborable_Function
;
19595 ---------------------------------
19596 -- Is_Protected_Self_Reference --
19597 ---------------------------------
19599 function Is_Protected_Self_Reference
(N
: Node_Id
) return Boolean is
19601 function In_Access_Definition
(N
: Node_Id
) return Boolean;
19602 -- Returns true if N belongs to an access definition
19604 --------------------------
19605 -- In_Access_Definition --
19606 --------------------------
19608 function In_Access_Definition
(N
: Node_Id
) return Boolean is
19613 while Present
(P
) loop
19614 if Nkind
(P
) = N_Access_Definition
then
19622 end In_Access_Definition
;
19624 -- Start of processing for Is_Protected_Self_Reference
19627 -- Verify that prefix is analyzed and has the proper form. Note that
19628 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also
19629 -- produce the address of an entity, do not analyze their prefix
19630 -- because they denote entities that are not necessarily visible.
19631 -- Neither of them can apply to a protected type.
19633 return Ada_Version
>= Ada_2005
19634 and then Is_Entity_Name
(N
)
19635 and then Present
(Entity
(N
))
19636 and then Is_Protected_Type
(Entity
(N
))
19637 and then In_Open_Scopes
(Entity
(N
))
19638 and then not In_Access_Definition
(N
);
19639 end Is_Protected_Self_Reference
;
19641 -----------------------------
19642 -- Is_RCI_Pkg_Spec_Or_Body --
19643 -----------------------------
19645 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
19647 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
19648 -- Return True if the unit of Cunit is an RCI package declaration
19650 ---------------------------
19651 -- Is_RCI_Pkg_Decl_Cunit --
19652 ---------------------------
19654 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
19655 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
19658 if Nkind
(The_Unit
) /= N_Package_Declaration
then
19662 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
19663 end Is_RCI_Pkg_Decl_Cunit
;
19665 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
19668 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
19670 (Nkind
(Unit
(Cunit
)) = N_Package_Body
19671 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
19672 end Is_RCI_Pkg_Spec_Or_Body
;
19674 -----------------------------------------
19675 -- Is_Remote_Access_To_Class_Wide_Type --
19676 -----------------------------------------
19678 function Is_Remote_Access_To_Class_Wide_Type
19679 (E
: Entity_Id
) return Boolean
19682 -- A remote access to class-wide type is a general access to object type
19683 -- declared in the visible part of a Remote_Types or Remote_Call_
19686 return Ekind
(E
) = E_General_Access_Type
19687 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
19688 end Is_Remote_Access_To_Class_Wide_Type
;
19690 -----------------------------------------
19691 -- Is_Remote_Access_To_Subprogram_Type --
19692 -----------------------------------------
19694 function Is_Remote_Access_To_Subprogram_Type
19695 (E
: Entity_Id
) return Boolean
19698 return (Ekind
(E
) = E_Access_Subprogram_Type
19699 or else (Ekind
(E
) = E_Record_Type
19700 and then Present
(Corresponding_Remote_Type
(E
))))
19701 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
19702 end Is_Remote_Access_To_Subprogram_Type
;
19704 --------------------
19705 -- Is_Remote_Call --
19706 --------------------
19708 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
19710 if Nkind
(N
) not in N_Subprogram_Call
then
19712 -- An entry call cannot be remote
19716 elsif Nkind
(Name
(N
)) in N_Has_Entity
19717 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
19719 -- A subprogram declared in the spec of a RCI package is remote
19723 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
19724 and then Is_Remote_Access_To_Subprogram_Type
19725 (Etype
(Prefix
(Name
(N
))))
19727 -- The dereference of a RAS is a remote call
19731 elsif Present
(Controlling_Argument
(N
))
19732 and then Is_Remote_Access_To_Class_Wide_Type
19733 (Etype
(Controlling_Argument
(N
)))
19735 -- Any primitive operation call with a controlling argument of
19736 -- a RACW type is a remote call.
19741 -- All other calls are local calls
19744 end Is_Remote_Call
;
19746 ----------------------
19747 -- Is_Renamed_Entry --
19748 ----------------------
19750 function Is_Renamed_Entry
(Proc_Nam
: Entity_Id
) return Boolean is
19751 Orig_Node
: Node_Id
:= Empty
;
19752 Subp_Decl
: Node_Id
:= Parent
(Parent
(Proc_Nam
));
19754 function Is_Entry
(Nam
: Node_Id
) return Boolean;
19755 -- Determine whether Nam is an entry. Traverse selectors if there are
19756 -- nested selected components.
19762 function Is_Entry
(Nam
: Node_Id
) return Boolean is
19764 if Nkind
(Nam
) = N_Selected_Component
then
19765 return Is_Entry
(Selector_Name
(Nam
));
19768 return Ekind
(Entity
(Nam
)) = E_Entry
;
19771 -- Start of processing for Is_Renamed_Entry
19774 if Present
(Alias
(Proc_Nam
)) then
19775 Subp_Decl
:= Parent
(Parent
(Alias
(Proc_Nam
)));
19778 -- Look for a rewritten subprogram renaming declaration
19780 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
19781 and then Present
(Original_Node
(Subp_Decl
))
19783 Orig_Node
:= Original_Node
(Subp_Decl
);
19786 -- The rewritten subprogram is actually an entry
19788 if Present
(Orig_Node
)
19789 and then Nkind
(Orig_Node
) = N_Subprogram_Renaming_Declaration
19790 and then Is_Entry
(Name
(Orig_Node
))
19796 end Is_Renamed_Entry
;
19798 ----------------------------
19799 -- Is_Reversible_Iterator --
19800 ----------------------------
19802 function Is_Reversible_Iterator
(Typ
: Entity_Id
) return Boolean is
19803 Ifaces_List
: Elist_Id
;
19804 Iface_Elmt
: Elmt_Id
;
19808 if Is_Class_Wide_Type
(Typ
)
19809 and then Chars
(Root_Type
(Typ
)) = Name_Reversible_Iterator
19810 and then In_Predefined_Unit
(Root_Type
(Typ
))
19814 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
19818 Collect_Interfaces
(Typ
, Ifaces_List
);
19820 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
19821 while Present
(Iface_Elmt
) loop
19822 Iface
:= Node
(Iface_Elmt
);
19823 if Chars
(Iface
) = Name_Reversible_Iterator
19824 and then In_Predefined_Unit
(Iface
)
19829 Next_Elmt
(Iface_Elmt
);
19834 end Is_Reversible_Iterator
;
19836 ----------------------
19837 -- Is_Selector_Name --
19838 ----------------------
19840 function Is_Selector_Name
(N
: Node_Id
) return Boolean is
19842 if not Is_List_Member
(N
) then
19844 P
: constant Node_Id
:= Parent
(N
);
19846 return Nkind
(P
) in N_Expanded_Name
19847 | N_Generic_Association
19848 | N_Parameter_Association
19849 | N_Selected_Component
19850 and then Selector_Name
(P
) = N
;
19855 L
: constant List_Id
:= List_Containing
(N
);
19856 P
: constant Node_Id
:= Parent
(L
);
19858 return (Nkind
(P
) = N_Discriminant_Association
19859 and then Selector_Names
(P
) = L
)
19861 (Nkind
(P
) = N_Component_Association
19862 and then Choices
(P
) = L
);
19865 end Is_Selector_Name
;
19867 ---------------------------------
19868 -- Is_Single_Concurrent_Object --
19869 ---------------------------------
19871 function Is_Single_Concurrent_Object
(Id
: Entity_Id
) return Boolean is
19874 Is_Single_Protected_Object
(Id
) or else Is_Single_Task_Object
(Id
);
19875 end Is_Single_Concurrent_Object
;
19877 -------------------------------
19878 -- Is_Single_Concurrent_Type --
19879 -------------------------------
19881 function Is_Single_Concurrent_Type
(Id
: Entity_Id
) return Boolean is
19884 Ekind
(Id
) in E_Protected_Type | E_Task_Type
19885 and then Is_Single_Concurrent_Type_Declaration
19886 (Declaration_Node
(Id
));
19887 end Is_Single_Concurrent_Type
;
19889 -------------------------------------------
19890 -- Is_Single_Concurrent_Type_Declaration --
19891 -------------------------------------------
19893 function Is_Single_Concurrent_Type_Declaration
19894 (N
: Node_Id
) return Boolean
19897 return Nkind
(Original_Node
(N
)) in
19898 N_Single_Protected_Declaration | N_Single_Task_Declaration
;
19899 end Is_Single_Concurrent_Type_Declaration
;
19901 ---------------------------------------------
19902 -- Is_Single_Precision_Floating_Point_Type --
19903 ---------------------------------------------
19905 function Is_Single_Precision_Floating_Point_Type
19906 (E
: Entity_Id
) return Boolean is
19908 return Is_Floating_Point_Type
(E
)
19909 and then Machine_Radix_Value
(E
) = Uint_2
19910 and then Machine_Mantissa_Value
(E
) = Uint_24
19911 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_7
19912 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_7
);
19913 end Is_Single_Precision_Floating_Point_Type
;
19915 --------------------------------
19916 -- Is_Single_Protected_Object --
19917 --------------------------------
19919 function Is_Single_Protected_Object
(Id
: Entity_Id
) return Boolean is
19922 Ekind
(Id
) = E_Variable
19923 and then Ekind
(Etype
(Id
)) = E_Protected_Type
19924 and then Is_Single_Concurrent_Type
(Etype
(Id
));
19925 end Is_Single_Protected_Object
;
19927 ---------------------------
19928 -- Is_Single_Task_Object --
19929 ---------------------------
19931 function Is_Single_Task_Object
(Id
: Entity_Id
) return Boolean is
19934 Ekind
(Id
) = E_Variable
19935 and then Ekind
(Etype
(Id
)) = E_Task_Type
19936 and then Is_Single_Concurrent_Type
(Etype
(Id
));
19937 end Is_Single_Task_Object
;
19939 --------------------------------------
19940 -- Is_Special_Aliased_Formal_Access --
19941 --------------------------------------
19943 function Is_Special_Aliased_Formal_Access
19945 In_Return_Context
: Boolean := False) return Boolean
19947 Scop
: constant Entity_Id
:= Current_Subprogram
;
19949 -- Verify the expression is an access reference to 'Access within a
19950 -- return statement as this is the only time an explicitly aliased
19951 -- formal has different semantics.
19953 if Nkind
(Exp
) /= N_Attribute_Reference
19954 or else Get_Attribute_Id
(Attribute_Name
(Exp
)) /= Attribute_Access
19955 or else not (In_Return_Value
(Exp
)
19956 or else In_Return_Context
)
19957 or else not Needs_Result_Accessibility_Level
(Scop
)
19962 -- Check if the prefix of the reference is indeed an explicitly aliased
19963 -- formal parameter for the function Scop. Additionally, we must check
19964 -- that Scop returns an anonymous access type, otherwise the special
19965 -- rules dictating a need for a dynamic check are not in effect.
19967 return Is_Entity_Name
(Prefix
(Exp
))
19968 and then Is_Explicitly_Aliased
(Entity
(Prefix
(Exp
)));
19969 end Is_Special_Aliased_Formal_Access
;
19971 -----------------------------
19972 -- Is_Specific_Tagged_Type --
19973 -----------------------------
19975 function Is_Specific_Tagged_Type
(Typ
: Entity_Id
) return Boolean is
19976 Full_Typ
: Entity_Id
;
19979 -- Handle private types
19981 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
19982 Full_Typ
:= Full_View
(Typ
);
19987 -- A specific tagged type is a non-class-wide tagged type
19989 return Is_Tagged_Type
(Full_Typ
) and not Is_Class_Wide_Type
(Full_Typ
);
19990 end Is_Specific_Tagged_Type
;
19996 function Is_Statement
(N
: Node_Id
) return Boolean is
19999 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
20000 or else Nkind
(N
) = N_Procedure_Call_Statement
;
20003 --------------------------------------
20004 -- Is_Static_Discriminant_Component --
20005 --------------------------------------
20007 function Is_Static_Discriminant_Component
(N
: Node_Id
) return Boolean is
20009 return Nkind
(N
) = N_Selected_Component
20010 and then not Is_In_Discriminant_Check
(N
)
20011 and then Present
(Etype
(Prefix
(N
)))
20012 and then Ekind
(Etype
(Prefix
(N
))) = E_Record_Subtype
20013 and then Has_Static_Discriminants
(Etype
(Prefix
(N
)))
20014 and then Present
(Entity
(Selector_Name
(N
)))
20015 and then Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
20016 and then not In_Check_Node
(N
);
20017 end Is_Static_Discriminant_Component
;
20019 ------------------------
20020 -- Is_Static_Function --
20021 ------------------------
20023 function Is_Static_Function
(Subp
: Entity_Id
) return Boolean is
20025 -- Always return False for pre Ada 2020 to e.g. ignore the Static
20026 -- aspect in package Interfaces for Ada_Version < 2020 and also
20029 return Ada_Version
>= Ada_2020
20030 and then Has_Aspect
(Subp
, Aspect_Static
)
20032 (No
(Find_Value_Of_Aspect
(Subp
, Aspect_Static
))
20033 or else Is_True
(Static_Boolean
20034 (Find_Value_Of_Aspect
(Subp
, Aspect_Static
))));
20035 end Is_Static_Function
;
20037 -----------------------------
20038 -- Is_Static_Function_Call --
20039 -----------------------------
20041 function Is_Static_Function_Call
(Call
: Node_Id
) return Boolean is
20042 function Has_All_Static_Actuals
(Call
: Node_Id
) return Boolean;
20043 -- Return whether all actual parameters of Call are static expressions
20045 ----------------------------
20046 -- Has_All_Static_Actuals --
20047 ----------------------------
20049 function Has_All_Static_Actuals
(Call
: Node_Id
) return Boolean is
20050 Actual
: Node_Id
:= First_Actual
(Call
);
20051 String_Result
: constant Boolean :=
20052 Is_String_Type
(Etype
(Entity
(Name
(Call
))));
20055 while Present
(Actual
) loop
20056 if not Is_Static_Expression
(Actual
) then
20058 -- ??? In the string-returning case we want to avoid a call
20059 -- being made to Establish_Transient_Scope in Resolve_Call,
20060 -- but at the point where that's tested for (which now includes
20061 -- a call to test Is_Static_Function_Call), the actuals of the
20062 -- call haven't been resolved, so expressions of the actuals
20063 -- may not have been marked Is_Static_Expression yet, so we
20064 -- force them to be resolved here, so we can tell if they're
20065 -- static. Calling Resolve here is admittedly a kludge, and we
20066 -- limit this call to string-returning cases.
20068 if String_Result
then
20072 -- Test flag again in case it's now True due to above Resolve
20074 if not Is_Static_Expression
(Actual
) then
20079 Next_Actual
(Actual
);
20083 end Has_All_Static_Actuals
;
20086 return Nkind
(Call
) = N_Function_Call
20087 and then Is_Entity_Name
(Name
(Call
))
20088 and then Is_Static_Function
(Entity
(Name
(Call
)))
20089 and then Has_All_Static_Actuals
(Call
);
20090 end Is_Static_Function_Call
;
20092 -------------------------------------------
20093 -- Is_Subcomponent_Of_Full_Access_Object --
20094 -------------------------------------------
20096 function Is_Subcomponent_Of_Full_Access_Object
(N
: Node_Id
) return Boolean
20101 R
:= Get_Referenced_Object
(N
);
20103 while Nkind
(R
) in N_Indexed_Component | N_Selected_Component | N_Slice
20105 R
:= Get_Referenced_Object
(Prefix
(R
));
20107 -- If the prefix is an access value, only the designated type matters
20109 if Is_Access_Type
(Etype
(R
)) then
20110 if Is_Full_Access
(Designated_Type
(Etype
(R
))) then
20115 if Is_Full_Access_Object
(R
) then
20122 end Is_Subcomponent_Of_Full_Access_Object
;
20124 ---------------------------------------
20125 -- Is_Subprogram_Contract_Annotation --
20126 ---------------------------------------
20128 function Is_Subprogram_Contract_Annotation
20129 (Item
: Node_Id
) return Boolean
20134 if Nkind
(Item
) = N_Aspect_Specification
then
20135 Nam
:= Chars
(Identifier
(Item
));
20137 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
20138 Nam
:= Pragma_Name
(Item
);
20141 return Nam
= Name_Contract_Cases
20142 or else Nam
= Name_Depends
20143 or else Nam
= Name_Extensions_Visible
20144 or else Nam
= Name_Global
20145 or else Nam
= Name_Post
20146 or else Nam
= Name_Post_Class
20147 or else Nam
= Name_Postcondition
20148 or else Nam
= Name_Pre
20149 or else Nam
= Name_Pre_Class
20150 or else Nam
= Name_Precondition
20151 or else Nam
= Name_Refined_Depends
20152 or else Nam
= Name_Refined_Global
20153 or else Nam
= Name_Refined_Post
20154 or else Nam
= Name_Subprogram_Variant
20155 or else Nam
= Name_Test_Case
;
20156 end Is_Subprogram_Contract_Annotation
;
20158 --------------------------------------------------
20159 -- Is_Subprogram_Stub_Without_Prior_Declaration --
20160 --------------------------------------------------
20162 function Is_Subprogram_Stub_Without_Prior_Declaration
20163 (N
: Node_Id
) return Boolean
20166 pragma Assert
(Nkind
(N
) = N_Subprogram_Body_Stub
);
20168 case Ekind
(Defining_Entity
(N
)) is
20170 -- A subprogram stub without prior declaration serves as declaration
20171 -- for the actual subprogram body. As such, it has an attached
20172 -- defining entity of E_Function or E_Procedure.
20179 -- Otherwise, it is completes a [generic] subprogram declaration
20181 when E_Generic_Function
20182 | E_Generic_Procedure
20183 | E_Subprogram_Body
20188 raise Program_Error
;
20190 end Is_Subprogram_Stub_Without_Prior_Declaration
;
20192 ---------------------------
20193 -- Is_Suitable_Primitive --
20194 ---------------------------
20196 function Is_Suitable_Primitive
(Subp_Id
: Entity_Id
) return Boolean is
20198 -- The Default_Initial_Condition and invariant procedures must not be
20199 -- treated as primitive operations even when they apply to a tagged
20200 -- type. These routines must not act as targets of dispatching calls
20201 -- because they already utilize class-wide-precondition semantics to
20202 -- handle inheritance and overriding.
20204 if Ekind
(Subp_Id
) = E_Procedure
20205 and then (Is_DIC_Procedure
(Subp_Id
)
20207 Is_Invariant_Procedure
(Subp_Id
))
20213 end Is_Suitable_Primitive
;
20215 --------------------------
20216 -- Is_Suspension_Object --
20217 --------------------------
20219 function Is_Suspension_Object
(Id
: Entity_Id
) return Boolean is
20221 -- This approach does an exact name match rather than to rely on
20222 -- RTSfind. Routine Is_Effectively_Volatile is used by clients of the
20223 -- front end at point where all auxiliary tables are locked and any
20224 -- modifications to them are treated as violations. Do not tamper with
20225 -- the tables, instead examine the Chars fields of all the scopes of Id.
20228 Chars
(Id
) = Name_Suspension_Object
20229 and then Present
(Scope
(Id
))
20230 and then Chars
(Scope
(Id
)) = Name_Synchronous_Task_Control
20231 and then Present
(Scope
(Scope
(Id
)))
20232 and then Chars
(Scope
(Scope
(Id
))) = Name_Ada
20233 and then Present
(Scope
(Scope
(Scope
(Id
))))
20234 and then Scope
(Scope
(Scope
(Id
))) = Standard_Standard
;
20235 end Is_Suspension_Object
;
20237 ----------------------------
20238 -- Is_Synchronized_Object --
20239 ----------------------------
20241 function Is_Synchronized_Object
(Id
: Entity_Id
) return Boolean is
20245 if Is_Object
(Id
) then
20247 -- The object is synchronized if it is of a type that yields a
20248 -- synchronized object.
20250 if Yields_Synchronized_Object
(Etype
(Id
)) then
20253 -- The object is synchronized if it is atomic and Async_Writers is
20256 elsif Is_Atomic_Object_Entity
(Id
)
20257 and then Async_Writers_Enabled
(Id
)
20261 -- A constant is a synchronized object by default, unless its type is
20262 -- access-to-variable type.
20264 elsif Ekind
(Id
) = E_Constant
20265 and then not Is_Access_Variable
(Etype
(Id
))
20269 -- A variable is a synchronized object if it is subject to pragma
20270 -- Constant_After_Elaboration.
20272 elsif Ekind
(Id
) = E_Variable
then
20273 Prag
:= Get_Pragma
(Id
, Pragma_Constant_After_Elaboration
);
20275 return Present
(Prag
) and then Is_Enabled_Pragma
(Prag
);
20279 -- Otherwise the input is not an object or it does not qualify as a
20280 -- synchronized object.
20283 end Is_Synchronized_Object
;
20285 ---------------------------------
20286 -- Is_Synchronized_Tagged_Type --
20287 ---------------------------------
20289 function Is_Synchronized_Tagged_Type
(E
: Entity_Id
) return Boolean is
20290 Kind
: constant Entity_Kind
:= Ekind
(Base_Type
(E
));
20293 -- A task or protected type derived from an interface is a tagged type.
20294 -- Such a tagged type is called a synchronized tagged type, as are
20295 -- synchronized interfaces and private extensions whose declaration
20296 -- includes the reserved word synchronized.
20298 return (Is_Tagged_Type
(E
)
20299 and then (Kind
= E_Task_Type
20301 Kind
= E_Protected_Type
))
20304 and then Is_Synchronized_Interface
(E
))
20306 (Ekind
(E
) = E_Record_Type_With_Private
20307 and then Nkind
(Parent
(E
)) = N_Private_Extension_Declaration
20308 and then (Synchronized_Present
(Parent
(E
))
20309 or else Is_Synchronized_Interface
(Etype
(E
))));
20310 end Is_Synchronized_Tagged_Type
;
20316 function Is_Transfer
(N
: Node_Id
) return Boolean is
20317 Kind
: constant Node_Kind
:= Nkind
(N
);
20320 if Kind
= N_Simple_Return_Statement
20322 Kind
= N_Extended_Return_Statement
20324 Kind
= N_Goto_Statement
20326 Kind
= N_Raise_Statement
20328 Kind
= N_Requeue_Statement
20332 elsif (Kind
= N_Exit_Statement
or else Kind
in N_Raise_xxx_Error
)
20333 and then No
(Condition
(N
))
20337 elsif Kind
= N_Procedure_Call_Statement
20338 and then Is_Entity_Name
(Name
(N
))
20339 and then Present
(Entity
(Name
(N
)))
20340 and then No_Return
(Entity
(Name
(N
)))
20344 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
20356 function Is_True
(U
: Uint
) return Boolean is
20361 --------------------------------------
20362 -- Is_Unchecked_Conversion_Instance --
20363 --------------------------------------
20365 function Is_Unchecked_Conversion_Instance
(Id
: Entity_Id
) return Boolean is
20369 -- Look for a function whose generic parent is the predefined intrinsic
20370 -- function Unchecked_Conversion, or for one that renames such an
20373 if Ekind
(Id
) = E_Function
then
20374 Par
:= Parent
(Id
);
20376 if Nkind
(Par
) = N_Function_Specification
then
20377 Par
:= Generic_Parent
(Par
);
20379 if Present
(Par
) then
20381 Chars
(Par
) = Name_Unchecked_Conversion
20382 and then Is_Intrinsic_Subprogram
(Par
)
20383 and then In_Predefined_Unit
(Par
);
20386 Present
(Alias
(Id
))
20387 and then Is_Unchecked_Conversion_Instance
(Alias
(Id
));
20393 end Is_Unchecked_Conversion_Instance
;
20395 -------------------------------
20396 -- Is_Universal_Numeric_Type --
20397 -------------------------------
20399 function Is_Universal_Numeric_Type
(T
: Entity_Id
) return Boolean is
20401 return T
= Universal_Integer
or else T
= Universal_Real
;
20402 end Is_Universal_Numeric_Type
;
20404 ------------------------------
20405 -- Is_User_Defined_Equality --
20406 ------------------------------
20408 function Is_User_Defined_Equality
(Id
: Entity_Id
) return Boolean is
20410 return Ekind
(Id
) = E_Function
20411 and then Chars
(Id
) = Name_Op_Eq
20412 and then Comes_From_Source
(Id
)
20414 -- Internally generated equalities have a full type declaration
20415 -- as their parent.
20417 and then Nkind
(Parent
(Id
)) = N_Function_Specification
;
20418 end Is_User_Defined_Equality
;
20420 --------------------------------------
20421 -- Is_Validation_Variable_Reference --
20422 --------------------------------------
20424 function Is_Validation_Variable_Reference
(N
: Node_Id
) return Boolean is
20425 Var
: constant Node_Id
:= Unqual_Conv
(N
);
20426 Var_Id
: Entity_Id
;
20431 if Is_Entity_Name
(Var
) then
20432 Var_Id
:= Entity
(Var
);
20437 and then Ekind
(Var_Id
) = E_Variable
20438 and then Present
(Validated_Object
(Var_Id
));
20439 end Is_Validation_Variable_Reference
;
20441 ----------------------------
20442 -- Is_Variable_Size_Array --
20443 ----------------------------
20445 function Is_Variable_Size_Array
(E
: Entity_Id
) return Boolean is
20449 pragma Assert
(Is_Array_Type
(E
));
20451 -- Check if some index is initialized with a non-constant value
20453 Idx
:= First_Index
(E
);
20454 while Present
(Idx
) loop
20455 if Nkind
(Idx
) = N_Range
then
20456 if not Is_Constant_Bound
(Low_Bound
(Idx
))
20457 or else not Is_Constant_Bound
(High_Bound
(Idx
))
20467 end Is_Variable_Size_Array
;
20469 -----------------------------
20470 -- Is_Variable_Size_Record --
20471 -----------------------------
20473 function Is_Variable_Size_Record
(E
: Entity_Id
) return Boolean is
20475 Comp_Typ
: Entity_Id
;
20478 pragma Assert
(Is_Record_Type
(E
));
20480 Comp
:= First_Component
(E
);
20481 while Present
(Comp
) loop
20482 Comp_Typ
:= Underlying_Type
(Etype
(Comp
));
20484 -- Recursive call if the record type has discriminants
20486 if Is_Record_Type
(Comp_Typ
)
20487 and then Has_Discriminants
(Comp_Typ
)
20488 and then Is_Variable_Size_Record
(Comp_Typ
)
20492 elsif Is_Array_Type
(Comp_Typ
)
20493 and then Is_Variable_Size_Array
(Comp_Typ
)
20498 Next_Component
(Comp
);
20502 end Is_Variable_Size_Record
;
20508 function Is_Variable
20510 Use_Original_Node
: Boolean := True) return Boolean
20512 Orig_Node
: Node_Id
;
20514 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
20515 -- Within a protected function, the private components of the enclosing
20516 -- protected type are constants. A function nested within a (protected)
20517 -- procedure is not itself protected. Within the body of a protected
20518 -- function the current instance of the protected type is a constant.
20520 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
20521 -- Prefixes can involve implicit dereferences, in which case we must
20522 -- test for the case of a reference of a constant access type, which can
20523 -- can never be a variable.
20525 ---------------------------
20526 -- In_Protected_Function --
20527 ---------------------------
20529 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
20534 -- E is the current instance of a type
20536 if Is_Type
(E
) then
20545 if not Is_Protected_Type
(Prot
) then
20549 S
:= Current_Scope
;
20550 while Present
(S
) and then S
/= Prot
loop
20551 if Ekind
(S
) = E_Function
and then Scope
(S
) = Prot
then
20560 end In_Protected_Function
;
20562 ------------------------
20563 -- Is_Variable_Prefix --
20564 ------------------------
20566 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
20568 if Is_Access_Type
(Etype
(P
)) then
20569 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
20571 -- For the case of an indexed component whose prefix has a packed
20572 -- array type, the prefix has been rewritten into a type conversion.
20573 -- Determine variable-ness from the converted expression.
20575 elsif Nkind
(P
) = N_Type_Conversion
20576 and then not Comes_From_Source
(P
)
20577 and then Is_Packed_Array
(Etype
(P
))
20579 return Is_Variable
(Expression
(P
));
20582 return Is_Variable
(P
);
20584 end Is_Variable_Prefix
;
20586 -- Start of processing for Is_Variable
20589 -- Special check, allow x'Deref(expr) as a variable
20591 if Nkind
(N
) = N_Attribute_Reference
20592 and then Attribute_Name
(N
) = Name_Deref
20597 -- Check if we perform the test on the original node since this may be a
20598 -- test of syntactic categories which must not be disturbed by whatever
20599 -- rewriting might have occurred. For example, an aggregate, which is
20600 -- certainly NOT a variable, could be turned into a variable by
20603 if Use_Original_Node
then
20604 Orig_Node
:= Original_Node
(N
);
20609 -- Definitely OK if Assignment_OK is set. Since this is something that
20610 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
20612 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
20615 -- Normally we go to the original node, but there is one exception where
20616 -- we use the rewritten node, namely when it is an explicit dereference.
20617 -- The generated code may rewrite a prefix which is an access type with
20618 -- an explicit dereference. The dereference is a variable, even though
20619 -- the original node may not be (since it could be a constant of the
20622 -- In Ada 2005 we have a further case to consider: the prefix may be a
20623 -- function call given in prefix notation. The original node appears to
20624 -- be a selected component, but we need to examine the call.
20626 elsif Nkind
(N
) = N_Explicit_Dereference
20627 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
20628 and then Present
(Etype
(Orig_Node
))
20629 and then Is_Access_Type
(Etype
(Orig_Node
))
20631 -- Note that if the prefix is an explicit dereference that does not
20632 -- come from source, we must check for a rewritten function call in
20633 -- prefixed notation before other forms of rewriting, to prevent a
20637 (Nkind
(Orig_Node
) = N_Function_Call
20638 and then not Is_Access_Constant
(Etype
(Prefix
(N
))))
20640 Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
20642 -- Generalized indexing operations are rewritten as explicit
20643 -- dereferences, and it is only during resolution that we can
20644 -- check whether the context requires an access_to_variable type.
20646 elsif Nkind
(N
) = N_Explicit_Dereference
20647 and then Present
(Etype
(Orig_Node
))
20648 and then Has_Implicit_Dereference
(Etype
(Orig_Node
))
20649 and then Ada_Version
>= Ada_2012
20651 return not Is_Access_Constant
(Etype
(Prefix
(N
)));
20653 -- A function call is never a variable
20655 elsif Nkind
(N
) = N_Function_Call
then
20658 -- All remaining checks use the original node
20660 elsif Is_Entity_Name
(Orig_Node
)
20661 and then Present
(Entity
(Orig_Node
))
20664 E
: constant Entity_Id
:= Entity
(Orig_Node
);
20665 K
: constant Entity_Kind
:= Ekind
(E
);
20668 if Is_Loop_Parameter
(E
) then
20672 return (K
= E_Variable
20673 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
20674 or else (K
= E_Component
20675 and then not In_Protected_Function
(E
))
20676 or else K
= E_Out_Parameter
20677 or else K
= E_In_Out_Parameter
20678 or else K
= E_Generic_In_Out_Parameter
20680 -- Current instance of type. If this is a protected type, check
20681 -- we are not within the body of one of its protected functions.
20683 or else (Is_Type
(E
)
20684 and then In_Open_Scopes
(E
)
20685 and then not In_Protected_Function
(E
))
20687 or else (Is_Incomplete_Or_Private_Type
(E
)
20688 and then In_Open_Scopes
(Full_View
(E
)));
20692 case Nkind
(Orig_Node
) is
20693 when N_Indexed_Component
20696 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
20698 when N_Selected_Component
=>
20699 return (Is_Variable
(Selector_Name
(Orig_Node
))
20700 and then Is_Variable_Prefix
(Prefix
(Orig_Node
)))
20702 (Nkind
(N
) = N_Expanded_Name
20703 and then Scope
(Entity
(N
)) = Entity
(Prefix
(N
)));
20705 -- For an explicit dereference, the type of the prefix cannot
20706 -- be an access to constant or an access to subprogram.
20708 when N_Explicit_Dereference
=>
20710 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
20712 return Is_Access_Type
(Typ
)
20713 and then not Is_Access_Constant
(Root_Type
(Typ
))
20714 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
20717 -- The type conversion is the case where we do not deal with the
20718 -- context dependent special case of an actual parameter. Thus
20719 -- the type conversion is only considered a variable for the
20720 -- purposes of this routine if the target type is tagged. However,
20721 -- a type conversion is considered to be a variable if it does not
20722 -- come from source (this deals for example with the conversions
20723 -- of expressions to their actual subtypes).
20725 when N_Type_Conversion
=>
20726 return Is_Variable
(Expression
(Orig_Node
))
20728 (not Comes_From_Source
(Orig_Node
)
20730 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
20732 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
20734 -- GNAT allows an unchecked type conversion as a variable. This
20735 -- only affects the generation of internal expanded code, since
20736 -- calls to instantiations of Unchecked_Conversion are never
20737 -- considered variables (since they are function calls).
20739 when N_Unchecked_Type_Conversion
=>
20740 return Is_Variable
(Expression
(Orig_Node
));
20748 ------------------------
20749 -- Is_View_Conversion --
20750 ------------------------
20752 function Is_View_Conversion
(N
: Node_Id
) return Boolean is
20754 if Nkind
(N
) = N_Type_Conversion
20755 and then Nkind
(Unqual_Conv
(N
)) in N_Has_Etype
20757 if Is_Tagged_Type
(Etype
(N
))
20758 and then Is_Tagged_Type
(Etype
(Unqual_Conv
(N
)))
20762 elsif Is_Actual_Parameter
(N
)
20763 and then (Is_Actual_Out_Parameter
(N
)
20764 or else Is_Actual_In_Out_Parameter
(N
))
20771 end Is_View_Conversion
;
20773 ---------------------------
20774 -- Is_Visibly_Controlled --
20775 ---------------------------
20777 function Is_Visibly_Controlled
(T
: Entity_Id
) return Boolean is
20778 Root
: constant Entity_Id
:= Root_Type
(T
);
20780 return Chars
(Scope
(Root
)) = Name_Finalization
20781 and then Chars
(Scope
(Scope
(Root
))) = Name_Ada
20782 and then Scope
(Scope
(Scope
(Root
))) = Standard_Standard
;
20783 end Is_Visibly_Controlled
;
20785 --------------------------------------
20786 -- Is_Volatile_Full_Access_Object --
20787 --------------------------------------
20789 function Is_Volatile_Full_Access_Object
(N
: Node_Id
) return Boolean is
20790 function Is_VFA_Object_Entity
(Id
: Entity_Id
) return Boolean;
20791 -- Determine whether arbitrary entity Id denotes an object that is
20792 -- Volatile_Full_Access.
20794 ----------------------------
20795 -- Is_VFA_Object_Entity --
20796 ----------------------------
20798 function Is_VFA_Object_Entity
(Id
: Entity_Id
) return Boolean is
20802 and then (Is_Volatile_Full_Access
(Id
)
20804 Is_Volatile_Full_Access
(Etype
(Id
)));
20805 end Is_VFA_Object_Entity
;
20807 -- Start of processing for Is_Volatile_Full_Access_Object
20810 if Is_Entity_Name
(N
) then
20811 return Is_VFA_Object_Entity
(Entity
(N
));
20813 elsif Is_Volatile_Full_Access
(Etype
(N
)) then
20816 elsif Nkind
(N
) = N_Selected_Component
then
20817 return Is_Volatile_Full_Access
(Entity
(Selector_Name
(N
)));
20822 end Is_Volatile_Full_Access_Object
;
20824 --------------------------
20825 -- Is_Volatile_Function --
20826 --------------------------
20828 function Is_Volatile_Function
(Func_Id
: Entity_Id
) return Boolean is
20830 pragma Assert
(Ekind
(Func_Id
) in E_Function | E_Generic_Function
);
20832 -- A function declared within a protected type is volatile
20834 if Is_Protected_Type
(Scope
(Func_Id
)) then
20837 -- An instance of Ada.Unchecked_Conversion is a volatile function if
20838 -- either the source or the target are effectively volatile.
20840 elsif Is_Unchecked_Conversion_Instance
(Func_Id
)
20841 and then Has_Effectively_Volatile_Profile
(Func_Id
)
20845 -- Otherwise the function is treated as volatile if it is subject to
20846 -- enabled pragma Volatile_Function.
20850 Is_Enabled_Pragma
(Get_Pragma
(Func_Id
, Pragma_Volatile_Function
));
20852 end Is_Volatile_Function
;
20854 ------------------------
20855 -- Is_Volatile_Object --
20856 ------------------------
20858 function Is_Volatile_Object
(N
: Node_Id
) return Boolean is
20859 function Is_Volatile_Object_Entity
(Id
: Entity_Id
) return Boolean;
20860 -- Determine whether arbitrary entity Id denotes an object that is
20863 function Prefix_Has_Volatile_Components
(P
: Node_Id
) return Boolean;
20864 -- Determine whether prefix P has volatile components. This requires
20865 -- the presence of a Volatile_Components aspect/pragma or that P be
20866 -- itself a volatile object as per RM C.6(8).
20868 ---------------------------------
20869 -- Is_Volatile_Object_Entity --
20870 ---------------------------------
20872 function Is_Volatile_Object_Entity
(Id
: Entity_Id
) return Boolean is
20876 and then (Is_Volatile
(Id
) or else Is_Volatile
(Etype
(Id
)));
20877 end Is_Volatile_Object_Entity
;
20879 ------------------------------------
20880 -- Prefix_Has_Volatile_Components --
20881 ------------------------------------
20883 function Prefix_Has_Volatile_Components
(P
: Node_Id
) return Boolean is
20884 Typ
: constant Entity_Id
:= Etype
(P
);
20887 if Is_Access_Type
(Typ
) then
20889 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
20892 return Has_Volatile_Components
(Dtyp
)
20893 or else Is_Volatile
(Dtyp
);
20896 elsif Has_Volatile_Components
(Typ
) then
20899 elsif Is_Entity_Name
(P
)
20900 and then Has_Volatile_Component
(Entity
(P
))
20904 elsif Is_Volatile_Object
(P
) then
20910 end Prefix_Has_Volatile_Components
;
20912 -- Start of processing for Is_Volatile_Object
20915 if Is_Entity_Name
(N
) then
20916 return Is_Volatile_Object_Entity
(Entity
(N
));
20918 elsif Is_Volatile
(Etype
(N
)) then
20921 elsif Nkind
(N
) = N_Indexed_Component
then
20922 return Prefix_Has_Volatile_Components
(Prefix
(N
));
20924 elsif Nkind
(N
) = N_Selected_Component
then
20925 return Prefix_Has_Volatile_Components
(Prefix
(N
))
20926 or else Is_Volatile
(Entity
(Selector_Name
(N
)));
20931 end Is_Volatile_Object
;
20933 -----------------------------
20934 -- Iterate_Call_Parameters --
20935 -----------------------------
20937 procedure Iterate_Call_Parameters
(Call
: Node_Id
) is
20938 Actual
: Node_Id
:= First_Actual
(Call
);
20939 Formal
: Entity_Id
:= First_Formal
(Get_Called_Entity
(Call
));
20942 while Present
(Formal
) and then Present
(Actual
) loop
20943 Handle_Parameter
(Formal
, Actual
);
20945 Next_Formal
(Formal
);
20946 Next_Actual
(Actual
);
20949 pragma Assert
(No
(Formal
));
20950 pragma Assert
(No
(Actual
));
20951 end Iterate_Call_Parameters
;
20953 ---------------------------
20954 -- Itype_Has_Declaration --
20955 ---------------------------
20957 function Itype_Has_Declaration
(Id
: Entity_Id
) return Boolean is
20959 pragma Assert
(Is_Itype
(Id
));
20960 return Present
(Parent
(Id
))
20961 and then Nkind
(Parent
(Id
)) in
20962 N_Full_Type_Declaration | N_Subtype_Declaration
20963 and then Defining_Entity
(Parent
(Id
)) = Id
;
20964 end Itype_Has_Declaration
;
20966 -------------------------
20967 -- Kill_Current_Values --
20968 -------------------------
20970 procedure Kill_Current_Values
20972 Last_Assignment_Only
: Boolean := False)
20975 if Is_Assignable
(Ent
) then
20976 Set_Last_Assignment
(Ent
, Empty
);
20979 if Is_Object
(Ent
) then
20980 if not Last_Assignment_Only
then
20982 Set_Current_Value
(Ent
, Empty
);
20984 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags
20985 -- for a constant. Once the constant is elaborated, its value is
20986 -- not changed, therefore the associated flags that describe the
20987 -- value should not be modified either.
20989 if Ekind
(Ent
) = E_Constant
then
20992 -- Non-constant entities
20995 if not Can_Never_Be_Null
(Ent
) then
20996 Set_Is_Known_Non_Null
(Ent
, False);
20999 Set_Is_Known_Null
(Ent
, False);
21001 -- Reset the Is_Known_Valid flag unless the type is always
21002 -- valid. This does not apply to a loop parameter because its
21003 -- bounds are defined by the loop header and therefore always
21006 if not Is_Known_Valid
(Etype
(Ent
))
21007 and then Ekind
(Ent
) /= E_Loop_Parameter
21009 Set_Is_Known_Valid
(Ent
, False);
21014 end Kill_Current_Values
;
21016 procedure Kill_Current_Values
(Last_Assignment_Only
: Boolean := False) is
21019 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
);
21020 -- Clear current value for entity E and all entities chained to E
21022 ------------------------------------------
21023 -- Kill_Current_Values_For_Entity_Chain --
21024 ------------------------------------------
21026 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
) is
21030 while Present
(Ent
) loop
21031 Kill_Current_Values
(Ent
, Last_Assignment_Only
);
21034 end Kill_Current_Values_For_Entity_Chain
;
21036 -- Start of processing for Kill_Current_Values
21039 -- Kill all saved checks, a special case of killing saved values
21041 if not Last_Assignment_Only
then
21045 -- Loop through relevant scopes, which includes the current scope and
21046 -- any parent scopes if the current scope is a block or a package.
21048 S
:= Current_Scope
;
21051 -- Clear current values of all entities in current scope
21053 Kill_Current_Values_For_Entity_Chain
(First_Entity
(S
));
21055 -- If scope is a package, also clear current values of all private
21056 -- entities in the scope.
21058 if Is_Package_Or_Generic_Package
(S
)
21059 or else Is_Concurrent_Type
(S
)
21061 Kill_Current_Values_For_Entity_Chain
(First_Private_Entity
(S
));
21064 -- If this is a not a subprogram, deal with parents
21066 if not Is_Subprogram
(S
) then
21068 exit Scope_Loop
when S
= Standard_Standard
;
21072 end loop Scope_Loop
;
21073 end Kill_Current_Values
;
21075 --------------------------
21076 -- Kill_Size_Check_Code --
21077 --------------------------
21079 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
21081 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
21082 and then Present
(Size_Check_Code
(E
))
21084 Remove
(Size_Check_Code
(E
));
21085 Set_Size_Check_Code
(E
, Empty
);
21087 end Kill_Size_Check_Code
;
21089 --------------------
21090 -- Known_Non_Null --
21091 --------------------
21093 function Known_Non_Null
(N
: Node_Id
) return Boolean is
21094 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
21101 -- The expression yields a non-null value ignoring simple flow analysis
21103 if Status
= Is_Non_Null
then
21106 -- Otherwise check whether N is a reference to an entity that appears
21107 -- within a conditional construct.
21109 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
21111 -- First check if we are in decisive conditional
21113 Get_Current_Value_Condition
(N
, Op
, Val
);
21115 if Known_Null
(Val
) then
21116 if Op
= N_Op_Eq
then
21118 elsif Op
= N_Op_Ne
then
21123 -- If OK to do replacement, test Is_Known_Non_Null flag
21127 if OK_To_Do_Constant_Replacement
(Id
) then
21128 return Is_Known_Non_Null
(Id
);
21132 -- Otherwise it is not possible to determine whether N yields a non-null
21136 end Known_Non_Null
;
21142 function Known_Null
(N
: Node_Id
) return Boolean is
21143 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
21150 -- The expression yields a null value ignoring simple flow analysis
21152 if Status
= Is_Null
then
21155 -- Otherwise check whether N is a reference to an entity that appears
21156 -- within a conditional construct.
21158 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
21160 -- First check if we are in decisive conditional
21162 Get_Current_Value_Condition
(N
, Op
, Val
);
21164 if Known_Null
(Val
) then
21165 if Op
= N_Op_Eq
then
21167 elsif Op
= N_Op_Ne
then
21172 -- If OK to do replacement, test Is_Known_Null flag
21176 if OK_To_Do_Constant_Replacement
(Id
) then
21177 return Is_Known_Null
(Id
);
21181 -- Otherwise it is not possible to determine whether N yields a null
21187 --------------------------
21188 -- Known_To_Be_Assigned --
21189 --------------------------
21191 function Known_To_Be_Assigned
(N
: Node_Id
) return Boolean is
21192 P
: constant Node_Id
:= Parent
(N
);
21197 -- Test left side of assignment
21199 when N_Assignment_Statement
=>
21200 return N
= Name
(P
);
21202 -- Function call arguments are never lvalues
21204 when N_Function_Call
=>
21207 -- Positional parameter for procedure or accept call
21209 when N_Accept_Statement
21210 | N_Procedure_Call_Statement
21218 Proc
:= Get_Subprogram_Entity
(P
);
21224 -- If we are not a list member, something is strange, so
21225 -- be conservative and return False.
21227 if not Is_List_Member
(N
) then
21231 -- We are going to find the right formal by stepping forward
21232 -- through the formals, as we step backwards in the actuals.
21234 Form
:= First_Formal
(Proc
);
21237 -- If no formal, something is weird, so be conservative
21238 -- and return False.
21245 exit when No
(Act
);
21246 Next_Formal
(Form
);
21249 return Ekind
(Form
) /= E_In_Parameter
;
21252 -- Named parameter for procedure or accept call
21254 when N_Parameter_Association
=>
21260 Proc
:= Get_Subprogram_Entity
(Parent
(P
));
21266 -- Loop through formals to find the one that matches
21268 Form
:= First_Formal
(Proc
);
21270 -- If no matching formal, that's peculiar, some kind of
21271 -- previous error, so return False to be conservative.
21272 -- Actually this also happens in legal code in the case
21273 -- where P is a parameter association for an Extra_Formal???
21279 -- Else test for match
21281 if Chars
(Form
) = Chars
(Selector_Name
(P
)) then
21282 return Ekind
(Form
) /= E_In_Parameter
;
21285 Next_Formal
(Form
);
21289 -- Test for appearing in a conversion that itself appears
21290 -- in an lvalue context, since this should be an lvalue.
21292 when N_Type_Conversion
=>
21293 return Known_To_Be_Assigned
(P
);
21295 -- All other references are definitely not known to be modifications
21300 end Known_To_Be_Assigned
;
21302 ---------------------------
21303 -- Last_Source_Statement --
21304 ---------------------------
21306 function Last_Source_Statement
(HSS
: Node_Id
) return Node_Id
is
21310 N
:= Last
(Statements
(HSS
));
21311 while Present
(N
) loop
21312 exit when Comes_From_Source
(N
);
21317 end Last_Source_Statement
;
21319 -----------------------
21320 -- Mark_Coextensions --
21321 -----------------------
21323 procedure Mark_Coextensions
(Context_Nod
: Node_Id
; Root_Nod
: Node_Id
) is
21324 Is_Dynamic
: Boolean;
21325 -- Indicates whether the context causes nested coextensions to be
21326 -- dynamic or static
21328 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
;
21329 -- Recognize an allocator node and label it as a dynamic coextension
21331 --------------------
21332 -- Mark_Allocator --
21333 --------------------
21335 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
is
21337 if Nkind
(N
) = N_Allocator
then
21339 Set_Is_Static_Coextension
(N
, False);
21340 Set_Is_Dynamic_Coextension
(N
);
21342 -- If the allocator expression is potentially dynamic, it may
21343 -- be expanded out of order and require dynamic allocation
21344 -- anyway, so we treat the coextension itself as dynamic.
21345 -- Potential optimization ???
21347 elsif Nkind
(Expression
(N
)) = N_Qualified_Expression
21348 and then Nkind
(Expression
(Expression
(N
))) = N_Op_Concat
21350 Set_Is_Static_Coextension
(N
, False);
21351 Set_Is_Dynamic_Coextension
(N
);
21353 Set_Is_Dynamic_Coextension
(N
, False);
21354 Set_Is_Static_Coextension
(N
);
21359 end Mark_Allocator
;
21361 procedure Mark_Allocators
is new Traverse_Proc
(Mark_Allocator
);
21363 -- Start of processing for Mark_Coextensions
21366 -- An allocator that appears on the right-hand side of an assignment is
21367 -- treated as a potentially dynamic coextension when the right-hand side
21368 -- is an allocator or a qualified expression.
21370 -- Obj := new ...'(new Coextension ...);
21372 if Nkind
(Context_Nod
) = N_Assignment_Statement
then
21373 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) in
21374 N_Allocator | N_Qualified_Expression
;
21376 -- An allocator that appears within the expression of a simple return
21377 -- statement is treated as a potentially dynamic coextension when the
21378 -- expression is either aggregate, allocator, or qualified expression.
21380 -- return (new Coextension ...);
21381 -- return new ...'(new Coextension ...);
21383 elsif Nkind
(Context_Nod
) = N_Simple_Return_Statement
then
21384 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) in
21385 N_Aggregate | N_Allocator | N_Qualified_Expression
;
21387 -- An alloctor that appears within the initialization expression of an
21388 -- object declaration is considered a potentially dynamic coextension
21389 -- when the initialization expression is an allocator or a qualified
21392 -- Obj : ... := new ...'(new Coextension ...);
21394 -- A similar case arises when the object declaration is part of an
21395 -- extended return statement.
21397 -- return Obj : ... := new ...'(new Coextension ...);
21398 -- return Obj : ... := (new Coextension ...);
21400 elsif Nkind
(Context_Nod
) = N_Object_Declaration
then
21401 Is_Dynamic
:= Nkind
(Root_Nod
) in N_Allocator | N_Qualified_Expression
21402 or else Nkind
(Parent
(Context_Nod
)) = N_Extended_Return_Statement
;
21404 -- This routine should not be called with constructs that cannot contain
21408 raise Program_Error
;
21411 Mark_Allocators
(Root_Nod
);
21412 end Mark_Coextensions
;
21414 ---------------------------------
21415 -- Mark_Elaboration_Attributes --
21416 ---------------------------------
21418 procedure Mark_Elaboration_Attributes
21419 (N_Id
: Node_Or_Entity_Id
;
21420 Checks
: Boolean := False;
21421 Level
: Boolean := False;
21422 Modes
: Boolean := False;
21423 Warnings
: Boolean := False)
21425 function Elaboration_Checks_OK
21426 (Target_Id
: Entity_Id
;
21427 Context_Id
: Entity_Id
) return Boolean;
21428 -- Determine whether elaboration checks are enabled for target Target_Id
21429 -- which resides within context Context_Id.
21431 procedure Mark_Elaboration_Attributes_Id
(Id
: Entity_Id
);
21432 -- Preserve relevant attributes of the context in arbitrary entity Id
21434 procedure Mark_Elaboration_Attributes_Node
(N
: Node_Id
);
21435 -- Preserve relevant attributes of the context in arbitrary node N
21437 ---------------------------
21438 -- Elaboration_Checks_OK --
21439 ---------------------------
21441 function Elaboration_Checks_OK
21442 (Target_Id
: Entity_Id
;
21443 Context_Id
: Entity_Id
) return Boolean
21445 Encl_Scop
: Entity_Id
;
21448 -- Elaboration checks are suppressed for the target
21450 if Elaboration_Checks_Suppressed
(Target_Id
) then
21454 -- Otherwise elaboration checks are OK for the target, but may be
21455 -- suppressed for the context where the target is declared.
21457 Encl_Scop
:= Context_Id
;
21458 while Present
(Encl_Scop
) and then Encl_Scop
/= Standard_Standard
loop
21459 if Elaboration_Checks_Suppressed
(Encl_Scop
) then
21463 Encl_Scop
:= Scope
(Encl_Scop
);
21466 -- Neither the target nor its declarative context have elaboration
21467 -- checks suppressed.
21470 end Elaboration_Checks_OK
;
21472 ------------------------------------
21473 -- Mark_Elaboration_Attributes_Id --
21474 ------------------------------------
21476 procedure Mark_Elaboration_Attributes_Id
(Id
: Entity_Id
) is
21478 -- Mark the status of elaboration checks in effect. Do not reset the
21479 -- status in case the entity is reanalyzed with checks suppressed.
21481 if Checks
and then not Is_Elaboration_Checks_OK_Id
(Id
) then
21482 Set_Is_Elaboration_Checks_OK_Id
(Id
,
21483 Elaboration_Checks_OK
21485 Context_Id
=> Scope
(Id
)));
21488 -- Mark the status of elaboration warnings in effect. Do not reset
21489 -- the status in case the entity is reanalyzed with warnings off.
21491 if Warnings
and then not Is_Elaboration_Warnings_OK_Id
(Id
) then
21492 Set_Is_Elaboration_Warnings_OK_Id
(Id
, Elab_Warnings
);
21494 end Mark_Elaboration_Attributes_Id
;
21496 --------------------------------------
21497 -- Mark_Elaboration_Attributes_Node --
21498 --------------------------------------
21500 procedure Mark_Elaboration_Attributes_Node
(N
: Node_Id
) is
21501 function Extract_Name
(N
: Node_Id
) return Node_Id
;
21502 -- Obtain the Name attribute of call or instantiation N
21508 function Extract_Name
(N
: Node_Id
) return Node_Id
is
21514 -- A call to an entry family appears in indexed form
21516 if Nkind
(Nam
) = N_Indexed_Component
then
21517 Nam
:= Prefix
(Nam
);
21520 -- The name may also appear in qualified form
21522 if Nkind
(Nam
) = N_Selected_Component
then
21523 Nam
:= Selector_Name
(Nam
);
21531 Context_Id
: Entity_Id
;
21534 -- Start of processing for Mark_Elaboration_Attributes_Node
21537 -- Mark the status of elaboration checks in effect. Do not reset the
21538 -- status in case the node is reanalyzed with checks suppressed.
21540 if Checks
and then not Is_Elaboration_Checks_OK_Node
(N
) then
21542 -- Assignments, attribute references, and variable references do
21543 -- not have a "declarative" context.
21545 Context_Id
:= Empty
;
21547 -- The status of elaboration checks for calls and instantiations
21548 -- depends on the most recent pragma Suppress/Unsuppress, as well
21549 -- as the suppression status of the context where the target is
21553 -- function Func ...;
21557 -- procedure Main is
21558 -- pragma Suppress (Elaboration_Checks, Pack);
21559 -- X : ... := Pack.Func;
21562 -- In the example above, the call to Func has elaboration checks
21563 -- enabled because there is no active general purpose suppression
21564 -- pragma, however the elaboration checks of Pack are explicitly
21565 -- suppressed. As a result the elaboration checks of the call must
21566 -- be disabled in order to preserve this dependency.
21568 if Nkind
(N
) in N_Entry_Call_Statement
21570 | N_Function_Instantiation
21571 | N_Package_Instantiation
21572 | N_Procedure_Call_Statement
21573 | N_Procedure_Instantiation
21575 Nam
:= Extract_Name
(N
);
21577 if Is_Entity_Name
(Nam
) and then Present
(Entity
(Nam
)) then
21578 Context_Id
:= Scope
(Entity
(Nam
));
21582 Set_Is_Elaboration_Checks_OK_Node
(N
,
21583 Elaboration_Checks_OK
21584 (Target_Id
=> Empty
,
21585 Context_Id
=> Context_Id
));
21588 -- Mark the enclosing level of the node. Do not reset the status in
21589 -- case the node is relocated and reanalyzed.
21591 if Level
and then not Is_Declaration_Level_Node
(N
) then
21592 Set_Is_Declaration_Level_Node
(N
,
21593 Find_Enclosing_Level
(N
) = Declaration_Level
);
21596 -- Mark the Ghost and SPARK mode in effect
21599 if Ghost_Mode
= Ignore
then
21600 Set_Is_Ignored_Ghost_Node
(N
);
21603 if SPARK_Mode
= On
then
21604 Set_Is_SPARK_Mode_On_Node
(N
);
21608 -- Mark the status of elaboration warnings in effect. Do not reset
21609 -- the status in case the node is reanalyzed with warnings off.
21611 if Warnings
and then not Is_Elaboration_Warnings_OK_Node
(N
) then
21612 Set_Is_Elaboration_Warnings_OK_Node
(N
, Elab_Warnings
);
21614 end Mark_Elaboration_Attributes_Node
;
21616 -- Start of processing for Mark_Elaboration_Attributes
21619 -- Do not capture any elaboration-related attributes when switch -gnatH
21620 -- (legacy elaboration checking mode enabled) is in effect because the
21621 -- attributes are useless to the legacy model.
21623 if Legacy_Elaboration_Checks
then
21627 if Nkind
(N_Id
) in N_Entity
then
21628 Mark_Elaboration_Attributes_Id
(N_Id
);
21630 Mark_Elaboration_Attributes_Node
(N_Id
);
21632 end Mark_Elaboration_Attributes
;
21634 ----------------------------------------
21635 -- Mark_Save_Invocation_Graph_Of_Body --
21636 ----------------------------------------
21638 procedure Mark_Save_Invocation_Graph_Of_Body
is
21639 Main
: constant Node_Id
:= Cunit
(Main_Unit
);
21640 Main_Unit
: constant Node_Id
:= Unit
(Main
);
21641 Aux_Id
: Entity_Id
;
21644 Set_Save_Invocation_Graph_Of_Body
(Main
);
21646 -- Assume that the main unit does not have a complimentary unit
21650 -- Obtain the complimentary unit of the main unit
21652 if Nkind
(Main_Unit
) in N_Generic_Package_Declaration
21653 | N_Generic_Subprogram_Declaration
21654 | N_Package_Declaration
21655 | N_Subprogram_Declaration
21657 Aux_Id
:= Corresponding_Body
(Main_Unit
);
21659 elsif Nkind
(Main_Unit
) in N_Package_Body
21660 | N_Subprogram_Body
21661 | N_Subprogram_Renaming_Declaration
21663 Aux_Id
:= Corresponding_Spec
(Main_Unit
);
21666 if Present
(Aux_Id
) then
21667 Set_Save_Invocation_Graph_Of_Body
21668 (Parent
(Unit_Declaration_Node
(Aux_Id
)));
21670 end Mark_Save_Invocation_Graph_Of_Body
;
21672 ----------------------------------
21673 -- Matching_Static_Array_Bounds --
21674 ----------------------------------
21676 function Matching_Static_Array_Bounds
21678 R_Typ
: Node_Id
) return Boolean
21680 L_Ndims
: constant Nat
:= Number_Dimensions
(L_Typ
);
21681 R_Ndims
: constant Nat
:= Number_Dimensions
(R_Typ
);
21683 L_Index
: Node_Id
:= Empty
; -- init to ...
21684 R_Index
: Node_Id
:= Empty
; -- ...avoid warnings
21693 if L_Ndims
/= R_Ndims
then
21697 -- Unconstrained types do not have static bounds
21699 if not Is_Constrained
(L_Typ
) or else not Is_Constrained
(R_Typ
) then
21703 -- First treat specially the first dimension, as the lower bound and
21704 -- length of string literals are not stored like those of arrays.
21706 if Ekind
(L_Typ
) = E_String_Literal_Subtype
then
21707 L_Low
:= String_Literal_Low_Bound
(L_Typ
);
21708 L_Len
:= String_Literal_Length
(L_Typ
);
21710 L_Index
:= First_Index
(L_Typ
);
21711 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
21713 if Is_OK_Static_Expression
(L_Low
)
21715 Is_OK_Static_Expression
(L_High
)
21717 if Expr_Value
(L_High
) < Expr_Value
(L_Low
) then
21720 L_Len
:= (Expr_Value
(L_High
) - Expr_Value
(L_Low
)) + 1;
21727 if Ekind
(R_Typ
) = E_String_Literal_Subtype
then
21728 R_Low
:= String_Literal_Low_Bound
(R_Typ
);
21729 R_Len
:= String_Literal_Length
(R_Typ
);
21731 R_Index
:= First_Index
(R_Typ
);
21732 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
21734 if Is_OK_Static_Expression
(R_Low
)
21736 Is_OK_Static_Expression
(R_High
)
21738 if Expr_Value
(R_High
) < Expr_Value
(R_Low
) then
21741 R_Len
:= (Expr_Value
(R_High
) - Expr_Value
(R_Low
)) + 1;
21748 if (Is_OK_Static_Expression
(L_Low
)
21750 Is_OK_Static_Expression
(R_Low
))
21751 and then Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
21752 and then L_Len
= R_Len
21759 -- Then treat all other dimensions
21761 for Indx
in 2 .. L_Ndims
loop
21765 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
21766 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
21768 if (Is_OK_Static_Expression
(L_Low
) and then
21769 Is_OK_Static_Expression
(L_High
) and then
21770 Is_OK_Static_Expression
(R_Low
) and then
21771 Is_OK_Static_Expression
(R_High
))
21772 and then (Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
21774 Expr_Value
(L_High
) = Expr_Value
(R_High
))
21782 -- If we fall through the loop, all indexes matched
21785 end Matching_Static_Array_Bounds
;
21787 -------------------
21788 -- May_Be_Lvalue --
21789 -------------------
21791 function May_Be_Lvalue
(N
: Node_Id
) return Boolean is
21792 P
: constant Node_Id
:= Parent
(N
);
21797 -- Test left side of assignment
21799 when N_Assignment_Statement
=>
21800 return N
= Name
(P
);
21802 -- Test prefix of component or attribute. Note that the prefix of an
21803 -- explicit or implicit dereference cannot be an l-value. In the case
21804 -- of a 'Read attribute, the reference can be an actual in the
21805 -- argument list of the attribute.
21807 when N_Attribute_Reference
=>
21808 return (N
= Prefix
(P
)
21809 and then Name_Implies_Lvalue_Prefix
(Attribute_Name
(P
)))
21811 Attribute_Name
(P
) = Name_Read
;
21813 -- For an expanded name, the name is an lvalue if the expanded name
21814 -- is an lvalue, but the prefix is never an lvalue, since it is just
21815 -- the scope where the name is found.
21817 when N_Expanded_Name
=>
21818 if N
= Prefix
(P
) then
21819 return May_Be_Lvalue
(P
);
21824 -- For a selected component A.B, A is certainly an lvalue if A.B is.
21825 -- B is a little interesting, if we have A.B := 3, there is some
21826 -- discussion as to whether B is an lvalue or not, we choose to say
21827 -- it is. Note however that A is not an lvalue if it is of an access
21828 -- type since this is an implicit dereference.
21830 when N_Selected_Component
=>
21832 and then Present
(Etype
(N
))
21833 and then Is_Access_Type
(Etype
(N
))
21837 return May_Be_Lvalue
(P
);
21840 -- For an indexed component or slice, the index or slice bounds is
21841 -- never an lvalue. The prefix is an lvalue if the indexed component
21842 -- or slice is an lvalue, except if it is an access type, where we
21843 -- have an implicit dereference.
21845 when N_Indexed_Component
21849 or else (Present
(Etype
(N
)) and then Is_Access_Type
(Etype
(N
)))
21853 return May_Be_Lvalue
(P
);
21856 -- Prefix of a reference is an lvalue if the reference is an lvalue
21858 when N_Reference
=>
21859 return May_Be_Lvalue
(P
);
21861 -- Prefix of explicit dereference is never an lvalue
21863 when N_Explicit_Dereference
=>
21866 -- Positional parameter for subprogram, entry, or accept call.
21867 -- In older versions of Ada function call arguments are never
21868 -- lvalues. In Ada 2012 functions can have in-out parameters.
21870 when N_Accept_Statement
21871 | N_Entry_Call_Statement
21872 | N_Subprogram_Call
21874 if Nkind
(P
) = N_Function_Call
and then Ada_Version
< Ada_2012
then
21878 -- The following mechanism is clumsy and fragile. A single flag
21879 -- set in Resolve_Actuals would be preferable ???
21887 Proc
:= Get_Subprogram_Entity
(P
);
21893 -- If we are not a list member, something is strange, so be
21894 -- conservative and return True.
21896 if not Is_List_Member
(N
) then
21900 -- We are going to find the right formal by stepping forward
21901 -- through the formals, as we step backwards in the actuals.
21903 Form
:= First_Formal
(Proc
);
21906 -- If no formal, something is weird, so be conservative and
21914 exit when No
(Act
);
21915 Next_Formal
(Form
);
21918 return Ekind
(Form
) /= E_In_Parameter
;
21921 -- Named parameter for procedure or accept call
21923 when N_Parameter_Association
=>
21929 Proc
:= Get_Subprogram_Entity
(Parent
(P
));
21935 -- Loop through formals to find the one that matches
21937 Form
:= First_Formal
(Proc
);
21939 -- If no matching formal, that's peculiar, some kind of
21940 -- previous error, so return True to be conservative.
21941 -- Actually happens with legal code for an unresolved call
21942 -- where we may get the wrong homonym???
21948 -- Else test for match
21950 if Chars
(Form
) = Chars
(Selector_Name
(P
)) then
21951 return Ekind
(Form
) /= E_In_Parameter
;
21954 Next_Formal
(Form
);
21958 -- Test for appearing in a conversion that itself appears in an
21959 -- lvalue context, since this should be an lvalue.
21961 when N_Type_Conversion
=>
21962 return May_Be_Lvalue
(P
);
21964 -- Test for appearance in object renaming declaration
21966 when N_Object_Renaming_Declaration
=>
21969 -- All other references are definitely not lvalues
21980 function Might_Raise
(N
: Node_Id
) return Boolean is
21981 Result
: Boolean := False;
21983 function Process
(N
: Node_Id
) return Traverse_Result
;
21984 -- Set Result to True if we find something that could raise an exception
21990 function Process
(N
: Node_Id
) return Traverse_Result
is
21992 if Nkind
(N
) in N_Procedure_Call_Statement
21994 | N_Raise_Statement
21995 | N_Raise_xxx_Error
22004 procedure Set_Result
is new Traverse_Proc
(Process
);
22006 -- Start of processing for Might_Raise
22009 -- False if exceptions can't be propagated
22011 if No_Exception_Handlers_Set
then
22015 -- If the checks handled by the back end are not disabled, we cannot
22016 -- ensure that no exception will be raised.
22018 if not Access_Checks_Suppressed
(Empty
)
22019 or else not Discriminant_Checks_Suppressed
(Empty
)
22020 or else not Range_Checks_Suppressed
(Empty
)
22021 or else not Index_Checks_Suppressed
(Empty
)
22022 or else Opt
.Stack_Checking_Enabled
22031 --------------------------------
22032 -- Nearest_Enclosing_Instance --
22033 --------------------------------
22035 function Nearest_Enclosing_Instance
(E
: Entity_Id
) return Entity_Id
is
22040 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
22041 if Is_Generic_Instance
(Inst
) then
22045 Inst
:= Scope
(Inst
);
22049 end Nearest_Enclosing_Instance
;
22051 ------------------------
22052 -- Needs_Finalization --
22053 ------------------------
22055 function Needs_Finalization
(Typ
: Entity_Id
) return Boolean is
22056 function Has_Some_Controlled_Component
22057 (Input_Typ
: Entity_Id
) return Boolean;
22058 -- Determine whether type Input_Typ has at least one controlled
22061 -----------------------------------
22062 -- Has_Some_Controlled_Component --
22063 -----------------------------------
22065 function Has_Some_Controlled_Component
22066 (Input_Typ
: Entity_Id
) return Boolean
22071 -- When a type is already frozen and has at least one controlled
22072 -- component, or is manually decorated, it is sufficient to inspect
22073 -- flag Has_Controlled_Component.
22075 if Has_Controlled_Component
(Input_Typ
) then
22078 -- Otherwise inspect the internals of the type
22080 elsif not Is_Frozen
(Input_Typ
) then
22081 if Is_Array_Type
(Input_Typ
) then
22082 return Needs_Finalization
(Component_Type
(Input_Typ
));
22084 elsif Is_Record_Type
(Input_Typ
) then
22085 Comp
:= First_Component
(Input_Typ
);
22086 while Present
(Comp
) loop
22087 if Needs_Finalization
(Etype
(Comp
)) then
22091 Next_Component
(Comp
);
22097 end Has_Some_Controlled_Component
;
22099 -- Start of processing for Needs_Finalization
22102 -- Certain run-time configurations and targets do not provide support
22103 -- for controlled types.
22105 if Restriction_Active
(No_Finalization
) then
22108 -- C++ types are not considered controlled. It is assumed that the non-
22109 -- Ada side will handle their clean up.
22111 elsif Convention
(Typ
) = Convention_CPP
then
22114 -- Class-wide types are treated as controlled because derivations from
22115 -- the root type may introduce controlled components.
22117 elsif Is_Class_Wide_Type
(Typ
) then
22120 -- Concurrent types are controlled as long as their corresponding record
22123 elsif Is_Concurrent_Type
(Typ
)
22124 and then Present
(Corresponding_Record_Type
(Typ
))
22125 and then Needs_Finalization
(Corresponding_Record_Type
(Typ
))
22129 -- Otherwise the type is controlled when it is either derived from type
22130 -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or
22131 -- contains at least one controlled component.
22135 Is_Controlled
(Typ
) or else Has_Some_Controlled_Component
(Typ
);
22137 end Needs_Finalization
;
22139 ----------------------
22140 -- Needs_One_Actual --
22141 ----------------------
22143 function Needs_One_Actual
(E
: Entity_Id
) return Boolean is
22144 Formal
: Entity_Id
;
22147 -- Ada 2005 or later, and formals present. The first formal must be
22148 -- of a type that supports prefix notation: a controlling argument,
22149 -- a class-wide type, or an access to such.
22151 if Ada_Version
>= Ada_2005
22152 and then Present
(First_Formal
(E
))
22153 and then No
(Default_Value
(First_Formal
(E
)))
22155 (Is_Controlling_Formal
(First_Formal
(E
))
22156 or else Is_Class_Wide_Type
(Etype
(First_Formal
(E
)))
22157 or else Is_Anonymous_Access_Type
(Etype
(First_Formal
(E
))))
22159 Formal
:= Next_Formal
(First_Formal
(E
));
22160 while Present
(Formal
) loop
22161 if No
(Default_Value
(Formal
)) then
22165 Next_Formal
(Formal
);
22170 -- Ada 83/95 or no formals
22175 end Needs_One_Actual
;
22177 --------------------------------------
22178 -- Needs_Result_Accessibility_Level --
22179 --------------------------------------
22181 function Needs_Result_Accessibility_Level
22182 (Func_Id
: Entity_Id
) return Boolean
22184 Func_Typ
: constant Entity_Id
:= Underlying_Type
(Etype
(Func_Id
));
22186 function Has_Unconstrained_Access_Discriminant_Component
22187 (Comp_Typ
: Entity_Id
) return Boolean;
22188 -- Returns True if any component of the type has an unconstrained access
22191 -----------------------------------------------------
22192 -- Has_Unconstrained_Access_Discriminant_Component --
22193 -----------------------------------------------------
22195 function Has_Unconstrained_Access_Discriminant_Component
22196 (Comp_Typ
: Entity_Id
) return Boolean
22199 if not Is_Limited_Type
(Comp_Typ
) then
22202 -- Only limited types can have access discriminants with
22205 elsif Has_Unconstrained_Access_Discriminants
(Comp_Typ
) then
22208 elsif Is_Array_Type
(Comp_Typ
) then
22209 return Has_Unconstrained_Access_Discriminant_Component
22210 (Underlying_Type
(Component_Type
(Comp_Typ
)));
22212 elsif Is_Record_Type
(Comp_Typ
) then
22217 Comp
:= First_Component
(Comp_Typ
);
22218 while Present
(Comp
) loop
22219 if Has_Unconstrained_Access_Discriminant_Component
22220 (Underlying_Type
(Etype
(Comp
)))
22225 Next_Component
(Comp
);
22231 end Has_Unconstrained_Access_Discriminant_Component
;
22233 Disable_Coextension_Cases
: constant Boolean := True;
22234 -- Flag used to temporarily disable a "True" result for types with
22235 -- access discriminants and related coextension cases.
22237 -- Start of processing for Needs_Result_Accessibility_Level
22240 -- False if completion unavailable (how does this happen???)
22242 if not Present
(Func_Typ
) then
22245 -- False if not a function, also handle enum-lit renames case
22247 elsif Func_Typ
= Standard_Void_Type
22248 or else Is_Scalar_Type
(Func_Typ
)
22252 -- Handle a corner case, a cross-dialect subp renaming. For example,
22253 -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
22254 -- an Ada 2005 (or earlier) unit references predefined run-time units.
22256 elsif Present
(Alias
(Func_Id
)) then
22258 -- Unimplemented: a cross-dialect subp renaming which does not set
22259 -- the Alias attribute (e.g., a rename of a dereference of an access
22260 -- to subprogram value). ???
22262 return Present
(Extra_Accessibility_Of_Result
(Alias
(Func_Id
)));
22264 -- Remaining cases require Ada 2012 mode
22266 elsif Ada_Version
< Ada_2012
then
22269 -- Handle the situation where a result is an anonymous access type
22270 -- RM 3.10.2 (10.3/3).
22272 elsif Ekind
(Func_Typ
) = E_Anonymous_Access_Type
then
22275 -- The following cases are related to coextensions and do not fully
22276 -- cover everything mentioned in RM 3.10.2 (12) ???
22278 -- Temporarily disabled ???
22280 elsif Disable_Coextension_Cases
then
22283 -- In the case of, say, a null tagged record result type, the need for
22284 -- this extra parameter might not be obvious so this function returns
22285 -- True for all tagged types for compatibility reasons.
22287 -- A function with, say, a tagged null controlling result type might
22288 -- be overridden by a primitive of an extension having an access
22289 -- discriminant and the overrider and overridden must have compatible
22290 -- calling conventions (including implicitly declared parameters).
22292 -- Similarly, values of one access-to-subprogram type might designate
22293 -- both a primitive subprogram of a given type and a function which is,
22294 -- for example, not a primitive subprogram of any type. Again, this
22295 -- requires calling convention compatibility. It might be possible to
22296 -- solve these issues by introducing wrappers, but that is not the
22297 -- approach that was chosen.
22299 elsif Is_Tagged_Type
(Func_Typ
) then
22302 elsif Has_Unconstrained_Access_Discriminants
(Func_Typ
) then
22305 elsif Has_Unconstrained_Access_Discriminant_Component
(Func_Typ
) then
22308 -- False for all other cases
22313 end Needs_Result_Accessibility_Level
;
22315 ---------------------------------
22316 -- Needs_Simple_Initialization --
22317 ---------------------------------
22319 function Needs_Simple_Initialization
22321 Consider_IS
: Boolean := True) return Boolean
22323 Consider_IS_NS
: constant Boolean :=
22324 Normalize_Scalars
or (Initialize_Scalars
and Consider_IS
);
22327 -- Never need initialization if it is suppressed
22329 if Initialization_Suppressed
(Typ
) then
22333 -- Check for private type, in which case test applies to the underlying
22334 -- type of the private type.
22336 if Is_Private_Type
(Typ
) then
22338 RT
: constant Entity_Id
:= Underlying_Type
(Typ
);
22340 if Present
(RT
) then
22341 return Needs_Simple_Initialization
(RT
);
22347 -- Scalar type with Default_Value aspect requires initialization
22349 elsif Is_Scalar_Type
(Typ
) and then Has_Default_Aspect
(Typ
) then
22352 -- Cases needing simple initialization are access types, and, if pragma
22353 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
22356 elsif Is_Access_Type
(Typ
)
22357 or else (Consider_IS_NS
and then (Is_Scalar_Type
(Typ
)))
22361 -- If Initialize/Normalize_Scalars is in effect, string objects also
22362 -- need initialization, unless they are created in the course of
22363 -- expanding an aggregate (since in the latter case they will be
22364 -- filled with appropriate initializing values before they are used).
22366 elsif Consider_IS_NS
22367 and then Is_Standard_String_Type
(Typ
)
22369 (not Is_Itype
(Typ
)
22370 or else Nkind
(Associated_Node_For_Itype
(Typ
)) /= N_Aggregate
)
22377 end Needs_Simple_Initialization
;
22379 -------------------------------------
22380 -- Needs_Variable_Reference_Marker --
22381 -------------------------------------
22383 function Needs_Variable_Reference_Marker
22385 Calls_OK
: Boolean) return Boolean
22387 function Within_Suitable_Context
(Ref
: Node_Id
) return Boolean;
22388 -- Deteremine whether variable reference Ref appears within a suitable
22389 -- context that allows the creation of a marker.
22391 -----------------------------
22392 -- Within_Suitable_Context --
22393 -----------------------------
22395 function Within_Suitable_Context
(Ref
: Node_Id
) return Boolean is
22400 while Present
(Par
) loop
22402 -- The context is not suitable when the reference appears within
22403 -- the formal part of an instantiation which acts as compilation
22404 -- unit because there is no proper list for the insertion of the
22407 if Nkind
(Par
) = N_Generic_Association
22408 and then Nkind
(Parent
(Par
)) in N_Generic_Instantiation
22409 and then Nkind
(Parent
(Parent
(Par
))) = N_Compilation_Unit
22413 -- The context is not suitable when the reference appears within
22414 -- a pragma. If the pragma has run-time semantics, the reference
22415 -- will be reconsidered once the pragma is expanded.
22417 elsif Nkind
(Par
) = N_Pragma
then
22420 -- The context is not suitable when the reference appears within a
22421 -- subprogram call, and the caller requests this behavior.
22424 and then Nkind
(Par
) in N_Entry_Call_Statement
22426 | N_Procedure_Call_Statement
22430 -- Prevent the search from going too far
22432 elsif Is_Body_Or_Package_Declaration
(Par
) then
22436 Par
:= Parent
(Par
);
22440 end Within_Suitable_Context
;
22445 Var_Id
: Entity_Id
;
22447 -- Start of processing for Needs_Variable_Reference_Marker
22450 -- No marker needs to be created when switch -gnatH (legacy elaboration
22451 -- checking mode enabled) is in effect because the legacy ABE mechanism
22452 -- does not use markers.
22454 if Legacy_Elaboration_Checks
then
22457 -- No marker needs to be created when the reference is preanalyzed
22458 -- because the marker will be inserted in the wrong place.
22460 elsif Preanalysis_Active
then
22463 -- Only references warrant a marker
22465 elsif Nkind
(N
) not in N_Expanded_Name | N_Identifier
then
22468 -- Only source references warrant a marker
22470 elsif not Comes_From_Source
(N
) then
22473 -- No marker needs to be created when the reference is erroneous, left
22474 -- in a bad state, or does not denote a variable.
22476 elsif not (Present
(Entity
(N
))
22477 and then Ekind
(Entity
(N
)) = E_Variable
22478 and then Entity
(N
) /= Any_Id
)
22483 Var_Id
:= Entity
(N
);
22484 Prag
:= SPARK_Pragma
(Var_Id
);
22486 -- Both the variable and reference must appear in SPARK_Mode On regions
22487 -- because this elaboration scenario falls under the SPARK rules.
22489 if not (Comes_From_Source
(Var_Id
)
22490 and then Present
(Prag
)
22491 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
22492 and then Is_SPARK_Mode_On_Node
(N
))
22496 -- No marker needs to be created when the reference does not appear
22497 -- within a suitable context (see body for details).
22499 -- Performance note: parent traversal
22501 elsif not Within_Suitable_Context
(N
) then
22505 -- At this point it is known that the variable reference will play a
22506 -- role in ABE diagnostics and requires a marker.
22509 end Needs_Variable_Reference_Marker
;
22511 ------------------------
22512 -- New_Copy_List_Tree --
22513 ------------------------
22515 function New_Copy_List_Tree
(List
: List_Id
) return List_Id
is
22520 if List
= No_List
then
22527 while Present
(E
) loop
22528 Append
(New_Copy_Tree
(E
), NL
);
22534 end New_Copy_List_Tree
;
22536 ----------------------------
22537 -- New_Copy_Separate_List --
22538 ----------------------------
22540 function New_Copy_Separate_List
(List
: List_Id
) return List_Id
is
22542 if List
= No_List
then
22547 List_Copy
: constant List_Id
:= New_List
;
22548 N
: Node_Id
:= First
(List
);
22551 while Present
(N
) loop
22552 Append
(New_Copy_Separate_Tree
(N
), List_Copy
);
22559 end New_Copy_Separate_List
;
22561 ----------------------------
22562 -- New_Copy_Separate_Tree --
22563 ----------------------------
22565 function New_Copy_Separate_Tree
(Source
: Node_Id
) return Node_Id
is
22566 function Search_Decl
(N
: Node_Id
) return Traverse_Result
;
22567 -- Subtree visitor which collects declarations
22569 procedure Search_Declarations
is new Traverse_Proc
(Search_Decl
);
22570 -- Subtree visitor instantiation
22578 function Search_Decl
(N
: Node_Id
) return Traverse_Result
is
22580 if Nkind
(N
) in N_Declaration
then
22581 Append_New_Elmt
(N
, Decls
);
22589 Source_Copy
: constant Node_Id
:= New_Copy_Tree
(Source
);
22591 -- Start of processing for New_Copy_Separate_Tree
22595 Search_Declarations
(Source_Copy
);
22597 -- Associate a new Entity with all the subtree declarations (keeping
22598 -- their original name).
22600 if Present
(Decls
) then
22607 Elmt
:= First_Elmt
(Decls
);
22608 while Present
(Elmt
) loop
22609 Decl
:= Node
(Elmt
);
22610 New_E
:= Make_Defining_Identifier
(Sloc
(Decl
),
22611 New_Internal_Name
('P'));
22613 if Nkind
(Decl
) = N_Expression_Function
then
22614 Decl
:= Specification
(Decl
);
22617 if Nkind
(Decl
) in N_Function_Instantiation
22618 | N_Function_Specification
22619 | N_Generic_Function_Renaming_Declaration
22620 | N_Generic_Package_Renaming_Declaration
22621 | N_Generic_Procedure_Renaming_Declaration
22623 | N_Package_Instantiation
22624 | N_Package_Renaming_Declaration
22625 | N_Package_Specification
22626 | N_Procedure_Instantiation
22627 | N_Procedure_Specification
22629 Set_Chars
(New_E
, Chars
(Defining_Unit_Name
(Decl
)));
22630 Set_Defining_Unit_Name
(Decl
, New_E
);
22632 Set_Chars
(New_E
, Chars
(Defining_Identifier
(Decl
)));
22633 Set_Defining_Identifier
(Decl
, New_E
);
22641 return Source_Copy
;
22642 end New_Copy_Separate_Tree
;
22644 -------------------
22645 -- New_Copy_Tree --
22646 -------------------
22648 -- The following tables play a key role in replicating entities and Itypes.
22649 -- They are intentionally declared at the library level rather than within
22650 -- New_Copy_Tree to avoid elaborating them on each call. This performance
22651 -- optimization saves up to 2% of the entire compilation time spent in the
22652 -- front end. Care should be taken to reset the tables on each new call to
22655 NCT_Table_Max
: constant := 511;
22657 subtype NCT_Table_Index
is Nat
range 0 .. NCT_Table_Max
- 1;
22659 function NCT_Table_Hash
(Key
: Node_Or_Entity_Id
) return NCT_Table_Index
;
22660 -- Obtain the hash value of node or entity Key
22662 --------------------
22663 -- NCT_Table_Hash --
22664 --------------------
22666 function NCT_Table_Hash
(Key
: Node_Or_Entity_Id
) return NCT_Table_Index
is
22668 return NCT_Table_Index
(Key
mod NCT_Table_Max
);
22669 end NCT_Table_Hash
;
22671 ----------------------
22672 -- NCT_New_Entities --
22673 ----------------------
22675 -- The following table maps old entities and Itypes to their corresponding
22676 -- new entities and Itypes.
22680 package NCT_New_Entities
is new Simple_HTable
(
22681 Header_Num
=> NCT_Table_Index
,
22682 Element
=> Entity_Id
,
22683 No_Element
=> Empty
,
22685 Hash
=> NCT_Table_Hash
,
22688 ------------------------
22689 -- NCT_Pending_Itypes --
22690 ------------------------
22692 -- The following table maps old Associated_Node_For_Itype nodes to a set of
22693 -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three
22694 -- have the same Associated_Node_For_Itype Ppp, and their corresponding new
22695 -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping:
22697 -- Ppp -> (Xxx, Yyy, Zzz)
22699 -- The set is expressed as an Elist
22701 package NCT_Pending_Itypes
is new Simple_HTable
(
22702 Header_Num
=> NCT_Table_Index
,
22703 Element
=> Elist_Id
,
22704 No_Element
=> No_Elist
,
22706 Hash
=> NCT_Table_Hash
,
22709 NCT_Tables_In_Use
: Boolean := False;
22710 -- This flag keeps track of whether the two tables NCT_New_Entities and
22711 -- NCT_Pending_Itypes are in use. The flag is part of an optimization
22712 -- where certain operations are not performed if the tables are not in
22713 -- use. This saves up to 8% of the entire compilation time spent in the
22716 -------------------
22717 -- New_Copy_Tree --
22718 -------------------
22720 function New_Copy_Tree
22722 Map
: Elist_Id
:= No_Elist
;
22723 New_Sloc
: Source_Ptr
:= No_Location
;
22724 New_Scope
: Entity_Id
:= Empty
;
22725 Scopes_In_EWA_OK
: Boolean := False) return Node_Id
22727 -- This routine performs low-level tree manipulations and needs access
22728 -- to the internals of the tree.
22730 use Atree
.Unchecked_Access
;
22731 use Atree_Private_Part
;
22733 EWA_Level
: Nat
:= 0;
22734 -- This counter keeps track of how many N_Expression_With_Actions nodes
22735 -- are encountered during a depth-first traversal of the subtree. These
22736 -- nodes may define new entities in their Actions lists and thus require
22737 -- special processing.
22739 EWA_Inner_Scope_Level
: Nat
:= 0;
22740 -- This counter keeps track of how many scoping constructs appear within
22741 -- an N_Expression_With_Actions node.
22743 procedure Add_New_Entity
(Old_Id
: Entity_Id
; New_Id
: Entity_Id
);
22744 pragma Inline
(Add_New_Entity
);
22745 -- Add an entry in the NCT_New_Entities table which maps key Old_Id to
22746 -- value New_Id. Old_Id is an entity which appears within the Actions
22747 -- list of an N_Expression_With_Actions node, or within an entity map.
22748 -- New_Id is the corresponding new entity generated during Phase 1.
22750 procedure Add_Pending_Itype
(Assoc_Nod
: Node_Id
; Itype
: Entity_Id
);
22751 pragma Inline
(Add_Pending_Itype
);
22752 -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to
22753 -- value Itype. Assoc_Nod is the associated node of an itype. Itype is
22756 procedure Build_NCT_Tables
(Entity_Map
: Elist_Id
);
22757 pragma Inline
(Build_NCT_Tables
);
22758 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the
22759 -- information supplied in entity map Entity_Map. The format of the
22760 -- entity map must be as follows:
22762 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
22764 function Copy_Any_Node_With_Replacement
22765 (N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
;
22766 pragma Inline
(Copy_Any_Node_With_Replacement
);
22767 -- Replicate entity or node N by invoking one of the following routines:
22769 -- Copy_Node_With_Replacement
22770 -- Corresponding_Entity
22772 function Copy_Elist_With_Replacement
(List
: Elist_Id
) return Elist_Id
;
22773 -- Replicate the elements of entity list List
22775 function Copy_Field_With_Replacement
22777 Old_Par
: Node_Id
:= Empty
;
22778 New_Par
: Node_Id
:= Empty
;
22779 Semantic
: Boolean := False) return Union_Id
;
22780 -- Replicate field Field by invoking one of the following routines:
22782 -- Copy_Elist_With_Replacement
22783 -- Copy_List_With_Replacement
22784 -- Copy_Node_With_Replacement
22785 -- Corresponding_Entity
22787 -- If the field is not an entity list, entity, itype, syntactic list,
22788 -- or node, then the field is returned unchanged. The routine always
22789 -- replicates entities, itypes, and valid syntactic fields. Old_Par is
22790 -- the expected parent of a syntactic field. New_Par is the new parent
22791 -- associated with a replicated syntactic field. Flag Semantic should
22792 -- be set when the input is a semantic field.
22794 function Copy_List_With_Replacement
(List
: List_Id
) return List_Id
;
22795 -- Replicate the elements of syntactic list List
22797 function Copy_Node_With_Replacement
(N
: Node_Id
) return Node_Id
;
22798 -- Replicate node N
22800 function Corresponding_Entity
(Id
: Entity_Id
) return Entity_Id
;
22801 pragma Inline
(Corresponding_Entity
);
22802 -- Return the corresponding new entity of Id generated during Phase 1.
22803 -- If there is no such entity, return Id.
22805 function In_Entity_Map
22807 Entity_Map
: Elist_Id
) return Boolean;
22808 pragma Inline
(In_Entity_Map
);
22809 -- Determine whether entity Id is one of the old ids specified in entity
22810 -- map Entity_Map. The format of the entity map must be as follows:
22812 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
22814 procedure Update_CFS_Sloc
(N
: Node_Or_Entity_Id
);
22815 pragma Inline
(Update_CFS_Sloc
);
22816 -- Update the Comes_From_Source and Sloc attributes of node or entity N
22818 procedure Update_First_Real_Statement
22819 (Old_HSS
: Node_Id
;
22820 New_HSS
: Node_Id
);
22821 pragma Inline
(Update_First_Real_Statement
);
22822 -- Update semantic attribute First_Real_Statement of handled sequence of
22823 -- statements New_HSS based on handled sequence of statements Old_HSS.
22825 procedure Update_Named_Associations
22826 (Old_Call
: Node_Id
;
22827 New_Call
: Node_Id
);
22828 pragma Inline
(Update_Named_Associations
);
22829 -- Update semantic chain First/Next_Named_Association of call New_call
22830 -- based on call Old_Call.
22832 procedure Update_New_Entities
(Entity_Map
: Elist_Id
);
22833 pragma Inline
(Update_New_Entities
);
22834 -- Update the semantic attributes of all new entities generated during
22835 -- Phase 1 that do not appear in entity map Entity_Map. The format of
22836 -- the entity map must be as follows:
22838 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
22840 procedure Update_Pending_Itypes
22841 (Old_Assoc
: Node_Id
;
22842 New_Assoc
: Node_Id
);
22843 pragma Inline
(Update_Pending_Itypes
);
22844 -- Update semantic attribute Associated_Node_For_Itype to refer to node
22845 -- New_Assoc for all itypes whose associated node is Old_Assoc.
22847 procedure Update_Semantic_Fields
(Id
: Entity_Id
);
22848 pragma Inline
(Update_Semantic_Fields
);
22849 -- Subsidiary to Update_New_Entities. Update semantic fields of entity
22852 procedure Visit_Any_Node
(N
: Node_Or_Entity_Id
);
22853 pragma Inline
(Visit_Any_Node
);
22854 -- Visit entity of node N by invoking one of the following routines:
22860 procedure Visit_Elist
(List
: Elist_Id
);
22861 -- Visit the elements of entity list List
22863 procedure Visit_Entity
(Id
: Entity_Id
);
22864 -- Visit entity Id. This action may create a new entity of Id and save
22865 -- it in table NCT_New_Entities.
22867 procedure Visit_Field
22869 Par_Nod
: Node_Id
:= Empty
;
22870 Semantic
: Boolean := False);
22871 -- Visit field Field by invoking one of the following routines:
22879 -- If the field is not an entity list, entity, itype, syntactic list,
22880 -- or node, then the field is not visited. The routine always visits
22881 -- valid syntactic fields. Par_Nod is the expected parent of the
22882 -- syntactic field. Flag Semantic should be set when the input is a
22885 procedure Visit_Itype
(Itype
: Entity_Id
);
22886 -- Visit itype Itype. This action may create a new entity for Itype and
22887 -- save it in table NCT_New_Entities. In addition, the routine may map
22888 -- the associated node of Itype to the new itype in NCT_Pending_Itypes.
22890 procedure Visit_List
(List
: List_Id
);
22891 -- Visit the elements of syntactic list List
22893 procedure Visit_Node
(N
: Node_Id
);
22896 procedure Visit_Semantic_Fields
(Id
: Entity_Id
);
22897 pragma Inline
(Visit_Semantic_Fields
);
22898 -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic
22899 -- fields of entity or itype Id.
22901 --------------------
22902 -- Add_New_Entity --
22903 --------------------
22905 procedure Add_New_Entity
(Old_Id
: Entity_Id
; New_Id
: Entity_Id
) is
22907 pragma Assert
(Present
(Old_Id
));
22908 pragma Assert
(Present
(New_Id
));
22909 pragma Assert
(Nkind
(Old_Id
) in N_Entity
);
22910 pragma Assert
(Nkind
(New_Id
) in N_Entity
);
22912 NCT_Tables_In_Use
:= True;
22914 -- Sanity check the NCT_New_Entities table. No previous mapping with
22915 -- key Old_Id should exist.
22917 pragma Assert
(No
(NCT_New_Entities
.Get
(Old_Id
)));
22919 -- Establish the mapping
22921 -- Old_Id -> New_Id
22923 NCT_New_Entities
.Set
(Old_Id
, New_Id
);
22924 end Add_New_Entity
;
22926 -----------------------
22927 -- Add_Pending_Itype --
22928 -----------------------
22930 procedure Add_Pending_Itype
(Assoc_Nod
: Node_Id
; Itype
: Entity_Id
) is
22934 pragma Assert
(Present
(Assoc_Nod
));
22935 pragma Assert
(Present
(Itype
));
22936 pragma Assert
(Nkind
(Itype
) in N_Entity
);
22937 pragma Assert
(Is_Itype
(Itype
));
22939 NCT_Tables_In_Use
:= True;
22941 -- It is not possible to sanity check the NCT_Pendint_Itypes table
22942 -- directly because a single node may act as the associated node for
22943 -- multiple itypes.
22945 Itypes
:= NCT_Pending_Itypes
.Get
(Assoc_Nod
);
22947 if No
(Itypes
) then
22948 Itypes
:= New_Elmt_List
;
22949 NCT_Pending_Itypes
.Set
(Assoc_Nod
, Itypes
);
22952 -- Establish the mapping
22954 -- Assoc_Nod -> (Itype, ...)
22956 -- Avoid inserting the same itype multiple times. This involves a
22957 -- linear search, however the set of itypes with the same associated
22958 -- node is very small.
22960 Append_Unique_Elmt
(Itype
, Itypes
);
22961 end Add_Pending_Itype
;
22963 ----------------------
22964 -- Build_NCT_Tables --
22965 ----------------------
22967 procedure Build_NCT_Tables
(Entity_Map
: Elist_Id
) is
22969 Old_Id
: Entity_Id
;
22970 New_Id
: Entity_Id
;
22973 -- Nothing to do when there is no entity map
22975 if No
(Entity_Map
) then
22979 Elmt
:= First_Elmt
(Entity_Map
);
22980 while Present
(Elmt
) loop
22982 -- Extract the (Old_Id, New_Id) pair from the entity map
22984 Old_Id
:= Node
(Elmt
);
22987 New_Id
:= Node
(Elmt
);
22990 -- Establish the following mapping within table NCT_New_Entities
22992 -- Old_Id -> New_Id
22994 Add_New_Entity
(Old_Id
, New_Id
);
22996 -- Establish the following mapping within table NCT_Pending_Itypes
22997 -- when the new entity is an itype.
22999 -- Assoc_Nod -> (New_Id, ...)
23001 -- IMPORTANT: the associated node is that of the old itype because
23002 -- the node will be replicated in Phase 2.
23004 if Is_Itype
(Old_Id
) then
23006 (Assoc_Nod
=> Associated_Node_For_Itype
(Old_Id
),
23010 end Build_NCT_Tables
;
23012 ------------------------------------
23013 -- Copy_Any_Node_With_Replacement --
23014 ------------------------------------
23016 function Copy_Any_Node_With_Replacement
23017 (N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
23020 if Nkind
(N
) in N_Entity
then
23021 return Corresponding_Entity
(N
);
23023 return Copy_Node_With_Replacement
(N
);
23025 end Copy_Any_Node_With_Replacement
;
23027 ---------------------------------
23028 -- Copy_Elist_With_Replacement --
23029 ---------------------------------
23031 function Copy_Elist_With_Replacement
(List
: Elist_Id
) return Elist_Id
is
23036 -- Copy the contents of the old list. Note that the list itself may
23037 -- be empty, in which case the routine returns a new empty list. This
23038 -- avoids sharing lists between subtrees. The element of an entity
23039 -- list could be an entity or a node, hence the invocation of routine
23040 -- Copy_Any_Node_With_Replacement.
23042 if Present
(List
) then
23043 Result
:= New_Elmt_List
;
23045 Elmt
:= First_Elmt
(List
);
23046 while Present
(Elmt
) loop
23048 (Copy_Any_Node_With_Replacement
(Node
(Elmt
)), Result
);
23053 -- Otherwise the list does not exist
23056 Result
:= No_Elist
;
23060 end Copy_Elist_With_Replacement
;
23062 ---------------------------------
23063 -- Copy_Field_With_Replacement --
23064 ---------------------------------
23066 function Copy_Field_With_Replacement
23068 Old_Par
: Node_Id
:= Empty
;
23069 New_Par
: Node_Id
:= Empty
;
23070 Semantic
: Boolean := False) return Union_Id
23072 function Has_More_Ids
(N
: Node_Id
) return Boolean;
23073 -- Return True when N has attribute More_Ids set to True
23075 function Is_Syntactic_Node
return Boolean;
23076 -- Return True when Field is a syntactic node
23082 function Has_More_Ids
(N
: Node_Id
) return Boolean is
23084 if Nkind
(N
) in N_Component_Declaration
23085 | N_Discriminant_Specification
23086 | N_Exception_Declaration
23087 | N_Formal_Object_Declaration
23088 | N_Number_Declaration
23089 | N_Object_Declaration
23090 | N_Parameter_Specification
23091 | N_Use_Package_Clause
23092 | N_Use_Type_Clause
23094 return More_Ids
(N
);
23100 -----------------------
23101 -- Is_Syntactic_Node --
23102 -----------------------
23104 function Is_Syntactic_Node
return Boolean is
23105 Old_N
: constant Node_Id
:= Node_Id
(Field
);
23108 if Parent
(Old_N
) = Old_Par
then
23111 elsif not Has_More_Ids
(Old_Par
) then
23114 -- Perform the check using the last last id in the syntactic chain
23118 N
: Node_Id
:= Old_Par
;
23121 while Present
(N
) and then More_Ids
(N
) loop
23125 pragma Assert
(Prev_Ids
(N
));
23126 return Parent
(Old_N
) = N
;
23129 end Is_Syntactic_Node
;
23132 -- The field is empty
23134 if Field
= Union_Id
(Empty
) then
23137 -- The field is an entity/itype/node
23139 elsif Field
in Node_Range
then
23141 Old_N
: constant Node_Id
:= Node_Id
(Field
);
23142 Syntactic
: constant Boolean := Is_Syntactic_Node
;
23147 -- The field is an entity/itype
23149 if Nkind
(Old_N
) in N_Entity
then
23151 -- An entity/itype is always replicated
23153 New_N
:= Corresponding_Entity
(Old_N
);
23155 -- Update the parent pointer when the entity is a syntactic
23156 -- field. Note that itypes do not have parent pointers.
23158 if Syntactic
and then New_N
/= Old_N
then
23159 Set_Parent
(New_N
, New_Par
);
23162 -- The field is a node
23165 -- A node is replicated when it is either a syntactic field
23166 -- or when the caller treats it as a semantic attribute.
23168 if Syntactic
or else Semantic
then
23169 New_N
:= Copy_Node_With_Replacement
(Old_N
);
23171 -- Update the parent pointer when the node is a syntactic
23174 if Syntactic
and then New_N
/= Old_N
then
23175 Set_Parent
(New_N
, New_Par
);
23178 -- Otherwise the node is returned unchanged
23185 return Union_Id
(New_N
);
23188 -- The field is an entity list
23190 elsif Field
in Elist_Range
then
23191 return Union_Id
(Copy_Elist_With_Replacement
(Elist_Id
(Field
)));
23193 -- The field is a syntactic list
23195 elsif Field
in List_Range
then
23197 Old_List
: constant List_Id
:= List_Id
(Field
);
23198 Syntactic
: constant Boolean := Parent
(Old_List
) = Old_Par
;
23200 New_List
: List_Id
;
23203 -- A list is replicated when it is either a syntactic field or
23204 -- when the caller treats it as a semantic attribute.
23206 if Syntactic
or else Semantic
then
23207 New_List
:= Copy_List_With_Replacement
(Old_List
);
23209 -- Update the parent pointer when the list is a syntactic
23212 if Syntactic
and then New_List
/= Old_List
then
23213 Set_Parent
(New_List
, New_Par
);
23216 -- Otherwise the list is returned unchanged
23219 New_List
:= Old_List
;
23222 return Union_Id
(New_List
);
23225 -- Otherwise the field denotes an attribute that does not need to be
23226 -- replicated (Chars, literals, etc).
23231 end Copy_Field_With_Replacement
;
23233 --------------------------------
23234 -- Copy_List_With_Replacement --
23235 --------------------------------
23237 function Copy_List_With_Replacement
(List
: List_Id
) return List_Id
is
23242 -- Copy the contents of the old list. Note that the list itself may
23243 -- be empty, in which case the routine returns a new empty list. This
23244 -- avoids sharing lists between subtrees. The element of a syntactic
23245 -- list is always a node, never an entity or itype, hence the call to
23246 -- routine Copy_Node_With_Replacement.
23248 if Present
(List
) then
23249 Result
:= New_List
;
23251 Elmt
:= First
(List
);
23252 while Present
(Elmt
) loop
23253 Append
(Copy_Node_With_Replacement
(Elmt
), Result
);
23258 -- Otherwise the list does not exist
23265 end Copy_List_With_Replacement
;
23267 --------------------------------
23268 -- Copy_Node_With_Replacement --
23269 --------------------------------
23271 function Copy_Node_With_Replacement
(N
: Node_Id
) return Node_Id
is
23275 -- Assume that the node must be returned unchanged
23279 if N
> Empty_Or_Error
then
23280 pragma Assert
(Nkind
(N
) not in N_Entity
);
23282 Result
:= New_Copy
(N
);
23284 Set_Field1
(Result
,
23285 Copy_Field_With_Replacement
23286 (Field
=> Field1
(Result
),
23288 New_Par
=> Result
));
23290 Set_Field2
(Result
,
23291 Copy_Field_With_Replacement
23292 (Field
=> Field2
(Result
),
23294 New_Par
=> Result
));
23296 Set_Field3
(Result
,
23297 Copy_Field_With_Replacement
23298 (Field
=> Field3
(Result
),
23300 New_Par
=> Result
));
23302 Set_Field4
(Result
,
23303 Copy_Field_With_Replacement
23304 (Field
=> Field4
(Result
),
23306 New_Par
=> Result
));
23308 Set_Field5
(Result
,
23309 Copy_Field_With_Replacement
23310 (Field
=> Field5
(Result
),
23312 New_Par
=> Result
));
23314 -- Update the Comes_From_Source and Sloc attributes of the node
23315 -- in case the caller has supplied new values.
23317 Update_CFS_Sloc
(Result
);
23319 -- Update the Associated_Node_For_Itype attribute of all itypes
23320 -- created during Phase 1 whose associated node is N. As a result
23321 -- the Associated_Node_For_Itype refers to the replicated node.
23322 -- No action needs to be taken when the Associated_Node_For_Itype
23323 -- refers to an entity because this was already handled during
23324 -- Phase 1, in Visit_Itype.
23326 Update_Pending_Itypes
23328 New_Assoc
=> Result
);
23330 -- Update the First/Next_Named_Association chain for a replicated
23333 if Nkind
(N
) in N_Entry_Call_Statement
23335 | N_Procedure_Call_Statement
23337 Update_Named_Associations
23339 New_Call
=> Result
);
23341 -- Update the Renamed_Object attribute of a replicated object
23344 elsif Nkind
(N
) = N_Object_Renaming_Declaration
then
23345 Set_Renamed_Object
(Defining_Entity
(Result
), Name
(Result
));
23347 -- Update the First_Real_Statement attribute of a replicated
23348 -- handled sequence of statements.
23350 elsif Nkind
(N
) = N_Handled_Sequence_Of_Statements
then
23351 Update_First_Real_Statement
23353 New_HSS
=> Result
);
23355 -- Update the Chars attribute of identifiers
23357 elsif Nkind
(N
) = N_Identifier
then
23359 -- The Entity field of identifiers that denote aspects is used
23360 -- to store arbitrary expressions (and hence we must check that
23361 -- they reference an actual entity before copying their Chars
23364 if Present
(Entity
(Result
))
23365 and then Nkind
(Entity
(Result
)) in N_Entity
23367 Set_Chars
(Result
, Chars
(Entity
(Result
)));
23371 if Has_Aspects
(N
) then
23372 Set_Aspect_Specifications
(Result
,
23373 Copy_List_With_Replacement
(Aspect_Specifications
(N
)));
23378 end Copy_Node_With_Replacement
;
23380 --------------------------
23381 -- Corresponding_Entity --
23382 --------------------------
23384 function Corresponding_Entity
(Id
: Entity_Id
) return Entity_Id
is
23385 New_Id
: Entity_Id
;
23386 Result
: Entity_Id
;
23389 -- Assume that the entity must be returned unchanged
23393 if Id
> Empty_Or_Error
then
23394 pragma Assert
(Nkind
(Id
) in N_Entity
);
23396 -- Determine whether the entity has a corresponding new entity
23397 -- generated during Phase 1 and if it does, use it.
23399 if NCT_Tables_In_Use
then
23400 New_Id
:= NCT_New_Entities
.Get
(Id
);
23402 if Present
(New_Id
) then
23409 end Corresponding_Entity
;
23411 -------------------
23412 -- In_Entity_Map --
23413 -------------------
23415 function In_Entity_Map
23417 Entity_Map
: Elist_Id
) return Boolean
23420 Old_Id
: Entity_Id
;
23423 -- The entity map contains pairs (Old_Id, New_Id). The advancement
23424 -- step always skips the New_Id portion of the pair.
23426 if Present
(Entity_Map
) then
23427 Elmt
:= First_Elmt
(Entity_Map
);
23428 while Present
(Elmt
) loop
23429 Old_Id
:= Node
(Elmt
);
23431 if Old_Id
= Id
then
23443 ---------------------
23444 -- Update_CFS_Sloc --
23445 ---------------------
23447 procedure Update_CFS_Sloc
(N
: Node_Or_Entity_Id
) is
23449 -- A new source location defaults the Comes_From_Source attribute
23451 if New_Sloc
/= No_Location
then
23452 Set_Comes_From_Source
(N
, Default_Node
.Comes_From_Source
);
23453 Set_Sloc
(N
, New_Sloc
);
23455 end Update_CFS_Sloc
;
23457 ---------------------------------
23458 -- Update_First_Real_Statement --
23459 ---------------------------------
23461 procedure Update_First_Real_Statement
23462 (Old_HSS
: Node_Id
;
23465 Old_First_Stmt
: constant Node_Id
:= First_Real_Statement
(Old_HSS
);
23467 New_Stmt
: Node_Id
;
23468 Old_Stmt
: Node_Id
;
23471 -- Recreate the First_Real_Statement attribute of a handled sequence
23472 -- of statements by traversing the statement lists of both sequences
23475 if Present
(Old_First_Stmt
) then
23476 New_Stmt
:= First
(Statements
(New_HSS
));
23477 Old_Stmt
:= First
(Statements
(Old_HSS
));
23478 while Present
(Old_Stmt
) and then Old_Stmt
/= Old_First_Stmt
loop
23483 pragma Assert
(Present
(New_Stmt
));
23484 pragma Assert
(Present
(Old_Stmt
));
23486 Set_First_Real_Statement
(New_HSS
, New_Stmt
);
23488 end Update_First_Real_Statement
;
23490 -------------------------------
23491 -- Update_Named_Associations --
23492 -------------------------------
23494 procedure Update_Named_Associations
23495 (Old_Call
: Node_Id
;
23496 New_Call
: Node_Id
)
23499 New_Next
: Node_Id
;
23501 Old_Next
: Node_Id
;
23504 if No
(First_Named_Actual
(Old_Call
)) then
23508 -- Recreate the First/Next_Named_Actual chain of a call by traversing
23509 -- the chains of both the old and new calls in parallel.
23511 New_Act
:= First
(Parameter_Associations
(New_Call
));
23512 Old_Act
:= First
(Parameter_Associations
(Old_Call
));
23513 while Present
(Old_Act
) loop
23514 if Nkind
(Old_Act
) = N_Parameter_Association
23515 and then Explicit_Actual_Parameter
(Old_Act
)
23516 = First_Named_Actual
(Old_Call
)
23518 Set_First_Named_Actual
(New_Call
,
23519 Explicit_Actual_Parameter
(New_Act
));
23522 if Nkind
(Old_Act
) = N_Parameter_Association
23523 and then Present
(Next_Named_Actual
(Old_Act
))
23525 -- Scan the actual parameter list to find the next suitable
23526 -- named actual. Note that the list may be out of order.
23528 New_Next
:= First
(Parameter_Associations
(New_Call
));
23529 Old_Next
:= First
(Parameter_Associations
(Old_Call
));
23530 while Nkind
(Old_Next
) /= N_Parameter_Association
23531 or else Explicit_Actual_Parameter
(Old_Next
) /=
23532 Next_Named_Actual
(Old_Act
)
23538 Set_Next_Named_Actual
(New_Act
,
23539 Explicit_Actual_Parameter
(New_Next
));
23545 end Update_Named_Associations
;
23547 -------------------------
23548 -- Update_New_Entities --
23549 -------------------------
23551 procedure Update_New_Entities
(Entity_Map
: Elist_Id
) is
23552 New_Id
: Entity_Id
:= Empty
;
23553 Old_Id
: Entity_Id
:= Empty
;
23556 if NCT_Tables_In_Use
then
23557 NCT_New_Entities
.Get_First
(Old_Id
, New_Id
);
23559 -- Update the semantic fields of all new entities created during
23560 -- Phase 1 which were not supplied via an entity map.
23561 -- ??? Is there a better way of distinguishing those?
23563 while Present
(Old_Id
) and then Present
(New_Id
) loop
23564 if not (Present
(Entity_Map
)
23565 and then In_Entity_Map
(Old_Id
, Entity_Map
))
23567 Update_Semantic_Fields
(New_Id
);
23570 NCT_New_Entities
.Get_Next
(Old_Id
, New_Id
);
23573 end Update_New_Entities
;
23575 ---------------------------
23576 -- Update_Pending_Itypes --
23577 ---------------------------
23579 procedure Update_Pending_Itypes
23580 (Old_Assoc
: Node_Id
;
23581 New_Assoc
: Node_Id
)
23587 if NCT_Tables_In_Use
then
23588 Itypes
:= NCT_Pending_Itypes
.Get
(Old_Assoc
);
23590 -- Update the Associated_Node_For_Itype attribute for all itypes
23591 -- which originally refer to Old_Assoc to designate New_Assoc.
23593 if Present
(Itypes
) then
23594 Item
:= First_Elmt
(Itypes
);
23595 while Present
(Item
) loop
23596 Set_Associated_Node_For_Itype
(Node
(Item
), New_Assoc
);
23602 end Update_Pending_Itypes
;
23604 ----------------------------
23605 -- Update_Semantic_Fields --
23606 ----------------------------
23608 procedure Update_Semantic_Fields
(Id
: Entity_Id
) is
23610 -- Discriminant_Constraint
23612 if Is_Type
(Id
) and then Has_Discriminants
(Base_Type
(Id
)) then
23613 Set_Discriminant_Constraint
(Id
, Elist_Id
(
23614 Copy_Field_With_Replacement
23615 (Field
=> Union_Id
(Discriminant_Constraint
(Id
)),
23616 Semantic
=> True)));
23621 Set_Etype
(Id
, Node_Id
(
23622 Copy_Field_With_Replacement
23623 (Field
=> Union_Id
(Etype
(Id
)),
23624 Semantic
=> True)));
23627 -- Packed_Array_Impl_Type
23629 if Is_Array_Type
(Id
) then
23630 if Present
(First_Index
(Id
)) then
23631 Set_First_Index
(Id
, First
(List_Id
(
23632 Copy_Field_With_Replacement
23633 (Field
=> Union_Id
(List_Containing
(First_Index
(Id
))),
23634 Semantic
=> True))));
23637 if Is_Packed
(Id
) then
23638 Set_Packed_Array_Impl_Type
(Id
, Node_Id
(
23639 Copy_Field_With_Replacement
23640 (Field
=> Union_Id
(Packed_Array_Impl_Type
(Id
)),
23641 Semantic
=> True)));
23647 Set_Prev_Entity
(Id
, Node_Id
(
23648 Copy_Field_With_Replacement
23649 (Field
=> Union_Id
(Prev_Entity
(Id
)),
23650 Semantic
=> True)));
23654 Set_Next_Entity
(Id
, Node_Id
(
23655 Copy_Field_With_Replacement
23656 (Field
=> Union_Id
(Next_Entity
(Id
)),
23657 Semantic
=> True)));
23661 if Is_Discrete_Type
(Id
) then
23662 Set_Scalar_Range
(Id
, Node_Id
(
23663 Copy_Field_With_Replacement
23664 (Field
=> Union_Id
(Scalar_Range
(Id
)),
23665 Semantic
=> True)));
23670 -- Update the scope when the caller specified an explicit one
23672 if Present
(New_Scope
) then
23673 Set_Scope
(Id
, New_Scope
);
23675 Set_Scope
(Id
, Node_Id
(
23676 Copy_Field_With_Replacement
23677 (Field
=> Union_Id
(Scope
(Id
)),
23678 Semantic
=> True)));
23680 end Update_Semantic_Fields
;
23682 --------------------
23683 -- Visit_Any_Node --
23684 --------------------
23686 procedure Visit_Any_Node
(N
: Node_Or_Entity_Id
) is
23688 if Nkind
(N
) in N_Entity
then
23689 if Is_Itype
(N
) then
23697 end Visit_Any_Node
;
23703 procedure Visit_Elist
(List
: Elist_Id
) is
23707 -- The element of an entity list could be an entity, itype, or a
23708 -- node, hence the call to Visit_Any_Node.
23710 if Present
(List
) then
23711 Elmt
:= First_Elmt
(List
);
23712 while Present
(Elmt
) loop
23713 Visit_Any_Node
(Node
(Elmt
));
23724 procedure Visit_Entity
(Id
: Entity_Id
) is
23725 New_Id
: Entity_Id
;
23728 pragma Assert
(Nkind
(Id
) in N_Entity
);
23729 pragma Assert
(not Is_Itype
(Id
));
23731 -- Nothing to do when the entity is not defined in the Actions list
23732 -- of an N_Expression_With_Actions node.
23734 if EWA_Level
= 0 then
23737 -- Nothing to do when the entity is defined in a scoping construct
23738 -- within an N_Expression_With_Actions node, unless the caller has
23739 -- requested their replication.
23741 -- ??? should this restriction be eliminated?
23743 elsif EWA_Inner_Scope_Level
> 0 and then not Scopes_In_EWA_OK
then
23746 -- Nothing to do when the entity does not denote a construct that
23747 -- may appear within an N_Expression_With_Actions node. Relaxing
23748 -- this restriction leads to a performance penalty.
23750 -- ??? this list is flaky, and may hide dormant bugs
23751 -- Should functions be included???
23753 -- Loop parameters appear within quantified expressions and contain
23754 -- an entity declaration that must be replaced when the expander is
23755 -- active if the expression has been preanalyzed or analyzed.
23757 elsif Ekind
(Id
) not in
23758 E_Block | E_Constant | E_Label | E_Loop_Parameter |
23759 E_Procedure | E_Variable
23760 and then not Is_Type
(Id
)
23764 elsif Ekind
(Id
) = E_Loop_Parameter
23765 and then No
(Etype
(Condition
(Parent
(Parent
(Id
)))))
23769 -- Nothing to do when the entity was already visited
23771 elsif NCT_Tables_In_Use
23772 and then Present
(NCT_New_Entities
.Get
(Id
))
23776 -- Nothing to do when the declaration node of the entity is not in
23777 -- the subtree being replicated.
23779 elsif not In_Subtree
23780 (N
=> Declaration_Node
(Id
),
23786 -- Create a new entity by directly copying the old entity. This
23787 -- action causes all attributes of the old entity to be inherited.
23789 New_Id
:= New_Copy
(Id
);
23791 -- Create a new name for the new entity because the back end needs
23792 -- distinct names for debugging purposes.
23794 Set_Chars
(New_Id
, New_Internal_Name
('T'));
23796 -- Update the Comes_From_Source and Sloc attributes of the entity in
23797 -- case the caller has supplied new values.
23799 Update_CFS_Sloc
(New_Id
);
23801 -- Establish the following mapping within table NCT_New_Entities:
23805 Add_New_Entity
(Id
, New_Id
);
23807 -- Deal with the semantic fields of entities. The fields are visited
23808 -- because they may mention entities which reside within the subtree
23811 Visit_Semantic_Fields
(Id
);
23818 procedure Visit_Field
23820 Par_Nod
: Node_Id
:= Empty
;
23821 Semantic
: Boolean := False)
23824 -- The field is empty
23826 if Field
= Union_Id
(Empty
) then
23829 -- The field is an entity/itype/node
23831 elsif Field
in Node_Range
then
23833 N
: constant Node_Id
:= Node_Id
(Field
);
23836 -- The field is an entity/itype
23838 if Nkind
(N
) in N_Entity
then
23840 -- Itypes are always visited
23842 if Is_Itype
(N
) then
23845 -- An entity is visited when it is either a syntactic field
23846 -- or when the caller treats it as a semantic attribute.
23848 elsif Parent
(N
) = Par_Nod
or else Semantic
then
23852 -- The field is a node
23855 -- A node is visited when it is either a syntactic field or
23856 -- when the caller treats it as a semantic attribute.
23858 if Parent
(N
) = Par_Nod
or else Semantic
then
23864 -- The field is an entity list
23866 elsif Field
in Elist_Range
then
23867 Visit_Elist
(Elist_Id
(Field
));
23869 -- The field is a syntax list
23871 elsif Field
in List_Range
then
23873 List
: constant List_Id
:= List_Id
(Field
);
23876 -- A syntax list is visited when it is either a syntactic field
23877 -- or when the caller treats it as a semantic attribute.
23879 if Parent
(List
) = Par_Nod
or else Semantic
then
23884 -- Otherwise the field denotes information which does not need to be
23885 -- visited (chars, literals, etc.).
23896 procedure Visit_Itype
(Itype
: Entity_Id
) is
23897 New_Assoc
: Node_Id
;
23898 New_Itype
: Entity_Id
;
23899 Old_Assoc
: Node_Id
;
23902 pragma Assert
(Nkind
(Itype
) in N_Entity
);
23903 pragma Assert
(Is_Itype
(Itype
));
23905 -- Itypes that describe the designated type of access to subprograms
23906 -- have the structure of subprogram declarations, with signatures,
23907 -- etc. Either we duplicate the signatures completely, or choose to
23908 -- share such itypes, which is fine because their elaboration will
23909 -- have no side effects.
23911 if Ekind
(Itype
) = E_Subprogram_Type
then
23914 -- Nothing to do if the itype was already visited
23916 elsif NCT_Tables_In_Use
23917 and then Present
(NCT_New_Entities
.Get
(Itype
))
23921 -- Nothing to do if the associated node of the itype is not within
23922 -- the subtree being replicated.
23924 elsif not In_Subtree
23925 (N
=> Associated_Node_For_Itype
(Itype
),
23931 -- Create a new itype by directly copying the old itype. This action
23932 -- causes all attributes of the old itype to be inherited.
23934 New_Itype
:= New_Copy
(Itype
);
23936 -- Create a new name for the new itype because the back end requires
23937 -- distinct names for debugging purposes.
23939 Set_Chars
(New_Itype
, New_Internal_Name
('T'));
23941 -- Update the Comes_From_Source and Sloc attributes of the itype in
23942 -- case the caller has supplied new values.
23944 Update_CFS_Sloc
(New_Itype
);
23946 -- Establish the following mapping within table NCT_New_Entities:
23948 -- Itype -> New_Itype
23950 Add_New_Entity
(Itype
, New_Itype
);
23952 -- The new itype must be unfrozen because the resulting subtree may
23953 -- be inserted anywhere and cause an earlier or later freezing.
23955 if Present
(Freeze_Node
(New_Itype
)) then
23956 Set_Freeze_Node
(New_Itype
, Empty
);
23957 Set_Is_Frozen
(New_Itype
, False);
23960 -- If a record subtype is simply copied, the entity list will be
23961 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
23962 -- ??? What does this do?
23964 if Ekind
(Itype
) in E_Class_Wide_Subtype | E_Record_Subtype
then
23965 Set_Cloned_Subtype
(New_Itype
, Itype
);
23968 -- The associated node may denote an entity, in which case it may
23969 -- already have a new corresponding entity created during a prior
23970 -- call to Visit_Entity or Visit_Itype for the same subtree.
23973 -- Old_Assoc ---------> New_Assoc
23975 -- Created by Visit_Itype
23976 -- Itype -------------> New_Itype
23977 -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated
23979 -- In the example above, Old_Assoc is an arbitrary entity that was
23980 -- already visited for the same subtree and has a corresponding new
23981 -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue
23982 -- of copying entities, however it must be updated to New_Assoc.
23984 Old_Assoc
:= Associated_Node_For_Itype
(Itype
);
23986 if Nkind
(Old_Assoc
) in N_Entity
then
23987 if NCT_Tables_In_Use
then
23988 New_Assoc
:= NCT_New_Entities
.Get
(Old_Assoc
);
23990 if Present
(New_Assoc
) then
23991 Set_Associated_Node_For_Itype
(New_Itype
, New_Assoc
);
23995 -- Otherwise the associated node denotes a node. Postpone the update
23996 -- until Phase 2 when the node is replicated. Establish the following
23997 -- mapping within table NCT_Pending_Itypes:
23999 -- Old_Assoc -> (New_Type, ...)
24002 Add_Pending_Itype
(Old_Assoc
, New_Itype
);
24005 -- Deal with the semantic fields of itypes. The fields are visited
24006 -- because they may mention entities that reside within the subtree
24009 Visit_Semantic_Fields
(Itype
);
24016 procedure Visit_List
(List
: List_Id
) is
24020 -- Note that the element of a syntactic list is always a node, never
24021 -- an entity or itype, hence the call to Visit_Node.
24023 if Present
(List
) then
24024 Elmt
:= First
(List
);
24025 while Present
(Elmt
) loop
24037 procedure Visit_Node
(N
: Node_Or_Entity_Id
) is
24039 pragma Assert
(Nkind
(N
) not in N_Entity
);
24041 -- If the node is a quantified expression and expander is active,
24042 -- it contains an implicit declaration that may require a new entity
24043 -- when the condition has already been (pre)analyzed.
24045 if Nkind
(N
) = N_Expression_With_Actions
24047 (Nkind
(N
) = N_Quantified_Expression
and then Expander_Active
)
24049 EWA_Level
:= EWA_Level
+ 1;
24051 elsif EWA_Level
> 0
24052 and then Nkind
(N
) in N_Block_Statement
24053 | N_Subprogram_Body
24054 | N_Subprogram_Declaration
24056 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
+ 1;
24060 (Field
=> Field1
(N
),
24064 (Field
=> Field2
(N
),
24068 (Field
=> Field3
(N
),
24072 (Field
=> Field4
(N
),
24076 (Field
=> Field5
(N
),
24080 and then Nkind
(N
) in N_Block_Statement
24081 | N_Subprogram_Body
24082 | N_Subprogram_Declaration
24084 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
- 1;
24086 elsif Nkind
(N
) = N_Expression_With_Actions
then
24087 EWA_Level
:= EWA_Level
- 1;
24091 ---------------------------
24092 -- Visit_Semantic_Fields --
24093 ---------------------------
24095 procedure Visit_Semantic_Fields
(Id
: Entity_Id
) is
24097 pragma Assert
(Nkind
(Id
) in N_Entity
);
24099 -- Discriminant_Constraint
24101 if Is_Type
(Id
) and then Has_Discriminants
(Base_Type
(Id
)) then
24103 (Field
=> Union_Id
(Discriminant_Constraint
(Id
)),
24110 (Field
=> Union_Id
(Etype
(Id
)),
24114 -- Packed_Array_Impl_Type
24116 if Is_Array_Type
(Id
) then
24117 if Present
(First_Index
(Id
)) then
24119 (Field
=> Union_Id
(List_Containing
(First_Index
(Id
))),
24123 if Is_Packed
(Id
) then
24125 (Field
=> Union_Id
(Packed_Array_Impl_Type
(Id
)),
24132 if Is_Discrete_Type
(Id
) then
24134 (Field
=> Union_Id
(Scalar_Range
(Id
)),
24137 end Visit_Semantic_Fields
;
24139 -- Start of processing for New_Copy_Tree
24142 -- Routine New_Copy_Tree performs a deep copy of a subtree by creating
24143 -- shallow copies for each node within, and then updating the child and
24144 -- parent pointers accordingly. This process is straightforward, however
24145 -- the routine must deal with the following complications:
24147 -- * Entities defined within N_Expression_With_Actions nodes must be
24148 -- replicated rather than shared to avoid introducing two identical
24149 -- symbols within the same scope. Note that no other expression can
24150 -- currently define entities.
24153 -- Source_Low : ...;
24154 -- Source_High : ...;
24156 -- <reference to Source_Low>
24157 -- <reference to Source_High>
24160 -- New_Copy_Tree handles this case by first creating new entities
24161 -- and then updating all existing references to point to these new
24168 -- <reference to New_Low>
24169 -- <reference to New_High>
24172 -- * Itypes defined within the subtree must be replicated to avoid any
24173 -- dependencies on invalid or inaccessible data.
24175 -- subtype Source_Itype is ... range Source_Low .. Source_High;
24177 -- New_Copy_Tree handles this case by first creating a new itype in
24178 -- the same fashion as entities, and then updating various relevant
24181 -- subtype New_Itype is ... range New_Low .. New_High;
24183 -- * The Associated_Node_For_Itype field of itypes must be updated to
24184 -- reference the proper replicated entity or node.
24186 -- * Semantic fields of entities such as Etype and Scope must be
24187 -- updated to reference the proper replicated entities.
24189 -- * Semantic fields of nodes such as First_Real_Statement must be
24190 -- updated to reference the proper replicated nodes.
24192 -- Finally, quantified expressions contain an implicit delaration for
24193 -- the bound variable. Given that quantified expressions appearing
24194 -- in contracts are copied to create pragmas and eventually checking
24195 -- procedures, a new bound variable must be created for each copy, to
24196 -- prevent multiple declarations of the same symbol.
24198 -- To meet all these demands, routine New_Copy_Tree is split into two
24201 -- Phase 1 traverses the tree in order to locate entities and itypes
24202 -- defined within the subtree. New entities are generated and saved in
24203 -- table NCT_New_Entities. The semantic fields of all new entities and
24204 -- itypes are then updated accordingly.
24206 -- Phase 2 traverses the tree in order to replicate each node. Various
24207 -- semantic fields of nodes and entities are updated accordingly.
24209 -- Preparatory phase. Clear the contents of tables NCT_New_Entities and
24210 -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some
24213 if NCT_Tables_In_Use
then
24214 NCT_Tables_In_Use
:= False;
24216 NCT_New_Entities
.Reset
;
24217 NCT_Pending_Itypes
.Reset
;
24220 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data
24221 -- supplied by a linear entity map. The tables offer faster access to
24224 Build_NCT_Tables
(Map
);
24226 -- Execute Phase 1. Traverse the subtree and generate new entities for
24227 -- the following cases:
24229 -- * An entity defined within an N_Expression_With_Actions node
24231 -- * An itype referenced within the subtree where the associated node
24232 -- is also in the subtree.
24234 -- All new entities are accessible via table NCT_New_Entities, which
24235 -- contains mappings of the form:
24237 -- Old_Entity -> New_Entity
24238 -- Old_Itype -> New_Itype
24240 -- In addition, the associated nodes of all new itypes are mapped in
24241 -- table NCT_Pending_Itypes:
24243 -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN)
24245 Visit_Any_Node
(Source
);
24247 -- Update the semantic attributes of all new entities generated during
24248 -- Phase 1 before starting Phase 2. The updates could be performed in
24249 -- routine Corresponding_Entity, however this may cause the same entity
24250 -- to be updated multiple times, effectively generating useless nodes.
24251 -- Keeping the updates separates from Phase 2 ensures that only one set
24252 -- of attributes is generated for an entity at any one time.
24254 Update_New_Entities
(Map
);
24256 -- Execute Phase 2. Replicate the source subtree one node at a time.
24257 -- The following transformations take place:
24259 -- * References to entities and itypes are updated to refer to the
24260 -- new entities and itypes generated during Phase 1.
24262 -- * All Associated_Node_For_Itype attributes of itypes are updated
24263 -- to refer to the new replicated Associated_Node_For_Itype.
24265 return Copy_Node_With_Replacement
(Source
);
24268 -------------------------
24269 -- New_External_Entity --
24270 -------------------------
24272 function New_External_Entity
24273 (Kind
: Entity_Kind
;
24274 Scope_Id
: Entity_Id
;
24275 Sloc_Value
: Source_Ptr
;
24276 Related_Id
: Entity_Id
;
24277 Suffix
: Character;
24278 Suffix_Index
: Int
:= 0;
24279 Prefix
: Character := ' ') return Entity_Id
24281 N
: constant Entity_Id
:=
24282 Make_Defining_Identifier
(Sloc_Value
,
24284 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
24287 Set_Ekind
(N
, Kind
);
24288 Set_Is_Internal
(N
, True);
24289 Append_Entity
(N
, Scope_Id
);
24290 Set_Public_Status
(N
);
24292 if Kind
in Type_Kind
then
24293 Init_Size_Align
(N
);
24297 end New_External_Entity
;
24299 -------------------------
24300 -- New_Internal_Entity --
24301 -------------------------
24303 function New_Internal_Entity
24304 (Kind
: Entity_Kind
;
24305 Scope_Id
: Entity_Id
;
24306 Sloc_Value
: Source_Ptr
;
24307 Id_Char
: Character) return Entity_Id
24309 N
: constant Entity_Id
:= Make_Temporary
(Sloc_Value
, Id_Char
);
24312 Set_Ekind
(N
, Kind
);
24313 Set_Is_Internal
(N
, True);
24314 Append_Entity
(N
, Scope_Id
);
24316 if Kind
in Type_Kind
then
24317 Init_Size_Align
(N
);
24321 end New_Internal_Entity
;
24327 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
24328 Par
: constant Node_Id
:= Parent
(Actual_Id
);
24332 -- If we are pointing at a positional parameter, it is a member of a
24333 -- node list (the list of parameters), and the next parameter is the
24334 -- next node on the list, unless we hit a parameter association, then
24335 -- we shift to using the chain whose head is the First_Named_Actual in
24336 -- the parent, and then is threaded using the Next_Named_Actual of the
24337 -- Parameter_Association. All this fiddling is because the original node
24338 -- list is in the textual call order, and what we need is the
24339 -- declaration order.
24341 if Is_List_Member
(Actual_Id
) then
24342 N
:= Next
(Actual_Id
);
24344 if Nkind
(N
) = N_Parameter_Association
then
24346 -- In case of a build-in-place call, the call will no longer be a
24347 -- call; it will have been rewritten.
24349 if Nkind
(Par
) in N_Entry_Call_Statement
24351 | N_Procedure_Call_Statement
24353 return First_Named_Actual
(Par
);
24355 -- In case of a call rewritten in GNATprove mode while "inlining
24356 -- for proof" go to the original call.
24358 elsif Nkind
(Par
) = N_Null_Statement
then
24362 Nkind
(Original_Node
(Par
)) in N_Subprogram_Call
);
24364 return First_Named_Actual
(Original_Node
(Par
));
24373 return Next_Named_Actual
(Parent
(Actual_Id
));
24377 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
24379 Actual_Id
:= Next_Actual
(Actual_Id
);
24386 function Next_Global
(Node
: Node_Id
) return Node_Id
is
24388 -- The global item may either be in a list, or by itself, in which case
24389 -- there is no next global item with the same mode.
24391 if Is_List_Member
(Node
) then
24392 return Next
(Node
);
24398 procedure Next_Global
(Node
: in out Node_Id
) is
24400 Node
:= Next_Global
(Node
);
24403 ------------------------
24404 -- No_Caching_Enabled --
24405 ------------------------
24407 function No_Caching_Enabled
(Id
: Entity_Id
) return Boolean is
24408 pragma Assert
(Ekind
(Id
) = E_Variable
);
24409 Prag
: constant Node_Id
:= Get_Pragma
(Id
, Pragma_No_Caching
);
24413 if Present
(Prag
) then
24414 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
24416 -- The pragma has an optional Boolean expression, the related
24417 -- property is enabled only when the expression evaluates to True.
24419 if Present
(Arg1
) then
24420 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
)));
24422 -- Otherwise the lack of expression enables the property by
24429 -- The property was never set in the first place
24434 end No_Caching_Enabled
;
24436 --------------------------
24437 -- No_Heap_Finalization --
24438 --------------------------
24440 function No_Heap_Finalization
(Typ
: Entity_Id
) return Boolean is
24442 if Ekind
(Typ
) in E_Access_Type | E_General_Access_Type
24443 and then Is_Library_Level_Entity
(Typ
)
24445 -- A global No_Heap_Finalization pragma applies to all library-level
24446 -- named access-to-object types.
24448 if Present
(No_Heap_Finalization_Pragma
) then
24451 -- The library-level named access-to-object type itself is subject to
24452 -- pragma No_Heap_Finalization.
24454 elsif Present
(Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
)) then
24460 end No_Heap_Finalization
;
24462 -----------------------
24463 -- Normalize_Actuals --
24464 -----------------------
24466 -- Chain actuals according to formals of subprogram. If there are no named
24467 -- associations, the chain is simply the list of Parameter Associations,
24468 -- since the order is the same as the declaration order. If there are named
24469 -- associations, then the First_Named_Actual field in the N_Function_Call
24470 -- or N_Procedure_Call_Statement node points to the Parameter_Association
24471 -- node for the parameter that comes first in declaration order. The
24472 -- remaining named parameters are then chained in declaration order using
24473 -- Next_Named_Actual.
24475 -- This routine also verifies that the number of actuals is compatible with
24476 -- the number and default values of formals, but performs no type checking
24477 -- (type checking is done by the caller).
24479 -- If the matching succeeds, Success is set to True and the caller proceeds
24480 -- with type-checking. If the match is unsuccessful, then Success is set to
24481 -- False, and the caller attempts a different interpretation, if there is
24484 -- If the flag Report is on, the call is not overloaded, and a failure to
24485 -- match can be reported here, rather than in the caller.
24487 procedure Normalize_Actuals
24491 Success
: out Boolean)
24493 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
24494 Actual
: Node_Id
:= Empty
;
24495 Formal
: Entity_Id
;
24496 Last
: Node_Id
:= Empty
;
24497 First_Named
: Node_Id
:= Empty
;
24500 Formals_To_Match
: Integer := 0;
24501 Actuals_To_Match
: Integer := 0;
24503 procedure Chain
(A
: Node_Id
);
24504 -- Add named actual at the proper place in the list, using the
24505 -- Next_Named_Actual link.
24507 function Reporting
return Boolean;
24508 -- Determines if an error is to be reported. To report an error, we
24509 -- need Report to be True, and also we do not report errors caused
24510 -- by calls to init procs that occur within other init procs. Such
24511 -- errors must always be cascaded errors, since if all the types are
24512 -- declared correctly, the compiler will certainly build decent calls.
24518 procedure Chain
(A
: Node_Id
) is
24522 -- Call node points to first actual in list
24524 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
24527 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
24531 Set_Next_Named_Actual
(Last
, Empty
);
24538 function Reporting
return Boolean is
24543 elsif not Within_Init_Proc
then
24546 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
24554 -- Start of processing for Normalize_Actuals
24557 if Is_Access_Type
(S
) then
24559 -- The name in the call is a function call that returns an access
24560 -- to subprogram. The designated type has the list of formals.
24562 Formal
:= First_Formal
(Designated_Type
(S
));
24564 Formal
:= First_Formal
(S
);
24567 while Present
(Formal
) loop
24568 Formals_To_Match
:= Formals_To_Match
+ 1;
24569 Next_Formal
(Formal
);
24572 -- Find if there is a named association, and verify that no positional
24573 -- associations appear after named ones.
24575 if Present
(Actuals
) then
24576 Actual
:= First
(Actuals
);
24579 while Present
(Actual
)
24580 and then Nkind
(Actual
) /= N_Parameter_Association
24582 Actuals_To_Match
:= Actuals_To_Match
+ 1;
24586 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
24588 -- Most common case: positional notation, no defaults
24593 elsif Actuals_To_Match
> Formals_To_Match
then
24595 -- Too many actuals: will not work
24598 if Is_Entity_Name
(Name
(N
)) then
24599 Error_Msg_N
("too many arguments in call to&", Name
(N
));
24601 Error_Msg_N
("too many arguments in call", N
);
24609 First_Named
:= Actual
;
24611 while Present
(Actual
) loop
24612 if Nkind
(Actual
) /= N_Parameter_Association
then
24614 ("positional parameters not allowed after named ones", Actual
);
24619 Actuals_To_Match
:= Actuals_To_Match
+ 1;
24625 if Present
(Actuals
) then
24626 Actual
:= First
(Actuals
);
24629 Formal
:= First_Formal
(S
);
24630 while Present
(Formal
) loop
24632 -- Match the formals in order. If the corresponding actual is
24633 -- positional, nothing to do. Else scan the list of named actuals
24634 -- to find the one with the right name.
24636 if Present
(Actual
)
24637 and then Nkind
(Actual
) /= N_Parameter_Association
24640 Actuals_To_Match
:= Actuals_To_Match
- 1;
24641 Formals_To_Match
:= Formals_To_Match
- 1;
24644 -- For named parameters, search the list of actuals to find
24645 -- one that matches the next formal name.
24647 Actual
:= First_Named
;
24649 while Present
(Actual
) loop
24650 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
24653 Actuals_To_Match
:= Actuals_To_Match
- 1;
24654 Formals_To_Match
:= Formals_To_Match
- 1;
24662 if Ekind
(Formal
) /= E_In_Parameter
24663 or else No
(Default_Value
(Formal
))
24666 if (Comes_From_Source
(S
)
24667 or else Sloc
(S
) = Standard_Location
)
24668 and then Is_Overloadable
(S
)
24672 Nkind
(Parent
(N
)) in N_Procedure_Call_Statement
24674 | N_Parameter_Association
24675 and then Ekind
(S
) /= E_Function
24677 Set_Etype
(N
, Etype
(S
));
24680 Error_Msg_Name_1
:= Chars
(S
);
24681 Error_Msg_Sloc
:= Sloc
(S
);
24683 ("missing argument for parameter & "
24684 & "in call to % declared #", N
, Formal
);
24687 elsif Is_Overloadable
(S
) then
24688 Error_Msg_Name_1
:= Chars
(S
);
24690 -- Point to type derivation that generated the
24693 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
24696 ("missing argument for parameter & "
24697 & "in call to % (inherited) #", N
, Formal
);
24701 ("missing argument for parameter &", N
, Formal
);
24709 Formals_To_Match
:= Formals_To_Match
- 1;
24714 Next_Formal
(Formal
);
24717 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
24724 -- Find some superfluous named actual that did not get
24725 -- attached to the list of associations.
24727 Actual
:= First
(Actuals
);
24728 while Present
(Actual
) loop
24729 if Nkind
(Actual
) = N_Parameter_Association
24730 and then Actual
/= Last
24731 and then No
(Next_Named_Actual
(Actual
))
24733 -- A validity check may introduce a copy of a call that
24734 -- includes an extra actual (for example for an unrelated
24735 -- accessibility check). Check that the extra actual matches
24736 -- some extra formal, which must exist already because
24737 -- subprogram must be frozen at this point.
24739 if Present
(Extra_Formals
(S
))
24740 and then not Comes_From_Source
(Actual
)
24741 and then Nkind
(Actual
) = N_Parameter_Association
24742 and then Chars
(Extra_Formals
(S
)) =
24743 Chars
(Selector_Name
(Actual
))
24748 ("unmatched actual & in call", Selector_Name
(Actual
));
24760 end Normalize_Actuals
;
24762 --------------------------------
24763 -- Note_Possible_Modification --
24764 --------------------------------
24766 procedure Note_Possible_Modification
(N
: Node_Id
; Sure
: Boolean) is
24767 Modification_Comes_From_Source
: constant Boolean :=
24768 Comes_From_Source
(Parent
(N
));
24774 -- Loop to find referenced entity, if there is one
24780 if Is_Entity_Name
(Exp
) then
24781 Ent
:= Entity
(Exp
);
24783 -- If the entity is missing, it is an undeclared identifier,
24784 -- and there is nothing to annotate.
24790 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
24792 P
: constant Node_Id
:= Prefix
(Exp
);
24795 -- In formal verification mode, keep track of all reads and
24796 -- writes through explicit dereferences.
24798 if GNATprove_Mode
then
24799 SPARK_Specific
.Generate_Dereference
(N
, 'm');
24802 if Nkind
(P
) = N_Selected_Component
24803 and then Present
(Entry_Formal
(Entity
(Selector_Name
(P
))))
24805 -- Case of a reference to an entry formal
24807 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
24809 elsif Nkind
(P
) = N_Identifier
24810 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
24811 and then Present
(Expression
(Parent
(Entity
(P
))))
24812 and then Nkind
(Expression
(Parent
(Entity
(P
)))) =
24815 -- Case of a reference to a value on which side effects have
24818 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
24826 elsif Nkind
(Exp
) in N_Type_Conversion | N_Unchecked_Type_Conversion
24828 Exp
:= Expression
(Exp
);
24831 elsif Nkind
(Exp
) in
24832 N_Slice | N_Indexed_Component | N_Selected_Component
24834 -- Special check, if the prefix is an access type, then return
24835 -- since we are modifying the thing pointed to, not the prefix.
24836 -- When we are expanding, most usually the prefix is replaced
24837 -- by an explicit dereference, and this test is not needed, but
24838 -- in some cases (notably -gnatc mode and generics) when we do
24839 -- not do full expansion, we need this special test.
24841 if Is_Access_Type
(Etype
(Prefix
(Exp
))) then
24844 -- Otherwise go to prefix and keep going
24847 Exp
:= Prefix
(Exp
);
24851 -- All other cases, not a modification
24857 -- Now look for entity being referenced
24859 if Present
(Ent
) then
24860 if Is_Object
(Ent
) then
24861 if Comes_From_Source
(Exp
)
24862 or else Modification_Comes_From_Source
24864 -- Give warning if pragma unmodified is given and we are
24865 -- sure this is a modification.
24867 if Has_Pragma_Unmodified
(Ent
) and then Sure
then
24869 -- Note that the entity may be present only as a result
24870 -- of pragma Unused.
24872 if Has_Pragma_Unused
(Ent
) then
24873 Error_Msg_NE
("??pragma Unused given for &!", N
, Ent
);
24876 ("??pragma Unmodified given for &!", N
, Ent
);
24880 Set_Never_Set_In_Source
(Ent
, False);
24883 Set_Is_True_Constant
(Ent
, False);
24884 Set_Current_Value
(Ent
, Empty
);
24885 Set_Is_Known_Null
(Ent
, False);
24887 if not Can_Never_Be_Null
(Ent
) then
24888 Set_Is_Known_Non_Null
(Ent
, False);
24891 -- Follow renaming chain
24893 if Ekind
(Ent
) in E_Variable | E_Constant
24894 and then Present
(Renamed_Object
(Ent
))
24896 Exp
:= Renamed_Object
(Ent
);
24898 -- If the entity is the loop variable in an iteration over
24899 -- a container, retrieve container expression to indicate
24900 -- possible modification.
24902 if Present
(Related_Expression
(Ent
))
24903 and then Nkind
(Parent
(Related_Expression
(Ent
))) =
24904 N_Iterator_Specification
24906 Exp
:= Original_Node
(Related_Expression
(Ent
));
24911 -- The expression may be the renaming of a subcomponent of an
24912 -- array or container. The assignment to the subcomponent is
24913 -- a modification of the container.
24915 elsif Comes_From_Source
(Original_Node
(Exp
))
24916 and then Nkind
(Original_Node
(Exp
)) in
24917 N_Selected_Component | N_Indexed_Component
24919 Exp
:= Prefix
(Original_Node
(Exp
));
24923 -- Generate a reference only if the assignment comes from
24924 -- source. This excludes, for example, calls to a dispatching
24925 -- assignment operation when the left-hand side is tagged. In
24926 -- GNATprove mode, we need those references also on generated
24927 -- code, as these are used to compute the local effects of
24930 if Modification_Comes_From_Source
or GNATprove_Mode
then
24931 Generate_Reference
(Ent
, Exp
, 'm');
24933 -- If the target of the assignment is the bound variable
24934 -- in an iterator, indicate that the corresponding array
24935 -- or container is also modified.
24937 if Ada_Version
>= Ada_2012
24938 and then Nkind
(Parent
(Ent
)) = N_Iterator_Specification
24941 Domain
: constant Node_Id
:= Name
(Parent
(Ent
));
24944 -- TBD : in the full version of the construct, the
24945 -- domain of iteration can be given by an expression.
24947 if Is_Entity_Name
(Domain
) then
24948 Generate_Reference
(Entity
(Domain
), Exp
, 'm');
24949 Set_Is_True_Constant
(Entity
(Domain
), False);
24950 Set_Never_Set_In_Source
(Entity
(Domain
), False);
24959 -- If we are sure this is a modification from source, and we know
24960 -- this modifies a constant, then give an appropriate warning.
24963 and then Modification_Comes_From_Source
24964 and then Overlays_Constant
(Ent
)
24965 and then Address_Clause_Overlay_Warnings
24968 Addr
: constant Node_Id
:= Address_Clause
(Ent
);
24973 Find_Overlaid_Entity
(Addr
, O_Ent
, Off
);
24975 Error_Msg_Sloc
:= Sloc
(Addr
);
24977 ("??constant& may be modified via address clause#",
24988 end Note_Possible_Modification
;
24994 function Null_Status
(N
: Node_Id
) return Null_Status_Kind
is
24995 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean;
24996 -- Determine whether definition Def carries a null exclusion
24998 function Null_Status_Of_Entity
(Id
: Entity_Id
) return Null_Status_Kind
;
24999 -- Determine the null status of arbitrary entity Id
25001 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
;
25002 -- Determine the null status of type Typ
25004 ---------------------------
25005 -- Is_Null_Excluding_Def --
25006 ---------------------------
25008 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean is
25010 return Nkind
(Def
) in N_Access_Definition
25011 | N_Access_Function_Definition
25012 | N_Access_Procedure_Definition
25013 | N_Access_To_Object_Definition
25014 | N_Component_Definition
25015 | N_Derived_Type_Definition
25016 and then Null_Exclusion_Present
(Def
);
25017 end Is_Null_Excluding_Def
;
25019 ---------------------------
25020 -- Null_Status_Of_Entity --
25021 ---------------------------
25023 function Null_Status_Of_Entity
25024 (Id
: Entity_Id
) return Null_Status_Kind
25026 Decl
: constant Node_Id
:= Declaration_Node
(Id
);
25030 -- The value of an imported or exported entity may be set externally
25031 -- regardless of a null exclusion. As a result, the value cannot be
25032 -- determined statically.
25034 if Is_Imported
(Id
) or else Is_Exported
(Id
) then
25037 elsif Nkind
(Decl
) in N_Component_Declaration
25038 | N_Discriminant_Specification
25039 | N_Formal_Object_Declaration
25040 | N_Object_Declaration
25041 | N_Object_Renaming_Declaration
25042 | N_Parameter_Specification
25044 -- A component declaration yields a non-null value when either
25045 -- its component definition or access definition carries a null
25048 if Nkind
(Decl
) = N_Component_Declaration
then
25049 Def
:= Component_Definition
(Decl
);
25051 if Is_Null_Excluding_Def
(Def
) then
25052 return Is_Non_Null
;
25055 Def
:= Access_Definition
(Def
);
25057 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25058 return Is_Non_Null
;
25061 -- A formal object declaration yields a non-null value if its
25062 -- access definition carries a null exclusion. If the object is
25063 -- default initialized, then the value depends on the expression.
25065 elsif Nkind
(Decl
) = N_Formal_Object_Declaration
then
25066 Def
:= Access_Definition
(Decl
);
25068 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25069 return Is_Non_Null
;
25072 -- A constant may yield a null or non-null value depending on its
25073 -- initialization expression.
25075 elsif Ekind
(Id
) = E_Constant
then
25076 return Null_Status
(Constant_Value
(Id
));
25078 -- The construct yields a non-null value when it has a null
25081 elsif Null_Exclusion_Present
(Decl
) then
25082 return Is_Non_Null
;
25084 -- An object renaming declaration yields a non-null value if its
25085 -- access definition carries a null exclusion. Otherwise the value
25086 -- depends on the renamed name.
25088 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
25089 Def
:= Access_Definition
(Decl
);
25091 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25092 return Is_Non_Null
;
25095 return Null_Status
(Name
(Decl
));
25100 -- At this point the declaration of the entity does not carry a null
25101 -- exclusion and lacks an initialization expression. Check the status
25104 return Null_Status_Of_Type
(Etype
(Id
));
25105 end Null_Status_Of_Entity
;
25107 -------------------------
25108 -- Null_Status_Of_Type --
25109 -------------------------
25111 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
is
25116 -- Traverse the type chain looking for types with null exclusion
25119 while Present
(Curr
) and then Etype
(Curr
) /= Curr
loop
25120 Decl
:= Parent
(Curr
);
25122 -- Guard against itypes which do not always have declarations. A
25123 -- type yields a non-null value if it carries a null exclusion.
25125 if Present
(Decl
) then
25126 if Nkind
(Decl
) = N_Full_Type_Declaration
25127 and then Is_Null_Excluding_Def
(Type_Definition
(Decl
))
25129 return Is_Non_Null
;
25131 elsif Nkind
(Decl
) = N_Subtype_Declaration
25132 and then Null_Exclusion_Present
(Decl
)
25134 return Is_Non_Null
;
25138 Curr
:= Etype
(Curr
);
25141 -- The type chain does not contain any null excluding types
25144 end Null_Status_Of_Type
;
25146 -- Start of processing for Null_Status
25149 -- Prevent cascaded errors or infinite loops when trying to determine
25150 -- the null status of an erroneous construct.
25152 if Error_Posted
(N
) then
25155 -- An allocator always creates a non-null value
25157 elsif Nkind
(N
) = N_Allocator
then
25158 return Is_Non_Null
;
25160 -- Taking the 'Access of something yields a non-null value
25162 elsif Nkind
(N
) = N_Attribute_Reference
25163 and then Attribute_Name
(N
) in Name_Access
25164 | Name_Unchecked_Access
25165 | Name_Unrestricted_Access
25167 return Is_Non_Null
;
25169 -- "null" yields null
25171 elsif Nkind
(N
) = N_Null
then
25174 -- Check the status of the operand of a type conversion
25176 elsif Nkind
(N
) = N_Type_Conversion
then
25177 return Null_Status
(Expression
(N
));
25179 -- The input denotes a reference to an entity. Determine whether the
25180 -- entity or its type yields a null or non-null value.
25182 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
25183 return Null_Status_Of_Entity
(Entity
(N
));
25186 -- Otherwise it is not possible to determine the null status of the
25187 -- subexpression at compile time without resorting to simple flow
25193 --------------------------------------
25194 -- Null_To_Null_Address_Convert_OK --
25195 --------------------------------------
25197 function Null_To_Null_Address_Convert_OK
25199 Typ
: Entity_Id
:= Empty
) return Boolean
25202 if not Relaxed_RM_Semantics
then
25206 if Nkind
(N
) = N_Null
then
25207 return Present
(Typ
) and then Is_Descendant_Of_Address
(Typ
);
25210 N_Op_Eq | N_Op_Ge | N_Op_Gt | N_Op_Le | N_Op_Lt | N_Op_Ne
25213 L
: constant Node_Id
:= Left_Opnd
(N
);
25214 R
: constant Node_Id
:= Right_Opnd
(N
);
25217 -- We check the Etype of the complementary operand since the
25218 -- N_Null node is not decorated at this stage.
25221 ((Nkind
(L
) = N_Null
25222 and then Is_Descendant_Of_Address
(Etype
(R
)))
25224 (Nkind
(R
) = N_Null
25225 and then Is_Descendant_Of_Address
(Etype
(L
))));
25230 end Null_To_Null_Address_Convert_OK
;
25232 ---------------------------------
25233 -- Number_Of_Elements_In_Array --
25234 ---------------------------------
25236 function Number_Of_Elements_In_Array
(T
: Entity_Id
) return Int
is
25244 pragma Assert
(Is_Array_Type
(T
));
25246 Indx
:= First_Index
(T
);
25247 while Present
(Indx
) loop
25248 Typ
:= Underlying_Type
(Etype
(Indx
));
25250 -- Never look at junk bounds of a generic type
25252 if Is_Generic_Type
(Typ
) then
25256 -- Check the array bounds are known at compile time and return zero
25257 -- if they are not.
25259 Low
:= Type_Low_Bound
(Typ
);
25260 High
:= Type_High_Bound
(Typ
);
25262 if not Compile_Time_Known_Value
(Low
) then
25264 elsif not Compile_Time_Known_Value
(High
) then
25268 Num
* UI_To_Int
((Expr_Value
(High
) - Expr_Value
(Low
) + 1));
25275 end Number_Of_Elements_In_Array
;
25277 ---------------------------------
25278 -- Original_Aspect_Pragma_Name --
25279 ---------------------------------
25281 function Original_Aspect_Pragma_Name
(N
: Node_Id
) return Name_Id
is
25283 Item_Nam
: Name_Id
;
25286 pragma Assert
(Nkind
(N
) in N_Aspect_Specification | N_Pragma
);
25290 -- The pragma was generated to emulate an aspect, use the original
25291 -- aspect specification.
25293 if Nkind
(Item
) = N_Pragma
and then From_Aspect_Specification
(Item
) then
25294 Item
:= Corresponding_Aspect
(Item
);
25297 -- Retrieve the name of the aspect/pragma. As assertion pragmas from
25298 -- a generic instantiation might have been rewritten into pragma Check,
25299 -- we look at the original node for Item. Note also that Pre, Pre_Class,
25300 -- Post and Post_Class rewrite their pragma identifier to preserve the
25301 -- original name, so we look at the original node for the identifier.
25302 -- ??? this is kludgey
25304 if Nkind
(Item
) = N_Pragma
then
25306 Chars
(Original_Node
(Pragma_Identifier
(Original_Node
(Item
))));
25309 pragma Assert
(Nkind
(Item
) = N_Aspect_Specification
);
25310 Item_Nam
:= Chars
(Identifier
(Item
));
25313 -- Deal with 'Class by converting the name to its _XXX form
25315 if Class_Present
(Item
) then
25316 if Item_Nam
= Name_Invariant
then
25317 Item_Nam
:= Name_uInvariant
;
25319 elsif Item_Nam
= Name_Post
then
25320 Item_Nam
:= Name_uPost
;
25322 elsif Item_Nam
= Name_Pre
then
25323 Item_Nam
:= Name_uPre
;
25325 elsif Item_Nam
in Name_Type_Invariant | Name_Type_Invariant_Class
25327 Item_Nam
:= Name_uType_Invariant
;
25329 -- Nothing to do for other cases (e.g. a Check that derived from
25330 -- Pre_Class and has the flag set). Also we do nothing if the name
25331 -- is already in special _xxx form.
25337 end Original_Aspect_Pragma_Name
;
25339 --------------------------------------
25340 -- Original_Corresponding_Operation --
25341 --------------------------------------
25343 function Original_Corresponding_Operation
(S
: Entity_Id
) return Entity_Id
25345 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
25348 -- If S is an inherited primitive S2 the original corresponding
25349 -- operation of S is the original corresponding operation of S2
25351 if Present
(Alias
(S
))
25352 and then Find_Dispatching_Type
(Alias
(S
)) /= Typ
25354 return Original_Corresponding_Operation
(Alias
(S
));
25356 -- If S overrides an inherited subprogram S2 the original corresponding
25357 -- operation of S is the original corresponding operation of S2
25359 elsif Present
(Overridden_Operation
(S
)) then
25360 return Original_Corresponding_Operation
(Overridden_Operation
(S
));
25362 -- otherwise it is S itself
25367 end Original_Corresponding_Operation
;
25369 -------------------
25370 -- Output_Entity --
25371 -------------------
25373 procedure Output_Entity
(Id
: Entity_Id
) is
25377 Scop
:= Scope
(Id
);
25379 -- The entity may lack a scope when it is in the process of being
25380 -- analyzed. Use the current scope as an approximation.
25383 Scop
:= Current_Scope
;
25386 Output_Name
(Chars
(Id
), Scop
);
25393 procedure Output_Name
(Nam
: Name_Id
; Scop
: Entity_Id
:= Current_Scope
) is
25397 (Get_Qualified_Name
25408 -- This would be trivial, simply a test for an identifier that was a
25409 -- reference to a formal, if it were not for the fact that a previous call
25410 -- to Expand_Entry_Parameter will have modified the reference to the
25411 -- identifier. A formal of a protected entity is rewritten as
25413 -- typ!(recobj).rec.all'Constrained
25415 -- where rec is a selector whose Entry_Formal link points to the formal
25417 -- If the type of the entry parameter has a representation clause, then an
25418 -- extra temp is involved (see below).
25420 -- For a formal of a task entity, the formal is rewritten as a local
25423 -- In addition, a formal that is marked volatile because it is aliased
25424 -- through an address clause is rewritten as dereference as well.
25426 function Param_Entity
(N
: Node_Id
) return Entity_Id
is
25427 Renamed_Obj
: Node_Id
;
25430 -- Simple reference case
25432 if Nkind
(N
) in N_Identifier | N_Expanded_Name
then
25433 if Is_Formal
(Entity
(N
)) then
25436 -- Handle renamings of formal parameters and formals of tasks that
25437 -- are rewritten as renamings.
25439 elsif Nkind
(Parent
(Entity
(N
))) = N_Object_Renaming_Declaration
then
25440 Renamed_Obj
:= Get_Referenced_Object
(Renamed_Object
(Entity
(N
)));
25442 if Is_Entity_Name
(Renamed_Obj
)
25443 and then Is_Formal
(Entity
(Renamed_Obj
))
25445 return Entity
(Renamed_Obj
);
25448 Nkind
(Parent
(Parent
(Entity
(N
)))) = N_Accept_Statement
25455 if Nkind
(N
) = N_Explicit_Dereference
then
25457 P
: Node_Id
:= Prefix
(N
);
25463 -- If the type of an entry parameter has a representation
25464 -- clause, then the prefix is not a selected component, but
25465 -- instead a reference to a temp pointing at the selected
25466 -- component. In this case, set P to be the initial value of
25469 if Nkind
(P
) = N_Identifier
then
25472 if Ekind
(E
) = E_Constant
then
25473 Decl
:= Parent
(E
);
25475 if Nkind
(Decl
) = N_Object_Declaration
then
25476 P
:= Expression
(Decl
);
25481 if Nkind
(P
) = N_Selected_Component
then
25482 S
:= Selector_Name
(P
);
25484 if Present
(Entry_Formal
(Entity
(S
))) then
25485 return Entry_Formal
(Entity
(S
));
25488 elsif Nkind
(Original_Node
(N
)) = N_Identifier
then
25489 return Param_Entity
(Original_Node
(N
));
25498 ----------------------
25499 -- Policy_In_Effect --
25500 ----------------------
25502 function Policy_In_Effect
(Policy
: Name_Id
) return Name_Id
is
25503 function Policy_In_List
(List
: Node_Id
) return Name_Id
;
25504 -- Determine the mode of a policy in a N_Pragma list
25506 --------------------
25507 -- Policy_In_List --
25508 --------------------
25510 function Policy_In_List
(List
: Node_Id
) return Name_Id
is
25517 while Present
(Prag
) loop
25518 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
25519 Arg2
:= Next
(Arg1
);
25521 Arg1
:= Get_Pragma_Arg
(Arg1
);
25522 Arg2
:= Get_Pragma_Arg
(Arg2
);
25524 -- The current Check_Policy pragma matches the requested policy or
25525 -- appears in the single argument form (Assertion, policy_id).
25527 if Chars
(Arg1
) in Name_Assertion | Policy
then
25528 return Chars
(Arg2
);
25531 Prag
:= Next_Pragma
(Prag
);
25535 end Policy_In_List
;
25541 -- Start of processing for Policy_In_Effect
25544 if not Is_Valid_Assertion_Kind
(Policy
) then
25545 raise Program_Error
;
25548 -- Inspect all policy pragmas that appear within scopes (if any)
25550 Kind
:= Policy_In_List
(Check_Policy_List
);
25552 -- Inspect all configuration policy pragmas (if any)
25554 if Kind
= No_Name
then
25555 Kind
:= Policy_In_List
(Check_Policy_List_Config
);
25558 -- The context lacks policy pragmas, determine the mode based on whether
25559 -- assertions are enabled at the configuration level. This ensures that
25560 -- the policy is preserved when analyzing generics.
25562 if Kind
= No_Name
then
25563 if Assertions_Enabled_Config
then
25564 Kind
:= Name_Check
;
25566 Kind
:= Name_Ignore
;
25570 -- In CodePeer mode and GNATprove mode, we need to consider all
25571 -- assertions, unless they are disabled. Force Name_Check on
25572 -- ignored assertions.
25574 if Kind
in Name_Ignore | Name_Off
25575 and then (CodePeer_Mode
or GNATprove_Mode
)
25577 Kind
:= Name_Check
;
25581 end Policy_In_Effect
;
25583 -------------------------------
25584 -- Preanalyze_Without_Errors --
25585 -------------------------------
25587 procedure Preanalyze_Without_Errors
(N
: Node_Id
) is
25588 Status
: constant Boolean := Get_Ignore_Errors
;
25590 Set_Ignore_Errors
(True);
25592 Set_Ignore_Errors
(Status
);
25593 end Preanalyze_Without_Errors
;
25595 -----------------------
25596 -- Predicate_Enabled --
25597 -----------------------
25599 function Predicate_Enabled
(Typ
: Entity_Id
) return Boolean is
25601 return Present
(Predicate_Function
(Typ
))
25602 and then not Predicates_Ignored
(Typ
)
25603 and then not Predicate_Checks_Suppressed
(Empty
);
25604 end Predicate_Enabled
;
25606 ----------------------------------
25607 -- Predicate_Tests_On_Arguments --
25608 ----------------------------------
25610 function Predicate_Tests_On_Arguments
(Subp
: Entity_Id
) return Boolean is
25612 -- Always test predicates on indirect call
25614 if Ekind
(Subp
) = E_Subprogram_Type
then
25617 -- Do not test predicates on call to generated default Finalize, since
25618 -- we are not interested in whether something we are finalizing (and
25619 -- typically destroying) satisfies its predicates.
25621 elsif Chars
(Subp
) = Name_Finalize
25622 and then not Comes_From_Source
(Subp
)
25626 -- Do not test predicates on any internally generated routines
25628 elsif Is_Internal_Name
(Chars
(Subp
)) then
25631 -- Do not test predicates on call to Init_Proc, since if needed the
25632 -- predicate test will occur at some other point.
25634 elsif Is_Init_Proc
(Subp
) then
25637 -- Do not test predicates on call to predicate function, since this
25638 -- would cause infinite recursion.
25640 elsif Ekind
(Subp
) = E_Function
25641 and then (Is_Predicate_Function
(Subp
)
25643 Is_Predicate_Function_M
(Subp
))
25647 -- For now, no other exceptions
25652 end Predicate_Tests_On_Arguments
;
25654 -----------------------
25655 -- Private_Component --
25656 -----------------------
25658 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
25659 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
25661 function Trace_Components
25663 Check
: Boolean) return Entity_Id
;
25664 -- Recursive function that does the work, and checks against circular
25665 -- definition for each subcomponent type.
25667 ----------------------
25668 -- Trace_Components --
25669 ----------------------
25671 function Trace_Components
25673 Check
: Boolean) return Entity_Id
25675 Btype
: constant Entity_Id
:= Base_Type
(T
);
25676 Component
: Entity_Id
;
25678 Candidate
: Entity_Id
:= Empty
;
25681 if Check
and then Btype
= Ancestor
then
25682 Error_Msg_N
("circular type definition", Type_Id
);
25686 if Is_Private_Type
(Btype
) and then not Is_Generic_Type
(Btype
) then
25687 if Present
(Full_View
(Btype
))
25688 and then Is_Record_Type
(Full_View
(Btype
))
25689 and then not Is_Frozen
(Btype
)
25691 -- To indicate that the ancestor depends on a private type, the
25692 -- current Btype is sufficient. However, to check for circular
25693 -- definition we must recurse on the full view.
25695 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
25697 if Candidate
= Any_Type
then
25707 elsif Is_Array_Type
(Btype
) then
25708 return Trace_Components
(Component_Type
(Btype
), True);
25710 elsif Is_Record_Type
(Btype
) then
25711 Component
:= First_Entity
(Btype
);
25712 while Present
(Component
)
25713 and then Comes_From_Source
(Component
)
25715 -- Skip anonymous types generated by constrained components
25717 if not Is_Type
(Component
) then
25718 P
:= Trace_Components
(Etype
(Component
), True);
25720 if Present
(P
) then
25721 if P
= Any_Type
then
25729 Next_Entity
(Component
);
25737 end Trace_Components
;
25739 -- Start of processing for Private_Component
25742 return Trace_Components
(Type_Id
, False);
25743 end Private_Component
;
25745 ---------------------------
25746 -- Primitive_Names_Match --
25747 ---------------------------
25749 function Primitive_Names_Match
(E1
, E2
: Entity_Id
) return Boolean is
25750 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
;
25751 -- Given an internal name, returns the corresponding non-internal name
25753 ------------------------
25754 -- Non_Internal_Name --
25755 ------------------------
25757 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
is
25759 Get_Name_String
(Chars
(E
));
25760 Name_Len
:= Name_Len
- 1;
25762 end Non_Internal_Name
;
25764 -- Start of processing for Primitive_Names_Match
25767 pragma Assert
(Present
(E1
) and then Present
(E2
));
25769 return Chars
(E1
) = Chars
(E2
)
25771 (not Is_Internal_Name
(Chars
(E1
))
25772 and then Is_Internal_Name
(Chars
(E2
))
25773 and then Non_Internal_Name
(E2
) = Chars
(E1
))
25775 (not Is_Internal_Name
(Chars
(E2
))
25776 and then Is_Internal_Name
(Chars
(E1
))
25777 and then Non_Internal_Name
(E1
) = Chars
(E2
))
25779 (Is_Predefined_Dispatching_Operation
(E1
)
25780 and then Is_Predefined_Dispatching_Operation
(E2
)
25781 and then Same_TSS
(E1
, E2
))
25783 (Is_Init_Proc
(E1
) and then Is_Init_Proc
(E2
));
25784 end Primitive_Names_Match
;
25786 -----------------------
25787 -- Process_End_Label --
25788 -----------------------
25790 procedure Process_End_Label
25799 Label_Ref
: Boolean;
25800 -- Set True if reference to end label itself is required
25803 -- Gets set to the operator symbol or identifier that references the
25804 -- entity Ent. For the child unit case, this is the identifier from the
25805 -- designator. For other cases, this is simply Endl.
25807 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
);
25808 -- N is an identifier node that appears as a parent unit reference in
25809 -- the case where Ent is a child unit. This procedure generates an
25810 -- appropriate cross-reference entry. E is the corresponding entity.
25812 -------------------------
25813 -- Generate_Parent_Ref --
25814 -------------------------
25816 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
) is
25818 -- If names do not match, something weird, skip reference
25820 if Chars
(E
) = Chars
(N
) then
25822 -- Generate the reference. We do NOT consider this as a reference
25823 -- for unreferenced symbol purposes.
25825 Generate_Reference
(E
, N
, 'r', Set_Ref
=> False, Force
=> True);
25827 if Style_Check
then
25828 Style
.Check_Identifier
(N
, E
);
25831 end Generate_Parent_Ref
;
25833 -- Start of processing for Process_End_Label
25836 -- If no node, ignore. This happens in some error situations, and
25837 -- also for some internally generated structures where no end label
25838 -- references are required in any case.
25844 -- Nothing to do if no End_Label, happens for internally generated
25845 -- constructs where we don't want an end label reference anyway. Also
25846 -- nothing to do if Endl is a string literal, which means there was
25847 -- some prior error (bad operator symbol)
25849 Endl
:= End_Label
(N
);
25851 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
25855 -- Reference node is not in extended main source unit
25857 if not In_Extended_Main_Source_Unit
(N
) then
25859 -- Generally we do not collect references except for the extended
25860 -- main source unit. The one exception is the 'e' entry for a
25861 -- package spec, where it is useful for a client to have the
25862 -- ending information to define scopes.
25868 Label_Ref
:= False;
25870 -- For this case, we can ignore any parent references, but we
25871 -- need the package name itself for the 'e' entry.
25873 if Nkind
(Endl
) = N_Designator
then
25874 Endl
:= Identifier
(Endl
);
25878 -- Reference is in extended main source unit
25883 -- For designator, generate references for the parent entries
25885 if Nkind
(Endl
) = N_Designator
then
25887 -- Generate references for the prefix if the END line comes from
25888 -- source (otherwise we do not need these references) We climb the
25889 -- scope stack to find the expected entities.
25891 if Comes_From_Source
(Endl
) then
25892 Nam
:= Name
(Endl
);
25893 Scop
:= Current_Scope
;
25894 while Nkind
(Nam
) = N_Selected_Component
loop
25895 Scop
:= Scope
(Scop
);
25896 exit when No
(Scop
);
25897 Generate_Parent_Ref
(Selector_Name
(Nam
), Scop
);
25898 Nam
:= Prefix
(Nam
);
25901 if Present
(Scop
) then
25902 Generate_Parent_Ref
(Nam
, Scope
(Scop
));
25906 Endl
:= Identifier
(Endl
);
25910 -- If the end label is not for the given entity, then either we have
25911 -- some previous error, or this is a generic instantiation for which
25912 -- we do not need to make a cross-reference in this case anyway. In
25913 -- either case we simply ignore the call.
25915 if Chars
(Ent
) /= Chars
(Endl
) then
25919 -- If label was really there, then generate a normal reference and then
25920 -- adjust the location in the end label to point past the name (which
25921 -- should almost always be the semicolon).
25923 Loc
:= Sloc
(Endl
);
25925 if Comes_From_Source
(Endl
) then
25927 -- If a label reference is required, then do the style check and
25928 -- generate an l-type cross-reference entry for the label
25931 if Style_Check
then
25932 Style
.Check_Identifier
(Endl
, Ent
);
25935 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
25938 -- Set the location to point past the label (normally this will
25939 -- mean the semicolon immediately following the label). This is
25940 -- done for the sake of the 'e' or 't' entry generated below.
25942 Get_Decoded_Name_String
(Chars
(Endl
));
25943 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
25946 -- Now generate the e/t reference
25948 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
25950 -- Restore Sloc, in case modified above, since we have an identifier
25951 -- and the normal Sloc should be left set in the tree.
25953 Set_Sloc
(Endl
, Loc
);
25954 end Process_End_Label
;
25956 --------------------------------
25957 -- Propagate_Concurrent_Flags --
25958 --------------------------------
25960 procedure Propagate_Concurrent_Flags
25962 Comp_Typ
: Entity_Id
)
25965 if Has_Task
(Comp_Typ
) then
25966 Set_Has_Task
(Typ
);
25969 if Has_Protected
(Comp_Typ
) then
25970 Set_Has_Protected
(Typ
);
25973 if Has_Timing_Event
(Comp_Typ
) then
25974 Set_Has_Timing_Event
(Typ
);
25976 end Propagate_Concurrent_Flags
;
25978 ------------------------------
25979 -- Propagate_DIC_Attributes --
25980 ------------------------------
25982 procedure Propagate_DIC_Attributes
25984 From_Typ
: Entity_Id
)
25986 DIC_Proc
: Entity_Id
;
25987 Partial_DIC_Proc
: Entity_Id
;
25990 if Present
(Typ
) and then Present
(From_Typ
) then
25991 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
25993 -- Nothing to do if both the source and the destination denote the
25996 if From_Typ
= Typ
then
25999 -- Nothing to do when the destination denotes an incomplete type
26000 -- because the DIC is associated with the current instance of a
26001 -- private type, thus it can never apply to an incomplete type.
26003 elsif Is_Incomplete_Type
(Typ
) then
26007 DIC_Proc
:= DIC_Procedure
(From_Typ
);
26008 Partial_DIC_Proc
:= Partial_DIC_Procedure
(From_Typ
);
26010 -- The setting of the attributes is intentionally conservative. This
26011 -- prevents accidental clobbering of enabled attributes.
26013 if Has_Inherited_DIC
(From_Typ
) then
26014 Set_Has_Inherited_DIC
(Typ
);
26017 if Has_Own_DIC
(From_Typ
) then
26018 Set_Has_Own_DIC
(Typ
);
26021 if Present
(DIC_Proc
) and then No
(DIC_Procedure
(Typ
)) then
26022 Set_DIC_Procedure
(Typ
, DIC_Proc
);
26025 if Present
(Partial_DIC_Proc
)
26026 and then No
(Partial_DIC_Procedure
(Typ
))
26028 Set_Partial_DIC_Procedure
(Typ
, Partial_DIC_Proc
);
26031 end Propagate_DIC_Attributes
;
26033 ------------------------------------
26034 -- Propagate_Invariant_Attributes --
26035 ------------------------------------
26037 procedure Propagate_Invariant_Attributes
26039 From_Typ
: Entity_Id
)
26041 Full_IP
: Entity_Id
;
26042 Part_IP
: Entity_Id
;
26045 if Present
(Typ
) and then Present
(From_Typ
) then
26046 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26048 -- Nothing to do if both the source and the destination denote the
26051 if From_Typ
= Typ
then
26055 Full_IP
:= Invariant_Procedure
(From_Typ
);
26056 Part_IP
:= Partial_Invariant_Procedure
(From_Typ
);
26058 -- The setting of the attributes is intentionally conservative. This
26059 -- prevents accidental clobbering of enabled attributes.
26061 if Has_Inheritable_Invariants
(From_Typ
) then
26062 Set_Has_Inheritable_Invariants
(Typ
);
26065 if Has_Inherited_Invariants
(From_Typ
) then
26066 Set_Has_Inherited_Invariants
(Typ
);
26069 if Has_Own_Invariants
(From_Typ
) then
26070 Set_Has_Own_Invariants
(Base_Type
(Typ
));
26073 if Present
(Full_IP
) and then No
(Invariant_Procedure
(Typ
)) then
26074 Set_Invariant_Procedure
(Typ
, Full_IP
);
26077 if Present
(Part_IP
) and then No
(Partial_Invariant_Procedure
(Typ
))
26079 Set_Partial_Invariant_Procedure
(Typ
, Part_IP
);
26082 end Propagate_Invariant_Attributes
;
26084 ------------------------------------
26085 -- Propagate_Predicate_Attributes --
26086 ------------------------------------
26088 procedure Propagate_Predicate_Attributes
26090 From_Typ
: Entity_Id
)
26092 Pred_Func
: Entity_Id
;
26093 Pred_Func_M
: Entity_Id
;
26096 if Present
(Typ
) and then Present
(From_Typ
) then
26097 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26099 -- Nothing to do if both the source and the destination denote the
26102 if From_Typ
= Typ
then
26106 Pred_Func
:= Predicate_Function
(From_Typ
);
26107 Pred_Func_M
:= Predicate_Function_M
(From_Typ
);
26109 -- The setting of the attributes is intentionally conservative. This
26110 -- prevents accidental clobbering of enabled attributes.
26112 if Has_Predicates
(From_Typ
) then
26113 Set_Has_Predicates
(Typ
);
26116 if Present
(Pred_Func
) and then No
(Predicate_Function
(Typ
)) then
26117 Set_Predicate_Function
(Typ
, Pred_Func
);
26120 if Present
(Pred_Func_M
) and then No
(Predicate_Function_M
(Typ
)) then
26121 Set_Predicate_Function_M
(Typ
, Pred_Func_M
);
26124 end Propagate_Predicate_Attributes
;
26126 ---------------------------------------
26127 -- Record_Possible_Part_Of_Reference --
26128 ---------------------------------------
26130 procedure Record_Possible_Part_Of_Reference
26131 (Var_Id
: Entity_Id
;
26134 Encap
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
26138 -- The variable is a constituent of a single protected/task type. Such
26139 -- a variable acts as a component of the type and must appear within a
26140 -- specific region (SPARK RM 9(3)). Instead of recording the reference,
26141 -- verify its legality now.
26143 if Present
(Encap
) and then Is_Single_Concurrent_Object
(Encap
) then
26144 Check_Part_Of_Reference
(Var_Id
, Ref
);
26146 -- The variable is subject to pragma Part_Of and may eventually become a
26147 -- constituent of a single protected/task type. Record the reference to
26148 -- verify its placement when the contract of the variable is analyzed.
26150 elsif Present
(Get_Pragma
(Var_Id
, Pragma_Part_Of
)) then
26151 Refs
:= Part_Of_References
(Var_Id
);
26154 Refs
:= New_Elmt_List
;
26155 Set_Part_Of_References
(Var_Id
, Refs
);
26158 Append_Elmt
(Ref
, Refs
);
26160 end Record_Possible_Part_Of_Reference
;
26166 function Referenced
(Id
: Entity_Id
; Expr
: Node_Id
) return Boolean is
26167 Seen
: Boolean := False;
26169 function Is_Reference
(N
: Node_Id
) return Traverse_Result
;
26170 -- Determine whether node N denotes a reference to Id. If this is the
26171 -- case, set global flag Seen to True and stop the traversal.
26177 function Is_Reference
(N
: Node_Id
) return Traverse_Result
is
26179 if Is_Entity_Name
(N
)
26180 and then Present
(Entity
(N
))
26181 and then Entity
(N
) = Id
26190 procedure Inspect_Expression
is new Traverse_Proc
(Is_Reference
);
26192 -- Start of processing for Referenced
26195 Inspect_Expression
(Expr
);
26199 ------------------------------------
26200 -- References_Generic_Formal_Type --
26201 ------------------------------------
26203 function References_Generic_Formal_Type
(N
: Node_Id
) return Boolean is
26205 function Process
(N
: Node_Id
) return Traverse_Result
;
26206 -- Process one node in search for generic formal type
26212 function Process
(N
: Node_Id
) return Traverse_Result
is
26214 if Nkind
(N
) in N_Has_Entity
then
26216 E
: constant Entity_Id
:= Entity
(N
);
26218 if Present
(E
) then
26219 if Is_Generic_Type
(E
) then
26221 elsif Present
(Etype
(E
))
26222 and then Is_Generic_Type
(Etype
(E
))
26233 function Traverse
is new Traverse_Func
(Process
);
26234 -- Traverse tree to look for generic type
26237 if Inside_A_Generic
then
26238 return Traverse
(N
) = Abandon
;
26242 end References_Generic_Formal_Type
;
26244 -------------------------------
26245 -- Remove_Entity_And_Homonym --
26246 -------------------------------
26248 procedure Remove_Entity_And_Homonym
(Id
: Entity_Id
) is
26250 Remove_Entity
(Id
);
26251 Remove_Homonym
(Id
);
26252 end Remove_Entity_And_Homonym
;
26254 --------------------
26255 -- Remove_Homonym --
26256 --------------------
26258 procedure Remove_Homonym
(Id
: Entity_Id
) is
26260 Prev
: Entity_Id
:= Empty
;
26263 if Id
= Current_Entity
(Id
) then
26264 if Present
(Homonym
(Id
)) then
26265 Set_Current_Entity
(Homonym
(Id
));
26267 Set_Name_Entity_Id
(Chars
(Id
), Empty
);
26271 Hom
:= Current_Entity
(Id
);
26272 while Present
(Hom
) and then Hom
/= Id
loop
26274 Hom
:= Homonym
(Hom
);
26277 -- If Id is not on the homonym chain, nothing to do
26279 if Present
(Hom
) then
26280 Set_Homonym
(Prev
, Homonym
(Id
));
26283 end Remove_Homonym
;
26285 ------------------------------
26286 -- Remove_Overloaded_Entity --
26287 ------------------------------
26289 procedure Remove_Overloaded_Entity
(Id
: Entity_Id
) is
26290 procedure Remove_Primitive_Of
(Typ
: Entity_Id
);
26291 -- Remove primitive subprogram Id from the list of primitives that
26292 -- belong to type Typ.
26294 -------------------------
26295 -- Remove_Primitive_Of --
26296 -------------------------
26298 procedure Remove_Primitive_Of
(Typ
: Entity_Id
) is
26302 if Is_Tagged_Type
(Typ
) then
26303 Prims
:= Direct_Primitive_Operations
(Typ
);
26305 if Present
(Prims
) then
26306 Remove
(Prims
, Id
);
26309 end Remove_Primitive_Of
;
26313 Formal
: Entity_Id
;
26315 -- Start of processing for Remove_Overloaded_Entity
26318 Remove_Entity_And_Homonym
(Id
);
26320 -- The entity denotes a primitive subprogram. Remove it from the list of
26321 -- primitives of the associated controlling type.
26323 if Ekind
(Id
) in E_Function | E_Procedure
and then Is_Primitive
(Id
) then
26324 Formal
:= First_Formal
(Id
);
26325 while Present
(Formal
) loop
26326 if Is_Controlling_Formal
(Formal
) then
26327 Remove_Primitive_Of
(Etype
(Formal
));
26331 Next_Formal
(Formal
);
26334 if Ekind
(Id
) = E_Function
and then Has_Controlling_Result
(Id
) then
26335 Remove_Primitive_Of
(Etype
(Id
));
26338 end Remove_Overloaded_Entity
;
26340 ---------------------
26341 -- Rep_To_Pos_Flag --
26342 ---------------------
26344 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
26346 return New_Occurrence_Of
26347 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
26348 end Rep_To_Pos_Flag
;
26350 --------------------
26351 -- Require_Entity --
26352 --------------------
26354 procedure Require_Entity
(N
: Node_Id
) is
26356 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
26357 if Total_Errors_Detected
/= 0 then
26358 Set_Entity
(N
, Any_Id
);
26360 raise Program_Error
;
26363 end Require_Entity
;
26365 ------------------------------
26366 -- Requires_Transient_Scope --
26367 ------------------------------
26369 -- A transient scope is required when variable-sized temporaries are
26370 -- allocated on the secondary stack, or when finalization actions must be
26371 -- generated before the next instruction.
26373 function Requires_Transient_Scope
(Id
: Entity_Id
) return Boolean is
26374 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean;
26375 -- This is called for untagged records and protected types, with
26376 -- nondefaulted discriminants. Returns True if the size of function
26377 -- results is known at the call site, False otherwise. Returns False
26378 -- if there is a variant part that depends on the discriminants of
26379 -- this type, or if there is an array constrained by the discriminants
26380 -- of this type. ???Currently, this is overly conservative (the array
26381 -- could be nested inside some other record that is constrained by
26382 -- nondiscriminants). That is, the recursive calls are too conservative.
26384 procedure Ensure_Minimum_Decoration
(Typ
: Entity_Id
);
26385 -- If Typ is not frozen then add to Typ the minimum decoration required
26386 -- by Requires_Transient_Scope to reliably provide its functionality;
26387 -- otherwise no action is performed.
26389 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean;
26390 -- Returns True if Typ is a nonlimited record with defaulted
26391 -- discriminants whose max size makes it unsuitable for allocating on
26392 -- the primary stack.
26394 ------------------------------
26395 -- Caller_Known_Size_Record --
26396 ------------------------------
26398 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean is
26399 pragma Assert
(Typ
= Underlying_Type
(Typ
));
26402 if Has_Variant_Part
(Typ
) and then not Is_Definite_Subtype
(Typ
) then
26410 Comp
:= First_Component
(Typ
);
26411 while Present
(Comp
) loop
26413 -- Only look at E_Component entities. No need to look at
26414 -- E_Discriminant entities, and we must ignore internal
26415 -- subtypes generated for constrained components.
26418 Comp_Type
: constant Entity_Id
:=
26419 Underlying_Type
(Etype
(Comp
));
26422 if Is_Record_Type
(Comp_Type
)
26424 Is_Protected_Type
(Comp_Type
)
26426 if not Caller_Known_Size_Record
(Comp_Type
) then
26430 elsif Is_Array_Type
(Comp_Type
) then
26431 if Size_Depends_On_Discriminant
(Comp_Type
) then
26437 Next_Component
(Comp
);
26442 end Caller_Known_Size_Record
;
26444 -------------------------------
26445 -- Ensure_Minimum_Decoration --
26446 -------------------------------
26448 procedure Ensure_Minimum_Decoration
(Typ
: Entity_Id
) is
26451 -- Do not set Has_Controlled_Component on a class-wide equivalent
26452 -- type. See Make_CW_Equivalent_Type.
26455 and then not Is_Frozen
(Typ
)
26456 and then (Is_Record_Type
(Typ
)
26457 or else Is_Concurrent_Type
(Typ
)
26458 or else Is_Incomplete_Or_Private_Type
(Typ
))
26459 and then not Is_Class_Wide_Equivalent_Type
(Typ
)
26461 Comp
:= First_Component
(Typ
);
26462 while Present
(Comp
) loop
26463 if Has_Controlled_Component
(Etype
(Comp
))
26465 (Chars
(Comp
) /= Name_uParent
26466 and then Is_Controlled
(Etype
(Comp
)))
26468 (Is_Protected_Type
(Etype
(Comp
))
26470 Present
(Corresponding_Record_Type
(Etype
(Comp
)))
26472 Has_Controlled_Component
26473 (Corresponding_Record_Type
(Etype
(Comp
))))
26475 Set_Has_Controlled_Component
(Typ
);
26479 Next_Component
(Comp
);
26482 end Ensure_Minimum_Decoration
;
26484 ------------------------------
26485 -- Large_Max_Size_Mutable --
26486 ------------------------------
26488 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean is
26489 pragma Assert
(Typ
= Underlying_Type
(Typ
));
26491 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean;
26492 -- Returns true if the discrete type T has a large range
26494 ----------------------------
26495 -- Is_Large_Discrete_Type --
26496 ----------------------------
26498 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean is
26499 Threshold
: constant Int
:= 16;
26500 -- Arbitrary threshold above which we consider it "large". We want
26501 -- a fairly large threshold, because these large types really
26502 -- shouldn't have default discriminants in the first place, in
26506 return UI_To_Int
(RM_Size
(T
)) > Threshold
;
26507 end Is_Large_Discrete_Type
;
26509 -- Start of processing for Large_Max_Size_Mutable
26512 if Is_Record_Type
(Typ
)
26513 and then not Is_Limited_View
(Typ
)
26514 and then Has_Defaulted_Discriminants
(Typ
)
26516 -- Loop through the components, looking for an array whose upper
26517 -- bound(s) depends on discriminants, where both the subtype of
26518 -- the discriminant and the index subtype are too large.
26524 Comp
:= First_Component
(Typ
);
26525 while Present
(Comp
) loop
26527 Comp_Type
: constant Entity_Id
:=
26528 Underlying_Type
(Etype
(Comp
));
26535 if Is_Array_Type
(Comp_Type
) then
26536 Indx
:= First_Index
(Comp_Type
);
26538 while Present
(Indx
) loop
26539 Ityp
:= Etype
(Indx
);
26540 Hi
:= Type_High_Bound
(Ityp
);
26542 if Nkind
(Hi
) = N_Identifier
26543 and then Ekind
(Entity
(Hi
)) = E_Discriminant
26544 and then Is_Large_Discrete_Type
(Ityp
)
26545 and then Is_Large_Discrete_Type
26546 (Etype
(Entity
(Hi
)))
26556 Next_Component
(Comp
);
26562 end Large_Max_Size_Mutable
;
26564 -- Local declarations
26566 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
26568 -- Start of processing for Requires_Transient_Scope
26571 Ensure_Minimum_Decoration
(Id
);
26573 -- This is a private type which is not completed yet. This can only
26574 -- happen in a default expression (of a formal parameter or of a
26575 -- record component). Do not expand transient scope in this case.
26580 -- Do not expand transient scope for non-existent procedure return or
26581 -- string literal types.
26583 elsif Typ
= Standard_Void_Type
26584 or else Ekind
(Typ
) = E_String_Literal_Subtype
26588 -- If Typ is a generic formal incomplete type, then we want to look at
26589 -- the actual type.
26591 elsif Ekind
(Typ
) = E_Record_Subtype
26592 and then Present
(Cloned_Subtype
(Typ
))
26594 return Requires_Transient_Scope
(Cloned_Subtype
(Typ
));
26596 -- Functions returning specific tagged types may dispatch on result, so
26597 -- their returned value is allocated on the secondary stack, even in the
26598 -- definite case. We must treat nondispatching functions the same way,
26599 -- because access-to-function types can point at both, so the calling
26600 -- conventions must be compatible. Is_Tagged_Type includes controlled
26601 -- types and class-wide types. Controlled type temporaries need
26604 -- ???It's not clear why we need to return noncontrolled types with
26605 -- controlled components on the secondary stack.
26607 elsif Is_Tagged_Type
(Typ
) or else Has_Controlled_Component
(Typ
) then
26610 -- Untagged definite subtypes are known size. This includes all
26611 -- elementary [sub]types. Tasks are known size even if they have
26612 -- discriminants. So we return False here, with one exception:
26613 -- For a type like:
26614 -- type T (Last : Natural := 0) is
26615 -- X : String (1 .. Last);
26617 -- we return True. That's because for "P(F(...));", where F returns T,
26618 -- we don't know the size of the result at the call site, so if we
26619 -- allocated it on the primary stack, we would have to allocate the
26620 -- maximum size, which is way too big.
26622 elsif Is_Definite_Subtype
(Typ
) or else Is_Task_Type
(Typ
) then
26623 return Large_Max_Size_Mutable
(Typ
);
26625 -- Indefinite (discriminated) untagged record or protected type
26627 elsif Is_Record_Type
(Typ
) or else Is_Protected_Type
(Typ
) then
26628 return not Caller_Known_Size_Record
(Typ
);
26630 -- Unconstrained array
26633 pragma Assert
(Is_Array_Type
(Typ
) and not Is_Definite_Subtype
(Typ
));
26636 end Requires_Transient_Scope
;
26638 --------------------------
26639 -- Reset_Analyzed_Flags --
26640 --------------------------
26642 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
26643 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
;
26644 -- Function used to reset Analyzed flags in tree. Note that we do
26645 -- not reset Analyzed flags in entities, since there is no need to
26646 -- reanalyze entities, and indeed, it is wrong to do so, since it
26647 -- can result in generating auxiliary stuff more than once.
26649 --------------------
26650 -- Clear_Analyzed --
26651 --------------------
26653 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
is
26655 if Nkind
(N
) not in N_Entity
then
26656 Set_Analyzed
(N
, False);
26660 end Clear_Analyzed
;
26662 procedure Reset_Analyzed
is new Traverse_Proc
(Clear_Analyzed
);
26664 -- Start of processing for Reset_Analyzed_Flags
26667 Reset_Analyzed
(N
);
26668 end Reset_Analyzed_Flags
;
26670 ------------------------
26671 -- Restore_SPARK_Mode --
26672 ------------------------
26674 procedure Restore_SPARK_Mode
26675 (Mode
: SPARK_Mode_Type
;
26679 SPARK_Mode
:= Mode
;
26680 SPARK_Mode_Pragma
:= Prag
;
26681 end Restore_SPARK_Mode
;
26683 --------------------------------
26684 -- Returns_Unconstrained_Type --
26685 --------------------------------
26687 function Returns_Unconstrained_Type
(Subp
: Entity_Id
) return Boolean is
26689 return Ekind
(Subp
) = E_Function
26690 and then not Is_Scalar_Type
(Etype
(Subp
))
26691 and then not Is_Access_Type
(Etype
(Subp
))
26692 and then not Is_Constrained
(Etype
(Subp
));
26693 end Returns_Unconstrained_Type
;
26695 ----------------------------
26696 -- Root_Type_Of_Full_View --
26697 ----------------------------
26699 function Root_Type_Of_Full_View
(T
: Entity_Id
) return Entity_Id
is
26700 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
26703 -- The root type of the full view may itself be a private type. Keep
26704 -- looking for the ultimate derivation parent.
26706 if Is_Private_Type
(Rtyp
) and then Present
(Full_View
(Rtyp
)) then
26707 return Root_Type_Of_Full_View
(Full_View
(Rtyp
));
26711 end Root_Type_Of_Full_View
;
26713 ---------------------------
26714 -- Safe_To_Capture_Value --
26715 ---------------------------
26717 function Safe_To_Capture_Value
26720 Cond
: Boolean := False) return Boolean
26723 -- The only entities for which we track constant values are variables
26724 -- which are not renamings, constants and formal parameters, so check
26725 -- if we have this case.
26727 -- Note: it may seem odd to track constant values for constants, but in
26728 -- fact this routine is used for other purposes than simply capturing
26729 -- the value. In particular, the setting of Known[_Non]_Null and
26732 if (Ekind
(Ent
) = E_Variable
and then No
(Renamed_Object
(Ent
)))
26734 Ekind
(Ent
) = E_Constant
26740 -- For conditionals, we also allow loop parameters
26742 elsif Cond
and then Ekind
(Ent
) = E_Loop_Parameter
then
26745 -- For all other cases, not just unsafe, but impossible to capture
26746 -- Current_Value, since the above are the only entities which have
26747 -- Current_Value fields.
26753 -- Skip if volatile or aliased, since funny things might be going on in
26754 -- these cases which we cannot necessarily track. Also skip any variable
26755 -- for which an address clause is given, or whose address is taken. Also
26756 -- never capture value of library level variables (an attempt to do so
26757 -- can occur in the case of package elaboration code).
26759 if Treat_As_Volatile
(Ent
)
26760 or else Is_Aliased
(Ent
)
26761 or else Present
(Address_Clause
(Ent
))
26762 or else Address_Taken
(Ent
)
26763 or else (Is_Library_Level_Entity
(Ent
)
26764 and then Ekind
(Ent
) = E_Variable
)
26769 -- OK, all above conditions are met. We also require that the scope of
26770 -- the reference be the same as the scope of the entity, not counting
26771 -- packages and blocks and loops.
26774 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
26775 R_Scope
: Entity_Id
;
26778 R_Scope
:= Current_Scope
;
26779 while R_Scope
/= Standard_Standard
loop
26780 exit when R_Scope
= E_Scope
;
26782 if Ekind
(R_Scope
) not in E_Package | E_Block | E_Loop
then
26785 R_Scope
:= Scope
(R_Scope
);
26790 -- We also require that the reference does not appear in a context
26791 -- where it is not sure to be executed (i.e. a conditional context
26792 -- or an exception handler). We skip this if Cond is True, since the
26793 -- capturing of values from conditional tests handles this ok.
26806 -- Seems dubious that case expressions are not handled here ???
26809 while Present
(P
) loop
26810 if Nkind
(P
) = N_If_Statement
26811 or else Nkind
(P
) = N_Case_Statement
26812 or else (Nkind
(P
) in N_Short_Circuit
26813 and then Desc
= Right_Opnd
(P
))
26814 or else (Nkind
(P
) = N_If_Expression
26815 and then Desc
/= First
(Expressions
(P
)))
26816 or else Nkind
(P
) = N_Exception_Handler
26817 or else Nkind
(P
) = N_Selective_Accept
26818 or else Nkind
(P
) = N_Conditional_Entry_Call
26819 or else Nkind
(P
) = N_Timed_Entry_Call
26820 or else Nkind
(P
) = N_Asynchronous_Select
26828 -- A special Ada 2012 case: the original node may be part
26829 -- of the else_actions of a conditional expression, in which
26830 -- case it might not have been expanded yet, and appears in
26831 -- a non-syntactic list of actions. In that case it is clearly
26832 -- not safe to save a value.
26835 and then Is_List_Member
(Desc
)
26836 and then No
(Parent
(List_Containing
(Desc
)))
26844 -- OK, looks safe to set value
26847 end Safe_To_Capture_Value
;
26853 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
26854 K1
: constant Node_Kind
:= Nkind
(N1
);
26855 K2
: constant Node_Kind
:= Nkind
(N2
);
26858 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
26859 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
26861 return Chars
(N1
) = Chars
(N2
);
26863 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
26864 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
26866 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
26867 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
26878 function Same_Object
(Node1
, Node2
: Node_Id
) return Boolean is
26879 N1
: constant Node_Id
:= Original_Node
(Node1
);
26880 N2
: constant Node_Id
:= Original_Node
(Node2
);
26881 -- We do the tests on original nodes, since we are most interested
26882 -- in the original source, not any expansion that got in the way.
26884 K1
: constant Node_Kind
:= Nkind
(N1
);
26885 K2
: constant Node_Kind
:= Nkind
(N2
);
26888 -- First case, both are entities with same entity
26890 if K1
in N_Has_Entity
and then K2
in N_Has_Entity
then
26892 EN1
: constant Entity_Id
:= Entity
(N1
);
26893 EN2
: constant Entity_Id
:= Entity
(N2
);
26895 if Present
(EN1
) and then Present
(EN2
)
26896 and then (Ekind
(EN1
) in E_Variable | E_Constant
26897 or else Is_Formal
(EN1
))
26905 -- Second case, selected component with same selector, same record
26907 if K1
= N_Selected_Component
26908 and then K2
= N_Selected_Component
26909 and then Chars
(Selector_Name
(N1
)) = Chars
(Selector_Name
(N2
))
26911 return Same_Object
(Prefix
(N1
), Prefix
(N2
));
26913 -- Third case, indexed component with same subscripts, same array
26915 elsif K1
= N_Indexed_Component
26916 and then K2
= N_Indexed_Component
26917 and then Same_Object
(Prefix
(N1
), Prefix
(N2
))
26922 E1
:= First
(Expressions
(N1
));
26923 E2
:= First
(Expressions
(N2
));
26924 while Present
(E1
) loop
26925 if not Same_Value
(E1
, E2
) then
26936 -- Fourth case, slice of same array with same bounds
26939 and then K2
= N_Slice
26940 and then Nkind
(Discrete_Range
(N1
)) = N_Range
26941 and then Nkind
(Discrete_Range
(N2
)) = N_Range
26942 and then Same_Value
(Low_Bound
(Discrete_Range
(N1
)),
26943 Low_Bound
(Discrete_Range
(N2
)))
26944 and then Same_Value
(High_Bound
(Discrete_Range
(N1
)),
26945 High_Bound
(Discrete_Range
(N2
)))
26947 return Same_Name
(Prefix
(N1
), Prefix
(N2
));
26949 -- All other cases, not clearly the same object
26956 ---------------------------------
26957 -- Same_Or_Aliased_Subprograms --
26958 ---------------------------------
26960 function Same_Or_Aliased_Subprograms
26962 E
: Entity_Id
) return Boolean
26964 Subp_Alias
: constant Entity_Id
:= Alias
(S
);
26966 return S
= E
or else (Present
(Subp_Alias
) and then Subp_Alias
= E
);
26967 end Same_Or_Aliased_Subprograms
;
26973 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
26978 elsif not Is_Constrained
(T1
)
26979 and then not Is_Constrained
(T2
)
26980 and then Base_Type
(T1
) = Base_Type
(T2
)
26984 -- For now don't bother with case of identical constraints, to be
26985 -- fiddled with later on perhaps (this is only used for optimization
26986 -- purposes, so it is not critical to do a best possible job)
26997 function Same_Value
(Node1
, Node2
: Node_Id
) return Boolean is
26999 if Compile_Time_Known_Value
(Node1
)
27000 and then Compile_Time_Known_Value
(Node2
)
27002 -- Handle properly compile-time expressions that are not
27005 if Is_String_Type
(Etype
(Node1
)) then
27006 return Expr_Value_S
(Node1
) = Expr_Value_S
(Node2
);
27009 return Expr_Value
(Node1
) = Expr_Value
(Node2
);
27012 elsif Same_Object
(Node1
, Node2
) then
27019 --------------------
27020 -- Set_SPARK_Mode --
27021 --------------------
27023 procedure Set_SPARK_Mode
(Context
: Entity_Id
) is
27025 -- Do not consider illegal or partially decorated constructs
27027 if Ekind
(Context
) = E_Void
or else Error_Posted
(Context
) then
27030 elsif Present
(SPARK_Pragma
(Context
)) then
27032 (Mode
=> Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Context
)),
27033 Prag
=> SPARK_Pragma
(Context
));
27035 end Set_SPARK_Mode
;
27037 -------------------------
27038 -- Scalar_Part_Present --
27039 -------------------------
27041 function Scalar_Part_Present
(Typ
: Entity_Id
) return Boolean is
27042 Val_Typ
: constant Entity_Id
:= Validated_View
(Typ
);
27046 if Is_Scalar_Type
(Val_Typ
) then
27049 elsif Is_Array_Type
(Val_Typ
) then
27050 return Scalar_Part_Present
(Component_Type
(Val_Typ
));
27052 elsif Is_Record_Type
(Val_Typ
) then
27053 Field
:= First_Component_Or_Discriminant
(Val_Typ
);
27054 while Present
(Field
) loop
27055 if Scalar_Part_Present
(Etype
(Field
)) then
27059 Next_Component_Or_Discriminant
(Field
);
27064 end Scalar_Part_Present
;
27066 ------------------------
27067 -- Scope_Is_Transient --
27068 ------------------------
27070 function Scope_Is_Transient
return Boolean is
27072 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
27073 end Scope_Is_Transient
;
27079 function Scope_Within
27080 (Inner
: Entity_Id
;
27081 Outer
: Entity_Id
) return Boolean
27087 while Present
(Curr
) and then Curr
/= Standard_Standard
loop
27088 Curr
:= Scope
(Curr
);
27090 if Curr
= Outer
then
27093 -- A selective accept body appears within a task type, but the
27094 -- enclosing subprogram is the procedure of the task body.
27096 elsif Ekind
(Implementation_Base_Type
(Curr
)) = E_Task_Type
27098 Outer
= Task_Body_Procedure
(Implementation_Base_Type
(Curr
))
27102 -- Ditto for the body of a protected operation
27104 elsif Is_Subprogram
(Curr
)
27105 and then Outer
= Protected_Body_Subprogram
(Curr
)
27109 -- Outside of its scope, a synchronized type may just be private
27111 elsif Is_Private_Type
(Curr
)
27112 and then Present
(Full_View
(Curr
))
27113 and then Is_Concurrent_Type
(Full_View
(Curr
))
27115 return Scope_Within
(Full_View
(Curr
), Outer
);
27122 --------------------------
27123 -- Scope_Within_Or_Same --
27124 --------------------------
27126 function Scope_Within_Or_Same
27127 (Inner
: Entity_Id
;
27128 Outer
: Entity_Id
) return Boolean
27130 Curr
: Entity_Id
:= Inner
;
27133 -- Similar to the above, but check for scope identity first
27135 while Present
(Curr
) and then Curr
/= Standard_Standard
loop
27136 if Curr
= Outer
then
27139 elsif Ekind
(Implementation_Base_Type
(Curr
)) = E_Task_Type
27141 Outer
= Task_Body_Procedure
(Implementation_Base_Type
(Curr
))
27145 elsif Is_Subprogram
(Curr
)
27146 and then Outer
= Protected_Body_Subprogram
(Curr
)
27150 elsif Is_Private_Type
(Curr
)
27151 and then Present
(Full_View
(Curr
))
27153 if Full_View
(Curr
) = Outer
then
27156 return Scope_Within
(Full_View
(Curr
), Outer
);
27160 Curr
:= Scope
(Curr
);
27164 end Scope_Within_Or_Same
;
27166 --------------------
27167 -- Set_Convention --
27168 --------------------
27170 procedure Set_Convention
(E
: Entity_Id
; Val
: Snames
.Convention_Id
) is
27172 Basic_Set_Convention
(E
, Val
);
27175 and then Is_Access_Subprogram_Type
(Base_Type
(E
))
27176 and then Has_Foreign_Convention
(E
)
27178 Set_Can_Use_Internal_Rep
(E
, False);
27181 -- If E is an object, including a component, and the type of E is an
27182 -- anonymous access type with no convention set, then also set the
27183 -- convention of the anonymous access type. We do not do this for
27184 -- anonymous protected types, since protected types always have the
27185 -- default convention.
27187 if Present
(Etype
(E
))
27188 and then (Is_Object
(E
)
27190 -- Allow E_Void (happens for pragma Convention appearing
27191 -- in the middle of a record applying to a component)
27193 or else Ekind
(E
) = E_Void
)
27196 Typ
: constant Entity_Id
:= Etype
(E
);
27199 if Ekind
(Typ
) in E_Anonymous_Access_Type
27200 | E_Anonymous_Access_Subprogram_Type
27201 and then not Has_Convention_Pragma
(Typ
)
27203 Basic_Set_Convention
(Typ
, Val
);
27204 Set_Has_Convention_Pragma
(Typ
);
27206 -- And for the access subprogram type, deal similarly with the
27207 -- designated E_Subprogram_Type, which is always internal.
27209 if Ekind
(Typ
) = E_Anonymous_Access_Subprogram_Type
then
27211 Dtype
: constant Entity_Id
:= Designated_Type
(Typ
);
27213 if Ekind
(Dtype
) = E_Subprogram_Type
27214 and then not Has_Convention_Pragma
(Dtype
)
27216 Basic_Set_Convention
(Dtype
, Val
);
27217 Set_Has_Convention_Pragma
(Dtype
);
27224 end Set_Convention
;
27226 ------------------------
27227 -- Set_Current_Entity --
27228 ------------------------
27230 -- The given entity is to be set as the currently visible definition of its
27231 -- associated name (i.e. the Node_Id associated with its name). All we have
27232 -- to do is to get the name from the identifier, and then set the
27233 -- associated Node_Id to point to the given entity.
27235 procedure Set_Current_Entity
(E
: Entity_Id
) is
27237 Set_Name_Entity_Id
(Chars
(E
), E
);
27238 end Set_Current_Entity
;
27240 ---------------------------
27241 -- Set_Debug_Info_Needed --
27242 ---------------------------
27244 procedure Set_Debug_Info_Needed
(T
: Entity_Id
) is
27246 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
);
27247 pragma Inline
(Set_Debug_Info_Needed_If_Not_Set
);
27248 -- Used to set debug info in a related node if not set already
27250 --------------------------------------
27251 -- Set_Debug_Info_Needed_If_Not_Set --
27252 --------------------------------------
27254 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
) is
27256 if Present
(E
) and then not Needs_Debug_Info
(E
) then
27257 Set_Debug_Info_Needed
(E
);
27259 -- For a private type, indicate that the full view also needs
27260 -- debug information.
27263 and then Is_Private_Type
(E
)
27264 and then Present
(Full_View
(E
))
27266 Set_Debug_Info_Needed
(Full_View
(E
));
27269 end Set_Debug_Info_Needed_If_Not_Set
;
27271 -- Start of processing for Set_Debug_Info_Needed
27274 -- Nothing to do if there is no available entity
27279 -- Nothing to do for an entity with suppressed debug information
27281 elsif Debug_Info_Off
(T
) then
27284 -- Nothing to do for an ignored Ghost entity because the entity will be
27285 -- eliminated from the tree.
27287 elsif Is_Ignored_Ghost_Entity
(T
) then
27290 -- Nothing to do if entity comes from a predefined file. Library files
27291 -- are compiled without debug information, but inlined bodies of these
27292 -- routines may appear in user code, and debug information on them ends
27293 -- up complicating debugging the user code.
27295 elsif In_Inlined_Body
and then In_Predefined_Unit
(T
) then
27296 Set_Needs_Debug_Info
(T
, False);
27299 -- Set flag in entity itself. Note that we will go through the following
27300 -- circuitry even if the flag is already set on T. That's intentional,
27301 -- it makes sure that the flag will be set in subsidiary entities.
27303 Set_Needs_Debug_Info
(T
);
27305 -- Set flag on subsidiary entities if not set already
27307 if Is_Object
(T
) then
27308 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
27310 elsif Is_Type
(T
) then
27311 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
27313 if Is_Record_Type
(T
) then
27315 Ent
: Entity_Id
:= First_Entity
(T
);
27317 while Present
(Ent
) loop
27318 Set_Debug_Info_Needed_If_Not_Set
(Ent
);
27323 -- For a class wide subtype, we also need debug information
27324 -- for the equivalent type.
27326 if Ekind
(T
) = E_Class_Wide_Subtype
then
27327 Set_Debug_Info_Needed_If_Not_Set
(Equivalent_Type
(T
));
27330 elsif Is_Array_Type
(T
) then
27331 Set_Debug_Info_Needed_If_Not_Set
(Component_Type
(T
));
27334 Indx
: Node_Id
:= First_Index
(T
);
27336 while Present
(Indx
) loop
27337 Set_Debug_Info_Needed_If_Not_Set
(Etype
(Indx
));
27342 -- For a packed array type, we also need debug information for
27343 -- the type used to represent the packed array. Conversely, we
27344 -- also need it for the former if we need it for the latter.
27346 if Is_Packed
(T
) then
27347 Set_Debug_Info_Needed_If_Not_Set
(Packed_Array_Impl_Type
(T
));
27350 if Is_Packed_Array_Impl_Type
(T
) then
27351 Set_Debug_Info_Needed_If_Not_Set
(Original_Array_Type
(T
));
27354 elsif Is_Access_Type
(T
) then
27355 Set_Debug_Info_Needed_If_Not_Set
(Directly_Designated_Type
(T
));
27357 elsif Is_Private_Type
(T
) then
27359 FV
: constant Entity_Id
:= Full_View
(T
);
27362 Set_Debug_Info_Needed_If_Not_Set
(FV
);
27364 -- If the full view is itself a derived private type, we need
27365 -- debug information on its underlying type.
27368 and then Is_Private_Type
(FV
)
27369 and then Present
(Underlying_Full_View
(FV
))
27371 Set_Needs_Debug_Info
(Underlying_Full_View
(FV
));
27375 elsif Is_Protected_Type
(T
) then
27376 Set_Debug_Info_Needed_If_Not_Set
(Corresponding_Record_Type
(T
));
27378 elsif Is_Scalar_Type
(T
) then
27380 -- If the subrange bounds are materialized by dedicated constant
27381 -- objects, also include them in the debug info to make sure the
27382 -- debugger can properly use them.
27384 if Present
(Scalar_Range
(T
))
27385 and then Nkind
(Scalar_Range
(T
)) = N_Range
27388 Low_Bnd
: constant Node_Id
:= Type_Low_Bound
(T
);
27389 High_Bnd
: constant Node_Id
:= Type_High_Bound
(T
);
27392 if Is_Entity_Name
(Low_Bnd
) then
27393 Set_Debug_Info_Needed_If_Not_Set
(Entity
(Low_Bnd
));
27396 if Is_Entity_Name
(High_Bnd
) then
27397 Set_Debug_Info_Needed_If_Not_Set
(Entity
(High_Bnd
));
27403 end Set_Debug_Info_Needed
;
27405 --------------------------------
27406 -- Set_Debug_Info_Defining_Id --
27407 --------------------------------
27409 procedure Set_Debug_Info_Defining_Id
(N
: Node_Id
) is
27411 if Comes_From_Source
(Defining_Identifier
(N
)) then
27412 Set_Debug_Info_Needed
(Defining_Identifier
(N
));
27414 end Set_Debug_Info_Defining_Id
;
27416 ----------------------------
27417 -- Set_Entity_With_Checks --
27418 ----------------------------
27420 procedure Set_Entity_With_Checks
(N
: Node_Id
; Val
: Entity_Id
) is
27421 Val_Actual
: Entity_Id
;
27423 Post_Node
: Node_Id
;
27426 -- Unconditionally set the entity
27428 Set_Entity
(N
, Val
);
27430 -- The node to post on is the selector in the case of an expanded name,
27431 -- and otherwise the node itself.
27433 if Nkind
(N
) = N_Expanded_Name
then
27434 Post_Node
:= Selector_Name
(N
);
27439 -- Check for violation of No_Fixed_IO
27441 if Restriction_Check_Required
(No_Fixed_IO
)
27443 ((RTU_Loaded
(Ada_Text_IO
)
27444 and then (Is_RTE
(Val
, RE_Decimal_IO
)
27446 Is_RTE
(Val
, RE_Fixed_IO
)))
27449 (RTU_Loaded
(Ada_Wide_Text_IO
)
27450 and then (Is_RTE
(Val
, RO_WT_Decimal_IO
)
27452 Is_RTE
(Val
, RO_WT_Fixed_IO
)))
27455 (RTU_Loaded
(Ada_Wide_Wide_Text_IO
)
27456 and then (Is_RTE
(Val
, RO_WW_Decimal_IO
)
27458 Is_RTE
(Val
, RO_WW_Fixed_IO
))))
27460 -- A special extra check, don't complain about a reference from within
27461 -- the Ada.Interrupts package itself!
27463 and then not In_Same_Extended_Unit
(N
, Val
)
27465 Check_Restriction
(No_Fixed_IO
, Post_Node
);
27468 -- Remaining checks are only done on source nodes. Note that we test
27469 -- for violation of No_Fixed_IO even on non-source nodes, because the
27470 -- cases for checking violations of this restriction are instantiations
27471 -- where the reference in the instance has Comes_From_Source False.
27473 if not Comes_From_Source
(N
) then
27477 -- Check for violation of No_Abort_Statements, which is triggered by
27478 -- call to Ada.Task_Identification.Abort_Task.
27480 if Restriction_Check_Required
(No_Abort_Statements
)
27481 and then (Is_RTE
(Val
, RE_Abort_Task
))
27483 -- A special extra check, don't complain about a reference from within
27484 -- the Ada.Task_Identification package itself!
27486 and then not In_Same_Extended_Unit
(N
, Val
)
27488 Check_Restriction
(No_Abort_Statements
, Post_Node
);
27491 if Val
= Standard_Long_Long_Integer
then
27492 Check_Restriction
(No_Long_Long_Integers
, Post_Node
);
27495 -- Check for violation of No_Dynamic_Attachment
27497 if Restriction_Check_Required
(No_Dynamic_Attachment
)
27498 and then RTU_Loaded
(Ada_Interrupts
)
27499 and then (Is_RTE
(Val
, RE_Is_Reserved
) or else
27500 Is_RTE
(Val
, RE_Is_Attached
) or else
27501 Is_RTE
(Val
, RE_Current_Handler
) or else
27502 Is_RTE
(Val
, RE_Attach_Handler
) or else
27503 Is_RTE
(Val
, RE_Exchange_Handler
) or else
27504 Is_RTE
(Val
, RE_Detach_Handler
) or else
27505 Is_RTE
(Val
, RE_Reference
))
27507 -- A special extra check, don't complain about a reference from within
27508 -- the Ada.Interrupts package itself!
27510 and then not In_Same_Extended_Unit
(N
, Val
)
27512 Check_Restriction
(No_Dynamic_Attachment
, Post_Node
);
27515 -- Check for No_Implementation_Identifiers
27517 if Restriction_Check_Required
(No_Implementation_Identifiers
) then
27519 -- We have an implementation defined entity if it is marked as
27520 -- implementation defined, or is defined in a package marked as
27521 -- implementation defined. However, library packages themselves
27522 -- are excluded (we don't want to flag Interfaces itself, just
27523 -- the entities within it).
27525 if (Is_Implementation_Defined
(Val
)
27527 (Present
(Scope
(Val
))
27528 and then Is_Implementation_Defined
(Scope
(Val
))))
27529 and then not (Is_Package_Or_Generic_Package
(Val
)
27530 and then Is_Library_Level_Entity
(Val
))
27532 Check_Restriction
(No_Implementation_Identifiers
, Post_Node
);
27536 -- Do the style check
27539 and then not Suppress_Style_Checks
(Val
)
27540 and then not In_Instance
27542 if Nkind
(N
) = N_Identifier
then
27544 elsif Nkind
(N
) = N_Expanded_Name
then
27545 Nod
:= Selector_Name
(N
);
27550 -- A special situation arises for derived operations, where we want
27551 -- to do the check against the parent (since the Sloc of the derived
27552 -- operation points to the derived type declaration itself).
27555 while not Comes_From_Source
(Val_Actual
)
27556 and then Nkind
(Val_Actual
) in N_Entity
27557 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
27558 or else Is_Subprogram_Or_Generic_Subprogram
(Val_Actual
))
27559 and then Present
(Alias
(Val_Actual
))
27561 Val_Actual
:= Alias
(Val_Actual
);
27564 -- Renaming declarations for generic actuals do not come from source,
27565 -- and have a different name from that of the entity they rename, so
27566 -- there is no style check to perform here.
27568 if Chars
(Nod
) = Chars
(Val_Actual
) then
27569 Style
.Check_Identifier
(Nod
, Val_Actual
);
27572 end Set_Entity_With_Checks
;
27574 ------------------------------
27575 -- Set_Invalid_Scalar_Value --
27576 ------------------------------
27578 procedure Set_Invalid_Scalar_Value
27579 (Scal_Typ
: Float_Scalar_Id
;
27582 Slot
: Ureal
renames Invalid_Floats
(Scal_Typ
);
27585 -- Detect an attempt to set a different value for the same scalar type
27587 pragma Assert
(Slot
= No_Ureal
);
27589 end Set_Invalid_Scalar_Value
;
27591 ------------------------------
27592 -- Set_Invalid_Scalar_Value --
27593 ------------------------------
27595 procedure Set_Invalid_Scalar_Value
27596 (Scal_Typ
: Integer_Scalar_Id
;
27599 Slot
: Uint
renames Invalid_Integers
(Scal_Typ
);
27602 -- Detect an attempt to set a different value for the same scalar type
27604 pragma Assert
(Slot
= No_Uint
);
27606 end Set_Invalid_Scalar_Value
;
27608 ------------------------
27609 -- Set_Name_Entity_Id --
27610 ------------------------
27612 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
27614 Set_Name_Table_Int
(Id
, Int
(Val
));
27615 end Set_Name_Entity_Id
;
27617 ---------------------
27618 -- Set_Next_Actual --
27619 ---------------------
27621 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
27623 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
27624 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
27626 end Set_Next_Actual
;
27628 ----------------------------------
27629 -- Set_Optimize_Alignment_Flags --
27630 ----------------------------------
27632 procedure Set_Optimize_Alignment_Flags
(E
: Entity_Id
) is
27634 if Optimize_Alignment
= 'S' then
27635 Set_Optimize_Alignment_Space
(E
);
27636 elsif Optimize_Alignment
= 'T' then
27637 Set_Optimize_Alignment_Time
(E
);
27639 end Set_Optimize_Alignment_Flags
;
27641 -----------------------
27642 -- Set_Public_Status --
27643 -----------------------
27645 procedure Set_Public_Status
(Id
: Entity_Id
) is
27646 S
: constant Entity_Id
:= Current_Scope
;
27648 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean;
27649 -- Determines if E is defined within handled statement sequence or
27650 -- an if statement, returns True if so, False otherwise.
27652 ----------------------
27653 -- Within_HSS_Or_If --
27654 ----------------------
27656 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean is
27659 N
:= Declaration_Node
(E
);
27667 N_Handled_Sequence_Of_Statements | N_If_Statement
27672 end Within_HSS_Or_If
;
27674 -- Start of processing for Set_Public_Status
27677 -- Everything in the scope of Standard is public
27679 if S
= Standard_Standard
then
27680 Set_Is_Public
(Id
);
27682 -- Entity is definitely not public if enclosing scope is not public
27684 elsif not Is_Public
(S
) then
27687 -- An object or function declaration that occurs in a handled sequence
27688 -- of statements or within an if statement is the declaration for a
27689 -- temporary object or local subprogram generated by the expander. It
27690 -- never needs to be made public and furthermore, making it public can
27691 -- cause back end problems.
27693 elsif Nkind
(Parent
(Id
)) in
27694 N_Object_Declaration | N_Function_Specification
27695 and then Within_HSS_Or_If
(Id
)
27699 -- Entities in public packages or records are public
27701 elsif Ekind
(S
) = E_Package
or Is_Record_Type
(S
) then
27702 Set_Is_Public
(Id
);
27704 -- The bounds of an entry family declaration can generate object
27705 -- declarations that are visible to the back-end, e.g. in the
27706 -- the declaration of a composite type that contains tasks.
27708 elsif Is_Concurrent_Type
(S
)
27709 and then not Has_Completion
(S
)
27710 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
27712 Set_Is_Public
(Id
);
27714 end Set_Public_Status
;
27716 -----------------------------
27717 -- Set_Referenced_Modified --
27718 -----------------------------
27720 procedure Set_Referenced_Modified
(N
: Node_Id
; Out_Param
: Boolean) is
27724 -- Deal with indexed or selected component where prefix is modified
27726 if Nkind
(N
) in N_Indexed_Component | N_Selected_Component
then
27727 Pref
:= Prefix
(N
);
27729 -- If prefix is access type, then it is the designated object that is
27730 -- being modified, which means we have no entity to set the flag on.
27732 if No
(Etype
(Pref
)) or else Is_Access_Type
(Etype
(Pref
)) then
27735 -- Otherwise chase the prefix
27738 Set_Referenced_Modified
(Pref
, Out_Param
);
27741 -- Otherwise see if we have an entity name (only other case to process)
27743 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
27744 Set_Referenced_As_LHS
(Entity
(N
), not Out_Param
);
27745 Set_Referenced_As_Out_Parameter
(Entity
(N
), Out_Param
);
27747 end Set_Referenced_Modified
;
27753 procedure Set_Rep_Info
(T1
: Entity_Id
; T2
: Entity_Id
) is
27755 Set_Is_Atomic
(T1
, Is_Atomic
(T2
));
27756 Set_Is_Independent
(T1
, Is_Independent
(T2
));
27757 Set_Is_Volatile_Full_Access
(T1
, Is_Volatile_Full_Access
(T2
));
27759 if Is_Base_Type
(T1
) then
27760 Set_Is_Volatile
(T1
, Is_Volatile
(T2
));
27764 ----------------------------
27765 -- Set_Scope_Is_Transient --
27766 ----------------------------
27768 procedure Set_Scope_Is_Transient
(V
: Boolean := True) is
27770 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= V
;
27771 end Set_Scope_Is_Transient
;
27773 -------------------
27774 -- Set_Size_Info --
27775 -------------------
27777 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
27779 -- We copy Esize, but not RM_Size, since in general RM_Size is
27780 -- subtype specific and does not get inherited by all subtypes.
27782 Set_Esize
(T1
, Esize
(T2
));
27783 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
27785 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
27787 Is_Discrete_Or_Fixed_Point_Type
(T2
)
27789 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
27792 Set_Alignment
(T1
, Alignment
(T2
));
27795 ------------------------------
27796 -- Should_Ignore_Pragma_Par --
27797 ------------------------------
27799 function Should_Ignore_Pragma_Par
(Prag_Name
: Name_Id
) return Boolean is
27800 pragma Assert
(Compiler_State
= Parsing
);
27801 -- This one can't work during semantic analysis, because we don't have a
27802 -- correct Current_Source_File.
27804 Result
: constant Boolean :=
27805 Get_Name_Table_Boolean3
(Prag_Name
)
27806 and then not Is_Internal_File_Name
27807 (File_Name
(Current_Source_File
));
27810 end Should_Ignore_Pragma_Par
;
27812 ------------------------------
27813 -- Should_Ignore_Pragma_Sem --
27814 ------------------------------
27816 function Should_Ignore_Pragma_Sem
(N
: Node_Id
) return Boolean is
27817 pragma Assert
(Compiler_State
= Analyzing
);
27818 Prag_Name
: constant Name_Id
:= Pragma_Name
(N
);
27819 Result
: constant Boolean :=
27820 Get_Name_Table_Boolean3
(Prag_Name
)
27821 and then not In_Internal_Unit
(N
);
27825 end Should_Ignore_Pragma_Sem
;
27827 --------------------
27828 -- Static_Boolean --
27829 --------------------
27831 function Static_Boolean
(N
: Node_Id
) return Uint
is
27833 Analyze_And_Resolve
(N
, Standard_Boolean
);
27836 or else Error_Posted
(N
)
27837 or else Etype
(N
) = Any_Type
27842 if Is_OK_Static_Expression
(N
) then
27843 if not Raises_Constraint_Error
(N
) then
27844 return Expr_Value
(N
);
27849 elsif Etype
(N
) = Any_Type
then
27853 Flag_Non_Static_Expr
27854 ("static boolean expression required here", N
);
27857 end Static_Boolean
;
27859 --------------------
27860 -- Static_Integer --
27861 --------------------
27863 function Static_Integer
(N
: Node_Id
) return Uint
is
27865 Analyze_And_Resolve
(N
, Any_Integer
);
27868 or else Error_Posted
(N
)
27869 or else Etype
(N
) = Any_Type
27874 if Is_OK_Static_Expression
(N
) then
27875 if not Raises_Constraint_Error
(N
) then
27876 return Expr_Value
(N
);
27881 elsif Etype
(N
) = Any_Type
then
27885 Flag_Non_Static_Expr
27886 ("static integer expression required here", N
);
27889 end Static_Integer
;
27891 -------------------------------
27892 -- Statically_Denotes_Entity --
27893 -------------------------------
27894 function Statically_Denotes_Entity
(N
: Node_Id
) return Boolean is
27897 if not Is_Entity_Name
(N
) then
27904 Nkind
(Parent
(E
)) /= N_Object_Renaming_Declaration
27905 or else Is_Prival
(E
)
27906 or else Statically_Denotes_Entity
(Renamed_Object
(E
));
27907 end Statically_Denotes_Entity
;
27909 -------------------------------
27910 -- Statically_Denotes_Object --
27911 -------------------------------
27913 function Statically_Denotes_Object
(N
: Node_Id
) return Boolean is
27915 return Statically_Denotes_Entity
(N
)
27916 and then Is_Object_Reference
(N
);
27917 end Statically_Denotes_Object
;
27919 --------------------------
27920 -- Statically_Different --
27921 --------------------------
27923 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
27924 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
27925 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
27927 return Is_Entity_Name
(R1
)
27928 and then Is_Entity_Name
(R2
)
27929 and then Entity
(R1
) /= Entity
(R2
)
27930 and then not Is_Formal
(Entity
(R1
))
27931 and then not Is_Formal
(Entity
(R2
));
27932 end Statically_Different
;
27934 -----------------------------
27935 -- Statically_Names_Object --
27936 -----------------------------
27938 function Statically_Names_Object
(N
: Node_Id
) return Boolean is
27940 if Statically_Denotes_Object
(N
) then
27942 elsif Is_Entity_Name
(N
) then
27944 E
: constant Entity_Id
:= Entity
(N
);
27946 return Nkind
(Parent
(E
)) = N_Object_Renaming_Declaration
27947 and then Statically_Names_Object
(Renamed_Object
(E
));
27952 when N_Indexed_Component
=>
27953 if Is_Access_Type
(Etype
(Prefix
(N
))) then
27954 -- treat implicit dereference same as explicit
27958 if not Is_Constrained
(Etype
(Prefix
(N
))) then
27963 Indx
: Node_Id
:= First_Index
(Etype
(Prefix
(N
)));
27964 Expr
: Node_Id
:= First
(Expressions
(N
));
27965 Index_Subtype
: Node_Id
;
27968 Index_Subtype
:= Etype
(Indx
);
27970 if not Is_Static_Subtype
(Index_Subtype
) then
27973 if not Is_OK_Static_Expression
(Expr
) then
27978 Index_Value
: constant Uint
:= Expr_Value
(Expr
);
27979 Low_Value
: constant Uint
:=
27980 Expr_Value
(Type_Low_Bound
(Index_Subtype
));
27981 High_Value
: constant Uint
:=
27982 Expr_Value
(Type_High_Bound
(Index_Subtype
));
27984 if (Index_Value
< Low_Value
)
27985 or (Index_Value
> High_Value
)
27992 Expr
:= Next
(Expr
);
27993 pragma Assert
((Present
(Indx
) = Present
(Expr
))
27994 or else (Serious_Errors_Detected
> 0));
27995 exit when not (Present
(Indx
) and Present
(Expr
));
27999 when N_Selected_Component
=>
28000 if Is_Access_Type
(Etype
(Prefix
(N
))) then
28001 -- treat implicit dereference same as explicit
28005 if Ekind
(Entity
(Selector_Name
(N
))) not in
28006 E_Component | E_Discriminant
28012 Comp
: constant Entity_Id
:=
28013 Original_Record_Component
(Entity
(Selector_Name
(N
)));
28015 -- AI12-0373 confirms that we should not call
28016 -- Has_Discriminant_Dependent_Constraint here which would be
28019 if Is_Declared_Within_Variant
(Comp
) then
28024 when others => -- includes N_Slice, N_Explicit_Dereference
28028 pragma Assert
(Present
(Prefix
(N
)));
28030 return Statically_Names_Object
(Prefix
(N
));
28031 end Statically_Names_Object
;
28033 ---------------------------------
28034 -- String_From_Numeric_Literal --
28035 ---------------------------------
28037 function String_From_Numeric_Literal
(N
: Node_Id
) return String_Id
is
28038 Loc
: constant Source_Ptr
:= Sloc
(N
);
28039 Sbuffer
: constant Source_Buffer_Ptr
:=
28040 Source_Text
(Get_Source_File_Index
(Loc
));
28041 Src_Ptr
: Source_Ptr
:= Loc
;
28043 C
: Character := Sbuffer
(Src_Ptr
);
28044 -- Current source program character
28046 function Belongs_To_Numeric_Literal
(C
: Character) return Boolean;
28047 -- Return True if C belongs to the numeric literal
28049 --------------------------------
28050 -- Belongs_To_Numeric_Literal --
28051 --------------------------------
28053 function Belongs_To_Numeric_Literal
(C
: Character) return Boolean is
28057 |
'_' |
'.' |
'e' |
'#' |
'A' |
'B' |
'C' |
'D' |
'E' |
'F'
28061 -- Make sure '+' or '-' is part of an exponent
28065 Prev_C
: constant Character := Sbuffer
(Src_Ptr
- 1);
28067 return Prev_C
= 'e' or else Prev_C
= 'E';
28070 -- Other characters cannot belong to a numeric literal
28075 end Belongs_To_Numeric_Literal
;
28077 -- Start of processing for String_From_Numeric_Literal
28081 while Belongs_To_Numeric_Literal
(C
) loop
28082 Store_String_Char
(C
);
28083 Src_Ptr
:= Src_Ptr
+ 1;
28084 C
:= Sbuffer
(Src_Ptr
);
28088 end String_From_Numeric_Literal
;
28090 --------------------------------------
28091 -- Subject_To_Loop_Entry_Attributes --
28092 --------------------------------------
28094 function Subject_To_Loop_Entry_Attributes
(N
: Node_Id
) return Boolean is
28100 -- The expansion mechanism transform a loop subject to at least one
28101 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
28102 -- the conditional part.
28104 if Nkind
(Stmt
) in N_Block_Statement | N_If_Statement
28105 and then Nkind
(Original_Node
(N
)) = N_Loop_Statement
28107 Stmt
:= Original_Node
(N
);
28111 Nkind
(Stmt
) = N_Loop_Statement
28112 and then Present
(Identifier
(Stmt
))
28113 and then Present
(Entity
(Identifier
(Stmt
)))
28114 and then Has_Loop_Entry_Attributes
(Entity
(Identifier
(Stmt
)));
28115 end Subject_To_Loop_Entry_Attributes
;
28117 -----------------------------
28118 -- Subprogram_Access_Level --
28119 -----------------------------
28121 function Subprogram_Access_Level
(Subp
: Entity_Id
) return Uint
is
28123 if Present
(Alias
(Subp
)) then
28124 return Subprogram_Access_Level
(Alias
(Subp
));
28126 return Scope_Depth
(Enclosing_Dynamic_Scope
(Subp
));
28128 end Subprogram_Access_Level
;
28130 ---------------------
28131 -- Subprogram_Name --
28132 ---------------------
28134 function Subprogram_Name
(N
: Node_Id
) return String is
28135 Buf
: Bounded_String
;
28136 Ent
: Node_Id
:= N
;
28140 while Present
(Ent
) loop
28141 case Nkind
(Ent
) is
28142 when N_Subprogram_Body
=>
28143 Ent
:= Defining_Unit_Name
(Specification
(Ent
));
28146 when N_Subprogram_Declaration
=>
28147 Nod
:= Corresponding_Body
(Ent
);
28149 if Present
(Nod
) then
28152 Ent
:= Defining_Unit_Name
(Specification
(Ent
));
28157 when N_Subprogram_Instantiation
28159 | N_Package_Specification
28161 Ent
:= Defining_Unit_Name
(Ent
);
28164 when N_Protected_Type_Declaration
=>
28165 Ent
:= Corresponding_Body
(Ent
);
28168 when N_Protected_Body
28171 Ent
:= Defining_Identifier
(Ent
);
28178 Ent
:= Parent
(Ent
);
28182 return "unknown subprogram:unknown file:0:0";
28185 -- If the subprogram is a child unit, use its simple name to start the
28186 -- construction of the fully qualified name.
28188 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
28189 Ent
:= Defining_Identifier
(Ent
);
28192 Append_Entity_Name
(Buf
, Ent
);
28194 -- Append homonym number if needed
28196 if Nkind
(N
) in N_Entity
and then Has_Homonym
(N
) then
28198 H
: Entity_Id
:= Homonym
(N
);
28202 while Present
(H
) loop
28203 if Scope
(H
) = Scope
(N
) then
28217 -- Append source location of Ent to Buf so that the string will
28218 -- look like "subp:file:line:col".
28221 Loc
: constant Source_Ptr
:= Sloc
(Ent
);
28224 Append
(Buf
, Reference_Name
(Get_Source_File_Index
(Loc
)));
28226 Append
(Buf
, Nat
(Get_Logical_Line_Number
(Loc
)));
28228 Append
(Buf
, Nat
(Get_Column_Number
(Loc
)));
28232 end Subprogram_Name
;
28234 -------------------------------
28235 -- Support_Atomic_Primitives --
28236 -------------------------------
28238 function Support_Atomic_Primitives
(Typ
: Entity_Id
) return Boolean is
28242 -- Verify the alignment of Typ is known
28244 if not Known_Alignment
(Typ
) then
28248 if Known_Static_Esize
(Typ
) then
28249 Size
:= UI_To_Int
(Esize
(Typ
));
28251 -- If the Esize (Object_Size) is unknown at compile time, look at the
28252 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
28254 elsif Known_Static_RM_Size
(Typ
) then
28255 Size
:= UI_To_Int
(RM_Size
(Typ
));
28257 -- Otherwise, the size is considered to be unknown.
28263 -- Check that the size of the component is 8, 16, 32, or 64 bits and
28264 -- that Typ is properly aligned.
28267 when 8 |
16 |
32 |
64 =>
28268 return Size
= UI_To_Int
(Alignment
(Typ
)) * 8;
28273 end Support_Atomic_Primitives
;
28279 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
28281 if Debug_Flag_W
then
28282 for J
in 0 .. Scope_Stack
.Last
loop
28287 Write_Name
(Chars
(E
));
28288 Write_Str
(" from ");
28289 Write_Location
(Sloc
(N
));
28294 -----------------------
28295 -- Transfer_Entities --
28296 -----------------------
28298 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
28299 procedure Set_Public_Status_Of
(Id
: Entity_Id
);
28300 -- Set the Is_Public attribute of arbitrary entity Id by calling routine
28301 -- Set_Public_Status. If successful and Id denotes a record type, set
28302 -- the Is_Public attribute of its fields.
28304 --------------------------
28305 -- Set_Public_Status_Of --
28306 --------------------------
28308 procedure Set_Public_Status_Of
(Id
: Entity_Id
) is
28312 if not Is_Public
(Id
) then
28313 Set_Public_Status
(Id
);
28315 -- When the input entity is a public record type, ensure that all
28316 -- its internal fields are also exposed to the linker. The fields
28317 -- of a class-wide type are never made public.
28320 and then Is_Record_Type
(Id
)
28321 and then not Is_Class_Wide_Type
(Id
)
28323 Field
:= First_Entity
(Id
);
28324 while Present
(Field
) loop
28325 Set_Is_Public
(Field
);
28326 Next_Entity
(Field
);
28330 end Set_Public_Status_Of
;
28334 Full_Id
: Entity_Id
;
28337 -- Start of processing for Transfer_Entities
28340 Id
:= First_Entity
(From
);
28342 if Present
(Id
) then
28344 -- Merge the entity chain of the source scope with that of the
28345 -- destination scope.
28347 if Present
(Last_Entity
(To
)) then
28348 Link_Entities
(Last_Entity
(To
), Id
);
28350 Set_First_Entity
(To
, Id
);
28353 Set_Last_Entity
(To
, Last_Entity
(From
));
28355 -- Inspect the entities of the source scope and update their Scope
28358 while Present
(Id
) loop
28359 Set_Scope
(Id
, To
);
28360 Set_Public_Status_Of
(Id
);
28362 -- Handle an internally generated full view for a private type
28364 if Is_Private_Type
(Id
)
28365 and then Present
(Full_View
(Id
))
28366 and then Is_Itype
(Full_View
(Id
))
28368 Full_Id
:= Full_View
(Id
);
28370 Set_Scope
(Full_Id
, To
);
28371 Set_Public_Status_Of
(Full_Id
);
28377 Set_First_Entity
(From
, Empty
);
28378 Set_Last_Entity
(From
, Empty
);
28380 end Transfer_Entities
;
28382 ------------------------
28383 -- Traverse_More_Func --
28384 ------------------------
28386 function Traverse_More_Func
(Node
: Node_Id
) return Traverse_Final_Result
is
28388 Processing_Itype
: Boolean := False;
28389 -- Set to True while traversing the nodes under an Itype, to prevent
28390 -- looping on Itype handling during that traversal.
28392 function Process_More
(N
: Node_Id
) return Traverse_Result
;
28393 -- Wrapper over the Process callback to handle parts of the AST that
28394 -- are not normally traversed as syntactic children.
28396 function Traverse_Rec
(N
: Node_Id
) return Traverse_Final_Result
;
28397 -- Main recursive traversal implemented as an instantiation of
28398 -- Traverse_Func over a modified Process callback.
28404 function Process_More
(N
: Node_Id
) return Traverse_Result
is
28406 procedure Traverse_More
(N
: Node_Id
;
28407 Res
: in out Traverse_Result
);
28408 procedure Traverse_More
(L
: List_Id
;
28409 Res
: in out Traverse_Result
);
28410 -- Traverse a node or list and update the traversal result to value
28411 -- Abandon when needed.
28413 -------------------
28414 -- Traverse_More --
28415 -------------------
28417 procedure Traverse_More
(N
: Node_Id
;
28418 Res
: in out Traverse_Result
)
28421 -- Do not process any more nodes if Abandon was reached
28423 if Res
= Abandon
then
28427 if Traverse_Rec
(N
) = Abandon
then
28432 procedure Traverse_More
(L
: List_Id
;
28433 Res
: in out Traverse_Result
)
28435 N
: Node_Id
:= First
(L
);
28438 -- Do not process any more nodes if Abandon was reached
28440 if Res
= Abandon
then
28444 while Present
(N
) loop
28445 Traverse_More
(N
, Res
);
28453 Result
: Traverse_Result
;
28455 -- Start of processing for Process_More
28458 -- Initial callback to Process. Return immediately on Skip/Abandon.
28459 -- Otherwise update the value of Node for further processing of
28460 -- non-syntactic children.
28462 Result
:= Process
(N
);
28465 when OK
=> Node
:= N
;
28466 when OK_Orig
=> Node
:= Original_Node
(N
);
28467 when Skip
=> return Skip
;
28468 when Abandon
=> return Abandon
;
28471 -- Process the relevant semantic children which are a logical part of
28472 -- the AST under this node before returning for the processing of
28473 -- syntactic children.
28475 -- Start with all non-syntactic lists of action nodes
28477 case Nkind
(Node
) is
28478 when N_Component_Association
=>
28479 Traverse_More
(Loop_Actions
(Node
), Result
);
28481 when N_Elsif_Part
=>
28482 Traverse_More
(Condition_Actions
(Node
), Result
);
28484 when N_Short_Circuit
=>
28485 Traverse_More
(Actions
(Node
), Result
);
28487 when N_Case_Expression_Alternative
=>
28488 Traverse_More
(Actions
(Node
), Result
);
28490 when N_Iterated_Component_Association
=>
28491 Traverse_More
(Loop_Actions
(Node
), Result
);
28493 when N_Iteration_Scheme
=>
28494 Traverse_More
(Condition_Actions
(Node
), Result
);
28496 when N_If_Expression
=>
28497 Traverse_More
(Then_Actions
(Node
), Result
);
28498 Traverse_More
(Else_Actions
(Node
), Result
);
28500 -- Various nodes have a field Actions as a syntactic node,
28501 -- so it will be traversed in the regular syntactic traversal.
28503 when N_Compilation_Unit_Aux
28504 | N_Compound_Statement
28505 | N_Expression_With_Actions
28514 -- If Process_Itypes is True, process unattached nodes which come
28515 -- from Itypes. This only concerns currently ranges of scalar
28516 -- (possibly as index) types. This traversal is protected against
28517 -- looping with Processing_Itype.
28520 and then not Processing_Itype
28521 and then Nkind
(Node
) in N_Has_Etype
28522 and then Present
(Etype
(Node
))
28523 and then Is_Itype
(Etype
(Node
))
28526 Typ
: constant Entity_Id
:= Etype
(Node
);
28528 Processing_Itype
:= True;
28530 case Ekind
(Typ
) is
28531 when Scalar_Kind
=>
28532 Traverse_More
(Scalar_Range
(Typ
), Result
);
28536 Index
: Node_Id
:= First_Index
(Typ
);
28539 while Present
(Index
) loop
28540 if Nkind
(Index
) in N_Has_Entity
then
28541 Rng
:= Scalar_Range
(Entity
(Index
));
28546 Traverse_More
(Rng
, Result
);
28547 Next_Index
(Index
);
28554 Processing_Itype
:= False;
28561 -- Define Traverse_Rec as a renaming of the instantiation, as an
28562 -- instantiation cannot complete a previous spec.
28564 function Traverse_Recursive
is new Traverse_Func
(Process_More
);
28565 function Traverse_Rec
(N
: Node_Id
) return Traverse_Final_Result
28566 renames Traverse_Recursive
;
28568 -- Start of processing for Traverse_More_Func
28571 return Traverse_Rec
(Node
);
28572 end Traverse_More_Func
;
28574 ------------------------
28575 -- Traverse_More_Proc --
28576 ------------------------
28578 procedure Traverse_More_Proc
(Node
: Node_Id
) is
28579 function Traverse
is new Traverse_More_Func
(Process
, Process_Itypes
);
28580 Discard
: Traverse_Final_Result
;
28581 pragma Warnings
(Off
, Discard
);
28583 Discard
:= Traverse
(Node
);
28584 end Traverse_More_Proc
;
28586 -----------------------
28587 -- Type_Access_Level --
28588 -----------------------
28590 function Type_Access_Level
(Typ
: Entity_Id
) return Uint
is
28594 Btyp
:= Base_Type
(Typ
);
28596 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
28597 -- simply use the level where the type is declared. This is true for
28598 -- stand-alone object declarations, and for anonymous access types
28599 -- associated with components the level is the same as that of the
28600 -- enclosing composite type. However, special treatment is needed for
28601 -- the cases of access parameters, return objects of an anonymous access
28602 -- type, and, in Ada 95, access discriminants of limited types.
28604 if Is_Access_Type
(Btyp
) then
28605 if Ekind
(Btyp
) = E_Anonymous_Access_Type
then
28607 -- If the type is a nonlocal anonymous access type (such as for
28608 -- an access parameter) we treat it as being declared at the
28609 -- library level to ensure that names such as X.all'access don't
28610 -- fail static accessibility checks.
28612 if not Is_Local_Anonymous_Access
(Typ
) then
28613 return Scope_Depth
(Standard_Standard
);
28615 -- If this is a return object, the accessibility level is that of
28616 -- the result subtype of the enclosing function. The test here is
28617 -- little complicated, because we have to account for extended
28618 -- return statements that have been rewritten as blocks, in which
28619 -- case we have to find and the Is_Return_Object attribute of the
28620 -- itype's associated object. It would be nice to find a way to
28621 -- simplify this test, but it doesn't seem worthwhile to add a new
28622 -- flag just for purposes of this test. ???
28624 elsif Ekind
(Scope
(Btyp
)) = E_Return_Statement
28627 and then Nkind
(Associated_Node_For_Itype
(Btyp
)) =
28628 N_Object_Declaration
28629 and then Is_Return_Object
28630 (Defining_Identifier
28631 (Associated_Node_For_Itype
(Btyp
))))
28637 Scop
:= Scope
(Scope
(Btyp
));
28638 while Present
(Scop
) loop
28639 exit when Ekind
(Scop
) = E_Function
;
28640 Scop
:= Scope
(Scop
);
28643 -- Treat the return object's type as having the level of the
28644 -- function's result subtype (as per RM05-6.5(5.3/2)).
28646 return Type_Access_Level
(Etype
(Scop
));
28651 Btyp
:= Root_Type
(Btyp
);
28653 -- The accessibility level of anonymous access types associated with
28654 -- discriminants is that of the current instance of the type, and
28655 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
28657 -- AI-402: access discriminants have accessibility based on the
28658 -- object rather than the type in Ada 2005, so the above paragraph
28661 -- ??? Needs completion with rules from AI-416
28663 if Ada_Version
<= Ada_95
28664 and then Ekind
(Typ
) = E_Anonymous_Access_Type
28665 and then Present
(Associated_Node_For_Itype
(Typ
))
28666 and then Nkind
(Associated_Node_For_Itype
(Typ
)) =
28667 N_Discriminant_Specification
28669 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
)) + 1;
28673 -- Return library level for a generic formal type. This is done because
28674 -- RM(10.3.2) says that "The statically deeper relationship does not
28675 -- apply to ... a descendant of a generic formal type". Rather than
28676 -- checking at each point where a static accessibility check is
28677 -- performed to see if we are dealing with a formal type, this rule is
28678 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
28679 -- return extreme values for a formal type; Deepest_Type_Access_Level
28680 -- returns Int'Last. By calling the appropriate function from among the
28681 -- two, we ensure that the static accessibility check will pass if we
28682 -- happen to run into a formal type. More specifically, we should call
28683 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
28684 -- call occurs as part of a static accessibility check and the error
28685 -- case is the case where the type's level is too shallow (as opposed
28688 if Is_Generic_Type
(Root_Type
(Btyp
)) then
28689 return Scope_Depth
(Standard_Standard
);
28692 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
));
28693 end Type_Access_Level
;
28695 ------------------------------------
28696 -- Type_Without_Stream_Operation --
28697 ------------------------------------
28699 function Type_Without_Stream_Operation
28701 Op
: TSS_Name_Type
:= TSS_Null
) return Entity_Id
28703 BT
: constant Entity_Id
:= Base_Type
(T
);
28704 Op_Missing
: Boolean;
28707 if not Restriction_Active
(No_Default_Stream_Attributes
) then
28711 if Is_Elementary_Type
(T
) then
28712 if Op
= TSS_Null
then
28714 No
(TSS
(BT
, TSS_Stream_Read
))
28715 or else No
(TSS
(BT
, TSS_Stream_Write
));
28718 Op_Missing
:= No
(TSS
(BT
, Op
));
28727 elsif Is_Array_Type
(T
) then
28728 return Type_Without_Stream_Operation
(Component_Type
(T
), Op
);
28730 elsif Is_Record_Type
(T
) then
28736 Comp
:= First_Component
(T
);
28737 while Present
(Comp
) loop
28738 C_Typ
:= Type_Without_Stream_Operation
(Etype
(Comp
), Op
);
28740 if Present
(C_Typ
) then
28744 Next_Component
(Comp
);
28750 elsif Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
28751 return Type_Without_Stream_Operation
(Full_View
(T
), Op
);
28755 end Type_Without_Stream_Operation
;
28757 ---------------------
28758 -- Ultimate_Prefix --
28759 ---------------------
28761 function Ultimate_Prefix
(N
: Node_Id
) return Node_Id
is
28766 while Nkind
(Pref
) in N_Explicit_Dereference
28767 | N_Indexed_Component
28768 | N_Selected_Component
28771 Pref
:= Prefix
(Pref
);
28775 end Ultimate_Prefix
;
28777 ----------------------------
28778 -- Unique_Defining_Entity --
28779 ----------------------------
28781 function Unique_Defining_Entity
(N
: Node_Id
) return Entity_Id
is
28783 return Unique_Entity
(Defining_Entity
(N
));
28784 end Unique_Defining_Entity
;
28786 -------------------
28787 -- Unique_Entity --
28788 -------------------
28790 function Unique_Entity
(E
: Entity_Id
) return Entity_Id
is
28791 U
: Entity_Id
:= E
;
28797 if Present
(Full_View
(E
)) then
28798 U
:= Full_View
(E
);
28802 if Nkind
(Parent
(E
)) = N_Entry_Body
then
28804 Prot_Item
: Entity_Id
;
28805 Prot_Type
: Entity_Id
;
28808 if Ekind
(E
) = E_Entry
then
28809 Prot_Type
:= Scope
(E
);
28811 -- Bodies of entry families are nested within an extra scope
28812 -- that contains an entry index declaration.
28815 Prot_Type
:= Scope
(Scope
(E
));
28818 -- A protected type may be declared as a private type, in
28819 -- which case we need to get its full view.
28821 if Is_Private_Type
(Prot_Type
) then
28822 Prot_Type
:= Full_View
(Prot_Type
);
28825 -- Full view may not be present on error, in which case
28826 -- return E by default.
28828 if Present
(Prot_Type
) then
28829 pragma Assert
(Ekind
(Prot_Type
) = E_Protected_Type
);
28831 -- Traverse the entity list of the protected type and
28832 -- locate an entry declaration which matches the entry
28835 Prot_Item
:= First_Entity
(Prot_Type
);
28836 while Present
(Prot_Item
) loop
28837 if Ekind
(Prot_Item
) in Entry_Kind
28838 and then Corresponding_Body
(Parent
(Prot_Item
)) = E
28844 Next_Entity
(Prot_Item
);
28850 when Formal_Kind
=>
28851 if Present
(Spec_Entity
(E
)) then
28852 U
:= Spec_Entity
(E
);
28855 when E_Package_Body
=>
28858 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
28862 if Nkind
(P
) = N_Package_Body
28863 and then Present
(Corresponding_Spec
(P
))
28865 U
:= Corresponding_Spec
(P
);
28867 elsif Nkind
(P
) = N_Package_Body_Stub
28868 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28870 U
:= Corresponding_Spec_Of_Stub
(P
);
28873 when E_Protected_Body
=>
28876 if Nkind
(P
) = N_Protected_Body
28877 and then Present
(Corresponding_Spec
(P
))
28879 U
:= Corresponding_Spec
(P
);
28881 elsif Nkind
(P
) = N_Protected_Body_Stub
28882 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28884 U
:= Corresponding_Spec_Of_Stub
(P
);
28886 if Is_Single_Protected_Object
(U
) then
28891 if Is_Private_Type
(U
) then
28892 U
:= Full_View
(U
);
28895 when E_Subprogram_Body
=>
28898 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
28904 if Nkind
(P
) = N_Subprogram_Body
28905 and then Present
(Corresponding_Spec
(P
))
28907 U
:= Corresponding_Spec
(P
);
28909 elsif Nkind
(P
) = N_Subprogram_Body_Stub
28910 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28912 U
:= Corresponding_Spec_Of_Stub
(P
);
28914 elsif Nkind
(P
) = N_Subprogram_Renaming_Declaration
then
28915 U
:= Corresponding_Spec
(P
);
28918 when E_Task_Body
=>
28921 if Nkind
(P
) = N_Task_Body
28922 and then Present
(Corresponding_Spec
(P
))
28924 U
:= Corresponding_Spec
(P
);
28926 elsif Nkind
(P
) = N_Task_Body_Stub
28927 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28929 U
:= Corresponding_Spec_Of_Stub
(P
);
28931 if Is_Single_Task_Object
(U
) then
28936 if Is_Private_Type
(U
) then
28937 U
:= Full_View
(U
);
28941 if Present
(Full_View
(E
)) then
28942 U
:= Full_View
(E
);
28956 function Unique_Name
(E
: Entity_Id
) return String is
28958 -- Local subprograms
28960 function Add_Homonym_Suffix
(E
: Entity_Id
) return String;
28962 function This_Name
return String;
28964 ------------------------
28965 -- Add_Homonym_Suffix --
28966 ------------------------
28968 function Add_Homonym_Suffix
(E
: Entity_Id
) return String is
28970 -- Names in E_Subprogram_Body or E_Package_Body entities are not
28971 -- reliable, as they may not include the overloading suffix.
28972 -- Instead, when looking for the name of E or one of its enclosing
28973 -- scope, we get the name of the corresponding Unique_Entity.
28975 U
: constant Entity_Id
:= Unique_Entity
(E
);
28976 Nam
: constant String := Get_Name_String
(Chars
(U
));
28979 -- If E has homonyms but is not fully qualified, as done in
28980 -- GNATprove mode, append the homonym number on the fly. Strip the
28981 -- leading space character in the image of natural numbers. Also do
28982 -- not print the homonym value of 1.
28984 if Has_Homonym
(U
) then
28986 N
: constant Pos
:= Homonym_Number
(U
);
28987 S
: constant String := N
'Img;
28990 return Nam
& "__" & S
(2 .. S
'Last);
28996 end Add_Homonym_Suffix
;
29002 function This_Name
return String is
29004 return Add_Homonym_Suffix
(E
);
29009 U
: constant Entity_Id
:= Unique_Entity
(E
);
29011 -- Start of processing for Unique_Name
29014 if E
= Standard_Standard
29015 or else Has_Fully_Qualified_Name
(E
)
29019 elsif Ekind
(E
) = E_Enumeration_Literal
then
29020 return Unique_Name
(Etype
(E
)) & "__" & This_Name
;
29024 S
: constant Entity_Id
:= Scope
(U
);
29025 pragma Assert
(Present
(S
));
29028 -- Prefix names of predefined types with standard__, but leave
29029 -- names of user-defined packages and subprograms without prefix
29030 -- (even if technically they are nested in the Standard package).
29032 if S
= Standard_Standard
then
29033 if Ekind
(U
) = E_Package
or else Is_Subprogram
(U
) then
29036 return Unique_Name
(S
) & "__" & This_Name
;
29039 -- For intances of generic subprograms use the name of the related
29040 -- instance and skip the scope of its wrapper package.
29042 elsif Is_Wrapper_Package
(S
) then
29043 pragma Assert
(Scope
(S
) = Scope
(Related_Instance
(S
)));
29044 -- Wrapper package and the instantiation are in the same scope
29047 Related_Name
: constant String :=
29048 Add_Homonym_Suffix
(Related_Instance
(S
));
29049 Enclosing_Name
: constant String :=
29050 Unique_Name
(Scope
(S
)) & "__" & Related_Name
;
29053 if Is_Subprogram
(U
)
29054 and then not Is_Generic_Actual_Subprogram
(U
)
29056 return Enclosing_Name
;
29058 return Enclosing_Name
& "__" & This_Name
;
29062 elsif Is_Child_Unit
(U
) then
29063 return Child_Prefix
& Unique_Name
(S
) & "__" & This_Name
;
29065 return Unique_Name
(S
) & "__" & This_Name
;
29071 ---------------------
29072 -- Unit_Is_Visible --
29073 ---------------------
29075 function Unit_Is_Visible
(U
: Entity_Id
) return Boolean is
29076 Curr
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
29077 Curr_Entity
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
29079 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean;
29080 -- For a child unit, check whether unit appears in a with_clause
29083 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean;
29084 -- Scan the context clause of one compilation unit looking for a
29085 -- with_clause for the unit in question.
29087 ----------------------------
29088 -- Unit_In_Parent_Context --
29089 ----------------------------
29091 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean is
29093 if Unit_In_Context
(Par_Unit
) then
29096 elsif Is_Child_Unit
(Defining_Entity
(Unit
(Par_Unit
))) then
29097 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Par_Unit
)));
29102 end Unit_In_Parent_Context
;
29104 ---------------------
29105 -- Unit_In_Context --
29106 ---------------------
29108 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean is
29112 Clause
:= First
(Context_Items
(Comp_Unit
));
29113 while Present
(Clause
) loop
29114 if Nkind
(Clause
) = N_With_Clause
then
29115 if Library_Unit
(Clause
) = U
then
29118 -- The with_clause may denote a renaming of the unit we are
29119 -- looking for, eg. Text_IO which renames Ada.Text_IO.
29122 Renamed_Entity
(Entity
(Name
(Clause
))) =
29123 Defining_Entity
(Unit
(U
))
29133 end Unit_In_Context
;
29135 -- Start of processing for Unit_Is_Visible
29138 -- The currrent unit is directly visible
29143 elsif Unit_In_Context
(Curr
) then
29146 -- If the current unit is a body, check the context of the spec
29148 elsif Nkind
(Unit
(Curr
)) = N_Package_Body
29150 (Nkind
(Unit
(Curr
)) = N_Subprogram_Body
29151 and then not Acts_As_Spec
(Unit
(Curr
)))
29153 if Unit_In_Context
(Library_Unit
(Curr
)) then
29158 -- If the spec is a child unit, examine the parents
29160 if Is_Child_Unit
(Curr_Entity
) then
29161 if Nkind
(Unit
(Curr
)) in N_Unit_Body
then
29163 Unit_In_Parent_Context
29164 (Parent_Spec
(Unit
(Library_Unit
(Curr
))));
29166 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Curr
)));
29172 end Unit_Is_Visible
;
29174 ------------------------------
29175 -- Universal_Interpretation --
29176 ------------------------------
29178 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
29179 Index
: Interp_Index
;
29183 -- The argument may be a formal parameter of an operator or subprogram
29184 -- with multiple interpretations, or else an expression for an actual.
29186 if Nkind
(Opnd
) = N_Defining_Identifier
29187 or else not Is_Overloaded
(Opnd
)
29189 if Etype
(Opnd
) = Universal_Integer
29190 or else Etype
(Opnd
) = Universal_Real
29192 return Etype
(Opnd
);
29198 Get_First_Interp
(Opnd
, Index
, It
);
29199 while Present
(It
.Typ
) loop
29200 if It
.Typ
= Universal_Integer
29201 or else It
.Typ
= Universal_Real
29206 Get_Next_Interp
(Index
, It
);
29211 end Universal_Interpretation
;
29217 function Unqualify
(Expr
: Node_Id
) return Node_Id
is
29219 -- Recurse to handle unlikely case of multiple levels of qualification
29221 if Nkind
(Expr
) = N_Qualified_Expression
then
29222 return Unqualify
(Expression
(Expr
));
29224 -- Normal case, not a qualified expression
29235 function Unqual_Conv
(Expr
: Node_Id
) return Node_Id
is
29237 -- Recurse to handle unlikely case of multiple levels of qualification
29238 -- and/or conversion.
29240 if Nkind
(Expr
) in N_Qualified_Expression
29241 | N_Type_Conversion
29242 | N_Unchecked_Type_Conversion
29244 return Unqual_Conv
(Expression
(Expr
));
29246 -- Normal case, not a qualified expression
29253 --------------------
29254 -- Validated_View --
29255 --------------------
29257 function Validated_View
(Typ
: Entity_Id
) return Entity_Id
is
29258 Continue
: Boolean;
29259 Val_Typ
: Entity_Id
;
29263 Val_Typ
:= Base_Type
(Typ
);
29265 -- Obtain the full view of the input type by stripping away concurrency,
29266 -- derivations, and privacy.
29268 while Continue
loop
29271 if Is_Concurrent_Type
(Val_Typ
) then
29272 if Present
(Corresponding_Record_Type
(Val_Typ
)) then
29274 Val_Typ
:= Corresponding_Record_Type
(Val_Typ
);
29277 elsif Is_Derived_Type
(Val_Typ
) then
29279 Val_Typ
:= Etype
(Val_Typ
);
29281 elsif Is_Private_Type
(Val_Typ
) then
29282 if Present
(Underlying_Full_View
(Val_Typ
)) then
29284 Val_Typ
:= Underlying_Full_View
(Val_Typ
);
29286 elsif Present
(Full_View
(Val_Typ
)) then
29288 Val_Typ
:= Full_View
(Val_Typ
);
29294 end Validated_View
;
29296 -----------------------
29297 -- Visible_Ancestors --
29298 -----------------------
29300 function Visible_Ancestors
(Typ
: Entity_Id
) return Elist_Id
is
29306 pragma Assert
(Is_Record_Type
(Typ
) and then Is_Tagged_Type
(Typ
));
29308 -- Collect all the parents and progenitors of Typ. If the full-view of
29309 -- private parents and progenitors is available then it is used to
29310 -- generate the list of visible ancestors; otherwise their partial
29311 -- view is added to the resulting list.
29316 Use_Full_View
=> True);
29320 Ifaces_List
=> List_2
,
29321 Exclude_Parents
=> True,
29322 Use_Full_View
=> True);
29324 -- Join the two lists. Avoid duplications because an interface may
29325 -- simultaneously be parent and progenitor of a type.
29327 Elmt
:= First_Elmt
(List_2
);
29328 while Present
(Elmt
) loop
29329 Append_Unique_Elmt
(Node
(Elmt
), List_1
);
29334 end Visible_Ancestors
;
29336 ----------------------
29337 -- Within_Init_Proc --
29338 ----------------------
29340 function Within_Init_Proc
return Boolean is
29344 S
:= Current_Scope
;
29345 while not Is_Overloadable
(S
) loop
29346 if S
= Standard_Standard
then
29353 return Is_Init_Proc
(S
);
29354 end Within_Init_Proc
;
29356 ---------------------------
29357 -- Within_Protected_Type --
29358 ---------------------------
29360 function Within_Protected_Type
(E
: Entity_Id
) return Boolean is
29361 Scop
: Entity_Id
:= Scope
(E
);
29364 while Present
(Scop
) loop
29365 if Ekind
(Scop
) = E_Protected_Type
then
29369 Scop
:= Scope
(Scop
);
29373 end Within_Protected_Type
;
29379 function Within_Scope
(E
: Entity_Id
; S
: Entity_Id
) return Boolean is
29381 return Scope_Within_Or_Same
(Scope
(E
), S
);
29384 ----------------------------
29385 -- Within_Subprogram_Call --
29386 ----------------------------
29388 function Within_Subprogram_Call
(N
: Node_Id
) return Boolean is
29392 -- Climb the parent chain looking for a function or procedure call
29395 while Present
(Par
) loop
29396 if Nkind
(Par
) in N_Entry_Call_Statement
29398 | N_Procedure_Call_Statement
29402 -- Prevent the search from going too far
29404 elsif Is_Body_Or_Package_Declaration
(Par
) then
29408 Par
:= Parent
(Par
);
29412 end Within_Subprogram_Call
;
29418 procedure Wrong_Type
(Expr
: Node_Id
; Expected_Type
: Entity_Id
) is
29419 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
29420 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
29422 Matching_Field
: Entity_Id
;
29423 -- Entity to give a more precise suggestion on how to write a one-
29424 -- element positional aggregate.
29426 function Has_One_Matching_Field
return Boolean;
29427 -- Determines if Expec_Type is a record type with a single component or
29428 -- discriminant whose type matches the found type or is one dimensional
29429 -- array whose component type matches the found type. In the case of
29430 -- one discriminant, we ignore the variant parts. That's not accurate,
29431 -- but good enough for the warning.
29433 ----------------------------
29434 -- Has_One_Matching_Field --
29435 ----------------------------
29437 function Has_One_Matching_Field
return Boolean is
29441 Matching_Field
:= Empty
;
29443 if Is_Array_Type
(Expec_Type
)
29444 and then Number_Dimensions
(Expec_Type
) = 1
29445 and then Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
29447 -- Use type name if available. This excludes multidimensional
29448 -- arrays and anonymous arrays.
29450 if Comes_From_Source
(Expec_Type
) then
29451 Matching_Field
:= Expec_Type
;
29453 -- For an assignment, use name of target
29455 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
29456 and then Is_Entity_Name
(Name
(Parent
(Expr
)))
29458 Matching_Field
:= Entity
(Name
(Parent
(Expr
)));
29463 elsif not Is_Record_Type
(Expec_Type
) then
29467 E
:= First_Entity
(Expec_Type
);
29472 elsif Ekind
(E
) not in E_Discriminant | E_Component
29473 or else Chars
(E
) in Name_uTag | Name_uParent
29482 if not Covers
(Etype
(E
), Found_Type
) then
29485 elsif Present
(Next_Entity
(E
))
29486 and then (Ekind
(E
) = E_Component
29487 or else Ekind
(Next_Entity
(E
)) = E_Discriminant
)
29492 Matching_Field
:= E
;
29496 end Has_One_Matching_Field
;
29498 -- Start of processing for Wrong_Type
29501 -- Don't output message if either type is Any_Type, or if a message
29502 -- has already been posted for this node. We need to do the latter
29503 -- check explicitly (it is ordinarily done in Errout), because we
29504 -- are using ! to force the output of the error messages.
29506 if Expec_Type
= Any_Type
29507 or else Found_Type
= Any_Type
29508 or else Error_Posted
(Expr
)
29512 -- If one of the types is a Taft-Amendment type and the other it its
29513 -- completion, it must be an illegal use of a TAT in the spec, for
29514 -- which an error was already emitted. Avoid cascaded errors.
29516 elsif Is_Incomplete_Type
(Expec_Type
)
29517 and then Has_Completion_In_Body
(Expec_Type
)
29518 and then Full_View
(Expec_Type
) = Etype
(Expr
)
29522 elsif Is_Incomplete_Type
(Etype
(Expr
))
29523 and then Has_Completion_In_Body
(Etype
(Expr
))
29524 and then Full_View
(Etype
(Expr
)) = Expec_Type
29528 -- In an instance, there is an ongoing problem with completion of
29529 -- types derived from private types. Their structure is what Gigi
29530 -- expects, but the Etype is the parent type rather than the derived
29531 -- private type itself. Do not flag error in this case. The private
29532 -- completion is an entity without a parent, like an Itype. Similarly,
29533 -- full and partial views may be incorrect in the instance.
29534 -- There is no simple way to insure that it is consistent ???
29536 -- A similar view discrepancy can happen in an inlined body, for the
29537 -- same reason: inserted body may be outside of the original package
29538 -- and only partial views are visible at the point of insertion.
29540 -- If In_Generic_Actual (Expr) is True then we cannot assume that
29541 -- the successful semantic analysis of the generic guarantees anything
29542 -- useful about type checking of this instance, so we ignore
29543 -- In_Instance in that case. There may be cases where this is not
29544 -- right (the symptom would probably be rejecting something
29545 -- that ought to be accepted) but we don't currently have any
29546 -- concrete examples of this.
29548 elsif (In_Instance
and then not In_Generic_Actual
(Expr
))
29549 or else In_Inlined_Body
29551 if Etype
(Etype
(Expr
)) = Etype
(Expected_Type
)
29553 (Has_Private_Declaration
(Expected_Type
)
29554 or else Has_Private_Declaration
(Etype
(Expr
)))
29555 and then No
(Parent
(Expected_Type
))
29559 elsif Nkind
(Parent
(Expr
)) = N_Qualified_Expression
29560 and then Entity
(Subtype_Mark
(Parent
(Expr
))) = Expected_Type
29564 elsif Is_Private_Type
(Expected_Type
)
29565 and then Present
(Full_View
(Expected_Type
))
29566 and then Covers
(Full_View
(Expected_Type
), Etype
(Expr
))
29570 -- Conversely, type of expression may be the private one
29572 elsif Is_Private_Type
(Base_Type
(Etype
(Expr
)))
29573 and then Full_View
(Base_Type
(Etype
(Expr
))) = Expected_Type
29579 -- An interesting special check. If the expression is parenthesized
29580 -- and its type corresponds to the type of the sole component of the
29581 -- expected record type, or to the component type of the expected one
29582 -- dimensional array type, then assume we have a bad aggregate attempt.
29584 if Nkind
(Expr
) in N_Subexpr
29585 and then Paren_Count
(Expr
) /= 0
29586 and then Has_One_Matching_Field
29588 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
29590 if Present
(Matching_Field
) then
29591 if Is_Array_Type
(Expec_Type
) then
29593 ("\write instead `&''First ='> ...`", Expr
, Matching_Field
);
29596 ("\write instead `& ='> ...`", Expr
, Matching_Field
);
29600 -- Another special check, if we are looking for a pool-specific access
29601 -- type and we found an E_Access_Attribute_Type, then we have the case
29602 -- of an Access attribute being used in a context which needs a pool-
29603 -- specific type, which is never allowed. The one extra check we make
29604 -- is that the expected designated type covers the Found_Type.
29606 elsif Is_Access_Type
(Expec_Type
)
29607 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
29608 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
29609 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
29611 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
29614 ("result must be general access type!", Expr
);
29615 Error_Msg_NE
-- CODEFIX
29616 ("\add ALL to }!", Expr
, Expec_Type
);
29618 -- Another special check, if the expected type is an integer type,
29619 -- but the expression is of type System.Address, and the parent is
29620 -- an addition or subtraction operation whose left operand is the
29621 -- expression in question and whose right operand is of an integral
29622 -- type, then this is an attempt at address arithmetic, so give
29623 -- appropriate message.
29625 elsif Is_Integer_Type
(Expec_Type
)
29626 and then Is_RTE
(Found_Type
, RE_Address
)
29627 and then Nkind
(Parent
(Expr
)) in N_Op_Add | N_Op_Subtract
29628 and then Expr
= Left_Opnd
(Parent
(Expr
))
29629 and then Is_Integer_Type
(Etype
(Right_Opnd
(Parent
(Expr
))))
29632 ("address arithmetic not predefined in package System",
29635 ("\possible missing with/use of System.Storage_Elements",
29639 -- If the expected type is an anonymous access type, as for access
29640 -- parameters and discriminants, the error is on the designated types.
29642 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
29643 if Comes_From_Source
(Expec_Type
) then
29644 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
29647 ("expected an access type with designated}",
29648 Expr
, Designated_Type
(Expec_Type
));
29651 if Is_Access_Type
(Found_Type
)
29652 and then not Comes_From_Source
(Found_Type
)
29655 ("\\found an access type with designated}!",
29656 Expr
, Designated_Type
(Found_Type
));
29658 if From_Limited_With
(Found_Type
) then
29659 Error_Msg_NE
("\\found incomplete}!", Expr
, Found_Type
);
29660 Error_Msg_Qual_Level
:= 99;
29661 Error_Msg_NE
-- CODEFIX
29662 ("\\missing `WITH &;", Expr
, Scope
(Found_Type
));
29663 Error_Msg_Qual_Level
:= 0;
29665 Error_Msg_NE
("found}!", Expr
, Found_Type
);
29669 -- Normal case of one type found, some other type expected
29672 -- If the names of the two types are the same, see if some number
29673 -- of levels of qualification will help. Don't try more than three
29674 -- levels, and if we get to standard, it's no use (and probably
29675 -- represents an error in the compiler) Also do not bother with
29676 -- internal scope names.
29679 Expec_Scope
: Entity_Id
;
29680 Found_Scope
: Entity_Id
;
29683 Expec_Scope
:= Expec_Type
;
29684 Found_Scope
:= Found_Type
;
29686 for Levels
in Nat
range 0 .. 3 loop
29687 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
29688 Error_Msg_Qual_Level
:= Levels
;
29692 Expec_Scope
:= Scope
(Expec_Scope
);
29693 Found_Scope
:= Scope
(Found_Scope
);
29695 exit when Expec_Scope
= Standard_Standard
29696 or else Found_Scope
= Standard_Standard
29697 or else not Comes_From_Source
(Expec_Scope
)
29698 or else not Comes_From_Source
(Found_Scope
);
29702 if Is_Record_Type
(Expec_Type
)
29703 and then Present
(Corresponding_Remote_Type
(Expec_Type
))
29705 Error_Msg_NE
("expected}!", Expr
,
29706 Corresponding_Remote_Type
(Expec_Type
));
29708 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
29711 if Is_Entity_Name
(Expr
)
29712 and then Is_Package_Or_Generic_Package
(Entity
(Expr
))
29714 Error_Msg_N
("\\found package name!", Expr
);
29716 elsif Is_Entity_Name
(Expr
)
29717 and then Ekind
(Entity
(Expr
)) in E_Procedure | E_Generic_Procedure
29719 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
29721 ("found procedure name, possibly missing Access attribute!",
29725 ("\\found procedure name instead of function!", Expr
);
29728 elsif Nkind
(Expr
) = N_Function_Call
29729 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
29730 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
29731 and then No
(Parameter_Associations
(Expr
))
29734 ("found function name, possibly missing Access attribute!",
29737 -- Catch common error: a prefix or infix operator which is not
29738 -- directly visible because the type isn't.
29740 elsif Nkind
(Expr
) in N_Op
29741 and then Is_Overloaded
(Expr
)
29742 and then not Is_Immediately_Visible
(Expec_Type
)
29743 and then not Is_Potentially_Use_Visible
(Expec_Type
)
29744 and then not In_Use
(Expec_Type
)
29745 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
29748 ("operator of the type is not directly visible!", Expr
);
29750 elsif Ekind
(Found_Type
) = E_Void
29751 and then Present
(Parent
(Found_Type
))
29752 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
29754 Error_Msg_NE
("\\found premature usage of}!", Expr
, Found_Type
);
29757 Error_Msg_NE
("\\found}!", Expr
, Found_Type
);
29760 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
29761 -- of the same modular type, and (M1 and M2) = 0 was intended.
29763 if Expec_Type
= Standard_Boolean
29764 and then Is_Modular_Integer_Type
(Found_Type
)
29765 and then Nkind
(Parent
(Expr
)) in N_Op_And | N_Op_Or | N_Op_Xor
29766 and then Nkind
(Right_Opnd
(Parent
(Expr
))) in N_Op_Compare
29769 Op
: constant Node_Id
:= Right_Opnd
(Parent
(Expr
));
29770 L
: constant Node_Id
:= Left_Opnd
(Op
);
29771 R
: constant Node_Id
:= Right_Opnd
(Op
);
29774 -- The case for the message is when the left operand of the
29775 -- comparison is the same modular type, or when it is an
29776 -- integer literal (or other universal integer expression),
29777 -- which would have been typed as the modular type if the
29778 -- parens had been there.
29780 if (Etype
(L
) = Found_Type
29782 Etype
(L
) = Universal_Integer
)
29783 and then Is_Integer_Type
(Etype
(R
))
29786 ("\\possible missing parens for modular operation", Expr
);
29791 -- Reset error message qualification indication
29793 Error_Msg_Qual_Level
:= 0;
29797 --------------------------------
29798 -- Yields_Synchronized_Object --
29799 --------------------------------
29801 function Yields_Synchronized_Object
(Typ
: Entity_Id
) return Boolean is
29802 Has_Sync_Comp
: Boolean := False;
29806 -- An array type yields a synchronized object if its component type
29807 -- yields a synchronized object.
29809 if Is_Array_Type
(Typ
) then
29810 return Yields_Synchronized_Object
(Component_Type
(Typ
));
29812 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object
29813 -- yields a synchronized object by default.
29815 elsif Is_Descendant_Of_Suspension_Object
(Typ
) then
29818 -- A protected type yields a synchronized object by default
29820 elsif Is_Protected_Type
(Typ
) then
29823 -- A record type or type extension yields a synchronized object when its
29824 -- discriminants (if any) lack default values and all components are of
29825 -- a type that yields a synchronized object.
29827 elsif Is_Record_Type
(Typ
) then
29829 -- Inspect all entities defined in the scope of the type, looking for
29830 -- components of a type that does not yield a synchronized object or
29831 -- for discriminants with default values.
29833 Id
:= First_Entity
(Typ
);
29834 while Present
(Id
) loop
29835 if Comes_From_Source
(Id
) then
29836 if Ekind
(Id
) = E_Component
then
29837 if Yields_Synchronized_Object
(Etype
(Id
)) then
29838 Has_Sync_Comp
:= True;
29840 -- The component does not yield a synchronized object
29846 elsif Ekind
(Id
) = E_Discriminant
29847 and then Present
(Expression
(Parent
(Id
)))
29856 -- Ensure that the parent type of a type extension yields a
29857 -- synchronized object.
29859 if Etype
(Typ
) /= Typ
29860 and then not Is_Private_Type
(Etype
(Typ
))
29861 and then not Yields_Synchronized_Object
(Etype
(Typ
))
29866 -- If we get here, then all discriminants lack default values and all
29867 -- components are of a type that yields a synchronized object.
29869 return Has_Sync_Comp
;
29871 -- A synchronized interface type yields a synchronized object by default
29873 elsif Is_Synchronized_Interface
(Typ
) then
29876 -- A task type yields a synchronized object by default
29878 elsif Is_Task_Type
(Typ
) then
29881 -- A private type yields a synchronized object if its underlying type
29884 elsif Is_Private_Type
(Typ
)
29885 and then Present
(Underlying_Type
(Typ
))
29887 return Yields_Synchronized_Object
(Underlying_Type
(Typ
));
29889 -- Otherwise the type does not yield a synchronized object
29894 end Yields_Synchronized_Object
;
29896 ---------------------------
29897 -- Yields_Universal_Type --
29898 ---------------------------
29900 function Yields_Universal_Type
(N
: Node_Id
) return Boolean is
29902 -- Integer and real literals are of a universal type
29904 if Nkind
(N
) in N_Integer_Literal | N_Real_Literal
then
29907 -- The values of certain attributes are of a universal type
29909 elsif Nkind
(N
) = N_Attribute_Reference
then
29911 Universal_Type_Attribute
(Get_Attribute_Id
(Attribute_Name
(N
)));
29913 -- ??? There are possibly other cases to consider
29918 end Yields_Universal_Type
;
29920 package body Interval_Lists
is
29922 procedure Check_Consistency
(Intervals
: Discrete_Interval_List
);
29923 -- Check that list is sorted, lacks null intervals, and has gaps
29924 -- between intervals.
29926 function Chosen_Interval
(Choice
: Node_Id
) return Discrete_Interval
;
29927 -- Given an element of a Discrete_Choices list, a
29928 -- Static_Discrete_Predicate list, or an Others_Discrete_Choices
29929 -- list (but not an N_Others_Choice node) return the corresponding
29930 -- interval. If an element that does not represent a single
29931 -- contiguous interval due to a static predicate (or which
29932 -- represents a single contiguous interval whose bounds depend on
29933 -- a static predicate) is encountered, then that is an error on the
29934 -- part of whoever built the list in question.
29936 function In_Interval
29937 (Value
: Uint
; Interval
: Discrete_Interval
) return Boolean;
29938 -- Does the given value lie within the given interval?
29940 procedure Normalize_Interval_List
29941 (List
: in out Discrete_Interval_List
; Last
: out Nat
);
29942 -- Perform sorting and merging as required by Check_Consistency.
29944 -------------------------
29945 -- Aggregate_Intervals --
29946 -------------------------
29948 function Aggregate_Intervals
(N
: Node_Id
) return Discrete_Interval_List
29950 pragma Assert
(Nkind
(N
) = N_Aggregate
29951 and then Is_Array_Type
(Etype
(N
)));
29953 function Unmerged_Intervals_Count
return Nat
;
29954 -- Count the number of intervals given in the aggregate N; the others
29955 -- choice (if present) is not taken into account.
29957 function Unmerged_Intervals_Count
return Nat
is
29962 Comp
:= First
(Component_Associations
(N
));
29963 while Present
(Comp
) loop
29964 Choice
:= First
(Choices
(Comp
));
29966 while Present
(Choice
) loop
29967 if Nkind
(Choice
) /= N_Others_Choice
then
29968 Count
:= Count
+ 1;
29978 end Unmerged_Intervals_Count
;
29983 Max_I
: constant Nat
:= Unmerged_Intervals_Count
;
29984 Intervals
: Discrete_Interval_List
(1 .. Max_I
);
29987 -- Start of processing for Aggregate_Intervals
29990 -- No action needed if there are no intervals
29996 -- Internally store all the unsorted intervals
29998 Comp
:= First
(Component_Associations
(N
));
29999 while Present
(Comp
) loop
30001 Choice_Intervals
: constant Discrete_Interval_List
30002 := Choice_List_Intervals
(Choices
(Comp
));
30004 for J
in Choice_Intervals
'Range loop
30005 Num_I
:= Num_I
+ 1;
30006 Intervals
(Num_I
) := Choice_Intervals
(J
);
30013 -- Normalize the lists sorting and merging the intervals
30016 Aggr_Intervals
: Discrete_Interval_List
(1 .. Num_I
)
30017 := Intervals
(1 .. Num_I
);
30019 Normalize_Interval_List
(Aggr_Intervals
, Num_I
);
30020 Check_Consistency
(Aggr_Intervals
(1 .. Num_I
));
30021 return Aggr_Intervals
(1 .. Num_I
);
30023 end Aggregate_Intervals
;
30025 ------------------------
30026 -- Check_Consistency --
30027 ------------------------
30029 procedure Check_Consistency
(Intervals
: Discrete_Interval_List
) is
30031 if Serious_Errors_Detected
> 0 then
30035 -- low bound is 1 and high bound equals length
30036 pragma Assert
(Intervals
'First = 1 and Intervals
'Last >= 0);
30037 for Idx
in Intervals
'Range loop
30038 -- each interval is non-null
30039 pragma Assert
(Intervals
(Idx
).Low
<= Intervals
(Idx
).High
);
30040 if Idx
/= Intervals
'First then
30041 -- intervals are sorted with non-empty gaps between them
30043 (Intervals
(Idx
- 1).High
< (Intervals
(Idx
).Low
- 1));
30047 end Check_Consistency
;
30049 ---------------------------
30050 -- Choice_List_Intervals --
30051 ---------------------------
30053 function Choice_List_Intervals
30054 (Discrete_Choices
: List_Id
) return Discrete_Interval_List
30056 function Unmerged_Choice_Count
return Nat
;
30057 -- The number of intervals before adjacent intervals are merged.
30059 ---------------------------
30060 -- Unmerged_Choice_Count --
30061 ---------------------------
30063 function Unmerged_Choice_Count
return Nat
is
30064 Choice
: Node_Id
:= First
(Discrete_Choices
);
30067 while Present
(Choice
) loop
30068 -- Non-contiguous choices involving static predicates
30069 -- have already been normalized away.
30071 if Nkind
(Choice
) = N_Others_Choice
then
30073 Count
+ List_Length
(Others_Discrete_Choices
(Choice
));
30075 Count
:= Count
+ 1; -- an ordinary expression or range
30081 end Unmerged_Choice_Count
;
30085 Choice
: Node_Id
:= First
(Discrete_Choices
);
30086 Result
: Discrete_Interval_List
(1 .. Unmerged_Choice_Count
);
30089 -- Start of processing for Choice_List_Intervals
30092 while Present
(Choice
) loop
30093 if Nkind
(Choice
) = N_Others_Choice
then
30095 Others_Choice
: Node_Id
30096 := First
(Others_Discrete_Choices
(Choice
));
30098 while Present
(Others_Choice
) loop
30099 Count
:= Count
+ 1;
30100 Result
(Count
) := Chosen_Interval
(Others_Choice
);
30101 Next
(Others_Choice
);
30105 Count
:= Count
+ 1;
30106 Result
(Count
) := Chosen_Interval
(Choice
);
30112 pragma Assert
(Count
= Result
'Last);
30113 Normalize_Interval_List
(Result
, Count
);
30114 Check_Consistency
(Result
(1 .. Count
));
30115 return Result
(1 .. Count
);
30116 end Choice_List_Intervals
;
30118 ---------------------
30119 -- Chosen_Interval --
30120 ---------------------
30122 function Chosen_Interval
(Choice
: Node_Id
) return Discrete_Interval
is
30124 case Nkind
(Choice
) is
30126 return (Low
=> Expr_Value
(Low_Bound
(Choice
)),
30127 High
=> Expr_Value
(High_Bound
(Choice
)));
30129 when N_Subtype_Indication
=>
30131 Range_Exp
: constant Node_Id
30132 := Range_Expression
(Constraint
(Choice
));
30134 return (Low
=> Expr_Value
(Low_Bound
(Range_Exp
)),
30135 High
=> Expr_Value
(High_Bound
(Range_Exp
)));
30138 when N_Others_Choice
=>
30139 raise Program_Error
;
30142 if Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
))
30145 (Low
=> Expr_Value
(Type_Low_Bound
(Entity
(Choice
))),
30146 High
=> Expr_Value
(Type_High_Bound
(Entity
(Choice
))));
30149 return (Low | High
=> Expr_Value
(Choice
));
30152 end Chosen_Interval
;
30158 function In_Interval
30159 (Value
: Uint
; Interval
: Discrete_Interval
) return Boolean is
30161 return Value
>= Interval
.Low
and then Value
<= Interval
.High
;
30169 (Subset
, Of_Set
: Discrete_Interval_List
) return Boolean
30171 -- Returns True iff for each interval of Subset we can find
30172 -- a single interval of Of_Set which contains the Subset interval.
30174 if Of_Set
'Length = 0 then
30175 return Subset
'Length = 0;
30179 Set_Index
: Pos
range Of_Set
'Range := Of_Set
'First;
30182 for Ss_Idx
in Subset
'Range loop
30183 while not In_Interval
30184 (Value
=> Subset
(Ss_Idx
).Low
,
30185 Interval
=> Of_Set
(Set_Index
))
30187 if Set_Index
= Of_Set
'Last then
30191 Set_Index
:= Set_Index
+ 1;
30195 (Value
=> Subset
(Ss_Idx
).High
,
30196 Interval
=> Of_Set
(Set_Index
))
30206 -----------------------------
30207 -- Normalize_Interval_List --
30208 -----------------------------
30210 procedure Normalize_Interval_List
30211 (List
: in out Discrete_Interval_List
; Last
: out Nat
)
30213 Temp_0
: Discrete_Interval
:= (others => Uint_0
);
30214 -- Cope with Heap_Sort_G idiosyncrasies.
30216 function Is_Null
(Idx
: Pos
) return Boolean;
30217 -- True iff List (Idx) defines a null range
30219 function Lt_Interval
(Idx1
, Idx2
: Natural) return Boolean;
30220 -- Compare two list elements
30222 procedure Merge_Intervals
(Null_Interval_Count
: out Nat
);
30223 -- Merge contiguous ranges by replacing one with merged range and
30224 -- the other with a null value. Return a count of the null intervals,
30225 -- both preexisting and those introduced by merging.
30227 procedure Move_Interval
(From
, To
: Natural);
30228 -- Copy interval from one location to another
30230 function Read_Interval
(From
: Natural) return Discrete_Interval
;
30231 -- Normal array indexing unless From = 0
30233 ----------------------
30234 -- Interval_Sorting --
30235 ----------------------
30237 package Interval_Sorting
is
30238 new Gnat
.Heap_Sort_G
(Move_Interval
, Lt_Interval
);
30244 function Is_Null
(Idx
: Pos
) return Boolean is
30246 return List
(Idx
).Low
> List
(Idx
).High
;
30253 function Lt_Interval
(Idx1
, Idx2
: Natural) return Boolean is
30254 Elem1
: constant Discrete_Interval
:= Read_Interval
(Idx1
);
30255 Elem2
: constant Discrete_Interval
:= Read_Interval
(Idx2
);
30256 Null_1
: constant Boolean := Elem1
.Low
> Elem1
.High
;
30257 Null_2
: constant Boolean := Elem2
.Low
> Elem2
.High
;
30259 if Null_1
/= Null_2
then
30260 -- So that sorting moves null intervals to high end
30263 elsif Elem1
.Low
/= Elem2
.Low
then
30264 return Elem1
.Low
< Elem2
.Low
;
30267 return Elem1
.High
< Elem2
.High
;
30271 ---------------------
30272 -- Merge_Intervals --
30273 ---------------------
30275 procedure Merge_Intervals
(Null_Interval_Count
: out Nat
) is
30276 Not_Null
: Pos
range List
'Range;
30277 -- Index of the most recently examined non-null interval
30279 Null_Interval
: constant Discrete_Interval
30280 := (Low
=> Uint_1
, High
=> Uint_0
); -- any null range ok here
30282 if List
'Length = 0 or else Is_Null
(List
'First) then
30283 Null_Interval_Count
:= List
'Length;
30284 -- no non-null elements, so no merge candidates
30288 Null_Interval_Count
:= 0;
30289 Not_Null
:= List
'First;
30291 for Idx
in List
'First + 1 .. List
'Last loop
30292 if Is_Null
(Idx
) then
30294 -- all remaining elements are null
30296 Null_Interval_Count
:=
30297 Null_Interval_Count
+ List
(Idx
.. List
'Last)'Length;
30300 elsif List
(Idx
).Low
= List
(Not_Null
).High
+ 1 then
30302 -- Merge the two intervals into one; discard the other
30304 List
(Not_Null
).High
:= List
(Idx
).High
;
30305 List
(Idx
) := Null_Interval
;
30306 Null_Interval_Count
:= Null_Interval_Count
+ 1;
30309 if List
(Idx
).Low
<= List
(Not_Null
).High
then
30310 raise Intervals_Error
;
30313 pragma Assert
(List
(Idx
).Low
> List
(Not_Null
).High
);
30317 end Merge_Intervals
;
30319 -------------------
30320 -- Move_Interval --
30321 -------------------
30323 procedure Move_Interval
(From
, To
: Natural) is
30324 Rhs
: constant Discrete_Interval
:= Read_Interval
(From
);
30329 List
(Pos
(To
)) := Rhs
;
30333 -------------------
30334 -- Read_Interval --
30335 -------------------
30337 function Read_Interval
(From
: Natural) return Discrete_Interval
is
30342 return List
(Pos
(From
));
30346 -- Start of processing for Normalize_Interval_Lists
30349 Interval_Sorting
.Sort
(Natural (List
'Last));
30352 Null_Interval_Count
: Nat
;
30355 Merge_Intervals
(Null_Interval_Count
);
30356 Last
:= List
'Last - Null_Interval_Count
;
30358 if Null_Interval_Count
/= 0 then
30359 -- Move null intervals introduced during merging to high end
30360 Interval_Sorting
.Sort
(Natural (List
'Last));
30363 end Normalize_Interval_List
;
30365 --------------------
30366 -- Type_Intervals --
30367 --------------------
30369 function Type_Intervals
(Typ
: Entity_Id
) return Discrete_Interval_List
30372 if Has_Static_Predicate
(Typ
) then
30374 -- No sorting or merging needed
30375 SDP_List
: constant List_Id
:= Static_Discrete_Predicate
(Typ
);
30376 Range_Or_Expr
: Node_Id
:= First
(SDP_List
);
30377 Result
: Discrete_Interval_List
(1 .. List_Length
(SDP_List
));
30380 for Idx
in Result
'Range loop
30381 Result
(Idx
) := Chosen_Interval
(Range_Or_Expr
);
30382 Next
(Range_Or_Expr
);
30385 pragma Assert
(not Present
(Range_Or_Expr
));
30386 Check_Consistency
(Result
);
30391 Low
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Typ
));
30392 High
: constant Uint
:= Expr_Value
(Type_High_Bound
(Typ
));
30396 Null_Array
: Discrete_Interval_List
(1 .. 0);
30401 return (1 => (Low
=> Low
, High
=> High
));
30405 end Type_Intervals
;
30407 end Interval_Lists
;
30409 package body Old_Attr_Util
is
30410 package body Conditional_Evaluation
is
30411 type Determining_Expr_Context
is
30412 (No_Context
, If_Expr
, Case_Expr
, Short_Circuit_Op
, Membership_Test
);
30414 -- Determining_Expr_Context enumeration elements (except for
30415 -- No_Context) correspond to the list items in RM 6.1.1 definition
30416 -- of "determining expression".
30418 type Determining_Expr
30419 (Context
: Determining_Expr_Context
:= No_Context
)
30421 Expr
: Node_Id
:= Empty
;
30423 when Short_Circuit_Op
=>
30424 Is_And_Then
: Boolean;
30426 Is_Then_Part
: Boolean;
30428 Alternatives
: Node_Id
;
30429 when Membership_Test
=>
30430 -- Given a subexpression of <exp4> in a membership test
30431 -- <exp1> in <exp2> | <exp3> | <exp4> | <exp5>
30432 -- the corresponding determining expression value would
30433 -- have First_Non_Preceding = <exp4> (See RM 6.1.1).
30434 First_Non_Preceding
: Node_Id
;
30440 type Determining_Expression_List
is
30441 array (Positive range <>) of Determining_Expr
;
30443 function Determining_Condition
(Det
: Determining_Expr
)
30445 -- Given a determining expression, build a Boolean-valued
30446 -- condition that incorporates that expression into condition
30447 -- suitable for deciding whether to initialize a 'Old constant.
30448 -- Polarity is "True => initialize the constant".
30450 function Determining_Expressions
30451 (Expr
: Node_Id
; Expr_Trailer
: Node_Id
:= Empty
)
30452 return Determining_Expression_List
;
30453 -- Given a conditionally evaluated expression, return its
30454 -- determining expressions.
30455 -- See RM 6.1.1 for definition of term "determining expressions".
30456 -- Tests should be performed in the order they occur in the
30457 -- array, with short circuiting.
30458 -- A determining expression need not be of a boolean type (e.g.,
30459 -- it might be the determining expression of a case expression).
30460 -- The Expr_Trailer parameter should be defaulted for nonrecursive
30463 function Is_Conditionally_Evaluated
(Expr
: Node_Id
) return Boolean;
30464 -- See RM 6.1.1 for definition of term "conditionally evaluated".
30466 function Is_Known_On_Entry
(Expr
: Node_Id
) return Boolean;
30467 -- See RM 6.1.1 for definition of term "known on entry".
30469 --------------------------------------
30470 -- Conditional_Evaluation_Condition --
30471 --------------------------------------
30473 function Conditional_Evaluation_Condition
30474 (Expr
: Node_Id
) return Node_Id
30476 Determiners
: constant Determining_Expression_List
:=
30477 Determining_Expressions
(Expr
);
30478 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
30479 Result
: Node_Id
:=
30480 New_Occurrence_Of
(Standard_True
, Loc
);
30482 pragma Assert
(Determiners
'Length > 0 or else
30483 Is_Anonymous_Access_Type
(Etype
(Expr
)));
30485 for I
in Determiners
'Range loop
30486 Result
:= Make_And_Then
30488 Left_Opnd
=> Result
,
30490 Determining_Condition
(Determiners
(I
)));
30493 end Conditional_Evaluation_Condition
;
30495 ---------------------------
30496 -- Determining_Condition --
30497 ---------------------------
30499 function Determining_Condition
(Det
: Determining_Expr
) return Node_Id
30501 Loc
: constant Source_Ptr
:= Sloc
(Det
.Expr
);
30503 case Det
.Context
is
30504 when Short_Circuit_Op
=>
30505 if Det
.Is_And_Then
then
30506 return New_Copy_Tree
(Det
.Expr
);
30508 return Make_Op_Not
(Loc
, New_Copy_Tree
(Det
.Expr
));
30512 if Det
.Is_Then_Part
then
30513 return New_Copy_Tree
(Det
.Expr
);
30515 return Make_Op_Not
(Loc
, New_Copy_Tree
(Det
.Expr
));
30520 Alts
: List_Id
:= Discrete_Choices
(Det
.Alternatives
);
30522 if Nkind
(First
(Alts
)) = N_Others_Choice
then
30523 Alts
:= Others_Discrete_Choices
(First
(Alts
));
30526 return Make_In
(Loc
,
30527 Left_Opnd
=> New_Copy_Tree
(Det
.Expr
),
30528 Right_Opnd
=> Empty
,
30529 Alternatives
=> New_Copy_List
(Alts
));
30532 when Membership_Test
=>
30534 function Copy_Prefix
30535 (List
: List_Id
; Suffix_Start
: Node_Id
)
30537 -- Given a list and a member of that list, returns
30538 -- a copy (similar to Nlists.New_Copy_List) of the
30539 -- prefix of the list up to but not including
30546 function Copy_Prefix
30547 (List
: List_Id
; Suffix_Start
: Node_Id
)
30550 Result
: constant List_Id
:= New_List
;
30551 Elem
: Node_Id
:= First
(List
);
30553 while Elem
/= Suffix_Start
loop
30554 Append
(New_Copy
(Elem
), Result
);
30556 pragma Assert
(Present
(Elem
));
30562 return Make_In
(Loc
,
30563 Left_Opnd
=> New_Copy_Tree
(Left_Opnd
(Det
.Expr
)),
30564 Right_Opnd
=> Empty
,
30565 Alternatives
=> Copy_Prefix
30566 (Alternatives
(Det
.Expr
),
30567 Det
.First_Non_Preceding
));
30571 raise Program_Error
;
30573 end Determining_Condition
;
30575 -----------------------------
30576 -- Determining_Expressions --
30577 -----------------------------
30579 function Determining_Expressions
30580 (Expr
: Node_Id
; Expr_Trailer
: Node_Id
:= Empty
)
30581 return Determining_Expression_List
30583 Par
: Node_Id
:= Expr
;
30584 Trailer
: Node_Id
:= Expr_Trailer
;
30585 Next_Element
: Determining_Expr
;
30587 -- We want to stop climbing up the tree when we reach the
30588 -- postcondition expression. An aspect_specification is
30589 -- transformed into a pragma, so reaching a pragma is our
30590 -- termination condition. This relies on the fact that
30591 -- pragmas are not allowed in declare expressions (or any
30592 -- other kind of expression).
30595 Next_Element
.Expr
:= Empty
;
30597 case Nkind
(Par
) is
30598 when N_Short_Circuit
=>
30599 if Trailer
= Right_Opnd
(Par
) then
30601 (Expr
=> Left_Opnd
(Par
),
30602 Context
=> Short_Circuit_Op
,
30603 Is_And_Then
=> Nkind
(Par
) = N_And_Then
);
30606 when N_If_Expression
=>
30607 -- For an expression like
30608 -- (if C1 then ... elsif C2 then ... else Foo'Old)
30609 -- the RM says are two determining expressions,
30610 -- C1 and C2. Our treatment here (where we only add
30611 -- one determining expression to the list) is ok because
30612 -- we will see two if-expressions, one within the other.
30614 if Trailer
/= First
(Expressions
(Par
)) then
30616 (Expr
=> First
(Expressions
(Par
)),
30617 Context
=> If_Expr
,
30619 Trailer
= Next
(First
(Expressions
(Par
))));
30622 when N_Case_Expression_Alternative
=>
30623 pragma Assert
(Nkind
(Parent
(Par
)) = N_Case_Expression
);
30626 (Expr
=> Expression
(Parent
(Par
)),
30627 Context
=> Case_Expr
,
30628 Alternatives
=> Par
);
30630 when N_Membership_Test
=>
30631 if Trailer
/= Left_Opnd
(Par
)
30632 and then Is_Non_Empty_List
(Alternatives
(Par
))
30633 and then Trailer
/= First
(Alternatives
(Par
))
30635 pragma Assert
(not Present
(Right_Opnd
(Par
)));
30637 (Is_List_Member
(Trailer
)
30638 and then List_Containing
(Trailer
)
30639 = Alternatives
(Par
));
30641 -- This one is different than the others
30642 -- because one element in the array result
30643 -- may represent multiple determining
30644 -- expressions (i.e. every member of the list
30645 -- Alternatives (Par)
30646 -- up to but not including Trailer).
30650 Context
=> Membership_Test
,
30651 First_Non_Preceding
=> Trailer
);
30656 Previous
: constant Node_Id
:= Prev
(Par
);
30657 Prev_Expr
: Node_Id
;
30659 if Nkind
(Previous
) = N_Pragma
and then
30660 Split_PPC
(Previous
)
30662 -- A source-level postcondition of
30663 -- A and then B and then C
30665 -- pragma Postcondition (A);
30666 -- pragma Postcondition (B);
30667 -- pragma Postcondition (C);
30668 -- with Split_PPC set to True on all but the
30669 -- last pragma. We account for that here.
30673 (Pragma_Argument_Associations
(Previous
)));
30675 -- This Analyze call is needed in the case when
30676 -- Sem_Attr.Analyze_Attribute calls
30677 -- Eligible_For_Conditional_Evaluation. Without
30678 -- it, we end up passing an unanalyzed expression
30679 -- to Is_Known_On_Entry and that doesn't work.
30681 Analyze
(Prev_Expr
);
30684 (Expr
=> Prev_Expr
,
30685 Context
=> Short_Circuit_Op
,
30686 Is_And_Then
=> True);
30688 return Determining_Expressions
(Prev_Expr
)
30692 (Get_Pragma_Id
(Pragma_Name
(Par
)) in
30693 Pragma_Post | Pragma_Postcondition
30694 | Pragma_Post_Class | Pragma_Refined_Post
30695 | Pragma_Check | Pragma_Contract_Cases
);
30697 return (1 .. 0 => <>); -- recursion terminates here
30702 -- This case should be impossible, but if it does
30703 -- happen somehow then we don't want an infinite loop.
30704 raise Program_Error
;
30711 Par
:= Parent
(Par
);
30713 if Present
(Next_Element
.Expr
) then
30714 return Determining_Expressions
30715 (Expr
=> Par
, Expr_Trailer
=> Trailer
)
30719 end Determining_Expressions
;
30721 -----------------------------------------
30722 -- Eligible_For_Conditional_Evaluation --
30723 -----------------------------------------
30725 function Eligible_For_Conditional_Evaluation
30726 (Expr
: Node_Id
) return Boolean
30729 if Is_Anonymous_Access_Type
(Etype
(Expr
)) then
30730 -- The code in exp_attr.adb that also builds declarations
30731 -- for 'Old constants doesn't handle the anonymous access
30732 -- type case correctly, so we avoid that problem by
30733 -- returning True here.
30735 elsif Ada_Version
< Ada_2020
then
30737 elsif not Is_Conditionally_Evaluated
(Expr
) then
30741 Determiners
: constant Determining_Expression_List
:=
30742 Determining_Expressions
(Expr
);
30744 pragma Assert
(Determiners
'Length > 0);
30746 for Idx
in Determiners
'Range loop
30747 if not Is_Known_On_Entry
(Determiners
(Idx
).Expr
) then
30754 end Eligible_For_Conditional_Evaluation
;
30756 --------------------------------
30757 -- Is_Conditionally_Evaluated --
30758 --------------------------------
30760 function Is_Conditionally_Evaluated
(Expr
: Node_Id
) return Boolean
30762 -- There are three possibilities - the expression is
30763 -- unconditionally evaluated, repeatedly evaluated, or
30764 -- conditionally evaluated (see RM 6.1.1). So we implement
30765 -- this test by testing for the other two.
30767 function Is_Repeatedly_Evaluated
(Expr
: Node_Id
) return Boolean;
30768 -- See RM 6.1.1 for definition of "repeatedly evaluated".
30770 -----------------------------
30771 -- Is_Repeatedly_Evaluated --
30772 -----------------------------
30774 function Is_Repeatedly_Evaluated
(Expr
: Node_Id
) return Boolean is
30775 Par
: Node_Id
:= Expr
;
30776 Trailer
: Node_Id
:= Empty
;
30778 -- There are three ways that an expression can be repeatedly
30781 -- An aspect_specification is transformed into a pragma, so
30782 -- reaching a pragma is our termination condition. We want to
30783 -- stop when we reach the postcondition expression.
30785 while Nkind
(Par
) /= N_Pragma
loop
30786 pragma Assert
(Present
(Par
));
30788 -- test for case 1:
30789 -- A subexpression of a predicate of a
30790 -- quantified_expression.
30792 if Nkind
(Par
) = N_Quantified_Expression
30793 and then Trailer
= Condition
(Par
)
30798 -- test for cases 2 and 3:
30799 -- A subexpression of the expression of an
30800 -- array_component_association or of
30801 -- a container_element_associatiation.
30803 if Nkind
(Par
) = N_Component_Association
30804 and then Trailer
= Expression
(Par
)
30806 -- determine whether Par is part of an array aggregate
30807 -- or a container aggregate
30809 Rover
: Node_Id
:= Par
;
30811 while Nkind
(Rover
) not in N_Has_Etype
loop
30812 pragma Assert
(Present
(Rover
));
30813 Rover
:= Parent
(Rover
);
30815 if Present
(Etype
(Rover
)) then
30816 if Is_Array_Type
(Etype
(Rover
))
30817 or else Is_Container_Aggregate
(Rover
)
30826 Par
:= Parent
(Par
);
30830 end Is_Repeatedly_Evaluated
;
30833 if not Is_Potentially_Unevaluated
(Expr
) then
30834 -- the expression is unconditionally evaluated
30836 elsif Is_Repeatedly_Evaluated
(Expr
) then
30841 end Is_Conditionally_Evaluated
;
30843 -----------------------
30844 -- Is_Known_On_Entry --
30845 -----------------------
30847 function Is_Known_On_Entry
(Expr
: Node_Id
) return Boolean is
30848 -- ??? This implementation is incomplete. See RM 6.1.1
30849 -- for details. In particular, this function *should* return
30850 -- True for a function call (or a user-defined literal, which
30851 -- is equivalent to a function call) if all actual parameters
30852 -- (including defaulted params) are known on entry and the
30853 -- function has "Globals => null" specified; the current
30854 -- implementation will incorrectly return False in this case.
30856 function All_Exps_Known_On_Entry
30857 (Expr_List
: List_Id
) return Boolean;
30858 -- Given a list of expressions, returns False iff
30859 -- Is_Known_On_Entry is False for at least one list element.
30861 -----------------------------
30862 -- All_Exps_Known_On_Entry --
30863 -----------------------------
30865 function All_Exps_Known_On_Entry
30866 (Expr_List
: List_Id
) return Boolean
30868 Expr
: Node_Id
:= First
(Expr_List
);
30870 while Present
(Expr
) loop
30871 if not Is_Known_On_Entry
(Expr
) then
30877 end All_Exps_Known_On_Entry
;
30880 if Is_Static_Expression
(Expr
) then
30884 if Is_Attribute_Old
(Expr
) then
30889 Pref
: Node_Id
:= Expr
;
30892 case Nkind
(Pref
) is
30893 when N_Selected_Component
=>
30896 when N_Indexed_Component
=>
30897 if not All_Exps_Known_On_Entry
(Expressions
(Pref
))
30903 return False; -- just to be clear about this case
30909 Pref
:= Prefix
(Pref
);
30912 if Is_Entity_Name
(Pref
)
30913 and then Is_Constant_Object
(Entity
(Pref
))
30916 Obj
: constant Entity_Id
:= Entity
(Pref
);
30917 Obj_Typ
: constant Entity_Id
:= Etype
(Obj
);
30919 case Ekind
(Obj
) is
30920 when E_In_Parameter
=>
30921 if not Is_Elementary_Type
(Obj_Typ
) then
30923 elsif Is_Aliased
(Obj
) then
30928 -- return False for a deferred constant
30929 if Present
(Full_View
(Obj
)) then
30933 -- return False if not "all views are constant".
30934 if Is_Immutably_Limited_Type
(Obj_Typ
)
30935 or Needs_Finalization
(Obj_Typ
)
30948 -- ??? Cope with a malformed tree. Code to cope with a
30949 -- nonstatic use of an enumeration literal should not be
30951 if Is_Entity_Name
(Pref
)
30952 and then Ekind
(Entity
(Pref
)) = E_Enumeration_Literal
30958 case Nkind
(Expr
) is
30960 return Is_Known_On_Entry
(Right_Opnd
(Expr
));
30962 when N_Binary_Op
=>
30963 return Is_Known_On_Entry
(Left_Opnd
(Expr
))
30964 and then Is_Known_On_Entry
(Right_Opnd
(Expr
));
30966 when N_Type_Conversion | N_Qualified_Expression
=>
30967 return Is_Known_On_Entry
(Expression
(Expr
));
30969 when N_If_Expression
=>
30970 if not All_Exps_Known_On_Entry
(Expressions
(Expr
)) then
30974 when N_Case_Expression
=>
30975 if not Is_Known_On_Entry
(Expression
(Expr
)) then
30980 Alt
: Node_Id
:= First
(Alternatives
(Expr
));
30982 while Present
(Alt
) loop
30983 if not Is_Known_On_Entry
(Expression
(Alt
)) then
30997 end Is_Known_On_Entry
;
30999 end Conditional_Evaluation
;
31001 package body Indirect_Temps
is
31003 Indirect_Temp_Access_Type_Char
: constant Character := 'K';
31004 -- The character passed to Make_Temporary when declaring
31005 -- the access type that is used in the implementation of an
31006 -- indirect temporary.
31008 --------------------------
31009 -- Indirect_Temp_Needed --
31010 --------------------------
31012 function Indirect_Temp_Needed
(Typ
: Entity_Id
) return Boolean is
31014 -- There should be no correctness issues if the only cases where
31015 -- this function returns False are cases where Typ is an
31016 -- anonymous access type and we need to generate a saooaaat (a
31017 -- stand-alone object of an anonymous access type) in order get
31018 -- accessibility right. In other cases where this function
31019 -- returns False, there would be no correctness problems with
31020 -- returning True instead; however, returning False when we can
31021 -- generally results in simpler code.
31025 -- If Typ is not definite, then we cannot generate
31028 or else not Is_Definite_Subtype
(Typ
)
31030 -- If Typ is tagged, then generating
31032 -- might generate an object with the wrong tag. If we had
31033 -- a predicate that indicated whether the nominal tag is
31034 -- trustworthy, we could use that predicate here.
31036 or else Is_Tagged_Type
(Typ
)
31038 -- If Typ needs finalization, then generating an implicit
31040 -- declaration could have user-visible side effects.
31042 or else Needs_Finalization
(Typ
)
31044 -- In the anonymous access type case, we need to
31045 -- generate a saooaaat. We don't want the code in
31046 -- in exp_attr.adb that deals with the case where this
31047 -- function returns False to have to deal with that case
31048 -- (just to avoid code duplication). So we cheat a little
31049 -- bit and return True here for an anonymous access type.
31051 or else Is_Anonymous_Access_Type
(Typ
);
31053 -- ??? Unimplemented - spec description says:
31054 -- For an unconstrained-but-definite discriminated subtype,
31055 -- returns True if the potential difference in size between an
31056 -- unconstrained object and a constrained object is large.
31059 -- type Typ (Len : Natural := 0) is
31060 -- record F : String (1 .. Len); end record;
31062 -- See Large_Max_Size_Mutable function elsewhere in this
31063 -- file (currently declared inside of
31064 -- Requires_Transient_Scope, so it would have to be
31065 -- moved if we want it to be callable from here).
31067 end Indirect_Temp_Needed
;
31069 ---------------------------
31070 -- Declare_Indirect_Temp --
31071 ---------------------------
31073 procedure Declare_Indirect_Temp
31074 (Attr_Prefix
: Node_Id
; Indirect_Temp
: out Entity_Id
)
31076 Loc
: constant Source_Ptr
:= Sloc
(Attr_Prefix
);
31077 Prefix_Type
: constant Entity_Id
:= Etype
(Attr_Prefix
);
31078 Temp_Id
: constant Entity_Id
:=
31079 Make_Temporary
(Loc
, 'P', Attr_Prefix
);
31081 procedure Declare_Indirect_Temp_Via_Allocation
;
31082 -- Handle the usual case.
31084 -------------------------------------------
31085 -- Declare_Indirect_Temp_Via_Allocation --
31086 -------------------------------------------
31088 procedure Declare_Indirect_Temp_Via_Allocation
is
31089 Access_Type_Id
: constant Entity_Id
31091 (Loc
, Indirect_Temp_Access_Type_Char
, Attr_Prefix
);
31093 Temp_Decl
: constant Node_Id
:=
31094 Make_Object_Declaration
(Loc
,
31095 Defining_Identifier
=> Temp_Id
,
31096 Object_Definition
=>
31097 New_Occurrence_Of
(Access_Type_Id
, Loc
));
31099 Allocate_Class_Wide
: constant Boolean :=
31100 Is_Specific_Tagged_Type
(Prefix_Type
);
31101 -- If True then access type designates the class-wide type in
31102 -- order to preserve (at run time) the value of the underlying
31104 -- ??? We could do better here (in the case where Prefix_Type
31105 -- is tagged and specific) if we had a predicate which takes an
31106 -- expression and returns True iff the expression is of
31107 -- a specific tagged type and the underlying tag (at run time)
31108 -- is statically known to match that of the specific type.
31109 -- In that case, Allocate_Class_Wide could safely be False.
31111 function Designated_Subtype_Mark
return Node_Id
;
31112 -- Usually, a subtype mark indicating the subtype of the
31113 -- attribute prefix. If that subtype is a specific tagged
31114 -- type, then returns the corresponding class-wide type.
31115 -- If the prefix is of an anonymous access type, then returns
31116 -- the designated type of that type.
31118 -----------------------------
31119 -- Designated_Subtype_Mark --
31120 -----------------------------
31122 function Designated_Subtype_Mark
return Node_Id
is
31123 Typ
: Entity_Id
:= Prefix_Type
;
31125 if Allocate_Class_Wide
then
31126 if Is_Private_Type
(Typ
)
31127 and then Present
(Full_View
(Typ
))
31129 Typ
:= Full_View
(Typ
);
31131 Typ
:= Class_Wide_Type
(Typ
);
31134 return New_Occurrence_Of
(Typ
, Loc
);
31135 end Designated_Subtype_Mark
;
31137 Access_Type_Def
: constant Node_Id
31138 := Make_Access_To_Object_Definition
31139 (Loc
, Subtype_Indication
=> Designated_Subtype_Mark
);
31141 Access_Type_Decl
: constant Node_Id
31142 := Make_Full_Type_Declaration
31143 (Loc
, Access_Type_Id
,
31144 Type_Definition
=> Access_Type_Def
);
31146 Set_Ekind
(Temp_Id
, E_Variable
);
31147 Set_Etype
(Temp_Id
, Access_Type_Id
);
31148 Set_Ekind
(Access_Type_Id
, E_Access_Type
);
31150 if Append_Decls_In_Reverse_Order
then
31151 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31152 Append_Item
(Access_Type_Decl
, Is_Eval_Stmt
=> False);
31154 Append_Item
(Access_Type_Decl
, Is_Eval_Stmt
=> False);
31155 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31158 -- When a type associated with an indirect temporary gets
31159 -- created for a 'Old attribute reference we need to mark
31160 -- the type as such. This allows, for example, finalization
31161 -- masters associated with them to be finalized in the correct
31162 -- order after postcondition checks.
31164 if Attribute_Name
(Parent
(Attr_Prefix
)) = Name_Old
then
31165 Set_Stores_Attribute_Old_Prefix
(Access_Type_Id
);
31168 Analyze
(Access_Type_Decl
);
31169 Analyze
(Temp_Decl
);
31172 (Is_Access_Type_For_Indirect_Temp
(Access_Type_Id
));
31175 Expression
: Node_Id
:= Attr_Prefix
;
31176 Allocator
: Node_Id
;
31178 if Allocate_Class_Wide
then
31179 -- generate T'Class'(T'Class (<prefix>))
31181 Make_Type_Conversion
(Loc
,
31182 Subtype_Mark
=> Designated_Subtype_Mark
,
31183 Expression
=> Expression
);
31187 Make_Allocator
(Loc
,
31188 Make_Qualified_Expression
31190 Subtype_Mark
=> Designated_Subtype_Mark
,
31191 Expression
=> Expression
));
31193 -- Allocate saved prefix value on the secondary stack
31194 -- in order to avoid introducing a storage leak. This
31195 -- allocated object is never explicitly reclaimed.
31197 -- ??? Emit storage leak warning if RE_SS_Pool
31200 if RTE_Available
(RE_SS_Pool
) then
31201 Set_Storage_Pool
(Allocator
, RTE
(RE_SS_Pool
));
31202 Set_Procedure_To_Call
31203 (Allocator
, RTE
(RE_SS_Allocate
));
31204 Set_Uses_Sec_Stack
(Current_Scope
);
31208 (Make_Assignment_Statement
(Loc
,
31209 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
31210 Expression
=> Allocator
),
31211 Is_Eval_Stmt
=> True);
31213 end Declare_Indirect_Temp_Via_Allocation
;
31216 Indirect_Temp
:= Temp_Id
;
31218 if Is_Anonymous_Access_Type
(Prefix_Type
) then
31219 -- In the anonymous access type case, we do not want a level
31220 -- indirection (which would result in declaring an
31221 -- access-to-access type); that would result in correctness
31222 -- problems - the accessibility level of the type of the
31223 -- 'Old constant would be wrong (See 6.1.1.). So in that case,
31224 -- we do not generate an allocator. Instead we generate
31225 -- Temp : access Designated := null;
31226 -- which is unconditionally elaborated and then
31227 -- Temp := <attribute prefix>;
31228 -- which is conditionally executed.
31231 Temp_Decl
: constant Node_Id
:=
31232 Make_Object_Declaration
(Loc
,
31233 Defining_Identifier
=> Temp_Id
,
31234 Object_Definition
=>
31235 Make_Access_Definition
31237 Constant_Present
=>
31238 Is_Access_Constant
(Prefix_Type
),
31241 (Designated_Type
(Prefix_Type
), Loc
)));
31243 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31244 Analyze
(Temp_Decl
);
31246 (Make_Assignment_Statement
(Loc
,
31247 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
31248 Expression
=> Attr_Prefix
),
31249 Is_Eval_Stmt
=> True);
31253 Declare_Indirect_Temp_Via_Allocation
;
31255 end Declare_Indirect_Temp
;
31257 -------------------------
31258 -- Indirect_Temp_Value --
31259 -------------------------
31261 function Indirect_Temp_Value
31264 Loc
: Source_Ptr
) return Node_Id
31268 if Is_Anonymous_Access_Type
(Typ
) then
31269 -- No indirection in this case; just evaluate the temp.
31270 Result
:= New_Occurrence_Of
(Temp
, Loc
);
31271 Set_Etype
(Result
, Etype
(Temp
));
31274 Result
:= Make_Explicit_Dereference
(Loc
,
31275 New_Occurrence_Of
(Temp
, Loc
));
31277 Set_Etype
(Result
, Designated_Type
(Etype
(Temp
)));
31279 if Is_Specific_Tagged_Type
(Typ
) then
31280 -- The designated type of the access type is class-wide, so
31281 -- convert to the specific type.
31284 Make_Type_Conversion
(Loc
,
31285 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
31286 Expression
=> Result
);
31288 Set_Etype
(Result
, Typ
);
31293 end Indirect_Temp_Value
;
31295 function Is_Access_Type_For_Indirect_Temp
31296 (T
: Entity_Id
) return Boolean is
31298 if Is_Access_Type
(T
)
31299 and then not Comes_From_Source
(T
)
31300 and then Is_Internal_Name
(Chars
(T
))
31301 and then Nkind
(Scope
(T
)) in N_Entity
31302 and then Ekind
(Scope
(T
))
31303 in E_Entry | E_Entry_Family | E_Function | E_Procedure
31305 (Present
(Postconditions_Proc
(Scope
(T
)))
31306 or else Present
(Contract
(Scope
(T
))))
31308 -- ??? Should define a flag for this. We could incorrectly
31309 -- return True if other clients of Make_Temporary happen to
31310 -- pass in the same character.
31312 Name
: constant String := Get_Name_String
(Chars
(T
));
31314 if Name
(Name
'First) = Indirect_Temp_Access_Type_Char
then
31320 end Is_Access_Type_For_Indirect_Temp
;
31322 end Indirect_Temps
;
31325 Erroutc
.Subprogram_Name_Ptr
:= Subprogram_Name
'Access;