1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Accessibility
; use Accessibility
;
27 with Casing
; use Casing
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
.Utils
; use Einfo
.Utils
;
31 with Elists
; use Elists
;
32 with Errout
; use Errout
;
33 with Erroutc
; use Erroutc
;
34 with Exp_Ch6
; use Exp_Ch6
;
35 with Exp_Ch11
; use Exp_Ch11
;
36 with Exp_Util
; use Exp_Util
;
37 with Fname
; use Fname
;
38 with Freeze
; use Freeze
;
39 with Itypes
; use Itypes
;
41 with Lib
.Xref
; use Lib
.Xref
;
42 with Namet
.Sp
; use Namet
.Sp
;
43 with Nlists
; use Nlists
;
44 with Nmake
; use Nmake
;
45 with Output
; use Output
;
46 with Restrict
; use Restrict
;
47 with Rident
; use Rident
;
48 with Rtsfind
; use Rtsfind
;
50 with Sem_Aux
; use Sem_Aux
;
51 with Sem_Attr
; use Sem_Attr
;
52 with Sem_Cat
; use Sem_Cat
;
53 with Sem_Ch6
; use Sem_Ch6
;
54 with Sem_Ch8
; use Sem_Ch8
;
55 with Sem_Ch13
; use Sem_Ch13
;
56 with Sem_Disp
; use Sem_Disp
;
57 with Sem_Elab
; use Sem_Elab
;
58 with Sem_Eval
; use Sem_Eval
;
59 with Sem_Prag
; use Sem_Prag
;
60 with Sem_Res
; use Sem_Res
;
61 with Sem_Warn
; use Sem_Warn
;
62 with Sem_Type
; use Sem_Type
;
63 with Sinfo
; use Sinfo
;
64 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
65 with Sinfo
.Utils
; use Sinfo
.Utils
;
66 with Sinput
; use Sinput
;
67 with Stand
; use Stand
;
69 with Stringt
; use Stringt
;
70 with Targparm
; use Targparm
;
71 with Tbuild
; use Tbuild
;
72 with Ttypes
; use Ttypes
;
73 with Uname
; use Uname
;
74 with Warnsw
; use Warnsw
;
76 with GNAT
.Heap_Sort_G
;
77 with GNAT
.HTable
; use GNAT
.HTable
;
79 package body Sem_Util
is
81 ---------------------------
82 -- Local Data Structures --
83 ---------------------------
85 Invalid_Binder_Values
: array (Scalar_Id
) of Entity_Id
:= (others => Empty
);
86 -- A collection to hold the entities of the variables declared in package
87 -- System.Scalar_Values which describe the invalid values of scalar types.
89 Invalid_Binder_Values_Set
: Boolean := False;
90 -- This flag prevents multiple attempts to initialize Invalid_Binder_Values
92 Invalid_Floats
: array (Float_Scalar_Id
) of Ureal
:= (others => No_Ureal
);
93 -- A collection to hold the invalid values of float types as specified by
94 -- pragma Initialize_Scalars.
96 Invalid_Integers
: array (Integer_Scalar_Id
) of Uint
:= (others => No_Uint
);
97 -- A collection to hold the invalid values of integer types as specified
98 -- by pragma Initialize_Scalars.
100 -----------------------
101 -- Local Subprograms --
102 -----------------------
104 function Build_Component_Subtype
107 T
: Entity_Id
) return Node_Id
;
108 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
109 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
110 -- Loc is the source location, T is the original subtype.
112 procedure Examine_Array_Bounds
114 All_Static
: out Boolean;
115 Has_Empty
: out Boolean);
116 -- Inspect the index constraints of array type Typ. Flag All_Static is set
117 -- when all ranges are static. Flag Has_Empty is set only when All_Static
118 -- is set and indicates that at least one range is empty.
120 function Has_Enabled_Property
121 (Item_Id
: Entity_Id
;
122 Property
: Name_Id
) return Boolean;
123 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
124 -- Determine whether the state abstraction, object, or type denoted by
125 -- entity Item_Id has enabled property Property.
127 function Has_Null_Extension
(T
: Entity_Id
) return Boolean;
128 -- T is a derived tagged type. Check whether the type extension is null.
129 -- If the parent type is fully initialized, T can be treated as such.
131 function Is_Atomic_Object_Entity
(Id
: Entity_Id
) return Boolean;
132 -- Determine whether arbitrary entity Id denotes an atomic object as per
135 function Is_Container_Aggregate
(Exp
: Node_Id
) return Boolean;
136 -- Is the given expression a container aggregate?
139 with function Is_Effectively_Volatile_Entity
140 (Id
: Entity_Id
) return Boolean;
141 -- Function to use on object and type entities
142 function Is_Effectively_Volatile_Object_Shared
143 (N
: Node_Id
) return Boolean;
144 -- Shared function used to detect effectively volatile objects and
145 -- effectively volatile objects for reading.
147 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean;
148 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
149 -- with discriminants whose default values are static, examine only the
150 -- components in the selected variant to determine whether all of them
153 function Is_Preelaborable_Function
(Id
: Entity_Id
) return Boolean;
154 -- Ada 2022: Determine whether the specified function is suitable as the
155 -- name of a call in a preelaborable construct (RM 10.2.1(7/5)).
157 type Null_Status_Kind
is
159 -- This value indicates that a subexpression is known to have a null
160 -- value at compile time.
163 -- This value indicates that a subexpression is known to have a non-null
164 -- value at compile time.
167 -- This value indicates that it cannot be determined at compile time
168 -- whether a subexpression yields a null or non-null value.
170 function Null_Status
(N
: Node_Id
) return Null_Status_Kind
;
171 -- Determine whether subexpression N of an access type yields a null value,
172 -- a non-null value, or the value cannot be determined at compile time. The
173 -- routine does not take simple flow diagnostics into account, it relies on
174 -- static facts such as the presence of null exclusions.
176 function Subprogram_Name
(N
: Node_Id
) return String;
177 -- Return the fully qualified name of the enclosing subprogram for the
178 -- given node N, with file:line:col information appended, e.g.
179 -- "subp:file:line:col", corresponding to the source location of the
180 -- body of the subprogram.
182 -----------------------------
183 -- Abstract_Interface_List --
184 -----------------------------
186 function Abstract_Interface_List
(Typ
: Entity_Id
) return List_Id
is
190 if Is_Concurrent_Type
(Typ
) then
192 -- If we are dealing with a synchronized subtype, go to the base
193 -- type, whose declaration has the interface list.
195 Nod
:= Declaration_Node
(Base_Type
(Typ
));
197 if Nkind
(Nod
) in N_Full_Type_Declaration | N_Private_Type_Declaration
202 elsif Ekind
(Typ
) = E_Record_Type_With_Private
then
203 if Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
then
204 Nod
:= Type_Definition
(Parent
(Typ
));
206 elsif Nkind
(Parent
(Typ
)) = N_Private_Type_Declaration
then
207 if Present
(Full_View
(Typ
))
209 Nkind
(Parent
(Full_View
(Typ
))) = N_Full_Type_Declaration
211 Nod
:= Type_Definition
(Parent
(Full_View
(Typ
)));
213 -- If the full-view is not available we cannot do anything else
214 -- here (the source has errors).
220 -- Support for generic formals with interfaces is still missing ???
222 elsif Nkind
(Parent
(Typ
)) = N_Formal_Type_Declaration
then
227 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
);
231 elsif Ekind
(Typ
) = E_Record_Subtype
then
232 Nod
:= Type_Definition
(Parent
(Etype
(Typ
)));
234 elsif Ekind
(Typ
) = E_Record_Subtype_With_Private
then
236 -- Recurse, because parent may still be a private extension. Also
237 -- note that the full view of the subtype or the full view of its
238 -- base type may (both) be unavailable.
240 return Abstract_Interface_List
(Etype
(Typ
));
242 elsif Ekind
(Typ
) = E_Record_Type
then
243 if Nkind
(Parent
(Typ
)) = N_Formal_Type_Declaration
then
244 Nod
:= Formal_Type_Definition
(Parent
(Typ
));
246 Nod
:= Type_Definition
(Parent
(Typ
));
249 -- Otherwise the type is of a kind which does not implement interfaces
255 return Interface_List
(Nod
);
256 end Abstract_Interface_List
;
258 ----------------------------------
259 -- Acquire_Warning_Match_String --
260 ----------------------------------
262 function Acquire_Warning_Match_String
(Str_Lit
: Node_Id
) return String is
263 S
: constant String := To_String
(Strval
(Str_Lit
));
268 -- Put "*" before or after or both, if it's not already there
271 F
: constant Boolean := S
(S
'First) = '*';
272 L
: constant Boolean := S
(S
'Last) = '*';
284 return "*" & S
& "*";
289 end Acquire_Warning_Match_String
;
291 --------------------------------
292 -- Add_Access_Type_To_Process --
293 --------------------------------
295 procedure Add_Access_Type_To_Process
(E
: Entity_Id
; A
: Entity_Id
) is
299 Ensure_Freeze_Node
(E
);
300 L
:= Access_Types_To_Process
(Freeze_Node
(E
));
304 Set_Access_Types_To_Process
(Freeze_Node
(E
), L
);
308 end Add_Access_Type_To_Process
;
310 --------------------------
311 -- Add_Block_Identifier --
312 --------------------------
314 procedure Add_Block_Identifier
317 Scope
: Entity_Id
:= Current_Scope
)
319 Loc
: constant Source_Ptr
:= Sloc
(N
);
321 pragma Assert
(Nkind
(N
) = N_Block_Statement
);
323 -- The block already has a label, return its entity
325 if Present
(Identifier
(N
)) then
326 Id
:= Entity
(Identifier
(N
));
328 -- Create a new block label and set its attributes
331 Id
:= New_Internal_Entity
(E_Block
, Scope
, Loc
, 'B');
332 Set_Etype
(Id
, Standard_Void_Type
);
335 Set_Identifier
(N
, New_Occurrence_Of
(Id
, Loc
));
336 Set_Block_Node
(Id
, Identifier
(N
));
338 end Add_Block_Identifier
;
340 ----------------------------
341 -- Add_Global_Declaration --
342 ----------------------------
344 procedure Add_Global_Declaration
(N
: Node_Id
) is
345 Aux_Node
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Current_Sem_Unit
));
348 if No
(Declarations
(Aux_Node
)) then
349 Set_Declarations
(Aux_Node
, New_List
);
352 Append_To
(Declarations
(Aux_Node
), N
);
354 end Add_Global_Declaration
;
356 --------------------------------
357 -- Address_Integer_Convert_OK --
358 --------------------------------
360 function Address_Integer_Convert_OK
(T1
, T2
: Entity_Id
) return Boolean is
362 if Allow_Integer_Address
363 and then ((Is_Descendant_Of_Address
(T1
)
364 and then Is_Private_Type
(T1
)
365 and then Is_Integer_Type
(T2
))
367 (Is_Descendant_Of_Address
(T2
)
368 and then Is_Private_Type
(T2
)
369 and then Is_Integer_Type
(T1
)))
375 end Address_Integer_Convert_OK
;
381 function Address_Value
(N
: Node_Id
) return Node_Id
is
386 -- For constant, get constant expression
388 if Is_Entity_Name
(Expr
)
389 and then Ekind
(Entity
(Expr
)) = E_Constant
391 Expr
:= Constant_Value
(Entity
(Expr
));
393 -- For unchecked conversion, get result to convert
395 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
396 Expr
:= Expression
(Expr
);
398 -- For (common case) of To_Address call, get argument
400 elsif Nkind
(Expr
) = N_Function_Call
401 and then Is_Entity_Name
(Name
(Expr
))
402 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
404 Expr
:= First_Actual
(Expr
);
406 -- We finally have the real expression
420 function Addressable
(V
: Uint
) return Boolean is
426 return V
= Uint_8
or else
430 (V
= Uint_128
and then System_Max_Integer_Size
= 128);
433 function Addressable
(V
: Int
) return Boolean is
439 V
= System_Max_Integer_Size
;
442 ---------------------------------
443 -- Aggregate_Constraint_Checks --
444 ---------------------------------
446 procedure Aggregate_Constraint_Checks
448 Check_Typ
: Entity_Id
)
450 Exp_Typ
: constant Entity_Id
:= Etype
(Exp
);
453 if Raises_Constraint_Error
(Exp
) then
457 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access
458 -- component's type to force the appropriate accessibility checks.
460 -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to
461 -- force the corresponding run-time check
463 if Is_Access_Type
(Check_Typ
)
464 and then Is_Local_Anonymous_Access
(Check_Typ
)
466 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
467 Analyze_And_Resolve
(Exp
, Check_Typ
);
468 Check_Unset_Reference
(Exp
);
471 -- What follows is really expansion activity, so check that expansion
472 -- is on and is allowed. In GNATprove mode, we also want check flags to
473 -- be added in the tree, so that the formal verification can rely on
474 -- those to be present. In GNATprove mode for formal verification, some
475 -- treatment typically only done during expansion needs to be performed
476 -- on the tree, but it should not be applied inside generics. Otherwise,
477 -- this breaks the name resolution mechanism for generic instances.
479 if not Expander_Active
480 and (Inside_A_Generic
or not Full_Analysis
or not GNATprove_Mode
)
485 if Is_Access_Type
(Check_Typ
)
486 and then Can_Never_Be_Null
(Check_Typ
)
487 and then not Can_Never_Be_Null
(Exp_Typ
)
489 Install_Null_Excluding_Check
(Exp
);
492 -- First check if we have to insert discriminant checks
494 if Has_Discriminants
(Exp_Typ
) then
495 Apply_Discriminant_Check
(Exp
, Check_Typ
);
497 -- Next emit length checks for array aggregates
499 elsif Is_Array_Type
(Exp_Typ
) then
500 Apply_Length_Check
(Exp
, Check_Typ
);
502 -- Finally emit scalar and string checks. If we are dealing with a
503 -- scalar literal we need to check by hand because the Etype of
504 -- literals is not necessarily correct.
506 elsif Is_Scalar_Type
(Exp_Typ
)
507 and then Compile_Time_Known_Value
(Exp
)
509 if Is_Out_Of_Range
(Exp
, Base_Type
(Check_Typ
)) then
510 Apply_Compile_Time_Constraint_Error
511 (Exp
, "value not in range of}??", CE_Range_Check_Failed
,
512 Ent
=> Base_Type
(Check_Typ
),
513 Typ
=> Base_Type
(Check_Typ
));
515 elsif Is_Out_Of_Range
(Exp
, Check_Typ
) then
516 Apply_Compile_Time_Constraint_Error
517 (Exp
, "value not in range of}??", CE_Range_Check_Failed
,
521 elsif not Range_Checks_Suppressed
(Check_Typ
) then
522 Apply_Scalar_Range_Check
(Exp
, Check_Typ
);
525 -- Verify that target type is also scalar, to prevent view anomalies
526 -- in instantiations.
528 elsif (Is_Scalar_Type
(Exp_Typ
)
529 or else Nkind
(Exp
) = N_String_Literal
)
530 and then Is_Scalar_Type
(Check_Typ
)
531 and then Exp_Typ
/= Check_Typ
533 -- If expression is a constant, it is worthwhile checking whether it
534 -- is a bound of the type.
536 if Is_Entity_Name
(Exp
)
537 and then Ekind
(Entity
(Exp
)) = E_Constant
539 if (Is_Entity_Name
(Type_Low_Bound
(Check_Typ
))
540 and then Entity
(Exp
) = Entity
(Type_Low_Bound
(Check_Typ
)))
542 (Is_Entity_Name
(Type_High_Bound
(Check_Typ
))
543 and then Entity
(Exp
) = Entity
(Type_High_Bound
(Check_Typ
)))
549 -- Change Exp into Check_Typ'(Exp) to ensure that range checks are
550 -- performed at run time.
552 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
553 Analyze_And_Resolve
(Exp
, Check_Typ
);
554 Check_Unset_Reference
(Exp
);
557 end Aggregate_Constraint_Checks
;
559 -----------------------
560 -- Alignment_In_Bits --
561 -----------------------
563 function Alignment_In_Bits
(E
: Entity_Id
) return Uint
is
565 return Alignment
(E
) * System_Storage_Unit
;
566 end Alignment_In_Bits
;
568 --------------------------------------
569 -- All_Composite_Constraints_Static --
570 --------------------------------------
572 function All_Composite_Constraints_Static
573 (Constr
: Node_Id
) return Boolean
576 if No
(Constr
) or else Error_Posted
(Constr
) then
580 case Nkind
(Constr
) is
582 if Nkind
(Constr
) in N_Has_Entity
583 and then Present
(Entity
(Constr
))
585 if Is_Type
(Entity
(Constr
)) then
587 not Is_Discrete_Type
(Entity
(Constr
))
588 or else Is_OK_Static_Subtype
(Entity
(Constr
));
591 elsif Nkind
(Constr
) = N_Range
then
593 Is_OK_Static_Expression
(Low_Bound
(Constr
))
595 Is_OK_Static_Expression
(High_Bound
(Constr
));
597 elsif Nkind
(Constr
) = N_Attribute_Reference
598 and then Attribute_Name
(Constr
) = Name_Range
601 Is_OK_Static_Expression
602 (Type_Low_Bound
(Etype
(Prefix
(Constr
))))
604 Is_OK_Static_Expression
605 (Type_High_Bound
(Etype
(Prefix
(Constr
))));
609 No
(Etype
(Constr
)) -- previous error
610 or else not Is_Discrete_Type
(Etype
(Constr
))
611 or else Is_OK_Static_Expression
(Constr
);
613 when N_Discriminant_Association
=>
614 return All_Composite_Constraints_Static
(Expression
(Constr
));
616 when N_Range_Constraint
=>
618 All_Composite_Constraints_Static
(Range_Expression
(Constr
));
620 when N_Index_Or_Discriminant_Constraint
=>
622 One_Cstr
: Entity_Id
;
624 One_Cstr
:= First
(Constraints
(Constr
));
625 while Present
(One_Cstr
) loop
626 if not All_Composite_Constraints_Static
(One_Cstr
) then
636 when N_Subtype_Indication
=>
638 All_Composite_Constraints_Static
(Subtype_Mark
(Constr
))
640 All_Composite_Constraints_Static
(Constraint
(Constr
));
645 end All_Composite_Constraints_Static
;
647 ------------------------
648 -- Append_Entity_Name --
649 ------------------------
651 procedure Append_Entity_Name
(Buf
: in out Bounded_String
; E
: Entity_Id
) is
652 Temp
: Bounded_String
;
654 procedure Inner
(E
: Entity_Id
);
655 -- Inner recursive routine, keep outer routine nonrecursive to ease
656 -- debugging when we get strange results from this routine.
662 procedure Inner
(E
: Entity_Id
) is
666 -- If entity has an internal name, skip by it, and print its scope.
667 -- Note that we strip a final R from the name before the test; this
668 -- is needed for some cases of instantiations.
671 E_Name
: Bounded_String
;
674 Append
(E_Name
, Chars
(E
));
676 if E_Name
.Chars
(E_Name
.Length
) = 'R' then
677 E_Name
.Length
:= E_Name
.Length
- 1;
680 if Is_Internal_Name
(E_Name
) then
688 -- Just print entity name if its scope is at the outer level
690 if Scop
= Standard_Standard
then
693 -- If scope comes from source, write scope and entity
695 elsif Comes_From_Source
(Scop
) then
696 Append_Entity_Name
(Temp
, Scop
);
699 -- If in wrapper package skip past it
701 elsif Present
(Scop
) and then Is_Wrapper_Package
(Scop
) then
702 Append_Entity_Name
(Temp
, Scope
(Scop
));
705 -- Otherwise nothing to output (happens in unnamed block statements)
714 E_Name
: Bounded_String
;
717 Append_Unqualified_Decoded
(E_Name
, Chars
(E
));
719 -- Remove trailing upper-case letters from the name (useful for
720 -- dealing with some cases of internal names generated in the case
721 -- of references from within a generic).
723 while E_Name
.Length
> 1
724 and then E_Name
.Chars
(E_Name
.Length
) in 'A' .. 'Z'
726 E_Name
.Length
:= E_Name
.Length
- 1;
729 -- Adjust casing appropriately (gets name from source if possible)
731 Adjust_Name_Case
(E_Name
, Sloc
(E
));
732 Append
(Temp
, E_Name
);
736 -- Start of processing for Append_Entity_Name
741 end Append_Entity_Name
;
743 ---------------------------------
744 -- Append_Inherited_Subprogram --
745 ---------------------------------
747 procedure Append_Inherited_Subprogram
(S
: Entity_Id
) is
748 Par
: constant Entity_Id
:= Alias
(S
);
749 -- The parent subprogram
751 Scop
: constant Entity_Id
:= Scope
(Par
);
752 -- The scope of definition of the parent subprogram
754 Typ
: constant Entity_Id
:= Defining_Entity
(Parent
(S
));
755 -- The derived type of which S is a primitive operation
761 if Ekind
(Current_Scope
) = E_Package
762 and then In_Private_Part
(Current_Scope
)
763 and then Has_Private_Declaration
(Typ
)
764 and then Is_Tagged_Type
(Typ
)
765 and then Scop
= Current_Scope
767 -- The inherited operation is available at the earliest place after
768 -- the derived type declaration (RM 7.3.1 (6/1)). This is only
769 -- relevant for type extensions. If the parent operation appears
770 -- after the type extension, the operation is not visible.
773 (Visible_Declarations
774 (Package_Specification
(Current_Scope
)));
775 while Present
(Decl
) loop
776 if Nkind
(Decl
) = N_Private_Extension_Declaration
777 and then Defining_Entity
(Decl
) = Typ
779 if Sloc
(Decl
) > Sloc
(Par
) then
780 Next_E
:= Next_Entity
(Par
);
781 Link_Entities
(Par
, S
);
782 Link_Entities
(S
, Next_E
);
794 -- If partial view is not a type extension, or it appears before the
795 -- subprogram declaration, insert normally at end of entity list.
797 Append_Entity
(S
, Current_Scope
);
798 end Append_Inherited_Subprogram
;
800 -----------------------------------------
801 -- Apply_Compile_Time_Constraint_Error --
802 -----------------------------------------
804 procedure Apply_Compile_Time_Constraint_Error
807 Reason
: RT_Exception_Code
;
808 Ent
: Entity_Id
:= Empty
;
809 Typ
: Entity_Id
:= Empty
;
810 Loc
: Source_Ptr
:= No_Location
;
811 Warn
: Boolean := False;
812 Emit_Message
: Boolean := True)
814 Stat
: constant Boolean := Is_Static_Expression
(N
);
815 R_Stat
: constant Node_Id
:=
816 Make_Raise_Constraint_Error
(Sloc
(N
), Reason
=> Reason
);
828 (Compile_Time_Constraint_Error
(N
, Msg
, Ent
, Loc
, Warn
=> Warn
));
831 -- Now we replace the node by an N_Raise_Constraint_Error node
832 -- This does not need reanalyzing, so set it as analyzed now.
835 Set_Analyzed
(N
, True);
838 Set_Raises_Constraint_Error
(N
);
840 -- Now deal with possible local raise handling
842 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
844 -- If the original expression was marked as static, the result is
845 -- still marked as static, but the Raises_Constraint_Error flag is
846 -- always set so that further static evaluation is not attempted.
849 Set_Is_Static_Expression
(N
);
851 end Apply_Compile_Time_Constraint_Error
;
853 ---------------------------
854 -- Async_Readers_Enabled --
855 ---------------------------
857 function Async_Readers_Enabled
(Id
: Entity_Id
) return Boolean is
859 return Has_Enabled_Property
(Id
, Name_Async_Readers
);
860 end Async_Readers_Enabled
;
862 ---------------------------
863 -- Async_Writers_Enabled --
864 ---------------------------
866 function Async_Writers_Enabled
(Id
: Entity_Id
) return Boolean is
868 return Has_Enabled_Property
(Id
, Name_Async_Writers
);
869 end Async_Writers_Enabled
;
871 --------------------------------------
872 -- Available_Full_View_Of_Component --
873 --------------------------------------
875 function Available_Full_View_Of_Component
(T
: Entity_Id
) return Boolean is
876 ST
: constant Entity_Id
:= Scope
(T
);
877 SCT
: constant Entity_Id
:= Scope
(Component_Type
(T
));
879 return In_Open_Scopes
(ST
)
880 and then In_Open_Scopes
(SCT
)
881 and then Scope_Depth
(ST
) >= Scope_Depth
(SCT
);
882 end Available_Full_View_Of_Component
;
891 Warn
: Boolean := False)
894 Error_Msg_Warn
:= Warn
;
895 Error_Msg_N
("<<& is not a valid aspect identifier", N
);
897 -- Check bad spelling
898 Error_Msg_Name_1
:= Aspect_Spell_Check
(Nam
);
899 if Error_Msg_Name_1
/= No_Name
then
900 Error_Msg_N
-- CODEFIX
901 ("\<<possible misspelling of %", N
);
909 procedure Bad_Attribute
912 Warn
: Boolean := False)
915 Error_Msg_Warn
:= Warn
;
916 Error_Msg_N
("<<unrecognized attribute&", N
);
918 -- Check for possible misspelling
920 Error_Msg_Name_1
:= Attribute_Spell_Check
(Nam
);
921 if Error_Msg_Name_1
/= No_Name
then
922 Error_Msg_N
-- CODEFIX
923 ("\<<possible misspelling of %", N
);
927 --------------------------------
928 -- Bad_Predicated_Subtype_Use --
929 --------------------------------
931 procedure Bad_Predicated_Subtype_Use
935 Suggest_Static
: Boolean := False)
940 -- Avoid cascaded errors
942 if Error_Posted
(N
) then
946 if Inside_A_Generic
then
947 Gen
:= Current_Scope
;
948 while Present
(Gen
) and then Ekind
(Gen
) /= E_Generic_Package
loop
956 if Is_Generic_Formal
(Typ
) and then Is_Discrete_Type
(Typ
) then
957 Set_No_Predicate_On_Actual
(Typ
);
960 elsif Has_Predicates
(Typ
) then
961 if Is_Generic_Actual_Type
(Typ
) then
963 -- The restriction on loop parameters is only that the type
964 -- should have no dynamic predicates.
966 if Nkind
(Parent
(N
)) = N_Loop_Parameter_Specification
967 and then not Has_Dynamic_Predicate_Aspect
(Typ
)
968 and then Is_OK_Static_Subtype
(Typ
)
973 Gen
:= Current_Scope
;
974 while not Is_Generic_Instance
(Gen
) loop
978 pragma Assert
(Present
(Gen
));
980 if Ekind
(Gen
) = E_Package
and then In_Package_Body
(Gen
) then
981 Error_Msg_Warn
:= SPARK_Mode
/= On
;
982 Error_Msg_FE
(Msg
& "<<", N
, Typ
);
983 Error_Msg_F
("\Program_Error [<<", N
);
986 Make_Raise_Program_Error
(Sloc
(N
),
987 Reason
=> PE_Bad_Predicated_Generic_Type
));
990 Error_Msg_FE
(Msg
, N
, Typ
);
994 Error_Msg_FE
(Msg
, N
, Typ
);
997 -- Suggest to use First_Valid/Last_Valid instead of First/Last/Range
998 -- if the predicate is static.
1000 if not Has_Dynamic_Predicate_Aspect
(Typ
)
1001 and then Has_Static_Predicate
(Typ
)
1002 and then Nkind
(N
) = N_Attribute_Reference
1005 Aname
: constant Name_Id
:= Attribute_Name
(N
);
1006 Attr_Id
: constant Attribute_Id
:= Get_Attribute_Id
(Aname
);
1009 when Attribute_First
=>
1010 Error_Msg_F
("\use attribute First_Valid instead", N
);
1011 when Attribute_Last
=>
1012 Error_Msg_F
("\use attribute Last_Valid instead", N
);
1013 when Attribute_Range
=>
1014 Error_Msg_F
("\use attributes First_Valid and "
1015 & "Last_Valid instead", N
);
1022 -- Emit an optional suggestion on how to remedy the error if the
1023 -- context warrants it.
1025 if Suggest_Static
and then Has_Static_Predicate
(Typ
) then
1026 Error_Msg_FE
("\predicate of & should be marked static", N
, Typ
);
1029 end Bad_Predicated_Subtype_Use
;
1031 -----------------------------------------
1032 -- Bad_Unordered_Enumeration_Reference --
1033 -----------------------------------------
1035 function Bad_Unordered_Enumeration_Reference
1037 T
: Entity_Id
) return Boolean
1040 return Is_Enumeration_Type
(T
)
1041 and then Warn_On_Unordered_Enumeration_Type
1042 and then not Is_Generic_Type
(T
)
1043 and then Comes_From_Source
(N
)
1044 and then not Has_Pragma_Ordered
(T
)
1045 and then not In_Same_Extended_Unit
(N
, T
);
1046 end Bad_Unordered_Enumeration_Reference
;
1048 ----------------------------
1049 -- Begin_Keyword_Location --
1050 ----------------------------
1052 function Begin_Keyword_Location
(N
: Node_Id
) return Source_Ptr
is
1064 HSS
:= Handled_Statement_Sequence
(N
);
1066 -- When the handled sequence of statements comes from source, the
1067 -- location of the "begin" keyword is that of the sequence itself.
1068 -- Note that an internal construct may inherit a source sequence.
1070 if Comes_From_Source
(HSS
) then
1073 -- The parser generates an internal handled sequence of statements to
1074 -- capture the location of the "begin" keyword if present in the source.
1075 -- Since there are no source statements, the location of the "begin"
1076 -- keyword is effectively that of the "end" keyword.
1078 elsif Comes_From_Source
(N
) then
1081 -- Otherwise the construct is internal and should carry the location of
1082 -- the original construct which prompted its creation.
1087 end Begin_Keyword_Location
;
1089 --------------------------
1090 -- Build_Actual_Subtype --
1091 --------------------------
1093 function Build_Actual_Subtype
1095 N
: Node_Or_Entity_Id
) return Node_Id
1098 -- Normally Sloc (N), but may point to corresponding body in some cases
1100 Constraints
: List_Id
;
1106 Disc_Type
: Entity_Id
;
1113 if Nkind
(N
) = N_Defining_Identifier
then
1114 Obj
:= New_Occurrence_Of
(N
, Loc
);
1116 -- If this is a formal parameter of a subprogram declaration, and
1117 -- we are compiling the body, we want the declaration for the
1118 -- actual subtype to carry the source position of the body, to
1119 -- prevent anomalies in gdb when stepping through the code.
1121 if Is_Formal
(N
) then
1123 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(N
));
1125 if Nkind
(Decl
) = N_Subprogram_Declaration
1126 and then Present
(Corresponding_Body
(Decl
))
1128 Loc
:= Sloc
(Corresponding_Body
(Decl
));
1137 if Is_Array_Type
(T
) then
1138 Constraints
:= New_List
;
1139 Index
:= First_Index
(T
);
1141 for J
in 1 .. Number_Dimensions
(T
) loop
1143 -- Build an array subtype declaration with the nominal subtype and
1144 -- the bounds of the actual. Add the declaration in front of the
1145 -- local declarations for the subprogram, for analysis before any
1146 -- reference to the formal in the body.
1148 -- If this is for an index with a fixed lower bound, then use
1149 -- the fixed lower bound as the lower bound of the actual
1150 -- subtype's corresponding index.
1152 if not Is_Constrained
(T
)
1153 and then Is_Fixed_Lower_Bound_Index_Subtype
(Etype
(Index
))
1155 Lo
:= New_Copy_Tree
(Type_Low_Bound
(Etype
(Index
)));
1159 Make_Attribute_Reference
(Loc
,
1161 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
1162 Attribute_Name
=> Name_First
,
1163 Expressions
=> New_List
(
1164 Make_Integer_Literal
(Loc
, J
)));
1168 Make_Attribute_Reference
(Loc
,
1170 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
1171 Attribute_Name
=> Name_Last
,
1172 Expressions
=> New_List
(
1173 Make_Integer_Literal
(Loc
, J
)));
1175 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
1180 -- If the type has unknown discriminants there is no constrained
1181 -- subtype to build. This is never called for a formal or for a
1182 -- lhs, so returning the type is ok ???
1184 elsif Has_Unknown_Discriminants
(T
) then
1188 Constraints
:= New_List
;
1190 -- Type T is a generic derived type, inherit the discriminants from
1193 if Is_Private_Type
(T
)
1194 and then No
(Full_View
(T
))
1196 -- T was flagged as an error if it was declared as a formal
1197 -- derived type with known discriminants. In this case there
1198 -- is no need to look at the parent type since T already carries
1199 -- its own discriminants.
1201 and then not Error_Posted
(T
)
1203 Disc_Type
:= Etype
(Base_Type
(T
));
1208 Discr
:= First_Discriminant
(Disc_Type
);
1209 while Present
(Discr
) loop
1210 Append_To
(Constraints
,
1211 Make_Selected_Component
(Loc
,
1213 Duplicate_Subexpr_No_Checks
(Obj
),
1214 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)));
1215 Next_Discriminant
(Discr
);
1219 Subt
:= Make_Temporary
(Loc
, 'S', Related_Node
=> N
);
1220 Set_Is_Internal
(Subt
);
1223 Make_Subtype_Declaration
(Loc
,
1224 Defining_Identifier
=> Subt
,
1225 Subtype_Indication
=>
1226 Make_Subtype_Indication
(Loc
,
1227 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
1229 Make_Index_Or_Discriminant_Constraint
(Loc
,
1230 Constraints
=> Constraints
)));
1232 Mark_Rewrite_Insertion
(Decl
);
1234 end Build_Actual_Subtype
;
1236 ---------------------------------------
1237 -- Build_Actual_Subtype_Of_Component --
1238 ---------------------------------------
1240 function Build_Actual_Subtype_Of_Component
1242 N
: Node_Id
) return Node_Id
1244 Loc
: constant Source_Ptr
:= Sloc
(N
);
1245 P
: constant Node_Id
:= Prefix
(N
);
1249 Index_Typ
: Entity_Id
;
1250 Sel
: Entity_Id
:= Empty
;
1252 Desig_Typ
: Entity_Id
;
1253 -- This is either a copy of T, or if T is an access type, then it is
1254 -- the directly designated type of this access type.
1256 function Build_Access_Record_Constraint
(C
: List_Id
) return List_Id
;
1257 -- If the record component is a constrained access to the current
1258 -- record, the subtype has not been constructed during analysis of
1259 -- the enclosing record type (see Analyze_Access). In that case, build
1260 -- a constrained access subtype after replacing references to the
1261 -- enclosing discriminants with the corresponding discriminant values
1264 function Build_Actual_Array_Constraint
return List_Id
;
1265 -- If one or more of the bounds of the component depends on
1266 -- discriminants, build actual constraint using the discriminants
1267 -- of the prefix, as above.
1269 function Build_Actual_Record_Constraint
return List_Id
;
1270 -- Similar to previous one, for discriminated components constrained
1271 -- by the discriminant of the enclosing object.
1273 function Build_Discriminant_Reference
1274 (Discrim_Name
: Node_Id
; Obj
: Node_Id
:= P
) return Node_Id
;
1275 -- Build a reference to the discriminant denoted by Discrim_Name.
1276 -- The prefix of the result is usually Obj, but it could be
1277 -- a prefix of Obj in some corner cases.
1279 function Copy_And_Maybe_Dereference
(N
: Node_Id
) return Node_Id
;
1280 -- Copy the subtree rooted at N and insert an explicit dereference if it
1281 -- is of an access type.
1283 -----------------------------------
1284 -- Build_Actual_Array_Constraint --
1285 -----------------------------------
1287 function Build_Actual_Array_Constraint
return List_Id
is
1288 Constraints
: constant List_Id
:= New_List
;
1296 Indx
:= First_Index
(Desig_Typ
);
1297 while Present
(Indx
) loop
1298 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
1299 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
1301 if Denotes_Discriminant
(Old_Lo
) then
1302 Lo
:= Build_Discriminant_Reference
(Old_Lo
);
1304 Lo
:= New_Copy_Tree
(Old_Lo
);
1306 -- The new bound will be reanalyzed in the enclosing
1307 -- declaration. For literal bounds that come from a type
1308 -- declaration, the type of the context must be imposed, so
1309 -- insure that analysis will take place. For non-universal
1310 -- types this is not strictly necessary.
1312 Set_Analyzed
(Lo
, False);
1315 if Denotes_Discriminant
(Old_Hi
) then
1316 Hi
:= Build_Discriminant_Reference
(Old_Hi
);
1318 Hi
:= New_Copy_Tree
(Old_Hi
);
1319 Set_Analyzed
(Hi
, False);
1322 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
1327 end Build_Actual_Array_Constraint
;
1329 ------------------------------------
1330 -- Build_Actual_Record_Constraint --
1331 ------------------------------------
1333 function Build_Actual_Record_Constraint
return List_Id
is
1334 Constraints
: constant List_Id
:= New_List
;
1339 D
:= First_Elmt
(Discriminant_Constraint
(Desig_Typ
));
1340 while Present
(D
) loop
1341 if Denotes_Discriminant
(Node
(D
)) then
1342 D_Val
:= Build_Discriminant_Reference
(Node
(D
));
1344 D_Val
:= New_Copy_Tree
(Node
(D
));
1347 Append
(D_Val
, Constraints
);
1352 end Build_Actual_Record_Constraint
;
1354 ----------------------------------
1355 -- Build_Discriminant_Reference --
1356 ----------------------------------
1358 function Build_Discriminant_Reference
1359 (Discrim_Name
: Node_Id
; Obj
: Node_Id
:= P
) return Node_Id
1361 Discrim
: constant Entity_Id
:= Entity
(Discrim_Name
);
1363 function Obj_Is_Good_Prefix
return Boolean;
1364 -- Returns True if Obj.Discrim makes sense; that is, if
1365 -- Obj has Discrim as one of its discriminants (or is an
1366 -- access value that designates such an object).
1368 ------------------------
1369 -- Obj_Is_Good_Prefix --
1370 ------------------------
1372 function Obj_Is_Good_Prefix
return Boolean is
1373 Obj_Type
: Entity_Id
:=
1374 Implementation_Base_Type
(Etype
(Obj
));
1376 Discriminated_Type
: constant Entity_Id
:=
1377 Implementation_Base_Type
1378 (Scope
(Original_Record_Component
(Discrim
)));
1380 -- The order of the following two tests matters in the
1381 -- access-to-class-wide case.
1383 if Is_Access_Type
(Obj_Type
) then
1384 Obj_Type
:= Implementation_Base_Type
1385 (Designated_Type
(Obj_Type
));
1388 if Is_Class_Wide_Type
(Obj_Type
) then
1389 Obj_Type
:= Implementation_Base_Type
1390 (Find_Specific_Type
(Obj_Type
));
1393 -- If a type T1 defines a discriminant D1, then Obj.D1 is ok (for
1394 -- our purposes here) if T1 is an ancestor of the type of Obj.
1395 -- So that's what we would like to test for here.
1396 -- The bad news: Is_Ancestor is only defined in the tagged case.
1397 -- The good news: in the untagged case, Implementation_Base_Type
1398 -- looks through derived types so we can use a simpler test.
1400 if Is_Tagged_Type
(Discriminated_Type
) then
1401 return Is_Ancestor
(Discriminated_Type
, Obj_Type
);
1403 return Discriminated_Type
= Obj_Type
;
1405 end Obj_Is_Good_Prefix
;
1407 -- Start of processing for Build_Discriminant_Reference
1410 if not Obj_Is_Good_Prefix
then
1411 -- If the given discriminant is not a component of the given
1412 -- object, then try the enclosing object.
1414 if Nkind
(Obj
) = N_Selected_Component
then
1415 return Build_Discriminant_Reference
1416 (Discrim_Name
=> Discrim_Name
,
1417 Obj
=> Prefix
(Obj
));
1418 elsif Nkind
(Obj
) in N_Has_Entity
1419 and then Nkind
(Parent
(Entity
(Obj
))) =
1420 N_Object_Renaming_Declaration
1422 -- Look through a renaming (a corner case of a corner case).
1423 return Build_Discriminant_Reference
1424 (Discrim_Name
=> Discrim_Name
,
1425 Obj
=> Name
(Parent
(Entity
(Obj
))));
1427 -- We are in some unexpected case here, so revert to the
1428 -- old behavior (by falling through to it).
1433 return Make_Selected_Component
(Loc
,
1434 Prefix
=> Copy_And_Maybe_Dereference
(Obj
),
1435 Selector_Name
=> New_Occurrence_Of
(Discrim
, Loc
));
1436 end Build_Discriminant_Reference
;
1438 ------------------------------------
1439 -- Build_Access_Record_Constraint --
1440 ------------------------------------
1442 function Build_Access_Record_Constraint
(C
: List_Id
) return List_Id
is
1443 Constraints
: constant List_Id
:= New_List
;
1448 -- Retrieve the constraint from the component declaration, because
1449 -- the component subtype has not been constructed and the component
1450 -- type is an unconstrained access.
1453 while Present
(D
) loop
1454 if Nkind
(D
) = N_Discriminant_Association
1455 and then Denotes_Discriminant
(Expression
(D
))
1457 D_Val
:= New_Copy_Tree
(D
);
1458 Set_Expression
(D_Val
,
1459 Make_Selected_Component
(Loc
,
1460 Prefix
=> Copy_And_Maybe_Dereference
(P
),
1462 New_Occurrence_Of
(Entity
(Expression
(D
)), Loc
)));
1464 elsif Denotes_Discriminant
(D
) then
1465 D_Val
:= Make_Selected_Component
(Loc
,
1466 Prefix
=> Copy_And_Maybe_Dereference
(P
),
1467 Selector_Name
=> New_Occurrence_Of
(Entity
(D
), Loc
));
1470 D_Val
:= New_Copy_Tree
(D
);
1473 Append
(D_Val
, Constraints
);
1478 end Build_Access_Record_Constraint
;
1480 --------------------------------
1481 -- Copy_And_Maybe_Dereference --
1482 --------------------------------
1484 function Copy_And_Maybe_Dereference
(N
: Node_Id
) return Node_Id
is
1485 New_N
: constant Node_Id
:= New_Copy_Tree
(N
);
1488 if Is_Access_Type
(Etype
(N
)) then
1489 return Make_Explicit_Dereference
(Sloc
(Parent
(N
)), New_N
);
1494 end Copy_And_Maybe_Dereference
;
1496 -- Start of processing for Build_Actual_Subtype_Of_Component
1499 -- The subtype does not need to be created for a selected component
1500 -- in a Spec_Expression.
1502 if In_Spec_Expression
then
1505 -- More comments for the rest of this body would be good ???
1507 elsif Nkind
(N
) = N_Explicit_Dereference
then
1508 if Is_Composite_Type
(T
)
1509 and then not Is_Constrained
(T
)
1510 and then not (Is_Class_Wide_Type
(T
)
1511 and then Is_Constrained
(Root_Type
(T
)))
1512 and then not Has_Unknown_Discriminants
(T
)
1514 -- If the type of the dereference is already constrained, it is an
1517 if Is_Array_Type
(Etype
(N
))
1518 and then Is_Constrained
(Etype
(N
))
1522 Remove_Side_Effects
(P
);
1523 return Build_Actual_Subtype
(T
, N
);
1530 elsif Nkind
(N
) = N_Selected_Component
then
1531 -- The entity of the selected component allows us to retrieve
1532 -- the original constraint from its component declaration.
1534 Sel
:= Entity
(Selector_Name
(N
));
1535 if Parent_Kind
(Sel
) /= N_Component_Declaration
then
1540 if Is_Access_Type
(T
) then
1541 Desig_Typ
:= Designated_Type
(T
);
1547 if Ekind
(Desig_Typ
) = E_Array_Subtype
then
1548 Id
:= First_Index
(Desig_Typ
);
1550 -- Check whether an index bound is constrained by a discriminant
1552 while Present
(Id
) loop
1553 Index_Typ
:= Underlying_Type
(Etype
(Id
));
1555 if Denotes_Discriminant
(Type_Low_Bound
(Index_Typ
))
1557 Denotes_Discriminant
(Type_High_Bound
(Index_Typ
))
1559 Remove_Side_Effects
(P
);
1561 Build_Component_Subtype
1562 (Build_Actual_Array_Constraint
, Loc
, Base_Type
(T
));
1568 elsif Is_Composite_Type
(Desig_Typ
)
1569 and then Has_Discriminants
(Desig_Typ
)
1570 and then not Is_Empty_Elmt_List
(Discriminant_Constraint
(Desig_Typ
))
1571 and then not Has_Unknown_Discriminants
(Desig_Typ
)
1573 if Is_Private_Type
(Desig_Typ
)
1574 and then No
(Discriminant_Constraint
(Desig_Typ
))
1576 Desig_Typ
:= Full_View
(Desig_Typ
);
1579 D
:= First_Elmt
(Discriminant_Constraint
(Desig_Typ
));
1580 while Present
(D
) loop
1581 if Denotes_Discriminant
(Node
(D
)) then
1582 Remove_Side_Effects
(P
);
1584 Build_Component_Subtype
(
1585 Build_Actual_Record_Constraint
, Loc
, Base_Type
(T
));
1591 -- Special processing for an access record component that is
1592 -- the target of an assignment. If the designated type is an
1593 -- unconstrained discriminated record we create its actual
1596 elsif Ekind
(T
) = E_Access_Type
1597 and then Present
(Sel
)
1598 and then Has_Per_Object_Constraint
(Sel
)
1599 and then Nkind
(Parent
(N
)) = N_Assignment_Statement
1600 and then N
= Name
(Parent
(N
))
1601 -- and then not Inside_Init_Proc
1602 -- and then Has_Discriminants (Desig_Typ)
1603 -- and then not Is_Constrained (Desig_Typ)
1606 S_Indic
: constant Node_Id
:=
1608 (Component_Definition
(Parent
(Sel
))));
1611 if Nkind
(S_Indic
) = N_Subtype_Indication
then
1612 Discs
:= Constraints
(Constraint
(S_Indic
));
1614 Remove_Side_Effects
(P
);
1615 return Build_Component_Subtype
1616 (Build_Access_Record_Constraint
(Discs
), Loc
, T
);
1623 -- If none of the above, the actual and nominal subtypes are the same
1626 end Build_Actual_Subtype_Of_Component
;
1628 -----------------------------
1629 -- Build_Component_Subtype --
1630 -----------------------------
1632 function Build_Component_Subtype
1635 T
: Entity_Id
) return Node_Id
1641 -- Unchecked_Union components do not require component subtypes
1643 if Is_Unchecked_Union
(T
) then
1647 Subt
:= Make_Temporary
(Loc
, 'S');
1648 Set_Is_Internal
(Subt
);
1651 Make_Subtype_Declaration
(Loc
,
1652 Defining_Identifier
=> Subt
,
1653 Subtype_Indication
=>
1654 Make_Subtype_Indication
(Loc
,
1655 Subtype_Mark
=> New_Occurrence_Of
(Base_Type
(T
), Loc
),
1657 Make_Index_Or_Discriminant_Constraint
(Loc
,
1658 Constraints
=> C
)));
1660 Mark_Rewrite_Insertion
(Decl
);
1662 end Build_Component_Subtype
;
1664 -----------------------------
1665 -- Build_Constrained_Itype --
1666 -----------------------------
1668 procedure Build_Constrained_Itype
1671 New_Assoc_List
: List_Id
)
1673 Constrs
: constant List_Id
:= New_List
;
1674 Loc
: constant Source_Ptr
:= Sloc
(N
);
1677 New_Assoc
: Node_Id
;
1678 Subtyp_Decl
: Node_Id
;
1681 New_Assoc
:= First
(New_Assoc_List
);
1682 while Present
(New_Assoc
) loop
1684 -- There is exactly one choice in the component association (and
1685 -- it is either a discriminant, a component or the others clause).
1686 pragma Assert
(List_Length
(Choices
(New_Assoc
)) = 1);
1688 -- Duplicate expression for the discriminant and put it on the
1689 -- list of constraints for the itype declaration.
1691 if Is_Entity_Name
(First
(Choices
(New_Assoc
)))
1693 Ekind
(Entity
(First
(Choices
(New_Assoc
)))) = E_Discriminant
1695 Append_To
(Constrs
, Duplicate_Subexpr
(Expression
(New_Assoc
)));
1701 if Has_Unknown_Discriminants
(Typ
)
1702 and then Present
(Underlying_Record_View
(Typ
))
1705 Make_Subtype_Indication
(Loc
,
1707 New_Occurrence_Of
(Underlying_Record_View
(Typ
), Loc
),
1709 Make_Index_Or_Discriminant_Constraint
(Loc
,
1710 Constraints
=> Constrs
));
1713 Make_Subtype_Indication
(Loc
,
1715 New_Occurrence_Of
(Base_Type
(Typ
), Loc
),
1717 Make_Index_Or_Discriminant_Constraint
(Loc
,
1718 Constraints
=> Constrs
));
1721 Def_Id
:= Create_Itype
(Ekind
(Typ
), N
);
1724 Make_Subtype_Declaration
(Loc
,
1725 Defining_Identifier
=> Def_Id
,
1726 Subtype_Indication
=> Indic
);
1727 Set_Parent
(Subtyp_Decl
, Parent
(N
));
1729 -- Itypes must be analyzed with checks off (see itypes.ads)
1731 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
1733 Set_Etype
(N
, Def_Id
);
1734 end Build_Constrained_Itype
;
1736 ---------------------------
1737 -- Build_Default_Subtype --
1738 ---------------------------
1740 function Build_Default_Subtype
1742 N
: Node_Id
) return Entity_Id
1744 Loc
: constant Source_Ptr
:= Sloc
(N
);
1748 -- The base type that is to be constrained by the defaults
1751 if not Has_Discriminants
(T
) or else Is_Constrained
(T
) then
1755 Bas
:= Base_Type
(T
);
1757 -- If T is non-private but its base type is private, this is the
1758 -- completion of a subtype declaration whose parent type is private
1759 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
1760 -- are to be found in the full view of the base. Check that the private
1761 -- status of T and its base differ.
1763 if Is_Private_Type
(Bas
)
1764 and then not Is_Private_Type
(T
)
1765 and then Present
(Full_View
(Bas
))
1767 Bas
:= Full_View
(Bas
);
1770 Disc
:= First_Discriminant
(T
);
1772 if No
(Discriminant_Default_Value
(Disc
)) then
1777 Act
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
1778 Constraints
: constant List_Id
:= New_List
;
1782 while Present
(Disc
) loop
1783 Append_To
(Constraints
,
1784 New_Copy_Tree
(Discriminant_Default_Value
(Disc
)));
1785 Next_Discriminant
(Disc
);
1789 Make_Subtype_Declaration
(Loc
,
1790 Defining_Identifier
=> Act
,
1791 Subtype_Indication
=>
1792 Make_Subtype_Indication
(Loc
,
1793 Subtype_Mark
=> New_Occurrence_Of
(Bas
, Loc
),
1795 Make_Index_Or_Discriminant_Constraint
(Loc
,
1796 Constraints
=> Constraints
)));
1798 Insert_Action
(N
, Decl
);
1800 -- If the context is a component declaration the subtype declaration
1801 -- will be analyzed when the enclosing type is frozen, otherwise do
1804 if Ekind
(Current_Scope
) /= E_Record_Type
then
1810 end Build_Default_Subtype
;
1812 ------------------------------
1813 -- Build_Default_Subtype_OK --
1814 ------------------------------
1816 function Build_Default_Subtype_OK
(T
: Entity_Id
) return Boolean is
1818 function Default_Discriminant_Values_Known_At_Compile_Time
1819 (T
: Entity_Id
) return Boolean;
1820 -- For an unconstrained type T, return False if the given type has a
1821 -- discriminant with default value not known at compile time. Return
1824 ---------------------------------------------------------
1825 -- Default_Discriminant_Values_Known_At_Compile_Time --
1826 ---------------------------------------------------------
1828 function Default_Discriminant_Values_Known_At_Compile_Time
1829 (T
: Entity_Id
) return Boolean
1836 -- If the type has no discriminant, we know them all at compile time
1838 if not Has_Discriminants
(T
) then
1842 -- The type has discriminants, check that none of them has a default
1843 -- value not known at compile time.
1845 Discr
:= First_Discriminant
(T
);
1847 while Present
(Discr
) loop
1848 DDV
:= Discriminant_Default_Value
(Discr
);
1850 if Present
(DDV
) and then not Compile_Time_Known_Value
(DDV
) then
1854 Next_Discriminant
(Discr
);
1858 end Default_Discriminant_Values_Known_At_Compile_Time
;
1860 -- Start of processing for Build_Default_Subtype_OK
1864 if Is_Constrained
(T
) then
1866 -- We won't build a new subtype if T is constrained
1871 if not Default_Discriminant_Values_Known_At_Compile_Time
(T
) then
1873 -- This is a special case of definite subtypes. To allocate a
1874 -- specific size to the subtype, we need to know the value at compile
1875 -- time. This might not be the case if the default value is the
1876 -- result of a function. In that case, the object might be definite
1877 -- and limited but the needed size might not be statically known or
1878 -- too tricky to obtain. In that case, we will not build the subtype.
1883 return Is_Definite_Subtype
(T
) and then Is_Limited_View
(T
);
1884 end Build_Default_Subtype_OK
;
1886 --------------------------------------------
1887 -- Build_Discriminal_Subtype_Of_Component --
1888 --------------------------------------------
1890 function Build_Discriminal_Subtype_Of_Component
1891 (T
: Entity_Id
) return Node_Id
1893 Loc
: constant Source_Ptr
:= Sloc
(T
);
1897 function Build_Discriminal_Array_Constraint
return List_Id
;
1898 -- If one or more of the bounds of the component depends on
1899 -- discriminants, build actual constraint using the discriminants
1902 function Build_Discriminal_Record_Constraint
return List_Id
;
1903 -- Similar to previous one, for discriminated components constrained by
1904 -- the discriminant of the enclosing object.
1906 ----------------------------------------
1907 -- Build_Discriminal_Array_Constraint --
1908 ----------------------------------------
1910 function Build_Discriminal_Array_Constraint
return List_Id
is
1911 Constraints
: constant List_Id
:= New_List
;
1919 Indx
:= First_Index
(T
);
1920 while Present
(Indx
) loop
1921 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
1922 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
1924 if Denotes_Discriminant
(Old_Lo
) then
1925 Lo
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Lo
)), Loc
);
1928 Lo
:= New_Copy_Tree
(Old_Lo
);
1931 if Denotes_Discriminant
(Old_Hi
) then
1932 Hi
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Hi
)), Loc
);
1935 Hi
:= New_Copy_Tree
(Old_Hi
);
1938 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
1943 end Build_Discriminal_Array_Constraint
;
1945 -----------------------------------------
1946 -- Build_Discriminal_Record_Constraint --
1947 -----------------------------------------
1949 function Build_Discriminal_Record_Constraint
return List_Id
is
1950 Constraints
: constant List_Id
:= New_List
;
1955 D
:= First_Elmt
(Discriminant_Constraint
(T
));
1956 while Present
(D
) loop
1957 if Denotes_Discriminant
(Node
(D
)) then
1959 New_Occurrence_Of
(Discriminal
(Entity
(Node
(D
))), Loc
);
1961 D_Val
:= New_Copy_Tree
(Node
(D
));
1964 Append
(D_Val
, Constraints
);
1969 end Build_Discriminal_Record_Constraint
;
1971 -- Start of processing for Build_Discriminal_Subtype_Of_Component
1974 if Ekind
(T
) = E_Array_Subtype
then
1975 Id
:= First_Index
(T
);
1976 while Present
(Id
) loop
1977 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(Id
)))
1979 Denotes_Discriminant
(Type_High_Bound
(Etype
(Id
)))
1981 return Build_Component_Subtype
1982 (Build_Discriminal_Array_Constraint
, Loc
, T
);
1988 elsif Ekind
(T
) = E_Record_Subtype
1989 and then Has_Discriminants
(T
)
1990 and then not Has_Unknown_Discriminants
(T
)
1992 D
:= First_Elmt
(Discriminant_Constraint
(T
));
1993 while Present
(D
) loop
1994 if Denotes_Discriminant
(Node
(D
)) then
1995 return Build_Component_Subtype
1996 (Build_Discriminal_Record_Constraint
, Loc
, T
);
2003 -- If none of the above, the actual and nominal subtypes are the same
2006 end Build_Discriminal_Subtype_Of_Component
;
2008 ------------------------------
2009 -- Build_Elaboration_Entity --
2010 ------------------------------
2012 procedure Build_Elaboration_Entity
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
2013 Loc
: constant Source_Ptr
:= Sloc
(N
);
2015 Elab_Ent
: Entity_Id
;
2017 procedure Set_Package_Name
(Ent
: Entity_Id
);
2018 -- Given an entity, sets the fully qualified name of the entity in
2019 -- Name_Buffer, with components separated by double underscores. This
2020 -- is a recursive routine that climbs the scope chain to Standard.
2022 ----------------------
2023 -- Set_Package_Name --
2024 ----------------------
2026 procedure Set_Package_Name
(Ent
: Entity_Id
) is
2028 if Scope
(Ent
) /= Standard_Standard
then
2029 Set_Package_Name
(Scope
(Ent
));
2032 Nam
: constant String := Get_Name_String
(Chars
(Ent
));
2034 Name_Buffer
(Name_Len
+ 1) := '_';
2035 Name_Buffer
(Name_Len
+ 2) := '_';
2036 Name_Buffer
(Name_Len
+ 3 .. Name_Len
+ Nam
'Length + 2) := Nam
;
2037 Name_Len
:= Name_Len
+ Nam
'Length + 2;
2041 Get_Name_String
(Chars
(Ent
));
2043 end Set_Package_Name
;
2045 -- Start of processing for Build_Elaboration_Entity
2048 -- Ignore call if already constructed
2050 if Present
(Elaboration_Entity
(Spec_Id
)) then
2053 -- Do not generate an elaboration entity in GNATprove move because the
2054 -- elaboration counter is a form of expansion.
2056 elsif GNATprove_Mode
then
2059 -- See if we need elaboration entity
2061 -- We always need an elaboration entity when preserving control flow, as
2062 -- we want to remain explicit about the unit's elaboration order.
2064 elsif Opt
.Suppress_Control_Flow_Optimizations
then
2067 -- We always need an elaboration entity for the dynamic elaboration
2068 -- model, since it is needed to properly generate the PE exception for
2069 -- access before elaboration.
2071 elsif Dynamic_Elaboration_Checks
then
2074 -- For the static model, we don't need the elaboration counter if this
2075 -- unit is sure to have no elaboration code, since that means there
2076 -- is no elaboration unit to be called. Note that we can't just decide
2077 -- after the fact by looking to see whether there was elaboration code,
2078 -- because that's too late to make this decision.
2080 elsif Restriction_Active
(No_Elaboration_Code
) then
2083 -- Similarly, for the static model, we can skip the elaboration counter
2084 -- if we have the No_Multiple_Elaboration restriction, since for the
2085 -- static model, that's the only purpose of the counter (to avoid
2086 -- multiple elaboration).
2088 elsif Restriction_Active
(No_Multiple_Elaboration
) then
2092 -- Here we need the elaboration entity
2094 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
2095 -- name with dots replaced by double underscore. We have to manually
2096 -- construct this name, since it will be elaborated in the outer scope,
2097 -- and thus will not have the unit name automatically prepended.
2099 Set_Package_Name
(Spec_Id
);
2100 Add_Str_To_Name_Buffer
("_E");
2102 -- Create elaboration counter
2104 Elab_Ent
:= Make_Defining_Identifier
(Loc
, Chars
=> Name_Find
);
2105 Set_Elaboration_Entity
(Spec_Id
, Elab_Ent
);
2108 Make_Object_Declaration
(Loc
,
2109 Defining_Identifier
=> Elab_Ent
,
2110 Object_Definition
=>
2111 New_Occurrence_Of
(Standard_Short_Integer
, Loc
),
2112 Expression
=> Make_Integer_Literal
(Loc
, Uint_0
));
2114 Push_Scope
(Standard_Standard
);
2115 Add_Global_Declaration
(Decl
);
2118 -- Reset True_Constant indication, since we will indeed assign a value
2119 -- to the variable in the binder main. We also kill the Current_Value
2120 -- and Last_Assignment fields for the same reason.
2122 Set_Is_True_Constant
(Elab_Ent
, False);
2123 Set_Current_Value
(Elab_Ent
, Empty
);
2124 Set_Last_Assignment
(Elab_Ent
, Empty
);
2126 -- We do not want any further qualification of the name (if we did not
2127 -- do this, we would pick up the name of the generic package in the case
2128 -- of a library level generic instantiation).
2130 Set_Has_Qualified_Name
(Elab_Ent
);
2131 Set_Has_Fully_Qualified_Name
(Elab_Ent
);
2132 end Build_Elaboration_Entity
;
2134 --------------------------------
2135 -- Build_Explicit_Dereference --
2136 --------------------------------
2138 procedure Build_Explicit_Dereference
2142 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
2147 -- An entity of a type with a reference aspect is overloaded with
2148 -- both interpretations: with and without the dereference. Now that
2149 -- the dereference is made explicit, set the type of the node properly,
2150 -- to prevent anomalies in the backend. Same if the expression is an
2151 -- overloaded function call whose return type has a reference aspect.
2153 if Is_Entity_Name
(Expr
) then
2154 Set_Etype
(Expr
, Etype
(Entity
(Expr
)));
2156 -- The designated entity will not be examined again when resolving
2157 -- the dereference, so generate a reference to it now.
2159 Generate_Reference
(Entity
(Expr
), Expr
);
2161 elsif Nkind
(Expr
) = N_Function_Call
then
2163 -- If the name of the indexing function is overloaded, locate the one
2164 -- whose return type has an implicit dereference on the desired
2165 -- discriminant, and set entity and type of function call.
2167 if Is_Overloaded
(Name
(Expr
)) then
2168 Get_First_Interp
(Name
(Expr
), I
, It
);
2170 while Present
(It
.Nam
) loop
2171 if Ekind
((It
.Typ
)) = E_Record_Type
2172 and then First_Entity
((It
.Typ
)) = Disc
2174 Set_Entity
(Name
(Expr
), It
.Nam
);
2175 Set_Etype
(Name
(Expr
), Etype
(It
.Nam
));
2179 Get_Next_Interp
(I
, It
);
2183 -- Set type of call from resolved function name.
2185 Set_Etype
(Expr
, Etype
(Name
(Expr
)));
2188 Set_Is_Overloaded
(Expr
, False);
2190 -- The expression will often be a generalized indexing that yields a
2191 -- container element that is then dereferenced, in which case the
2192 -- generalized indexing call is also non-overloaded.
2194 if Nkind
(Expr
) = N_Indexed_Component
2195 and then Present
(Generalized_Indexing
(Expr
))
2197 Set_Is_Overloaded
(Generalized_Indexing
(Expr
), False);
2201 Make_Explicit_Dereference
(Loc
,
2203 Make_Selected_Component
(Loc
,
2204 Prefix
=> Relocate_Node
(Expr
),
2205 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
))));
2206 Set_Etype
(Prefix
(Expr
), Etype
(Disc
));
2207 Set_Etype
(Expr
, Designated_Type
(Etype
(Disc
)));
2208 end Build_Explicit_Dereference
;
2210 ---------------------------
2211 -- Build_Overriding_Spec --
2212 ---------------------------
2214 function Build_Overriding_Spec
2216 Typ
: Entity_Id
) return Node_Id
2218 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
2219 Par_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Op
);
2220 Spec
: constant Node_Id
:= Specification
(Unit_Declaration_Node
(Op
));
2222 Formal_Spec
: Node_Id
;
2223 Formal_Type
: Node_Id
;
2227 New_Spec
:= Copy_Subprogram_Spec
(Spec
);
2229 Formal_Spec
:= First
(Parameter_Specifications
(New_Spec
));
2230 while Present
(Formal_Spec
) loop
2231 Formal_Type
:= Parameter_Type
(Formal_Spec
);
2233 if Is_Entity_Name
(Formal_Type
)
2234 and then Entity
(Formal_Type
) = Par_Typ
2236 Rewrite
(Formal_Type
, New_Occurrence_Of
(Typ
, Loc
));
2239 -- Nothing needs to be done for access parameters
2245 end Build_Overriding_Spec
;
2251 function Build_Subtype
2252 (Related_Node
: Node_Id
;
2255 Constraints
: List_Id
)
2259 Subtyp_Decl
: Node_Id
;
2261 Btyp
: Entity_Id
:= Base_Type
(Typ
);
2264 -- The Related_Node better be here or else we won't be able to
2265 -- attach new itypes to a node in the tree.
2267 pragma Assert
(Present
(Related_Node
));
2269 -- If the view of the component's type is incomplete or private
2270 -- with unknown discriminants, then the constraint must be applied
2271 -- to the full type.
2273 if Has_Unknown_Discriminants
(Btyp
)
2274 and then Present
(Underlying_Type
(Btyp
))
2276 Btyp
:= Underlying_Type
(Btyp
);
2280 Make_Subtype_Indication
(Loc
,
2281 Subtype_Mark
=> New_Occurrence_Of
(Btyp
, Loc
),
2283 Make_Index_Or_Discriminant_Constraint
(Loc
, Constraints
));
2285 Def_Id
:= Create_Itype
(Ekind
(Typ
), Related_Node
);
2288 Make_Subtype_Declaration
(Loc
,
2289 Defining_Identifier
=> Def_Id
,
2290 Subtype_Indication
=> Indic
);
2292 Set_Parent
(Subtyp_Decl
, Parent
(Related_Node
));
2294 -- Itypes must be analyzed with checks off (see package Itypes)
2296 Analyze
(Subtyp_Decl
, Suppress
=> All_Checks
);
2298 if Is_Itype
(Def_Id
) and then Has_Predicates
(Typ
) then
2299 Inherit_Predicate_Flags
(Def_Id
, Typ
);
2301 -- Indicate where the predicate function may be found
2303 if Is_Itype
(Typ
) then
2304 if Present
(Predicate_Function
(Def_Id
)) then
2307 elsif Present
(Predicate_Function
(Typ
)) then
2308 Set_Predicate_Function
(Def_Id
, Predicate_Function
(Typ
));
2311 Set_Predicated_Parent
(Def_Id
, Predicated_Parent
(Typ
));
2314 elsif No
(Predicate_Function
(Def_Id
)) then
2315 Set_Predicated_Parent
(Def_Id
, Typ
);
2322 -----------------------------------
2323 -- Cannot_Raise_Constraint_Error --
2324 -----------------------------------
2326 function Cannot_Raise_Constraint_Error
(Expr
: Node_Id
) return Boolean is
2328 function List_Cannot_Raise_CE
(L
: List_Id
) return Boolean;
2329 -- Returns True if none of the list members cannot possibly raise
2330 -- Constraint_Error.
2332 --------------------------
2333 -- List_Cannot_Raise_CE --
2334 --------------------------
2336 function List_Cannot_Raise_CE
(L
: List_Id
) return Boolean is
2340 while Present
(N
) loop
2341 if Cannot_Raise_Constraint_Error
(N
) then
2349 end List_Cannot_Raise_CE
;
2351 -- Start of processing for Cannot_Raise_Constraint_Error
2354 if Compile_Time_Known_Value
(Expr
) then
2357 elsif Do_Range_Check
(Expr
) then
2360 elsif Raises_Constraint_Error
(Expr
) then
2364 case Nkind
(Expr
) is
2365 when N_Identifier
=>
2368 when N_Expanded_Name
=>
2371 when N_Indexed_Component
=>
2372 return not Do_Range_Check
(Expr
)
2373 and then Cannot_Raise_Constraint_Error
(Prefix
(Expr
))
2374 and then List_Cannot_Raise_CE
(Expressions
(Expr
));
2376 when N_Selected_Component
=>
2377 return not Do_Discriminant_Check
(Expr
)
2378 and then Cannot_Raise_Constraint_Error
(Prefix
(Expr
));
2380 when N_Attribute_Reference
=>
2381 if Do_Overflow_Check
(Expr
) then
2384 elsif No
(Expressions
(Expr
)) then
2388 return List_Cannot_Raise_CE
(Expressions
(Expr
));
2391 when N_Type_Conversion
=>
2392 if Do_Overflow_Check
(Expr
)
2393 or else Do_Length_Check
(Expr
)
2397 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
2400 when N_Unchecked_Type_Conversion
=>
2401 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
2404 if Do_Overflow_Check
(Expr
) then
2407 return Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
2414 if Do_Division_Check
(Expr
)
2416 Do_Overflow_Check
(Expr
)
2421 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
2423 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
2442 | N_Op_Shift_Right_Arithmetic
2446 if Do_Overflow_Check
(Expr
) then
2450 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
2452 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
2459 end Cannot_Raise_Constraint_Error
;
2461 -------------------------------
2462 -- Check_Ambiguous_Aggregate --
2463 -------------------------------
2465 procedure Check_Ambiguous_Aggregate
(Call
: Node_Id
) is
2469 if All_Extensions_Allowed
then
2470 Actual
:= First_Actual
(Call
);
2471 while Present
(Actual
) loop
2472 if Nkind
(Actual
) = N_Aggregate
then
2474 ("\add type qualification to aggregate actual", Actual
);
2477 Next_Actual
(Actual
);
2480 end Check_Ambiguous_Aggregate
;
2482 -----------------------------------------
2483 -- Check_Dynamically_Tagged_Expression --
2484 -----------------------------------------
2486 procedure Check_Dynamically_Tagged_Expression
2489 Related_Nod
: Node_Id
)
2492 pragma Assert
(Is_Tagged_Type
(Typ
));
2494 -- In order to avoid spurious errors when analyzing the expanded code,
2495 -- this check is done only for nodes that come from source and for
2496 -- actuals of generic instantiations.
2498 if (Comes_From_Source
(Related_Nod
)
2499 or else In_Generic_Actual
(Expr
))
2500 and then (Is_Class_Wide_Type
(Etype
(Expr
))
2501 or else Is_Dynamically_Tagged
(Expr
))
2502 and then not Is_Class_Wide_Type
(Typ
)
2504 Error_Msg_N
("dynamically tagged expression not allowed!", Expr
);
2506 end Check_Dynamically_Tagged_Expression
;
2508 --------------------------
2509 -- Check_Fully_Declared --
2510 --------------------------
2512 procedure Check_Fully_Declared
(T
: Entity_Id
; N
: Node_Id
) is
2514 if Ekind
(T
) = E_Incomplete_Type
then
2516 -- Ada 2005 (AI-50217): If the type is available through a limited
2517 -- with_clause, verify that its full view has been analyzed.
2519 if From_Limited_With
(T
)
2520 and then Present
(Non_Limited_View
(T
))
2521 and then Ekind
(Non_Limited_View
(T
)) /= E_Incomplete_Type
2523 -- The non-limited view is fully declared
2529 ("premature usage of incomplete}", N
, First_Subtype
(T
));
2532 -- Need comments for these tests ???
2534 elsif Has_Private_Component
(T
)
2535 and then not Is_Generic_Type
(Root_Type
(T
))
2536 and then not In_Spec_Expression
2538 -- Special case: if T is the anonymous type created for a single
2539 -- task or protected object, use the name of the source object.
2541 if Is_Concurrent_Type
(T
)
2542 and then not Comes_From_Source
(T
)
2543 and then Nkind
(N
) = N_Object_Declaration
2546 ("type of& has incomplete component",
2547 N
, Defining_Identifier
(N
));
2550 ("premature usage of incomplete}",
2551 N
, First_Subtype
(T
));
2554 end Check_Fully_Declared
;
2556 -------------------------------------------
2557 -- Check_Function_With_Address_Parameter --
2558 -------------------------------------------
2560 procedure Check_Function_With_Address_Parameter
(Subp_Id
: Entity_Id
) is
2565 F
:= First_Formal
(Subp_Id
);
2566 while Present
(F
) loop
2569 if Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
2573 if Is_Descendant_Of_Address
(T
) or else Is_Limited_Type
(T
) then
2574 Set_Is_Pure
(Subp_Id
, False);
2580 end Check_Function_With_Address_Parameter
;
2582 -------------------------------------
2583 -- Check_Function_Writable_Actuals --
2584 -------------------------------------
2586 procedure Check_Function_Writable_Actuals
(N
: Node_Id
) is
2587 Writable_Actuals_List
: Elist_Id
:= No_Elist
;
2588 Identifiers_List
: Elist_Id
:= No_Elist
;
2589 Aggr_Error_Node
: Node_Id
:= Empty
;
2590 Error_Node
: Node_Id
:= Empty
;
2592 procedure Collect_Identifiers
(N
: Node_Id
);
2593 -- In a single traversal of subtree N collect in Writable_Actuals_List
2594 -- all the actuals of functions with writable actuals, and in the list
2595 -- Identifiers_List collect all the identifiers that are not actuals of
2596 -- functions with writable actuals. If a writable actual is referenced
2597 -- twice as writable actual then Error_Node is set to reference its
2598 -- second occurrence, the error is reported, and the tree traversal
2601 -------------------------
2602 -- Collect_Identifiers --
2603 -------------------------
2605 procedure Collect_Identifiers
(N
: Node_Id
) is
2607 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
2608 -- Process a single node during the tree traversal to collect the
2609 -- writable actuals of functions and all the identifiers which are
2610 -- not writable actuals of functions.
2612 function Contains
(List
: Elist_Id
; N
: Node_Id
) return Boolean;
2613 -- Returns True if List has a node whose Entity is Entity (N)
2619 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
2620 Is_Writable_Actual
: Boolean := False;
2624 if Nkind
(N
) = N_Identifier
then
2626 -- No analysis possible if the entity is not decorated
2628 if No
(Entity
(N
)) then
2631 -- Don't collect identifiers of packages, called functions, etc
2633 elsif Ekind
(Entity
(N
)) in
2634 E_Package | E_Function | E_Procedure | E_Entry
2638 -- For rewritten nodes, continue the traversal in the original
2639 -- subtree. Needed to handle aggregates in original expressions
2640 -- extracted from the tree by Remove_Side_Effects.
2642 elsif Is_Rewrite_Substitution
(N
) then
2643 Collect_Identifiers
(Original_Node
(N
));
2646 -- For now we skip aggregate discriminants, since they require
2647 -- performing the analysis in two phases to identify conflicts:
2648 -- first one analyzing discriminants and second one analyzing
2649 -- the rest of components (since at run time, discriminants are
2650 -- evaluated prior to components): too much computation cost
2651 -- to identify a corner case???
2653 elsif Nkind
(Parent
(N
)) = N_Component_Association
2654 and then Nkind
(Parent
(Parent
(N
))) in
2655 N_Aggregate | N_Extension_Aggregate
2658 Choice
: constant Node_Id
:= First
(Choices
(Parent
(N
)));
2661 if Ekind
(Entity
(N
)) = E_Discriminant
then
2664 elsif Expression
(Parent
(N
)) = N
2665 and then Nkind
(Choice
) = N_Identifier
2666 and then Ekind
(Entity
(Choice
)) = E_Discriminant
2672 -- Analyze if N is a writable actual of a function
2674 elsif Nkind
(Parent
(N
)) = N_Function_Call
then
2676 Call
: constant Node_Id
:= Parent
(N
);
2681 Id
:= Get_Called_Entity
(Call
);
2683 -- In case of previous error, no check is possible
2689 if Ekind
(Id
) in E_Function | E_Generic_Function
2690 and then Has_Out_Or_In_Out_Parameter
(Id
)
2692 Formal
:= First_Formal
(Id
);
2693 Actual
:= First_Actual
(Call
);
2694 while Present
(Actual
) and then Present
(Formal
) loop
2696 if Ekind
(Formal
) in E_Out_Parameter
2697 | E_In_Out_Parameter
2699 Is_Writable_Actual
:= True;
2705 Next_Formal
(Formal
);
2706 Next_Actual
(Actual
);
2712 if Is_Writable_Actual
then
2714 -- Skip checking the error in non-elementary types since
2715 -- RM 6.4.1(6.15/3) is restricted to elementary types, but
2716 -- store this actual in Writable_Actuals_List since it is
2717 -- needed to perform checks on other constructs that have
2718 -- arbitrary order of evaluation (for example, aggregates).
2720 if not Is_Elementary_Type
(Etype
(N
)) then
2721 if not Contains
(Writable_Actuals_List
, N
) then
2722 Append_New_Elmt
(N
, To
=> Writable_Actuals_List
);
2725 -- Second occurrence of an elementary type writable actual
2727 elsif Contains
(Writable_Actuals_List
, N
) then
2729 -- Report the error on the second occurrence of the
2730 -- identifier. We cannot assume that N is the second
2731 -- occurrence (according to their location in the
2732 -- sources), since Traverse_Func walks through Field2
2733 -- last (see comment in the body of Traverse_Func).
2739 Elmt
:= First_Elmt
(Writable_Actuals_List
);
2740 while Present
(Elmt
)
2741 and then Entity
(Node
(Elmt
)) /= Entity
(N
)
2746 if Sloc
(N
) > Sloc
(Node
(Elmt
)) then
2749 Error_Node
:= Node
(Elmt
);
2753 ("value may be affected by call to & "
2754 & "because order of evaluation is arbitrary",
2759 -- First occurrence of a elementary type writable actual
2762 Append_New_Elmt
(N
, To
=> Writable_Actuals_List
);
2766 if No
(Identifiers_List
) then
2767 Identifiers_List
:= New_Elmt_List
;
2770 Append_Unique_Elmt
(N
, Identifiers_List
);
2783 N
: Node_Id
) return Boolean
2785 pragma Assert
(Nkind
(N
) in N_Has_Entity
);
2794 Elmt
:= First_Elmt
(List
);
2795 while Present
(Elmt
) loop
2796 if Entity
(Node
(Elmt
)) = Entity
(N
) then
2810 procedure Do_Traversal
is new Traverse_Proc
(Check_Node
);
2811 -- The traversal procedure
2813 -- Start of processing for Collect_Identifiers
2816 if Present
(Error_Node
) then
2820 if Nkind
(N
) in N_Subexpr
and then Is_OK_Static_Expression
(N
) then
2825 end Collect_Identifiers
;
2827 -- Start of processing for Check_Function_Writable_Actuals
2830 -- The check only applies to Ada 2012 code on which Check_Actuals has
2831 -- been set, and only to constructs that have multiple constituents
2832 -- whose order of evaluation is not specified by the language.
2834 if Ada_Version
< Ada_2012
2835 or else not Check_Actuals
(N
)
2836 or else Nkind
(N
) not in N_Op
2840 | N_Extension_Aggregate
2841 | N_Full_Type_Declaration
2843 | N_Procedure_Call_Statement
2844 | N_Entry_Call_Statement
2845 or else (Nkind
(N
) = N_Full_Type_Declaration
2846 and then not Is_Record_Type
(Defining_Identifier
(N
)))
2848 -- In addition, this check only applies to source code, not to code
2849 -- generated by constraint checks.
2851 or else not Comes_From_Source
(N
)
2856 -- If a construct C has two or more direct constituents that are names
2857 -- or expressions whose evaluation may occur in an arbitrary order, at
2858 -- least one of which contains a function call with an in out or out
2859 -- parameter, then the construct is legal only if: for each name N that
2860 -- is passed as a parameter of mode in out or out to some inner function
2861 -- call C2 (not including the construct C itself), there is no other
2862 -- name anywhere within a direct constituent of the construct C other
2863 -- than the one containing C2, that is known to refer to the same
2864 -- object (RM 6.4.1(6.17/3)).
2868 Collect_Identifiers
(Low_Bound
(N
));
2869 Collect_Identifiers
(High_Bound
(N
));
2871 when N_Membership_Test
2878 Collect_Identifiers
(Left_Opnd
(N
));
2880 if Present
(Right_Opnd
(N
)) then
2881 Collect_Identifiers
(Right_Opnd
(N
));
2884 if Nkind
(N
) in N_In | N_Not_In
2885 and then Present
(Alternatives
(N
))
2887 Expr
:= First
(Alternatives
(N
));
2888 while Present
(Expr
) loop
2889 Collect_Identifiers
(Expr
);
2896 when N_Full_Type_Declaration
=>
2898 function Get_Record_Part
(N
: Node_Id
) return Node_Id
;
2899 -- Return the record part of this record type definition
2901 function Get_Record_Part
(N
: Node_Id
) return Node_Id
is
2902 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
2904 if Nkind
(Type_Def
) = N_Derived_Type_Definition
then
2905 return Record_Extension_Part
(Type_Def
);
2909 end Get_Record_Part
;
2912 Def_Id
: Entity_Id
:= Defining_Identifier
(N
);
2913 Rec
: Node_Id
:= Get_Record_Part
(N
);
2916 -- No need to perform any analysis if the record has no
2919 if No
(Rec
) or else No
(Component_List
(Rec
)) then
2923 -- Collect the identifiers starting from the deepest
2924 -- derivation. Done to report the error in the deepest
2928 if Present
(Component_List
(Rec
)) then
2929 Comp
:= First
(Component_Items
(Component_List
(Rec
)));
2930 while Present
(Comp
) loop
2931 if Nkind
(Comp
) = N_Component_Declaration
2932 and then Present
(Expression
(Comp
))
2934 Collect_Identifiers
(Expression
(Comp
));
2941 exit when No
(Underlying_Type
(Etype
(Def_Id
)))
2942 or else Base_Type
(Underlying_Type
(Etype
(Def_Id
)))
2945 Def_Id
:= Base_Type
(Underlying_Type
(Etype
(Def_Id
)));
2946 Rec
:= Get_Record_Part
(Parent
(Def_Id
));
2950 when N_Entry_Call_Statement
2954 Id
: constant Entity_Id
:= Get_Called_Entity
(N
);
2959 Formal
:= First_Formal
(Id
);
2960 Actual
:= First_Actual
(N
);
2961 while Present
(Actual
) and then Present
(Formal
) loop
2962 if Ekind
(Formal
) in E_Out_Parameter | E_In_Out_Parameter
2964 Collect_Identifiers
(Actual
);
2967 Next_Formal
(Formal
);
2968 Next_Actual
(Actual
);
2973 | N_Extension_Aggregate
2978 Comp_Expr
: Node_Id
;
2981 -- Handle the N_Others_Choice of array aggregates with static
2982 -- bounds. There is no need to perform this analysis in
2983 -- aggregates without static bounds since we cannot evaluate
2984 -- if the N_Others_Choice covers several elements. There is
2985 -- no need to handle the N_Others choice of record aggregates
2986 -- since at this stage it has been already expanded by
2987 -- Resolve_Record_Aggregate.
2989 if Is_Array_Type
(Etype
(N
))
2990 and then Nkind
(N
) = N_Aggregate
2991 and then Present
(Aggregate_Bounds
(N
))
2992 and then Compile_Time_Known_Bounds
(Etype
(N
))
2993 and then Expr_Value
(High_Bound
(Aggregate_Bounds
(N
)))
2995 Expr_Value
(Low_Bound
(Aggregate_Bounds
(N
)))
2998 Count_Components
: Uint
:= Uint_0
;
2999 Num_Components
: Uint
;
3000 Others_Assoc
: Node_Id
:= Empty
;
3001 Others_Choice
: Node_Id
:= Empty
;
3002 Others_Box_Present
: Boolean := False;
3005 -- Count positional associations
3007 if Present
(Expressions
(N
)) then
3008 Comp_Expr
:= First
(Expressions
(N
));
3009 while Present
(Comp_Expr
) loop
3010 Count_Components
:= Count_Components
+ 1;
3015 -- Count the rest of elements and locate the N_Others
3018 Assoc
:= First
(Component_Associations
(N
));
3019 while Present
(Assoc
) loop
3020 Choice
:= First
(Choices
(Assoc
));
3021 while Present
(Choice
) loop
3022 if Nkind
(Choice
) = N_Others_Choice
then
3023 Others_Assoc
:= Assoc
;
3024 Others_Choice
:= Choice
;
3025 Others_Box_Present
:= Box_Present
(Assoc
);
3027 -- Count several components
3029 elsif Nkind
(Choice
) in
3030 N_Range | N_Subtype_Indication
3031 or else (Is_Entity_Name
(Choice
)
3032 and then Is_Type
(Entity
(Choice
)))
3037 Get_Index_Bounds
(Choice
, L
, H
);
3039 (Compile_Time_Known_Value
(L
)
3040 and then Compile_Time_Known_Value
(H
));
3043 + Expr_Value
(H
) - Expr_Value
(L
) + 1;
3046 -- Count single component. No other case available
3047 -- since we are handling an aggregate with static
3051 pragma Assert
(Is_OK_Static_Expression
(Choice
)
3052 or else Nkind
(Choice
) = N_Identifier
3053 or else Nkind
(Choice
) = N_Integer_Literal
);
3055 Count_Components
:= Count_Components
+ 1;
3065 Expr_Value
(High_Bound
(Aggregate_Bounds
(N
))) -
3066 Expr_Value
(Low_Bound
(Aggregate_Bounds
(N
))) + 1;
3068 pragma Assert
(Count_Components
<= Num_Components
);
3070 -- Handle the N_Others choice if it covers several
3073 if Present
(Others_Choice
)
3074 and then (Num_Components
- Count_Components
) > 1
3076 if not Others_Box_Present
then
3078 -- At this stage, if expansion is active, the
3079 -- expression of the others choice has not been
3080 -- analyzed. Hence we generate a duplicate and
3081 -- we analyze it silently to have available the
3082 -- minimum decoration required to collect the
3085 pragma Assert
(Present
(Others_Assoc
));
3087 if not Expander_Active
then
3088 Comp_Expr
:= Expression
(Others_Assoc
);
3091 New_Copy_Tree
(Expression
(Others_Assoc
));
3092 Preanalyze_Without_Errors
(Comp_Expr
);
3095 Collect_Identifiers
(Comp_Expr
);
3097 if Present
(Writable_Actuals_List
) then
3099 -- As suggested by Robert, at current stage we
3100 -- report occurrences of this case as warnings.
3103 ("writable function parameter may affect "
3104 & "value in other component because order "
3105 & "of evaluation is unspecified??",
3106 Node
(First_Elmt
(Writable_Actuals_List
)));
3112 -- For an array aggregate, a discrete_choice_list that has
3113 -- a nonstatic range is considered as two or more separate
3114 -- occurrences of the expression (RM 6.4.1(20/3)).
3116 elsif Is_Array_Type
(Etype
(N
))
3117 and then Nkind
(N
) = N_Aggregate
3118 and then Present
(Aggregate_Bounds
(N
))
3119 and then not Compile_Time_Known_Bounds
(Etype
(N
))
3121 -- Collect identifiers found in the dynamic bounds
3124 Count_Components
: Natural := 0;
3125 Low
, High
: Node_Id
;
3128 Assoc
:= First
(Component_Associations
(N
));
3129 while Present
(Assoc
) loop
3130 Choice
:= First
(Choices
(Assoc
));
3131 while Present
(Choice
) loop
3132 if Nkind
(Choice
) in
3133 N_Range | N_Subtype_Indication
3134 or else (Is_Entity_Name
(Choice
)
3135 and then Is_Type
(Entity
(Choice
)))
3137 Get_Index_Bounds
(Choice
, Low
, High
);
3139 if not Compile_Time_Known_Value
(Low
) then
3140 Collect_Identifiers
(Low
);
3142 if No
(Aggr_Error_Node
) then
3143 Aggr_Error_Node
:= Low
;
3147 if not Compile_Time_Known_Value
(High
) then
3148 Collect_Identifiers
(High
);
3150 if No
(Aggr_Error_Node
) then
3151 Aggr_Error_Node
:= High
;
3155 -- The RM rule is violated if there is more than
3156 -- a single choice in a component association.
3159 Count_Components
:= Count_Components
+ 1;
3161 if No
(Aggr_Error_Node
)
3162 and then Count_Components
> 1
3164 Aggr_Error_Node
:= Choice
;
3167 if not Compile_Time_Known_Value
(Choice
) then
3168 Collect_Identifiers
(Choice
);
3180 -- Handle ancestor part of extension aggregates
3182 if Nkind
(N
) = N_Extension_Aggregate
then
3183 Collect_Identifiers
(Ancestor_Part
(N
));
3186 -- Handle positional associations
3188 if Present
(Expressions
(N
)) then
3189 Comp_Expr
:= First
(Expressions
(N
));
3190 while Present
(Comp_Expr
) loop
3191 if not Is_OK_Static_Expression
(Comp_Expr
) then
3192 Collect_Identifiers
(Comp_Expr
);
3199 -- Handle discrete associations
3201 if Present
(Component_Associations
(N
)) then
3202 Assoc
:= First
(Component_Associations
(N
));
3203 while Present
(Assoc
) loop
3205 if not Box_Present
(Assoc
) then
3206 Choice
:= First
(Choices
(Assoc
));
3207 while Present
(Choice
) loop
3209 -- For now we skip discriminants since it requires
3210 -- performing the analysis in two phases: first one
3211 -- analyzing discriminants and second one analyzing
3212 -- the rest of components since discriminants are
3213 -- evaluated prior to components: too much extra
3214 -- work to detect a corner case???
3216 if Nkind
(Choice
) in N_Has_Entity
3217 and then Present
(Entity
(Choice
))
3218 and then Ekind
(Entity
(Choice
)) = E_Discriminant
3222 elsif Box_Present
(Assoc
) then
3226 if not Analyzed
(Expression
(Assoc
)) then
3228 New_Copy_Tree
(Expression
(Assoc
));
3229 Set_Parent
(Comp_Expr
, Parent
(N
));
3230 Preanalyze_Without_Errors
(Comp_Expr
);
3232 Comp_Expr
:= Expression
(Assoc
);
3235 Collect_Identifiers
(Comp_Expr
);
3251 -- No further action needed if we already reported an error
3253 if Present
(Error_Node
) then
3257 -- Check violation of RM 6.20/3 in aggregates
3259 if Present
(Aggr_Error_Node
)
3260 and then Present
(Writable_Actuals_List
)
3263 ("value may be affected by call in other component because they "
3264 & "are evaluated in unspecified order",
3265 Node
(First_Elmt
(Writable_Actuals_List
)));
3269 -- Check if some writable argument of a function is referenced
3271 if Present
(Writable_Actuals_List
)
3272 and then Present
(Identifiers_List
)
3279 Elmt_1
:= First_Elmt
(Writable_Actuals_List
);
3280 while Present
(Elmt_1
) loop
3281 Elmt_2
:= First_Elmt
(Identifiers_List
);
3282 while Present
(Elmt_2
) loop
3283 if Entity
(Node
(Elmt_1
)) = Entity
(Node
(Elmt_2
)) then
3284 case Nkind
(Parent
(Node
(Elmt_2
))) is
3286 | N_Component_Association
3287 | N_Component_Declaration
3290 ("value may be affected by call in other "
3291 & "component because they are evaluated "
3292 & "in unspecified order",
3299 ("value may be affected by call in other "
3300 & "alternative because they are evaluated "
3301 & "in unspecified order",
3306 ("value of actual may be affected by call in "
3307 & "other actual because they are evaluated "
3308 & "in unspecified order",
3320 end Check_Function_Writable_Actuals
;
3322 --------------------------------
3323 -- Check_Implicit_Dereference --
3324 --------------------------------
3326 procedure Check_Implicit_Dereference
(N
: Node_Id
; Typ
: Entity_Id
) is
3332 if Nkind
(N
) = N_Indexed_Component
3333 and then Present
(Generalized_Indexing
(N
))
3335 Nam
:= Generalized_Indexing
(N
);
3340 if Ada_Version
< Ada_2012
3341 or else not Has_Implicit_Dereference
(Base_Type
(Typ
))
3345 elsif not Comes_From_Source
(N
)
3346 and then Nkind
(N
) /= N_Indexed_Component
3350 elsif Is_Entity_Name
(Nam
) and then Is_Type
(Entity
(Nam
)) then
3354 Disc
:= First_Discriminant
(Typ
);
3355 while Present
(Disc
) loop
3356 if Has_Implicit_Dereference
(Disc
) then
3357 Desig
:= Designated_Type
(Etype
(Disc
));
3358 Add_One_Interp
(Nam
, Disc
, Desig
);
3360 -- If the node is a generalized indexing, add interpretation
3361 -- to that node as well, for subsequent resolution.
3363 if Nkind
(N
) = N_Indexed_Component
then
3364 Add_One_Interp
(N
, Disc
, Desig
);
3367 -- If the operation comes from a generic unit and the context
3368 -- is a selected component, the selector name may be global
3369 -- and set in the instance already. Remove the entity to
3370 -- force resolution of the selected component, and the
3371 -- generation of an explicit dereference if needed.
3374 and then Nkind
(Parent
(Nam
)) = N_Selected_Component
3376 Set_Entity
(Selector_Name
(Parent
(Nam
)), Empty
);
3382 Next_Discriminant
(Disc
);
3385 end Check_Implicit_Dereference
;
3387 ----------------------------------
3388 -- Check_Internal_Protected_Use --
3389 ----------------------------------
3391 procedure Check_Internal_Protected_Use
(N
: Node_Id
; Nam
: Entity_Id
) is
3399 while Present
(S
) loop
3400 if S
= Standard_Standard
then
3403 elsif Ekind
(S
) = E_Function
3404 and then Ekind
(Scope
(S
)) = E_Protected_Type
3414 and then Scope
(Nam
) = Prot
3415 and then Ekind
(Nam
) /= E_Function
3417 -- An indirect function call (e.g. a callback within a protected
3418 -- function body) is not statically illegal. If the access type is
3419 -- anonymous and is the type of an access parameter, the scope of Nam
3420 -- will be the protected type, but it is not a protected operation.
3422 if Ekind
(Nam
) = E_Subprogram_Type
3423 and then Nkind
(Associated_Node_For_Itype
(Nam
)) =
3424 N_Function_Specification
3428 elsif Nkind
(N
) = N_Subprogram_Renaming_Declaration
then
3430 ("within protected function cannot use protected procedure in "
3431 & "renaming or as generic actual", N
);
3433 elsif Nkind
(N
) = N_Attribute_Reference
then
3435 ("within protected function cannot take access of protected "
3440 ("within protected function, protected object is constant", N
);
3442 ("\cannot call operation that may modify it", N
);
3446 -- Verify that an internal call does not appear within a precondition
3447 -- of a protected operation. This implements AI12-0166.
3448 -- The precondition aspect has been rewritten as a pragma Precondition
3449 -- and we check whether the scope of the called subprogram is the same
3450 -- as that of the entity to which the aspect applies.
3452 if Convention
(Nam
) = Convention_Protected
then
3458 while Present
(P
) loop
3459 if Nkind
(P
) = N_Pragma
3460 and then Chars
(Pragma_Identifier
(P
)) = Name_Precondition
3461 and then From_Aspect_Specification
(P
)
3463 Scope
(Entity
(Corresponding_Aspect
(P
))) = Scope
(Nam
)
3466 ("internal call cannot appear in precondition of "
3467 & "protected operation", N
);
3470 elsif Nkind
(P
) = N_Pragma
3471 and then Chars
(Pragma_Identifier
(P
)) = Name_Contract_Cases
3473 -- Check whether call is in a case guard. It is legal in a
3477 while Present
(P
) loop
3478 if Nkind
(Parent
(P
)) = N_Component_Association
3479 and then P
/= Expression
(Parent
(P
))
3482 ("internal call cannot appear in case guard in a "
3483 & "contract case", N
);
3491 elsif Nkind
(P
) = N_Parameter_Specification
3492 and then Scope
(Current_Scope
) = Scope
(Nam
)
3493 and then Nkind
(Parent
(P
)) in
3494 N_Entry_Declaration | N_Subprogram_Declaration
3497 ("internal call cannot appear in default for formal of "
3498 & "protected operation", N
);
3506 end Check_Internal_Protected_Use
;
3508 ---------------------------------------
3509 -- Check_Later_Vs_Basic_Declarations --
3510 ---------------------------------------
3512 procedure Check_Later_Vs_Basic_Declarations
3514 During_Parsing
: Boolean)
3516 Body_Sloc
: Source_Ptr
;
3519 function Is_Later_Declarative_Item
(Decl
: Node_Id
) return Boolean;
3520 -- Return whether Decl is considered as a declarative item.
3521 -- When During_Parsing is True, the semantics of Ada 83 is followed.
3522 -- When During_Parsing is False, the semantics of SPARK is followed.
3524 -------------------------------
3525 -- Is_Later_Declarative_Item --
3526 -------------------------------
3528 function Is_Later_Declarative_Item
(Decl
: Node_Id
) return Boolean is
3530 if Nkind
(Decl
) in N_Later_Decl_Item
then
3533 elsif Nkind
(Decl
) = N_Pragma
then
3536 elsif During_Parsing
then
3539 -- In SPARK, a package declaration is not considered as a later
3540 -- declarative item.
3542 elsif Nkind
(Decl
) = N_Package_Declaration
then
3545 -- In SPARK, a renaming is considered as a later declarative item
3547 elsif Nkind
(Decl
) in N_Renaming_Declaration
then
3553 end Is_Later_Declarative_Item
;
3555 -- Start of processing for Check_Later_Vs_Basic_Declarations
3558 Decl
:= First
(Decls
);
3560 -- Loop through sequence of basic declarative items
3562 Outer
: while Present
(Decl
) loop
3563 if Nkind
(Decl
) not in
3564 N_Subprogram_Body | N_Package_Body | N_Task_Body
3565 and then Nkind
(Decl
) not in N_Body_Stub
3569 -- Once a body is encountered, we only allow later declarative
3570 -- items. The inner loop checks the rest of the list.
3573 Body_Sloc
:= Sloc
(Decl
);
3575 Inner
: while Present
(Decl
) loop
3576 if not Is_Later_Declarative_Item
(Decl
) then
3577 if During_Parsing
then
3578 if Ada_Version
= Ada_83
then
3579 Error_Msg_Sloc
:= Body_Sloc
;
3581 ("(Ada 83) decl cannot appear after body#", Decl
);
3590 end Check_Later_Vs_Basic_Declarations
;
3592 ---------------------------
3593 -- Check_No_Hidden_State --
3594 ---------------------------
3596 procedure Check_No_Hidden_State
(Id
: Entity_Id
) is
3597 Context
: Entity_Id
:= Empty
;
3598 Not_Visible
: Boolean := False;
3602 pragma Assert
(Ekind
(Id
) in E_Abstract_State | E_Variable
);
3604 -- Nothing to do for internally-generated abstract states and variables
3605 -- because they do not represent the hidden state of the source unit.
3607 if not Comes_From_Source
(Id
) then
3611 -- Find the proper context where the object or state appears
3614 while Present
(Scop
) loop
3617 -- Keep track of the context's visibility
3619 Not_Visible
:= Not_Visible
or else In_Private_Part
(Context
);
3621 -- Prevent the search from going too far
3623 if Context
= Standard_Standard
then
3626 -- Objects and states that appear immediately within a subprogram or
3627 -- entry inside a construct nested within a subprogram do not
3628 -- introduce a hidden state. They behave as local variable
3629 -- declarations. The same is true for elaboration code inside a block
3632 elsif Is_Subprogram_Or_Entry
(Context
)
3633 or else Ekind
(Context
) in E_Block | E_Task_Type
3638 -- Stop the traversal when a package subject to a null abstract state
3641 if Is_Package_Or_Generic_Package
(Context
)
3642 and then Has_Null_Abstract_State
(Context
)
3647 Scop
:= Scope
(Scop
);
3650 -- At this point we know that there is at least one package with a null
3651 -- abstract state in visibility. Emit an error message unconditionally
3652 -- if the entity being processed is a state because the placement of the
3653 -- related package is irrelevant. This is not the case for objects as
3654 -- the intermediate context matters.
3656 if Present
(Context
)
3657 and then (Ekind
(Id
) = E_Abstract_State
or else Not_Visible
)
3659 Error_Msg_N
("cannot introduce hidden state &", Id
);
3660 Error_Msg_NE
("\package & has null abstract state", Id
, Context
);
3662 end Check_No_Hidden_State
;
3664 ---------------------------------------------
3665 -- Check_Nonoverridable_Aspect_Consistency --
3666 ---------------------------------------------
3668 procedure Check_Inherited_Nonoverridable_Aspects
3669 (Inheritor
: Entity_Id
;
3670 Interface_List
: List_Id
;
3671 Parent_Type
: Entity_Id
) is
3673 -- array needed for iterating over subtype values
3674 Nonoverridable_Aspects
: constant array (Positive range <>) of
3675 Nonoverridable_Aspect_Id
:=
3676 (Aspect_Default_Iterator
,
3677 Aspect_Iterator_Element
,
3678 Aspect_Implicit_Dereference
,
3679 Aspect_Constant_Indexing
,
3680 Aspect_Variable_Indexing
,
3682 Aspect_Max_Entry_Queue_Length
3683 -- , Aspect_No_Controlled_Parts
3686 -- Note that none of these 8 aspects can be specified (for a type)
3687 -- via a pragma. For 7 of them, the corresponding pragma does not
3688 -- exist. The Pragma_Id enumeration type does include
3689 -- Pragma_Max_Entry_Queue_Length, but that pragma is only use to
3690 -- specify the aspect for a protected entry or entry family, not for
3691 -- a type, and therefore cannot introduce the sorts of inheritance
3692 -- issues that we are concerned with in this procedure.
3694 type Entity_Array
is array (Nat
range <>) of Entity_Id
;
3696 function Ancestor_Entities
return Entity_Array
;
3697 -- Returns all progenitors (including parent type, if present)
3699 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors
3700 (Aspect
: Nonoverridable_Aspect_Id
;
3701 Ancestor_1
: Entity_Id
;
3702 Aspect_Spec_1
: Node_Id
;
3703 Ancestor_2
: Entity_Id
;
3704 Aspect_Spec_2
: Node_Id
);
3705 -- A given aspect has been specified for each of two ancestors;
3706 -- check that the two aspect specifications are compatible (see
3707 -- RM 13.1.1(18.5) and AI12-0211).
3709 -----------------------
3710 -- Ancestor_Entities --
3711 -----------------------
3713 function Ancestor_Entities
return Entity_Array
is
3714 Ifc_Count
: constant Nat
:= List_Length
(Interface_List
);
3715 Ifc_Ancestors
: Entity_Array
(1 .. Ifc_Count
);
3716 Ifc
: Node_Id
:= First
(Interface_List
);
3718 for Idx
in Ifc_Ancestors
'Range loop
3719 Ifc_Ancestors
(Idx
) := Entity
(Ifc
);
3720 pragma Assert
(Present
(Ifc_Ancestors
(Idx
)));
3723 pragma Assert
(No
(Ifc
));
3724 if Present
(Parent_Type
) then
3725 return Parent_Type
& Ifc_Ancestors
;
3727 return Ifc_Ancestors
;
3729 end Ancestor_Entities
;
3731 -------------------------------------------------------
3732 -- Check_Consistency_For_One_Aspect_Of_Two_Ancestors --
3733 -------------------------------------------------------
3735 procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors
3736 (Aspect
: Nonoverridable_Aspect_Id
;
3737 Ancestor_1
: Entity_Id
;
3738 Aspect_Spec_1
: Node_Id
;
3739 Ancestor_2
: Entity_Id
;
3740 Aspect_Spec_2
: Node_Id
) is
3742 if not Is_Confirming
(Aspect
, Aspect_Spec_1
, Aspect_Spec_2
) then
3743 Error_Msg_Name_1
:= Aspect_Names
(Aspect
);
3744 Error_Msg_Name_2
:= Chars
(Ancestor_1
);
3745 Error_Msg_Name_3
:= Chars
(Ancestor_2
);
3748 "incompatible % aspects inherited from ancestors % and %",
3751 end Check_Consistency_For_One_Aspect_Of_Two_Ancestors
;
3753 Ancestors
: constant Entity_Array
:= Ancestor_Entities
;
3755 -- start of processing for Check_Inherited_Nonoverridable_Aspects
3757 -- No Ada_Version check here; AI12-0211 is a binding interpretation.
3759 if Ancestors
'Length < 2 then
3760 return; -- Inconsistency impossible; it takes 2 to disagree.
3761 elsif In_Instance_Body
then
3762 return; -- No legality checking in an instance body.
3765 for Aspect
of Nonoverridable_Aspects
loop
3767 First_Ancestor_With_Aspect
: Entity_Id
:= Empty
;
3768 First_Aspect_Spec
, Current_Aspect_Spec
: Node_Id
:= Empty
;
3770 for Ancestor
of Ancestors
loop
3771 Current_Aspect_Spec
:= Find_Aspect
(Ancestor
, Aspect
);
3772 if Present
(Current_Aspect_Spec
) then
3773 if Present
(First_Ancestor_With_Aspect
) then
3774 Check_Consistency_For_One_Aspect_Of_Two_Ancestors
3776 Ancestor_1
=> First_Ancestor_With_Aspect
,
3777 Aspect_Spec_1
=> First_Aspect_Spec
,
3778 Ancestor_2
=> Ancestor
,
3779 Aspect_Spec_2
=> Current_Aspect_Spec
);
3781 First_Ancestor_With_Aspect
:= Ancestor
;
3782 First_Aspect_Spec
:= Current_Aspect_Spec
;
3788 end Check_Inherited_Nonoverridable_Aspects
;
3790 ----------------------------------------
3791 -- Check_Nonvolatile_Function_Profile --
3792 ----------------------------------------
3794 procedure Check_Nonvolatile_Function_Profile
(Func_Id
: Entity_Id
) is
3798 -- Inspect all formal parameters
3800 Formal
:= First_Formal
(Func_Id
);
3801 while Present
(Formal
) loop
3802 if Is_Effectively_Volatile_For_Reading
(Etype
(Formal
)) then
3804 ("nonvolatile function & cannot have a volatile parameter",
3808 Next_Formal
(Formal
);
3811 -- Inspect the return type
3813 if Is_Effectively_Volatile_For_Reading
(Etype
(Func_Id
)) then
3815 ("nonvolatile function & cannot have a volatile return type",
3816 Result_Definition
(Parent
(Func_Id
)), Func_Id
);
3818 end Check_Nonvolatile_Function_Profile
;
3824 function Check_Parents
(N
: Node_Id
; List
: Elist_Id
) return Boolean is
3827 (Parent_Node
: Node_Id
;
3828 N
: Node_Id
) return Traverse_Result
;
3829 -- Process a single node.
3836 (Parent_Node
: Node_Id
;
3837 N
: Node_Id
) return Traverse_Result
is
3839 if Nkind
(N
) = N_Identifier
3840 and then Parent
(N
) /= Parent_Node
3841 and then Present
(Entity
(N
))
3842 and then Contains
(List
, Entity
(N
))
3850 function Traverse
is new Traverse_Func_With_Parent
(Check_Node
);
3852 -- Start of processing for Check_Parents
3855 return Traverse
(N
) = OK
;
3858 -----------------------------
3859 -- Check_Part_Of_Reference --
3860 -----------------------------
3862 procedure Check_Part_Of_Reference
(Var_Id
: Entity_Id
; Ref
: Node_Id
) is
3863 function Is_Enclosing_Package_Body
3864 (Body_Decl
: Node_Id
;
3865 Obj_Id
: Entity_Id
) return Boolean;
3866 pragma Inline
(Is_Enclosing_Package_Body
);
3867 -- Determine whether package body Body_Decl or its corresponding spec
3868 -- immediately encloses the declaration of object Obj_Id.
3870 function Is_Internal_Declaration_Or_Body
3871 (Decl
: Node_Id
) return Boolean;
3872 pragma Inline
(Is_Internal_Declaration_Or_Body
);
3873 -- Determine whether declaration or body denoted by Decl is internal
3875 function Is_Single_Declaration_Or_Body
3877 Conc_Typ
: Entity_Id
) return Boolean;
3878 pragma Inline
(Is_Single_Declaration_Or_Body
);
3879 -- Determine whether protected/task declaration or body denoted by Decl
3880 -- belongs to single concurrent type Conc_Typ.
3882 function Is_Single_Task_Pragma
3884 Task_Typ
: Entity_Id
) return Boolean;
3885 pragma Inline
(Is_Single_Task_Pragma
);
3886 -- Determine whether pragma Prag belongs to single task type Task_Typ
3888 -------------------------------
3889 -- Is_Enclosing_Package_Body --
3890 -------------------------------
3892 function Is_Enclosing_Package_Body
3893 (Body_Decl
: Node_Id
;
3894 Obj_Id
: Entity_Id
) return Boolean
3896 Obj_Context
: Node_Id
;
3899 -- Find the context of the object declaration
3901 Obj_Context
:= Parent
(Declaration_Node
(Obj_Id
));
3903 if Nkind
(Obj_Context
) = N_Package_Specification
then
3904 Obj_Context
:= Parent
(Obj_Context
);
3907 -- The object appears immediately within the package body
3909 if Obj_Context
= Body_Decl
then
3912 -- The object appears immediately within the corresponding spec
3914 elsif Nkind
(Obj_Context
) = N_Package_Declaration
3915 and then Unit_Declaration_Node
(Corresponding_Spec
(Body_Decl
)) =
3922 end Is_Enclosing_Package_Body
;
3924 -------------------------------------
3925 -- Is_Internal_Declaration_Or_Body --
3926 -------------------------------------
3928 function Is_Internal_Declaration_Or_Body
3929 (Decl
: Node_Id
) return Boolean
3932 if Comes_From_Source
(Decl
) then
3935 -- A body generated for an expression function which has not been
3936 -- inserted into the tree yet (In_Spec_Expression is True) is not
3937 -- considered internal.
3939 elsif Nkind
(Decl
) = N_Subprogram_Body
3940 and then Was_Expression_Function
(Decl
)
3941 and then not In_Spec_Expression
3947 end Is_Internal_Declaration_Or_Body
;
3949 -----------------------------------
3950 -- Is_Single_Declaration_Or_Body --
3951 -----------------------------------
3953 function Is_Single_Declaration_Or_Body
3955 Conc_Typ
: Entity_Id
) return Boolean
3957 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
3961 Present
(Anonymous_Object
(Spec_Id
))
3962 and then Anonymous_Object
(Spec_Id
) = Conc_Typ
;
3963 end Is_Single_Declaration_Or_Body
;
3965 ---------------------------
3966 -- Is_Single_Task_Pragma --
3967 ---------------------------
3969 function Is_Single_Task_Pragma
3971 Task_Typ
: Entity_Id
) return Boolean
3973 Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(Prag
);
3976 -- To qualify, the pragma must be associated with single task type
3980 Is_Single_Task_Object
(Task_Typ
)
3981 and then Nkind
(Decl
) = N_Object_Declaration
3982 and then Defining_Entity
(Decl
) = Task_Typ
;
3983 end Is_Single_Task_Pragma
;
3987 Conc_Obj
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
3992 -- Start of processing for Check_Part_Of_Reference
3995 -- Nothing to do when the variable was recorded, but did not become a
3996 -- constituent of a single concurrent type.
3998 if No
(Conc_Obj
) then
4002 -- Traverse the parent chain looking for a suitable context for the
4003 -- reference to the concurrent constituent.
4006 Par
:= Parent
(Prev
);
4007 while Present
(Par
) loop
4008 if Nkind
(Par
) = N_Pragma
then
4009 Prag_Nam
:= Pragma_Name
(Par
);
4011 -- A concurrent constituent is allowed to appear in pragmas
4012 -- Initial_Condition and Initializes as this is part of the
4013 -- elaboration checks for the constituent (SPARK RM 9(3)).
4015 if Prag_Nam
in Name_Initial_Condition | Name_Initializes
then
4018 -- When the reference appears within pragma Depends or Global,
4019 -- check whether the pragma applies to a single task type. Note
4020 -- that the pragma may not encapsulated by the type definition,
4021 -- but this is still a valid context.
4023 elsif Prag_Nam
in Name_Depends | Name_Global
4024 and then Is_Single_Task_Pragma
(Par
, Conc_Obj
)
4029 -- The reference appears somewhere in the definition of a single
4030 -- concurrent type (SPARK RM 9(3)).
4032 elsif Nkind
(Par
) in
4033 N_Single_Protected_Declaration | N_Single_Task_Declaration
4034 and then Defining_Entity
(Par
) = Conc_Obj
4038 -- The reference appears within the declaration or body of a single
4039 -- concurrent type (SPARK RM 9(3)).
4041 elsif Nkind
(Par
) in N_Protected_Body
4042 | N_Protected_Type_Declaration
4044 | N_Task_Type_Declaration
4045 and then Is_Single_Declaration_Or_Body
(Par
, Conc_Obj
)
4049 -- The reference appears within the statement list of the object's
4050 -- immediately enclosing package (SPARK RM 9(3)).
4052 elsif Nkind
(Par
) = N_Package_Body
4053 and then Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
4054 and then Is_Enclosing_Package_Body
(Par
, Var_Id
)
4058 -- The reference has been relocated within an internally generated
4059 -- package or subprogram. Assume that the reference is legal as the
4060 -- real check was already performed in the original context of the
4063 elsif Nkind
(Par
) in N_Package_Body
4064 | N_Package_Declaration
4066 | N_Subprogram_Declaration
4067 and then Is_Internal_Declaration_Or_Body
(Par
)
4071 -- The reference has been relocated to an inlined body for GNATprove.
4072 -- Assume that the reference is legal as the real check was already
4073 -- performed in the original context of the reference.
4075 elsif GNATprove_Mode
4076 and then Nkind
(Par
) = N_Subprogram_Body
4077 and then Chars
(Defining_Entity
(Par
)) = Name_uParent
4083 Par
:= Parent
(Prev
);
4086 -- At this point it is known that the reference does not appear within a
4090 ("reference to variable & cannot appear in this context", Ref
, Var_Id
);
4091 Error_Msg_Name_1
:= Chars
(Var_Id
);
4093 if Is_Single_Protected_Object
(Conc_Obj
) then
4095 ("\% is constituent of single protected type &", Ref
, Conc_Obj
);
4099 ("\% is constituent of single task type &", Ref
, Conc_Obj
);
4101 end Check_Part_Of_Reference
;
4103 ------------------------------------------
4104 -- Check_Potentially_Blocking_Operation --
4105 ------------------------------------------
4107 procedure Check_Potentially_Blocking_Operation
(N
: Node_Id
) is
4111 -- N is one of the potentially blocking operations listed in 9.5.1(8).
4112 -- When pragma Detect_Blocking is active, the run time will raise
4113 -- Program_Error. Here we only issue a warning, since we generally
4114 -- support the use of potentially blocking operations in the absence
4117 -- Indirect blocking through a subprogram call cannot be diagnosed
4118 -- statically without interprocedural analysis, so we do not attempt
4121 S
:= Scope
(Current_Scope
);
4122 while Present
(S
) and then S
/= Standard_Standard
loop
4123 if Is_Protected_Type
(S
) then
4125 ("potentially blocking operation in protected operation??", N
);
4131 end Check_Potentially_Blocking_Operation
;
4133 ------------------------------------
4134 -- Check_Previous_Null_Procedure --
4135 ------------------------------------
4137 procedure Check_Previous_Null_Procedure
4142 if Ekind
(Prev
) = E_Procedure
4143 and then Nkind
(Parent
(Prev
)) = N_Procedure_Specification
4144 and then Null_Present
(Parent
(Prev
))
4146 Error_Msg_Sloc
:= Sloc
(Prev
);
4148 ("declaration cannot complete previous null procedure#", Decl
);
4150 end Check_Previous_Null_Procedure
;
4152 ---------------------------------
4153 -- Check_Result_And_Post_State --
4154 ---------------------------------
4156 procedure Check_Result_And_Post_State
(Subp_Id
: Entity_Id
) is
4157 procedure Check_Result_And_Post_State_In_Pragma
4159 Result_Seen
: in out Boolean);
4160 -- Determine whether pragma Prag mentions attribute 'Result and whether
4161 -- the pragma contains an expression that evaluates differently in pre-
4162 -- and post-state. Prag is a [refined] postcondition or a contract-cases
4163 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result
4165 -------------------------------------------
4166 -- Check_Result_And_Post_State_In_Pragma --
4167 -------------------------------------------
4169 procedure Check_Result_And_Post_State_In_Pragma
4171 Result_Seen
: in out Boolean)
4173 procedure Check_Conjunct
(Expr
: Node_Id
);
4174 -- Check an individual conjunct in a conjunction of Boolean
4175 -- expressions, connected by "and" or "and then" operators.
4177 procedure Check_Conjuncts
(Expr
: Node_Id
);
4178 -- Apply the post-state check to every conjunct in an expression, in
4179 -- case this is a conjunction of Boolean expressions. Otherwise apply
4180 -- it to the expression as a whole.
4182 procedure Check_Expression
(Expr
: Node_Id
);
4183 -- Perform the 'Result and post-state checks on a given expression
4185 function Is_Function_Result
(N
: Node_Id
) return Traverse_Result
;
4186 -- Attempt to find attribute 'Result in a subtree denoted by N
4188 function Mentions_Post_State
(N
: Node_Id
) return Boolean;
4189 -- Determine whether a subtree denoted by N mentions any construct
4190 -- that denotes a post-state.
4192 procedure Check_Function_Result
is
4193 new Traverse_Proc
(Is_Function_Result
);
4195 --------------------
4196 -- Check_Conjunct --
4197 --------------------
4199 procedure Check_Conjunct
(Expr
: Node_Id
) is
4200 function Adjust_Message
(Msg
: String) return String;
4201 -- Prepend a prefix to the input message Msg denoting that the
4202 -- message applies to a conjunct in the expression, when this
4205 function Applied_On_Conjunct
return Boolean;
4206 -- Returns True if the message applies to a conjunct in the
4207 -- expression, instead of the whole expression.
4209 function Has_Global_Output
(Subp
: Entity_Id
) return Boolean;
4210 -- Returns True if Subp has an output in its Global contract
4212 function Has_No_Output
(Subp
: Entity_Id
) return Boolean;
4213 -- Returns True if Subp has no declared output: no function
4214 -- result, no output parameter, and no output in its Global
4217 --------------------
4218 -- Adjust_Message --
4219 --------------------
4221 function Adjust_Message
(Msg
: String) return String is
4223 if Applied_On_Conjunct
then
4224 return "conjunct in " & Msg
;
4230 -------------------------
4231 -- Applied_On_Conjunct --
4232 -------------------------
4234 function Applied_On_Conjunct
return Boolean is
4236 -- Expr is the conjunct of an enclosing "and" expression
4238 return Nkind
(Parent
(Expr
)) in N_Subexpr
4240 -- or Expr is a conjunct of an enclosing "and then"
4241 -- expression in a postcondition aspect that was split into
4242 -- multiple pragmas. The first conjunct has the "and then"
4243 -- expression as Original_Node, and other conjuncts have
4244 -- Split_PCC set to True.
4246 or else Nkind
(Original_Node
(Expr
)) = N_And_Then
4247 or else Split_PPC
(Prag
);
4248 end Applied_On_Conjunct
;
4250 -----------------------
4251 -- Has_Global_Output --
4252 -----------------------
4254 function Has_Global_Output
(Subp
: Entity_Id
) return Boolean is
4255 Global
: constant Node_Id
:= Get_Pragma
(Subp
, Pragma_Global
);
4264 List
:= Expression
(Get_Argument
(Global
, Subp
));
4266 -- Empty list (no global items) or single global item
4267 -- declaration (only input items).
4269 if Nkind
(List
) in N_Null
4272 | N_Selected_Component
4276 -- Simple global list (only input items) or moded global list
4279 elsif Nkind
(List
) = N_Aggregate
then
4280 if Present
(Expressions
(List
)) then
4284 Assoc
:= First
(Component_Associations
(List
));
4285 while Present
(Assoc
) loop
4286 if Chars
(First
(Choices
(Assoc
))) /= Name_Input
then
4296 -- To accommodate partial decoration of disabled SPARK
4297 -- features, this routine may be called with illegal input.
4298 -- If this is the case, do not raise Program_Error.
4303 end Has_Global_Output
;
4309 function Has_No_Output
(Subp
: Entity_Id
) return Boolean is
4313 -- A function has its result as output
4315 if Ekind
(Subp
) = E_Function
then
4319 -- An OUT or IN OUT parameter is an output
4321 Param
:= First_Formal
(Subp
);
4322 while Present
(Param
) loop
4323 if Ekind
(Param
) in E_Out_Parameter | E_In_Out_Parameter
then
4327 Next_Formal
(Param
);
4330 -- An item of mode Output or In_Out in the Global contract is
4333 if Has_Global_Output
(Subp
) then
4343 -- Error node when reporting a warning on a (refined)
4346 -- Start of processing for Check_Conjunct
4349 if Applied_On_Conjunct
then
4355 -- Do not report missing reference to outcome in postcondition if
4356 -- either the postcondition is trivially True or False, or if the
4357 -- subprogram is ghost and has no declared output.
4359 if not Is_Trivial_Boolean
(Expr
)
4360 and then not Mentions_Post_State
(Expr
)
4361 and then not (Is_Ghost_Entity
(Subp_Id
)
4362 and then Has_No_Output
(Subp_Id
))
4363 and then not Is_Wrapper
(Subp_Id
)
4365 if Pragma_Name
(Prag
) = Name_Contract_Cases
then
4366 Error_Msg_NE
(Adjust_Message
4367 ("contract case does not check the outcome of calling "
4368 & "&?.t?"), Expr
, Subp_Id
);
4370 elsif Pragma_Name
(Prag
) = Name_Refined_Post
then
4371 Error_Msg_NE
(Adjust_Message
4372 ("refined postcondition does not check the outcome of "
4373 & "calling &?.t?"), Err_Node
, Subp_Id
);
4376 Error_Msg_NE
(Adjust_Message
4377 ("postcondition does not check the outcome of calling "
4378 & "&?.t?"), Err_Node
, Subp_Id
);
4383 ---------------------
4384 -- Check_Conjuncts --
4385 ---------------------
4387 procedure Check_Conjuncts
(Expr
: Node_Id
) is
4389 if Nkind
(Expr
) in N_Op_And | N_And_Then
then
4390 Check_Conjuncts
(Left_Opnd
(Expr
));
4391 Check_Conjuncts
(Right_Opnd
(Expr
));
4393 Check_Conjunct
(Expr
);
4395 end Check_Conjuncts
;
4397 ----------------------
4398 -- Check_Expression --
4399 ----------------------
4401 procedure Check_Expression
(Expr
: Node_Id
) is
4403 if not Is_Trivial_Boolean
(Expr
) then
4404 Check_Function_Result
(Expr
);
4405 Check_Conjuncts
(Expr
);
4407 end Check_Expression
;
4409 ------------------------
4410 -- Is_Function_Result --
4411 ------------------------
4413 function Is_Function_Result
(N
: Node_Id
) return Traverse_Result
is
4415 if Is_Attribute_Result
(N
) then
4416 Result_Seen
:= True;
4419 -- Warn on infinite recursion if call is to current function
4421 elsif Nkind
(N
) = N_Function_Call
4422 and then Is_Entity_Name
(Name
(N
))
4423 and then Entity
(Name
(N
)) = Subp_Id
4424 and then not Is_Potentially_Unevaluated
(N
)
4427 ("call to & within its postcondition will lead to infinite "
4428 & "recursion?", N
, Subp_Id
);
4431 -- Continue the traversal
4436 end Is_Function_Result
;
4438 -------------------------
4439 -- Mentions_Post_State --
4440 -------------------------
4442 function Mentions_Post_State
(N
: Node_Id
) return Boolean is
4443 Post_State_Seen
: Boolean := False;
4445 function Is_Post_State
(N
: Node_Id
) return Traverse_Result
;
4446 -- Attempt to find a construct that denotes a post-state. If this
4447 -- is the case, set flag Post_State_Seen.
4453 function Is_Post_State
(N
: Node_Id
) return Traverse_Result
is
4457 if Nkind
(N
) in N_Explicit_Dereference | N_Function_Call
then
4458 Post_State_Seen
:= True;
4461 elsif Nkind
(N
) in N_Expanded_Name | N_Identifier
then
4464 -- Treat an undecorated reference as OK
4468 -- A reference to an assignable entity is considered a
4469 -- change in the post-state of a subprogram.
4471 or else Ekind
(Ent
) in E_Generic_In_Out_Parameter
4472 | E_In_Out_Parameter
4476 -- The reference may be modified through a dereference
4478 or else (Is_Access_Type
(Etype
(Ent
))
4479 and then Nkind
(Parent
(N
)) =
4480 N_Selected_Component
)
4482 Post_State_Seen
:= True;
4486 elsif Nkind
(N
) = N_Attribute_Reference
then
4487 if Attribute_Name
(N
) = Name_Old
then
4490 elsif Attribute_Name
(N
) = Name_Result
then
4491 Post_State_Seen
:= True;
4499 procedure Find_Post_State
is new Traverse_Proc
(Is_Post_State
);
4501 -- Start of processing for Mentions_Post_State
4504 Find_Post_State
(N
);
4506 return Post_State_Seen
;
4507 end Mentions_Post_State
;
4511 Expr
: constant Node_Id
:=
4513 (First
(Pragma_Argument_Associations
(Prag
)));
4514 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
4517 -- Start of processing for Check_Result_And_Post_State_In_Pragma
4520 -- Examine all consequences
4522 if Nam
= Name_Contract_Cases
then
4523 CCase
:= First
(Component_Associations
(Expr
));
4524 while Present
(CCase
) loop
4525 Check_Expression
(Expression
(CCase
));
4530 -- Examine the expression of a postcondition
4532 else pragma Assert
(Nam
in Name_Postcondition | Name_Refined_Post
);
4533 Check_Expression
(Expr
);
4535 end Check_Result_And_Post_State_In_Pragma
;
4539 Items
: constant Node_Id
:= Contract
(Subp_Id
);
4540 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
4541 Case_Prag
: Node_Id
:= Empty
;
4542 Post_Prag
: Node_Id
:= Empty
;
4544 Seen_In_Case
: Boolean := False;
4545 Seen_In_Post
: Boolean := False;
4546 Spec_Id
: Entity_Id
;
4548 -- Start of processing for Check_Result_And_Post_State
4551 -- The lack of attribute 'Result or a post-state is classified as a
4552 -- suspicious contract. Do not perform the check if the corresponding
4553 -- swich is not set.
4555 if not Warn_On_Suspicious_Contract
then
4558 -- Nothing to do if there is no contract
4560 elsif No
(Items
) then
4564 -- Retrieve the entity of the subprogram spec (if any)
4566 if Nkind
(Subp_Decl
) = N_Subprogram_Body
4567 and then Present
(Corresponding_Spec
(Subp_Decl
))
4569 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
4571 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4572 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4574 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
4580 -- Examine all postconditions for attribute 'Result and a post-state
4582 Prag
:= Pre_Post_Conditions
(Items
);
4583 while Present
(Prag
) loop
4584 if Pragma_Name_Unmapped
(Prag
)
4585 in Name_Postcondition | Name_Refined_Post
4586 and then not Error_Posted
(Prag
)
4589 Check_Result_And_Post_State_In_Pragma
(Prag
, Seen_In_Post
);
4592 Prag
:= Next_Pragma
(Prag
);
4595 -- Examine the contract cases of the subprogram for attribute 'Result
4596 -- and a post-state.
4598 Prag
:= Contract_Test_Cases
(Items
);
4599 while Present
(Prag
) loop
4600 if Pragma_Name
(Prag
) = Name_Contract_Cases
4601 and then not Error_Posted
(Prag
)
4604 Check_Result_And_Post_State_In_Pragma
(Prag
, Seen_In_Case
);
4607 Prag
:= Next_Pragma
(Prag
);
4610 -- Do not emit any errors if the subprogram is not a function
4612 if Ekind
(Spec_Id
) not in E_Function | E_Generic_Function
then
4615 -- Regardless of whether the function has postconditions or contract
4616 -- cases, or whether they mention attribute 'Result, an [IN] OUT formal
4617 -- parameter is always treated as a result.
4619 elsif Has_Out_Or_In_Out_Parameter
(Spec_Id
) then
4622 -- The function has both a postcondition and contract cases and they do
4623 -- not mention attribute 'Result.
4625 elsif Present
(Case_Prag
)
4626 and then not Seen_In_Case
4627 and then Present
(Post_Prag
)
4628 and then not Seen_In_Post
4631 ("neither postcondition nor contract cases mention function "
4632 & "result?.t?", Post_Prag
);
4634 -- The function has contract cases only and they do not mention
4635 -- attribute 'Result.
4637 elsif Present
(Case_Prag
) and then not Seen_In_Case
then
4638 Error_Msg_N
("contract cases do not mention result?.t?", Case_Prag
);
4640 -- The function has non-trivial postconditions only and they do not
4641 -- mention attribute 'Result.
4643 elsif Present
(Post_Prag
)
4644 and then not Seen_In_Post
4645 and then not Is_Trivial_Boolean
4646 (Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Post_Prag
))))
4649 ("postcondition does not mention function result?.t?", Post_Prag
);
4651 end Check_Result_And_Post_State
;
4653 -----------------------------
4654 -- Check_State_Refinements --
4655 -----------------------------
4657 procedure Check_State_Refinements
4659 Is_Main_Unit
: Boolean := False)
4661 procedure Check_Package
(Pack
: Node_Id
);
4662 -- Verify that all abstract states of a [generic] package denoted by its
4663 -- declarative node Pack have proper refinement. Recursively verify the
4664 -- visible and private declarations of the [generic] package for other
4667 procedure Check_Packages_In
(Decls
: List_Id
);
4668 -- Seek out [generic] package declarations within declarative list Decls
4669 -- and verify the status of their abstract state refinement.
4671 function SPARK_Mode_Is_Off
(N
: Node_Id
) return Boolean;
4672 -- Determine whether construct N is subject to pragma SPARK_Mode Off
4678 procedure Check_Package
(Pack
: Node_Id
) is
4679 Body_Id
: constant Entity_Id
:= Corresponding_Body
(Pack
);
4680 Spec
: constant Node_Id
:= Specification
(Pack
);
4681 States
: constant Elist_Id
:=
4682 Abstract_States
(Defining_Entity
(Pack
));
4684 State_Elmt
: Elmt_Id
;
4685 State_Id
: Entity_Id
;
4688 -- Do not verify proper state refinement when the package is subject
4689 -- to pragma SPARK_Mode Off because this disables the requirement for
4690 -- state refinement.
4692 if SPARK_Mode_Is_Off
(Pack
) then
4695 -- State refinement can only occur in a completing package body. Do
4696 -- not verify proper state refinement when the body is subject to
4697 -- pragma SPARK_Mode Off because this disables the requirement for
4698 -- state refinement.
4700 elsif Present
(Body_Id
)
4701 and then SPARK_Mode_Is_Off
(Unit_Declaration_Node
(Body_Id
))
4705 -- Do not verify proper state refinement when the package is an
4706 -- instance as this check was already performed in the generic.
4708 elsif Present
(Generic_Parent
(Spec
)) then
4711 -- Otherwise examine the contents of the package
4714 if Present
(States
) then
4715 State_Elmt
:= First_Elmt
(States
);
4716 while Present
(State_Elmt
) loop
4717 State_Id
:= Node
(State_Elmt
);
4719 -- Emit an error when a non-null state lacks refinement,
4720 -- but has Part_Of constituents or there is a package
4721 -- body (SPARK RM 7.1.4(4)). Constituents in private
4722 -- child packages, which are not known at this stage,
4723 -- independently require the existence of a package body.
4725 if not Is_Null_State
(State_Id
)
4726 and then No
(Refinement_Constituents
(State_Id
))
4728 (Present
(Part_Of_Constituents
(State_Id
))
4732 Error_Msg_N
("state & requires refinement", State_Id
);
4733 Error_Msg_N
("\package body should have Refined_State "
4734 & "for state & with constituents", State_Id
);
4737 Next_Elmt
(State_Elmt
);
4741 Check_Packages_In
(Visible_Declarations
(Spec
));
4742 Check_Packages_In
(Private_Declarations
(Spec
));
4746 -----------------------
4747 -- Check_Packages_In --
4748 -----------------------
4750 procedure Check_Packages_In
(Decls
: List_Id
) is
4754 if Present
(Decls
) then
4755 Decl
:= First
(Decls
);
4756 while Present
(Decl
) loop
4757 if Nkind
(Decl
) in N_Generic_Package_Declaration
4758 | N_Package_Declaration
4760 Check_Package
(Decl
);
4766 end Check_Packages_In
;
4768 -----------------------
4769 -- SPARK_Mode_Is_Off --
4770 -----------------------
4772 function SPARK_Mode_Is_Off
(N
: Node_Id
) return Boolean is
4773 Id
: constant Entity_Id
:= Defining_Entity
(N
);
4774 Prag
: constant Node_Id
:= SPARK_Pragma
(Id
);
4777 -- Default the mode to "off" when the context is an instance and all
4778 -- SPARK_Mode pragmas found within are to be ignored.
4780 if Ignore_SPARK_Mode_Pragmas
(Id
) then
4786 and then Get_SPARK_Mode_From_Annotation
(Prag
) = Off
;
4788 end SPARK_Mode_Is_Off
;
4790 -- Start of processing for Check_State_Refinements
4793 -- A block may declare a nested package
4795 if Nkind
(Context
) = N_Block_Statement
then
4796 Check_Packages_In
(Declarations
(Context
));
4798 -- An entry, protected, subprogram, or task body may declare a nested
4801 elsif Nkind
(Context
) in N_Entry_Body
4806 -- Do not verify proper state refinement when the body is subject to
4807 -- pragma SPARK_Mode Off because this disables the requirement for
4808 -- state refinement.
4810 if not SPARK_Mode_Is_Off
(Context
) then
4811 Check_Packages_In
(Declarations
(Context
));
4814 -- A package body may declare a nested package
4816 elsif Nkind
(Context
) = N_Package_Body
then
4817 Check_Package
(Unit_Declaration_Node
(Corresponding_Spec
(Context
)));
4819 -- Do not verify proper state refinement when the body is subject to
4820 -- pragma SPARK_Mode Off because this disables the requirement for
4821 -- state refinement.
4823 if not SPARK_Mode_Is_Off
(Context
) then
4824 Check_Packages_In
(Declarations
(Context
));
4827 -- A library level [generic] package may declare a nested package
4829 elsif Nkind
(Context
) in
4830 N_Generic_Package_Declaration | N_Package_Declaration
4831 and then Is_Main_Unit
4833 Check_Package
(Context
);
4835 end Check_State_Refinements
;
4837 ------------------------------
4838 -- Check_Unprotected_Access --
4839 ------------------------------
4841 procedure Check_Unprotected_Access
4845 Cont_Encl_Typ
: Entity_Id
;
4846 Pref_Encl_Typ
: Entity_Id
;
4848 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
;
4849 -- Check whether Obj is a private component of a protected object.
4850 -- Return the protected type where the component resides, Empty
4853 function Is_Public_Operation
return Boolean;
4854 -- Verify that the enclosing operation is callable from outside the
4855 -- protected object, to minimize false positives.
4857 ------------------------------
4858 -- Enclosing_Protected_Type --
4859 ------------------------------
4861 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
is
4863 if Is_Entity_Name
(Obj
) then
4865 Ent
: Entity_Id
:= Entity
(Obj
);
4868 -- The object can be a renaming of a private component, use
4869 -- the original record component.
4871 if Is_Prival
(Ent
) then
4872 Ent
:= Prival_Link
(Ent
);
4875 if Is_Protected_Type
(Scope
(Ent
)) then
4881 -- For indexed and selected components, recursively check the prefix
4883 if Nkind
(Obj
) in N_Indexed_Component | N_Selected_Component
then
4884 return Enclosing_Protected_Type
(Prefix
(Obj
));
4886 -- The object does not denote a protected component
4891 end Enclosing_Protected_Type
;
4893 -------------------------
4894 -- Is_Public_Operation --
4895 -------------------------
4897 function Is_Public_Operation
return Boolean is
4903 while Present
(S
) and then S
/= Pref_Encl_Typ
loop
4904 if Scope
(S
) = Pref_Encl_Typ
then
4905 E
:= First_Entity
(Pref_Encl_Typ
);
4907 and then E
/= First_Private_Entity
(Pref_Encl_Typ
)
4921 end Is_Public_Operation
;
4923 -- Start of processing for Check_Unprotected_Access
4926 if Nkind
(Expr
) = N_Attribute_Reference
4927 and then Attribute_Name
(Expr
) = Name_Unchecked_Access
4929 Cont_Encl_Typ
:= Enclosing_Protected_Type
(Context
);
4930 Pref_Encl_Typ
:= Enclosing_Protected_Type
(Prefix
(Expr
));
4932 -- Check whether we are trying to export a protected component to a
4933 -- context with an equal or lower access level.
4935 if Present
(Pref_Encl_Typ
)
4936 and then No
(Cont_Encl_Typ
)
4937 and then Is_Public_Operation
4938 and then Scope_Depth
(Pref_Encl_Typ
)
4939 >= Static_Accessibility_Level
4940 (Context
, Object_Decl_Level
)
4943 ("??possible unprotected access to protected data", Expr
);
4946 end Check_Unprotected_Access
;
4948 ------------------------------
4949 -- Check_Unused_Body_States --
4950 ------------------------------
4952 procedure Check_Unused_Body_States
(Body_Id
: Entity_Id
) is
4953 procedure Process_Refinement_Clause
4956 -- Inspect all constituents of refinement clause Clause and remove any
4957 -- matches from body state list States.
4959 procedure Report_Unused_Body_States
(States
: Elist_Id
);
4960 -- Emit errors for each abstract state or object found in list States
4962 -------------------------------
4963 -- Process_Refinement_Clause --
4964 -------------------------------
4966 procedure Process_Refinement_Clause
4970 procedure Process_Constituent
(Constit
: Node_Id
);
4971 -- Remove constituent Constit from body state list States
4973 -------------------------
4974 -- Process_Constituent --
4975 -------------------------
4977 procedure Process_Constituent
(Constit
: Node_Id
) is
4978 Constit_Id
: Entity_Id
;
4981 -- Guard against illegal constituents. Only abstract states and
4982 -- objects can appear on the right hand side of a refinement.
4984 if Is_Entity_Name
(Constit
) then
4985 Constit_Id
:= Entity_Of
(Constit
);
4987 if Present
(Constit_Id
)
4988 and then Ekind
(Constit_Id
) in
4989 E_Abstract_State | E_Constant | E_Variable
4991 Remove
(States
, Constit_Id
);
4994 end Process_Constituent
;
5000 -- Start of processing for Process_Refinement_Clause
5003 if Nkind
(Clause
) = N_Component_Association
then
5004 Constit
:= Expression
(Clause
);
5006 -- Multiple constituents appear as an aggregate
5008 if Nkind
(Constit
) = N_Aggregate
then
5009 Constit
:= First
(Expressions
(Constit
));
5010 while Present
(Constit
) loop
5011 Process_Constituent
(Constit
);
5015 -- Various forms of a single constituent
5018 Process_Constituent
(Constit
);
5021 end Process_Refinement_Clause
;
5023 -------------------------------
5024 -- Report_Unused_Body_States --
5025 -------------------------------
5027 procedure Report_Unused_Body_States
(States
: Elist_Id
) is
5028 Posted
: Boolean := False;
5029 State_Elmt
: Elmt_Id
;
5030 State_Id
: Entity_Id
;
5033 if Present
(States
) then
5034 State_Elmt
:= First_Elmt
(States
);
5035 while Present
(State_Elmt
) loop
5036 State_Id
:= Node
(State_Elmt
);
5038 -- Constants are part of the hidden state of a package, but the
5039 -- compiler cannot determine whether they have variable input
5040 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a
5041 -- hidden state. Do not emit an error when a constant does not
5042 -- participate in a state refinement, even though it acts as a
5045 if Ekind
(State_Id
) = E_Constant
then
5048 -- Overlays do not contribute to package state
5050 elsif Ekind
(State_Id
) = E_Variable
5051 and then Present
(Ultimate_Overlaid_Entity
(State_Id
))
5055 -- Generate an error message of the form:
5057 -- body of package ... has unused hidden states
5058 -- abstract state ... defined at ...
5059 -- variable ... defined at ...
5065 ("body of package & has unused hidden states", Body_Id
);
5068 Error_Msg_Sloc
:= Sloc
(State_Id
);
5070 if Ekind
(State_Id
) = E_Abstract_State
then
5072 ("\abstract state & defined #", Body_Id
, State_Id
);
5075 SPARK_Msg_NE
("\variable & defined #", Body_Id
, State_Id
);
5079 Next_Elmt
(State_Elmt
);
5082 end Report_Unused_Body_States
;
5086 Prag
: constant Node_Id
:= Get_Pragma
(Body_Id
, Pragma_Refined_State
);
5087 Spec_Id
: constant Entity_Id
:= Spec_Entity
(Body_Id
);
5091 -- Start of processing for Check_Unused_Body_States
5094 -- Inspect the clauses of pragma Refined_State and determine whether all
5095 -- visible states declared within the package body participate in the
5098 if Present
(Prag
) then
5099 Clause
:= Expression
(Get_Argument
(Prag
, Spec_Id
));
5100 States
:= Collect_Body_States
(Body_Id
);
5102 -- Multiple non-null state refinements appear as an aggregate
5104 if Nkind
(Clause
) = N_Aggregate
then
5105 Clause
:= First
(Component_Associations
(Clause
));
5106 while Present
(Clause
) loop
5107 Process_Refinement_Clause
(Clause
, States
);
5111 -- Various forms of a single state refinement
5114 Process_Refinement_Clause
(Clause
, States
);
5117 -- Ensure that all abstract states and objects declared in the
5118 -- package body state space are utilized as constituents.
5120 Report_Unused_Body_States
(States
);
5122 end Check_Unused_Body_States
;
5124 ------------------------------------
5125 -- Check_Volatility_Compatibility --
5126 ------------------------------------
5128 procedure Check_Volatility_Compatibility
5129 (Id1
, Id2
: Entity_Id
;
5130 Description_1
, Description_2
: String;
5131 Srcpos_Bearer
: Node_Id
) is
5134 if SPARK_Mode
/= On
then
5139 AR1
: constant Boolean := Async_Readers_Enabled
(Id1
);
5140 AW1
: constant Boolean := Async_Writers_Enabled
(Id1
);
5141 ER1
: constant Boolean := Effective_Reads_Enabled
(Id1
);
5142 EW1
: constant Boolean := Effective_Writes_Enabled
(Id1
);
5143 AR2
: constant Boolean := Async_Readers_Enabled
(Id2
);
5144 AW2
: constant Boolean := Async_Writers_Enabled
(Id2
);
5145 ER2
: constant Boolean := Effective_Reads_Enabled
(Id2
);
5146 EW2
: constant Boolean := Effective_Writes_Enabled
(Id2
);
5148 AR_Check_Failed
: constant Boolean := AR1
and not AR2
;
5149 AW_Check_Failed
: constant Boolean := AW1
and not AW2
;
5150 ER_Check_Failed
: constant Boolean := ER1
and not ER2
;
5151 EW_Check_Failed
: constant Boolean := EW1
and not EW2
;
5153 package Failure_Description
is
5154 procedure Note_If_Failure
5155 (Failed
: Boolean; Aspect_Name
: String);
5156 -- If Failed is False, do nothing.
5157 -- If Failed is True, add Aspect_Name to the failure description.
5159 function Failure_Text
return String;
5160 -- returns accumulated list of failing aspects
5161 end Failure_Description
;
5163 package body Failure_Description
is
5164 Description_Buffer
: Bounded_String
;
5166 ---------------------
5167 -- Note_If_Failure --
5168 ---------------------
5170 procedure Note_If_Failure
5171 (Failed
: Boolean; Aspect_Name
: String) is
5174 if Description_Buffer
.Length
/= 0 then
5175 Append
(Description_Buffer
, ", ");
5177 Append
(Description_Buffer
, Aspect_Name
);
5179 end Note_If_Failure
;
5185 function Failure_Text
return String is
5187 return +Description_Buffer
;
5189 end Failure_Description
;
5191 use Failure_Description
;
5198 Note_If_Failure
(AR_Check_Failed
, "Async_Readers");
5199 Note_If_Failure
(AW_Check_Failed
, "Async_Writers");
5200 Note_If_Failure
(ER_Check_Failed
, "Effective_Reads");
5201 Note_If_Failure
(EW_Check_Failed
, "Effective_Writes");
5207 & " are not compatible with respect to volatility due to "
5212 end Check_Volatility_Compatibility
;
5218 function Choice_List
(N
: Node_Id
) return List_Id
is
5220 if Nkind
(N
) = N_Iterated_Component_Association
then
5221 return Discrete_Choices
(N
);
5227 ---------------------
5228 -- Class_Condition --
5229 ---------------------
5231 function Class_Condition
5232 (Kind
: Condition_Kind
;
5233 Subp
: Entity_Id
) return Node_Id
is
5237 when Class_Postcondition
=>
5238 return Class_Postconditions
(Subp
);
5240 when Class_Precondition
=>
5241 return Class_Preconditions
(Subp
);
5243 when Ignored_Class_Postcondition
=>
5244 return Ignored_Class_Postconditions
(Subp
);
5246 when Ignored_Class_Precondition
=>
5247 return Ignored_Class_Preconditions
(Subp
);
5249 end Class_Condition
;
5251 -------------------------
5252 -- Collect_Body_States --
5253 -------------------------
5255 function Collect_Body_States
(Body_Id
: Entity_Id
) return Elist_Id
is
5256 function Is_Visible_Object
(Obj_Id
: Entity_Id
) return Boolean;
5257 -- Determine whether object Obj_Id is a suitable visible state of a
5260 procedure Collect_Visible_States
5261 (Pack_Id
: Entity_Id
;
5262 States
: in out Elist_Id
);
5263 -- Gather the entities of all abstract states and objects declared in
5264 -- the visible state space of package Pack_Id.
5266 ----------------------------
5267 -- Collect_Visible_States --
5268 ----------------------------
5270 procedure Collect_Visible_States
5271 (Pack_Id
: Entity_Id
;
5272 States
: in out Elist_Id
)
5274 Item_Id
: Entity_Id
;
5277 -- Traverse the entity chain of the package and inspect all visible
5280 Item_Id
:= First_Entity
(Pack_Id
);
5281 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
5283 -- Do not consider internally generated items as those cannot be
5284 -- named and participate in refinement.
5286 if not Comes_From_Source
(Item_Id
) then
5289 elsif Ekind
(Item_Id
) = E_Abstract_State
then
5290 Append_New_Elmt
(Item_Id
, States
);
5292 elsif Ekind
(Item_Id
) in E_Constant | E_Variable
5293 and then Is_Visible_Object
(Item_Id
)
5295 Append_New_Elmt
(Item_Id
, States
);
5297 -- Recursively gather the visible states of a nested package
5298 -- except for nested package renamings.
5300 elsif Ekind
(Item_Id
) = E_Package
5301 and then No
(Renamed_Entity
(Item_Id
))
5303 Collect_Visible_States
(Item_Id
, States
);
5306 Next_Entity
(Item_Id
);
5308 end Collect_Visible_States
;
5310 -----------------------
5311 -- Is_Visible_Object --
5312 -----------------------
5314 function Is_Visible_Object
(Obj_Id
: Entity_Id
) return Boolean is
5316 -- Objects that map generic formals to their actuals are not visible
5317 -- from outside the generic instantiation.
5319 if Present
(Corresponding_Generic_Association
5320 (Declaration_Node
(Obj_Id
)))
5324 -- Constituents of a single protected/task type act as components of
5325 -- the type and are not visible from outside the type.
5327 elsif Ekind
(Obj_Id
) = E_Variable
5328 and then Present
(Encapsulating_State
(Obj_Id
))
5329 and then Is_Single_Concurrent_Object
(Encapsulating_State
(Obj_Id
))
5336 end Is_Visible_Object
;
5340 Body_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Body_Id
);
5342 Item_Id
: Entity_Id
;
5343 States
: Elist_Id
:= No_Elist
;
5345 -- Start of processing for Collect_Body_States
5348 -- Inspect the declarations of the body looking for source objects,
5349 -- packages and package instantiations. Note that even though this
5350 -- processing is very similar to Collect_Visible_States, a package
5351 -- body does not have a First/Next_Entity list.
5353 Decl
:= First
(Declarations
(Body_Decl
));
5354 while Present
(Decl
) loop
5356 -- Capture source objects as internally generated temporaries cannot
5357 -- be named and participate in refinement.
5359 if Nkind
(Decl
) = N_Object_Declaration
then
5360 Item_Id
:= Defining_Entity
(Decl
);
5362 if Comes_From_Source
(Item_Id
)
5363 and then Is_Visible_Object
(Item_Id
)
5365 Append_New_Elmt
(Item_Id
, States
);
5368 -- Capture the visible abstract states and objects of a source
5369 -- package [instantiation].
5371 elsif Nkind
(Decl
) = N_Package_Declaration
then
5372 Item_Id
:= Defining_Entity
(Decl
);
5374 if Comes_From_Source
(Item_Id
) then
5375 Collect_Visible_States
(Item_Id
, States
);
5383 end Collect_Body_States
;
5385 ------------------------
5386 -- Collect_Interfaces --
5387 ------------------------
5389 procedure Collect_Interfaces
5391 Ifaces_List
: out Elist_Id
;
5392 Exclude_Parents
: Boolean := False;
5393 Use_Full_View
: Boolean := True)
5395 procedure Collect
(Typ
: Entity_Id
);
5396 -- Subsidiary subprogram used to traverse the whole list
5397 -- of directly and indirectly implemented interfaces
5403 procedure Collect
(Typ
: Entity_Id
) is
5404 Ancestor
: Entity_Id
;
5412 -- Handle private types and subtypes
5415 and then Is_Private_Type
(Typ
)
5416 and then Present
(Full_View
(Typ
))
5418 Full_T
:= Full_View
(Typ
);
5420 if Ekind
(Full_T
) = E_Record_Subtype
then
5421 Full_T
:= Etype
(Typ
);
5423 if Present
(Full_View
(Full_T
)) then
5424 Full_T
:= Full_View
(Full_T
);
5429 -- Include the ancestor if we are generating the whole list of
5430 -- abstract interfaces.
5432 if Etype
(Full_T
) /= Typ
5434 -- Protect the frontend against wrong sources. For example:
5437 -- type A is tagged null record;
5438 -- type B is new A with private;
5439 -- type C is new A with private;
5441 -- type B is new C with null record;
5442 -- type C is new B with null record;
5445 and then Etype
(Full_T
) /= T
5447 Ancestor
:= Etype
(Full_T
);
5450 if Is_Interface
(Ancestor
) and then not Exclude_Parents
then
5451 Append_Unique_Elmt
(Ancestor
, Ifaces_List
);
5455 -- Traverse the graph of ancestor interfaces
5457 Id
:= First
(Abstract_Interface_List
(Full_T
));
5458 while Present
(Id
) loop
5459 Iface
:= Etype
(Id
);
5461 -- Protect against wrong uses. For example:
5462 -- type I is interface;
5463 -- type O is tagged null record;
5464 -- type Wrong is new I and O with null record; -- ERROR
5466 if Is_Interface
(Iface
) then
5468 and then Etype
(T
) /= T
5469 and then Interface_Present_In_Ancestor
(Etype
(T
), Iface
)
5474 Append_Unique_Elmt
(Iface
, Ifaces_List
);
5482 -- Start of processing for Collect_Interfaces
5485 pragma Assert
(Is_Tagged_Type
(T
) or else Is_Concurrent_Type
(T
));
5486 Ifaces_List
:= New_Elmt_List
;
5488 end Collect_Interfaces
;
5490 ----------------------------------
5491 -- Collect_Interface_Components --
5492 ----------------------------------
5494 procedure Collect_Interface_Components
5495 (Tagged_Type
: Entity_Id
;
5496 Components_List
: out Elist_Id
)
5498 procedure Collect
(Typ
: Entity_Id
);
5499 -- Subsidiary subprogram used to climb to the parents
5505 procedure Collect
(Typ
: Entity_Id
) is
5506 Tag_Comp
: Entity_Id
;
5507 Parent_Typ
: Entity_Id
;
5510 -- Handle private types
5512 if Present
(Full_View
(Etype
(Typ
))) then
5513 Parent_Typ
:= Full_View
(Etype
(Typ
));
5515 Parent_Typ
:= Etype
(Typ
);
5518 if Parent_Typ
/= Typ
5520 -- Protect the frontend against wrong sources. For example:
5523 -- type A is tagged null record;
5524 -- type B is new A with private;
5525 -- type C is new A with private;
5527 -- type B is new C with null record;
5528 -- type C is new B with null record;
5531 and then Parent_Typ
/= Tagged_Type
5533 Collect
(Parent_Typ
);
5536 -- Collect the components containing tags of secondary dispatch
5539 Tag_Comp
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
5540 while Present
(Tag_Comp
) loop
5541 pragma Assert
(Present
(Related_Type
(Tag_Comp
)));
5542 Append_Elmt
(Tag_Comp
, Components_List
);
5544 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
5548 -- Start of processing for Collect_Interface_Components
5551 pragma Assert
(Ekind
(Tagged_Type
) = E_Record_Type
5552 and then Is_Tagged_Type
(Tagged_Type
));
5554 Components_List
:= New_Elmt_List
;
5555 Collect
(Tagged_Type
);
5556 end Collect_Interface_Components
;
5558 -----------------------------
5559 -- Collect_Interfaces_Info --
5560 -----------------------------
5562 procedure Collect_Interfaces_Info
5564 Ifaces_List
: out Elist_Id
;
5565 Components_List
: out Elist_Id
;
5566 Tags_List
: out Elist_Id
)
5568 Comps_List
: Elist_Id
;
5569 Comp_Elmt
: Elmt_Id
;
5570 Comp_Iface
: Entity_Id
;
5571 Iface_Elmt
: Elmt_Id
;
5574 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
;
5575 -- Search for the secondary tag associated with the interface type
5576 -- Iface that is implemented by T.
5582 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
is
5585 if not Is_CPP_Class
(T
) then
5586 ADT
:= Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
))));
5588 ADT
:= Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
)));
5592 and then Is_Tag
(Node
(ADT
))
5593 and then Related_Type
(Node
(ADT
)) /= Iface
5595 -- Skip secondary dispatch table referencing thunks to user
5596 -- defined primitives covered by this interface.
5598 pragma Assert
(Has_Suffix
(Node
(ADT
), 'P'));
5601 -- Skip secondary dispatch tables of Ada types
5603 if not Is_CPP_Class
(T
) then
5605 -- Skip secondary dispatch table referencing thunks to
5606 -- predefined primitives.
5608 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Y'));
5611 -- Skip secondary dispatch table referencing user-defined
5612 -- primitives covered by this interface.
5614 pragma Assert
(Has_Suffix
(Node
(ADT
), 'D'));
5617 -- Skip secondary dispatch table referencing predefined
5620 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Z'));
5625 pragma Assert
(Is_Tag
(Node
(ADT
)));
5629 -- Start of processing for Collect_Interfaces_Info
5632 Collect_Interfaces
(T
, Ifaces_List
);
5633 Collect_Interface_Components
(T
, Comps_List
);
5635 -- Search for the record component and tag associated with each
5636 -- interface type of T.
5638 Components_List
:= New_Elmt_List
;
5639 Tags_List
:= New_Elmt_List
;
5641 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
5642 while Present
(Iface_Elmt
) loop
5643 Iface
:= Node
(Iface_Elmt
);
5645 -- Associate the primary tag component and the primary dispatch table
5646 -- with all the interfaces that are parents of T
5648 if Is_Ancestor
(Iface
, T
, Use_Full_View
=> True) then
5649 Append_Elmt
(First_Tag_Component
(T
), Components_List
);
5650 Append_Elmt
(Node
(First_Elmt
(Access_Disp_Table
(T
))), Tags_List
);
5652 -- Otherwise search for the tag component and secondary dispatch
5656 Comp_Elmt
:= First_Elmt
(Comps_List
);
5657 while Present
(Comp_Elmt
) loop
5658 Comp_Iface
:= Related_Type
(Node
(Comp_Elmt
));
5660 if Comp_Iface
= Iface
5661 or else Is_Ancestor
(Iface
, Comp_Iface
, Use_Full_View
=> True)
5663 Append_Elmt
(Node
(Comp_Elmt
), Components_List
);
5664 Append_Elmt
(Search_Tag
(Comp_Iface
), Tags_List
);
5668 Next_Elmt
(Comp_Elmt
);
5670 pragma Assert
(Present
(Comp_Elmt
));
5673 Next_Elmt
(Iface_Elmt
);
5675 end Collect_Interfaces_Info
;
5677 ---------------------
5678 -- Collect_Parents --
5679 ---------------------
5681 procedure Collect_Parents
5683 List
: out Elist_Id
;
5684 Use_Full_View
: Boolean := True)
5686 Current_Typ
: Entity_Id
:= T
;
5687 Parent_Typ
: Entity_Id
;
5690 List
:= New_Elmt_List
;
5692 -- No action if the if the type has no parents
5694 if T
= Etype
(T
) then
5699 Parent_Typ
:= Etype
(Current_Typ
);
5701 if Is_Private_Type
(Parent_Typ
)
5702 and then Present
(Full_View
(Parent_Typ
))
5703 and then Use_Full_View
5705 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
5708 Append_Elmt
(Parent_Typ
, List
);
5710 exit when Parent_Typ
= Current_Typ
;
5711 Current_Typ
:= Parent_Typ
;
5713 end Collect_Parents
;
5715 ----------------------------------
5716 -- Collect_Primitive_Operations --
5717 ----------------------------------
5719 function Collect_Primitive_Operations
(T
: Entity_Id
) return Elist_Id
is
5720 B_Type
: constant Entity_Id
:= Base_Type
(T
);
5722 function Match
(E
: Entity_Id
) return Boolean;
5723 -- True if E's base type is B_Type, or E is of an anonymous access type
5724 -- and the base type of its designated type is B_Type.
5730 function Match
(E
: Entity_Id
) return Boolean is
5731 Etyp
: Entity_Id
:= Etype
(E
);
5734 if Ekind
(Etyp
) = E_Anonymous_Access_Type
then
5735 Etyp
:= Designated_Type
(Etyp
);
5738 -- In Ada 2012 a primitive operation may have a formal of an
5739 -- incomplete view of the parent type.
5741 return Base_Type
(Etyp
) = B_Type
5743 (Ada_Version
>= Ada_2012
5744 and then Ekind
(Etyp
) = E_Incomplete_Type
5745 and then Full_View
(Etyp
) = B_Type
);
5750 B_Decl
: constant Node_Id
:= Original_Node
(Parent
(B_Type
));
5751 B_Scope
: Entity_Id
:= Scope
(B_Type
);
5753 Eq_Prims_List
: Elist_Id
:= No_Elist
;
5756 Is_Type_In_Pkg
: Boolean;
5757 Formal_Derived
: Boolean := False;
5760 -- Start of processing for Collect_Primitive_Operations
5763 -- For tagged types, the primitive operations are collected as they
5764 -- are declared, and held in an explicit list which is simply returned.
5766 if Is_Tagged_Type
(B_Type
) then
5767 return Primitive_Operations
(B_Type
);
5769 -- An untagged generic type that is a derived type inherits the
5770 -- primitive operations of its parent type. Other formal types only
5771 -- have predefined operators, which are not explicitly represented.
5773 elsif Is_Generic_Type
(B_Type
) then
5774 if Nkind
(B_Decl
) = N_Formal_Type_Declaration
5775 and then Nkind
(Formal_Type_Definition
(B_Decl
)) =
5776 N_Formal_Derived_Type_Definition
5778 Formal_Derived
:= True;
5780 return New_Elmt_List
;
5784 Op_List
:= New_Elmt_List
;
5786 if B_Scope
= Standard_Standard
then
5787 if B_Type
= Standard_String
then
5788 Append_Elmt
(Standard_Op_Concat
, Op_List
);
5790 elsif B_Type
= Standard_Wide_String
then
5791 Append_Elmt
(Standard_Op_Concatw
, Op_List
);
5797 -- Locate the primitive subprograms of the type
5800 -- The primitive operations appear after the base type, except if the
5801 -- derivation happens within the private part of B_Scope and the type
5802 -- is a private type, in which case both the type and some primitive
5803 -- operations may appear before the base type, and the list of
5804 -- candidates starts after the type.
5806 if In_Open_Scopes
(B_Scope
)
5807 and then Scope
(T
) = B_Scope
5808 and then In_Private_Part
(B_Scope
)
5810 Id
:= Next_Entity
(T
);
5812 -- In Ada 2012, If the type has an incomplete partial view, there may
5813 -- be primitive operations declared before the full view, so we need
5814 -- to start scanning from the incomplete view, which is earlier on
5815 -- the entity chain.
5817 elsif Nkind
(Parent
(B_Type
)) = N_Full_Type_Declaration
5818 and then Present
(Incomplete_View
(Parent
(B_Type
)))
5820 Id
:= Incomplete_View
(Parent
(B_Type
));
5822 -- If T is a derived from a type with an incomplete view declared
5823 -- elsewhere, that incomplete view is irrelevant, we want the
5824 -- operations in the scope of T.
5826 if Scope
(Id
) /= Scope
(B_Type
) then
5827 Id
:= Next_Entity
(B_Type
);
5831 Id
:= Next_Entity
(B_Type
);
5834 -- Set flag if this is a type in a package spec
5837 Is_Package_Or_Generic_Package
(B_Scope
)
5839 Parent_Kind
(Declaration_Node
(First_Subtype
(T
))) /=
5842 while Present
(Id
) loop
5844 -- Test whether the result type or any of the parameter types of
5845 -- each subprogram following the type match that type when the
5846 -- type is declared in a package spec, is a derived type, or the
5847 -- subprogram is marked as primitive. (The Is_Primitive test is
5848 -- needed to find primitives of nonderived types in declarative
5849 -- parts that happen to override the predefined "=" operator.)
5851 -- Note that generic formal subprograms are not considered to be
5852 -- primitive operations and thus are never inherited.
5854 if Is_Overloadable
(Id
)
5855 and then (Is_Type_In_Pkg
5856 or else Is_Derived_Type
(B_Type
)
5857 or else Is_Primitive
(Id
))
5858 and then Parent_Kind
(Parent
(Id
))
5859 not in N_Formal_Subprogram_Declaration
5867 Formal
:= First_Formal
(Id
);
5868 while Present
(Formal
) loop
5869 if Match
(Formal
) then
5874 Next_Formal
(Formal
);
5878 -- For a formal derived type, the only primitives are the ones
5879 -- inherited from the parent type. Operations appearing in the
5880 -- package declaration are not primitive for it.
5883 and then (not Formal_Derived
or else Present
(Alias
(Id
)))
5885 -- In the special case of an equality operator aliased to
5886 -- an overriding dispatching equality belonging to the same
5887 -- type, we don't include it in the list of primitives.
5888 -- This avoids inheriting multiple equality operators when
5889 -- deriving from untagged private types whose full type is
5890 -- tagged, which can otherwise cause ambiguities. Note that
5891 -- this should only happen for this kind of untagged parent
5892 -- type, since normally dispatching operations are inherited
5893 -- using the type's Primitive_Operations list.
5895 if Chars
(Id
) = Name_Op_Eq
5896 and then Is_Dispatching_Operation
(Id
)
5897 and then Present
(Alias
(Id
))
5898 and then Present
(Overridden_Operation
(Alias
(Id
)))
5899 and then Base_Type
(Etype
(First_Entity
(Id
))) =
5900 Base_Type
(Etype
(First_Entity
(Alias
(Id
))))
5904 -- Include the subprogram in the list of primitives
5907 Append_Elmt
(Id
, Op_List
);
5909 -- Save collected equality primitives for later filtering
5910 -- (if we are processing a private type for which we can
5911 -- collect several candidates).
5913 if Inherits_From_Tagged_Full_View
(T
)
5914 and then Chars
(Id
) = Name_Op_Eq
5915 and then Etype
(First_Formal
(Id
)) =
5916 Etype
(Next_Formal
(First_Formal
(Id
)))
5918 Append_New_Elmt
(Id
, Eq_Prims_List
);
5926 -- For a type declared in System, some of its operations may
5927 -- appear in the target-specific extension to System.
5930 and then Is_RTU
(B_Scope
, System
)
5931 and then Present_System_Aux
5933 B_Scope
:= System_Aux_Id
;
5934 Id
:= First_Entity
(System_Aux_Id
);
5938 -- Filter collected equality primitives
5940 if Inherits_From_Tagged_Full_View
(T
)
5941 and then Present
(Eq_Prims_List
)
5944 First
: constant Elmt_Id
:= First_Elmt
(Eq_Prims_List
);
5948 pragma Assert
(No
(Next_Elmt
(First
))
5949 or else No
(Next_Elmt
(Next_Elmt
(First
))));
5951 -- No action needed if we have collected a single equality
5954 if Present
(Next_Elmt
(First
)) then
5955 Second
:= Next_Elmt
(First
);
5957 if Is_Dispatching_Operation
5958 (Ultimate_Alias
(Node
(First
)))
5960 Remove
(Op_List
, Node
(First
));
5962 elsif Is_Dispatching_Operation
5963 (Ultimate_Alias
(Node
(Second
)))
5965 Remove
(Op_List
, Node
(Second
));
5968 raise Program_Error
;
5976 end Collect_Primitive_Operations
;
5978 -----------------------------------
5979 -- Compile_Time_Constraint_Error --
5980 -----------------------------------
5982 function Compile_Time_Constraint_Error
5985 Ent
: Entity_Id
:= Empty
;
5986 Loc
: Source_Ptr
:= No_Location
;
5987 Warn
: Boolean := False;
5988 Extra_Msg
: String := "") return Node_Id
5990 Msgc
: String (1 .. Msg
'Length + 3);
5991 -- Copy of message, with room for possible ?? or << and ! at end
5998 -- If this is a warning, convert it into an error if we are in code
5999 -- subject to SPARK_Mode being set On, unless Warn is True to force a
6000 -- warning. The rationale is that a compile-time constraint error should
6001 -- lead to an error instead of a warning when SPARK_Mode is On, but in
6002 -- a few cases we prefer to issue a warning and generate both a suitable
6003 -- run-time error in GNAT and a suitable check message in GNATprove.
6004 -- Those cases are those that likely correspond to deactivated SPARK
6005 -- code, so that this kind of code can be compiled and analyzed instead
6006 -- of being rejected.
6008 Error_Msg_Warn
:= Warn
or SPARK_Mode
/= On
;
6010 -- A static constraint error in an instance body is not a fatal error.
6011 -- We choose to inhibit the message altogether, because there is no
6012 -- obvious node (for now) on which to post it. On the other hand the
6013 -- offending node must be replaced with a constraint_error in any case.
6015 -- No messages are generated if we already posted an error on this node
6017 if not Error_Posted
(N
) then
6018 if Loc
/= No_Location
then
6024 -- Copy message to Msgc, converting any ? in the message into <
6025 -- instead, so that we have an error in GNATprove mode.
6029 for J
in 1 .. Msgl
loop
6030 if Msg
(J
) = '?' and then (J
= 1 or else Msg
(J
- 1) /= ''') then
6033 Msgc
(J
) := Msg
(J
);
6037 -- Message is a warning, even in Ada 95 case
6039 if Msg
(Msg
'Last) = '?' or else Msg
(Msg
'Last) = '<' then
6042 -- In Ada 83, all messages are warnings. In the private part and the
6043 -- body of an instance, constraint_checks are only warnings. We also
6044 -- make this a warning if the Warn parameter is set.
6047 or else (Ada_Version
= Ada_83
and then Comes_From_Source
(N
))
6048 or else In_Instance_Not_Visible
6056 -- Otherwise we have a real error message (Ada 95 static case) and we
6057 -- make this an unconditional message. Note that in the warning case
6058 -- we do not make the message unconditional, it seems reasonable to
6059 -- delete messages like this (about exceptions that will be raised)
6068 -- One more test, skip the warning if the related expression is
6069 -- statically unevaluated, since we don't want to warn about what
6070 -- will happen when something is evaluated if it never will be
6073 -- Suppress error reporting when checking that the expression of a
6074 -- static expression function is a potentially static expression,
6075 -- because we don't want additional errors being reported during the
6076 -- preanalysis of the expression (see Analyze_Expression_Function).
6078 if not Is_Statically_Unevaluated
(N
)
6079 and then not Checking_Potentially_Static_Expression
6081 if Present
(Ent
) then
6082 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Ent
, Eloc
);
6084 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Etype
(N
), Eloc
);
6087 -- Emit any extra message as a continuation
6089 if Extra_Msg
/= "" then
6090 Error_Msg_N
('\' & Extra_Msg
, N
);
6095 -- Check whether the context is an Init_Proc
6097 if Inside_Init_Proc
then
6099 Init_Proc_Type
: constant Entity_Id
:=
6100 Etype
(First_Formal
(Current_Scope_No_Loops
));
6102 Conc_Typ
: constant Entity_Id
:=
6103 (if Present
(Init_Proc_Type
)
6104 and then Init_Proc_Type
in E_Record_Type_Id
6105 then Corresponding_Concurrent_Type
(Init_Proc_Type
)
6109 -- Don't complain if the corresponding concurrent type
6110 -- doesn't come from source (i.e. a single task/protected
6113 if Present
(Conc_Typ
)
6114 and then not Comes_From_Source
(Conc_Typ
)
6116 Error_Msg
("\& [<<", Eloc
, N
);
6119 if GNATprove_Mode
then
6121 ("\Constraint_Error would have been raised"
6122 & " for objects of this type", Eloc
, N
);
6125 ("\Constraint_Error will be raised"
6126 & " for objects of this type??", Eloc
, N
);
6132 Error_Msg
("\Constraint_Error [<<", Eloc
, N
);
6136 Error_Msg
("\static expression fails Constraint_Check", Eloc
);
6137 Set_Error_Posted
(N
);
6143 end Compile_Time_Constraint_Error
;
6145 ----------------------------
6146 -- Compute_Returns_By_Ref --
6147 ----------------------------
6149 procedure Compute_Returns_By_Ref
(Func
: Entity_Id
) is
6150 Kind
: constant Entity_Kind
:= Ekind
(Func
);
6151 Typ
: constant Entity_Id
:= Etype
(Func
);
6154 -- Nothing to do for procedures
6156 if Kind
in E_Procedure | E_Generic_Procedure
6157 or else (Kind
= E_Subprogram_Type
and then Typ
= Standard_Void_Type
)
6161 -- The build-in-place protocols return a reference to the result
6163 elsif Is_Build_In_Place_Function
(Func
) then
6164 Set_Returns_By_Ref
(Func
);
6166 -- In Ada 95, limited types are returned by reference
6168 elsif Is_Limited_View
(Typ
) then
6169 Set_Returns_By_Ref
(Func
);
6171 end Compute_Returns_By_Ref
;
6173 --------------------------------
6174 -- Collect_Types_In_Hierarchy --
6175 --------------------------------
6177 function Collect_Types_In_Hierarchy
6179 Examine_Components
: Boolean := False) return Elist_Id
6183 procedure Process_Type
(Typ
: Entity_Id
);
6184 -- Collect type Typ if it satisfies function Predicate. Do so for its
6185 -- parent type, base type, progenitor types, and any component types.
6191 procedure Process_Type
(Typ
: Entity_Id
) is
6193 Iface_Elmt
: Elmt_Id
;
6196 if not Is_Type
(Typ
) or else Error_Posted
(Typ
) then
6200 -- Collect the current type if it satisfies the predicate
6202 if Predicate
(Typ
) then
6203 Append_Elmt
(Typ
, Results
);
6206 -- Process component types
6208 if Examine_Components
then
6210 -- Examine components and discriminants
6212 if Is_Concurrent_Type
(Typ
)
6213 or else Is_Incomplete_Or_Private_Type
(Typ
)
6214 or else Is_Record_Type
(Typ
)
6215 or else Has_Discriminants
(Typ
)
6217 Comp
:= First_Component_Or_Discriminant
(Typ
);
6219 while Present
(Comp
) loop
6220 Process_Type
(Etype
(Comp
));
6222 Next_Component_Or_Discriminant
(Comp
);
6225 -- Examine array components
6227 elsif Ekind
(Typ
) = E_Array_Type
then
6228 Process_Type
(Component_Type
(Typ
));
6232 -- Examine parent type
6234 if Etype
(Typ
) /= Typ
then
6235 Process_Type
(Etype
(Typ
));
6238 -- Examine base type
6240 if Base_Type
(Typ
) /= Typ
then
6241 Process_Type
(Base_Type
(Typ
));
6244 -- Examine interfaces
6246 if Is_Record_Type
(Typ
)
6247 and then Present
(Interfaces
(Typ
))
6249 Iface_Elmt
:= First_Elmt
(Interfaces
(Typ
));
6250 while Present
(Iface_Elmt
) loop
6251 Process_Type
(Node
(Iface_Elmt
));
6253 Next_Elmt
(Iface_Elmt
);
6258 -- Start of processing for Collect_Types_In_Hierarchy
6261 Results
:= New_Elmt_List
;
6264 end Collect_Types_In_Hierarchy
;
6266 -----------------------
6267 -- Conditional_Delay --
6268 -----------------------
6270 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
6272 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
6273 Set_Has_Delayed_Freeze
(New_Ent
);
6275 end Conditional_Delay
;
6277 -------------------------
6278 -- Copy_Component_List --
6279 -------------------------
6281 function Copy_Component_List
6283 Loc
: Source_Ptr
) return List_Id
6286 Comps
: constant List_Id
:= New_List
;
6289 Comp
:= First_Component
(Underlying_Type
(R_Typ
));
6290 while Present
(Comp
) loop
6291 if Comes_From_Source
(Comp
) then
6293 Comp_Decl
: constant Node_Id
:= Declaration_Node
(Comp
);
6296 Make_Component_Declaration
(Loc
,
6297 Defining_Identifier
=>
6298 Make_Defining_Identifier
(Loc
, Chars
(Comp
)),
6299 Component_Definition
=>
6301 (Component_Definition
(Comp_Decl
), New_Sloc
=> Loc
)));
6305 Next_Component
(Comp
);
6309 end Copy_Component_List
;
6311 -----------------------
6312 -- Copy_Ghost_Aspect --
6313 -----------------------
6315 procedure Copy_Ghost_Aspect
(From
: Node_Id
; To
: Node_Id
) is
6316 pragma Assert
(not Has_Aspects
(To
));
6320 if Has_Aspects
(From
) then
6321 Asp
:= Find_Aspect
(Defining_Entity
(From
), Aspect_Ghost
);
6323 if Present
(Asp
) then
6324 Set_Aspect_Specifications
(To
, New_List
(New_Copy_Tree
(Asp
)));
6327 end Copy_Ghost_Aspect
;
6329 -------------------------
6330 -- Copy_Parameter_List --
6331 -------------------------
6333 function Copy_Parameter_List
(Subp_Id
: Entity_Id
) return List_Id
is
6334 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
6336 Formal
: Entity_Id
:= First_Formal
(Subp_Id
);
6339 if Present
(Formal
) then
6341 while Present
(Formal
) loop
6343 Make_Parameter_Specification
(Loc
,
6344 Defining_Identifier
=>
6345 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
6346 In_Present
=> In_Present
(Parent
(Formal
)),
6347 Out_Present
=> Out_Present
(Parent
(Formal
)),
6349 New_Occurrence_Of
(Etype
(Formal
), Loc
),
6351 New_Copy_Tree
(Expression
(Parent
(Formal
)))));
6353 Next_Formal
(Formal
);
6360 end Copy_Parameter_List
;
6362 ----------------------------
6363 -- Copy_SPARK_Mode_Aspect --
6364 ----------------------------
6366 procedure Copy_SPARK_Mode_Aspect
(From
: Node_Id
; To
: Node_Id
) is
6367 pragma Assert
(not Has_Aspects
(To
));
6371 if Has_Aspects
(From
) then
6372 Asp
:= Find_Aspect
(Defining_Entity
(From
), Aspect_SPARK_Mode
);
6374 if Present
(Asp
) then
6375 Set_Aspect_Specifications
(To
, New_List
(New_Copy_Tree
(Asp
)));
6378 end Copy_SPARK_Mode_Aspect
;
6380 --------------------------
6381 -- Copy_Subprogram_Spec --
6382 --------------------------
6384 function Copy_Subprogram_Spec
6386 New_Sloc
: Source_Ptr
:= No_Location
) return Node_Id
6389 Formal_Spec
: Node_Id
;
6393 -- The structure of the original tree must be replicated without any
6394 -- alterations. Use New_Copy_Tree for this purpose.
6396 Result
:= New_Copy_Tree
(Spec
, New_Sloc
=> New_Sloc
);
6398 -- However, the spec of a null procedure carries the corresponding null
6399 -- statement of the body (created by the parser), and this cannot be
6400 -- shared with the new subprogram spec.
6402 if Nkind
(Result
) = N_Procedure_Specification
then
6403 Set_Null_Statement
(Result
, Empty
);
6406 -- Create a new entity for the defining unit name
6408 Def_Id
:= Defining_Unit_Name
(Result
);
6409 Set_Defining_Unit_Name
(Result
,
6410 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
6412 -- Create new entities for the formal parameters
6414 Formal_Spec
:= First
(Parameter_Specifications
(Result
));
6415 while Present
(Formal_Spec
) loop
6416 Def_Id
:= Defining_Identifier
(Formal_Spec
);
6417 Set_Defining_Identifier
(Formal_Spec
,
6418 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
6424 end Copy_Subprogram_Spec
;
6426 --------------------------------
6427 -- Corresponding_Generic_Type --
6428 --------------------------------
6430 function Corresponding_Generic_Type
(T
: Entity_Id
) return Entity_Id
is
6436 if not Is_Generic_Actual_Type
(T
) then
6439 -- If the actual is the actual of an enclosing instance, resolution
6440 -- was correct in the generic.
6442 elsif Nkind
(Parent
(T
)) = N_Subtype_Declaration
6443 and then Is_Entity_Name
(Subtype_Indication
(Parent
(T
)))
6445 Is_Generic_Actual_Type
(Entity
(Subtype_Indication
(Parent
(T
))))
6452 if Is_Wrapper_Package
(Inst
) then
6453 Inst
:= Related_Instance
(Inst
);
6458 (Specification
(Unit_Declaration_Node
(Inst
)));
6460 -- Generic actual has the same name as the corresponding formal
6462 Typ
:= First_Entity
(Gen
);
6463 while Present
(Typ
) loop
6464 if Chars
(Typ
) = Chars
(T
) then
6473 end Corresponding_Generic_Type
;
6475 --------------------------------
6476 -- Corresponding_Primitive_Op --
6477 --------------------------------
6479 function Corresponding_Primitive_Op
6480 (Ancestor_Op
: Entity_Id
;
6481 Descendant_Type
: Entity_Id
) return Entity_Id
6483 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Ancestor_Op
);
6487 function Profile_Matches_Ancestor
(S
: Entity_Id
) return Boolean;
6488 -- Returns True if subprogram S has the proper profile for an
6489 -- overriding of Ancestor_Op (that is, corresponding formals either
6490 -- have the same type, or are corresponding controlling formals,
6491 -- and similarly for result types).
6493 ------------------------------
6494 -- Profile_Matches_Ancestor --
6495 ------------------------------
6497 function Profile_Matches_Ancestor
(S
: Entity_Id
) return Boolean is
6498 F1
: Entity_Id
:= First_Formal
(Ancestor_Op
);
6499 F2
: Entity_Id
:= First_Formal
(S
);
6502 if Ekind
(Ancestor_Op
) /= Ekind
(S
) then
6506 -- ??? This should probably account for anonymous access formals,
6507 -- but the parent function (Corresponding_Primitive_Op) is currently
6508 -- only called for user-defined literal functions, which can't have
6509 -- such formals. But if this is ever used in a more general context
6510 -- it should be extended to handle such formals (and result types).
6512 while Present
(F1
) and then Present
(F2
) loop
6513 if Etype
(F1
) = Etype
(F2
)
6514 or else Is_Ancestor
(Typ
, Etype
(F2
))
6525 and then (Etype
(Ancestor_Op
) = Etype
(S
)
6526 or else Is_Ancestor
(Typ
, Etype
(S
)));
6527 end Profile_Matches_Ancestor
;
6529 -- Start of processing for Corresponding_Primitive_Op
6532 pragma Assert
(Is_Dispatching_Operation
(Ancestor_Op
));
6533 pragma Assert
(Is_Ancestor
(Typ
, Descendant_Type
)
6534 or else Is_Progenitor
(Typ
, Descendant_Type
));
6536 Elmt
:= First_Elmt
(Primitive_Operations
(Descendant_Type
));
6538 while Present
(Elmt
) loop
6539 Subp
:= Node
(Elmt
);
6541 -- For regular primitives we need to check the profile against
6542 -- the ancestor when the name matches the name of Ancestor_Op,
6543 -- but for predefined dispatching operations we cannot rely on
6544 -- the name of the primitive to identify a candidate since their
6545 -- name is internally built by adding a suffix to the name of the
6548 if Chars
(Subp
) = Chars
(Ancestor_Op
)
6549 or else Is_Predefined_Dispatching_Operation
(Subp
)
6551 -- Handle case where Ancestor_Op is a primitive of a progenitor.
6552 -- We rely on internal entities that map interface primitives:
6553 -- their attribute Interface_Alias references the interface
6554 -- primitive, and their Alias attribute references the primitive
6555 -- of Descendant_Type implementing that interface primitive.
6557 if Present
(Interface_Alias
(Subp
)) then
6558 if Interface_Alias
(Subp
) = Ancestor_Op
then
6559 return Alias
(Subp
);
6562 -- Otherwise, return subprogram when profile matches its ancestor
6564 elsif Profile_Matches_Ancestor
(Subp
) then
6572 pragma Assert
(False);
6574 end Corresponding_Primitive_Op
;
6576 --------------------
6577 -- Current_Entity --
6578 --------------------
6580 -- The currently visible definition for a given identifier is the
6581 -- one most chained at the start of the visibility chain, i.e. the
6582 -- one that is referenced by the Node_Id value of the name of the
6583 -- given identifier.
6585 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
6587 return Get_Name_Entity_Id
(Chars
(N
));
6590 -----------------------------
6591 -- Current_Entity_In_Scope --
6592 -----------------------------
6594 function Current_Entity_In_Scope
(N
: Name_Id
) return Entity_Id
is
6595 CS
: constant Entity_Id
:= Current_Scope
;
6600 E
:= Get_Name_Entity_Id
(N
);
6605 elsif Scope_Is_Transient
then
6606 while Present
(E
) loop
6607 exit when Scope
(E
) = CS
or else Scope
(E
) = Scope
(CS
);
6613 while Present
(E
) loop
6614 exit when Scope
(E
) = CS
;
6621 end Current_Entity_In_Scope
;
6623 -----------------------------
6624 -- Current_Entity_In_Scope --
6625 -----------------------------
6627 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
6629 return Current_Entity_In_Scope
(Chars
(N
));
6630 end Current_Entity_In_Scope
;
6636 function Current_Scope
return Entity_Id
is
6638 if Scope_Stack
.Last
= -1 then
6639 return Standard_Standard
;
6642 C
: constant Entity_Id
:=
6643 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
6648 return Standard_Standard
;
6654 ----------------------------
6655 -- Current_Scope_No_Loops --
6656 ----------------------------
6658 function Current_Scope_No_Loops
return Entity_Id
is
6662 -- Examine the scope stack starting from the current scope and skip any
6663 -- internally generated loops.
6666 while Present
(S
) and then S
/= Standard_Standard
loop
6667 if Ekind
(S
) = E_Loop
and then not Comes_From_Source
(S
) then
6675 end Current_Scope_No_Loops
;
6677 ------------------------
6678 -- Current_Subprogram --
6679 ------------------------
6681 function Current_Subprogram
return Entity_Id
is
6682 Scop
: constant Entity_Id
:= Current_Scope
;
6684 if Is_Subprogram_Or_Generic_Subprogram
(Scop
) then
6687 return Enclosing_Subprogram
(Scop
);
6689 end Current_Subprogram
;
6691 ------------------------------
6692 -- CW_Or_Needs_Finalization --
6693 ------------------------------
6695 function CW_Or_Needs_Finalization
(Typ
: Entity_Id
) return Boolean is
6697 return Is_Class_Wide_Type
(Typ
) or else Needs_Finalization
(Typ
);
6698 end CW_Or_Needs_Finalization
;
6700 ---------------------
6701 -- Defining_Entity --
6702 ---------------------
6704 function Defining_Entity
(N
: Node_Id
) return Entity_Id
is
6705 Ent
: constant Entity_Id
:= Defining_Entity_Or_Empty
(N
);
6708 if Present
(Ent
) then
6712 raise Program_Error
;
6714 end Defining_Entity
;
6716 ------------------------------
6717 -- Defining_Entity_Or_Empty --
6718 ------------------------------
6720 function Defining_Entity_Or_Empty
(N
: Node_Id
) return Entity_Id
is
6723 when N_Abstract_Subprogram_Declaration
6724 | N_Expression_Function
6725 | N_Formal_Subprogram_Declaration
6726 | N_Generic_Package_Declaration
6727 | N_Generic_Subprogram_Declaration
6728 | N_Package_Declaration
6730 | N_Subprogram_Body_Stub
6731 | N_Subprogram_Declaration
6732 | N_Subprogram_Renaming_Declaration
6734 return Defining_Entity
(Specification
(N
));
6736 when N_Component_Declaration
6737 | N_Defining_Program_Unit_Name
6738 | N_Discriminant_Specification
6740 | N_Entry_Declaration
6741 | N_Entry_Index_Specification
6742 | N_Exception_Declaration
6743 | N_Exception_Renaming_Declaration
6744 | N_Formal_Object_Declaration
6745 | N_Formal_Package_Declaration
6746 | N_Formal_Type_Declaration
6747 | N_Full_Type_Declaration
6748 | N_Implicit_Label_Declaration
6749 | N_Incomplete_Type_Declaration
6750 | N_Iterator_Specification
6751 | N_Loop_Parameter_Specification
6752 | N_Number_Declaration
6753 | N_Object_Declaration
6754 | N_Object_Renaming_Declaration
6755 | N_Package_Body_Stub
6756 | N_Parameter_Specification
6757 | N_Private_Extension_Declaration
6758 | N_Private_Type_Declaration
6760 | N_Protected_Body_Stub
6761 | N_Protected_Type_Declaration
6762 | N_Single_Protected_Declaration
6763 | N_Single_Task_Declaration
6764 | N_Subtype_Declaration
6767 | N_Task_Type_Declaration
6769 return Defining_Identifier
(N
);
6771 when N_Compilation_Unit
=>
6772 return Defining_Entity
(Unit
(N
));
6775 return Defining_Entity
(Proper_Body
(N
));
6777 when N_Function_Instantiation
6778 | N_Function_Specification
6779 | N_Generic_Function_Renaming_Declaration
6780 | N_Generic_Package_Renaming_Declaration
6781 | N_Generic_Procedure_Renaming_Declaration
6783 | N_Package_Instantiation
6784 | N_Package_Renaming_Declaration
6785 | N_Package_Specification
6786 | N_Procedure_Instantiation
6787 | N_Procedure_Specification
6790 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
6791 Err
: Entity_Id
:= Empty
;
6794 if Nkind
(Nam
) in N_Entity
then
6797 -- For Error, make up a name and attach to declaration so we
6798 -- can continue semantic analysis.
6800 elsif Nam
= Error
then
6801 Err
:= Make_Temporary
(Sloc
(N
), 'T');
6802 Set_Defining_Unit_Name
(N
, Err
);
6806 -- If not an entity, get defining identifier
6809 return Defining_Identifier
(Nam
);
6813 when N_Block_Statement
6816 return Entity
(Identifier
(N
));
6821 end Defining_Entity_Or_Empty
;
6823 --------------------------
6824 -- Denotes_Discriminant --
6825 --------------------------
6827 function Denotes_Discriminant
6829 Check_Concurrent
: Boolean := False) return Boolean
6834 if not Is_Entity_Name
(N
) or else No
(Entity
(N
)) then
6840 -- If we are checking for a protected type, the discriminant may have
6841 -- been rewritten as the corresponding discriminal of the original type
6842 -- or of the corresponding concurrent record, depending on whether we
6843 -- are in the spec or body of the protected type.
6845 return Ekind
(E
) = E_Discriminant
6848 and then Ekind
(E
) = E_In_Parameter
6849 and then Present
(Discriminal_Link
(E
))
6851 (Is_Concurrent_Type
(Scope
(Discriminal_Link
(E
)))
6853 Is_Concurrent_Record_Type
(Scope
(Discriminal_Link
(E
)))));
6854 end Denotes_Discriminant
;
6856 -------------------------
6857 -- Denotes_Same_Object --
6858 -------------------------
6860 function Denotes_Same_Object
(A1
, A2
: Node_Id
) return Boolean is
6861 function Is_Object_Renaming
(N
: Node_Id
) return Boolean;
6862 -- Return true if N names an object renaming entity
6864 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean;
6865 -- For renamings, return False if the prefix of any dereference within
6866 -- the renamed object_name is a variable, or any expression within the
6867 -- renamed object_name contains references to variables or calls on
6868 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
6870 ------------------------
6871 -- Is_Object_Renaming --
6872 ------------------------
6874 function Is_Object_Renaming
(N
: Node_Id
) return Boolean is
6876 return Is_Entity_Name
(N
)
6877 and then Ekind
(Entity
(N
)) in E_Variable | E_Constant
6878 and then Present
(Renamed_Object
(Entity
(N
)));
6879 end Is_Object_Renaming
;
6881 -----------------------
6882 -- Is_Valid_Renaming --
6883 -----------------------
6885 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean is
6887 if Is_Object_Renaming
(N
)
6888 and then not Is_Valid_Renaming
(Renamed_Object
(Entity
(N
)))
6893 -- Check if any expression within the renamed object_name contains no
6894 -- references to variables nor calls on nonstatic functions.
6896 if Nkind
(N
) = N_Indexed_Component
then
6901 Indx
:= First
(Expressions
(N
));
6902 while Present
(Indx
) loop
6903 if not Is_OK_Static_Expression
(Indx
) then
6911 elsif Nkind
(N
) = N_Slice
then
6913 Rng
: constant Node_Id
:= Discrete_Range
(N
);
6915 -- Bounds specified as a range
6917 if Nkind
(Rng
) = N_Range
then
6918 if not Is_OK_Static_Range
(Rng
) then
6922 -- Bounds specified as a constrained subtype indication
6924 elsif Nkind
(Rng
) = N_Subtype_Indication
then
6925 if not Is_OK_Static_Range
6926 (Range_Expression
(Constraint
(Rng
)))
6931 -- Bounds specified as a subtype name
6933 elsif not Is_OK_Static_Expression
(Rng
) then
6939 if Has_Prefix
(N
) then
6941 P
: constant Node_Id
:= Prefix
(N
);
6944 if Nkind
(N
) = N_Explicit_Dereference
6945 and then Is_Variable
(P
)
6949 elsif Is_Entity_Name
(P
)
6950 and then Ekind
(Entity
(P
)) = E_Function
6954 elsif Nkind
(P
) = N_Function_Call
then
6958 -- Recursion to continue traversing the prefix of the
6959 -- renaming expression
6961 return Is_Valid_Renaming
(P
);
6966 end Is_Valid_Renaming
;
6968 -- Start of processing for Denotes_Same_Object
6971 -- Both names statically denote the same stand-alone object or
6972 -- parameter (RM 6.4.1(6.6/3)).
6974 if Is_Entity_Name
(A1
)
6975 and then Is_Entity_Name
(A2
)
6976 and then Entity
(A1
) = Entity
(A2
)
6980 -- Both names are selected_components, their prefixes are known to
6981 -- denote the same object, and their selector_names denote the same
6982 -- component (RM 6.4.1(6.7/3)).
6984 elsif Nkind
(A1
) = N_Selected_Component
6985 and then Nkind
(A2
) = N_Selected_Component
6987 return Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
))
6989 Entity
(Selector_Name
(A1
)) = Entity
(Selector_Name
(A2
));
6991 -- Both names are dereferences and the dereferenced names are known to
6992 -- denote the same object (RM 6.4.1(6.8/3)).
6994 elsif Nkind
(A1
) = N_Explicit_Dereference
6995 and then Nkind
(A2
) = N_Explicit_Dereference
6997 return Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
));
6999 -- Both names are indexed_components, their prefixes are known to denote
7000 -- the same object, and each of the pairs of corresponding index values
7001 -- are either both static expressions with the same static value or both
7002 -- names that are known to denote the same object (RM 6.4.1(6.9/3)).
7004 elsif Nkind
(A1
) = N_Indexed_Component
7005 and then Nkind
(A2
) = N_Indexed_Component
7007 if not Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
)) then
7015 Indx1
:= First
(Expressions
(A1
));
7016 Indx2
:= First
(Expressions
(A2
));
7017 while Present
(Indx1
) loop
7019 -- Indexes must denote the same static value or same object
7021 if Is_OK_Static_Expression
(Indx1
) then
7022 if not Is_OK_Static_Expression
(Indx2
) then
7025 elsif Expr_Value
(Indx1
) /= Expr_Value
(Indx2
) then
7029 elsif not Denotes_Same_Object
(Indx1
, Indx2
) then
7041 -- Both names are slices, their prefixes are known to denote the same
7042 -- object, and the two slices have statically matching index constraints
7043 -- (RM 6.4.1(6.10/3)).
7045 elsif Nkind
(A1
) = N_Slice
7046 and then Nkind
(A2
) = N_Slice
7048 if not Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
)) then
7052 Lo1
, Lo2
, Hi1
, Hi2
: Node_Id
;
7055 Get_Index_Bounds
(Discrete_Range
(A1
), Lo1
, Hi1
);
7056 Get_Index_Bounds
(Discrete_Range
(A2
), Lo2
, Hi2
);
7058 -- Check whether bounds are statically identical. There is no
7059 -- attempt to detect partial overlap of slices.
7061 return Is_OK_Static_Expression
(Lo1
)
7062 and then Is_OK_Static_Expression
(Lo2
)
7063 and then Is_OK_Static_Expression
(Hi1
)
7064 and then Is_OK_Static_Expression
(Hi2
)
7065 and then Expr_Value
(Lo1
) = Expr_Value
(Lo2
)
7066 and then Expr_Value
(Hi1
) = Expr_Value
(Hi2
);
7070 -- One of the two names statically denotes a renaming declaration whose
7071 -- renamed object_name is known to denote the same object as the other;
7072 -- the prefix of any dereference within the renamed object_name is not a
7073 -- variable, and any expression within the renamed object_name contains
7074 -- no references to variables nor calls on nonstatic functions (RM
7077 elsif Is_Object_Renaming
(A1
)
7078 and then Is_Valid_Renaming
(A1
)
7080 return Denotes_Same_Object
(Renamed_Object
(Entity
(A1
)), A2
);
7082 elsif Is_Object_Renaming
(A2
)
7083 and then Is_Valid_Renaming
(A2
)
7085 return Denotes_Same_Object
(A1
, Renamed_Object
(Entity
(A2
)));
7090 end Denotes_Same_Object
;
7092 -------------------------
7093 -- Denotes_Same_Prefix --
7094 -------------------------
7096 function Denotes_Same_Prefix
(A1
, A2
: Node_Id
) return Boolean is
7098 if Is_Entity_Name
(A1
) then
7099 if Nkind
(A2
) in N_Selected_Component | N_Indexed_Component
7100 and then not Is_Access_Type
(Etype
(A1
))
7102 return Denotes_Same_Object
(A1
, Prefix
(A2
))
7103 or else Denotes_Same_Prefix
(A1
, Prefix
(A2
));
7108 elsif Is_Entity_Name
(A2
) then
7109 return Denotes_Same_Prefix
(A1
=> A2
, A2
=> A1
);
7111 elsif Nkind
(A1
) in N_Selected_Component | N_Indexed_Component | N_Slice
7113 Nkind
(A2
) in N_Selected_Component | N_Indexed_Component | N_Slice
7116 Root1
, Root2
: Node_Id
;
7117 Depth1
, Depth2
: Nat
:= 0;
7120 Root1
:= Prefix
(A1
);
7121 while not Is_Entity_Name
(Root1
) loop
7122 if Nkind
(Root1
) not in
7123 N_Selected_Component | N_Indexed_Component
7127 Root1
:= Prefix
(Root1
);
7130 Depth1
:= Depth1
+ 1;
7133 Root2
:= Prefix
(A2
);
7134 while not Is_Entity_Name
(Root2
) loop
7135 if Nkind
(Root2
) not in
7136 N_Selected_Component | N_Indexed_Component
7140 Root2
:= Prefix
(Root2
);
7143 Depth2
:= Depth2
+ 1;
7146 -- If both have the same depth and they do not denote the same
7147 -- object, they are disjoint and no warning is needed.
7149 if Depth1
= Depth2
then
7152 elsif Depth1
> Depth2
then
7153 Root1
:= Prefix
(A1
);
7154 for J
in 1 .. Depth1
- Depth2
- 1 loop
7155 Root1
:= Prefix
(Root1
);
7158 return Denotes_Same_Object
(Root1
, A2
);
7161 Root2
:= Prefix
(A2
);
7162 for J
in 1 .. Depth2
- Depth1
- 1 loop
7163 Root2
:= Prefix
(Root2
);
7166 return Denotes_Same_Object
(A1
, Root2
);
7173 end Denotes_Same_Prefix
;
7175 ----------------------
7176 -- Denotes_Variable --
7177 ----------------------
7179 function Denotes_Variable
(N
: Node_Id
) return Boolean is
7181 return Is_Variable
(N
) and then Paren_Count
(N
) = 0;
7182 end Denotes_Variable
;
7184 -----------------------------
7185 -- Depends_On_Discriminant --
7186 -----------------------------
7188 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
7193 Get_Index_Bounds
(N
, L
, H
);
7194 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
7195 end Depends_On_Discriminant
;
7197 -------------------------------------
7198 -- Derivation_Too_Early_To_Inherit --
7199 -------------------------------------
7201 function Derivation_Too_Early_To_Inherit
7202 (Typ
: Entity_Id
; Streaming_Op
: TSS_Name_Type
) return Boolean is
7204 Btyp
: constant Entity_Id
:= Implementation_Base_Type
(Typ
);
7205 Parent_Type
: Entity_Id
;
7209 -- Start of processing for Derivation_Too_Early_To_Inherit
7212 if Is_Derived_Type
(Btyp
) then
7213 Parent_Type
:= Implementation_Base_Type
(Etype
(Btyp
));
7214 pragma Assert
(Parent_Type
/= Btyp
);
7216 if Has_Stream_Attribute_Definition
7217 (Parent_Type
, Streaming_Op
, Real_Rep
=> Real_Rep
)
7219 and then In_Same_Extended_Unit
(Btyp
, Parent_Type
)
7220 and then Instantiation
(Get_Source_File_Index
(Sloc
(Btyp
))) =
7221 Instantiation
(Get_Source_File_Index
(Sloc
(Parent_Type
)))
7223 return Earlier_In_Extended_Unit
(Btyp
, Real_Rep
);
7228 end Derivation_Too_Early_To_Inherit
;
7230 -------------------------
7231 -- Designate_Same_Unit --
7232 -------------------------
7234 function Designate_Same_Unit
7236 Name2
: Node_Id
) return Boolean
7238 K1
: constant Node_Kind
:= Nkind
(Name1
);
7239 K2
: constant Node_Kind
:= Nkind
(Name2
);
7241 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
7242 -- Returns the parent unit name node of a defining program unit name
7243 -- or the prefix if N is a selected component or an expanded name.
7245 function Select_Node
(N
: Node_Id
) return Node_Id
;
7246 -- Returns the defining identifier node of a defining program unit
7247 -- name or the selector node if N is a selected component or an
7254 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
7256 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
7267 function Select_Node
(N
: Node_Id
) return Node_Id
is
7269 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
7270 return Defining_Identifier
(N
);
7272 return Selector_Name
(N
);
7276 -- Start of processing for Designate_Same_Unit
7279 if K1
in N_Identifier | N_Defining_Identifier
7281 K2
in N_Identifier | N_Defining_Identifier
7283 return Chars
(Name1
) = Chars
(Name2
);
7285 elsif K1
in N_Expanded_Name
7286 | N_Selected_Component
7287 | N_Defining_Program_Unit_Name
7289 K2
in N_Expanded_Name
7290 | N_Selected_Component
7291 | N_Defining_Program_Unit_Name
7294 (Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
)))
7296 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
7301 end Designate_Same_Unit
;
7303 ---------------------------------------------
7304 -- Diagnose_Iterated_Component_Association --
7305 ---------------------------------------------
7307 procedure Diagnose_Iterated_Component_Association
(N
: Node_Id
) is
7308 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
7312 -- Determine whether the iterated component association appears within
7313 -- an aggregate. If this is the case, raise Program_Error because the
7314 -- iterated component association cannot be left in the tree as is and
7315 -- must always be processed by the related aggregate.
7318 while Present
(Aggr
) loop
7319 if Nkind
(Aggr
) = N_Aggregate
then
7320 raise Program_Error
;
7322 -- Prevent the search from going too far
7324 elsif Is_Body_Or_Package_Declaration
(Aggr
) then
7328 Aggr
:= Parent
(Aggr
);
7331 -- At this point it is known that the iterated component association is
7332 -- not within an aggregate. This is really a quantified expression with
7333 -- a missing "all" or "some" quantifier.
7335 Error_Msg_N
("missing quantifier", Def_Id
);
7337 -- Rewrite the iterated component association as True to prevent any
7340 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Sloc
(N
)));
7342 end Diagnose_Iterated_Component_Association
;
7344 ------------------------
7345 -- Discriminated_Size --
7346 ------------------------
7348 function Discriminated_Size
(Comp
: Entity_Id
) return Boolean is
7349 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean;
7350 -- Check whether the bound of an index is non-static and does denote
7351 -- a discriminant, in which case any object of the type (protected or
7352 -- otherwise) will have a non-static size.
7354 ----------------------
7355 -- Non_Static_Bound --
7356 ----------------------
7358 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean is
7360 if Is_OK_Static_Expression
(Bound
) then
7363 -- If the bound is given by a discriminant it is non-static
7364 -- (A static constraint replaces the reference with the value).
7365 -- In an protected object the discriminant has been replaced by
7366 -- the corresponding discriminal within the protected operation.
7368 elsif Is_Entity_Name
(Bound
)
7370 (Ekind
(Entity
(Bound
)) = E_Discriminant
7371 or else Present
(Discriminal_Link
(Entity
(Bound
))))
7378 end Non_Static_Bound
;
7382 Typ
: constant Entity_Id
:= Etype
(Comp
);
7385 -- Start of processing for Discriminated_Size
7388 if not Is_Array_Type
(Typ
) then
7392 if Ekind
(Typ
) = E_Array_Subtype
then
7393 Index
:= First_Index
(Typ
);
7394 while Present
(Index
) loop
7395 if Non_Static_Bound
(Low_Bound
(Index
))
7396 or else Non_Static_Bound
(High_Bound
(Index
))
7408 end Discriminated_Size
;
7410 -----------------------------
7411 -- Effective_Reads_Enabled --
7412 -----------------------------
7414 function Effective_Reads_Enabled
(Id
: Entity_Id
) return Boolean is
7416 return Has_Enabled_Property
(Id
, Name_Effective_Reads
);
7417 end Effective_Reads_Enabled
;
7419 ------------------------------
7420 -- Effective_Writes_Enabled --
7421 ------------------------------
7423 function Effective_Writes_Enabled
(Id
: Entity_Id
) return Boolean is
7425 return Has_Enabled_Property
(Id
, Name_Effective_Writes
);
7426 end Effective_Writes_Enabled
;
7428 ------------------------------
7429 -- Enclosing_Comp_Unit_Node --
7430 ------------------------------
7432 function Enclosing_Comp_Unit_Node
(N
: Node_Id
) return Node_Id
is
7433 Current_Node
: Node_Id
;
7437 while Present
(Current_Node
)
7438 and then Nkind
(Current_Node
) /= N_Compilation_Unit
7440 Current_Node
:= Parent
(Current_Node
);
7443 return Current_Node
;
7444 end Enclosing_Comp_Unit_Node
;
7446 --------------------------
7447 -- Enclosing_CPP_Parent --
7448 --------------------------
7450 function Enclosing_CPP_Parent
(Typ
: Entity_Id
) return Entity_Id
is
7451 Parent_Typ
: Entity_Id
:= Typ
;
7454 while not Is_CPP_Class
(Parent_Typ
)
7455 and then Etype
(Parent_Typ
) /= Parent_Typ
7457 Parent_Typ
:= Etype
(Parent_Typ
);
7459 if Is_Private_Type
(Parent_Typ
) then
7460 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
7464 pragma Assert
(Is_CPP_Class
(Parent_Typ
));
7466 end Enclosing_CPP_Parent
;
7468 ---------------------------
7469 -- Enclosing_Declaration --
7470 ---------------------------
7472 function Enclosing_Declaration
(N
: Node_Id
) return Node_Id
is
7473 Decl
: Node_Id
:= N
;
7476 while Present
(Decl
)
7477 and then not (Nkind
(Decl
) in N_Declaration
7479 Nkind
(Decl
) in N_Later_Decl_Item
7481 Nkind
(Decl
) in N_Renaming_Declaration
7483 Nkind
(Decl
) = N_Number_Declaration
)
7485 Decl
:= Parent
(Decl
);
7489 end Enclosing_Declaration
;
7491 ----------------------------------------
7492 -- Enclosing_Declaration_Or_Statement --
7493 ----------------------------------------
7495 function Enclosing_Declaration_Or_Statement
7496 (N
: Node_Id
) return Node_Id
7502 while Present
(Par
) loop
7503 if Is_Declaration
(Par
) or else Is_Statement
(Par
) then
7506 -- Prevent the search from going too far
7508 elsif Is_Body_Or_Package_Declaration
(Par
) then
7512 Par
:= Parent
(Par
);
7516 end Enclosing_Declaration_Or_Statement
;
7518 ----------------------------
7519 -- Enclosing_Generic_Body --
7520 ----------------------------
7522 function Enclosing_Generic_Body
(N
: Node_Id
) return Node_Id
is
7524 Spec_Id
: Entity_Id
;
7528 while Present
(Par
) loop
7529 if Nkind
(Par
) in N_Package_Body | N_Subprogram_Body
then
7530 Spec_Id
:= Corresponding_Spec
(Par
);
7532 if Present
(Spec_Id
)
7533 and then Nkind
(Unit_Declaration_Node
(Spec_Id
)) in
7534 N_Generic_Declaration
7540 Par
:= Parent
(Par
);
7544 end Enclosing_Generic_Body
;
7546 ----------------------------
7547 -- Enclosing_Generic_Unit --
7548 ----------------------------
7550 function Enclosing_Generic_Unit
(N
: Node_Id
) return Node_Id
is
7552 Spec_Decl
: Node_Id
;
7553 Spec_Id
: Entity_Id
;
7557 while Present
(Par
) loop
7558 if Nkind
(Par
) in N_Generic_Declaration
then
7561 elsif Nkind
(Par
) in N_Package_Body | N_Subprogram_Body
then
7562 Spec_Id
:= Corresponding_Spec
(Par
);
7564 if Present
(Spec_Id
) then
7565 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
7567 if Nkind
(Spec_Decl
) in N_Generic_Declaration
then
7573 Par
:= Parent
(Par
);
7577 end Enclosing_Generic_Unit
;
7583 function Enclosing_HSS
(Stmt
: Node_Id
) return Node_Id
is
7586 pragma Assert
(Is_Statement
(Stmt
));
7588 Par
:= Parent
(Stmt
);
7589 while Present
(Par
) loop
7591 if Nkind
(Par
) = N_Handled_Sequence_Of_Statements
then
7594 -- Prevent the search from going too far
7596 elsif Is_Body_Or_Package_Declaration
(Par
) then
7601 Par
:= Parent
(Par
);
7607 -------------------------------
7608 -- Enclosing_Lib_Unit_Entity --
7609 -------------------------------
7611 function Enclosing_Lib_Unit_Entity
7612 (E
: Entity_Id
:= Current_Scope
) return Entity_Id
7614 Unit_Entity
: Entity_Id
;
7617 -- Look for enclosing library unit entity by following scope links.
7618 -- Equivalent to, but faster than indexing through the scope stack.
7621 while (Present
(Scope
(Unit_Entity
))
7622 and then Scope
(Unit_Entity
) /= Standard_Standard
)
7623 and not Is_Child_Unit
(Unit_Entity
)
7625 Unit_Entity
:= Scope
(Unit_Entity
);
7629 end Enclosing_Lib_Unit_Entity
;
7631 -----------------------------
7632 -- Enclosing_Lib_Unit_Node --
7633 -----------------------------
7635 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
7636 Encl_Unit
: Node_Id
;
7639 Encl_Unit
:= Enclosing_Comp_Unit_Node
(N
);
7640 while Present
(Encl_Unit
)
7641 and then Nkind
(Unit
(Encl_Unit
)) = N_Subunit
7643 Encl_Unit
:= Library_Unit
(Encl_Unit
);
7646 pragma Assert
(Nkind
(Encl_Unit
) = N_Compilation_Unit
);
7648 end Enclosing_Lib_Unit_Node
;
7650 -----------------------
7651 -- Enclosing_Package --
7652 -----------------------
7654 function Enclosing_Package
(N
: Node_Or_Entity_Id
) return Entity_Id
is
7655 Dynamic_Scope
: Entity_Id
;
7658 -- Obtain the enclosing scope when N is a Node_Id - taking care to
7659 -- handle the case when the enclosing scope is already a package.
7661 if Nkind
(N
) not in N_Entity
then
7663 Encl_Scop
: constant Entity_Id
:= Find_Enclosing_Scope
(N
);
7665 if No
(Encl_Scop
) then
7667 elsif Ekind
(Encl_Scop
) in
7668 E_Generic_Package | E_Package | E_Package_Body
7673 return Enclosing_Package
(Encl_Scop
);
7677 -- When N is already an Entity_Id proceed
7679 Dynamic_Scope
:= Enclosing_Dynamic_Scope
(N
);
7680 if Dynamic_Scope
= Standard_Standard
then
7681 return Standard_Standard
;
7683 elsif Dynamic_Scope
= Empty
then
7686 elsif Ekind
(Dynamic_Scope
) in
7687 E_Generic_Package | E_Package | E_Package_Body
7689 return Dynamic_Scope
;
7692 return Enclosing_Package
(Dynamic_Scope
);
7694 end Enclosing_Package
;
7696 -------------------------------------
7697 -- Enclosing_Package_Or_Subprogram --
7698 -------------------------------------
7700 function Enclosing_Package_Or_Subprogram
(E
: Entity_Id
) return Entity_Id
is
7705 while Present
(S
) loop
7706 if Is_Package_Or_Generic_Package
(S
)
7707 or else Is_Subprogram_Or_Generic_Subprogram
(S
)
7717 end Enclosing_Package_Or_Subprogram
;
7719 --------------------------
7720 -- Enclosing_Subprogram --
7721 --------------------------
7723 function Enclosing_Subprogram
(N
: Node_Or_Entity_Id
) return Entity_Id
is
7724 Dyn_Scop
: Entity_Id
;
7725 Encl_Scop
: Entity_Id
;
7728 -- Obtain the enclosing scope when N is a Node_Id - taking care to
7729 -- handle the case when the enclosing scope is already a subprogram.
7731 if Nkind
(N
) not in N_Entity
then
7732 Encl_Scop
:= Find_Enclosing_Scope
(N
);
7734 if No
(Encl_Scop
) then
7736 elsif Ekind
(Encl_Scop
) in Subprogram_Kind
then
7740 return Enclosing_Subprogram
(Encl_Scop
);
7743 -- When N is already an Entity_Id proceed
7745 Dyn_Scop
:= Enclosing_Dynamic_Scope
(N
);
7746 if Dyn_Scop
= Standard_Standard
then
7749 elsif Dyn_Scop
= Empty
then
7752 elsif Ekind
(Dyn_Scop
) = E_Subprogram_Body
then
7753 return Corresponding_Spec
(Parent
(Parent
(Dyn_Scop
)));
7755 elsif Ekind
(Dyn_Scop
) in E_Block | E_Loop | E_Return_Statement
then
7756 return Enclosing_Subprogram
(Dyn_Scop
);
7758 elsif Ekind
(Dyn_Scop
) in E_Entry | E_Entry_Family
then
7760 -- For a task entry or entry family, return the enclosing subprogram
7761 -- of the task itself.
7763 if Ekind
(Scope
(Dyn_Scop
)) = E_Task_Type
then
7764 return Enclosing_Subprogram
(Dyn_Scop
);
7766 -- A protected entry or entry family is rewritten as a protected
7767 -- procedure which is the desired enclosing subprogram. This is
7768 -- relevant when unnesting a procedure local to an entry body.
7771 return Protected_Body_Subprogram
(Dyn_Scop
);
7774 elsif Ekind
(Dyn_Scop
) = E_Task_Type
then
7775 return Get_Task_Body_Procedure
(Dyn_Scop
);
7777 -- The scope may appear as a private type or as a private extension
7778 -- whose completion is a task or protected type.
7780 elsif Ekind
(Dyn_Scop
) in
7781 E_Limited_Private_Type | E_Record_Type_With_Private
7782 and then Present
(Full_View
(Dyn_Scop
))
7783 and then Ekind
(Full_View
(Dyn_Scop
)) in E_Task_Type | E_Protected_Type
7785 return Get_Task_Body_Procedure
(Full_View
(Dyn_Scop
));
7787 -- No body is generated if the protected operation is eliminated
7789 elsif not Is_Eliminated
(Dyn_Scop
)
7790 and then Present
(Protected_Body_Subprogram
(Dyn_Scop
))
7792 return Protected_Body_Subprogram
(Dyn_Scop
);
7797 end Enclosing_Subprogram
;
7799 --------------------------
7800 -- End_Keyword_Location --
7801 --------------------------
7803 function End_Keyword_Location
(N
: Node_Id
) return Source_Ptr
is
7804 function End_Label_Loc
(Nod
: Node_Id
) return Source_Ptr
;
7805 -- Return the source location of Nod's end label according to the
7806 -- following precedence rules:
7808 -- 1) If the end label exists, return its location
7809 -- 2) If Nod exists, return its location
7810 -- 3) Return the location of N
7816 function End_Label_Loc
(Nod
: Node_Id
) return Source_Ptr
is
7820 if Present
(Nod
) then
7821 Label
:= End_Label
(Nod
);
7823 if Present
(Label
) then
7824 return Sloc
(Label
);
7836 Owner
: Node_Id
:= Empty
;
7838 -- Start of processing for End_Keyword_Location
7841 if Nkind
(N
) in N_Block_Statement
7847 Owner
:= Handled_Statement_Sequence
(N
);
7849 elsif Nkind
(N
) = N_Package_Declaration
then
7850 Owner
:= Specification
(N
);
7852 elsif Nkind
(N
) = N_Protected_Body
then
7855 elsif Nkind
(N
) in N_Protected_Type_Declaration
7856 | N_Single_Protected_Declaration
7858 Owner
:= Protected_Definition
(N
);
7860 elsif Nkind
(N
) in N_Single_Task_Declaration | N_Task_Type_Declaration
7862 Owner
:= Task_Definition
(N
);
7864 -- This routine should not be called with other contexts
7867 pragma Assert
(False);
7871 return End_Label_Loc
(Owner
);
7872 end End_Keyword_Location
;
7874 ------------------------
7875 -- Ensure_Freeze_Node --
7876 ------------------------
7878 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
7881 if No
(Freeze_Node
(E
)) then
7882 FN
:= Make_Freeze_Entity
(Sloc
(E
));
7883 Set_Has_Delayed_Freeze
(E
);
7884 Set_Freeze_Node
(E
, FN
);
7885 Set_Access_Types_To_Process
(FN
, No_Elist
);
7886 Set_TSS_Elist
(FN
, No_Elist
);
7889 end Ensure_Freeze_Node
;
7895 procedure Enter_Name
(Def_Id
: Entity_Id
) is
7896 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
7897 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
7898 S
: constant Entity_Id
:= Current_Scope
;
7901 Generate_Definition
(Def_Id
);
7903 -- Add new name to current scope declarations. Check for duplicate
7904 -- declaration, which may or may not be a genuine error.
7908 -- Case of previous entity entered because of a missing declaration
7909 -- or else a bad subtype indication. Best is to use the new entity,
7910 -- and make the previous one invisible.
7912 if Etype
(E
) = Any_Type
then
7913 Set_Is_Immediately_Visible
(E
, False);
7915 -- Case of renaming declaration constructed for package instances.
7916 -- if there is an explicit declaration with the same identifier,
7917 -- the renaming is not immediately visible any longer, but remains
7918 -- visible through selected component notation.
7920 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
7921 and then not Comes_From_Source
(E
)
7923 Set_Is_Immediately_Visible
(E
, False);
7925 -- The new entity may be the package renaming, which has the same
7926 -- same name as a generic formal which has been seen already.
7928 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
7929 and then not Comes_From_Source
(Def_Id
)
7931 Set_Is_Immediately_Visible
(E
, False);
7933 -- For a fat pointer corresponding to a remote access to subprogram,
7934 -- we use the same identifier as the RAS type, so that the proper
7935 -- name appears in the stub. This type is only retrieved through
7936 -- the RAS type and never by visibility, and is not added to the
7937 -- visibility list (see below).
7939 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
7940 and then Ekind
(Def_Id
) = E_Record_Type
7941 and then Present
(Corresponding_Remote_Type
(Def_Id
))
7945 -- Case of an implicit operation or derived literal. The new entity
7946 -- hides the implicit one, which is removed from all visibility,
7947 -- i.e. the entity list of its scope, and homonym chain of its name.
7949 elsif (Is_Overloadable
(E
) and then Is_Inherited_Operation
(E
))
7950 or else Is_Internal
(E
)
7953 Decl
: constant Node_Id
:= Parent
(E
);
7955 Prev_Vis
: Entity_Id
;
7958 -- If E is an implicit declaration, it cannot be the first
7959 -- entity in the scope.
7961 Prev
:= First_Entity
(Current_Scope
);
7962 while Present
(Prev
) and then Next_Entity
(Prev
) /= E
loop
7968 -- If E is not on the entity chain of the current scope,
7969 -- it is an implicit declaration in the generic formal
7970 -- part of a generic subprogram. When analyzing the body,
7971 -- the generic formals are visible but not on the entity
7972 -- chain of the subprogram. The new entity will become
7973 -- the visible one in the body.
7976 (Nkind
(Parent
(Decl
)) = N_Generic_Subprogram_Declaration
);
7980 Link_Entities
(Prev
, Next_Entity
(E
));
7982 if No
(Next_Entity
(Prev
)) then
7983 Set_Last_Entity
(Current_Scope
, Prev
);
7986 if E
= Current_Entity
(E
) then
7990 Prev_Vis
:= Current_Entity
(E
);
7991 while Homonym
(Prev_Vis
) /= E
loop
7992 Prev_Vis
:= Homonym
(Prev_Vis
);
7996 if Present
(Prev_Vis
) then
7998 -- Skip E in the visibility chain
8000 Set_Homonym
(Prev_Vis
, Homonym
(E
));
8003 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
8006 -- The inherited operation cannot be retrieved
8007 -- by name, even though it may remain accesssible
8008 -- in some cases involving subprogram bodies without
8009 -- specs appearing in with_clauses..
8011 Set_Is_Immediately_Visible
(E
, False);
8015 -- This section of code could use a comment ???
8017 elsif Present
(Etype
(E
))
8018 and then Is_Concurrent_Type
(Etype
(E
))
8023 -- If the homograph is a protected component renaming, it should not
8024 -- be hiding the current entity. Such renamings are treated as weak
8027 elsif Is_Prival
(E
) then
8028 Set_Is_Immediately_Visible
(E
, False);
8030 -- In this case the current entity is a protected component renaming.
8031 -- Perform minimal decoration by setting the scope and return since
8032 -- the prival should not be hiding other visible entities.
8034 elsif Is_Prival
(Def_Id
) then
8035 Set_Scope
(Def_Id
, Current_Scope
);
8038 -- Analogous to privals, the discriminal generated for an entry index
8039 -- parameter acts as a weak declaration. Perform minimal decoration
8040 -- to avoid bogus errors.
8042 elsif Is_Discriminal
(Def_Id
)
8043 and then Ekind
(Discriminal_Link
(Def_Id
)) = E_Entry_Index_Parameter
8045 Set_Scope
(Def_Id
, Current_Scope
);
8048 -- In the body or private part of an instance, a type extension may
8049 -- introduce a component with the same name as that of an actual. The
8050 -- legality rule is not enforced, but the semantics of the full type
8051 -- with two components of same name are not clear at this point???
8053 elsif In_Instance_Not_Visible
then
8056 -- When compiling a package body, some child units may have become
8057 -- visible. They cannot conflict with local entities that hide them.
8059 elsif Is_Child_Unit
(E
)
8060 and then In_Open_Scopes
(Scope
(E
))
8061 and then not Is_Immediately_Visible
(E
)
8065 -- Conversely, with front-end inlining we may compile the parent body
8066 -- first, and a child unit subsequently. The context is now the
8067 -- parent spec, and body entities are not visible.
8069 elsif Is_Child_Unit
(Def_Id
)
8070 and then Is_Package_Body_Entity
(E
)
8071 and then not In_Package_Body
(Current_Scope
)
8075 -- Case of genuine duplicate declaration
8078 Error_Msg_Sloc
:= Sloc
(E
);
8080 -- If the previous declaration is an incomplete type declaration
8081 -- this may be an attempt to complete it with a private type. The
8082 -- following avoids confusing cascaded errors.
8084 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
8085 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
8088 ("incomplete type cannot be completed with a private " &
8089 "declaration", Parent
(Def_Id
));
8090 Set_Is_Immediately_Visible
(E
, False);
8091 Set_Full_View
(E
, Def_Id
);
8093 -- An inherited component of a record conflicts with a new
8094 -- discriminant. The discriminant is inserted first in the scope,
8095 -- but the error should be posted on it, not on the component.
8097 elsif Ekind
(E
) = E_Discriminant
8098 and then Present
(Scope
(Def_Id
))
8099 and then Scope
(Def_Id
) /= Current_Scope
8101 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8102 Error_Msg_N
("& conflicts with declaration#", E
);
8105 -- If the name of the unit appears in its own context clause, a
8106 -- dummy package with the name has already been created, and the
8107 -- error emitted. Try to continue quietly.
8109 elsif Error_Posted
(E
)
8110 and then Sloc
(E
) = No_Location
8111 and then Nkind
(Parent
(E
)) = N_Package_Specification
8112 and then Current_Scope
= Standard_Standard
8114 Set_Scope
(Def_Id
, Current_Scope
);
8118 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
8120 -- Avoid cascaded messages with duplicate components in
8123 if Ekind
(E
) in E_Component | E_Discriminant
then
8128 if Nkind
(Parent
(Parent
(Def_Id
))) =
8129 N_Generic_Subprogram_Declaration
8131 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
8133 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
8136 -- If entity is in standard, then we are in trouble, because it
8137 -- means that we have a library package with a duplicated name.
8138 -- That's hard to recover from, so abort.
8140 if S
= Standard_Standard
then
8141 raise Unrecoverable_Error
;
8143 -- Otherwise we continue with the declaration. Having two
8144 -- identical declarations should not cause us too much trouble.
8152 -- If we fall through, declaration is OK, at least OK enough to continue
8154 -- If Def_Id is a discriminant or a record component we are in the midst
8155 -- of inheriting components in a derived record definition. Preserve
8156 -- their Ekind and Etype.
8158 if Ekind
(Def_Id
) in E_Discriminant | E_Component
then
8161 -- If a type is already set, leave it alone (happens when a type
8162 -- declaration is reanalyzed following a call to the optimizer).
8164 elsif Present
(Etype
(Def_Id
)) then
8167 -- Otherwise, the kind E_Void insures that premature uses of the entity
8168 -- will be detected. Any_Type insures that no cascaded errors will occur
8171 Mutate_Ekind
(Def_Id
, E_Void
);
8172 Set_Etype
(Def_Id
, Any_Type
);
8175 -- All entities except Itypes are immediately visible
8177 if not Is_Itype
(Def_Id
) then
8178 Set_Is_Immediately_Visible
(Def_Id
);
8179 Set_Current_Entity
(Def_Id
);
8182 Set_Homonym
(Def_Id
, C
);
8183 Append_Entity
(Def_Id
, S
);
8184 Set_Public_Status
(Def_Id
);
8186 -- Warn if new entity hides an old one
8188 if Warn_On_Hiding
and then Present
(C
) then
8189 Warn_On_Hiding_Entity
(Def_Id
, Hidden
=> C
, Visible
=> Def_Id
,
8190 On_Use_Clause
=> False);
8198 function Entity_Of
(N
: Node_Id
) return Entity_Id
is
8203 -- Assume that the arbitrary node does not have an entity
8207 if Is_Entity_Name
(N
) then
8210 -- Follow a possible chain of renamings to reach the earliest renamed
8214 and then Is_Object
(Id
)
8215 and then Present
(Renamed_Object
(Id
))
8217 Ren
:= Renamed_Object
(Id
);
8219 -- The reference renames an abstract state or a whole object
8222 -- Ren : ... renames Obj;
8224 if Is_Entity_Name
(Ren
) then
8226 -- Do not follow a renaming that goes through a generic formal,
8227 -- because these entities are hidden and must not be referenced
8228 -- from outside the generic.
8230 if Is_Hidden
(Entity
(Ren
)) then
8237 -- The reference renames a function result. Check the original
8238 -- node in case expansion relocates the function call.
8240 -- Ren : ... renames Func_Call;
8242 elsif Nkind
(Original_Node
(Ren
)) = N_Function_Call
then
8245 -- Otherwise the reference renames something which does not yield
8246 -- an abstract state or a whole object. Treat the reference as not
8247 -- having a proper entity for SPARK legality purposes.
8259 --------------------------
8260 -- Examine_Array_Bounds --
8261 --------------------------
8263 procedure Examine_Array_Bounds
8265 All_Static
: out Boolean;
8266 Has_Empty
: out Boolean)
8268 function Is_OK_Static_Bound
(Bound
: Node_Id
) return Boolean;
8269 -- Determine whether bound Bound is a suitable static bound
8271 ------------------------
8272 -- Is_OK_Static_Bound --
8273 ------------------------
8275 function Is_OK_Static_Bound
(Bound
: Node_Id
) return Boolean is
8278 not Error_Posted
(Bound
)
8279 and then Is_OK_Static_Expression
(Bound
);
8280 end Is_OK_Static_Bound
;
8288 -- Start of processing for Examine_Array_Bounds
8291 -- An unconstrained array type does not have static bounds, and it is
8292 -- not known whether they are empty or not.
8294 if not Is_Constrained
(Typ
) then
8295 All_Static
:= False;
8298 -- A string literal has static bounds, and is not empty as long as it
8299 -- contains at least one character.
8301 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
8303 Has_Empty
:= String_Literal_Length
(Typ
) > 0;
8306 -- Assume that all bounds are static and not empty
8311 -- Examine each index
8313 Index
:= First_Index
(Typ
);
8314 while Present
(Index
) loop
8315 if Is_Discrete_Type
(Etype
(Index
)) then
8316 Get_Index_Bounds
(Index
, Lo_Bound
, Hi_Bound
);
8318 if Is_OK_Static_Bound
(Lo_Bound
)
8320 Is_OK_Static_Bound
(Hi_Bound
)
8322 -- The static bounds produce an empty range
8324 if Is_Null_Range
(Lo_Bound
, Hi_Bound
) then
8328 -- Otherwise at least one of the bounds is not static
8331 All_Static
:= False;
8334 -- Otherwise the index is non-discrete, therefore not static
8337 All_Static
:= False;
8342 end Examine_Array_Bounds
;
8348 function Exceptions_OK
return Boolean is
8351 not (Restriction_Active
(No_Exception_Handlers
) or else
8352 Restriction_Active
(No_Exception_Propagation
) or else
8353 Restriction_Active
(No_Exceptions
));
8356 --------------------------
8357 -- Explain_Limited_Type --
8358 --------------------------
8360 procedure Explain_Limited_Type
(T
: Entity_Id
; N
: Node_Id
) is
8364 -- For array, component type must be limited
8366 if Is_Array_Type
(T
) then
8367 Error_Msg_Node_2
:= T
;
8369 ("\component type& of type& is limited", N
, Component_Type
(T
));
8370 Explain_Limited_Type
(Component_Type
(T
), N
);
8372 elsif Is_Record_Type
(T
) then
8374 -- No need for extra messages if explicit limited record
8376 if Is_Limited_Record
(Base_Type
(T
)) then
8380 -- Otherwise find a limited component. Check only components that
8381 -- come from source, or inherited components that appear in the
8382 -- source of the ancestor.
8384 C
:= First_Component
(T
);
8385 while Present
(C
) loop
8386 if Is_Limited_Type
(Etype
(C
))
8388 (Comes_From_Source
(C
)
8390 (Present
(Original_Record_Component
(C
))
8392 Comes_From_Source
(Original_Record_Component
(C
))))
8394 Error_Msg_Node_2
:= T
;
8395 Error_Msg_NE
("\component& of type& has limited type", N
, C
);
8396 Explain_Limited_Type
(Etype
(C
), N
);
8403 -- The type may be declared explicitly limited, even if no component
8404 -- of it is limited, in which case we fall out of the loop.
8407 end Explain_Limited_Type
;
8409 ---------------------------------------
8410 -- Expression_Of_Expression_Function --
8411 ---------------------------------------
8413 function Expression_Of_Expression_Function
8414 (Subp
: Entity_Id
) return Node_Id
8416 Expr_Func
: Node_Id
:= Empty
;
8419 pragma Assert
(Is_Expression_Function_Or_Completion
(Subp
));
8421 if Nkind
(Original_Node
(Subprogram_Spec
(Subp
))) =
8422 N_Expression_Function
8424 Expr_Func
:= Original_Node
(Subprogram_Spec
(Subp
));
8426 elsif Nkind
(Original_Node
(Subprogram_Body
(Subp
))) =
8427 N_Expression_Function
8429 Expr_Func
:= Original_Node
(Subprogram_Body
(Subp
));
8432 pragma Assert
(False);
8436 return Original_Node
(Expression
(Expr_Func
));
8437 end Expression_Of_Expression_Function
;
8439 -------------------------------
8440 -- Extensions_Visible_Status --
8441 -------------------------------
8443 function Extensions_Visible_Status
8444 (Id
: Entity_Id
) return Extensions_Visible_Mode
8453 -- When a formal parameter is subject to Extensions_Visible, the pragma
8454 -- is stored in the contract of related subprogram.
8456 if Is_Formal
(Id
) then
8459 elsif Is_Subprogram_Or_Generic_Subprogram
(Id
) then
8462 -- No other construct carries this pragma
8465 return Extensions_Visible_None
;
8468 Prag
:= Get_Pragma
(Subp
, Pragma_Extensions_Visible
);
8470 -- In certain cases analysis may request the Extensions_Visible status
8471 -- of an expression function before the pragma has been analyzed yet.
8472 -- Inspect the declarative items after the expression function looking
8473 -- for the pragma (if any).
8475 if No
(Prag
) and then Is_Expression_Function
(Subp
) then
8476 Decl
:= Next
(Unit_Declaration_Node
(Subp
));
8477 while Present
(Decl
) loop
8478 if Nkind
(Decl
) = N_Pragma
8479 and then Pragma_Name
(Decl
) = Name_Extensions_Visible
8484 -- A source construct ends the region where Extensions_Visible may
8485 -- appear, stop the traversal. An expanded expression function is
8486 -- no longer a source construct, but it must still be recognized.
8488 elsif Comes_From_Source
(Decl
)
8490 (Nkind
(Decl
) in N_Subprogram_Body | N_Subprogram_Declaration
8491 and then Is_Expression_Function
(Defining_Entity
(Decl
)))
8500 -- Extract the value from the Boolean expression (if any)
8502 if Present
(Prag
) then
8503 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
8505 if Present
(Arg
) then
8506 Expr
:= Get_Pragma_Arg
(Arg
);
8508 -- When the associated subprogram is an expression function, the
8509 -- argument of the pragma may not have been analyzed.
8511 if not Analyzed
(Expr
) then
8512 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
8515 -- Guard against cascading errors when the argument of pragma
8516 -- Extensions_Visible is not a valid static Boolean expression.
8518 if Error_Posted
(Expr
) then
8519 return Extensions_Visible_None
;
8521 elsif Is_True
(Expr_Value
(Expr
)) then
8522 return Extensions_Visible_True
;
8525 return Extensions_Visible_False
;
8528 -- Otherwise the aspect or pragma defaults to True
8531 return Extensions_Visible_True
;
8534 -- Otherwise aspect or pragma Extensions_Visible is not inherited or
8535 -- directly specified. In SPARK code, its value defaults to "False".
8537 elsif SPARK_Mode
= On
then
8538 return Extensions_Visible_False
;
8540 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to
8544 return Extensions_Visible_True
;
8546 end Extensions_Visible_Status
;
8552 procedure Find_Actual
8554 Formal
: out Entity_Id
;
8557 Context
: constant Node_Id
:= Parent
(N
);
8562 if Nkind
(Context
) in N_Indexed_Component | N_Selected_Component
8563 and then N
= Prefix
(Context
)
8565 Find_Actual
(Context
, Formal
, Call
);
8568 elsif Nkind
(Context
) = N_Parameter_Association
8569 and then N
= Explicit_Actual_Parameter
(Context
)
8571 Call
:= Parent
(Context
);
8573 elsif Nkind
(Context
) in N_Entry_Call_Statement
8575 | N_Procedure_Call_Statement
8585 -- If we have a call to a subprogram look for the parameter. Note that
8586 -- we exclude overloaded calls, since we don't know enough to be sure
8587 -- of giving the right answer in this case.
8589 if Nkind
(Call
) in N_Entry_Call_Statement
8591 | N_Procedure_Call_Statement
8593 Call_Nam
:= Name
(Call
);
8595 -- A call to an entry family may appear as an indexed component
8597 if Nkind
(Call_Nam
) = N_Indexed_Component
then
8598 Call_Nam
:= Prefix
(Call_Nam
);
8601 -- A call to a protected or task entry appears as a selected
8602 -- component rather than an expanded name.
8604 if Nkind
(Call_Nam
) = N_Selected_Component
then
8605 Call_Nam
:= Selector_Name
(Call_Nam
);
8608 if Is_Entity_Name
(Call_Nam
)
8609 and then Present
(Entity
(Call_Nam
))
8610 and then (Is_Generic_Subprogram
(Entity
(Call_Nam
))
8611 or else Is_Overloadable
(Entity
(Call_Nam
))
8612 or else Ekind
(Entity
(Call_Nam
)) in E_Entry_Family
8614 | E_Subprogram_Type
)
8615 and then not Is_Overloaded
(Call_Nam
)
8617 -- If node is name in call it is not an actual
8619 if N
= Call_Nam
then
8625 -- Fall here if we are definitely a parameter
8627 Actual
:= First_Actual
(Call
);
8628 Formal
:= First_Formal
(Entity
(Call_Nam
));
8629 while Present
(Formal
) and then Present
(Actual
) loop
8633 -- An actual that is the prefix in a prefixed call may have
8634 -- been rewritten in the call. Check if sloc and kinds and
8637 elsif Sloc
(Actual
) = Sloc
(N
)
8638 and then Nkind
(Actual
) = N_Identifier
8639 and then Nkind
(Actual
) = Nkind
(N
)
8640 and then Chars
(Actual
) = Chars
(N
)
8645 Next_Actual
(Actual
);
8646 Next_Formal
(Formal
);
8652 -- Fall through here if we did not find matching actual
8658 ---------------------------
8659 -- Find_Body_Discriminal --
8660 ---------------------------
8662 function Find_Body_Discriminal
8663 (Spec_Discriminant
: Entity_Id
) return Entity_Id
8669 -- If expansion is suppressed, then the scope can be the concurrent type
8670 -- itself rather than a corresponding concurrent record type.
8672 if Is_Concurrent_Type
(Scope
(Spec_Discriminant
)) then
8673 Tsk
:= Scope
(Spec_Discriminant
);
8676 pragma Assert
(Is_Concurrent_Record_Type
(Scope
(Spec_Discriminant
)));
8678 Tsk
:= Corresponding_Concurrent_Type
(Scope
(Spec_Discriminant
));
8681 -- Find discriminant of original concurrent type, and use its current
8682 -- discriminal, which is the renaming within the task/protected body.
8684 Disc
:= First_Discriminant
(Tsk
);
8685 while Present
(Disc
) loop
8686 if Chars
(Disc
) = Chars
(Spec_Discriminant
) then
8687 return Discriminal
(Disc
);
8690 Next_Discriminant
(Disc
);
8693 -- That loop should always succeed in finding a matching entry and
8694 -- returning. Fatal error if not.
8696 raise Program_Error
;
8697 end Find_Body_Discriminal
;
8699 -------------------------------------
8700 -- Find_Corresponding_Discriminant --
8701 -------------------------------------
8703 function Find_Corresponding_Discriminant
8705 Typ
: Entity_Id
) return Entity_Id
8707 Par_Disc
: Entity_Id
;
8708 Old_Disc
: Entity_Id
;
8709 New_Disc
: Entity_Id
;
8712 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
8714 -- The original type may currently be private, and the discriminant
8715 -- only appear on its full view.
8717 if Is_Private_Type
(Scope
(Par_Disc
))
8718 and then not Has_Discriminants
(Scope
(Par_Disc
))
8719 and then Present
(Full_View
(Scope
(Par_Disc
)))
8721 Old_Disc
:= First_Discriminant
(Full_View
(Scope
(Par_Disc
)));
8723 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
8726 if Is_Class_Wide_Type
(Typ
) then
8727 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
8729 New_Disc
:= First_Discriminant
(Typ
);
8732 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
8733 if Old_Disc
= Par_Disc
then
8737 Next_Discriminant
(Old_Disc
);
8738 Next_Discriminant
(New_Disc
);
8741 -- Should always find it
8743 raise Program_Error
;
8744 end Find_Corresponding_Discriminant
;
8750 function Find_DIC_Type
(Typ
: Entity_Id
) return Entity_Id
is
8751 Curr_Typ
: Entity_Id
;
8752 -- The current type being examined in the parent hierarchy traversal
8754 DIC_Typ
: Entity_Id
;
8755 -- The type which carries the DIC pragma. This variable denotes the
8756 -- partial view when private types are involved.
8758 Par_Typ
: Entity_Id
;
8759 -- The parent type of the current type. This variable denotes the full
8760 -- view when private types are involved.
8763 -- The input type defines its own DIC pragma, therefore it is the owner
8765 if Has_Own_DIC
(Typ
) then
8768 -- Otherwise the DIC pragma is inherited from a parent type
8771 pragma Assert
(Has_Inherited_DIC
(Typ
));
8773 -- Climb the parent chain
8777 -- Inspect the parent type. Do not consider subtypes as they
8778 -- inherit the DIC attributes from their base types.
8780 DIC_Typ
:= Base_Type
(Etype
(Curr_Typ
));
8782 -- Look at the full view of a private type because the type may
8783 -- have a hidden parent introduced in the full view.
8787 if Is_Private_Type
(Par_Typ
)
8788 and then Present
(Full_View
(Par_Typ
))
8790 Par_Typ
:= Full_View
(Par_Typ
);
8793 -- Stop the climb once the nearest parent type which defines a DIC
8794 -- pragma of its own is encountered or when the root of the parent
8795 -- chain is reached.
8797 exit when Has_Own_DIC
(DIC_Typ
) or else Curr_Typ
= Par_Typ
;
8799 Curr_Typ
:= Par_Typ
;
8806 ----------------------------------
8807 -- Find_Enclosing_Iterator_Loop --
8808 ----------------------------------
8810 function Find_Enclosing_Iterator_Loop
(Id
: Entity_Id
) return Entity_Id
is
8815 -- Traverse the scope chain looking for an iterator loop. Such loops are
8816 -- usually transformed into blocks, hence the use of Original_Node.
8819 while Present
(S
) and then S
/= Standard_Standard
loop
8820 if Ekind
(S
) = E_Loop
8821 and then Nkind
(Parent
(S
)) = N_Implicit_Label_Declaration
8823 Constr
:= Original_Node
(Label_Construct
(Parent
(S
)));
8825 if Nkind
(Constr
) = N_Loop_Statement
8826 and then Present
(Iteration_Scheme
(Constr
))
8827 and then Nkind
(Iterator_Specification
8828 (Iteration_Scheme
(Constr
))) =
8829 N_Iterator_Specification
8839 end Find_Enclosing_Iterator_Loop
;
8841 --------------------------
8842 -- Find_Enclosing_Scope --
8843 --------------------------
8845 function Find_Enclosing_Scope
(N
: Node_Id
) return Entity_Id
is
8849 -- Examine the parent chain looking for a construct which defines a
8853 while Present
(Par
) loop
8856 -- The construct denotes a declaration, the proper scope is its
8859 when N_Entry_Declaration
8860 | N_Expression_Function
8861 | N_Full_Type_Declaration
8862 | N_Generic_Package_Declaration
8863 | N_Generic_Subprogram_Declaration
8864 | N_Package_Declaration
8865 | N_Private_Extension_Declaration
8866 | N_Protected_Type_Declaration
8867 | N_Single_Protected_Declaration
8868 | N_Single_Task_Declaration
8869 | N_Subprogram_Declaration
8870 | N_Task_Type_Declaration
8872 return Defining_Entity
(Par
);
8874 -- The construct denotes a body, the proper scope is the entity of
8875 -- the corresponding spec or that of the body if the body does not
8876 -- complete a previous declaration.
8884 return Unique_Defining_Entity
(Par
);
8888 -- Blocks carry either a source or an internally-generated scope,
8889 -- unless the block is a byproduct of exception handling.
8891 when N_Block_Statement
=>
8892 if not Exception_Junk
(Par
) then
8893 return Entity
(Identifier
(Par
));
8896 -- Loops carry an internally-generated scope
8898 when N_Loop_Statement
=>
8899 return Entity
(Identifier
(Par
));
8901 -- Extended return statements carry an internally-generated scope
8903 when N_Extended_Return_Statement
=>
8904 return Return_Statement_Entity
(Par
);
8906 -- A traversal from a subunit continues via the corresponding stub
8909 Par
:= Corresponding_Stub
(Par
);
8915 Par
:= Parent
(Par
);
8918 return Standard_Standard
;
8919 end Find_Enclosing_Scope
;
8921 ------------------------------------
8922 -- Find_Loop_In_Conditional_Block --
8923 ------------------------------------
8925 function Find_Loop_In_Conditional_Block
(N
: Node_Id
) return Node_Id
is
8931 if Nkind
(Stmt
) = N_If_Statement
then
8932 Stmt
:= First
(Then_Statements
(Stmt
));
8935 pragma Assert
(Nkind
(Stmt
) = N_Block_Statement
);
8937 -- Inspect the statements of the conditional block. In general the loop
8938 -- should be the first statement in the statement sequence of the block,
8939 -- but the finalization machinery may have introduced extra object
8942 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Stmt
)));
8943 while Present
(Stmt
) loop
8944 if Nkind
(Stmt
) = N_Loop_Statement
then
8951 -- The expansion of attribute 'Loop_Entry produced a malformed block
8953 raise Program_Error
;
8954 end Find_Loop_In_Conditional_Block
;
8956 --------------------------
8957 -- Find_Overlaid_Entity --
8958 --------------------------
8960 procedure Find_Overlaid_Entity
8962 Ent
: out Entity_Id
;
8966 (Nkind
(N
) = N_Attribute_Definition_Clause
8967 and then Chars
(N
) = Name_Address
);
8972 -- We are looking for one of the two following forms:
8974 -- for X'Address use Y'Address
8978 -- Const : constant Address := expr;
8980 -- for X'Address use Const;
8982 -- In the second case, the expr is either Y'Address, or recursively a
8983 -- constant that eventually references Y'Address.
8988 Expr
:= Expression
(N
);
8990 -- This loop checks the form of the expression for Y'Address, using
8991 -- recursion to deal with intermediate constants.
8994 -- Check for Y'Address
8996 if Nkind
(Expr
) = N_Attribute_Reference
8997 and then Attribute_Name
(Expr
) = Name_Address
8999 Expr
:= Prefix
(Expr
);
9002 -- Check for Const where Const is a constant entity
9004 elsif Is_Entity_Name
(Expr
)
9005 and then Ekind
(Entity
(Expr
)) = E_Constant
9007 Expr
:= Constant_Value
(Entity
(Expr
));
9009 -- Anything else does not need checking
9016 -- This loop checks the form of the prefix for an entity, using
9017 -- recursion to deal with intermediate components.
9020 -- Check for Y where Y is an entity
9022 if Is_Entity_Name
(Expr
) then
9023 Ent
:= Entity
(Expr
);
9025 -- If expansion is disabled, then we might see an entity of a
9026 -- protected component or of a discriminant of a concurrent unit.
9027 -- Ignore such entities, because further warnings for overlays
9028 -- expect this routine to only collect entities of entire objects.
9030 if Ekind
(Ent
) in E_Component | E_Discriminant
then
9032 (not Expander_Active
9033 and then Is_Concurrent_Type
(Scope
(Ent
)));
9038 -- Check for components
9040 elsif Nkind
(Expr
) in N_Selected_Component | N_Indexed_Component
then
9041 Expr
:= Prefix
(Expr
);
9044 -- Anything else does not need checking
9050 end Find_Overlaid_Entity
;
9052 -------------------------
9053 -- Find_Parameter_Type --
9054 -------------------------
9056 function Find_Parameter_Type
(Param
: Node_Id
) return Entity_Id
is
9058 if Nkind
(Param
) /= N_Parameter_Specification
then
9061 -- For an access parameter, obtain the type from the formal entity
9062 -- itself, because access to subprogram nodes do not carry a type.
9063 -- Shouldn't we always use the formal entity ???
9065 elsif Nkind
(Parameter_Type
(Param
)) = N_Access_Definition
then
9066 return Etype
(Defining_Identifier
(Param
));
9069 return Etype
(Parameter_Type
(Param
));
9071 end Find_Parameter_Type
;
9073 -----------------------------------
9074 -- Find_Placement_In_State_Space --
9075 -----------------------------------
9077 procedure Find_Placement_In_State_Space
9078 (Item_Id
: Entity_Id
;
9079 Placement
: out State_Space_Kind
;
9080 Pack_Id
: out Entity_Id
)
9082 function Inside_Package_Body
(Id
: Entity_Id
) return Boolean;
9083 function Inside_Private_Part
(Id
: Entity_Id
) return Boolean;
9084 -- Return True if Id is declared directly within the package body
9085 -- and the package private parts, respectively. We cannot use
9086 -- In_Private_Part/In_Body_Part flags, as these are only set during the
9087 -- analysis of the package itself, while Find_Placement_In_State_Space
9088 -- can be called on an entity of another package.
9090 ------------------------
9091 -- Inside_Package_Body --
9092 ------------------------
9094 function Inside_Package_Body
(Id
: Entity_Id
) return Boolean is
9095 Spec_Id
: constant Entity_Id
:= Scope
(Id
);
9096 Body_Decl
: constant Opt_N_Package_Body_Id
:= Package_Body
(Spec_Id
);
9097 Decl
: constant Node_Id
:= Enclosing_Declaration
(Id
);
9099 if Present
(Body_Decl
)
9100 and then Is_List_Member
(Decl
)
9101 and then List_Containing
(Decl
) = Declarations
(Body_Decl
)
9107 end Inside_Package_Body
;
9109 -------------------------
9110 -- Inside_Private_Part --
9111 -------------------------
9113 function Inside_Private_Part
(Id
: Entity_Id
) return Boolean is
9114 Spec_Id
: constant Entity_Id
:= Scope
(Id
);
9115 Private_Decls
: constant List_Id
:=
9116 Private_Declarations
(Package_Specification
(Spec_Id
));
9117 Decl
: constant Node_Id
:= Enclosing_Declaration
(Id
);
9119 if Is_List_Member
(Decl
)
9120 and then List_Containing
(Decl
) = Private_Decls
9124 elsif Ekind
(Id
) = E_Package
9125 and then Is_Private_Library_Unit
(Id
)
9132 end Inside_Private_Part
;
9136 Context
: Entity_Id
;
9138 -- Start of processing for Find_Placement_In_State_Space
9141 -- Assume that the item does not appear in the state space of a package
9143 Placement
:= Not_In_Package
;
9145 -- Climb the scope stack and examine the enclosing context
9148 Pack_Id
:= Scope
(Context
);
9149 while Present
(Pack_Id
) and then Pack_Id
/= Standard_Standard
loop
9150 if Is_Package_Or_Generic_Package
(Pack_Id
) then
9152 -- A package body is a cut off point for the traversal as the
9153 -- item cannot be visible to the outside from this point on.
9155 if Inside_Package_Body
(Context
) then
9156 Placement
:= Body_State_Space
;
9159 -- The private part of a package is a cut off point for the
9160 -- traversal as the item cannot be visible to the outside
9161 -- from this point on.
9163 elsif Inside_Private_Part
(Context
) then
9164 Placement
:= Private_State_Space
;
9167 -- When the item appears in the visible state space of a package,
9168 -- continue to climb the scope stack as this may not be the final
9172 Placement
:= Visible_State_Space
;
9174 -- The visible state space of a child unit acts as the proper
9175 -- placement of an item, unless this is a private child unit.
9177 if Is_Child_Unit
(Pack_Id
)
9178 and then not Is_Private_Library_Unit
(Pack_Id
)
9184 -- The item or its enclosing package appear in a construct that has
9188 Placement
:= Not_In_Package
;
9193 Context
:= Scope
(Context
);
9194 Pack_Id
:= Scope
(Context
);
9196 end Find_Placement_In_State_Space
;
9198 -----------------------
9199 -- Find_Primitive_Eq --
9200 -----------------------
9202 function Find_Primitive_Eq
(Typ
: Entity_Id
) return Entity_Id
is
9203 function Find_Eq_Prim
(Prims_List
: Elist_Id
) return Entity_Id
;
9204 -- Search for the equality primitive; return Empty if the primitive is
9211 function Find_Eq_Prim
(Prims_List
: Elist_Id
) return Entity_Id
is
9213 Prim_Elmt
: Elmt_Id
;
9216 Prim_Elmt
:= First_Elmt
(Prims_List
);
9217 while Present
(Prim_Elmt
) loop
9218 Prim
:= Node
(Prim_Elmt
);
9220 -- Locate primitive equality with the right signature
9222 if Chars
(Prim
) = Name_Op_Eq
9223 and then Etype
(First_Formal
(Prim
)) =
9224 Etype
(Next_Formal
(First_Formal
(Prim
)))
9225 and then Base_Type
(Etype
(Prim
)) = Standard_Boolean
9230 Next_Elmt
(Prim_Elmt
);
9238 Eq_Prim
: Entity_Id
;
9239 Full_Type
: Entity_Id
;
9241 -- Start of processing for Find_Primitive_Eq
9244 if Is_Private_Type
(Typ
) then
9245 Full_Type
:= Underlying_Type
(Typ
);
9250 if No
(Full_Type
) then
9254 Full_Type
:= Base_Type
(Full_Type
);
9256 -- When the base type itself is private, use the full view
9258 if Is_Private_Type
(Full_Type
) then
9259 Full_Type
:= Underlying_Type
(Full_Type
);
9262 if Is_Class_Wide_Type
(Full_Type
) then
9263 Full_Type
:= Root_Type
(Full_Type
);
9266 if not Is_Tagged_Type
(Full_Type
) then
9267 Eq_Prim
:= Find_Eq_Prim
(Collect_Primitive_Operations
(Typ
));
9269 -- If this is an untagged private type completed with a derivation of
9270 -- an untagged private type whose full view is a tagged type, we use
9271 -- the primitive operations of the private parent type (since it does
9272 -- not have a full view, and also because its equality primitive may
9273 -- have been overridden in its untagged full view). If no equality was
9274 -- defined for it then take its dispatching equality primitive.
9276 elsif Inherits_From_Tagged_Full_View
(Typ
) then
9277 Eq_Prim
:= Find_Eq_Prim
(Collect_Primitive_Operations
(Typ
));
9279 if No
(Eq_Prim
) then
9280 Eq_Prim
:= Find_Eq_Prim
(Primitive_Operations
(Full_Type
));
9284 Eq_Prim
:= Find_Eq_Prim
(Primitive_Operations
(Full_Type
));
9288 end Find_Primitive_Eq
;
9290 ------------------------
9291 -- Find_Specific_Type --
9292 ------------------------
9294 function Find_Specific_Type
(CW
: Entity_Id
) return Entity_Id
is
9295 Typ
: Entity_Id
:= Root_Type
(CW
);
9298 if Ekind
(Typ
) = E_Incomplete_Type
then
9299 if From_Limited_With
(Typ
) then
9300 Typ
:= Non_Limited_View
(Typ
);
9302 Typ
:= Full_View
(Typ
);
9306 if Is_Private_Type
(Typ
)
9307 and then not Is_Tagged_Type
(Typ
)
9308 and then Present
(Full_View
(Typ
))
9310 return Full_View
(Typ
);
9314 end Find_Specific_Type
;
9316 -----------------------------
9317 -- Find_Static_Alternative --
9318 -----------------------------
9320 function Find_Static_Alternative
(N
: Node_Id
) return Node_Id
is
9321 Expr
: constant Node_Id
:= Expression
(N
);
9322 Val
: constant Uint
:= Expr_Value
(Expr
);
9327 Alt
:= First
(Alternatives
(N
));
9330 if Nkind
(Alt
) /= N_Pragma
then
9331 Choice
:= First
(Discrete_Choices
(Alt
));
9332 while Present
(Choice
) loop
9334 -- Others choice, always matches
9336 if Nkind
(Choice
) = N_Others_Choice
then
9339 -- Range, check if value is in the range
9341 elsif Nkind
(Choice
) = N_Range
then
9343 Val
>= Expr_Value
(Low_Bound
(Choice
))
9345 Val
<= Expr_Value
(High_Bound
(Choice
));
9347 -- Choice is a subtype name. Note that we know it must
9348 -- be a static subtype, since otherwise it would have
9349 -- been diagnosed as illegal.
9351 elsif Is_Entity_Name
(Choice
)
9352 and then Is_Type
(Entity
(Choice
))
9354 exit Search
when Is_In_Range
(Expr
, Etype
(Choice
),
9355 Assume_Valid
=> False);
9357 -- Choice is a subtype indication
9359 elsif Nkind
(Choice
) = N_Subtype_Indication
then
9361 C
: constant Node_Id
:= Constraint
(Choice
);
9362 R
: constant Node_Id
:= Range_Expression
(C
);
9366 Val
>= Expr_Value
(Low_Bound
(R
))
9368 Val
<= Expr_Value
(High_Bound
(R
));
9371 -- Choice is a simple expression
9374 exit Search
when Val
= Expr_Value
(Choice
);
9382 pragma Assert
(Present
(Alt
));
9385 -- The above loop *must* terminate by finding a match, since we know the
9386 -- case statement is valid, and the value of the expression is known at
9387 -- compile time. When we fall out of the loop, Alt points to the
9388 -- alternative that we know will be selected at run time.
9391 end Find_Static_Alternative
;
9397 function First_Actual
(Node
: Node_Id
) return Node_Id
is
9401 if No
(Parameter_Associations
(Node
)) then
9405 N
:= First
(Parameter_Associations
(Node
));
9407 if Nkind
(N
) = N_Parameter_Association
then
9408 return First_Named_Actual
(Node
);
9418 function First_Global
9420 Global_Mode
: Name_Id
;
9421 Refined
: Boolean := False) return Node_Id
9423 function First_From_Global_List
9425 Global_Mode
: Name_Id
:= Name_Input
) return Entity_Id
;
9426 -- Get the first item with suitable mode from List
9428 ----------------------------
9429 -- First_From_Global_List --
9430 ----------------------------
9432 function First_From_Global_List
9434 Global_Mode
: Name_Id
:= Name_Input
) return Entity_Id
9439 -- Empty list (no global items)
9441 if Nkind
(List
) = N_Null
then
9444 -- Single global item declaration (only input items)
9446 elsif Nkind
(List
) in N_Expanded_Name | N_Identifier
then
9447 if Global_Mode
= Name_Input
then
9453 -- Simple global list (only input items) or moded global list
9456 elsif Nkind
(List
) = N_Aggregate
then
9457 if Present
(Expressions
(List
)) then
9458 if Global_Mode
= Name_Input
then
9459 return First
(Expressions
(List
));
9465 Assoc
:= First
(Component_Associations
(List
));
9466 while Present
(Assoc
) loop
9468 -- When we find the desired mode in an association, call
9469 -- recursively First_From_Global_List as if the mode was
9470 -- Name_Input, in order to reuse the existing machinery
9471 -- for the other cases.
9473 if Chars
(First
(Choices
(Assoc
))) = Global_Mode
then
9474 return First_From_Global_List
(Expression
(Assoc
));
9483 -- To accommodate partial decoration of disabled SPARK features,
9484 -- this routine may be called with illegal input. If this is the
9485 -- case, do not raise Program_Error.
9490 end First_From_Global_List
;
9494 Global
: Node_Id
:= Empty
;
9495 Body_Id
: Entity_Id
;
9497 -- Start of processing for First_Global
9500 pragma Assert
(Global_Mode
in Name_In_Out
9505 -- Retrieve the suitable pragma Global or Refined_Global. In the second
9506 -- case, it can only be located on the body entity.
9509 if Is_Subprogram_Or_Generic_Subprogram
(Subp
) then
9510 Body_Id
:= Subprogram_Body_Entity
(Subp
);
9512 elsif Is_Entry
(Subp
) or else Is_Task_Type
(Subp
) then
9513 Body_Id
:= Corresponding_Body
(Parent
(Subp
));
9515 -- ??? It should be possible to retrieve the Refined_Global on the
9516 -- task body associated to the task object. This is not yet possible.
9518 elsif Is_Single_Task_Object
(Subp
) then
9525 if Present
(Body_Id
) then
9526 Global
:= Get_Pragma
(Body_Id
, Pragma_Refined_Global
);
9529 Global
:= Get_Pragma
(Subp
, Pragma_Global
);
9532 -- No corresponding global if pragma is not present
9537 -- Otherwise retrieve the corresponding list of items depending on the
9541 return First_From_Global_List
9542 (Expression
(Get_Argument
(Global
, Subp
)), Global_Mode
);
9550 function Fix_Msg
(Id
: Entity_Id
; Msg
: String) return String is
9551 Is_Task
: constant Boolean :=
9552 Ekind
(Id
) in E_Task_Body | E_Task_Type
9553 or else Is_Single_Task_Object
(Id
);
9554 Msg_Last
: constant Natural := Msg
'Last;
9555 Msg_Index
: Natural;
9556 Res
: String (Msg
'Range) := (others => ' ');
9557 Res_Index
: Natural;
9560 -- Copy all characters from the input message Msg to result Res with
9561 -- suitable replacements.
9563 Msg_Index
:= Msg
'First;
9564 Res_Index
:= Res
'First;
9565 while Msg_Index
<= Msg_Last
loop
9567 -- Replace "subprogram" with a different word
9569 if Msg_Index
<= Msg_Last
- 10
9570 and then Msg
(Msg_Index
.. Msg_Index
+ 9) = "subprogram"
9572 if Is_Entry
(Id
) then
9573 Res
(Res_Index
.. Res_Index
+ 4) := "entry";
9574 Res_Index
:= Res_Index
+ 5;
9577 Res
(Res_Index
.. Res_Index
+ 8) := "task type";
9578 Res_Index
:= Res_Index
+ 9;
9581 Res
(Res_Index
.. Res_Index
+ 9) := "subprogram";
9582 Res_Index
:= Res_Index
+ 10;
9585 Msg_Index
:= Msg_Index
+ 10;
9587 -- Replace "protected" with a different word
9589 elsif Msg_Index
<= Msg_Last
- 9
9590 and then Msg
(Msg_Index
.. Msg_Index
+ 8) = "protected"
9593 Res
(Res_Index
.. Res_Index
+ 3) := "task";
9594 Res_Index
:= Res_Index
+ 4;
9595 Msg_Index
:= Msg_Index
+ 9;
9597 -- Otherwise copy the character
9600 Res
(Res_Index
) := Msg
(Msg_Index
);
9601 Msg_Index
:= Msg_Index
+ 1;
9602 Res_Index
:= Res_Index
+ 1;
9606 return Res
(Res
'First .. Res_Index
- 1);
9609 -------------------------
9610 -- From_Nested_Package --
9611 -------------------------
9613 function From_Nested_Package
(T
: Entity_Id
) return Boolean is
9614 Pack
: constant Entity_Id
:= Scope
(T
);
9618 Ekind
(Pack
) = E_Package
9619 and then not Is_Frozen
(Pack
)
9620 and then not Scope_Within_Or_Same
(Current_Scope
, Pack
)
9621 and then In_Open_Scopes
(Scope
(Pack
));
9622 end From_Nested_Package
;
9624 -----------------------
9625 -- Gather_Components --
9626 -----------------------
9628 procedure Gather_Components
9630 Comp_List
: Node_Id
;
9631 Governed_By
: List_Id
;
9633 Report_Errors
: out Boolean;
9634 Allow_Compile_Time
: Boolean := False;
9635 Include_Interface_Tag
: Boolean := False)
9639 Discrete_Choice
: Node_Id
;
9640 Comp_Item
: Node_Id
;
9641 Discrim
: Entity_Id
;
9642 Discrim_Name
: Node_Id
;
9644 type Discriminant_Value_Status
is
9645 (Static_Expr
, Static_Subtype
, Bad
);
9646 subtype Good_Discrim_Value_Status
is Discriminant_Value_Status
9647 range Static_Expr
.. Static_Subtype
; -- range excludes Bad
9649 Discrim_Value
: Node_Id
;
9650 Discrim_Value_Subtype
: Node_Id
;
9651 Discrim_Value_Status
: Discriminant_Value_Status
:= Bad
;
9653 function OK_Scope_For_Discrim_Value_Error_Messages
return Boolean is
9654 (Scope
(Original_Record_Component
9655 (Entity
(First
(Choices
(Assoc
))))) = Typ
);
9656 -- Used to avoid generating error messages having a source position
9657 -- which refers to somewhere (e.g., a discriminant value in a derived
9658 -- tagged type declaration) unrelated to the offending construct. This
9659 -- is required for correctness - clients of Gather_Components such as
9660 -- Sem_Ch3.Create_Constrained_Components depend on this function
9661 -- returning True while processing semantically correct examples;
9662 -- generating an error message in this case would be wrong.
9665 Report_Errors
:= False;
9667 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
9670 elsif Present
(Component_Items
(Comp_List
)) then
9671 Comp_Item
:= First
(Component_Items
(Comp_List
));
9677 while Present
(Comp_Item
) loop
9679 -- Skip the tag of a tagged record, as well as all items that are not
9680 -- user components (anonymous types, rep clauses, Parent field,
9681 -- controller field).
9683 if Nkind
(Comp_Item
) = N_Component_Declaration
then
9685 Comp
: constant Entity_Id
:= Defining_Identifier
(Comp_Item
);
9687 if not (Is_Tag
(Comp
)
9689 (Include_Interface_Tag
9690 and then Etype
(Comp
) = RTE
(RE_Interface_Tag
)))
9691 and then Chars
(Comp
) /= Name_uParent
9693 Append_Elmt
(Comp
, Into
);
9701 if No
(Variant_Part
(Comp_List
)) then
9704 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
9705 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
9708 -- Look for the discriminant that governs this variant part.
9709 -- The discriminant *must* be in the Governed_By List
9711 Assoc
:= First
(Governed_By
);
9712 Find_Constraint
: loop
9713 Discrim
:= First
(Choices
(Assoc
));
9714 exit Find_Constraint
when
9715 Chars
(Discrim_Name
) = Chars
(Discrim
)
9717 (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
9718 and then Chars
(Corresponding_Discriminant
9719 (Entity
(Discrim
))) = Chars
(Discrim_Name
))
9721 Chars
(Original_Record_Component
(Entity
(Discrim
))) =
9722 Chars
(Discrim_Name
);
9724 if No
(Next
(Assoc
)) then
9725 if not Is_Constrained
(Typ
) and then Is_Derived_Type
(Typ
) then
9727 -- If the type is a tagged type with inherited discriminants,
9728 -- use the stored constraint on the parent in order to find
9729 -- the values of discriminants that are otherwise hidden by an
9730 -- explicit constraint. Renamed discriminants are handled in
9733 -- If several parent discriminants are renamed by a single
9734 -- discriminant of the derived type, the call to obtain the
9735 -- Corresponding_Discriminant field only retrieves the last
9736 -- of them. We recover the constraint on the others from the
9737 -- Stored_Constraint as well.
9739 -- An inherited discriminant may have been constrained in a
9740 -- later ancestor (not the immediate parent) so we must examine
9741 -- the stored constraint of all of them to locate the inherited
9747 T
: Entity_Id
:= Typ
;
9750 while Is_Derived_Type
(T
) loop
9751 if Present
(Stored_Constraint
(T
)) then
9752 D
:= First_Discriminant
(Etype
(T
));
9753 C
:= First_Elmt
(Stored_Constraint
(T
));
9754 while Present
(D
) and then Present
(C
) loop
9755 if Chars
(Discrim_Name
) = Chars
(D
) then
9756 if Is_Entity_Name
(Node
(C
))
9757 and then Entity
(Node
(C
)) = Entity
(Discrim
)
9759 -- D is renamed by Discrim, whose value is
9766 Make_Component_Association
(Sloc
(Typ
),
9768 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
9769 Duplicate_Subexpr_No_Checks
(Node
(C
)));
9772 exit Find_Constraint
;
9775 Next_Discriminant
(D
);
9780 -- Discriminant may be inherited from ancestor
9788 if No
(Next
(Assoc
)) then
9790 (" missing value for discriminant&",
9791 First
(Governed_By
), Discrim_Name
);
9793 Report_Errors
:= True;
9798 end loop Find_Constraint
;
9800 Discrim_Value
:= Expression
(Assoc
);
9802 if Is_OK_Static_Expression
(Discrim_Value
)
9803 or else (Allow_Compile_Time
9804 and then Compile_Time_Known_Value
(Discrim_Value
))
9806 Discrim_Value_Status
:= Static_Expr
;
9808 if Ada_Version
>= Ada_2022
then
9809 if Is_Rewrite_Substitution
(Discrim_Value
)
9810 and then Nkind
(Discrim_Value
) = N_Type_Conversion
9811 and then Etype
(Original_Node
(Discrim_Value
))
9812 = Etype
(Expression
(Discrim_Value
))
9814 Discrim_Value_Subtype
:= Etype
(Original_Node
(Discrim_Value
));
9815 -- An unhelpful (for this code) type conversion may be
9816 -- introduced in some cases; deal with it.
9818 Discrim_Value_Subtype
:= Etype
(Discrim_Value
);
9821 if Is_OK_Static_Subtype
(Discrim_Value_Subtype
) and then
9822 not Is_Null_Range
(Type_Low_Bound
(Discrim_Value_Subtype
),
9823 Type_High_Bound
(Discrim_Value_Subtype
))
9825 -- Is_Null_Range test doesn't account for predicates, as in
9826 -- subtype Null_By_Predicate is Natural
9827 -- with Static_Predicate => Null_By_Predicate < 0;
9828 -- so test for that null case separately.
9830 if (not Has_Static_Predicate
(Discrim_Value_Subtype
))
9831 or else Present
(First
(Static_Discrete_Predicate
9832 (Discrim_Value_Subtype
)))
9834 Discrim_Value_Status
:= Static_Subtype
;
9839 if Discrim_Value_Status
= Bad
then
9841 -- If the variant part is governed by a discriminant of the type
9842 -- this is an error. If the variant part and the discriminant are
9843 -- inherited from an ancestor this is legal (AI05-220) unless the
9844 -- components are being gathered for an aggregate, in which case
9845 -- the caller must check Report_Errors.
9847 -- In Ada 2022 the above rules are relaxed. A nonstatic governing
9848 -- discriminant is OK as long as it has a static subtype and
9849 -- every value of that subtype (and there must be at least one)
9850 -- selects the same variant.
9852 if OK_Scope_For_Discrim_Value_Error_Messages
then
9853 if Ada_Version
>= Ada_2022
then
9855 ("value for discriminant & must be static or " &
9856 "discriminant's nominal subtype must be static " &
9858 Discrim_Value
, Discrim
);
9861 ("value for discriminant & must be static!",
9862 Discrim_Value
, Discrim
);
9864 Why_Not_Static
(Discrim_Value
);
9867 Report_Errors
:= True;
9872 Search_For_Discriminant_Value
: declare
9878 UI_Discrim_Value
: Uint
;
9881 case Good_Discrim_Value_Status
'(Discrim_Value_Status) is
9883 UI_Discrim_Value := Expr_Value (Discrim_Value);
9884 when Static_Subtype =>
9885 -- Arbitrarily pick one value of the subtype and look
9886 -- for the variant associated with that value; we will
9887 -- check later that the same variant is associated with
9888 -- all of the other values of the subtype.
9889 if Has_Static_Predicate (Discrim_Value_Subtype) then
9891 Range_Or_Expr : constant Node_Id :=
9892 First (Static_Discrete_Predicate
9893 (Discrim_Value_Subtype));
9895 if Nkind (Range_Or_Expr) = N_Range then
9897 Expr_Value (Low_Bound (Range_Or_Expr));
9899 UI_Discrim_Value := Expr_Value (Range_Or_Expr);
9904 := Expr_Value (Type_Low_Bound (Discrim_Value_Subtype));
9908 Find_Discrete_Value : while Present (Variant) loop
9910 -- If a choice is a subtype with a static predicate, it must
9911 -- be rewritten as an explicit list of non-predicated choices.
9913 Expand_Static_Predicates_In_Choices (Variant);
9915 Discrete_Choice := First (Discrete_Choices (Variant));
9916 while Present (Discrete_Choice) loop
9917 exit Find_Discrete_Value when
9918 Nkind (Discrete_Choice) = N_Others_Choice;
9920 Get_Index_Bounds (Discrete_Choice, Low, High);
9922 UI_Low := Expr_Value (Low);
9923 UI_High := Expr_Value (High);
9925 exit Find_Discrete_Value when
9926 UI_Low <= UI_Discrim_Value
9928 UI_High >= UI_Discrim_Value;
9930 Next (Discrete_Choice);
9933 Next_Non_Pragma (Variant);
9934 end loop Find_Discrete_Value;
9935 end Search_For_Discriminant_Value;
9937 -- The case statement must include a variant that corresponds to the
9938 -- value of the discriminant, unless the discriminant type has a
9939 -- static predicate. In that case the absence of an others_choice that
9940 -- would cover this value becomes a run-time error (3.8.1 (21.1/2)).
9943 and then not Has_Static_Predicate (Etype (Discrim_Name))
9946 ("value of discriminant & is out of range", Discrim_Value, Discrim);
9947 Report_Errors := True;
9951 -- If we have found the corresponding choice, recursively add its
9952 -- components to the Into list. The nested components are part of
9953 -- the same record type.
9955 if Present (Variant) then
9956 if Discrim_Value_Status = Static_Subtype then
9958 Discrim_Value_Subtype_Intervals
9959 : constant Interval_Lists.Discrete_Interval_List
9960 := Interval_Lists.Type_Intervals (Discrim_Value_Subtype);
9963 : constant Interval_Lists.Discrete_Interval_List
9964 := Interval_Lists.Choice_List_Intervals
9965 (Discrete_Choices => Discrete_Choices (Variant));
9967 if not Interval_Lists.Is_Subset
9968 (Subset => Discrim_Value_Subtype_Intervals,
9969 Of_Set => Variant_Intervals)
9971 if OK_Scope_For_Discrim_Value_Error_Messages then
9973 ("no single variant is associated with all values of " &
9974 "the subtype of discriminant value &",
9975 Discrim_Value, Discrim);
9977 Report_Errors := True;
9984 (Typ, Component_List (Variant), Governed_By, Into,
9985 Report_Errors, Allow_Compile_Time);
9987 end Gather_Components;
9989 ------------------------
9990 -- Get_Actual_Subtype --
9991 ------------------------
9993 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
9994 Typ : constant Entity_Id := Etype (N);
9995 Utyp : Entity_Id := Underlying_Type (Typ);
10004 -- If what we have is an identifier that references a subprogram
10005 -- formal, or a variable or constant object, then we get the actual
10006 -- subtype from the referenced entity if one has been built.
10008 if Nkind (N) = N_Identifier
10010 (Is_Formal (Entity (N))
10011 or else Ekind (Entity (N)) = E_Constant
10012 or else Ekind (Entity (N)) = E_Variable)
10013 and then Present (Actual_Subtype (Entity (N)))
10015 return Actual_Subtype (Entity (N));
10017 -- Actual subtype of unchecked union is always itself. We never need
10018 -- the "real" actual subtype. If we did, we couldn't get it anyway
10019 -- because the discriminant is not available. The restrictions on
10020 -- Unchecked_Union are designed to make sure that this is OK.
10022 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
10025 -- Here for the unconstrained case, we must find actual subtype
10026 -- No actual subtype is available, so we must build it on the fly.
10028 -- Checking the type, not the underlying type, for constrainedness
10029 -- seems to be necessary. Maybe all the tests should be on the type???
10031 elsif (not Is_Constrained (Typ))
10032 and then (Is_Array_Type (Utyp)
10033 or else (Is_Record_Type (Utyp)
10034 and then Has_Discriminants (Utyp)))
10035 and then not Has_Unknown_Discriminants (Utyp)
10036 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
10038 -- Nothing to do if in spec expression (why not???)
10040 if In_Spec_Expression then
10043 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then
10045 -- If the type has no discriminants, there is no subtype to
10046 -- build, even if the underlying type is discriminated.
10050 -- Else build the actual subtype
10053 Decl := Build_Actual_Subtype (Typ, N);
10055 -- The call may yield a declaration, or just return the entity
10061 Atyp := Defining_Identifier (Decl);
10063 -- If Build_Actual_Subtype generated a new declaration then use it
10065 if Atyp /= Typ then
10067 -- The actual subtype is an Itype, so analyze the declaration,
10068 -- but do not attach it to the tree, to get the type defined.
10070 Set_Parent (Decl, N);
10071 Set_Is_Itype (Atyp);
10072 Analyze (Decl, Suppress => All_Checks);
10073 Set_Associated_Node_For_Itype (Atyp, N);
10074 if Expander_Active then
10075 Set_Has_Delayed_Freeze (Atyp, False);
10077 -- We need to freeze the actual subtype immediately. This is
10078 -- needed because otherwise this Itype will not get frozen
10079 -- at all; it is always safe to freeze on creation because
10080 -- any associated types must be frozen at this point.
10082 -- On the other hand, if we are performing preanalysis on
10083 -- a conjured-up copy of a name (see calls to
10084 -- Preanalyze_Range in sem_ch5.adb) then we don't want
10085 -- to freeze Atyp, now or ever. In this case, the tree
10086 -- we eventually pass to the back end should contain no
10087 -- references to Atyp (and a freeze node would contain
10088 -- such a reference). That's why Expander_Active is tested.
10090 Freeze_Itype (Atyp, N);
10094 -- Otherwise we did not build a declaration, so return original
10101 -- For all remaining cases, the actual subtype is the same as
10102 -- the nominal type.
10107 end Get_Actual_Subtype;
10109 -------------------------------------
10110 -- Get_Actual_Subtype_If_Available --
10111 -------------------------------------
10113 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
10114 Typ : constant Entity_Id := Etype (N);
10117 -- If what we have is an identifier that references a subprogram
10118 -- formal, or a variable or constant object, then we get the actual
10119 -- subtype from the referenced entity if one has been built.
10121 if Nkind (N) = N_Identifier
10123 (Is_Formal (Entity (N))
10124 or else Ekind (Entity (N)) = E_Constant
10125 or else Ekind (Entity (N)) = E_Variable)
10126 and then Present (Actual_Subtype (Entity (N)))
10128 return Actual_Subtype (Entity (N));
10130 -- Otherwise the Etype of N is returned unchanged
10135 end Get_Actual_Subtype_If_Available;
10137 ------------------------
10138 -- Get_Body_From_Stub --
10139 ------------------------
10141 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
10143 return Proper_Body (Unit (Library_Unit (N)));
10144 end Get_Body_From_Stub;
10146 ---------------------
10147 -- Get_Cursor_Type --
10148 ---------------------
10150 function Get_Cursor_Type
10152 Typ : Entity_Id) return Entity_Id
10156 First_Op : Entity_Id;
10157 Cursor : Entity_Id;
10160 -- If error already detected, return
10162 if Error_Posted (Aspect) then
10166 -- The cursor type for an Iterable aspect is the return type of a
10167 -- non-overloaded First primitive operation. Locate association for
10170 Assoc := First (Component_Associations (Expression (Aspect)));
10171 First_Op := Any_Id;
10172 while Present (Assoc) loop
10173 if Chars (First (Choices (Assoc))) = Name_First then
10174 First_Op := Expression (Assoc);
10181 if First_Op = Any_Id then
10182 Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
10185 elsif not Analyzed (First_Op) then
10186 Analyze (First_Op);
10189 Cursor := Any_Type;
10191 -- Locate function with desired name and profile in scope of type
10192 -- In the rare case where the type is an integer type, a base type
10193 -- is created for it, check that the base type of the first formal
10194 -- of First matches the base type of the domain.
10196 Func := First_Entity (Scope (Typ));
10197 while Present (Func) loop
10198 if Chars (Func) = Chars (First_Op)
10199 and then Ekind (Func) = E_Function
10200 and then Present (First_Formal (Func))
10201 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ)
10202 and then No (Next_Formal (First_Formal (Func)))
10204 if Cursor /= Any_Type then
10206 ("operation First for iterable type must be unique", Aspect);
10209 Cursor := Etype (Func);
10213 Next_Entity (Func);
10216 -- If not found, no way to resolve remaining primitives
10218 if Cursor = Any_Type then
10220 ("primitive operation for Iterable type must appear in the same "
10221 & "list of declarations as the type", Aspect);
10225 end Get_Cursor_Type;
10227 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is
10229 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First));
10230 end Get_Cursor_Type;
10232 -------------------------------
10233 -- Get_Default_External_Name --
10234 -------------------------------
10236 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
10238 Get_Decoded_Name_String (Chars (E));
10240 if Opt.External_Name_Imp_Casing = Uppercase then
10241 Set_Casing (All_Upper_Case);
10243 Set_Casing (All_Lower_Case);
10247 Make_String_Literal (Sloc (E),
10248 Strval => String_From_Name_Buffer);
10249 end Get_Default_External_Name;
10251 --------------------------
10252 -- Get_Enclosing_Object --
10253 --------------------------
10255 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
10257 if Is_Entity_Name (N) then
10261 when N_Indexed_Component
10262 | N_Selected_Component
10265 -- If not generating code, a dereference may be left implicit.
10266 -- In thoses cases, return Empty.
10268 if Is_Access_Type (Etype (Prefix (N))) then
10271 return Get_Enclosing_Object (Prefix (N));
10274 when N_Type_Conversion =>
10275 return Get_Enclosing_Object (Expression (N));
10281 end Get_Enclosing_Object;
10283 -------------------------------
10284 -- Get_Enclosing_Deep_Object --
10285 -------------------------------
10287 function Get_Enclosing_Deep_Object (N : Node_Id) return Entity_Id is
10289 if Is_Entity_Name (N) then
10293 when N_Explicit_Dereference
10294 | N_Indexed_Component
10295 | N_Selected_Component
10298 return Get_Enclosing_Deep_Object (Prefix (N));
10300 when N_Type_Conversion =>
10301 return Get_Enclosing_Deep_Object (Expression (N));
10307 end Get_Enclosing_Deep_Object;
10309 ---------------------------
10310 -- Get_Enum_Lit_From_Pos --
10311 ---------------------------
10313 function Get_Enum_Lit_From_Pos
10316 Loc : Source_Ptr) return Node_Id
10318 Btyp : Entity_Id := Base_Type (T);
10323 -- In the case where the literal is of type Character, Wide_Character
10324 -- or Wide_Wide_Character or of a type derived from them, there needs
10325 -- to be some special handling since there is no explicit chain of
10326 -- literals to search. Instead, an N_Character_Literal node is created
10327 -- with the appropriate Char_Code and Chars fields.
10329 if Is_Standard_Character_Type (T) then
10330 Set_Character_Literal_Name (UI_To_CC (Pos));
10333 Make_Character_Literal (Loc,
10334 Chars => Name_Find,
10335 Char_Literal_Value => Pos);
10337 -- For all other cases, we have a complete table of literals, and
10338 -- we simply iterate through the chain of literal until the one
10339 -- with the desired position value is found.
10342 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
10343 Btyp := Full_View (Btyp);
10346 Lit := First_Literal (Btyp);
10348 -- Position in the enumeration type starts at 0
10351 raise Constraint_Error;
10354 for J in 1 .. UI_To_Int (Pos) loop
10355 Next_Literal (Lit);
10357 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error
10358 -- inside the loop to avoid calling Next_Literal on Empty.
10361 raise Constraint_Error;
10365 -- Create a new node from Lit, with source location provided by Loc
10366 -- if not equal to No_Location, or by copying the source location of
10371 if LLoc = No_Location then
10372 LLoc := Sloc (Lit);
10375 return New_Occurrence_Of (Lit, LLoc);
10377 end Get_Enum_Lit_From_Pos;
10379 ----------------------
10380 -- Get_Fullest_View --
10381 ----------------------
10383 function Get_Fullest_View
10385 Include_PAT : Boolean := True;
10386 Recurse : Boolean := True) return Entity_Id
10388 New_E : Entity_Id := Empty;
10391 -- Prevent cascaded errors
10397 -- Look at each kind of entity to see where we may need to go deeper.
10400 when Incomplete_Kind =>
10401 if From_Limited_With (E) then
10402 New_E := Non_Limited_View (E);
10403 elsif Present (Full_View (E)) then
10404 New_E := Full_View (E);
10405 elsif Ekind (E) = E_Incomplete_Subtype then
10406 New_E := Etype (E);
10409 when Private_Kind =>
10410 if Present (Underlying_Full_View (E)) then
10411 New_E := Underlying_Full_View (E);
10412 elsif Present (Full_View (E)) then
10413 New_E := Full_View (E);
10414 elsif Etype (E) /= E then
10415 New_E := Etype (E);
10419 if Include_PAT and then Present (Packed_Array_Impl_Type (E)) then
10420 New_E := Packed_Array_Impl_Type (E);
10423 when E_Record_Subtype =>
10424 if Present (Cloned_Subtype (E)) then
10425 New_E := Cloned_Subtype (E);
10428 when E_Class_Wide_Type =>
10429 New_E := Root_Type (E);
10431 when E_Class_Wide_Subtype =>
10432 if Present (Equivalent_Type (E)) then
10433 New_E := Equivalent_Type (E);
10434 elsif Present (Cloned_Subtype (E)) then
10435 New_E := Cloned_Subtype (E);
10438 when E_Protected_Subtype
10443 if Present (Corresponding_Record_Type (E)) then
10444 New_E := Corresponding_Record_Type (E);
10447 when E_Access_Protected_Subprogram_Type
10448 | E_Anonymous_Access_Protected_Subprogram_Type
10450 if Present (Equivalent_Type (E)) then
10451 New_E := Equivalent_Type (E);
10454 when E_Access_Subtype =>
10455 New_E := Base_Type (E);
10461 -- If we found a fuller view, either return it or recurse. Otherwise,
10462 -- return our input.
10464 return (if No (New_E) then E
10465 elsif Recurse then Get_Fullest_View (New_E, Include_PAT, Recurse)
10467 end Get_Fullest_View;
10469 ------------------------
10470 -- Get_Generic_Entity --
10471 ------------------------
10473 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
10474 Ent : constant Entity_Id := Entity (Name (N));
10476 if Present (Renamed_Entity (Ent)) then
10477 return Renamed_Entity (Ent);
10481 end Get_Generic_Entity;
10483 -------------------------------------
10484 -- Get_Incomplete_View_Of_Ancestor --
10485 -------------------------------------
10487 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
10488 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
10489 Par_Scope : Entity_Id;
10490 Par_Type : Entity_Id;
10493 -- The incomplete view of an ancestor is only relevant for private
10494 -- derived types in child units.
10496 if not Is_Derived_Type (E)
10497 or else not Is_Child_Unit (Cur_Unit)
10502 Par_Scope := Scope (Cur_Unit);
10503 if No (Par_Scope) then
10507 Par_Type := Etype (Base_Type (E));
10509 -- Traverse list of ancestor types until we find one declared in
10510 -- a parent or grandparent unit (two levels seem sufficient).
10512 while Present (Par_Type) loop
10513 if Scope (Par_Type) = Par_Scope
10514 or else Scope (Par_Type) = Scope (Par_Scope)
10518 elsif not Is_Derived_Type (Par_Type) then
10522 Par_Type := Etype (Base_Type (Par_Type));
10526 -- If none found, there is no relevant ancestor type.
10530 end Get_Incomplete_View_Of_Ancestor;
10532 ----------------------
10533 -- Get_Index_Bounds --
10534 ----------------------
10536 procedure Get_Index_Bounds
10540 Use_Full_View : Boolean := False)
10542 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id;
10543 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and
10544 -- Typ qualifies, the scalar range is obtained from the full view of the
10547 --------------------------
10548 -- Scalar_Range_Of_Type --
10549 --------------------------
10551 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is
10552 T : Entity_Id := Typ;
10555 if Use_Full_View and then Present (Full_View (T)) then
10556 T := Full_View (T);
10559 return Scalar_Range (T);
10560 end Scalar_Range_Of_Type;
10564 Kind : constant Node_Kind := Nkind (N);
10567 -- Start of processing for Get_Index_Bounds
10570 if Kind = N_Range then
10571 L := Low_Bound (N);
10572 H := High_Bound (N);
10574 elsif Kind = N_Subtype_Indication then
10575 Rng := Range_Expression (Constraint (N));
10577 if Rng = Error then
10583 L := Low_Bound (Range_Expression (Constraint (N)));
10584 H := High_Bound (Range_Expression (Constraint (N)));
10587 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
10588 Rng := Scalar_Range_Of_Type (Entity (N));
10590 if Error_Posted (Rng) then
10594 elsif Nkind (Rng) = N_Subtype_Indication then
10595 Get_Index_Bounds (Rng, L, H);
10598 L := Low_Bound (Rng);
10599 H := High_Bound (Rng);
10603 -- N is an expression, indicating a range with one value
10608 end Get_Index_Bounds;
10610 function Get_Index_Bounds
10612 Use_Full_View : Boolean := False) return Range_Nodes is
10613 Result : Range_Nodes;
10615 Get_Index_Bounds (N, Result.First, Result.Last, Use_Full_View);
10617 end Get_Index_Bounds;
10619 function Get_Index_Bounds
10621 Use_Full_View : Boolean := False) return Range_Values is
10622 Nodes : constant Range_Nodes := Get_Index_Bounds (N, Use_Full_View);
10624 return (Expr_Value (Nodes.First), Expr_Value (Nodes.Last));
10625 end Get_Index_Bounds;
10627 -----------------------------
10628 -- Get_Interfacing_Aspects --
10629 -----------------------------
10631 procedure Get_Interfacing_Aspects
10632 (Iface_Asp : Node_Id;
10633 Conv_Asp : out Node_Id;
10634 EN_Asp : out Node_Id;
10635 Expo_Asp : out Node_Id;
10636 Imp_Asp : out Node_Id;
10637 LN_Asp : out Node_Id;
10638 Do_Checks : Boolean := False)
10640 procedure Save_Or_Duplication_Error
10642 To : in out Node_Id);
10643 -- Save the value of aspect Asp in node To. If To already has a value,
10644 -- then this is considered a duplicate use of aspect. Emit an error if
10645 -- flag Do_Checks is set.
10647 -------------------------------
10648 -- Save_Or_Duplication_Error --
10649 -------------------------------
10651 procedure Save_Or_Duplication_Error
10653 To : in out Node_Id)
10656 -- Detect an extra aspect and issue an error
10658 if Present (To) then
10660 Error_Msg_Name_1 := Chars (Identifier (Asp));
10661 Error_Msg_Sloc := Sloc (To);
10662 Error_Msg_N ("aspect % previously given #", Asp);
10665 -- Otherwise capture the aspect
10670 end Save_Or_Duplication_Error;
10675 Asp_Id : Aspect_Id;
10677 -- The following variables capture each individual aspect
10679 Conv : Node_Id := Empty;
10680 EN : Node_Id := Empty;
10681 Expo : Node_Id := Empty;
10682 Imp : Node_Id := Empty;
10683 LN : Node_Id := Empty;
10685 -- Start of processing for Get_Interfacing_Aspects
10688 -- The input interfacing aspect should reside in an aspect specification
10691 pragma Assert (Is_List_Member (Iface_Asp));
10693 -- Examine the aspect specifications of the related entity. Find and
10694 -- capture all interfacing aspects. Detect duplicates and emit errors
10697 Asp := First (List_Containing (Iface_Asp));
10698 while Present (Asp) loop
10699 Asp_Id := Get_Aspect_Id (Asp);
10701 if Asp_Id = Aspect_Convention then
10702 Save_Or_Duplication_Error (Asp, Conv);
10704 elsif Asp_Id = Aspect_External_Name then
10705 Save_Or_Duplication_Error (Asp, EN);
10707 elsif Asp_Id = Aspect_Export then
10708 Save_Or_Duplication_Error (Asp, Expo);
10710 elsif Asp_Id = Aspect_Import then
10711 Save_Or_Duplication_Error (Asp, Imp);
10713 elsif Asp_Id = Aspect_Link_Name then
10714 Save_Or_Duplication_Error (Asp, LN);
10725 end Get_Interfacing_Aspects;
10727 ---------------------------------
10728 -- Get_Iterable_Type_Primitive --
10729 ---------------------------------
10731 function Get_Iterable_Type_Primitive
10733 Nam : Name_Id) return Entity_Id
10738 Nam in Name_Element
10745 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
10753 Assoc := First (Component_Associations (Funcs));
10754 while Present (Assoc) loop
10755 if Chars (First (Choices (Assoc))) = Nam then
10756 return Entity (Expression (Assoc));
10764 end Get_Iterable_Type_Primitive;
10766 ---------------------------
10767 -- Get_Library_Unit_Name --
10768 ---------------------------
10770 function Get_Library_Unit_Name (Decl_Node : Node_Id) return String_Id is
10771 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
10772 Buf : Bounded_String;
10774 Get_Unit_Name_String (Buf, Unit_Name_Id);
10776 -- Remove the last seven characters (" (spec)" or " (body)")
10778 Buf.Length := Buf.Length - 7;
10779 pragma Assert (Buf.Chars (Buf.Length + 1) = ' ');
10781 return String_From_Name_Buffer (Buf);
10782 end Get_Library_Unit_Name;
10784 --------------------------
10785 -- Get_Max_Queue_Length --
10786 --------------------------
10788 function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
10789 pragma Assert (Is_Entry (Id));
10790 Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
10794 -- A value of 0 or -1 represents no maximum specified, and entries and
10795 -- entry families with no Max_Queue_Length aspect or pragma default to
10803 (Expression (First (Pragma_Argument_Associations (Prag))));
10805 -- Since -1 and 0 are equivalent, return 0 for instances of -1 for
10813 end Get_Max_Queue_Length;
10815 ------------------------
10816 -- Get_Name_Entity_Id --
10817 ------------------------
10819 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
10821 return Entity_Id (Get_Name_Table_Int (Id));
10822 end Get_Name_Entity_Id;
10824 ------------------------------
10825 -- Get_Name_From_CTC_Pragma --
10826 ------------------------------
10828 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
10829 Arg : constant Node_Id :=
10830 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
10832 return Strval (Expr_Value_S (Arg));
10833 end Get_Name_From_CTC_Pragma;
10835 -----------------------
10836 -- Get_Parent_Entity --
10837 -----------------------
10839 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
10841 if Nkind (Unit) = N_Package_Body
10842 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
10844 return Defining_Entity
10845 (Specification (Instance_Spec (Original_Node (Unit))));
10846 elsif Nkind (Unit) = N_Package_Instantiation then
10847 return Defining_Entity (Specification (Instance_Spec (Unit)));
10849 return Defining_Entity (Unit);
10851 end Get_Parent_Entity;
10853 -------------------
10854 -- Get_Pragma_Id --
10855 -------------------
10857 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
10859 return Get_Pragma_Id (Pragma_Name_Unmapped (N));
10862 ------------------------
10863 -- Get_Qualified_Name --
10864 ------------------------
10866 function Get_Qualified_Name
10868 Suffix : Entity_Id := Empty) return Name_Id
10870 Suffix_Nam : Name_Id := No_Name;
10873 if Present (Suffix) then
10874 Suffix_Nam := Chars (Suffix);
10877 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id));
10878 end Get_Qualified_Name;
10880 function Get_Qualified_Name
10882 Suffix : Name_Id := No_Name;
10883 Scop : Entity_Id := Current_Scope) return Name_Id
10885 procedure Add_Scope (S : Entity_Id);
10886 -- Add the fully qualified form of scope S to the name buffer. The
10894 procedure Add_Scope (S : Entity_Id) is
10899 elsif S = Standard_Standard then
10903 Add_Scope (Scope (S));
10904 Get_Name_String_And_Append (Chars (S));
10905 Add_Str_To_Name_Buffer ("__");
10909 -- Start of processing for Get_Qualified_Name
10915 -- Append the base name after all scopes have been chained
10917 Get_Name_String_And_Append (Nam);
10919 -- Append the suffix (if present)
10921 if Suffix /= No_Name then
10922 Add_Str_To_Name_Buffer ("__");
10923 Get_Name_String_And_Append (Suffix);
10927 end Get_Qualified_Name;
10929 -----------------------
10930 -- Get_Reason_String --
10931 -----------------------
10933 procedure Get_Reason_String (N : Node_Id) is
10935 if Nkind (N) = N_String_Literal then
10936 Store_String_Chars (Strval (N));
10938 elsif Nkind (N) = N_Op_Concat then
10939 Get_Reason_String (Left_Opnd (N));
10940 Get_Reason_String (Right_Opnd (N));
10942 -- If not of required form, error
10946 ("Reason for pragma Warnings has wrong form", N);
10948 ("\must be string literal or concatenation of string literals", N);
10951 end Get_Reason_String;
10953 --------------------------------
10954 -- Get_Reference_Discriminant --
10955 --------------------------------
10957 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is
10961 D := First_Discriminant (Typ);
10962 while Present (D) loop
10963 if Has_Implicit_Dereference (D) then
10966 Next_Discriminant (D);
10970 end Get_Reference_Discriminant;
10972 ---------------------------
10973 -- Get_Referenced_Object --
10974 ---------------------------
10976 function Get_Referenced_Object (N : Node_Id) return Node_Id is
10981 while Is_Entity_Name (R)
10982 and then Is_Object (Entity (R))
10983 and then Present (Renamed_Object (Entity (R)))
10985 R := Renamed_Object (Entity (R));
10989 end Get_Referenced_Object;
10991 ------------------------
10992 -- Get_Renamed_Entity --
10993 ------------------------
10995 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
10996 R : Entity_Id := E;
10998 while Present (Renamed_Entity (R)) loop
10999 R := Renamed_Entity (R);
11003 end Get_Renamed_Entity;
11005 -----------------------
11006 -- Get_Return_Object --
11007 -----------------------
11009 function Get_Return_Object (N : Node_Id) return Entity_Id is
11013 Decl := First (Return_Object_Declarations (N));
11014 while Present (Decl) loop
11015 exit when Nkind (Decl) = N_Object_Declaration
11016 and then Is_Return_Object (Defining_Identifier (Decl));
11020 pragma Assert (Present (Decl));
11021 return Defining_Identifier (Decl);
11022 end Get_Return_Object;
11024 ---------------------------
11025 -- Get_Subprogram_Entity --
11026 ---------------------------
11028 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
11030 Subp_Id : Entity_Id;
11033 if Nkind (Nod) = N_Accept_Statement then
11034 Subp := Entry_Direct_Name (Nod);
11036 elsif Nkind (Nod) = N_Slice then
11037 Subp := Prefix (Nod);
11040 Subp := Name (Nod);
11043 -- Strip the subprogram call
11046 if Nkind (Subp) in N_Explicit_Dereference
11047 | N_Indexed_Component
11048 | N_Selected_Component
11050 Subp := Prefix (Subp);
11052 elsif Nkind (Subp) in N_Type_Conversion
11053 | N_Unchecked_Type_Conversion
11055 Subp := Expression (Subp);
11062 -- Extract the entity of the subprogram call
11064 if Is_Entity_Name (Subp) then
11065 Subp_Id := Entity (Subp);
11067 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
11068 Subp_Id := Directly_Designated_Type (Subp_Id);
11071 if Is_Subprogram (Subp_Id) then
11077 -- The search did not find a construct that denotes a subprogram
11082 end Get_Subprogram_Entity;
11084 -----------------------------
11085 -- Get_Task_Body_Procedure --
11086 -----------------------------
11088 function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is
11090 -- Note: A task type may be the completion of a private type with
11091 -- discriminants. When performing elaboration checks on a task
11092 -- declaration, the current view of the type may be the private one,
11093 -- and the procedure that holds the body of the task is held in its
11094 -- underlying type.
11096 -- This is an odd function, why not have Task_Body_Procedure do
11097 -- the following digging???
11099 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
11100 end Get_Task_Body_Procedure;
11102 -------------------------------
11103 -- Get_User_Defined_Equality --
11104 -------------------------------
11106 function Get_User_Defined_Equality (E : Entity_Id) return Entity_Id is
11110 Prim := First_Elmt (Collect_Primitive_Operations (E));
11111 while Present (Prim) loop
11112 if Is_User_Defined_Equality (Node (Prim)) then
11113 return Node (Prim);
11120 end Get_User_Defined_Equality;
11126 procedure Get_Views
11128 Priv_Typ : out Entity_Id;
11129 Full_Typ : out Entity_Id;
11130 UFull_Typ : out Entity_Id;
11131 CRec_Typ : out Entity_Id)
11133 IP_View : Entity_Id;
11136 -- Assume that none of the views can be recovered
11140 UFull_Typ := Empty;
11143 -- The input type is the corresponding record type of a protected or a
11146 if Ekind (Typ) = E_Record_Type
11147 and then Is_Concurrent_Record_Type (Typ)
11150 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
11151 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
11153 -- Otherwise the input type denotes an arbitrary type
11156 IP_View := Incomplete_Or_Partial_View (Typ);
11158 -- The input type denotes the full view of a private type
11160 if Present (IP_View) then
11161 Priv_Typ := IP_View;
11164 -- The input type is a private type
11166 elsif Is_Private_Type (Typ) then
11168 Full_Typ := Full_View (Priv_Typ);
11170 -- Otherwise the input type does not have any views
11176 if Present (Full_Typ) and then Is_Private_Type (Full_Typ) then
11177 UFull_Typ := Underlying_Full_View (Full_Typ);
11179 if Present (UFull_Typ)
11180 and then Ekind (UFull_Typ) in E_Protected_Type | E_Task_Type
11182 CRec_Typ := Corresponding_Record_Type (UFull_Typ);
11186 if Present (Full_Typ)
11187 and then Ekind (Full_Typ) in E_Protected_Type | E_Task_Type
11189 CRec_Typ := Corresponding_Record_Type (Full_Typ);
11195 ------------------------------
11196 -- Has_Compatible_Alignment --
11197 ------------------------------
11199 function Has_Compatible_Alignment
11202 Layout_Done : Boolean) return Alignment_Result
11204 function Has_Compatible_Alignment_Internal
11207 Layout_Done : Boolean;
11208 Default : Alignment_Result) return Alignment_Result;
11209 -- This is the internal recursive function that actually does the work.
11210 -- There is one additional parameter, which says what the result should
11211 -- be if no alignment information is found, and there is no definite
11212 -- indication of compatible alignments. At the outer level, this is set
11213 -- to Unknown, but for internal recursive calls in the case where types
11214 -- are known to be correct, it is set to Known_Compatible.
11216 ---------------------------------------
11217 -- Has_Compatible_Alignment_Internal --
11218 ---------------------------------------
11220 function Has_Compatible_Alignment_Internal
11223 Layout_Done : Boolean;
11224 Default : Alignment_Result) return Alignment_Result
11226 Result : Alignment_Result := Known_Compatible;
11227 -- Holds the current status of the result. Note that once a value of
11228 -- Known_Incompatible is set, it is sticky and does not get changed
11229 -- to Unknown (the value in Result only gets worse as we go along,
11232 Offs : Uint := No_Uint;
11233 -- Set to a factor of the offset from the base object when Expr is a
11234 -- selected or indexed component, based on Component_Bit_Offset and
11235 -- Component_Size respectively. A negative value is used to represent
11236 -- a value that is not known at compile time.
11238 procedure Check_Prefix;
11239 -- Checks the prefix recursively in the case where the expression
11240 -- is an indexed or selected component.
11242 procedure Set_Result (R : Alignment_Result);
11243 -- If R represents a worse outcome (unknown instead of known
11244 -- compatible, or known incompatible), then set Result to R.
11250 procedure Check_Prefix is
11252 -- The subtlety here is that in doing a recursive call to check
11253 -- the prefix, we have to decide what to do in the case where we
11254 -- don't find any specific indication of an alignment problem.
11256 -- At the outer level, we normally set Unknown as the result in
11257 -- this case, since we can only set Known_Compatible if we really
11258 -- know that the alignment value is OK, but for the recursive
11259 -- call, in the case where the types match, and we have not
11260 -- specified a peculiar alignment for the object, we are only
11261 -- concerned about suspicious rep clauses, the default case does
11262 -- not affect us, since the compiler will, in the absence of such
11263 -- rep clauses, ensure that the alignment is correct.
11265 if Default = Known_Compatible
11267 (Etype (Obj) = Etype (Expr)
11268 and then (not Known_Alignment (Obj)
11270 Alignment (Obj) = Alignment (Etype (Obj))))
11273 (Has_Compatible_Alignment_Internal
11274 (Obj, Prefix (Expr), Layout_Done, Known_Compatible));
11276 -- In all other cases, we need a full check on the prefix
11280 (Has_Compatible_Alignment_Internal
11281 (Obj, Prefix (Expr), Layout_Done, Unknown));
11289 procedure Set_Result (R : Alignment_Result) is
11296 -- Start of processing for Has_Compatible_Alignment_Internal
11299 -- If Expr is a selected component, we must make sure there is no
11300 -- potentially troublesome component clause and that the record is
11301 -- not packed if the layout is not done.
11303 if Nkind (Expr) = N_Selected_Component then
11305 -- Packing generates unknown alignment if layout is not done
11307 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then
11308 Set_Result (Unknown);
11311 -- Check prefix and component offset
11314 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
11316 -- If Expr is an indexed component, we must make sure there is no
11317 -- potentially troublesome Component_Size clause and that the array
11318 -- is not bit-packed if the layout is not done.
11320 elsif Nkind (Expr) = N_Indexed_Component then
11322 Typ : constant Entity_Id := Etype (Prefix (Expr));
11325 -- Packing generates unknown alignment if layout is not done
11327 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then
11328 Set_Result (Unknown);
11331 -- Check prefix and component offset (or at least size)
11334 Offs := Indexed_Component_Bit_Offset (Expr);
11336 Offs := Component_Size (Typ);
11341 -- If we have a null offset, the result is entirely determined by
11342 -- the base object and has already been computed recursively.
11344 if Present (Offs) and then Offs = Uint_0 then
11347 -- Case where we know the alignment of the object
11349 elsif Known_Alignment (Obj) then
11351 ObjA : constant Uint := Alignment (Obj);
11352 ExpA : Uint := No_Uint;
11353 SizA : Uint := No_Uint;
11356 -- If alignment of Obj is 1, then we are always OK
11359 Set_Result (Known_Compatible);
11361 -- Alignment of Obj is greater than 1, so we need to check
11364 -- If we have an offset, see if it is compatible
11366 if Present (Offs) and then Offs > Uint_0 then
11367 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
11368 Set_Result (Known_Incompatible);
11371 -- See if Expr is an object with known alignment
11373 elsif Is_Entity_Name (Expr)
11374 and then Known_Alignment (Entity (Expr))
11377 ExpA := Alignment (Entity (Expr));
11379 -- Otherwise, we can use the alignment of the type of Expr
11380 -- given that we already checked for discombobulating rep
11381 -- clauses for the cases of indexed and selected components
11384 elsif Known_Alignment (Etype (Expr)) then
11385 ExpA := Alignment (Etype (Expr));
11387 -- Otherwise the alignment is unknown
11390 Set_Result (Default);
11393 -- If we got an alignment, see if it is acceptable
11395 if Present (ExpA) and then ExpA < ObjA then
11396 Set_Result (Known_Incompatible);
11399 -- If Expr is a component or an entire object with a known
11400 -- alignment, then we are fine. Otherwise, if its size is
11401 -- known, it must be big enough for the required alignment.
11403 if Present (Offs) then
11406 -- See if Expr is an object with known size
11408 elsif Is_Entity_Name (Expr)
11409 and then Known_Static_Esize (Entity (Expr))
11411 SizA := Esize (Entity (Expr));
11413 -- Otherwise, we check the object size of the Expr type
11415 elsif Known_Static_Esize (Etype (Expr)) then
11416 SizA := Esize (Etype (Expr));
11419 -- If we got a size, see if it is a multiple of the Obj
11420 -- alignment; if not, then the alignment cannot be
11421 -- acceptable, since the size is always a multiple of the
11424 if Present (SizA) then
11425 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
11426 Set_Result (Known_Incompatible);
11432 -- If we do not know required alignment, any non-zero offset is a
11433 -- potential problem (but certainly may be OK, so result is unknown).
11435 elsif Present (Offs) then
11436 Set_Result (Unknown);
11438 -- If we can't find the result by direct comparison of alignment
11439 -- values, then there is still one case that we can determine known
11440 -- result, and that is when we can determine that the types are the
11441 -- same, and no alignments are specified. Then we known that the
11442 -- alignments are compatible, even if we don't know the alignment
11443 -- value in the front end.
11445 elsif Etype (Obj) = Etype (Expr) then
11447 -- Types are the same, but we have to check for possible size
11448 -- and alignments on the Expr object that may make the alignment
11449 -- different, even though the types are the same.
11451 if Is_Entity_Name (Expr) then
11453 -- First check alignment of the Expr object. Any alignment less
11454 -- than Maximum_Alignment is worrisome since this is the case
11455 -- where we do not know the alignment of Obj.
11457 if Known_Alignment (Entity (Expr))
11458 and then Alignment (Entity (Expr)) < Ttypes.Maximum_Alignment
11460 Set_Result (Unknown);
11462 -- Now check size of Expr object. Any size that is not an even
11463 -- multiple of Maximum_Alignment is also worrisome since it
11464 -- may cause the alignment of the object to be less than the
11465 -- alignment of the type.
11467 elsif Known_Static_Esize (Entity (Expr))
11469 Esize (Entity (Expr)) mod
11470 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)
11473 Set_Result (Unknown);
11475 -- Otherwise same type is decisive
11478 Set_Result (Known_Compatible);
11482 -- Another case to deal with is when there is an explicit size or
11483 -- alignment clause when the types are not the same. If so, then the
11484 -- result is Unknown. We don't need to do this test if the Default is
11485 -- Unknown, since that result will be set in any case.
11487 elsif Default /= Unknown
11488 and then (Has_Size_Clause (Etype (Expr))
11490 Has_Alignment_Clause (Etype (Expr)))
11492 Set_Result (Unknown);
11494 -- If no indication found, set default
11497 Set_Result (Default);
11500 -- Return worst result found
11503 end Has_Compatible_Alignment_Internal;
11505 -- Start of processing for Has_Compatible_Alignment
11508 -- If Obj has no specified alignment, then set alignment from the type
11509 -- alignment. Perhaps we should always do this, but for sure we should
11510 -- do it when there is an address clause since we can do more if the
11511 -- alignment is known.
11513 if not Known_Alignment (Obj) and then Known_Alignment (Etype (Obj)) then
11514 Set_Alignment (Obj, Alignment (Etype (Obj)));
11517 -- Now do the internal call that does all the work
11520 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown);
11521 end Has_Compatible_Alignment;
11523 ----------------------
11524 -- Has_Declarations --
11525 ----------------------
11527 function Has_Declarations (N : Node_Id) return Boolean is
11529 return Nkind (N) in N_Accept_Statement
11530 | N_Block_Statement
11531 | N_Compilation_Unit_Aux
11535 | N_Subprogram_Body
11537 | N_Package_Specification;
11538 end Has_Declarations;
11540 ---------------------------------
11541 -- Has_Defaulted_Discriminants --
11542 ---------------------------------
11544 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
11546 return Has_Discriminants (Typ)
11547 and then Present (Discriminant_Default_Value
11548 (First_Discriminant (Typ)));
11549 end Has_Defaulted_Discriminants;
11551 -------------------
11552 -- Has_Denormals --
11553 -------------------
11555 function Has_Denormals (E : Entity_Id) return Boolean is
11557 return Is_Floating_Point_Type (E) and then Denorm_On_Target;
11560 -------------------------------------------
11561 -- Has_Discriminant_Dependent_Constraint --
11562 -------------------------------------------
11564 function Has_Discriminant_Dependent_Constraint
11565 (Comp : Entity_Id) return Boolean
11567 Comp_Decl : constant Node_Id := Parent (Comp);
11568 Subt_Indic : Node_Id;
11573 -- Discriminants can't depend on discriminants
11575 if Ekind (Comp) = E_Discriminant then
11579 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
11581 if Nkind (Subt_Indic) = N_Subtype_Indication then
11582 Constr := Constraint (Subt_Indic);
11584 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
11585 Assn := First (Constraints (Constr));
11586 while Present (Assn) loop
11587 case Nkind (Assn) is
11590 | N_Subtype_Indication
11592 if Depends_On_Discriminant (Assn) then
11596 when N_Discriminant_Association =>
11597 if Depends_On_Discriminant (Expression (Assn)) then
11612 end Has_Discriminant_Dependent_Constraint;
11614 --------------------------------------
11615 -- Has_Effectively_Volatile_Profile --
11616 --------------------------------------
11618 function Has_Effectively_Volatile_Profile
11619 (Subp_Id : Entity_Id) return Boolean
11621 Formal : Entity_Id;
11624 -- Inspect the formal parameters looking for an effectively volatile
11625 -- type for reading.
11627 Formal := First_Formal (Subp_Id);
11628 while Present (Formal) loop
11629 if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then
11633 Next_Formal (Formal);
11636 -- Inspect the return type of functions
11638 if Ekind (Subp_Id) in E_Function | E_Generic_Function
11639 and then Is_Effectively_Volatile_For_Reading (Etype (Subp_Id))
11645 end Has_Effectively_Volatile_Profile;
11647 --------------------------
11648 -- Has_Enabled_Property --
11649 --------------------------
11651 function Has_Enabled_Property
11652 (Item_Id : Entity_Id;
11653 Property : Name_Id) return Boolean
11655 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean;
11656 -- Determine whether a protected type or variable denoted by Item_Id
11657 -- has the property enabled.
11659 function State_Has_Enabled_Property return Boolean;
11660 -- Determine whether a state denoted by Item_Id has the property enabled
11662 function Type_Or_Variable_Has_Enabled_Property
11663 (Item_Id : Entity_Id) return Boolean;
11664 -- Determine whether type or variable denoted by Item_Id has the
11665 -- property enabled.
11667 -----------------------------------------------------
11668 -- Protected_Type_Or_Variable_Has_Enabled_Property --
11669 -----------------------------------------------------
11671 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean
11674 -- Protected entities always have the properties Async_Readers and
11675 -- Async_Writers (SPARK RM 7.1.2(16)).
11677 if Property = Name_Async_Readers
11678 or else Property = Name_Async_Writers
11682 -- Protected objects that have Part_Of components also inherit their
11683 -- properties Effective_Reads and Effective_Writes
11684 -- (SPARK RM 7.1.2(16)).
11686 elsif Is_Single_Protected_Object (Item_Id) then
11688 Constit_Elmt : Elmt_Id;
11689 Constit_Id : Entity_Id;
11690 Constits : constant Elist_Id
11691 := Part_Of_Constituents (Item_Id);
11693 if Present (Constits) then
11694 Constit_Elmt := First_Elmt (Constits);
11695 while Present (Constit_Elmt) loop
11696 Constit_Id := Node (Constit_Elmt);
11698 if Has_Enabled_Property (Constit_Id, Property) then
11702 Next_Elmt (Constit_Elmt);
11709 end Protected_Type_Or_Variable_Has_Enabled_Property;
11711 --------------------------------
11712 -- State_Has_Enabled_Property --
11713 --------------------------------
11715 function State_Has_Enabled_Property return Boolean is
11716 Decl : constant Node_Id := Parent (Item_Id);
11718 procedure Find_Simple_Properties
11719 (Has_External : out Boolean;
11720 Has_Synchronous : out Boolean);
11721 -- Extract the simple properties associated with declaration Decl
11723 function Is_Enabled_External_Property return Boolean;
11724 -- Determine whether property Property appears within the external
11725 -- property list of declaration Decl, and return its status.
11727 ----------------------------
11728 -- Find_Simple_Properties --
11729 ----------------------------
11731 procedure Find_Simple_Properties
11732 (Has_External : out Boolean;
11733 Has_Synchronous : out Boolean)
11738 -- Assume that none of the properties are available
11740 Has_External := False;
11741 Has_Synchronous := False;
11743 Opt := First (Expressions (Decl));
11744 while Present (Opt) loop
11745 if Nkind (Opt) = N_Identifier then
11746 if Chars (Opt) = Name_External then
11747 Has_External := True;
11749 elsif Chars (Opt) = Name_Synchronous then
11750 Has_Synchronous := True;
11756 end Find_Simple_Properties;
11758 ----------------------------------
11759 -- Is_Enabled_External_Property --
11760 ----------------------------------
11762 function Is_Enabled_External_Property return Boolean is
11766 Prop_Nam : Node_Id;
11770 Opt := First (Component_Associations (Decl));
11771 while Present (Opt) loop
11772 Opt_Nam := First (Choices (Opt));
11774 if Nkind (Opt_Nam) = N_Identifier
11775 and then Chars (Opt_Nam) = Name_External
11777 Props := Expression (Opt);
11779 -- Multiple properties appear as an aggregate
11781 if Nkind (Props) = N_Aggregate then
11783 -- Simple property form
11785 Prop := First (Expressions (Props));
11786 while Present (Prop) loop
11787 if Chars (Prop) = Property then
11794 -- Property with expression form
11796 Prop := First (Component_Associations (Props));
11797 while Present (Prop) loop
11798 Prop_Nam := First (Choices (Prop));
11800 -- The property can be represented in two ways:
11801 -- others => <value>
11802 -- <property> => <value>
11804 if Nkind (Prop_Nam) = N_Others_Choice
11805 or else (Nkind (Prop_Nam) = N_Identifier
11806 and then Chars (Prop_Nam) = Property)
11808 return Is_True (Expr_Value (Expression (Prop)));
11817 return Chars (Props) = Property;
11825 end Is_Enabled_External_Property;
11829 Has_External : Boolean;
11830 Has_Synchronous : Boolean;
11832 -- Start of processing for State_Has_Enabled_Property
11835 -- The declaration of an external abstract state appears as an
11836 -- extension aggregate. If this is not the case, properties can
11839 if Nkind (Decl) /= N_Extension_Aggregate then
11843 Find_Simple_Properties (Has_External, Has_Synchronous);
11845 -- Simple option External enables all properties (SPARK RM 7.1.2(2))
11847 if Has_External then
11850 -- Option External may enable or disable specific properties
11852 elsif Is_Enabled_External_Property then
11855 -- Simple option Synchronous
11857 -- enables disables
11858 -- Async_Readers Effective_Reads
11859 -- Async_Writers Effective_Writes
11861 -- Note that both forms of External have higher precedence than
11862 -- Synchronous (SPARK RM 7.1.4(9)).
11864 elsif Has_Synchronous then
11865 return Property in Name_Async_Readers | Name_Async_Writers;
11869 end State_Has_Enabled_Property;
11871 -------------------------------------------
11872 -- Type_Or_Variable_Has_Enabled_Property --
11873 -------------------------------------------
11875 function Type_Or_Variable_Has_Enabled_Property
11876 (Item_Id : Entity_Id) return Boolean
11878 AR : constant Node_Id :=
11879 Get_Pragma (Item_Id, Pragma_Async_Readers);
11880 AW : constant Node_Id :=
11881 Get_Pragma (Item_Id, Pragma_Async_Writers);
11882 ER : constant Node_Id :=
11883 Get_Pragma (Item_Id, Pragma_Effective_Reads);
11884 EW : constant Node_Id :=
11885 Get_Pragma (Item_Id, Pragma_Effective_Writes);
11887 Is_Derived_Type_With_Volatile_Parent_Type : constant Boolean :=
11888 Is_Derived_Type (Item_Id)
11889 and then Is_Effectively_Volatile (Etype (Base_Type (Item_Id)));
11892 -- A non-effectively volatile object can never possess external
11895 if not Is_Effectively_Volatile (Item_Id) then
11898 -- External properties related to variables come in two flavors -
11899 -- explicit and implicit. The explicit case is characterized by the
11900 -- presence of a property pragma with an optional Boolean flag. The
11901 -- property is enabled when the flag evaluates to True or the flag is
11902 -- missing altogether.
11904 elsif Property = Name_Async_Readers and then Present (AR) then
11905 return Is_Enabled_Pragma (AR);
11907 elsif Property = Name_Async_Writers and then Present (AW) then
11908 return Is_Enabled_Pragma (AW);
11910 elsif Property = Name_Effective_Reads and then Present (ER) then
11911 return Is_Enabled_Pragma (ER);
11913 elsif Property = Name_Effective_Writes and then Present (EW) then
11914 return Is_Enabled_Pragma (EW);
11916 -- If other properties are set explicitly, then this one is set
11917 -- implicitly to False, except in the case of a derived type
11918 -- whose parent type is volatile (in that case, we will inherit
11919 -- from the parent type, below).
11921 elsif (Present (AR)
11922 or else Present (AW)
11923 or else Present (ER)
11924 or else Present (EW))
11925 and then not Is_Derived_Type_With_Volatile_Parent_Type
11929 -- For a private type (including subtype of a private types), look at
11932 elsif Is_Private_Type (Item_Id) and then Present (Full_View (Item_Id))
11934 return Type_Or_Variable_Has_Enabled_Property (Full_View (Item_Id));
11936 -- For a derived type whose parent type is volatile, the
11937 -- property may be inherited (but ignore a non-volatile parent).
11939 elsif Is_Derived_Type_With_Volatile_Parent_Type then
11940 return Type_Or_Variable_Has_Enabled_Property
11941 (First_Subtype (Etype (Base_Type (Item_Id))));
11943 -- For a subtype, the property will be inherited from its base type.
11945 elsif Is_Type (Item_Id)
11946 and then not Is_Base_Type (Item_Id)
11948 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id));
11950 -- If not specified explicitly for an object and its type
11951 -- is effectively volatile, then take result from the type.
11953 elsif Is_Object (Item_Id)
11954 and then Is_Effectively_Volatile (Etype (Item_Id))
11956 return Has_Enabled_Property (Etype (Item_Id), Property);
11958 -- The implicit case lacks all property pragmas
11960 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
11961 if Is_Protected_Type (Etype (Item_Id)) then
11962 return Protected_Type_Or_Variable_Has_Enabled_Property;
11970 end Type_Or_Variable_Has_Enabled_Property;
11972 -- Start of processing for Has_Enabled_Property
11975 -- Abstract states and variables have a flexible scheme of specifying
11976 -- external properties.
11978 if Ekind (Item_Id) = E_Abstract_State then
11979 return State_Has_Enabled_Property;
11981 elsif Ekind (Item_Id) in E_Variable | E_Constant then
11982 return Type_Or_Variable_Has_Enabled_Property (Item_Id);
11984 -- Other objects can only inherit properties through their type. We
11985 -- cannot call directly Type_Or_Variable_Has_Enabled_Property on
11986 -- these as they don't have contracts attached, which is expected by
11989 elsif Is_Object (Item_Id) then
11990 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id));
11992 elsif Is_Type (Item_Id) then
11993 return Type_Or_Variable_Has_Enabled_Property
11994 (Item_Id => First_Subtype (Item_Id));
11996 -- Otherwise a property is enabled when the related item is effectively
12000 return Is_Effectively_Volatile (Item_Id);
12002 end Has_Enabled_Property;
12004 -------------------------------------
12005 -- Has_Full_Default_Initialization --
12006 -------------------------------------
12008 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
12012 -- A type subject to pragma Default_Initial_Condition may be fully
12013 -- default initialized depending on inheritance and the argument of
12014 -- the pragma. Since any type may act as the full view of a private
12015 -- type, this check must be performed prior to the specialized tests
12018 if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then
12022 -- A scalar type is fully default initialized if it is subject to aspect
12025 if Is_Scalar_Type (Typ) then
12026 return Has_Default_Aspect (Typ);
12028 -- An access type is fully default initialized by default
12030 elsif Is_Access_Type (Typ) then
12033 -- An array type is fully default initialized if its element type is
12034 -- scalar and the array type carries aspect Default_Component_Value or
12035 -- the element type is fully default initialized.
12037 elsif Is_Array_Type (Typ) then
12039 Has_Default_Aspect (Typ)
12040 or else Has_Full_Default_Initialization (Component_Type (Typ));
12042 -- A protected type, record type, or type extension is fully default
12043 -- initialized if all its components either carry an initialization
12044 -- expression or have a type that is fully default initialized. The
12045 -- parent type of a type extension must be fully default initialized.
12047 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
12049 -- Inspect all entities defined in the scope of the type, looking for
12050 -- uninitialized components.
12052 Comp := First_Component (Typ);
12053 while Present (Comp) loop
12054 if Comes_From_Source (Comp)
12055 and then No (Expression (Parent (Comp)))
12056 and then not Has_Full_Default_Initialization (Etype (Comp))
12061 Next_Component (Comp);
12064 -- Ensure that the parent type of a type extension is fully default
12067 if Etype (Typ) /= Typ
12068 and then not Has_Full_Default_Initialization (Etype (Typ))
12073 -- If we get here, then all components and parent portion are fully
12074 -- default initialized.
12078 -- A task type is fully default initialized by default
12080 elsif Is_Task_Type (Typ) then
12083 -- Otherwise the type is not fully default initialized
12088 end Has_Full_Default_Initialization;
12090 -----------------------------------------------
12091 -- Has_Fully_Default_Initializing_DIC_Pragma --
12092 -----------------------------------------------
12094 function Has_Fully_Default_Initializing_DIC_Pragma
12095 (Typ : Entity_Id) return Boolean
12101 -- A type that inherits pragma Default_Initial_Condition from a parent
12102 -- type is automatically fully default initialized.
12104 if Has_Inherited_DIC (Typ) then
12107 -- Otherwise the type is fully default initialized only when the pragma
12108 -- appears without an argument, or the argument is non-null.
12110 elsif Has_Own_DIC (Typ) then
12111 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
12112 pragma Assert (Present (Prag));
12113 Args := Pragma_Argument_Associations (Prag);
12115 -- The pragma appears without an argument in which case it defaults
12121 -- The pragma appears with a non-null expression
12123 elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then
12129 end Has_Fully_Default_Initializing_DIC_Pragma;
12131 ---------------------------------
12132 -- Has_Inferable_Discriminants --
12133 ---------------------------------
12135 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
12137 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
12138 -- Determines whether the left-most prefix of a selected component is a
12139 -- formal parameter in a subprogram. Assumes N is a selected component.
12141 --------------------------------
12142 -- Prefix_Is_Formal_Parameter --
12143 --------------------------------
12145 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
12146 Sel_Comp : Node_Id;
12149 -- Move to the left-most prefix by climbing up the tree
12152 while Present (Parent (Sel_Comp))
12153 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
12155 Sel_Comp := Parent (Sel_Comp);
12158 return Is_Formal (Entity (Prefix (Sel_Comp)));
12159 end Prefix_Is_Formal_Parameter;
12161 -- Start of processing for Has_Inferable_Discriminants
12164 -- For selected components, the subtype of the selector must be a
12165 -- constrained Unchecked_Union. If the component is subject to a
12166 -- per-object constraint, then the enclosing object must have inferable
12169 if Nkind (N) = N_Selected_Component then
12170 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
12172 -- A small hack. If we have a per-object constrained selected
12173 -- component of a formal parameter, return True since we do not
12174 -- know the actual parameter association yet.
12176 if Prefix_Is_Formal_Parameter (N) then
12179 -- Otherwise, check the enclosing object and the selector
12182 return Has_Inferable_Discriminants (Prefix (N))
12183 and then Has_Inferable_Discriminants (Selector_Name (N));
12186 -- The call to Has_Inferable_Discriminants will determine whether
12187 -- the selector has a constrained Unchecked_Union nominal type.
12190 return Has_Inferable_Discriminants (Selector_Name (N));
12193 -- A qualified expression has inferable discriminants if its subtype
12194 -- mark is a constrained Unchecked_Union subtype.
12196 elsif Nkind (N) = N_Qualified_Expression then
12197 return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
12198 and then Is_Constrained (Etype (Subtype_Mark (N)));
12200 -- For all other names, it is sufficient to have a constrained
12201 -- Unchecked_Union nominal subtype.
12204 return Is_Unchecked_Union (Base_Type (Etype (N)))
12205 and then Is_Constrained (Etype (N));
12207 end Has_Inferable_Discriminants;
12209 --------------------
12210 -- Has_Infinities --
12211 --------------------
12213 function Has_Infinities (E : Entity_Id) return Boolean is
12216 Is_Floating_Point_Type (E)
12217 and then Nkind (Scalar_Range (E)) = N_Range
12218 and then Includes_Infinities (Scalar_Range (E));
12219 end Has_Infinities;
12221 --------------------
12222 -- Has_Interfaces --
12223 --------------------
12225 function Has_Interfaces
12227 Use_Full_View : Boolean := True) return Boolean
12229 Typ : Entity_Id := Base_Type (T);
12232 -- Handle concurrent types
12234 if Is_Concurrent_Type (Typ) then
12235 Typ := Corresponding_Record_Type (Typ);
12239 or else not Is_Record_Type (Typ)
12240 or else not Is_Tagged_Type (Typ)
12245 -- Handle private types
12247 if Use_Full_View and then Present (Full_View (Typ)) then
12248 Typ := Full_View (Typ);
12251 -- Handle concurrent record types
12253 if Is_Concurrent_Record_Type (Typ)
12254 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
12260 if Is_Interface (Typ)
12262 (Is_Record_Type (Typ)
12263 and then Present (Interfaces (Typ))
12264 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
12269 exit when Etype (Typ) = Typ
12271 -- Handle private types
12273 or else (Present (Full_View (Etype (Typ)))
12274 and then Full_View (Etype (Typ)) = Typ)
12276 -- Protect frontend against wrong sources with cyclic derivations
12278 or else Etype (Typ) = T;
12280 -- Climb to the ancestor type handling private types
12282 if Present (Full_View (Etype (Typ))) then
12283 Typ := Full_View (Etype (Typ));
12285 Typ := Etype (Typ);
12290 end Has_Interfaces;
12292 --------------------------
12293 -- Has_Max_Queue_Length --
12294 --------------------------
12296 function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is
12299 Ekind (Id) = E_Entry
12300 and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length));
12301 end Has_Max_Queue_Length;
12303 ---------------------------------
12304 -- Has_No_Obvious_Side_Effects --
12305 ---------------------------------
12307 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
12309 -- For now handle literals, constants, and non-volatile variables and
12310 -- expressions combining these with operators or short circuit forms.
12312 if Nkind (N) in N_Numeric_Or_String_Literal then
12315 elsif Nkind (N) = N_Character_Literal then
12318 elsif Nkind (N) in N_Unary_Op then
12319 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
12321 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
12322 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
12324 Has_No_Obvious_Side_Effects (Right_Opnd (N));
12326 elsif Nkind (N) = N_Expression_With_Actions
12327 and then Is_Empty_List (Actions (N))
12329 return Has_No_Obvious_Side_Effects (Expression (N));
12331 elsif Nkind (N) in N_Has_Entity then
12332 return Present (Entity (N))
12334 Ekind (Entity (N)) in
12335 E_Variable | E_Constant | E_Enumeration_Literal |
12336 E_In_Parameter | E_Out_Parameter | E_In_Out_Parameter
12337 and then not Is_Volatile (Entity (N));
12342 end Has_No_Obvious_Side_Effects;
12344 -----------------------------
12345 -- Has_Non_Null_Refinement --
12346 -----------------------------
12348 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is
12349 Constits : Elist_Id;
12352 pragma Assert (Ekind (Id) = E_Abstract_State);
12353 Constits := Refinement_Constituents (Id);
12355 -- For a refinement to be non-null, the first constituent must be
12356 -- anything other than null.
12360 and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
12361 end Has_Non_Null_Refinement;
12363 -----------------------------
12364 -- Has_Non_Null_Statements --
12365 -----------------------------
12367 function Has_Non_Null_Statements (L : List_Id) return Boolean is
12373 while Present (Node) loop
12374 if Nkind (Node) not in N_Null_Statement | N_Call_Marker then
12382 end Has_Non_Null_Statements;
12384 ----------------------------------
12385 -- Is_Access_Subprogram_Wrapper --
12386 ----------------------------------
12388 function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean is
12389 Formal : constant Entity_Id := Last_Formal (E);
12391 return Present (Formal)
12392 and then Ekind (Etype (Formal)) in Access_Subprogram_Kind
12393 and then Access_Subprogram_Wrapper
12394 (Directly_Designated_Type (Etype (Formal))) = E;
12395 end Is_Access_Subprogram_Wrapper;
12397 ---------------------------
12398 -- Is_Explicitly_Aliased --
12399 ---------------------------
12401 function Is_Explicitly_Aliased (N : Node_Id) return Boolean is
12403 return Is_Formal (N)
12404 and then Present (Parent (N))
12405 and then Nkind (Parent (N)) = N_Parameter_Specification
12406 and then Aliased_Present (Parent (N));
12407 end Is_Explicitly_Aliased;
12409 ----------------------------
12410 -- Is_Container_Aggregate --
12411 ----------------------------
12413 function Is_Container_Aggregate (Exp : Node_Id) return Boolean is
12415 function Is_Record_Aggregate return Boolean is (False);
12416 -- ??? Unimplemented. Given an aggregate whose type is a
12417 -- record type with specified Aggregate aspect, how do we
12418 -- determine whether it is a record aggregate or a container
12419 -- aggregate? If the code where the aggregate occurs can see only
12420 -- a partial view of the aggregate's type then the aggregate
12421 -- cannot be a record type; an aggregate of a private type has to
12422 -- be a container aggregate.
12425 return Nkind (Exp) = N_Aggregate
12426 and then Has_Aspect (Etype (Exp), Aspect_Aggregate)
12427 and then not Is_Record_Aggregate;
12428 end Is_Container_Aggregate;
12430 ---------------------------------
12431 -- Side_Effect_Free_Statements --
12432 ---------------------------------
12434 function Side_Effect_Free_Statements (L : List_Id) return Boolean is
12440 while Present (Node) loop
12441 case Nkind (Node) is
12442 when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error =>
12445 when N_Object_Declaration =>
12446 if Present (Expression (Node))
12447 and then not Side_Effect_Free (Expression (Node))
12460 end Side_Effect_Free_Statements;
12462 ---------------------------
12463 -- Side_Effect_Free_Loop --
12464 ---------------------------
12466 function Side_Effect_Free_Loop (N : Node_Id) return Boolean is
12472 -- If this is not a loop (e.g. because the loop has been rewritten),
12473 -- then return false.
12475 if Nkind (N) /= N_Loop_Statement then
12479 -- First check the statements
12481 if Side_Effect_Free_Statements (Statements (N)) then
12483 -- Then check the loop condition/indexes
12485 if Present (Iteration_Scheme (N)) then
12486 Scheme := Iteration_Scheme (N);
12488 if Present (Condition (Scheme))
12489 or else Present (Iterator_Specification (Scheme))
12492 elsif Present (Loop_Parameter_Specification (Scheme)) then
12493 Spec := Loop_Parameter_Specification (Scheme);
12494 Subt := Discrete_Subtype_Definition (Spec);
12496 if Present (Subt) then
12497 if Nkind (Subt) = N_Range then
12498 return Side_Effect_Free (Low_Bound (Subt))
12499 and then Side_Effect_Free (High_Bound (Subt));
12501 -- subtype indication
12511 end Side_Effect_Free_Loop;
12513 ----------------------------------
12514 -- Has_Non_Trivial_Precondition --
12515 ----------------------------------
12517 function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is
12518 Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre,
12519 Class_Present => True);
12523 and then not Is_Entity_Name (Expression (Pre));
12524 end Has_Non_Trivial_Precondition;
12526 -------------------
12527 -- Has_Null_Body --
12528 -------------------
12530 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is
12531 Body_Id : Entity_Id;
12538 Spec := Parent (Proc_Id);
12539 Decl := Parent (Spec);
12541 -- Retrieve the entity of the procedure body (e.g. invariant proc).
12543 if Nkind (Spec) = N_Procedure_Specification
12544 and then Nkind (Decl) = N_Subprogram_Declaration
12546 Body_Id := Corresponding_Body (Decl);
12548 -- The body acts as a spec
12551 Body_Id := Proc_Id;
12554 -- The body will be generated later
12556 if No (Body_Id) then
12560 Spec := Parent (Body_Id);
12561 Decl := Parent (Spec);
12564 (Nkind (Spec) = N_Procedure_Specification
12565 and then Nkind (Decl) = N_Subprogram_Body);
12567 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl)));
12569 -- Look for a null statement followed by an optional return
12572 if Nkind (Stmt1) = N_Null_Statement then
12573 Stmt2 := Next (Stmt1);
12575 if Present (Stmt2) then
12576 return Nkind (Stmt2) = N_Simple_Return_Statement;
12585 ------------------------
12586 -- Has_Null_Exclusion --
12587 ------------------------
12589 function Has_Null_Exclusion (N : Node_Id) return Boolean is
12592 when N_Access_Definition
12593 | N_Access_Function_Definition
12594 | N_Access_Procedure_Definition
12595 | N_Access_To_Object_Definition
12597 | N_Derived_Type_Definition
12598 | N_Function_Specification
12599 | N_Subtype_Declaration
12601 return Null_Exclusion_Present (N);
12603 when N_Component_Definition
12604 | N_Formal_Object_Declaration
12606 if Present (Subtype_Mark (N)) then
12607 return Null_Exclusion_Present (N);
12608 else pragma Assert (Present (Access_Definition (N)));
12609 return Null_Exclusion_Present (Access_Definition (N));
12612 when N_Object_Renaming_Declaration =>
12613 if Present (Subtype_Mark (N)) then
12614 return Null_Exclusion_Present (N);
12615 elsif Present (Access_Definition (N)) then
12616 return Null_Exclusion_Present (Access_Definition (N));
12618 return False; -- Case of no subtype in renaming (AI12-0275)
12621 when N_Discriminant_Specification =>
12622 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
12623 return Null_Exclusion_Present (Discriminant_Type (N));
12625 return Null_Exclusion_Present (N);
12628 when N_Object_Declaration =>
12629 if Nkind (Object_Definition (N)) = N_Access_Definition then
12630 return Null_Exclusion_Present (Object_Definition (N));
12632 return Null_Exclusion_Present (N);
12635 when N_Parameter_Specification =>
12636 if Nkind (Parameter_Type (N)) = N_Access_Definition then
12637 return Null_Exclusion_Present (Parameter_Type (N))
12638 or else Null_Exclusion_Present (N);
12640 return Null_Exclusion_Present (N);
12646 end Has_Null_Exclusion;
12648 ------------------------
12649 -- Has_Null_Extension --
12650 ------------------------
12652 function Has_Null_Extension (T : Entity_Id) return Boolean is
12653 B : constant Entity_Id := Base_Type (T);
12658 if Nkind (Parent (B)) = N_Full_Type_Declaration
12659 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
12661 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
12663 if Present (Ext) then
12664 if Null_Present (Ext) then
12667 Comps := Component_List (Ext);
12669 -- The null component list is rewritten during analysis to
12670 -- include the parent component. Any other component indicates
12671 -- that the extension was not originally null.
12673 return Null_Present (Comps)
12674 or else No (Next (First (Component_Items (Comps))));
12683 end Has_Null_Extension;
12685 -------------------------
12686 -- Has_Null_Refinement --
12687 -------------------------
12689 function Has_Null_Refinement (Id : Entity_Id) return Boolean is
12690 Constits : Elist_Id;
12693 pragma Assert (Ekind (Id) = E_Abstract_State);
12694 Constits := Refinement_Constituents (Id);
12696 -- For a refinement to be null, the state's sole constituent must be a
12701 and then Nkind (Node (First_Elmt (Constits))) = N_Null;
12702 end Has_Null_Refinement;
12704 ------------------------------------------
12705 -- Has_Nonstatic_Class_Wide_Pre_Or_Post --
12706 ------------------------------------------
12708 function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
12709 (Subp : Entity_Id) return Boolean
12711 Disp_Type : constant Entity_Id := Find_Dispatching_Type (Subp);
12713 Pragma_Arg : Node_Id;
12716 if Present (Disp_Type)
12717 and then Is_Abstract_Type (Disp_Type)
12718 and then Present (Contract (Subp))
12720 Prag := Pre_Post_Conditions (Contract (Subp));
12722 while Present (Prag) loop
12723 if Pragma_Name (Prag) in Name_Precondition | Name_Postcondition
12724 and then Class_Present (Prag)
12728 (Pragma_Argument_Associations (Prag));
12730 if not Is_Static_Expression (Expression (Pragma_Arg)) then
12735 Prag := Next_Pragma (Prag);
12740 end Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post;
12742 -------------------------------
12743 -- Has_Overriding_Initialize --
12744 -------------------------------
12746 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
12747 BT : constant Entity_Id := Base_Type (T);
12751 if Is_Controlled (BT) then
12752 if Is_RTU (Scope (BT), Ada_Finalization) then
12755 elsif Present (Primitive_Operations (BT)) then
12756 P := First_Elmt (Primitive_Operations (BT));
12757 while Present (P) loop
12759 Init : constant Entity_Id := Node (P);
12760 Formal : constant Entity_Id := First_Formal (Init);
12762 if Ekind (Init) = E_Procedure
12763 and then Chars (Init) = Name_Initialize
12764 and then Comes_From_Source (Init)
12765 and then Present (Formal)
12766 and then Etype (Formal) = BT
12767 and then No (Next_Formal (Formal))
12768 and then (Ada_Version < Ada_2012
12769 or else not Null_Present (Parent (Init)))
12779 -- Here if type itself does not have a non-null Initialize operation:
12780 -- check immediate ancestor.
12782 if Is_Derived_Type (BT)
12783 and then Has_Overriding_Initialize (Etype (BT))
12790 end Has_Overriding_Initialize;
12792 --------------------------------------
12793 -- Has_Preelaborable_Initialization --
12794 --------------------------------------
12796 function Has_Preelaborable_Initialization
12798 Preelab_Init_Expr : Node_Id := Empty) return Boolean
12802 procedure Check_Components (E : Entity_Id);
12803 -- Check component/discriminant chain, sets Has_PE False if a component
12804 -- or discriminant does not meet the preelaborable initialization rules.
12806 function Type_Named_In_Preelab_Init_Expression
12808 Expr : Node_Id) return Boolean;
12809 -- Returns True iff Typ'Preelaborable_Initialization occurs in Expr
12810 -- (where Expr may be a conjunction of one or more P_I attributes).
12812 ----------------------
12813 -- Check_Components --
12814 ----------------------
12816 procedure Check_Components (E : Entity_Id) is
12821 -- Loop through components and discriminants of record or protected
12824 Ent := First_Component_Or_Discriminant (E);
12825 while Present (Ent) loop
12827 case Ekind (Ent) is
12828 when E_Component =>
12830 -- Get default expression if any. If there is no declaration
12831 -- node, it means we have an internal entity. The parent and
12832 -- tag fields are examples of such entities. For such cases,
12833 -- we just test the type of the entity.
12835 if Present (Declaration_Node (Ent)) then
12836 Exp := Expression (Declaration_Node (Ent));
12841 when E_Discriminant =>
12843 -- Note: for a renamed discriminant, the Declaration_Node
12844 -- may point to the one from the ancestor, and have a
12845 -- different expression, so use the proper attribute to
12846 -- retrieve the expression from the derived constraint.
12848 Exp := Discriminant_Default_Value (Ent);
12851 raise Program_Error;
12854 -- A component has PI if it has no default expression and the
12855 -- component type has PI.
12858 if not Has_Preelaborable_Initialization
12859 (Etype (Ent), Preelab_Init_Expr)
12865 -- Require the default expression to be preelaborable
12867 elsif not Is_Preelaborable_Construct (Exp) then
12872 Next_Component_Or_Discriminant (Ent);
12874 end Check_Components;
12876 --------------------------------------
12877 -- Type_Named_In_Preelab_Expression --
12878 --------------------------------------
12880 function Type_Named_In_Preelab_Init_Expression
12882 Expr : Node_Id) return Boolean
12885 -- Return True if Expr is a Preelaborable_Initialization attribute
12886 -- and the prefix is a subtype that has the same type as Typ.
12888 if Nkind (Expr) = N_Attribute_Reference
12889 and then Attribute_Name (Expr) = Name_Preelaborable_Initialization
12890 and then Is_Entity_Name (Prefix (Expr))
12891 and then Base_Type (Entity (Prefix (Expr))) = Base_Type (Typ)
12895 -- In the case where Expr is a conjunction, test whether either
12896 -- operand is a Preelaborable_Initialization attribute whose prefix
12897 -- has the same type as Typ, and return True if so.
12899 elsif Nkind (Expr) = N_Op_And
12901 (Type_Named_In_Preelab_Init_Expression (Typ, Left_Opnd (Expr))
12903 Type_Named_In_Preelab_Init_Expression (Typ, Right_Opnd (Expr)))
12907 -- Typ not named in a Preelaborable_Initialization attribute of Expr
12912 end Type_Named_In_Preelab_Init_Expression;
12914 -- Start of processing for Has_Preelaborable_Initialization
12917 -- Immediate return if already marked as known preelaborable init. This
12918 -- covers types for which this function has already been called once
12919 -- and returned True (in which case the result is cached), and also
12920 -- types to which a pragma Preelaborable_Initialization applies.
12922 if Known_To_Have_Preelab_Init (E) then
12926 -- If the type is a subtype representing a generic actual type, then
12927 -- test whether its base type has preelaborable initialization since
12928 -- the subtype representing the actual does not inherit this attribute
12929 -- from the actual or formal. (but maybe it should???)
12931 if Is_Generic_Actual_Type (E) then
12932 return Has_Preelaborable_Initialization (Base_Type (E));
12935 -- All elementary types have preelaborable initialization
12937 if Is_Elementary_Type (E) then
12940 -- Array types have PI if the component type has PI
12942 elsif Is_Array_Type (E) then
12943 Has_PE := Has_Preelaborable_Initialization
12944 (Component_Type (E), Preelab_Init_Expr);
12946 -- A derived type has preelaborable initialization if its parent type
12947 -- has preelaborable initialization and (in the case of a derived record
12948 -- extension) if the non-inherited components all have preelaborable
12949 -- initialization. However, a user-defined controlled type with an
12950 -- overriding Initialize procedure does not have preelaborable
12953 elsif Is_Derived_Type (E) then
12955 -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component
12956 -- of a generic formal derived type has preelaborable initialization.
12957 -- (See comment on spec of Has_Preelaborable_Initialization.)
12959 if Is_Generic_Type (E)
12960 and then Present (Preelab_Init_Expr)
12962 Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr)
12967 -- If the derived type is a private extension then it doesn't have
12968 -- preelaborable initialization.
12970 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
12974 -- First check whether ancestor type has preelaborable initialization
12976 Has_PE := Has_Preelaborable_Initialization
12977 (Etype (Base_Type (E)), Preelab_Init_Expr);
12979 -- If OK, check extension components (if any)
12981 if Has_PE and then Is_Record_Type (E) then
12982 Check_Components (E);
12985 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
12986 -- with a user defined Initialize procedure does not have PI. If
12987 -- the type is untagged, the control primitives come from a component
12988 -- that has already been checked.
12991 and then Is_Controlled (E)
12992 and then Is_Tagged_Type (E)
12993 and then Has_Overriding_Initialize (E)
12998 -- Private types not derived from a type having preelaborable init and
12999 -- that are not marked with pragma Preelaborable_Initialization do not
13000 -- have preelaborable initialization.
13002 elsif Is_Private_Type (E) then
13004 -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component
13005 -- of a generic formal private type has preelaborable initialization.
13006 -- (See comment on spec of Has_Preelaborable_Initialization.)
13008 if Is_Generic_Type (E)
13009 and then Present (Preelab_Init_Expr)
13011 Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr)
13018 -- Record type has PI if it is non private and all components have PI
13020 elsif Is_Record_Type (E) then
13022 Check_Components (E);
13024 -- Protected types must not have entries, and components must meet
13025 -- same set of rules as for record components.
13027 elsif Is_Protected_Type (E) then
13028 if Has_Entries (E) then
13032 Check_Components (E);
13035 -- Type System.Address always has preelaborable initialization
13037 elsif Is_RTE (E, RE_Address) then
13040 -- In all other cases, type does not have preelaborable initialization
13046 -- If type has preelaborable initialization, cache result
13049 Set_Known_To_Have_Preelab_Init (E);
13053 end Has_Preelaborable_Initialization;
13059 function Has_Prefix (N : Node_Id) return Boolean is
13061 return Nkind (N) in
13062 N_Attribute_Reference | N_Expanded_Name | N_Explicit_Dereference |
13063 N_Indexed_Component | N_Reference | N_Selected_Component |
13067 ---------------------------
13068 -- Has_Private_Component --
13069 ---------------------------
13071 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
13072 Btype : Entity_Id := Base_Type (Type_Id);
13073 Component : Entity_Id;
13076 if Error_Posted (Type_Id)
13077 or else Error_Posted (Btype)
13082 if Is_Class_Wide_Type (Btype) then
13083 Btype := Root_Type (Btype);
13086 if Is_Private_Type (Btype) then
13088 UT : constant Entity_Id := Underlying_Type (Btype);
13091 if No (Full_View (Btype)) then
13092 return not Is_Generic_Type (Btype)
13094 not Is_Generic_Type (Root_Type (Btype));
13096 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
13099 return not Is_Frozen (UT) and then Has_Private_Component (UT);
13103 elsif Is_Array_Type (Btype) then
13104 return Has_Private_Component (Component_Type (Btype));
13106 elsif Is_Record_Type (Btype) then
13107 Component := First_Component (Btype);
13108 while Present (Component) loop
13109 if Has_Private_Component (Etype (Component)) then
13113 Next_Component (Component);
13118 elsif Is_Protected_Type (Btype)
13119 and then Present (Corresponding_Record_Type (Btype))
13121 return Has_Private_Component (Corresponding_Record_Type (Btype));
13126 end Has_Private_Component;
13128 --------------------------------
13129 -- Has_Relaxed_Initialization --
13130 --------------------------------
13132 function Has_Relaxed_Initialization (E : Entity_Id) return Boolean is
13134 function Denotes_Relaxed_Parameter
13138 -- Returns True iff expression Expr denotes a formal parameter or
13139 -- function Param (through its attribute Result).
13141 -------------------------------
13142 -- Denotes_Relaxed_Parameter --
13143 -------------------------------
13145 function Denotes_Relaxed_Parameter
13147 Param : Entity_Id) return Boolean is
13149 if Nkind (Expr) in N_Identifier | N_Expanded_Name then
13150 return Entity (Expr) = Param;
13152 pragma Assert (Is_Attribute_Result (Expr));
13153 return Entity (Prefix (Expr)) = Param;
13155 end Denotes_Relaxed_Parameter;
13157 -- Start of processing for Has_Relaxed_Initialization
13160 -- When analyzing, we checked all syntax legality rules for the aspect
13161 -- Relaxed_Initialization, but didn't store the property anywhere (e.g.
13162 -- as an Einfo flag). To query the property we look directly at the AST,
13163 -- but now without any syntactic checks.
13166 -- Abstract states have option Relaxed_Initialization
13168 when E_Abstract_State =>
13169 return Is_Relaxed_Initialization_State (E);
13171 -- Constants have this aspect attached directly; for deferred
13172 -- constants, the aspect is attached to the partial view.
13175 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13177 -- Variables have this aspect attached directly
13180 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13182 -- Types have this aspect attached directly (though we only allow it
13183 -- to be specified for the first subtype). For private types, the
13184 -- aspect is attached to the partial view.
13187 pragma Assert (Is_First_Subtype (E));
13188 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13190 -- Formal parameters and functions have the Relaxed_Initialization
13191 -- aspect attached to the subprogram entity and must be listed in
13192 -- the aspect expression.
13198 Subp_Id : Entity_Id;
13199 Aspect_Expr : Node_Id;
13200 Param_Expr : Node_Id;
13204 if Is_Formal (E) then
13205 Subp_Id := Scope (E);
13210 if Has_Aspect (Subp_Id, Aspect_Relaxed_Initialization) then
13212 Find_Value_Of_Aspect
13213 (Subp_Id, Aspect_Relaxed_Initialization);
13215 -- Aspect expression is either an aggregate with an optional
13216 -- Boolean expression (which defaults to True), e.g.:
13218 -- function F (X : Integer) return Integer
13219 -- with Relaxed_Initialization => (X => True, F'Result);
13221 if Nkind (Aspect_Expr) = N_Aggregate then
13223 if Present (Component_Associations (Aspect_Expr)) then
13224 Assoc := First (Component_Associations (Aspect_Expr));
13226 while Present (Assoc) loop
13227 if Denotes_Relaxed_Parameter
13228 (First (Choices (Assoc)), E)
13232 (Static_Boolean (Expression (Assoc)));
13239 Param_Expr := First (Expressions (Aspect_Expr));
13241 while Present (Param_Expr) loop
13242 if Denotes_Relaxed_Parameter (Param_Expr, E) then
13251 -- or it is a single identifier, e.g.:
13253 -- function F (X : Integer) return Integer
13254 -- with Relaxed_Initialization => X;
13257 return Denotes_Relaxed_Parameter (Aspect_Expr, E);
13265 raise Program_Error;
13267 end Has_Relaxed_Initialization;
13269 ----------------------
13270 -- Has_Signed_Zeros --
13271 ----------------------
13273 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
13275 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target;
13276 end Has_Signed_Zeros;
13278 ------------------------------
13279 -- Has_Significant_Contract --
13280 ------------------------------
13282 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is
13283 Subp_Nam : constant Name_Id := Chars (Subp_Id);
13286 -- _Finalizer procedure
13288 if Subp_Nam = Name_uFinalizer then
13291 -- _Wrapped_Statements procedure which gets generated as part of the
13292 -- expansion of postconditions.
13294 elsif Subp_Nam = Name_uWrapped_Statements then
13297 -- Predicate function
13299 elsif Ekind (Subp_Id) = E_Function
13300 and then Is_Predicate_Function (Subp_Id)
13306 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then
13312 end Has_Significant_Contract;
13314 -----------------------------
13315 -- Has_Static_Array_Bounds --
13316 -----------------------------
13318 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
13319 All_Static : Boolean;
13323 Examine_Array_Bounds (Typ, All_Static, Dummy);
13326 end Has_Static_Array_Bounds;
13328 ---------------------------------------
13329 -- Has_Static_Non_Empty_Array_Bounds --
13330 ---------------------------------------
13332 function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is
13333 All_Static : Boolean;
13334 Has_Empty : Boolean;
13337 Examine_Array_Bounds (Typ, All_Static, Has_Empty);
13339 return All_Static and not Has_Empty;
13340 end Has_Static_Non_Empty_Array_Bounds;
13346 function Has_Stream (T : Entity_Id) return Boolean is
13353 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
13356 elsif Is_Array_Type (T) then
13357 return Has_Stream (Component_Type (T));
13359 elsif Is_Record_Type (T) then
13360 E := First_Component (T);
13361 while Present (E) loop
13362 if Has_Stream (Etype (E)) then
13365 Next_Component (E);
13371 elsif Is_Private_Type (T) then
13372 return Has_Stream (Underlying_Type (T));
13383 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
13385 Get_Name_String (Chars (E));
13386 return Name_Buffer (Name_Len) = Suffix;
13393 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
13395 Get_Name_String (Chars (E));
13396 Add_Char_To_Name_Buffer (Suffix);
13400 -------------------
13401 -- Remove_Suffix --
13402 -------------------
13404 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
13406 pragma Assert (Has_Suffix (E, Suffix));
13407 Get_Name_String (Chars (E));
13408 Name_Len := Name_Len - 1;
13412 ----------------------------------
13413 -- Replace_Null_By_Null_Address --
13414 ----------------------------------
13416 procedure Replace_Null_By_Null_Address (N : Node_Id) is
13417 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id);
13418 -- Replace operand Op with a reference to Null_Address when the operand
13419 -- denotes a null Address. Other_Op denotes the other operand.
13421 --------------------------
13422 -- Replace_Null_Operand --
13423 --------------------------
13425 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is
13427 -- Check the type of the complementary operand since the N_Null node
13428 -- has not been decorated yet.
13430 if Nkind (Op) = N_Null
13431 and then Is_Descendant_Of_Address (Etype (Other_Op))
13433 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op)));
13435 end Replace_Null_Operand;
13437 -- Start of processing for Replace_Null_By_Null_Address
13440 pragma Assert (Relaxed_RM_Semantics);
13441 pragma Assert (Nkind (N) in N_Null | N_Op_Compare);
13443 if Nkind (N) = N_Null then
13444 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
13448 L : constant Node_Id := Left_Opnd (N);
13449 R : constant Node_Id := Right_Opnd (N);
13452 Replace_Null_Operand (L, Other_Op => R);
13453 Replace_Null_Operand (R, Other_Op => L);
13456 end Replace_Null_By_Null_Address;
13458 --------------------------
13459 -- Has_Tagged_Component --
13460 --------------------------
13462 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
13466 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then
13467 return Has_Tagged_Component (Underlying_Type (Typ));
13469 elsif Is_Array_Type (Typ) then
13470 return Has_Tagged_Component (Component_Type (Typ));
13472 elsif Is_Tagged_Type (Typ) then
13475 elsif Is_Record_Type (Typ) then
13476 Comp := First_Component (Typ);
13477 while Present (Comp) loop
13478 if Has_Tagged_Component (Etype (Comp)) then
13482 Next_Component (Comp);
13490 end Has_Tagged_Component;
13492 -----------------------------
13493 -- Has_Undefined_Reference --
13494 -----------------------------
13496 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is
13497 Has_Undef_Ref : Boolean := False;
13498 -- Flag set when expression Expr contains at least one undefined
13501 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result;
13502 -- Determine whether N denotes a reference and if it does, whether it is
13505 ----------------------------
13506 -- Is_Undefined_Reference --
13507 ----------------------------
13509 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is
13511 if Is_Entity_Name (N)
13512 and then Present (Entity (N))
13513 and then Entity (N) = Any_Id
13515 Has_Undef_Ref := True;
13520 end Is_Undefined_Reference;
13522 procedure Find_Undefined_References is
13523 new Traverse_Proc (Is_Undefined_Reference);
13525 -- Start of processing for Has_Undefined_Reference
13528 Find_Undefined_References (Expr);
13530 return Has_Undef_Ref;
13531 end Has_Undefined_Reference;
13533 ----------------------------------------
13534 -- Has_Effectively_Volatile_Component --
13535 ----------------------------------------
13537 function Has_Effectively_Volatile_Component
13538 (Typ : Entity_Id) return Boolean
13543 if Has_Volatile_Components (Typ) then
13546 elsif Is_Array_Type (Typ) then
13547 return Is_Effectively_Volatile (Component_Type (Typ));
13549 elsif Is_Record_Type (Typ) then
13550 Comp := First_Component (Typ);
13551 while Present (Comp) loop
13552 if Is_Effectively_Volatile (Etype (Comp)) then
13556 Next_Component (Comp);
13561 end Has_Effectively_Volatile_Component;
13563 ----------------------------
13564 -- Has_Volatile_Component --
13565 ----------------------------
13567 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is
13571 if Has_Volatile_Components (Typ) then
13574 elsif Is_Array_Type (Typ) then
13575 return Is_Volatile (Component_Type (Typ));
13577 elsif Is_Record_Type (Typ) then
13578 Comp := First_Component (Typ);
13579 while Present (Comp) loop
13580 if Is_Volatile_Object_Ref (Comp) then
13584 Next_Component (Comp);
13589 end Has_Volatile_Component;
13591 -------------------------
13592 -- Implementation_Kind --
13593 -------------------------
13595 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
13596 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
13599 pragma Assert (Present (Impl_Prag));
13600 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
13601 return Chars (Get_Pragma_Arg (Arg));
13602 end Implementation_Kind;
13604 --------------------------
13605 -- Implements_Interface --
13606 --------------------------
13608 function Implements_Interface
13609 (Typ_Ent : Entity_Id;
13610 Iface_Ent : Entity_Id;
13611 Exclude_Parents : Boolean := False) return Boolean
13613 Ifaces_List : Elist_Id;
13615 Iface : Entity_Id := Base_Type (Iface_Ent);
13616 Typ : Entity_Id := Base_Type (Typ_Ent);
13619 if Is_Class_Wide_Type (Typ) then
13620 Typ := Root_Type (Typ);
13623 if not Has_Interfaces (Typ) then
13627 if Is_Class_Wide_Type (Iface) then
13628 Iface := Root_Type (Iface);
13631 Collect_Interfaces (Typ, Ifaces_List);
13633 Elmt := First_Elmt (Ifaces_List);
13634 while Present (Elmt) loop
13635 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
13636 and then Exclude_Parents
13640 elsif Node (Elmt) = Iface then
13648 end Implements_Interface;
13650 --------------------------------
13651 -- Implicitly_Designated_Type --
13652 --------------------------------
13654 function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id is
13655 Desig : constant Entity_Id := Designated_Type (Typ);
13658 -- An implicit dereference is a legal occurrence of an incomplete type
13659 -- imported through a limited_with clause, if the full view is visible.
13661 if Is_Incomplete_Type (Desig)
13662 and then From_Limited_With (Desig)
13663 and then not From_Limited_With (Scope (Desig))
13665 (Is_Immediately_Visible (Scope (Desig))
13667 (Is_Child_Unit (Scope (Desig))
13668 and then Is_Visible_Lib_Unit (Scope (Desig))))
13670 return Available_View (Desig);
13674 end Implicitly_Designated_Type;
13676 ------------------------------------
13677 -- In_Assertion_Expression_Pragma --
13678 ------------------------------------
13680 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is
13682 Prag : Node_Id := Empty;
13685 -- Climb the parent chain looking for an enclosing pragma
13688 while Present (Par) loop
13689 if Nkind (Par) = N_Pragma then
13693 -- Precondition-like pragmas are expanded into if statements, check
13694 -- the original node instead.
13696 elsif Nkind (Original_Node (Par)) = N_Pragma then
13697 Prag := Original_Node (Par);
13700 -- The expansion of attribute 'Old generates a
constant to capture
13701 -- the result of the prefix. If the parent traversal reaches
13702 -- one of these constants, then the node technically came from a
13703 -- postcondition-like pragma. Note that the Ekind is not tested here
13704 -- because N may be the expression of an object declaration which is
13705 -- currently being analyzed. Such objects carry Ekind of E_Void.
13707 elsif Nkind
(Par
) = N_Object_Declaration
13708 and then Constant_Present
(Par
)
13709 and then Stores_Attribute_Old_Prefix
(Defining_Entity
(Par
))
13713 -- Prevent the search from going too far
13715 elsif Is_Body_Or_Package_Declaration
(Par
) then
13719 Par
:= Parent
(Par
);
13724 and then Assertion_Expression_Pragma
(Get_Pragma_Id
(Prag
));
13725 end In_Assertion_Expression_Pragma
;
13727 -------------------
13728 -- In_Check_Node --
13729 -------------------
13731 function In_Check_Node
(N
: Node_Id
) return Boolean is
13732 Par
: Node_Id
:= Parent
(N
);
13734 while Present
(Par
) loop
13735 if Nkind
(Par
) in N_Raise_xxx_Error
then
13738 -- Prevent the search from going too far
13740 elsif Is_Body_Or_Package_Declaration
(Par
) then
13744 Par
:= Parent
(Par
);
13751 -------------------------------
13752 -- In_Generic_Formal_Package --
13753 -------------------------------
13755 function In_Generic_Formal_Package
(E
: Entity_Id
) return Boolean is
13760 while Present
(Par
) loop
13761 if Nkind
(Par
) = N_Formal_Package_Declaration
13762 or else Nkind
(Original_Node
(Par
)) = N_Formal_Package_Declaration
13767 Par
:= Parent
(Par
);
13771 end In_Generic_Formal_Package
;
13773 ----------------------
13774 -- In_Generic_Scope --
13775 ----------------------
13777 function In_Generic_Scope
(E
: Entity_Id
) return Boolean is
13782 while Present
(S
) and then S
/= Standard_Standard
loop
13783 if Is_Generic_Unit
(S
) then
13791 end In_Generic_Scope
;
13797 function In_Instance
return Boolean is
13798 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
13802 S
:= Current_Scope
;
13803 while Present
(S
) and then S
/= Standard_Standard
loop
13804 if Is_Generic_Instance
(S
) then
13806 -- A child instance is always compiled in the context of a parent
13807 -- instance. Nevertheless, its actuals must not be analyzed in an
13808 -- instance context. We detect this case by examining the current
13809 -- compilation unit, which must be a child instance, and checking
13810 -- that it has not been analyzed yet.
13812 if Is_Child_Unit
(Curr_Unit
)
13813 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
13814 N_Package_Instantiation
13815 and then Ekind
(Curr_Unit
) = E_Void
13829 ----------------------
13830 -- In_Instance_Body --
13831 ----------------------
13833 function In_Instance_Body
return Boolean is
13837 S
:= Current_Scope
;
13838 while Present
(S
) and then S
/= Standard_Standard
loop
13839 if Ekind
(S
) in E_Function | E_Procedure
13840 and then Is_Generic_Instance
(S
)
13844 elsif Ekind
(S
) = E_Package
13845 and then In_Package_Body
(S
)
13846 and then Is_Generic_Instance
(S
)
13855 end In_Instance_Body
;
13857 -----------------------------
13858 -- In_Instance_Not_Visible --
13859 -----------------------------
13861 function In_Instance_Not_Visible
return Boolean is
13865 S
:= Current_Scope
;
13866 while Present
(S
) and then S
/= Standard_Standard
loop
13867 if Ekind
(S
) in E_Function | E_Procedure
13868 and then Is_Generic_Instance
(S
)
13872 elsif Ekind
(S
) = E_Package
13873 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
13874 and then Is_Generic_Instance
(S
)
13883 end In_Instance_Not_Visible
;
13885 ------------------------------
13886 -- In_Instance_Visible_Part --
13887 ------------------------------
13889 function In_Instance_Visible_Part
13890 (Id
: Entity_Id
:= Current_Scope
) return Boolean
13896 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
13897 if Ekind
(Inst
) = E_Package
13898 and then Is_Generic_Instance
(Inst
)
13899 and then not In_Package_Body
(Inst
)
13900 and then not In_Private_Part
(Inst
)
13905 Inst
:= Scope
(Inst
);
13909 end In_Instance_Visible_Part
;
13911 ---------------------
13912 -- In_Package_Body --
13913 ---------------------
13915 function In_Package_Body
return Boolean is
13919 S
:= Current_Scope
;
13920 while Present
(S
) and then S
/= Standard_Standard
loop
13921 if Ekind
(S
) = E_Package
and then In_Package_Body
(S
) then
13929 end In_Package_Body
;
13931 --------------------------
13932 -- In_Pragma_Expression --
13933 --------------------------
13935 function In_Pragma_Expression
(N
: Node_Id
; Nam
: Name_Id
) return Boolean is
13943 -- Prevent the search from going too far
13945 elsif Is_Body_Or_Package_Declaration
(P
) then
13948 elsif Nkind
(P
) = N_Pragma
and then Pragma_Name
(P
) = Nam
then
13955 end In_Pragma_Expression
;
13957 ---------------------------
13958 -- In_Pre_Post_Condition --
13959 ---------------------------
13961 function In_Pre_Post_Condition
13962 (N
: Node_Id
; Class_Wide_Only
: Boolean := False) return Boolean
13965 Prag
: Node_Id
:= Empty
;
13966 Prag_Id
: Pragma_Id
;
13969 -- Climb the parent chain looking for an enclosing pragma
13972 while Present
(Par
) loop
13973 if Nkind
(Par
) = N_Pragma
then
13977 -- Prevent the search from going too far
13979 elsif Is_Body_Or_Package_Declaration
(Par
) then
13983 Par
:= Parent
(Par
);
13986 if Present
(Prag
) then
13987 Prag_Id
:= Get_Pragma_Id
(Prag
);
13989 if Class_Wide_Only
then
13991 Prag_Id
= Pragma_Post_Class
13992 or else Prag_Id
= Pragma_Pre_Class
13993 or else (Class_Present
(Prag
)
13994 and then (Prag_Id
= Pragma_Post
13995 or else Prag_Id
= Pragma_Postcondition
13996 or else Prag_Id
= Pragma_Pre
13997 or else Prag_Id
= Pragma_Precondition
));
14000 Prag_Id
= Pragma_Post
14001 or else Prag_Id
= Pragma_Post_Class
14002 or else Prag_Id
= Pragma_Postcondition
14003 or else Prag_Id
= Pragma_Pre
14004 or else Prag_Id
= Pragma_Pre_Class
14005 or else Prag_Id
= Pragma_Precondition
;
14008 -- Otherwise the node is not enclosed by a pre/postcondition pragma
14013 end In_Pre_Post_Condition
;
14015 ------------------------------
14016 -- In_Quantified_Expression --
14017 ------------------------------
14019 function In_Quantified_Expression
(N
: Node_Id
) return Boolean is
14027 -- Prevent the search from going too far
14029 elsif Is_Body_Or_Package_Declaration
(P
) then
14032 elsif Nkind
(P
) = N_Quantified_Expression
then
14038 end In_Quantified_Expression
;
14040 -------------------------------------
14041 -- In_Reverse_Storage_Order_Object --
14042 -------------------------------------
14044 function In_Reverse_Storage_Order_Object
(N
: Node_Id
) return Boolean is
14046 Btyp
: Entity_Id
:= Empty
;
14049 -- Climb up indexed components
14053 case Nkind
(Pref
) is
14054 when N_Selected_Component
=>
14055 Pref
:= Prefix
(Pref
);
14058 when N_Indexed_Component
=>
14059 Pref
:= Prefix
(Pref
);
14067 if Present
(Pref
) then
14068 Btyp
:= Base_Type
(Etype
(Pref
));
14071 return Present
(Btyp
)
14072 and then (Is_Record_Type
(Btyp
) or else Is_Array_Type
(Btyp
))
14073 and then Reverse_Storage_Order
(Btyp
);
14074 end In_Reverse_Storage_Order_Object
;
14076 ------------------------------
14077 -- In_Same_Declarative_Part --
14078 ------------------------------
14080 function In_Same_Declarative_Part
14081 (Context
: Node_Id
;
14082 N
: Node_Id
) return Boolean
14084 Cont
: Node_Id
:= Context
;
14088 if Nkind
(Cont
) = N_Compilation_Unit_Aux
then
14089 Cont
:= Parent
(Cont
);
14093 while Present
(Nod
) loop
14097 elsif Nkind
(Nod
) in N_Accept_Statement
14098 | N_Block_Statement
14099 | N_Compilation_Unit
14102 | N_Package_Declaration
14104 | N_Subprogram_Body
14109 elsif Nkind
(Nod
) = N_Subunit
then
14110 Nod
:= Corresponding_Stub
(Nod
);
14113 Nod
:= Parent
(Nod
);
14118 end In_Same_Declarative_Part
;
14120 --------------------------------------
14121 -- In_Subprogram_Or_Concurrent_Unit --
14122 --------------------------------------
14124 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
14129 -- Use scope chain to check successively outer scopes
14131 E
:= Current_Scope
;
14135 if K
in Subprogram_Kind
14136 or else K
in Concurrent_Kind
14137 or else K
in Generic_Subprogram_Kind
14141 elsif E
= Standard_Standard
then
14147 end In_Subprogram_Or_Concurrent_Unit
;
14153 function In_Subtree
(N
: Node_Id
; Root
: Node_Id
) return Boolean is
14158 while Present
(Curr
) loop
14159 if Curr
= Root
then
14163 Curr
:= Parent
(Curr
);
14173 function In_Subtree
14176 Root2
: Node_Id
) return Boolean
14182 while Present
(Curr
) loop
14183 if Curr
= Root1
or else Curr
= Root2
then
14187 Curr
:= Parent
(Curr
);
14193 ---------------------
14194 -- In_Return_Value --
14195 ---------------------
14197 function In_Return_Value
(Expr
: Node_Id
) return Boolean is
14199 Prev_Par
: Node_Id
;
14201 In_Function_Call
: Boolean := False;
14204 -- Move through parent nodes to determine if Expr contributes to the
14205 -- return value of the current subprogram.
14209 while Present
(Par
) loop
14211 case Nkind
(Par
) is
14212 -- Ignore ranges and they don't contribute to the result
14217 -- An object declaration whose parent is an extended return
14218 -- statement is a return object.
14220 when N_Object_Declaration
=>
14221 if Present
(Parent
(Par
))
14222 and then Nkind
(Parent
(Par
)) = N_Extended_Return_Statement
14227 -- We hit a simple return statement, so we know we are in one
14229 when N_Simple_Return_Statement
=>
14232 -- Only include one nexting level of function calls
14234 when N_Function_Call
=>
14235 if not In_Function_Call
then
14236 In_Function_Call
:= True;
14238 -- When the function return type has implicit dereference
14239 -- specified we know it cannot directly contribute to the
14242 if Present
(Etype
(Par
))
14243 and then Has_Implicit_Dereference
14244 (Get_Full_View
(Etype
(Par
)))
14252 -- Check if we are on the right-hand side of an assignment
14253 -- statement to a return object.
14255 -- This is not specified in the RM ???
14257 when N_Assignment_Statement
=>
14258 if Prev_Par
= Name
(Par
) then
14263 while Present
(Pre
) loop
14264 if Is_Entity_Name
(Pre
)
14265 and then Is_Return_Object
(Entity
(Pre
))
14270 exit when Nkind
(Pre
) not in N_Selected_Component
14271 | N_Indexed_Component
14274 Pre
:= Prefix
(Pre
);
14277 -- Otherwise, we hit a master which was not relevant
14280 if Is_Master
(Par
) then
14285 -- Iterate up to the next parent, keeping track of the previous one
14288 Par
:= Parent
(Par
);
14292 end In_Return_Value
;
14294 -----------------------------------------
14295 -- In_Statement_Condition_With_Actions --
14296 -----------------------------------------
14298 function In_Statement_Condition_With_Actions
(N
: Node_Id
) return Boolean is
14299 Prev
: Node_Id
:= N
;
14300 P
: Node_Id
:= Parent
(N
);
14301 -- P and Prev will be used for traversing the AST, while maintaining an
14302 -- invariant that P = Parent (Prev).
14304 while Present
(P
) loop
14305 if Nkind
(P
) = N_Iteration_Scheme
14306 and then Prev
= Condition
(P
)
14310 elsif Nkind
(P
) = N_Elsif_Part
14311 and then Prev
= Condition
(P
)
14315 -- No point in going beyond statements
14317 elsif Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
14318 | N_Procedure_Call_Statement
14322 -- Prevent the search from going too far
14324 elsif Is_Body_Or_Package_Declaration
(P
) then
14333 end In_Statement_Condition_With_Actions
;
14335 ---------------------
14336 -- In_Visible_Part --
14337 ---------------------
14339 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
14341 return Is_Package_Or_Generic_Package
(Scope_Id
)
14342 and then In_Open_Scopes
(Scope_Id
)
14343 and then not In_Package_Body
(Scope_Id
)
14344 and then not In_Private_Part
(Scope_Id
);
14345 end In_Visible_Part
;
14347 --------------------------------
14348 -- Incomplete_Or_Partial_View --
14349 --------------------------------
14351 function Incomplete_Or_Partial_View
(Id
: Entity_Id
) return Entity_Id
is
14352 S
: constant Entity_Id
:= Scope
(Id
);
14354 function Inspect_Decls
14356 Taft
: Boolean := False) return Entity_Id
;
14357 -- Check whether a declarative region contains the incomplete or partial
14360 -------------------
14361 -- Inspect_Decls --
14362 -------------------
14364 function Inspect_Decls
14366 Taft
: Boolean := False) return Entity_Id
14372 Decl
:= First
(Decls
);
14373 while Present
(Decl
) loop
14376 -- The partial view of a Taft-amendment type is an incomplete
14380 if Nkind
(Decl
) = N_Incomplete_Type_Declaration
then
14381 Match
:= Defining_Identifier
(Decl
);
14384 -- Otherwise look for a private type whose full view matches the
14385 -- input type. Note that this checks full_type_declaration nodes
14386 -- to account for derivations from a private type where the type
14387 -- declaration hold the partial view and the full view is an
14390 elsif Nkind
(Decl
) in N_Full_Type_Declaration
14391 | N_Private_Extension_Declaration
14392 | N_Private_Type_Declaration
14394 Match
:= Defining_Identifier
(Decl
);
14397 -- Guard against unanalyzed entities
14400 and then Is_Type
(Match
)
14401 and then Present
(Full_View
(Match
))
14402 and then Full_View
(Match
) = Id
14417 -- Start of processing for Incomplete_Or_Partial_View
14420 -- Deferred constant or incomplete type case
14422 Prev
:= Current_Entity
(Id
);
14424 while Present
(Prev
) loop
14425 exit when Scope
(Prev
) = S
;
14427 Prev
:= Homonym
(Prev
);
14431 and then (Is_Incomplete_Type
(Prev
) or else Ekind
(Prev
) = E_Constant
)
14432 and then Present
(Full_View
(Prev
))
14433 and then Full_View
(Prev
) = Id
14438 -- Private or Taft amendment type case
14440 if Present
(S
) and then Is_Package_Or_Generic_Package
(S
) then
14442 Pkg_Decl
: constant Node_Id
:= Package_Specification
(S
);
14445 -- It is knows that Typ has a private view, look for it in the
14446 -- visible declarations of the enclosing scope. A special case
14447 -- of this is when the two views have been exchanged - the full
14448 -- appears earlier than the private.
14450 if Has_Private_Declaration
(Id
) then
14451 Prev
:= Inspect_Decls
(Visible_Declarations
(Pkg_Decl
));
14453 -- Exchanged view case, look in the private declarations
14456 Prev
:= Inspect_Decls
(Private_Declarations
(Pkg_Decl
));
14461 -- Otherwise if this is the package body, then Typ is a potential
14462 -- Taft amendment type. The incomplete view should be located in
14463 -- the private declarations of the enclosing scope.
14465 elsif In_Package_Body
(S
) then
14466 return Inspect_Decls
(Private_Declarations
(Pkg_Decl
), True);
14471 -- The type has no incomplete or private view
14474 end Incomplete_Or_Partial_View
;
14476 ---------------------------------------
14477 -- Incomplete_View_From_Limited_With --
14478 ---------------------------------------
14480 function Incomplete_View_From_Limited_With
14481 (Typ
: Entity_Id
) return Entity_Id
14484 -- It might make sense to make this an attribute in Einfo, and set it
14485 -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on
14486 -- slots for new attributes, and it seems a bit simpler to just search
14487 -- the Limited_View (if it exists) for an incomplete type whose
14488 -- Non_Limited_View is Typ.
14490 if Ekind
(Scope
(Typ
)) = E_Package
14491 and then Present
(Limited_View
(Scope
(Typ
)))
14494 Ent
: Entity_Id
:= First_Entity
(Limited_View
(Scope
(Typ
)));
14496 while Present
(Ent
) loop
14497 if Is_Incomplete_Type
(Ent
)
14498 and then Non_Limited_View
(Ent
) = Typ
14509 end Incomplete_View_From_Limited_With
;
14511 ----------------------------------
14512 -- Indexed_Component_Bit_Offset --
14513 ----------------------------------
14515 function Indexed_Component_Bit_Offset
(N
: Node_Id
) return Uint
is
14516 Exp
: constant Node_Id
:= First
(Expressions
(N
));
14517 Typ
: constant Entity_Id
:= Etype
(Prefix
(N
));
14518 Off
: constant Uint
:= Component_Size
(Typ
);
14522 -- Return early if the component size is not known or variable
14524 if No
(Off
) or else Off
< Uint_0
then
14528 -- Deal with the degenerate case of an empty component
14530 if Off
= Uint_0
then
14534 -- Check that both the index value and the low bound are known
14536 if not Compile_Time_Known_Value
(Exp
) then
14540 Ind
:= First_Index
(Typ
);
14545 -- Do not attempt to compute offsets within multi-dimensional arrays
14547 if Present
(Next_Index
(Ind
)) then
14551 if Nkind
(Ind
) = N_Subtype_Indication
then
14552 Ind
:= Constraint
(Ind
);
14554 if Nkind
(Ind
) = N_Range_Constraint
then
14555 Ind
:= Range_Expression
(Ind
);
14559 if Nkind
(Ind
) /= N_Range
14560 or else not Compile_Time_Known_Value
(Low_Bound
(Ind
))
14565 -- Return the scaled offset
14567 return Off
* (Expr_Value
(Exp
) - Expr_Value
(Low_Bound
(Ind
)));
14568 end Indexed_Component_Bit_Offset
;
14570 -----------------------------
14571 -- Inherit_Predicate_Flags --
14572 -----------------------------
14574 procedure Inherit_Predicate_Flags
(Subt
, Par
: Entity_Id
) is
14576 if Ada_Version
< Ada_2012
14577 or else Present
(Predicate_Function
(Subt
))
14582 Set_Has_Predicates
(Subt
, Has_Predicates
(Par
));
14583 Set_Has_Static_Predicate_Aspect
14584 (Subt
, Has_Static_Predicate_Aspect
(Par
));
14585 Set_Has_Dynamic_Predicate_Aspect
14586 (Subt
, Has_Dynamic_Predicate_Aspect
(Par
));
14588 -- A named subtype does not inherit the predicate function of its
14589 -- parent but an itype declared for a loop index needs the discrete
14590 -- predicate information of its parent to execute the loop properly.
14591 -- A non-discrete type may has a static predicate (for example True)
14592 -- but has no static_discrete_predicate.
14594 if Is_Itype
(Subt
) and then Present
(Predicate_Function
(Par
)) then
14595 Set_Subprograms_For_Type
(Subt
, Subprograms_For_Type
(Par
));
14597 if Has_Static_Predicate
(Par
) and then Is_Discrete_Type
(Par
) then
14598 Set_Static_Discrete_Predicate
14599 (Subt
, Static_Discrete_Predicate
(Par
));
14602 end Inherit_Predicate_Flags
;
14604 ----------------------------
14605 -- Inherit_Rep_Item_Chain --
14606 ----------------------------
14608 procedure Inherit_Rep_Item_Chain
(Typ
: Entity_Id
; From_Typ
: Entity_Id
) is
14610 Next_Item
: Node_Id
;
14613 -- There are several inheritance scenarios to consider depending on
14614 -- whether both types have rep item chains and whether the destination
14615 -- type already inherits part of the source type's rep item chain.
14617 -- 1) The source type lacks a rep item chain
14618 -- From_Typ ---> Empty
14620 -- Typ --------> Item (or Empty)
14622 -- In this case inheritance cannot take place because there are no items
14625 -- 2) The destination type lacks a rep item chain
14626 -- From_Typ ---> Item ---> ...
14628 -- Typ --------> Empty
14630 -- Inheritance takes place by setting the First_Rep_Item of the
14631 -- destination type to the First_Rep_Item of the source type.
14632 -- From_Typ ---> Item ---> ...
14634 -- Typ -----------+
14636 -- 3.1) Both source and destination types have at least one rep item.
14637 -- The destination type does NOT inherit a rep item from the source
14639 -- From_Typ ---> Item ---> Item
14641 -- Typ --------> Item ---> Item
14643 -- Inheritance takes place by setting the Next_Rep_Item of the last item
14644 -- of the destination type to the First_Rep_Item of the source type.
14645 -- From_Typ -------------------> Item ---> Item
14647 -- Typ --------> Item ---> Item --+
14649 -- 3.2) Both source and destination types have at least one rep item.
14650 -- The destination type DOES inherit part of the rep item chain of the
14652 -- From_Typ ---> Item ---> Item ---> Item
14654 -- Typ --------> Item ------+
14656 -- This rare case arises when the full view of a private extension must
14657 -- inherit the rep item chain from the full view of its parent type and
14658 -- the full view of the parent type contains extra rep items. Currently
14659 -- only invariants may lead to such form of inheritance.
14661 -- type From_Typ is tagged private
14662 -- with Type_Invariant'Class => Item_2;
14664 -- type Typ is new From_Typ with private
14665 -- with Type_Invariant => Item_4;
14667 -- At this point the rep item chains contain the following items
14669 -- From_Typ -----------> Item_2 ---> Item_3
14671 -- Typ --------> Item_4 --+
14673 -- The full views of both types may introduce extra invariants
14675 -- type From_Typ is tagged null record
14676 -- with Type_Invariant => Item_1;
14678 -- type Typ is new From_Typ with null record;
14680 -- The full view of Typ would have to inherit any new rep items added to
14681 -- the full view of From_Typ.
14683 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
14685 -- Typ --------> Item_4 --+
14687 -- To achieve this form of inheritance, the destination type must first
14688 -- sever the link between its own rep chain and that of the source type,
14689 -- then inheritance 3.1 takes place.
14691 -- Case 1: The source type lacks a rep item chain
14693 if No
(First_Rep_Item
(From_Typ
)) then
14696 -- Case 2: The destination type lacks a rep item chain
14698 elsif No
(First_Rep_Item
(Typ
)) then
14699 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
14701 -- Case 3: Both the source and destination types have at least one rep
14702 -- item. Traverse the rep item chain of the destination type to find the
14707 Next_Item
:= First_Rep_Item
(Typ
);
14708 while Present
(Next_Item
) loop
14710 -- Detect a link between the destination type's rep chain and that
14711 -- of the source type. There are two possibilities:
14716 -- From_Typ ---> Item_1 --->
14718 -- Typ -----------+
14725 -- From_Typ ---> Item_1 ---> Item_2 --->
14727 -- Typ --------> Item_3 ------+
14731 if Present_In_Rep_Item
(From_Typ
, Next_Item
) then
14736 Next_Item
:= Next_Rep_Item
(Next_Item
);
14739 -- Inherit the source type's rep item chain
14741 if Present
(Item
) then
14742 Set_Next_Rep_Item
(Item
, First_Rep_Item
(From_Typ
));
14744 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
14747 end Inherit_Rep_Item_Chain
;
14749 ------------------------------------
14750 -- Inherits_From_Tagged_Full_View --
14751 ------------------------------------
14753 function Inherits_From_Tagged_Full_View
(Typ
: Entity_Id
) return Boolean is
14755 return Is_Private_Type
(Typ
)
14756 and then Present
(Full_View
(Typ
))
14757 and then Is_Private_Type
(Full_View
(Typ
))
14758 and then not Is_Tagged_Type
(Full_View
(Typ
))
14759 and then Present
(Underlying_Type
(Full_View
(Typ
)))
14760 and then Is_Tagged_Type
(Underlying_Type
(Full_View
(Typ
)));
14761 end Inherits_From_Tagged_Full_View
;
14763 ---------------------------------
14764 -- Insert_Explicit_Dereference --
14765 ---------------------------------
14767 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
14768 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
14769 Ent
: Entity_Id
:= Empty
;
14770 Pref
: Node_Id
:= Empty
;
14776 Save_Interps
(N
, New_Prefix
);
14779 Make_Explicit_Dereference
(Sloc
(Parent
(N
)),
14780 Prefix
=> New_Prefix
));
14782 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
14784 if Is_Overloaded
(New_Prefix
) then
14786 -- The dereference is also overloaded, and its interpretations are
14787 -- the designated types of the interpretations of the original node.
14789 Set_Etype
(N
, Any_Type
);
14791 Get_First_Interp
(New_Prefix
, I
, It
);
14792 while Present
(It
.Nam
) loop
14795 if Is_Access_Type
(T
) then
14796 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
14799 Get_Next_Interp
(I
, It
);
14803 -- Prefix is unambiguous: mark the original prefix (which might
14804 -- Come_From_Source) as a reference, since the new (relocated) one
14805 -- won't be taken into account.
14807 if Is_Entity_Name
(New_Prefix
) then
14808 Ent
:= Entity
(New_Prefix
);
14809 Pref
:= New_Prefix
;
14811 -- For a retrieval of a subcomponent of some composite object,
14812 -- retrieve the ultimate entity if there is one.
14814 elsif Nkind
(New_Prefix
) in N_Selected_Component | N_Indexed_Component
14816 Pref
:= Prefix
(New_Prefix
);
14817 while Present
(Pref
)
14818 and then Nkind
(Pref
) in
14819 N_Selected_Component | N_Indexed_Component
14821 Pref
:= Prefix
(Pref
);
14824 if Present
(Pref
) and then Is_Entity_Name
(Pref
) then
14825 Ent
:= Entity
(Pref
);
14829 -- Place the reference on the entity node
14831 if Present
(Ent
) then
14832 Generate_Reference
(Ent
, Pref
);
14835 end Insert_Explicit_Dereference
;
14837 ------------------------------------------
14838 -- Inspect_Deferred_Constant_Completion --
14839 ------------------------------------------
14841 procedure Inspect_Deferred_Constant_Completion
(Decls
: List_Id
) is
14845 Decl
:= First
(Decls
);
14846 while Present
(Decl
) loop
14848 -- Deferred constant signature
14850 if Nkind
(Decl
) = N_Object_Declaration
14851 and then Constant_Present
(Decl
)
14852 and then No
(Expression
(Decl
))
14854 -- No need to check internally generated constants
14856 and then Comes_From_Source
(Decl
)
14858 -- The constant is not completed. A full object declaration or a
14859 -- pragma Import complete a deferred constant.
14861 and then not Has_Completion
(Defining_Identifier
(Decl
))
14864 ("constant declaration requires initialization expression",
14865 Defining_Identifier
(Decl
));
14870 end Inspect_Deferred_Constant_Completion
;
14872 -------------------------------
14873 -- Install_Elaboration_Model --
14874 -------------------------------
14876 procedure Install_Elaboration_Model
(Unit_Id
: Entity_Id
) is
14877 function Find_Elaboration_Checks_Pragma
(L
: List_Id
) return Node_Id
;
14878 -- Try to find pragma Elaboration_Checks in arbitrary list L. Return
14879 -- Empty if there is no such pragma.
14881 ------------------------------------
14882 -- Find_Elaboration_Checks_Pragma --
14883 ------------------------------------
14885 function Find_Elaboration_Checks_Pragma
(L
: List_Id
) return Node_Id
is
14890 while Present
(Item
) loop
14891 if Nkind
(Item
) = N_Pragma
14892 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
14901 end Find_Elaboration_Checks_Pragma
;
14910 -- Start of processing for Install_Elaboration_Model
14913 -- Nothing to do when the unit does not exist
14915 if No
(Unit_Id
) then
14919 Unit
:= Parent
(Unit_Declaration_Node
(Unit_Id
));
14921 -- Nothing to do when the unit is not a library unit
14923 if Nkind
(Unit
) /= N_Compilation_Unit
then
14927 Prag
:= Find_Elaboration_Checks_Pragma
(Context_Items
(Unit
));
14929 -- The compilation unit is subject to pragma Elaboration_Checks. Set the
14930 -- elaboration model as specified by the pragma.
14932 if Present
(Prag
) then
14933 Args
:= Pragma_Argument_Associations
(Prag
);
14935 -- Guard against an illegal pragma. The sole argument must be an
14936 -- identifier which specifies either Dynamic or Static model.
14938 if Present
(Args
) then
14939 Model
:= Get_Pragma_Arg
(First
(Args
));
14941 if Nkind
(Model
) = N_Identifier
then
14942 Dynamic_Elaboration_Checks
:= Chars
(Model
) = Name_Dynamic
;
14946 end Install_Elaboration_Model
;
14948 -----------------------------
14949 -- Install_Generic_Formals --
14950 -----------------------------
14952 procedure Install_Generic_Formals
(Subp_Id
: Entity_Id
) is
14956 pragma Assert
(Is_Generic_Subprogram
(Subp_Id
));
14958 E
:= First_Entity
(Subp_Id
);
14959 while Present
(E
) loop
14960 Install_Entity
(E
);
14963 end Install_Generic_Formals
;
14965 ------------------------
14966 -- Install_SPARK_Mode --
14967 ------------------------
14969 procedure Install_SPARK_Mode
(Mode
: SPARK_Mode_Type
; Prag
: Node_Id
) is
14971 SPARK_Mode
:= Mode
;
14972 SPARK_Mode_Pragma
:= Prag
;
14973 end Install_SPARK_Mode
;
14975 --------------------------
14976 -- Invalid_Scalar_Value --
14977 --------------------------
14979 function Invalid_Scalar_Value
14981 Scal_Typ
: Scalar_Id
) return Node_Id
14983 function Invalid_Binder_Value
return Node_Id
;
14984 -- Return a reference to the corresponding invalid value for type
14985 -- Scal_Typ as defined in unit System.Scalar_Values.
14987 function Invalid_Float_Value
return Node_Id
;
14988 -- Return the invalid value of float type Scal_Typ
14990 function Invalid_Integer_Value
return Node_Id
;
14991 -- Return the invalid value of integer type Scal_Typ
14993 procedure Set_Invalid_Binder_Values
;
14994 -- Set the contents of collection Invalid_Binder_Values
14996 --------------------------
14997 -- Invalid_Binder_Value --
14998 --------------------------
15000 function Invalid_Binder_Value
return Node_Id
is
15001 Val_Id
: Entity_Id
;
15004 -- Initialize the collection of invalid binder values the first time
15007 Set_Invalid_Binder_Values
;
15009 -- Obtain the corresponding variable from System.Scalar_Values which
15010 -- holds the invalid value for this type.
15012 Val_Id
:= Invalid_Binder_Values
(Scal_Typ
);
15013 pragma Assert
(Present
(Val_Id
));
15015 return New_Occurrence_Of
(Val_Id
, Loc
);
15016 end Invalid_Binder_Value
;
15018 -------------------------
15019 -- Invalid_Float_Value --
15020 -------------------------
15022 function Invalid_Float_Value
return Node_Id
is
15023 Value
: constant Ureal
:= Invalid_Floats
(Scal_Typ
);
15026 -- Pragma Invalid_Scalars did not specify an invalid value for this
15027 -- type. Fall back to the value provided by the binder.
15029 if Value
= No_Ureal
then
15030 return Invalid_Binder_Value
;
15032 return Make_Real_Literal
(Loc
, Realval
=> Value
);
15034 end Invalid_Float_Value
;
15036 ---------------------------
15037 -- Invalid_Integer_Value --
15038 ---------------------------
15040 function Invalid_Integer_Value
return Node_Id
is
15041 Value
: constant Uint
:= Invalid_Integers
(Scal_Typ
);
15044 -- Pragma Invalid_Scalars did not specify an invalid value for this
15045 -- type. Fall back to the value provided by the binder.
15048 return Invalid_Binder_Value
;
15050 return Make_Integer_Literal
(Loc
, Intval
=> Value
);
15052 end Invalid_Integer_Value
;
15054 -------------------------------
15055 -- Set_Invalid_Binder_Values --
15056 -------------------------------
15058 procedure Set_Invalid_Binder_Values
is
15060 if not Invalid_Binder_Values_Set
then
15061 Invalid_Binder_Values_Set
:= True;
15063 -- Initialize the contents of the collection once since RTE calls
15066 Invalid_Binder_Values
:=
15067 (Name_Short_Float
=> RTE
(RE_IS_Isf
),
15068 Name_Float
=> RTE
(RE_IS_Ifl
),
15069 Name_Long_Float
=> RTE
(RE_IS_Ilf
),
15070 Name_Long_Long_Float
=> RTE
(RE_IS_Ill
),
15071 Name_Signed_8
=> RTE
(RE_IS_Is1
),
15072 Name_Signed_16
=> RTE
(RE_IS_Is2
),
15073 Name_Signed_32
=> RTE
(RE_IS_Is4
),
15074 Name_Signed_64
=> RTE
(RE_IS_Is8
),
15075 Name_Signed_128
=> Empty
,
15076 Name_Unsigned_8
=> RTE
(RE_IS_Iu1
),
15077 Name_Unsigned_16
=> RTE
(RE_IS_Iu2
),
15078 Name_Unsigned_32
=> RTE
(RE_IS_Iu4
),
15079 Name_Unsigned_64
=> RTE
(RE_IS_Iu8
),
15080 Name_Unsigned_128
=> Empty
);
15082 if System_Max_Integer_Size
< 128 then
15083 Invalid_Binder_Values
(Name_Signed_128
) := RTE
(RE_IS_Is8
);
15084 Invalid_Binder_Values
(Name_Unsigned_128
) := RTE
(RE_IS_Iu8
);
15086 Invalid_Binder_Values
(Name_Signed_128
) := RTE
(RE_IS_Is16
);
15087 Invalid_Binder_Values
(Name_Unsigned_128
) := RTE
(RE_IS_Iu16
);
15090 end Set_Invalid_Binder_Values
;
15092 -- Start of processing for Invalid_Scalar_Value
15095 if Scal_Typ
in Float_Scalar_Id
then
15096 return Invalid_Float_Value
;
15098 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
15099 return Invalid_Integer_Value
;
15101 end Invalid_Scalar_Value
;
15103 ------------------------
15104 -- Is_Access_Variable --
15105 ------------------------
15107 function Is_Access_Variable
(E
: Entity_Id
) return Boolean is
15109 return Is_Access_Type
(E
)
15110 and then not Is_Access_Constant
(E
)
15111 and then Ekind
(Directly_Designated_Type
(E
)) /= E_Subprogram_Type
;
15112 end Is_Access_Variable
;
15114 -----------------------------
15115 -- Is_Actual_Out_Parameter --
15116 -----------------------------
15118 function Is_Actual_Out_Parameter
(N
: Node_Id
) return Boolean is
15119 Formal
: Entity_Id
;
15122 Find_Actual
(N
, Formal
, Call
);
15123 return Present
(Formal
) and then Ekind
(Formal
) = E_Out_Parameter
;
15124 end Is_Actual_Out_Parameter
;
15126 --------------------------------
15127 -- Is_Actual_In_Out_Parameter --
15128 --------------------------------
15130 function Is_Actual_In_Out_Parameter
(N
: Node_Id
) return Boolean is
15131 Formal
: Entity_Id
;
15134 Find_Actual
(N
, Formal
, Call
);
15135 return Present
(Formal
) and then Ekind
(Formal
) = E_In_Out_Parameter
;
15136 end Is_Actual_In_Out_Parameter
;
15138 ---------------------------------------
15139 -- Is_Actual_Out_Or_In_Out_Parameter --
15140 ---------------------------------------
15142 function Is_Actual_Out_Or_In_Out_Parameter
(N
: Node_Id
) return Boolean is
15143 Formal
: Entity_Id
;
15146 Find_Actual
(N
, Formal
, Call
);
15147 return Present
(Formal
)
15148 and then Ekind
(Formal
) in E_Out_Parameter | E_In_Out_Parameter
;
15149 end Is_Actual_Out_Or_In_Out_Parameter
;
15151 -------------------------
15152 -- Is_Actual_Parameter --
15153 -------------------------
15155 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
15156 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
15160 when N_Parameter_Association
=>
15161 return N
= Explicit_Actual_Parameter
(Parent
(N
));
15163 when N_Entry_Call_Statement
15164 | N_Subprogram_Call
15166 return Is_List_Member
(N
)
15168 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
15173 end Is_Actual_Parameter
;
15175 --------------------------------
15176 -- Is_Actual_Tagged_Parameter --
15177 --------------------------------
15179 function Is_Actual_Tagged_Parameter
(N
: Node_Id
) return Boolean is
15180 Formal
: Entity_Id
;
15183 Find_Actual
(N
, Formal
, Call
);
15184 return Present
(Formal
) and then Is_Tagged_Type
(Etype
(Formal
));
15185 end Is_Actual_Tagged_Parameter
;
15187 ---------------------
15188 -- Is_Aliased_View --
15189 ---------------------
15191 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
15195 if Is_Entity_Name
(Obj
) then
15202 or else (Present
(Renamed_Object
(E
))
15203 and then Is_Aliased_View
(Renamed_Object
(E
)))))
15205 or else ((Is_Formal
(E
) or else Is_Formal_Object
(E
))
15206 and then Is_Tagged_Type
(Etype
(E
)))
15208 or else (Is_Concurrent_Type
(E
) and then In_Open_Scopes
(E
))
15210 -- Current instance of type, either directly or as rewritten
15211 -- reference to the current object.
15213 or else (Is_Entity_Name
(Original_Node
(Obj
))
15214 and then Present
(Entity
(Original_Node
(Obj
)))
15215 and then Is_Type
(Entity
(Original_Node
(Obj
))))
15217 or else (Is_Type
(E
) and then E
= Current_Scope
)
15219 or else (Is_Incomplete_Or_Private_Type
(E
)
15220 and then Full_View
(E
) = Current_Scope
)
15222 -- Ada 2012 AI05-0053: the return object of an extended return
15223 -- statement is aliased if its type is immutably limited.
15225 or else (Is_Return_Object
(E
)
15226 and then Is_Limited_View
(Etype
(E
)))
15228 -- The current instance of a limited type is aliased, so
15229 -- we want to allow uses of T'Access in the init proc for
15230 -- a limited type T. However, we don't want to mark the formal
15231 -- parameter as being aliased since that could impact callers.
15233 or else (Is_Formal
(E
)
15234 and then Chars
(E
) = Name_uInit
15235 and then Is_Limited_View
(Etype
(E
)));
15237 elsif Nkind
(Obj
) = N_Selected_Component
then
15238 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
15240 elsif Nkind
(Obj
) = N_Indexed_Component
then
15241 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
15243 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
15244 and then Has_Aliased_Components
15245 (Designated_Type
(Etype
(Prefix
(Obj
)))));
15247 elsif Nkind
(Obj
) in N_Unchecked_Type_Conversion | N_Type_Conversion
then
15248 return Is_Tagged_Type
(Etype
(Obj
))
15249 and then Is_Aliased_View
(Expression
(Obj
));
15251 -- Ada 2022 AI12-0228
15253 elsif Nkind
(Obj
) = N_Qualified_Expression
15254 and then Ada_Version
>= Ada_2012
15256 return Is_Aliased_View
(Expression
(Obj
));
15258 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
15259 return Nkind
(Original_Node
(Obj
)) /= N_Function_Call
;
15264 end Is_Aliased_View
;
15266 -------------------------
15267 -- Is_Ancestor_Package --
15268 -------------------------
15270 function Is_Ancestor_Package
15272 E2
: Entity_Id
) return Boolean
15278 while Present
(Par
) and then Par
/= Standard_Standard
loop
15283 Par
:= Scope
(Par
);
15287 end Is_Ancestor_Package
;
15289 ----------------------
15290 -- Is_Atomic_Object --
15291 ----------------------
15293 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
15294 function Prefix_Has_Atomic_Components
(P
: Node_Id
) return Boolean;
15295 -- Determine whether prefix P has atomic components. This requires the
15296 -- presence of an Atomic_Components aspect/pragma.
15298 ---------------------------------
15299 -- Prefix_Has_Atomic_Components --
15300 ---------------------------------
15302 function Prefix_Has_Atomic_Components
(P
: Node_Id
) return Boolean is
15303 Typ
: constant Entity_Id
:= Etype
(P
);
15306 if Is_Access_Type
(Typ
) then
15307 return Has_Atomic_Components
(Designated_Type
(Typ
));
15309 elsif Has_Atomic_Components
(Typ
) then
15312 elsif Is_Entity_Name
(P
)
15313 and then Has_Atomic_Components
(Entity
(P
))
15320 end Prefix_Has_Atomic_Components
;
15322 -- Start of processing for Is_Atomic_Object
15325 if Is_Entity_Name
(N
) then
15326 return Is_Atomic_Object_Entity
(Entity
(N
));
15328 elsif Is_Atomic
(Etype
(N
)) then
15331 elsif Nkind
(N
) = N_Indexed_Component
then
15332 return Prefix_Has_Atomic_Components
(Prefix
(N
));
15334 elsif Nkind
(N
) = N_Selected_Component
then
15335 return Is_Atomic
(Entity
(Selector_Name
(N
)));
15340 end Is_Atomic_Object
;
15342 -----------------------------
15343 -- Is_Atomic_Object_Entity --
15344 -----------------------------
15346 function Is_Atomic_Object_Entity
(Id
: Entity_Id
) return Boolean is
15350 and then (Is_Atomic
(Id
) or else Is_Atomic
(Etype
(Id
)));
15351 end Is_Atomic_Object_Entity
;
15353 -----------------------------
15354 -- Is_Attribute_Loop_Entry --
15355 -----------------------------
15357 function Is_Attribute_Loop_Entry
(N
: Node_Id
) return Boolean is
15359 return Nkind
(N
) = N_Attribute_Reference
15360 and then Attribute_Name
(N
) = Name_Loop_Entry
;
15361 end Is_Attribute_Loop_Entry
;
15363 ----------------------
15364 -- Is_Attribute_Old --
15365 ----------------------
15367 function Is_Attribute_Old
(N
: Node_Id
) return Boolean is
15369 return Nkind
(N
) = N_Attribute_Reference
15370 and then Attribute_Name
(N
) = Name_Old
;
15371 end Is_Attribute_Old
;
15373 -------------------------
15374 -- Is_Attribute_Result --
15375 -------------------------
15377 function Is_Attribute_Result
(N
: Node_Id
) return Boolean is
15379 return Nkind
(N
) = N_Attribute_Reference
15380 and then Attribute_Name
(N
) = Name_Result
;
15381 end Is_Attribute_Result
;
15383 -------------------------
15384 -- Is_Attribute_Update --
15385 -------------------------
15387 function Is_Attribute_Update
(N
: Node_Id
) return Boolean is
15389 return Nkind
(N
) = N_Attribute_Reference
15390 and then Attribute_Name
(N
) = Name_Update
;
15391 end Is_Attribute_Update
;
15393 ------------------------------------
15394 -- Is_Body_Or_Package_Declaration --
15395 ------------------------------------
15397 function Is_Body_Or_Package_Declaration
(N
: Node_Id
) return Boolean is
15399 return Is_Body
(N
) or else Nkind
(N
) = N_Package_Declaration
;
15400 end Is_Body_Or_Package_Declaration
;
15402 -----------------------
15403 -- Is_Bounded_String --
15404 -----------------------
15406 function Is_Bounded_String
(T
: Entity_Id
) return Boolean is
15407 Under
: constant Entity_Id
:= Underlying_Type
(Root_Type
(T
));
15410 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
15411 -- Super_String, or one of the [Wide_]Wide_ versions. This will
15412 -- be True for all the Bounded_String types in instances of the
15413 -- Generic_Bounded_Length generics, and for types derived from those.
15415 return Present
(Under
)
15416 and then (Is_RTE
(Root_Type
(Under
), RO_SU_Super_String
) or else
15417 Is_RTE
(Root_Type
(Under
), RO_WI_Super_String
) or else
15418 Is_RTE
(Root_Type
(Under
), RO_WW_Super_String
));
15419 end Is_Bounded_String
;
15421 -------------------------------
15422 -- Is_By_Protected_Procedure --
15423 -------------------------------
15425 function Is_By_Protected_Procedure
(Id
: Entity_Id
) return Boolean is
15427 return Ekind
(Id
) = E_Procedure
15428 and then Present
(Get_Rep_Pragma
(Id
, Name_Implemented
))
15429 and then Implementation_Kind
(Id
) = Name_By_Protected_Procedure
;
15430 end Is_By_Protected_Procedure
;
15432 ---------------------
15433 -- Is_CCT_Instance --
15434 ---------------------
15436 function Is_CCT_Instance
15437 (Ref_Id
: Entity_Id
;
15438 Context_Id
: Entity_Id
) return Boolean
15441 pragma Assert
(Ekind
(Ref_Id
) in E_Protected_Type | E_Task_Type
);
15443 if Is_Single_Task_Object
(Context_Id
) then
15444 return Scope_Within_Or_Same
(Etype
(Context_Id
), Ref_Id
);
15448 (Ekind
(Context_Id
) in
15449 E_Entry | E_Entry_Family | E_Function | E_Package |
15450 E_Procedure | E_Protected_Type | E_Task_Type
15451 or else Is_Record_Type
(Context_Id
));
15452 return Scope_Within_Or_Same
(Context_Id
, Ref_Id
);
15454 end Is_CCT_Instance
;
15456 -------------------------
15457 -- Is_Child_Or_Sibling --
15458 -------------------------
15460 function Is_Child_Or_Sibling
15461 (Pack_1
: Entity_Id
;
15462 Pack_2
: Entity_Id
) return Boolean
15464 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
;
15465 -- Given an arbitrary package, return the number of "climbs" necessary
15466 -- to reach scope Standard_Standard.
15468 procedure Equalize_Depths
15469 (Pack
: in out Entity_Id
;
15470 Depth
: in out Nat
;
15471 Depth_To_Reach
: Nat
);
15472 -- Given an arbitrary package, its depth and a target depth to reach,
15473 -- climb the scope chain until the said depth is reached. The pointer
15474 -- to the package and its depth a modified during the climb.
15476 ----------------------------
15477 -- Distance_From_Standard --
15478 ----------------------------
15480 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
is
15487 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
15489 Scop
:= Scope
(Scop
);
15493 end Distance_From_Standard
;
15495 ---------------------
15496 -- Equalize_Depths --
15497 ---------------------
15499 procedure Equalize_Depths
15500 (Pack
: in out Entity_Id
;
15501 Depth
: in out Nat
;
15502 Depth_To_Reach
: Nat
)
15505 -- The package must be at a greater or equal depth
15507 if Depth
< Depth_To_Reach
then
15508 raise Program_Error
;
15511 -- Climb the scope chain until the desired depth is reached
15513 while Present
(Pack
) and then Depth
/= Depth_To_Reach
loop
15514 Pack
:= Scope
(Pack
);
15515 Depth
:= Depth
- 1;
15517 end Equalize_Depths
;
15521 P_1
: Entity_Id
:= Pack_1
;
15522 P_1_Child
: Boolean := False;
15523 P_1_Depth
: Nat
:= Distance_From_Standard
(P_1
);
15524 P_2
: Entity_Id
:= Pack_2
;
15525 P_2_Child
: Boolean := False;
15526 P_2_Depth
: Nat
:= Distance_From_Standard
(P_2
);
15528 -- Start of processing for Is_Child_Or_Sibling
15532 (Ekind
(Pack_1
) = E_Package
and then Ekind
(Pack_2
) = E_Package
);
15534 -- Both packages denote the same entity, therefore they cannot be
15535 -- children or siblings.
15540 -- One of the packages is at a deeper level than the other. Note that
15541 -- both may still come from different hierarchies.
15549 elsif P_1_Depth
> P_2_Depth
then
15552 Depth
=> P_1_Depth
,
15553 Depth_To_Reach
=> P_2_Depth
);
15562 elsif P_2_Depth
> P_1_Depth
then
15565 Depth
=> P_2_Depth
,
15566 Depth_To_Reach
=> P_1_Depth
);
15570 -- At this stage the package pointers have been elevated to the same
15571 -- depth. If the related entities are the same, then one package is a
15572 -- potential child of the other:
15576 -- X became P_1 P_2 or vice versa
15582 return Is_Child_Unit
(Pack_1
);
15584 else pragma Assert
(P_2_Child
);
15585 return Is_Child_Unit
(Pack_2
);
15588 -- The packages may come from the same package chain or from entirely
15589 -- different hierarchies. To determine this, climb the scope stack until
15590 -- a common root is found.
15592 -- (root) (root 1) (root 2)
15597 while Present
(P_1
) and then Present
(P_2
) loop
15599 -- The two packages may be siblings
15602 return Is_Child_Unit
(Pack_1
) and then Is_Child_Unit
(Pack_2
);
15605 P_1
:= Scope
(P_1
);
15606 P_2
:= Scope
(P_2
);
15611 end Is_Child_Or_Sibling
;
15613 -------------------
15614 -- Is_Confirming --
15615 -------------------
15617 function Is_Confirming
(Aspect
: Nonoverridable_Aspect_Id
;
15618 Aspect_Spec_1
, Aspect_Spec_2
: Node_Id
)
15620 function Names_Match
(Nm1
, Nm2
: Node_Id
) return Boolean;
15626 function Names_Match
(Nm1
, Nm2
: Node_Id
) return Boolean is
15628 if Nkind
(Nm1
) /= Nkind
(Nm2
) then
15630 -- This may be too restrictive given that visibility
15631 -- may allow an identifier in one case and an expanded
15632 -- name in the other.
15634 case Nkind
(Nm1
) is
15635 when N_Identifier
=>
15636 return Name_Equals
(Chars
(Nm1
), Chars
(Nm2
));
15638 when N_Expanded_Name
=>
15639 -- An inherited operation has the same name as its
15640 -- ancestor, but they may have different scopes.
15641 -- This may be too permissive for Iterator_Element, which
15642 -- is intended to be identical in parent and derived type.
15644 return Names_Match
(Selector_Name
(Nm1
),
15645 Selector_Name
(Nm2
));
15648 return True; -- needed for Aggregate aspect checking
15651 -- e.g., 'Class attribute references
15652 if Is_Entity_Name
(Nm1
) and Is_Entity_Name
(Nm2
) then
15653 return Entity
(Nm1
) = Entity
(Nm2
);
15656 raise Program_Error
;
15660 -- allow users to disable "shall be confirming" check, at least for now
15661 if Relaxed_RM_Semantics
then
15665 -- ??? Type conversion here (along with "when others =>" below) is a
15666 -- workaround for a bootstrapping problem related to casing on a
15667 -- static-predicate-bearing subtype.
15669 case Aspect_Id
(Aspect
) is
15670 -- name-valued aspects; compare text of names, not resolution.
15671 when Aspect_Default_Iterator
15672 | Aspect_Iterator_Element
15673 | Aspect_Constant_Indexing
15674 | Aspect_Variable_Indexing
=>
15676 Item_1
: constant Node_Id
:= Aspect_Rep_Item
(Aspect_Spec_1
);
15677 Item_2
: constant Node_Id
:= Aspect_Rep_Item
(Aspect_Spec_2
);
15679 if (Nkind
(Item_1
) /= N_Attribute_Definition_Clause
)
15680 or (Nkind
(Item_2
) /= N_Attribute_Definition_Clause
)
15682 pragma Assert
(Serious_Errors_Detected
> 0);
15686 return Names_Match
(Expression
(Item_1
),
15687 Expression
(Item_2
));
15690 -- A confirming aspect for Implicit_Derenfence on a derived type
15691 -- has already been checked in Analyze_Aspect_Implicit_Dereference,
15692 -- including the presence of renamed discriminants.
15694 when Aspect_Implicit_Dereference
=>
15698 when Aspect_Aggregate
=>
15709 Assign_Indexed_2
: Node_Id
:= Empty
;
15711 Parse_Aspect_Aggregate
15712 (N
=> Expression
(Aspect_Spec_1
),
15713 Empty_Subp
=> Empty_1
,
15714 Add_Named_Subp
=> Add_Named_1
,
15715 Add_Unnamed_Subp
=> Add_Unnamed_1
,
15716 New_Indexed_Subp
=> New_Indexed_1
,
15717 Assign_Indexed_Subp
=> Assign_Indexed_1
);
15718 Parse_Aspect_Aggregate
15719 (N
=> Expression
(Aspect_Spec_2
),
15720 Empty_Subp
=> Empty_2
,
15721 Add_Named_Subp
=> Add_Named_2
,
15722 Add_Unnamed_Subp
=> Add_Unnamed_2
,
15723 New_Indexed_Subp
=> New_Indexed_2
,
15724 Assign_Indexed_Subp
=> Assign_Indexed_2
);
15726 Names_Match
(Empty_1
, Empty_2
) and then
15727 Names_Match
(Add_Named_1
, Add_Named_2
) and then
15728 Names_Match
(Add_Unnamed_1
, Add_Unnamed_2
) and then
15729 Names_Match
(New_Indexed_1
, New_Indexed_2
) and then
15730 Names_Match
(Assign_Indexed_1
, Assign_Indexed_2
);
15733 -- Checking for this aspect is performed elsewhere during freezing
15734 when Aspect_No_Controlled_Parts
=>
15737 -- scalar-valued aspects; compare (static) values.
15738 when Aspect_Max_Entry_Queue_Length
=>
15739 -- This should be unreachable. Max_Entry_Queue_Length is
15740 -- supported only for protected entries, not for types.
15741 pragma Assert
(Serious_Errors_Detected
/= 0);
15745 raise Program_Error
;
15749 -----------------------------
15750 -- Is_Concurrent_Interface --
15751 -----------------------------
15753 function Is_Concurrent_Interface
(T
: Entity_Id
) return Boolean is
15755 return Is_Protected_Interface
(T
)
15756 or else Is_Synchronized_Interface
(T
)
15757 or else Is_Task_Interface
(T
);
15758 end Is_Concurrent_Interface
;
15760 ------------------------------------------------------
15761 -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes --
15762 ------------------------------------------------------
15764 function Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15765 (Expr
: Node_Id
) return Boolean
15768 function Is_Formal_Preelab_Init_Attribute
15769 (N
: Node_Id
) return Boolean;
15770 -- Returns True if N is a Preelaborable_Initialization attribute
15771 -- applied to a generic formal type, or N's Original_Node is such
15774 --------------------------------------
15775 -- Is_Formal_Preelab_Init_Attribute --
15776 --------------------------------------
15778 function Is_Formal_Preelab_Init_Attribute
15779 (N
: Node_Id
) return Boolean
15781 Orig_N
: constant Node_Id
:= Original_Node
(N
);
15784 return Nkind
(Orig_N
) = N_Attribute_Reference
15785 and then Attribute_Name
(Orig_N
) = Name_Preelaborable_Initialization
15786 and then Is_Entity_Name
(Prefix
(Orig_N
))
15787 and then Is_Generic_Type
(Entity
(Prefix
(Orig_N
)));
15788 end Is_Formal_Preelab_Init_Attribute
;
15790 -- Start of Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15793 return Is_Formal_Preelab_Init_Attribute
(Expr
)
15794 or else (Nkind
(Expr
) = N_Op_And
15796 Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15799 Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15800 (Right_Opnd
(Expr
)));
15801 end Is_Conjunction_Of_Formal_Preelab_Init_Attributes
;
15803 -----------------------
15804 -- Is_Constant_Bound --
15805 -----------------------
15807 function Is_Constant_Bound
(Exp
: Node_Id
) return Boolean is
15809 if Compile_Time_Known_Value
(Exp
) then
15812 elsif Is_Entity_Name
(Exp
) and then Present
(Entity
(Exp
)) then
15813 return Is_Constant_Object
(Entity
(Exp
))
15814 or else Ekind
(Entity
(Exp
)) = E_Enumeration_Literal
;
15816 elsif Nkind
(Exp
) in N_Binary_Op
then
15817 return Is_Constant_Bound
(Left_Opnd
(Exp
))
15818 and then Is_Constant_Bound
(Right_Opnd
(Exp
))
15819 and then Scope
(Entity
(Exp
)) = Standard_Standard
;
15824 end Is_Constant_Bound
;
15826 ---------------------------
15827 -- Is_Container_Element --
15828 ---------------------------
15830 function Is_Container_Element
(Exp
: Node_Id
) return Boolean is
15831 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
15832 Pref
: constant Node_Id
:= Prefix
(Exp
);
15835 -- Call to an indexing aspect
15837 Cont_Typ
: Entity_Id
;
15838 -- The type of the container being accessed
15840 Elem_Typ
: Entity_Id
;
15841 -- Its element type
15843 Indexing
: Entity_Id
;
15844 Is_Const
: Boolean;
15845 -- Indicates that constant indexing is used, and the element is thus
15848 Ref_Typ
: Entity_Id
;
15849 -- The reference type returned by the indexing operation
15852 -- If C is a container, in a context that imposes the element type of
15853 -- that container, the indexing notation C (X) is rewritten as:
15855 -- Indexing (C, X).Discr.all
15857 -- where Indexing is one of the indexing aspects of the container.
15858 -- If the context does not require a reference, the construct can be
15863 -- First, verify that the construct has the proper form
15865 if not Expander_Active
then
15868 elsif Nkind
(Pref
) /= N_Selected_Component
then
15871 elsif Nkind
(Prefix
(Pref
)) /= N_Function_Call
then
15875 Call
:= Prefix
(Pref
);
15876 Ref_Typ
:= Etype
(Call
);
15879 if not Has_Implicit_Dereference
(Ref_Typ
)
15880 or else No
(First
(Parameter_Associations
(Call
)))
15881 or else not Is_Entity_Name
(Name
(Call
))
15886 -- Retrieve type of container object, and its iterator aspects
15888 Cont_Typ
:= Etype
(First
(Parameter_Associations
(Call
)));
15889 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Constant_Indexing
);
15892 if No
(Indexing
) then
15894 -- Container should have at least one indexing operation
15898 elsif Entity
(Name
(Call
)) /= Entity
(Indexing
) then
15900 -- This may be a variable indexing operation
15902 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Variable_Indexing
);
15905 or else Entity
(Name
(Call
)) /= Entity
(Indexing
)
15914 Elem_Typ
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Iterator_Element
);
15916 if No
(Elem_Typ
) or else Entity
(Elem_Typ
) /= Etype
(Exp
) then
15920 -- Check that the expression is not the target of an assignment, in
15921 -- which case the rewriting is not possible.
15923 if not Is_Const
then
15929 while Present
(Par
)
15931 if Nkind
(Parent
(Par
)) = N_Assignment_Statement
15932 and then Par
= Name
(Parent
(Par
))
15936 -- A renaming produces a reference, and the transformation
15939 elsif Nkind
(Parent
(Par
)) = N_Object_Renaming_Declaration
then
15942 elsif Nkind
(Parent
(Par
)) in
15944 N_Procedure_Call_Statement |
15945 N_Entry_Call_Statement
15947 -- Check that the element is not part of an actual for an
15948 -- in-out parameter.
15955 F
:= First_Formal
(Entity
(Name
(Parent
(Par
))));
15956 A
:= First
(Parameter_Associations
(Parent
(Par
)));
15957 while Present
(F
) loop
15958 if A
= Par
and then Ekind
(F
) /= E_In_Parameter
then
15967 -- E_In_Parameter in a call: element is not modified.
15972 Par
:= Parent
(Par
);
15977 -- The expression has the proper form and the context requires the
15978 -- element type. Retrieve the Element function of the container and
15979 -- rewrite the construct as a call to it.
15985 Op
:= First_Elmt
(Primitive_Operations
(Cont_Typ
));
15986 while Present
(Op
) loop
15987 exit when Chars
(Node
(Op
)) = Name_Element
;
15996 Make_Function_Call
(Loc
,
15997 Name
=> New_Occurrence_Of
(Node
(Op
), Loc
),
15998 Parameter_Associations
=> Parameter_Associations
(Call
)));
15999 Analyze_And_Resolve
(Exp
, Entity
(Elem_Typ
));
16003 end Is_Container_Element
;
16005 ----------------------------
16006 -- Is_Contract_Annotation --
16007 ----------------------------
16009 function Is_Contract_Annotation
(Item
: Node_Id
) return Boolean is
16011 return Is_Package_Contract_Annotation
(Item
)
16013 Is_Subprogram_Contract_Annotation
(Item
);
16014 end Is_Contract_Annotation
;
16016 --------------------------------------
16017 -- Is_Controlling_Limited_Procedure --
16018 --------------------------------------
16020 function Is_Controlling_Limited_Procedure
16021 (Proc_Nam
: Entity_Id
) return Boolean
16024 Param_Typ
: Entity_Id
:= Empty
;
16027 if Ekind
(Proc_Nam
) = E_Procedure
16028 and then Present
(Parameter_Specifications
(Parent
(Proc_Nam
)))
16032 (First
(Parameter_Specifications
(Parent
(Proc_Nam
))));
16034 -- The formal may be an anonymous access type
16036 if Nkind
(Param
) = N_Access_Definition
then
16037 Param_Typ
:= Entity
(Subtype_Mark
(Param
));
16039 Param_Typ
:= Etype
(Param
);
16042 -- In the case where an Itype was created for a dispatchin call, the
16043 -- procedure call has been rewritten. The actual may be an access to
16044 -- interface type in which case it is the designated type that is the
16045 -- controlling type.
16047 elsif Present
(Associated_Node_For_Itype
(Proc_Nam
))
16048 and then Present
(Original_Node
(Associated_Node_For_Itype
(Proc_Nam
)))
16050 Present
(Parameter_Associations
16051 (Associated_Node_For_Itype
(Proc_Nam
)))
16054 Etype
(First
(Parameter_Associations
16055 (Associated_Node_For_Itype
(Proc_Nam
))));
16057 if Ekind
(Param_Typ
) = E_Anonymous_Access_Type
then
16058 Param_Typ
:= Directly_Designated_Type
(Param_Typ
);
16062 if Present
(Param_Typ
) then
16064 Is_Interface
(Param_Typ
)
16065 and then Is_Limited_Record
(Param_Typ
);
16069 end Is_Controlling_Limited_Procedure
;
16071 -----------------------------
16072 -- Is_CPP_Constructor_Call --
16073 -----------------------------
16075 function Is_CPP_Constructor_Call
(N
: Node_Id
) return Boolean is
16077 return Nkind
(N
) = N_Function_Call
16078 and then Is_CPP_Class
(Etype
(Etype
(N
)))
16079 and then Is_Constructor
(Entity
(Name
(N
)))
16080 and then Is_Imported
(Entity
(Name
(N
)));
16081 end Is_CPP_Constructor_Call
;
16083 -------------------------
16084 -- Is_Current_Instance --
16085 -------------------------
16087 function Is_Current_Instance
(N
: Node_Id
) return Boolean is
16088 Typ
: constant Entity_Id
:= Entity
(N
);
16092 -- Simplest case: entity is a concurrent type and we are currently
16093 -- inside the body. This will eventually be expanded into a call to
16094 -- Self (for tasks) or _object (for protected objects).
16096 if Is_Concurrent_Type
(Typ
) and then In_Open_Scopes
(Typ
) then
16100 -- Check whether the context is a (sub)type declaration for the
16104 while Present
(P
) loop
16105 if Nkind
(P
) in N_Full_Type_Declaration
16106 | N_Private_Type_Declaration
16107 | N_Subtype_Declaration
16108 and then Comes_From_Source
(P
)
16110 -- If the type has a previous incomplete declaration, the
16111 -- reference in the type definition may have the incomplete
16112 -- view. So, here we detect if this incomplete view is a current
16113 -- instance by checking if its full view is the entity of the
16114 -- full declaration begin analyzed.
16117 (Defining_Entity
(P
) = Typ
16119 (Ekind
(Typ
) = E_Incomplete_Type
16120 and then Full_View
(Typ
) = Defining_Entity
(P
)))
16124 -- A subtype name may appear in an aspect specification for a
16125 -- Predicate_Failure aspect, for which we do not construct a
16126 -- wrapper procedure. The subtype will be replaced by the
16127 -- expression being tested when the corresponding predicate
16128 -- check is expanded. It may also appear in the pragma Predicate
16129 -- expression during legality checking.
16131 elsif Nkind
(P
) = N_Aspect_Specification
16132 and then Nkind
(Parent
(P
)) = N_Subtype_Declaration
16133 and then Underlying_Type
(Defining_Identifier
(Parent
(P
))) =
16134 Underlying_Type
(Typ
)
16138 elsif Nkind
(P
) = N_Pragma
16139 and then Get_Pragma_Id
(P
) in Pragma_Predicate
16140 | Pragma_Predicate_Failure
16143 Arg
: constant Entity_Id
:=
16144 Entity
(Expression
(Get_Argument
(P
)));
16146 if Underlying_Type
(Arg
) = Underlying_Type
(Typ
) then
16156 -- In any other context this is not a current occurrence
16159 end Is_Current_Instance
;
16161 --------------------------------------------------
16162 -- Is_Current_Instance_Reference_In_Type_Aspect --
16163 --------------------------------------------------
16165 function Is_Current_Instance_Reference_In_Type_Aspect
16166 (N
: Node_Id
) return Boolean
16169 -- When a current_instance is referenced within an aspect_specification
16170 -- of a type or subtype, it will show up as a reference to the formal
16171 -- parameter of the aspect's associated subprogram rather than as a
16172 -- reference to the type or subtype itself (in fact, the original name
16173 -- is never even analyzed). We check for predicate, invariant, and
16174 -- Default_Initial_Condition subprograms (in theory there could be
16175 -- other cases added, in which case this function will need updating).
16177 if Is_Entity_Name
(N
) then
16178 return Present
(Entity
(N
))
16179 and then Ekind
(Entity
(N
)) = E_In_Parameter
16180 and then Ekind
(Scope
(Entity
(N
))) in E_Function | E_Procedure
16182 (Is_Predicate_Function
(Scope
(Entity
(N
)))
16183 or else Is_Invariant_Procedure
(Scope
(Entity
(N
)))
16184 or else Is_Partial_Invariant_Procedure
(Scope
(Entity
(N
)))
16185 or else Is_DIC_Procedure
(Scope
(Entity
(N
))));
16189 when N_Indexed_Component
16193 Is_Current_Instance_Reference_In_Type_Aspect
(Prefix
(N
));
16195 when N_Selected_Component
=>
16197 Is_Current_Instance_Reference_In_Type_Aspect
(Prefix
(N
));
16199 when N_Type_Conversion
=>
16200 return Is_Current_Instance_Reference_In_Type_Aspect
16203 when N_Qualified_Expression
=>
16204 return Is_Current_Instance_Reference_In_Type_Aspect
16211 end Is_Current_Instance_Reference_In_Type_Aspect
;
16213 --------------------
16214 -- Is_Declaration --
16215 --------------------
16217 function Is_Declaration
16219 Body_OK
: Boolean := True;
16220 Concurrent_OK
: Boolean := True;
16221 Formal_OK
: Boolean := True;
16222 Generic_OK
: Boolean := True;
16223 Instantiation_OK
: Boolean := True;
16224 Renaming_OK
: Boolean := True;
16225 Stub_OK
: Boolean := True;
16226 Subprogram_OK
: Boolean := True;
16227 Type_OK
: Boolean := True) return Boolean
16232 -- Body declarations
16234 when N_Proper_Body
=>
16237 -- Concurrent type declarations
16239 when N_Protected_Type_Declaration
16240 | N_Single_Protected_Declaration
16241 | N_Single_Task_Declaration
16242 | N_Task_Type_Declaration
16244 return Concurrent_OK
or Type_OK
;
16246 -- Formal declarations
16248 when N_Formal_Abstract_Subprogram_Declaration
16249 | N_Formal_Concrete_Subprogram_Declaration
16250 | N_Formal_Object_Declaration
16251 | N_Formal_Package_Declaration
16252 | N_Formal_Type_Declaration
16256 -- Generic declarations
16258 when N_Generic_Package_Declaration
16259 | N_Generic_Subprogram_Declaration
16263 -- Generic instantiations
16265 when N_Function_Instantiation
16266 | N_Package_Instantiation
16267 | N_Procedure_Instantiation
16269 return Instantiation_OK
;
16271 -- Generic renaming declarations
16273 when N_Generic_Renaming_Declaration
=>
16274 return Generic_OK
or Renaming_OK
;
16276 -- Renaming declarations
16278 when N_Exception_Renaming_Declaration
16279 | N_Object_Renaming_Declaration
16280 | N_Package_Renaming_Declaration
16281 | N_Subprogram_Renaming_Declaration
16283 return Renaming_OK
;
16285 -- Stub declarations
16287 when N_Body_Stub
=>
16290 -- Subprogram declarations
16292 when N_Abstract_Subprogram_Declaration
16293 | N_Entry_Declaration
16294 | N_Expression_Function
16295 | N_Subprogram_Declaration
16297 return Subprogram_OK
;
16299 -- Type declarations
16301 when N_Full_Type_Declaration
16302 | N_Incomplete_Type_Declaration
16303 | N_Private_Extension_Declaration
16304 | N_Private_Type_Declaration
16305 | N_Subtype_Declaration
16311 when N_Component_Declaration
16312 | N_Exception_Declaration
16313 | N_Implicit_Label_Declaration
16314 | N_Number_Declaration
16315 | N_Object_Declaration
16316 | N_Package_Declaration
16323 end Is_Declaration
;
16325 --------------------------------
16326 -- Is_Declared_Within_Variant --
16327 --------------------------------
16329 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
16330 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
16331 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
16333 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
16334 end Is_Declared_Within_Variant
;
16336 ----------------------------------------------
16337 -- Is_Dependent_Component_Of_Mutable_Object --
16338 ----------------------------------------------
16340 function Is_Dependent_Component_Of_Mutable_Object
16341 (Object
: Node_Id
) return Boolean
16344 Prefix_Type
: Entity_Id
;
16345 P_Aliased
: Boolean := False;
16348 Deref
: Node_Id
:= Original_Node
(Object
);
16349 -- Dereference node, in something like X.all.Y(2)
16351 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
16354 -- Find the dereference node if any
16356 while Nkind
(Deref
) in
16357 N_Indexed_Component | N_Selected_Component | N_Slice
16359 Deref
:= Original_Node
(Prefix
(Deref
));
16362 -- If the prefix is a qualified expression of a variable, then function
16363 -- Is_Variable will return False for that because a qualified expression
16364 -- denotes a constant view, so we need to get the name being qualified
16365 -- so we can test below whether that's a variable (or a dereference).
16367 if Nkind
(Deref
) = N_Qualified_Expression
then
16368 Deref
:= Expression
(Deref
);
16371 -- Ada 2005: If we have a component or slice of a dereference, something
16372 -- like X.all.Y (2) and the type of X is access-to-constant, Is_Variable
16373 -- will return False, because it is indeed a constant view. But it might
16374 -- be a view of a variable object, so we want the following condition to
16375 -- be True in that case.
16377 if Is_Variable
(Object
)
16378 or else Is_Variable
(Deref
)
16380 (Ada_Version
>= Ada_2005
16381 and then (Nkind
(Deref
) = N_Explicit_Dereference
16382 or else (Present
(Etype
(Deref
))
16383 and then Is_Access_Type
(Etype
(Deref
)))))
16385 if Nkind
(Object
) = N_Selected_Component
then
16387 -- If the selector is not a component, then we definitely return
16388 -- False (it could be a function selector in a prefix form call
16389 -- occurring in an iterator specification).
16391 if Ekind
(Entity
(Selector_Name
(Object
))) not in
16392 E_Component | E_Discriminant
16397 -- Get the original node of the prefix in case it has been
16398 -- rewritten, which can occur, for example, in qualified
16399 -- expression cases. Also, a discriminant check on a selected
16400 -- component may be expanded into a dereference when removing
16401 -- side effects, and the subtype of the original node may be
16404 P
:= Original_Node
(Prefix
(Object
));
16405 Prefix_Type
:= Etype
(P
);
16407 -- If the prefix is a qualified expression, we want to look at its
16410 if Nkind
(P
) = N_Qualified_Expression
then
16411 P
:= Expression
(P
);
16412 Prefix_Type
:= Etype
(P
);
16415 if Is_Entity_Name
(P
) then
16416 -- The Etype may not be set on P (which is wrong) in certain
16417 -- corner cases involving the deprecated front-end inlining of
16418 -- subprograms (via -gnatN), so use the Etype set on the
16419 -- the entity for these instances since we know it is present.
16421 if No
(Prefix_Type
) then
16422 Prefix_Type
:= Etype
(Entity
(P
));
16425 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
16426 Prefix_Type
:= Base_Type
(Prefix_Type
);
16429 if Is_Aliased
(Entity
(P
)) then
16433 -- For explicit dereferences we get the access prefix so we can
16434 -- treat this similarly to implicit dereferences and examine the
16435 -- kind of the access type and its designated subtype further
16438 elsif Nkind
(P
) = N_Explicit_Dereference
then
16440 Prefix_Type
:= Etype
(P
);
16443 -- Check for prefix being an aliased component???
16448 -- A heap object is constrained by its initial value
16450 -- Ada 2005 (AI-363): Always assume the object could be mutable in
16451 -- the dereferenced case, since the access value might denote an
16452 -- unconstrained aliased object, whereas in Ada 95 the designated
16453 -- object is guaranteed to be constrained. A worst-case assumption
16454 -- has to apply in Ada 2005 because we can't tell at compile
16455 -- time whether the object is "constrained by its initial value",
16456 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
16457 -- rules (these rules are acknowledged to need fixing). We don't
16458 -- impose this more stringent checking for earlier Ada versions or
16459 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's
16460 -- benefit, though it's unclear on why using -gnat95 would not be
16463 if Ada_Version
< Ada_2005
or else Relaxed_RM_Semantics
then
16464 if Is_Access_Type
(Prefix_Type
)
16465 or else Nkind
(P
) = N_Explicit_Dereference
16470 else pragma Assert
(Ada_Version
>= Ada_2005
);
16471 if Is_Access_Type
(Prefix_Type
) then
16472 -- We need to make sure we have the base subtype, in case
16473 -- this is actually an access subtype (whose Ekind will be
16474 -- E_Access_Subtype).
16476 Prefix_Type
:= Etype
(Prefix_Type
);
16478 -- If the access type is pool-specific, and there is no
16479 -- constrained partial view of the designated type, then the
16480 -- designated object is known to be constrained. If it's a
16481 -- formal access type and the renaming is in the generic
16482 -- spec, we also treat it as pool-specific (known to be
16483 -- constrained), but assume the worst if in the generic body
16484 -- (see RM 3.3(23.3/3)).
16486 if Ekind
(Prefix_Type
) = E_Access_Type
16487 and then (not Is_Generic_Type
(Prefix_Type
)
16488 or else not In_Generic_Body
(Current_Scope
))
16489 and then not Object_Type_Has_Constrained_Partial_View
16490 (Typ
=> Designated_Type
(Prefix_Type
),
16491 Scop
=> Current_Scope
)
16495 -- Otherwise (general access type, or there is a constrained
16496 -- partial view of the designated type), we need to check
16497 -- based on the designated type.
16500 Prefix_Type
:= Designated_Type
(Prefix_Type
);
16506 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
16508 -- As per AI-0017, the renaming is illegal in a generic body, even
16509 -- if the subtype is indefinite (only applies to prefixes of an
16510 -- untagged formal type, see RM 3.3 (23.11/3)).
16512 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
16514 if not Is_Constrained
(Prefix_Type
)
16515 and then (Is_Definite_Subtype
(Prefix_Type
)
16517 (not Is_Tagged_Type
(Prefix_Type
)
16518 and then Is_Generic_Type
(Prefix_Type
)
16519 and then In_Generic_Body
(Current_Scope
)))
16521 and then (Is_Declared_Within_Variant
(Comp
)
16522 or else Has_Discriminant_Dependent_Constraint
(Comp
))
16523 and then (not P_Aliased
or else Ada_Version
>= Ada_2005
)
16527 -- If the prefix is of an access type at this point, then we want
16528 -- to return False, rather than calling this function recursively
16529 -- on the access object (which itself might be a discriminant-
16530 -- dependent component of some other object, but that isn't
16531 -- relevant to checking the object passed to us). This avoids
16532 -- issuing wrong errors when compiling with -gnatc, where there
16533 -- can be implicit dereferences that have not been expanded.
16535 elsif Is_Access_Type
(Etype
(Prefix
(Object
))) then
16540 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
16543 elsif Nkind
(Object
) = N_Indexed_Component
16544 or else Nkind
(Object
) = N_Slice
16546 return Is_Dependent_Component_Of_Mutable_Object
16547 (Original_Node
(Prefix
(Object
)));
16549 -- A type conversion that Is_Variable is a view conversion:
16550 -- go back to the denoted object.
16552 elsif Nkind
(Object
) = N_Type_Conversion
then
16554 Is_Dependent_Component_Of_Mutable_Object
16555 (Original_Node
(Expression
(Object
)));
16560 end Is_Dependent_Component_Of_Mutable_Object
;
16562 ---------------------
16563 -- Is_Dereferenced --
16564 ---------------------
16566 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
16567 P
: constant Node_Id
:= Parent
(N
);
16569 return Nkind
(P
) in N_Selected_Component
16570 | N_Explicit_Dereference
16571 | N_Indexed_Component
16573 and then Prefix
(P
) = N
;
16574 end Is_Dereferenced
;
16576 ----------------------
16577 -- Is_Descendant_Of --
16578 ----------------------
16580 function Is_Descendant_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
16585 pragma Assert
(Nkind
(T1
) in N_Entity
);
16586 pragma Assert
(Nkind
(T2
) in N_Entity
);
16588 T
:= Base_Type
(T1
);
16590 -- Immediate return if the types match
16595 -- Comment needed here ???
16597 elsif Ekind
(T
) = E_Class_Wide_Type
then
16598 return Etype
(T
) = T2
;
16606 -- Done if we found the type we are looking for
16611 -- Done if no more derivations to check
16618 -- Following test catches error cases resulting from prev errors
16620 elsif No
(Etyp
) then
16623 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
16626 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
16630 T
:= Base_Type
(Etyp
);
16633 end Is_Descendant_Of
;
16635 ----------------------------------------
16636 -- Is_Descendant_Of_Suspension_Object --
16637 ----------------------------------------
16639 function Is_Descendant_Of_Suspension_Object
16640 (Typ
: Entity_Id
) return Boolean
16642 Cur_Typ
: Entity_Id
;
16643 Par_Typ
: Entity_Id
;
16646 -- Climb the type derivation chain checking each parent type against
16647 -- Suspension_Object.
16649 Cur_Typ
:= Base_Type
(Typ
);
16650 while Present
(Cur_Typ
) loop
16651 Par_Typ
:= Etype
(Cur_Typ
);
16653 -- The current type is a match
16655 if Is_RTE
(Cur_Typ
, RE_Suspension_Object
) then
16658 -- Stop the traversal once the root of the derivation chain has been
16659 -- reached. In that case the current type is its own base type.
16661 elsif Cur_Typ
= Par_Typ
then
16665 Cur_Typ
:= Base_Type
(Par_Typ
);
16669 end Is_Descendant_Of_Suspension_Object
;
16671 ---------------------------------------------
16672 -- Is_Double_Precision_Floating_Point_Type --
16673 ---------------------------------------------
16675 function Is_Double_Precision_Floating_Point_Type
16676 (E
: Entity_Id
) return Boolean is
16678 return Is_Floating_Point_Type
(E
)
16679 and then Machine_Radix_Value
(E
) = Uint_2
16680 and then Machine_Mantissa_Value
(E
) = UI_From_Int
(53)
16681 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_10
16682 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_10
);
16683 end Is_Double_Precision_Floating_Point_Type
;
16685 -----------------------------
16686 -- Is_Effectively_Volatile --
16687 -----------------------------
16689 function Is_Effectively_Volatile
16691 Ignore_Protected
: Boolean := False) return Boolean is
16693 if Is_Type
(Id
) then
16695 -- An arbitrary type is effectively volatile when it is subject to
16696 -- pragma Atomic or Volatile, unless No_Caching is enabled.
16698 if Is_Volatile
(Id
)
16699 and then not No_Caching_Enabled
(Id
)
16703 -- An array type is effectively volatile when it is subject to pragma
16704 -- Atomic_Components or Volatile_Components or its component type is
16705 -- effectively volatile.
16707 elsif Is_Array_Type
(Id
) then
16708 if Has_Volatile_Components
(Id
) then
16712 Anc
: Entity_Id
:= Base_Type
(Id
);
16714 if Is_Private_Type
(Anc
) then
16715 Anc
:= Full_View
(Anc
);
16718 -- Test for presence of ancestor, as the full view of a
16719 -- private type may be missing in case of error.
16721 return Present
(Anc
)
16722 and then Is_Effectively_Volatile
16723 (Component_Type
(Anc
), Ignore_Protected
);
16727 -- A protected type is always volatile unless Ignore_Protected is
16730 elsif Is_Protected_Type
(Id
) and then not Ignore_Protected
then
16733 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is
16734 -- automatically volatile.
16736 elsif Is_Descendant_Of_Suspension_Object
(Id
) then
16739 -- Otherwise the type is not effectively volatile
16745 -- Otherwise Id denotes an object
16747 else pragma Assert
(Is_Object
(Id
));
16748 -- A volatile object for which No_Caching is enabled is not
16749 -- effectively volatile.
16754 (Ekind
(Id
) = E_Variable
and then No_Caching_Enabled
(Id
)))
16755 or else Has_Volatile_Components
(Id
)
16756 or else Is_Effectively_Volatile
(Etype
(Id
), Ignore_Protected
);
16758 end Is_Effectively_Volatile
;
16760 -----------------------------------------
16761 -- Is_Effectively_Volatile_For_Reading --
16762 -----------------------------------------
16764 function Is_Effectively_Volatile_For_Reading
16766 Ignore_Protected
: Boolean := False) return Boolean
16769 -- A concurrent type is effectively volatile for reading, except for a
16770 -- protected type when Ignore_Protected is True.
16772 if Is_Task_Type
(Id
)
16773 or else (Is_Protected_Type
(Id
) and then not Ignore_Protected
)
16777 elsif Is_Effectively_Volatile
(Id
, Ignore_Protected
) then
16779 -- Other volatile types and objects are effectively volatile for
16780 -- reading when they have property Async_Writers or Effective_Reads
16781 -- set to True. This includes the case of an array type whose
16782 -- Volatile_Components aspect is True (hence it is effectively
16783 -- volatile) which does not have the properties Async_Writers
16784 -- and Effective_Reads set to False.
16786 if Async_Writers_Enabled
(Id
)
16787 or else Effective_Reads_Enabled
(Id
)
16791 -- In addition, an array type is effectively volatile for reading
16792 -- when its component type is effectively volatile for reading.
16794 elsif Is_Array_Type
(Id
) then
16796 Anc
: Entity_Id
:= Base_Type
(Id
);
16798 if Is_Private_Type
(Anc
) then
16799 Anc
:= Full_View
(Anc
);
16802 -- Test for presence of ancestor, as the full view of a
16803 -- private type may be missing in case of error.
16805 return Present
(Anc
)
16806 and then Is_Effectively_Volatile_For_Reading
16807 (Component_Type
(Anc
), Ignore_Protected
);
16814 end Is_Effectively_Volatile_For_Reading
;
16816 ------------------------------------
16817 -- Is_Effectively_Volatile_Object --
16818 ------------------------------------
16820 function Is_Effectively_Volatile_Object
(N
: Node_Id
) return Boolean is
16821 function Is_Effectively_Volatile
(E
: Entity_Id
) return Boolean is
16822 (Is_Effectively_Volatile
(E
, Ignore_Protected
=> False));
16824 function Is_Effectively_Volatile_Object_Inst
16825 is new Is_Effectively_Volatile_Object_Shared
(Is_Effectively_Volatile
);
16827 return Is_Effectively_Volatile_Object_Inst
(N
);
16828 end Is_Effectively_Volatile_Object
;
16830 ------------------------------------------------
16831 -- Is_Effectively_Volatile_Object_For_Reading --
16832 ------------------------------------------------
16834 function Is_Effectively_Volatile_Object_For_Reading
16835 (N
: Node_Id
) return Boolean
16837 function Is_Effectively_Volatile_For_Reading
16838 (E
: Entity_Id
) return Boolean
16839 is (Is_Effectively_Volatile_For_Reading
(E
, Ignore_Protected
=> False));
16841 function Is_Effectively_Volatile_Object_For_Reading_Inst
16842 is new Is_Effectively_Volatile_Object_Shared
16843 (Is_Effectively_Volatile_For_Reading
);
16845 return Is_Effectively_Volatile_Object_For_Reading_Inst
(N
);
16846 end Is_Effectively_Volatile_Object_For_Reading
;
16848 -------------------------------------------
16849 -- Is_Effectively_Volatile_Object_Shared --
16850 -------------------------------------------
16852 function Is_Effectively_Volatile_Object_Shared
16853 (N
: Node_Id
) return Boolean
16856 if Is_Entity_Name
(N
) then
16857 return Is_Object
(Entity
(N
))
16858 and then Is_Effectively_Volatile_Entity
(Entity
(N
));
16860 elsif Nkind
(N
) in N_Indexed_Component | N_Slice
then
16861 return Is_Effectively_Volatile_Object_Shared
(Prefix
(N
));
16863 elsif Nkind
(N
) = N_Selected_Component
then
16865 Is_Effectively_Volatile_Object_Shared
(Prefix
(N
))
16867 Is_Effectively_Volatile_Object_Shared
(Selector_Name
(N
));
16869 elsif Nkind
(N
) in N_Qualified_Expression
16870 | N_Unchecked_Type_Conversion
16871 | N_Type_Conversion
16873 return Is_Effectively_Volatile_Object_Shared
(Expression
(N
));
16878 end Is_Effectively_Volatile_Object_Shared
;
16880 ----------------------------------------
16881 -- Is_Entity_Of_Quantified_Expression --
16882 ----------------------------------------
16884 function Is_Entity_Of_Quantified_Expression
(Id
: Entity_Id
) return Boolean
16886 Par
: constant Node_Id
:= Parent
(Id
);
16889 return (Nkind
(Par
) = N_Loop_Parameter_Specification
16890 or else Nkind
(Par
) = N_Iterator_Specification
)
16891 and then Defining_Identifier
(Par
) = Id
16892 and then Nkind
(Parent
(Par
)) = N_Quantified_Expression
;
16893 end Is_Entity_Of_Quantified_Expression
;
16895 -------------------
16896 -- Is_Entry_Body --
16897 -------------------
16899 function Is_Entry_Body
(Id
: Entity_Id
) return Boolean is
16903 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Body
;
16906 --------------------------
16907 -- Is_Entry_Declaration --
16908 --------------------------
16910 function Is_Entry_Declaration
(Id
: Entity_Id
) return Boolean is
16914 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Declaration
;
16915 end Is_Entry_Declaration
;
16917 ------------------------------------
16918 -- Is_Expanded_Priority_Attribute --
16919 ------------------------------------
16921 function Is_Expanded_Priority_Attribute
(E
: Entity_Id
) return Boolean is
16924 Nkind
(E
) = N_Function_Call
16925 and then not Configurable_Run_Time_Mode
16926 and then Nkind
(Original_Node
(E
)) = N_Attribute_Reference
16927 and then (Is_RTE
(Entity
(Name
(E
)), RE_Get_Ceiling
)
16928 or else Is_RTE
(Entity
(Name
(E
)), RO_PE_Get_Ceiling
));
16929 end Is_Expanded_Priority_Attribute
;
16931 ----------------------------
16932 -- Is_Expression_Function --
16933 ----------------------------
16935 function Is_Expression_Function
(Subp
: Entity_Id
) return Boolean is
16937 if Ekind
(Subp
) in E_Function | E_Subprogram_Body
then
16939 Nkind
(Original_Node
(Unit_Declaration_Node
(Subp
))) =
16940 N_Expression_Function
;
16944 end Is_Expression_Function
;
16946 ------------------------------------------
16947 -- Is_Expression_Function_Or_Completion --
16948 ------------------------------------------
16950 function Is_Expression_Function_Or_Completion
16951 (Subp
: Entity_Id
) return Boolean
16953 Subp_Decl
: Node_Id
;
16956 if Ekind
(Subp
) = E_Function
then
16957 Subp_Decl
:= Unit_Declaration_Node
(Subp
);
16959 -- The function declaration is either an expression function or is
16960 -- completed by an expression function body.
16963 Is_Expression_Function
(Subp
)
16964 or else (Nkind
(Subp_Decl
) = N_Subprogram_Declaration
16965 and then Present
(Corresponding_Body
(Subp_Decl
))
16966 and then Is_Expression_Function
16967 (Corresponding_Body
(Subp_Decl
)));
16969 elsif Ekind
(Subp
) = E_Subprogram_Body
then
16970 return Is_Expression_Function
(Subp
);
16975 end Is_Expression_Function_Or_Completion
;
16977 -----------------------------------------------
16978 -- Is_Extended_Precision_Floating_Point_Type --
16979 -----------------------------------------------
16981 function Is_Extended_Precision_Floating_Point_Type
16982 (E
: Entity_Id
) return Boolean is
16984 return Is_Floating_Point_Type
(E
)
16985 and then Machine_Radix_Value
(E
) = Uint_2
16986 and then Machine_Mantissa_Value
(E
) = Uint_64
16987 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_14
16988 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_14
);
16989 end Is_Extended_Precision_Floating_Point_Type
;
16991 -----------------------
16992 -- Is_EVF_Expression --
16993 -----------------------
16995 function Is_EVF_Expression
(N
: Node_Id
) return Boolean is
16996 Orig_N
: constant Node_Id
:= Original_Node
(N
);
17002 -- Detect a reference to a formal parameter of a specific tagged type
17003 -- whose related subprogram is subject to pragma Expresions_Visible with
17006 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
17011 and then Is_Specific_Tagged_Type
(Etype
(Id
))
17012 and then Extensions_Visible_Status
(Id
) =
17013 Extensions_Visible_False
;
17015 -- A case expression is an EVF expression when it contains at least one
17016 -- EVF dependent_expression. Note that a case expression may have been
17017 -- expanded, hence the use of Original_Node.
17019 elsif Nkind
(Orig_N
) = N_Case_Expression
then
17020 Alt
:= First
(Alternatives
(Orig_N
));
17021 while Present
(Alt
) loop
17022 if Is_EVF_Expression
(Expression
(Alt
)) then
17029 -- An if expression is an EVF expression when it contains at least one
17030 -- EVF dependent_expression. Note that an if expression may have been
17031 -- expanded, hence the use of Original_Node.
17033 elsif Nkind
(Orig_N
) = N_If_Expression
then
17034 Expr
:= Next
(First
(Expressions
(Orig_N
)));
17035 while Present
(Expr
) loop
17036 if Is_EVF_Expression
(Expr
) then
17043 -- A qualified expression or a type conversion is an EVF expression when
17044 -- its operand is an EVF expression.
17046 elsif Nkind
(N
) in N_Qualified_Expression
17047 | N_Unchecked_Type_Conversion
17048 | N_Type_Conversion
17050 return Is_EVF_Expression
(Expression
(N
));
17052 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when
17053 -- their prefix denotes an EVF expression.
17055 elsif Nkind
(N
) = N_Attribute_Reference
17056 and then Attribute_Name
(N
) in Name_Loop_Entry
17060 return Is_EVF_Expression
(Prefix
(N
));
17064 end Is_EVF_Expression
;
17070 function Is_False
(U
: Opt_Ubool
) return Boolean is
17072 return not Is_True
(U
);
17075 ---------------------------
17076 -- Is_Fixed_Model_Number --
17077 ---------------------------
17079 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
17080 S
: constant Ureal
:= Small_Value
(T
);
17081 M
: Urealp
.Save_Mark
;
17086 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
17087 Urealp
.Release
(M
);
17089 end Is_Fixed_Model_Number
;
17091 -----------------------------
17092 -- Is_Full_Access_Object --
17093 -----------------------------
17095 function Is_Full_Access_Object
(N
: Node_Id
) return Boolean is
17097 return Is_Atomic_Object
(N
)
17098 or else Is_Volatile_Full_Access_Object_Ref
(N
);
17099 end Is_Full_Access_Object
;
17101 -------------------------------
17102 -- Is_Fully_Initialized_Type --
17103 -------------------------------
17105 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
17109 if Is_Scalar_Type
(Typ
) then
17111 -- A scalar type with an aspect Default_Value is fully initialized
17113 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization
17114 -- of a scalar type, but we don't take that into account here, since
17115 -- we don't want these to affect warnings.
17117 return Has_Default_Aspect
(Typ
);
17119 elsif Is_Access_Type
(Typ
) then
17122 elsif Is_Array_Type
(Typ
) then
17123 if Is_Fully_Initialized_Type
(Component_Type
(Typ
))
17124 or else (Ada_Version
>= Ada_2012
and then Has_Default_Aspect
(Typ
))
17129 -- An interesting case, if we have a constrained type one of whose
17130 -- bounds is known to be null, then there are no elements to be
17131 -- initialized, so all the elements are initialized.
17133 if Is_Constrained
(Typ
) then
17136 Indx_Typ
: Entity_Id
;
17137 Lbd
, Hbd
: Node_Id
;
17140 Indx
:= First_Index
(Typ
);
17141 while Present
(Indx
) loop
17142 if Etype
(Indx
) = Any_Type
then
17145 -- If index is a range, use directly
17147 elsif Nkind
(Indx
) = N_Range
then
17148 Lbd
:= Low_Bound
(Indx
);
17149 Hbd
:= High_Bound
(Indx
);
17152 Indx_Typ
:= Etype
(Indx
);
17154 if Is_Private_Type
(Indx_Typ
) then
17155 Indx_Typ
:= Full_View
(Indx_Typ
);
17158 if No
(Indx_Typ
) or else Etype
(Indx_Typ
) = Any_Type
then
17161 Lbd
:= Type_Low_Bound
(Indx_Typ
);
17162 Hbd
:= Type_High_Bound
(Indx_Typ
);
17166 if Compile_Time_Known_Value
(Lbd
)
17168 Compile_Time_Known_Value
(Hbd
)
17170 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
17180 -- If no null indexes, then type is not fully initialized
17186 elsif Is_Record_Type
(Typ
) then
17187 if Has_Defaulted_Discriminants
(Typ
)
17188 and then Is_Fully_Initialized_Variant
(Typ
)
17193 -- We consider bounded string types to be fully initialized, because
17194 -- otherwise we get false alarms when the Data component is not
17195 -- default-initialized.
17197 if Is_Bounded_String
(Typ
) then
17201 -- Controlled records are considered to be fully initialized if
17202 -- there is a user defined Initialize routine. This may not be
17203 -- entirely correct, but as the spec notes, we are guessing here
17204 -- what is best from the point of view of issuing warnings.
17206 if Is_Controlled
(Typ
) then
17208 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
17211 if Present
(Utyp
) then
17213 Init
: constant Entity_Id
:=
17214 (Find_Optional_Prim_Op
17215 (Underlying_Type
(Typ
), Name_Initialize
));
17219 and then Comes_From_Source
(Init
)
17220 and then not In_Predefined_Unit
(Init
)
17224 elsif Has_Null_Extension
(Typ
)
17226 Is_Fully_Initialized_Type
17227 (Etype
(Base_Type
(Typ
)))
17236 -- Otherwise see if all record components are initialized
17242 Comp
:= First_Component
(Typ
);
17243 while Present
(Comp
) loop
17244 if (No
(Parent
(Comp
))
17245 or else No
(Expression
(Parent
(Comp
))))
17246 and then not Is_Fully_Initialized_Type
(Etype
(Comp
))
17248 -- Special VM case for tag components, which need to be
17249 -- defined in this case, but are never initialized as VMs
17250 -- are using other dispatching mechanisms. Ignore this
17251 -- uninitialized case. Note that this applies both to the
17252 -- uTag entry and the main vtable pointer (CPP_Class case).
17254 and then (Tagged_Type_Expansion
or else not Is_Tag
(Comp
))
17259 Next_Component
(Comp
);
17263 -- No uninitialized components, so type is fully initialized.
17264 -- Note that this catches the case of no components as well.
17268 elsif Is_Concurrent_Type
(Typ
) then
17271 elsif Is_Private_Type
(Typ
) then
17273 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
17279 return Is_Fully_Initialized_Type
(U
);
17286 end Is_Fully_Initialized_Type
;
17288 ----------------------------------
17289 -- Is_Fully_Initialized_Variant --
17290 ----------------------------------
17292 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
17293 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
17294 Constraints
: constant List_Id
:= New_List
;
17295 Components
: constant Elist_Id
:= New_Elmt_List
;
17296 Comp_Elmt
: Elmt_Id
;
17298 Comp_List
: Node_Id
;
17300 Discr_Val
: Node_Id
;
17302 Report_Errors
: Boolean;
17303 pragma Warnings
(Off
, Report_Errors
);
17306 if Serious_Errors_Detected
> 0 then
17310 if Is_Record_Type
(Typ
)
17311 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
17312 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
17314 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
17316 Discr
:= First_Discriminant
(Typ
);
17317 while Present
(Discr
) loop
17318 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
17319 Discr_Val
:= Expression
(Parent
(Discr
));
17321 if Present
(Discr_Val
)
17322 and then Is_OK_Static_Expression
(Discr_Val
)
17324 Append_To
(Constraints
,
17325 Make_Component_Association
(Loc
,
17326 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
17327 Expression
=> New_Copy
(Discr_Val
)));
17335 Next_Discriminant
(Discr
);
17340 Comp_List
=> Comp_List
,
17341 Governed_By
=> Constraints
,
17342 Into
=> Components
,
17343 Report_Errors
=> Report_Errors
);
17345 -- Check that each component present is fully initialized
17347 Comp_Elmt
:= First_Elmt
(Components
);
17348 while Present
(Comp_Elmt
) loop
17349 Comp_Id
:= Node
(Comp_Elmt
);
17351 if Ekind
(Comp_Id
) = E_Component
17352 and then (No
(Parent
(Comp_Id
))
17353 or else No
(Expression
(Parent
(Comp_Id
))))
17354 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
17359 Next_Elmt
(Comp_Elmt
);
17364 elsif Is_Private_Type
(Typ
) then
17366 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
17372 return Is_Fully_Initialized_Variant
(U
);
17379 end Is_Fully_Initialized_Variant
;
17381 ------------------------------------
17382 -- Is_Generic_Declaration_Or_Body --
17383 ------------------------------------
17385 function Is_Generic_Declaration_Or_Body
(Decl
: Node_Id
) return Boolean is
17386 Spec_Decl
: Node_Id
;
17389 -- Package/subprogram body
17391 if Nkind
(Decl
) in N_Package_Body | N_Subprogram_Body
17392 and then Present
(Corresponding_Spec
(Decl
))
17394 Spec_Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(Decl
));
17396 -- Package/subprogram body stub
17398 elsif Nkind
(Decl
) in N_Package_Body_Stub | N_Subprogram_Body_Stub
17399 and then Present
(Corresponding_Spec_Of_Stub
(Decl
))
17402 Unit_Declaration_Node
(Corresponding_Spec_Of_Stub
(Decl
));
17410 -- Rather than inspecting the defining entity of the spec declaration,
17411 -- look at its Nkind. This takes care of the case where the analysis of
17412 -- a generic body modifies the Ekind of its spec to allow for recursive
17415 return Nkind
(Spec_Decl
) in N_Generic_Declaration
;
17416 end Is_Generic_Declaration_Or_Body
;
17418 ---------------------------
17419 -- Is_Independent_Object --
17420 ---------------------------
17422 function Is_Independent_Object
(N
: Node_Id
) return Boolean is
17423 function Is_Independent_Object_Entity
(Id
: Entity_Id
) return Boolean;
17424 -- Determine whether arbitrary entity Id denotes an object that is
17427 function Prefix_Has_Independent_Components
(P
: Node_Id
) return Boolean;
17428 -- Determine whether prefix P has independent components. This requires
17429 -- the presence of an Independent_Components aspect/pragma.
17431 ------------------------------------
17432 -- Is_Independent_Object_Entity --
17433 ------------------------------------
17435 function Is_Independent_Object_Entity
(Id
: Entity_Id
) return Boolean is
17439 and then (Is_Independent
(Id
)
17441 Is_Independent
(Etype
(Id
)));
17442 end Is_Independent_Object_Entity
;
17444 -------------------------------------
17445 -- Prefix_Has_Independent_Components --
17446 -------------------------------------
17448 function Prefix_Has_Independent_Components
(P
: Node_Id
) return Boolean
17450 Typ
: constant Entity_Id
:= Etype
(P
);
17453 if Is_Access_Type
(Typ
) then
17454 return Has_Independent_Components
(Designated_Type
(Typ
));
17456 elsif Has_Independent_Components
(Typ
) then
17459 elsif Is_Entity_Name
(P
)
17460 and then Has_Independent_Components
(Entity
(P
))
17467 end Prefix_Has_Independent_Components
;
17469 -- Start of processing for Is_Independent_Object
17472 if Is_Entity_Name
(N
) then
17473 return Is_Independent_Object_Entity
(Entity
(N
));
17475 elsif Is_Independent
(Etype
(N
)) then
17478 elsif Nkind
(N
) = N_Indexed_Component
then
17479 return Prefix_Has_Independent_Components
(Prefix
(N
));
17481 elsif Nkind
(N
) = N_Selected_Component
then
17482 return Prefix_Has_Independent_Components
(Prefix
(N
))
17483 or else Is_Independent
(Entity
(Selector_Name
(N
)));
17488 end Is_Independent_Object
;
17490 ----------------------------
17491 -- Is_Inherited_Operation --
17492 ----------------------------
17494 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
17495 pragma Assert
(Is_Overloadable
(E
));
17496 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
17498 return Kind
= N_Full_Type_Declaration
17499 or else Kind
= N_Private_Extension_Declaration
17500 or else Kind
= N_Subtype_Declaration
17501 or else (Ekind
(E
) = E_Enumeration_Literal
17502 and then Is_Derived_Type
(Etype
(E
)));
17503 end Is_Inherited_Operation
;
17505 -------------------------------------
17506 -- Is_Inherited_Operation_For_Type --
17507 -------------------------------------
17509 function Is_Inherited_Operation_For_Type
17511 Typ
: Entity_Id
) return Boolean
17514 -- Check that the operation has been created by the type declaration
17516 return Is_Inherited_Operation
(E
)
17517 and then Defining_Identifier
(Parent
(E
)) = Typ
;
17518 end Is_Inherited_Operation_For_Type
;
17520 --------------------------------------
17521 -- Is_Inlinable_Expression_Function --
17522 --------------------------------------
17524 function Is_Inlinable_Expression_Function
17525 (Subp
: Entity_Id
) return Boolean
17527 Return_Expr
: Node_Id
;
17530 if Is_Expression_Function_Or_Completion
(Subp
)
17531 and then Has_Pragma_Inline_Always
(Subp
)
17532 and then Needs_No_Actuals
(Subp
)
17533 and then No
(Contract
(Subp
))
17534 and then not Is_Dispatching_Operation
(Subp
)
17535 and then Needs_Finalization
(Etype
(Subp
))
17536 and then not Is_Class_Wide_Type
(Etype
(Subp
))
17537 and then not Has_Invariants
(Etype
(Subp
))
17538 and then Present
(Subprogram_Body
(Subp
))
17539 and then Was_Expression_Function
(Subprogram_Body
(Subp
))
17541 Return_Expr
:= Expression_Of_Expression_Function
(Subp
);
17543 -- The returned object must not have a qualified expression and its
17544 -- nominal subtype must be statically compatible with the result
17545 -- subtype of the expression function.
17548 Nkind
(Return_Expr
) = N_Identifier
17549 and then Etype
(Return_Expr
) = Etype
(Subp
);
17553 end Is_Inlinable_Expression_Function
;
17559 function Is_Iterator
(Typ
: Entity_Id
) return Boolean is
17560 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean;
17561 -- Determine whether type Iter_Typ is a predefined forward or reversible
17564 ----------------------
17565 -- Denotes_Iterator --
17566 ----------------------
17568 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean is
17570 -- Check that the name matches, and that the ultimate ancestor is in
17571 -- a predefined unit, i.e the one that declares iterator interfaces.
17574 Chars
(Iter_Typ
) in Name_Forward_Iterator | Name_Reversible_Iterator
17575 and then In_Predefined_Unit
(Root_Type
(Iter_Typ
));
17576 end Denotes_Iterator
;
17580 Iface_Elmt
: Elmt_Id
;
17583 -- Start of processing for Is_Iterator
17586 -- The type may be a subtype of a descendant of the proper instance of
17587 -- the predefined interface type, so we must use the root type of the
17588 -- given type. The same is done for Is_Reversible_Iterator.
17590 if Is_Class_Wide_Type
(Typ
)
17591 and then Denotes_Iterator
(Root_Type
(Typ
))
17595 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
17598 elsif Present
(Find_Value_Of_Aspect
(Typ
, Aspect_Iterable
)) then
17602 Collect_Interfaces
(Typ
, Ifaces
);
17604 Iface_Elmt
:= First_Elmt
(Ifaces
);
17605 while Present
(Iface_Elmt
) loop
17606 if Denotes_Iterator
(Node
(Iface_Elmt
)) then
17610 Next_Elmt
(Iface_Elmt
);
17617 ----------------------------
17618 -- Is_Iterator_Over_Array --
17619 ----------------------------
17621 function Is_Iterator_Over_Array
(N
: Node_Id
) return Boolean is
17622 Container
: constant Node_Id
:= Name
(N
);
17623 Container_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Container
));
17625 return Is_Array_Type
(Container_Typ
);
17626 end Is_Iterator_Over_Array
;
17628 --------------------------
17629 -- Known_To_Be_Assigned --
17630 --------------------------
17632 function Known_To_Be_Assigned
17634 Only_LHS
: Boolean := False) return Boolean
17636 function Known_Assn
(N
: Node_Id
) return Boolean is
17637 (Known_To_Be_Assigned
(N
, Only_LHS
));
17638 -- Local function to simplify the passing of parameters for recursive
17641 P
: constant Node_Id
:= Parent
(N
);
17642 Form
: Entity_Id
:= Empty
;
17643 Call
: Node_Id
:= Empty
;
17645 -- Start of processing for Known_To_Be_Assigned
17648 -- Check for out parameters
17650 Find_Actual
(N
, Form
, Call
);
17652 if Present
(Form
) then
17653 return Ekind
(Form
) /= E_In_Parameter
and then not Only_LHS
;
17656 -- Otherwise look at the parent
17660 -- Test left side of assignment
17662 when N_Assignment_Statement
=>
17663 return N
= Name
(P
);
17665 -- Test prefix of component or attribute. Note that the prefix of an
17666 -- explicit or implicit dereference cannot be an l-value. In the case
17667 -- of a 'Read attribute, the reference can be an actual in the
17668 -- argument list of the attribute.
17670 when N_Attribute_Reference
=>
17672 not Only_LHS
and then
17674 and then Name_Implies_Lvalue_Prefix
(Attribute_Name
(P
)))
17676 Attribute_Name
(P
) = Name_Read
);
17678 -- For an expanded name, the name is an lvalue if the expanded name
17679 -- is an lvalue, but the prefix is never an lvalue, since it is just
17680 -- the scope where the name is found.
17682 when N_Expanded_Name
=>
17683 if N
= Prefix
(P
) then
17684 return Known_Assn
(P
);
17689 -- For a selected component A.B, A is certainly an lvalue if A.B is.
17690 -- B is a little interesting, if we have A.B := 3, there is some
17691 -- discussion as to whether B is an lvalue or not, we choose to say
17692 -- it is. Note however that A is not an lvalue if it is of an access
17693 -- type since this is an implicit dereference.
17695 when N_Selected_Component
=>
17697 and then Present
(Etype
(N
))
17698 and then Is_Access_Type
(Etype
(N
))
17702 return Known_Assn
(P
);
17705 -- For an indexed component or slice, the index or slice bounds is
17706 -- never an lvalue. The prefix is an lvalue if the indexed component
17707 -- or slice is an lvalue, except if it is an access type, where we
17708 -- have an implicit dereference.
17710 when N_Indexed_Component | N_Slice
=>
17712 or else (Present
(Etype
(N
)) and then Is_Access_Type
(Etype
(N
)))
17716 return Known_Assn
(P
);
17719 -- Prefix of a reference is an lvalue if the reference is an lvalue
17721 when N_Reference
=>
17722 return Known_Assn
(P
);
17724 -- Prefix of explicit dereference is never an lvalue
17726 when N_Explicit_Dereference
=>
17729 -- Test for appearing in a conversion that itself appears in an
17730 -- lvalue context, since this should be an lvalue.
17732 when N_Type_Conversion
=>
17733 return Known_Assn
(P
);
17735 -- Test for appearance in object renaming declaration
17737 when N_Object_Renaming_Declaration
=>
17738 return not Only_LHS
;
17740 -- All other references are definitely not lvalues
17745 end Known_To_Be_Assigned
;
17747 -----------------------------
17748 -- Is_Library_Level_Entity --
17749 -----------------------------
17751 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
17753 -- The following is a small optimization, and it also properly handles
17754 -- discriminals, which in task bodies might appear in expressions before
17755 -- the corresponding procedure has been created, and which therefore do
17756 -- not have an assigned scope.
17758 if Is_Formal
(E
) then
17761 -- If we somehow got an empty value for Scope, the tree must be
17762 -- malformed. Rather than blow up we return True in this case.
17764 elsif No
(Scope
(E
)) then
17767 -- Handle loops since Enclosing_Dynamic_Scope skips them; required to
17768 -- properly handle entities local to quantified expressions in library
17769 -- level specifications.
17771 elsif Ekind
(Scope
(E
)) = E_Loop
then
17775 -- Normal test is simply that the enclosing dynamic scope is Standard
17777 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
17778 end Is_Library_Level_Entity
;
17780 --------------------------------
17781 -- Is_Limited_Class_Wide_Type --
17782 --------------------------------
17784 function Is_Limited_Class_Wide_Type
(Typ
: Entity_Id
) return Boolean is
17787 Is_Class_Wide_Type
(Typ
)
17788 and then (Is_Limited_Type
(Typ
) or else From_Limited_With
(Typ
));
17789 end Is_Limited_Class_Wide_Type
;
17791 ---------------------------------
17792 -- Is_Local_Variable_Reference --
17793 ---------------------------------
17795 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
17797 if not Is_Entity_Name
(Expr
) then
17802 Ent
: constant Entity_Id
:= Entity
(Expr
);
17803 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
17806 not in E_Variable | E_In_Out_Parameter | E_Out_Parameter
17810 return Present
(Sub
) and then Sub
= Current_Subprogram
;
17814 end Is_Local_Variable_Reference
;
17820 function Is_Master
(N
: Node_Id
) return Boolean is
17821 Disable_Subexpression_Masters
: constant Boolean := True;
17824 if Nkind
(N
) in N_Subprogram_Body | N_Task_Body | N_Entry_Body
17825 or else Is_Statement
(N
)
17830 -- We avoid returning True when the master is a subexpression described
17831 -- in RM 7.6.1(3/2) for the proposes of accessibility level calculation
17832 -- in Accessibility_Level_Helper.Innermost_Master_Scope_Depth ???
17834 if not Disable_Subexpression_Masters
17835 and then Nkind
(N
) in N_Subexpr
17838 Par
: Node_Id
:= N
;
17840 subtype N_Simple_Statement_Other_Than_Simple_Return
17841 is Node_Kind
with Static_Predicate
=>
17842 N_Simple_Statement_Other_Than_Simple_Return
17843 in N_Abort_Statement
17844 | N_Assignment_Statement
17846 | N_Delay_Statement
17847 | N_Entry_Call_Statement
17851 | N_Raise_Statement
17852 | N_Requeue_Statement
17854 | N_Procedure_Call_Statement
;
17856 while Present
(Par
) loop
17857 Par
:= Parent
(Par
);
17858 if Nkind
(Par
) in N_Subexpr |
17859 N_Simple_Statement_Other_Than_Simple_Return
17872 -----------------------
17873 -- Is_Name_Reference --
17874 -----------------------
17876 function Is_Name_Reference
(N
: Node_Id
) return Boolean is
17878 if Is_Entity_Name
(N
) then
17879 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
));
17883 when N_Indexed_Component
17887 Is_Name_Reference
(Prefix
(N
))
17888 or else Is_Access_Type
(Etype
(Prefix
(N
)));
17890 -- Attributes 'Input, 'Old and 'Result produce objects
17892 when N_Attribute_Reference
=>
17893 return Attribute_Name
(N
) in Name_Input | Name_Old | Name_Result
;
17895 when N_Selected_Component
=>
17897 Is_Name_Reference
(Selector_Name
(N
))
17899 (Is_Name_Reference
(Prefix
(N
))
17900 or else Is_Access_Type
(Etype
(Prefix
(N
))));
17902 when N_Explicit_Dereference
=>
17905 -- A view conversion of a tagged name is a name reference
17907 when N_Type_Conversion
=>
17909 Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
17910 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
17911 and then Is_Name_Reference
(Expression
(N
));
17913 -- An unchecked type conversion is considered to be a name if the
17914 -- operand is a name (this construction arises only as a result of
17915 -- expansion activities).
17917 when N_Unchecked_Type_Conversion
=>
17918 return Is_Name_Reference
(Expression
(N
));
17923 end Is_Name_Reference
;
17925 --------------------------
17926 -- Is_Newly_Constructed --
17927 --------------------------
17929 function Is_Newly_Constructed
17930 (Exp
: Node_Id
; Context_Requires_NC
: Boolean) return Boolean
17932 Original_Exp
: constant Node_Id
:= Original_Node
(Exp
);
17934 function Is_NC
(Exp
: Node_Id
) return Boolean is
17935 (Is_Newly_Constructed
(Exp
, Context_Requires_NC
));
17937 -- If the context requires that the expression shall be newly
17938 -- constructed, then "True" is a good result in the sense that the
17939 -- expression satisfies the requirements of the context (and "False"
17940 -- is analogously a bad result). If the context requires that the
17941 -- expression shall *not* be newly constructed, then things are
17942 -- reversed: "False" is the good value and "True" is the bad value.
17944 Good_Result
: constant Boolean := Context_Requires_NC
;
17945 Bad_Result
: constant Boolean := not Good_Result
;
17947 case Nkind
(Original_Exp
) is
17949 | N_Extension_Aggregate
17955 when N_Identifier
=>
17956 return Present
(Entity
(Original_Exp
))
17957 and then Ekind
(Entity
(Original_Exp
)) = E_Function
;
17959 when N_Qualified_Expression
=>
17960 return Is_NC
(Expression
(Original_Exp
));
17962 when N_Type_Conversion
17963 | N_Unchecked_Type_Conversion
17965 if Is_View_Conversion
(Original_Exp
) then
17966 return Is_NC
(Expression
(Original_Exp
));
17967 elsif not Comes_From_Source
(Exp
) then
17968 if Exp
/= Original_Exp
then
17969 return Is_NC
(Original_Exp
);
17971 return Is_NC
(Expression
(Original_Exp
));
17977 when N_Explicit_Dereference
17978 | N_Indexed_Component
17979 | N_Selected_Component
17981 return Nkind
(Exp
) = N_Function_Call
;
17983 -- A use of 'Input is a function call, hence allowed. Normally the
17984 -- attribute will be changed to a call, but the attribute by itself
17985 -- can occur with -gnatc.
17987 when N_Attribute_Reference
=>
17988 return Attribute_Name
(Original_Exp
) = Name_Input
;
17990 -- "return raise ..." is OK
17992 when N_Raise_Expression
=>
17993 return Good_Result
;
17995 -- For a case expression, all dependent expressions must be legal
17997 when N_Case_Expression
=>
18002 Alt
:= First
(Alternatives
(Original_Exp
));
18003 while Present
(Alt
) loop
18004 if Is_NC
(Expression
(Alt
)) = Bad_Result
then
18011 return Good_Result
;
18014 -- For an if expression, all dependent expressions must be legal
18016 when N_If_Expression
=>
18018 Then_Expr
: constant Node_Id
:=
18019 Next
(First
(Expressions
(Original_Exp
)));
18020 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
18022 if (Is_NC
(Then_Expr
) = Bad_Result
)
18023 or else (Is_NC
(Else_Expr
) = Bad_Result
)
18027 return Good_Result
;
18034 end Is_Newly_Constructed
;
18036 ------------------------------------
18037 -- Is_Non_Preelaborable_Construct --
18038 ------------------------------------
18040 function Is_Non_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
18042 -- NOTE: the routines within Is_Non_Preelaborable_Construct are
18043 -- intentionally unnested to avoid deep indentation of code.
18045 Non_Preelaborable
: exception;
18046 -- This exception is raised when the construct violates preelaborability
18047 -- to terminate the recursion.
18049 procedure Visit
(Nod
: Node_Id
);
18050 -- Semantically inspect construct Nod to determine whether it violates
18051 -- preelaborability. This routine raises Non_Preelaborable.
18053 procedure Visit_List
(List
: List_Id
);
18054 pragma Inline
(Visit_List
);
18055 -- Invoke Visit on each element of list List. This routine raises
18056 -- Non_Preelaborable.
18058 procedure Visit_Pragma
(Prag
: Node_Id
);
18059 pragma Inline
(Visit_Pragma
);
18060 -- Semantically inspect pragma Prag to determine whether it violates
18061 -- preelaborability. This routine raises Non_Preelaborable.
18063 procedure Visit_Subexpression
(Expr
: Node_Id
);
18064 pragma Inline
(Visit_Subexpression
);
18065 -- Semantically inspect expression Expr to determine whether it violates
18066 -- preelaborability. This routine raises Non_Preelaborable.
18072 procedure Visit
(Nod
: Node_Id
) is
18074 case Nkind
(Nod
) is
18078 when N_Component_Declaration
=>
18080 -- Defining_Identifier is left out because it is not relevant
18081 -- for preelaborability.
18083 Visit
(Component_Definition
(Nod
));
18084 Visit
(Expression
(Nod
));
18086 when N_Derived_Type_Definition
=>
18088 -- Interface_List is left out because it is not relevant for
18089 -- preelaborability.
18091 Visit
(Record_Extension_Part
(Nod
));
18092 Visit
(Subtype_Indication
(Nod
));
18094 when N_Entry_Declaration
=>
18096 -- A protected type with at leat one entry is not preelaborable
18097 -- while task types are never preelaborable. This renders entry
18098 -- declarations non-preelaborable.
18100 raise Non_Preelaborable
;
18102 when N_Full_Type_Declaration
=>
18104 -- Defining_Identifier and Discriminant_Specifications are left
18105 -- out because they are not relevant for preelaborability.
18107 Visit
(Type_Definition
(Nod
));
18109 when N_Function_Instantiation
18110 | N_Package_Instantiation
18111 | N_Procedure_Instantiation
18113 -- Defining_Unit_Name and Name are left out because they are
18114 -- not relevant for preelaborability.
18116 Visit_List
(Generic_Associations
(Nod
));
18118 when N_Object_Declaration
=>
18120 -- Defining_Identifier is left out because it is not relevant
18121 -- for preelaborability.
18123 Visit
(Object_Definition
(Nod
));
18125 if Has_Init_Expression
(Nod
) then
18126 Visit
(Expression
(Nod
));
18128 elsif not Constant_Present
(Nod
)
18129 and then not Has_Preelaborable_Initialization
18130 (Etype
(Defining_Entity
(Nod
)))
18132 raise Non_Preelaborable
;
18135 when N_Private_Extension_Declaration
18136 | N_Subtype_Declaration
18138 -- Defining_Identifier, Discriminant_Specifications, and
18139 -- Interface_List are left out because they are not relevant
18140 -- for preelaborability.
18142 Visit
(Subtype_Indication
(Nod
));
18144 when N_Protected_Type_Declaration
18145 | N_Single_Protected_Declaration
18147 -- Defining_Identifier, Discriminant_Specifications, and
18148 -- Interface_List are left out because they are not relevant
18149 -- for preelaborability.
18151 Visit
(Protected_Definition
(Nod
));
18153 -- A [single] task type is never preelaborable
18155 when N_Single_Task_Declaration
18156 | N_Task_Type_Declaration
18158 raise Non_Preelaborable
;
18163 Visit_Pragma
(Nod
);
18167 when N_Statement_Other_Than_Procedure_Call
=>
18168 if Nkind
(Nod
) /= N_Null_Statement
then
18169 raise Non_Preelaborable
;
18175 Visit_Subexpression
(Nod
);
18179 when N_Access_To_Object_Definition
=>
18180 Visit
(Subtype_Indication
(Nod
));
18182 when N_Case_Expression_Alternative
=>
18183 Visit
(Expression
(Nod
));
18184 Visit_List
(Discrete_Choices
(Nod
));
18186 when N_Component_Definition
=>
18187 Visit
(Access_Definition
(Nod
));
18188 Visit
(Subtype_Indication
(Nod
));
18190 when N_Component_List
=>
18191 Visit_List
(Component_Items
(Nod
));
18192 Visit
(Variant_Part
(Nod
));
18194 when N_Constrained_Array_Definition
=>
18195 Visit_List
(Discrete_Subtype_Definitions
(Nod
));
18196 Visit
(Component_Definition
(Nod
));
18198 when N_Delta_Constraint
18199 | N_Digits_Constraint
18201 -- Delta_Expression and Digits_Expression are left out because
18202 -- they are not relevant for preelaborability.
18204 Visit
(Range_Constraint
(Nod
));
18206 when N_Discriminant_Specification
=>
18208 -- Defining_Identifier and Expression are left out because they
18209 -- are not relevant for preelaborability.
18211 Visit
(Discriminant_Type
(Nod
));
18213 when N_Generic_Association
=>
18215 -- Selector_Name is left out because it is not relevant for
18216 -- preelaborability.
18218 Visit
(Explicit_Generic_Actual_Parameter
(Nod
));
18220 when N_Index_Or_Discriminant_Constraint
=>
18221 Visit_List
(Constraints
(Nod
));
18223 when N_Iterator_Specification
=>
18225 -- Defining_Identifier is left out because it is not relevant
18226 -- for preelaborability.
18228 Visit
(Name
(Nod
));
18229 Visit
(Subtype_Indication
(Nod
));
18231 when N_Loop_Parameter_Specification
=>
18233 -- Defining_Identifier is left out because it is not relevant
18234 -- for preelaborability.
18236 Visit
(Discrete_Subtype_Definition
(Nod
));
18238 when N_Parameter_Association
=>
18239 Visit
(Explicit_Actual_Parameter
(N
));
18241 when N_Protected_Definition
=>
18243 -- End_Label is left out because it is not relevant for
18244 -- preelaborability.
18246 Visit_List
(Private_Declarations
(Nod
));
18247 Visit_List
(Visible_Declarations
(Nod
));
18249 when N_Range_Constraint
=>
18250 Visit
(Range_Expression
(Nod
));
18252 when N_Record_Definition
18255 -- End_Label, Discrete_Choices, and Interface_List are left out
18256 -- because they are not relevant for preelaborability.
18258 Visit
(Component_List
(Nod
));
18260 when N_Subtype_Indication
=>
18262 -- Subtype_Mark is left out because it is not relevant for
18263 -- preelaborability.
18265 Visit
(Constraint
(Nod
));
18267 when N_Unconstrained_Array_Definition
=>
18269 -- Subtype_Marks is left out because it is not relevant for
18270 -- preelaborability.
18272 Visit
(Component_Definition
(Nod
));
18274 when N_Variant_Part
=>
18276 -- Name is left out because it is not relevant for
18277 -- preelaborability.
18279 Visit_List
(Variants
(Nod
));
18292 procedure Visit_List
(List
: List_Id
) is
18296 Nod
:= First
(List
);
18297 while Present
(Nod
) loop
18307 procedure Visit_Pragma
(Prag
: Node_Id
) is
18309 case Get_Pragma_Id
(Prag
) is
18311 | Pragma_Assert_And_Cut
18313 | Pragma_Async_Readers
18314 | Pragma_Async_Writers
18315 | Pragma_Attribute_Definition
18317 | Pragma_Constant_After_Elaboration
18319 | Pragma_Deadline_Floor
18320 | Pragma_Dispatching_Domain
18321 | Pragma_Effective_Reads
18322 | Pragma_Effective_Writes
18323 | Pragma_Extensions_Visible
18325 | Pragma_Secondary_Stack_Size
18327 | Pragma_Volatile_Function
18329 Visit_List
(Pragma_Argument_Associations
(Prag
));
18338 -------------------------
18339 -- Visit_Subexpression --
18340 -------------------------
18342 procedure Visit_Subexpression
(Expr
: Node_Id
) is
18343 procedure Visit_Aggregate
(Aggr
: Node_Id
);
18344 pragma Inline
(Visit_Aggregate
);
18345 -- Semantically inspect aggregate Aggr to determine whether it
18346 -- violates preelaborability.
18348 ---------------------
18349 -- Visit_Aggregate --
18350 ---------------------
18352 procedure Visit_Aggregate
(Aggr
: Node_Id
) is
18354 if not Is_Preelaborable_Aggregate
(Aggr
) then
18355 raise Non_Preelaborable
;
18357 end Visit_Aggregate
;
18359 -- Start of processing for Visit_Subexpression
18362 case Nkind
(Expr
) is
18364 | N_Qualified_Expression
18365 | N_Type_Conversion
18366 | N_Unchecked_Expression
18367 | N_Unchecked_Type_Conversion
18369 -- Subpool_Handle_Name and Subtype_Mark are left out because
18370 -- they are not relevant for preelaborability.
18372 Visit
(Expression
(Expr
));
18375 | N_Extension_Aggregate
18377 Visit_Aggregate
(Expr
);
18379 when N_Attribute_Reference
18380 | N_Explicit_Dereference
18383 -- Attribute_Name and Expressions are left out because they are
18384 -- not relevant for preelaborability.
18386 Visit
(Prefix
(Expr
));
18388 when N_Case_Expression
=>
18390 -- End_Span is left out because it is not relevant for
18391 -- preelaborability.
18393 Visit_List
(Alternatives
(Expr
));
18394 Visit
(Expression
(Expr
));
18396 when N_Delta_Aggregate
=>
18397 Visit_Aggregate
(Expr
);
18398 Visit
(Expression
(Expr
));
18400 when N_Expression_With_Actions
=>
18401 Visit_List
(Actions
(Expr
));
18402 Visit
(Expression
(Expr
));
18404 when N_Function_Call
=>
18406 -- Ada 2022 (AI12-0175): Calls to certain functions that are
18407 -- essentially unchecked conversions are preelaborable.
18409 if Ada_Version
>= Ada_2022
18410 and then Nkind
(Expr
) = N_Function_Call
18411 and then Is_Entity_Name
(Name
(Expr
))
18412 and then Is_Preelaborable_Function
(Entity
(Name
(Expr
)))
18414 Visit_List
(Parameter_Associations
(Expr
));
18416 raise Non_Preelaborable
;
18419 when N_If_Expression
=>
18420 Visit_List
(Expressions
(Expr
));
18422 when N_Quantified_Expression
=>
18423 Visit
(Condition
(Expr
));
18424 Visit
(Iterator_Specification
(Expr
));
18425 Visit
(Loop_Parameter_Specification
(Expr
));
18428 Visit
(High_Bound
(Expr
));
18429 Visit
(Low_Bound
(Expr
));
18432 Visit
(Discrete_Range
(Expr
));
18433 Visit
(Prefix
(Expr
));
18439 -- The evaluation of an object name is not preelaborable,
18440 -- unless the name is a static expression (checked further
18441 -- below), or statically denotes a discriminant.
18443 if Is_Entity_Name
(Expr
) then
18444 Object_Name
: declare
18445 Id
: constant Entity_Id
:= Entity
(Expr
);
18448 if Is_Object
(Id
) then
18449 if Ekind
(Id
) = E_Discriminant
then
18452 elsif Ekind
(Id
) in E_Constant | E_In_Parameter
18453 and then Present
(Discriminal_Link
(Id
))
18458 raise Non_Preelaborable
;
18463 -- A non-static expression is not preelaborable
18465 elsif not Is_OK_Static_Expression
(Expr
) then
18466 raise Non_Preelaborable
;
18469 end Visit_Subexpression
;
18471 -- Start of processing for Is_Non_Preelaborable_Construct
18476 -- At this point it is known that the construct is preelaborable
18482 -- The elaboration of the construct performs an action which violates
18483 -- preelaborability.
18485 when Non_Preelaborable
=>
18487 end Is_Non_Preelaborable_Construct
;
18489 ---------------------------------
18490 -- Is_Nontrivial_DIC_Procedure --
18491 ---------------------------------
18493 function Is_Nontrivial_DIC_Procedure
(Id
: Entity_Id
) return Boolean is
18494 Body_Decl
: Node_Id
;
18498 if Ekind
(Id
) = E_Procedure
and then Is_DIC_Procedure
(Id
) then
18500 Unit_Declaration_Node
18501 (Corresponding_Body
(Unit_Declaration_Node
(Id
)));
18503 -- The body of the Default_Initial_Condition procedure must contain
18504 -- at least one statement, otherwise the generation of the subprogram
18507 pragma Assert
(Present
(Handled_Statement_Sequence
(Body_Decl
)));
18509 -- To qualify as nontrivial, the first statement of the procedure
18510 -- must be a check in the form of an if statement. If the original
18511 -- Default_Initial_Condition expression was folded, then the first
18512 -- statement is not a check.
18514 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Body_Decl
)));
18517 Nkind
(Stmt
) = N_If_Statement
18518 and then Nkind
(Original_Node
(Stmt
)) = N_Pragma
;
18522 end Is_Nontrivial_DIC_Procedure
;
18524 -----------------------
18525 -- Is_Null_Extension --
18526 -----------------------
18528 function Is_Null_Extension
18529 (T
: Entity_Id
; Ignore_Privacy
: Boolean := False) return Boolean
18531 Type_Decl
: Node_Id
;
18532 Type_Def
: Node_Id
;
18534 pragma Assert
(not Is_Class_Wide_Type
(T
));
18536 if Ignore_Privacy
then
18537 Type_Decl
:= Parent
(Underlying_Type
(Base_Type
(T
)));
18539 Type_Decl
:= Parent
(Base_Type
(T
));
18540 if Nkind
(Type_Decl
) /= N_Full_Type_Declaration
then
18544 pragma Assert
(Nkind
(Type_Decl
) = N_Full_Type_Declaration
);
18545 Type_Def
:= Type_Definition
(Type_Decl
);
18546 if Present
(Discriminant_Specifications
(Type_Decl
))
18547 or else Nkind
(Type_Def
) /= N_Derived_Type_Definition
18548 or else not Is_Tagged_Type
(T
)
18549 or else No
(Record_Extension_Part
(Type_Def
))
18554 return Is_Null_Record_Definition
(Record_Extension_Part
(Type_Def
));
18555 end Is_Null_Extension
;
18557 --------------------------
18558 -- Is_Null_Extension_Of --
18559 --------------------------
18561 function Is_Null_Extension_Of
18562 (Descendant
, Ancestor
: Entity_Id
) return Boolean
18564 Ancestor_Type
: constant Entity_Id
18565 := Underlying_Type
(Base_Type
(Ancestor
));
18566 Descendant_Type
: Entity_Id
:= Underlying_Type
(Base_Type
(Descendant
));
18568 pragma Assert
(not Is_Class_Wide_Type
(Descendant
));
18569 pragma Assert
(not Is_Class_Wide_Type
(Ancestor
));
18570 pragma Assert
(Descendant_Type
/= Ancestor_Type
);
18572 while Descendant_Type
/= Ancestor_Type
loop
18573 if not Is_Null_Extension
18574 (Descendant_Type
, Ignore_Privacy
=> True)
18578 Descendant_Type
:= Etype
(Subtype_Indication
18579 (Type_Definition
(Parent
(Descendant_Type
))));
18580 Descendant_Type
:= Underlying_Type
(Base_Type
(Descendant_Type
));
18583 end Is_Null_Extension_Of
;
18585 -------------------------------
18586 -- Is_Null_Record_Definition --
18587 -------------------------------
18589 function Is_Null_Record_Definition
(Record_Def
: Node_Id
) return Boolean is
18592 -- Testing Null_Present is just an optimization, not required.
18594 if Null_Present
(Record_Def
) then
18596 elsif Present
(Variant_Part
(Component_List
(Record_Def
))) then
18598 elsif No
(Component_List
(Record_Def
)) then
18602 Item
:= First
(Component_Items
(Component_List
(Record_Def
)));
18604 while Present
(Item
) loop
18605 if Nkind
(Item
) = N_Component_Declaration
18606 and then Is_Internal_Name
(Chars
(Defining_Identifier
(Item
)))
18609 elsif Nkind
(Item
) = N_Pragma
then
18614 Item
:= Next
(Item
);
18618 end Is_Null_Record_Definition
;
18620 -------------------------
18621 -- Is_Null_Record_Type --
18622 -------------------------
18624 function Is_Null_Record_Type
18625 (T
: Entity_Id
; Ignore_Privacy
: Boolean := False) return Boolean
18628 Type_Def
: Node_Id
;
18630 if not Is_Record_Type
(T
) then
18634 if Ignore_Privacy
then
18635 Decl
:= Parent
(Underlying_Type
(Base_Type
(T
)));
18637 Decl
:= Parent
(Base_Type
(T
));
18638 if Nkind
(Decl
) /= N_Full_Type_Declaration
then
18642 pragma Assert
(Nkind
(Decl
) = N_Full_Type_Declaration
);
18643 Type_Def
:= Type_Definition
(Decl
);
18645 if Has_Discriminants
(Defining_Identifier
(Decl
)) then
18649 case Nkind
(Type_Def
) is
18650 when N_Record_Definition
=>
18651 return Is_Null_Record_Definition
(Type_Def
);
18652 when N_Derived_Type_Definition
=>
18653 if not Is_Null_Record_Type
18654 (Etype
(Subtype_Indication
(Type_Def
)),
18655 Ignore_Privacy
=> Ignore_Privacy
)
18658 elsif not Is_Tagged_Type
(T
) then
18661 return Is_Null_Extension
(T
, Ignore_Privacy
=> Ignore_Privacy
);
18666 end Is_Null_Record_Type
;
18668 ---------------------
18669 -- Is_Object_Image --
18670 ---------------------
18672 function Is_Object_Image
(Prefix
: Node_Id
) return Boolean is
18674 -- Here we test for the case that the prefix is not a type and assume
18675 -- if it is not then it must be a named value or an object reference.
18676 -- This is because the parser always checks that prefixes of attributes
18679 return not (Is_Entity_Name
(Prefix
)
18680 and then Is_Type
(Entity
(Prefix
))
18681 and then not Is_Current_Instance
(Prefix
));
18682 end Is_Object_Image
;
18684 -------------------------
18685 -- Is_Object_Reference --
18686 -------------------------
18688 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
18689 function Safe_Prefix
(N
: Node_Id
) return Node_Id
;
18690 -- Return Prefix (N) unless it has been rewritten as an
18691 -- N_Raise_xxx_Error node, in which case return its original node.
18697 function Safe_Prefix
(N
: Node_Id
) return Node_Id
is
18699 if Nkind
(Prefix
(N
)) in N_Raise_xxx_Error
then
18700 return Original_Node
(Prefix
(N
));
18707 -- AI12-0068: Note that a current instance reference in a type or
18708 -- subtype's aspect_specification is considered a value, not an object
18709 -- (see RM 8.6(18/5)).
18711 if Is_Entity_Name
(N
) then
18712 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
))
18713 and then not Is_Current_Instance_Reference_In_Type_Aspect
(N
);
18717 when N_Indexed_Component
18721 Is_Object_Reference
(Safe_Prefix
(N
))
18722 or else Is_Access_Type
(Etype
(Safe_Prefix
(N
)));
18724 -- In Ada 95, a function call is a constant object; a procedure
18727 -- Note that predefined operators are functions as well, and so
18728 -- are attributes that are (can be renamed as) functions.
18730 when N_Function_Call
18733 return Etype
(N
) /= Standard_Void_Type
;
18735 -- Attributes references 'Loop_Entry, 'Old, 'Priority and 'Result
18736 -- yield objects, even though they are not functions.
18738 when N_Attribute_Reference
=>
18740 Attribute_Name
(N
) in Name_Loop_Entry
18744 or else Is_Function_Attribute_Name
(Attribute_Name
(N
));
18746 when N_Selected_Component
=>
18748 Is_Object_Reference
(Selector_Name
(N
))
18750 (Is_Object_Reference
(Safe_Prefix
(N
))
18751 or else Is_Access_Type
(Etype
(Safe_Prefix
(N
))));
18753 -- An explicit dereference denotes an object, except that a
18754 -- conditional expression gets turned into an explicit dereference
18755 -- in some cases, and conditional expressions are not object
18758 when N_Explicit_Dereference
=>
18759 return Nkind
(Original_Node
(N
)) not in
18760 N_Case_Expression | N_If_Expression
;
18762 -- A view conversion of a tagged object is an object reference
18764 when N_Type_Conversion
=>
18765 if Ada_Version
<= Ada_2012
then
18766 -- A view conversion of a tagged object is an object
18768 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
18769 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
18770 and then Is_Object_Reference
(Expression
(N
));
18773 -- AI12-0226: In Ada 2022 a value conversion of an object is
18776 return Is_Object_Reference
(Expression
(N
));
18779 -- An unchecked type conversion is considered to be an object if
18780 -- the operand is an object (this construction arises only as a
18781 -- result of expansion activities).
18783 when N_Unchecked_Type_Conversion
=>
18786 -- AI05-0003: In Ada 2012 a qualified expression is a name.
18787 -- This allows disambiguation of function calls and the use
18788 -- of aggregates in more contexts.
18790 when N_Qualified_Expression
=>
18791 return Ada_Version
>= Ada_2012
18792 and then Is_Object_Reference
(Expression
(N
));
18794 -- In Ada 95 an aggregate is an object reference
18797 | N_Delta_Aggregate
18798 | N_Extension_Aggregate
18800 return Ada_Version
>= Ada_95
;
18802 -- A string literal is not an object reference, but it might come
18803 -- from rewriting of an object reference, e.g. from folding of an
18806 when N_String_Literal
=>
18807 return Is_Rewrite_Substitution
(N
)
18808 and then Is_Object_Reference
(Original_Node
(N
));
18810 -- AI12-0125: Target name represents a constant object
18812 when N_Target_Name
=>
18819 end Is_Object_Reference
;
18821 -----------------------------------
18822 -- Is_OK_Variable_For_Out_Formal --
18823 -----------------------------------
18825 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
18827 Note_Possible_Modification
(AV
, Sure
=> True);
18829 -- We must reject parenthesized variable names. Comes_From_Source is
18830 -- checked because there are currently cases where the compiler violates
18831 -- this rule (e.g. passing a task object to its controlled Initialize
18832 -- routine). This should be properly documented in sinfo???
18834 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
18837 -- A variable is always allowed
18839 elsif Is_Variable
(AV
) then
18842 -- Generalized indexing operations are rewritten as explicit
18843 -- dereferences, and it is only during resolution that we can
18844 -- check whether the context requires an access_to_variable type.
18846 elsif Nkind
(AV
) = N_Explicit_Dereference
18847 and then Present
(Etype
(Original_Node
(AV
)))
18848 and then Has_Implicit_Dereference
(Etype
(Original_Node
(AV
)))
18849 and then Ada_Version
>= Ada_2012
18851 return not Is_Access_Constant
(Etype
(Prefix
(AV
)));
18853 -- Unchecked conversions are allowed only if they come from the
18854 -- generated code, which sometimes uses unchecked conversions for out
18855 -- parameters in cases where code generation is unaffected. We tell
18856 -- source unchecked conversions by seeing if they are rewrites of
18857 -- an original Unchecked_Conversion function call, or of an explicit
18858 -- conversion of a function call or an aggregate (as may happen in the
18859 -- expansion of a packed array aggregate).
18861 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
18862 if Nkind
(Original_Node
(AV
)) in N_Function_Call | N_Aggregate
then
18865 elsif Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
then
18868 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
18869 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
18875 -- Normal type conversions are allowed if argument is a variable
18877 elsif Nkind
(AV
) = N_Type_Conversion
then
18878 if Is_Variable
(Expression
(AV
))
18879 and then Paren_Count
(Expression
(AV
)) = 0
18881 Note_Possible_Modification
(Expression
(AV
), Sure
=> True);
18884 -- We also allow a non-parenthesized expression that raises
18885 -- constraint error if it rewrites what used to be a variable
18887 elsif Raises_Constraint_Error
(Expression
(AV
))
18888 and then Paren_Count
(Expression
(AV
)) = 0
18889 and then Is_Variable
(Original_Node
(Expression
(AV
)))
18893 -- Type conversion of something other than a variable
18899 -- If this node is rewritten, then test the original form, if that is
18900 -- OK, then we consider the rewritten node OK (for example, if the
18901 -- original node is a conversion, then Is_Variable will not be true
18902 -- but we still want to allow the conversion if it converts a variable).
18904 elsif Is_Rewrite_Substitution
(AV
) then
18905 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
18907 -- All other non-variables are rejected
18912 end Is_OK_Variable_For_Out_Formal
;
18914 ----------------------------
18915 -- Is_OK_Volatile_Context --
18916 ----------------------------
18918 function Is_OK_Volatile_Context
18919 (Context
: Node_Id
;
18921 Check_Actuals
: Boolean) return Boolean
18923 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean;
18924 -- Determine whether an arbitrary node denotes a call to a protected
18925 -- entry, function, or procedure in prefixed form where the prefix is
18928 function Within_Check
(Nod
: Node_Id
) return Boolean;
18929 -- Determine whether an arbitrary node appears in a check node
18931 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean;
18932 -- Determine whether an arbitrary entity appears in a volatile function
18934 ---------------------------------
18935 -- Is_Protected_Operation_Call --
18936 ---------------------------------
18938 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean is
18943 -- A call to a protected operations retains its selected component
18944 -- form as opposed to other prefixed calls that are transformed in
18947 if Nkind
(Nod
) = N_Selected_Component
then
18948 Pref
:= Prefix
(Nod
);
18949 Subp
:= Selector_Name
(Nod
);
18953 and then Present
(Etype
(Pref
))
18954 and then Is_Protected_Type
(Etype
(Pref
))
18955 and then Is_Entity_Name
(Subp
)
18956 and then Present
(Entity
(Subp
))
18957 and then Ekind
(Entity
(Subp
)) in
18958 E_Entry | E_Entry_Family | E_Function | E_Procedure
;
18962 end Is_Protected_Operation_Call
;
18968 function Within_Check
(Nod
: Node_Id
) return Boolean is
18972 -- Climb the parent chain looking for a check node
18975 while Present
(Par
) loop
18976 if Nkind
(Par
) in N_Raise_xxx_Error
then
18979 -- Prevent the search from going too far
18981 elsif Is_Body_Or_Package_Declaration
(Par
) then
18985 Par
:= Parent
(Par
);
18991 ------------------------------
18992 -- Within_Volatile_Function --
18993 ------------------------------
18995 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean is
18996 pragma Assert
(Ekind
(Id
) = E_Return_Statement
);
18998 Func_Id
: constant Entity_Id
:= Return_Applies_To
(Id
);
19001 pragma Assert
(Ekind
(Func_Id
) in E_Function | E_Generic_Function
);
19003 return Is_Volatile_Function
(Func_Id
);
19004 end Within_Volatile_Function
;
19008 Obj_Id
: Entity_Id
;
19010 -- Start of processing for Is_OK_Volatile_Context
19013 -- Ignore context restriction when doing preanalysis, e.g. on a copy of
19014 -- an expression function, because this copy is not fully decorated and
19015 -- it is not possible to reliably decide the legality of the context.
19016 -- Any violations will be reported anyway when doing the full analysis.
19018 if not Full_Analysis
then
19022 -- For actual parameters within explicit parameter associations switch
19023 -- the context to the corresponding subprogram call.
19025 if Nkind
(Context
) = N_Parameter_Association
then
19026 return Is_OK_Volatile_Context
(Context
=> Parent
(Context
),
19027 Obj_Ref
=> Obj_Ref
,
19028 Check_Actuals
=> Check_Actuals
);
19030 -- The volatile object appears on either side of an assignment
19032 elsif Nkind
(Context
) = N_Assignment_Statement
then
19035 -- The volatile object is part of the initialization expression of
19038 elsif Nkind
(Context
) = N_Object_Declaration
19039 and then Present
(Expression
(Context
))
19040 and then Expression
(Context
) = Obj_Ref
19041 and then Nkind
(Parent
(Context
)) /= N_Expression_With_Actions
19043 Obj_Id
:= Defining_Entity
(Context
);
19045 -- The volatile object acts as the initialization expression of an
19046 -- extended return statement. This is valid context as long as the
19047 -- function is volatile.
19049 if Is_Return_Object
(Obj_Id
) then
19050 return Within_Volatile_Function
(Scope
(Obj_Id
));
19052 -- Otherwise this is a normal object initialization
19058 -- The volatile object acts as the name of a renaming declaration
19060 elsif Nkind
(Context
) = N_Object_Renaming_Declaration
19061 and then Name
(Context
) = Obj_Ref
19065 -- The volatile object appears as an actual parameter in a call to an
19066 -- instance of Unchecked_Conversion whose result is renamed.
19068 elsif Nkind
(Context
) = N_Function_Call
19069 and then Is_Entity_Name
(Name
(Context
))
19070 and then Is_Unchecked_Conversion_Instance
(Entity
(Name
(Context
)))
19071 and then Nkind
(Parent
(Context
)) = N_Object_Renaming_Declaration
19075 -- The volatile object is actually the prefix in a protected entry,
19076 -- function, or procedure call.
19078 elsif Is_Protected_Operation_Call
(Context
) then
19081 -- The volatile object appears as the expression of a simple return
19082 -- statement that applies to a volatile function.
19084 elsif Nkind
(Context
) = N_Simple_Return_Statement
19085 and then Expression
(Context
) = Obj_Ref
19088 Within_Volatile_Function
(Return_Statement_Entity
(Context
));
19090 -- The volatile object appears as the prefix of a name occurring in a
19091 -- non-interfering context.
19093 elsif Nkind
(Context
) in
19094 N_Attribute_Reference |
19095 N_Explicit_Dereference |
19096 N_Indexed_Component |
19097 N_Selected_Component |
19099 and then Prefix
(Context
) = Obj_Ref
19100 and then Is_OK_Volatile_Context
19101 (Context
=> Parent
(Context
),
19102 Obj_Ref
=> Context
,
19103 Check_Actuals
=> Check_Actuals
)
19107 -- The volatile object appears as the prefix of attributes Address,
19108 -- Alignment, Component_Size, First, First_Bit, Last, Last_Bit, Length,
19109 -- Position, Size, Storage_Size.
19111 elsif Nkind
(Context
) = N_Attribute_Reference
19112 and then Prefix
(Context
) = Obj_Ref
19113 and then Attribute_Name
(Context
) in Name_Address
19115 | Name_Component_Size
19123 | Name_Storage_Size
19127 -- The volatile object appears as the expression of a type conversion
19128 -- occurring in a non-interfering context.
19130 elsif Nkind
(Context
) in N_Qualified_Expression
19131 | N_Type_Conversion
19132 | N_Unchecked_Type_Conversion
19133 and then Expression
(Context
) = Obj_Ref
19134 and then Is_OK_Volatile_Context
19135 (Context
=> Parent
(Context
),
19136 Obj_Ref
=> Context
,
19137 Check_Actuals
=> Check_Actuals
)
19141 -- The volatile object appears as the expression in a delay statement
19143 elsif Nkind
(Context
) in N_Delay_Statement
then
19146 -- Allow references to volatile objects in various checks. This is not a
19147 -- direct SPARK 2014 requirement.
19149 elsif Within_Check
(Context
) then
19152 -- References to effectively volatile objects that appear as actual
19153 -- parameters in subprogram calls can be examined only after call itself
19154 -- has been resolved. Before that, assume such references to be legal.
19156 elsif Nkind
(Context
) in N_Subprogram_Call | N_Entry_Call_Statement
then
19157 if Check_Actuals
then
19160 Formal
: Entity_Id
;
19161 Subp
: constant Entity_Id
:= Get_Called_Entity
(Context
);
19163 Find_Actual
(Obj_Ref
, Formal
, Call
);
19164 pragma Assert
(Call
= Context
);
19166 -- An effectively volatile object may act as an actual when the
19167 -- corresponding formal is of a non-scalar effectively volatile
19168 -- type (SPARK RM 7.1.3(10)).
19170 if not Is_Scalar_Type
(Etype
(Formal
))
19171 and then Is_Effectively_Volatile_For_Reading
(Etype
(Formal
))
19175 -- An effectively volatile object may act as an actual in a
19176 -- call to an instance of Unchecked_Conversion. (SPARK RM
19179 elsif Is_Unchecked_Conversion_Instance
(Subp
) then
19192 end Is_OK_Volatile_Context
;
19194 ------------------------------------
19195 -- Is_Package_Contract_Annotation --
19196 ------------------------------------
19198 function Is_Package_Contract_Annotation
(Item
: Node_Id
) return Boolean is
19202 if Nkind
(Item
) = N_Aspect_Specification
then
19203 Nam
:= Chars
(Identifier
(Item
));
19205 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
19206 Nam
:= Pragma_Name
(Item
);
19209 return Nam
= Name_Abstract_State
19210 or else Nam
= Name_Initial_Condition
19211 or else Nam
= Name_Initializes
19212 or else Nam
= Name_Refined_State
;
19213 end Is_Package_Contract_Annotation
;
19215 -----------------------------------
19216 -- Is_Partially_Initialized_Type --
19217 -----------------------------------
19219 function Is_Partially_Initialized_Type
19221 Include_Implicit
: Boolean := True) return Boolean
19224 if Is_Scalar_Type
(Typ
) then
19225 return Has_Default_Aspect
(Base_Type
(Typ
));
19227 elsif Is_Access_Type
(Typ
) then
19228 return Include_Implicit
;
19230 elsif Is_Array_Type
(Typ
) then
19232 -- If component type is partially initialized, so is array type
19234 if Has_Default_Aspect
(Base_Type
(Typ
))
19235 or else Is_Partially_Initialized_Type
19236 (Component_Type
(Typ
), Include_Implicit
)
19240 -- Otherwise we are only partially initialized if we are fully
19241 -- initialized (this is the empty array case, no point in us
19242 -- duplicating that code here).
19245 return Is_Fully_Initialized_Type
(Typ
);
19248 elsif Is_Record_Type
(Typ
) then
19250 -- A discriminated type is always partially initialized if in
19253 if Has_Discriminants
(Typ
) and then Include_Implicit
then
19256 -- A tagged type is always partially initialized
19258 elsif Is_Tagged_Type
(Typ
) then
19261 -- Case of nondiscriminated record
19267 Component_Present
: Boolean := False;
19268 -- Set True if at least one component is present. If no
19269 -- components are present, then record type is fully
19270 -- initialized (another odd case, like the null array).
19273 -- Loop through components
19275 Comp
:= First_Component
(Typ
);
19276 while Present
(Comp
) loop
19277 Component_Present
:= True;
19279 -- If a component has an initialization expression then the
19280 -- enclosing record type is partially initialized
19282 if Present
(Parent
(Comp
))
19283 and then Present
(Expression
(Parent
(Comp
)))
19287 -- If a component is of a type which is itself partially
19288 -- initialized, then the enclosing record type is also.
19290 elsif Is_Partially_Initialized_Type
19291 (Etype
(Comp
), Include_Implicit
)
19296 Next_Component
(Comp
);
19299 -- No initialized components found. If we found any components
19300 -- they were all uninitialized so the result is false.
19302 if Component_Present
then
19305 -- But if we found no components, then all the components are
19306 -- initialized so we consider the type to be initialized.
19314 -- Concurrent types are always fully initialized
19316 elsif Is_Concurrent_Type
(Typ
) then
19319 -- For a private type, go to underlying type. If there is no underlying
19320 -- type then just assume this partially initialized. Not clear if this
19321 -- can happen in a non-error case, but no harm in testing for this.
19323 elsif Is_Private_Type
(Typ
) then
19325 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
19330 return Is_Partially_Initialized_Type
(U
, Include_Implicit
);
19334 -- For any other type (are there any?) assume partially initialized
19339 end Is_Partially_Initialized_Type
;
19341 ------------------------------------
19342 -- Is_Potentially_Persistent_Type --
19343 ------------------------------------
19345 function Is_Potentially_Persistent_Type
(T
: Entity_Id
) return Boolean is
19350 -- For private type, test corresponding full type
19352 if Is_Private_Type
(T
) then
19353 return Is_Potentially_Persistent_Type
(Full_View
(T
));
19355 -- Scalar types are potentially persistent
19357 elsif Is_Scalar_Type
(T
) then
19360 -- Record type is potentially persistent if not tagged and the types of
19361 -- all it components are potentially persistent, and no component has
19362 -- an initialization expression.
19364 elsif Is_Record_Type
(T
)
19365 and then not Is_Tagged_Type
(T
)
19366 and then not Is_Partially_Initialized_Type
(T
)
19368 Comp
:= First_Component
(T
);
19369 while Present
(Comp
) loop
19370 if not Is_Potentially_Persistent_Type
(Etype
(Comp
)) then
19373 Next_Entity
(Comp
);
19379 -- Array type is potentially persistent if its component type is
19380 -- potentially persistent and if all its constraints are static.
19382 elsif Is_Array_Type
(T
) then
19383 if not Is_Potentially_Persistent_Type
(Component_Type
(T
)) then
19387 Indx
:= First_Index
(T
);
19388 while Present
(Indx
) loop
19389 if not Is_OK_Static_Subtype
(Etype
(Indx
)) then
19398 -- All other types are not potentially persistent
19403 end Is_Potentially_Persistent_Type
;
19405 --------------------------------
19406 -- Is_Potentially_Unevaluated --
19407 --------------------------------
19409 function Is_Potentially_Unevaluated
(N
: Node_Id
) return Boolean is
19410 function Has_Null_Others_Choice
(Aggr
: Node_Id
) return Boolean;
19411 -- Aggr is an array aggregate with static bounds and an others clause;
19412 -- return True if the others choice of the given array aggregate does
19413 -- not cover any component (i.e. is null).
19415 function Immediate_Context_Implies_Is_Potentially_Unevaluated
19416 (Expr
: Node_Id
) return Boolean;
19417 -- Return True if the *immediate* context of this expression tells us
19418 -- that it is potentially unevaluated; return False if the *immediate*
19419 -- context doesn't provide an answer to this question and we need to
19422 function Non_Static_Or_Null_Range
(N
: Node_Id
) return Boolean;
19423 -- Return True if the given range is nonstatic or null
19425 ----------------------------
19426 -- Has_Null_Others_Choice --
19427 ----------------------------
19429 function Has_Null_Others_Choice
(Aggr
: Node_Id
) return Boolean is
19430 Idx
: constant Node_Id
:= First_Index
(Etype
(Aggr
));
19431 Hiv
: constant Uint
:= Expr_Value
(Type_High_Bound
(Etype
(Idx
)));
19432 Lov
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Etype
(Idx
)));
19436 Intervals
: constant Interval_Lists
.Discrete_Interval_List
:=
19437 Interval_Lists
.Aggregate_Intervals
(Aggr
);
19440 -- The others choice is null if, after normalization, we
19441 -- have a single interval covering the whole aggregate.
19443 return Intervals
'Length = 1
19445 Intervals
(Intervals
'First).Low
= Lov
19447 Intervals
(Intervals
'First).High
= Hiv
;
19450 -- If the aggregate is malformed (that is, indexes are not disjoint)
19451 -- then no action is needed at this stage; the error will be reported
19452 -- later by the frontend.
19455 when Interval_Lists
.Intervals_Error
=>
19457 end Has_Null_Others_Choice
;
19459 ----------------------------------------------------------
19460 -- Immediate_Context_Implies_Is_Potentially_Unevaluated --
19461 ----------------------------------------------------------
19463 function Immediate_Context_Implies_Is_Potentially_Unevaluated
19464 (Expr
: Node_Id
) return Boolean
19466 Par
: constant Node_Id
:= Parent
(Expr
);
19468 function Aggregate_Type
return Node_Id
is (Etype
(Parent
(Par
)));
19470 if Nkind
(Par
) = N_If_Expression
then
19471 return Is_Elsif
(Par
) or else Expr
/= First
(Expressions
(Par
));
19473 elsif Nkind
(Par
) = N_Case_Expression
then
19474 return Expr
/= Expression
(Par
);
19476 elsif Nkind
(Par
) in N_And_Then | N_Or_Else
then
19477 return Expr
= Right_Opnd
(Par
);
19479 elsif Nkind
(Par
) in N_In | N_Not_In
then
19481 -- If the membership includes several alternatives, only the first
19482 -- is definitely evaluated.
19484 if Present
(Alternatives
(Par
)) then
19485 return Expr
/= First
(Alternatives
(Par
));
19487 -- If this is a range membership both bounds are evaluated
19493 elsif Nkind
(Par
) = N_Quantified_Expression
then
19494 return Expr
= Condition
(Par
);
19496 elsif Nkind
(Par
) = N_Component_Association
19497 and then Expr
= Expression
(Par
)
19498 and then Nkind
(Parent
(Par
))
19499 in N_Aggregate | N_Delta_Aggregate | N_Extension_Aggregate
19500 and then Present
(Aggregate_Type
)
19501 and then Aggregate_Type
/= Any_Composite
19503 if Is_Array_Type
(Aggregate_Type
) then
19504 if Ada_Version
>= Ada_2022
then
19505 -- For Ada 2022, this predicate returns True for
19506 -- any "repeatedly evaluated" expression.
19512 In_Others_Choice
: Boolean := False;
19513 Array_Agg
: constant Node_Id
:= Parent
(Par
);
19515 -- The expression of an array_component_association is
19516 -- potentially unevaluated if the associated choice is a
19517 -- subtype_indication or range that defines a nonstatic or
19520 Choice
:= First
(Choices
(Par
));
19521 while Present
(Choice
) loop
19522 if Nkind
(Choice
) = N_Range
19523 and then Non_Static_Or_Null_Range
(Choice
)
19527 elsif Nkind
(Choice
) = N_Identifier
19528 and then Present
(Scalar_Range
(Etype
(Choice
)))
19530 Non_Static_Or_Null_Range
19531 (Scalar_Range
(Etype
(Choice
)))
19535 elsif Nkind
(Choice
) = N_Others_Choice
then
19536 In_Others_Choice
:= True;
19542 -- It is also potentially unevaluated if the associated
19543 -- choice is an others choice and the applicable index
19544 -- constraint is nonstatic or null.
19546 if In_Others_Choice
then
19547 if not Compile_Time_Known_Bounds
(Aggregate_Type
) then
19550 return Has_Null_Others_Choice
(Array_Agg
);
19555 elsif Is_Container_Aggregate
(Parent
(Par
)) then
19556 -- a component of a container aggregate
19565 end Immediate_Context_Implies_Is_Potentially_Unevaluated
;
19567 ------------------------------
19568 -- Non_Static_Or_Null_Range --
19569 ------------------------------
19571 function Non_Static_Or_Null_Range
(N
: Node_Id
) return Boolean is
19572 Low
, High
: Node_Id
;
19575 Get_Index_Bounds
(N
, Low
, High
);
19577 -- Check static bounds
19579 if not Compile_Time_Known_Value
(Low
)
19580 or else not Compile_Time_Known_Value
(High
)
19584 -- Check null range
19586 elsif Expr_Value
(High
) < Expr_Value
(Low
) then
19591 end Non_Static_Or_Null_Range
;
19598 -- Start of processing for Is_Potentially_Unevaluated
19604 -- A postcondition whose expression is a short-circuit is broken down
19605 -- into individual aspects for better exception reporting. The original
19606 -- short-circuit expression is rewritten as the second operand, and an
19607 -- occurrence of 'Old in that operand is potentially unevaluated.
19608 -- See sem_ch13.adb for details of this transformation. The reference
19609 -- to 'Old may appear within an expression, so we must look for the
19610 -- enclosing pragma argument in the tree that contains the reference.
19612 while Present
(Par
)
19613 and then Nkind
(Par
) /= N_Pragma_Argument_Association
19615 if Is_Rewrite_Substitution
(Par
)
19616 and then Nkind
(Original_Node
(Par
)) = N_And_Then
19621 Par
:= Parent
(Par
);
19624 -- Other cases; 'Old appears within other expression (not the top-level
19625 -- conjunct in a postcondition) with a potentially unevaluated operand.
19627 Par
:= Parent
(Expr
);
19629 while Present
(Par
)
19630 and then Nkind
(Par
) /= N_Pragma_Argument_Association
19632 if Comes_From_Source
(Par
)
19634 Immediate_Context_Implies_Is_Potentially_Unevaluated
(Expr
)
19638 -- For component associations continue climbing; it may be part of
19639 -- an array aggregate.
19641 elsif Nkind
(Par
) = N_Component_Association
then
19644 -- If the context is not an expression, or if is the result of
19645 -- expansion of an enclosing construct (such as another attribute)
19646 -- the predicate does not apply.
19648 elsif Nkind
(Par
) = N_Case_Expression_Alternative
then
19651 elsif Nkind
(Par
) not in N_Subexpr
19652 or else not Comes_From_Source
(Par
)
19658 Par
:= Parent
(Par
);
19662 end Is_Potentially_Unevaluated
;
19664 -----------------------------------------
19665 -- Is_Predefined_Dispatching_Operation --
19666 -----------------------------------------
19668 function Is_Predefined_Dispatching_Operation
19669 (E
: Entity_Id
) return Boolean
19671 TSS_Name
: TSS_Name_Type
;
19674 if not Is_Dispatching_Operation
(E
) then
19678 Get_Name_String
(Chars
(E
));
19680 -- Most predefined primitives have internally generated names. Equality
19681 -- must be treated differently; the predefined operation is recognized
19682 -- as a homogeneous binary operator that returns Boolean.
19684 if Name_Len
> TSS_Name_Type
'Last then
19687 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
19689 if Chars
(E
) in Name_uAssign | Name_uSize
19691 (Chars
(E
) = Name_Op_Eq
19692 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
19693 or else TSS_Name
= TSS_Deep_Adjust
19694 or else TSS_Name
= TSS_Deep_Finalize
19695 or else TSS_Name
= TSS_Stream_Input
19696 or else TSS_Name
= TSS_Stream_Output
19697 or else TSS_Name
= TSS_Stream_Read
19698 or else TSS_Name
= TSS_Stream_Write
19699 or else TSS_Name
= TSS_Put_Image
19700 or else Is_Predefined_Interface_Primitive
(E
)
19707 end Is_Predefined_Dispatching_Operation
;
19709 ---------------------------------------
19710 -- Is_Predefined_Interface_Primitive --
19711 ---------------------------------------
19713 function Is_Predefined_Interface_Primitive
(E
: Entity_Id
) return Boolean is
19715 -- In VM targets we don't restrict the functionality of this test to
19716 -- compiling in Ada 2005 mode since in VM targets any tagged type has
19717 -- these primitives.
19719 return (Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
)
19720 and then Chars
(E
) in Name_uDisp_Asynchronous_Select
19721 | Name_uDisp_Conditional_Select
19722 | Name_uDisp_Get_Prim_Op_Kind
19723 | Name_uDisp_Get_Task_Id
19724 | Name_uDisp_Requeue
19725 | Name_uDisp_Timed_Select
;
19726 end Is_Predefined_Interface_Primitive
;
19728 ---------------------------------------
19729 -- Is_Predefined_Internal_Operation --
19730 ---------------------------------------
19732 function Is_Predefined_Internal_Operation
19733 (E
: Entity_Id
) return Boolean
19735 TSS_Name
: TSS_Name_Type
;
19738 if not Is_Dispatching_Operation
(E
) then
19742 Get_Name_String
(Chars
(E
));
19744 -- Most predefined primitives have internally generated names. Equality
19745 -- must be treated differently; the predefined operation is recognized
19746 -- as a homogeneous binary operator that returns Boolean.
19748 if Name_Len
> TSS_Name_Type
'Last then
19751 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
19753 if Chars
(E
) in Name_uSize | Name_uAssign
19755 (Chars
(E
) = Name_Op_Eq
19756 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
19757 or else TSS_Name
= TSS_Deep_Adjust
19758 or else TSS_Name
= TSS_Deep_Finalize
19759 or else Is_Predefined_Interface_Primitive
(E
)
19766 end Is_Predefined_Internal_Operation
;
19768 --------------------------------
19769 -- Is_Preelaborable_Aggregate --
19770 --------------------------------
19772 function Is_Preelaborable_Aggregate
(Aggr
: Node_Id
) return Boolean is
19773 Aggr_Typ
: constant Entity_Id
:= Etype
(Aggr
);
19774 Array_Aggr
: constant Boolean := Is_Array_Type
(Aggr_Typ
);
19776 Anc_Part
: Node_Id
;
19779 Comp_Typ
: Entity_Id
:= Empty
; -- init to avoid warning
19784 Comp_Typ
:= Component_Type
(Aggr_Typ
);
19787 -- Inspect the ancestor part
19789 if Nkind
(Aggr
) = N_Extension_Aggregate
then
19790 Anc_Part
:= Ancestor_Part
(Aggr
);
19792 -- The ancestor denotes a subtype mark
19794 if Is_Entity_Name
(Anc_Part
)
19795 and then Is_Type
(Entity
(Anc_Part
))
19797 if not Has_Preelaborable_Initialization
(Entity
(Anc_Part
)) then
19801 -- Otherwise the ancestor denotes an expression
19803 elsif not Is_Preelaborable_Construct
(Anc_Part
) then
19808 -- Inspect the positional associations
19810 Expr
:= First
(Expressions
(Aggr
));
19811 while Present
(Expr
) loop
19812 if not Is_Preelaborable_Construct
(Expr
) then
19819 -- Inspect the named associations
19821 Assoc
:= First
(Component_Associations
(Aggr
));
19822 while Present
(Assoc
) loop
19824 -- Inspect the choices of the current named association
19826 Choice
:= First
(Choices
(Assoc
));
19827 while Present
(Choice
) loop
19830 -- For a choice to be preelaborable, it must denote either a
19831 -- static range or a static expression.
19833 if Nkind
(Choice
) = N_Others_Choice
then
19836 elsif Nkind
(Choice
) = N_Range
then
19837 if not Is_OK_Static_Range
(Choice
) then
19841 elsif not Is_OK_Static_Expression
(Choice
) then
19846 Comp_Typ
:= Etype
(Choice
);
19852 -- The type of the choice must have preelaborable initialization if
19853 -- the association carries a <>.
19855 pragma Assert
(Present
(Comp_Typ
));
19856 if Box_Present
(Assoc
) then
19857 if not Has_Preelaborable_Initialization
(Comp_Typ
) then
19861 -- The type of the expression must have preelaborable initialization
19863 elsif not Is_Preelaborable_Construct
(Expression
(Assoc
)) then
19870 -- At this point the aggregate is preelaborable
19873 end Is_Preelaborable_Aggregate
;
19875 --------------------------------
19876 -- Is_Preelaborable_Construct --
19877 --------------------------------
19879 function Is_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
19883 if Nkind
(N
) in N_Aggregate | N_Extension_Aggregate
then
19884 return Is_Preelaborable_Aggregate
(N
);
19886 -- Attributes are allowed in general, even if their prefix is a formal
19887 -- type. It seems that certain attributes known not to be static might
19888 -- not be allowed, but there are no rules to prevent them.
19890 elsif Nkind
(N
) = N_Attribute_Reference
then
19895 elsif Nkind
(N
) in N_Subexpr
and then Is_OK_Static_Expression
(N
) then
19898 elsif Nkind
(N
) = N_Qualified_Expression
then
19899 return Is_Preelaborable_Construct
(Expression
(N
));
19901 -- Names are preelaborable when they denote a discriminant of an
19902 -- enclosing type. Discriminals are also considered for this check.
19904 elsif Is_Entity_Name
(N
)
19905 and then Present
(Entity
(N
))
19907 (Ekind
(Entity
(N
)) = E_Discriminant
19908 or else (Ekind
(Entity
(N
)) in E_Constant | E_In_Parameter
19909 and then Present
(Discriminal_Link
(Entity
(N
)))))
19915 elsif Nkind
(N
) = N_Null
then
19918 -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially
19919 -- unchecked conversions are preelaborable.
19921 elsif Ada_Version
>= Ada_2022
19922 and then Nkind
(N
) = N_Function_Call
19923 and then Is_Entity_Name
(Name
(N
))
19924 and then Is_Preelaborable_Function
(Entity
(Name
(N
)))
19929 A
:= First_Actual
(N
);
19931 while Present
(A
) loop
19932 if not Is_Preelaborable_Construct
(A
) then
19942 -- Otherwise the construct is not preelaborable
19947 end Is_Preelaborable_Construct
;
19949 -------------------------------
19950 -- Is_Preelaborable_Function --
19951 -------------------------------
19953 function Is_Preelaborable_Function
(Id
: Entity_Id
) return Boolean is
19954 SATAC
: constant Rtsfind
.RTU_Id
:= System_Address_To_Access_Conversions
;
19955 Scop
: constant Entity_Id
:= Scope
(Id
);
19958 -- Small optimization: every allowed function has convention Intrinsic
19959 -- (see Analyze_Subprogram_Instantiation for the subtlety in the test).
19961 if not Is_Intrinsic_Subprogram
(Id
)
19962 and then Convention
(Id
) /= Convention_Intrinsic
19967 -- An instance of Unchecked_Conversion
19969 if Is_Unchecked_Conversion_Instance
(Id
) then
19973 -- A function declared in System.Storage_Elements
19975 if Is_RTU
(Scop
, System_Storage_Elements
) then
19979 -- The functions To_Pointer and To_Address declared in an instance of
19980 -- System.Address_To_Access_Conversions (they are the only ones).
19982 if Ekind
(Scop
) = E_Package
19983 and then Nkind
(Parent
(Scop
)) = N_Package_Specification
19984 and then Present
(Generic_Parent
(Parent
(Scop
)))
19985 and then Is_RTU
(Generic_Parent
(Parent
(Scop
)), SATAC
)
19991 end Is_Preelaborable_Function
;
19993 -----------------------------
19994 -- Is_Private_Library_Unit --
19995 -----------------------------
19997 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean is
19998 Comp_Unit
: constant Node_Id
:= Parent
(Unit_Declaration_Node
(Unit
));
20000 return Nkind
(Comp_Unit
) = N_Compilation_Unit
20001 and then Private_Present
(Comp_Unit
);
20002 end Is_Private_Library_Unit
;
20004 ---------------------------------
20005 -- Is_Protected_Self_Reference --
20006 ---------------------------------
20008 function Is_Protected_Self_Reference
(N
: Node_Id
) return Boolean is
20010 function In_Access_Definition
(N
: Node_Id
) return Boolean;
20011 -- Returns true if N belongs to an access definition
20013 --------------------------
20014 -- In_Access_Definition --
20015 --------------------------
20017 function In_Access_Definition
(N
: Node_Id
) return Boolean is
20022 while Present
(P
) loop
20023 if Nkind
(P
) = N_Access_Definition
then
20031 end In_Access_Definition
;
20033 -- Start of processing for Is_Protected_Self_Reference
20036 -- Verify that prefix is analyzed and has the proper form. Note that
20037 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also
20038 -- produce the address of an entity, do not analyze their prefix
20039 -- because they denote entities that are not necessarily visible.
20040 -- Neither of them can apply to a protected type.
20042 return Ada_Version
>= Ada_2005
20043 and then Is_Entity_Name
(N
)
20044 and then Present
(Entity
(N
))
20045 and then Is_Protected_Type
(Entity
(N
))
20046 and then In_Open_Scopes
(Entity
(N
))
20047 and then not In_Access_Definition
(N
);
20048 end Is_Protected_Self_Reference
;
20050 -----------------------------
20051 -- Is_RCI_Pkg_Spec_Or_Body --
20052 -----------------------------
20054 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
20056 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
20057 -- Return True if the unit of Cunit is an RCI package declaration
20059 ---------------------------
20060 -- Is_RCI_Pkg_Decl_Cunit --
20061 ---------------------------
20063 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
20064 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
20067 if Nkind
(The_Unit
) /= N_Package_Declaration
then
20071 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
20072 end Is_RCI_Pkg_Decl_Cunit
;
20074 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
20077 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
20079 (Nkind
(Unit
(Cunit
)) = N_Package_Body
20080 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
20081 end Is_RCI_Pkg_Spec_Or_Body
;
20083 -----------------------------------------
20084 -- Is_Remote_Access_To_Class_Wide_Type --
20085 -----------------------------------------
20087 function Is_Remote_Access_To_Class_Wide_Type
20088 (E
: Entity_Id
) return Boolean
20091 -- A remote access to class-wide type is a general access to object type
20092 -- declared in the visible part of a Remote_Types or Remote_Call_
20095 return Ekind
(E
) = E_General_Access_Type
20096 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
20097 end Is_Remote_Access_To_Class_Wide_Type
;
20099 -----------------------------------------
20100 -- Is_Remote_Access_To_Subprogram_Type --
20101 -----------------------------------------
20103 function Is_Remote_Access_To_Subprogram_Type
20104 (E
: Entity_Id
) return Boolean
20107 return (Ekind
(E
) = E_Access_Subprogram_Type
20108 or else (Ekind
(E
) = E_Record_Type
20109 and then Present
(Corresponding_Remote_Type
(E
))))
20110 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
20111 end Is_Remote_Access_To_Subprogram_Type
;
20113 --------------------
20114 -- Is_Remote_Call --
20115 --------------------
20117 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
20119 if Nkind
(N
) not in N_Subprogram_Call
then
20121 -- An entry call cannot be remote
20125 elsif Nkind
(Name
(N
)) in N_Has_Entity
20126 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
20128 -- A subprogram declared in the spec of a RCI package is remote
20132 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
20133 and then Is_Remote_Access_To_Subprogram_Type
20134 (Etype
(Prefix
(Name
(N
))))
20136 -- The dereference of a RAS is a remote call
20140 elsif Present
(Controlling_Argument
(N
))
20141 and then Is_Remote_Access_To_Class_Wide_Type
20142 (Etype
(Controlling_Argument
(N
)))
20144 -- Any primitive operation call with a controlling argument of
20145 -- a RACW type is a remote call.
20150 -- All other calls are local calls
20153 end Is_Remote_Call
;
20155 ----------------------
20156 -- Is_Renamed_Entry --
20157 ----------------------
20159 function Is_Renamed_Entry
(Proc_Nam
: Entity_Id
) return Boolean is
20160 Orig_Node
: Node_Id
:= Empty
;
20161 Subp_Decl
: Node_Id
:=
20162 (if No
(Parent
(Proc_Nam
)) then Empty
else Parent
(Parent
(Proc_Nam
)));
20164 function Is_Entry
(Nam
: Node_Id
) return Boolean;
20165 -- Determine whether Nam is an entry. Traverse selectors if there are
20166 -- nested selected components.
20172 function Is_Entry
(Nam
: Node_Id
) return Boolean is
20174 if Nkind
(Nam
) = N_Selected_Component
then
20175 return Is_Entry
(Selector_Name
(Nam
));
20178 return Ekind
(Entity
(Nam
)) = E_Entry
;
20181 -- Start of processing for Is_Renamed_Entry
20184 if Present
(Alias
(Proc_Nam
)) then
20185 Subp_Decl
:= Parent
(Parent
(Alias
(Proc_Nam
)));
20188 -- Look for a rewritten subprogram renaming declaration
20190 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
20191 and then Present
(Original_Node
(Subp_Decl
))
20193 Orig_Node
:= Original_Node
(Subp_Decl
);
20196 -- The rewritten subprogram is actually an entry
20198 if Present
(Orig_Node
)
20199 and then Nkind
(Orig_Node
) = N_Subprogram_Renaming_Declaration
20200 and then Is_Entry
(Name
(Orig_Node
))
20206 end Is_Renamed_Entry
;
20208 ----------------------------
20209 -- Is_Reversible_Iterator --
20210 ----------------------------
20212 function Is_Reversible_Iterator
(Typ
: Entity_Id
) return Boolean is
20213 Ifaces_List
: Elist_Id
;
20214 Iface_Elmt
: Elmt_Id
;
20218 if Is_Class_Wide_Type
(Typ
)
20219 and then Chars
(Root_Type
(Typ
)) = Name_Reversible_Iterator
20220 and then In_Predefined_Unit
(Root_Type
(Typ
))
20224 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
20228 Collect_Interfaces
(Typ
, Ifaces_List
);
20230 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
20231 while Present
(Iface_Elmt
) loop
20232 Iface
:= Node
(Iface_Elmt
);
20233 if Chars
(Iface
) = Name_Reversible_Iterator
20234 and then In_Predefined_Unit
(Iface
)
20239 Next_Elmt
(Iface_Elmt
);
20244 end Is_Reversible_Iterator
;
20246 ---------------------------------
20247 -- Is_Single_Concurrent_Object --
20248 ---------------------------------
20250 function Is_Single_Concurrent_Object
(Id
: Entity_Id
) return Boolean is
20253 Is_Single_Protected_Object
(Id
) or else Is_Single_Task_Object
(Id
);
20254 end Is_Single_Concurrent_Object
;
20256 -------------------------------
20257 -- Is_Single_Concurrent_Type --
20258 -------------------------------
20260 function Is_Single_Concurrent_Type
(Id
: Entity_Id
) return Boolean is
20263 Ekind
(Id
) in E_Protected_Type | E_Task_Type
20264 and then Is_Single_Concurrent_Type_Declaration
20265 (Declaration_Node
(Id
));
20266 end Is_Single_Concurrent_Type
;
20268 -------------------------------------------
20269 -- Is_Single_Concurrent_Type_Declaration --
20270 -------------------------------------------
20272 function Is_Single_Concurrent_Type_Declaration
20273 (N
: Node_Id
) return Boolean
20276 return Nkind
(Original_Node
(N
)) in
20277 N_Single_Protected_Declaration | N_Single_Task_Declaration
;
20278 end Is_Single_Concurrent_Type_Declaration
;
20280 ---------------------------------------------
20281 -- Is_Single_Precision_Floating_Point_Type --
20282 ---------------------------------------------
20284 function Is_Single_Precision_Floating_Point_Type
20285 (E
: Entity_Id
) return Boolean is
20287 return Is_Floating_Point_Type
(E
)
20288 and then Machine_Radix_Value
(E
) = Uint_2
20289 and then Machine_Mantissa_Value
(E
) = Uint_24
20290 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_7
20291 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_7
);
20292 end Is_Single_Precision_Floating_Point_Type
;
20294 --------------------------------
20295 -- Is_Single_Protected_Object --
20296 --------------------------------
20298 function Is_Single_Protected_Object
(Id
: Entity_Id
) return Boolean is
20301 Ekind
(Id
) = E_Variable
20302 and then Ekind
(Etype
(Id
)) = E_Protected_Type
20303 and then Is_Single_Concurrent_Type
(Etype
(Id
));
20304 end Is_Single_Protected_Object
;
20306 ---------------------------
20307 -- Is_Single_Task_Object --
20308 ---------------------------
20310 function Is_Single_Task_Object
(Id
: Entity_Id
) return Boolean is
20313 Ekind
(Id
) = E_Variable
20314 and then Ekind
(Etype
(Id
)) = E_Task_Type
20315 and then Is_Single_Concurrent_Type
(Etype
(Id
));
20316 end Is_Single_Task_Object
;
20318 -----------------------------
20319 -- Is_Specific_Tagged_Type --
20320 -----------------------------
20322 function Is_Specific_Tagged_Type
(Typ
: Entity_Id
) return Boolean is
20323 Full_Typ
: Entity_Id
;
20326 -- Handle private types
20328 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
20329 Full_Typ
:= Full_View
(Typ
);
20334 -- A specific tagged type is a non-class-wide tagged type
20336 return Is_Tagged_Type
(Full_Typ
) and not Is_Class_Wide_Type
(Full_Typ
);
20337 end Is_Specific_Tagged_Type
;
20343 function Is_Statement
(N
: Node_Id
) return Boolean is
20346 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
20347 or else Nkind
(N
) = N_Procedure_Call_Statement
;
20350 --------------------------------------
20351 -- Is_Static_Discriminant_Component --
20352 --------------------------------------
20354 function Is_Static_Discriminant_Component
(N
: Node_Id
) return Boolean is
20356 return Nkind
(N
) = N_Selected_Component
20357 and then not Is_In_Discriminant_Check
(N
)
20358 and then Present
(Etype
(Prefix
(N
)))
20359 and then Ekind
(Etype
(Prefix
(N
))) = E_Record_Subtype
20360 and then Has_Static_Discriminants
(Etype
(Prefix
(N
)))
20361 and then Present
(Entity
(Selector_Name
(N
)))
20362 and then Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
20363 and then not In_Check_Node
(N
);
20364 end Is_Static_Discriminant_Component
;
20366 ------------------------
20367 -- Is_Static_Function --
20368 ------------------------
20370 function Is_Static_Function
(Subp
: Entity_Id
) return Boolean is
20372 -- Always return False for pre Ada 2022 to e.g. ignore the Static
20373 -- aspect in package Interfaces for Ada_Version < 2022 and also
20376 return Ada_Version
>= Ada_2022
20377 and then Has_Aspect
(Subp
, Aspect_Static
)
20379 (No
(Find_Value_Of_Aspect
(Subp
, Aspect_Static
))
20380 or else Is_True
(Static_Boolean
20381 (Find_Value_Of_Aspect
(Subp
, Aspect_Static
))));
20382 end Is_Static_Function
;
20384 -----------------------------
20385 -- Is_Static_Function_Call --
20386 -----------------------------
20388 function Is_Static_Function_Call
(Call
: Node_Id
) return Boolean is
20389 function Has_All_Static_Actuals
(Call
: Node_Id
) return Boolean;
20390 -- Return whether all actual parameters of Call are static expressions
20392 ----------------------------
20393 -- Has_All_Static_Actuals --
20394 ----------------------------
20396 function Has_All_Static_Actuals
(Call
: Node_Id
) return Boolean is
20397 Actual
: Node_Id
:= First_Actual
(Call
);
20398 String_Result
: constant Boolean :=
20399 Is_String_Type
(Etype
(Entity
(Name
(Call
))));
20402 while Present
(Actual
) loop
20403 if not Is_Static_Expression
(Actual
) then
20405 -- ??? In the string-returning case we want to avoid a call
20406 -- being made to Establish_Transient_Scope in Resolve_Call,
20407 -- but at the point where that's tested for (which now includes
20408 -- a call to test Is_Static_Function_Call), the actuals of the
20409 -- call haven't been resolved, so expressions of the actuals
20410 -- may not have been marked Is_Static_Expression yet, so we
20411 -- force them to be resolved here, so we can tell if they're
20412 -- static. Calling Resolve here is admittedly a kludge, and we
20413 -- limit this call to string-returning cases.
20415 if String_Result
then
20419 -- Test flag again in case it's now True due to above Resolve
20421 if not Is_Static_Expression
(Actual
) then
20426 Next_Actual
(Actual
);
20430 end Has_All_Static_Actuals
;
20433 return Nkind
(Call
) = N_Function_Call
20434 and then Is_Entity_Name
(Name
(Call
))
20435 and then Is_Static_Function
(Entity
(Name
(Call
)))
20436 and then Has_All_Static_Actuals
(Call
);
20437 end Is_Static_Function_Call
;
20439 -------------------------------------------
20440 -- Is_Subcomponent_Of_Full_Access_Object --
20441 -------------------------------------------
20443 function Is_Subcomponent_Of_Full_Access_Object
(N
: Node_Id
) return Boolean
20448 R
:= Get_Referenced_Object
(N
);
20450 while Nkind
(R
) in N_Indexed_Component | N_Selected_Component | N_Slice
20452 R
:= Get_Referenced_Object
(Prefix
(R
));
20454 -- If the prefix is an access value, only the designated type matters
20456 if Is_Access_Type
(Etype
(R
)) then
20457 if Is_Full_Access
(Designated_Type
(Etype
(R
))) then
20462 if Is_Full_Access_Object
(R
) then
20469 end Is_Subcomponent_Of_Full_Access_Object
;
20471 ---------------------------------------
20472 -- Is_Subprogram_Contract_Annotation --
20473 ---------------------------------------
20475 function Is_Subprogram_Contract_Annotation
20476 (Item
: Node_Id
) return Boolean
20481 if Nkind
(Item
) = N_Aspect_Specification
then
20482 Nam
:= Chars
(Identifier
(Item
));
20484 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
20485 Nam
:= Pragma_Name
(Item
);
20488 return Nam
= Name_Contract_Cases
20489 or else Nam
= Name_Depends
20490 or else Nam
= Name_Extensions_Visible
20491 or else Nam
= Name_Global
20492 or else Nam
= Name_Post
20493 or else Nam
= Name_Post_Class
20494 or else Nam
= Name_Postcondition
20495 or else Nam
= Name_Pre
20496 or else Nam
= Name_Pre_Class
20497 or else Nam
= Name_Precondition
20498 or else Nam
= Name_Refined_Depends
20499 or else Nam
= Name_Refined_Global
20500 or else Nam
= Name_Refined_Post
20501 or else Nam
= Name_Subprogram_Variant
20502 or else Nam
= Name_Test_Case
;
20503 end Is_Subprogram_Contract_Annotation
;
20505 --------------------------------------------------
20506 -- Is_Subprogram_Stub_Without_Prior_Declaration --
20507 --------------------------------------------------
20509 function Is_Subprogram_Stub_Without_Prior_Declaration
20510 (N
: Node_Id
) return Boolean
20513 pragma Assert
(Nkind
(N
) = N_Subprogram_Body_Stub
);
20515 case Ekind
(Defining_Entity
(N
)) is
20517 -- A subprogram stub without prior declaration serves as declaration
20518 -- for the actual subprogram body. As such, it has an attached
20519 -- defining entity of E_Function or E_Procedure.
20526 -- Otherwise, it is completes a [generic] subprogram declaration
20528 when E_Generic_Function
20529 | E_Generic_Procedure
20530 | E_Subprogram_Body
20535 raise Program_Error
;
20537 end Is_Subprogram_Stub_Without_Prior_Declaration
;
20539 ---------------------------
20540 -- Is_Suitable_Primitive --
20541 ---------------------------
20543 function Is_Suitable_Primitive
(Subp_Id
: Entity_Id
) return Boolean is
20545 -- The Default_Initial_Condition and invariant procedures must not be
20546 -- treated as primitive operations even when they apply to a tagged
20547 -- type. These routines must not act as targets of dispatching calls
20548 -- because they already utilize class-wide-precondition semantics to
20549 -- handle inheritance and overriding.
20551 if Ekind
(Subp_Id
) = E_Procedure
20552 and then (Is_DIC_Procedure
(Subp_Id
)
20554 Is_Invariant_Procedure
(Subp_Id
))
20560 end Is_Suitable_Primitive
;
20562 ----------------------------
20563 -- Is_Synchronized_Object --
20564 ----------------------------
20566 function Is_Synchronized_Object
(Id
: Entity_Id
) return Boolean is
20570 if Is_Object
(Id
) then
20572 -- The object is synchronized if it is of a type that yields a
20573 -- synchronized object.
20575 if Yields_Synchronized_Object
(Etype
(Id
)) then
20578 -- The object is synchronized if it is atomic and Async_Writers is
20581 elsif Is_Atomic_Object_Entity
(Id
)
20582 and then Async_Writers_Enabled
(Id
)
20586 -- A constant is a synchronized object by default, unless its type is
20587 -- access-to-variable type.
20589 elsif Ekind
(Id
) = E_Constant
20590 and then not Is_Access_Variable
(Etype
(Id
))
20594 -- A variable is a synchronized object if it is subject to pragma
20595 -- Constant_After_Elaboration.
20597 elsif Ekind
(Id
) = E_Variable
then
20598 Prag
:= Get_Pragma
(Id
, Pragma_Constant_After_Elaboration
);
20600 return Present
(Prag
) and then Is_Enabled_Pragma
(Prag
);
20604 -- Otherwise the input is not an object or it does not qualify as a
20605 -- synchronized object.
20608 end Is_Synchronized_Object
;
20610 ---------------------------------
20611 -- Is_Synchronized_Tagged_Type --
20612 ---------------------------------
20614 function Is_Synchronized_Tagged_Type
(E
: Entity_Id
) return Boolean is
20615 Kind
: constant Entity_Kind
:= Ekind
(Base_Type
(E
));
20618 -- A task or protected type derived from an interface is a tagged type.
20619 -- Such a tagged type is called a synchronized tagged type, as are
20620 -- synchronized interfaces and private extensions whose declaration
20621 -- includes the reserved word synchronized.
20623 return (Is_Tagged_Type
(E
)
20624 and then (Kind
= E_Task_Type
20626 Kind
= E_Protected_Type
))
20629 and then Is_Synchronized_Interface
(E
))
20631 (Ekind
(E
) = E_Record_Type_With_Private
20632 and then Nkind
(Parent
(E
)) = N_Private_Extension_Declaration
20633 and then (Synchronized_Present
(Parent
(E
))
20634 or else Is_Synchronized_Interface
(Etype
(E
))));
20635 end Is_Synchronized_Tagged_Type
;
20641 function Is_Transfer
(N
: Node_Id
) return Boolean is
20642 Kind
: constant Node_Kind
:= Nkind
(N
);
20645 if Kind
in N_Simple_Return_Statement
20646 | N_Extended_Return_Statement
20648 | N_Raise_Statement
20649 | N_Requeue_Statement
20653 elsif Kind
in N_Exit_Statement | N_Raise_xxx_Error
20654 and then No
(Condition
(N
))
20658 elsif Kind
= N_Procedure_Call_Statement
20659 and then Is_Entity_Name
(Name
(N
))
20660 and then Present
(Entity
(Name
(N
)))
20661 and then No_Return
(Entity
(Name
(N
)))
20665 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
20677 function Is_True
(U
: Opt_Ubool
) return Boolean is
20679 return No
(U
) or else U
= Uint_1
;
20682 ------------------------
20683 -- Is_Trivial_Boolean --
20684 ------------------------
20686 function Is_Trivial_Boolean
(N
: Node_Id
) return Boolean is
20688 return Comes_From_Source
(N
)
20689 and then Nkind
(N
) in N_Identifier | N_Expanded_Name
20690 and then Entity
(N
) in Standard_True | Standard_False
;
20691 end Is_Trivial_Boolean
;
20693 --------------------------------------
20694 -- Is_Unchecked_Conversion_Instance --
20695 --------------------------------------
20697 function Is_Unchecked_Conversion_Instance
(Id
: Entity_Id
) return Boolean is
20701 -- Look for a function whose generic parent is the predefined intrinsic
20702 -- function Unchecked_Conversion, or for one that renames such an
20705 if Ekind
(Id
) = E_Function
then
20706 Par
:= Parent
(Id
);
20708 if Nkind
(Par
) = N_Function_Specification
then
20709 Par
:= Generic_Parent
(Par
);
20711 if Present
(Par
) then
20713 Chars
(Par
) = Name_Unchecked_Conversion
20714 and then Is_Intrinsic_Subprogram
(Par
)
20715 and then In_Predefined_Unit
(Par
);
20718 Present
(Alias
(Id
))
20719 and then Is_Unchecked_Conversion_Instance
(Alias
(Id
));
20725 end Is_Unchecked_Conversion_Instance
;
20727 -------------------------------
20728 -- Is_Universal_Numeric_Type --
20729 -------------------------------
20731 function Is_Universal_Numeric_Type
(T
: Entity_Id
) return Boolean is
20733 return T
= Universal_Integer
or else T
= Universal_Real
;
20734 end Is_Universal_Numeric_Type
;
20736 ------------------------------
20737 -- Is_User_Defined_Equality --
20738 ------------------------------
20740 function Is_User_Defined_Equality
(Id
: Entity_Id
) return Boolean is
20741 F1
, F2
: Entity_Id
;
20744 -- An equality operator is a function that carries the name "=", returns
20745 -- Boolean, and has exactly two formal parameters of an identical type.
20747 if Ekind
(Id
) = E_Function
20748 and then Chars
(Id
) = Name_Op_Eq
20749 and then Base_Type
(Etype
(Id
)) = Standard_Boolean
20751 F1
:= First_Formal
(Id
);
20757 F2
:= Next_Formal
(F1
);
20759 return Present
(F2
)
20760 and then No
(Next_Formal
(F2
))
20761 and then Base_Type
(Etype
(F1
)) = Base_Type
(Etype
(F2
));
20766 end Is_User_Defined_Equality
;
20768 -----------------------------
20769 -- Is_User_Defined_Literal --
20770 -----------------------------
20772 function Is_User_Defined_Literal
20774 Typ
: Entity_Id
) return Boolean
20776 Literal_Aspect_Map
:
20777 constant array (N_Numeric_Or_String_Literal
) of Aspect_Id
:=
20778 (N_Integer_Literal
=> Aspect_Integer_Literal
,
20779 N_Real_Literal
=> Aspect_Real_Literal
,
20780 N_String_Literal
=> Aspect_String_Literal
);
20783 -- Return True when N is either a literal or a named number and the
20784 -- type has the appropriate user-defined literal aspect.
20786 return (Nkind
(N
) in N_Numeric_Or_String_Literal
20787 and then Has_Aspect
(Typ
, Literal_Aspect_Map
(Nkind
(N
))))
20789 (Is_Entity_Name
(N
)
20790 and then Present
(Entity
(N
))
20792 ((Ekind
(Entity
(N
)) = E_Named_Integer
20793 and then Has_Aspect
(Typ
, Aspect_Integer_Literal
))
20795 (Ekind
(Entity
(N
)) = E_Named_Real
20796 and then Has_Aspect
(Typ
, Aspect_Real_Literal
))));
20797 end Is_User_Defined_Literal
;
20799 --------------------------------------
20800 -- Is_Validation_Variable_Reference --
20801 --------------------------------------
20803 function Is_Validation_Variable_Reference
(N
: Node_Id
) return Boolean is
20804 Var
: constant Node_Id
:= Unqual_Conv
(N
);
20805 Var_Id
: Entity_Id
;
20810 if Is_Entity_Name
(Var
) then
20811 Var_Id
:= Entity
(Var
);
20816 and then Ekind
(Var_Id
) = E_Variable
20817 and then Present
(Validated_Object
(Var_Id
));
20818 end Is_Validation_Variable_Reference
;
20820 ----------------------------
20821 -- Is_Variable_Size_Array --
20822 ----------------------------
20824 function Is_Variable_Size_Array
(E
: Entity_Id
) return Boolean is
20828 pragma Assert
(Is_Array_Type
(E
));
20830 -- Check if some index is initialized with a non-constant value
20832 Idx
:= First_Index
(E
);
20833 while Present
(Idx
) loop
20834 if Nkind
(Idx
) = N_Range
then
20835 if not Is_Constant_Bound
(Low_Bound
(Idx
))
20836 or else not Is_Constant_Bound
(High_Bound
(Idx
))
20846 end Is_Variable_Size_Array
;
20848 -----------------------------
20849 -- Is_Variable_Size_Record --
20850 -----------------------------
20852 function Is_Variable_Size_Record
(E
: Entity_Id
) return Boolean is
20854 Comp_Typ
: Entity_Id
;
20857 pragma Assert
(Is_Record_Type
(E
));
20859 Comp
:= First_Component
(E
);
20860 while Present
(Comp
) loop
20861 Comp_Typ
:= Underlying_Type
(Etype
(Comp
));
20863 -- Recursive call if the record type has discriminants
20865 if Is_Record_Type
(Comp_Typ
)
20866 and then Has_Discriminants
(Comp_Typ
)
20867 and then Is_Variable_Size_Record
(Comp_Typ
)
20871 elsif Is_Array_Type
(Comp_Typ
)
20872 and then Is_Variable_Size_Array
(Comp_Typ
)
20877 Next_Component
(Comp
);
20881 end Is_Variable_Size_Record
;
20887 -- Should Is_Variable be refactored to better handle dereferences and
20888 -- technical debt ???
20890 function Is_Variable
20892 Use_Original_Node
: Boolean := True) return Boolean
20894 Orig_Node
: Node_Id
;
20896 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
20897 -- Within a protected function, the private components of the enclosing
20898 -- protected type are constants. A function nested within a (protected)
20899 -- procedure is not itself protected. Within the body of a protected
20900 -- function the current instance of the protected type is a constant.
20902 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
20903 -- Prefixes can involve implicit dereferences, in which case we must
20904 -- test for the case of a reference of a constant access type, which can
20905 -- can never be a variable.
20907 ---------------------------
20908 -- In_Protected_Function --
20909 ---------------------------
20911 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
20916 -- E is the current instance of a type
20918 if Is_Type
(E
) then
20927 if not Is_Protected_Type
(Prot
) then
20931 S
:= Current_Scope
;
20932 while Present
(S
) and then S
/= Prot
loop
20933 if Ekind
(S
) = E_Function
and then Scope
(S
) = Prot
then
20942 end In_Protected_Function
;
20944 ------------------------
20945 -- Is_Variable_Prefix --
20946 ------------------------
20948 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
20950 if Is_Access_Type
(Etype
(P
)) then
20951 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
20953 -- For the case of an indexed component whose prefix has a packed
20954 -- array type, the prefix has been rewritten into a type conversion.
20955 -- Determine variable-ness from the converted expression.
20957 elsif Nkind
(P
) = N_Type_Conversion
20958 and then not Comes_From_Source
(P
)
20959 and then Is_Packed_Array
(Etype
(P
))
20961 return Is_Variable
(Expression
(P
));
20964 return Is_Variable
(P
);
20966 end Is_Variable_Prefix
;
20968 -- Start of processing for Is_Variable
20971 -- Special check, allow x'Deref(expr) as a variable
20973 if Nkind
(N
) = N_Attribute_Reference
20974 and then Attribute_Name
(N
) = Name_Deref
20979 -- Check if we perform the test on the original node since this may be a
20980 -- test of syntactic categories which must not be disturbed by whatever
20981 -- rewriting might have occurred. For example, an aggregate, which is
20982 -- certainly NOT a variable, could be turned into a variable by
20985 if Use_Original_Node
then
20986 Orig_Node
:= Original_Node
(N
);
20991 -- Definitely OK if Assignment_OK is set. Since this is something that
20992 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
20994 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
20997 -- Normally we go to the original node, but there is one exception where
20998 -- we use the rewritten node, namely when it is an explicit dereference.
20999 -- The generated code may rewrite a prefix which is an access type with
21000 -- an explicit dereference. The dereference is a variable, even though
21001 -- the original node may not be (since it could be a constant of the
21004 -- In Ada 2005 we have a further case to consider: the prefix may be a
21005 -- function call given in prefix notation. The original node appears to
21006 -- be a selected component, but we need to examine the call.
21008 elsif Nkind
(N
) = N_Explicit_Dereference
21009 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
21010 and then Present
(Etype
(Orig_Node
))
21011 and then Is_Access_Type
(Etype
(Orig_Node
))
21013 -- Note that if the prefix is an explicit dereference that does not
21014 -- come from source, we must check for a rewritten function call in
21015 -- prefixed notation before other forms of rewriting, to prevent a
21019 (Nkind
(Orig_Node
) = N_Function_Call
21020 and then not Is_Access_Constant
(Etype
(Prefix
(N
))))
21022 Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
21024 -- Generalized indexing operations are rewritten as explicit
21025 -- dereferences, and it is only during resolution that we can
21026 -- check whether the context requires an access_to_variable type.
21028 elsif Nkind
(N
) = N_Explicit_Dereference
21029 and then Present
(Etype
(Orig_Node
))
21030 and then Has_Implicit_Dereference
(Etype
(Orig_Node
))
21031 and then Ada_Version
>= Ada_2012
21033 return not Is_Access_Constant
(Etype
(Prefix
(N
)));
21035 -- A function call is never a variable
21037 elsif Nkind
(N
) = N_Function_Call
then
21040 -- All remaining checks use the original node
21042 elsif Is_Entity_Name
(Orig_Node
)
21043 and then Present
(Entity
(Orig_Node
))
21046 E
: constant Entity_Id
:= Entity
(Orig_Node
);
21047 K
: constant Entity_Kind
:= Ekind
(E
);
21050 if Is_Loop_Parameter
(E
) then
21054 return (K
= E_Variable
21055 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
21056 or else (K
= E_Component
21057 and then not In_Protected_Function
(E
))
21058 or else (Present
(Etype
(E
))
21059 and then Is_Access_Variable
(Etype
(E
))
21060 and then Is_Dereferenced
(N
))
21061 or else K
= E_Out_Parameter
21062 or else K
= E_In_Out_Parameter
21063 or else K
= E_Generic_In_Out_Parameter
21065 -- Current instance of type. If this is a protected type, check
21066 -- we are not within the body of one of its protected functions.
21068 or else (Is_Type
(E
)
21069 and then In_Open_Scopes
(E
)
21070 and then not In_Protected_Function
(E
))
21072 or else (Is_Incomplete_Or_Private_Type
(E
)
21073 and then In_Open_Scopes
(Full_View
(E
)));
21077 case Nkind
(Orig_Node
) is
21078 when N_Indexed_Component
21081 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
21083 when N_Selected_Component
=>
21084 return (Is_Variable
(Selector_Name
(Orig_Node
))
21085 and then Is_Variable_Prefix
(Prefix
(Orig_Node
)))
21087 (Nkind
(N
) = N_Expanded_Name
21088 and then Scope
(Entity
(N
)) = Entity
(Prefix
(N
)));
21090 -- For an explicit dereference, the type of the prefix cannot
21091 -- be an access to constant or an access to subprogram.
21093 when N_Explicit_Dereference
=>
21095 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
21097 return Is_Access_Type
(Typ
)
21098 and then not Is_Access_Constant
(Root_Type
(Typ
))
21099 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
21102 -- The type conversion is the case where we do not deal with the
21103 -- context dependent special case of an actual parameter. Thus
21104 -- the type conversion is only considered a variable for the
21105 -- purposes of this routine if the target type is tagged. However,
21106 -- a type conversion is considered to be a variable if it does not
21107 -- come from source (this deals for example with the conversions
21108 -- of expressions to their actual subtypes).
21110 when N_Type_Conversion
=>
21111 return Is_Variable
(Expression
(Orig_Node
))
21113 (not Comes_From_Source
(Orig_Node
)
21115 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
21117 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
21119 -- GNAT allows an unchecked type conversion as a variable. This
21120 -- only affects the generation of internal expanded code, since
21121 -- calls to instantiations of Unchecked_Conversion are never
21122 -- considered variables (since they are function calls).
21124 when N_Unchecked_Type_Conversion
=>
21125 return Is_Variable
(Expression
(Orig_Node
));
21133 ------------------------
21134 -- Is_View_Conversion --
21135 ------------------------
21137 function Is_View_Conversion
(N
: Node_Id
) return Boolean is
21139 if Nkind
(N
) = N_Type_Conversion
21140 and then Nkind
(Unqual_Conv
(N
)) in N_Has_Etype
21142 if Is_Tagged_Type
(Etype
(N
))
21143 and then Is_Tagged_Type
(Etype
(Unqual_Conv
(N
)))
21147 elsif Is_Actual_Parameter
(N
)
21148 and then (Is_Actual_Out_Parameter
(N
)
21149 or else Is_Actual_In_Out_Parameter
(N
))
21156 end Is_View_Conversion
;
21158 ---------------------------
21159 -- Is_Visibly_Controlled --
21160 ---------------------------
21162 function Is_Visibly_Controlled
(T
: Entity_Id
) return Boolean is
21163 Root
: constant Entity_Id
:= Root_Type
(T
);
21165 return Chars
(Scope
(Root
)) = Name_Finalization
21166 and then Chars
(Scope
(Scope
(Root
))) = Name_Ada
21167 and then Scope
(Scope
(Scope
(Root
))) = Standard_Standard
;
21168 end Is_Visibly_Controlled
;
21170 ----------------------------------------
21171 -- Is_Volatile_Full_Access_Object_Ref --
21172 ----------------------------------------
21174 function Is_Volatile_Full_Access_Object_Ref
(N
: Node_Id
) return Boolean is
21175 function Is_VFA_Object_Entity
(Id
: Entity_Id
) return Boolean;
21176 -- Determine whether arbitrary entity Id denotes an object that is
21177 -- Volatile_Full_Access.
21179 ----------------------------
21180 -- Is_VFA_Object_Entity --
21181 ----------------------------
21183 function Is_VFA_Object_Entity
(Id
: Entity_Id
) return Boolean is
21187 and then (Is_Volatile_Full_Access
(Id
)
21189 Is_Volatile_Full_Access
(Etype
(Id
)));
21190 end Is_VFA_Object_Entity
;
21192 -- Start of processing for Is_Volatile_Full_Access_Object_Ref
21195 if Is_Entity_Name
(N
) then
21196 return Is_VFA_Object_Entity
(Entity
(N
));
21198 elsif Is_Volatile_Full_Access
(Etype
(N
)) then
21201 elsif Nkind
(N
) = N_Selected_Component
then
21202 return Is_Volatile_Full_Access
(Entity
(Selector_Name
(N
)));
21207 end Is_Volatile_Full_Access_Object_Ref
;
21209 --------------------------
21210 -- Is_Volatile_Function --
21211 --------------------------
21213 function Is_Volatile_Function
(Func_Id
: Entity_Id
) return Boolean is
21215 pragma Assert
(Ekind
(Func_Id
) in E_Function | E_Generic_Function
);
21217 -- A protected function is volatile
21219 if Nkind
(Parent
(Unit_Declaration_Node
(Func_Id
))) =
21220 N_Protected_Definition
21224 -- An instance of Ada.Unchecked_Conversion is a volatile function if
21225 -- either the source or the target are effectively volatile.
21227 elsif Is_Unchecked_Conversion_Instance
(Func_Id
)
21228 and then Has_Effectively_Volatile_Profile
(Func_Id
)
21232 -- Otherwise the function is treated as volatile if it is subject to
21233 -- enabled pragma Volatile_Function.
21237 Is_Enabled_Pragma
(Get_Pragma
(Func_Id
, Pragma_Volatile_Function
));
21239 end Is_Volatile_Function
;
21241 ----------------------------
21242 -- Is_Volatile_Object_Ref --
21243 ----------------------------
21245 function Is_Volatile_Object_Ref
(N
: Node_Id
) return Boolean is
21246 function Is_Volatile_Object_Entity
(Id
: Entity_Id
) return Boolean;
21247 -- Determine whether arbitrary entity Id denotes an object that is
21250 function Prefix_Has_Volatile_Components
(P
: Node_Id
) return Boolean;
21251 -- Determine whether prefix P has volatile components. This requires
21252 -- the presence of a Volatile_Components aspect/pragma or that P be
21253 -- itself a volatile object as per RM C.6(8).
21255 ---------------------------------
21256 -- Is_Volatile_Object_Entity --
21257 ---------------------------------
21259 function Is_Volatile_Object_Entity
(Id
: Entity_Id
) return Boolean is
21263 and then (Is_Volatile
(Id
) or else Is_Volatile
(Etype
(Id
)));
21264 end Is_Volatile_Object_Entity
;
21266 ------------------------------------
21267 -- Prefix_Has_Volatile_Components --
21268 ------------------------------------
21270 function Prefix_Has_Volatile_Components
(P
: Node_Id
) return Boolean is
21271 Typ
: constant Entity_Id
:= Etype
(P
);
21274 if Is_Access_Type
(Typ
) then
21276 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
21279 return Has_Volatile_Components
(Dtyp
)
21280 or else Is_Volatile
(Dtyp
);
21283 elsif Has_Volatile_Components
(Typ
) then
21286 elsif Is_Entity_Name
(P
)
21287 and then Has_Volatile_Component
(Entity
(P
))
21291 elsif Is_Volatile_Object_Ref
(P
) then
21297 end Prefix_Has_Volatile_Components
;
21299 -- Start of processing for Is_Volatile_Object_Ref
21302 if Is_Entity_Name
(N
) then
21303 return Is_Volatile_Object_Entity
(Entity
(N
));
21305 elsif Is_Volatile
(Etype
(N
)) then
21308 elsif Nkind
(N
) = N_Indexed_Component
then
21309 return Prefix_Has_Volatile_Components
(Prefix
(N
));
21311 elsif Nkind
(N
) = N_Selected_Component
then
21312 return Prefix_Has_Volatile_Components
(Prefix
(N
))
21313 or else Is_Volatile
(Entity
(Selector_Name
(N
)));
21318 end Is_Volatile_Object_Ref
;
21320 -----------------------------
21321 -- Iterate_Call_Parameters --
21322 -----------------------------
21324 procedure Iterate_Call_Parameters
(Call
: Node_Id
) is
21325 Actual
: Node_Id
:= First_Actual
(Call
);
21326 Formal
: Entity_Id
:= First_Formal
(Get_Called_Entity
(Call
));
21329 while Present
(Formal
) and then Present
(Actual
) loop
21330 Handle_Parameter
(Formal
, Actual
);
21332 Next_Formal
(Formal
);
21333 Next_Actual
(Actual
);
21336 pragma Assert
(No
(Formal
));
21337 pragma Assert
(No
(Actual
));
21338 end Iterate_Call_Parameters
;
21340 -------------------------
21341 -- Kill_Current_Values --
21342 -------------------------
21344 procedure Kill_Current_Values
21346 Last_Assignment_Only
: Boolean := False)
21349 if Is_Assignable
(Ent
) then
21350 Set_Last_Assignment
(Ent
, Empty
);
21353 if Is_Object
(Ent
) then
21354 if not Last_Assignment_Only
then
21356 Set_Current_Value
(Ent
, Empty
);
21358 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags
21359 -- for a constant. Once the constant is elaborated, its value is
21360 -- not changed, therefore the associated flags that describe the
21361 -- value should not be modified either.
21363 if Ekind
(Ent
) = E_Constant
then
21366 -- Non-constant entities
21369 if not Can_Never_Be_Null
(Ent
) then
21370 Set_Is_Known_Non_Null
(Ent
, False);
21373 Set_Is_Known_Null
(Ent
, False);
21375 -- Reset the Is_Known_Valid flag unless the type is always
21376 -- valid. This does not apply to a loop parameter because its
21377 -- bounds are defined by the loop header and therefore always
21380 if not Is_Known_Valid
(Etype
(Ent
))
21381 and then Ekind
(Ent
) /= E_Loop_Parameter
21383 Set_Is_Known_Valid
(Ent
, False);
21388 end Kill_Current_Values
;
21390 procedure Kill_Current_Values
(Last_Assignment_Only
: Boolean := False) is
21394 -- Kill all saved checks, a special case of killing saved values
21396 if not Last_Assignment_Only
then
21400 -- Loop through relevant scopes, which includes the current scope and
21401 -- any parent scopes if the current scope is a block or a package.
21403 S
:= Current_Scope
;
21406 -- Clear current values of all entities in current scope
21411 Ent
:= First_Entity
(S
);
21412 while Present
(Ent
) loop
21413 Kill_Current_Values
(Ent
, Last_Assignment_Only
);
21418 -- If this is a not a subprogram, deal with parents
21420 if not Is_Subprogram
(S
) then
21422 exit Scope_Loop
when S
= Standard_Standard
;
21426 end loop Scope_Loop
;
21427 end Kill_Current_Values
;
21429 --------------------------
21430 -- Kill_Size_Check_Code --
21431 --------------------------
21433 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
21435 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
21436 and then Present
(Size_Check_Code
(E
))
21438 Remove
(Size_Check_Code
(E
));
21439 Set_Size_Check_Code
(E
, Empty
);
21441 end Kill_Size_Check_Code
;
21443 --------------------
21444 -- Known_Non_Null --
21445 --------------------
21447 function Known_Non_Null
(N
: Node_Id
) return Boolean is
21448 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
21455 -- The expression yields a non-null value ignoring simple flow analysis
21457 if Status
= Is_Non_Null
then
21460 -- Otherwise check whether N is a reference to an entity that appears
21461 -- within a conditional construct.
21463 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
21465 -- First check if we are in decisive conditional
21467 Get_Current_Value_Condition
(N
, Op
, Val
);
21469 if Known_Null
(Val
) then
21470 if Op
= N_Op_Eq
then
21472 elsif Op
= N_Op_Ne
then
21477 -- If OK to do replacement, test Is_Known_Non_Null flag
21481 if OK_To_Do_Constant_Replacement
(Id
) then
21482 return Is_Known_Non_Null
(Id
);
21486 -- Otherwise it is not possible to determine whether N yields a non-null
21490 end Known_Non_Null
;
21496 function Known_Null
(N
: Node_Id
) return Boolean is
21497 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
21504 -- The expression yields a null value ignoring simple flow analysis
21506 if Status
= Is_Null
then
21509 -- Otherwise check whether N is a reference to an entity that appears
21510 -- within a conditional construct.
21512 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
21514 -- First check if we are in decisive conditional
21516 Get_Current_Value_Condition
(N
, Op
, Val
);
21518 -- If Get_Current_Value_Condition were to return Val = N, then the
21519 -- recursion below could be infinite.
21522 raise Program_Error
;
21525 if Known_Null
(Val
) then
21526 if Op
= N_Op_Eq
then
21528 elsif Op
= N_Op_Ne
then
21533 -- If OK to do replacement, test Is_Known_Null flag
21537 if OK_To_Do_Constant_Replacement
(Id
) then
21538 return Is_Known_Null
(Id
);
21542 -- Otherwise it is not possible to determine whether N yields a null
21548 ---------------------------
21549 -- Last_Source_Statement --
21550 ---------------------------
21552 function Last_Source_Statement
(HSS
: Node_Id
) return Node_Id
is
21556 N
:= Last
(Statements
(HSS
));
21557 while Present
(N
) loop
21558 exit when Comes_From_Source
(N
);
21563 end Last_Source_Statement
;
21565 -----------------------
21566 -- Mark_Coextensions --
21567 -----------------------
21569 procedure Mark_Coextensions
(Context_Nod
: Node_Id
; Root_Nod
: Node_Id
) is
21570 Is_Dynamic
: Boolean;
21571 -- Indicates whether the context causes nested coextensions to be
21572 -- dynamic or static
21574 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
;
21575 -- Recognize an allocator node and label it as a dynamic coextension
21577 --------------------
21578 -- Mark_Allocator --
21579 --------------------
21581 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
is
21583 if Nkind
(N
) = N_Allocator
then
21585 Set_Is_Static_Coextension
(N
, False);
21586 Set_Is_Dynamic_Coextension
(N
);
21588 -- If the allocator expression is potentially dynamic, it may
21589 -- be expanded out of order and require dynamic allocation
21590 -- anyway, so we treat the coextension itself as dynamic.
21591 -- Potential optimization ???
21593 elsif Nkind
(Expression
(N
)) = N_Qualified_Expression
21594 and then Nkind
(Expression
(Expression
(N
))) = N_Op_Concat
21596 Set_Is_Static_Coextension
(N
, False);
21597 Set_Is_Dynamic_Coextension
(N
);
21599 Set_Is_Dynamic_Coextension
(N
, False);
21600 Set_Is_Static_Coextension
(N
);
21605 end Mark_Allocator
;
21607 procedure Mark_Allocators
is new Traverse_Proc
(Mark_Allocator
);
21609 -- Start of processing for Mark_Coextensions
21612 -- An allocator that appears on the right-hand side of an assignment is
21613 -- treated as a potentially dynamic coextension when the right-hand side
21614 -- is an allocator or a qualified expression.
21616 -- Obj := new ...'(new Coextension ...);
21618 if Nkind
(Context_Nod
) = N_Assignment_Statement
then
21619 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) in
21620 N_Allocator | N_Qualified_Expression
;
21622 -- An allocator that appears within the expression of a simple return
21623 -- statement is treated as a potentially dynamic coextension when the
21624 -- expression is either aggregate, allocator, or qualified expression.
21626 -- return (new Coextension ...);
21627 -- return new ...'(new Coextension ...);
21629 elsif Nkind
(Context_Nod
) = N_Simple_Return_Statement
then
21630 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) in
21631 N_Aggregate | N_Allocator | N_Qualified_Expression
;
21633 -- An alloctor that appears within the initialization expression of an
21634 -- object declaration is considered a potentially dynamic coextension
21635 -- when the initialization expression is an allocator or a qualified
21638 -- Obj : ... := new ...'(new Coextension ...);
21640 -- A similar case arises when the object declaration is part of an
21641 -- extended return statement.
21643 -- return Obj : ... := new ...'(new Coextension ...);
21644 -- return Obj : ... := (new Coextension ...);
21646 elsif Nkind
(Context_Nod
) = N_Object_Declaration
then
21647 Is_Dynamic
:= Nkind
(Root_Nod
) in N_Allocator | N_Qualified_Expression
21648 or else Nkind
(Parent
(Context_Nod
)) = N_Extended_Return_Statement
;
21650 -- This routine should not be called with constructs that cannot contain
21654 raise Program_Error
;
21657 Mark_Allocators
(Root_Nod
);
21658 end Mark_Coextensions
;
21660 ---------------------------------
21661 -- Mark_Elaboration_Attributes --
21662 ---------------------------------
21664 procedure Mark_Elaboration_Attributes
21665 (N_Id
: Node_Or_Entity_Id
;
21666 Checks
: Boolean := False;
21667 Level
: Boolean := False;
21668 Modes
: Boolean := False;
21669 Warnings
: Boolean := False)
21671 function Elaboration_Checks_OK
21672 (Target_Id
: Entity_Id
;
21673 Context_Id
: Entity_Id
) return Boolean;
21674 -- Determine whether elaboration checks are enabled for target Target_Id
21675 -- which resides within context Context_Id.
21677 procedure Mark_Elaboration_Attributes_Id
(Id
: Entity_Id
);
21678 -- Preserve relevant attributes of the context in arbitrary entity Id
21680 procedure Mark_Elaboration_Attributes_Node
(N
: Node_Id
);
21681 -- Preserve relevant attributes of the context in arbitrary node N
21683 ---------------------------
21684 -- Elaboration_Checks_OK --
21685 ---------------------------
21687 function Elaboration_Checks_OK
21688 (Target_Id
: Entity_Id
;
21689 Context_Id
: Entity_Id
) return Boolean
21691 Encl_Scop
: Entity_Id
;
21694 -- Elaboration checks are suppressed for the target
21696 if Elaboration_Checks_Suppressed
(Target_Id
) then
21700 -- Otherwise elaboration checks are OK for the target, but may be
21701 -- suppressed for the context where the target is declared.
21703 Encl_Scop
:= Context_Id
;
21704 while Present
(Encl_Scop
) and then Encl_Scop
/= Standard_Standard
loop
21705 if Elaboration_Checks_Suppressed
(Encl_Scop
) then
21709 Encl_Scop
:= Scope
(Encl_Scop
);
21712 -- Neither the target nor its declarative context have elaboration
21713 -- checks suppressed.
21716 end Elaboration_Checks_OK
;
21718 ------------------------------------
21719 -- Mark_Elaboration_Attributes_Id --
21720 ------------------------------------
21722 procedure Mark_Elaboration_Attributes_Id
(Id
: Entity_Id
) is
21724 -- Mark the status of elaboration checks in effect. Do not reset the
21725 -- status in case the entity is reanalyzed with checks suppressed.
21727 if Checks
and then not Is_Elaboration_Checks_OK_Id
(Id
) then
21728 Set_Is_Elaboration_Checks_OK_Id
(Id
,
21729 Elaboration_Checks_OK
21731 Context_Id
=> Scope
(Id
)));
21734 -- Mark the status of elaboration warnings in effect. Do not reset
21735 -- the status in case the entity is reanalyzed with warnings off.
21737 if Warnings
and then not Is_Elaboration_Warnings_OK_Id
(Id
) then
21738 Set_Is_Elaboration_Warnings_OK_Id
(Id
, Elab_Warnings
);
21740 end Mark_Elaboration_Attributes_Id
;
21742 --------------------------------------
21743 -- Mark_Elaboration_Attributes_Node --
21744 --------------------------------------
21746 procedure Mark_Elaboration_Attributes_Node
(N
: Node_Id
) is
21747 function Extract_Name
(N
: Node_Id
) return Node_Id
;
21748 -- Obtain the Name attribute of call or instantiation N
21754 function Extract_Name
(N
: Node_Id
) return Node_Id
is
21760 -- A call to an entry family appears in indexed form
21762 if Nkind
(Nam
) = N_Indexed_Component
then
21763 Nam
:= Prefix
(Nam
);
21766 -- The name may also appear in qualified form
21768 if Nkind
(Nam
) = N_Selected_Component
then
21769 Nam
:= Selector_Name
(Nam
);
21777 Context_Id
: Entity_Id
;
21780 -- Start of processing for Mark_Elaboration_Attributes_Node
21783 -- Mark the status of elaboration checks in effect. Do not reset the
21784 -- status in case the node is reanalyzed with checks suppressed.
21786 if Checks
and then not Is_Elaboration_Checks_OK_Node
(N
) then
21788 -- Assignments, attribute references, and variable references do
21789 -- not have a "declarative" context.
21791 Context_Id
:= Empty
;
21793 -- The status of elaboration checks for calls and instantiations
21794 -- depends on the most recent pragma Suppress/Unsuppress, as well
21795 -- as the suppression status of the context where the target is
21799 -- function Func ...;
21803 -- procedure Main is
21804 -- pragma Suppress (Elaboration_Checks, Pack);
21805 -- X : ... := Pack.Func;
21808 -- In the example above, the call to Func has elaboration checks
21809 -- enabled because there is no active general purpose suppression
21810 -- pragma, however the elaboration checks of Pack are explicitly
21811 -- suppressed. As a result the elaboration checks of the call must
21812 -- be disabled in order to preserve this dependency.
21814 if Nkind
(N
) in N_Entry_Call_Statement
21816 | N_Function_Instantiation
21817 | N_Package_Instantiation
21818 | N_Procedure_Call_Statement
21819 | N_Procedure_Instantiation
21821 Nam
:= Extract_Name
(N
);
21823 if Is_Entity_Name
(Nam
) and then Present
(Entity
(Nam
)) then
21824 Context_Id
:= Scope
(Entity
(Nam
));
21828 Set_Is_Elaboration_Checks_OK_Node
(N
,
21829 Elaboration_Checks_OK
21830 (Target_Id
=> Empty
,
21831 Context_Id
=> Context_Id
));
21834 -- Mark the enclosing level of the node. Do not reset the status in
21835 -- case the node is relocated and reanalyzed.
21837 if Level
and then not Is_Declaration_Level_Node
(N
) then
21838 Set_Is_Declaration_Level_Node
(N
,
21839 Find_Enclosing_Level
(N
) = Declaration_Level
);
21842 -- Mark the Ghost and SPARK mode in effect
21845 if Ghost_Mode
= Ignore
then
21846 Set_Is_Ignored_Ghost_Node
(N
);
21849 if SPARK_Mode
= On
then
21850 Set_Is_SPARK_Mode_On_Node
(N
);
21854 -- Mark the status of elaboration warnings in effect. Do not reset
21855 -- the status in case the node is reanalyzed with warnings off.
21857 if Warnings
and then not Is_Elaboration_Warnings_OK_Node
(N
) then
21858 Set_Is_Elaboration_Warnings_OK_Node
(N
, Elab_Warnings
);
21860 end Mark_Elaboration_Attributes_Node
;
21862 -- Start of processing for Mark_Elaboration_Attributes
21865 -- Do not capture any elaboration-related attributes when switch -gnatH
21866 -- (legacy elaboration checking mode enabled) is in effect because the
21867 -- attributes are useless to the legacy model.
21869 if Legacy_Elaboration_Checks
then
21873 if Nkind
(N_Id
) in N_Entity
then
21874 Mark_Elaboration_Attributes_Id
(N_Id
);
21876 Mark_Elaboration_Attributes_Node
(N_Id
);
21878 end Mark_Elaboration_Attributes
;
21880 ----------------------------------------
21881 -- Mark_Save_Invocation_Graph_Of_Body --
21882 ----------------------------------------
21884 procedure Mark_Save_Invocation_Graph_Of_Body
is
21885 Main
: constant Node_Id
:= Cunit
(Main_Unit
);
21886 Main_Unit
: constant Node_Id
:= Unit
(Main
);
21887 Aux_Id
: Entity_Id
;
21890 Set_Save_Invocation_Graph_Of_Body
(Main
);
21892 -- Assume that the main unit does not have a complimentary unit
21896 -- Obtain the complimentary unit of the main unit
21898 if Nkind
(Main_Unit
) in N_Generic_Package_Declaration
21899 | N_Generic_Subprogram_Declaration
21900 | N_Package_Declaration
21901 | N_Subprogram_Declaration
21903 Aux_Id
:= Corresponding_Body
(Main_Unit
);
21905 elsif Nkind
(Main_Unit
) in N_Package_Body
21906 | N_Subprogram_Body
21907 | N_Subprogram_Renaming_Declaration
21909 Aux_Id
:= Corresponding_Spec
(Main_Unit
);
21912 if Present
(Aux_Id
) then
21913 Set_Save_Invocation_Graph_Of_Body
21914 (Parent
(Unit_Declaration_Node
(Aux_Id
)));
21916 end Mark_Save_Invocation_Graph_Of_Body
;
21918 ----------------------------------
21919 -- Matching_Static_Array_Bounds --
21920 ----------------------------------
21922 function Matching_Static_Array_Bounds
21924 R_Typ
: Node_Id
) return Boolean
21926 L_Ndims
: constant Nat
:= Number_Dimensions
(L_Typ
);
21927 R_Ndims
: constant Nat
:= Number_Dimensions
(R_Typ
);
21929 L_Index
: Node_Id
:= Empty
; -- init to ...
21930 R_Index
: Node_Id
:= Empty
; -- ...avoid warnings
21939 if L_Ndims
/= R_Ndims
then
21943 -- Unconstrained types do not have static bounds
21945 if not Is_Constrained
(L_Typ
) or else not Is_Constrained
(R_Typ
) then
21949 -- First treat specially the first dimension, as the lower bound and
21950 -- length of string literals are not stored like those of arrays.
21952 if Ekind
(L_Typ
) = E_String_Literal_Subtype
then
21953 L_Low
:= String_Literal_Low_Bound
(L_Typ
);
21954 L_Len
:= String_Literal_Length
(L_Typ
);
21956 L_Index
:= First_Index
(L_Typ
);
21957 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
21959 if Is_OK_Static_Expression
(L_Low
)
21961 Is_OK_Static_Expression
(L_High
)
21963 if Expr_Value
(L_High
) < Expr_Value
(L_Low
) then
21966 L_Len
:= (Expr_Value
(L_High
) - Expr_Value
(L_Low
)) + 1;
21973 if Ekind
(R_Typ
) = E_String_Literal_Subtype
then
21974 R_Low
:= String_Literal_Low_Bound
(R_Typ
);
21975 R_Len
:= String_Literal_Length
(R_Typ
);
21977 R_Index
:= First_Index
(R_Typ
);
21978 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
21980 if Is_OK_Static_Expression
(R_Low
)
21982 Is_OK_Static_Expression
(R_High
)
21984 if Expr_Value
(R_High
) < Expr_Value
(R_Low
) then
21987 R_Len
:= (Expr_Value
(R_High
) - Expr_Value
(R_Low
)) + 1;
21994 if (Is_OK_Static_Expression
(L_Low
)
21996 Is_OK_Static_Expression
(R_Low
))
21997 and then Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
21998 and then L_Len
= R_Len
22005 -- Then treat all other dimensions
22007 for Indx
in 2 .. L_Ndims
loop
22011 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
22012 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
22014 if (Is_OK_Static_Expression
(L_Low
) and then
22015 Is_OK_Static_Expression
(L_High
) and then
22016 Is_OK_Static_Expression
(R_Low
) and then
22017 Is_OK_Static_Expression
(R_High
))
22018 and then (Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
22020 Expr_Value
(L_High
) = Expr_Value
(R_High
))
22028 -- If we fall through the loop, all indexes matched
22031 end Matching_Static_Array_Bounds
;
22037 function Might_Raise
(N
: Node_Id
) return Boolean is
22038 Result
: Boolean := False;
22040 function Process
(N
: Node_Id
) return Traverse_Result
;
22041 -- Set Result to True if we find something that could raise an exception
22047 function Process
(N
: Node_Id
) return Traverse_Result
is
22049 if Nkind
(N
) in N_Procedure_Call_Statement
22051 | N_Raise_Statement
22052 | N_Raise_xxx_Error
22053 | N_Raise_Expression
22062 procedure Set_Result
is new Traverse_Proc
(Process
);
22064 -- Start of processing for Might_Raise
22067 -- False if exceptions can't be propagated
22069 if No_Exception_Handlers_Set
then
22073 -- If the checks handled by the back end are not disabled, we cannot
22074 -- ensure that no exception will be raised.
22076 if not Access_Checks_Suppressed
(Empty
)
22077 or else not Discriminant_Checks_Suppressed
(Empty
)
22078 or else not Range_Checks_Suppressed
(Empty
)
22079 or else not Index_Checks_Suppressed
(Empty
)
22080 or else Opt
.Stack_Checking_Enabled
22089 ----------------------------------------
22090 -- Nearest_Class_Condition_Subprogram --
22091 ----------------------------------------
22093 function Nearest_Class_Condition_Subprogram
22094 (Kind
: Condition_Kind
;
22095 Spec_Id
: Entity_Id
) return Entity_Id
22097 Subp_Id
: constant Entity_Id
:= Ultimate_Alias
(Spec_Id
);
22100 -- Prevent cascaded errors
22102 if not Is_Dispatching_Operation
(Subp_Id
) then
22105 -- No need to search if this subprogram has class-wide postconditions
22107 elsif Present
(Class_Condition
(Kind
, Subp_Id
)) then
22111 -- Process the contracts of inherited subprograms, looking for
22112 -- class-wide pre/postconditions.
22115 Subps
: constant Subprogram_List
:= Inherited_Subprograms
(Subp_Id
);
22116 Subp_Id
: Entity_Id
;
22119 for Index
in Subps
'Range loop
22120 Subp_Id
:= Subps
(Index
);
22122 if Present
(Alias
(Subp_Id
)) then
22123 Subp_Id
:= Ultimate_Alias
(Subp_Id
);
22126 -- Wrappers of class-wide pre/postconditions reference the
22127 -- parent primitive that has the inherited contract.
22129 if Is_Wrapper
(Subp_Id
)
22130 and then Present
(LSP_Subprogram
(Subp_Id
))
22132 Subp_Id
:= LSP_Subprogram
(Subp_Id
);
22135 if Present
(Class_Condition
(Kind
, Subp_Id
)) then
22142 end Nearest_Class_Condition_Subprogram
;
22144 --------------------------------
22145 -- Nearest_Enclosing_Instance --
22146 --------------------------------
22148 function Nearest_Enclosing_Instance
(E
: Entity_Id
) return Entity_Id
is
22153 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
22154 if Is_Generic_Instance
(Inst
) then
22158 Inst
:= Scope
(Inst
);
22162 end Nearest_Enclosing_Instance
;
22164 ------------------------
22165 -- Needs_Finalization --
22166 ------------------------
22168 function Needs_Finalization
(Typ
: Entity_Id
) return Boolean is
22169 function Has_Some_Controlled_Component
22170 (Input_Typ
: Entity_Id
) return Boolean;
22171 -- Determine whether type Input_Typ has at least one controlled
22174 -----------------------------------
22175 -- Has_Some_Controlled_Component --
22176 -----------------------------------
22178 function Has_Some_Controlled_Component
22179 (Input_Typ
: Entity_Id
) return Boolean
22184 -- When a type is already frozen and has at least one controlled
22185 -- component, or is manually decorated, it is sufficient to inspect
22186 -- flag Has_Controlled_Component.
22188 if Has_Controlled_Component
(Input_Typ
) then
22191 -- Otherwise inspect the internals of the type
22193 elsif not Is_Frozen
(Input_Typ
) then
22194 if Is_Array_Type
(Input_Typ
) then
22195 return Needs_Finalization
(Component_Type
(Input_Typ
));
22197 elsif Is_Record_Type
(Input_Typ
) then
22198 Comp
:= First_Component
(Input_Typ
);
22199 while Present
(Comp
) loop
22200 if Needs_Finalization
(Etype
(Comp
)) then
22204 Next_Component
(Comp
);
22210 end Has_Some_Controlled_Component
;
22212 -- Start of processing for Needs_Finalization
22215 -- Certain run-time configurations and targets do not provide support
22216 -- for controlled types.
22218 if Restriction_Active
(No_Finalization
) then
22221 -- C++ types are not considered controlled. It is assumed that the non-
22222 -- Ada side will handle their clean up.
22224 elsif Convention
(Typ
) = Convention_CPP
then
22227 -- Class-wide types are treated as controlled because derivations from
22228 -- the root type may introduce controlled components.
22230 elsif Is_Class_Wide_Type
(Typ
) then
22233 -- Concurrent types are controlled as long as their corresponding record
22236 elsif Is_Concurrent_Type
(Typ
)
22237 and then Present
(Corresponding_Record_Type
(Typ
))
22238 and then Needs_Finalization
(Corresponding_Record_Type
(Typ
))
22242 -- Otherwise the type is controlled when it is either derived from type
22243 -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or
22244 -- contains at least one controlled component.
22248 Is_Controlled
(Typ
) or else Has_Some_Controlled_Component
(Typ
);
22250 end Needs_Finalization
;
22252 ----------------------
22253 -- Needs_One_Actual --
22254 ----------------------
22256 function Needs_One_Actual
(E
: Entity_Id
) return Boolean is
22257 Formal
: Entity_Id
;
22260 -- Ada 2005 or later, and formals present. The first formal must be
22261 -- of a type that supports prefix notation: a controlling argument,
22262 -- a class-wide type, or an access to such.
22264 if Ada_Version
>= Ada_2005
22265 and then Present
(First_Formal
(E
))
22266 and then No
(Default_Value
(First_Formal
(E
)))
22268 (Is_Controlling_Formal
(First_Formal
(E
))
22269 or else Is_Class_Wide_Type
(Etype
(First_Formal
(E
)))
22270 or else Is_Anonymous_Access_Type
(Etype
(First_Formal
(E
))))
22272 Formal
:= Next_Formal
(First_Formal
(E
));
22273 while Present
(Formal
) loop
22274 if No
(Default_Value
(Formal
)) then
22278 Next_Formal
(Formal
);
22283 -- Ada 83/95 or no formals
22288 end Needs_One_Actual
;
22290 ----------------------------
22291 -- Needs_Secondary_Stack --
22292 ----------------------------
22294 function Needs_Secondary_Stack
(Id
: Entity_Id
) return Boolean is
22295 pragma Assert
(if Present
(Id
) then Ekind
(Id
) in E_Void | Type_Kind
);
22297 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean;
22298 -- Called for untagged record and protected types. Return True if the
22299 -- size of function results is known in the caller for Typ.
22301 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean;
22302 -- Returns True if Typ is a nonlimited record with defaulted
22303 -- discriminants whose max size makes it unsuitable for allocating on
22304 -- the primary stack.
22306 ------------------------------
22307 -- Caller_Known_Size_Record --
22308 ------------------------------
22310 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean is
22311 pragma Assert
(if Present
(Typ
) then Typ
= Underlying_Type
(Typ
));
22313 function Depends_On_Discriminant
(Typ
: Entity_Id
) return Boolean;
22314 -- Called for untagged record and protected types. Return True if Typ
22315 -- depends on discriminants, either directly when it is unconstrained
22316 -- or indirectly when it is constrained by uplevel discriminants.
22318 -----------------------------
22319 -- Depends_On_Discriminant --
22320 -----------------------------
22322 function Depends_On_Discriminant
(Typ
: Entity_Id
) return Boolean is
22326 if Has_Discriminants
(Typ
) then
22327 if not Is_Constrained
(Typ
) then
22331 Cons
:= First_Elmt
(Discriminant_Constraint
(Typ
));
22332 while Present
(Cons
) loop
22333 if Nkind
(Node
(Cons
)) = N_Identifier
22334 and then Ekind
(Entity
(Node
(Cons
))) = E_Discriminant
22345 end Depends_On_Discriminant
;
22348 -- This is a protected type without Corresponding_Record_Type set,
22349 -- typically because expansion is disabled. The safe thing to do is
22350 -- to return True, so Needs_Secondary_Stack returns False.
22356 -- First see if we have a variant part and return False if it depends
22357 -- on discriminants.
22359 if Has_Variant_Part
(Typ
) and then Depends_On_Discriminant
(Typ
) then
22363 -- Then loop over components and return False if their subtype has a
22364 -- caller-unknown size, possibly recursively.
22366 -- ??? This is overly conservative, an array could be nested inside
22367 -- some other record that is constrained by nondiscriminants. That
22368 -- is, the recursive calls are too conservative.
22374 Comp
:= First_Component
(Typ
);
22375 while Present
(Comp
) loop
22377 Comp_Type
: constant Entity_Id
:=
22378 Underlying_Type
(Etype
(Comp
));
22381 if Is_Record_Type
(Comp_Type
) then
22382 if not Caller_Known_Size_Record
(Comp_Type
) then
22386 elsif Is_Protected_Type
(Comp_Type
) then
22387 if not Caller_Known_Size_Record
22388 (Corresponding_Record_Type
(Comp_Type
))
22393 elsif Is_Array_Type
(Comp_Type
) then
22394 if Size_Depends_On_Discriminant
(Comp_Type
) then
22400 Next_Component
(Comp
);
22405 end Caller_Known_Size_Record
;
22407 ------------------------------
22408 -- Large_Max_Size_Mutable --
22409 ------------------------------
22411 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean is
22412 pragma Assert
(Typ
= Underlying_Type
(Typ
));
22414 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean;
22415 -- Returns true if the discrete type T has a large range
22417 ----------------------------
22418 -- Is_Large_Discrete_Type --
22419 ----------------------------
22421 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean is
22422 Threshold
: constant Int
:= 16;
22423 -- Arbitrary threshold above which we consider it "large". We want
22424 -- a fairly large threshold, because these large types really
22425 -- shouldn't have default discriminants in the first place, in
22429 return UI_To_Int
(RM_Size
(T
)) > Threshold
;
22430 end Is_Large_Discrete_Type
;
22432 -- Start of processing for Large_Max_Size_Mutable
22435 if Is_Record_Type
(Typ
)
22436 and then not Is_Limited_View
(Typ
)
22437 and then Has_Defaulted_Discriminants
(Typ
)
22439 -- Loop through the components, looking for an array whose upper
22440 -- bound(s) depends on discriminants, where both the subtype of
22441 -- the discriminant and the index subtype are too large.
22447 Comp
:= First_Component
(Typ
);
22448 while Present
(Comp
) loop
22450 Comp_Type
: constant Entity_Id
:=
22451 Underlying_Type
(Etype
(Comp
));
22458 if Is_Array_Type
(Comp_Type
) then
22459 Indx
:= First_Index
(Comp_Type
);
22461 while Present
(Indx
) loop
22462 Ityp
:= Etype
(Indx
);
22463 Hi
:= Type_High_Bound
(Ityp
);
22465 if Nkind
(Hi
) = N_Identifier
22466 and then Ekind
(Entity
(Hi
)) = E_Discriminant
22467 and then Is_Large_Discrete_Type
(Ityp
)
22468 and then Is_Large_Discrete_Type
22469 (Etype
(Entity
(Hi
)))
22479 Next_Component
(Comp
);
22485 end Large_Max_Size_Mutable
;
22487 -- Local declarations
22489 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
22491 -- Start of processing for Needs_Secondary_Stack
22494 -- This is a private type which is not completed yet. This can only
22495 -- happen in a default expression (of a formal parameter or of a
22496 -- record component). The safe thing to do is to return False.
22502 -- Do not expand transient scope for non-existent procedure return or
22503 -- string literal types.
22505 if Typ
= Standard_Void_Type
22506 or else Ekind
(Typ
) = E_String_Literal_Subtype
22510 -- If Typ is a generic formal incomplete type, then we want to look at
22511 -- the actual type.
22513 elsif Ekind
(Typ
) = E_Record_Subtype
22514 and then Present
(Cloned_Subtype
(Typ
))
22516 return Needs_Secondary_Stack
(Cloned_Subtype
(Typ
));
22518 -- Class-wide types obviously have an unknown size. For specific tagged
22519 -- types, if a call returning one of them is dispatching on result, and
22520 -- this type is not returned on the secondary stack, then the call goes
22521 -- through a thunk that only moves the result from the primary onto the
22522 -- secondary stack, because the computation of the size of the result is
22523 -- possible but complex from the outside.
22525 elsif Is_Class_Wide_Type
(Typ
) then
22528 -- If the return slot of the back end cannot be accessed, then there
22529 -- is no way to call Adjust at the right time for the return object if
22530 -- the type needs finalization, so the return object must be allocated
22531 -- on the secondary stack.
22533 elsif not Back_End_Return_Slot
and then Needs_Finalization
(Typ
) then
22536 -- Definite subtypes have a known size. This includes all elementary
22537 -- types. Tasks have a known size even if they have discriminants, so
22538 -- we return False here, with one exception:
22539 -- For a type like:
22540 -- type T (Last : Natural := 0) is
22541 -- X : String (1 .. Last);
22543 -- we return True. That's because for "P(F(...));", where F returns T,
22544 -- we don't know the size of the result at the call site, so if we
22545 -- allocated it on the primary stack, we would have to allocate the
22546 -- maximum size, which is way too big.
22548 elsif Is_Definite_Subtype
(Typ
) or else Is_Task_Type
(Typ
) then
22549 return Large_Max_Size_Mutable
(Typ
);
22551 -- Indefinite (discriminated) record type
22553 elsif Is_Record_Type
(Typ
) then
22554 return not Caller_Known_Size_Record
(Typ
);
22556 -- Indefinite (discriminated) protected type
22558 elsif Is_Protected_Type
(Typ
) then
22559 return not Caller_Known_Size_Record
(Corresponding_Record_Type
(Typ
));
22561 -- Unconstrained array type
22564 pragma Assert
(Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
));
22567 end Needs_Secondary_Stack
;
22569 ---------------------------------
22570 -- Needs_Simple_Initialization --
22571 ---------------------------------
22573 function Needs_Simple_Initialization
22575 Consider_IS
: Boolean := True) return Boolean
22577 Consider_IS_NS
: constant Boolean :=
22578 Normalize_Scalars
or (Initialize_Scalars
and Consider_IS
);
22581 -- Never need initialization if it is suppressed
22583 if Initialization_Suppressed
(Typ
) then
22587 -- Check for private type, in which case test applies to the underlying
22588 -- type of the private type.
22590 if Is_Private_Type
(Typ
) then
22592 RT
: constant Entity_Id
:= Underlying_Type
(Typ
);
22594 if Present
(RT
) then
22595 return Needs_Simple_Initialization
(RT
);
22601 -- Scalar type with Default_Value aspect requires initialization
22603 elsif Is_Scalar_Type
(Typ
) and then Has_Default_Aspect
(Typ
) then
22606 -- Cases needing simple initialization are access types, and, if pragma
22607 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
22610 elsif Is_Access_Type
(Typ
)
22611 or else (Consider_IS_NS
and then Is_Scalar_Type
(Typ
))
22615 -- If Initialize/Normalize_Scalars is in effect, string objects also
22616 -- need initialization, unless they are created in the course of
22617 -- expanding an aggregate (since in the latter case they will be
22618 -- filled with appropriate initializing values before they are used).
22620 elsif Consider_IS_NS
22621 and then Is_Standard_String_Type
(Typ
)
22623 (not Is_Itype
(Typ
)
22624 or else Nkind
(Associated_Node_For_Itype
(Typ
)) /= N_Aggregate
)
22631 end Needs_Simple_Initialization
;
22633 -------------------------------------
22634 -- Needs_Variable_Reference_Marker --
22635 -------------------------------------
22637 function Needs_Variable_Reference_Marker
22639 Calls_OK
: Boolean) return Boolean
22641 function Within_Suitable_Context
(Ref
: Node_Id
) return Boolean;
22642 -- Deteremine whether variable reference Ref appears within a suitable
22643 -- context that allows the creation of a marker.
22645 -----------------------------
22646 -- Within_Suitable_Context --
22647 -----------------------------
22649 function Within_Suitable_Context
(Ref
: Node_Id
) return Boolean is
22654 while Present
(Par
) loop
22656 -- The context is not suitable when the reference appears within
22657 -- the formal part of an instantiation which acts as compilation
22658 -- unit because there is no proper list for the insertion of the
22661 if Nkind
(Par
) = N_Generic_Association
22662 and then Nkind
(Parent
(Par
)) in N_Generic_Instantiation
22663 and then Nkind
(Parent
(Parent
(Par
))) = N_Compilation_Unit
22667 -- The context is not suitable when the reference appears within
22668 -- a pragma. If the pragma has run-time semantics, the reference
22669 -- will be reconsidered once the pragma is expanded.
22671 elsif Nkind
(Par
) = N_Pragma
then
22674 -- The context is not suitable when the reference appears within a
22675 -- subprogram call, and the caller requests this behavior.
22678 and then Nkind
(Par
) in N_Entry_Call_Statement
22680 | N_Procedure_Call_Statement
22684 -- Prevent the search from going too far
22686 elsif Is_Body_Or_Package_Declaration
(Par
) then
22690 Par
:= Parent
(Par
);
22694 end Within_Suitable_Context
;
22699 Var_Id
: Entity_Id
;
22701 -- Start of processing for Needs_Variable_Reference_Marker
22704 -- No marker needs to be created when switch -gnatH (legacy elaboration
22705 -- checking mode enabled) is in effect because the legacy ABE mechanism
22706 -- does not use markers.
22708 if Legacy_Elaboration_Checks
then
22711 -- No marker needs to be created when the reference is preanalyzed
22712 -- because the marker will be inserted in the wrong place.
22714 elsif Preanalysis_Active
then
22717 -- Only references warrant a marker
22719 elsif Nkind
(N
) not in N_Expanded_Name | N_Identifier
then
22722 -- Only source references warrant a marker
22724 elsif not Comes_From_Source
(N
) then
22727 -- No marker needs to be created when the reference is erroneous, left
22728 -- in a bad state, or does not denote a variable.
22730 elsif not (Present
(Entity
(N
))
22731 and then Ekind
(Entity
(N
)) = E_Variable
22732 and then Entity
(N
) /= Any_Id
)
22737 Var_Id
:= Entity
(N
);
22738 Prag
:= SPARK_Pragma
(Var_Id
);
22740 -- Both the variable and reference must appear in SPARK_Mode On regions
22741 -- because this elaboration scenario falls under the SPARK rules.
22743 if not (Comes_From_Source
(Var_Id
)
22744 and then Present
(Prag
)
22745 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
22746 and then Is_SPARK_Mode_On_Node
(N
))
22750 -- No marker needs to be created when the reference does not appear
22751 -- within a suitable context (see body for details).
22753 -- Performance note: parent traversal
22755 elsif not Within_Suitable_Context
(N
) then
22759 -- At this point it is known that the variable reference will play a
22760 -- role in ABE diagnostics and requires a marker.
22763 end Needs_Variable_Reference_Marker
;
22765 ------------------------
22766 -- New_Copy_List_Tree --
22767 ------------------------
22769 function New_Copy_List_Tree
(List
: List_Id
) return List_Id
is
22774 if List
= No_List
then
22781 while Present
(E
) loop
22782 Append
(New_Copy_Tree
(E
), NL
);
22788 end New_Copy_List_Tree
;
22790 ----------------------------
22791 -- New_Copy_Separate_List --
22792 ----------------------------
22794 function New_Copy_Separate_List
(List
: List_Id
) return List_Id
is
22796 if List
= No_List
then
22801 List_Copy
: constant List_Id
:= New_List
;
22802 N
: Node_Id
:= First
(List
);
22805 while Present
(N
) loop
22806 Append
(New_Copy_Separate_Tree
(N
), List_Copy
);
22813 end New_Copy_Separate_List
;
22815 ----------------------------
22816 -- New_Copy_Separate_Tree --
22817 ----------------------------
22819 function New_Copy_Separate_Tree
(Source
: Node_Id
) return Node_Id
is
22820 function Search_Decl
(N
: Node_Id
) return Traverse_Result
;
22821 -- Subtree visitor which collects declarations
22823 procedure Search_Declarations
is new Traverse_Proc
(Search_Decl
);
22824 -- Subtree visitor instantiation
22832 function Search_Decl
(N
: Node_Id
) return Traverse_Result
is
22834 if Nkind
(N
) in N_Declaration
then
22835 Append_New_Elmt
(N
, Decls
);
22843 Source_Copy
: constant Node_Id
:= New_Copy_Tree
(Source
);
22845 -- Start of processing for New_Copy_Separate_Tree
22849 Search_Declarations
(Source_Copy
);
22851 -- Associate a new Entity with all the subtree declarations (keeping
22852 -- their original name).
22854 if Present
(Decls
) then
22861 Elmt
:= First_Elmt
(Decls
);
22862 while Present
(Elmt
) loop
22863 Decl
:= Node
(Elmt
);
22864 New_E
:= Make_Temporary
(Sloc
(Decl
), 'P');
22866 if Nkind
(Decl
) = N_Expression_Function
then
22867 Decl
:= Specification
(Decl
);
22870 if Nkind
(Decl
) in N_Function_Instantiation
22871 | N_Function_Specification
22872 | N_Generic_Function_Renaming_Declaration
22873 | N_Generic_Package_Renaming_Declaration
22874 | N_Generic_Procedure_Renaming_Declaration
22876 | N_Package_Instantiation
22877 | N_Package_Renaming_Declaration
22878 | N_Package_Specification
22879 | N_Procedure_Instantiation
22880 | N_Procedure_Specification
22882 Set_Chars
(New_E
, Chars
(Defining_Unit_Name
(Decl
)));
22883 Set_Defining_Unit_Name
(Decl
, New_E
);
22885 Set_Chars
(New_E
, Chars
(Defining_Identifier
(Decl
)));
22886 Set_Defining_Identifier
(Decl
, New_E
);
22894 return Source_Copy
;
22895 end New_Copy_Separate_Tree
;
22897 -------------------
22898 -- New_Copy_Tree --
22899 -------------------
22901 -- The following tables play a key role in replicating entities and Itypes.
22902 -- They are intentionally declared at the library level rather than within
22903 -- New_Copy_Tree to avoid elaborating them on each call. This performance
22904 -- optimization saves up to 2% of the entire compilation time spent in the
22905 -- front end. Care should be taken to reset the tables on each new call to
22908 NCT_Table_Max
: constant := 511;
22910 subtype NCT_Table_Index
is Nat
range 0 .. NCT_Table_Max
- 1;
22912 function NCT_Table_Hash
(Key
: Node_Or_Entity_Id
) return NCT_Table_Index
;
22913 -- Obtain the hash value of node or entity Key
22915 --------------------
22916 -- NCT_Table_Hash --
22917 --------------------
22919 function NCT_Table_Hash
(Key
: Node_Or_Entity_Id
) return NCT_Table_Index
is
22921 return NCT_Table_Index
(Key
mod NCT_Table_Max
);
22922 end NCT_Table_Hash
;
22924 ----------------------
22925 -- NCT_New_Entities --
22926 ----------------------
22928 -- The following table maps old entities and Itypes to their corresponding
22929 -- new entities and Itypes.
22933 package NCT_New_Entities
is new Simple_HTable
(
22934 Header_Num
=> NCT_Table_Index
,
22935 Element
=> Entity_Id
,
22936 No_Element
=> Empty
,
22938 Hash
=> NCT_Table_Hash
,
22941 ------------------------
22942 -- NCT_Pending_Itypes --
22943 ------------------------
22945 -- The following table maps old Associated_Node_For_Itype nodes to a set of
22946 -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three
22947 -- have the same Associated_Node_For_Itype Ppp, and their corresponding new
22948 -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping:
22950 -- Ppp -> (Xxx, Yyy, Zzz)
22952 -- The set is expressed as an Elist
22954 package NCT_Pending_Itypes
is new Simple_HTable
(
22955 Header_Num
=> NCT_Table_Index
,
22956 Element
=> Elist_Id
,
22957 No_Element
=> No_Elist
,
22959 Hash
=> NCT_Table_Hash
,
22962 NCT_Tables_In_Use
: Boolean := False;
22963 -- This flag keeps track of whether the two tables NCT_New_Entities and
22964 -- NCT_Pending_Itypes are in use. The flag is part of an optimization
22965 -- where certain operations are not performed if the tables are not in
22966 -- use. This saves up to 8% of the entire compilation time spent in the
22969 -------------------
22970 -- New_Copy_Tree --
22971 -------------------
22973 function New_Copy_Tree
22975 Map
: Elist_Id
:= No_Elist
;
22976 New_Sloc
: Source_Ptr
:= No_Location
;
22977 New_Scope
: Entity_Id
:= Empty
;
22978 Scopes_In_EWA_OK
: Boolean := False) return Node_Id
22980 -- This routine performs low-level tree manipulations and needs access
22981 -- to the internals of the tree.
22983 EWA_Level
: Nat
:= 0;
22984 -- This counter keeps track of how many N_Expression_With_Actions nodes
22985 -- are encountered during a depth-first traversal of the subtree. These
22986 -- nodes may define new entities in their Actions lists and thus require
22987 -- special processing.
22989 EWA_Inner_Scope_Level
: Nat
:= 0;
22990 -- This counter keeps track of how many scoping constructs appear within
22991 -- an N_Expression_With_Actions node.
22993 procedure Add_New_Entity
(Old_Id
: Entity_Id
; New_Id
: Entity_Id
);
22994 pragma Inline
(Add_New_Entity
);
22995 -- Add an entry in the NCT_New_Entities table which maps key Old_Id to
22996 -- value New_Id. Old_Id is an entity which appears within the Actions
22997 -- list of an N_Expression_With_Actions node, or within an entity map.
22998 -- New_Id is the corresponding new entity generated during Phase 1.
23000 procedure Add_Pending_Itype
(Assoc_Nod
: Node_Id
; Itype
: Entity_Id
);
23001 pragma Inline
(Add_Pending_Itype
);
23002 -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to
23003 -- value Itype. Assoc_Nod is the associated node of an itype. Itype is
23006 procedure Build_NCT_Tables
(Entity_Map
: Elist_Id
);
23007 pragma Inline
(Build_NCT_Tables
);
23008 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the
23009 -- information supplied in entity map Entity_Map. The format of the
23010 -- entity map must be as follows:
23012 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
23014 function Copy_Any_Node_With_Replacement
23015 (N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
;
23016 pragma Inline
(Copy_Any_Node_With_Replacement
);
23017 -- Replicate entity or node N by invoking one of the following routines:
23019 -- Copy_Node_With_Replacement
23020 -- Corresponding_Entity
23022 function Copy_Elist_With_Replacement
(List
: Elist_Id
) return Elist_Id
;
23023 -- Replicate the elements of entity list List
23025 function Copy_Field_With_Replacement
23027 Old_Par
: Node_Id
:= Empty
;
23028 New_Par
: Node_Id
:= Empty
;
23029 Semantic
: Boolean := False) return Union_Id
;
23030 -- Replicate field Field by invoking one of the following routines:
23032 -- Copy_Elist_With_Replacement
23033 -- Copy_List_With_Replacement
23034 -- Copy_Node_With_Replacement
23035 -- Corresponding_Entity
23037 -- If the field is not an entity list, entity, itype, syntactic list,
23038 -- or node, then the field is returned unchanged. The routine always
23039 -- replicates entities, itypes, and valid syntactic fields. Old_Par is
23040 -- the expected parent of a syntactic field. New_Par is the new parent
23041 -- associated with a replicated syntactic field. Flag Semantic should
23042 -- be set when the input is a semantic field.
23044 function Copy_List_With_Replacement
(List
: List_Id
) return List_Id
;
23045 -- Replicate the elements of syntactic list List
23047 function Copy_Node_With_Replacement
(N
: Node_Id
) return Node_Id
;
23048 -- Replicate node N
23050 function Corresponding_Entity
(Id
: Entity_Id
) return Entity_Id
;
23051 pragma Inline
(Corresponding_Entity
);
23052 -- Return the corresponding new entity of Id generated during Phase 1.
23053 -- If there is no such entity, return Id.
23055 function In_Entity_Map
23057 Entity_Map
: Elist_Id
) return Boolean;
23058 pragma Inline
(In_Entity_Map
);
23059 -- Determine whether entity Id is one of the old ids specified in entity
23060 -- map Entity_Map. The format of the entity map must be as follows:
23062 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
23064 procedure Update_CFS_Sloc
(N
: Node_Or_Entity_Id
);
23065 pragma Inline
(Update_CFS_Sloc
);
23066 -- Update the Comes_From_Source and Sloc attributes of node or entity N
23068 procedure Update_Named_Associations
23069 (Old_Call
: Node_Id
;
23070 New_Call
: Node_Id
);
23071 pragma Inline
(Update_Named_Associations
);
23072 -- Update semantic chain First/Next_Named_Association of call New_call
23073 -- based on call Old_Call.
23075 procedure Update_New_Entities
(Entity_Map
: Elist_Id
);
23076 pragma Inline
(Update_New_Entities
);
23077 -- Update the semantic attributes of all new entities generated during
23078 -- Phase 1 that do not appear in entity map Entity_Map. The format of
23079 -- the entity map must be as follows:
23081 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
23083 procedure Update_Pending_Itypes
23084 (Old_Assoc
: Node_Id
;
23085 New_Assoc
: Node_Id
);
23086 pragma Inline
(Update_Pending_Itypes
);
23087 -- Update semantic attribute Associated_Node_For_Itype to refer to node
23088 -- New_Assoc for all itypes whose associated node is Old_Assoc.
23090 procedure Update_Semantic_Fields
(Id
: Entity_Id
);
23091 pragma Inline
(Update_Semantic_Fields
);
23092 -- Subsidiary to Update_New_Entities. Update semantic fields of entity
23095 procedure Visit_Any_Node
(N
: Node_Or_Entity_Id
);
23096 pragma Inline
(Visit_Any_Node
);
23097 -- Visit entity of node N by invoking one of the following routines:
23103 procedure Visit_Elist
(List
: Elist_Id
);
23104 -- Visit the elements of entity list List
23106 procedure Visit_Entity
(Id
: Entity_Id
);
23107 -- Visit entity Id. This action may create a new entity of Id and save
23108 -- it in table NCT_New_Entities.
23110 procedure Visit_Field
23112 Par_Nod
: Node_Id
:= Empty
;
23113 Semantic
: Boolean := False);
23114 -- Visit field Field by invoking one of the following routines:
23122 -- If the field is not an entity list, entity, itype, syntactic list,
23123 -- or node, then the field is not visited. The routine always visits
23124 -- valid syntactic fields. Par_Nod is the expected parent of the
23125 -- syntactic field. Flag Semantic should be set when the input is a
23128 procedure Visit_Itype
(Itype
: Entity_Id
);
23129 -- Visit itype Itype. This action may create a new entity for Itype and
23130 -- save it in table NCT_New_Entities. In addition, the routine may map
23131 -- the associated node of Itype to the new itype in NCT_Pending_Itypes.
23133 procedure Visit_List
(List
: List_Id
);
23134 -- Visit the elements of syntactic list List
23136 procedure Visit_Node
(N
: Node_Id
);
23139 procedure Visit_Semantic_Fields
(Id
: Entity_Id
);
23140 pragma Inline
(Visit_Semantic_Fields
);
23141 -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic
23142 -- fields of entity or itype Id.
23144 --------------------
23145 -- Add_New_Entity --
23146 --------------------
23148 procedure Add_New_Entity
(Old_Id
: Entity_Id
; New_Id
: Entity_Id
) is
23150 pragma Assert
(Present
(Old_Id
));
23151 pragma Assert
(Present
(New_Id
));
23152 pragma Assert
(Nkind
(Old_Id
) in N_Entity
);
23153 pragma Assert
(Nkind
(New_Id
) in N_Entity
);
23155 NCT_Tables_In_Use
:= True;
23157 -- Sanity check the NCT_New_Entities table. No previous mapping with
23158 -- key Old_Id should exist.
23160 pragma Assert
(No
(NCT_New_Entities
.Get
(Old_Id
)));
23162 -- Establish the mapping
23164 -- Old_Id -> New_Id
23166 NCT_New_Entities
.Set
(Old_Id
, New_Id
);
23167 end Add_New_Entity
;
23169 -----------------------
23170 -- Add_Pending_Itype --
23171 -----------------------
23173 procedure Add_Pending_Itype
(Assoc_Nod
: Node_Id
; Itype
: Entity_Id
) is
23177 pragma Assert
(Present
(Assoc_Nod
));
23178 pragma Assert
(Present
(Itype
));
23179 pragma Assert
(Nkind
(Itype
) in N_Entity
);
23180 pragma Assert
(Is_Itype
(Itype
));
23182 NCT_Tables_In_Use
:= True;
23184 -- It is not possible to sanity check the NCT_Pendint_Itypes table
23185 -- directly because a single node may act as the associated node for
23186 -- multiple itypes.
23188 Itypes
:= NCT_Pending_Itypes
.Get
(Assoc_Nod
);
23190 if No
(Itypes
) then
23191 Itypes
:= New_Elmt_List
;
23192 NCT_Pending_Itypes
.Set
(Assoc_Nod
, Itypes
);
23195 -- Establish the mapping
23197 -- Assoc_Nod -> (Itype, ...)
23199 -- Avoid inserting the same itype multiple times. This involves a
23200 -- linear search, however the set of itypes with the same associated
23201 -- node is very small.
23203 Append_Unique_Elmt
(Itype
, Itypes
);
23204 end Add_Pending_Itype
;
23206 ----------------------
23207 -- Build_NCT_Tables --
23208 ----------------------
23210 procedure Build_NCT_Tables
(Entity_Map
: Elist_Id
) is
23212 Old_Id
: Entity_Id
;
23213 New_Id
: Entity_Id
;
23216 -- Nothing to do when there is no entity map
23218 if No
(Entity_Map
) then
23222 Elmt
:= First_Elmt
(Entity_Map
);
23223 while Present
(Elmt
) loop
23225 -- Extract the (Old_Id, New_Id) pair from the entity map
23227 Old_Id
:= Node
(Elmt
);
23230 New_Id
:= Node
(Elmt
);
23233 -- Establish the following mapping within table NCT_New_Entities
23235 -- Old_Id -> New_Id
23237 Add_New_Entity
(Old_Id
, New_Id
);
23239 -- Establish the following mapping within table NCT_Pending_Itypes
23240 -- when the new entity is an itype.
23242 -- Assoc_Nod -> (New_Id, ...)
23244 -- IMPORTANT: the associated node is that of the old itype because
23245 -- the node will be replicated in Phase 2.
23247 if Is_Itype
(Old_Id
) then
23249 (Assoc_Nod
=> Associated_Node_For_Itype
(Old_Id
),
23253 end Build_NCT_Tables
;
23255 ------------------------------------
23256 -- Copy_Any_Node_With_Replacement --
23257 ------------------------------------
23259 function Copy_Any_Node_With_Replacement
23260 (N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
23263 if Nkind
(N
) in N_Entity
then
23264 return Corresponding_Entity
(N
);
23266 return Copy_Node_With_Replacement
(N
);
23268 end Copy_Any_Node_With_Replacement
;
23270 ---------------------------------
23271 -- Copy_Elist_With_Replacement --
23272 ---------------------------------
23274 function Copy_Elist_With_Replacement
(List
: Elist_Id
) return Elist_Id
is
23279 -- Copy the contents of the old list. Note that the list itself may
23280 -- be empty, in which case the routine returns a new empty list. This
23281 -- avoids sharing lists between subtrees. The element of an entity
23282 -- list could be an entity or a node, hence the invocation of routine
23283 -- Copy_Any_Node_With_Replacement.
23285 if Present
(List
) then
23286 Result
:= New_Elmt_List
;
23288 Elmt
:= First_Elmt
(List
);
23289 while Present
(Elmt
) loop
23291 (Copy_Any_Node_With_Replacement
(Node
(Elmt
)), Result
);
23296 -- Otherwise the list does not exist
23299 Result
:= No_Elist
;
23303 end Copy_Elist_With_Replacement
;
23305 ---------------------------------
23306 -- Copy_Field_With_Replacement --
23307 ---------------------------------
23309 function Copy_Field_With_Replacement
23311 Old_Par
: Node_Id
:= Empty
;
23312 New_Par
: Node_Id
:= Empty
;
23313 Semantic
: Boolean := False) return Union_Id
23315 function Has_More_Ids
(N
: Node_Id
) return Boolean;
23316 -- Return True when N has attribute More_Ids set to True
23318 function Is_Syntactic_Node
return Boolean;
23319 -- Return True when Field is a syntactic node
23325 function Has_More_Ids
(N
: Node_Id
) return Boolean is
23327 if Nkind
(N
) in N_Component_Declaration
23328 | N_Discriminant_Specification
23329 | N_Exception_Declaration
23330 | N_Formal_Object_Declaration
23331 | N_Number_Declaration
23332 | N_Object_Declaration
23333 | N_Parameter_Specification
23334 | N_Use_Package_Clause
23335 | N_Use_Type_Clause
23337 return More_Ids
(N
);
23343 -----------------------
23344 -- Is_Syntactic_Node --
23345 -----------------------
23347 function Is_Syntactic_Node
return Boolean is
23348 Old_N
: constant Node_Id
:= Node_Id
(Field
);
23351 if Parent
(Old_N
) = Old_Par
then
23354 elsif not Has_More_Ids
(Old_Par
) then
23357 -- Perform the check using the last last id in the syntactic chain
23361 N
: Node_Id
:= Old_Par
;
23364 while Present
(N
) and then More_Ids
(N
) loop
23368 pragma Assert
(Prev_Ids
(N
));
23369 return Parent
(Old_N
) = N
;
23372 end Is_Syntactic_Node
;
23375 -- The field is empty
23377 if Field
= Union_Id
(Empty
) then
23380 -- The field is an entity/itype/node
23382 elsif Field
in Node_Range
then
23384 Old_N
: constant Node_Id
:= Node_Id
(Field
);
23385 Syntactic
: constant Boolean := Is_Syntactic_Node
;
23390 -- The field is an entity/itype
23392 if Nkind
(Old_N
) in N_Entity
then
23394 -- An entity/itype is always replicated
23396 New_N
:= Corresponding_Entity
(Old_N
);
23398 -- Update the parent pointer when the entity is a syntactic
23399 -- field. Note that itypes do not have parent pointers.
23401 if Syntactic
and then New_N
/= Old_N
then
23402 Set_Parent
(New_N
, New_Par
);
23405 -- The field is a node
23408 -- A node is replicated when it is either a syntactic field
23409 -- or when the caller treats it as a semantic attribute.
23411 if Syntactic
or else Semantic
then
23412 New_N
:= Copy_Node_With_Replacement
(Old_N
);
23414 -- Update the parent pointer when the node is a syntactic
23417 if Syntactic
and then New_N
/= Old_N
then
23418 Set_Parent
(New_N
, New_Par
);
23421 -- Otherwise the node is returned unchanged
23428 return Union_Id
(New_N
);
23431 -- The field is an entity list
23433 elsif Field
in Elist_Range
then
23434 return Union_Id
(Copy_Elist_With_Replacement
(Elist_Id
(Field
)));
23436 -- The field is a syntactic list
23438 elsif Field
in List_Range
then
23440 Old_List
: constant List_Id
:= List_Id
(Field
);
23441 Syntactic
: constant Boolean := Parent
(Old_List
) = Old_Par
;
23443 New_List
: List_Id
;
23446 -- A list is replicated when it is either a syntactic field or
23447 -- when the caller treats it as a semantic attribute.
23449 if Syntactic
or else Semantic
then
23450 New_List
:= Copy_List_With_Replacement
(Old_List
);
23452 -- Update the parent pointer when the list is a syntactic
23455 if Syntactic
and then New_List
/= Old_List
then
23456 Set_Parent
(New_List
, New_Par
);
23459 -- Otherwise the list is returned unchanged
23462 New_List
:= Old_List
;
23465 return Union_Id
(New_List
);
23468 -- Otherwise the field denotes an attribute that does not need to be
23469 -- replicated (Chars, literals, etc).
23474 end Copy_Field_With_Replacement
;
23476 --------------------------------
23477 -- Copy_List_With_Replacement --
23478 --------------------------------
23480 function Copy_List_With_Replacement
(List
: List_Id
) return List_Id
is
23485 -- Copy the contents of the old list. Note that the list itself may
23486 -- be empty, in which case the routine returns a new empty list. This
23487 -- avoids sharing lists between subtrees. The element of a syntactic
23488 -- list is always a node, never an entity or itype, hence the call to
23489 -- routine Copy_Node_With_Replacement.
23491 if Present
(List
) then
23492 Result
:= New_List
;
23494 Elmt
:= First
(List
);
23495 while Present
(Elmt
) loop
23496 Append
(Copy_Node_With_Replacement
(Elmt
), Result
);
23501 -- Otherwise the list does not exist
23508 end Copy_List_With_Replacement
;
23510 --------------------------------
23511 -- Copy_Node_With_Replacement --
23512 --------------------------------
23514 function Copy_Node_With_Replacement
(N
: Node_Id
) return Node_Id
is
23517 function Transform
(U
: Union_Id
) return Union_Id
;
23518 -- Copies one field, replacing N with Result
23524 function Transform
(U
: Union_Id
) return Union_Id
is
23526 return Copy_Field_With_Replacement
23529 New_Par
=> Result
);
23532 procedure Walk
is new Walk_Sinfo_Fields_Pairwise
(Transform
);
23534 -- Start of processing for Copy_Node_With_Replacement
23537 -- Assume that the node must be returned unchanged
23541 if N
> Empty_Or_Error
then
23542 pragma Assert
(Nkind
(N
) not in N_Entity
);
23544 Result
:= New_Copy
(N
);
23546 Walk
(Result
, Result
);
23548 -- Update the Comes_From_Source and Sloc attributes of the node
23549 -- in case the caller has supplied new values.
23551 Update_CFS_Sloc
(Result
);
23553 -- Update the Associated_Node_For_Itype attribute of all itypes
23554 -- created during Phase 1 whose associated node is N. As a result
23555 -- the Associated_Node_For_Itype refers to the replicated node.
23556 -- No action needs to be taken when the Associated_Node_For_Itype
23557 -- refers to an entity because this was already handled during
23558 -- Phase 1, in Visit_Itype.
23560 Update_Pending_Itypes
23562 New_Assoc
=> Result
);
23564 -- Update the First/Next_Named_Association chain for a replicated
23567 if Nkind
(N
) in N_Entry_Call_Statement
23569 | N_Procedure_Call_Statement
23571 Update_Named_Associations
23573 New_Call
=> Result
);
23575 -- Update the Renamed_Object attribute of a replicated object
23578 elsif Nkind
(N
) = N_Object_Renaming_Declaration
then
23579 Set_Renamed_Object_Of_Possibly_Void
23580 (Defining_Entity
(Result
), Name
(Result
));
23582 -- Update the Chars attribute of identifiers
23584 elsif Nkind
(N
) = N_Identifier
then
23586 -- The Entity field of identifiers that denote aspects is used
23587 -- to store arbitrary expressions (and hence we must check that
23588 -- they reference an actual entity before copying their Chars
23591 if Present
(Entity
(Result
))
23592 and then Nkind
(Entity
(Result
)) in N_Entity
23594 Set_Chars
(Result
, Chars
(Entity
(Result
)));
23598 if Has_Aspects
(N
) then
23599 Set_Aspect_Specifications
(Result
,
23600 Copy_List_With_Replacement
(Aspect_Specifications
(N
)));
23605 end Copy_Node_With_Replacement
;
23607 --------------------------
23608 -- Corresponding_Entity --
23609 --------------------------
23611 function Corresponding_Entity
(Id
: Entity_Id
) return Entity_Id
is
23612 New_Id
: Entity_Id
;
23613 Result
: Entity_Id
;
23616 -- Assume that the entity must be returned unchanged
23620 if Id
> Empty_Or_Error
then
23621 pragma Assert
(Nkind
(Id
) in N_Entity
);
23623 -- Determine whether the entity has a corresponding new entity
23624 -- generated during Phase 1 and if it does, use it.
23626 if NCT_Tables_In_Use
then
23627 New_Id
:= NCT_New_Entities
.Get
(Id
);
23629 if Present
(New_Id
) then
23636 end Corresponding_Entity
;
23638 -------------------
23639 -- In_Entity_Map --
23640 -------------------
23642 function In_Entity_Map
23644 Entity_Map
: Elist_Id
) return Boolean
23647 Old_Id
: Entity_Id
;
23650 -- The entity map contains pairs (Old_Id, New_Id). The advancement
23651 -- step always skips the New_Id portion of the pair.
23653 if Present
(Entity_Map
) then
23654 Elmt
:= First_Elmt
(Entity_Map
);
23655 while Present
(Elmt
) loop
23656 Old_Id
:= Node
(Elmt
);
23658 if Old_Id
= Id
then
23670 ---------------------
23671 -- Update_CFS_Sloc --
23672 ---------------------
23674 procedure Update_CFS_Sloc
(N
: Node_Or_Entity_Id
) is
23676 -- A new source location defaults the Comes_From_Source attribute
23678 if New_Sloc
/= No_Location
then
23679 Set_Comes_From_Source
(N
, Get_Comes_From_Source_Default
);
23680 Set_Sloc
(N
, New_Sloc
);
23682 end Update_CFS_Sloc
;
23684 -------------------------------
23685 -- Update_Named_Associations --
23686 -------------------------------
23688 procedure Update_Named_Associations
23689 (Old_Call
: Node_Id
;
23690 New_Call
: Node_Id
)
23693 New_Next
: Node_Id
;
23695 Old_Next
: Node_Id
;
23698 if No
(First_Named_Actual
(Old_Call
)) then
23702 -- Recreate the First/Next_Named_Actual chain of a call by traversing
23703 -- the chains of both the old and new calls in parallel.
23705 New_Act
:= First
(Parameter_Associations
(New_Call
));
23706 Old_Act
:= First
(Parameter_Associations
(Old_Call
));
23707 while Present
(Old_Act
) loop
23708 if Nkind
(Old_Act
) = N_Parameter_Association
23709 and then Explicit_Actual_Parameter
(Old_Act
)
23710 = First_Named_Actual
(Old_Call
)
23712 Set_First_Named_Actual
(New_Call
,
23713 Explicit_Actual_Parameter
(New_Act
));
23716 if Nkind
(Old_Act
) = N_Parameter_Association
23717 and then Present
(Next_Named_Actual
(Old_Act
))
23719 -- Scan the actual parameter list to find the next suitable
23720 -- named actual. Note that the list may be out of order.
23722 New_Next
:= First
(Parameter_Associations
(New_Call
));
23723 Old_Next
:= First
(Parameter_Associations
(Old_Call
));
23724 while Nkind
(Old_Next
) /= N_Parameter_Association
23725 or else Explicit_Actual_Parameter
(Old_Next
) /=
23726 Next_Named_Actual
(Old_Act
)
23732 Set_Next_Named_Actual
(New_Act
,
23733 Explicit_Actual_Parameter
(New_Next
));
23739 end Update_Named_Associations
;
23741 -------------------------
23742 -- Update_New_Entities --
23743 -------------------------
23745 procedure Update_New_Entities
(Entity_Map
: Elist_Id
) is
23746 New_Id
: Entity_Id
:= Empty
;
23747 Old_Id
: Entity_Id
:= Empty
;
23750 if NCT_Tables_In_Use
then
23751 NCT_New_Entities
.Get_First
(Old_Id
, New_Id
);
23753 -- Update the semantic fields of all new entities created during
23754 -- Phase 1 which were not supplied via an entity map.
23755 -- ??? Is there a better way of distinguishing those?
23757 while Present
(Old_Id
) and then Present
(New_Id
) loop
23758 if not (Present
(Entity_Map
)
23759 and then In_Entity_Map
(Old_Id
, Entity_Map
))
23761 Update_Semantic_Fields
(New_Id
);
23764 NCT_New_Entities
.Get_Next
(Old_Id
, New_Id
);
23767 end Update_New_Entities
;
23769 ---------------------------
23770 -- Update_Pending_Itypes --
23771 ---------------------------
23773 procedure Update_Pending_Itypes
23774 (Old_Assoc
: Node_Id
;
23775 New_Assoc
: Node_Id
)
23781 if NCT_Tables_In_Use
then
23782 Itypes
:= NCT_Pending_Itypes
.Get
(Old_Assoc
);
23784 -- Update the Associated_Node_For_Itype attribute for all itypes
23785 -- which originally refer to Old_Assoc to designate New_Assoc.
23787 if Present
(Itypes
) then
23788 Item
:= First_Elmt
(Itypes
);
23789 while Present
(Item
) loop
23790 Set_Associated_Node_For_Itype
(Node
(Item
), New_Assoc
);
23796 end Update_Pending_Itypes
;
23798 ----------------------------
23799 -- Update_Semantic_Fields --
23800 ----------------------------
23802 procedure Update_Semantic_Fields
(Id
: Entity_Id
) is
23804 -- Discriminant_Constraint
23806 if Is_Type
(Id
) and then Has_Discriminants
(Base_Type
(Id
)) then
23807 Set_Discriminant_Constraint
(Id
, Elist_Id
(
23808 Copy_Field_With_Replacement
23809 (Field
=> Union_Id
(Discriminant_Constraint
(Id
)),
23810 Semantic
=> True)));
23815 Set_Etype
(Id
, Node_Id
(
23816 Copy_Field_With_Replacement
23817 (Field
=> Union_Id
(Etype
(Id
)),
23818 Semantic
=> True)));
23821 -- Packed_Array_Impl_Type
23823 if Is_Array_Type
(Id
) then
23824 if Present
(First_Index
(Id
)) then
23825 Set_First_Index
(Id
, First
(List_Id
(
23826 Copy_Field_With_Replacement
23827 (Field
=> Union_Id
(List_Containing
(First_Index
(Id
))),
23828 Semantic
=> True))));
23831 if Is_Packed
(Id
) then
23832 Set_Packed_Array_Impl_Type
(Id
, Node_Id
(
23833 Copy_Field_With_Replacement
23834 (Field
=> Union_Id
(Packed_Array_Impl_Type
(Id
)),
23835 Semantic
=> True)));
23841 Set_Prev_Entity
(Id
, Node_Id
(
23842 Copy_Field_With_Replacement
23843 (Field
=> Union_Id
(Prev_Entity
(Id
)),
23844 Semantic
=> True)));
23848 Set_Next_Entity
(Id
, Node_Id
(
23849 Copy_Field_With_Replacement
23850 (Field
=> Union_Id
(Next_Entity
(Id
)),
23851 Semantic
=> True)));
23855 if Is_Discrete_Type
(Id
) then
23856 Set_Scalar_Range
(Id
, Node_Id
(
23857 Copy_Field_With_Replacement
23858 (Field
=> Union_Id
(Scalar_Range
(Id
)),
23859 Semantic
=> True)));
23864 -- Update the scope when the caller specified an explicit one
23866 if Present
(New_Scope
) then
23867 Set_Scope
(Id
, New_Scope
);
23869 Set_Scope
(Id
, Node_Id
(
23870 Copy_Field_With_Replacement
23871 (Field
=> Union_Id
(Scope
(Id
)),
23872 Semantic
=> True)));
23874 end Update_Semantic_Fields
;
23876 --------------------
23877 -- Visit_Any_Node --
23878 --------------------
23880 procedure Visit_Any_Node
(N
: Node_Or_Entity_Id
) is
23882 if Nkind
(N
) in N_Entity
then
23883 if Is_Itype
(N
) then
23891 end Visit_Any_Node
;
23897 procedure Visit_Elist
(List
: Elist_Id
) is
23901 -- The element of an entity list could be an entity, itype, or a
23902 -- node, hence the call to Visit_Any_Node.
23904 if Present
(List
) then
23905 Elmt
:= First_Elmt
(List
);
23906 while Present
(Elmt
) loop
23907 Visit_Any_Node
(Node
(Elmt
));
23918 procedure Visit_Entity
(Id
: Entity_Id
) is
23919 New_Id
: Entity_Id
;
23922 pragma Assert
(Nkind
(Id
) in N_Entity
);
23923 pragma Assert
(not Is_Itype
(Id
));
23925 -- Nothing to do when the entity is not defined in the Actions list
23926 -- of an N_Expression_With_Actions node.
23928 if EWA_Level
= 0 then
23931 -- Nothing to do when the entity is defined in a scoping construct
23932 -- within an N_Expression_With_Actions node, unless the caller has
23933 -- requested their replication.
23935 -- ??? should this restriction be eliminated?
23937 elsif EWA_Inner_Scope_Level
> 0 and then not Scopes_In_EWA_OK
then
23940 -- Nothing to do when the entity does not denote a construct that
23941 -- may appear within an N_Expression_With_Actions node. Relaxing
23942 -- this restriction leads to a performance penalty.
23944 -- ??? this list is flaky, and may hide dormant bugs
23945 -- Should functions be included???
23947 -- Quantified expressions contain an entity declaration that must
23948 -- always be replaced when the expander is active, even if it has
23949 -- not been analyzed yet like e.g. in predicates.
23951 elsif Ekind
(Id
) not in E_Block
23956 and then not Is_Entity_Of_Quantified_Expression
(Id
)
23957 and then not Is_Type
(Id
)
23961 -- Nothing to do when the entity was already visited
23963 elsif NCT_Tables_In_Use
23964 and then Present
(NCT_New_Entities
.Get
(Id
))
23968 -- Nothing to do when the declaration node of the entity is not in
23969 -- the subtree being replicated.
23971 elsif not In_Subtree
23972 (N
=> Declaration_Node
(Id
),
23978 -- Create a new entity by directly copying the old entity. This
23979 -- action causes all attributes of the old entity to be inherited.
23981 New_Id
:= New_Copy
(Id
);
23983 -- Create a new name for the new entity because the back end needs
23984 -- distinct names for debugging purposes, provided that the entity
23985 -- has already been analyzed.
23987 if Ekind
(Id
) /= E_Void
then
23988 Set_Chars
(New_Id
, New_Internal_Name
('T'));
23991 -- Update the Comes_From_Source and Sloc attributes of the entity in
23992 -- case the caller has supplied new values.
23994 Update_CFS_Sloc
(New_Id
);
23996 -- Establish the following mapping within table NCT_New_Entities:
24000 Add_New_Entity
(Id
, New_Id
);
24002 -- Deal with the semantic fields of entities. The fields are visited
24003 -- because they may mention entities which reside within the subtree
24006 Visit_Semantic_Fields
(Id
);
24013 procedure Visit_Field
24015 Par_Nod
: Node_Id
:= Empty
;
24016 Semantic
: Boolean := False)
24019 -- The field is empty
24021 if Field
= Union_Id
(Empty
) then
24024 -- The field is an entity/itype/node
24026 elsif Field
in Node_Range
then
24028 N
: constant Node_Id
:= Node_Id
(Field
);
24031 -- The field is an entity/itype
24033 if Nkind
(N
) in N_Entity
then
24035 -- Itypes are always visited
24037 if Is_Itype
(N
) then
24040 -- An entity is visited when it is either a syntactic field
24041 -- or when the caller treats it as a semantic attribute.
24043 elsif Parent
(N
) = Par_Nod
or else Semantic
then
24047 -- The field is a node
24050 -- A node is visited when it is either a syntactic field or
24051 -- when the caller treats it as a semantic attribute.
24053 if Parent
(N
) = Par_Nod
or else Semantic
then
24059 -- The field is an entity list
24061 elsif Field
in Elist_Range
then
24062 Visit_Elist
(Elist_Id
(Field
));
24064 -- The field is a syntax list
24066 elsif Field
in List_Range
then
24068 List
: constant List_Id
:= List_Id
(Field
);
24071 -- A syntax list is visited when it is either a syntactic field
24072 -- or when the caller treats it as a semantic attribute.
24074 if Parent
(List
) = Par_Nod
or else Semantic
then
24079 -- Otherwise the field denotes information which does not need to be
24080 -- visited (chars, literals, etc.).
24091 procedure Visit_Itype
(Itype
: Entity_Id
) is
24092 New_Assoc
: Node_Id
;
24093 New_Itype
: Entity_Id
;
24094 Old_Assoc
: Node_Id
;
24097 pragma Assert
(Nkind
(Itype
) in N_Entity
);
24098 pragma Assert
(Is_Itype
(Itype
));
24100 -- Itypes that describe the designated type of access to subprograms
24101 -- have the structure of subprogram declarations, with signatures,
24102 -- etc. Either we duplicate the signatures completely, or choose to
24103 -- share such itypes, which is fine because their elaboration will
24104 -- have no side effects.
24106 if Ekind
(Itype
) = E_Subprogram_Type
then
24109 -- Nothing to do if the itype was already visited
24111 elsif NCT_Tables_In_Use
24112 and then Present
(NCT_New_Entities
.Get
(Itype
))
24116 -- Nothing to do if the associated node of the itype is not within
24117 -- the subtree being replicated.
24119 elsif not In_Subtree
24120 (N
=> Associated_Node_For_Itype
(Itype
),
24126 -- Create a new itype by directly copying the old itype. This action
24127 -- causes all attributes of the old itype to be inherited.
24129 New_Itype
:= New_Copy
(Itype
);
24131 -- Create a new name for the new itype because the back end requires
24132 -- distinct names for debugging purposes.
24134 Set_Chars
(New_Itype
, New_Internal_Name
('T'));
24136 -- Update the Comes_From_Source and Sloc attributes of the itype in
24137 -- case the caller has supplied new values.
24139 Update_CFS_Sloc
(New_Itype
);
24141 -- Establish the following mapping within table NCT_New_Entities:
24143 -- Itype -> New_Itype
24145 Add_New_Entity
(Itype
, New_Itype
);
24147 -- The new itype must be unfrozen because the resulting subtree may
24148 -- be inserted anywhere and cause an earlier or later freezing.
24150 if Present
(Freeze_Node
(New_Itype
)) then
24151 Set_Freeze_Node
(New_Itype
, Empty
);
24152 Set_Is_Frozen
(New_Itype
, False);
24155 -- If a record subtype is simply copied, the entity list will be
24156 -- shared, so Cloned_Subtype must be set to indicate this.
24158 if Ekind
(Itype
) in E_Class_Wide_Subtype | E_Record_Subtype
then
24159 Set_Cloned_Subtype
(New_Itype
, Itype
);
24162 -- The associated node may denote an entity, in which case it may
24163 -- already have a new corresponding entity created during a prior
24164 -- call to Visit_Entity or Visit_Itype for the same subtree.
24167 -- Old_Assoc ---------> New_Assoc
24169 -- Created by Visit_Itype
24170 -- Itype -------------> New_Itype
24171 -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated
24173 -- In the example above, Old_Assoc is an arbitrary entity that was
24174 -- already visited for the same subtree and has a corresponding new
24175 -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue
24176 -- of copying entities, however it must be updated to New_Assoc.
24178 Old_Assoc
:= Associated_Node_For_Itype
(Itype
);
24180 if Nkind
(Old_Assoc
) in N_Entity
then
24181 if NCT_Tables_In_Use
then
24182 New_Assoc
:= NCT_New_Entities
.Get
(Old_Assoc
);
24184 if Present
(New_Assoc
) then
24185 Set_Associated_Node_For_Itype
(New_Itype
, New_Assoc
);
24189 -- Otherwise the associated node denotes a node. Postpone the update
24190 -- until Phase 2 when the node is replicated. Establish the following
24191 -- mapping within table NCT_Pending_Itypes:
24193 -- Old_Assoc -> (New_Type, ...)
24196 Add_Pending_Itype
(Old_Assoc
, New_Itype
);
24199 -- Deal with the semantic fields of itypes. The fields are visited
24200 -- because they may mention entities that reside within the subtree
24203 Visit_Semantic_Fields
(Itype
);
24210 procedure Visit_List
(List
: List_Id
) is
24214 -- Note that the element of a syntactic list is always a node, never
24215 -- an entity or itype, hence the call to Visit_Node.
24217 if Present
(List
) then
24218 Elmt
:= First
(List
);
24219 while Present
(Elmt
) loop
24231 procedure Visit_Node
(N
: Node_Id
) is
24233 pragma Assert
(Nkind
(N
) not in N_Entity
);
24235 -- If the node is a quantified expression and expander is active,
24236 -- it contains an implicit declaration that may require a new entity
24237 -- when the condition has already been (pre)analyzed.
24239 if Nkind
(N
) = N_Expression_With_Actions
24241 (Nkind
(N
) = N_Quantified_Expression
and then Expander_Active
)
24243 EWA_Level
:= EWA_Level
+ 1;
24245 elsif EWA_Level
> 0
24246 and then Nkind
(N
) in N_Block_Statement
24247 | N_Subprogram_Body
24248 | N_Subprogram_Declaration
24250 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
+ 1;
24253 -- If the node is a block, we need to process all declarations
24254 -- in the block and make new entities for each.
24256 if Nkind
(N
) = N_Block_Statement
and then Present
(Declarations
(N
))
24259 Decl
: Node_Id
:= First
(Declarations
(N
));
24262 while Present
(Decl
) loop
24263 if Nkind
(Decl
) = N_Object_Declaration
then
24264 Add_New_Entity
(Defining_Identifier
(Decl
),
24265 New_Copy
(Defining_Identifier
(Decl
)));
24274 procedure Action
(U
: Union_Id
);
24275 procedure Action
(U
: Union_Id
) is
24277 Visit_Field
(Field
=> U
, Par_Nod
=> N
);
24280 procedure Walk
is new Walk_Sinfo_Fields
(Action
);
24286 and then Nkind
(N
) in N_Block_Statement
24287 | N_Subprogram_Body
24288 | N_Subprogram_Declaration
24290 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
- 1;
24292 elsif Nkind
(N
) = N_Expression_With_Actions
then
24293 EWA_Level
:= EWA_Level
- 1;
24297 ---------------------------
24298 -- Visit_Semantic_Fields --
24299 ---------------------------
24301 procedure Visit_Semantic_Fields
(Id
: Entity_Id
) is
24303 pragma Assert
(Nkind
(Id
) in N_Entity
);
24305 -- Discriminant_Constraint
24307 if Is_Type
(Id
) and then Has_Discriminants
(Base_Type
(Id
)) then
24309 (Field
=> Union_Id
(Discriminant_Constraint
(Id
)),
24316 (Field
=> Union_Id
(Etype
(Id
)),
24320 -- Packed_Array_Impl_Type
24322 if Is_Array_Type
(Id
) then
24323 if Present
(First_Index
(Id
)) then
24325 (Field
=> Union_Id
(List_Containing
(First_Index
(Id
))),
24329 if Is_Packed
(Id
) then
24331 (Field
=> Union_Id
(Packed_Array_Impl_Type
(Id
)),
24338 if Is_Discrete_Type
(Id
) then
24340 (Field
=> Union_Id
(Scalar_Range
(Id
)),
24343 end Visit_Semantic_Fields
;
24345 -- Start of processing for New_Copy_Tree
24348 -- Routine New_Copy_Tree performs a deep copy of a subtree by creating
24349 -- shallow copies for each node within, and then updating the child and
24350 -- parent pointers accordingly. This process is straightforward, however
24351 -- the routine must deal with the following complications:
24353 -- * Entities defined within N_Expression_With_Actions nodes must be
24354 -- replicated rather than shared to avoid introducing two identical
24355 -- symbols within the same scope. Note that no other expression can
24356 -- currently define entities.
24359 -- Source_Low : ...;
24360 -- Source_High : ...;
24362 -- <reference to Source_Low>
24363 -- <reference to Source_High>
24366 -- New_Copy_Tree handles this case by first creating new entities
24367 -- and then updating all existing references to point to these new
24374 -- <reference to New_Low>
24375 -- <reference to New_High>
24378 -- * Itypes defined within the subtree must be replicated to avoid any
24379 -- dependencies on invalid or inaccessible data.
24381 -- subtype Source_Itype is ... range Source_Low .. Source_High;
24383 -- New_Copy_Tree handles this case by first creating a new itype in
24384 -- the same fashion as entities, and then updating various relevant
24387 -- subtype New_Itype is ... range New_Low .. New_High;
24389 -- * The Associated_Node_For_Itype field of itypes must be updated to
24390 -- reference the proper replicated entity or node.
24392 -- * Semantic fields of entities such as Etype and Scope must be
24393 -- updated to reference the proper replicated entities.
24395 -- * Some semantic fields of nodes must be updated to reference
24396 -- the proper replicated nodes.
24398 -- Finally, quantified expressions contain an implicit declaration for
24399 -- the bound variable. Given that quantified expressions appearing
24400 -- in contracts are copied to create pragmas and eventually checking
24401 -- procedures, a new bound variable must be created for each copy, to
24402 -- prevent multiple declarations of the same symbol.
24404 -- To meet all these demands, routine New_Copy_Tree is split into two
24407 -- Phase 1 traverses the tree in order to locate entities and itypes
24408 -- defined within the subtree. New entities are generated and saved in
24409 -- table NCT_New_Entities. The semantic fields of all new entities and
24410 -- itypes are then updated accordingly.
24412 -- Phase 2 traverses the tree in order to replicate each node. Various
24413 -- semantic fields of nodes and entities are updated accordingly.
24415 -- Preparatory phase. Clear the contents of tables NCT_New_Entities and
24416 -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some
24419 if NCT_Tables_In_Use
then
24420 NCT_Tables_In_Use
:= False;
24422 NCT_New_Entities
.Reset
;
24423 NCT_Pending_Itypes
.Reset
;
24426 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data
24427 -- supplied by a linear entity map. The tables offer faster access to
24430 Build_NCT_Tables
(Map
);
24432 -- Execute Phase 1. Traverse the subtree and generate new entities for
24433 -- the following cases:
24435 -- * An entity defined within an N_Expression_With_Actions node
24437 -- * An itype referenced within the subtree where the associated node
24438 -- is also in the subtree.
24440 -- All new entities are accessible via table NCT_New_Entities, which
24441 -- contains mappings of the form:
24443 -- Old_Entity -> New_Entity
24444 -- Old_Itype -> New_Itype
24446 -- In addition, the associated nodes of all new itypes are mapped in
24447 -- table NCT_Pending_Itypes:
24449 -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN)
24451 Visit_Any_Node
(Source
);
24453 -- Update the semantic attributes of all new entities generated during
24454 -- Phase 1 before starting Phase 2. The updates could be performed in
24455 -- routine Corresponding_Entity, however this may cause the same entity
24456 -- to be updated multiple times, effectively generating useless nodes.
24457 -- Keeping the updates separates from Phase 2 ensures that only one set
24458 -- of attributes is generated for an entity at any one time.
24460 Update_New_Entities
(Map
);
24462 -- Execute Phase 2. Replicate the source subtree one node at a time.
24463 -- The following transformations take place:
24465 -- * References to entities and itypes are updated to refer to the
24466 -- new entities and itypes generated during Phase 1.
24468 -- * All Associated_Node_For_Itype attributes of itypes are updated
24469 -- to refer to the new replicated Associated_Node_For_Itype.
24471 return Copy_Node_With_Replacement
(Source
);
24474 -------------------------
24475 -- New_External_Entity --
24476 -------------------------
24478 function New_External_Entity
24479 (Kind
: Entity_Kind
;
24480 Scope_Id
: Entity_Id
;
24481 Sloc_Value
: Source_Ptr
;
24482 Related_Id
: Entity_Id
;
24483 Suffix
: Character;
24484 Suffix_Index
: Int
:= 0;
24485 Prefix
: Character := ' ') return Entity_Id
24487 N
: constant Entity_Id
:=
24488 Make_Defining_Identifier
(Sloc_Value
,
24490 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
24493 Mutate_Ekind
(N
, Kind
);
24494 Set_Is_Internal
(N
, True);
24495 Append_Entity
(N
, Scope_Id
);
24496 Set_Public_Status
(N
);
24498 if Kind
in Type_Kind
then
24499 Reinit_Size_Align
(N
);
24503 end New_External_Entity
;
24505 -------------------------
24506 -- New_Internal_Entity --
24507 -------------------------
24509 function New_Internal_Entity
24510 (Kind
: Entity_Kind
;
24511 Scope_Id
: Entity_Id
;
24512 Sloc_Value
: Source_Ptr
;
24513 Id_Char
: Character) return Entity_Id
24515 N
: constant Entity_Id
:= Make_Temporary
(Sloc_Value
, Id_Char
);
24518 Mutate_Ekind
(N
, Kind
);
24519 Set_Is_Internal
(N
, True);
24520 Append_Entity
(N
, Scope_Id
);
24522 if Kind
in Type_Kind
then
24523 Reinit_Size_Align
(N
);
24527 end New_Internal_Entity
;
24533 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
24534 Par
: constant Node_Id
:= Parent
(Actual_Id
);
24538 -- If we are pointing at a positional parameter, it is a member of a
24539 -- node list (the list of parameters), and the next parameter is the
24540 -- next node on the list, unless we hit a parameter association, then
24541 -- we shift to using the chain whose head is the First_Named_Actual in
24542 -- the parent, and then is threaded using the Next_Named_Actual of the
24543 -- Parameter_Association. All this fiddling is because the original node
24544 -- list is in the textual call order, and what we need is the
24545 -- declaration order.
24547 if Is_List_Member
(Actual_Id
) then
24548 N
:= Next
(Actual_Id
);
24550 if Nkind
(N
) = N_Parameter_Association
then
24552 -- In case of a build-in-place call, the call will no longer be a
24553 -- call; it will have been rewritten.
24555 if Nkind
(Par
) in N_Entry_Call_Statement
24557 | N_Procedure_Call_Statement
24559 return First_Named_Actual
(Par
);
24561 -- In case of a call rewritten in GNATprove mode while "inlining
24562 -- for proof" go to the original call.
24564 elsif Nkind
(Par
) = N_Null_Statement
then
24568 Nkind
(Original_Node
(Par
)) in N_Subprogram_Call
);
24570 return First_Named_Actual
(Original_Node
(Par
));
24579 return Next_Named_Actual
(Parent
(Actual_Id
));
24583 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
24585 Actual_Id
:= Next_Actual
(Actual_Id
);
24592 function Next_Global
(Node
: Node_Id
) return Node_Id
is
24594 -- The global item may either be in a list, or by itself, in which case
24595 -- there is no next global item with the same mode.
24597 if Is_List_Member
(Node
) then
24598 return Next
(Node
);
24604 procedure Next_Global
(Node
: in out Node_Id
) is
24606 Node
:= Next_Global
(Node
);
24609 ------------------------
24610 -- No_Caching_Enabled --
24611 ------------------------
24613 function No_Caching_Enabled
(Id
: Entity_Id
) return Boolean is
24614 Prag
: constant Node_Id
:= Get_Pragma
(Id
, Pragma_No_Caching
);
24618 if Present
(Prag
) then
24619 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
24621 -- The pragma has an optional Boolean expression, the related
24622 -- property is enabled only when the expression evaluates to True.
24624 if Present
(Arg1
) then
24625 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
)));
24627 -- Otherwise the lack of expression enables the property by
24634 -- The property was never set in the first place
24639 end No_Caching_Enabled
;
24641 --------------------------
24642 -- No_Heap_Finalization --
24643 --------------------------
24645 function No_Heap_Finalization
(Typ
: Entity_Id
) return Boolean is
24647 if Ekind
(Typ
) in E_Access_Type | E_General_Access_Type
24648 and then Is_Library_Level_Entity
(Typ
)
24650 -- A global No_Heap_Finalization pragma applies to all library-level
24651 -- named access-to-object types.
24653 if Present
(No_Heap_Finalization_Pragma
) then
24656 -- The library-level named access-to-object type itself is subject to
24657 -- pragma No_Heap_Finalization.
24659 elsif Present
(Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
)) then
24665 end No_Heap_Finalization
;
24667 -----------------------
24668 -- Normalize_Actuals --
24669 -----------------------
24671 -- Chain actuals according to formals of subprogram. If there are no named
24672 -- associations, the chain is simply the list of Parameter Associations,
24673 -- since the order is the same as the declaration order. If there are named
24674 -- associations, then the First_Named_Actual field in the N_Function_Call
24675 -- or N_Procedure_Call_Statement node points to the Parameter_Association
24676 -- node for the parameter that comes first in declaration order. The
24677 -- remaining named parameters are then chained in declaration order using
24678 -- Next_Named_Actual.
24680 -- This routine also verifies that the number of actuals is compatible with
24681 -- the number and default values of formals, but performs no type checking
24682 -- (type checking is done by the caller).
24684 -- If the matching succeeds, Success is set to True and the caller proceeds
24685 -- with type-checking. If the match is unsuccessful, then Success is set to
24686 -- False, and the caller attempts a different interpretation, if there is
24689 -- If the flag Report is on, the call is not overloaded, and a failure to
24690 -- match can be reported here, rather than in the caller.
24692 procedure Normalize_Actuals
24696 Success
: out Boolean)
24698 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
24699 Actual
: Node_Id
:= Empty
;
24700 Formal
: Entity_Id
;
24701 Last
: Node_Id
:= Empty
;
24702 First_Named
: Node_Id
:= Empty
;
24705 Formals_To_Match
: Integer := 0;
24706 Actuals_To_Match
: Integer := 0;
24708 procedure Chain
(A
: Node_Id
);
24709 -- Add named actual at the proper place in the list, using the
24710 -- Next_Named_Actual link.
24712 function Reporting
return Boolean;
24713 -- Determines if an error is to be reported. To report an error, we
24714 -- need Report to be True, and also we do not report errors caused
24715 -- by calls to init procs that occur within other init procs. Such
24716 -- errors must always be cascaded errors, since if all the types are
24717 -- declared correctly, the compiler will certainly build decent calls.
24723 procedure Chain
(A
: Node_Id
) is
24727 -- Call node points to first actual in list
24729 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
24732 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
24736 Set_Next_Named_Actual
(Last
, Empty
);
24743 function Reporting
return Boolean is
24748 elsif not Within_Init_Proc
then
24751 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
24759 -- Start of processing for Normalize_Actuals
24762 if Is_Access_Type
(S
) then
24764 -- The name in the call is a function call that returns an access
24765 -- to subprogram. The designated type has the list of formals.
24767 Formal
:= First_Formal
(Designated_Type
(S
));
24769 Formal
:= First_Formal
(S
);
24772 while Present
(Formal
) loop
24773 Formals_To_Match
:= Formals_To_Match
+ 1;
24774 Next_Formal
(Formal
);
24777 -- Find if there is a named association, and verify that no positional
24778 -- associations appear after named ones.
24780 if Present
(Actuals
) then
24781 Actual
:= First
(Actuals
);
24784 while Present
(Actual
)
24785 and then Nkind
(Actual
) /= N_Parameter_Association
24787 Actuals_To_Match
:= Actuals_To_Match
+ 1;
24791 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
24793 -- Most common case: positional notation, no defaults
24798 elsif Actuals_To_Match
> Formals_To_Match
then
24800 -- Too many actuals: will not work
24803 if Is_Entity_Name
(Name
(N
)) then
24804 Error_Msg_N
("too many arguments in call to&", Name
(N
));
24806 Error_Msg_N
("too many arguments in call", N
);
24814 First_Named
:= Actual
;
24816 while Present
(Actual
) loop
24817 if Nkind
(Actual
) /= N_Parameter_Association
then
24819 ("positional parameters not allowed after named ones", Actual
);
24824 Actuals_To_Match
:= Actuals_To_Match
+ 1;
24830 if Present
(Actuals
) then
24831 Actual
:= First
(Actuals
);
24834 Formal
:= First_Formal
(S
);
24835 while Present
(Formal
) loop
24837 -- Match the formals in order. If the corresponding actual is
24838 -- positional, nothing to do. Else scan the list of named actuals
24839 -- to find the one with the right name.
24841 if Present
(Actual
)
24842 and then Nkind
(Actual
) /= N_Parameter_Association
24845 Actuals_To_Match
:= Actuals_To_Match
- 1;
24846 Formals_To_Match
:= Formals_To_Match
- 1;
24849 -- For named parameters, search the list of actuals to find
24850 -- one that matches the next formal name.
24852 Actual
:= First_Named
;
24854 while Present
(Actual
) loop
24855 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
24858 Actuals_To_Match
:= Actuals_To_Match
- 1;
24859 Formals_To_Match
:= Formals_To_Match
- 1;
24867 if Ekind
(Formal
) /= E_In_Parameter
24868 or else No
(Default_Value
(Formal
))
24871 if (Comes_From_Source
(S
)
24872 or else Sloc
(S
) = Standard_Location
)
24873 and then Is_Overloadable
(S
)
24877 Nkind
(Parent
(N
)) in N_Procedure_Call_Statement
24879 | N_Parameter_Association
24880 and then Ekind
(S
) /= E_Function
24882 Set_Etype
(N
, Etype
(S
));
24885 Error_Msg_Name_1
:= Chars
(S
);
24886 Error_Msg_Sloc
:= Sloc
(S
);
24888 ("missing argument for parameter & "
24889 & "in call to % declared #", N
, Formal
);
24892 elsif Is_Overloadable
(S
) then
24893 Error_Msg_Name_1
:= Chars
(S
);
24895 -- Point to type derivation that generated the
24898 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
24901 ("missing argument for parameter & "
24902 & "in call to % (inherited) #", N
, Formal
);
24906 ("missing argument for parameter &", N
, Formal
);
24914 Formals_To_Match
:= Formals_To_Match
- 1;
24919 Next_Formal
(Formal
);
24922 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
24929 -- Find some superfluous named actual that did not get
24930 -- attached to the list of associations.
24932 Actual
:= First
(Actuals
);
24933 while Present
(Actual
) loop
24934 if Nkind
(Actual
) = N_Parameter_Association
24935 and then Actual
/= Last
24936 and then No
(Next_Named_Actual
(Actual
))
24938 -- A validity check may introduce a copy of a call that
24939 -- includes an extra actual (for example for an unrelated
24940 -- accessibility check). Check that the extra actual matches
24941 -- some extra formal, which must exist already because
24942 -- subprogram must be frozen at this point.
24944 if Present
(Extra_Formals
(S
))
24945 and then not Comes_From_Source
(Actual
)
24946 and then Nkind
(Actual
) = N_Parameter_Association
24947 and then Chars
(Extra_Formals
(S
)) =
24948 Chars
(Selector_Name
(Actual
))
24953 ("unmatched actual & in call", Selector_Name
(Actual
));
24965 end Normalize_Actuals
;
24967 --------------------------------
24968 -- Note_Possible_Modification --
24969 --------------------------------
24971 procedure Note_Possible_Modification
(N
: Node_Id
; Sure
: Boolean) is
24972 Modification_Comes_From_Source
: constant Boolean :=
24973 Comes_From_Source
(Parent
(N
));
24979 -- Loop to find referenced entity, if there is one
24985 if Is_Entity_Name
(Exp
) then
24986 Ent
:= Entity
(Exp
);
24988 -- If the entity is missing, it is an undeclared identifier,
24989 -- and there is nothing to annotate.
24995 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
24997 P
: constant Node_Id
:= Prefix
(Exp
);
25000 -- In formal verification mode, keep track of all reads and
25001 -- writes through explicit dereferences.
25003 if GNATprove_Mode
then
25004 SPARK_Specific
.Generate_Dereference
(N
, 'm');
25007 if Nkind
(P
) = N_Selected_Component
25008 and then Present
(Entry_Formal
(Entity
(Selector_Name
(P
))))
25010 -- Case of a reference to an entry formal
25012 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
25014 elsif Nkind
(P
) = N_Identifier
25015 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
25016 and then Present
(Expression
(Parent
(Entity
(P
))))
25017 and then Nkind
(Expression
(Parent
(Entity
(P
)))) =
25020 -- Case of a reference to a value on which side effects have
25023 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
25031 elsif Nkind
(Exp
) in N_Type_Conversion | N_Unchecked_Type_Conversion
25033 Exp
:= Expression
(Exp
);
25036 elsif Nkind
(Exp
) in
25037 N_Slice | N_Indexed_Component | N_Selected_Component
25039 -- Special check, if the prefix is an access type, then return
25040 -- since we are modifying the thing pointed to, not the prefix.
25041 -- When we are expanding, most usually the prefix is replaced
25042 -- by an explicit dereference, and this test is not needed, but
25043 -- in some cases (notably -gnatc mode and generics) when we do
25044 -- not do full expansion, we need this special test.
25046 if Is_Access_Type
(Etype
(Prefix
(Exp
))) then
25049 -- Otherwise go to prefix and keep going
25052 Exp
:= Prefix
(Exp
);
25056 -- All other cases, not a modification
25062 -- Now look for entity being referenced
25064 if Present
(Ent
) then
25065 if Is_Object
(Ent
) then
25066 if Comes_From_Source
(Exp
)
25067 or else Modification_Comes_From_Source
25069 -- Give warning if pragma unmodified is given and we are
25070 -- sure this is a modification.
25072 if Has_Pragma_Unmodified
(Ent
) and then Sure
then
25074 -- Note that the entity may be present only as a result
25075 -- of pragma Unused.
25077 if Has_Pragma_Unused
(Ent
) then
25079 ("??aspect Unused specified for &!", N
, Ent
);
25082 ("??aspect Unmodified specified for &!", N
, Ent
);
25086 Set_Never_Set_In_Source
(Ent
, False);
25089 Set_Is_True_Constant
(Ent
, False);
25090 Set_Current_Value
(Ent
, Empty
);
25091 Set_Is_Known_Null
(Ent
, False);
25093 if not Can_Never_Be_Null
(Ent
) then
25094 Set_Is_Known_Non_Null
(Ent
, False);
25097 -- Follow renaming chain
25099 if Ekind
(Ent
) in E_Variable | E_Constant
25100 and then Present
(Renamed_Object
(Ent
))
25102 Exp
:= Renamed_Object
(Ent
);
25104 -- If the entity is the loop variable in an iteration over
25105 -- a container, retrieve container expression to indicate
25106 -- possible modification.
25108 if Present
(Related_Expression
(Ent
))
25109 and then Nkind
(Parent
(Related_Expression
(Ent
))) =
25110 N_Iterator_Specification
25112 Exp
:= Original_Node
(Related_Expression
(Ent
));
25117 -- The expression may be the renaming of a subcomponent of an
25118 -- array or container. The assignment to the subcomponent is
25119 -- a modification of the container.
25121 elsif Comes_From_Source
(Original_Node
(Exp
))
25122 and then Nkind
(Original_Node
(Exp
)) in
25123 N_Selected_Component | N_Indexed_Component
25125 Exp
:= Prefix
(Original_Node
(Exp
));
25129 -- Generate a reference only if the assignment comes from
25130 -- source. This excludes, for example, calls to a dispatching
25131 -- assignment operation when the left-hand side is tagged. In
25132 -- GNATprove mode, we need those references also on generated
25133 -- code, as these are used to compute the local effects of
25136 if Modification_Comes_From_Source
or GNATprove_Mode
then
25137 Generate_Reference
(Ent
, Exp
, 'm');
25139 -- If the target of the assignment is the bound variable
25140 -- in an iterator, indicate that the corresponding array
25141 -- or container is also modified.
25143 if Ada_Version
>= Ada_2012
25144 and then Nkind
(Parent
(Ent
)) = N_Iterator_Specification
25147 Domain
: constant Node_Id
:= Name
(Parent
(Ent
));
25150 -- ??? In the full version of the construct, the
25151 -- domain of iteration can be given by an expression.
25153 if Is_Entity_Name
(Domain
) then
25154 Generate_Reference
(Entity
(Domain
), Exp
, 'm');
25155 Set_Is_True_Constant
(Entity
(Domain
), False);
25156 Set_Never_Set_In_Source
(Entity
(Domain
), False);
25165 -- If we are sure this is a modification from source, and we know
25166 -- this modifies a constant, then give an appropriate warning.
25169 and then Modification_Comes_From_Source
25170 and then Overlays_Constant
(Ent
)
25171 and then Address_Clause_Overlay_Warnings
25174 Addr
: constant Node_Id
:= Address_Clause
(Ent
);
25179 Find_Overlaid_Entity
(Addr
, O_Ent
, Off
);
25181 Error_Msg_Sloc
:= Sloc
(Addr
);
25183 ("?o?constant& may be modified via address clause#",
25194 end Note_Possible_Modification
;
25200 function Null_Status
(N
: Node_Id
) return Null_Status_Kind
is
25201 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean;
25202 -- Determine whether definition Def carries a null exclusion
25204 function Null_Status_Of_Entity
(Id
: Entity_Id
) return Null_Status_Kind
;
25205 -- Determine the null status of arbitrary entity Id
25207 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
;
25208 -- Determine the null status of type Typ
25210 ---------------------------
25211 -- Is_Null_Excluding_Def --
25212 ---------------------------
25214 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean is
25216 return Nkind
(Def
) in N_Access_Definition
25217 | N_Access_Function_Definition
25218 | N_Access_Procedure_Definition
25219 | N_Access_To_Object_Definition
25220 | N_Component_Definition
25221 | N_Derived_Type_Definition
25222 and then Null_Exclusion_Present
(Def
);
25223 end Is_Null_Excluding_Def
;
25225 ---------------------------
25226 -- Null_Status_Of_Entity --
25227 ---------------------------
25229 function Null_Status_Of_Entity
25230 (Id
: Entity_Id
) return Null_Status_Kind
25232 Decl
: constant Node_Id
:= Declaration_Node
(Id
);
25236 -- The value of an imported or exported entity may be set externally
25237 -- regardless of a null exclusion. As a result, the value cannot be
25238 -- determined statically.
25240 if Is_Imported
(Id
) or else Is_Exported
(Id
) then
25243 elsif Nkind
(Decl
) in N_Component_Declaration
25244 | N_Discriminant_Specification
25245 | N_Formal_Object_Declaration
25246 | N_Object_Declaration
25247 | N_Object_Renaming_Declaration
25248 | N_Parameter_Specification
25250 -- A component declaration yields a non-null value when either
25251 -- its component definition or access definition carries a null
25254 if Nkind
(Decl
) = N_Component_Declaration
then
25255 Def
:= Component_Definition
(Decl
);
25257 if Is_Null_Excluding_Def
(Def
) then
25258 return Is_Non_Null
;
25261 Def
:= Access_Definition
(Def
);
25263 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25264 return Is_Non_Null
;
25267 -- A formal object declaration yields a non-null value if its
25268 -- access definition carries a null exclusion. If the object is
25269 -- default initialized, then the value depends on the expression.
25271 elsif Nkind
(Decl
) = N_Formal_Object_Declaration
then
25272 Def
:= Access_Definition
(Decl
);
25274 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25275 return Is_Non_Null
;
25278 -- A constant may yield a null or non-null value depending on its
25279 -- initialization expression.
25281 elsif Ekind
(Id
) = E_Constant
then
25282 return Null_Status
(Constant_Value
(Id
));
25284 -- The construct yields a non-null value when it has a null
25287 elsif Null_Exclusion_Present
(Decl
) then
25288 return Is_Non_Null
;
25290 -- An object renaming declaration yields a non-null value if its
25291 -- access definition carries a null exclusion. Otherwise the value
25292 -- depends on the renamed name.
25294 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
25295 Def
:= Access_Definition
(Decl
);
25297 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25298 return Is_Non_Null
;
25301 return Null_Status
(Name
(Decl
));
25306 -- At this point the declaration of the entity does not carry a null
25307 -- exclusion and lacks an initialization expression. Check the status
25310 return Null_Status_Of_Type
(Etype
(Id
));
25311 end Null_Status_Of_Entity
;
25313 -------------------------
25314 -- Null_Status_Of_Type --
25315 -------------------------
25317 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
is
25322 -- Traverse the type chain looking for types with null exclusion
25325 while Present
(Curr
) and then Etype
(Curr
) /= Curr
loop
25326 Decl
:= Parent
(Curr
);
25328 -- Guard against itypes which do not always have declarations. A
25329 -- type yields a non-null value if it carries a null exclusion.
25331 if Present
(Decl
) then
25332 if Nkind
(Decl
) = N_Full_Type_Declaration
25333 and then Is_Null_Excluding_Def
(Type_Definition
(Decl
))
25335 return Is_Non_Null
;
25337 elsif Nkind
(Decl
) = N_Subtype_Declaration
25338 and then Null_Exclusion_Present
(Decl
)
25340 return Is_Non_Null
;
25344 Curr
:= Etype
(Curr
);
25347 -- The type chain does not contain any null excluding types
25350 end Null_Status_Of_Type
;
25352 -- Start of processing for Null_Status
25355 -- Prevent cascaded errors or infinite loops when trying to determine
25356 -- the null status of an erroneous construct.
25358 if Error_Posted
(N
) then
25361 -- An allocator always creates a non-null value
25363 elsif Nkind
(N
) = N_Allocator
then
25364 return Is_Non_Null
;
25366 -- Taking the 'Access of something yields a non-null value
25368 elsif Nkind
(N
) = N_Attribute_Reference
25369 and then Attribute_Name
(N
) in Name_Access
25370 | Name_Unchecked_Access
25371 | Name_Unrestricted_Access
25373 return Is_Non_Null
;
25375 -- "null" yields null
25377 elsif Nkind
(N
) = N_Null
then
25380 -- Check the status of the operand of a type conversion
25382 elsif Nkind
(N
) = N_Type_Conversion
then
25383 return Null_Status
(Expression
(N
));
25385 -- The input denotes a reference to an entity. Determine whether the
25386 -- entity or its type yields a null or non-null value.
25388 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
25389 return Null_Status_Of_Entity
(Entity
(N
));
25392 -- Otherwise it is not possible to determine the null status of the
25393 -- subexpression at compile time without resorting to simple flow
25399 --------------------------------------
25400 -- Null_To_Null_Address_Convert_OK --
25401 --------------------------------------
25403 function Null_To_Null_Address_Convert_OK
25405 Typ
: Entity_Id
:= Empty
) return Boolean
25408 if not Relaxed_RM_Semantics
then
25412 if Nkind
(N
) = N_Null
then
25413 return Present
(Typ
) and then Is_Descendant_Of_Address
(Typ
);
25415 elsif Nkind
(N
) in N_Op_Compare
then
25417 L
: constant Node_Id
:= Left_Opnd
(N
);
25418 R
: constant Node_Id
:= Right_Opnd
(N
);
25421 -- We check the Etype of the complementary operand since the
25422 -- N_Null node is not decorated at this stage.
25425 ((Nkind
(L
) = N_Null
25426 and then Is_Descendant_Of_Address
(Etype
(R
)))
25428 (Nkind
(R
) = N_Null
25429 and then Is_Descendant_Of_Address
(Etype
(L
))));
25434 end Null_To_Null_Address_Convert_OK
;
25436 ---------------------------------
25437 -- Number_Of_Elements_In_Array --
25438 ---------------------------------
25440 function Number_Of_Elements_In_Array
(T
: Entity_Id
) return Int
is
25448 pragma Assert
(Is_Array_Type
(T
));
25450 Indx
:= First_Index
(T
);
25451 while Present
(Indx
) loop
25452 Typ
:= Underlying_Type
(Etype
(Indx
));
25454 -- Never look at junk bounds of a generic type
25456 if Is_Generic_Type
(Typ
) then
25460 -- Check the array bounds are known at compile time and return zero
25461 -- if they are not.
25463 Low
:= Type_Low_Bound
(Typ
);
25464 High
:= Type_High_Bound
(Typ
);
25466 if not Compile_Time_Known_Value
(Low
) then
25468 elsif not Compile_Time_Known_Value
(High
) then
25472 Num
* UI_To_Int
((Expr_Value
(High
) - Expr_Value
(Low
) + 1));
25479 end Number_Of_Elements_In_Array
;
25481 ---------------------------------
25482 -- Original_Aspect_Pragma_Name --
25483 ---------------------------------
25485 function Original_Aspect_Pragma_Name
(N
: Node_Id
) return Name_Id
is
25487 Item_Nam
: Name_Id
;
25490 pragma Assert
(Nkind
(N
) in N_Aspect_Specification | N_Pragma
);
25494 -- The pragma was generated to emulate an aspect, use the original
25495 -- aspect specification.
25497 if Nkind
(Item
) = N_Pragma
and then From_Aspect_Specification
(Item
) then
25498 Item
:= Corresponding_Aspect
(Item
);
25501 -- Retrieve the name of the aspect/pragma. As assertion pragmas from
25502 -- a generic instantiation might have been rewritten into pragma Check,
25503 -- we look at the original node for Item. Note also that Pre, Pre_Class,
25504 -- Post and Post_Class rewrite their pragma identifier to preserve the
25505 -- original name, so we look at the original node for the identifier.
25506 -- ??? this is kludgey
25508 if Nkind
(Item
) = N_Pragma
then
25510 Chars
(Original_Node
(Pragma_Identifier
(Original_Node
(Item
))));
25512 if Item_Nam
= Name_Check
then
25513 -- Pragma "Check" preserves the original pragma name as its first
25516 Chars
(Expression
(First
(Pragma_Argument_Associations
25517 (Original_Node
(Item
)))));
25521 pragma Assert
(Nkind
(Item
) = N_Aspect_Specification
);
25522 Item_Nam
:= Chars
(Identifier
(Item
));
25525 -- Deal with 'Class by converting the name to its _XXX form
25527 if Class_Present
(Item
) then
25528 if Item_Nam
= Name_Invariant
then
25529 Item_Nam
:= Name_uInvariant
;
25531 elsif Item_Nam
= Name_Post
then
25532 Item_Nam
:= Name_uPost
;
25534 elsif Item_Nam
= Name_Pre
then
25535 Item_Nam
:= Name_uPre
;
25537 elsif Item_Nam
in Name_Type_Invariant | Name_Type_Invariant_Class
25539 Item_Nam
:= Name_uType_Invariant
;
25541 -- Nothing to do for other cases (e.g. a Check that derived from
25542 -- Pre_Class and has the flag set). Also we do nothing if the name
25543 -- is already in special _xxx form.
25549 end Original_Aspect_Pragma_Name
;
25551 --------------------------------------
25552 -- Original_Corresponding_Operation --
25553 --------------------------------------
25555 function Original_Corresponding_Operation
(S
: Entity_Id
) return Entity_Id
25557 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
25560 -- If S is an inherited primitive S2 the original corresponding
25561 -- operation of S is the original corresponding operation of S2
25563 if Present
(Alias
(S
))
25564 and then Find_Dispatching_Type
(Alias
(S
)) /= Typ
25566 return Original_Corresponding_Operation
(Alias
(S
));
25568 -- If S overrides an inherited subprogram S2 the original corresponding
25569 -- operation of S is the original corresponding operation of S2
25571 elsif Present
(Overridden_Operation
(S
)) then
25572 return Original_Corresponding_Operation
(Overridden_Operation
(S
));
25574 -- otherwise it is S itself
25579 end Original_Corresponding_Operation
;
25581 -----------------------------------
25582 -- Original_View_In_Visible_Part --
25583 -----------------------------------
25585 function Original_View_In_Visible_Part
25586 (Typ
: Entity_Id
) return Boolean
25588 Scop
: constant Entity_Id
:= Scope
(Typ
);
25591 -- The scope must be a package
25593 if not Is_Package_Or_Generic_Package
(Scop
) then
25597 -- A type with a private declaration has a private view declared in
25598 -- the visible part.
25600 if Has_Private_Declaration
(Typ
) then
25604 return List_Containing
(Parent
(Typ
)) =
25605 Visible_Declarations
(Package_Specification
(Scop
));
25606 end Original_View_In_Visible_Part
;
25608 -------------------
25609 -- Output_Entity --
25610 -------------------
25612 procedure Output_Entity
(Id
: Entity_Id
) is
25616 Scop
:= Scope
(Id
);
25618 -- The entity may lack a scope when it is in the process of being
25619 -- analyzed. Use the current scope as an approximation.
25622 Scop
:= Current_Scope
;
25625 Output_Name
(Chars
(Id
), Scop
);
25632 procedure Output_Name
(Nam
: Name_Id
; Scop
: Entity_Id
:= Current_Scope
) is
25636 (Get_Qualified_Name
25647 -- This would be trivial, simply a test for an identifier that was a
25648 -- reference to a formal, if it were not for the fact that a previous call
25649 -- to Expand_Entry_Parameter will have modified the reference to the
25650 -- identifier. A formal of a protected entity is rewritten as
25652 -- typ!(recobj).rec.all'Constrained
25654 -- where rec is a selector whose Entry_Formal link points to the formal
25656 -- If the type of the entry parameter has a representation clause, then an
25657 -- extra temp is involved (see below).
25659 -- For a formal of a task entity, the formal is rewritten as a local
25662 -- In addition, a formal that is marked volatile because it is aliased
25663 -- through an address clause is rewritten as dereference as well.
25665 function Param_Entity
(N
: Node_Id
) return Entity_Id
is
25666 Renamed_Obj
: Node_Id
;
25669 -- Simple reference case
25671 if Nkind
(N
) in N_Identifier | N_Expanded_Name
then
25672 if Is_Formal
(Entity
(N
)) then
25675 -- Handle renamings of formal parameters and formals of tasks that
25676 -- are rewritten as renamings.
25678 elsif Nkind
(Parent
(Entity
(N
))) = N_Object_Renaming_Declaration
then
25679 Renamed_Obj
:= Get_Referenced_Object
(Renamed_Object
(Entity
(N
)));
25681 if Is_Entity_Name
(Renamed_Obj
)
25682 and then Is_Formal
(Entity
(Renamed_Obj
))
25684 return Entity
(Renamed_Obj
);
25687 Nkind
(Parent
(Parent
(Entity
(N
)))) = N_Accept_Statement
25694 if Nkind
(N
) = N_Explicit_Dereference
then
25696 P
: Node_Id
:= Prefix
(N
);
25702 -- If the type of an entry parameter has a representation
25703 -- clause, then the prefix is not a selected component, but
25704 -- instead a reference to a temp pointing at the selected
25705 -- component. In this case, set P to be the initial value of
25708 if Nkind
(P
) = N_Identifier
then
25711 if Ekind
(E
) = E_Constant
then
25712 Decl
:= Parent
(E
);
25714 if Nkind
(Decl
) = N_Object_Declaration
then
25715 P
:= Expression
(Decl
);
25720 if Nkind
(P
) = N_Selected_Component
then
25721 S
:= Selector_Name
(P
);
25723 if Present
(Entry_Formal
(Entity
(S
))) then
25724 return Entry_Formal
(Entity
(S
));
25727 elsif Nkind
(Original_Node
(N
)) = N_Identifier
then
25728 return Param_Entity
(Original_Node
(N
));
25737 ----------------------
25738 -- Policy_In_Effect --
25739 ----------------------
25741 function Policy_In_Effect
(Policy
: Name_Id
) return Name_Id
is
25742 function Policy_In_List
(List
: Node_Id
) return Name_Id
;
25743 -- Determine the mode of a policy in a N_Pragma list
25745 --------------------
25746 -- Policy_In_List --
25747 --------------------
25749 function Policy_In_List
(List
: Node_Id
) return Name_Id
is
25756 while Present
(Prag
) loop
25757 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
25758 Arg2
:= Next
(Arg1
);
25760 Arg1
:= Get_Pragma_Arg
(Arg1
);
25761 Arg2
:= Get_Pragma_Arg
(Arg2
);
25763 -- The current Check_Policy pragma matches the requested policy or
25764 -- appears in the single argument form (Assertion, policy_id).
25766 if Chars
(Arg1
) in Name_Assertion | Policy
then
25767 return Chars
(Arg2
);
25770 Prag
:= Next_Pragma
(Prag
);
25774 end Policy_In_List
;
25780 -- Start of processing for Policy_In_Effect
25783 if not Is_Valid_Assertion_Kind
(Policy
) then
25784 raise Program_Error
;
25787 -- Inspect all policy pragmas that appear within scopes (if any)
25789 Kind
:= Policy_In_List
(Check_Policy_List
);
25791 -- Inspect all configuration policy pragmas (if any)
25793 if Kind
= No_Name
then
25794 Kind
:= Policy_In_List
(Check_Policy_List_Config
);
25797 -- The context lacks policy pragmas, determine the mode based on whether
25798 -- assertions are enabled at the configuration level. This ensures that
25799 -- the policy is preserved when analyzing generics.
25801 if Kind
= No_Name
then
25802 if Assertions_Enabled_Config
then
25803 Kind
:= Name_Check
;
25805 Kind
:= Name_Ignore
;
25809 -- In CodePeer mode and GNATprove mode, we need to consider all
25810 -- assertions, unless they are disabled. Force Name_Check on
25811 -- ignored assertions.
25813 if Kind
in Name_Ignore | Name_Off
25814 and then (CodePeer_Mode
or GNATprove_Mode
)
25816 Kind
:= Name_Check
;
25820 end Policy_In_Effect
;
25822 -------------------------------
25823 -- Preanalyze_Without_Errors --
25824 -------------------------------
25826 procedure Preanalyze_Without_Errors
(N
: Node_Id
) is
25827 Status
: constant Boolean := Get_Ignore_Errors
;
25829 Set_Ignore_Errors
(True);
25831 Set_Ignore_Errors
(Status
);
25832 end Preanalyze_Without_Errors
;
25834 -----------------------
25835 -- Predicate_Enabled --
25836 -----------------------
25838 function Predicate_Enabled
(Typ
: Entity_Id
) return Boolean is
25840 return Present
(Predicate_Function
(Typ
))
25841 and then not Predicates_Ignored
(Typ
)
25842 and then not Predicate_Checks_Suppressed
(Empty
);
25843 end Predicate_Enabled
;
25845 ----------------------------------
25846 -- Predicate_Failure_Expression --
25847 ----------------------------------
25849 function Predicate_Failure_Expression
25850 (Typ
: Entity_Id
; Inherited_OK
: Boolean) return Node_Id
25852 PF_Aspect
: constant Node_Id
:=
25853 Find_Aspect
(Typ
, Aspect_Predicate_Failure
);
25855 -- Check for Predicate_Failure aspect specification via an
25856 -- aspect_specification (as opposed to via a pragma).
25858 if Present
(PF_Aspect
) then
25859 if Inherited_OK
or else Entity
(PF_Aspect
) = Typ
then
25860 return Expression
(PF_Aspect
);
25866 -- Check for Predicate_Failure aspect specification via a pragma.
25869 Rep_Item
: Node_Id
:= First_Rep_Item
(Typ
);
25871 while Present
(Rep_Item
) loop
25872 if Nkind
(Rep_Item
) = N_Pragma
25873 and then Get_Pragma_Id
(Rep_Item
) = Pragma_Predicate_Failure
25876 Arg1
: constant Node_Id
:=
25878 (First
(Pragma_Argument_Associations
(Rep_Item
)));
25879 Arg2
: constant Node_Id
:=
25881 (Next
(First
(Pragma_Argument_Associations
(Rep_Item
))));
25883 if Inherited_OK
or else
25884 (Nkind
(Arg1
) in N_Has_Entity
25885 and then Entity
(Arg1
) = Typ
)
25892 Next_Rep_Item
(Rep_Item
);
25896 -- If we are interested in an inherited Predicate_Failure aspect
25897 -- and we have an ancestor to inherit from, then recursively check
25900 if Inherited_OK
and then Present
(Nearest_Ancestor
(Typ
)) then
25901 return Predicate_Failure_Expression
(Nearest_Ancestor
(Typ
),
25902 Inherited_OK
=> True);
25906 end Predicate_Failure_Expression
;
25908 ----------------------------------
25909 -- Predicate_Tests_On_Arguments --
25910 ----------------------------------
25912 function Predicate_Tests_On_Arguments
(Subp
: Entity_Id
) return Boolean is
25914 -- Always test predicates on indirect call
25916 if Ekind
(Subp
) = E_Subprogram_Type
then
25919 -- Do not test predicates on call to generated default Finalize, since
25920 -- we are not interested in whether something we are finalizing (and
25921 -- typically destroying) satisfies its predicates.
25923 elsif Chars
(Subp
) = Name_Finalize
25924 and then not Comes_From_Source
(Subp
)
25928 -- Do not test predicates on any internally generated routines
25930 elsif Is_Internal_Name
(Chars
(Subp
)) then
25933 -- Do not test predicates on call to Init_Proc, since if needed the
25934 -- predicate test will occur at some other point.
25936 elsif Is_Init_Proc
(Subp
) then
25939 -- Do not test predicates on call to predicate function, since this
25940 -- would cause infinite recursion.
25942 elsif Ekind
(Subp
) = E_Function
25943 and then Is_Predicate_Function
(Subp
)
25947 -- For now, no other exceptions
25952 end Predicate_Tests_On_Arguments
;
25954 -----------------------
25955 -- Private_Component --
25956 -----------------------
25958 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
25959 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
25961 function Trace_Components
25963 Check
: Boolean) return Entity_Id
;
25964 -- Recursive function that does the work, and checks against circular
25965 -- definition for each subcomponent type.
25967 ----------------------
25968 -- Trace_Components --
25969 ----------------------
25971 function Trace_Components
25973 Check
: Boolean) return Entity_Id
25975 Btype
: constant Entity_Id
:= Base_Type
(T
);
25976 Component
: Entity_Id
;
25978 Candidate
: Entity_Id
:= Empty
;
25981 if Check
and then Btype
= Ancestor
then
25982 Error_Msg_N
("circular type definition", Type_Id
);
25986 if Is_Private_Type
(Btype
) and then not Is_Generic_Type
(Btype
) then
25987 if Present
(Full_View
(Btype
))
25988 and then Is_Record_Type
(Full_View
(Btype
))
25989 and then not Is_Frozen
(Btype
)
25991 -- To indicate that the ancestor depends on a private type, the
25992 -- current Btype is sufficient. However, to check for circular
25993 -- definition we must recurse on the full view.
25995 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
25997 if Candidate
= Any_Type
then
26007 elsif Is_Array_Type
(Btype
) then
26008 return Trace_Components
(Component_Type
(Btype
), True);
26010 elsif Is_Record_Type
(Btype
) then
26011 Component
:= First_Entity
(Btype
);
26012 while Present
(Component
)
26013 and then Comes_From_Source
(Component
)
26015 -- Skip anonymous types generated by constrained components
26017 if not Is_Type
(Component
) then
26018 P
:= Trace_Components
(Etype
(Component
), True);
26020 if Present
(P
) then
26021 if P
= Any_Type
then
26029 Next_Entity
(Component
);
26037 end Trace_Components
;
26039 -- Start of processing for Private_Component
26042 return Trace_Components
(Type_Id
, False);
26043 end Private_Component
;
26045 ---------------------------
26046 -- Primitive_Names_Match --
26047 ---------------------------
26049 function Primitive_Names_Match
(E1
, E2
: Entity_Id
) return Boolean is
26050 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
;
26051 -- Given an internal name, returns the corresponding non-internal name
26053 ------------------------
26054 -- Non_Internal_Name --
26055 ------------------------
26057 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
is
26059 Get_Name_String
(Chars
(E
));
26060 Name_Len
:= Name_Len
- 1;
26062 end Non_Internal_Name
;
26064 -- Start of processing for Primitive_Names_Match
26067 pragma Assert
(Present
(E1
) and then Present
(E2
));
26069 return Chars
(E1
) = Chars
(E2
)
26071 (not Is_Internal_Name
(Chars
(E1
))
26072 and then Is_Internal_Name
(Chars
(E2
))
26073 and then Non_Internal_Name
(E2
) = Chars
(E1
))
26075 (not Is_Internal_Name
(Chars
(E2
))
26076 and then Is_Internal_Name
(Chars
(E1
))
26077 and then Non_Internal_Name
(E1
) = Chars
(E2
))
26079 (Is_Predefined_Dispatching_Operation
(E1
)
26080 and then Is_Predefined_Dispatching_Operation
(E2
)
26081 and then Same_TSS
(E1
, E2
))
26083 (Is_Init_Proc
(E1
) and then Is_Init_Proc
(E2
));
26084 end Primitive_Names_Match
;
26086 -----------------------
26087 -- Process_End_Label --
26088 -----------------------
26090 procedure Process_End_Label
26099 Label_Ref
: Boolean;
26100 -- Set True if reference to end label itself is required
26103 -- Gets set to the operator symbol or identifier that references the
26104 -- entity Ent. For the child unit case, this is the identifier from the
26105 -- designator. For other cases, this is simply Endl.
26107 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
);
26108 -- N is an identifier node that appears as a parent unit reference in
26109 -- the case where Ent is a child unit. This procedure generates an
26110 -- appropriate cross-reference entry. E is the corresponding entity.
26112 -------------------------
26113 -- Generate_Parent_Ref --
26114 -------------------------
26116 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
) is
26118 -- If names do not match, something weird, skip reference
26120 if Chars
(E
) = Chars
(N
) then
26122 -- Generate the reference. We do NOT consider this as a reference
26123 -- for unreferenced symbol purposes.
26125 Generate_Reference
(E
, N
, 'r', Set_Ref
=> False, Force
=> True);
26127 if Style_Check
then
26128 Style
.Check_Identifier
(N
, E
);
26131 end Generate_Parent_Ref
;
26133 -- Start of processing for Process_End_Label
26136 -- If no node, ignore. This happens in some error situations, and
26137 -- also for some internally generated structures where no end label
26138 -- references are required in any case.
26144 -- Nothing to do if no End_Label, happens for internally generated
26145 -- constructs where we don't want an end label reference anyway. Also
26146 -- nothing to do if Endl is a string literal, which means there was
26147 -- some prior error (bad operator symbol)
26149 Endl
:= End_Label
(N
);
26151 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
26155 -- Reference node is not in extended main source unit
26157 if not In_Extended_Main_Source_Unit
(N
) then
26159 -- Generally we do not collect references except for the extended
26160 -- main source unit. The one exception is the 'e' entry for a
26161 -- package spec, where it is useful for a client to have the
26162 -- ending information to define scopes.
26168 Label_Ref
:= False;
26170 -- For this case, we can ignore any parent references, but we
26171 -- need the package name itself for the 'e' entry.
26173 if Nkind
(Endl
) = N_Designator
then
26174 Endl
:= Identifier
(Endl
);
26178 -- Reference is in extended main source unit
26183 -- For designator, generate references for the parent entries
26185 if Nkind
(Endl
) = N_Designator
then
26187 -- Generate references for the prefix if the END line comes from
26188 -- source (otherwise we do not need these references) We climb the
26189 -- scope stack to find the expected entities.
26191 if Comes_From_Source
(Endl
) then
26192 Nam
:= Name
(Endl
);
26193 Scop
:= Current_Scope
;
26194 while Nkind
(Nam
) = N_Selected_Component
loop
26195 Scop
:= Scope
(Scop
);
26196 exit when No
(Scop
);
26197 Generate_Parent_Ref
(Selector_Name
(Nam
), Scop
);
26198 Nam
:= Prefix
(Nam
);
26201 if Present
(Scop
) then
26202 Generate_Parent_Ref
(Nam
, Scope
(Scop
));
26206 Endl
:= Identifier
(Endl
);
26210 -- If the end label is not for the given entity, then either we have
26211 -- some previous error, or this is a generic instantiation for which
26212 -- we do not need to make a cross-reference in this case anyway. In
26213 -- either case we simply ignore the call.
26215 if Chars
(Ent
) /= Chars
(Endl
) then
26219 -- If label was really there, then generate a normal reference and then
26220 -- adjust the location in the end label to point past the name (which
26221 -- should almost always be the semicolon).
26223 Loc
:= Sloc
(Endl
);
26225 if Comes_From_Source
(Endl
) then
26227 -- If a label reference is required, then do the style check and
26228 -- generate an l-type cross-reference entry for the label
26231 if Style_Check
then
26232 Style
.Check_Identifier
(Endl
, Ent
);
26235 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
26238 -- Set the location to point past the label (normally this will
26239 -- mean the semicolon immediately following the label). This is
26240 -- done for the sake of the 'e' or 't' entry generated below.
26242 Get_Decoded_Name_String
(Chars
(Endl
));
26243 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
26246 -- Now generate the e/t reference
26248 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
26250 -- Restore Sloc, in case modified above, since we have an identifier
26251 -- and the normal Sloc should be left set in the tree.
26253 Set_Sloc
(Endl
, Loc
);
26254 end Process_End_Label
;
26256 --------------------------------
26257 -- Propagate_Concurrent_Flags --
26258 --------------------------------
26260 procedure Propagate_Concurrent_Flags
26262 Comp_Typ
: Entity_Id
)
26265 if Has_Task
(Comp_Typ
) then
26266 Set_Has_Task
(Typ
);
26269 if Has_Protected
(Comp_Typ
) then
26270 Set_Has_Protected
(Typ
);
26273 if Has_Timing_Event
(Comp_Typ
) then
26274 Set_Has_Timing_Event
(Typ
);
26276 end Propagate_Concurrent_Flags
;
26278 ------------------------------
26279 -- Propagate_DIC_Attributes --
26280 ------------------------------
26282 procedure Propagate_DIC_Attributes
26284 From_Typ
: Entity_Id
)
26286 DIC_Proc
: Entity_Id
;
26287 Partial_DIC_Proc
: Entity_Id
;
26290 if Present
(Typ
) and then Present
(From_Typ
) then
26291 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26293 -- Nothing to do if both the source and the destination denote the
26296 if From_Typ
= Typ
then
26299 -- Nothing to do when the destination denotes an incomplete type
26300 -- because the DIC is associated with the current instance of a
26301 -- private type, thus it can never apply to an incomplete type.
26303 elsif Is_Incomplete_Type
(Typ
) then
26307 DIC_Proc
:= DIC_Procedure
(From_Typ
);
26308 Partial_DIC_Proc
:= Partial_DIC_Procedure
(From_Typ
);
26310 -- The setting of the attributes is intentionally conservative. This
26311 -- prevents accidental clobbering of enabled attributes. We need to
26312 -- call Base_Type twice, because it is sometimes not set to an actual
26315 if Has_Inherited_DIC
(From_Typ
) then
26316 Set_Has_Inherited_DIC
(Base_Type
(Base_Type
(Typ
)));
26319 if Has_Own_DIC
(From_Typ
) then
26320 Set_Has_Own_DIC
(Base_Type
(Base_Type
(Typ
)));
26323 if Present
(DIC_Proc
) and then No
(DIC_Procedure
(Typ
)) then
26324 Set_DIC_Procedure
(Typ
, DIC_Proc
);
26327 if Present
(Partial_DIC_Proc
)
26328 and then No
(Partial_DIC_Procedure
(Typ
))
26330 Set_Partial_DIC_Procedure
(Typ
, Partial_DIC_Proc
);
26333 end Propagate_DIC_Attributes
;
26335 ------------------------------------
26336 -- Propagate_Invariant_Attributes --
26337 ------------------------------------
26339 procedure Propagate_Invariant_Attributes
26341 From_Typ
: Entity_Id
)
26343 Full_IP
: Entity_Id
;
26344 Part_IP
: Entity_Id
;
26347 if Present
(Typ
) and then Present
(From_Typ
) then
26348 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26350 -- Nothing to do if both the source and the destination denote the
26353 if From_Typ
= Typ
then
26357 Full_IP
:= Invariant_Procedure
(From_Typ
);
26358 Part_IP
:= Partial_Invariant_Procedure
(From_Typ
);
26360 -- The setting of the attributes is intentionally conservative. This
26361 -- prevents accidental clobbering of enabled attributes. We need to
26362 -- call Base_Type twice, because it is sometimes not set to an actual
26365 if Has_Inheritable_Invariants
(From_Typ
) then
26366 Set_Has_Inheritable_Invariants
(Base_Type
(Base_Type
(Typ
)));
26369 if Has_Inherited_Invariants
(From_Typ
) then
26370 Set_Has_Inherited_Invariants
(Base_Type
(Base_Type
(Typ
)));
26373 if Has_Own_Invariants
(From_Typ
) then
26374 Set_Has_Own_Invariants
(Base_Type
(Base_Type
(Typ
)));
26377 if Present
(Full_IP
) and then No
(Invariant_Procedure
(Typ
)) then
26378 Set_Invariant_Procedure
(Typ
, Full_IP
);
26381 if Present
(Part_IP
) and then No
(Partial_Invariant_Procedure
(Typ
))
26383 Set_Partial_Invariant_Procedure
(Typ
, Part_IP
);
26386 end Propagate_Invariant_Attributes
;
26388 ------------------------------------
26389 -- Propagate_Predicate_Attributes --
26390 ------------------------------------
26392 procedure Propagate_Predicate_Attributes
26394 From_Typ
: Entity_Id
)
26396 Pred_Func
: Entity_Id
;
26398 if Present
(Typ
) and then Present
(From_Typ
) then
26399 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26401 -- Nothing to do if both the source and the destination denote the
26404 if From_Typ
= Typ
then
26408 Pred_Func
:= Predicate_Function
(From_Typ
);
26410 -- The setting of the attributes is intentionally conservative. This
26411 -- prevents accidental clobbering of enabled attributes.
26413 if Has_Predicates
(From_Typ
) then
26414 Set_Has_Predicates
(Typ
);
26417 if Present
(Pred_Func
) and then No
(Predicate_Function
(Typ
)) then
26418 Set_Predicate_Function
(Typ
, Pred_Func
);
26421 end Propagate_Predicate_Attributes
;
26423 ---------------------------------------
26424 -- Record_Possible_Part_Of_Reference --
26425 ---------------------------------------
26427 procedure Record_Possible_Part_Of_Reference
26428 (Var_Id
: Entity_Id
;
26431 Encap
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
26435 -- The variable is a constituent of a single protected/task type. Such
26436 -- a variable acts as a component of the type and must appear within a
26437 -- specific region (SPARK RM 9(3)). Instead of recording the reference,
26438 -- verify its legality now.
26440 if Present
(Encap
) and then Is_Single_Concurrent_Object
(Encap
) then
26441 Check_Part_Of_Reference
(Var_Id
, Ref
);
26443 -- The variable is subject to pragma Part_Of and may eventually become a
26444 -- constituent of a single protected/task type. Record the reference to
26445 -- verify its placement when the contract of the variable is analyzed.
26447 elsif Present
(Get_Pragma
(Var_Id
, Pragma_Part_Of
)) then
26448 Refs
:= Part_Of_References
(Var_Id
);
26451 Refs
:= New_Elmt_List
;
26452 Set_Part_Of_References
(Var_Id
, Refs
);
26455 Append_Elmt
(Ref
, Refs
);
26457 end Record_Possible_Part_Of_Reference
;
26463 function Referenced
(Id
: Entity_Id
; Expr
: Node_Id
) return Boolean is
26464 Seen
: Boolean := False;
26466 function Is_Reference
(N
: Node_Id
) return Traverse_Result
;
26467 -- Determine whether node N denotes a reference to Id. If this is the
26468 -- case, set global flag Seen to True and stop the traversal.
26474 function Is_Reference
(N
: Node_Id
) return Traverse_Result
is
26476 if Is_Entity_Name
(N
)
26477 and then Present
(Entity
(N
))
26478 and then Entity
(N
) = Id
26487 procedure Inspect_Expression
is new Traverse_Proc
(Is_Reference
);
26489 -- Start of processing for Referenced
26492 Inspect_Expression
(Expr
);
26496 ------------------------------------
26497 -- References_Generic_Formal_Type --
26498 ------------------------------------
26500 function References_Generic_Formal_Type
(N
: Node_Id
) return Boolean is
26502 function Process
(N
: Node_Id
) return Traverse_Result
;
26503 -- Process one node in search for generic formal type
26509 function Process
(N
: Node_Id
) return Traverse_Result
is
26511 if Nkind
(N
) in N_Has_Entity
then
26513 E
: constant Entity_Id
:= Entity
(N
);
26515 if Present
(E
) then
26516 if Is_Generic_Type
(E
) then
26518 elsif Present
(Etype
(E
))
26519 and then Is_Generic_Type
(Etype
(E
))
26530 function Traverse
is new Traverse_Func
(Process
);
26531 -- Traverse tree to look for generic type
26534 if Inside_A_Generic
then
26535 return Traverse
(N
) = Abandon
;
26539 end References_Generic_Formal_Type
;
26541 -------------------------------
26542 -- Remove_Entity_And_Homonym --
26543 -------------------------------
26545 procedure Remove_Entity_And_Homonym
(Id
: Entity_Id
) is
26547 Remove_Entity
(Id
);
26548 Remove_Homonym
(Id
);
26549 end Remove_Entity_And_Homonym
;
26551 --------------------
26552 -- Remove_Homonym --
26553 --------------------
26555 procedure Remove_Homonym
(Id
: Entity_Id
) is
26557 Prev
: Entity_Id
:= Empty
;
26560 if Id
= Current_Entity
(Id
) then
26561 if Present
(Homonym
(Id
)) then
26562 Set_Current_Entity
(Homonym
(Id
));
26564 Set_Name_Entity_Id
(Chars
(Id
), Empty
);
26568 Hom
:= Current_Entity
(Id
);
26569 while Present
(Hom
) and then Hom
/= Id
loop
26571 Hom
:= Homonym
(Hom
);
26574 -- If Id is not on the homonym chain, nothing to do
26576 if Present
(Hom
) then
26577 Set_Homonym
(Prev
, Homonym
(Id
));
26580 end Remove_Homonym
;
26582 ------------------------------
26583 -- Remove_Overloaded_Entity --
26584 ------------------------------
26586 procedure Remove_Overloaded_Entity
(Id
: Entity_Id
) is
26587 procedure Remove_Primitive_Of
(Typ
: Entity_Id
);
26588 -- Remove primitive subprogram Id from the list of primitives that
26589 -- belong to type Typ.
26591 -------------------------
26592 -- Remove_Primitive_Of --
26593 -------------------------
26595 procedure Remove_Primitive_Of
(Typ
: Entity_Id
) is
26599 if Is_Tagged_Type
(Typ
) then
26600 Prims
:= Direct_Primitive_Operations
(Typ
);
26602 if Present
(Prims
) then
26603 Remove
(Prims
, Id
);
26606 end Remove_Primitive_Of
;
26610 Formal
: Entity_Id
;
26612 -- Start of processing for Remove_Overloaded_Entity
26615 Remove_Entity_And_Homonym
(Id
);
26617 -- The entity denotes a primitive subprogram. Remove it from the list of
26618 -- primitives of the associated controlling type.
26620 if Ekind
(Id
) in E_Function | E_Procedure
and then Is_Primitive
(Id
) then
26621 Formal
:= First_Formal
(Id
);
26622 while Present
(Formal
) loop
26623 if Is_Controlling_Formal
(Formal
) then
26624 Remove_Primitive_Of
(Etype
(Formal
));
26628 Next_Formal
(Formal
);
26631 if Ekind
(Id
) = E_Function
and then Has_Controlling_Result
(Id
) then
26632 Remove_Primitive_Of
(Etype
(Id
));
26635 end Remove_Overloaded_Entity
;
26637 ---------------------
26638 -- Rep_To_Pos_Flag --
26639 ---------------------
26641 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
26643 return New_Occurrence_Of
26644 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
26645 end Rep_To_Pos_Flag
;
26647 --------------------
26648 -- Require_Entity --
26649 --------------------
26651 procedure Require_Entity
(N
: Node_Id
) is
26653 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
26654 if Total_Errors_Detected
/= 0 then
26655 Set_Entity
(N
, Any_Id
);
26657 raise Program_Error
;
26660 end Require_Entity
;
26662 ------------------------------
26663 -- Requires_Transient_Scope --
26664 ------------------------------
26666 function Requires_Transient_Scope
(Typ
: Entity_Id
) return Boolean is
26668 return Needs_Secondary_Stack
(Typ
) or else Needs_Finalization
(Typ
);
26669 end Requires_Transient_Scope
;
26671 --------------------------
26672 -- Reset_Analyzed_Flags --
26673 --------------------------
26675 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
26676 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
;
26677 -- Function used to reset Analyzed flags in tree. Note that we do
26678 -- not reset Analyzed flags in entities, since there is no need to
26679 -- reanalyze entities, and indeed, it is wrong to do so, since it
26680 -- can result in generating auxiliary stuff more than once.
26682 --------------------
26683 -- Clear_Analyzed --
26684 --------------------
26686 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
is
26688 if Nkind
(N
) not in N_Entity
then
26689 Set_Analyzed
(N
, False);
26693 end Clear_Analyzed
;
26695 procedure Reset_Analyzed
is new Traverse_Proc
(Clear_Analyzed
);
26697 -- Start of processing for Reset_Analyzed_Flags
26700 Reset_Analyzed
(N
);
26701 end Reset_Analyzed_Flags
;
26703 ------------------------
26704 -- Restore_SPARK_Mode --
26705 ------------------------
26707 procedure Restore_SPARK_Mode
26708 (Mode
: SPARK_Mode_Type
;
26712 SPARK_Mode
:= Mode
;
26713 SPARK_Mode_Pragma
:= Prag
;
26714 end Restore_SPARK_Mode
;
26716 --------------------------------
26717 -- Returns_Unconstrained_Type --
26718 --------------------------------
26720 function Returns_Unconstrained_Type
(Subp
: Entity_Id
) return Boolean is
26722 return Ekind
(Subp
) = E_Function
26723 and then not Is_Scalar_Type
(Etype
(Subp
))
26724 and then not Is_Access_Type
(Etype
(Subp
))
26725 and then not Is_Constrained
(Etype
(Subp
));
26726 end Returns_Unconstrained_Type
;
26728 ----------------------------
26729 -- Root_Type_Of_Full_View --
26730 ----------------------------
26732 function Root_Type_Of_Full_View
(T
: Entity_Id
) return Entity_Id
is
26733 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
26736 -- The root type of the full view may itself be a private type. Keep
26737 -- looking for the ultimate derivation parent.
26739 if Is_Private_Type
(Rtyp
) and then Present
(Full_View
(Rtyp
)) then
26740 return Root_Type_Of_Full_View
(Full_View
(Rtyp
));
26744 end Root_Type_Of_Full_View
;
26746 ---------------------------
26747 -- Safe_To_Capture_Value --
26748 ---------------------------
26750 function Safe_To_Capture_Value
26753 Cond
: Boolean := False) return Boolean
26756 -- The only entities for which we track constant values are variables
26757 -- that are not renamings, constants and formal parameters, so check
26758 -- if we have this case.
26760 -- Note: it may seem odd to track constant values for constants, but in
26761 -- fact this routine is used for other purposes than simply capturing
26762 -- the value. In particular, the setting of Known[_Non]_Null and
26765 if (Ekind
(Ent
) = E_Variable
and then No
(Renamed_Object
(Ent
)))
26767 Ekind
(Ent
) = E_Constant
26773 -- For conditionals, we also allow loop parameters
26775 elsif Cond
and then Ekind
(Ent
) = E_Loop_Parameter
then
26778 -- For all other cases, not just unsafe, but impossible to capture
26779 -- Current_Value, since the above are the only entities which have
26780 -- Current_Value fields.
26786 -- Skip if volatile or aliased, since funny things might be going on in
26787 -- these cases which we cannot necessarily track. Also skip any variable
26788 -- for which an address clause is given, or whose address is taken. Also
26789 -- never capture value of library level variables (an attempt to do so
26790 -- can occur in the case of package elaboration code).
26792 if Treat_As_Volatile
(Ent
)
26793 or else Is_Aliased
(Ent
)
26794 or else Present
(Address_Clause
(Ent
))
26795 or else Address_Taken
(Ent
)
26796 or else (Is_Library_Level_Entity
(Ent
)
26797 and then Ekind
(Ent
) = E_Variable
)
26802 -- OK, all above conditions are met. We also require that the scope of
26803 -- the reference be the same as the scope of the entity, not counting
26804 -- packages and blocks and loops.
26807 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
26808 R_Scope
: Entity_Id
;
26811 R_Scope
:= Current_Scope
;
26812 while R_Scope
/= Standard_Standard
loop
26813 exit when R_Scope
= E_Scope
;
26815 if Ekind
(R_Scope
) not in E_Package | E_Block | E_Loop
then
26818 R_Scope
:= Scope
(R_Scope
);
26823 -- We also require that the reference does not appear in a context
26824 -- where it is not sure to be executed (i.e. a conditional context
26825 -- or an exception handler). We skip this if Cond is True, since the
26826 -- capturing of values from conditional tests handles this ok.
26828 if Cond
or else No
(N
) then
26839 -- Seems dubious that case expressions are not handled here ???
26842 while Present
(P
) loop
26843 if Is_Body
(P
) then
26846 elsif Nkind
(P
) = N_If_Statement
26847 or else Nkind
(P
) = N_Case_Statement
26848 or else (Nkind
(P
) in N_Short_Circuit
26849 and then Desc
= Right_Opnd
(P
))
26850 or else (Nkind
(P
) = N_If_Expression
26851 and then Desc
/= First
(Expressions
(P
)))
26852 or else Nkind
(P
) = N_Exception_Handler
26853 or else Nkind
(P
) = N_Selective_Accept
26854 or else Nkind
(P
) = N_Conditional_Entry_Call
26855 or else Nkind
(P
) = N_Timed_Entry_Call
26856 or else Nkind
(P
) = N_Asynchronous_Select
26864 -- A special Ada 2012 case: the original node may be part
26865 -- of the else_actions of a conditional expression, in which
26866 -- case it might not have been expanded yet, and appears in
26867 -- a non-syntactic list of actions. In that case it is clearly
26868 -- not safe to save a value.
26871 and then Is_List_Member
(Desc
)
26872 and then No
(Parent
(List_Containing
(Desc
)))
26880 -- OK, looks safe to set value
26883 end Safe_To_Capture_Value
;
26889 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
26890 K1
: constant Node_Kind
:= Nkind
(N1
);
26891 K2
: constant Node_Kind
:= Nkind
(N2
);
26894 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
26895 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
26897 return Chars
(N1
) = Chars
(N2
);
26899 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
26900 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
26902 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
26903 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
26914 function Same_Object
(Node1
, Node2
: Node_Id
) return Boolean is
26915 N1
: constant Node_Id
:= Original_Node
(Node1
);
26916 N2
: constant Node_Id
:= Original_Node
(Node2
);
26917 -- We do the tests on original nodes, since we are most interested
26918 -- in the original source, not any expansion that got in the way.
26920 K1
: constant Node_Kind
:= Nkind
(N1
);
26921 K2
: constant Node_Kind
:= Nkind
(N2
);
26924 -- First case, both are entities with same entity
26926 if K1
in N_Has_Entity
and then K2
in N_Has_Entity
then
26928 EN1
: constant Entity_Id
:= Entity
(N1
);
26929 EN2
: constant Entity_Id
:= Entity
(N2
);
26931 if Present
(EN1
) and then Present
(EN2
)
26932 and then (Ekind
(EN1
) in E_Variable | E_Constant
26933 or else Is_Formal
(EN1
))
26941 -- Second case, selected component with same selector, same record
26943 if K1
= N_Selected_Component
26944 and then K2
= N_Selected_Component
26945 and then Chars
(Selector_Name
(N1
)) = Chars
(Selector_Name
(N2
))
26947 return Same_Object
(Prefix
(N1
), Prefix
(N2
));
26949 -- Third case, indexed component with same subscripts, same array
26951 elsif K1
= N_Indexed_Component
26952 and then K2
= N_Indexed_Component
26953 and then Same_Object
(Prefix
(N1
), Prefix
(N2
))
26958 E1
:= First
(Expressions
(N1
));
26959 E2
:= First
(Expressions
(N2
));
26960 while Present
(E1
) loop
26961 if not Same_Value
(E1
, E2
) then
26972 -- Fourth case, slice of same array with same bounds
26975 and then K2
= N_Slice
26976 and then Nkind
(Discrete_Range
(N1
)) = N_Range
26977 and then Nkind
(Discrete_Range
(N2
)) = N_Range
26978 and then Same_Value
(Low_Bound
(Discrete_Range
(N1
)),
26979 Low_Bound
(Discrete_Range
(N2
)))
26980 and then Same_Value
(High_Bound
(Discrete_Range
(N1
)),
26981 High_Bound
(Discrete_Range
(N2
)))
26983 return Same_Name
(Prefix
(N1
), Prefix
(N2
));
26985 -- All other cases, not clearly the same object
26992 ---------------------------------
26993 -- Same_Or_Aliased_Subprograms --
26994 ---------------------------------
26996 function Same_Or_Aliased_Subprograms
26998 E
: Entity_Id
) return Boolean
27000 Subp_Alias
: constant Entity_Id
:= Alias
(S
);
27001 Subp
: Entity_Id
:= E
;
27003 -- During expansion of subprograms with postconditions the original
27004 -- subprogram's declarations and statements get wrapped into a local
27005 -- _Wrapped_Statements subprogram.
27007 if Chars
(Subp
) = Name_uWrapped_Statements
then
27008 Subp
:= Enclosing_Subprogram
(Subp
);
27012 or else (Present
(Subp_Alias
) and then Subp_Alias
= Subp
);
27013 end Same_Or_Aliased_Subprograms
;
27019 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
27024 elsif not Is_Constrained
(T1
)
27025 and then not Is_Constrained
(T2
)
27026 and then Base_Type
(T1
) = Base_Type
(T2
)
27030 -- For now don't bother with case of identical constraints, to be
27031 -- fiddled with later on perhaps (this is only used for optimization
27032 -- purposes, so it is not critical to do a best possible job)
27043 function Same_Value
(Node1
, Node2
: Node_Id
) return Boolean is
27045 if Compile_Time_Known_Value
(Node1
)
27046 and then Compile_Time_Known_Value
(Node2
)
27048 -- Handle properly compile-time expressions that are not
27051 if Is_String_Type
(Etype
(Node1
)) then
27052 return Expr_Value_S
(Node1
) = Expr_Value_S
(Node2
);
27055 return Expr_Value
(Node1
) = Expr_Value
(Node2
);
27058 elsif Same_Object
(Node1
, Node2
) then
27065 --------------------
27066 -- Set_SPARK_Mode --
27067 --------------------
27069 procedure Set_SPARK_Mode
(Context
: Entity_Id
) is
27071 -- Do not consider illegal or partially decorated constructs
27073 if Ekind
(Context
) = E_Void
or else Error_Posted
(Context
) then
27076 elsif Present
(SPARK_Pragma
(Context
)) then
27078 (Mode
=> Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Context
)),
27079 Prag
=> SPARK_Pragma
(Context
));
27081 end Set_SPARK_Mode
;
27083 -------------------------
27084 -- Scalar_Part_Present --
27085 -------------------------
27087 function Scalar_Part_Present
(Typ
: Entity_Id
) return Boolean is
27088 Val_Typ
: constant Entity_Id
:= Validated_View
(Typ
);
27092 if Is_Scalar_Type
(Val_Typ
) then
27095 elsif Is_Array_Type
(Val_Typ
) then
27096 return Scalar_Part_Present
(Component_Type
(Val_Typ
));
27098 elsif Is_Record_Type
(Val_Typ
) then
27099 Field
:= First_Component_Or_Discriminant
(Val_Typ
);
27100 while Present
(Field
) loop
27101 if Scalar_Part_Present
(Etype
(Field
)) then
27105 Next_Component_Or_Discriminant
(Field
);
27110 end Scalar_Part_Present
;
27112 ------------------------
27113 -- Scope_Is_Transient --
27114 ------------------------
27116 function Scope_Is_Transient
return Boolean is
27118 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
27119 end Scope_Is_Transient
;
27125 function Scope_Within
27126 (Inner
: Entity_Id
;
27127 Outer
: Entity_Id
) return Boolean
27133 while Present
(Curr
) and then Curr
/= Standard_Standard
loop
27134 Curr
:= Scope
(Curr
);
27136 if Curr
= Outer
then
27139 -- A selective accept body appears within a task type, but the
27140 -- enclosing subprogram is the procedure of the task body.
27142 elsif Ekind
(Implementation_Base_Type
(Curr
)) = E_Task_Type
27144 Outer
= Task_Body_Procedure
(Implementation_Base_Type
(Curr
))
27148 -- Ditto for the body of a protected operation
27150 elsif Is_Subprogram
(Curr
)
27151 and then Outer
= Protected_Body_Subprogram
(Curr
)
27155 -- Outside of its scope, a synchronized type may just be private
27157 elsif Is_Private_Type
(Curr
)
27158 and then Present
(Full_View
(Curr
))
27159 and then Is_Concurrent_Type
(Full_View
(Curr
))
27161 return Scope_Within
(Full_View
(Curr
), Outer
);
27168 --------------------------
27169 -- Scope_Within_Or_Same --
27170 --------------------------
27172 function Scope_Within_Or_Same
27173 (Inner
: Entity_Id
;
27174 Outer
: Entity_Id
) return Boolean
27176 Curr
: Entity_Id
:= Inner
;
27179 -- Similar to the above, but check for scope identity first
27181 while Present
(Curr
) and then Curr
/= Standard_Standard
loop
27182 if Curr
= Outer
then
27185 elsif Ekind
(Implementation_Base_Type
(Curr
)) = E_Task_Type
27187 Outer
= Task_Body_Procedure
(Implementation_Base_Type
(Curr
))
27191 elsif Is_Subprogram
(Curr
)
27192 and then Outer
= Protected_Body_Subprogram
(Curr
)
27196 elsif Is_Private_Type
(Curr
)
27197 and then Present
(Full_View
(Curr
))
27199 if Full_View
(Curr
) = Outer
then
27202 return Scope_Within
(Full_View
(Curr
), Outer
);
27206 Curr
:= Scope
(Curr
);
27210 end Scope_Within_Or_Same
;
27212 ------------------------
27213 -- Set_Current_Entity --
27214 ------------------------
27216 -- The given entity is to be set as the currently visible definition of its
27217 -- associated name (i.e. the Node_Id associated with its name). All we have
27218 -- to do is to get the name from the identifier, and then set the
27219 -- associated Node_Id to point to the given entity.
27221 procedure Set_Current_Entity
(E
: Entity_Id
) is
27223 Set_Name_Entity_Id
(Chars
(E
), E
);
27224 end Set_Current_Entity
;
27226 ---------------------------
27227 -- Set_Debug_Info_Needed --
27228 ---------------------------
27230 procedure Set_Debug_Info_Needed
(T
: Entity_Id
) is
27232 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
);
27233 pragma Inline
(Set_Debug_Info_Needed_If_Not_Set
);
27234 -- Used to set debug info in a related node if not set already
27236 --------------------------------------
27237 -- Set_Debug_Info_Needed_If_Not_Set --
27238 --------------------------------------
27240 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
) is
27242 if Present
(E
) and then not Needs_Debug_Info
(E
) then
27243 Set_Debug_Info_Needed
(E
);
27245 -- For a private type, indicate that the full view also needs
27246 -- debug information.
27249 and then Is_Private_Type
(E
)
27250 and then Present
(Full_View
(E
))
27252 Set_Debug_Info_Needed
(Full_View
(E
));
27255 end Set_Debug_Info_Needed_If_Not_Set
;
27257 -- Start of processing for Set_Debug_Info_Needed
27260 -- Nothing to do if there is no available entity
27265 -- Nothing to do for an entity with suppressed debug information
27267 elsif Debug_Info_Off
(T
) then
27270 -- Nothing to do for an ignored Ghost entity because the entity will be
27271 -- eliminated from the tree.
27273 elsif Is_Ignored_Ghost_Entity
(T
) then
27276 -- Nothing to do if entity comes from a predefined file. Library files
27277 -- are compiled without debug information, but inlined bodies of these
27278 -- routines may appear in user code, and debug information on them ends
27279 -- up complicating debugging the user code.
27281 elsif In_Inlined_Body
and then In_Predefined_Unit
(T
) then
27282 Set_Needs_Debug_Info
(T
, False);
27285 -- Set flag in entity itself. Note that we will go through the following
27286 -- circuitry even if the flag is already set on T. That's intentional,
27287 -- it makes sure that the flag will be set in subsidiary entities.
27289 Set_Needs_Debug_Info
(T
);
27291 -- Set flag on subsidiary entities if not set already
27293 if Is_Object
(T
) then
27294 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
27296 elsif Is_Type
(T
) then
27297 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
27299 if Is_Record_Type
(T
) then
27301 Ent
: Entity_Id
:= First_Entity
(T
);
27303 while Present
(Ent
) loop
27304 Set_Debug_Info_Needed_If_Not_Set
(Ent
);
27309 -- For a class wide subtype, we also need debug information
27310 -- for the equivalent type.
27312 if Ekind
(T
) = E_Class_Wide_Subtype
then
27313 Set_Debug_Info_Needed_If_Not_Set
(Equivalent_Type
(T
));
27316 elsif Is_Array_Type
(T
) then
27317 Set_Debug_Info_Needed_If_Not_Set
(Component_Type
(T
));
27320 Indx
: Node_Id
:= First_Index
(T
);
27322 while Present
(Indx
) loop
27323 Set_Debug_Info_Needed_If_Not_Set
(Etype
(Indx
));
27328 -- For a packed array type, we also need debug information for
27329 -- the type used to represent the packed array. Conversely, we
27330 -- also need it for the former if we need it for the latter.
27332 if Is_Packed
(T
) then
27333 Set_Debug_Info_Needed_If_Not_Set
(Packed_Array_Impl_Type
(T
));
27336 if Is_Packed_Array_Impl_Type
(T
) then
27337 Set_Debug_Info_Needed_If_Not_Set
(Original_Array_Type
(T
));
27340 elsif Is_Access_Type
(T
) then
27341 Set_Debug_Info_Needed_If_Not_Set
(Directly_Designated_Type
(T
));
27343 elsif Is_Private_Type
(T
) then
27345 FV
: constant Entity_Id
:= Full_View
(T
);
27348 Set_Debug_Info_Needed_If_Not_Set
(FV
);
27350 -- If the full view is itself a derived private type, we need
27351 -- debug information on its underlying type.
27354 and then Is_Private_Type
(FV
)
27355 and then Present
(Underlying_Full_View
(FV
))
27357 Set_Needs_Debug_Info
(Underlying_Full_View
(FV
));
27361 elsif Is_Protected_Type
(T
) then
27362 Set_Debug_Info_Needed_If_Not_Set
(Corresponding_Record_Type
(T
));
27364 elsif Is_Scalar_Type
(T
) then
27366 -- If the subrange bounds are materialized by dedicated constant
27367 -- objects, also include them in the debug info to make sure the
27368 -- debugger can properly use them.
27370 if Present
(Scalar_Range
(T
))
27371 and then Nkind
(Scalar_Range
(T
)) = N_Range
27374 Low_Bnd
: constant Node_Id
:= Type_Low_Bound
(T
);
27375 High_Bnd
: constant Node_Id
:= Type_High_Bound
(T
);
27378 if Is_Entity_Name
(Low_Bnd
) then
27379 Set_Debug_Info_Needed_If_Not_Set
(Entity
(Low_Bnd
));
27382 if Is_Entity_Name
(High_Bnd
) then
27383 Set_Debug_Info_Needed_If_Not_Set
(Entity
(High_Bnd
));
27389 end Set_Debug_Info_Needed
;
27391 --------------------------------
27392 -- Set_Debug_Info_Defining_Id --
27393 --------------------------------
27395 procedure Set_Debug_Info_Defining_Id
(N
: Node_Id
) is
27397 if Comes_From_Source
(Defining_Identifier
(N
)) then
27398 Set_Debug_Info_Needed
(Defining_Identifier
(N
));
27400 end Set_Debug_Info_Defining_Id
;
27402 ----------------------------
27403 -- Set_Entity_With_Checks --
27404 ----------------------------
27406 procedure Set_Entity_With_Checks
(N
: Node_Id
; Val
: Entity_Id
) is
27407 Val_Actual
: Entity_Id
;
27409 Post_Node
: Node_Id
;
27412 -- Unconditionally set the entity
27414 Set_Entity
(N
, Val
);
27416 -- The node to post on is the selector in the case of an expanded name,
27417 -- and otherwise the node itself.
27419 if Nkind
(N
) = N_Expanded_Name
then
27420 Post_Node
:= Selector_Name
(N
);
27425 -- Check for violation of No_Fixed_IO
27427 if Restriction_Check_Required
(No_Fixed_IO
)
27429 ((RTU_Loaded
(Ada_Text_IO
)
27430 and then (Is_RTE
(Val
, RE_Decimal_IO
)
27432 Is_RTE
(Val
, RE_Fixed_IO
)))
27435 (RTU_Loaded
(Ada_Wide_Text_IO
)
27436 and then (Is_RTE
(Val
, RO_WT_Decimal_IO
)
27438 Is_RTE
(Val
, RO_WT_Fixed_IO
)))
27441 (RTU_Loaded
(Ada_Wide_Wide_Text_IO
)
27442 and then (Is_RTE
(Val
, RO_WW_Decimal_IO
)
27444 Is_RTE
(Val
, RO_WW_Fixed_IO
))))
27446 -- A special extra check, don't complain about a reference from within
27447 -- the Ada.Interrupts package itself!
27449 and then not In_Same_Extended_Unit
(N
, Val
)
27451 Check_Restriction
(No_Fixed_IO
, Post_Node
);
27454 -- Remaining checks are only done on source nodes. Note that we test
27455 -- for violation of No_Fixed_IO even on non-source nodes, because the
27456 -- cases for checking violations of this restriction are instantiations
27457 -- where the reference in the instance has Comes_From_Source False.
27459 if not Comes_From_Source
(N
) then
27463 -- Check for violation of No_Abort_Statements, which is triggered by
27464 -- call to Ada.Task_Identification.Abort_Task.
27466 if Restriction_Check_Required
(No_Abort_Statements
)
27467 and then (Is_RTE
(Val
, RE_Abort_Task
))
27469 -- A special extra check, don't complain about a reference from within
27470 -- the Ada.Task_Identification package itself!
27472 and then not In_Same_Extended_Unit
(N
, Val
)
27474 Check_Restriction
(No_Abort_Statements
, Post_Node
);
27477 if Val
= Standard_Long_Long_Integer
then
27478 Check_Restriction
(No_Long_Long_Integers
, Post_Node
);
27481 -- Check for violation of No_Dynamic_Attachment
27483 if Restriction_Check_Required
(No_Dynamic_Attachment
)
27484 and then RTU_Loaded
(Ada_Interrupts
)
27485 and then (Is_RTE
(Val
, RE_Is_Reserved
) or else
27486 Is_RTE
(Val
, RE_Is_Attached
) or else
27487 Is_RTE
(Val
, RE_Current_Handler
) or else
27488 Is_RTE
(Val
, RE_Attach_Handler
) or else
27489 Is_RTE
(Val
, RE_Exchange_Handler
) or else
27490 Is_RTE
(Val
, RE_Detach_Handler
) or else
27491 Is_RTE
(Val
, RE_Reference
))
27493 -- A special extra check, don't complain about a reference from within
27494 -- the Ada.Interrupts package itself!
27496 and then not In_Same_Extended_Unit
(N
, Val
)
27498 Check_Restriction
(No_Dynamic_Attachment
, Post_Node
);
27501 -- Check for No_Implementation_Identifiers
27503 if Restriction_Check_Required
(No_Implementation_Identifiers
) then
27505 -- We have an implementation defined entity if it is marked as
27506 -- implementation defined, or is defined in a package marked as
27507 -- implementation defined. However, library packages themselves
27508 -- are excluded (we don't want to flag Interfaces itself, just
27509 -- the entities within it).
27511 if (Is_Implementation_Defined
(Val
)
27513 (Present
(Scope
(Val
))
27514 and then Is_Implementation_Defined
(Scope
(Val
))))
27515 and then not (Is_Package_Or_Generic_Package
(Val
)
27516 and then Is_Library_Level_Entity
(Val
))
27518 Check_Restriction
(No_Implementation_Identifiers
, Post_Node
);
27522 -- Do the style check
27525 and then not Suppress_Style_Checks
(Val
)
27526 and then not In_Instance
27528 if Nkind
(N
) = N_Identifier
then
27530 elsif Nkind
(N
) = N_Expanded_Name
then
27531 Nod
:= Selector_Name
(N
);
27536 -- A special situation arises for derived operations, where we want
27537 -- to do the check against the parent (since the Sloc of the derived
27538 -- operation points to the derived type declaration itself).
27541 while not Comes_From_Source
(Val_Actual
)
27542 and then Nkind
(Val_Actual
) in N_Entity
27543 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
27544 or else Is_Subprogram_Or_Generic_Subprogram
(Val_Actual
))
27545 and then Present
(Alias
(Val_Actual
))
27547 Val_Actual
:= Alias
(Val_Actual
);
27550 -- Renaming declarations for generic actuals do not come from source,
27551 -- and have a different name from that of the entity they rename, so
27552 -- there is no style check to perform here.
27554 if Chars
(Nod
) = Chars
(Val_Actual
) then
27555 Style
.Check_Identifier
(Nod
, Val_Actual
);
27558 end Set_Entity_With_Checks
;
27560 ------------------------------
27561 -- Set_Invalid_Scalar_Value --
27562 ------------------------------
27564 procedure Set_Invalid_Scalar_Value
27565 (Scal_Typ
: Float_Scalar_Id
;
27568 Slot
: Ureal
renames Invalid_Floats
(Scal_Typ
);
27571 -- Detect an attempt to set a different value for the same scalar type
27573 pragma Assert
(Slot
= No_Ureal
);
27575 end Set_Invalid_Scalar_Value
;
27577 ------------------------------
27578 -- Set_Invalid_Scalar_Value --
27579 ------------------------------
27581 procedure Set_Invalid_Scalar_Value
27582 (Scal_Typ
: Integer_Scalar_Id
;
27585 Slot
: Uint
renames Invalid_Integers
(Scal_Typ
);
27588 -- Detect an attempt to set a different value for the same scalar type
27590 pragma Assert
(No
(Slot
));
27592 end Set_Invalid_Scalar_Value
;
27594 ------------------------
27595 -- Set_Name_Entity_Id --
27596 ------------------------
27598 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
27600 Set_Name_Table_Int
(Id
, Int
(Val
));
27601 end Set_Name_Entity_Id
;
27603 ---------------------
27604 -- Set_Next_Actual --
27605 ---------------------
27607 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
27609 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
27610 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
27612 end Set_Next_Actual
;
27614 ----------------------------------
27615 -- Set_Optimize_Alignment_Flags --
27616 ----------------------------------
27618 procedure Set_Optimize_Alignment_Flags
(E
: Entity_Id
) is
27620 if Optimize_Alignment
= 'S' then
27621 Set_Optimize_Alignment_Space
(E
);
27622 elsif Optimize_Alignment
= 'T' then
27623 Set_Optimize_Alignment_Time
(E
);
27625 end Set_Optimize_Alignment_Flags
;
27627 -----------------------
27628 -- Set_Public_Status --
27629 -----------------------
27631 procedure Set_Public_Status
(Id
: Entity_Id
) is
27632 S
: constant Entity_Id
:= Current_Scope
;
27634 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean;
27635 -- Determines if E is defined within handled statement sequence or
27636 -- an if statement, returns True if so, False otherwise.
27638 ----------------------
27639 -- Within_HSS_Or_If --
27640 ----------------------
27642 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean is
27645 N
:= Declaration_Node
(E
);
27653 N_Handled_Sequence_Of_Statements | N_If_Statement
27658 end Within_HSS_Or_If
;
27660 -- Start of processing for Set_Public_Status
27663 -- Everything in the scope of Standard is public
27665 if S
= Standard_Standard
then
27666 Set_Is_Public
(Id
);
27668 -- Entity is definitely not public if enclosing scope is not public
27670 elsif not Is_Public
(S
) then
27673 -- An object or function declaration that occurs in a handled sequence
27674 -- of statements or within an if statement is the declaration for a
27675 -- temporary object or local subprogram generated by the expander. It
27676 -- never needs to be made public and furthermore, making it public can
27677 -- cause back end problems.
27679 elsif Nkind
(Parent
(Id
)) in
27680 N_Object_Declaration | N_Function_Specification
27681 and then Within_HSS_Or_If
(Id
)
27685 -- Entities in public packages or records are public
27687 elsif Ekind
(S
) = E_Package
or Is_Record_Type
(S
) then
27688 Set_Is_Public
(Id
);
27690 -- The bounds of an entry family declaration can generate object
27691 -- declarations that are visible to the back-end, e.g. in the
27692 -- the declaration of a composite type that contains tasks.
27694 elsif Is_Concurrent_Type
(S
)
27695 and then not Has_Completion
(S
)
27696 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
27698 Set_Is_Public
(Id
);
27700 end Set_Public_Status
;
27702 -----------------------------
27703 -- Set_Referenced_Modified --
27704 -----------------------------
27706 procedure Set_Referenced_Modified
(N
: Node_Id
; Out_Param
: Boolean) is
27710 -- Deal with indexed or selected component where prefix is modified
27712 if Nkind
(N
) in N_Indexed_Component | N_Selected_Component
then
27713 Pref
:= Prefix
(N
);
27715 -- If prefix is access type, then it is the designated object that is
27716 -- being modified, which means we have no entity to set the flag on.
27718 if No
(Etype
(Pref
)) or else Is_Access_Type
(Etype
(Pref
)) then
27721 -- Otherwise chase the prefix
27724 Set_Referenced_Modified
(Pref
, Out_Param
);
27727 -- Otherwise see if we have an entity name (only other case to process)
27729 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
27730 Set_Referenced_As_LHS
(Entity
(N
), not Out_Param
);
27731 Set_Referenced_As_Out_Parameter
(Entity
(N
), Out_Param
);
27733 end Set_Referenced_Modified
;
27739 procedure Set_Rep_Info
(T1
: Entity_Id
; T2
: Entity_Id
) is
27741 Set_Is_Atomic
(T1
, Is_Atomic
(T2
));
27742 Set_Is_Independent
(T1
, Is_Independent
(T2
));
27743 Set_Is_Volatile_Full_Access
(T1
, Is_Volatile_Full_Access
(T2
));
27745 if Is_Base_Type
(T1
) then
27746 Set_Is_Volatile
(T1
, Is_Volatile
(T2
));
27750 ----------------------------
27751 -- Set_Scope_Is_Transient --
27752 ----------------------------
27754 procedure Set_Scope_Is_Transient
(V
: Boolean := True) is
27756 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= V
;
27757 end Set_Scope_Is_Transient
;
27759 -------------------
27760 -- Set_Size_Info --
27761 -------------------
27763 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
27765 -- We copy Esize, but not RM_Size, since in general RM_Size is
27766 -- subtype specific and does not get inherited by all subtypes.
27768 Copy_Esize
(To
=> T1
, From
=> T2
);
27769 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
27771 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
27773 Is_Discrete_Or_Fixed_Point_Type
(T2
)
27775 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
27778 Copy_Alignment
(To
=> T1
, From
=> T2
);
27781 ------------------------------
27782 -- Should_Ignore_Pragma_Par --
27783 ------------------------------
27785 function Should_Ignore_Pragma_Par
(Prag_Name
: Name_Id
) return Boolean is
27786 pragma Assert
(Compiler_State
= Parsing
);
27787 -- This one can't work during semantic analysis, because we don't have a
27788 -- correct Current_Source_File.
27790 Result
: constant Boolean :=
27791 Get_Name_Table_Boolean3
(Prag_Name
)
27792 and then not Is_Internal_File_Name
27793 (File_Name
(Current_Source_File
));
27796 end Should_Ignore_Pragma_Par
;
27798 ------------------------------
27799 -- Should_Ignore_Pragma_Sem --
27800 ------------------------------
27802 function Should_Ignore_Pragma_Sem
(N
: Node_Id
) return Boolean is
27803 pragma Assert
(Compiler_State
= Analyzing
);
27804 Prag_Name
: constant Name_Id
:= Pragma_Name
(N
);
27805 Result
: constant Boolean :=
27806 Get_Name_Table_Boolean3
(Prag_Name
)
27807 and then not In_Internal_Unit
(N
);
27811 end Should_Ignore_Pragma_Sem
;
27813 --------------------
27814 -- Static_Boolean --
27815 --------------------
27817 function Static_Boolean
(N
: Node_Id
) return Opt_Ubool
is
27819 Analyze_And_Resolve
(N
, Standard_Boolean
);
27822 or else Error_Posted
(N
)
27823 or else Etype
(N
) = Any_Type
27828 if Is_OK_Static_Expression
(N
) then
27829 if not Raises_Constraint_Error
(N
) then
27830 return Expr_Value
(N
);
27835 elsif Etype
(N
) = Any_Type
then
27839 Flag_Non_Static_Expr
27840 ("static boolean expression required here", N
);
27843 end Static_Boolean
;
27845 --------------------
27846 -- Static_Integer --
27847 --------------------
27849 function Static_Integer
(N
: Node_Id
) return Uint
is
27851 Analyze_And_Resolve
(N
, Any_Integer
);
27854 or else Error_Posted
(N
)
27855 or else Etype
(N
) = Any_Type
27860 if Is_OK_Static_Expression
(N
) then
27861 if not Raises_Constraint_Error
(N
) then
27862 return Expr_Value
(N
);
27867 elsif Etype
(N
) = Any_Type
then
27871 Flag_Non_Static_Expr
27872 ("static integer expression required here", N
);
27875 end Static_Integer
;
27877 -------------------------------
27878 -- Statically_Denotes_Entity --
27879 -------------------------------
27881 function Statically_Denotes_Entity
(N
: Node_Id
) return Boolean is
27884 if not Is_Entity_Name
(N
) then
27891 Nkind
(Parent
(E
)) /= N_Object_Renaming_Declaration
27892 or else Is_Prival
(E
)
27893 or else Statically_Denotes_Entity
(Renamed_Object
(E
));
27894 end Statically_Denotes_Entity
;
27896 -------------------------------
27897 -- Statically_Denotes_Object --
27898 -------------------------------
27900 function Statically_Denotes_Object
(N
: Node_Id
) return Boolean is
27902 return Statically_Denotes_Entity
(N
)
27903 and then Is_Object_Reference
(N
);
27904 end Statically_Denotes_Object
;
27906 --------------------------
27907 -- Statically_Different --
27908 --------------------------
27910 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
27911 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
27912 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
27914 return Is_Entity_Name
(R1
)
27915 and then Is_Entity_Name
(R2
)
27916 and then Entity
(R1
) /= Entity
(R2
)
27917 and then not Is_Formal
(Entity
(R1
))
27918 and then not Is_Formal
(Entity
(R2
));
27919 end Statically_Different
;
27921 -----------------------------
27922 -- Statically_Names_Object --
27923 -----------------------------
27925 function Statically_Names_Object
(N
: Node_Id
) return Boolean is
27927 if Statically_Denotes_Object
(N
) then
27929 elsif Is_Entity_Name
(N
) then
27931 E
: constant Entity_Id
:= Entity
(N
);
27933 return Nkind
(Parent
(E
)) = N_Object_Renaming_Declaration
27934 and then Statically_Names_Object
(Renamed_Object
(E
));
27939 when N_Indexed_Component
=>
27940 if Is_Access_Type
(Etype
(Prefix
(N
))) then
27941 -- treat implicit dereference same as explicit
27945 if not Is_Constrained
(Etype
(Prefix
(N
))) then
27950 Indx
: Node_Id
:= First_Index
(Etype
(Prefix
(N
)));
27951 Expr
: Node_Id
:= First
(Expressions
(N
));
27952 Index_Subtype
: Node_Id
;
27955 Index_Subtype
:= Etype
(Indx
);
27957 if not Is_Static_Subtype
(Index_Subtype
) then
27960 if not Is_OK_Static_Expression
(Expr
) then
27965 Index_Value
: constant Uint
:= Expr_Value
(Expr
);
27966 Low_Value
: constant Uint
:=
27967 Expr_Value
(Type_Low_Bound
(Index_Subtype
));
27968 High_Value
: constant Uint
:=
27969 Expr_Value
(Type_High_Bound
(Index_Subtype
));
27971 if (Index_Value
< Low_Value
)
27972 or (Index_Value
> High_Value
)
27979 Expr
:= Next
(Expr
);
27980 pragma Assert
((Present
(Indx
) = Present
(Expr
))
27981 or else (Serious_Errors_Detected
> 0));
27982 exit when not (Present
(Indx
) and Present
(Expr
));
27986 when N_Selected_Component
=>
27987 if Is_Access_Type
(Etype
(Prefix
(N
))) then
27988 -- treat implicit dereference same as explicit
27992 if Ekind
(Entity
(Selector_Name
(N
))) not in
27993 E_Component | E_Discriminant
27999 Comp
: constant Entity_Id
:=
28000 Original_Record_Component
(Entity
(Selector_Name
(N
)));
28002 -- AI12-0373 confirms that we should not call
28003 -- Has_Discriminant_Dependent_Constraint here which would be
28006 if Is_Declared_Within_Variant
(Comp
) then
28011 when others => -- includes N_Slice, N_Explicit_Dereference
28015 pragma Assert
(Present
(Prefix
(N
)));
28017 return Statically_Names_Object
(Prefix
(N
));
28018 end Statically_Names_Object
;
28020 ---------------------------------
28021 -- String_From_Numeric_Literal --
28022 ---------------------------------
28024 function String_From_Numeric_Literal
(N
: Node_Id
) return String_Id
is
28025 Loc
: constant Source_Ptr
:= Sloc
(N
);
28026 Sbuffer
: constant Source_Buffer_Ptr
:=
28027 Source_Text
(Get_Source_File_Index
(Loc
));
28028 Src_Ptr
: Source_Ptr
:= Loc
;
28030 C
: Character := Sbuffer
(Src_Ptr
);
28031 -- Current source program character
28033 function Belongs_To_Numeric_Literal
(C
: Character) return Boolean;
28034 -- Return True if C belongs to the numeric literal
28036 --------------------------------
28037 -- Belongs_To_Numeric_Literal --
28038 --------------------------------
28040 function Belongs_To_Numeric_Literal
(C
: Character) return Boolean is
28043 when '0' .. '9' |
'_' |
'.' |
'e' |
'#' |
'A' .. 'F' =>
28046 -- Make sure '+' or '-' is part of an exponent
28050 Prev_C
: constant Character := Sbuffer
(Src_Ptr
- 1);
28052 return Prev_C
in 'e' |
'E';
28055 -- Other characters cannot belong to a numeric literal
28060 end Belongs_To_Numeric_Literal
;
28062 -- Start of processing for String_From_Numeric_Literal
28066 while Belongs_To_Numeric_Literal
(C
) loop
28067 Store_String_Char
(C
);
28068 Src_Ptr
:= Src_Ptr
+ 1;
28069 C
:= Sbuffer
(Src_Ptr
);
28073 end String_From_Numeric_Literal
;
28075 --------------------------------------
28076 -- Subject_To_Loop_Entry_Attributes --
28077 --------------------------------------
28079 function Subject_To_Loop_Entry_Attributes
(N
: Node_Id
) return Boolean is
28085 -- The expansion mechanism transform a loop subject to at least one
28086 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
28087 -- the conditional part.
28089 if Nkind
(Stmt
) in N_Block_Statement | N_If_Statement
28090 and then Nkind
(Original_Node
(N
)) = N_Loop_Statement
28092 Stmt
:= Original_Node
(N
);
28096 Nkind
(Stmt
) = N_Loop_Statement
28097 and then Present
(Identifier
(Stmt
))
28098 and then Present
(Entity
(Identifier
(Stmt
)))
28099 and then Has_Loop_Entry_Attributes
(Entity
(Identifier
(Stmt
)));
28100 end Subject_To_Loop_Entry_Attributes
;
28102 ---------------------
28103 -- Subprogram_Name --
28104 ---------------------
28106 function Subprogram_Name
(N
: Node_Id
) return String is
28107 Buf
: Bounded_String
;
28108 Ent
: Node_Id
:= N
;
28112 while Present
(Ent
) loop
28113 case Nkind
(Ent
) is
28114 when N_Subprogram_Body
=>
28115 Ent
:= Defining_Unit_Name
(Specification
(Ent
));
28118 when N_Subprogram_Declaration
=>
28119 Nod
:= Corresponding_Body
(Ent
);
28121 if Present
(Nod
) then
28124 Ent
:= Defining_Unit_Name
(Specification
(Ent
));
28129 when N_Subprogram_Instantiation
28131 | N_Package_Specification
28133 Ent
:= Defining_Unit_Name
(Ent
);
28136 when N_Protected_Type_Declaration
=>
28137 Ent
:= Corresponding_Body
(Ent
);
28140 when N_Protected_Body
28143 Ent
:= Defining_Identifier
(Ent
);
28150 Ent
:= Parent
(Ent
);
28154 return "unknown subprogram:unknown file:0:0";
28157 -- If the subprogram is a child unit, use its simple name to start the
28158 -- construction of the fully qualified name.
28160 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
28161 Ent
:= Defining_Identifier
(Ent
);
28164 Append_Entity_Name
(Buf
, Ent
);
28166 -- Append homonym number if needed
28168 if Nkind
(N
) in N_Entity
and then Has_Homonym
(N
) then
28170 H
: Entity_Id
:= Homonym
(N
);
28174 while Present
(H
) loop
28175 if Scope
(H
) = Scope
(N
) then
28189 -- Append source location of Ent to Buf so that the string will
28190 -- look like "subp:file:line:col".
28193 Loc
: constant Source_Ptr
:= Sloc
(Ent
);
28196 Append
(Buf
, Reference_Name
(Get_Source_File_Index
(Loc
)));
28198 Append
(Buf
, Nat
(Get_Logical_Line_Number
(Loc
)));
28200 Append
(Buf
, Nat
(Get_Column_Number
(Loc
)));
28204 end Subprogram_Name
;
28206 -------------------------------
28207 -- Support_Atomic_Primitives --
28208 -------------------------------
28210 function Support_Atomic_Primitives
(Typ
: Entity_Id
) return Boolean is
28214 -- Verify the alignment of Typ is known
28216 if not Known_Alignment
(Typ
) then
28220 if Known_Static_Esize
(Typ
) then
28221 Size
:= UI_To_Int
(Esize
(Typ
));
28223 -- If the Esize (Object_Size) is unknown at compile time, look at the
28224 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
28226 elsif Known_Static_RM_Size
(Typ
) then
28227 Size
:= UI_To_Int
(RM_Size
(Typ
));
28229 -- Otherwise, the size is considered to be unknown.
28235 -- Check that the size of the component is 8, 16, 32, or 64 bits and
28236 -- that Typ is properly aligned.
28239 when 8 |
16 |
32 |
64 =>
28240 return Size
= UI_To_Int
(Alignment
(Typ
)) * 8;
28245 end Support_Atomic_Primitives
;
28251 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
28253 if Debug_Flag_W
then
28254 for J
in 0 .. Scope_Stack
.Last
loop
28259 Write_Name
(Chars
(E
));
28260 Write_Str
(" from ");
28261 Write_Location
(Sloc
(N
));
28266 -----------------------
28267 -- Transfer_Entities --
28268 -----------------------
28270 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
28271 procedure Set_Public_Status_Of
(Id
: Entity_Id
);
28272 -- Set the Is_Public attribute of arbitrary entity Id by calling routine
28273 -- Set_Public_Status. If successful and Id denotes a record type, set
28274 -- the Is_Public attribute of its fields.
28276 --------------------------
28277 -- Set_Public_Status_Of --
28278 --------------------------
28280 procedure Set_Public_Status_Of
(Id
: Entity_Id
) is
28284 if not Is_Public
(Id
) then
28285 Set_Public_Status
(Id
);
28287 -- When the input entity is a public record type, ensure that all
28288 -- its internal fields are also exposed to the linker. The fields
28289 -- of a class-wide type are never made public.
28292 and then Is_Record_Type
(Id
)
28293 and then not Is_Class_Wide_Type
(Id
)
28295 Field
:= First_Entity
(Id
);
28296 while Present
(Field
) loop
28297 Set_Is_Public
(Field
);
28298 Next_Entity
(Field
);
28302 end Set_Public_Status_Of
;
28306 Full_Id
: Entity_Id
;
28309 -- Start of processing for Transfer_Entities
28312 Id
:= First_Entity
(From
);
28314 if Present
(Id
) then
28316 -- Merge the entity chain of the source scope with that of the
28317 -- destination scope.
28319 if Present
(Last_Entity
(To
)) then
28320 Link_Entities
(Last_Entity
(To
), Id
);
28322 Set_First_Entity
(To
, Id
);
28325 Set_Last_Entity
(To
, Last_Entity
(From
));
28327 -- Inspect the entities of the source scope and update their Scope
28330 while Present
(Id
) loop
28331 Set_Scope
(Id
, To
);
28332 Set_Public_Status_Of
(Id
);
28334 -- Handle an internally generated full view for a private type
28336 if Is_Private_Type
(Id
)
28337 and then Present
(Full_View
(Id
))
28338 and then Is_Itype
(Full_View
(Id
))
28340 Full_Id
:= Full_View
(Id
);
28342 Set_Scope
(Full_Id
, To
);
28343 Set_Public_Status_Of
(Full_Id
);
28349 Set_First_Entity
(From
, Empty
);
28350 Set_Last_Entity
(From
, Empty
);
28352 end Transfer_Entities
;
28354 ------------------------
28355 -- Traverse_More_Func --
28356 ------------------------
28358 function Traverse_More_Func
(Node
: Node_Id
) return Traverse_Final_Result
is
28360 Processing_Itype
: Boolean := False;
28361 -- Set to True while traversing the nodes under an Itype, to prevent
28362 -- looping on Itype handling during that traversal.
28364 function Process_More
(N
: Node_Id
) return Traverse_Result
;
28365 -- Wrapper over the Process callback to handle parts of the AST that
28366 -- are not normally traversed as syntactic children.
28368 function Traverse_Rec
(N
: Node_Id
) return Traverse_Final_Result
;
28369 -- Main recursive traversal implemented as an instantiation of
28370 -- Traverse_Func over a modified Process callback.
28376 function Process_More
(N
: Node_Id
) return Traverse_Result
is
28378 procedure Traverse_More
(N
: Node_Id
;
28379 Res
: in out Traverse_Result
);
28380 procedure Traverse_More
(L
: List_Id
;
28381 Res
: in out Traverse_Result
);
28382 -- Traverse a node or list and update the traversal result to value
28383 -- Abandon when needed.
28385 -------------------
28386 -- Traverse_More --
28387 -------------------
28389 procedure Traverse_More
(N
: Node_Id
;
28390 Res
: in out Traverse_Result
)
28393 -- Do not process any more nodes if Abandon was reached
28395 if Res
= Abandon
then
28399 if Traverse_Rec
(N
) = Abandon
then
28404 procedure Traverse_More
(L
: List_Id
;
28405 Res
: in out Traverse_Result
)
28407 N
: Node_Id
:= First
(L
);
28410 -- Do not process any more nodes if Abandon was reached
28412 if Res
= Abandon
then
28416 while Present
(N
) loop
28417 Traverse_More
(N
, Res
);
28425 Result
: Traverse_Result
;
28427 -- Start of processing for Process_More
28430 -- Initial callback to Process. Return immediately on Skip/Abandon.
28431 -- Otherwise update the value of Node for further processing of
28432 -- non-syntactic children.
28434 Result
:= Process
(N
);
28437 when OK
=> Node
:= N
;
28438 when OK_Orig
=> Node
:= Original_Node
(N
);
28439 when Skip
=> return Skip
;
28440 when Abandon
=> return Abandon
;
28443 -- Process the relevant semantic children which are a logical part of
28444 -- the AST under this node before returning for the processing of
28445 -- syntactic children.
28447 -- Start with all non-syntactic lists of action nodes
28449 case Nkind
(Node
) is
28450 when N_Component_Association
=>
28451 Traverse_More
(Loop_Actions
(Node
), Result
);
28453 when N_Elsif_Part
=>
28454 Traverse_More
(Condition_Actions
(Node
), Result
);
28456 when N_Short_Circuit
=>
28457 Traverse_More
(Actions
(Node
), Result
);
28459 when N_Case_Expression_Alternative
=>
28460 Traverse_More
(Actions
(Node
), Result
);
28462 when N_Iterated_Component_Association
=>
28463 Traverse_More
(Loop_Actions
(Node
), Result
);
28465 when N_Iterated_Element_Association
=>
28466 Traverse_More
(Loop_Actions
(Node
), Result
);
28468 when N_Iteration_Scheme
=>
28469 Traverse_More
(Condition_Actions
(Node
), Result
);
28471 when N_If_Expression
=>
28472 Traverse_More
(Then_Actions
(Node
), Result
);
28473 Traverse_More
(Else_Actions
(Node
), Result
);
28475 -- Various nodes have a field Actions as a syntactic node,
28476 -- so it will be traversed in the regular syntactic traversal.
28478 when N_Compilation_Unit_Aux
28479 | N_Compound_Statement
28480 | N_Expression_With_Actions
28489 -- If Process_Itypes is True, process unattached nodes which come
28490 -- from Itypes. This only concerns currently ranges of scalar
28491 -- (possibly as index) types. This traversal is protected against
28492 -- looping with Processing_Itype.
28495 and then not Processing_Itype
28496 and then Nkind
(Node
) in N_Has_Etype
28497 and then Present
(Etype
(Node
))
28498 and then Is_Itype
(Etype
(Node
))
28501 Typ
: constant Entity_Id
:= Etype
(Node
);
28503 Processing_Itype
:= True;
28505 case Ekind
(Typ
) is
28506 when Scalar_Kind
=>
28507 Traverse_More
(Scalar_Range
(Typ
), Result
);
28511 Index
: Node_Id
:= First_Index
(Typ
);
28514 while Present
(Index
) loop
28515 if Nkind
(Index
) in N_Has_Entity
then
28516 Rng
:= Scalar_Range
(Entity
(Index
));
28521 Traverse_More
(Rng
, Result
);
28522 Next_Index
(Index
);
28529 Processing_Itype
:= False;
28536 -- Define Traverse_Rec as a renaming of the instantiation, as an
28537 -- instantiation cannot complete a previous spec.
28539 function Traverse_Recursive
is new Traverse_Func
(Process_More
);
28540 function Traverse_Rec
(N
: Node_Id
) return Traverse_Final_Result
28541 renames Traverse_Recursive
;
28543 -- Start of processing for Traverse_More_Func
28546 return Traverse_Rec
(Node
);
28547 end Traverse_More_Func
;
28549 ------------------------
28550 -- Traverse_More_Proc --
28551 ------------------------
28553 procedure Traverse_More_Proc
(Node
: Node_Id
) is
28554 function Traverse
is new Traverse_More_Func
(Process
, Process_Itypes
);
28555 Discard
: Traverse_Final_Result
;
28556 pragma Warnings
(Off
, Discard
);
28558 Discard
:= Traverse
(Node
);
28559 end Traverse_More_Proc
;
28561 ------------------------------------
28562 -- Type_Without_Stream_Operation --
28563 ------------------------------------
28565 function Type_Without_Stream_Operation
28567 Op
: TSS_Name_Type
:= TSS_Null
) return Entity_Id
28569 BT
: constant Entity_Id
:= Base_Type
(T
);
28570 Op_Missing
: Boolean;
28573 if not Restriction_Active
(No_Default_Stream_Attributes
) then
28577 if Is_Elementary_Type
(T
) then
28578 if Op
= TSS_Null
then
28580 No
(TSS
(BT
, TSS_Stream_Read
))
28581 or else No
(TSS
(BT
, TSS_Stream_Write
));
28584 Op_Missing
:= No
(TSS
(BT
, Op
));
28593 elsif Is_Array_Type
(T
) then
28594 return Type_Without_Stream_Operation
(Component_Type
(T
), Op
);
28596 elsif Is_Record_Type
(T
) then
28602 Comp
:= First_Component
(T
);
28603 while Present
(Comp
) loop
28604 C_Typ
:= Type_Without_Stream_Operation
(Etype
(Comp
), Op
);
28606 if Present
(C_Typ
) then
28610 Next_Component
(Comp
);
28616 elsif Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
28617 return Type_Without_Stream_Operation
(Full_View
(T
), Op
);
28621 end Type_Without_Stream_Operation
;
28623 ------------------------------
28624 -- Ultimate_Overlaid_Entity --
28625 ------------------------------
28627 function Ultimate_Overlaid_Entity
(E
: Entity_Id
) return Entity_Id
is
28629 Alias
: Entity_Id
:= E
;
28633 -- Currently this routine is only called for stand-alone objects that
28634 -- have been analysed, since the analysis of the Address aspect is often
28637 pragma Assert
(Ekind
(E
) in E_Constant | E_Variable
);
28640 Address
:= Address_Clause
(Alias
);
28641 if Present
(Address
) then
28642 Find_Overlaid_Entity
(Address
, Alias
, Offset
);
28643 if Present
(Alias
) then
28648 elsif Alias
= E
then
28654 end Ultimate_Overlaid_Entity
;
28656 ---------------------
28657 -- Ultimate_Prefix --
28658 ---------------------
28660 function Ultimate_Prefix
(N
: Node_Id
) return Node_Id
is
28665 while Nkind
(Pref
) in N_Explicit_Dereference
28666 | N_Indexed_Component
28667 | N_Selected_Component
28670 Pref
:= Prefix
(Pref
);
28674 end Ultimate_Prefix
;
28676 ----------------------------
28677 -- Unique_Defining_Entity --
28678 ----------------------------
28680 function Unique_Defining_Entity
(N
: Node_Id
) return Entity_Id
is
28682 return Unique_Entity
(Defining_Entity
(N
));
28683 end Unique_Defining_Entity
;
28685 -------------------
28686 -- Unique_Entity --
28687 -------------------
28689 function Unique_Entity
(E
: Entity_Id
) return Entity_Id
is
28690 U
: Entity_Id
:= E
;
28696 if Present
(Full_View
(E
)) then
28697 U
:= Full_View
(E
);
28701 if Nkind
(Parent
(E
)) = N_Entry_Body
then
28703 Prot_Item
: Entity_Id
;
28704 Prot_Type
: Entity_Id
;
28707 if Ekind
(E
) = E_Entry
then
28708 Prot_Type
:= Scope
(E
);
28710 -- Bodies of entry families are nested within an extra scope
28711 -- that contains an entry index declaration.
28714 Prot_Type
:= Scope
(Scope
(E
));
28717 -- A protected type may be declared as a private type, in
28718 -- which case we need to get its full view.
28720 if Is_Private_Type
(Prot_Type
) then
28721 Prot_Type
:= Full_View
(Prot_Type
);
28724 -- Full view may not be present on error, in which case
28725 -- return E by default.
28727 if Present
(Prot_Type
) then
28728 pragma Assert
(Ekind
(Prot_Type
) = E_Protected_Type
);
28730 -- Traverse the entity list of the protected type and
28731 -- locate an entry declaration which matches the entry
28734 Prot_Item
:= First_Entity
(Prot_Type
);
28735 while Present
(Prot_Item
) loop
28736 if Ekind
(Prot_Item
) in Entry_Kind
28737 and then Corresponding_Body
(Parent
(Prot_Item
)) = E
28743 Next_Entity
(Prot_Item
);
28749 when Formal_Kind
=>
28750 if Present
(Spec_Entity
(E
)) then
28751 U
:= Spec_Entity
(E
);
28754 when E_Package_Body
=>
28757 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
28761 if Nkind
(P
) = N_Package_Body
28762 and then Present
(Corresponding_Spec
(P
))
28764 U
:= Corresponding_Spec
(P
);
28766 elsif Nkind
(P
) = N_Package_Body_Stub
28767 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28769 U
:= Corresponding_Spec_Of_Stub
(P
);
28772 when E_Protected_Body
=>
28775 if Nkind
(P
) = N_Protected_Body
28776 and then Present
(Corresponding_Spec
(P
))
28778 U
:= Corresponding_Spec
(P
);
28780 elsif Nkind
(P
) = N_Protected_Body_Stub
28781 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28783 U
:= Corresponding_Spec_Of_Stub
(P
);
28785 if Is_Single_Protected_Object
(U
) then
28790 if Is_Private_Type
(U
) then
28791 U
:= Full_View
(U
);
28794 when E_Subprogram_Body
=>
28797 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
28803 if Nkind
(P
) = N_Subprogram_Body
28804 and then Present
(Corresponding_Spec
(P
))
28806 U
:= Corresponding_Spec
(P
);
28808 elsif Nkind
(P
) = N_Subprogram_Body_Stub
28809 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28811 U
:= Corresponding_Spec_Of_Stub
(P
);
28813 elsif Nkind
(P
) = N_Subprogram_Renaming_Declaration
then
28814 U
:= Corresponding_Spec
(P
);
28817 when E_Task_Body
=>
28820 if Nkind
(P
) = N_Task_Body
28821 and then Present
(Corresponding_Spec
(P
))
28823 U
:= Corresponding_Spec
(P
);
28825 elsif Nkind
(P
) = N_Task_Body_Stub
28826 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28828 U
:= Corresponding_Spec_Of_Stub
(P
);
28830 if Is_Single_Task_Object
(U
) then
28835 if Is_Private_Type
(U
) then
28836 U
:= Full_View
(U
);
28840 if Present
(Full_View
(E
)) then
28841 U
:= Full_View
(E
);
28855 function Unique_Name
(E
: Entity_Id
) return String is
28857 -- Local subprograms
28859 function Add_Homonym_Suffix
(E
: Entity_Id
) return String;
28861 function This_Name
return String;
28863 ------------------------
28864 -- Add_Homonym_Suffix --
28865 ------------------------
28867 function Add_Homonym_Suffix
(E
: Entity_Id
) return String is
28869 -- Names in E_Subprogram_Body or E_Package_Body entities are not
28870 -- reliable, as they may not include the overloading suffix.
28871 -- Instead, when looking for the name of E or one of its enclosing
28872 -- scope, we get the name of the corresponding Unique_Entity.
28874 U
: constant Entity_Id
:= Unique_Entity
(E
);
28875 Nam
: constant String := Get_Name_String
(Chars
(U
));
28878 -- If E has homonyms but is not fully qualified, as done in
28879 -- GNATprove mode, append the homonym number on the fly. Strip the
28880 -- leading space character in the image of natural numbers. Also do
28881 -- not print the homonym value of 1.
28883 if Has_Homonym
(U
) then
28885 N
: constant Pos
:= Homonym_Number
(U
);
28886 S
: constant String := N
'Img;
28889 return Nam
& "__" & S
(2 .. S
'Last);
28895 end Add_Homonym_Suffix
;
28901 function This_Name
return String is
28903 return Add_Homonym_Suffix
(E
);
28908 U
: constant Entity_Id
:= Unique_Entity
(E
);
28910 -- Start of processing for Unique_Name
28913 if E
= Standard_Standard
28914 or else Has_Fully_Qualified_Name
(E
)
28918 elsif Ekind
(E
) = E_Enumeration_Literal
then
28919 return Unique_Name
(Etype
(E
)) & "__" & This_Name
;
28923 S
: constant Entity_Id
:= Scope
(U
);
28924 pragma Assert
(Present
(S
));
28927 -- Prefix names of predefined types with standard__, but leave
28928 -- names of user-defined packages and subprograms without prefix
28929 -- (even if technically they are nested in the Standard package).
28931 if S
= Standard_Standard
then
28932 if Ekind
(U
) = E_Package
or else Is_Subprogram
(U
) then
28935 return Unique_Name
(S
) & "__" & This_Name
;
28938 -- For intances of generic subprograms use the name of the related
28939 -- instance and skip the scope of its wrapper package.
28941 elsif Is_Wrapper_Package
(S
) then
28942 pragma Assert
(Scope
(S
) = Scope
(Related_Instance
(S
)));
28943 -- Wrapper package and the instantiation are in the same scope
28946 Related_Name
: constant String :=
28947 Add_Homonym_Suffix
(Related_Instance
(S
));
28948 Enclosing_Name
: constant String :=
28949 Unique_Name
(Scope
(S
)) & "__" & Related_Name
;
28952 if Is_Subprogram
(U
)
28953 and then not Is_Generic_Actual_Subprogram
(U
)
28955 return Enclosing_Name
;
28957 return Enclosing_Name
& "__" & This_Name
;
28961 elsif Is_Child_Unit
(U
) then
28962 return Child_Prefix
& Unique_Name
(S
) & "__" & This_Name
;
28964 return Unique_Name
(S
) & "__" & This_Name
;
28970 ---------------------
28971 -- Unit_Is_Visible --
28972 ---------------------
28974 function Unit_Is_Visible
(U
: Entity_Id
) return Boolean is
28975 Curr
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
28976 Curr_Entity
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
28978 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean;
28979 -- For a child unit, check whether unit appears in a with_clause
28982 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean;
28983 -- Scan the context clause of one compilation unit looking for a
28984 -- with_clause for the unit in question.
28986 ----------------------------
28987 -- Unit_In_Parent_Context --
28988 ----------------------------
28990 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean is
28992 if Unit_In_Context
(Par_Unit
) then
28995 elsif Is_Child_Unit
(Defining_Entity
(Unit
(Par_Unit
))) then
28996 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Par_Unit
)));
29001 end Unit_In_Parent_Context
;
29003 ---------------------
29004 -- Unit_In_Context --
29005 ---------------------
29007 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean is
29011 Clause
:= First
(Context_Items
(Comp_Unit
));
29012 while Present
(Clause
) loop
29013 if Nkind
(Clause
) = N_With_Clause
then
29014 if Library_Unit
(Clause
) = U
then
29017 -- The with_clause may denote a renaming of the unit we are
29018 -- looking for, eg. Text_IO which renames Ada.Text_IO.
29021 Renamed_Entity
(Entity
(Name
(Clause
))) =
29022 Defining_Entity
(Unit
(U
))
29032 end Unit_In_Context
;
29034 -- Start of processing for Unit_Is_Visible
29037 -- The currrent unit is directly visible
29042 elsif Unit_In_Context
(Curr
) then
29045 -- If the current unit is a body, check the context of the spec
29047 elsif Nkind
(Unit
(Curr
)) = N_Package_Body
29049 (Nkind
(Unit
(Curr
)) = N_Subprogram_Body
29050 and then not Acts_As_Spec
(Unit
(Curr
)))
29052 if Unit_In_Context
(Library_Unit
(Curr
)) then
29057 -- If the spec is a child unit, examine the parents
29059 if Is_Child_Unit
(Curr_Entity
) then
29060 if Nkind
(Unit
(Curr
)) in N_Unit_Body
then
29062 Unit_In_Parent_Context
29063 (Parent_Spec
(Unit
(Library_Unit
(Curr
))));
29065 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Curr
)));
29071 end Unit_Is_Visible
;
29073 ------------------------------
29074 -- Universal_Interpretation --
29075 ------------------------------
29077 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
29078 Index
: Interp_Index
;
29082 -- The argument may be a formal parameter of an operator or subprogram
29083 -- with multiple interpretations, or else an expression for an actual.
29085 if Nkind
(Opnd
) = N_Defining_Identifier
29086 or else not Is_Overloaded
(Opnd
)
29088 if Is_Universal_Numeric_Type
(Etype
(Opnd
)) then
29089 return Etype
(Opnd
);
29095 Get_First_Interp
(Opnd
, Index
, It
);
29096 while Present
(It
.Typ
) loop
29097 if Is_Universal_Numeric_Type
(It
.Typ
) then
29101 Get_Next_Interp
(Index
, It
);
29106 end Universal_Interpretation
;
29112 function Unqualify
(Expr
: Node_Id
) return Node_Id
is
29114 -- Recurse to handle unlikely case of multiple levels of qualification
29116 if Nkind
(Expr
) = N_Qualified_Expression
then
29117 return Unqualify
(Expression
(Expr
));
29119 -- Normal case, not a qualified expression
29130 function Unqual_Conv
(Expr
: Node_Id
) return Node_Id
is
29132 -- Recurse to handle unlikely case of multiple levels of qualification
29133 -- and/or conversion.
29135 if Nkind
(Expr
) in N_Qualified_Expression
29136 | N_Type_Conversion
29137 | N_Unchecked_Type_Conversion
29139 return Unqual_Conv
(Expression
(Expr
));
29141 -- Normal case, not a qualified expression
29148 --------------------
29149 -- Validated_View --
29150 --------------------
29152 function Validated_View
(Typ
: Entity_Id
) return Entity_Id
is
29154 -- Scalar types can be always validated. In fast, switiching to the base
29155 -- type would drop the range constraints and force validation to use a
29156 -- larger type than necessary.
29158 if Is_Scalar_Type
(Typ
) then
29161 -- Array types can be validated even when they are derived, because
29162 -- validation only requires their bounds and component types to be
29163 -- accessible. In fact, switching to the parent type would pollute
29164 -- expansion of attribute Valid_Scalars with unnecessary conversion
29165 -- that might not be eliminated by the frontend.
29167 elsif Is_Array_Type
(Typ
) then
29170 -- For other types, in particular for record subtypes, we switch to the
29173 elsif not Is_Base_Type
(Typ
) then
29174 return Validated_View
(Base_Type
(Typ
));
29176 -- Obtain the full view of the input type by stripping away concurrency,
29177 -- derivations, and privacy.
29179 elsif Is_Concurrent_Type
(Typ
) then
29180 if Present
(Corresponding_Record_Type
(Typ
)) then
29181 return Corresponding_Record_Type
(Typ
);
29186 elsif Is_Derived_Type
(Typ
) then
29187 return Validated_View
(Etype
(Typ
));
29189 elsif Is_Private_Type
(Typ
) then
29190 if Present
(Underlying_Full_View
(Typ
)) then
29191 return Validated_View
(Underlying_Full_View
(Typ
));
29193 elsif Present
(Full_View
(Typ
)) then
29194 return Validated_View
(Full_View
(Typ
));
29202 end Validated_View
;
29204 -----------------------
29205 -- Visible_Ancestors --
29206 -----------------------
29208 function Visible_Ancestors
(Typ
: Entity_Id
) return Elist_Id
is
29214 pragma Assert
(Is_Record_Type
(Typ
) and then Is_Tagged_Type
(Typ
));
29216 -- Collect all the parents and progenitors of Typ. If the full-view of
29217 -- private parents and progenitors is available then it is used to
29218 -- generate the list of visible ancestors; otherwise their partial
29219 -- view is added to the resulting list.
29224 Use_Full_View
=> True);
29228 Ifaces_List
=> List_2
,
29229 Exclude_Parents
=> True,
29230 Use_Full_View
=> True);
29232 -- Join the two lists. Avoid duplications because an interface may
29233 -- simultaneously be parent and progenitor of a type.
29235 Elmt
:= First_Elmt
(List_2
);
29236 while Present
(Elmt
) loop
29237 Append_Unique_Elmt
(Node
(Elmt
), List_1
);
29242 end Visible_Ancestors
;
29244 ---------------------------
29245 -- Warn_On_Hiding_Entity --
29246 ---------------------------
29248 procedure Warn_On_Hiding_Entity
29250 Hidden
, Visible
: Entity_Id
;
29251 On_Use_Clause
: Boolean)
29254 -- Don't warn for record components since they always have a well
29255 -- defined scope which does not confuse other uses. Note that in
29256 -- some cases, Ekind has not been set yet.
29258 if Ekind
(Hidden
) /= E_Component
29259 and then Ekind
(Hidden
) /= E_Discriminant
29260 and then Nkind
(Parent
(Hidden
)) /= N_Component_Declaration
29261 and then Ekind
(Visible
) /= E_Component
29262 and then Ekind
(Visible
) /= E_Discriminant
29263 and then Nkind
(Parent
(Visible
)) /= N_Component_Declaration
29265 -- Don't warn for one character variables. It is too common to use
29266 -- such variables as locals and will just cause too many false hits.
29268 and then Length_Of_Name
(Chars
(Hidden
)) /= 1
29270 -- Don't warn for non-source entities
29272 and then Comes_From_Source
(Hidden
)
29273 and then Comes_From_Source
(Visible
)
29275 -- Don't warn within a generic instantiation
29277 and then not In_Instance
29279 -- Don't warn unless entity in question is in extended main source
29281 and then In_Extended_Main_Source_Unit
(Visible
)
29283 -- Finally, in the case of a declaration, the hidden entity must
29284 -- be either immediately visible or use visible (i.e. from a used
29285 -- package). In the case of a use clause, the visible entity must
29286 -- be immediately visible.
29289 (if On_Use_Clause
then
29290 Is_Immediately_Visible
(Visible
)
29292 (Is_Immediately_Visible
(Hidden
)
29294 Is_Potentially_Use_Visible
(Hidden
)))
29296 if On_Use_Clause
then
29297 Error_Msg_Sloc
:= Sloc
(Visible
);
29298 Error_Msg_NE
("visible declaration of&# hides homonym "
29299 & "from use clause?h?", N
, Hidden
);
29301 Error_Msg_Sloc
:= Sloc
(Hidden
);
29302 Error_Msg_NE
("declaration hides &#?h?", N
, Visible
);
29305 end Warn_On_Hiding_Entity
;
29307 ----------------------
29308 -- Within_Init_Proc --
29309 ----------------------
29311 function Within_Init_Proc
return Boolean is
29315 S
:= Current_Scope
;
29316 while not Is_Overloadable
(S
) loop
29317 if S
= Standard_Standard
then
29324 return Is_Init_Proc
(S
);
29325 end Within_Init_Proc
;
29327 ---------------------------
29328 -- Within_Protected_Type --
29329 ---------------------------
29331 function Within_Protected_Type
(E
: Entity_Id
) return Boolean is
29332 Scop
: Entity_Id
:= Scope
(E
);
29335 while Present
(Scop
) loop
29336 if Ekind
(Scop
) = E_Protected_Type
then
29340 Scop
:= Scope
(Scop
);
29344 end Within_Protected_Type
;
29350 function Within_Scope
(E
: Entity_Id
; S
: Entity_Id
) return Boolean is
29352 return Scope_Within_Or_Same
(Scope
(E
), S
);
29359 procedure Wrong_Type
(Expr
: Node_Id
; Expected_Type
: Entity_Id
) is
29360 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
29361 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
29363 Err_Msg_Exp_Typ
: Entity_Id
:= Expected_Type
;
29364 -- Type entity used when printing errors concerning the expected type
29366 Matching_Field
: Entity_Id
;
29367 -- Entity to give a more precise suggestion on how to write a one-
29368 -- element positional aggregate.
29370 function Has_One_Matching_Field
return Boolean;
29371 -- Determines if Expec_Type is a record type with a single component or
29372 -- discriminant whose type matches the found type or is one dimensional
29373 -- array whose component type matches the found type. In the case of
29374 -- one discriminant, we ignore the variant parts. That's not accurate,
29375 -- but good enough for the warning.
29377 ----------------------------
29378 -- Has_One_Matching_Field --
29379 ----------------------------
29381 function Has_One_Matching_Field
return Boolean is
29385 Matching_Field
:= Empty
;
29387 if Is_Array_Type
(Expec_Type
)
29388 and then Number_Dimensions
(Expec_Type
) = 1
29389 and then Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
29391 -- Use type name if available. This excludes multidimensional
29392 -- arrays and anonymous arrays.
29394 if Comes_From_Source
(Expec_Type
) then
29395 Matching_Field
:= Expec_Type
;
29397 -- For an assignment, use name of target
29399 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
29400 and then Is_Entity_Name
(Name
(Parent
(Expr
)))
29402 Matching_Field
:= Entity
(Name
(Parent
(Expr
)));
29407 elsif not Is_Record_Type
(Expec_Type
) then
29411 E
:= First_Entity
(Expec_Type
);
29416 elsif Ekind
(E
) not in E_Discriminant | E_Component
29417 or else Chars
(E
) in Name_uTag | Name_uParent
29426 if not Covers
(Etype
(E
), Found_Type
) then
29429 elsif Present
(Next_Entity
(E
))
29430 and then (Ekind
(E
) = E_Component
29431 or else Ekind
(Next_Entity
(E
)) = E_Discriminant
)
29436 Matching_Field
:= E
;
29440 end Has_One_Matching_Field
;
29442 -- Start of processing for Wrong_Type
29445 -- Don't output message if either type is Any_Type, or if a message
29446 -- has already been posted for this node. We need to do the latter
29447 -- check explicitly (it is ordinarily done in Errout), because we
29448 -- are using ! to force the output of the error messages.
29450 if Expec_Type
= Any_Type
29451 or else Found_Type
= Any_Type
29452 or else Error_Posted
(Expr
)
29456 -- If one of the types is a Taft-Amendment type and the other it its
29457 -- completion, it must be an illegal use of a TAT in the spec, for
29458 -- which an error was already emitted. Avoid cascaded errors.
29460 elsif Is_Incomplete_Type
(Expec_Type
)
29461 and then Has_Completion_In_Body
(Expec_Type
)
29462 and then Full_View
(Expec_Type
) = Etype
(Expr
)
29466 elsif Is_Incomplete_Type
(Etype
(Expr
))
29467 and then Has_Completion_In_Body
(Etype
(Expr
))
29468 and then Full_View
(Etype
(Expr
)) = Expec_Type
29472 -- In an instance, there is an ongoing problem with completion of
29473 -- types derived from private types. Their structure is what Gigi
29474 -- expects, but the Etype is the parent type rather than the derived
29475 -- private type itself. Do not flag error in this case. The private
29476 -- completion is an entity without a parent, like an Itype. Similarly,
29477 -- full and partial views may be incorrect in the instance.
29478 -- There is no simple way to insure that it is consistent ???
29480 -- A similar view discrepancy can happen in an inlined body, for the
29481 -- same reason: inserted body may be outside of the original package
29482 -- and only partial views are visible at the point of insertion.
29484 -- If In_Generic_Actual (Expr) is True then we cannot assume that
29485 -- the successful semantic analysis of the generic guarantees anything
29486 -- useful about type checking of this instance, so we ignore
29487 -- In_Instance in that case. There may be cases where this is not
29488 -- right (the symptom would probably be rejecting something
29489 -- that ought to be accepted) but we don't currently have any
29490 -- concrete examples of this.
29492 elsif (In_Instance
and then not In_Generic_Actual
(Expr
))
29493 or else In_Inlined_Body
29495 if Etype
(Etype
(Expr
)) = Etype
(Expected_Type
)
29497 (Has_Private_Declaration
(Expected_Type
)
29498 or else Has_Private_Declaration
(Etype
(Expr
)))
29499 and then No
(Parent
(Expected_Type
))
29503 elsif Nkind
(Parent
(Expr
)) = N_Qualified_Expression
29504 and then Entity
(Subtype_Mark
(Parent
(Expr
))) = Expected_Type
29508 elsif Is_Private_Type
(Expected_Type
)
29509 and then Present
(Full_View
(Expected_Type
))
29510 and then Covers
(Full_View
(Expected_Type
), Etype
(Expr
))
29514 -- Conversely, type of expression may be the private one
29516 elsif Is_Private_Type
(Base_Type
(Etype
(Expr
)))
29517 and then Full_View
(Base_Type
(Etype
(Expr
))) = Expected_Type
29523 -- Avoid printing internally generated subtypes in error messages and
29524 -- instead use the corresponding first subtype in such cases.
29526 if not Comes_From_Source
(Err_Msg_Exp_Typ
)
29527 or else not Comes_From_Source
(Declaration_Node
(Err_Msg_Exp_Typ
))
29529 Err_Msg_Exp_Typ
:= First_Subtype
(Err_Msg_Exp_Typ
);
29532 -- An interesting special check. If the expression is parenthesized
29533 -- and its type corresponds to the type of the sole component of the
29534 -- expected record type, or to the component type of the expected one
29535 -- dimensional array type, then assume we have a bad aggregate attempt.
29537 if Nkind
(Expr
) in N_Subexpr
29538 and then Paren_Count
(Expr
) /= 0
29539 and then Has_One_Matching_Field
29541 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
29543 if Present
(Matching_Field
) then
29544 if Is_Array_Type
(Expec_Type
) then
29546 ("\write instead `&''First ='> ...`", Expr
, Matching_Field
);
29549 ("\write instead `& ='> ...`", Expr
, Matching_Field
);
29553 -- Another special check, if we are looking for a pool-specific access
29554 -- type and we found an E_Access_Attribute_Type, then we have the case
29555 -- of an Access attribute being used in a context which needs a pool-
29556 -- specific type, which is never allowed. The one extra check we make
29557 -- is that the expected designated type covers the Found_Type.
29559 elsif Is_Access_Type
(Expec_Type
)
29560 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
29561 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
29562 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
29564 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
29567 ("result must be general access type!", Expr
);
29568 Error_Msg_NE
-- CODEFIX
29569 ("\add ALL to }!", Expr
, Err_Msg_Exp_Typ
);
29571 -- Another special check, if the expected type is an integer type,
29572 -- but the expression is of type System.Address, and the parent is
29573 -- an addition or subtraction operation whose left operand is the
29574 -- expression in question and whose right operand is of an integral
29575 -- type, then this is an attempt at address arithmetic, so give
29576 -- appropriate message.
29578 elsif Is_Integer_Type
(Expec_Type
)
29579 and then Is_RTE
(Found_Type
, RE_Address
)
29580 and then Nkind
(Parent
(Expr
)) in N_Op_Add | N_Op_Subtract
29581 and then Expr
= Left_Opnd
(Parent
(Expr
))
29582 and then Is_Integer_Type
(Etype
(Right_Opnd
(Parent
(Expr
))))
29585 ("address arithmetic not predefined in package System",
29588 ("\possible missing with/use of System.Storage_Elements",
29592 -- If the expected type is an anonymous access type, as for access
29593 -- parameters and discriminants, the error is on the designated types.
29595 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
29596 if Comes_From_Source
(Expec_Type
) then
29597 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
29600 ("expected an access type with designated}",
29601 Expr
, Designated_Type
(Expec_Type
));
29604 if Is_Access_Type
(Found_Type
)
29605 and then not Comes_From_Source
(Found_Type
)
29608 ("\\found an access type with designated}!",
29609 Expr
, Designated_Type
(Found_Type
));
29611 if From_Limited_With
(Found_Type
) then
29612 Error_Msg_NE
("\\found incomplete}!", Expr
, Found_Type
);
29613 Error_Msg_Qual_Level
:= 99;
29614 Error_Msg_NE
-- CODEFIX
29615 ("\\missing `WITH &;", Expr
, Scope
(Found_Type
));
29616 Error_Msg_Qual_Level
:= 0;
29618 Error_Msg_NE
("found}!", Expr
, Found_Type
);
29622 -- Normal case of one type found, some other type expected
29625 -- If the names of the two types are the same, see if some number
29626 -- of levels of qualification will help. Don't try more than three
29627 -- levels, and if we get to standard, it's no use (and probably
29628 -- represents an error in the compiler) Also do not bother with
29629 -- internal scope names.
29632 Expec_Scope
: Entity_Id
;
29633 Found_Scope
: Entity_Id
;
29636 Expec_Scope
:= Expec_Type
;
29637 Found_Scope
:= Found_Type
;
29639 for Levels
in Nat
range 0 .. 3 loop
29640 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
29641 Error_Msg_Qual_Level
:= Levels
;
29645 Expec_Scope
:= Scope
(Expec_Scope
);
29646 Found_Scope
:= Scope
(Found_Scope
);
29648 exit when Expec_Scope
= Standard_Standard
29649 or else Found_Scope
= Standard_Standard
29650 or else not Comes_From_Source
(Expec_Scope
)
29651 or else not Comes_From_Source
(Found_Scope
);
29655 if Is_Record_Type
(Expec_Type
)
29656 and then Present
(Corresponding_Remote_Type
(Expec_Type
))
29658 Error_Msg_NE
("expected}!", Expr
,
29659 Corresponding_Remote_Type
(Expec_Type
));
29661 Error_Msg_NE
("expected}!", Expr
, Err_Msg_Exp_Typ
);
29664 if Is_Entity_Name
(Expr
)
29665 and then Is_Package_Or_Generic_Package
(Entity
(Expr
))
29667 Error_Msg_N
("\\found package name!", Expr
);
29669 elsif Is_Entity_Name
(Expr
)
29670 and then Ekind
(Entity
(Expr
)) in E_Procedure | E_Generic_Procedure
29672 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
29674 ("found procedure name, possibly missing Access attribute!",
29678 ("\\found procedure name instead of function!", Expr
);
29681 elsif Nkind
(Expr
) = N_Function_Call
29682 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
29683 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
29684 and then No
(Parameter_Associations
(Expr
))
29687 ("found function name, possibly missing Access attribute!",
29690 -- Catch common error: a prefix or infix operator which is not
29691 -- directly visible because the type isn't.
29693 elsif Nkind
(Expr
) in N_Op
29694 and then Is_Overloaded
(Expr
)
29695 and then not Is_Immediately_Visible
(Expec_Type
)
29696 and then not Is_Potentially_Use_Visible
(Expec_Type
)
29697 and then not In_Use
(Expec_Type
)
29698 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
29701 ("operator of the type is not directly visible!", Expr
);
29703 elsif Ekind
(Found_Type
) = E_Void
29704 and then Present
(Parent
(Found_Type
))
29705 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
29707 Error_Msg_NE
("\\found premature usage of}!", Expr
, Found_Type
);
29710 Error_Msg_NE
("\\found}!", Expr
, Found_Type
);
29713 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
29714 -- of the same modular type, and (M1 and M2) = 0 was intended.
29716 if Expec_Type
= Standard_Boolean
29717 and then Is_Modular_Integer_Type
(Found_Type
)
29718 and then Nkind
(Parent
(Expr
)) in N_Op_And | N_Op_Or | N_Op_Xor
29719 and then Nkind
(Right_Opnd
(Parent
(Expr
))) in N_Op_Compare
29722 Op
: constant Node_Id
:= Right_Opnd
(Parent
(Expr
));
29723 L
: constant Node_Id
:= Left_Opnd
(Op
);
29724 R
: constant Node_Id
:= Right_Opnd
(Op
);
29727 -- The case for the message is when the left operand of the
29728 -- comparison is the same modular type, or when it is an
29729 -- integer literal (or other universal integer expression),
29730 -- which would have been typed as the modular type if the
29731 -- parens had been there.
29733 if (Etype
(L
) = Found_Type
29735 Etype
(L
) = Universal_Integer
)
29736 and then Is_Integer_Type
(Etype
(R
))
29739 ("\\possible missing parens for modular operation", Expr
);
29744 -- Reset error message qualification indication
29746 Error_Msg_Qual_Level
:= 0;
29750 --------------------------------
29751 -- Yields_Synchronized_Object --
29752 --------------------------------
29754 function Yields_Synchronized_Object
(Typ
: Entity_Id
) return Boolean is
29755 Has_Sync_Comp
: Boolean := False;
29759 -- An array type yields a synchronized object if its component type
29760 -- yields a synchronized object.
29762 if Is_Array_Type
(Typ
) then
29763 return Yields_Synchronized_Object
(Component_Type
(Typ
));
29765 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object
29766 -- yields a synchronized object by default.
29768 elsif Is_Descendant_Of_Suspension_Object
(Typ
) then
29771 -- A protected type yields a synchronized object by default
29773 elsif Is_Protected_Type
(Typ
) then
29776 -- A record type or type extension yields a synchronized object when its
29777 -- discriminants (if any) lack default values and all components are of
29778 -- a type that yields a synchronized object.
29780 elsif Is_Record_Type
(Typ
) then
29782 -- Inspect all entities defined in the scope of the type, looking for
29783 -- components of a type that does not yield a synchronized object or
29784 -- for discriminants with default values.
29786 Id
:= First_Entity
(Typ
);
29787 while Present
(Id
) loop
29788 if Comes_From_Source
(Id
) then
29789 if Ekind
(Id
) = E_Component
then
29790 if Yields_Synchronized_Object
(Etype
(Id
)) then
29791 Has_Sync_Comp
:= True;
29793 -- The component does not yield a synchronized object
29799 elsif Ekind
(Id
) = E_Discriminant
29800 and then Present
(Expression
(Parent
(Id
)))
29809 -- Ensure that the parent type of a type extension yields a
29810 -- synchronized object.
29812 if Etype
(Typ
) /= Typ
29813 and then not Is_Private_Type
(Etype
(Typ
))
29814 and then not Yields_Synchronized_Object
(Etype
(Typ
))
29819 -- If we get here, then all discriminants lack default values and all
29820 -- components are of a type that yields a synchronized object.
29822 return Has_Sync_Comp
;
29824 -- A synchronized interface type yields a synchronized object by default
29826 elsif Is_Synchronized_Interface
(Typ
) then
29829 -- A task type yields a synchronized object by default
29831 elsif Is_Task_Type
(Typ
) then
29834 -- A private type yields a synchronized object if its underlying type
29837 elsif Is_Private_Type
(Typ
)
29838 and then Present
(Underlying_Type
(Typ
))
29840 return Yields_Synchronized_Object
(Underlying_Type
(Typ
));
29842 -- Otherwise the type does not yield a synchronized object
29847 end Yields_Synchronized_Object
;
29849 ---------------------------
29850 -- Yields_Universal_Type --
29851 ---------------------------
29853 function Yields_Universal_Type
(N
: Node_Id
) return Boolean is
29855 -- Integer and real literals are of a universal type
29857 if Nkind
(N
) in N_Integer_Literal | N_Real_Literal
then
29860 -- The values of certain attributes are of a universal type
29862 elsif Nkind
(N
) = N_Attribute_Reference
then
29864 Universal_Type_Attribute
(Get_Attribute_Id
(Attribute_Name
(N
)));
29866 -- ??? There are possibly other cases to consider
29871 end Yields_Universal_Type
;
29873 package body Interval_Lists
is
29875 procedure Check_Consistency
(Intervals
: Discrete_Interval_List
);
29876 -- Check that list is sorted, lacks null intervals, and has gaps
29877 -- between intervals.
29879 function Chosen_Interval
(Choice
: Node_Id
) return Discrete_Interval
;
29880 -- Given an element of a Discrete_Choices list, a
29881 -- Static_Discrete_Predicate list, or an Others_Discrete_Choices
29882 -- list (but not an N_Others_Choice node) return the corresponding
29883 -- interval. If an element that does not represent a single
29884 -- contiguous interval due to a static predicate (or which
29885 -- represents a single contiguous interval whose bounds depend on
29886 -- a static predicate) is encountered, then that is an error on the
29887 -- part of whoever built the list in question.
29889 function In_Interval
29890 (Value
: Uint
; Interval
: Discrete_Interval
) return Boolean;
29891 -- Does the given value lie within the given interval?
29893 procedure Normalize_Interval_List
29894 (List
: in out Discrete_Interval_List
; Last
: out Nat
);
29895 -- Perform sorting and merging as required by Check_Consistency
29897 -------------------------
29898 -- Aggregate_Intervals --
29899 -------------------------
29901 function Aggregate_Intervals
(N
: Node_Id
) return Discrete_Interval_List
29903 pragma Assert
(Nkind
(N
) = N_Aggregate
29904 and then Is_Array_Type
(Etype
(N
)));
29906 function Unmerged_Intervals_Count
return Nat
;
29907 -- Count the number of intervals given in the aggregate N; the others
29908 -- choice (if present) is not taken into account.
29910 ------------------------------
29911 -- Unmerged_Intervals_Count --
29912 ------------------------------
29914 function Unmerged_Intervals_Count
return Nat
is
29919 Comp
:= First
(Component_Associations
(N
));
29920 while Present
(Comp
) loop
29921 Choice
:= First
(Choices
(Comp
));
29923 while Present
(Choice
) loop
29924 if Nkind
(Choice
) /= N_Others_Choice
then
29925 Count
:= Count
+ 1;
29935 end Unmerged_Intervals_Count
;
29940 Max_I
: constant Nat
:= Unmerged_Intervals_Count
;
29941 Intervals
: Discrete_Interval_List
(1 .. Max_I
);
29944 -- Start of processing for Aggregate_Intervals
29947 -- No action needed if there are no intervals
29953 -- Internally store all the unsorted intervals
29955 Comp
:= First
(Component_Associations
(N
));
29956 while Present
(Comp
) loop
29958 Choice_Intervals
: constant Discrete_Interval_List
29959 := Choice_List_Intervals
(Choices
(Comp
));
29961 for J
in Choice_Intervals
'Range loop
29962 Num_I
:= Num_I
+ 1;
29963 Intervals
(Num_I
) := Choice_Intervals
(J
);
29970 -- Normalize the lists sorting and merging the intervals
29973 Aggr_Intervals
: Discrete_Interval_List
(1 .. Num_I
)
29974 := Intervals
(1 .. Num_I
);
29976 Normalize_Interval_List
(Aggr_Intervals
, Num_I
);
29977 Check_Consistency
(Aggr_Intervals
(1 .. Num_I
));
29978 return Aggr_Intervals
(1 .. Num_I
);
29980 end Aggregate_Intervals
;
29982 ------------------------
29983 -- Check_Consistency --
29984 ------------------------
29986 procedure Check_Consistency
(Intervals
: Discrete_Interval_List
) is
29988 if Serious_Errors_Detected
> 0 then
29992 -- low bound is 1 and high bound equals length
29993 pragma Assert
(Intervals
'First = 1 and Intervals
'Last >= 0);
29994 for Idx
in Intervals
'Range loop
29995 -- each interval is non-null
29996 pragma Assert
(Intervals
(Idx
).Low
<= Intervals
(Idx
).High
);
29997 if Idx
/= Intervals
'First then
29998 -- intervals are sorted with non-empty gaps between them
30000 (Intervals
(Idx
- 1).High
< (Intervals
(Idx
).Low
- 1));
30004 end Check_Consistency
;
30006 ---------------------------
30007 -- Choice_List_Intervals --
30008 ---------------------------
30010 function Choice_List_Intervals
30011 (Discrete_Choices
: List_Id
) return Discrete_Interval_List
30013 function Unmerged_Choice_Count
return Nat
;
30014 -- The number of intervals before adjacent intervals are merged
30016 ---------------------------
30017 -- Unmerged_Choice_Count --
30018 ---------------------------
30020 function Unmerged_Choice_Count
return Nat
is
30021 Choice
: Node_Id
:= First
(Discrete_Choices
);
30024 while Present
(Choice
) loop
30025 -- Non-contiguous choices involving static predicates
30026 -- have already been normalized away.
30028 if Nkind
(Choice
) = N_Others_Choice
then
30030 Count
+ List_Length
(Others_Discrete_Choices
(Choice
));
30032 Count
:= Count
+ 1; -- an ordinary expression or range
30038 end Unmerged_Choice_Count
;
30042 Choice
: Node_Id
:= First
(Discrete_Choices
);
30043 Result
: Discrete_Interval_List
(1 .. Unmerged_Choice_Count
);
30046 -- Start of processing for Choice_List_Intervals
30049 while Present
(Choice
) loop
30050 if Nkind
(Choice
) = N_Others_Choice
then
30052 Others_Choice
: Node_Id
30053 := First
(Others_Discrete_Choices
(Choice
));
30055 while Present
(Others_Choice
) loop
30056 Count
:= Count
+ 1;
30057 Result
(Count
) := Chosen_Interval
(Others_Choice
);
30058 Next
(Others_Choice
);
30062 Count
:= Count
+ 1;
30063 Result
(Count
) := Chosen_Interval
(Choice
);
30069 pragma Assert
(Count
= Result
'Last);
30070 Normalize_Interval_List
(Result
, Count
);
30071 Check_Consistency
(Result
(1 .. Count
));
30072 return Result
(1 .. Count
);
30073 end Choice_List_Intervals
;
30075 ---------------------
30076 -- Chosen_Interval --
30077 ---------------------
30079 function Chosen_Interval
(Choice
: Node_Id
) return Discrete_Interval
is
30081 case Nkind
(Choice
) is
30083 return (Low
=> Expr_Value
(Low_Bound
(Choice
)),
30084 High
=> Expr_Value
(High_Bound
(Choice
)));
30086 when N_Subtype_Indication
=>
30088 Range_Exp
: constant Node_Id
30089 := Range_Expression
(Constraint
(Choice
));
30091 return (Low
=> Expr_Value
(Low_Bound
(Range_Exp
)),
30092 High
=> Expr_Value
(High_Bound
(Range_Exp
)));
30095 when N_Others_Choice
=>
30096 raise Program_Error
;
30099 if Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
))
30102 (Low
=> Expr_Value
(Type_Low_Bound
(Entity
(Choice
))),
30103 High
=> Expr_Value
(Type_High_Bound
(Entity
(Choice
))));
30106 return (Low | High
=> Expr_Value
(Choice
));
30109 end Chosen_Interval
;
30115 function In_Interval
30116 (Value
: Uint
; Interval
: Discrete_Interval
) return Boolean is
30118 return Value
>= Interval
.Low
and then Value
<= Interval
.High
;
30126 (Subset
, Of_Set
: Discrete_Interval_List
) return Boolean
30128 -- Returns True iff for each interval of Subset we can find
30129 -- a single interval of Of_Set which contains the Subset interval.
30131 if Of_Set
'Length = 0 then
30132 return Subset
'Length = 0;
30136 Set_Index
: Pos
range Of_Set
'Range := Of_Set
'First;
30139 for Ss_Idx
in Subset
'Range loop
30140 while not In_Interval
30141 (Value
=> Subset
(Ss_Idx
).Low
,
30142 Interval
=> Of_Set
(Set_Index
))
30144 if Set_Index
= Of_Set
'Last then
30148 Set_Index
:= Set_Index
+ 1;
30152 (Value
=> Subset
(Ss_Idx
).High
,
30153 Interval
=> Of_Set
(Set_Index
))
30163 -----------------------------
30164 -- Normalize_Interval_List --
30165 -----------------------------
30167 procedure Normalize_Interval_List
30168 (List
: in out Discrete_Interval_List
; Last
: out Nat
)
30170 Temp_0
: Discrete_Interval
:= (others => Uint_0
);
30171 -- Cope with Heap_Sort_G idiosyncrasies.
30173 function Is_Null
(Idx
: Pos
) return Boolean;
30174 -- True iff List (Idx) defines a null range
30176 function Lt_Interval
(Idx1
, Idx2
: Natural) return Boolean;
30177 -- Compare two list elements
30179 procedure Merge_Intervals
(Null_Interval_Count
: out Nat
);
30180 -- Merge contiguous ranges by replacing one with merged range and
30181 -- the other with a null value. Return a count of the null intervals,
30182 -- both preexisting and those introduced by merging.
30184 procedure Move_Interval
(From
, To
: Natural);
30185 -- Copy interval from one location to another
30187 function Read_Interval
(From
: Natural) return Discrete_Interval
;
30188 -- Normal array indexing unless From = 0
30190 ----------------------
30191 -- Interval_Sorting --
30192 ----------------------
30194 package Interval_Sorting
is
30195 new Gnat
.Heap_Sort_G
(Move_Interval
, Lt_Interval
);
30201 function Is_Null
(Idx
: Pos
) return Boolean is
30203 return List
(Idx
).Low
> List
(Idx
).High
;
30210 function Lt_Interval
(Idx1
, Idx2
: Natural) return Boolean is
30211 Elem1
: constant Discrete_Interval
:= Read_Interval
(Idx1
);
30212 Elem2
: constant Discrete_Interval
:= Read_Interval
(Idx2
);
30213 Null_1
: constant Boolean := Elem1
.Low
> Elem1
.High
;
30214 Null_2
: constant Boolean := Elem2
.Low
> Elem2
.High
;
30216 if Null_1
/= Null_2
then
30217 -- So that sorting moves null intervals to high end
30220 elsif Elem1
.Low
/= Elem2
.Low
then
30221 return Elem1
.Low
< Elem2
.Low
;
30224 return Elem1
.High
< Elem2
.High
;
30228 ---------------------
30229 -- Merge_Intervals --
30230 ---------------------
30232 procedure Merge_Intervals
(Null_Interval_Count
: out Nat
) is
30233 Not_Null
: Pos
range List
'Range;
30234 -- Index of the most recently examined non-null interval
30236 Null_Interval
: constant Discrete_Interval
30237 := (Low
=> Uint_1
, High
=> Uint_0
); -- any null range ok here
30239 if List
'Length = 0 or else Is_Null
(List
'First) then
30240 Null_Interval_Count
:= List
'Length;
30241 -- no non-null elements, so no merge candidates
30245 Null_Interval_Count
:= 0;
30246 Not_Null
:= List
'First;
30248 for Idx
in List
'First + 1 .. List
'Last loop
30249 if Is_Null
(Idx
) then
30251 -- all remaining elements are null
30253 Null_Interval_Count
:=
30254 Null_Interval_Count
+ List
(Idx
.. List
'Last)'Length;
30257 elsif List
(Idx
).Low
= List
(Not_Null
).High
+ 1 then
30259 -- Merge the two intervals into one; discard the other
30261 List
(Not_Null
).High
:= List
(Idx
).High
;
30262 List
(Idx
) := Null_Interval
;
30263 Null_Interval_Count
:= Null_Interval_Count
+ 1;
30266 if List
(Idx
).Low
<= List
(Not_Null
).High
then
30267 raise Intervals_Error
;
30270 pragma Assert
(List
(Idx
).Low
> List
(Not_Null
).High
);
30274 end Merge_Intervals
;
30276 -------------------
30277 -- Move_Interval --
30278 -------------------
30280 procedure Move_Interval
(From
, To
: Natural) is
30281 Rhs
: constant Discrete_Interval
:= Read_Interval
(From
);
30286 List
(Pos
(To
)) := Rhs
;
30290 -------------------
30291 -- Read_Interval --
30292 -------------------
30294 function Read_Interval
(From
: Natural) return Discrete_Interval
is
30299 return List
(Pos
(From
));
30303 -- Start of processing for Normalize_Interval_Lists
30306 Interval_Sorting
.Sort
(Natural (List
'Last));
30309 Null_Interval_Count
: Nat
;
30312 Merge_Intervals
(Null_Interval_Count
);
30313 Last
:= List
'Last - Null_Interval_Count
;
30315 if Null_Interval_Count
/= 0 then
30316 -- Move null intervals introduced during merging to high end
30317 Interval_Sorting
.Sort
(Natural (List
'Last));
30320 end Normalize_Interval_List
;
30322 --------------------
30323 -- Type_Intervals --
30324 --------------------
30326 function Type_Intervals
(Typ
: Entity_Id
) return Discrete_Interval_List
30329 if Has_Static_Predicate
(Typ
) then
30331 -- No sorting or merging needed
30332 SDP_List
: constant List_Id
:= Static_Discrete_Predicate
(Typ
);
30333 Range_Or_Expr
: Node_Id
:= First
(SDP_List
);
30334 Result
: Discrete_Interval_List
(1 .. List_Length
(SDP_List
));
30337 for Idx
in Result
'Range loop
30338 Result
(Idx
) := Chosen_Interval
(Range_Or_Expr
);
30339 Next
(Range_Or_Expr
);
30342 pragma Assert
(No
(Range_Or_Expr
));
30343 Check_Consistency
(Result
);
30348 Low
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Typ
));
30349 High
: constant Uint
:= Expr_Value
(Type_High_Bound
(Typ
));
30353 Null_Array
: Discrete_Interval_List
(1 .. 0);
30358 return (1 => (Low
=> Low
, High
=> High
));
30362 end Type_Intervals
;
30364 end Interval_Lists
;
30366 package body Old_Attr_Util
is
30367 package body Conditional_Evaluation
is
30368 type Determining_Expr_Context
is
30369 (No_Context
, If_Expr
, Case_Expr
, Short_Circuit_Op
, Membership_Test
);
30371 -- Determining_Expr_Context enumeration elements (except for
30372 -- No_Context) correspond to the list items in RM 6.1.1 definition
30373 -- of "determining expression".
30375 type Determining_Expr
30376 (Context
: Determining_Expr_Context
:= No_Context
)
30378 Expr
: Node_Id
:= Empty
;
30380 when Short_Circuit_Op
=>
30381 Is_And_Then
: Boolean;
30383 Is_Then_Part
: Boolean;
30385 Alternatives
: Node_Id
;
30386 when Membership_Test
=>
30387 -- Given a subexpression of <exp4> in a membership test
30388 -- <exp1> in <exp2> | <exp3> | <exp4> | <exp5>
30389 -- the corresponding determining expression value would
30390 -- have First_Non_Preceding = <exp4> (See RM 6.1.1).
30391 First_Non_Preceding
: Node_Id
;
30397 type Determining_Expression_List
is
30398 array (Positive range <>) of Determining_Expr
;
30400 function Determining_Condition
(Det
: Determining_Expr
)
30402 -- Given a determining expression, build a Boolean-valued
30403 -- condition that incorporates that expression into condition
30404 -- suitable for deciding whether to initialize a 'Old constant.
30405 -- Polarity is "True => initialize the constant".
30407 function Determining_Expressions
30408 (Expr
: Node_Id
; Expr_Trailer
: Node_Id
:= Empty
)
30409 return Determining_Expression_List
;
30410 -- Given a conditionally evaluated expression, return its
30411 -- determining expressions.
30412 -- See RM 6.1.1 for definition of term "determining expressions".
30413 -- Tests should be performed in the order they occur in the
30414 -- array, with short circuiting.
30415 -- A determining expression need not be of a boolean type (e.g.,
30416 -- it might be the determining expression of a case expression).
30417 -- The Expr_Trailer parameter should be defaulted for nonrecursive
30420 function Is_Conditionally_Evaluated
(Expr
: Node_Id
) return Boolean;
30421 -- See RM 6.1.1 for definition of term "conditionally evaluated".
30423 function Is_Known_On_Entry
(Expr
: Node_Id
) return Boolean;
30424 -- See RM 6.1.1 for definition of term "known on entry".
30426 --------------------------------------
30427 -- Conditional_Evaluation_Condition --
30428 --------------------------------------
30430 function Conditional_Evaluation_Condition
30431 (Expr
: Node_Id
) return Node_Id
30433 Determiners
: constant Determining_Expression_List
:=
30434 Determining_Expressions
(Expr
);
30435 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
30436 Result
: Node_Id
:=
30437 New_Occurrence_Of
(Standard_True
, Loc
);
30439 pragma Assert
(Determiners
'Length > 0 or else
30440 Is_Anonymous_Access_Type
(Etype
(Expr
)));
30442 for I
in Determiners
'Range loop
30443 Result
:= Make_And_Then
30445 Left_Opnd
=> Result
,
30447 Determining_Condition
(Determiners
(I
)));
30450 end Conditional_Evaluation_Condition
;
30452 ---------------------------
30453 -- Determining_Condition --
30454 ---------------------------
30456 function Determining_Condition
(Det
: Determining_Expr
) return Node_Id
30458 Loc
: constant Source_Ptr
:= Sloc
(Det
.Expr
);
30460 case Det
.Context
is
30461 when Short_Circuit_Op
=>
30462 if Det
.Is_And_Then
then
30463 return New_Copy_Tree
(Det
.Expr
);
30465 return Make_Op_Not
(Loc
, New_Copy_Tree
(Det
.Expr
));
30469 if Det
.Is_Then_Part
then
30470 return New_Copy_Tree
(Det
.Expr
);
30472 return Make_Op_Not
(Loc
, New_Copy_Tree
(Det
.Expr
));
30477 Alts
: List_Id
:= Discrete_Choices
(Det
.Alternatives
);
30479 if Nkind
(First
(Alts
)) = N_Others_Choice
then
30480 Alts
:= Others_Discrete_Choices
(First
(Alts
));
30483 return Make_In
(Loc
,
30484 Left_Opnd
=> New_Copy_Tree
(Det
.Expr
),
30485 Right_Opnd
=> Empty
,
30486 Alternatives
=> New_Copy_List
(Alts
));
30489 when Membership_Test
=>
30491 function Copy_Prefix
30492 (List
: List_Id
; Suffix_Start
: Node_Id
)
30494 -- Given a list and a member of that list, returns
30495 -- a copy (similar to Nlists.New_Copy_List) of the
30496 -- prefix of the list up to but not including
30503 function Copy_Prefix
30504 (List
: List_Id
; Suffix_Start
: Node_Id
)
30507 Result
: constant List_Id
:= New_List
;
30508 Elem
: Node_Id
:= First
(List
);
30510 while Elem
/= Suffix_Start
loop
30511 Append
(New_Copy
(Elem
), Result
);
30513 pragma Assert
(Present
(Elem
));
30519 return Make_In
(Loc
,
30520 Left_Opnd
=> New_Copy_Tree
(Left_Opnd
(Det
.Expr
)),
30521 Right_Opnd
=> Empty
,
30522 Alternatives
=> Copy_Prefix
30523 (Alternatives
(Det
.Expr
),
30524 Det
.First_Non_Preceding
));
30528 raise Program_Error
;
30530 end Determining_Condition
;
30532 -----------------------------
30533 -- Determining_Expressions --
30534 -----------------------------
30536 function Determining_Expressions
30537 (Expr
: Node_Id
; Expr_Trailer
: Node_Id
:= Empty
)
30538 return Determining_Expression_List
30540 Par
: Node_Id
:= Expr
;
30541 Trailer
: Node_Id
:= Expr_Trailer
;
30542 Next_Element
: Determining_Expr
;
30544 -- We want to stop climbing up the tree when we reach the
30545 -- postcondition expression. An aspect_specification is
30546 -- transformed into a pragma, so reaching a pragma is our
30547 -- termination condition. This relies on the fact that
30548 -- pragmas are not allowed in declare expressions (or any
30549 -- other kind of expression).
30552 Next_Element
.Expr
:= Empty
;
30554 case Nkind
(Par
) is
30555 when N_Short_Circuit
=>
30556 if Trailer
= Right_Opnd
(Par
) then
30558 (Expr
=> Left_Opnd
(Par
),
30559 Context
=> Short_Circuit_Op
,
30560 Is_And_Then
=> Nkind
(Par
) = N_And_Then
);
30563 when N_If_Expression
=>
30564 -- For an expression like
30565 -- (if C1 then ... elsif C2 then ... else Foo'Old)
30566 -- the RM says are two determining expressions,
30567 -- C1 and C2. Our treatment here (where we only add
30568 -- one determining expression to the list) is ok because
30569 -- we will see two if-expressions, one within the other.
30571 if Trailer
/= First
(Expressions
(Par
)) then
30573 (Expr
=> First
(Expressions
(Par
)),
30574 Context
=> If_Expr
,
30576 Trailer
= Next
(First
(Expressions
(Par
))));
30579 when N_Case_Expression_Alternative
=>
30580 pragma Assert
(Nkind
(Parent
(Par
)) = N_Case_Expression
);
30583 (Expr
=> Expression
(Parent
(Par
)),
30584 Context
=> Case_Expr
,
30585 Alternatives
=> Par
);
30587 when N_Membership_Test
=>
30588 if Trailer
/= Left_Opnd
(Par
)
30589 and then Is_Non_Empty_List
(Alternatives
(Par
))
30590 and then Trailer
/= First
(Alternatives
(Par
))
30592 pragma Assert
(No
(Right_Opnd
(Par
)));
30594 (Is_List_Member
(Trailer
)
30595 and then List_Containing
(Trailer
)
30596 = Alternatives
(Par
));
30598 -- This one is different than the others
30599 -- because one element in the array result
30600 -- may represent multiple determining
30601 -- expressions (i.e. every member of the list
30602 -- Alternatives (Par)
30603 -- up to but not including Trailer).
30607 Context
=> Membership_Test
,
30608 First_Non_Preceding
=> Trailer
);
30613 Previous
: constant Node_Id
:= Prev
(Par
);
30614 Prev_Expr
: Node_Id
;
30616 if Nkind
(Previous
) = N_Pragma
and then
30617 Split_PPC
(Previous
)
30619 -- A source-level postcondition of
30620 -- A and then B and then C
30622 -- pragma Postcondition (A);
30623 -- pragma Postcondition (B);
30624 -- pragma Postcondition (C);
30625 -- with Split_PPC set to True on all but the
30626 -- last pragma. We account for that here.
30630 (Pragma_Argument_Associations
(Previous
)));
30632 -- This Analyze call is needed in the case when
30633 -- Sem_Attr.Analyze_Attribute calls
30634 -- Eligible_For_Conditional_Evaluation. Without
30635 -- it, we end up passing an unanalyzed expression
30636 -- to Is_Known_On_Entry and that doesn't work.
30638 Analyze
(Prev_Expr
);
30641 (Expr
=> Prev_Expr
,
30642 Context
=> Short_Circuit_Op
,
30643 Is_And_Then
=> True);
30645 return Determining_Expressions
(Prev_Expr
)
30649 (Get_Pragma_Id
(Pragma_Name
(Par
)) in
30650 Pragma_Post | Pragma_Postcondition
30651 | Pragma_Post_Class | Pragma_Refined_Post
30652 | Pragma_Check | Pragma_Contract_Cases
);
30654 return (1 .. 0 => <>); -- recursion terminates here
30659 -- This case should be impossible, but if it does
30660 -- happen somehow then we don't want an infinite loop.
30661 raise Program_Error
;
30668 Par
:= Parent
(Par
);
30670 if Present
(Next_Element
.Expr
) then
30671 return Determining_Expressions
30672 (Expr
=> Par
, Expr_Trailer
=> Trailer
)
30676 end Determining_Expressions
;
30678 -----------------------------------------
30679 -- Eligible_For_Conditional_Evaluation --
30680 -----------------------------------------
30682 function Eligible_For_Conditional_Evaluation
30683 (Expr
: Node_Id
) return Boolean
30686 if Is_Anonymous_Access_Type
(Etype
(Expr
)) then
30687 -- The code in exp_attr.adb that also builds declarations
30688 -- for 'Old constants doesn't handle the anonymous access
30689 -- type case correctly, so we avoid that problem by
30690 -- returning True here.
30693 elsif Ada_Version
< Ada_2022
then
30696 elsif Inside_Class_Condition_Preanalysis
then
30697 -- No need to evaluate it during preanalysis of a class-wide
30698 -- pre/postcondition since the expression is not installed yet
30699 -- on its definite context.
30702 elsif not Is_Conditionally_Evaluated
(Expr
) then
30706 Determiners
: constant Determining_Expression_List
:=
30707 Determining_Expressions
(Expr
);
30709 pragma Assert
(Determiners
'Length > 0);
30711 for Idx
in Determiners
'Range loop
30712 if not Is_Known_On_Entry
(Determiners
(Idx
).Expr
) then
30719 end Eligible_For_Conditional_Evaluation
;
30721 --------------------------------
30722 -- Is_Conditionally_Evaluated --
30723 --------------------------------
30725 function Is_Conditionally_Evaluated
(Expr
: Node_Id
) return Boolean
30727 -- There are three possibilities - the expression is
30728 -- unconditionally evaluated, repeatedly evaluated, or
30729 -- conditionally evaluated (see RM 6.1.1). So we implement
30730 -- this test by testing for the other two.
30732 function Is_Repeatedly_Evaluated
(Expr
: Node_Id
) return Boolean;
30733 -- See RM 6.1.1 for definition of "repeatedly evaluated".
30735 -----------------------------
30736 -- Is_Repeatedly_Evaluated --
30737 -----------------------------
30739 function Is_Repeatedly_Evaluated
(Expr
: Node_Id
) return Boolean is
30740 Par
: Node_Id
:= Expr
;
30741 Trailer
: Node_Id
:= Empty
;
30743 -- There are three ways that an expression can be repeatedly
30746 -- An aspect_specification is transformed into a pragma, so
30747 -- reaching a pragma is our termination condition. We want to
30748 -- stop when we reach the postcondition expression.
30750 while Nkind
(Par
) /= N_Pragma
loop
30751 pragma Assert
(Present
(Par
));
30753 -- test for case 1:
30754 -- A subexpression of a predicate of a
30755 -- quantified_expression.
30757 if Nkind
(Par
) = N_Quantified_Expression
30758 and then Trailer
= Condition
(Par
)
30761 elsif Nkind
(Par
) = N_Expression_With_Actions
30763 Nkind
(Original_Node
(Par
)) = N_Quantified_Expression
30768 -- test for cases 2 and 3:
30769 -- A subexpression of the expression of an
30770 -- array_component_association or of
30771 -- a container_element_associatiation.
30773 if Nkind
(Par
) = N_Component_Association
30774 and then Trailer
= Expression
(Par
)
30776 -- determine whether Par is part of an array aggregate
30777 -- or a container aggregate
30779 Rover
: Node_Id
:= Par
;
30781 while Nkind
(Rover
) not in N_Has_Etype
loop
30782 pragma Assert
(Present
(Rover
));
30783 Rover
:= Parent
(Rover
);
30785 if Present
(Etype
(Rover
)) then
30786 if Is_Array_Type
(Etype
(Rover
))
30787 or else Is_Container_Aggregate
(Rover
)
30796 Par
:= Parent
(Par
);
30800 end Is_Repeatedly_Evaluated
;
30803 if not Is_Potentially_Unevaluated
(Expr
) then
30804 -- the expression is unconditionally evaluated
30806 elsif Is_Repeatedly_Evaluated
(Expr
) then
30811 end Is_Conditionally_Evaluated
;
30813 -----------------------
30814 -- Is_Known_On_Entry --
30815 -----------------------
30817 function Is_Known_On_Entry
(Expr
: Node_Id
) return Boolean is
30818 -- ??? This implementation is incomplete. See RM 6.1.1
30819 -- for details. In particular, this function *should* return
30820 -- True for a function call (or a user-defined literal, which
30821 -- is equivalent to a function call) if all actual parameters
30822 -- (including defaulted params) are known on entry and the
30823 -- function has "Globals => null" specified; the current
30824 -- implementation will incorrectly return False in this case.
30826 function All_Exps_Known_On_Entry
30827 (Expr_List
: List_Id
) return Boolean;
30828 -- Given a list of expressions, returns False iff
30829 -- Is_Known_On_Entry is False for at least one list element.
30831 -----------------------------
30832 -- All_Exps_Known_On_Entry --
30833 -----------------------------
30835 function All_Exps_Known_On_Entry
30836 (Expr_List
: List_Id
) return Boolean
30838 Expr
: Node_Id
:= First
(Expr_List
);
30840 while Present
(Expr
) loop
30841 if not Is_Known_On_Entry
(Expr
) then
30847 end All_Exps_Known_On_Entry
;
30850 if Is_Static_Expression
(Expr
) then
30854 if Is_Attribute_Old
(Expr
) then
30859 Pref
: Node_Id
:= Expr
;
30862 case Nkind
(Pref
) is
30863 when N_Selected_Component
=>
30866 when N_Indexed_Component
=>
30867 if not All_Exps_Known_On_Entry
(Expressions
(Pref
))
30873 return False; -- just to be clear about this case
30879 Pref
:= Prefix
(Pref
);
30882 if Is_Entity_Name
(Pref
)
30883 and then Is_Constant_Object
(Entity
(Pref
))
30886 Obj
: constant Entity_Id
:= Entity
(Pref
);
30887 Obj_Typ
: constant Entity_Id
:= Etype
(Obj
);
30889 case Ekind
(Obj
) is
30890 when E_In_Parameter
=>
30891 if not Is_Elementary_Type
(Obj_Typ
) then
30893 elsif Is_Aliased
(Obj
) then
30898 -- return False for a deferred constant
30899 if Present
(Full_View
(Obj
)) then
30903 -- return False if not "all views are constant".
30904 if Is_Immutably_Limited_Type
(Obj_Typ
)
30905 or Needs_Finalization
(Obj_Typ
)
30918 -- ??? Cope with a malformed tree. Code to cope with a
30919 -- nonstatic use of an enumeration literal should not be
30921 if Is_Entity_Name
(Pref
)
30922 and then Ekind
(Entity
(Pref
)) = E_Enumeration_Literal
30928 case Nkind
(Expr
) is
30930 return Is_Known_On_Entry
(Right_Opnd
(Expr
));
30932 when N_Binary_Op
=>
30933 return Is_Known_On_Entry
(Left_Opnd
(Expr
))
30934 and then Is_Known_On_Entry
(Right_Opnd
(Expr
));
30936 when N_Type_Conversion | N_Qualified_Expression
=>
30937 return Is_Known_On_Entry
(Expression
(Expr
));
30939 when N_If_Expression
=>
30940 if not All_Exps_Known_On_Entry
(Expressions
(Expr
)) then
30944 when N_Case_Expression
=>
30945 if not Is_Known_On_Entry
(Expression
(Expr
)) then
30950 Alt
: Node_Id
:= First
(Alternatives
(Expr
));
30952 while Present
(Alt
) loop
30953 if not Is_Known_On_Entry
(Expression
(Alt
)) then
30967 end Is_Known_On_Entry
;
30969 end Conditional_Evaluation
;
30971 package body Indirect_Temps
is
30973 Indirect_Temp_Access_Type_Char
: constant Character := 'K';
30974 -- The character passed to Make_Temporary when declaring
30975 -- the access type that is used in the implementation of an
30976 -- indirect temporary.
30978 --------------------------
30979 -- Indirect_Temp_Needed --
30980 --------------------------
30982 function Indirect_Temp_Needed
(Typ
: Entity_Id
) return Boolean is
30984 -- There should be no correctness issues if the only cases where
30985 -- this function returns False are cases where Typ is an
30986 -- anonymous access type and we need to generate a saooaaat (a
30987 -- stand-alone object of an anonymous access type) in order get
30988 -- accessibility right. In other cases where this function
30989 -- returns False, there would be no correctness problems with
30990 -- returning True instead; however, returning False when we can
30991 -- generally results in simpler code.
30995 -- If Typ is not definite, then we cannot generate
30998 or else not Is_Definite_Subtype
(Typ
)
31000 -- If Typ is tagged, then generating
31002 -- might generate an object with the wrong tag. If we had
31003 -- a predicate that indicated whether the nominal tag is
31004 -- trustworthy, we could use that predicate here.
31006 or else Is_Tagged_Type
(Typ
)
31008 -- If Typ needs finalization, then generating an implicit
31010 -- declaration could have user-visible side effects.
31012 or else Needs_Finalization
(Typ
)
31014 -- In the anonymous access type case, we need to
31015 -- generate a saooaaat. We don't want the code in
31016 -- in exp_attr.adb that deals with the case where this
31017 -- function returns False to have to deal with that case
31018 -- (just to avoid code duplication). So we cheat a little
31019 -- bit and return True here for an anonymous access type.
31021 or else Is_Anonymous_Access_Type
(Typ
);
31023 -- ??? Unimplemented - spec description says:
31024 -- For an unconstrained-but-definite discriminated subtype,
31025 -- returns True if the potential difference in size between an
31026 -- unconstrained object and a constrained object is large.
31029 -- type Typ (Len : Natural := 0) is
31030 -- record F : String (1 .. Len); end record;
31032 -- See Large_Max_Size_Mutable function elsewhere in this file,
31033 -- currently declared inside of Needs_Secondary_Stack, so it
31034 -- would have to be moved if we want it to be callable from here.
31036 end Indirect_Temp_Needed
;
31038 ---------------------------
31039 -- Declare_Indirect_Temp --
31040 ---------------------------
31042 procedure Declare_Indirect_Temp
31043 (Attr_Prefix
: Node_Id
; Indirect_Temp
: out Entity_Id
)
31045 Loc
: constant Source_Ptr
:= Sloc
(Attr_Prefix
);
31046 Prefix_Type
: constant Entity_Id
:= Etype
(Attr_Prefix
);
31047 Temp_Id
: constant Entity_Id
:=
31048 Make_Temporary
(Loc
, 'P', Attr_Prefix
);
31050 procedure Declare_Indirect_Temp_Via_Allocation
;
31051 -- Handle the usual case.
31053 -------------------------------------------
31054 -- Declare_Indirect_Temp_Via_Allocation --
31055 -------------------------------------------
31057 procedure Declare_Indirect_Temp_Via_Allocation
is
31058 Access_Type_Id
: constant Entity_Id
31060 (Loc
, Indirect_Temp_Access_Type_Char
, Attr_Prefix
);
31062 Temp_Decl
: constant Node_Id
:=
31063 Make_Object_Declaration
(Loc
,
31064 Defining_Identifier
=> Temp_Id
,
31065 Object_Definition
=>
31066 New_Occurrence_Of
(Access_Type_Id
, Loc
));
31068 Allocate_Class_Wide
: constant Boolean :=
31069 Is_Specific_Tagged_Type
(Prefix_Type
);
31070 -- If True then access type designates the class-wide type in
31071 -- order to preserve (at run time) the value of the underlying
31073 -- ??? We could do better here (in the case where Prefix_Type
31074 -- is tagged and specific) if we had a predicate which takes an
31075 -- expression and returns True iff the expression is of
31076 -- a specific tagged type and the underlying tag (at run time)
31077 -- is statically known to match that of the specific type.
31078 -- In that case, Allocate_Class_Wide could safely be False.
31080 function Designated_Subtype_Mark
return Node_Id
;
31081 -- Usually, a subtype mark indicating the subtype of the
31082 -- attribute prefix. If that subtype is a specific tagged
31083 -- type, then returns the corresponding class-wide type.
31084 -- If the prefix is of an anonymous access type, then returns
31085 -- the designated type of that type.
31087 -----------------------------
31088 -- Designated_Subtype_Mark --
31089 -----------------------------
31091 function Designated_Subtype_Mark
return Node_Id
is
31092 Typ
: Entity_Id
:= Prefix_Type
;
31094 if Allocate_Class_Wide
then
31095 if Is_Private_Type
(Typ
)
31096 and then Present
(Full_View
(Typ
))
31098 Typ
:= Full_View
(Typ
);
31100 Typ
:= Class_Wide_Type
(Typ
);
31103 return New_Occurrence_Of
(Typ
, Loc
);
31104 end Designated_Subtype_Mark
;
31106 Access_Type_Def
: constant Node_Id
31107 := Make_Access_To_Object_Definition
31108 (Loc
, Subtype_Indication
=> Designated_Subtype_Mark
);
31110 Access_Type_Decl
: constant Node_Id
31111 := Make_Full_Type_Declaration
31112 (Loc
, Access_Type_Id
,
31113 Type_Definition
=> Access_Type_Def
);
31115 Mutate_Ekind
(Temp_Id
, E_Variable
);
31116 Set_Etype
(Temp_Id
, Access_Type_Id
);
31117 Mutate_Ekind
(Access_Type_Id
, E_Access_Type
);
31119 if Append_Decls_In_Reverse_Order
then
31120 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31121 Append_Item
(Access_Type_Decl
, Is_Eval_Stmt
=> False);
31123 Append_Item
(Access_Type_Decl
, Is_Eval_Stmt
=> False);
31124 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31127 -- When a type associated with an indirect temporary gets
31128 -- created for a 'Old attribute reference we need to mark
31129 -- the type as such. This allows, for example, finalization
31130 -- masters associated with them to be finalized in the correct
31131 -- order after postcondition checks.
31133 if Attribute_Name
(Parent
(Attr_Prefix
)) = Name_Old
then
31134 Set_Stores_Attribute_Old_Prefix
(Access_Type_Id
);
31137 Analyze
(Access_Type_Decl
);
31138 Analyze
(Temp_Decl
);
31141 (Is_Access_Type_For_Indirect_Temp
(Access_Type_Id
));
31144 Expression
: Node_Id
:= Attr_Prefix
;
31145 Allocator
: Node_Id
;
31147 if Allocate_Class_Wide
then
31148 -- generate T'Class'(T'Class (<prefix>))
31150 Make_Type_Conversion
(Loc
,
31151 Subtype_Mark
=> Designated_Subtype_Mark
,
31152 Expression
=> Expression
);
31156 Make_Allocator
(Loc
,
31157 Make_Qualified_Expression
31159 Subtype_Mark
=> Designated_Subtype_Mark
,
31160 Expression
=> Expression
));
31162 -- Allocate saved prefix value on the secondary stack
31163 -- in order to avoid introducing a storage leak. This
31164 -- allocated object is never explicitly reclaimed.
31166 -- ??? Emit storage leak warning if RE_SS_Pool
31169 if RTE_Available
(RE_SS_Pool
) then
31170 Set_Storage_Pool
(Allocator
, RTE
(RE_SS_Pool
));
31171 Set_Procedure_To_Call
31172 (Allocator
, RTE
(RE_SS_Allocate
));
31173 Set_Uses_Sec_Stack
(Current_Scope
);
31177 (Make_Assignment_Statement
(Loc
,
31178 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
31179 Expression
=> Allocator
),
31180 Is_Eval_Stmt
=> True);
31182 end Declare_Indirect_Temp_Via_Allocation
;
31185 Indirect_Temp
:= Temp_Id
;
31187 if Is_Anonymous_Access_Type
(Prefix_Type
) then
31188 -- In the anonymous access type case, we do not want a level
31189 -- indirection (which would result in declaring an
31190 -- access-to-access type); that would result in correctness
31191 -- problems - the accessibility level of the type of the
31192 -- 'Old constant would be wrong (See 6.1.1.). So in that case,
31193 -- we do not generate an allocator. Instead we generate
31194 -- Temp : access Designated := null;
31195 -- which is unconditionally elaborated and then
31196 -- Temp := <attribute prefix>;
31197 -- which is conditionally executed.
31200 Temp_Decl
: constant Node_Id
:=
31201 Make_Object_Declaration
(Loc
,
31202 Defining_Identifier
=> Temp_Id
,
31203 Object_Definition
=>
31204 Make_Access_Definition
31206 Constant_Present
=>
31207 Is_Access_Constant
(Prefix_Type
),
31210 (Designated_Type
(Prefix_Type
), Loc
)));
31212 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31213 Analyze
(Temp_Decl
);
31215 (Make_Assignment_Statement
(Loc
,
31216 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
31217 Expression
=> Attr_Prefix
),
31218 Is_Eval_Stmt
=> True);
31222 Declare_Indirect_Temp_Via_Allocation
;
31224 end Declare_Indirect_Temp
;
31226 -------------------------
31227 -- Indirect_Temp_Value --
31228 -------------------------
31230 function Indirect_Temp_Value
31233 Loc
: Source_Ptr
) return Node_Id
31237 if Is_Anonymous_Access_Type
(Typ
) then
31238 -- No indirection in this case; just evaluate the temp.
31239 Result
:= New_Occurrence_Of
(Temp
, Loc
);
31240 Set_Etype
(Result
, Etype
(Temp
));
31243 Result
:= Make_Explicit_Dereference
(Loc
,
31244 New_Occurrence_Of
(Temp
, Loc
));
31246 Set_Etype
(Result
, Designated_Type
(Etype
(Temp
)));
31248 if Is_Specific_Tagged_Type
(Typ
) then
31249 -- The designated type of the access type is class-wide, so
31250 -- convert to the specific type.
31253 Make_Type_Conversion
(Loc
,
31254 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
31255 Expression
=> Result
);
31257 Set_Etype
(Result
, Typ
);
31262 end Indirect_Temp_Value
;
31264 function Is_Access_Type_For_Indirect_Temp
31265 (T
: Entity_Id
) return Boolean is
31267 if Is_Access_Type
(T
)
31268 and then not Comes_From_Source
(T
)
31269 and then Is_Internal_Name
(Chars
(T
))
31270 and then Nkind
(Scope
(T
)) in N_Entity
31271 and then Ekind
(Scope
(T
))
31272 in E_Entry | E_Entry_Family | E_Function | E_Procedure
31274 (Present
(Wrapped_Statements
(Scope
(T
)))
31275 or else Present
(Contract
(Scope
(T
))))
31277 -- ??? Should define a flag for this. We could incorrectly
31278 -- return True if other clients of Make_Temporary happen to
31279 -- pass in the same character.
31281 Name
: constant String := Get_Name_String
(Chars
(T
));
31283 if Name
(Name
'First) = Indirect_Temp_Access_Type_Char
then
31290 end Is_Access_Type_For_Indirect_Temp
;
31292 end Indirect_Temps
;
31295 package body Storage_Model_Support
is
31297 -----------------------------------------
31298 -- Has_Designated_Storage_Model_Aspect --
31299 -----------------------------------------
31301 function Has_Designated_Storage_Model_Aspect
31302 (Typ
: Entity_Id
) return Boolean
31305 return Has_Aspect
(Typ
, Aspect_Designated_Storage_Model
);
31306 end Has_Designated_Storage_Model_Aspect
;
31308 -----------------------------------
31309 -- Has_Storage_Model_Type_Aspect --
31310 -----------------------------------
31312 function Has_Storage_Model_Type_Aspect
(Typ
: Entity_Id
) return Boolean
31315 return Has_Aspect
(Typ
, Aspect_Storage_Model_Type
);
31316 end Has_Storage_Model_Type_Aspect
;
31318 --------------------------
31319 -- Storage_Model_Object --
31320 --------------------------
31322 function Storage_Model_Object
(Typ
: Entity_Id
) return Entity_Id
is
31324 pragma Assert
(Has_Designated_Storage_Model_Aspect
(Typ
));
31328 (Find_Value_Of_Aspect
(Typ
, Aspect_Designated_Storage_Model
));
31329 end Storage_Model_Object
;
31331 ------------------------
31332 -- Storage_Model_Type --
31333 ------------------------
31335 function Storage_Model_Type
(Obj
: Entity_Id
) return Entity_Id
is
31337 pragma Assert
(Has_Storage_Model_Type_Aspect
(Etype
(Obj
)));
31339 return Etype
(Obj
);
31340 end Storage_Model_Type
;
31342 -----------------------------------
31343 -- Get_Storage_Model_Type_Entity --
31344 -----------------------------------
31346 function Get_Storage_Model_Type_Entity
31347 (SM_Obj_Or_Type
: Entity_Id
;
31348 Nam
: Name_Id
) return Entity_Id
31350 Typ
: constant Entity_Id
:= (if Is_Object
(SM_Obj_Or_Type
) then
31351 Storage_Model_Type
(SM_Obj_Or_Type
)
31357 Nam
in Name_Address_Type
31358 | Name_Null_Address
31363 | Name_Storage_Size
);
31366 SMT_Aspect_Value
: constant Node_Id
:=
31367 Find_Value_Of_Aspect
(Typ
, Aspect_Storage_Model_Type
);
31370 -- When the aspect has an aggregate expression, search through it
31371 -- to locate a match for the name of the given "subaspect" and return
31372 -- the entity of the aggregate association's expression.
31374 if Present
(SMT_Aspect_Value
) then
31375 Assoc
:= First
(Component_Associations
(SMT_Aspect_Value
));
31376 while Present
(Assoc
) loop
31377 if Chars
(First
(Choices
(Assoc
))) = Nam
then
31378 return Entity
(Expression
(Assoc
));
31385 -- The aggregate argument of Storage_Model_Type is optional, and when
31386 -- not present the aspect defaults to the native storage model, where
31387 -- the address type is System.Address. In that case, we return
31388 -- System.Address for Name_Address_Type and System.Null_Address for
31389 -- Name_Null_Address, but return Empty for other cases, and leave it
31390 -- to the back end to map those to the appropriate native operations.
31392 if Nam
= Name_Address_Type
then
31393 return RTE
(RE_Address
);
31395 elsif Nam
= Name_Null_Address
then
31396 return RTE
(RE_Null_Address
);
31401 end Get_Storage_Model_Type_Entity
;
31403 --------------------------------
31404 -- Storage_Model_Address_Type --
31405 --------------------------------
31407 function Storage_Model_Address_Type
31408 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31412 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Address_Type
);
31413 end Storage_Model_Address_Type
;
31415 --------------------------------
31416 -- Storage_Model_Null_Address --
31417 --------------------------------
31419 function Storage_Model_Null_Address
31420 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31424 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Null_Address
);
31425 end Storage_Model_Null_Address
;
31427 ----------------------------
31428 -- Storage_Model_Allocate --
31429 ----------------------------
31431 function Storage_Model_Allocate
31432 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31435 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Allocate
);
31436 end Storage_Model_Allocate
;
31438 ------------------------------
31439 -- Storage_Model_Deallocate --
31440 ------------------------------
31442 function Storage_Model_Deallocate
31443 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31447 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Deallocate
);
31448 end Storage_Model_Deallocate
;
31450 -----------------------------
31451 -- Storage_Model_Copy_From --
31452 -----------------------------
31454 function Storage_Model_Copy_From
31455 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31458 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Copy_From
);
31459 end Storage_Model_Copy_From
;
31461 ---------------------------
31462 -- Storage_Model_Copy_To --
31463 ---------------------------
31465 function Storage_Model_Copy_To
31466 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31469 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Copy_To
);
31470 end Storage_Model_Copy_To
;
31472 --------------------------------
31473 -- Storage_Model_Storage_Size --
31474 --------------------------------
31476 function Storage_Model_Storage_Size
31477 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31481 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Storage_Size
);
31482 end Storage_Model_Storage_Size
;
31484 end Storage_Model_Support
;
31487 Erroutc
.Subprogram_Name_Ptr
:= Subprogram_Name
'Access;