1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Accessibility
; use Accessibility
;
27 with Casing
; use Casing
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
.Utils
; use Einfo
.Utils
;
31 with Elists
; use Elists
;
32 with Errout
; use Errout
;
33 with Erroutc
; use Erroutc
;
34 with Exp_Ch6
; use Exp_Ch6
;
35 with Exp_Ch11
; use Exp_Ch11
;
36 with Exp_Util
; use Exp_Util
;
37 with Fname
; use Fname
;
38 with Freeze
; use Freeze
;
39 with Itypes
; use Itypes
;
41 with Lib
.Xref
; use Lib
.Xref
;
42 with Namet
.Sp
; use Namet
.Sp
;
43 with Nlists
; use Nlists
;
44 with Nmake
; use Nmake
;
45 with Output
; use Output
;
46 with Restrict
; use Restrict
;
47 with Rident
; use Rident
;
48 with Rtsfind
; use Rtsfind
;
50 with Sem_Aux
; use Sem_Aux
;
51 with Sem_Attr
; use Sem_Attr
;
52 with Sem_Cat
; use Sem_Cat
;
53 with Sem_Ch6
; use Sem_Ch6
;
54 with Sem_Ch8
; use Sem_Ch8
;
55 with Sem_Ch13
; use Sem_Ch13
;
56 with Sem_Disp
; use Sem_Disp
;
57 with Sem_Elab
; use Sem_Elab
;
58 with Sem_Eval
; use Sem_Eval
;
59 with Sem_Prag
; use Sem_Prag
;
60 with Sem_Res
; use Sem_Res
;
61 with Sem_Warn
; use Sem_Warn
;
62 with Sem_Type
; use Sem_Type
;
63 with Sinfo
; use Sinfo
;
64 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
65 with Sinfo
.Utils
; use Sinfo
.Utils
;
66 with Sinput
; use Sinput
;
67 with Stand
; use Stand
;
69 with Stringt
; use Stringt
;
70 with Targparm
; use Targparm
;
71 with Tbuild
; use Tbuild
;
72 with Ttypes
; use Ttypes
;
73 with Uname
; use Uname
;
74 with Warnsw
; use Warnsw
;
76 with GNAT
.Heap_Sort_G
;
77 with GNAT
.HTable
; use GNAT
.HTable
;
79 package body Sem_Util
is
81 ---------------------------
82 -- Local Data Structures --
83 ---------------------------
85 Invalid_Binder_Values
: array (Scalar_Id
) of Entity_Id
:= (others => Empty
);
86 -- A collection to hold the entities of the variables declared in package
87 -- System.Scalar_Values which describe the invalid values of scalar types.
89 Invalid_Binder_Values_Set
: Boolean := False;
90 -- This flag prevents multiple attempts to initialize Invalid_Binder_Values
92 Invalid_Floats
: array (Float_Scalar_Id
) of Ureal
:= (others => No_Ureal
);
93 -- A collection to hold the invalid values of float types as specified by
94 -- pragma Initialize_Scalars.
96 Invalid_Integers
: array (Integer_Scalar_Id
) of Uint
:= (others => No_Uint
);
97 -- A collection to hold the invalid values of integer types as specified
98 -- by pragma Initialize_Scalars.
100 -----------------------
101 -- Local Subprograms --
102 -----------------------
104 function Build_Component_Subtype
107 T
: Entity_Id
) return Node_Id
;
108 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
109 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
110 -- Loc is the source location, T is the original subtype.
112 procedure Examine_Array_Bounds
114 All_Static
: out Boolean;
115 Has_Empty
: out Boolean);
116 -- Inspect the index constraints of array type Typ. Flag All_Static is set
117 -- when all ranges are static. Flag Has_Empty is set only when All_Static
118 -- is set and indicates that at least one range is empty.
120 function Has_Enabled_Property
121 (Item_Id
: Entity_Id
;
122 Property
: Name_Id
) return Boolean;
123 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
124 -- Determine whether the state abstraction, object, or type denoted by
125 -- entity Item_Id has enabled property Property.
127 function Has_Null_Extension
(T
: Entity_Id
) return Boolean;
128 -- T is a derived tagged type. Check whether the type extension is null.
129 -- If the parent type is fully initialized, T can be treated as such.
131 function Is_Atomic_Object_Entity
(Id
: Entity_Id
) return Boolean;
132 -- Determine whether arbitrary entity Id denotes an atomic object as per
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, but not if the
6167 -- convention is other than Ada.
6169 elsif Is_Limited_View
(Typ
)
6170 and then not Has_Foreign_Convention
(Func
)
6172 Set_Returns_By_Ref
(Func
);
6174 end Compute_Returns_By_Ref
;
6176 --------------------------------
6177 -- Collect_Types_In_Hierarchy --
6178 --------------------------------
6180 function Collect_Types_In_Hierarchy
6182 Examine_Components
: Boolean := False) return Elist_Id
6186 procedure Process_Type
(Typ
: Entity_Id
);
6187 -- Collect type Typ if it satisfies function Predicate. Do so for its
6188 -- parent type, base type, progenitor types, and any component types.
6194 procedure Process_Type
(Typ
: Entity_Id
) is
6196 Iface_Elmt
: Elmt_Id
;
6199 if not Is_Type
(Typ
) or else Error_Posted
(Typ
) then
6203 -- Collect the current type if it satisfies the predicate
6205 if Predicate
(Typ
) then
6206 Append_Elmt
(Typ
, Results
);
6209 -- Process component types
6211 if Examine_Components
then
6213 -- Examine components and discriminants
6215 if Is_Concurrent_Type
(Typ
)
6216 or else Is_Incomplete_Or_Private_Type
(Typ
)
6217 or else Is_Record_Type
(Typ
)
6218 or else Has_Discriminants
(Typ
)
6220 Comp
:= First_Component_Or_Discriminant
(Typ
);
6222 while Present
(Comp
) loop
6223 Process_Type
(Etype
(Comp
));
6225 Next_Component_Or_Discriminant
(Comp
);
6228 -- Examine array components
6230 elsif Ekind
(Typ
) = E_Array_Type
then
6231 Process_Type
(Component_Type
(Typ
));
6235 -- Examine parent type
6237 if Etype
(Typ
) /= Typ
then
6238 Process_Type
(Etype
(Typ
));
6241 -- Examine base type
6243 if Base_Type
(Typ
) /= Typ
then
6244 Process_Type
(Base_Type
(Typ
));
6247 -- Examine interfaces
6249 if Is_Record_Type
(Typ
)
6250 and then Present
(Interfaces
(Typ
))
6252 Iface_Elmt
:= First_Elmt
(Interfaces
(Typ
));
6253 while Present
(Iface_Elmt
) loop
6254 Process_Type
(Node
(Iface_Elmt
));
6256 Next_Elmt
(Iface_Elmt
);
6261 -- Start of processing for Collect_Types_In_Hierarchy
6264 Results
:= New_Elmt_List
;
6267 end Collect_Types_In_Hierarchy
;
6269 -----------------------
6270 -- Conditional_Delay --
6271 -----------------------
6273 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
6275 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
6276 Set_Has_Delayed_Freeze
(New_Ent
);
6278 end Conditional_Delay
;
6280 -------------------------
6281 -- Copy_Component_List --
6282 -------------------------
6284 function Copy_Component_List
6286 Loc
: Source_Ptr
) return List_Id
6289 Comps
: constant List_Id
:= New_List
;
6292 Comp
:= First_Component
(Underlying_Type
(R_Typ
));
6293 while Present
(Comp
) loop
6294 if Comes_From_Source
(Comp
) then
6296 Comp_Decl
: constant Node_Id
:= Declaration_Node
(Comp
);
6299 Make_Component_Declaration
(Loc
,
6300 Defining_Identifier
=>
6301 Make_Defining_Identifier
(Loc
, Chars
(Comp
)),
6302 Component_Definition
=>
6304 (Component_Definition
(Comp_Decl
), New_Sloc
=> Loc
)));
6308 Next_Component
(Comp
);
6312 end Copy_Component_List
;
6314 -----------------------
6315 -- Copy_Ghost_Aspect --
6316 -----------------------
6318 procedure Copy_Ghost_Aspect
(From
: Node_Id
; To
: Node_Id
) is
6319 pragma Assert
(not Has_Aspects
(To
));
6323 if Has_Aspects
(From
) then
6324 Asp
:= Find_Aspect
(Defining_Entity
(From
), Aspect_Ghost
);
6326 if Present
(Asp
) then
6327 Set_Aspect_Specifications
(To
, New_List
(New_Copy_Tree
(Asp
)));
6330 end Copy_Ghost_Aspect
;
6332 -------------------------
6333 -- Copy_Parameter_List --
6334 -------------------------
6336 function Copy_Parameter_List
(Subp_Id
: Entity_Id
) return List_Id
is
6337 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
6339 Formal
: Entity_Id
:= First_Formal
(Subp_Id
);
6342 if Present
(Formal
) then
6344 while Present
(Formal
) loop
6346 Make_Parameter_Specification
(Loc
,
6347 Defining_Identifier
=>
6348 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
6349 In_Present
=> In_Present
(Parent
(Formal
)),
6350 Out_Present
=> Out_Present
(Parent
(Formal
)),
6352 New_Occurrence_Of
(Etype
(Formal
), Loc
),
6354 New_Copy_Tree
(Expression
(Parent
(Formal
)))));
6356 Next_Formal
(Formal
);
6363 end Copy_Parameter_List
;
6365 ----------------------------
6366 -- Copy_SPARK_Mode_Aspect --
6367 ----------------------------
6369 procedure Copy_SPARK_Mode_Aspect
(From
: Node_Id
; To
: Node_Id
) is
6370 pragma Assert
(not Has_Aspects
(To
));
6374 if Has_Aspects
(From
) then
6375 Asp
:= Find_Aspect
(Defining_Entity
(From
), Aspect_SPARK_Mode
);
6377 if Present
(Asp
) then
6378 Set_Aspect_Specifications
(To
, New_List
(New_Copy_Tree
(Asp
)));
6381 end Copy_SPARK_Mode_Aspect
;
6383 --------------------------
6384 -- Copy_Subprogram_Spec --
6385 --------------------------
6387 function Copy_Subprogram_Spec
6389 New_Sloc
: Source_Ptr
:= No_Location
) return Node_Id
6392 Formal_Spec
: Node_Id
;
6396 -- The structure of the original tree must be replicated without any
6397 -- alterations. Use New_Copy_Tree for this purpose.
6399 Result
:= New_Copy_Tree
(Spec
, New_Sloc
=> New_Sloc
);
6401 -- However, the spec of a null procedure carries the corresponding null
6402 -- statement of the body (created by the parser), and this cannot be
6403 -- shared with the new subprogram spec.
6405 if Nkind
(Result
) = N_Procedure_Specification
then
6406 Set_Null_Statement
(Result
, Empty
);
6409 -- Create a new entity for the defining unit name
6411 Def_Id
:= Defining_Unit_Name
(Result
);
6412 Set_Defining_Unit_Name
(Result
,
6413 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
6415 -- Create new entities for the formal parameters
6417 Formal_Spec
:= First
(Parameter_Specifications
(Result
));
6418 while Present
(Formal_Spec
) loop
6419 Def_Id
:= Defining_Identifier
(Formal_Spec
);
6420 Set_Defining_Identifier
(Formal_Spec
,
6421 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
6427 end Copy_Subprogram_Spec
;
6429 --------------------------------
6430 -- Corresponding_Generic_Type --
6431 --------------------------------
6433 function Corresponding_Generic_Type
(T
: Entity_Id
) return Entity_Id
is
6439 if not Is_Generic_Actual_Type
(T
) then
6442 -- If the actual is the actual of an enclosing instance, resolution
6443 -- was correct in the generic.
6445 elsif Nkind
(Parent
(T
)) = N_Subtype_Declaration
6446 and then Is_Entity_Name
(Subtype_Indication
(Parent
(T
)))
6448 Is_Generic_Actual_Type
(Entity
(Subtype_Indication
(Parent
(T
))))
6455 if Is_Wrapper_Package
(Inst
) then
6456 Inst
:= Related_Instance
(Inst
);
6461 (Specification
(Unit_Declaration_Node
(Inst
)));
6463 -- Generic actual has the same name as the corresponding formal
6465 Typ
:= First_Entity
(Gen
);
6466 while Present
(Typ
) loop
6467 if Chars
(Typ
) = Chars
(T
) then
6476 end Corresponding_Generic_Type
;
6478 --------------------------------
6479 -- Corresponding_Primitive_Op --
6480 --------------------------------
6482 function Corresponding_Primitive_Op
6483 (Ancestor_Op
: Entity_Id
;
6484 Descendant_Type
: Entity_Id
) return Entity_Id
6486 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Ancestor_Op
);
6490 function Profile_Matches_Ancestor
(S
: Entity_Id
) return Boolean;
6491 -- Returns True if subprogram S has the proper profile for an
6492 -- overriding of Ancestor_Op (that is, corresponding formals either
6493 -- have the same type, or are corresponding controlling formals,
6494 -- and similarly for result types).
6496 ------------------------------
6497 -- Profile_Matches_Ancestor --
6498 ------------------------------
6500 function Profile_Matches_Ancestor
(S
: Entity_Id
) return Boolean is
6501 F1
: Entity_Id
:= First_Formal
(Ancestor_Op
);
6502 F2
: Entity_Id
:= First_Formal
(S
);
6505 if Ekind
(Ancestor_Op
) /= Ekind
(S
) then
6509 -- ??? This should probably account for anonymous access formals,
6510 -- but the parent function (Corresponding_Primitive_Op) is currently
6511 -- only called for user-defined literal functions, which can't have
6512 -- such formals. But if this is ever used in a more general context
6513 -- it should be extended to handle such formals (and result types).
6515 while Present
(F1
) and then Present
(F2
) loop
6516 if Etype
(F1
) = Etype
(F2
)
6517 or else Is_Ancestor
(Typ
, Etype
(F2
))
6528 and then (Etype
(Ancestor_Op
) = Etype
(S
)
6529 or else Is_Ancestor
(Typ
, Etype
(S
)));
6530 end Profile_Matches_Ancestor
;
6532 -- Start of processing for Corresponding_Primitive_Op
6535 pragma Assert
(Is_Dispatching_Operation
(Ancestor_Op
));
6536 pragma Assert
(Is_Ancestor
(Typ
, Descendant_Type
)
6537 or else Is_Progenitor
(Typ
, Descendant_Type
));
6539 Elmt
:= First_Elmt
(Primitive_Operations
(Descendant_Type
));
6541 while Present
(Elmt
) loop
6542 Subp
:= Node
(Elmt
);
6544 -- For regular primitives we need to check the profile against
6545 -- the ancestor when the name matches the name of Ancestor_Op,
6546 -- but for predefined dispatching operations we cannot rely on
6547 -- the name of the primitive to identify a candidate since their
6548 -- name is internally built by adding a suffix to the name of the
6551 if Chars
(Subp
) = Chars
(Ancestor_Op
)
6552 or else Is_Predefined_Dispatching_Operation
(Subp
)
6554 -- Handle case where Ancestor_Op is a primitive of a progenitor.
6555 -- We rely on internal entities that map interface primitives:
6556 -- their attribute Interface_Alias references the interface
6557 -- primitive, and their Alias attribute references the primitive
6558 -- of Descendant_Type implementing that interface primitive.
6560 if Present
(Interface_Alias
(Subp
)) then
6561 if Interface_Alias
(Subp
) = Ancestor_Op
then
6562 return Alias
(Subp
);
6565 -- Otherwise, return subprogram when profile matches its ancestor
6567 elsif Profile_Matches_Ancestor
(Subp
) then
6575 pragma Assert
(False);
6577 end Corresponding_Primitive_Op
;
6579 --------------------
6580 -- Current_Entity --
6581 --------------------
6583 -- The currently visible definition for a given identifier is the
6584 -- one most chained at the start of the visibility chain, i.e. the
6585 -- one that is referenced by the Node_Id value of the name of the
6586 -- given identifier.
6588 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
6590 return Get_Name_Entity_Id
(Chars
(N
));
6593 -----------------------------
6594 -- Current_Entity_In_Scope --
6595 -----------------------------
6597 function Current_Entity_In_Scope
(N
: Name_Id
) return Entity_Id
is
6598 CS
: constant Entity_Id
:= Current_Scope
;
6603 E
:= Get_Name_Entity_Id
(N
);
6608 elsif Scope_Is_Transient
then
6609 while Present
(E
) loop
6610 exit when Scope
(E
) = CS
or else Scope
(E
) = Scope
(CS
);
6616 while Present
(E
) loop
6617 exit when Scope
(E
) = CS
;
6624 end Current_Entity_In_Scope
;
6626 -----------------------------
6627 -- Current_Entity_In_Scope --
6628 -----------------------------
6630 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
6632 return Current_Entity_In_Scope
(Chars
(N
));
6633 end Current_Entity_In_Scope
;
6639 function Current_Scope
return Entity_Id
is
6641 if Scope_Stack
.Last
= -1 then
6642 return Standard_Standard
;
6645 C
: constant Entity_Id
:=
6646 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
6651 return Standard_Standard
;
6657 ----------------------------
6658 -- Current_Scope_No_Loops --
6659 ----------------------------
6661 function Current_Scope_No_Loops
return Entity_Id
is
6665 -- Examine the scope stack starting from the current scope and skip any
6666 -- internally generated loops.
6669 while Present
(S
) and then S
/= Standard_Standard
loop
6670 if Ekind
(S
) = E_Loop
and then not Comes_From_Source
(S
) then
6678 end Current_Scope_No_Loops
;
6680 ------------------------
6681 -- Current_Subprogram --
6682 ------------------------
6684 function Current_Subprogram
return Entity_Id
is
6685 Scop
: constant Entity_Id
:= Current_Scope
;
6687 if Is_Subprogram_Or_Generic_Subprogram
(Scop
) then
6690 return Enclosing_Subprogram
(Scop
);
6692 end Current_Subprogram
;
6694 ------------------------------
6695 -- CW_Or_Needs_Finalization --
6696 ------------------------------
6698 function CW_Or_Needs_Finalization
(Typ
: Entity_Id
) return Boolean is
6700 return Is_Class_Wide_Type
(Typ
) or else Needs_Finalization
(Typ
);
6701 end CW_Or_Needs_Finalization
;
6703 ---------------------
6704 -- Defining_Entity --
6705 ---------------------
6707 function Defining_Entity
(N
: Node_Id
) return Entity_Id
is
6708 Ent
: constant Entity_Id
:= Defining_Entity_Or_Empty
(N
);
6711 if Present
(Ent
) then
6715 raise Program_Error
;
6717 end Defining_Entity
;
6719 ------------------------------
6720 -- Defining_Entity_Or_Empty --
6721 ------------------------------
6723 function Defining_Entity_Or_Empty
(N
: Node_Id
) return Entity_Id
is
6726 when N_Abstract_Subprogram_Declaration
6727 | N_Expression_Function
6728 | N_Formal_Subprogram_Declaration
6729 | N_Generic_Package_Declaration
6730 | N_Generic_Subprogram_Declaration
6731 | N_Package_Declaration
6733 | N_Subprogram_Body_Stub
6734 | N_Subprogram_Declaration
6735 | N_Subprogram_Renaming_Declaration
6737 return Defining_Entity
(Specification
(N
));
6739 when N_Component_Declaration
6740 | N_Defining_Program_Unit_Name
6741 | N_Discriminant_Specification
6743 | N_Entry_Declaration
6744 | N_Entry_Index_Specification
6745 | N_Exception_Declaration
6746 | N_Exception_Renaming_Declaration
6747 | N_Formal_Object_Declaration
6748 | N_Formal_Package_Declaration
6749 | N_Formal_Type_Declaration
6750 | N_Full_Type_Declaration
6751 | N_Implicit_Label_Declaration
6752 | N_Incomplete_Type_Declaration
6753 | N_Iterator_Specification
6754 | N_Loop_Parameter_Specification
6755 | N_Number_Declaration
6756 | N_Object_Declaration
6757 | N_Object_Renaming_Declaration
6758 | N_Package_Body_Stub
6759 | N_Parameter_Specification
6760 | N_Private_Extension_Declaration
6761 | N_Private_Type_Declaration
6763 | N_Protected_Body_Stub
6764 | N_Protected_Type_Declaration
6765 | N_Single_Protected_Declaration
6766 | N_Single_Task_Declaration
6767 | N_Subtype_Declaration
6770 | N_Task_Type_Declaration
6772 return Defining_Identifier
(N
);
6774 when N_Compilation_Unit
=>
6775 return Defining_Entity
(Unit
(N
));
6778 return Defining_Entity
(Proper_Body
(N
));
6780 when N_Function_Instantiation
6781 | N_Function_Specification
6782 | N_Generic_Function_Renaming_Declaration
6783 | N_Generic_Package_Renaming_Declaration
6784 | N_Generic_Procedure_Renaming_Declaration
6786 | N_Package_Instantiation
6787 | N_Package_Renaming_Declaration
6788 | N_Package_Specification
6789 | N_Procedure_Instantiation
6790 | N_Procedure_Specification
6793 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
6794 Err
: Entity_Id
:= Empty
;
6797 if Nkind
(Nam
) in N_Entity
then
6800 -- For Error, make up a name and attach to declaration so we
6801 -- can continue semantic analysis.
6803 elsif Nam
= Error
then
6804 Err
:= Make_Temporary
(Sloc
(N
), 'T');
6805 Set_Defining_Unit_Name
(N
, Err
);
6809 -- If not an entity, get defining identifier
6812 return Defining_Identifier
(Nam
);
6816 when N_Block_Statement
6819 return Entity
(Identifier
(N
));
6824 end Defining_Entity_Or_Empty
;
6826 --------------------------
6827 -- Denotes_Discriminant --
6828 --------------------------
6830 function Denotes_Discriminant
6832 Check_Concurrent
: Boolean := False) return Boolean
6837 if not Is_Entity_Name
(N
) or else No
(Entity
(N
)) then
6843 -- If we are checking for a protected type, the discriminant may have
6844 -- been rewritten as the corresponding discriminal of the original type
6845 -- or of the corresponding concurrent record, depending on whether we
6846 -- are in the spec or body of the protected type.
6848 return Ekind
(E
) = E_Discriminant
6851 and then Ekind
(E
) = E_In_Parameter
6852 and then Present
(Discriminal_Link
(E
))
6854 (Is_Concurrent_Type
(Scope
(Discriminal_Link
(E
)))
6856 Is_Concurrent_Record_Type
(Scope
(Discriminal_Link
(E
)))));
6857 end Denotes_Discriminant
;
6859 -------------------------
6860 -- Denotes_Same_Object --
6861 -------------------------
6863 function Denotes_Same_Object
(A1
, A2
: Node_Id
) return Boolean is
6864 function Is_Object_Renaming
(N
: Node_Id
) return Boolean;
6865 -- Return true if N names an object renaming entity
6867 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean;
6868 -- For renamings, return False if the prefix of any dereference within
6869 -- the renamed object_name is a variable, or any expression within the
6870 -- renamed object_name contains references to variables or calls on
6871 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
6873 ------------------------
6874 -- Is_Object_Renaming --
6875 ------------------------
6877 function Is_Object_Renaming
(N
: Node_Id
) return Boolean is
6879 return Is_Entity_Name
(N
)
6880 and then Ekind
(Entity
(N
)) in E_Variable | E_Constant
6881 and then Present
(Renamed_Object
(Entity
(N
)));
6882 end Is_Object_Renaming
;
6884 -----------------------
6885 -- Is_Valid_Renaming --
6886 -----------------------
6888 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean is
6890 if Is_Object_Renaming
(N
)
6891 and then not Is_Valid_Renaming
(Renamed_Object
(Entity
(N
)))
6896 -- Check if any expression within the renamed object_name contains no
6897 -- references to variables nor calls on nonstatic functions.
6899 if Nkind
(N
) = N_Indexed_Component
then
6904 Indx
:= First
(Expressions
(N
));
6905 while Present
(Indx
) loop
6906 if not Is_OK_Static_Expression
(Indx
) then
6914 elsif Nkind
(N
) = N_Slice
then
6916 Rng
: constant Node_Id
:= Discrete_Range
(N
);
6918 -- Bounds specified as a range
6920 if Nkind
(Rng
) = N_Range
then
6921 if not Is_OK_Static_Range
(Rng
) then
6925 -- Bounds specified as a constrained subtype indication
6927 elsif Nkind
(Rng
) = N_Subtype_Indication
then
6928 if not Is_OK_Static_Range
6929 (Range_Expression
(Constraint
(Rng
)))
6934 -- Bounds specified as a subtype name
6936 elsif not Is_OK_Static_Expression
(Rng
) then
6942 if Has_Prefix
(N
) then
6944 P
: constant Node_Id
:= Prefix
(N
);
6947 if Nkind
(N
) = N_Explicit_Dereference
6948 and then Is_Variable
(P
)
6952 elsif Is_Entity_Name
(P
)
6953 and then Ekind
(Entity
(P
)) = E_Function
6957 elsif Nkind
(P
) = N_Function_Call
then
6961 -- Recursion to continue traversing the prefix of the
6962 -- renaming expression
6964 return Is_Valid_Renaming
(P
);
6969 end Is_Valid_Renaming
;
6971 -- Start of processing for Denotes_Same_Object
6974 -- Both names statically denote the same stand-alone object or
6975 -- parameter (RM 6.4.1(6.6/3)).
6977 if Is_Entity_Name
(A1
)
6978 and then Is_Entity_Name
(A2
)
6979 and then Entity
(A1
) = Entity
(A2
)
6983 -- Both names are selected_components, their prefixes are known to
6984 -- denote the same object, and their selector_names denote the same
6985 -- component (RM 6.4.1(6.7/3)).
6987 elsif Nkind
(A1
) = N_Selected_Component
6988 and then Nkind
(A2
) = N_Selected_Component
6990 return Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
))
6992 Entity
(Selector_Name
(A1
)) = Entity
(Selector_Name
(A2
));
6994 -- Both names are dereferences and the dereferenced names are known to
6995 -- denote the same object (RM 6.4.1(6.8/3)).
6997 elsif Nkind
(A1
) = N_Explicit_Dereference
6998 and then Nkind
(A2
) = N_Explicit_Dereference
7000 return Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
));
7002 -- Both names are indexed_components, their prefixes are known to denote
7003 -- the same object, and each of the pairs of corresponding index values
7004 -- are either both static expressions with the same static value or both
7005 -- names that are known to denote the same object (RM 6.4.1(6.9/3)).
7007 elsif Nkind
(A1
) = N_Indexed_Component
7008 and then Nkind
(A2
) = N_Indexed_Component
7010 if not Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
)) then
7018 Indx1
:= First
(Expressions
(A1
));
7019 Indx2
:= First
(Expressions
(A2
));
7020 while Present
(Indx1
) loop
7022 -- Indexes must denote the same static value or same object
7024 if Is_OK_Static_Expression
(Indx1
) then
7025 if not Is_OK_Static_Expression
(Indx2
) then
7028 elsif Expr_Value
(Indx1
) /= Expr_Value
(Indx2
) then
7032 elsif not Denotes_Same_Object
(Indx1
, Indx2
) then
7044 -- Both names are slices, their prefixes are known to denote the same
7045 -- object, and the two slices have statically matching index constraints
7046 -- (RM 6.4.1(6.10/3)).
7048 elsif Nkind
(A1
) = N_Slice
7049 and then Nkind
(A2
) = N_Slice
7051 if not Denotes_Same_Object
(Prefix
(A1
), Prefix
(A2
)) then
7055 Lo1
, Lo2
, Hi1
, Hi2
: Node_Id
;
7058 Get_Index_Bounds
(Discrete_Range
(A1
), Lo1
, Hi1
);
7059 Get_Index_Bounds
(Discrete_Range
(A2
), Lo2
, Hi2
);
7061 -- Check whether bounds are statically identical. There is no
7062 -- attempt to detect partial overlap of slices.
7064 return Is_OK_Static_Expression
(Lo1
)
7065 and then Is_OK_Static_Expression
(Lo2
)
7066 and then Is_OK_Static_Expression
(Hi1
)
7067 and then Is_OK_Static_Expression
(Hi2
)
7068 and then Expr_Value
(Lo1
) = Expr_Value
(Lo2
)
7069 and then Expr_Value
(Hi1
) = Expr_Value
(Hi2
);
7073 -- One of the two names statically denotes a renaming declaration whose
7074 -- renamed object_name is known to denote the same object as the other;
7075 -- the prefix of any dereference within the renamed object_name is not a
7076 -- variable, and any expression within the renamed object_name contains
7077 -- no references to variables nor calls on nonstatic functions (RM
7080 elsif Is_Object_Renaming
(A1
)
7081 and then Is_Valid_Renaming
(A1
)
7083 return Denotes_Same_Object
(Renamed_Object
(Entity
(A1
)), A2
);
7085 elsif Is_Object_Renaming
(A2
)
7086 and then Is_Valid_Renaming
(A2
)
7088 return Denotes_Same_Object
(A1
, Renamed_Object
(Entity
(A2
)));
7093 end Denotes_Same_Object
;
7095 -------------------------
7096 -- Denotes_Same_Prefix --
7097 -------------------------
7099 function Denotes_Same_Prefix
(A1
, A2
: Node_Id
) return Boolean is
7101 if Is_Entity_Name
(A1
) then
7102 if Nkind
(A2
) in N_Selected_Component | N_Indexed_Component
7103 and then not Is_Access_Type
(Etype
(A1
))
7105 return Denotes_Same_Object
(A1
, Prefix
(A2
))
7106 or else Denotes_Same_Prefix
(A1
, Prefix
(A2
));
7111 elsif Is_Entity_Name
(A2
) then
7112 return Denotes_Same_Prefix
(A1
=> A2
, A2
=> A1
);
7114 elsif Nkind
(A1
) in N_Selected_Component | N_Indexed_Component | N_Slice
7116 Nkind
(A2
) in N_Selected_Component | N_Indexed_Component | N_Slice
7119 Root1
, Root2
: Node_Id
;
7120 Depth1
, Depth2
: Nat
:= 0;
7123 Root1
:= Prefix
(A1
);
7124 while not Is_Entity_Name
(Root1
) loop
7125 if Nkind
(Root1
) not in
7126 N_Selected_Component | N_Indexed_Component
7130 Root1
:= Prefix
(Root1
);
7133 Depth1
:= Depth1
+ 1;
7136 Root2
:= Prefix
(A2
);
7137 while not Is_Entity_Name
(Root2
) loop
7138 if Nkind
(Root2
) not in
7139 N_Selected_Component | N_Indexed_Component
7143 Root2
:= Prefix
(Root2
);
7146 Depth2
:= Depth2
+ 1;
7149 -- If both have the same depth and they do not denote the same
7150 -- object, they are disjoint and no warning is needed.
7152 if Depth1
= Depth2
then
7155 elsif Depth1
> Depth2
then
7156 Root1
:= Prefix
(A1
);
7157 for J
in 1 .. Depth1
- Depth2
- 1 loop
7158 Root1
:= Prefix
(Root1
);
7161 return Denotes_Same_Object
(Root1
, A2
);
7164 Root2
:= Prefix
(A2
);
7165 for J
in 1 .. Depth2
- Depth1
- 1 loop
7166 Root2
:= Prefix
(Root2
);
7169 return Denotes_Same_Object
(A1
, Root2
);
7176 end Denotes_Same_Prefix
;
7178 ----------------------
7179 -- Denotes_Variable --
7180 ----------------------
7182 function Denotes_Variable
(N
: Node_Id
) return Boolean is
7184 return Is_Variable
(N
) and then Paren_Count
(N
) = 0;
7185 end Denotes_Variable
;
7187 -----------------------------
7188 -- Depends_On_Discriminant --
7189 -----------------------------
7191 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
7196 Get_Index_Bounds
(N
, L
, H
);
7197 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
7198 end Depends_On_Discriminant
;
7200 -------------------------------------
7201 -- Derivation_Too_Early_To_Inherit --
7202 -------------------------------------
7204 function Derivation_Too_Early_To_Inherit
7205 (Typ
: Entity_Id
; Streaming_Op
: TSS_Name_Type
) return Boolean is
7207 Btyp
: constant Entity_Id
:= Implementation_Base_Type
(Typ
);
7208 Parent_Type
: Entity_Id
;
7212 -- Start of processing for Derivation_Too_Early_To_Inherit
7215 if Is_Derived_Type
(Btyp
) then
7216 Parent_Type
:= Implementation_Base_Type
(Etype
(Btyp
));
7217 pragma Assert
(Parent_Type
/= Btyp
);
7219 if Has_Stream_Attribute_Definition
7220 (Parent_Type
, Streaming_Op
, Real_Rep
=> Real_Rep
)
7222 and then In_Same_Extended_Unit
(Btyp
, Parent_Type
)
7223 and then Instantiation
(Get_Source_File_Index
(Sloc
(Btyp
))) =
7224 Instantiation
(Get_Source_File_Index
(Sloc
(Parent_Type
)))
7226 return Earlier_In_Extended_Unit
(Btyp
, Real_Rep
);
7231 end Derivation_Too_Early_To_Inherit
;
7233 -------------------------
7234 -- Designate_Same_Unit --
7235 -------------------------
7237 function Designate_Same_Unit
7239 Name2
: Node_Id
) return Boolean
7241 K1
: constant Node_Kind
:= Nkind
(Name1
);
7242 K2
: constant Node_Kind
:= Nkind
(Name2
);
7244 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
7245 -- Returns the parent unit name node of a defining program unit name
7246 -- or the prefix if N is a selected component or an expanded name.
7248 function Select_Node
(N
: Node_Id
) return Node_Id
;
7249 -- Returns the defining identifier node of a defining program unit
7250 -- name or the selector node if N is a selected component or an
7257 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
7259 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
7270 function Select_Node
(N
: Node_Id
) return Node_Id
is
7272 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
7273 return Defining_Identifier
(N
);
7275 return Selector_Name
(N
);
7279 -- Start of processing for Designate_Same_Unit
7282 if K1
in N_Identifier | N_Defining_Identifier
7284 K2
in N_Identifier | N_Defining_Identifier
7286 return Chars
(Name1
) = Chars
(Name2
);
7288 elsif K1
in N_Expanded_Name
7289 | N_Selected_Component
7290 | N_Defining_Program_Unit_Name
7292 K2
in N_Expanded_Name
7293 | N_Selected_Component
7294 | N_Defining_Program_Unit_Name
7297 (Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
)))
7299 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
7304 end Designate_Same_Unit
;
7306 ---------------------------------------------
7307 -- Diagnose_Iterated_Component_Association --
7308 ---------------------------------------------
7310 procedure Diagnose_Iterated_Component_Association
(N
: Node_Id
) is
7311 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
7315 -- Determine whether the iterated component association appears within
7316 -- an aggregate. If this is the case, raise Program_Error because the
7317 -- iterated component association cannot be left in the tree as is and
7318 -- must always be processed by the related aggregate.
7321 while Present
(Aggr
) loop
7322 if Nkind
(Aggr
) = N_Aggregate
then
7323 raise Program_Error
;
7325 -- Prevent the search from going too far
7327 elsif Is_Body_Or_Package_Declaration
(Aggr
) then
7331 Aggr
:= Parent
(Aggr
);
7334 -- At this point it is known that the iterated component association is
7335 -- not within an aggregate. This is really a quantified expression with
7336 -- a missing "all" or "some" quantifier.
7338 Error_Msg_N
("missing quantifier", Def_Id
);
7340 -- Rewrite the iterated component association as True to prevent any
7343 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Sloc
(N
)));
7345 end Diagnose_Iterated_Component_Association
;
7347 ------------------------
7348 -- Discriminated_Size --
7349 ------------------------
7351 function Discriminated_Size
(Comp
: Entity_Id
) return Boolean is
7352 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean;
7353 -- Check whether the bound of an index is non-static and does denote
7354 -- a discriminant, in which case any object of the type (protected or
7355 -- otherwise) will have a non-static size.
7357 ----------------------
7358 -- Non_Static_Bound --
7359 ----------------------
7361 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean is
7363 if Is_OK_Static_Expression
(Bound
) then
7366 -- If the bound is given by a discriminant it is non-static
7367 -- (A static constraint replaces the reference with the value).
7368 -- In an protected object the discriminant has been replaced by
7369 -- the corresponding discriminal within the protected operation.
7371 elsif Is_Entity_Name
(Bound
)
7373 (Ekind
(Entity
(Bound
)) = E_Discriminant
7374 or else Present
(Discriminal_Link
(Entity
(Bound
))))
7381 end Non_Static_Bound
;
7385 Typ
: constant Entity_Id
:= Etype
(Comp
);
7388 -- Start of processing for Discriminated_Size
7391 if not Is_Array_Type
(Typ
) then
7395 if Ekind
(Typ
) = E_Array_Subtype
then
7396 Index
:= First_Index
(Typ
);
7397 while Present
(Index
) loop
7398 if Non_Static_Bound
(Low_Bound
(Index
))
7399 or else Non_Static_Bound
(High_Bound
(Index
))
7411 end Discriminated_Size
;
7413 -----------------------------
7414 -- Effective_Reads_Enabled --
7415 -----------------------------
7417 function Effective_Reads_Enabled
(Id
: Entity_Id
) return Boolean is
7419 return Has_Enabled_Property
(Id
, Name_Effective_Reads
);
7420 end Effective_Reads_Enabled
;
7422 ------------------------------
7423 -- Effective_Writes_Enabled --
7424 ------------------------------
7426 function Effective_Writes_Enabled
(Id
: Entity_Id
) return Boolean is
7428 return Has_Enabled_Property
(Id
, Name_Effective_Writes
);
7429 end Effective_Writes_Enabled
;
7431 ------------------------------
7432 -- Enclosing_Comp_Unit_Node --
7433 ------------------------------
7435 function Enclosing_Comp_Unit_Node
(N
: Node_Id
) return Node_Id
is
7436 Current_Node
: Node_Id
;
7440 while Present
(Current_Node
)
7441 and then Nkind
(Current_Node
) /= N_Compilation_Unit
7443 Current_Node
:= Parent
(Current_Node
);
7446 return Current_Node
;
7447 end Enclosing_Comp_Unit_Node
;
7449 --------------------------
7450 -- Enclosing_CPP_Parent --
7451 --------------------------
7453 function Enclosing_CPP_Parent
(Typ
: Entity_Id
) return Entity_Id
is
7454 Parent_Typ
: Entity_Id
:= Typ
;
7457 while not Is_CPP_Class
(Parent_Typ
)
7458 and then Etype
(Parent_Typ
) /= Parent_Typ
7460 Parent_Typ
:= Etype
(Parent_Typ
);
7462 if Is_Private_Type
(Parent_Typ
) then
7463 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
7467 pragma Assert
(Is_CPP_Class
(Parent_Typ
));
7469 end Enclosing_CPP_Parent
;
7471 ---------------------------
7472 -- Enclosing_Declaration --
7473 ---------------------------
7475 function Enclosing_Declaration
(N
: Node_Id
) return Node_Id
is
7476 Decl
: Node_Id
:= N
;
7479 while Present
(Decl
)
7480 and then not (Nkind
(Decl
) in N_Declaration
7482 Nkind
(Decl
) in N_Later_Decl_Item
7484 Nkind
(Decl
) in N_Renaming_Declaration
7486 Nkind
(Decl
) = N_Number_Declaration
)
7488 Decl
:= Parent
(Decl
);
7492 end Enclosing_Declaration
;
7494 ----------------------------------------
7495 -- Enclosing_Declaration_Or_Statement --
7496 ----------------------------------------
7498 function Enclosing_Declaration_Or_Statement
7499 (N
: Node_Id
) return Node_Id
7505 while Present
(Par
) loop
7506 if Is_Declaration
(Par
) or else Is_Statement
(Par
) then
7509 -- Prevent the search from going too far
7511 elsif Is_Body_Or_Package_Declaration
(Par
) then
7515 Par
:= Parent
(Par
);
7519 end Enclosing_Declaration_Or_Statement
;
7521 ----------------------------
7522 -- Enclosing_Generic_Body --
7523 ----------------------------
7525 function Enclosing_Generic_Body
(N
: Node_Id
) return Node_Id
is
7527 Spec_Id
: Entity_Id
;
7531 while Present
(Par
) loop
7532 if Nkind
(Par
) in N_Package_Body | N_Subprogram_Body
then
7533 Spec_Id
:= Corresponding_Spec
(Par
);
7535 if Present
(Spec_Id
)
7536 and then Nkind
(Unit_Declaration_Node
(Spec_Id
)) in
7537 N_Generic_Declaration
7543 Par
:= Parent
(Par
);
7547 end Enclosing_Generic_Body
;
7549 ----------------------------
7550 -- Enclosing_Generic_Unit --
7551 ----------------------------
7553 function Enclosing_Generic_Unit
(N
: Node_Id
) return Node_Id
is
7555 Spec_Decl
: Node_Id
;
7556 Spec_Id
: Entity_Id
;
7560 while Present
(Par
) loop
7561 if Nkind
(Par
) in N_Generic_Declaration
then
7564 elsif Nkind
(Par
) in N_Package_Body | N_Subprogram_Body
then
7565 Spec_Id
:= Corresponding_Spec
(Par
);
7567 if Present
(Spec_Id
) then
7568 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
7570 if Nkind
(Spec_Decl
) in N_Generic_Declaration
then
7576 Par
:= Parent
(Par
);
7580 end Enclosing_Generic_Unit
;
7586 function Enclosing_HSS
(Stmt
: Node_Id
) return Node_Id
is
7589 pragma Assert
(Is_Statement
(Stmt
));
7591 Par
:= Parent
(Stmt
);
7592 while Present
(Par
) loop
7594 if Nkind
(Par
) = N_Handled_Sequence_Of_Statements
then
7597 -- Prevent the search from going too far
7599 elsif Is_Body_Or_Package_Declaration
(Par
) then
7604 Par
:= Parent
(Par
);
7610 -------------------------------
7611 -- Enclosing_Lib_Unit_Entity --
7612 -------------------------------
7614 function Enclosing_Lib_Unit_Entity
7615 (E
: Entity_Id
:= Current_Scope
) return Entity_Id
7617 Unit_Entity
: Entity_Id
;
7620 -- Look for enclosing library unit entity by following scope links.
7621 -- Equivalent to, but faster than indexing through the scope stack.
7624 while (Present
(Scope
(Unit_Entity
))
7625 and then Scope
(Unit_Entity
) /= Standard_Standard
)
7626 and not Is_Child_Unit
(Unit_Entity
)
7628 Unit_Entity
:= Scope
(Unit_Entity
);
7632 end Enclosing_Lib_Unit_Entity
;
7634 -----------------------------
7635 -- Enclosing_Lib_Unit_Node --
7636 -----------------------------
7638 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
7639 Encl_Unit
: Node_Id
;
7642 Encl_Unit
:= Enclosing_Comp_Unit_Node
(N
);
7643 while Present
(Encl_Unit
)
7644 and then Nkind
(Unit
(Encl_Unit
)) = N_Subunit
7646 Encl_Unit
:= Library_Unit
(Encl_Unit
);
7649 pragma Assert
(Nkind
(Encl_Unit
) = N_Compilation_Unit
);
7651 end Enclosing_Lib_Unit_Node
;
7653 -----------------------
7654 -- Enclosing_Package --
7655 -----------------------
7657 function Enclosing_Package
(N
: Node_Or_Entity_Id
) return Entity_Id
is
7658 Dynamic_Scope
: Entity_Id
;
7661 -- Obtain the enclosing scope when N is a Node_Id - taking care to
7662 -- handle the case when the enclosing scope is already a package.
7664 if Nkind
(N
) not in N_Entity
then
7666 Encl_Scop
: constant Entity_Id
:= Find_Enclosing_Scope
(N
);
7668 if No
(Encl_Scop
) then
7670 elsif Ekind
(Encl_Scop
) in
7671 E_Generic_Package | E_Package | E_Package_Body
7676 return Enclosing_Package
(Encl_Scop
);
7680 -- When N is already an Entity_Id proceed
7682 Dynamic_Scope
:= Enclosing_Dynamic_Scope
(N
);
7683 if Dynamic_Scope
= Standard_Standard
then
7684 return Standard_Standard
;
7686 elsif Dynamic_Scope
= Empty
then
7689 elsif Ekind
(Dynamic_Scope
) in
7690 E_Generic_Package | E_Package | E_Package_Body
7692 return Dynamic_Scope
;
7695 return Enclosing_Package
(Dynamic_Scope
);
7697 end Enclosing_Package
;
7699 -------------------------------------
7700 -- Enclosing_Package_Or_Subprogram --
7701 -------------------------------------
7703 function Enclosing_Package_Or_Subprogram
(E
: Entity_Id
) return Entity_Id
is
7708 while Present
(S
) loop
7709 if Is_Package_Or_Generic_Package
(S
)
7710 or else Is_Subprogram_Or_Generic_Subprogram
(S
)
7720 end Enclosing_Package_Or_Subprogram
;
7722 --------------------------
7723 -- Enclosing_Subprogram --
7724 --------------------------
7726 function Enclosing_Subprogram
(N
: Node_Or_Entity_Id
) return Entity_Id
is
7727 Dyn_Scop
: Entity_Id
;
7728 Encl_Scop
: Entity_Id
;
7731 -- Obtain the enclosing scope when N is a Node_Id - taking care to
7732 -- handle the case when the enclosing scope is already a subprogram.
7734 if Nkind
(N
) not in N_Entity
then
7735 Encl_Scop
:= Find_Enclosing_Scope
(N
);
7737 if No
(Encl_Scop
) then
7739 elsif Ekind
(Encl_Scop
) in Subprogram_Kind
then
7743 return Enclosing_Subprogram
(Encl_Scop
);
7746 -- When N is already an Entity_Id proceed
7748 Dyn_Scop
:= Enclosing_Dynamic_Scope
(N
);
7749 if Dyn_Scop
= Standard_Standard
then
7752 elsif Dyn_Scop
= Empty
then
7755 elsif Ekind
(Dyn_Scop
) = E_Subprogram_Body
then
7756 return Corresponding_Spec
(Parent
(Parent
(Dyn_Scop
)));
7758 elsif Ekind
(Dyn_Scop
) in E_Block | E_Loop | E_Return_Statement
then
7759 return Enclosing_Subprogram
(Dyn_Scop
);
7761 elsif Ekind
(Dyn_Scop
) in E_Entry | E_Entry_Family
then
7763 -- For a task entry or entry family, return the enclosing subprogram
7764 -- of the task itself.
7766 if Ekind
(Scope
(Dyn_Scop
)) = E_Task_Type
then
7767 return Enclosing_Subprogram
(Dyn_Scop
);
7769 -- A protected entry or entry family is rewritten as a protected
7770 -- procedure which is the desired enclosing subprogram. This is
7771 -- relevant when unnesting a procedure local to an entry body.
7774 return Protected_Body_Subprogram
(Dyn_Scop
);
7777 elsif Ekind
(Dyn_Scop
) = E_Task_Type
then
7778 return Get_Task_Body_Procedure
(Dyn_Scop
);
7780 -- The scope may appear as a private type or as a private extension
7781 -- whose completion is a task or protected type.
7783 elsif Ekind
(Dyn_Scop
) in
7784 E_Limited_Private_Type | E_Record_Type_With_Private
7785 and then Present
(Full_View
(Dyn_Scop
))
7786 and then Ekind
(Full_View
(Dyn_Scop
)) in E_Task_Type | E_Protected_Type
7788 return Get_Task_Body_Procedure
(Full_View
(Dyn_Scop
));
7790 -- No body is generated if the protected operation is eliminated
7792 elsif not Is_Eliminated
(Dyn_Scop
)
7793 and then Present
(Protected_Body_Subprogram
(Dyn_Scop
))
7795 return Protected_Body_Subprogram
(Dyn_Scop
);
7800 end Enclosing_Subprogram
;
7802 --------------------------
7803 -- End_Keyword_Location --
7804 --------------------------
7806 function End_Keyword_Location
(N
: Node_Id
) return Source_Ptr
is
7807 function End_Label_Loc
(Nod
: Node_Id
) return Source_Ptr
;
7808 -- Return the source location of Nod's end label according to the
7809 -- following precedence rules:
7811 -- 1) If the end label exists, return its location
7812 -- 2) If Nod exists, return its location
7813 -- 3) Return the location of N
7819 function End_Label_Loc
(Nod
: Node_Id
) return Source_Ptr
is
7823 if Present
(Nod
) then
7824 Label
:= End_Label
(Nod
);
7826 if Present
(Label
) then
7827 return Sloc
(Label
);
7839 Owner
: Node_Id
:= Empty
;
7841 -- Start of processing for End_Keyword_Location
7844 if Nkind
(N
) in N_Block_Statement
7850 Owner
:= Handled_Statement_Sequence
(N
);
7852 elsif Nkind
(N
) = N_Package_Declaration
then
7853 Owner
:= Specification
(N
);
7855 elsif Nkind
(N
) = N_Protected_Body
then
7858 elsif Nkind
(N
) in N_Protected_Type_Declaration
7859 | N_Single_Protected_Declaration
7861 Owner
:= Protected_Definition
(N
);
7863 elsif Nkind
(N
) in N_Single_Task_Declaration | N_Task_Type_Declaration
7865 Owner
:= Task_Definition
(N
);
7867 -- This routine should not be called with other contexts
7870 pragma Assert
(False);
7874 return End_Label_Loc
(Owner
);
7875 end End_Keyword_Location
;
7877 ------------------------
7878 -- Ensure_Freeze_Node --
7879 ------------------------
7881 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
7884 if No
(Freeze_Node
(E
)) then
7885 FN
:= Make_Freeze_Entity
(Sloc
(E
));
7886 Set_Has_Delayed_Freeze
(E
);
7887 Set_Freeze_Node
(E
, FN
);
7888 Set_Access_Types_To_Process
(FN
, No_Elist
);
7889 Set_TSS_Elist
(FN
, No_Elist
);
7892 end Ensure_Freeze_Node
;
7898 procedure Enter_Name
(Def_Id
: Entity_Id
) is
7899 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
7900 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
7901 S
: constant Entity_Id
:= Current_Scope
;
7904 Generate_Definition
(Def_Id
);
7906 -- Add new name to current scope declarations. Check for duplicate
7907 -- declaration, which may or may not be a genuine error.
7911 -- Case of previous entity entered because of a missing declaration
7912 -- or else a bad subtype indication. Best is to use the new entity,
7913 -- and make the previous one invisible.
7915 if Etype
(E
) = Any_Type
then
7916 Set_Is_Immediately_Visible
(E
, False);
7918 -- Case of renaming declaration constructed for package instances.
7919 -- if there is an explicit declaration with the same identifier,
7920 -- the renaming is not immediately visible any longer, but remains
7921 -- visible through selected component notation.
7923 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
7924 and then not Comes_From_Source
(E
)
7926 Set_Is_Immediately_Visible
(E
, False);
7928 -- The new entity may be the package renaming, which has the same
7929 -- same name as a generic formal which has been seen already.
7931 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
7932 and then not Comes_From_Source
(Def_Id
)
7934 Set_Is_Immediately_Visible
(E
, False);
7936 -- For a fat pointer corresponding to a remote access to subprogram,
7937 -- we use the same identifier as the RAS type, so that the proper
7938 -- name appears in the stub. This type is only retrieved through
7939 -- the RAS type and never by visibility, and is not added to the
7940 -- visibility list (see below).
7942 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
7943 and then Ekind
(Def_Id
) = E_Record_Type
7944 and then Present
(Corresponding_Remote_Type
(Def_Id
))
7948 -- Case of an implicit operation or derived literal. The new entity
7949 -- hides the implicit one, which is removed from all visibility,
7950 -- i.e. the entity list of its scope, and homonym chain of its name.
7952 elsif (Is_Overloadable
(E
) and then Is_Inherited_Operation
(E
))
7953 or else Is_Internal
(E
)
7956 Decl
: constant Node_Id
:= Parent
(E
);
7958 Prev_Vis
: Entity_Id
;
7961 -- If E is an implicit declaration, it cannot be the first
7962 -- entity in the scope.
7964 Prev
:= First_Entity
(Current_Scope
);
7965 while Present
(Prev
) and then Next_Entity
(Prev
) /= E
loop
7971 -- If E is not on the entity chain of the current scope,
7972 -- it is an implicit declaration in the generic formal
7973 -- part of a generic subprogram. When analyzing the body,
7974 -- the generic formals are visible but not on the entity
7975 -- chain of the subprogram. The new entity will become
7976 -- the visible one in the body.
7979 (Nkind
(Parent
(Decl
)) = N_Generic_Subprogram_Declaration
);
7983 Link_Entities
(Prev
, Next_Entity
(E
));
7985 if No
(Next_Entity
(Prev
)) then
7986 Set_Last_Entity
(Current_Scope
, Prev
);
7989 if E
= Current_Entity
(E
) then
7993 Prev_Vis
:= Current_Entity
(E
);
7994 while Homonym
(Prev_Vis
) /= E
loop
7995 Prev_Vis
:= Homonym
(Prev_Vis
);
7999 if Present
(Prev_Vis
) then
8001 -- Skip E in the visibility chain
8003 Set_Homonym
(Prev_Vis
, Homonym
(E
));
8006 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
8009 -- The inherited operation cannot be retrieved
8010 -- by name, even though it may remain accesssible
8011 -- in some cases involving subprogram bodies without
8012 -- specs appearing in with_clauses..
8014 Set_Is_Immediately_Visible
(E
, False);
8018 -- This section of code could use a comment ???
8020 elsif Present
(Etype
(E
))
8021 and then Is_Concurrent_Type
(Etype
(E
))
8026 -- If the homograph is a protected component renaming, it should not
8027 -- be hiding the current entity. Such renamings are treated as weak
8030 elsif Is_Prival
(E
) then
8031 Set_Is_Immediately_Visible
(E
, False);
8033 -- In this case the current entity is a protected component renaming.
8034 -- Perform minimal decoration by setting the scope and return since
8035 -- the prival should not be hiding other visible entities.
8037 elsif Is_Prival
(Def_Id
) then
8038 Set_Scope
(Def_Id
, Current_Scope
);
8041 -- Analogous to privals, the discriminal generated for an entry index
8042 -- parameter acts as a weak declaration. Perform minimal decoration
8043 -- to avoid bogus errors.
8045 elsif Is_Discriminal
(Def_Id
)
8046 and then Ekind
(Discriminal_Link
(Def_Id
)) = E_Entry_Index_Parameter
8048 Set_Scope
(Def_Id
, Current_Scope
);
8051 -- In the body or private part of an instance, a type extension may
8052 -- introduce a component with the same name as that of an actual. The
8053 -- legality rule is not enforced, but the semantics of the full type
8054 -- with two components of same name are not clear at this point???
8056 elsif In_Instance_Not_Visible
then
8059 -- When compiling a package body, some child units may have become
8060 -- visible. They cannot conflict with local entities that hide them.
8062 elsif Is_Child_Unit
(E
)
8063 and then In_Open_Scopes
(Scope
(E
))
8064 and then not Is_Immediately_Visible
(E
)
8068 -- Conversely, with front-end inlining we may compile the parent body
8069 -- first, and a child unit subsequently. The context is now the
8070 -- parent spec, and body entities are not visible.
8072 elsif Is_Child_Unit
(Def_Id
)
8073 and then Is_Package_Body_Entity
(E
)
8074 and then not In_Package_Body
(Current_Scope
)
8078 -- Case of genuine duplicate declaration
8081 Error_Msg_Sloc
:= Sloc
(E
);
8083 -- If the previous declaration is an incomplete type declaration
8084 -- this may be an attempt to complete it with a private type. The
8085 -- following avoids confusing cascaded errors.
8087 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
8088 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
8091 ("incomplete type cannot be completed with a private " &
8092 "declaration", Parent
(Def_Id
));
8093 Set_Is_Immediately_Visible
(E
, False);
8094 Set_Full_View
(E
, Def_Id
);
8096 -- An inherited component of a record conflicts with a new
8097 -- discriminant. The discriminant is inserted first in the scope,
8098 -- but the error should be posted on it, not on the component.
8100 elsif Ekind
(E
) = E_Discriminant
8101 and then Present
(Scope
(Def_Id
))
8102 and then Scope
(Def_Id
) /= Current_Scope
8104 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8105 Error_Msg_N
("& conflicts with declaration#", E
);
8108 -- If the name of the unit appears in its own context clause, a
8109 -- dummy package with the name has already been created, and the
8110 -- error emitted. Try to continue quietly.
8112 elsif Error_Posted
(E
)
8113 and then Sloc
(E
) = No_Location
8114 and then Nkind
(Parent
(E
)) = N_Package_Specification
8115 and then Current_Scope
= Standard_Standard
8117 Set_Scope
(Def_Id
, Current_Scope
);
8121 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
8123 -- Avoid cascaded messages with duplicate components in
8126 if Ekind
(E
) in E_Component | E_Discriminant
then
8131 if Nkind
(Parent
(Parent
(Def_Id
))) =
8132 N_Generic_Subprogram_Declaration
8134 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
8136 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
8139 -- If entity is in standard, then we are in trouble, because it
8140 -- means that we have a library package with a duplicated name.
8141 -- That's hard to recover from, so abort.
8143 if S
= Standard_Standard
then
8144 raise Unrecoverable_Error
;
8146 -- Otherwise we continue with the declaration. Having two
8147 -- identical declarations should not cause us too much trouble.
8155 -- If we fall through, declaration is OK, at least OK enough to continue
8157 -- If Def_Id is a discriminant or a record component we are in the midst
8158 -- of inheriting components in a derived record definition. Preserve
8159 -- their Ekind and Etype.
8161 if Ekind
(Def_Id
) in E_Discriminant | E_Component
then
8164 -- If a type is already set, leave it alone (happens when a type
8165 -- declaration is reanalyzed following a call to the optimizer).
8167 elsif Present
(Etype
(Def_Id
)) then
8170 -- Otherwise, the kind E_Void insures that premature uses of the entity
8171 -- will be detected. Any_Type insures that no cascaded errors will occur
8174 Mutate_Ekind
(Def_Id
, E_Void
);
8175 Set_Etype
(Def_Id
, Any_Type
);
8178 -- All entities except Itypes are immediately visible
8180 if not Is_Itype
(Def_Id
) then
8181 Set_Is_Immediately_Visible
(Def_Id
);
8182 Set_Current_Entity
(Def_Id
);
8185 Set_Homonym
(Def_Id
, C
);
8186 Append_Entity
(Def_Id
, S
);
8187 Set_Public_Status
(Def_Id
);
8189 -- Warn if new entity hides an old one
8191 if Warn_On_Hiding
and then Present
(C
) then
8192 Warn_On_Hiding_Entity
(Def_Id
, Hidden
=> C
, Visible
=> Def_Id
,
8193 On_Use_Clause
=> False);
8201 function Entity_Of
(N
: Node_Id
) return Entity_Id
is
8206 -- Assume that the arbitrary node does not have an entity
8210 if Is_Entity_Name
(N
) then
8213 -- Follow a possible chain of renamings to reach the earliest renamed
8217 and then Is_Object
(Id
)
8218 and then Present
(Renamed_Object
(Id
))
8220 Ren
:= Renamed_Object
(Id
);
8222 -- The reference renames an abstract state or a whole object
8225 -- Ren : ... renames Obj;
8227 if Is_Entity_Name
(Ren
) then
8229 -- Do not follow a renaming that goes through a generic formal,
8230 -- because these entities are hidden and must not be referenced
8231 -- from outside the generic.
8233 if Is_Hidden
(Entity
(Ren
)) then
8240 -- The reference renames a function result. Check the original
8241 -- node in case expansion relocates the function call.
8243 -- Ren : ... renames Func_Call;
8245 elsif Nkind
(Original_Node
(Ren
)) = N_Function_Call
then
8248 -- Otherwise the reference renames something which does not yield
8249 -- an abstract state or a whole object. Treat the reference as not
8250 -- having a proper entity for SPARK legality purposes.
8262 --------------------------
8263 -- Examine_Array_Bounds --
8264 --------------------------
8266 procedure Examine_Array_Bounds
8268 All_Static
: out Boolean;
8269 Has_Empty
: out Boolean)
8271 function Is_OK_Static_Bound
(Bound
: Node_Id
) return Boolean;
8272 -- Determine whether bound Bound is a suitable static bound
8274 ------------------------
8275 -- Is_OK_Static_Bound --
8276 ------------------------
8278 function Is_OK_Static_Bound
(Bound
: Node_Id
) return Boolean is
8281 not Error_Posted
(Bound
)
8282 and then Is_OK_Static_Expression
(Bound
);
8283 end Is_OK_Static_Bound
;
8291 -- Start of processing for Examine_Array_Bounds
8294 -- An unconstrained array type does not have static bounds, and it is
8295 -- not known whether they are empty or not.
8297 if not Is_Constrained
(Typ
) then
8298 All_Static
:= False;
8301 -- A string literal has static bounds, and is not empty as long as it
8302 -- contains at least one character.
8304 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
8306 Has_Empty
:= String_Literal_Length
(Typ
) > 0;
8309 -- Assume that all bounds are static and not empty
8314 -- Examine each index
8316 Index
:= First_Index
(Typ
);
8317 while Present
(Index
) loop
8318 if Is_Discrete_Type
(Etype
(Index
)) then
8319 Get_Index_Bounds
(Index
, Lo_Bound
, Hi_Bound
);
8321 if Is_OK_Static_Bound
(Lo_Bound
)
8323 Is_OK_Static_Bound
(Hi_Bound
)
8325 -- The static bounds produce an empty range
8327 if Is_Null_Range
(Lo_Bound
, Hi_Bound
) then
8331 -- Otherwise at least one of the bounds is not static
8334 All_Static
:= False;
8337 -- Otherwise the index is non-discrete, therefore not static
8340 All_Static
:= False;
8345 end Examine_Array_Bounds
;
8351 function Exceptions_OK
return Boolean is
8354 not (Restriction_Active
(No_Exception_Handlers
) or else
8355 Restriction_Active
(No_Exception_Propagation
) or else
8356 Restriction_Active
(No_Exceptions
));
8359 --------------------------
8360 -- Explain_Limited_Type --
8361 --------------------------
8363 procedure Explain_Limited_Type
(T
: Entity_Id
; N
: Node_Id
) is
8367 -- For array, component type must be limited
8369 if Is_Array_Type
(T
) then
8370 Error_Msg_Node_2
:= T
;
8372 ("\component type& of type& is limited", N
, Component_Type
(T
));
8373 Explain_Limited_Type
(Component_Type
(T
), N
);
8375 elsif Is_Record_Type
(T
) then
8377 -- No need for extra messages if explicit limited record
8379 if Is_Limited_Record
(Base_Type
(T
)) then
8383 -- Otherwise find a limited component. Check only components that
8384 -- come from source, or inherited components that appear in the
8385 -- source of the ancestor.
8387 C
:= First_Component
(T
);
8388 while Present
(C
) loop
8389 if Is_Limited_Type
(Etype
(C
))
8391 (Comes_From_Source
(C
)
8393 (Present
(Original_Record_Component
(C
))
8395 Comes_From_Source
(Original_Record_Component
(C
))))
8397 Error_Msg_Node_2
:= T
;
8398 Error_Msg_NE
("\component& of type& has limited type", N
, C
);
8399 Explain_Limited_Type
(Etype
(C
), N
);
8406 -- The type may be declared explicitly limited, even if no component
8407 -- of it is limited, in which case we fall out of the loop.
8410 end Explain_Limited_Type
;
8412 ---------------------------------------
8413 -- Expression_Of_Expression_Function --
8414 ---------------------------------------
8416 function Expression_Of_Expression_Function
8417 (Subp
: Entity_Id
) return Node_Id
8419 Expr_Func
: Node_Id
:= Empty
;
8422 pragma Assert
(Is_Expression_Function_Or_Completion
(Subp
));
8424 if Nkind
(Original_Node
(Subprogram_Spec
(Subp
))) =
8425 N_Expression_Function
8427 Expr_Func
:= Original_Node
(Subprogram_Spec
(Subp
));
8429 elsif Nkind
(Original_Node
(Subprogram_Body
(Subp
))) =
8430 N_Expression_Function
8432 Expr_Func
:= Original_Node
(Subprogram_Body
(Subp
));
8435 pragma Assert
(False);
8439 return Original_Node
(Expression
(Expr_Func
));
8440 end Expression_Of_Expression_Function
;
8442 -------------------------------
8443 -- Extensions_Visible_Status --
8444 -------------------------------
8446 function Extensions_Visible_Status
8447 (Id
: Entity_Id
) return Extensions_Visible_Mode
8456 -- When a formal parameter is subject to Extensions_Visible, the pragma
8457 -- is stored in the contract of related subprogram.
8459 if Is_Formal
(Id
) then
8462 elsif Is_Subprogram_Or_Generic_Subprogram
(Id
) then
8465 -- No other construct carries this pragma
8468 return Extensions_Visible_None
;
8471 Prag
:= Get_Pragma
(Subp
, Pragma_Extensions_Visible
);
8473 -- In certain cases analysis may request the Extensions_Visible status
8474 -- of an expression function before the pragma has been analyzed yet.
8475 -- Inspect the declarative items after the expression function looking
8476 -- for the pragma (if any).
8478 if No
(Prag
) and then Is_Expression_Function
(Subp
) then
8479 Decl
:= Next
(Unit_Declaration_Node
(Subp
));
8480 while Present
(Decl
) loop
8481 if Nkind
(Decl
) = N_Pragma
8482 and then Pragma_Name
(Decl
) = Name_Extensions_Visible
8487 -- A source construct ends the region where Extensions_Visible may
8488 -- appear, stop the traversal. An expanded expression function is
8489 -- no longer a source construct, but it must still be recognized.
8491 elsif Comes_From_Source
(Decl
)
8493 (Nkind
(Decl
) in N_Subprogram_Body | N_Subprogram_Declaration
8494 and then Is_Expression_Function
(Defining_Entity
(Decl
)))
8503 -- Extract the value from the Boolean expression (if any)
8505 if Present
(Prag
) then
8506 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
8508 if Present
(Arg
) then
8509 Expr
:= Get_Pragma_Arg
(Arg
);
8511 -- When the associated subprogram is an expression function, the
8512 -- argument of the pragma may not have been analyzed.
8514 if not Analyzed
(Expr
) then
8515 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
8518 -- Guard against cascading errors when the argument of pragma
8519 -- Extensions_Visible is not a valid static Boolean expression.
8521 if Error_Posted
(Expr
) then
8522 return Extensions_Visible_None
;
8524 elsif Is_True
(Expr_Value
(Expr
)) then
8525 return Extensions_Visible_True
;
8528 return Extensions_Visible_False
;
8531 -- Otherwise the aspect or pragma defaults to True
8534 return Extensions_Visible_True
;
8537 -- Otherwise aspect or pragma Extensions_Visible is not inherited or
8538 -- directly specified. In SPARK code, its value defaults to "False".
8540 elsif SPARK_Mode
= On
then
8541 return Extensions_Visible_False
;
8543 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to
8547 return Extensions_Visible_True
;
8549 end Extensions_Visible_Status
;
8555 procedure Find_Actual
8557 Formal
: out Entity_Id
;
8560 Context
: constant Node_Id
:= Parent
(N
);
8565 if Nkind
(Context
) in N_Indexed_Component | N_Selected_Component
8566 and then N
= Prefix
(Context
)
8568 Find_Actual
(Context
, Formal
, Call
);
8571 elsif Nkind
(Context
) = N_Parameter_Association
8572 and then N
= Explicit_Actual_Parameter
(Context
)
8574 Call
:= Parent
(Context
);
8576 elsif Nkind
(Context
) in N_Entry_Call_Statement
8578 | N_Procedure_Call_Statement
8588 -- If we have a call to a subprogram look for the parameter. Note that
8589 -- we exclude overloaded calls, since we don't know enough to be sure
8590 -- of giving the right answer in this case.
8592 if Nkind
(Call
) in N_Entry_Call_Statement
8594 | N_Procedure_Call_Statement
8596 Call_Nam
:= Name
(Call
);
8598 -- A call to an entry family may appear as an indexed component
8600 if Nkind
(Call_Nam
) = N_Indexed_Component
then
8601 Call_Nam
:= Prefix
(Call_Nam
);
8604 -- A call to a protected or task entry appears as a selected
8605 -- component rather than an expanded name.
8607 if Nkind
(Call_Nam
) = N_Selected_Component
then
8608 Call_Nam
:= Selector_Name
(Call_Nam
);
8611 if Is_Entity_Name
(Call_Nam
)
8612 and then Present
(Entity
(Call_Nam
))
8613 and then (Is_Generic_Subprogram
(Entity
(Call_Nam
))
8614 or else Is_Overloadable
(Entity
(Call_Nam
))
8615 or else Ekind
(Entity
(Call_Nam
)) in E_Entry_Family
8617 | E_Subprogram_Type
)
8618 and then not Is_Overloaded
(Call_Nam
)
8620 -- If node is name in call it is not an actual
8622 if N
= Call_Nam
then
8628 -- Fall here if we are definitely a parameter
8630 Actual
:= First_Actual
(Call
);
8631 Formal
:= First_Formal
(Entity
(Call_Nam
));
8632 while Present
(Formal
) and then Present
(Actual
) loop
8636 -- An actual that is the prefix in a prefixed call may have
8637 -- been rewritten in the call. Check if sloc and kinds and
8640 elsif Sloc
(Actual
) = Sloc
(N
)
8641 and then Nkind
(Actual
) = N_Identifier
8642 and then Nkind
(Actual
) = Nkind
(N
)
8643 and then Chars
(Actual
) = Chars
(N
)
8648 Next_Actual
(Actual
);
8649 Next_Formal
(Formal
);
8655 -- Fall through here if we did not find matching actual
8661 ---------------------------
8662 -- Find_Body_Discriminal --
8663 ---------------------------
8665 function Find_Body_Discriminal
8666 (Spec_Discriminant
: Entity_Id
) return Entity_Id
8672 -- If expansion is suppressed, then the scope can be the concurrent type
8673 -- itself rather than a corresponding concurrent record type.
8675 if Is_Concurrent_Type
(Scope
(Spec_Discriminant
)) then
8676 Tsk
:= Scope
(Spec_Discriminant
);
8679 pragma Assert
(Is_Concurrent_Record_Type
(Scope
(Spec_Discriminant
)));
8681 Tsk
:= Corresponding_Concurrent_Type
(Scope
(Spec_Discriminant
));
8684 -- Find discriminant of original concurrent type, and use its current
8685 -- discriminal, which is the renaming within the task/protected body.
8687 Disc
:= First_Discriminant
(Tsk
);
8688 while Present
(Disc
) loop
8689 if Chars
(Disc
) = Chars
(Spec_Discriminant
) then
8690 return Discriminal
(Disc
);
8693 Next_Discriminant
(Disc
);
8696 -- That loop should always succeed in finding a matching entry and
8697 -- returning. Fatal error if not.
8699 raise Program_Error
;
8700 end Find_Body_Discriminal
;
8702 -------------------------------------
8703 -- Find_Corresponding_Discriminant --
8704 -------------------------------------
8706 function Find_Corresponding_Discriminant
8708 Typ
: Entity_Id
) return Entity_Id
8710 Par_Disc
: Entity_Id
;
8711 Old_Disc
: Entity_Id
;
8712 New_Disc
: Entity_Id
;
8715 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
8717 -- The original type may currently be private, and the discriminant
8718 -- only appear on its full view.
8720 if Is_Private_Type
(Scope
(Par_Disc
))
8721 and then not Has_Discriminants
(Scope
(Par_Disc
))
8722 and then Present
(Full_View
(Scope
(Par_Disc
)))
8724 Old_Disc
:= First_Discriminant
(Full_View
(Scope
(Par_Disc
)));
8726 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
8729 if Is_Class_Wide_Type
(Typ
) then
8730 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
8732 New_Disc
:= First_Discriminant
(Typ
);
8735 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
8736 if Old_Disc
= Par_Disc
then
8740 Next_Discriminant
(Old_Disc
);
8741 Next_Discriminant
(New_Disc
);
8744 -- Should always find it
8746 raise Program_Error
;
8747 end Find_Corresponding_Discriminant
;
8753 function Find_DIC_Type
(Typ
: Entity_Id
) return Entity_Id
is
8754 Curr_Typ
: Entity_Id
;
8755 -- The current type being examined in the parent hierarchy traversal
8757 DIC_Typ
: Entity_Id
;
8758 -- The type which carries the DIC pragma. This variable denotes the
8759 -- partial view when private types are involved.
8761 Par_Typ
: Entity_Id
;
8762 -- The parent type of the current type. This variable denotes the full
8763 -- view when private types are involved.
8766 -- The input type defines its own DIC pragma, therefore it is the owner
8768 if Has_Own_DIC
(Typ
) then
8771 -- Otherwise the DIC pragma is inherited from a parent type
8774 pragma Assert
(Has_Inherited_DIC
(Typ
));
8776 -- Climb the parent chain
8780 -- Inspect the parent type. Do not consider subtypes as they
8781 -- inherit the DIC attributes from their base types.
8783 DIC_Typ
:= Base_Type
(Etype
(Curr_Typ
));
8785 -- Look at the full view of a private type because the type may
8786 -- have a hidden parent introduced in the full view.
8790 if Is_Private_Type
(Par_Typ
)
8791 and then Present
(Full_View
(Par_Typ
))
8793 Par_Typ
:= Full_View
(Par_Typ
);
8796 -- Stop the climb once the nearest parent type which defines a DIC
8797 -- pragma of its own is encountered or when the root of the parent
8798 -- chain is reached.
8800 exit when Has_Own_DIC
(DIC_Typ
) or else Curr_Typ
= Par_Typ
;
8802 Curr_Typ
:= Par_Typ
;
8809 ----------------------------------
8810 -- Find_Enclosing_Iterator_Loop --
8811 ----------------------------------
8813 function Find_Enclosing_Iterator_Loop
(Id
: Entity_Id
) return Entity_Id
is
8818 -- Traverse the scope chain looking for an iterator loop. Such loops are
8819 -- usually transformed into blocks, hence the use of Original_Node.
8822 while Present
(S
) and then S
/= Standard_Standard
loop
8823 if Ekind
(S
) = E_Loop
8824 and then Nkind
(Parent
(S
)) = N_Implicit_Label_Declaration
8826 Constr
:= Original_Node
(Label_Construct
(Parent
(S
)));
8828 if Nkind
(Constr
) = N_Loop_Statement
8829 and then Present
(Iteration_Scheme
(Constr
))
8830 and then Nkind
(Iterator_Specification
8831 (Iteration_Scheme
(Constr
))) =
8832 N_Iterator_Specification
8842 end Find_Enclosing_Iterator_Loop
;
8844 --------------------------
8845 -- Find_Enclosing_Scope --
8846 --------------------------
8848 function Find_Enclosing_Scope
(N
: Node_Id
) return Entity_Id
is
8852 -- Examine the parent chain looking for a construct which defines a
8856 while Present
(Par
) loop
8859 -- The construct denotes a declaration, the proper scope is its
8862 when N_Entry_Declaration
8863 | N_Expression_Function
8864 | N_Full_Type_Declaration
8865 | N_Generic_Package_Declaration
8866 | N_Generic_Subprogram_Declaration
8867 | N_Package_Declaration
8868 | N_Private_Extension_Declaration
8869 | N_Protected_Type_Declaration
8870 | N_Single_Protected_Declaration
8871 | N_Single_Task_Declaration
8872 | N_Subprogram_Declaration
8873 | N_Task_Type_Declaration
8875 return Defining_Entity
(Par
);
8877 -- The construct denotes a body, the proper scope is the entity of
8878 -- the corresponding spec or that of the body if the body does not
8879 -- complete a previous declaration.
8887 return Unique_Defining_Entity
(Par
);
8891 -- Blocks carry either a source or an internally-generated scope,
8892 -- unless the block is a byproduct of exception handling.
8894 when N_Block_Statement
=>
8895 if not Exception_Junk
(Par
) then
8896 return Entity
(Identifier
(Par
));
8899 -- Loops carry an internally-generated scope
8901 when N_Loop_Statement
=>
8902 return Entity
(Identifier
(Par
));
8904 -- Extended return statements carry an internally-generated scope
8906 when N_Extended_Return_Statement
=>
8907 return Return_Statement_Entity
(Par
);
8909 -- A traversal from a subunit continues via the corresponding stub
8912 Par
:= Corresponding_Stub
(Par
);
8918 Par
:= Parent
(Par
);
8921 return Standard_Standard
;
8922 end Find_Enclosing_Scope
;
8924 ------------------------------------
8925 -- Find_Loop_In_Conditional_Block --
8926 ------------------------------------
8928 function Find_Loop_In_Conditional_Block
(N
: Node_Id
) return Node_Id
is
8934 if Nkind
(Stmt
) = N_If_Statement
then
8935 Stmt
:= First
(Then_Statements
(Stmt
));
8938 pragma Assert
(Nkind
(Stmt
) = N_Block_Statement
);
8940 -- Inspect the statements of the conditional block. In general the loop
8941 -- should be the first statement in the statement sequence of the block,
8942 -- but the finalization machinery may have introduced extra object
8945 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Stmt
)));
8946 while Present
(Stmt
) loop
8947 if Nkind
(Stmt
) = N_Loop_Statement
then
8954 -- The expansion of attribute 'Loop_Entry produced a malformed block
8956 raise Program_Error
;
8957 end Find_Loop_In_Conditional_Block
;
8959 --------------------------
8960 -- Find_Overlaid_Entity --
8961 --------------------------
8963 procedure Find_Overlaid_Entity
8965 Ent
: out Entity_Id
;
8969 (Nkind
(N
) = N_Attribute_Definition_Clause
8970 and then Chars
(N
) = Name_Address
);
8975 -- We are looking for one of the two following forms:
8977 -- for X'Address use Y'Address
8981 -- Const : constant Address := expr;
8983 -- for X'Address use Const;
8985 -- In the second case, the expr is either Y'Address, or recursively a
8986 -- constant that eventually references Y'Address.
8991 Expr
:= Expression
(N
);
8993 -- This loop checks the form of the expression for Y'Address, using
8994 -- recursion to deal with intermediate constants.
8997 -- Check for Y'Address
8999 if Nkind
(Expr
) = N_Attribute_Reference
9000 and then Attribute_Name
(Expr
) = Name_Address
9002 Expr
:= Prefix
(Expr
);
9005 -- Check for Const where Const is a constant entity
9007 elsif Is_Entity_Name
(Expr
)
9008 and then Ekind
(Entity
(Expr
)) = E_Constant
9010 Expr
:= Constant_Value
(Entity
(Expr
));
9012 -- Anything else does not need checking
9019 -- This loop checks the form of the prefix for an entity, using
9020 -- recursion to deal with intermediate components.
9023 -- Check for Y where Y is an entity
9025 if Is_Entity_Name
(Expr
) then
9026 Ent
:= Entity
(Expr
);
9028 -- If expansion is disabled, then we might see an entity of a
9029 -- protected component or of a discriminant of a concurrent unit.
9030 -- Ignore such entities, because further warnings for overlays
9031 -- expect this routine to only collect entities of entire objects.
9033 if Ekind
(Ent
) in E_Component | E_Discriminant
then
9035 (not Expander_Active
9036 and then Is_Concurrent_Type
(Scope
(Ent
)));
9041 -- Check for components
9043 elsif Nkind
(Expr
) in N_Selected_Component | N_Indexed_Component
then
9044 Expr
:= Prefix
(Expr
);
9047 -- Anything else does not need checking
9053 end Find_Overlaid_Entity
;
9055 -------------------------
9056 -- Find_Parameter_Type --
9057 -------------------------
9059 function Find_Parameter_Type
(Param
: Node_Id
) return Entity_Id
is
9061 if Nkind
(Param
) /= N_Parameter_Specification
then
9064 -- For an access parameter, obtain the type from the formal entity
9065 -- itself, because access to subprogram nodes do not carry a type.
9066 -- Shouldn't we always use the formal entity ???
9068 elsif Nkind
(Parameter_Type
(Param
)) = N_Access_Definition
then
9069 return Etype
(Defining_Identifier
(Param
));
9072 return Etype
(Parameter_Type
(Param
));
9074 end Find_Parameter_Type
;
9076 -----------------------------------
9077 -- Find_Placement_In_State_Space --
9078 -----------------------------------
9080 procedure Find_Placement_In_State_Space
9081 (Item_Id
: Entity_Id
;
9082 Placement
: out State_Space_Kind
;
9083 Pack_Id
: out Entity_Id
)
9085 function Inside_Package_Body
(Id
: Entity_Id
) return Boolean;
9086 function Inside_Private_Part
(Id
: Entity_Id
) return Boolean;
9087 -- Return True if Id is declared directly within the package body
9088 -- and the package private parts, respectively. We cannot use
9089 -- In_Private_Part/In_Body_Part flags, as these are only set during the
9090 -- analysis of the package itself, while Find_Placement_In_State_Space
9091 -- can be called on an entity of another package.
9093 ------------------------
9094 -- Inside_Package_Body --
9095 ------------------------
9097 function Inside_Package_Body
(Id
: Entity_Id
) return Boolean is
9098 Spec_Id
: constant Entity_Id
:= Scope
(Id
);
9099 Body_Decl
: constant Opt_N_Package_Body_Id
:= Package_Body
(Spec_Id
);
9100 Decl
: constant Node_Id
:= Enclosing_Declaration
(Id
);
9102 if Present
(Body_Decl
)
9103 and then Is_List_Member
(Decl
)
9104 and then List_Containing
(Decl
) = Declarations
(Body_Decl
)
9110 end Inside_Package_Body
;
9112 -------------------------
9113 -- Inside_Private_Part --
9114 -------------------------
9116 function Inside_Private_Part
(Id
: Entity_Id
) return Boolean is
9117 Spec_Id
: constant Entity_Id
:= Scope
(Id
);
9118 Private_Decls
: constant List_Id
:=
9119 Private_Declarations
(Package_Specification
(Spec_Id
));
9120 Decl
: constant Node_Id
:= Enclosing_Declaration
(Id
);
9122 if Is_List_Member
(Decl
)
9123 and then List_Containing
(Decl
) = Private_Decls
9127 elsif Ekind
(Id
) = E_Package
9128 and then Is_Private_Library_Unit
(Id
)
9135 end Inside_Private_Part
;
9139 Context
: Entity_Id
;
9141 -- Start of processing for Find_Placement_In_State_Space
9144 -- Assume that the item does not appear in the state space of a package
9146 Placement
:= Not_In_Package
;
9148 -- Climb the scope stack and examine the enclosing context
9151 Pack_Id
:= Scope
(Context
);
9152 while Present
(Pack_Id
) and then Pack_Id
/= Standard_Standard
loop
9153 if Is_Package_Or_Generic_Package
(Pack_Id
) then
9155 -- A package body is a cut off point for the traversal as the
9156 -- item cannot be visible to the outside from this point on.
9158 if Inside_Package_Body
(Context
) then
9159 Placement
:= Body_State_Space
;
9162 -- The private part of a package is a cut off point for the
9163 -- traversal as the item cannot be visible to the outside
9164 -- from this point on.
9166 elsif Inside_Private_Part
(Context
) then
9167 Placement
:= Private_State_Space
;
9170 -- When the item appears in the visible state space of a package,
9171 -- continue to climb the scope stack as this may not be the final
9175 Placement
:= Visible_State_Space
;
9177 -- The visible state space of a child unit acts as the proper
9178 -- placement of an item, unless this is a private child unit.
9180 if Is_Child_Unit
(Pack_Id
)
9181 and then not Is_Private_Library_Unit
(Pack_Id
)
9187 -- The item or its enclosing package appear in a construct that has
9191 Placement
:= Not_In_Package
;
9196 Context
:= Scope
(Context
);
9197 Pack_Id
:= Scope
(Context
);
9199 end Find_Placement_In_State_Space
;
9201 -----------------------
9202 -- Find_Primitive_Eq --
9203 -----------------------
9205 function Find_Primitive_Eq
(Typ
: Entity_Id
) return Entity_Id
is
9206 function Find_Eq_Prim
(Prims_List
: Elist_Id
) return Entity_Id
;
9207 -- Search for the equality primitive; return Empty if the primitive is
9214 function Find_Eq_Prim
(Prims_List
: Elist_Id
) return Entity_Id
is
9216 Prim_Elmt
: Elmt_Id
;
9219 Prim_Elmt
:= First_Elmt
(Prims_List
);
9220 while Present
(Prim_Elmt
) loop
9221 Prim
:= Node
(Prim_Elmt
);
9223 -- Locate primitive equality with the right signature
9225 if Chars
(Prim
) = Name_Op_Eq
9226 and then Etype
(First_Formal
(Prim
)) =
9227 Etype
(Next_Formal
(First_Formal
(Prim
)))
9228 and then Base_Type
(Etype
(Prim
)) = Standard_Boolean
9233 Next_Elmt
(Prim_Elmt
);
9241 Eq_Prim
: Entity_Id
;
9242 Full_Type
: Entity_Id
;
9244 -- Start of processing for Find_Primitive_Eq
9247 if Is_Private_Type
(Typ
) then
9248 Full_Type
:= Underlying_Type
(Typ
);
9253 if No
(Full_Type
) then
9257 Full_Type
:= Base_Type
(Full_Type
);
9259 -- When the base type itself is private, use the full view
9261 if Is_Private_Type
(Full_Type
) then
9262 Full_Type
:= Underlying_Type
(Full_Type
);
9265 if Is_Class_Wide_Type
(Full_Type
) then
9266 Full_Type
:= Root_Type
(Full_Type
);
9269 if not Is_Tagged_Type
(Full_Type
) then
9270 Eq_Prim
:= Find_Eq_Prim
(Collect_Primitive_Operations
(Typ
));
9272 -- If this is an untagged private type completed with a derivation of
9273 -- an untagged private type whose full view is a tagged type, we use
9274 -- the primitive operations of the private parent type (since it does
9275 -- not have a full view, and also because its equality primitive may
9276 -- have been overridden in its untagged full view). If no equality was
9277 -- defined for it then take its dispatching equality primitive.
9279 elsif Inherits_From_Tagged_Full_View
(Typ
) then
9280 Eq_Prim
:= Find_Eq_Prim
(Collect_Primitive_Operations
(Typ
));
9282 if No
(Eq_Prim
) then
9283 Eq_Prim
:= Find_Eq_Prim
(Primitive_Operations
(Full_Type
));
9287 Eq_Prim
:= Find_Eq_Prim
(Primitive_Operations
(Full_Type
));
9291 end Find_Primitive_Eq
;
9293 ------------------------
9294 -- Find_Specific_Type --
9295 ------------------------
9297 function Find_Specific_Type
(CW
: Entity_Id
) return Entity_Id
is
9298 Typ
: Entity_Id
:= Root_Type
(CW
);
9301 if Ekind
(Typ
) = E_Incomplete_Type
then
9302 if From_Limited_With
(Typ
) then
9303 Typ
:= Non_Limited_View
(Typ
);
9305 Typ
:= Full_View
(Typ
);
9309 if Is_Private_Type
(Typ
)
9310 and then not Is_Tagged_Type
(Typ
)
9311 and then Present
(Full_View
(Typ
))
9313 return Full_View
(Typ
);
9317 end Find_Specific_Type
;
9319 -----------------------------
9320 -- Find_Static_Alternative --
9321 -----------------------------
9323 function Find_Static_Alternative
(N
: Node_Id
) return Node_Id
is
9324 Expr
: constant Node_Id
:= Expression
(N
);
9325 Val
: constant Uint
:= Expr_Value
(Expr
);
9330 Alt
:= First
(Alternatives
(N
));
9333 if Nkind
(Alt
) /= N_Pragma
then
9334 Choice
:= First
(Discrete_Choices
(Alt
));
9335 while Present
(Choice
) loop
9337 -- Others choice, always matches
9339 if Nkind
(Choice
) = N_Others_Choice
then
9342 -- Range, check if value is in the range
9344 elsif Nkind
(Choice
) = N_Range
then
9346 Val
>= Expr_Value
(Low_Bound
(Choice
))
9348 Val
<= Expr_Value
(High_Bound
(Choice
));
9350 -- Choice is a subtype name. Note that we know it must
9351 -- be a static subtype, since otherwise it would have
9352 -- been diagnosed as illegal.
9354 elsif Is_Entity_Name
(Choice
)
9355 and then Is_Type
(Entity
(Choice
))
9357 exit Search
when Is_In_Range
(Expr
, Etype
(Choice
),
9358 Assume_Valid
=> False);
9360 -- Choice is a subtype indication
9362 elsif Nkind
(Choice
) = N_Subtype_Indication
then
9364 C
: constant Node_Id
:= Constraint
(Choice
);
9365 R
: constant Node_Id
:= Range_Expression
(C
);
9369 Val
>= Expr_Value
(Low_Bound
(R
))
9371 Val
<= Expr_Value
(High_Bound
(R
));
9374 -- Choice is a simple expression
9377 exit Search
when Val
= Expr_Value
(Choice
);
9385 pragma Assert
(Present
(Alt
));
9388 -- The above loop *must* terminate by finding a match, since we know the
9389 -- case statement is valid, and the value of the expression is known at
9390 -- compile time. When we fall out of the loop, Alt points to the
9391 -- alternative that we know will be selected at run time.
9394 end Find_Static_Alternative
;
9400 function First_Actual
(Node
: Node_Id
) return Node_Id
is
9404 if No
(Parameter_Associations
(Node
)) then
9408 N
:= First
(Parameter_Associations
(Node
));
9410 if Nkind
(N
) = N_Parameter_Association
then
9411 return First_Named_Actual
(Node
);
9421 function First_Global
9423 Global_Mode
: Name_Id
;
9424 Refined
: Boolean := False) return Node_Id
9426 function First_From_Global_List
9428 Global_Mode
: Name_Id
:= Name_Input
) return Entity_Id
;
9429 -- Get the first item with suitable mode from List
9431 ----------------------------
9432 -- First_From_Global_List --
9433 ----------------------------
9435 function First_From_Global_List
9437 Global_Mode
: Name_Id
:= Name_Input
) return Entity_Id
9442 -- Empty list (no global items)
9444 if Nkind
(List
) = N_Null
then
9447 -- Single global item declaration (only input items)
9449 elsif Nkind
(List
) in N_Expanded_Name | N_Identifier
then
9450 if Global_Mode
= Name_Input
then
9456 -- Simple global list (only input items) or moded global list
9459 elsif Nkind
(List
) = N_Aggregate
then
9460 if Present
(Expressions
(List
)) then
9461 if Global_Mode
= Name_Input
then
9462 return First
(Expressions
(List
));
9468 Assoc
:= First
(Component_Associations
(List
));
9469 while Present
(Assoc
) loop
9471 -- When we find the desired mode in an association, call
9472 -- recursively First_From_Global_List as if the mode was
9473 -- Name_Input, in order to reuse the existing machinery
9474 -- for the other cases.
9476 if Chars
(First
(Choices
(Assoc
))) = Global_Mode
then
9477 return First_From_Global_List
(Expression
(Assoc
));
9486 -- To accommodate partial decoration of disabled SPARK features,
9487 -- this routine may be called with illegal input. If this is the
9488 -- case, do not raise Program_Error.
9493 end First_From_Global_List
;
9497 Global
: Node_Id
:= Empty
;
9498 Body_Id
: Entity_Id
;
9500 -- Start of processing for First_Global
9503 pragma Assert
(Global_Mode
in Name_In_Out
9508 -- Retrieve the suitable pragma Global or Refined_Global. In the second
9509 -- case, it can only be located on the body entity.
9512 if Is_Subprogram_Or_Generic_Subprogram
(Subp
) then
9513 Body_Id
:= Subprogram_Body_Entity
(Subp
);
9515 elsif Is_Entry
(Subp
) or else Is_Task_Type
(Subp
) then
9516 Body_Id
:= Corresponding_Body
(Parent
(Subp
));
9518 -- ??? It should be possible to retrieve the Refined_Global on the
9519 -- task body associated to the task object. This is not yet possible.
9521 elsif Is_Single_Task_Object
(Subp
) then
9528 if Present
(Body_Id
) then
9529 Global
:= Get_Pragma
(Body_Id
, Pragma_Refined_Global
);
9532 Global
:= Get_Pragma
(Subp
, Pragma_Global
);
9535 -- No corresponding global if pragma is not present
9540 -- Otherwise retrieve the corresponding list of items depending on the
9544 return First_From_Global_List
9545 (Expression
(Get_Argument
(Global
, Subp
)), Global_Mode
);
9553 function Fix_Msg
(Id
: Entity_Id
; Msg
: String) return String is
9554 Is_Task
: constant Boolean :=
9555 Ekind
(Id
) in E_Task_Body | E_Task_Type
9556 or else Is_Single_Task_Object
(Id
);
9557 Msg_Last
: constant Natural := Msg
'Last;
9558 Msg_Index
: Natural;
9559 Res
: String (Msg
'Range) := (others => ' ');
9560 Res_Index
: Natural;
9563 -- Copy all characters from the input message Msg to result Res with
9564 -- suitable replacements.
9566 Msg_Index
:= Msg
'First;
9567 Res_Index
:= Res
'First;
9568 while Msg_Index
<= Msg_Last
loop
9570 -- Replace "subprogram" with a different word
9572 if Msg_Index
<= Msg_Last
- 10
9573 and then Msg
(Msg_Index
.. Msg_Index
+ 9) = "subprogram"
9575 if Is_Entry
(Id
) then
9576 Res
(Res_Index
.. Res_Index
+ 4) := "entry";
9577 Res_Index
:= Res_Index
+ 5;
9580 Res
(Res_Index
.. Res_Index
+ 8) := "task type";
9581 Res_Index
:= Res_Index
+ 9;
9584 Res
(Res_Index
.. Res_Index
+ 9) := "subprogram";
9585 Res_Index
:= Res_Index
+ 10;
9588 Msg_Index
:= Msg_Index
+ 10;
9590 -- Replace "protected" with a different word
9592 elsif Msg_Index
<= Msg_Last
- 9
9593 and then Msg
(Msg_Index
.. Msg_Index
+ 8) = "protected"
9596 Res
(Res_Index
.. Res_Index
+ 3) := "task";
9597 Res_Index
:= Res_Index
+ 4;
9598 Msg_Index
:= Msg_Index
+ 9;
9600 -- Otherwise copy the character
9603 Res
(Res_Index
) := Msg
(Msg_Index
);
9604 Msg_Index
:= Msg_Index
+ 1;
9605 Res_Index
:= Res_Index
+ 1;
9609 return Res
(Res
'First .. Res_Index
- 1);
9612 -------------------------
9613 -- From_Nested_Package --
9614 -------------------------
9616 function From_Nested_Package
(T
: Entity_Id
) return Boolean is
9617 Pack
: constant Entity_Id
:= Scope
(T
);
9621 Ekind
(Pack
) = E_Package
9622 and then not Is_Frozen
(Pack
)
9623 and then not Scope_Within_Or_Same
(Current_Scope
, Pack
)
9624 and then In_Open_Scopes
(Scope
(Pack
));
9625 end From_Nested_Package
;
9627 -----------------------
9628 -- Gather_Components --
9629 -----------------------
9631 procedure Gather_Components
9633 Comp_List
: Node_Id
;
9634 Governed_By
: List_Id
;
9636 Report_Errors
: out Boolean;
9637 Allow_Compile_Time
: Boolean := False;
9638 Include_Interface_Tag
: Boolean := False)
9642 Discrete_Choice
: Node_Id
;
9643 Comp_Item
: Node_Id
;
9644 Discrim
: Entity_Id
;
9645 Discrim_Name
: Node_Id
;
9647 type Discriminant_Value_Status
is
9648 (Static_Expr
, Static_Subtype
, Bad
);
9649 subtype Good_Discrim_Value_Status
is Discriminant_Value_Status
9650 range Static_Expr
.. Static_Subtype
; -- range excludes Bad
9652 Discrim_Value
: Node_Id
;
9653 Discrim_Value_Subtype
: Node_Id
;
9654 Discrim_Value_Status
: Discriminant_Value_Status
:= Bad
;
9656 function OK_Scope_For_Discrim_Value_Error_Messages
return Boolean is
9657 (Scope
(Original_Record_Component
9658 (Entity
(First
(Choices
(Assoc
))))) = Typ
);
9659 -- Used to avoid generating error messages having a source position
9660 -- which refers to somewhere (e.g., a discriminant value in a derived
9661 -- tagged type declaration) unrelated to the offending construct. This
9662 -- is required for correctness - clients of Gather_Components such as
9663 -- Sem_Ch3.Create_Constrained_Components depend on this function
9664 -- returning True while processing semantically correct examples;
9665 -- generating an error message in this case would be wrong.
9668 Report_Errors
:= False;
9670 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
9673 elsif Present
(Component_Items
(Comp_List
)) then
9674 Comp_Item
:= First
(Component_Items
(Comp_List
));
9680 while Present
(Comp_Item
) loop
9682 -- Skip the tag of a tagged record, as well as all items that are not
9683 -- user components (anonymous types, rep clauses, Parent field,
9684 -- controller field).
9686 if Nkind
(Comp_Item
) = N_Component_Declaration
then
9688 Comp
: constant Entity_Id
:= Defining_Identifier
(Comp_Item
);
9690 if not (Is_Tag
(Comp
)
9692 (Include_Interface_Tag
9693 and then Etype
(Comp
) = RTE
(RE_Interface_Tag
)))
9694 and then Chars
(Comp
) /= Name_uParent
9696 Append_Elmt
(Comp
, Into
);
9704 if No
(Variant_Part
(Comp_List
)) then
9707 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
9708 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
9711 -- Look for the discriminant that governs this variant part.
9712 -- The discriminant *must* be in the Governed_By List
9714 Assoc
:= First
(Governed_By
);
9715 Find_Constraint
: loop
9716 Discrim
:= First
(Choices
(Assoc
));
9717 exit Find_Constraint
when
9718 Chars
(Discrim_Name
) = Chars
(Discrim
)
9720 (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
9721 and then Chars
(Corresponding_Discriminant
9722 (Entity
(Discrim
))) = Chars
(Discrim_Name
))
9724 Chars
(Original_Record_Component
(Entity
(Discrim
))) =
9725 Chars
(Discrim_Name
);
9727 if No
(Next
(Assoc
)) then
9728 if not Is_Constrained
(Typ
) and then Is_Derived_Type
(Typ
) then
9730 -- If the type is a tagged type with inherited discriminants,
9731 -- use the stored constraint on the parent in order to find
9732 -- the values of discriminants that are otherwise hidden by an
9733 -- explicit constraint. Renamed discriminants are handled in
9736 -- If several parent discriminants are renamed by a single
9737 -- discriminant of the derived type, the call to obtain the
9738 -- Corresponding_Discriminant field only retrieves the last
9739 -- of them. We recover the constraint on the others from the
9740 -- Stored_Constraint as well.
9742 -- An inherited discriminant may have been constrained in a
9743 -- later ancestor (not the immediate parent) so we must examine
9744 -- the stored constraint of all of them to locate the inherited
9750 T
: Entity_Id
:= Typ
;
9753 while Is_Derived_Type
(T
) loop
9754 if Present
(Stored_Constraint
(T
)) then
9755 D
:= First_Discriminant
(Etype
(T
));
9756 C
:= First_Elmt
(Stored_Constraint
(T
));
9757 while Present
(D
) and then Present
(C
) loop
9758 if Chars
(Discrim_Name
) = Chars
(D
) then
9759 if Is_Entity_Name
(Node
(C
))
9760 and then Entity
(Node
(C
)) = Entity
(Discrim
)
9762 -- D is renamed by Discrim, whose value is
9769 Make_Component_Association
(Sloc
(Typ
),
9771 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
9772 Duplicate_Subexpr_No_Checks
(Node
(C
)));
9775 exit Find_Constraint
;
9778 Next_Discriminant
(D
);
9783 -- Discriminant may be inherited from ancestor
9791 if No
(Next
(Assoc
)) then
9793 (" missing value for discriminant&",
9794 First
(Governed_By
), Discrim_Name
);
9796 Report_Errors
:= True;
9801 end loop Find_Constraint
;
9803 Discrim_Value
:= Expression
(Assoc
);
9805 if Is_OK_Static_Expression
(Discrim_Value
)
9806 or else (Allow_Compile_Time
9807 and then Compile_Time_Known_Value
(Discrim_Value
))
9809 Discrim_Value_Status
:= Static_Expr
;
9811 if Ada_Version
>= Ada_2022
then
9812 if Is_Rewrite_Substitution
(Discrim_Value
)
9813 and then Nkind
(Discrim_Value
) = N_Type_Conversion
9814 and then Etype
(Original_Node
(Discrim_Value
))
9815 = Etype
(Expression
(Discrim_Value
))
9817 Discrim_Value_Subtype
:= Etype
(Original_Node
(Discrim_Value
));
9818 -- An unhelpful (for this code) type conversion may be
9819 -- introduced in some cases; deal with it.
9821 Discrim_Value_Subtype
:= Etype
(Discrim_Value
);
9824 if Is_OK_Static_Subtype
(Discrim_Value_Subtype
) and then
9825 not Is_Null_Range
(Type_Low_Bound
(Discrim_Value_Subtype
),
9826 Type_High_Bound
(Discrim_Value_Subtype
))
9828 -- Is_Null_Range test doesn't account for predicates, as in
9829 -- subtype Null_By_Predicate is Natural
9830 -- with Static_Predicate => Null_By_Predicate < 0;
9831 -- so test for that null case separately.
9833 if (not Has_Static_Predicate
(Discrim_Value_Subtype
))
9834 or else Present
(First
(Static_Discrete_Predicate
9835 (Discrim_Value_Subtype
)))
9837 Discrim_Value_Status
:= Static_Subtype
;
9842 if Discrim_Value_Status
= Bad
then
9844 -- If the variant part is governed by a discriminant of the type
9845 -- this is an error. If the variant part and the discriminant are
9846 -- inherited from an ancestor this is legal (AI05-220) unless the
9847 -- components are being gathered for an aggregate, in which case
9848 -- the caller must check Report_Errors.
9850 -- In Ada 2022 the above rules are relaxed. A nonstatic governing
9851 -- discriminant is OK as long as it has a static subtype and
9852 -- every value of that subtype (and there must be at least one)
9853 -- selects the same variant.
9855 if OK_Scope_For_Discrim_Value_Error_Messages
then
9856 if Ada_Version
>= Ada_2022
then
9858 ("value for discriminant & must be static or " &
9859 "discriminant's nominal subtype must be static " &
9861 Discrim_Value
, Discrim
);
9864 ("value for discriminant & must be static!",
9865 Discrim_Value
, Discrim
);
9867 Why_Not_Static
(Discrim_Value
);
9870 Report_Errors
:= True;
9875 Search_For_Discriminant_Value
: declare
9881 UI_Discrim_Value
: Uint
;
9884 case Good_Discrim_Value_Status
'(Discrim_Value_Status) is
9886 UI_Discrim_Value := Expr_Value (Discrim_Value);
9887 when Static_Subtype =>
9888 -- Arbitrarily pick one value of the subtype and look
9889 -- for the variant associated with that value; we will
9890 -- check later that the same variant is associated with
9891 -- all of the other values of the subtype.
9892 if Has_Static_Predicate (Discrim_Value_Subtype) then
9894 Range_Or_Expr : constant Node_Id :=
9895 First (Static_Discrete_Predicate
9896 (Discrim_Value_Subtype));
9898 if Nkind (Range_Or_Expr) = N_Range then
9900 Expr_Value (Low_Bound (Range_Or_Expr));
9902 UI_Discrim_Value := Expr_Value (Range_Or_Expr);
9907 := Expr_Value (Type_Low_Bound (Discrim_Value_Subtype));
9911 Find_Discrete_Value : while Present (Variant) loop
9913 -- If a choice is a subtype with a static predicate, it must
9914 -- be rewritten as an explicit list of non-predicated choices.
9916 Expand_Static_Predicates_In_Choices (Variant);
9918 Discrete_Choice := First (Discrete_Choices (Variant));
9919 while Present (Discrete_Choice) loop
9920 exit Find_Discrete_Value when
9921 Nkind (Discrete_Choice) = N_Others_Choice;
9923 Get_Index_Bounds (Discrete_Choice, Low, High);
9925 UI_Low := Expr_Value (Low);
9926 UI_High := Expr_Value (High);
9928 exit Find_Discrete_Value when
9929 UI_Low <= UI_Discrim_Value
9931 UI_High >= UI_Discrim_Value;
9933 Next (Discrete_Choice);
9936 Next_Non_Pragma (Variant);
9937 end loop Find_Discrete_Value;
9938 end Search_For_Discriminant_Value;
9940 -- The case statement must include a variant that corresponds to the
9941 -- value of the discriminant, unless the discriminant type has a
9942 -- static predicate. In that case the absence of an others_choice that
9943 -- would cover this value becomes a run-time error (3.8.1 (21.1/2)).
9946 and then not Has_Static_Predicate (Etype (Discrim_Name))
9949 ("value of discriminant & is out of range", Discrim_Value, Discrim);
9950 Report_Errors := True;
9954 -- If we have found the corresponding choice, recursively add its
9955 -- components to the Into list. The nested components are part of
9956 -- the same record type.
9958 if Present (Variant) then
9959 if Discrim_Value_Status = Static_Subtype then
9961 Discrim_Value_Subtype_Intervals
9962 : constant Interval_Lists.Discrete_Interval_List
9963 := Interval_Lists.Type_Intervals (Discrim_Value_Subtype);
9966 : constant Interval_Lists.Discrete_Interval_List
9967 := Interval_Lists.Choice_List_Intervals
9968 (Discrete_Choices => Discrete_Choices (Variant));
9970 if not Interval_Lists.Is_Subset
9971 (Subset => Discrim_Value_Subtype_Intervals,
9972 Of_Set => Variant_Intervals)
9974 if OK_Scope_For_Discrim_Value_Error_Messages then
9976 ("no single variant is associated with all values of " &
9977 "the subtype of discriminant value &",
9978 Discrim_Value, Discrim);
9980 Report_Errors := True;
9987 (Typ, Component_List (Variant), Governed_By, Into,
9988 Report_Errors, Allow_Compile_Time);
9990 end Gather_Components;
9992 ------------------------
9993 -- Get_Actual_Subtype --
9994 ------------------------
9996 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
9997 Typ : constant Entity_Id := Etype (N);
9998 Utyp : Entity_Id := Underlying_Type (Typ);
10007 -- If what we have is an identifier that references a subprogram
10008 -- formal, or a variable or constant object, then we get the actual
10009 -- subtype from the referenced entity if one has been built.
10011 if Nkind (N) = N_Identifier
10013 (Is_Formal (Entity (N))
10014 or else Ekind (Entity (N)) = E_Constant
10015 or else Ekind (Entity (N)) = E_Variable)
10016 and then Present (Actual_Subtype (Entity (N)))
10018 return Actual_Subtype (Entity (N));
10020 -- Actual subtype of unchecked union is always itself. We never need
10021 -- the "real" actual subtype. If we did, we couldn't get it anyway
10022 -- because the discriminant is not available. The restrictions on
10023 -- Unchecked_Union are designed to make sure that this is OK.
10025 elsif Is_Unchecked_Union (Base_Type (Utyp)) then
10028 -- Here for the unconstrained case, we must find actual subtype
10029 -- No actual subtype is available, so we must build it on the fly.
10031 -- Checking the type, not the underlying type, for constrainedness
10032 -- seems to be necessary. Maybe all the tests should be on the type???
10034 elsif (not Is_Constrained (Typ))
10035 and then (Is_Array_Type (Utyp)
10036 or else (Is_Record_Type (Utyp)
10037 and then Has_Discriminants (Utyp)))
10038 and then not Has_Unknown_Discriminants (Utyp)
10039 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
10041 -- Nothing to do if in spec expression (why not???)
10043 if In_Spec_Expression then
10046 elsif Is_Private_Type (Typ) and then not Has_Discriminants (Typ) then
10048 -- If the type has no discriminants, there is no subtype to
10049 -- build, even if the underlying type is discriminated.
10053 -- Else build the actual subtype
10056 Decl := Build_Actual_Subtype (Typ, N);
10058 -- The call may yield a declaration, or just return the entity
10064 Atyp := Defining_Identifier (Decl);
10066 -- If Build_Actual_Subtype generated a new declaration then use it
10068 if Atyp /= Typ then
10070 -- The actual subtype is an Itype, so analyze the declaration,
10071 -- but do not attach it to the tree, to get the type defined.
10073 Set_Parent (Decl, N);
10074 Set_Is_Itype (Atyp);
10075 Analyze (Decl, Suppress => All_Checks);
10076 Set_Associated_Node_For_Itype (Atyp, N);
10077 if Expander_Active then
10078 Set_Has_Delayed_Freeze (Atyp, False);
10080 -- We need to freeze the actual subtype immediately. This is
10081 -- needed because otherwise this Itype will not get frozen
10082 -- at all; it is always safe to freeze on creation because
10083 -- any associated types must be frozen at this point.
10085 -- On the other hand, if we are performing preanalysis on
10086 -- a conjured-up copy of a name (see calls to
10087 -- Preanalyze_Range in sem_ch5.adb) then we don't want
10088 -- to freeze Atyp, now or ever. In this case, the tree
10089 -- we eventually pass to the back end should contain no
10090 -- references to Atyp (and a freeze node would contain
10091 -- such a reference). That's why Expander_Active is tested.
10093 Freeze_Itype (Atyp, N);
10097 -- Otherwise we did not build a declaration, so return original
10104 -- For all remaining cases, the actual subtype is the same as
10105 -- the nominal type.
10110 end Get_Actual_Subtype;
10112 -------------------------------------
10113 -- Get_Actual_Subtype_If_Available --
10114 -------------------------------------
10116 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
10117 Typ : constant Entity_Id := Etype (N);
10120 -- If what we have is an identifier that references a subprogram
10121 -- formal, or a variable or constant object, then we get the actual
10122 -- subtype from the referenced entity if one has been built.
10124 if Nkind (N) = N_Identifier
10126 (Is_Formal (Entity (N))
10127 or else Ekind (Entity (N)) = E_Constant
10128 or else Ekind (Entity (N)) = E_Variable)
10129 and then Present (Actual_Subtype (Entity (N)))
10131 return Actual_Subtype (Entity (N));
10133 -- Otherwise the Etype of N is returned unchanged
10138 end Get_Actual_Subtype_If_Available;
10140 ------------------------
10141 -- Get_Body_From_Stub --
10142 ------------------------
10144 function Get_Body_From_Stub (N : Node_Id) return Node_Id is
10146 return Proper_Body (Unit (Library_Unit (N)));
10147 end Get_Body_From_Stub;
10149 ---------------------
10150 -- Get_Cursor_Type --
10151 ---------------------
10153 function Get_Cursor_Type
10155 Typ : Entity_Id) return Entity_Id
10159 First_Op : Entity_Id;
10160 Cursor : Entity_Id;
10163 -- If error already detected, return
10165 if Error_Posted (Aspect) then
10169 -- The cursor type for an Iterable aspect is the return type of a
10170 -- non-overloaded First primitive operation. Locate association for
10173 Assoc := First (Component_Associations (Expression (Aspect)));
10174 First_Op := Any_Id;
10175 while Present (Assoc) loop
10176 if Chars (First (Choices (Assoc))) = Name_First then
10177 First_Op := Expression (Assoc);
10184 if First_Op = Any_Id then
10185 Error_Msg_N ("aspect Iterable must specify First operation", Aspect);
10188 elsif not Analyzed (First_Op) then
10189 Analyze (First_Op);
10192 Cursor := Any_Type;
10194 -- Locate function with desired name and profile in scope of type
10195 -- In the rare case where the type is an integer type, a base type
10196 -- is created for it, check that the base type of the first formal
10197 -- of First matches the base type of the domain.
10199 Func := First_Entity (Scope (Typ));
10200 while Present (Func) loop
10201 if Chars (Func) = Chars (First_Op)
10202 and then Ekind (Func) = E_Function
10203 and then Present (First_Formal (Func))
10204 and then Base_Type (Etype (First_Formal (Func))) = Base_Type (Typ)
10205 and then No (Next_Formal (First_Formal (Func)))
10207 if Cursor /= Any_Type then
10209 ("operation First for iterable type must be unique", Aspect);
10212 Cursor := Etype (Func);
10216 Next_Entity (Func);
10219 -- If not found, no way to resolve remaining primitives
10221 if Cursor = Any_Type then
10223 ("primitive operation for Iterable type must appear in the same "
10224 & "list of declarations as the type", Aspect);
10228 end Get_Cursor_Type;
10230 function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is
10232 return Etype (Get_Iterable_Type_Primitive (Typ, Name_First));
10233 end Get_Cursor_Type;
10235 -------------------------------
10236 -- Get_Default_External_Name --
10237 -------------------------------
10239 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
10241 Get_Decoded_Name_String (Chars (E));
10243 if Opt.External_Name_Imp_Casing = Uppercase then
10244 Set_Casing (All_Upper_Case);
10246 Set_Casing (All_Lower_Case);
10250 Make_String_Literal (Sloc (E),
10251 Strval => String_From_Name_Buffer);
10252 end Get_Default_External_Name;
10254 --------------------------
10255 -- Get_Enclosing_Object --
10256 --------------------------
10258 function Get_Enclosing_Object (N : Node_Id) return Entity_Id is
10260 if Is_Entity_Name (N) then
10264 when N_Indexed_Component
10265 | N_Selected_Component
10268 -- If not generating code, a dereference may be left implicit.
10269 -- In thoses cases, return Empty.
10271 if Is_Access_Type (Etype (Prefix (N))) then
10274 return Get_Enclosing_Object (Prefix (N));
10277 when N_Type_Conversion =>
10278 return Get_Enclosing_Object (Expression (N));
10284 end Get_Enclosing_Object;
10286 -------------------------------
10287 -- Get_Enclosing_Deep_Object --
10288 -------------------------------
10290 function Get_Enclosing_Deep_Object (N : Node_Id) return Entity_Id is
10292 if Is_Entity_Name (N) then
10296 when N_Explicit_Dereference
10297 | N_Indexed_Component
10298 | N_Selected_Component
10301 return Get_Enclosing_Deep_Object (Prefix (N));
10303 when N_Type_Conversion =>
10304 return Get_Enclosing_Deep_Object (Expression (N));
10310 end Get_Enclosing_Deep_Object;
10312 ---------------------------
10313 -- Get_Enum_Lit_From_Pos --
10314 ---------------------------
10316 function Get_Enum_Lit_From_Pos
10319 Loc : Source_Ptr) return Node_Id
10321 Btyp : Entity_Id := Base_Type (T);
10326 -- In the case where the literal is of type Character, Wide_Character
10327 -- or Wide_Wide_Character or of a type derived from them, there needs
10328 -- to be some special handling since there is no explicit chain of
10329 -- literals to search. Instead, an N_Character_Literal node is created
10330 -- with the appropriate Char_Code and Chars fields.
10332 if Is_Standard_Character_Type (T) then
10333 Set_Character_Literal_Name (UI_To_CC (Pos));
10336 Make_Character_Literal (Loc,
10337 Chars => Name_Find,
10338 Char_Literal_Value => Pos);
10340 -- For all other cases, we have a complete table of literals, and
10341 -- we simply iterate through the chain of literal until the one
10342 -- with the desired position value is found.
10345 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
10346 Btyp := Full_View (Btyp);
10349 Lit := First_Literal (Btyp);
10351 -- Position in the enumeration type starts at 0
10354 raise Constraint_Error;
10357 for J in 1 .. UI_To_Int (Pos) loop
10358 Next_Literal (Lit);
10360 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error
10361 -- inside the loop to avoid calling Next_Literal on Empty.
10364 raise Constraint_Error;
10368 -- Create a new node from Lit, with source location provided by Loc
10369 -- if not equal to No_Location, or by copying the source location of
10374 if LLoc = No_Location then
10375 LLoc := Sloc (Lit);
10378 return New_Occurrence_Of (Lit, LLoc);
10380 end Get_Enum_Lit_From_Pos;
10382 ----------------------
10383 -- Get_Fullest_View --
10384 ----------------------
10386 function Get_Fullest_View
10388 Include_PAT : Boolean := True;
10389 Recurse : Boolean := True) return Entity_Id
10391 New_E : Entity_Id := Empty;
10394 -- Prevent cascaded errors
10400 -- Look at each kind of entity to see where we may need to go deeper.
10403 when Incomplete_Kind =>
10404 if From_Limited_With (E) then
10405 New_E := Non_Limited_View (E);
10406 elsif Present (Full_View (E)) then
10407 New_E := Full_View (E);
10408 elsif Ekind (E) = E_Incomplete_Subtype then
10409 New_E := Etype (E);
10412 when Private_Kind =>
10413 if Present (Underlying_Full_View (E)) then
10414 New_E := Underlying_Full_View (E);
10415 elsif Present (Full_View (E)) then
10416 New_E := Full_View (E);
10417 elsif Etype (E) /= E then
10418 New_E := Etype (E);
10422 if Include_PAT and then Present (Packed_Array_Impl_Type (E)) then
10423 New_E := Packed_Array_Impl_Type (E);
10426 when E_Record_Subtype =>
10427 if Present (Cloned_Subtype (E)) then
10428 New_E := Cloned_Subtype (E);
10431 when E_Class_Wide_Type =>
10432 New_E := Root_Type (E);
10434 when E_Class_Wide_Subtype =>
10435 if Present (Equivalent_Type (E)) then
10436 New_E := Equivalent_Type (E);
10437 elsif Present (Cloned_Subtype (E)) then
10438 New_E := Cloned_Subtype (E);
10441 when E_Protected_Subtype
10446 if Present (Corresponding_Record_Type (E)) then
10447 New_E := Corresponding_Record_Type (E);
10450 when E_Access_Protected_Subprogram_Type
10451 | E_Anonymous_Access_Protected_Subprogram_Type
10453 if Present (Equivalent_Type (E)) then
10454 New_E := Equivalent_Type (E);
10457 when E_Access_Subtype =>
10458 New_E := Base_Type (E);
10464 -- If we found a fuller view, either return it or recurse. Otherwise,
10465 -- return our input.
10467 return (if No (New_E) then E
10468 elsif Recurse then Get_Fullest_View (New_E, Include_PAT, Recurse)
10470 end Get_Fullest_View;
10472 ------------------------
10473 -- Get_Generic_Entity --
10474 ------------------------
10476 function Get_Generic_Entity (N : Node_Id) return Entity_Id is
10477 Ent : constant Entity_Id := Entity (Name (N));
10479 if Present (Renamed_Entity (Ent)) then
10480 return Renamed_Entity (Ent);
10484 end Get_Generic_Entity;
10486 -------------------------------------
10487 -- Get_Incomplete_View_Of_Ancestor --
10488 -------------------------------------
10490 function Get_Incomplete_View_Of_Ancestor (E : Entity_Id) return Entity_Id is
10491 Cur_Unit : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
10492 Par_Scope : Entity_Id;
10493 Par_Type : Entity_Id;
10496 -- The incomplete view of an ancestor is only relevant for private
10497 -- derived types in child units.
10499 if not Is_Derived_Type (E)
10500 or else not Is_Child_Unit (Cur_Unit)
10505 Par_Scope := Scope (Cur_Unit);
10506 if No (Par_Scope) then
10510 Par_Type := Etype (Base_Type (E));
10512 -- Traverse list of ancestor types until we find one declared in
10513 -- a parent or grandparent unit (two levels seem sufficient).
10515 while Present (Par_Type) loop
10516 if Scope (Par_Type) = Par_Scope
10517 or else Scope (Par_Type) = Scope (Par_Scope)
10521 elsif not Is_Derived_Type (Par_Type) then
10525 Par_Type := Etype (Base_Type (Par_Type));
10529 -- If none found, there is no relevant ancestor type.
10533 end Get_Incomplete_View_Of_Ancestor;
10535 ----------------------
10536 -- Get_Index_Bounds --
10537 ----------------------
10539 procedure Get_Index_Bounds
10543 Use_Full_View : Boolean := False)
10545 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id;
10546 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and
10547 -- Typ qualifies, the scalar range is obtained from the full view of the
10550 --------------------------
10551 -- Scalar_Range_Of_Type --
10552 --------------------------
10554 function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is
10555 T : Entity_Id := Typ;
10558 if Use_Full_View and then Present (Full_View (T)) then
10559 T := Full_View (T);
10562 return Scalar_Range (T);
10563 end Scalar_Range_Of_Type;
10567 Kind : constant Node_Kind := Nkind (N);
10570 -- Start of processing for Get_Index_Bounds
10573 if Kind = N_Range then
10574 L := Low_Bound (N);
10575 H := High_Bound (N);
10577 elsif Kind = N_Subtype_Indication then
10578 Rng := Range_Expression (Constraint (N));
10580 if Rng = Error then
10586 L := Low_Bound (Range_Expression (Constraint (N)));
10587 H := High_Bound (Range_Expression (Constraint (N)));
10590 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
10591 Rng := Scalar_Range_Of_Type (Entity (N));
10593 if Error_Posted (Rng) then
10597 elsif Nkind (Rng) = N_Subtype_Indication then
10598 Get_Index_Bounds (Rng, L, H);
10601 L := Low_Bound (Rng);
10602 H := High_Bound (Rng);
10606 -- N is an expression, indicating a range with one value
10611 end Get_Index_Bounds;
10613 function Get_Index_Bounds
10615 Use_Full_View : Boolean := False) return Range_Nodes is
10616 Result : Range_Nodes;
10618 Get_Index_Bounds (N, Result.First, Result.Last, Use_Full_View);
10620 end Get_Index_Bounds;
10622 function Get_Index_Bounds
10624 Use_Full_View : Boolean := False) return Range_Values is
10625 Nodes : constant Range_Nodes := Get_Index_Bounds (N, Use_Full_View);
10627 return (Expr_Value (Nodes.First), Expr_Value (Nodes.Last));
10628 end Get_Index_Bounds;
10630 -----------------------------
10631 -- Get_Interfacing_Aspects --
10632 -----------------------------
10634 procedure Get_Interfacing_Aspects
10635 (Iface_Asp : Node_Id;
10636 Conv_Asp : out Node_Id;
10637 EN_Asp : out Node_Id;
10638 Expo_Asp : out Node_Id;
10639 Imp_Asp : out Node_Id;
10640 LN_Asp : out Node_Id;
10641 Do_Checks : Boolean := False)
10643 procedure Save_Or_Duplication_Error
10645 To : in out Node_Id);
10646 -- Save the value of aspect Asp in node To. If To already has a value,
10647 -- then this is considered a duplicate use of aspect. Emit an error if
10648 -- flag Do_Checks is set.
10650 -------------------------------
10651 -- Save_Or_Duplication_Error --
10652 -------------------------------
10654 procedure Save_Or_Duplication_Error
10656 To : in out Node_Id)
10659 -- Detect an extra aspect and issue an error
10661 if Present (To) then
10663 Error_Msg_Name_1 := Chars (Identifier (Asp));
10664 Error_Msg_Sloc := Sloc (To);
10665 Error_Msg_N ("aspect % previously given #", Asp);
10668 -- Otherwise capture the aspect
10673 end Save_Or_Duplication_Error;
10678 Asp_Id : Aspect_Id;
10680 -- The following variables capture each individual aspect
10682 Conv : Node_Id := Empty;
10683 EN : Node_Id := Empty;
10684 Expo : Node_Id := Empty;
10685 Imp : Node_Id := Empty;
10686 LN : Node_Id := Empty;
10688 -- Start of processing for Get_Interfacing_Aspects
10691 -- The input interfacing aspect should reside in an aspect specification
10694 pragma Assert (Is_List_Member (Iface_Asp));
10696 -- Examine the aspect specifications of the related entity. Find and
10697 -- capture all interfacing aspects. Detect duplicates and emit errors
10700 Asp := First (List_Containing (Iface_Asp));
10701 while Present (Asp) loop
10702 Asp_Id := Get_Aspect_Id (Asp);
10704 if Asp_Id = Aspect_Convention then
10705 Save_Or_Duplication_Error (Asp, Conv);
10707 elsif Asp_Id = Aspect_External_Name then
10708 Save_Or_Duplication_Error (Asp, EN);
10710 elsif Asp_Id = Aspect_Export then
10711 Save_Or_Duplication_Error (Asp, Expo);
10713 elsif Asp_Id = Aspect_Import then
10714 Save_Or_Duplication_Error (Asp, Imp);
10716 elsif Asp_Id = Aspect_Link_Name then
10717 Save_Or_Duplication_Error (Asp, LN);
10728 end Get_Interfacing_Aspects;
10730 ---------------------------------
10731 -- Get_Iterable_Type_Primitive --
10732 ---------------------------------
10734 function Get_Iterable_Type_Primitive
10736 Nam : Name_Id) return Entity_Id
10741 Nam in Name_Element
10748 Funcs : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterable);
10756 Assoc := First (Component_Associations (Funcs));
10757 while Present (Assoc) loop
10758 if Chars (First (Choices (Assoc))) = Nam then
10759 return Entity (Expression (Assoc));
10767 end Get_Iterable_Type_Primitive;
10769 ---------------------------
10770 -- Get_Library_Unit_Name --
10771 ---------------------------
10773 function Get_Library_Unit_Name (Decl_Node : Node_Id) return String_Id is
10774 Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
10775 Buf : Bounded_String;
10777 Get_Unit_Name_String (Buf, Unit_Name_Id);
10779 -- Remove the last seven characters (" (spec)" or " (body)")
10781 Buf.Length := Buf.Length - 7;
10782 pragma Assert (Buf.Chars (Buf.Length + 1) = ' ');
10784 return String_From_Name_Buffer (Buf);
10785 end Get_Library_Unit_Name;
10787 --------------------------
10788 -- Get_Max_Queue_Length --
10789 --------------------------
10791 function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
10792 pragma Assert (Is_Entry (Id));
10793 Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
10797 -- A value of 0 or -1 represents no maximum specified, and entries and
10798 -- entry families with no Max_Queue_Length aspect or pragma default to
10806 (Expression (First (Pragma_Argument_Associations (Prag))));
10808 -- Since -1 and 0 are equivalent, return 0 for instances of -1 for
10816 end Get_Max_Queue_Length;
10818 ------------------------
10819 -- Get_Name_Entity_Id --
10820 ------------------------
10822 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
10824 return Entity_Id (Get_Name_Table_Int (Id));
10825 end Get_Name_Entity_Id;
10827 ------------------------------
10828 -- Get_Name_From_CTC_Pragma --
10829 ------------------------------
10831 function Get_Name_From_CTC_Pragma (N : Node_Id) return String_Id is
10832 Arg : constant Node_Id :=
10833 Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
10835 return Strval (Expr_Value_S (Arg));
10836 end Get_Name_From_CTC_Pragma;
10838 -----------------------
10839 -- Get_Parent_Entity --
10840 -----------------------
10842 function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is
10844 if Nkind (Unit) = N_Package_Body
10845 and then Nkind (Original_Node (Unit)) = N_Package_Instantiation
10847 return Defining_Entity
10848 (Specification (Instance_Spec (Original_Node (Unit))));
10849 elsif Nkind (Unit) = N_Package_Instantiation then
10850 return Defining_Entity (Specification (Instance_Spec (Unit)));
10852 return Defining_Entity (Unit);
10854 end Get_Parent_Entity;
10856 -------------------
10857 -- Get_Pragma_Id --
10858 -------------------
10860 function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
10862 return Get_Pragma_Id (Pragma_Name_Unmapped (N));
10865 ------------------------
10866 -- Get_Qualified_Name --
10867 ------------------------
10869 function Get_Qualified_Name
10871 Suffix : Entity_Id := Empty) return Name_Id
10873 Suffix_Nam : Name_Id := No_Name;
10876 if Present (Suffix) then
10877 Suffix_Nam := Chars (Suffix);
10880 return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id));
10881 end Get_Qualified_Name;
10883 function Get_Qualified_Name
10885 Suffix : Name_Id := No_Name;
10886 Scop : Entity_Id := Current_Scope) return Name_Id
10888 procedure Add_Scope (S : Entity_Id);
10889 -- Add the fully qualified form of scope S to the name buffer. The
10897 procedure Add_Scope (S : Entity_Id) is
10902 elsif S = Standard_Standard then
10906 Add_Scope (Scope (S));
10907 Get_Name_String_And_Append (Chars (S));
10908 Add_Str_To_Name_Buffer ("__");
10912 -- Start of processing for Get_Qualified_Name
10918 -- Append the base name after all scopes have been chained
10920 Get_Name_String_And_Append (Nam);
10922 -- Append the suffix (if present)
10924 if Suffix /= No_Name then
10925 Add_Str_To_Name_Buffer ("__");
10926 Get_Name_String_And_Append (Suffix);
10930 end Get_Qualified_Name;
10932 -----------------------
10933 -- Get_Reason_String --
10934 -----------------------
10936 procedure Get_Reason_String (N : Node_Id) is
10938 if Nkind (N) = N_String_Literal then
10939 Store_String_Chars (Strval (N));
10941 elsif Nkind (N) = N_Op_Concat then
10942 Get_Reason_String (Left_Opnd (N));
10943 Get_Reason_String (Right_Opnd (N));
10945 -- If not of required form, error
10949 ("Reason for pragma Warnings has wrong form", N);
10951 ("\must be string literal or concatenation of string literals", N);
10954 end Get_Reason_String;
10956 --------------------------------
10957 -- Get_Reference_Discriminant --
10958 --------------------------------
10960 function Get_Reference_Discriminant (Typ : Entity_Id) return Entity_Id is
10964 D := First_Discriminant (Typ);
10965 while Present (D) loop
10966 if Has_Implicit_Dereference (D) then
10969 Next_Discriminant (D);
10973 end Get_Reference_Discriminant;
10975 ---------------------------
10976 -- Get_Referenced_Object --
10977 ---------------------------
10979 function Get_Referenced_Object (N : Node_Id) return Node_Id is
10984 while Is_Entity_Name (R)
10985 and then Is_Object (Entity (R))
10986 and then Present (Renamed_Object (Entity (R)))
10988 R := Renamed_Object (Entity (R));
10992 end Get_Referenced_Object;
10994 ------------------------
10995 -- Get_Renamed_Entity --
10996 ------------------------
10998 function Get_Renamed_Entity (E : Entity_Id) return Entity_Id is
10999 R : Entity_Id := E;
11001 while Present (Renamed_Entity (R)) loop
11002 R := Renamed_Entity (R);
11006 end Get_Renamed_Entity;
11008 -----------------------
11009 -- Get_Return_Object --
11010 -----------------------
11012 function Get_Return_Object (N : Node_Id) return Entity_Id is
11016 Decl := First (Return_Object_Declarations (N));
11017 while Present (Decl) loop
11018 exit when Nkind (Decl) = N_Object_Declaration
11019 and then Is_Return_Object (Defining_Identifier (Decl));
11023 pragma Assert (Present (Decl));
11024 return Defining_Identifier (Decl);
11025 end Get_Return_Object;
11027 ---------------------------
11028 -- Get_Subprogram_Entity --
11029 ---------------------------
11031 function Get_Subprogram_Entity (Nod : Node_Id) return Entity_Id is
11033 Subp_Id : Entity_Id;
11036 if Nkind (Nod) = N_Accept_Statement then
11037 Subp := Entry_Direct_Name (Nod);
11039 elsif Nkind (Nod) = N_Slice then
11040 Subp := Prefix (Nod);
11043 Subp := Name (Nod);
11046 -- Strip the subprogram call
11049 if Nkind (Subp) in N_Explicit_Dereference
11050 | N_Indexed_Component
11051 | N_Selected_Component
11053 Subp := Prefix (Subp);
11055 elsif Nkind (Subp) in N_Type_Conversion
11056 | N_Unchecked_Type_Conversion
11058 Subp := Expression (Subp);
11065 -- Extract the entity of the subprogram call
11067 if Is_Entity_Name (Subp) then
11068 Subp_Id := Entity (Subp);
11070 if Ekind (Subp_Id) = E_Access_Subprogram_Type then
11071 Subp_Id := Directly_Designated_Type (Subp_Id);
11074 if Is_Subprogram (Subp_Id) then
11080 -- The search did not find a construct that denotes a subprogram
11085 end Get_Subprogram_Entity;
11087 -----------------------------
11088 -- Get_Task_Body_Procedure --
11089 -----------------------------
11091 function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is
11093 -- Note: A task type may be the completion of a private type with
11094 -- discriminants. When performing elaboration checks on a task
11095 -- declaration, the current view of the type may be the private one,
11096 -- and the procedure that holds the body of the task is held in its
11097 -- underlying type.
11099 -- This is an odd function, why not have Task_Body_Procedure do
11100 -- the following digging???
11102 return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
11103 end Get_Task_Body_Procedure;
11105 -------------------------------
11106 -- Get_User_Defined_Equality --
11107 -------------------------------
11109 function Get_User_Defined_Equality (E : Entity_Id) return Entity_Id is
11113 Prim := First_Elmt (Collect_Primitive_Operations (E));
11114 while Present (Prim) loop
11115 if Is_User_Defined_Equality (Node (Prim)) then
11116 return Node (Prim);
11123 end Get_User_Defined_Equality;
11129 procedure Get_Views
11131 Priv_Typ : out Entity_Id;
11132 Full_Typ : out Entity_Id;
11133 UFull_Typ : out Entity_Id;
11134 CRec_Typ : out Entity_Id)
11136 IP_View : Entity_Id;
11139 -- Assume that none of the views can be recovered
11143 UFull_Typ := Empty;
11146 -- The input type is the corresponding record type of a protected or a
11149 if Ekind (Typ) = E_Record_Type
11150 and then Is_Concurrent_Record_Type (Typ)
11153 Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
11154 Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
11156 -- Otherwise the input type denotes an arbitrary type
11159 IP_View := Incomplete_Or_Partial_View (Typ);
11161 -- The input type denotes the full view of a private type
11163 if Present (IP_View) then
11164 Priv_Typ := IP_View;
11167 -- The input type is a private type
11169 elsif Is_Private_Type (Typ) then
11171 Full_Typ := Full_View (Priv_Typ);
11173 -- Otherwise the input type does not have any views
11179 if Present (Full_Typ) and then Is_Private_Type (Full_Typ) then
11180 UFull_Typ := Underlying_Full_View (Full_Typ);
11182 if Present (UFull_Typ)
11183 and then Ekind (UFull_Typ) in E_Protected_Type | E_Task_Type
11185 CRec_Typ := Corresponding_Record_Type (UFull_Typ);
11189 if Present (Full_Typ)
11190 and then Ekind (Full_Typ) in E_Protected_Type | E_Task_Type
11192 CRec_Typ := Corresponding_Record_Type (Full_Typ);
11198 ------------------------------
11199 -- Has_Compatible_Alignment --
11200 ------------------------------
11202 function Has_Compatible_Alignment
11205 Layout_Done : Boolean) return Alignment_Result
11207 function Has_Compatible_Alignment_Internal
11210 Layout_Done : Boolean;
11211 Default : Alignment_Result) return Alignment_Result;
11212 -- This is the internal recursive function that actually does the work.
11213 -- There is one additional parameter, which says what the result should
11214 -- be if no alignment information is found, and there is no definite
11215 -- indication of compatible alignments. At the outer level, this is set
11216 -- to Unknown, but for internal recursive calls in the case where types
11217 -- are known to be correct, it is set to Known_Compatible.
11219 ---------------------------------------
11220 -- Has_Compatible_Alignment_Internal --
11221 ---------------------------------------
11223 function Has_Compatible_Alignment_Internal
11226 Layout_Done : Boolean;
11227 Default : Alignment_Result) return Alignment_Result
11229 Result : Alignment_Result := Known_Compatible;
11230 -- Holds the current status of the result. Note that once a value of
11231 -- Known_Incompatible is set, it is sticky and does not get changed
11232 -- to Unknown (the value in Result only gets worse as we go along,
11235 Offs : Uint := No_Uint;
11236 -- Set to a factor of the offset from the base object when Expr is a
11237 -- selected or indexed component, based on Component_Bit_Offset and
11238 -- Component_Size respectively. A negative value is used to represent
11239 -- a value that is not known at compile time.
11241 procedure Check_Prefix;
11242 -- Checks the prefix recursively in the case where the expression
11243 -- is an indexed or selected component.
11245 procedure Set_Result (R : Alignment_Result);
11246 -- If R represents a worse outcome (unknown instead of known
11247 -- compatible, or known incompatible), then set Result to R.
11253 procedure Check_Prefix is
11255 -- The subtlety here is that in doing a recursive call to check
11256 -- the prefix, we have to decide what to do in the case where we
11257 -- don't find any specific indication of an alignment problem.
11259 -- At the outer level, we normally set Unknown as the result in
11260 -- this case, since we can only set Known_Compatible if we really
11261 -- know that the alignment value is OK, but for the recursive
11262 -- call, in the case where the types match, and we have not
11263 -- specified a peculiar alignment for the object, we are only
11264 -- concerned about suspicious rep clauses, the default case does
11265 -- not affect us, since the compiler will, in the absence of such
11266 -- rep clauses, ensure that the alignment is correct.
11268 if Default = Known_Compatible
11270 (Etype (Obj) = Etype (Expr)
11271 and then (not Known_Alignment (Obj)
11273 Alignment (Obj) = Alignment (Etype (Obj))))
11276 (Has_Compatible_Alignment_Internal
11277 (Obj, Prefix (Expr), Layout_Done, Known_Compatible));
11279 -- In all other cases, we need a full check on the prefix
11283 (Has_Compatible_Alignment_Internal
11284 (Obj, Prefix (Expr), Layout_Done, Unknown));
11292 procedure Set_Result (R : Alignment_Result) is
11299 -- Start of processing for Has_Compatible_Alignment_Internal
11302 -- If Expr is a selected component, we must make sure there is no
11303 -- potentially troublesome component clause and that the record is
11304 -- not packed if the layout is not done.
11306 if Nkind (Expr) = N_Selected_Component then
11308 -- Packing generates unknown alignment if layout is not done
11310 if Is_Packed (Etype (Prefix (Expr))) and then not Layout_Done then
11311 Set_Result (Unknown);
11314 -- Check prefix and component offset
11317 Offs := Component_Bit_Offset (Entity (Selector_Name (Expr)));
11319 -- If Expr is an indexed component, we must make sure there is no
11320 -- potentially troublesome Component_Size clause and that the array
11321 -- is not bit-packed if the layout is not done.
11323 elsif Nkind (Expr) = N_Indexed_Component then
11325 Typ : constant Entity_Id := Etype (Prefix (Expr));
11328 -- Packing generates unknown alignment if layout is not done
11330 if Is_Bit_Packed_Array (Typ) and then not Layout_Done then
11331 Set_Result (Unknown);
11334 -- Check prefix and component offset (or at least size)
11337 Offs := Indexed_Component_Bit_Offset (Expr);
11339 Offs := Component_Size (Typ);
11344 -- If we have a null offset, the result is entirely determined by
11345 -- the base object and has already been computed recursively.
11347 if Present (Offs) and then Offs = Uint_0 then
11350 -- Case where we know the alignment of the object
11352 elsif Known_Alignment (Obj) then
11354 ObjA : constant Uint := Alignment (Obj);
11355 ExpA : Uint := No_Uint;
11356 SizA : Uint := No_Uint;
11359 -- If alignment of Obj is 1, then we are always OK
11362 Set_Result (Known_Compatible);
11364 -- Alignment of Obj is greater than 1, so we need to check
11367 -- If we have an offset, see if it is compatible
11369 if Present (Offs) and then Offs > Uint_0 then
11370 if Offs mod (System_Storage_Unit * ObjA) /= 0 then
11371 Set_Result (Known_Incompatible);
11374 -- See if Expr is an object with known alignment
11376 elsif Is_Entity_Name (Expr)
11377 and then Known_Alignment (Entity (Expr))
11380 ExpA := Alignment (Entity (Expr));
11382 -- Otherwise, we can use the alignment of the type of Expr
11383 -- given that we already checked for discombobulating rep
11384 -- clauses for the cases of indexed and selected components
11387 elsif Known_Alignment (Etype (Expr)) then
11388 ExpA := Alignment (Etype (Expr));
11390 -- Otherwise the alignment is unknown
11393 Set_Result (Default);
11396 -- If we got an alignment, see if it is acceptable
11398 if Present (ExpA) and then ExpA < ObjA then
11399 Set_Result (Known_Incompatible);
11402 -- If Expr is a component or an entire object with a known
11403 -- alignment, then we are fine. Otherwise, if its size is
11404 -- known, it must be big enough for the required alignment.
11406 if Present (Offs) then
11409 -- See if Expr is an object with known size
11411 elsif Is_Entity_Name (Expr)
11412 and then Known_Static_Esize (Entity (Expr))
11414 SizA := Esize (Entity (Expr));
11416 -- Otherwise, we check the object size of the Expr type
11418 elsif Known_Static_Esize (Etype (Expr)) then
11419 SizA := Esize (Etype (Expr));
11422 -- If we got a size, see if it is a multiple of the Obj
11423 -- alignment; if not, then the alignment cannot be
11424 -- acceptable, since the size is always a multiple of the
11427 if Present (SizA) then
11428 if SizA mod (ObjA * Ttypes.System_Storage_Unit) /= 0 then
11429 Set_Result (Known_Incompatible);
11435 -- If we do not know required alignment, any non-zero offset is a
11436 -- potential problem (but certainly may be OK, so result is unknown).
11438 elsif Present (Offs) then
11439 Set_Result (Unknown);
11441 -- If we can't find the result by direct comparison of alignment
11442 -- values, then there is still one case that we can determine known
11443 -- result, and that is when we can determine that the types are the
11444 -- same, and no alignments are specified. Then we known that the
11445 -- alignments are compatible, even if we don't know the alignment
11446 -- value in the front end.
11448 elsif Etype (Obj) = Etype (Expr) then
11450 -- Types are the same, but we have to check for possible size
11451 -- and alignments on the Expr object that may make the alignment
11452 -- different, even though the types are the same.
11454 if Is_Entity_Name (Expr) then
11456 -- First check alignment of the Expr object. Any alignment less
11457 -- than Maximum_Alignment is worrisome since this is the case
11458 -- where we do not know the alignment of Obj.
11460 if Known_Alignment (Entity (Expr))
11461 and then Alignment (Entity (Expr)) < Ttypes.Maximum_Alignment
11463 Set_Result (Unknown);
11465 -- Now check size of Expr object. Any size that is not an even
11466 -- multiple of Maximum_Alignment is also worrisome since it
11467 -- may cause the alignment of the object to be less than the
11468 -- alignment of the type.
11470 elsif Known_Static_Esize (Entity (Expr))
11472 Esize (Entity (Expr)) mod
11473 (Ttypes.Maximum_Alignment * Ttypes.System_Storage_Unit)
11476 Set_Result (Unknown);
11478 -- Otherwise same type is decisive
11481 Set_Result (Known_Compatible);
11485 -- Another case to deal with is when there is an explicit size or
11486 -- alignment clause when the types are not the same. If so, then the
11487 -- result is Unknown. We don't need to do this test if the Default is
11488 -- Unknown, since that result will be set in any case.
11490 elsif Default /= Unknown
11491 and then (Has_Size_Clause (Etype (Expr))
11493 Has_Alignment_Clause (Etype (Expr)))
11495 Set_Result (Unknown);
11497 -- If no indication found, set default
11500 Set_Result (Default);
11503 -- Return worst result found
11506 end Has_Compatible_Alignment_Internal;
11508 -- Start of processing for Has_Compatible_Alignment
11511 -- If Obj has no specified alignment, then set alignment from the type
11512 -- alignment. Perhaps we should always do this, but for sure we should
11513 -- do it when there is an address clause since we can do more if the
11514 -- alignment is known.
11516 if not Known_Alignment (Obj) and then Known_Alignment (Etype (Obj)) then
11517 Set_Alignment (Obj, Alignment (Etype (Obj)));
11520 -- Now do the internal call that does all the work
11523 Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown);
11524 end Has_Compatible_Alignment;
11526 ----------------------
11527 -- Has_Declarations --
11528 ----------------------
11530 function Has_Declarations (N : Node_Id) return Boolean is
11532 return Nkind (N) in N_Accept_Statement
11533 | N_Block_Statement
11534 | N_Compilation_Unit_Aux
11538 | N_Subprogram_Body
11540 | N_Package_Specification;
11541 end Has_Declarations;
11543 ---------------------------------
11544 -- Has_Defaulted_Discriminants --
11545 ---------------------------------
11547 function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is
11549 return Has_Discriminants (Typ)
11550 and then Present (Discriminant_Default_Value
11551 (First_Discriminant (Typ)));
11552 end Has_Defaulted_Discriminants;
11554 -------------------
11555 -- Has_Denormals --
11556 -------------------
11558 function Has_Denormals (E : Entity_Id) return Boolean is
11560 return Is_Floating_Point_Type (E) and then Denorm_On_Target;
11563 -------------------------------------------
11564 -- Has_Discriminant_Dependent_Constraint --
11565 -------------------------------------------
11567 function Has_Discriminant_Dependent_Constraint
11568 (Comp : Entity_Id) return Boolean
11570 Comp_Decl : constant Node_Id := Parent (Comp);
11571 Subt_Indic : Node_Id;
11576 -- Discriminants can't depend on discriminants
11578 if Ekind (Comp) = E_Discriminant then
11582 Subt_Indic := Subtype_Indication (Component_Definition (Comp_Decl));
11584 if Nkind (Subt_Indic) = N_Subtype_Indication then
11585 Constr := Constraint (Subt_Indic);
11587 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
11588 Assn := First (Constraints (Constr));
11589 while Present (Assn) loop
11590 case Nkind (Assn) is
11593 | N_Subtype_Indication
11595 if Depends_On_Discriminant (Assn) then
11599 when N_Discriminant_Association =>
11600 if Depends_On_Discriminant (Expression (Assn)) then
11615 end Has_Discriminant_Dependent_Constraint;
11617 --------------------------------------
11618 -- Has_Effectively_Volatile_Profile --
11619 --------------------------------------
11621 function Has_Effectively_Volatile_Profile
11622 (Subp_Id : Entity_Id) return Boolean
11624 Formal : Entity_Id;
11627 -- Inspect the formal parameters looking for an effectively volatile
11628 -- type for reading.
11630 Formal := First_Formal (Subp_Id);
11631 while Present (Formal) loop
11632 if Is_Effectively_Volatile_For_Reading (Etype (Formal)) then
11636 Next_Formal (Formal);
11639 -- Inspect the return type of functions
11641 if Ekind (Subp_Id) in E_Function | E_Generic_Function
11642 and then Is_Effectively_Volatile_For_Reading (Etype (Subp_Id))
11648 end Has_Effectively_Volatile_Profile;
11650 --------------------------
11651 -- Has_Enabled_Property --
11652 --------------------------
11654 function Has_Enabled_Property
11655 (Item_Id : Entity_Id;
11656 Property : Name_Id) return Boolean
11658 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean;
11659 -- Determine whether a protected type or variable denoted by Item_Id
11660 -- has the property enabled.
11662 function State_Has_Enabled_Property return Boolean;
11663 -- Determine whether a state denoted by Item_Id has the property enabled
11665 function Type_Or_Variable_Has_Enabled_Property
11666 (Item_Id : Entity_Id) return Boolean;
11667 -- Determine whether type or variable denoted by Item_Id has the
11668 -- property enabled.
11670 -----------------------------------------------------
11671 -- Protected_Type_Or_Variable_Has_Enabled_Property --
11672 -----------------------------------------------------
11674 function Protected_Type_Or_Variable_Has_Enabled_Property return Boolean
11677 -- Protected entities always have the properties Async_Readers and
11678 -- Async_Writers (SPARK RM 7.1.2(16)).
11680 if Property = Name_Async_Readers
11681 or else Property = Name_Async_Writers
11685 -- Protected objects that have Part_Of components also inherit their
11686 -- properties Effective_Reads and Effective_Writes
11687 -- (SPARK RM 7.1.2(16)).
11689 elsif Is_Single_Protected_Object (Item_Id) then
11691 Constit_Elmt : Elmt_Id;
11692 Constit_Id : Entity_Id;
11693 Constits : constant Elist_Id
11694 := Part_Of_Constituents (Item_Id);
11696 if Present (Constits) then
11697 Constit_Elmt := First_Elmt (Constits);
11698 while Present (Constit_Elmt) loop
11699 Constit_Id := Node (Constit_Elmt);
11701 if Has_Enabled_Property (Constit_Id, Property) then
11705 Next_Elmt (Constit_Elmt);
11712 end Protected_Type_Or_Variable_Has_Enabled_Property;
11714 --------------------------------
11715 -- State_Has_Enabled_Property --
11716 --------------------------------
11718 function State_Has_Enabled_Property return Boolean is
11719 Decl : constant Node_Id := Parent (Item_Id);
11721 procedure Find_Simple_Properties
11722 (Has_External : out Boolean;
11723 Has_Synchronous : out Boolean);
11724 -- Extract the simple properties associated with declaration Decl
11726 function Is_Enabled_External_Property return Boolean;
11727 -- Determine whether property Property appears within the external
11728 -- property list of declaration Decl, and return its status.
11730 ----------------------------
11731 -- Find_Simple_Properties --
11732 ----------------------------
11734 procedure Find_Simple_Properties
11735 (Has_External : out Boolean;
11736 Has_Synchronous : out Boolean)
11741 -- Assume that none of the properties are available
11743 Has_External := False;
11744 Has_Synchronous := False;
11746 Opt := First (Expressions (Decl));
11747 while Present (Opt) loop
11748 if Nkind (Opt) = N_Identifier then
11749 if Chars (Opt) = Name_External then
11750 Has_External := True;
11752 elsif Chars (Opt) = Name_Synchronous then
11753 Has_Synchronous := True;
11759 end Find_Simple_Properties;
11761 ----------------------------------
11762 -- Is_Enabled_External_Property --
11763 ----------------------------------
11765 function Is_Enabled_External_Property return Boolean is
11769 Prop_Nam : Node_Id;
11773 Opt := First (Component_Associations (Decl));
11774 while Present (Opt) loop
11775 Opt_Nam := First (Choices (Opt));
11777 if Nkind (Opt_Nam) = N_Identifier
11778 and then Chars (Opt_Nam) = Name_External
11780 Props := Expression (Opt);
11782 -- Multiple properties appear as an aggregate
11784 if Nkind (Props) = N_Aggregate then
11786 -- Simple property form
11788 Prop := First (Expressions (Props));
11789 while Present (Prop) loop
11790 if Chars (Prop) = Property then
11797 -- Property with expression form
11799 Prop := First (Component_Associations (Props));
11800 while Present (Prop) loop
11801 Prop_Nam := First (Choices (Prop));
11803 -- The property can be represented in two ways:
11804 -- others => <value>
11805 -- <property> => <value>
11807 if Nkind (Prop_Nam) = N_Others_Choice
11808 or else (Nkind (Prop_Nam) = N_Identifier
11809 and then Chars (Prop_Nam) = Property)
11811 return Is_True (Expr_Value (Expression (Prop)));
11820 return Chars (Props) = Property;
11828 end Is_Enabled_External_Property;
11832 Has_External : Boolean;
11833 Has_Synchronous : Boolean;
11835 -- Start of processing for State_Has_Enabled_Property
11838 -- The declaration of an external abstract state appears as an
11839 -- extension aggregate. If this is not the case, properties can
11842 if Nkind (Decl) /= N_Extension_Aggregate then
11846 Find_Simple_Properties (Has_External, Has_Synchronous);
11848 -- Simple option External enables all properties (SPARK RM 7.1.2(2))
11850 if Has_External then
11853 -- Option External may enable or disable specific properties
11855 elsif Is_Enabled_External_Property then
11858 -- Simple option Synchronous
11860 -- enables disables
11861 -- Async_Readers Effective_Reads
11862 -- Async_Writers Effective_Writes
11864 -- Note that both forms of External have higher precedence than
11865 -- Synchronous (SPARK RM 7.1.4(9)).
11867 elsif Has_Synchronous then
11868 return Property in Name_Async_Readers | Name_Async_Writers;
11872 end State_Has_Enabled_Property;
11874 -------------------------------------------
11875 -- Type_Or_Variable_Has_Enabled_Property --
11876 -------------------------------------------
11878 function Type_Or_Variable_Has_Enabled_Property
11879 (Item_Id : Entity_Id) return Boolean
11881 AR : constant Node_Id :=
11882 Get_Pragma (Item_Id, Pragma_Async_Readers);
11883 AW : constant Node_Id :=
11884 Get_Pragma (Item_Id, Pragma_Async_Writers);
11885 ER : constant Node_Id :=
11886 Get_Pragma (Item_Id, Pragma_Effective_Reads);
11887 EW : constant Node_Id :=
11888 Get_Pragma (Item_Id, Pragma_Effective_Writes);
11890 Is_Derived_Type_With_Volatile_Parent_Type : constant Boolean :=
11891 Is_Derived_Type (Item_Id)
11892 and then Is_Effectively_Volatile (Etype (Base_Type (Item_Id)));
11895 -- A non-effectively volatile object can never possess external
11898 if not Is_Effectively_Volatile (Item_Id) then
11901 -- External properties related to variables come in two flavors -
11902 -- explicit and implicit. The explicit case is characterized by the
11903 -- presence of a property pragma with an optional Boolean flag. The
11904 -- property is enabled when the flag evaluates to True or the flag is
11905 -- missing altogether.
11907 elsif Property = Name_Async_Readers and then Present (AR) then
11908 return Is_Enabled_Pragma (AR);
11910 elsif Property = Name_Async_Writers and then Present (AW) then
11911 return Is_Enabled_Pragma (AW);
11913 elsif Property = Name_Effective_Reads and then Present (ER) then
11914 return Is_Enabled_Pragma (ER);
11916 elsif Property = Name_Effective_Writes and then Present (EW) then
11917 return Is_Enabled_Pragma (EW);
11919 -- If other properties are set explicitly, then this one is set
11920 -- implicitly to False, except in the case of a derived type
11921 -- whose parent type is volatile (in that case, we will inherit
11922 -- from the parent type, below).
11924 elsif (Present (AR)
11925 or else Present (AW)
11926 or else Present (ER)
11927 or else Present (EW))
11928 and then not Is_Derived_Type_With_Volatile_Parent_Type
11932 -- For a private type (including subtype of a private types), look at
11935 elsif Is_Private_Type (Item_Id) and then Present (Full_View (Item_Id))
11937 return Type_Or_Variable_Has_Enabled_Property (Full_View (Item_Id));
11939 -- For a derived type whose parent type is volatile, the
11940 -- property may be inherited (but ignore a non-volatile parent).
11942 elsif Is_Derived_Type_With_Volatile_Parent_Type then
11943 return Type_Or_Variable_Has_Enabled_Property
11944 (First_Subtype (Etype (Base_Type (Item_Id))));
11946 -- For a subtype, the property will be inherited from its base type.
11948 elsif Is_Type (Item_Id)
11949 and then not Is_Base_Type (Item_Id)
11951 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id));
11953 -- If not specified explicitly for an object and its type
11954 -- is effectively volatile, then take result from the type.
11956 elsif Is_Object (Item_Id)
11957 and then Is_Effectively_Volatile (Etype (Item_Id))
11959 return Has_Enabled_Property (Etype (Item_Id), Property);
11961 -- The implicit case lacks all property pragmas
11963 elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
11964 if Is_Protected_Type (Etype (Item_Id)) then
11965 return Protected_Type_Or_Variable_Has_Enabled_Property;
11973 end Type_Or_Variable_Has_Enabled_Property;
11975 -- Start of processing for Has_Enabled_Property
11978 -- Abstract states and variables have a flexible scheme of specifying
11979 -- external properties.
11981 if Ekind (Item_Id) = E_Abstract_State then
11982 return State_Has_Enabled_Property;
11984 elsif Ekind (Item_Id) in E_Variable | E_Constant then
11985 return Type_Or_Variable_Has_Enabled_Property (Item_Id);
11987 -- Other objects can only inherit properties through their type. We
11988 -- cannot call directly Type_Or_Variable_Has_Enabled_Property on
11989 -- these as they don't have contracts attached, which is expected by
11992 elsif Is_Object (Item_Id) then
11993 return Type_Or_Variable_Has_Enabled_Property (Etype (Item_Id));
11995 elsif Is_Type (Item_Id) then
11996 return Type_Or_Variable_Has_Enabled_Property
11997 (Item_Id => First_Subtype (Item_Id));
11999 -- Otherwise a property is enabled when the related item is effectively
12003 return Is_Effectively_Volatile (Item_Id);
12005 end Has_Enabled_Property;
12007 -------------------------------------
12008 -- Has_Full_Default_Initialization --
12009 -------------------------------------
12011 function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
12015 -- A type subject to pragma Default_Initial_Condition may be fully
12016 -- default initialized depending on inheritance and the argument of
12017 -- the pragma. Since any type may act as the full view of a private
12018 -- type, this check must be performed prior to the specialized tests
12021 if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then
12025 -- A scalar type is fully default initialized if it is subject to aspect
12028 if Is_Scalar_Type (Typ) then
12029 return Has_Default_Aspect (Typ);
12031 -- An access type is fully default initialized by default
12033 elsif Is_Access_Type (Typ) then
12036 -- An array type is fully default initialized if its element type is
12037 -- scalar and the array type carries aspect Default_Component_Value or
12038 -- the element type is fully default initialized.
12040 elsif Is_Array_Type (Typ) then
12042 Has_Default_Aspect (Typ)
12043 or else Has_Full_Default_Initialization (Component_Type (Typ));
12045 -- A protected type, record type, or type extension is fully default
12046 -- initialized if all its components either carry an initialization
12047 -- expression or have a type that is fully default initialized. The
12048 -- parent type of a type extension must be fully default initialized.
12050 elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
12052 -- Inspect all entities defined in the scope of the type, looking for
12053 -- uninitialized components.
12055 Comp := First_Component (Typ);
12056 while Present (Comp) loop
12057 if Comes_From_Source (Comp)
12058 and then No (Expression (Parent (Comp)))
12059 and then not Has_Full_Default_Initialization (Etype (Comp))
12064 Next_Component (Comp);
12067 -- Ensure that the parent type of a type extension is fully default
12070 if Etype (Typ) /= Typ
12071 and then not Has_Full_Default_Initialization (Etype (Typ))
12076 -- If we get here, then all components and parent portion are fully
12077 -- default initialized.
12081 -- A task type is fully default initialized by default
12083 elsif Is_Task_Type (Typ) then
12086 -- Otherwise the type is not fully default initialized
12091 end Has_Full_Default_Initialization;
12093 -----------------------------------------------
12094 -- Has_Fully_Default_Initializing_DIC_Pragma --
12095 -----------------------------------------------
12097 function Has_Fully_Default_Initializing_DIC_Pragma
12098 (Typ : Entity_Id) return Boolean
12104 -- A type that inherits pragma Default_Initial_Condition from a parent
12105 -- type is automatically fully default initialized.
12107 if Has_Inherited_DIC (Typ) then
12110 -- Otherwise the type is fully default initialized only when the pragma
12111 -- appears without an argument, or the argument is non-null.
12113 elsif Has_Own_DIC (Typ) then
12114 Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
12115 pragma Assert (Present (Prag));
12116 Args := Pragma_Argument_Associations (Prag);
12118 -- The pragma appears without an argument in which case it defaults
12124 -- The pragma appears with a non-null expression
12126 elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then
12132 end Has_Fully_Default_Initializing_DIC_Pragma;
12134 ---------------------------------
12135 -- Has_Inferable_Discriminants --
12136 ---------------------------------
12138 function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
12140 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
12141 -- Determines whether the left-most prefix of a selected component is a
12142 -- formal parameter in a subprogram. Assumes N is a selected component.
12144 --------------------------------
12145 -- Prefix_Is_Formal_Parameter --
12146 --------------------------------
12148 function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
12149 Sel_Comp : Node_Id;
12152 -- Move to the left-most prefix by climbing up the tree
12155 while Present (Parent (Sel_Comp))
12156 and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
12158 Sel_Comp := Parent (Sel_Comp);
12161 return Is_Formal (Entity (Prefix (Sel_Comp)));
12162 end Prefix_Is_Formal_Parameter;
12164 -- Start of processing for Has_Inferable_Discriminants
12167 -- For selected components, the subtype of the selector must be a
12168 -- constrained Unchecked_Union. If the component is subject to a
12169 -- per-object constraint, then the enclosing object must have inferable
12172 if Nkind (N) = N_Selected_Component then
12173 if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
12175 -- A small hack. If we have a per-object constrained selected
12176 -- component of a formal parameter, return True since we do not
12177 -- know the actual parameter association yet.
12179 if Prefix_Is_Formal_Parameter (N) then
12182 -- Otherwise, check the enclosing object and the selector
12185 return Has_Inferable_Discriminants (Prefix (N))
12186 and then Has_Inferable_Discriminants (Selector_Name (N));
12189 -- The call to Has_Inferable_Discriminants will determine whether
12190 -- the selector has a constrained Unchecked_Union nominal type.
12193 return Has_Inferable_Discriminants (Selector_Name (N));
12196 -- A qualified expression has inferable discriminants if its subtype
12197 -- mark is a constrained Unchecked_Union subtype.
12199 elsif Nkind (N) = N_Qualified_Expression then
12200 return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
12201 and then Is_Constrained (Etype (Subtype_Mark (N)));
12203 -- For all other names, it is sufficient to have a constrained
12204 -- Unchecked_Union nominal subtype.
12207 return Is_Unchecked_Union (Base_Type (Etype (N)))
12208 and then Is_Constrained (Etype (N));
12210 end Has_Inferable_Discriminants;
12212 --------------------
12213 -- Has_Infinities --
12214 --------------------
12216 function Has_Infinities (E : Entity_Id) return Boolean is
12219 Is_Floating_Point_Type (E)
12220 and then Nkind (Scalar_Range (E)) = N_Range
12221 and then Includes_Infinities (Scalar_Range (E));
12222 end Has_Infinities;
12224 --------------------
12225 -- Has_Interfaces --
12226 --------------------
12228 function Has_Interfaces
12230 Use_Full_View : Boolean := True) return Boolean
12232 Typ : Entity_Id := Base_Type (T);
12235 -- Handle concurrent types
12237 if Is_Concurrent_Type (Typ) then
12238 Typ := Corresponding_Record_Type (Typ);
12242 or else not Is_Record_Type (Typ)
12243 or else not Is_Tagged_Type (Typ)
12248 -- Handle private types
12250 if Use_Full_View and then Present (Full_View (Typ)) then
12251 Typ := Full_View (Typ);
12254 -- Handle concurrent record types
12256 if Is_Concurrent_Record_Type (Typ)
12257 and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
12263 if Is_Interface (Typ)
12265 (Is_Record_Type (Typ)
12266 and then Present (Interfaces (Typ))
12267 and then not Is_Empty_Elmt_List (Interfaces (Typ)))
12272 exit when Etype (Typ) = Typ
12274 -- Handle private types
12276 or else (Present (Full_View (Etype (Typ)))
12277 and then Full_View (Etype (Typ)) = Typ)
12279 -- Protect frontend against wrong sources with cyclic derivations
12281 or else Etype (Typ) = T;
12283 -- Climb to the ancestor type handling private types
12285 if Present (Full_View (Etype (Typ))) then
12286 Typ := Full_View (Etype (Typ));
12288 Typ := Etype (Typ);
12293 end Has_Interfaces;
12295 --------------------------
12296 -- Has_Max_Queue_Length --
12297 --------------------------
12299 function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is
12302 Ekind (Id) = E_Entry
12303 and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length));
12304 end Has_Max_Queue_Length;
12306 ---------------------------------
12307 -- Has_No_Obvious_Side_Effects --
12308 ---------------------------------
12310 function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
12312 -- For now handle literals, constants, and non-volatile variables and
12313 -- expressions combining these with operators or short circuit forms.
12315 if Nkind (N) in N_Numeric_Or_String_Literal then
12318 elsif Nkind (N) = N_Character_Literal then
12321 elsif Nkind (N) in N_Unary_Op then
12322 return Has_No_Obvious_Side_Effects (Right_Opnd (N));
12324 elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then
12325 return Has_No_Obvious_Side_Effects (Left_Opnd (N))
12327 Has_No_Obvious_Side_Effects (Right_Opnd (N));
12329 elsif Nkind (N) = N_Expression_With_Actions
12330 and then Is_Empty_List (Actions (N))
12332 return Has_No_Obvious_Side_Effects (Expression (N));
12334 elsif Nkind (N) in N_Has_Entity then
12335 return Present (Entity (N))
12337 Ekind (Entity (N)) in
12338 E_Variable | E_Constant | E_Enumeration_Literal |
12339 E_In_Parameter | E_Out_Parameter | E_In_Out_Parameter
12340 and then not Is_Volatile (Entity (N));
12345 end Has_No_Obvious_Side_Effects;
12347 -----------------------------
12348 -- Has_Non_Null_Refinement --
12349 -----------------------------
12351 function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is
12352 Constits : Elist_Id;
12355 pragma Assert (Ekind (Id) = E_Abstract_State);
12356 Constits := Refinement_Constituents (Id);
12358 -- For a refinement to be non-null, the first constituent must be
12359 -- anything other than null.
12363 and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
12364 end Has_Non_Null_Refinement;
12366 -----------------------------
12367 -- Has_Non_Null_Statements --
12368 -----------------------------
12370 function Has_Non_Null_Statements (L : List_Id) return Boolean is
12376 while Present (Node) loop
12377 if Nkind (Node) not in N_Null_Statement | N_Call_Marker then
12385 end Has_Non_Null_Statements;
12387 ----------------------------------
12388 -- Is_Access_Subprogram_Wrapper --
12389 ----------------------------------
12391 function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean is
12392 Formal : constant Entity_Id := Last_Formal (E);
12394 return Present (Formal)
12395 and then Ekind (Etype (Formal)) in Access_Subprogram_Kind
12396 and then Access_Subprogram_Wrapper
12397 (Directly_Designated_Type (Etype (Formal))) = E;
12398 end Is_Access_Subprogram_Wrapper;
12400 ---------------------------
12401 -- Is_Explicitly_Aliased --
12402 ---------------------------
12404 function Is_Explicitly_Aliased (N : Node_Id) return Boolean is
12406 return Is_Formal (N)
12407 and then Present (Parent (N))
12408 and then Nkind (Parent (N)) = N_Parameter_Specification
12409 and then Aliased_Present (Parent (N));
12410 end Is_Explicitly_Aliased;
12412 ----------------------------
12413 -- Is_Container_Aggregate --
12414 ----------------------------
12416 function Is_Container_Aggregate (Exp : Node_Id) return Boolean is
12418 function Is_Record_Aggregate return Boolean is (False);
12419 -- ??? Unimplemented. Given an aggregate whose type is a
12420 -- record type with specified Aggregate aspect, how do we
12421 -- determine whether it is a record aggregate or a container
12422 -- aggregate? If the code where the aggregate occurs can see only
12423 -- a partial view of the aggregate's type then the aggregate
12424 -- cannot be a record type; an aggregate of a private type has to
12425 -- be a container aggregate.
12428 return Nkind (Exp) = N_Aggregate
12429 and then Has_Aspect (Etype (Exp), Aspect_Aggregate)
12430 and then not Is_Record_Aggregate;
12431 end Is_Container_Aggregate;
12433 ---------------------------------
12434 -- Side_Effect_Free_Statements --
12435 ---------------------------------
12437 function Side_Effect_Free_Statements (L : List_Id) return Boolean is
12443 while Present (Node) loop
12444 case Nkind (Node) is
12445 when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error =>
12448 when N_Object_Declaration =>
12449 if Present (Expression (Node))
12450 and then not Side_Effect_Free (Expression (Node))
12463 end Side_Effect_Free_Statements;
12465 ---------------------------
12466 -- Side_Effect_Free_Loop --
12467 ---------------------------
12469 function Side_Effect_Free_Loop (N : Node_Id) return Boolean is
12475 -- If this is not a loop (e.g. because the loop has been rewritten),
12476 -- then return false.
12478 if Nkind (N) /= N_Loop_Statement then
12482 -- First check the statements
12484 if Side_Effect_Free_Statements (Statements (N)) then
12486 -- Then check the loop condition/indexes
12488 if Present (Iteration_Scheme (N)) then
12489 Scheme := Iteration_Scheme (N);
12491 if Present (Condition (Scheme))
12492 or else Present (Iterator_Specification (Scheme))
12495 elsif Present (Loop_Parameter_Specification (Scheme)) then
12496 Spec := Loop_Parameter_Specification (Scheme);
12497 Subt := Discrete_Subtype_Definition (Spec);
12499 if Present (Subt) then
12500 if Nkind (Subt) = N_Range then
12501 return Side_Effect_Free (Low_Bound (Subt))
12502 and then Side_Effect_Free (High_Bound (Subt));
12504 -- subtype indication
12514 end Side_Effect_Free_Loop;
12516 ----------------------------------
12517 -- Has_Non_Trivial_Precondition --
12518 ----------------------------------
12520 function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is
12521 Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre,
12522 Class_Present => True);
12526 and then not Is_Entity_Name (Expression (Pre));
12527 end Has_Non_Trivial_Precondition;
12529 -------------------
12530 -- Has_Null_Body --
12531 -------------------
12533 function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is
12534 Body_Id : Entity_Id;
12541 Spec := Parent (Proc_Id);
12542 Decl := Parent (Spec);
12544 -- Retrieve the entity of the procedure body (e.g. invariant proc).
12546 if Nkind (Spec) = N_Procedure_Specification
12547 and then Nkind (Decl) = N_Subprogram_Declaration
12549 Body_Id := Corresponding_Body (Decl);
12551 -- The body acts as a spec
12554 Body_Id := Proc_Id;
12557 -- The body will be generated later
12559 if No (Body_Id) then
12563 Spec := Parent (Body_Id);
12564 Decl := Parent (Spec);
12567 (Nkind (Spec) = N_Procedure_Specification
12568 and then Nkind (Decl) = N_Subprogram_Body);
12570 Stmt1 := First (Statements (Handled_Statement_Sequence (Decl)));
12572 -- Look for a null statement followed by an optional return
12575 if Nkind (Stmt1) = N_Null_Statement then
12576 Stmt2 := Next (Stmt1);
12578 if Present (Stmt2) then
12579 return Nkind (Stmt2) = N_Simple_Return_Statement;
12588 ------------------------
12589 -- Has_Null_Exclusion --
12590 ------------------------
12592 function Has_Null_Exclusion (N : Node_Id) return Boolean is
12595 when N_Access_Definition
12596 | N_Access_Function_Definition
12597 | N_Access_Procedure_Definition
12598 | N_Access_To_Object_Definition
12600 | N_Derived_Type_Definition
12601 | N_Function_Specification
12602 | N_Subtype_Declaration
12604 return Null_Exclusion_Present (N);
12606 when N_Component_Definition
12607 | N_Formal_Object_Declaration
12609 if Present (Subtype_Mark (N)) then
12610 return Null_Exclusion_Present (N);
12611 else pragma Assert (Present (Access_Definition (N)));
12612 return Null_Exclusion_Present (Access_Definition (N));
12615 when N_Object_Renaming_Declaration =>
12616 if Present (Subtype_Mark (N)) then
12617 return Null_Exclusion_Present (N);
12618 elsif Present (Access_Definition (N)) then
12619 return Null_Exclusion_Present (Access_Definition (N));
12621 return False; -- Case of no subtype in renaming (AI12-0275)
12624 when N_Discriminant_Specification =>
12625 if Nkind (Discriminant_Type (N)) = N_Access_Definition then
12626 return Null_Exclusion_Present (Discriminant_Type (N));
12628 return Null_Exclusion_Present (N);
12631 when N_Object_Declaration =>
12632 if Nkind (Object_Definition (N)) = N_Access_Definition then
12633 return Null_Exclusion_Present (Object_Definition (N));
12635 return Null_Exclusion_Present (N);
12638 when N_Parameter_Specification =>
12639 if Nkind (Parameter_Type (N)) = N_Access_Definition then
12640 return Null_Exclusion_Present (Parameter_Type (N))
12641 or else Null_Exclusion_Present (N);
12643 return Null_Exclusion_Present (N);
12649 end Has_Null_Exclusion;
12651 ------------------------
12652 -- Has_Null_Extension --
12653 ------------------------
12655 function Has_Null_Extension (T : Entity_Id) return Boolean is
12656 B : constant Entity_Id := Base_Type (T);
12661 if Nkind (Parent (B)) = N_Full_Type_Declaration
12662 and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
12664 Ext := Record_Extension_Part (Type_Definition (Parent (B)));
12666 if Present (Ext) then
12667 if Null_Present (Ext) then
12670 Comps := Component_List (Ext);
12672 -- The null component list is rewritten during analysis to
12673 -- include the parent component. Any other component indicates
12674 -- that the extension was not originally null.
12676 return Null_Present (Comps)
12677 or else No (Next (First (Component_Items (Comps))));
12686 end Has_Null_Extension;
12688 -------------------------
12689 -- Has_Null_Refinement --
12690 -------------------------
12692 function Has_Null_Refinement (Id : Entity_Id) return Boolean is
12693 Constits : Elist_Id;
12696 pragma Assert (Ekind (Id) = E_Abstract_State);
12697 Constits := Refinement_Constituents (Id);
12699 -- For a refinement to be null, the state's sole constituent must be a
12704 and then Nkind (Node (First_Elmt (Constits))) = N_Null;
12705 end Has_Null_Refinement;
12707 ------------------------------------------
12708 -- Has_Nonstatic_Class_Wide_Pre_Or_Post --
12709 ------------------------------------------
12711 function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post
12712 (Subp : Entity_Id) return Boolean
12714 Disp_Type : constant Entity_Id := Find_Dispatching_Type (Subp);
12716 Pragma_Arg : Node_Id;
12719 if Present (Disp_Type)
12720 and then Is_Abstract_Type (Disp_Type)
12721 and then Present (Contract (Subp))
12723 Prag := Pre_Post_Conditions (Contract (Subp));
12725 while Present (Prag) loop
12726 if Pragma_Name (Prag) in Name_Precondition | Name_Postcondition
12727 and then Class_Present (Prag)
12731 (Pragma_Argument_Associations (Prag));
12733 if not Is_Static_Expression (Expression (Pragma_Arg)) then
12738 Prag := Next_Pragma (Prag);
12743 end Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post;
12745 -------------------------------
12746 -- Has_Overriding_Initialize --
12747 -------------------------------
12749 function Has_Overriding_Initialize (T : Entity_Id) return Boolean is
12750 BT : constant Entity_Id := Base_Type (T);
12754 if Is_Controlled (BT) then
12755 if Is_RTU (Scope (BT), Ada_Finalization) then
12758 elsif Present (Primitive_Operations (BT)) then
12759 P := First_Elmt (Primitive_Operations (BT));
12760 while Present (P) loop
12762 Init : constant Entity_Id := Node (P);
12763 Formal : constant Entity_Id := First_Formal (Init);
12765 if Ekind (Init) = E_Procedure
12766 and then Chars (Init) = Name_Initialize
12767 and then Comes_From_Source (Init)
12768 and then Present (Formal)
12769 and then Etype (Formal) = BT
12770 and then No (Next_Formal (Formal))
12771 and then (Ada_Version < Ada_2012
12772 or else not Null_Present (Parent (Init)))
12782 -- Here if type itself does not have a non-null Initialize operation:
12783 -- check immediate ancestor.
12785 if Is_Derived_Type (BT)
12786 and then Has_Overriding_Initialize (Etype (BT))
12793 end Has_Overriding_Initialize;
12795 --------------------------------------
12796 -- Has_Preelaborable_Initialization --
12797 --------------------------------------
12799 function Has_Preelaborable_Initialization
12801 Preelab_Init_Expr : Node_Id := Empty) return Boolean
12805 procedure Check_Components (E : Entity_Id);
12806 -- Check component/discriminant chain, sets Has_PE False if a component
12807 -- or discriminant does not meet the preelaborable initialization rules.
12809 function Type_Named_In_Preelab_Init_Expression
12811 Expr : Node_Id) return Boolean;
12812 -- Returns True iff Typ'Preelaborable_Initialization occurs in Expr
12813 -- (where Expr may be a conjunction of one or more P_I attributes).
12815 ----------------------
12816 -- Check_Components --
12817 ----------------------
12819 procedure Check_Components (E : Entity_Id) is
12824 -- Loop through components and discriminants of record or protected
12827 Ent := First_Component_Or_Discriminant (E);
12828 while Present (Ent) loop
12830 case Ekind (Ent) is
12831 when E_Component =>
12833 -- Get default expression if any. If there is no declaration
12834 -- node, it means we have an internal entity. The parent and
12835 -- tag fields are examples of such entities. For such cases,
12836 -- we just test the type of the entity.
12838 if Present (Declaration_Node (Ent)) then
12839 Exp := Expression (Declaration_Node (Ent));
12844 when E_Discriminant =>
12846 -- Note: for a renamed discriminant, the Declaration_Node
12847 -- may point to the one from the ancestor, and have a
12848 -- different expression, so use the proper attribute to
12849 -- retrieve the expression from the derived constraint.
12851 Exp := Discriminant_Default_Value (Ent);
12854 raise Program_Error;
12857 -- A component has PI if it has no default expression and the
12858 -- component type has PI.
12861 if not Has_Preelaborable_Initialization
12862 (Etype (Ent), Preelab_Init_Expr)
12868 -- Require the default expression to be preelaborable
12870 elsif not Is_Preelaborable_Construct (Exp) then
12875 Next_Component_Or_Discriminant (Ent);
12877 end Check_Components;
12879 --------------------------------------
12880 -- Type_Named_In_Preelab_Expression --
12881 --------------------------------------
12883 function Type_Named_In_Preelab_Init_Expression
12885 Expr : Node_Id) return Boolean
12888 -- Return True if Expr is a Preelaborable_Initialization attribute
12889 -- and the prefix is a subtype that has the same type as Typ.
12891 if Nkind (Expr) = N_Attribute_Reference
12892 and then Attribute_Name (Expr) = Name_Preelaborable_Initialization
12893 and then Is_Entity_Name (Prefix (Expr))
12894 and then Base_Type (Entity (Prefix (Expr))) = Base_Type (Typ)
12898 -- In the case where Expr is a conjunction, test whether either
12899 -- operand is a Preelaborable_Initialization attribute whose prefix
12900 -- has the same type as Typ, and return True if so.
12902 elsif Nkind (Expr) = N_Op_And
12904 (Type_Named_In_Preelab_Init_Expression (Typ, Left_Opnd (Expr))
12906 Type_Named_In_Preelab_Init_Expression (Typ, Right_Opnd (Expr)))
12910 -- Typ not named in a Preelaborable_Initialization attribute of Expr
12915 end Type_Named_In_Preelab_Init_Expression;
12917 -- Start of processing for Has_Preelaborable_Initialization
12920 -- Immediate return if already marked as known preelaborable init. This
12921 -- covers types for which this function has already been called once
12922 -- and returned True (in which case the result is cached), and also
12923 -- types to which a pragma Preelaborable_Initialization applies.
12925 if Known_To_Have_Preelab_Init (E) then
12929 -- If the type is a subtype representing a generic actual type, then
12930 -- test whether its base type has preelaborable initialization since
12931 -- the subtype representing the actual does not inherit this attribute
12932 -- from the actual or formal. (but maybe it should???)
12934 if Is_Generic_Actual_Type (E) then
12935 return Has_Preelaborable_Initialization (Base_Type (E));
12938 -- All elementary types have preelaborable initialization
12940 if Is_Elementary_Type (E) then
12943 -- Array types have PI if the component type has PI
12945 elsif Is_Array_Type (E) then
12946 Has_PE := Has_Preelaborable_Initialization
12947 (Component_Type (E), Preelab_Init_Expr);
12949 -- A derived type has preelaborable initialization if its parent type
12950 -- has preelaborable initialization and (in the case of a derived record
12951 -- extension) if the non-inherited components all have preelaborable
12952 -- initialization. However, a user-defined controlled type with an
12953 -- overriding Initialize procedure does not have preelaborable
12956 elsif Is_Derived_Type (E) then
12958 -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component
12959 -- of a generic formal derived type has preelaborable initialization.
12960 -- (See comment on spec of Has_Preelaborable_Initialization.)
12962 if Is_Generic_Type (E)
12963 and then Present (Preelab_Init_Expr)
12965 Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr)
12970 -- If the derived type is a private extension then it doesn't have
12971 -- preelaborable initialization.
12973 if Ekind (Base_Type (E)) = E_Record_Type_With_Private then
12977 -- First check whether ancestor type has preelaborable initialization
12979 Has_PE := Has_Preelaborable_Initialization
12980 (Etype (Base_Type (E)), Preelab_Init_Expr);
12982 -- If OK, check extension components (if any)
12984 if Has_PE and then Is_Record_Type (E) then
12985 Check_Components (E);
12988 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
12989 -- with a user defined Initialize procedure does not have PI. If
12990 -- the type is untagged, the control primitives come from a component
12991 -- that has already been checked.
12994 and then Is_Controlled (E)
12995 and then Is_Tagged_Type (E)
12996 and then Has_Overriding_Initialize (E)
13001 -- Private types not derived from a type having preelaborable init and
13002 -- that are not marked with pragma Preelaborable_Initialization do not
13003 -- have preelaborable initialization.
13005 elsif Is_Private_Type (E) then
13007 -- When the rule of RM 10.2.1(11.8/5) applies, we presume a component
13008 -- of a generic formal private type has preelaborable initialization.
13009 -- (See comment on spec of Has_Preelaborable_Initialization.)
13011 if Is_Generic_Type (E)
13012 and then Present (Preelab_Init_Expr)
13014 Type_Named_In_Preelab_Init_Expression (E, Preelab_Init_Expr)
13021 -- Record type has PI if it is non private and all components have PI
13023 elsif Is_Record_Type (E) then
13025 Check_Components (E);
13027 -- Protected types must not have entries, and components must meet
13028 -- same set of rules as for record components.
13030 elsif Is_Protected_Type (E) then
13031 if Has_Entries (E) then
13035 Check_Components (E);
13038 -- Type System.Address always has preelaborable initialization
13040 elsif Is_RTE (E, RE_Address) then
13043 -- In all other cases, type does not have preelaborable initialization
13049 -- If type has preelaborable initialization, cache result
13052 Set_Known_To_Have_Preelab_Init (E);
13056 end Has_Preelaborable_Initialization;
13062 function Has_Prefix (N : Node_Id) return Boolean is
13064 return Nkind (N) in
13065 N_Attribute_Reference | N_Expanded_Name | N_Explicit_Dereference |
13066 N_Indexed_Component | N_Reference | N_Selected_Component |
13070 ---------------------------
13071 -- Has_Private_Component --
13072 ---------------------------
13074 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
13075 Btype : Entity_Id := Base_Type (Type_Id);
13076 Component : Entity_Id;
13079 if Error_Posted (Type_Id)
13080 or else Error_Posted (Btype)
13085 if Is_Class_Wide_Type (Btype) then
13086 Btype := Root_Type (Btype);
13089 if Is_Private_Type (Btype) then
13091 UT : constant Entity_Id := Underlying_Type (Btype);
13094 if No (Full_View (Btype)) then
13095 return not Is_Generic_Type (Btype)
13097 not Is_Generic_Type (Root_Type (Btype));
13099 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
13102 return not Is_Frozen (UT) and then Has_Private_Component (UT);
13106 elsif Is_Array_Type (Btype) then
13107 return Has_Private_Component (Component_Type (Btype));
13109 elsif Is_Record_Type (Btype) then
13110 Component := First_Component (Btype);
13111 while Present (Component) loop
13112 if Has_Private_Component (Etype (Component)) then
13116 Next_Component (Component);
13121 elsif Is_Protected_Type (Btype)
13122 and then Present (Corresponding_Record_Type (Btype))
13124 return Has_Private_Component (Corresponding_Record_Type (Btype));
13129 end Has_Private_Component;
13131 --------------------------------
13132 -- Has_Relaxed_Initialization --
13133 --------------------------------
13135 function Has_Relaxed_Initialization (E : Entity_Id) return Boolean is
13137 function Denotes_Relaxed_Parameter
13141 -- Returns True iff expression Expr denotes a formal parameter or
13142 -- function Param (through its attribute Result).
13144 -------------------------------
13145 -- Denotes_Relaxed_Parameter --
13146 -------------------------------
13148 function Denotes_Relaxed_Parameter
13150 Param : Entity_Id) return Boolean is
13152 if Nkind (Expr) in N_Identifier | N_Expanded_Name then
13153 return Entity (Expr) = Param;
13155 pragma Assert (Is_Attribute_Result (Expr));
13156 return Entity (Prefix (Expr)) = Param;
13158 end Denotes_Relaxed_Parameter;
13160 -- Start of processing for Has_Relaxed_Initialization
13163 -- When analyzing, we checked all syntax legality rules for the aspect
13164 -- Relaxed_Initialization, but didn't store the property anywhere (e.g.
13165 -- as an Einfo flag). To query the property we look directly at the AST,
13166 -- but now without any syntactic checks.
13169 -- Abstract states have option Relaxed_Initialization
13171 when E_Abstract_State =>
13172 return Is_Relaxed_Initialization_State (E);
13174 -- Constants have this aspect attached directly; for deferred
13175 -- constants, the aspect is attached to the partial view.
13178 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13180 -- Variables have this aspect attached directly
13183 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13185 -- Types have this aspect attached directly (though we only allow it
13186 -- to be specified for the first subtype). For private types, the
13187 -- aspect is attached to the partial view.
13190 pragma Assert (Is_First_Subtype (E));
13191 return Has_Aspect (E, Aspect_Relaxed_Initialization);
13193 -- Formal parameters and functions have the Relaxed_Initialization
13194 -- aspect attached to the subprogram entity and must be listed in
13195 -- the aspect expression.
13201 Subp_Id : Entity_Id;
13202 Aspect_Expr : Node_Id;
13203 Param_Expr : Node_Id;
13207 if Is_Formal (E) then
13208 Subp_Id := Scope (E);
13213 if Has_Aspect (Subp_Id, Aspect_Relaxed_Initialization) then
13215 Find_Value_Of_Aspect
13216 (Subp_Id, Aspect_Relaxed_Initialization);
13218 -- Aspect expression is either an aggregate with an optional
13219 -- Boolean expression (which defaults to True), e.g.:
13221 -- function F (X : Integer) return Integer
13222 -- with Relaxed_Initialization => (X => True, F'Result);
13224 if Nkind (Aspect_Expr) = N_Aggregate then
13226 if Present (Component_Associations (Aspect_Expr)) then
13227 Assoc := First (Component_Associations (Aspect_Expr));
13229 while Present (Assoc) loop
13230 if Denotes_Relaxed_Parameter
13231 (First (Choices (Assoc)), E)
13235 (Static_Boolean (Expression (Assoc)));
13242 Param_Expr := First (Expressions (Aspect_Expr));
13244 while Present (Param_Expr) loop
13245 if Denotes_Relaxed_Parameter (Param_Expr, E) then
13254 -- or it is a single identifier, e.g.:
13256 -- function F (X : Integer) return Integer
13257 -- with Relaxed_Initialization => X;
13260 return Denotes_Relaxed_Parameter (Aspect_Expr, E);
13268 raise Program_Error;
13270 end Has_Relaxed_Initialization;
13272 ----------------------
13273 -- Has_Signed_Zeros --
13274 ----------------------
13276 function Has_Signed_Zeros (E : Entity_Id) return Boolean is
13278 return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target;
13279 end Has_Signed_Zeros;
13281 ------------------------------
13282 -- Has_Significant_Contract --
13283 ------------------------------
13285 function Has_Significant_Contract (Subp_Id : Entity_Id) return Boolean is
13286 Subp_Nam : constant Name_Id := Chars (Subp_Id);
13289 -- _Finalizer procedure
13291 if Subp_Nam = Name_uFinalizer then
13294 -- _Wrapped_Statements procedure which gets generated as part of the
13295 -- expansion of postconditions.
13297 elsif Subp_Nam = Name_uWrapped_Statements then
13300 -- Predicate function
13302 elsif Ekind (Subp_Id) = E_Function
13303 and then Is_Predicate_Function (Subp_Id)
13309 elsif Get_TSS_Name (Subp_Id) /= TSS_Null then
13315 end Has_Significant_Contract;
13317 -----------------------------
13318 -- Has_Static_Array_Bounds --
13319 -----------------------------
13321 function Has_Static_Array_Bounds (Typ : Node_Id) return Boolean is
13322 All_Static : Boolean;
13326 Examine_Array_Bounds (Typ, All_Static, Dummy);
13329 end Has_Static_Array_Bounds;
13331 ---------------------------------------
13332 -- Has_Static_Non_Empty_Array_Bounds --
13333 ---------------------------------------
13335 function Has_Static_Non_Empty_Array_Bounds (Typ : Node_Id) return Boolean is
13336 All_Static : Boolean;
13337 Has_Empty : Boolean;
13340 Examine_Array_Bounds (Typ, All_Static, Has_Empty);
13342 return All_Static and not Has_Empty;
13343 end Has_Static_Non_Empty_Array_Bounds;
13349 function Has_Stream (T : Entity_Id) return Boolean is
13356 elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then
13359 elsif Is_Array_Type (T) then
13360 return Has_Stream (Component_Type (T));
13362 elsif Is_Record_Type (T) then
13363 E := First_Component (T);
13364 while Present (E) loop
13365 if Has_Stream (Etype (E)) then
13368 Next_Component (E);
13374 elsif Is_Private_Type (T) then
13375 return Has_Stream (Underlying_Type (T));
13386 function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean is
13388 Get_Name_String (Chars (E));
13389 return Name_Buffer (Name_Len) = Suffix;
13396 function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
13398 Get_Name_String (Chars (E));
13399 Add_Char_To_Name_Buffer (Suffix);
13403 -------------------
13404 -- Remove_Suffix --
13405 -------------------
13407 function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is
13409 pragma Assert (Has_Suffix (E, Suffix));
13410 Get_Name_String (Chars (E));
13411 Name_Len := Name_Len - 1;
13415 ----------------------------------
13416 -- Replace_Null_By_Null_Address --
13417 ----------------------------------
13419 procedure Replace_Null_By_Null_Address (N : Node_Id) is
13420 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id);
13421 -- Replace operand Op with a reference to Null_Address when the operand
13422 -- denotes a null Address. Other_Op denotes the other operand.
13424 --------------------------
13425 -- Replace_Null_Operand --
13426 --------------------------
13428 procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is
13430 -- Check the type of the complementary operand since the N_Null node
13431 -- has not been decorated yet.
13433 if Nkind (Op) = N_Null
13434 and then Is_Descendant_Of_Address (Etype (Other_Op))
13436 Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op)));
13438 end Replace_Null_Operand;
13440 -- Start of processing for Replace_Null_By_Null_Address
13443 pragma Assert (Relaxed_RM_Semantics);
13444 pragma Assert (Nkind (N) in N_Null | N_Op_Compare);
13446 if Nkind (N) = N_Null then
13447 Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
13451 L : constant Node_Id := Left_Opnd (N);
13452 R : constant Node_Id := Right_Opnd (N);
13455 Replace_Null_Operand (L, Other_Op => R);
13456 Replace_Null_Operand (R, Other_Op => L);
13459 end Replace_Null_By_Null_Address;
13461 --------------------------
13462 -- Has_Tagged_Component --
13463 --------------------------
13465 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
13469 if Is_Private_Type (Typ) and then Present (Underlying_Type (Typ)) then
13470 return Has_Tagged_Component (Underlying_Type (Typ));
13472 elsif Is_Array_Type (Typ) then
13473 return Has_Tagged_Component (Component_Type (Typ));
13475 elsif Is_Tagged_Type (Typ) then
13478 elsif Is_Record_Type (Typ) then
13479 Comp := First_Component (Typ);
13480 while Present (Comp) loop
13481 if Has_Tagged_Component (Etype (Comp)) then
13485 Next_Component (Comp);
13493 end Has_Tagged_Component;
13495 -----------------------------
13496 -- Has_Undefined_Reference --
13497 -----------------------------
13499 function Has_Undefined_Reference (Expr : Node_Id) return Boolean is
13500 Has_Undef_Ref : Boolean := False;
13501 -- Flag set when expression Expr contains at least one undefined
13504 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result;
13505 -- Determine whether N denotes a reference and if it does, whether it is
13508 ----------------------------
13509 -- Is_Undefined_Reference --
13510 ----------------------------
13512 function Is_Undefined_Reference (N : Node_Id) return Traverse_Result is
13514 if Is_Entity_Name (N)
13515 and then Present (Entity (N))
13516 and then Entity (N) = Any_Id
13518 Has_Undef_Ref := True;
13523 end Is_Undefined_Reference;
13525 procedure Find_Undefined_References is
13526 new Traverse_Proc (Is_Undefined_Reference);
13528 -- Start of processing for Has_Undefined_Reference
13531 Find_Undefined_References (Expr);
13533 return Has_Undef_Ref;
13534 end Has_Undefined_Reference;
13536 ----------------------------------------
13537 -- Has_Effectively_Volatile_Component --
13538 ----------------------------------------
13540 function Has_Effectively_Volatile_Component
13541 (Typ : Entity_Id) return Boolean
13546 if Has_Volatile_Components (Typ) then
13549 elsif Is_Array_Type (Typ) then
13550 return Is_Effectively_Volatile (Component_Type (Typ));
13552 elsif Is_Record_Type (Typ) then
13553 Comp := First_Component (Typ);
13554 while Present (Comp) loop
13555 if Is_Effectively_Volatile (Etype (Comp)) then
13559 Next_Component (Comp);
13564 end Has_Effectively_Volatile_Component;
13566 ----------------------------
13567 -- Has_Volatile_Component --
13568 ----------------------------
13570 function Has_Volatile_Component (Typ : Entity_Id) return Boolean is
13574 if Has_Volatile_Components (Typ) then
13577 elsif Is_Array_Type (Typ) then
13578 return Is_Volatile (Component_Type (Typ));
13580 elsif Is_Record_Type (Typ) then
13581 Comp := First_Component (Typ);
13582 while Present (Comp) loop
13583 if Is_Volatile_Object_Ref (Comp) then
13587 Next_Component (Comp);
13592 end Has_Volatile_Component;
13594 -------------------------
13595 -- Implementation_Kind --
13596 -------------------------
13598 function Implementation_Kind (Subp : Entity_Id) return Name_Id is
13599 Impl_Prag : constant Node_Id := Get_Rep_Pragma (Subp, Name_Implemented);
13602 pragma Assert (Present (Impl_Prag));
13603 Arg := Last (Pragma_Argument_Associations (Impl_Prag));
13604 return Chars (Get_Pragma_Arg (Arg));
13605 end Implementation_Kind;
13607 --------------------------
13608 -- Implements_Interface --
13609 --------------------------
13611 function Implements_Interface
13612 (Typ_Ent : Entity_Id;
13613 Iface_Ent : Entity_Id;
13614 Exclude_Parents : Boolean := False) return Boolean
13616 Ifaces_List : Elist_Id;
13618 Iface : Entity_Id := Base_Type (Iface_Ent);
13619 Typ : Entity_Id := Base_Type (Typ_Ent);
13622 if Is_Class_Wide_Type (Typ) then
13623 Typ := Root_Type (Typ);
13626 if not Has_Interfaces (Typ) then
13630 if Is_Class_Wide_Type (Iface) then
13631 Iface := Root_Type (Iface);
13634 Collect_Interfaces (Typ, Ifaces_List);
13636 Elmt := First_Elmt (Ifaces_List);
13637 while Present (Elmt) loop
13638 if Is_Ancestor (Node (Elmt), Typ, Use_Full_View => True)
13639 and then Exclude_Parents
13643 elsif Node (Elmt) = Iface then
13651 end Implements_Interface;
13653 --------------------------------
13654 -- Implicitly_Designated_Type --
13655 --------------------------------
13657 function Implicitly_Designated_Type (Typ : Entity_Id) return Entity_Id is
13658 Desig : constant Entity_Id := Designated_Type (Typ);
13661 -- An implicit dereference is a legal occurrence of an incomplete type
13662 -- imported through a limited_with clause, if the full view is visible.
13664 if Is_Incomplete_Type (Desig)
13665 and then From_Limited_With (Desig)
13666 and then not From_Limited_With (Scope (Desig))
13668 (Is_Immediately_Visible (Scope (Desig))
13670 (Is_Child_Unit (Scope (Desig))
13671 and then Is_Visible_Lib_Unit (Scope (Desig))))
13673 return Available_View (Desig);
13677 end Implicitly_Designated_Type;
13679 ------------------------------------
13680 -- In_Assertion_Expression_Pragma --
13681 ------------------------------------
13683 function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean is
13685 Prag : Node_Id := Empty;
13688 -- Climb the parent chain looking for an enclosing pragma
13691 while Present (Par) loop
13692 if Nkind (Par) = N_Pragma then
13696 -- Precondition-like pragmas are expanded into if statements, check
13697 -- the original node instead.
13699 elsif Nkind (Original_Node (Par)) = N_Pragma then
13700 Prag := Original_Node (Par);
13703 -- The expansion of attribute 'Old generates a
constant to capture
13704 -- the result of the prefix. If the parent traversal reaches
13705 -- one of these constants, then the node technically came from a
13706 -- postcondition-like pragma. Note that the Ekind is not tested here
13707 -- because N may be the expression of an object declaration which is
13708 -- currently being analyzed. Such objects carry Ekind of E_Void.
13710 elsif Nkind
(Par
) = N_Object_Declaration
13711 and then Constant_Present
(Par
)
13712 and then Stores_Attribute_Old_Prefix
(Defining_Entity
(Par
))
13716 -- Prevent the search from going too far
13718 elsif Is_Body_Or_Package_Declaration
(Par
) then
13722 Par
:= Parent
(Par
);
13727 and then Assertion_Expression_Pragma
(Get_Pragma_Id
(Prag
));
13728 end In_Assertion_Expression_Pragma
;
13730 -------------------
13731 -- In_Check_Node --
13732 -------------------
13734 function In_Check_Node
(N
: Node_Id
) return Boolean is
13735 Par
: Node_Id
:= Parent
(N
);
13737 while Present
(Par
) loop
13738 if Nkind
(Par
) in N_Raise_xxx_Error
then
13741 -- Prevent the search from going too far
13743 elsif Is_Body_Or_Package_Declaration
(Par
) then
13747 Par
:= Parent
(Par
);
13754 -------------------------------
13755 -- In_Generic_Formal_Package --
13756 -------------------------------
13758 function In_Generic_Formal_Package
(E
: Entity_Id
) return Boolean is
13763 while Present
(Par
) loop
13764 if Nkind
(Par
) = N_Formal_Package_Declaration
13765 or else Nkind
(Original_Node
(Par
)) = N_Formal_Package_Declaration
13770 Par
:= Parent
(Par
);
13774 end In_Generic_Formal_Package
;
13776 ----------------------
13777 -- In_Generic_Scope --
13778 ----------------------
13780 function In_Generic_Scope
(E
: Entity_Id
) return Boolean is
13785 while Present
(S
) and then S
/= Standard_Standard
loop
13786 if Is_Generic_Unit
(S
) then
13794 end In_Generic_Scope
;
13800 function In_Instance
return Boolean is
13801 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
13805 S
:= Current_Scope
;
13806 while Present
(S
) and then S
/= Standard_Standard
loop
13807 if Is_Generic_Instance
(S
) then
13809 -- A child instance is always compiled in the context of a parent
13810 -- instance. Nevertheless, its actuals must not be analyzed in an
13811 -- instance context. We detect this case by examining the current
13812 -- compilation unit, which must be a child instance, and checking
13813 -- that it has not been analyzed yet.
13815 if Is_Child_Unit
(Curr_Unit
)
13816 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
13817 N_Package_Instantiation
13818 and then Ekind
(Curr_Unit
) = E_Void
13832 ----------------------
13833 -- In_Instance_Body --
13834 ----------------------
13836 function In_Instance_Body
return Boolean is
13840 S
:= Current_Scope
;
13841 while Present
(S
) and then S
/= Standard_Standard
loop
13842 if Ekind
(S
) in E_Function | E_Procedure
13843 and then Is_Generic_Instance
(S
)
13847 elsif Ekind
(S
) = E_Package
13848 and then In_Package_Body
(S
)
13849 and then Is_Generic_Instance
(S
)
13858 end In_Instance_Body
;
13860 -----------------------------
13861 -- In_Instance_Not_Visible --
13862 -----------------------------
13864 function In_Instance_Not_Visible
return Boolean is
13868 S
:= Current_Scope
;
13869 while Present
(S
) and then S
/= Standard_Standard
loop
13870 if Ekind
(S
) in E_Function | E_Procedure
13871 and then Is_Generic_Instance
(S
)
13875 elsif Ekind
(S
) = E_Package
13876 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
13877 and then Is_Generic_Instance
(S
)
13886 end In_Instance_Not_Visible
;
13888 ------------------------------
13889 -- In_Instance_Visible_Part --
13890 ------------------------------
13892 function In_Instance_Visible_Part
13893 (Id
: Entity_Id
:= Current_Scope
) return Boolean
13899 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
13900 if Ekind
(Inst
) = E_Package
13901 and then Is_Generic_Instance
(Inst
)
13902 and then not In_Package_Body
(Inst
)
13903 and then not In_Private_Part
(Inst
)
13908 Inst
:= Scope
(Inst
);
13912 end In_Instance_Visible_Part
;
13914 ---------------------
13915 -- In_Package_Body --
13916 ---------------------
13918 function In_Package_Body
return Boolean is
13922 S
:= Current_Scope
;
13923 while Present
(S
) and then S
/= Standard_Standard
loop
13924 if Ekind
(S
) = E_Package
and then In_Package_Body
(S
) then
13932 end In_Package_Body
;
13934 --------------------------
13935 -- In_Pragma_Expression --
13936 --------------------------
13938 function In_Pragma_Expression
(N
: Node_Id
; Nam
: Name_Id
) return Boolean is
13946 -- Prevent the search from going too far
13948 elsif Is_Body_Or_Package_Declaration
(P
) then
13951 elsif Nkind
(P
) = N_Pragma
and then Pragma_Name
(P
) = Nam
then
13958 end In_Pragma_Expression
;
13960 ---------------------------
13961 -- In_Pre_Post_Condition --
13962 ---------------------------
13964 function In_Pre_Post_Condition
13965 (N
: Node_Id
; Class_Wide_Only
: Boolean := False) return Boolean
13968 Prag
: Node_Id
:= Empty
;
13969 Prag_Id
: Pragma_Id
;
13972 -- Climb the parent chain looking for an enclosing pragma
13975 while Present
(Par
) loop
13976 if Nkind
(Par
) = N_Pragma
then
13980 -- Prevent the search from going too far
13982 elsif Is_Body_Or_Package_Declaration
(Par
) then
13986 Par
:= Parent
(Par
);
13989 if Present
(Prag
) then
13990 Prag_Id
:= Get_Pragma_Id
(Prag
);
13992 if Class_Wide_Only
then
13994 Prag_Id
= Pragma_Post_Class
13995 or else Prag_Id
= Pragma_Pre_Class
13996 or else (Class_Present
(Prag
)
13997 and then (Prag_Id
= Pragma_Post
13998 or else Prag_Id
= Pragma_Postcondition
13999 or else Prag_Id
= Pragma_Pre
14000 or else Prag_Id
= Pragma_Precondition
));
14003 Prag_Id
= Pragma_Post
14004 or else Prag_Id
= Pragma_Post_Class
14005 or else Prag_Id
= Pragma_Postcondition
14006 or else Prag_Id
= Pragma_Pre
14007 or else Prag_Id
= Pragma_Pre_Class
14008 or else Prag_Id
= Pragma_Precondition
;
14011 -- Otherwise the node is not enclosed by a pre/postcondition pragma
14016 end In_Pre_Post_Condition
;
14018 ------------------------------
14019 -- In_Quantified_Expression --
14020 ------------------------------
14022 function In_Quantified_Expression
(N
: Node_Id
) return Boolean is
14030 -- Prevent the search from going too far
14032 elsif Is_Body_Or_Package_Declaration
(P
) then
14035 elsif Nkind
(P
) = N_Quantified_Expression
then
14041 end In_Quantified_Expression
;
14043 -------------------------------------
14044 -- In_Reverse_Storage_Order_Object --
14045 -------------------------------------
14047 function In_Reverse_Storage_Order_Object
(N
: Node_Id
) return Boolean is
14049 Btyp
: Entity_Id
:= Empty
;
14052 -- Climb up indexed components
14056 case Nkind
(Pref
) is
14057 when N_Selected_Component
=>
14058 Pref
:= Prefix
(Pref
);
14061 when N_Indexed_Component
=>
14062 Pref
:= Prefix
(Pref
);
14070 if Present
(Pref
) then
14071 Btyp
:= Base_Type
(Etype
(Pref
));
14074 return Present
(Btyp
)
14075 and then (Is_Record_Type
(Btyp
) or else Is_Array_Type
(Btyp
))
14076 and then Reverse_Storage_Order
(Btyp
);
14077 end In_Reverse_Storage_Order_Object
;
14079 ------------------------------
14080 -- In_Same_Declarative_Part --
14081 ------------------------------
14083 function In_Same_Declarative_Part
14084 (Context
: Node_Id
;
14085 N
: Node_Id
) return Boolean
14087 Cont
: Node_Id
:= Context
;
14091 if Nkind
(Cont
) = N_Compilation_Unit_Aux
then
14092 Cont
:= Parent
(Cont
);
14096 while Present
(Nod
) loop
14100 elsif Nkind
(Nod
) in N_Accept_Statement
14101 | N_Block_Statement
14102 | N_Compilation_Unit
14105 | N_Package_Declaration
14107 | N_Subprogram_Body
14112 elsif Nkind
(Nod
) = N_Subunit
then
14113 Nod
:= Corresponding_Stub
(Nod
);
14116 Nod
:= Parent
(Nod
);
14121 end In_Same_Declarative_Part
;
14123 --------------------------------------
14124 -- In_Subprogram_Or_Concurrent_Unit --
14125 --------------------------------------
14127 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
14132 -- Use scope chain to check successively outer scopes
14134 E
:= Current_Scope
;
14138 if K
in Subprogram_Kind
14139 or else K
in Concurrent_Kind
14140 or else K
in Generic_Subprogram_Kind
14144 elsif E
= Standard_Standard
then
14150 end In_Subprogram_Or_Concurrent_Unit
;
14156 function In_Subtree
(N
: Node_Id
; Root
: Node_Id
) return Boolean is
14161 while Present
(Curr
) loop
14162 if Curr
= Root
then
14166 Curr
:= Parent
(Curr
);
14176 function In_Subtree
14179 Root2
: Node_Id
) return Boolean
14185 while Present
(Curr
) loop
14186 if Curr
= Root1
or else Curr
= Root2
then
14190 Curr
:= Parent
(Curr
);
14196 ---------------------
14197 -- In_Return_Value --
14198 ---------------------
14200 function In_Return_Value
(Expr
: Node_Id
) return Boolean is
14202 Prev_Par
: Node_Id
;
14204 In_Function_Call
: Boolean := False;
14207 -- Move through parent nodes to determine if Expr contributes to the
14208 -- return value of the current subprogram.
14212 while Present
(Par
) loop
14214 case Nkind
(Par
) is
14215 -- Ignore ranges and they don't contribute to the result
14220 -- An object declaration whose parent is an extended return
14221 -- statement is a return object.
14223 when N_Object_Declaration
=>
14224 if Present
(Parent
(Par
))
14225 and then Nkind
(Parent
(Par
)) = N_Extended_Return_Statement
14230 -- We hit a simple return statement, so we know we are in one
14232 when N_Simple_Return_Statement
=>
14235 -- Only include one nexting level of function calls
14237 when N_Function_Call
=>
14238 if not In_Function_Call
then
14239 In_Function_Call
:= True;
14241 -- When the function return type has implicit dereference
14242 -- specified we know it cannot directly contribute to the
14245 if Present
(Etype
(Par
))
14246 and then Has_Implicit_Dereference
14247 (Get_Full_View
(Etype
(Par
)))
14255 -- Check if we are on the right-hand side of an assignment
14256 -- statement to a return object.
14258 -- This is not specified in the RM ???
14260 when N_Assignment_Statement
=>
14261 if Prev_Par
= Name
(Par
) then
14266 while Present
(Pre
) loop
14267 if Is_Entity_Name
(Pre
)
14268 and then Is_Return_Object
(Entity
(Pre
))
14273 exit when Nkind
(Pre
) not in N_Selected_Component
14274 | N_Indexed_Component
14277 Pre
:= Prefix
(Pre
);
14280 -- Otherwise, we hit a master which was not relevant
14283 if Is_Master
(Par
) then
14288 -- Iterate up to the next parent, keeping track of the previous one
14291 Par
:= Parent
(Par
);
14295 end In_Return_Value
;
14297 -----------------------------------------
14298 -- In_Statement_Condition_With_Actions --
14299 -----------------------------------------
14301 function In_Statement_Condition_With_Actions
(N
: Node_Id
) return Boolean is
14302 Prev
: Node_Id
:= N
;
14303 P
: Node_Id
:= Parent
(N
);
14304 -- P and Prev will be used for traversing the AST, while maintaining an
14305 -- invariant that P = Parent (Prev).
14307 while Present
(P
) loop
14308 if Nkind
(P
) = N_Iteration_Scheme
14309 and then Prev
= Condition
(P
)
14313 elsif Nkind
(P
) = N_Elsif_Part
14314 and then Prev
= Condition
(P
)
14318 -- No point in going beyond statements
14320 elsif Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
14321 | N_Procedure_Call_Statement
14325 -- Prevent the search from going too far
14327 elsif Is_Body_Or_Package_Declaration
(P
) then
14336 end In_Statement_Condition_With_Actions
;
14338 ---------------------
14339 -- In_Visible_Part --
14340 ---------------------
14342 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
14344 return Is_Package_Or_Generic_Package
(Scope_Id
)
14345 and then In_Open_Scopes
(Scope_Id
)
14346 and then not In_Package_Body
(Scope_Id
)
14347 and then not In_Private_Part
(Scope_Id
);
14348 end In_Visible_Part
;
14350 --------------------------------
14351 -- Incomplete_Or_Partial_View --
14352 --------------------------------
14354 function Incomplete_Or_Partial_View
(Id
: Entity_Id
) return Entity_Id
is
14355 S
: constant Entity_Id
:= Scope
(Id
);
14357 function Inspect_Decls
14359 Taft
: Boolean := False) return Entity_Id
;
14360 -- Check whether a declarative region contains the incomplete or partial
14363 -------------------
14364 -- Inspect_Decls --
14365 -------------------
14367 function Inspect_Decls
14369 Taft
: Boolean := False) return Entity_Id
14375 Decl
:= First
(Decls
);
14376 while Present
(Decl
) loop
14379 -- The partial view of a Taft-amendment type is an incomplete
14383 if Nkind
(Decl
) = N_Incomplete_Type_Declaration
then
14384 Match
:= Defining_Identifier
(Decl
);
14387 -- Otherwise look for a private type whose full view matches the
14388 -- input type. Note that this checks full_type_declaration nodes
14389 -- to account for derivations from a private type where the type
14390 -- declaration hold the partial view and the full view is an
14393 elsif Nkind
(Decl
) in N_Full_Type_Declaration
14394 | N_Private_Extension_Declaration
14395 | N_Private_Type_Declaration
14397 Match
:= Defining_Identifier
(Decl
);
14400 -- Guard against unanalyzed entities
14403 and then Is_Type
(Match
)
14404 and then Present
(Full_View
(Match
))
14405 and then Full_View
(Match
) = Id
14420 -- Start of processing for Incomplete_Or_Partial_View
14423 -- Deferred constant or incomplete type case
14425 Prev
:= Current_Entity
(Id
);
14427 while Present
(Prev
) loop
14428 exit when Scope
(Prev
) = S
;
14430 Prev
:= Homonym
(Prev
);
14434 and then (Is_Incomplete_Type
(Prev
) or else Ekind
(Prev
) = E_Constant
)
14435 and then Present
(Full_View
(Prev
))
14436 and then Full_View
(Prev
) = Id
14441 -- Private or Taft amendment type case
14443 if Present
(S
) and then Is_Package_Or_Generic_Package
(S
) then
14445 Pkg_Decl
: constant Node_Id
:= Package_Specification
(S
);
14448 -- It is knows that Typ has a private view, look for it in the
14449 -- visible declarations of the enclosing scope. A special case
14450 -- of this is when the two views have been exchanged - the full
14451 -- appears earlier than the private.
14453 if Has_Private_Declaration
(Id
) then
14454 Prev
:= Inspect_Decls
(Visible_Declarations
(Pkg_Decl
));
14456 -- Exchanged view case, look in the private declarations
14459 Prev
:= Inspect_Decls
(Private_Declarations
(Pkg_Decl
));
14464 -- Otherwise if this is the package body, then Typ is a potential
14465 -- Taft amendment type. The incomplete view should be located in
14466 -- the private declarations of the enclosing scope.
14468 elsif In_Package_Body
(S
) then
14469 return Inspect_Decls
(Private_Declarations
(Pkg_Decl
), True);
14474 -- The type has no incomplete or private view
14477 end Incomplete_Or_Partial_View
;
14479 ---------------------------------------
14480 -- Incomplete_View_From_Limited_With --
14481 ---------------------------------------
14483 function Incomplete_View_From_Limited_With
14484 (Typ
: Entity_Id
) return Entity_Id
14487 -- It might make sense to make this an attribute in Einfo, and set it
14488 -- in Sem_Ch10 in Build_Shadow_Entity. However, we're running short on
14489 -- slots for new attributes, and it seems a bit simpler to just search
14490 -- the Limited_View (if it exists) for an incomplete type whose
14491 -- Non_Limited_View is Typ.
14493 if Ekind
(Scope
(Typ
)) = E_Package
14494 and then Present
(Limited_View
(Scope
(Typ
)))
14497 Ent
: Entity_Id
:= First_Entity
(Limited_View
(Scope
(Typ
)));
14499 while Present
(Ent
) loop
14500 if Is_Incomplete_Type
(Ent
)
14501 and then Non_Limited_View
(Ent
) = Typ
14512 end Incomplete_View_From_Limited_With
;
14514 ----------------------------------
14515 -- Indexed_Component_Bit_Offset --
14516 ----------------------------------
14518 function Indexed_Component_Bit_Offset
(N
: Node_Id
) return Uint
is
14519 Exp
: constant Node_Id
:= First
(Expressions
(N
));
14520 Typ
: constant Entity_Id
:= Etype
(Prefix
(N
));
14521 Off
: constant Uint
:= Component_Size
(Typ
);
14525 -- Return early if the component size is not known or variable
14527 if No
(Off
) or else Off
< Uint_0
then
14531 -- Deal with the degenerate case of an empty component
14533 if Off
= Uint_0
then
14537 -- Check that both the index value and the low bound are known
14539 if not Compile_Time_Known_Value
(Exp
) then
14543 Ind
:= First_Index
(Typ
);
14548 -- Do not attempt to compute offsets within multi-dimensional arrays
14550 if Present
(Next_Index
(Ind
)) then
14554 if Nkind
(Ind
) = N_Subtype_Indication
then
14555 Ind
:= Constraint
(Ind
);
14557 if Nkind
(Ind
) = N_Range_Constraint
then
14558 Ind
:= Range_Expression
(Ind
);
14562 if Nkind
(Ind
) /= N_Range
14563 or else not Compile_Time_Known_Value
(Low_Bound
(Ind
))
14568 -- Return the scaled offset
14570 return Off
* (Expr_Value
(Exp
) - Expr_Value
(Low_Bound
(Ind
)));
14571 end Indexed_Component_Bit_Offset
;
14573 -----------------------------
14574 -- Inherit_Predicate_Flags --
14575 -----------------------------
14577 procedure Inherit_Predicate_Flags
(Subt
, Par
: Entity_Id
) is
14579 if Ada_Version
< Ada_2012
14580 or else Present
(Predicate_Function
(Subt
))
14585 Set_Has_Predicates
(Subt
, Has_Predicates
(Par
));
14586 Set_Has_Static_Predicate_Aspect
14587 (Subt
, Has_Static_Predicate_Aspect
(Par
));
14588 Set_Has_Dynamic_Predicate_Aspect
14589 (Subt
, Has_Dynamic_Predicate_Aspect
(Par
));
14591 -- A named subtype does not inherit the predicate function of its
14592 -- parent but an itype declared for a loop index needs the discrete
14593 -- predicate information of its parent to execute the loop properly.
14594 -- A non-discrete type may has a static predicate (for example True)
14595 -- but has no static_discrete_predicate.
14597 if Is_Itype
(Subt
) and then Present
(Predicate_Function
(Par
)) then
14598 Set_Subprograms_For_Type
(Subt
, Subprograms_For_Type
(Par
));
14600 if Has_Static_Predicate
(Par
) and then Is_Discrete_Type
(Par
) then
14601 Set_Static_Discrete_Predicate
14602 (Subt
, Static_Discrete_Predicate
(Par
));
14605 end Inherit_Predicate_Flags
;
14607 ----------------------------
14608 -- Inherit_Rep_Item_Chain --
14609 ----------------------------
14611 procedure Inherit_Rep_Item_Chain
(Typ
: Entity_Id
; From_Typ
: Entity_Id
) is
14613 Next_Item
: Node_Id
;
14616 -- There are several inheritance scenarios to consider depending on
14617 -- whether both types have rep item chains and whether the destination
14618 -- type already inherits part of the source type's rep item chain.
14620 -- 1) The source type lacks a rep item chain
14621 -- From_Typ ---> Empty
14623 -- Typ --------> Item (or Empty)
14625 -- In this case inheritance cannot take place because there are no items
14628 -- 2) The destination type lacks a rep item chain
14629 -- From_Typ ---> Item ---> ...
14631 -- Typ --------> Empty
14633 -- Inheritance takes place by setting the First_Rep_Item of the
14634 -- destination type to the First_Rep_Item of the source type.
14635 -- From_Typ ---> Item ---> ...
14637 -- Typ -----------+
14639 -- 3.1) Both source and destination types have at least one rep item.
14640 -- The destination type does NOT inherit a rep item from the source
14642 -- From_Typ ---> Item ---> Item
14644 -- Typ --------> Item ---> Item
14646 -- Inheritance takes place by setting the Next_Rep_Item of the last item
14647 -- of the destination type to the First_Rep_Item of the source type.
14648 -- From_Typ -------------------> Item ---> Item
14650 -- Typ --------> Item ---> Item --+
14652 -- 3.2) Both source and destination types have at least one rep item.
14653 -- The destination type DOES inherit part of the rep item chain of the
14655 -- From_Typ ---> Item ---> Item ---> Item
14657 -- Typ --------> Item ------+
14659 -- This rare case arises when the full view of a private extension must
14660 -- inherit the rep item chain from the full view of its parent type and
14661 -- the full view of the parent type contains extra rep items. Currently
14662 -- only invariants may lead to such form of inheritance.
14664 -- type From_Typ is tagged private
14665 -- with Type_Invariant'Class => Item_2;
14667 -- type Typ is new From_Typ with private
14668 -- with Type_Invariant => Item_4;
14670 -- At this point the rep item chains contain the following items
14672 -- From_Typ -----------> Item_2 ---> Item_3
14674 -- Typ --------> Item_4 --+
14676 -- The full views of both types may introduce extra invariants
14678 -- type From_Typ is tagged null record
14679 -- with Type_Invariant => Item_1;
14681 -- type Typ is new From_Typ with null record;
14683 -- The full view of Typ would have to inherit any new rep items added to
14684 -- the full view of From_Typ.
14686 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
14688 -- Typ --------> Item_4 --+
14690 -- To achieve this form of inheritance, the destination type must first
14691 -- sever the link between its own rep chain and that of the source type,
14692 -- then inheritance 3.1 takes place.
14694 -- Case 1: The source type lacks a rep item chain
14696 if No
(First_Rep_Item
(From_Typ
)) then
14699 -- Case 2: The destination type lacks a rep item chain
14701 elsif No
(First_Rep_Item
(Typ
)) then
14702 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
14704 -- Case 3: Both the source and destination types have at least one rep
14705 -- item. Traverse the rep item chain of the destination type to find the
14710 Next_Item
:= First_Rep_Item
(Typ
);
14711 while Present
(Next_Item
) loop
14713 -- Detect a link between the destination type's rep chain and that
14714 -- of the source type. There are two possibilities:
14719 -- From_Typ ---> Item_1 --->
14721 -- Typ -----------+
14728 -- From_Typ ---> Item_1 ---> Item_2 --->
14730 -- Typ --------> Item_3 ------+
14734 if Present_In_Rep_Item
(From_Typ
, Next_Item
) then
14739 Next_Item
:= Next_Rep_Item
(Next_Item
);
14742 -- Inherit the source type's rep item chain
14744 if Present
(Item
) then
14745 Set_Next_Rep_Item
(Item
, First_Rep_Item
(From_Typ
));
14747 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
14750 end Inherit_Rep_Item_Chain
;
14752 ------------------------------------
14753 -- Inherits_From_Tagged_Full_View --
14754 ------------------------------------
14756 function Inherits_From_Tagged_Full_View
(Typ
: Entity_Id
) return Boolean is
14758 return Is_Private_Type
(Typ
)
14759 and then Present
(Full_View
(Typ
))
14760 and then Is_Private_Type
(Full_View
(Typ
))
14761 and then not Is_Tagged_Type
(Full_View
(Typ
))
14762 and then Present
(Underlying_Type
(Full_View
(Typ
)))
14763 and then Is_Tagged_Type
(Underlying_Type
(Full_View
(Typ
)));
14764 end Inherits_From_Tagged_Full_View
;
14766 ---------------------------------
14767 -- Insert_Explicit_Dereference --
14768 ---------------------------------
14770 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
14771 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
14772 Ent
: Entity_Id
:= Empty
;
14773 Pref
: Node_Id
:= Empty
;
14779 Save_Interps
(N
, New_Prefix
);
14782 Make_Explicit_Dereference
(Sloc
(Parent
(N
)),
14783 Prefix
=> New_Prefix
));
14785 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
14787 if Is_Overloaded
(New_Prefix
) then
14789 -- The dereference is also overloaded, and its interpretations are
14790 -- the designated types of the interpretations of the original node.
14792 Set_Etype
(N
, Any_Type
);
14794 Get_First_Interp
(New_Prefix
, I
, It
);
14795 while Present
(It
.Nam
) loop
14798 if Is_Access_Type
(T
) then
14799 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
14802 Get_Next_Interp
(I
, It
);
14806 -- Prefix is unambiguous: mark the original prefix (which might
14807 -- Come_From_Source) as a reference, since the new (relocated) one
14808 -- won't be taken into account.
14810 if Is_Entity_Name
(New_Prefix
) then
14811 Ent
:= Entity
(New_Prefix
);
14812 Pref
:= New_Prefix
;
14814 -- For a retrieval of a subcomponent of some composite object,
14815 -- retrieve the ultimate entity if there is one.
14817 elsif Nkind
(New_Prefix
) in N_Selected_Component | N_Indexed_Component
14819 Pref
:= Prefix
(New_Prefix
);
14820 while Present
(Pref
)
14821 and then Nkind
(Pref
) in
14822 N_Selected_Component | N_Indexed_Component
14824 Pref
:= Prefix
(Pref
);
14827 if Present
(Pref
) and then Is_Entity_Name
(Pref
) then
14828 Ent
:= Entity
(Pref
);
14832 -- Place the reference on the entity node
14834 if Present
(Ent
) then
14835 Generate_Reference
(Ent
, Pref
);
14838 end Insert_Explicit_Dereference
;
14840 ------------------------------------------
14841 -- Inspect_Deferred_Constant_Completion --
14842 ------------------------------------------
14844 procedure Inspect_Deferred_Constant_Completion
(Decls
: List_Id
) is
14848 Decl
:= First
(Decls
);
14849 while Present
(Decl
) loop
14851 -- Deferred constant signature
14853 if Nkind
(Decl
) = N_Object_Declaration
14854 and then Constant_Present
(Decl
)
14855 and then No
(Expression
(Decl
))
14857 -- No need to check internally generated constants
14859 and then Comes_From_Source
(Decl
)
14861 -- The constant is not completed. A full object declaration or a
14862 -- pragma Import complete a deferred constant.
14864 and then not Has_Completion
(Defining_Identifier
(Decl
))
14867 ("constant declaration requires initialization expression",
14868 Defining_Identifier
(Decl
));
14873 end Inspect_Deferred_Constant_Completion
;
14875 -------------------------------
14876 -- Install_Elaboration_Model --
14877 -------------------------------
14879 procedure Install_Elaboration_Model
(Unit_Id
: Entity_Id
) is
14880 function Find_Elaboration_Checks_Pragma
(L
: List_Id
) return Node_Id
;
14881 -- Try to find pragma Elaboration_Checks in arbitrary list L. Return
14882 -- Empty if there is no such pragma.
14884 ------------------------------------
14885 -- Find_Elaboration_Checks_Pragma --
14886 ------------------------------------
14888 function Find_Elaboration_Checks_Pragma
(L
: List_Id
) return Node_Id
is
14893 while Present
(Item
) loop
14894 if Nkind
(Item
) = N_Pragma
14895 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
14904 end Find_Elaboration_Checks_Pragma
;
14913 -- Start of processing for Install_Elaboration_Model
14916 -- Nothing to do when the unit does not exist
14918 if No
(Unit_Id
) then
14922 Unit
:= Parent
(Unit_Declaration_Node
(Unit_Id
));
14924 -- Nothing to do when the unit is not a library unit
14926 if Nkind
(Unit
) /= N_Compilation_Unit
then
14930 Prag
:= Find_Elaboration_Checks_Pragma
(Context_Items
(Unit
));
14932 -- The compilation unit is subject to pragma Elaboration_Checks. Set the
14933 -- elaboration model as specified by the pragma.
14935 if Present
(Prag
) then
14936 Args
:= Pragma_Argument_Associations
(Prag
);
14938 -- Guard against an illegal pragma. The sole argument must be an
14939 -- identifier which specifies either Dynamic or Static model.
14941 if Present
(Args
) then
14942 Model
:= Get_Pragma_Arg
(First
(Args
));
14944 if Nkind
(Model
) = N_Identifier
then
14945 Dynamic_Elaboration_Checks
:= Chars
(Model
) = Name_Dynamic
;
14949 end Install_Elaboration_Model
;
14951 -----------------------------
14952 -- Install_Generic_Formals --
14953 -----------------------------
14955 procedure Install_Generic_Formals
(Subp_Id
: Entity_Id
) is
14959 pragma Assert
(Is_Generic_Subprogram
(Subp_Id
));
14961 E
:= First_Entity
(Subp_Id
);
14962 while Present
(E
) loop
14963 Install_Entity
(E
);
14966 end Install_Generic_Formals
;
14968 ------------------------
14969 -- Install_SPARK_Mode --
14970 ------------------------
14972 procedure Install_SPARK_Mode
(Mode
: SPARK_Mode_Type
; Prag
: Node_Id
) is
14974 SPARK_Mode
:= Mode
;
14975 SPARK_Mode_Pragma
:= Prag
;
14976 end Install_SPARK_Mode
;
14978 --------------------------
14979 -- Invalid_Scalar_Value --
14980 --------------------------
14982 function Invalid_Scalar_Value
14984 Scal_Typ
: Scalar_Id
) return Node_Id
14986 function Invalid_Binder_Value
return Node_Id
;
14987 -- Return a reference to the corresponding invalid value for type
14988 -- Scal_Typ as defined in unit System.Scalar_Values.
14990 function Invalid_Float_Value
return Node_Id
;
14991 -- Return the invalid value of float type Scal_Typ
14993 function Invalid_Integer_Value
return Node_Id
;
14994 -- Return the invalid value of integer type Scal_Typ
14996 procedure Set_Invalid_Binder_Values
;
14997 -- Set the contents of collection Invalid_Binder_Values
14999 --------------------------
15000 -- Invalid_Binder_Value --
15001 --------------------------
15003 function Invalid_Binder_Value
return Node_Id
is
15004 Val_Id
: Entity_Id
;
15007 -- Initialize the collection of invalid binder values the first time
15010 Set_Invalid_Binder_Values
;
15012 -- Obtain the corresponding variable from System.Scalar_Values which
15013 -- holds the invalid value for this type.
15015 Val_Id
:= Invalid_Binder_Values
(Scal_Typ
);
15016 pragma Assert
(Present
(Val_Id
));
15018 return New_Occurrence_Of
(Val_Id
, Loc
);
15019 end Invalid_Binder_Value
;
15021 -------------------------
15022 -- Invalid_Float_Value --
15023 -------------------------
15025 function Invalid_Float_Value
return Node_Id
is
15026 Value
: constant Ureal
:= Invalid_Floats
(Scal_Typ
);
15029 -- Pragma Invalid_Scalars did not specify an invalid value for this
15030 -- type. Fall back to the value provided by the binder.
15032 if Value
= No_Ureal
then
15033 return Invalid_Binder_Value
;
15035 return Make_Real_Literal
(Loc
, Realval
=> Value
);
15037 end Invalid_Float_Value
;
15039 ---------------------------
15040 -- Invalid_Integer_Value --
15041 ---------------------------
15043 function Invalid_Integer_Value
return Node_Id
is
15044 Value
: constant Uint
:= Invalid_Integers
(Scal_Typ
);
15047 -- Pragma Invalid_Scalars did not specify an invalid value for this
15048 -- type. Fall back to the value provided by the binder.
15051 return Invalid_Binder_Value
;
15053 return Make_Integer_Literal
(Loc
, Intval
=> Value
);
15055 end Invalid_Integer_Value
;
15057 -------------------------------
15058 -- Set_Invalid_Binder_Values --
15059 -------------------------------
15061 procedure Set_Invalid_Binder_Values
is
15063 if not Invalid_Binder_Values_Set
then
15064 Invalid_Binder_Values_Set
:= True;
15066 -- Initialize the contents of the collection once since RTE calls
15069 Invalid_Binder_Values
:=
15070 (Name_Short_Float
=> RTE
(RE_IS_Isf
),
15071 Name_Float
=> RTE
(RE_IS_Ifl
),
15072 Name_Long_Float
=> RTE
(RE_IS_Ilf
),
15073 Name_Long_Long_Float
=> RTE
(RE_IS_Ill
),
15074 Name_Signed_8
=> RTE
(RE_IS_Is1
),
15075 Name_Signed_16
=> RTE
(RE_IS_Is2
),
15076 Name_Signed_32
=> RTE
(RE_IS_Is4
),
15077 Name_Signed_64
=> RTE
(RE_IS_Is8
),
15078 Name_Signed_128
=> Empty
,
15079 Name_Unsigned_8
=> RTE
(RE_IS_Iu1
),
15080 Name_Unsigned_16
=> RTE
(RE_IS_Iu2
),
15081 Name_Unsigned_32
=> RTE
(RE_IS_Iu4
),
15082 Name_Unsigned_64
=> RTE
(RE_IS_Iu8
),
15083 Name_Unsigned_128
=> Empty
);
15085 if System_Max_Integer_Size
< 128 then
15086 Invalid_Binder_Values
(Name_Signed_128
) := RTE
(RE_IS_Is8
);
15087 Invalid_Binder_Values
(Name_Unsigned_128
) := RTE
(RE_IS_Iu8
);
15089 Invalid_Binder_Values
(Name_Signed_128
) := RTE
(RE_IS_Is16
);
15090 Invalid_Binder_Values
(Name_Unsigned_128
) := RTE
(RE_IS_Iu16
);
15093 end Set_Invalid_Binder_Values
;
15095 -- Start of processing for Invalid_Scalar_Value
15098 if Scal_Typ
in Float_Scalar_Id
then
15099 return Invalid_Float_Value
;
15101 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
15102 return Invalid_Integer_Value
;
15104 end Invalid_Scalar_Value
;
15106 ------------------------
15107 -- Is_Access_Variable --
15108 ------------------------
15110 function Is_Access_Variable
(E
: Entity_Id
) return Boolean is
15112 return Is_Access_Type
(E
)
15113 and then not Is_Access_Constant
(E
)
15114 and then Ekind
(Directly_Designated_Type
(E
)) /= E_Subprogram_Type
;
15115 end Is_Access_Variable
;
15117 -----------------------------
15118 -- Is_Actual_Out_Parameter --
15119 -----------------------------
15121 function Is_Actual_Out_Parameter
(N
: Node_Id
) return Boolean is
15122 Formal
: Entity_Id
;
15125 Find_Actual
(N
, Formal
, Call
);
15126 return Present
(Formal
) and then Ekind
(Formal
) = E_Out_Parameter
;
15127 end Is_Actual_Out_Parameter
;
15129 --------------------------------
15130 -- Is_Actual_In_Out_Parameter --
15131 --------------------------------
15133 function Is_Actual_In_Out_Parameter
(N
: Node_Id
) return Boolean is
15134 Formal
: Entity_Id
;
15137 Find_Actual
(N
, Formal
, Call
);
15138 return Present
(Formal
) and then Ekind
(Formal
) = E_In_Out_Parameter
;
15139 end Is_Actual_In_Out_Parameter
;
15141 ---------------------------------------
15142 -- Is_Actual_Out_Or_In_Out_Parameter --
15143 ---------------------------------------
15145 function Is_Actual_Out_Or_In_Out_Parameter
(N
: Node_Id
) return Boolean is
15146 Formal
: Entity_Id
;
15149 Find_Actual
(N
, Formal
, Call
);
15150 return Present
(Formal
)
15151 and then Ekind
(Formal
) in E_Out_Parameter | E_In_Out_Parameter
;
15152 end Is_Actual_Out_Or_In_Out_Parameter
;
15154 -------------------------
15155 -- Is_Actual_Parameter --
15156 -------------------------
15158 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
15159 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
15163 when N_Parameter_Association
=>
15164 return N
= Explicit_Actual_Parameter
(Parent
(N
));
15166 when N_Entry_Call_Statement
15167 | N_Subprogram_Call
15169 return Is_List_Member
(N
)
15171 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
15176 end Is_Actual_Parameter
;
15178 --------------------------------
15179 -- Is_Actual_Tagged_Parameter --
15180 --------------------------------
15182 function Is_Actual_Tagged_Parameter
(N
: Node_Id
) return Boolean is
15183 Formal
: Entity_Id
;
15186 Find_Actual
(N
, Formal
, Call
);
15187 return Present
(Formal
) and then Is_Tagged_Type
(Etype
(Formal
));
15188 end Is_Actual_Tagged_Parameter
;
15190 ---------------------
15191 -- Is_Aliased_View --
15192 ---------------------
15194 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
15198 if Is_Entity_Name
(Obj
) then
15205 or else (Present
(Renamed_Object
(E
))
15206 and then Is_Aliased_View
(Renamed_Object
(E
)))))
15208 or else ((Is_Formal
(E
) or else Is_Formal_Object
(E
))
15209 and then Is_Tagged_Type
(Etype
(E
)))
15211 or else (Is_Concurrent_Type
(E
) and then In_Open_Scopes
(E
))
15213 -- Current instance of type, either directly or as rewritten
15214 -- reference to the current object.
15216 or else (Is_Entity_Name
(Original_Node
(Obj
))
15217 and then Present
(Entity
(Original_Node
(Obj
)))
15218 and then Is_Type
(Entity
(Original_Node
(Obj
))))
15220 or else (Is_Type
(E
) and then E
= Current_Scope
)
15222 or else (Is_Incomplete_Or_Private_Type
(E
)
15223 and then Full_View
(E
) = Current_Scope
)
15225 -- Ada 2012 AI05-0053: the return object of an extended return
15226 -- statement is aliased if its type is immutably limited.
15228 or else (Is_Return_Object
(E
)
15229 and then Is_Limited_View
(Etype
(E
)))
15231 -- The current instance of a limited type is aliased, so
15232 -- we want to allow uses of T'Access in the init proc for
15233 -- a limited type T. However, we don't want to mark the formal
15234 -- parameter as being aliased since that could impact callers.
15236 or else (Is_Formal
(E
)
15237 and then Chars
(E
) = Name_uInit
15238 and then Is_Limited_View
(Etype
(E
)));
15240 elsif Nkind
(Obj
) = N_Selected_Component
then
15241 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
15243 elsif Nkind
(Obj
) = N_Indexed_Component
then
15244 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
15246 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
15247 and then Has_Aliased_Components
15248 (Designated_Type
(Etype
(Prefix
(Obj
)))));
15250 elsif Nkind
(Obj
) in N_Unchecked_Type_Conversion | N_Type_Conversion
then
15251 return Is_Tagged_Type
(Etype
(Obj
))
15252 and then Is_Aliased_View
(Expression
(Obj
));
15254 -- Ada 2022 AI12-0228
15256 elsif Nkind
(Obj
) = N_Qualified_Expression
15257 and then Ada_Version
>= Ada_2012
15259 return Is_Aliased_View
(Expression
(Obj
));
15261 -- The dereference of an access-to-object value denotes an aliased view,
15262 -- but this routine uses the rules of the language so we need to exclude
15263 -- rewritten constructs that introduce artificial dereferences.
15265 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
15266 return not Is_Captured_Function_Call
(Obj
)
15268 (Nkind
(Parent
(Obj
)) = N_Object_Renaming_Declaration
15269 and then Is_Return_Object
(Defining_Entity
(Parent
(Obj
))));
15274 end Is_Aliased_View
;
15276 -------------------------
15277 -- Is_Ancestor_Package --
15278 -------------------------
15280 function Is_Ancestor_Package
15282 E2
: Entity_Id
) return Boolean
15288 while Present
(Par
) and then Par
/= Standard_Standard
loop
15293 Par
:= Scope
(Par
);
15297 end Is_Ancestor_Package
;
15299 ----------------------
15300 -- Is_Atomic_Object --
15301 ----------------------
15303 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
15304 function Prefix_Has_Atomic_Components
(P
: Node_Id
) return Boolean;
15305 -- Determine whether prefix P has atomic components. This requires the
15306 -- presence of an Atomic_Components aspect/pragma.
15308 ---------------------------------
15309 -- Prefix_Has_Atomic_Components --
15310 ---------------------------------
15312 function Prefix_Has_Atomic_Components
(P
: Node_Id
) return Boolean is
15313 Typ
: constant Entity_Id
:= Etype
(P
);
15316 if Is_Access_Type
(Typ
) then
15317 return Has_Atomic_Components
(Designated_Type
(Typ
));
15319 elsif Has_Atomic_Components
(Typ
) then
15322 elsif Is_Entity_Name
(P
)
15323 and then Has_Atomic_Components
(Entity
(P
))
15330 end Prefix_Has_Atomic_Components
;
15332 -- Start of processing for Is_Atomic_Object
15335 if Is_Entity_Name
(N
) then
15336 return Is_Atomic_Object_Entity
(Entity
(N
));
15338 elsif Is_Atomic
(Etype
(N
)) then
15341 elsif Nkind
(N
) = N_Indexed_Component
then
15342 return Prefix_Has_Atomic_Components
(Prefix
(N
));
15344 elsif Nkind
(N
) = N_Selected_Component
then
15345 return Is_Atomic
(Entity
(Selector_Name
(N
)));
15350 end Is_Atomic_Object
;
15352 -----------------------------
15353 -- Is_Atomic_Object_Entity --
15354 -----------------------------
15356 function Is_Atomic_Object_Entity
(Id
: Entity_Id
) return Boolean is
15360 and then (Is_Atomic
(Id
) or else Is_Atomic
(Etype
(Id
)));
15361 end Is_Atomic_Object_Entity
;
15363 -----------------------------
15364 -- Is_Attribute_Loop_Entry --
15365 -----------------------------
15367 function Is_Attribute_Loop_Entry
(N
: Node_Id
) return Boolean is
15369 return Nkind
(N
) = N_Attribute_Reference
15370 and then Attribute_Name
(N
) = Name_Loop_Entry
;
15371 end Is_Attribute_Loop_Entry
;
15373 ----------------------
15374 -- Is_Attribute_Old --
15375 ----------------------
15377 function Is_Attribute_Old
(N
: Node_Id
) return Boolean is
15379 return Nkind
(N
) = N_Attribute_Reference
15380 and then Attribute_Name
(N
) = Name_Old
;
15381 end Is_Attribute_Old
;
15383 -------------------------
15384 -- Is_Attribute_Result --
15385 -------------------------
15387 function Is_Attribute_Result
(N
: Node_Id
) return Boolean is
15389 return Nkind
(N
) = N_Attribute_Reference
15390 and then Attribute_Name
(N
) = Name_Result
;
15391 end Is_Attribute_Result
;
15393 -------------------------
15394 -- Is_Attribute_Update --
15395 -------------------------
15397 function Is_Attribute_Update
(N
: Node_Id
) return Boolean is
15399 return Nkind
(N
) = N_Attribute_Reference
15400 and then Attribute_Name
(N
) = Name_Update
;
15401 end Is_Attribute_Update
;
15403 ------------------------------------
15404 -- Is_Body_Or_Package_Declaration --
15405 ------------------------------------
15407 function Is_Body_Or_Package_Declaration
(N
: Node_Id
) return Boolean is
15409 return Is_Body
(N
) or else Nkind
(N
) = N_Package_Declaration
;
15410 end Is_Body_Or_Package_Declaration
;
15412 -----------------------
15413 -- Is_Bounded_String --
15414 -----------------------
15416 function Is_Bounded_String
(T
: Entity_Id
) return Boolean is
15417 Under
: constant Entity_Id
:= Underlying_Type
(Root_Type
(T
));
15420 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
15421 -- Super_String, or one of the [Wide_]Wide_ versions. This will
15422 -- be True for all the Bounded_String types in instances of the
15423 -- Generic_Bounded_Length generics, and for types derived from those.
15425 return Present
(Under
)
15426 and then (Is_RTE
(Root_Type
(Under
), RO_SU_Super_String
) or else
15427 Is_RTE
(Root_Type
(Under
), RO_WI_Super_String
) or else
15428 Is_RTE
(Root_Type
(Under
), RO_WW_Super_String
));
15429 end Is_Bounded_String
;
15431 -------------------------------
15432 -- Is_By_Protected_Procedure --
15433 -------------------------------
15435 function Is_By_Protected_Procedure
(Id
: Entity_Id
) return Boolean is
15437 return Ekind
(Id
) = E_Procedure
15438 and then Present
(Get_Rep_Pragma
(Id
, Name_Implemented
))
15439 and then Implementation_Kind
(Id
) = Name_By_Protected_Procedure
;
15440 end Is_By_Protected_Procedure
;
15442 ---------------------
15443 -- Is_CCT_Instance --
15444 ---------------------
15446 function Is_CCT_Instance
15447 (Ref_Id
: Entity_Id
;
15448 Context_Id
: Entity_Id
) return Boolean
15451 pragma Assert
(Ekind
(Ref_Id
) in E_Protected_Type | E_Task_Type
);
15453 if Is_Single_Task_Object
(Context_Id
) then
15454 return Scope_Within_Or_Same
(Etype
(Context_Id
), Ref_Id
);
15458 (Ekind
(Context_Id
) in
15459 E_Entry | E_Entry_Family | E_Function | E_Package |
15460 E_Procedure | E_Protected_Type | E_Task_Type
15461 or else Is_Record_Type
(Context_Id
));
15462 return Scope_Within_Or_Same
(Context_Id
, Ref_Id
);
15464 end Is_CCT_Instance
;
15466 -------------------------
15467 -- Is_Child_Or_Sibling --
15468 -------------------------
15470 function Is_Child_Or_Sibling
15471 (Pack_1
: Entity_Id
;
15472 Pack_2
: Entity_Id
) return Boolean
15474 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
;
15475 -- Given an arbitrary package, return the number of "climbs" necessary
15476 -- to reach scope Standard_Standard.
15478 procedure Equalize_Depths
15479 (Pack
: in out Entity_Id
;
15480 Depth
: in out Nat
;
15481 Depth_To_Reach
: Nat
);
15482 -- Given an arbitrary package, its depth and a target depth to reach,
15483 -- climb the scope chain until the said depth is reached. The pointer
15484 -- to the package and its depth a modified during the climb.
15486 ----------------------------
15487 -- Distance_From_Standard --
15488 ----------------------------
15490 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
is
15497 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
15499 Scop
:= Scope
(Scop
);
15503 end Distance_From_Standard
;
15505 ---------------------
15506 -- Equalize_Depths --
15507 ---------------------
15509 procedure Equalize_Depths
15510 (Pack
: in out Entity_Id
;
15511 Depth
: in out Nat
;
15512 Depth_To_Reach
: Nat
)
15515 -- The package must be at a greater or equal depth
15517 if Depth
< Depth_To_Reach
then
15518 raise Program_Error
;
15521 -- Climb the scope chain until the desired depth is reached
15523 while Present
(Pack
) and then Depth
/= Depth_To_Reach
loop
15524 Pack
:= Scope
(Pack
);
15525 Depth
:= Depth
- 1;
15527 end Equalize_Depths
;
15531 P_1
: Entity_Id
:= Pack_1
;
15532 P_1_Child
: Boolean := False;
15533 P_1_Depth
: Nat
:= Distance_From_Standard
(P_1
);
15534 P_2
: Entity_Id
:= Pack_2
;
15535 P_2_Child
: Boolean := False;
15536 P_2_Depth
: Nat
:= Distance_From_Standard
(P_2
);
15538 -- Start of processing for Is_Child_Or_Sibling
15542 (Ekind
(Pack_1
) = E_Package
and then Ekind
(Pack_2
) = E_Package
);
15544 -- Both packages denote the same entity, therefore they cannot be
15545 -- children or siblings.
15550 -- One of the packages is at a deeper level than the other. Note that
15551 -- both may still come from different hierarchies.
15559 elsif P_1_Depth
> P_2_Depth
then
15562 Depth
=> P_1_Depth
,
15563 Depth_To_Reach
=> P_2_Depth
);
15572 elsif P_2_Depth
> P_1_Depth
then
15575 Depth
=> P_2_Depth
,
15576 Depth_To_Reach
=> P_1_Depth
);
15580 -- At this stage the package pointers have been elevated to the same
15581 -- depth. If the related entities are the same, then one package is a
15582 -- potential child of the other:
15586 -- X became P_1 P_2 or vice versa
15592 return Is_Child_Unit
(Pack_1
);
15594 else pragma Assert
(P_2_Child
);
15595 return Is_Child_Unit
(Pack_2
);
15598 -- The packages may come from the same package chain or from entirely
15599 -- different hierarchies. To determine this, climb the scope stack until
15600 -- a common root is found.
15602 -- (root) (root 1) (root 2)
15607 while Present
(P_1
) and then Present
(P_2
) loop
15609 -- The two packages may be siblings
15612 return Is_Child_Unit
(Pack_1
) and then Is_Child_Unit
(Pack_2
);
15615 P_1
:= Scope
(P_1
);
15616 P_2
:= Scope
(P_2
);
15621 end Is_Child_Or_Sibling
;
15623 -------------------
15624 -- Is_Confirming --
15625 -------------------
15627 function Is_Confirming
(Aspect
: Nonoverridable_Aspect_Id
;
15628 Aspect_Spec_1
, Aspect_Spec_2
: Node_Id
)
15630 function Names_Match
(Nm1
, Nm2
: Node_Id
) return Boolean;
15636 function Names_Match
(Nm1
, Nm2
: Node_Id
) return Boolean is
15638 if Nkind
(Nm1
) /= Nkind
(Nm2
) then
15640 -- This may be too restrictive given that visibility
15641 -- may allow an identifier in one case and an expanded
15642 -- name in the other.
15644 case Nkind
(Nm1
) is
15645 when N_Identifier
=>
15646 return Name_Equals
(Chars
(Nm1
), Chars
(Nm2
));
15648 when N_Expanded_Name
=>
15649 -- An inherited operation has the same name as its
15650 -- ancestor, but they may have different scopes.
15651 -- This may be too permissive for Iterator_Element, which
15652 -- is intended to be identical in parent and derived type.
15654 return Names_Match
(Selector_Name
(Nm1
),
15655 Selector_Name
(Nm2
));
15658 return True; -- needed for Aggregate aspect checking
15661 -- e.g., 'Class attribute references
15662 if Is_Entity_Name
(Nm1
) and Is_Entity_Name
(Nm2
) then
15663 return Entity
(Nm1
) = Entity
(Nm2
);
15666 raise Program_Error
;
15670 -- allow users to disable "shall be confirming" check, at least for now
15671 if Relaxed_RM_Semantics
then
15675 -- ??? Type conversion here (along with "when others =>" below) is a
15676 -- workaround for a bootstrapping problem related to casing on a
15677 -- static-predicate-bearing subtype.
15679 case Aspect_Id
(Aspect
) is
15680 -- name-valued aspects; compare text of names, not resolution.
15681 when Aspect_Default_Iterator
15682 | Aspect_Iterator_Element
15683 | Aspect_Constant_Indexing
15684 | Aspect_Variable_Indexing
=>
15686 Item_1
: constant Node_Id
:= Aspect_Rep_Item
(Aspect_Spec_1
);
15687 Item_2
: constant Node_Id
:= Aspect_Rep_Item
(Aspect_Spec_2
);
15689 if (Nkind
(Item_1
) /= N_Attribute_Definition_Clause
)
15690 or (Nkind
(Item_2
) /= N_Attribute_Definition_Clause
)
15692 pragma Assert
(Serious_Errors_Detected
> 0);
15696 return Names_Match
(Expression
(Item_1
),
15697 Expression
(Item_2
));
15700 -- A confirming aspect for Implicit_Derenfence on a derived type
15701 -- has already been checked in Analyze_Aspect_Implicit_Dereference,
15702 -- including the presence of renamed discriminants.
15704 when Aspect_Implicit_Dereference
=>
15708 when Aspect_Aggregate
=>
15719 Assign_Indexed_2
: Node_Id
:= Empty
;
15721 Parse_Aspect_Aggregate
15722 (N
=> Expression
(Aspect_Spec_1
),
15723 Empty_Subp
=> Empty_1
,
15724 Add_Named_Subp
=> Add_Named_1
,
15725 Add_Unnamed_Subp
=> Add_Unnamed_1
,
15726 New_Indexed_Subp
=> New_Indexed_1
,
15727 Assign_Indexed_Subp
=> Assign_Indexed_1
);
15728 Parse_Aspect_Aggregate
15729 (N
=> Expression
(Aspect_Spec_2
),
15730 Empty_Subp
=> Empty_2
,
15731 Add_Named_Subp
=> Add_Named_2
,
15732 Add_Unnamed_Subp
=> Add_Unnamed_2
,
15733 New_Indexed_Subp
=> New_Indexed_2
,
15734 Assign_Indexed_Subp
=> Assign_Indexed_2
);
15736 Names_Match
(Empty_1
, Empty_2
) and then
15737 Names_Match
(Add_Named_1
, Add_Named_2
) and then
15738 Names_Match
(Add_Unnamed_1
, Add_Unnamed_2
) and then
15739 Names_Match
(New_Indexed_1
, New_Indexed_2
) and then
15740 Names_Match
(Assign_Indexed_1
, Assign_Indexed_2
);
15743 -- Checking for this aspect is performed elsewhere during freezing
15744 when Aspect_No_Controlled_Parts
=>
15747 -- scalar-valued aspects; compare (static) values.
15748 when Aspect_Max_Entry_Queue_Length
=>
15749 -- This should be unreachable. Max_Entry_Queue_Length is
15750 -- supported only for protected entries, not for types.
15751 pragma Assert
(Serious_Errors_Detected
/= 0);
15755 raise Program_Error
;
15759 -----------------------------
15760 -- Is_Concurrent_Interface --
15761 -----------------------------
15763 function Is_Concurrent_Interface
(T
: Entity_Id
) return Boolean is
15765 return Is_Protected_Interface
(T
)
15766 or else Is_Synchronized_Interface
(T
)
15767 or else Is_Task_Interface
(T
);
15768 end Is_Concurrent_Interface
;
15770 ------------------------------------------------------
15771 -- Is_Conjunction_Of_Formal_Preelab_Init_Attributes --
15772 ------------------------------------------------------
15774 function Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15775 (Expr
: Node_Id
) return Boolean
15778 function Is_Formal_Preelab_Init_Attribute
15779 (N
: Node_Id
) return Boolean;
15780 -- Returns True if N is a Preelaborable_Initialization attribute
15781 -- applied to a generic formal type, or N's Original_Node is such
15784 --------------------------------------
15785 -- Is_Formal_Preelab_Init_Attribute --
15786 --------------------------------------
15788 function Is_Formal_Preelab_Init_Attribute
15789 (N
: Node_Id
) return Boolean
15791 Orig_N
: constant Node_Id
:= Original_Node
(N
);
15794 return Nkind
(Orig_N
) = N_Attribute_Reference
15795 and then Attribute_Name
(Orig_N
) = Name_Preelaborable_Initialization
15796 and then Is_Entity_Name
(Prefix
(Orig_N
))
15797 and then Is_Generic_Type
(Entity
(Prefix
(Orig_N
)));
15798 end Is_Formal_Preelab_Init_Attribute
;
15800 -- Start of Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15803 return Is_Formal_Preelab_Init_Attribute
(Expr
)
15804 or else (Nkind
(Expr
) = N_Op_And
15806 Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15809 Is_Conjunction_Of_Formal_Preelab_Init_Attributes
15810 (Right_Opnd
(Expr
)));
15811 end Is_Conjunction_Of_Formal_Preelab_Init_Attributes
;
15813 -----------------------
15814 -- Is_Constant_Bound --
15815 -----------------------
15817 function Is_Constant_Bound
(Exp
: Node_Id
) return Boolean is
15819 if Compile_Time_Known_Value
(Exp
) then
15822 elsif Is_Entity_Name
(Exp
) and then Present
(Entity
(Exp
)) then
15823 return Is_Constant_Object
(Entity
(Exp
))
15824 or else Ekind
(Entity
(Exp
)) = E_Enumeration_Literal
;
15826 elsif Nkind
(Exp
) in N_Binary_Op
then
15827 return Is_Constant_Bound
(Left_Opnd
(Exp
))
15828 and then Is_Constant_Bound
(Right_Opnd
(Exp
))
15829 and then Scope
(Entity
(Exp
)) = Standard_Standard
;
15834 end Is_Constant_Bound
;
15836 ---------------------------
15837 -- Is_Container_Element --
15838 ---------------------------
15840 function Is_Container_Element
(Exp
: Node_Id
) return Boolean is
15841 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
15842 Pref
: constant Node_Id
:= Prefix
(Exp
);
15845 -- Call to an indexing aspect
15847 Cont_Typ
: Entity_Id
;
15848 -- The type of the container being accessed
15850 Elem_Typ
: Entity_Id
;
15851 -- Its element type
15853 Indexing
: Entity_Id
;
15854 Is_Const
: Boolean;
15855 -- Indicates that constant indexing is used, and the element is thus
15858 Ref_Typ
: Entity_Id
;
15859 -- The reference type returned by the indexing operation
15862 -- If C is a container, in a context that imposes the element type of
15863 -- that container, the indexing notation C (X) is rewritten as:
15865 -- Indexing (C, X).Discr.all
15867 -- where Indexing is one of the indexing aspects of the container.
15868 -- If the context does not require a reference, the construct can be
15873 -- First, verify that the construct has the proper form
15875 if not Expander_Active
then
15878 elsif Nkind
(Pref
) /= N_Selected_Component
then
15881 elsif Nkind
(Prefix
(Pref
)) /= N_Function_Call
then
15885 Call
:= Prefix
(Pref
);
15886 Ref_Typ
:= Etype
(Call
);
15889 if not Has_Implicit_Dereference
(Ref_Typ
)
15890 or else No
(First
(Parameter_Associations
(Call
)))
15891 or else not Is_Entity_Name
(Name
(Call
))
15896 -- Retrieve type of container object, and its iterator aspects
15898 Cont_Typ
:= Etype
(First
(Parameter_Associations
(Call
)));
15899 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Constant_Indexing
);
15902 if No
(Indexing
) then
15904 -- Container should have at least one indexing operation
15908 elsif Entity
(Name
(Call
)) /= Entity
(Indexing
) then
15910 -- This may be a variable indexing operation
15912 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Variable_Indexing
);
15915 or else Entity
(Name
(Call
)) /= Entity
(Indexing
)
15924 Elem_Typ
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Iterator_Element
);
15926 if No
(Elem_Typ
) or else Entity
(Elem_Typ
) /= Etype
(Exp
) then
15930 -- Check that the expression is not the target of an assignment, in
15931 -- which case the rewriting is not possible.
15933 if not Is_Const
then
15939 while Present
(Par
)
15941 if Nkind
(Parent
(Par
)) = N_Assignment_Statement
15942 and then Par
= Name
(Parent
(Par
))
15946 -- A renaming produces a reference, and the transformation
15949 elsif Nkind
(Parent
(Par
)) = N_Object_Renaming_Declaration
then
15952 elsif Nkind
(Parent
(Par
)) in
15954 N_Procedure_Call_Statement |
15955 N_Entry_Call_Statement
15957 -- Check that the element is not part of an actual for an
15958 -- in-out parameter.
15965 F
:= First_Formal
(Entity
(Name
(Parent
(Par
))));
15966 A
:= First
(Parameter_Associations
(Parent
(Par
)));
15967 while Present
(F
) loop
15968 if A
= Par
and then Ekind
(F
) /= E_In_Parameter
then
15977 -- E_In_Parameter in a call: element is not modified.
15982 Par
:= Parent
(Par
);
15987 -- The expression has the proper form and the context requires the
15988 -- element type. Retrieve the Element function of the container and
15989 -- rewrite the construct as a call to it.
15995 Op
:= First_Elmt
(Primitive_Operations
(Cont_Typ
));
15996 while Present
(Op
) loop
15997 exit when Chars
(Node
(Op
)) = Name_Element
;
16006 Make_Function_Call
(Loc
,
16007 Name
=> New_Occurrence_Of
(Node
(Op
), Loc
),
16008 Parameter_Associations
=> Parameter_Associations
(Call
)));
16009 Analyze_And_Resolve
(Exp
, Entity
(Elem_Typ
));
16013 end Is_Container_Element
;
16015 ----------------------------
16016 -- Is_Contract_Annotation --
16017 ----------------------------
16019 function Is_Contract_Annotation
(Item
: Node_Id
) return Boolean is
16021 return Is_Package_Contract_Annotation
(Item
)
16023 Is_Subprogram_Contract_Annotation
(Item
);
16024 end Is_Contract_Annotation
;
16026 --------------------------------------
16027 -- Is_Controlling_Limited_Procedure --
16028 --------------------------------------
16030 function Is_Controlling_Limited_Procedure
16031 (Proc_Nam
: Entity_Id
) return Boolean
16034 Param_Typ
: Entity_Id
:= Empty
;
16037 if Ekind
(Proc_Nam
) = E_Procedure
16038 and then Present
(Parameter_Specifications
(Parent
(Proc_Nam
)))
16042 (First
(Parameter_Specifications
(Parent
(Proc_Nam
))));
16044 -- The formal may be an anonymous access type
16046 if Nkind
(Param
) = N_Access_Definition
then
16047 Param_Typ
:= Entity
(Subtype_Mark
(Param
));
16049 Param_Typ
:= Etype
(Param
);
16052 -- In the case where an Itype was created for a dispatchin call, the
16053 -- procedure call has been rewritten. The actual may be an access to
16054 -- interface type in which case it is the designated type that is the
16055 -- controlling type.
16057 elsif Present
(Associated_Node_For_Itype
(Proc_Nam
))
16058 and then Present
(Original_Node
(Associated_Node_For_Itype
(Proc_Nam
)))
16060 Present
(Parameter_Associations
16061 (Associated_Node_For_Itype
(Proc_Nam
)))
16064 Etype
(First
(Parameter_Associations
16065 (Associated_Node_For_Itype
(Proc_Nam
))));
16067 if Ekind
(Param_Typ
) = E_Anonymous_Access_Type
then
16068 Param_Typ
:= Directly_Designated_Type
(Param_Typ
);
16072 if Present
(Param_Typ
) then
16074 Is_Interface
(Param_Typ
)
16075 and then Is_Limited_Record
(Param_Typ
);
16079 end Is_Controlling_Limited_Procedure
;
16081 -----------------------------
16082 -- Is_CPP_Constructor_Call --
16083 -----------------------------
16085 function Is_CPP_Constructor_Call
(N
: Node_Id
) return Boolean is
16087 return Nkind
(N
) = N_Function_Call
16088 and then Is_CPP_Class
(Etype
(Etype
(N
)))
16089 and then Is_Constructor
(Entity
(Name
(N
)))
16090 and then Is_Imported
(Entity
(Name
(N
)));
16091 end Is_CPP_Constructor_Call
;
16093 -------------------------
16094 -- Is_Current_Instance --
16095 -------------------------
16097 function Is_Current_Instance
(N
: Node_Id
) return Boolean is
16098 Typ
: constant Entity_Id
:= Entity
(N
);
16102 -- Simplest case: entity is a concurrent type and we are currently
16103 -- inside the body. This will eventually be expanded into a call to
16104 -- Self (for tasks) or _object (for protected objects).
16106 if Is_Concurrent_Type
(Typ
) and then In_Open_Scopes
(Typ
) then
16110 -- Check whether the context is a (sub)type declaration for the
16114 while Present
(P
) loop
16115 if Nkind
(P
) in N_Full_Type_Declaration
16116 | N_Private_Type_Declaration
16117 | N_Subtype_Declaration
16118 and then Comes_From_Source
(P
)
16120 -- If the type has a previous incomplete declaration, the
16121 -- reference in the type definition may have the incomplete
16122 -- view. So, here we detect if this incomplete view is a current
16123 -- instance by checking if its full view is the entity of the
16124 -- full declaration begin analyzed.
16127 (Defining_Entity
(P
) = Typ
16129 (Ekind
(Typ
) = E_Incomplete_Type
16130 and then Full_View
(Typ
) = Defining_Entity
(P
)))
16134 -- A subtype name may appear in an aspect specification for a
16135 -- Predicate_Failure aspect, for which we do not construct a
16136 -- wrapper procedure. The subtype will be replaced by the
16137 -- expression being tested when the corresponding predicate
16138 -- check is expanded. It may also appear in the pragma Predicate
16139 -- expression during legality checking.
16141 elsif Nkind
(P
) = N_Aspect_Specification
16142 and then Nkind
(Parent
(P
)) = N_Subtype_Declaration
16143 and then Underlying_Type
(Defining_Identifier
(Parent
(P
))) =
16144 Underlying_Type
(Typ
)
16148 elsif Nkind
(P
) = N_Pragma
16149 and then Get_Pragma_Id
(P
) in Pragma_Predicate
16150 | Pragma_Predicate_Failure
16153 Arg
: constant Entity_Id
:=
16154 Entity
(Expression
(Get_Argument
(P
)));
16156 if Underlying_Type
(Arg
) = Underlying_Type
(Typ
) then
16166 -- In any other context this is not a current occurrence
16169 end Is_Current_Instance
;
16171 --------------------------------------------------
16172 -- Is_Current_Instance_Reference_In_Type_Aspect --
16173 --------------------------------------------------
16175 function Is_Current_Instance_Reference_In_Type_Aspect
16176 (N
: Node_Id
) return Boolean
16179 -- When a current_instance is referenced within an aspect_specification
16180 -- of a type or subtype, it will show up as a reference to the formal
16181 -- parameter of the aspect's associated subprogram rather than as a
16182 -- reference to the type or subtype itself (in fact, the original name
16183 -- is never even analyzed). We check for predicate, invariant, and
16184 -- Default_Initial_Condition subprograms (in theory there could be
16185 -- other cases added, in which case this function will need updating).
16187 if Is_Entity_Name
(N
) then
16188 return Present
(Entity
(N
))
16189 and then Ekind
(Entity
(N
)) = E_In_Parameter
16190 and then Ekind
(Scope
(Entity
(N
))) in E_Function | E_Procedure
16192 (Is_Predicate_Function
(Scope
(Entity
(N
)))
16193 or else Is_Invariant_Procedure
(Scope
(Entity
(N
)))
16194 or else Is_Partial_Invariant_Procedure
(Scope
(Entity
(N
)))
16195 or else Is_DIC_Procedure
(Scope
(Entity
(N
))));
16199 when N_Indexed_Component
16203 Is_Current_Instance_Reference_In_Type_Aspect
(Prefix
(N
));
16205 when N_Selected_Component
=>
16207 Is_Current_Instance_Reference_In_Type_Aspect
(Prefix
(N
));
16209 when N_Type_Conversion
=>
16210 return Is_Current_Instance_Reference_In_Type_Aspect
16213 when N_Qualified_Expression
=>
16214 return Is_Current_Instance_Reference_In_Type_Aspect
16221 end Is_Current_Instance_Reference_In_Type_Aspect
;
16223 --------------------
16224 -- Is_Declaration --
16225 --------------------
16227 function Is_Declaration
16229 Body_OK
: Boolean := True;
16230 Concurrent_OK
: Boolean := True;
16231 Formal_OK
: Boolean := True;
16232 Generic_OK
: Boolean := True;
16233 Instantiation_OK
: Boolean := True;
16234 Renaming_OK
: Boolean := True;
16235 Stub_OK
: Boolean := True;
16236 Subprogram_OK
: Boolean := True;
16237 Type_OK
: Boolean := True) return Boolean
16242 -- Body declarations
16244 when N_Proper_Body
=>
16247 -- Concurrent type declarations
16249 when N_Protected_Type_Declaration
16250 | N_Single_Protected_Declaration
16251 | N_Single_Task_Declaration
16252 | N_Task_Type_Declaration
16254 return Concurrent_OK
or Type_OK
;
16256 -- Formal declarations
16258 when N_Formal_Abstract_Subprogram_Declaration
16259 | N_Formal_Concrete_Subprogram_Declaration
16260 | N_Formal_Object_Declaration
16261 | N_Formal_Package_Declaration
16262 | N_Formal_Type_Declaration
16266 -- Generic declarations
16268 when N_Generic_Package_Declaration
16269 | N_Generic_Subprogram_Declaration
16273 -- Generic instantiations
16275 when N_Function_Instantiation
16276 | N_Package_Instantiation
16277 | N_Procedure_Instantiation
16279 return Instantiation_OK
;
16281 -- Generic renaming declarations
16283 when N_Generic_Renaming_Declaration
=>
16284 return Generic_OK
or Renaming_OK
;
16286 -- Renaming declarations
16288 when N_Exception_Renaming_Declaration
16289 | N_Object_Renaming_Declaration
16290 | N_Package_Renaming_Declaration
16291 | N_Subprogram_Renaming_Declaration
16293 return Renaming_OK
;
16295 -- Stub declarations
16297 when N_Body_Stub
=>
16300 -- Subprogram declarations
16302 when N_Abstract_Subprogram_Declaration
16303 | N_Entry_Declaration
16304 | N_Expression_Function
16305 | N_Subprogram_Declaration
16307 return Subprogram_OK
;
16309 -- Type declarations
16311 when N_Full_Type_Declaration
16312 | N_Incomplete_Type_Declaration
16313 | N_Private_Extension_Declaration
16314 | N_Private_Type_Declaration
16315 | N_Subtype_Declaration
16321 when N_Component_Declaration
16322 | N_Exception_Declaration
16323 | N_Implicit_Label_Declaration
16324 | N_Number_Declaration
16325 | N_Object_Declaration
16326 | N_Package_Declaration
16333 end Is_Declaration
;
16335 --------------------------------
16336 -- Is_Declared_Within_Variant --
16337 --------------------------------
16339 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
16340 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
16341 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
16343 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
16344 end Is_Declared_Within_Variant
;
16346 ----------------------------------------------
16347 -- Is_Dependent_Component_Of_Mutable_Object --
16348 ----------------------------------------------
16350 function Is_Dependent_Component_Of_Mutable_Object
16351 (Object
: Node_Id
) return Boolean
16354 Prefix_Type
: Entity_Id
;
16355 P_Aliased
: Boolean := False;
16358 Deref
: Node_Id
:= Original_Node
(Object
);
16359 -- Dereference node, in something like X.all.Y(2)
16361 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
16364 -- Find the dereference node if any
16366 while Nkind
(Deref
) in
16367 N_Indexed_Component | N_Selected_Component | N_Slice
16369 Deref
:= Original_Node
(Prefix
(Deref
));
16372 -- If the prefix is a qualified expression of a variable, then function
16373 -- Is_Variable will return False for that because a qualified expression
16374 -- denotes a constant view, so we need to get the name being qualified
16375 -- so we can test below whether that's a variable (or a dereference).
16377 if Nkind
(Deref
) = N_Qualified_Expression
then
16378 Deref
:= Expression
(Deref
);
16381 -- Ada 2005: If we have a component or slice of a dereference, something
16382 -- like X.all.Y (2) and the type of X is access-to-constant, Is_Variable
16383 -- will return False, because it is indeed a constant view. But it might
16384 -- be a view of a variable object, so we want the following condition to
16385 -- be True in that case.
16387 if Is_Variable
(Object
)
16388 or else Is_Variable
(Deref
)
16390 (Ada_Version
>= Ada_2005
16391 and then (Nkind
(Deref
) = N_Explicit_Dereference
16392 or else (Present
(Etype
(Deref
))
16393 and then Is_Access_Type
(Etype
(Deref
)))))
16395 if Nkind
(Object
) = N_Selected_Component
then
16397 -- If the selector is not a component, then we definitely return
16398 -- False (it could be a function selector in a prefix form call
16399 -- occurring in an iterator specification).
16401 if Ekind
(Entity
(Selector_Name
(Object
))) not in
16402 E_Component | E_Discriminant
16407 -- Get the original node of the prefix in case it has been
16408 -- rewritten, which can occur, for example, in qualified
16409 -- expression cases. Also, a discriminant check on a selected
16410 -- component may be expanded into a dereference when removing
16411 -- side effects, and the subtype of the original node may be
16414 P
:= Original_Node
(Prefix
(Object
));
16415 Prefix_Type
:= Etype
(P
);
16417 -- If the prefix is a qualified expression, we want to look at its
16420 if Nkind
(P
) = N_Qualified_Expression
then
16421 P
:= Expression
(P
);
16422 Prefix_Type
:= Etype
(P
);
16425 if Is_Entity_Name
(P
) then
16426 -- The Etype may not be set on P (which is wrong) in certain
16427 -- corner cases involving the deprecated front-end inlining of
16428 -- subprograms (via -gnatN), so use the Etype set on the
16429 -- the entity for these instances since we know it is present.
16431 if No
(Prefix_Type
) then
16432 Prefix_Type
:= Etype
(Entity
(P
));
16435 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
16436 Prefix_Type
:= Base_Type
(Prefix_Type
);
16439 if Is_Aliased
(Entity
(P
)) then
16443 -- For explicit dereferences we get the access prefix so we can
16444 -- treat this similarly to implicit dereferences and examine the
16445 -- kind of the access type and its designated subtype further
16448 elsif Nkind
(P
) = N_Explicit_Dereference
then
16450 Prefix_Type
:= Etype
(P
);
16453 -- Check for prefix being an aliased component???
16458 -- A heap object is constrained by its initial value
16460 -- Ada 2005 (AI-363): Always assume the object could be mutable in
16461 -- the dereferenced case, since the access value might denote an
16462 -- unconstrained aliased object, whereas in Ada 95 the designated
16463 -- object is guaranteed to be constrained. A worst-case assumption
16464 -- has to apply in Ada 2005 because we can't tell at compile
16465 -- time whether the object is "constrained by its initial value",
16466 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
16467 -- rules (these rules are acknowledged to need fixing). We don't
16468 -- impose this more stringent checking for earlier Ada versions or
16469 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's
16470 -- benefit, though it's unclear on why using -gnat95 would not be
16473 if Ada_Version
< Ada_2005
or else Relaxed_RM_Semantics
then
16474 if Is_Access_Type
(Prefix_Type
)
16475 or else Nkind
(P
) = N_Explicit_Dereference
16480 else pragma Assert
(Ada_Version
>= Ada_2005
);
16481 if Is_Access_Type
(Prefix_Type
) then
16482 -- We need to make sure we have the base subtype, in case
16483 -- this is actually an access subtype (whose Ekind will be
16484 -- E_Access_Subtype).
16486 Prefix_Type
:= Etype
(Prefix_Type
);
16488 -- If the access type is pool-specific, and there is no
16489 -- constrained partial view of the designated type, then the
16490 -- designated object is known to be constrained. If it's a
16491 -- formal access type and the renaming is in the generic
16492 -- spec, we also treat it as pool-specific (known to be
16493 -- constrained), but assume the worst if in the generic body
16494 -- (see RM 3.3(23.3/3)).
16496 if Ekind
(Prefix_Type
) = E_Access_Type
16497 and then (not Is_Generic_Type
(Prefix_Type
)
16498 or else not In_Generic_Body
(Current_Scope
))
16499 and then not Object_Type_Has_Constrained_Partial_View
16500 (Typ
=> Designated_Type
(Prefix_Type
),
16501 Scop
=> Current_Scope
)
16505 -- Otherwise (general access type, or there is a constrained
16506 -- partial view of the designated type), we need to check
16507 -- based on the designated type.
16510 Prefix_Type
:= Designated_Type
(Prefix_Type
);
16516 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
16518 -- As per AI-0017, the renaming is illegal in a generic body, even
16519 -- if the subtype is indefinite (only applies to prefixes of an
16520 -- untagged formal type, see RM 3.3 (23.11/3)).
16522 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
16524 if not Is_Constrained
(Prefix_Type
)
16525 and then (Is_Definite_Subtype
(Prefix_Type
)
16527 (not Is_Tagged_Type
(Prefix_Type
)
16528 and then Is_Generic_Type
(Prefix_Type
)
16529 and then In_Generic_Body
(Current_Scope
)))
16531 and then (Is_Declared_Within_Variant
(Comp
)
16532 or else Has_Discriminant_Dependent_Constraint
(Comp
))
16533 and then (not P_Aliased
or else Ada_Version
>= Ada_2005
)
16537 -- If the prefix is of an access type at this point, then we want
16538 -- to return False, rather than calling this function recursively
16539 -- on the access object (which itself might be a discriminant-
16540 -- dependent component of some other object, but that isn't
16541 -- relevant to checking the object passed to us). This avoids
16542 -- issuing wrong errors when compiling with -gnatc, where there
16543 -- can be implicit dereferences that have not been expanded.
16545 elsif Is_Access_Type
(Etype
(Prefix
(Object
))) then
16550 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
16553 elsif Nkind
(Object
) = N_Indexed_Component
16554 or else Nkind
(Object
) = N_Slice
16556 return Is_Dependent_Component_Of_Mutable_Object
16557 (Original_Node
(Prefix
(Object
)));
16559 -- A type conversion that Is_Variable is a view conversion:
16560 -- go back to the denoted object.
16562 elsif Nkind
(Object
) = N_Type_Conversion
then
16564 Is_Dependent_Component_Of_Mutable_Object
16565 (Original_Node
(Expression
(Object
)));
16570 end Is_Dependent_Component_Of_Mutable_Object
;
16572 ---------------------
16573 -- Is_Dereferenced --
16574 ---------------------
16576 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
16577 P
: constant Node_Id
:= Parent
(N
);
16579 return Nkind
(P
) in N_Selected_Component
16580 | N_Explicit_Dereference
16581 | N_Indexed_Component
16583 and then Prefix
(P
) = N
;
16584 end Is_Dereferenced
;
16586 ----------------------
16587 -- Is_Descendant_Of --
16588 ----------------------
16590 function Is_Descendant_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
16595 pragma Assert
(Nkind
(T1
) in N_Entity
);
16596 pragma Assert
(Nkind
(T2
) in N_Entity
);
16598 T
:= Base_Type
(T1
);
16600 -- Immediate return if the types match
16605 -- Comment needed here ???
16607 elsif Ekind
(T
) = E_Class_Wide_Type
then
16608 return Etype
(T
) = T2
;
16616 -- Done if we found the type we are looking for
16621 -- Done if no more derivations to check
16628 -- Following test catches error cases resulting from prev errors
16630 elsif No
(Etyp
) then
16633 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
16636 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
16640 T
:= Base_Type
(Etyp
);
16643 end Is_Descendant_Of
;
16645 ----------------------------------------
16646 -- Is_Descendant_Of_Suspension_Object --
16647 ----------------------------------------
16649 function Is_Descendant_Of_Suspension_Object
16650 (Typ
: Entity_Id
) return Boolean
16652 Cur_Typ
: Entity_Id
;
16653 Par_Typ
: Entity_Id
;
16656 -- Climb the type derivation chain checking each parent type against
16657 -- Suspension_Object.
16659 Cur_Typ
:= Base_Type
(Typ
);
16660 while Present
(Cur_Typ
) loop
16661 Par_Typ
:= Etype
(Cur_Typ
);
16663 -- The current type is a match
16665 if Is_RTE
(Cur_Typ
, RE_Suspension_Object
) then
16668 -- Stop the traversal once the root of the derivation chain has been
16669 -- reached. In that case the current type is its own base type.
16671 elsif Cur_Typ
= Par_Typ
then
16675 Cur_Typ
:= Base_Type
(Par_Typ
);
16679 end Is_Descendant_Of_Suspension_Object
;
16681 ---------------------------------------------
16682 -- Is_Double_Precision_Floating_Point_Type --
16683 ---------------------------------------------
16685 function Is_Double_Precision_Floating_Point_Type
16686 (E
: Entity_Id
) return Boolean is
16688 return Is_Floating_Point_Type
(E
)
16689 and then Machine_Radix_Value
(E
) = Uint_2
16690 and then Machine_Mantissa_Value
(E
) = UI_From_Int
(53)
16691 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_10
16692 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_10
);
16693 end Is_Double_Precision_Floating_Point_Type
;
16695 -----------------------------
16696 -- Is_Effectively_Volatile --
16697 -----------------------------
16699 function Is_Effectively_Volatile
16701 Ignore_Protected
: Boolean := False) return Boolean is
16703 if Is_Type
(Id
) then
16705 -- An arbitrary type is effectively volatile when it is subject to
16706 -- pragma Atomic or Volatile, unless No_Caching is enabled.
16708 if Is_Volatile
(Id
)
16709 and then not No_Caching_Enabled
(Id
)
16713 -- An array type is effectively volatile when it is subject to pragma
16714 -- Atomic_Components or Volatile_Components or its component type is
16715 -- effectively volatile.
16717 elsif Is_Array_Type
(Id
) then
16718 if Has_Volatile_Components
(Id
) then
16722 Anc
: Entity_Id
:= Base_Type
(Id
);
16724 if Is_Private_Type
(Anc
) then
16725 Anc
:= Full_View
(Anc
);
16728 -- Test for presence of ancestor, as the full view of a
16729 -- private type may be missing in case of error.
16731 return Present
(Anc
)
16732 and then Is_Effectively_Volatile
16733 (Component_Type
(Anc
), Ignore_Protected
);
16737 -- A protected type is always volatile unless Ignore_Protected is
16740 elsif Is_Protected_Type
(Id
) and then not Ignore_Protected
then
16743 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is
16744 -- automatically volatile.
16746 elsif Is_Descendant_Of_Suspension_Object
(Id
) then
16749 -- Otherwise the type is not effectively volatile
16755 -- Otherwise Id denotes an object
16757 else pragma Assert
(Is_Object
(Id
));
16758 -- A volatile object for which No_Caching is enabled is not
16759 -- effectively volatile.
16764 (Ekind
(Id
) = E_Variable
and then No_Caching_Enabled
(Id
)))
16765 or else Has_Volatile_Components
(Id
)
16766 or else Is_Effectively_Volatile
(Etype
(Id
), Ignore_Protected
);
16768 end Is_Effectively_Volatile
;
16770 -----------------------------------------
16771 -- Is_Effectively_Volatile_For_Reading --
16772 -----------------------------------------
16774 function Is_Effectively_Volatile_For_Reading
16776 Ignore_Protected
: Boolean := False) return Boolean
16779 -- A concurrent type is effectively volatile for reading, except for a
16780 -- protected type when Ignore_Protected is True.
16782 if Is_Task_Type
(Id
)
16783 or else (Is_Protected_Type
(Id
) and then not Ignore_Protected
)
16787 elsif Is_Effectively_Volatile
(Id
, Ignore_Protected
) then
16789 -- Other volatile types and objects are effectively volatile for
16790 -- reading when they have property Async_Writers or Effective_Reads
16791 -- set to True. This includes the case of an array type whose
16792 -- Volatile_Components aspect is True (hence it is effectively
16793 -- volatile) which does not have the properties Async_Writers
16794 -- and Effective_Reads set to False.
16796 if Async_Writers_Enabled
(Id
)
16797 or else Effective_Reads_Enabled
(Id
)
16801 -- In addition, an array type is effectively volatile for reading
16802 -- when its component type is effectively volatile for reading.
16804 elsif Is_Array_Type
(Id
) then
16806 Anc
: Entity_Id
:= Base_Type
(Id
);
16808 if Is_Private_Type
(Anc
) then
16809 Anc
:= Full_View
(Anc
);
16812 -- Test for presence of ancestor, as the full view of a
16813 -- private type may be missing in case of error.
16815 return Present
(Anc
)
16816 and then Is_Effectively_Volatile_For_Reading
16817 (Component_Type
(Anc
), Ignore_Protected
);
16824 end Is_Effectively_Volatile_For_Reading
;
16826 ------------------------------------
16827 -- Is_Effectively_Volatile_Object --
16828 ------------------------------------
16830 function Is_Effectively_Volatile_Object
(N
: Node_Id
) return Boolean is
16831 function Is_Effectively_Volatile
(E
: Entity_Id
) return Boolean is
16832 (Is_Effectively_Volatile
(E
, Ignore_Protected
=> False));
16834 function Is_Effectively_Volatile_Object_Inst
16835 is new Is_Effectively_Volatile_Object_Shared
(Is_Effectively_Volatile
);
16837 return Is_Effectively_Volatile_Object_Inst
(N
);
16838 end Is_Effectively_Volatile_Object
;
16840 ------------------------------------------------
16841 -- Is_Effectively_Volatile_Object_For_Reading --
16842 ------------------------------------------------
16844 function Is_Effectively_Volatile_Object_For_Reading
16845 (N
: Node_Id
) return Boolean
16847 function Is_Effectively_Volatile_For_Reading
16848 (E
: Entity_Id
) return Boolean
16849 is (Is_Effectively_Volatile_For_Reading
(E
, Ignore_Protected
=> False));
16851 function Is_Effectively_Volatile_Object_For_Reading_Inst
16852 is new Is_Effectively_Volatile_Object_Shared
16853 (Is_Effectively_Volatile_For_Reading
);
16855 return Is_Effectively_Volatile_Object_For_Reading_Inst
(N
);
16856 end Is_Effectively_Volatile_Object_For_Reading
;
16858 -------------------------------------------
16859 -- Is_Effectively_Volatile_Object_Shared --
16860 -------------------------------------------
16862 function Is_Effectively_Volatile_Object_Shared
16863 (N
: Node_Id
) return Boolean
16866 if Is_Entity_Name
(N
) then
16867 return Is_Object
(Entity
(N
))
16868 and then Is_Effectively_Volatile_Entity
(Entity
(N
));
16870 elsif Nkind
(N
) in N_Indexed_Component | N_Slice
then
16871 return Is_Effectively_Volatile_Object_Shared
(Prefix
(N
));
16873 elsif Nkind
(N
) = N_Selected_Component
then
16875 Is_Effectively_Volatile_Object_Shared
(Prefix
(N
))
16877 Is_Effectively_Volatile_Object_Shared
(Selector_Name
(N
));
16879 elsif Nkind
(N
) in N_Qualified_Expression
16880 | N_Unchecked_Type_Conversion
16881 | N_Type_Conversion
16883 return Is_Effectively_Volatile_Object_Shared
(Expression
(N
));
16888 end Is_Effectively_Volatile_Object_Shared
;
16890 ----------------------------------------
16891 -- Is_Entity_Of_Quantified_Expression --
16892 ----------------------------------------
16894 function Is_Entity_Of_Quantified_Expression
(Id
: Entity_Id
) return Boolean
16896 Par
: constant Node_Id
:= Parent
(Id
);
16899 return (Nkind
(Par
) = N_Loop_Parameter_Specification
16900 or else Nkind
(Par
) = N_Iterator_Specification
)
16901 and then Defining_Identifier
(Par
) = Id
16902 and then Nkind
(Parent
(Par
)) = N_Quantified_Expression
;
16903 end Is_Entity_Of_Quantified_Expression
;
16905 -------------------
16906 -- Is_Entry_Body --
16907 -------------------
16909 function Is_Entry_Body
(Id
: Entity_Id
) return Boolean is
16913 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Body
;
16916 --------------------------
16917 -- Is_Entry_Declaration --
16918 --------------------------
16920 function Is_Entry_Declaration
(Id
: Entity_Id
) return Boolean is
16924 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Declaration
;
16925 end Is_Entry_Declaration
;
16927 ------------------------------------
16928 -- Is_Expanded_Priority_Attribute --
16929 ------------------------------------
16931 function Is_Expanded_Priority_Attribute
(E
: Entity_Id
) return Boolean is
16934 Nkind
(E
) = N_Function_Call
16935 and then not Configurable_Run_Time_Mode
16936 and then Nkind
(Original_Node
(E
)) = N_Attribute_Reference
16937 and then (Is_RTE
(Entity
(Name
(E
)), RE_Get_Ceiling
)
16938 or else Is_RTE
(Entity
(Name
(E
)), RO_PE_Get_Ceiling
));
16939 end Is_Expanded_Priority_Attribute
;
16941 ----------------------------
16942 -- Is_Expression_Function --
16943 ----------------------------
16945 function Is_Expression_Function
(Subp
: Entity_Id
) return Boolean is
16947 if Ekind
(Subp
) in E_Function | E_Subprogram_Body
then
16949 Nkind
(Original_Node
(Unit_Declaration_Node
(Subp
))) =
16950 N_Expression_Function
;
16954 end Is_Expression_Function
;
16956 ------------------------------------------
16957 -- Is_Expression_Function_Or_Completion --
16958 ------------------------------------------
16960 function Is_Expression_Function_Or_Completion
16961 (Subp
: Entity_Id
) return Boolean
16963 Subp_Decl
: Node_Id
;
16966 if Ekind
(Subp
) = E_Function
then
16967 Subp_Decl
:= Unit_Declaration_Node
(Subp
);
16969 -- The function declaration is either an expression function or is
16970 -- completed by an expression function body.
16973 Is_Expression_Function
(Subp
)
16974 or else (Nkind
(Subp_Decl
) = N_Subprogram_Declaration
16975 and then Present
(Corresponding_Body
(Subp_Decl
))
16976 and then Is_Expression_Function
16977 (Corresponding_Body
(Subp_Decl
)));
16979 elsif Ekind
(Subp
) = E_Subprogram_Body
then
16980 return Is_Expression_Function
(Subp
);
16985 end Is_Expression_Function_Or_Completion
;
16987 -----------------------------------------------
16988 -- Is_Extended_Precision_Floating_Point_Type --
16989 -----------------------------------------------
16991 function Is_Extended_Precision_Floating_Point_Type
16992 (E
: Entity_Id
) return Boolean is
16994 return Is_Floating_Point_Type
(E
)
16995 and then Machine_Radix_Value
(E
) = Uint_2
16996 and then Machine_Mantissa_Value
(E
) = Uint_64
16997 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_14
16998 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_14
);
16999 end Is_Extended_Precision_Floating_Point_Type
;
17001 -----------------------
17002 -- Is_EVF_Expression --
17003 -----------------------
17005 function Is_EVF_Expression
(N
: Node_Id
) return Boolean is
17006 Orig_N
: constant Node_Id
:= Original_Node
(N
);
17012 -- Detect a reference to a formal parameter of a specific tagged type
17013 -- whose related subprogram is subject to pragma Expresions_Visible with
17016 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
17021 and then Is_Specific_Tagged_Type
(Etype
(Id
))
17022 and then Extensions_Visible_Status
(Id
) =
17023 Extensions_Visible_False
;
17025 -- A case expression is an EVF expression when it contains at least one
17026 -- EVF dependent_expression. Note that a case expression may have been
17027 -- expanded, hence the use of Original_Node.
17029 elsif Nkind
(Orig_N
) = N_Case_Expression
then
17030 Alt
:= First
(Alternatives
(Orig_N
));
17031 while Present
(Alt
) loop
17032 if Is_EVF_Expression
(Expression
(Alt
)) then
17039 -- An if expression is an EVF expression when it contains at least one
17040 -- EVF dependent_expression. Note that an if expression may have been
17041 -- expanded, hence the use of Original_Node.
17043 elsif Nkind
(Orig_N
) = N_If_Expression
then
17044 Expr
:= Next
(First
(Expressions
(Orig_N
)));
17045 while Present
(Expr
) loop
17046 if Is_EVF_Expression
(Expr
) then
17053 -- A qualified expression or a type conversion is an EVF expression when
17054 -- its operand is an EVF expression.
17056 elsif Nkind
(N
) in N_Qualified_Expression
17057 | N_Unchecked_Type_Conversion
17058 | N_Type_Conversion
17060 return Is_EVF_Expression
(Expression
(N
));
17062 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when
17063 -- their prefix denotes an EVF expression.
17065 elsif Nkind
(N
) = N_Attribute_Reference
17066 and then Attribute_Name
(N
) in Name_Loop_Entry
17070 return Is_EVF_Expression
(Prefix
(N
));
17074 end Is_EVF_Expression
;
17080 function Is_False
(U
: Opt_Ubool
) return Boolean is
17082 return not Is_True
(U
);
17085 ---------------------------
17086 -- Is_Fixed_Model_Number --
17087 ---------------------------
17089 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
17090 S
: constant Ureal
:= Small_Value
(T
);
17091 M
: Urealp
.Save_Mark
;
17096 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
17097 Urealp
.Release
(M
);
17099 end Is_Fixed_Model_Number
;
17101 -----------------------------
17102 -- Is_Full_Access_Object --
17103 -----------------------------
17105 function Is_Full_Access_Object
(N
: Node_Id
) return Boolean is
17107 return Is_Atomic_Object
(N
)
17108 or else Is_Volatile_Full_Access_Object_Ref
(N
);
17109 end Is_Full_Access_Object
;
17111 -------------------------------
17112 -- Is_Fully_Initialized_Type --
17113 -------------------------------
17115 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
17119 if Is_Scalar_Type
(Typ
) then
17121 -- A scalar type with an aspect Default_Value is fully initialized
17123 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization
17124 -- of a scalar type, but we don't take that into account here, since
17125 -- we don't want these to affect warnings.
17127 return Has_Default_Aspect
(Typ
);
17129 elsif Is_Access_Type
(Typ
) then
17132 elsif Is_Array_Type
(Typ
) then
17133 if Is_Fully_Initialized_Type
(Component_Type
(Typ
))
17134 or else (Ada_Version
>= Ada_2012
and then Has_Default_Aspect
(Typ
))
17139 -- An interesting case, if we have a constrained type one of whose
17140 -- bounds is known to be null, then there are no elements to be
17141 -- initialized, so all the elements are initialized.
17143 if Is_Constrained
(Typ
) then
17146 Indx_Typ
: Entity_Id
;
17147 Lbd
, Hbd
: Node_Id
;
17150 Indx
:= First_Index
(Typ
);
17151 while Present
(Indx
) loop
17152 if Etype
(Indx
) = Any_Type
then
17155 -- If index is a range, use directly
17157 elsif Nkind
(Indx
) = N_Range
then
17158 Lbd
:= Low_Bound
(Indx
);
17159 Hbd
:= High_Bound
(Indx
);
17162 Indx_Typ
:= Etype
(Indx
);
17164 if Is_Private_Type
(Indx_Typ
) then
17165 Indx_Typ
:= Full_View
(Indx_Typ
);
17168 if No
(Indx_Typ
) or else Etype
(Indx_Typ
) = Any_Type
then
17171 Lbd
:= Type_Low_Bound
(Indx_Typ
);
17172 Hbd
:= Type_High_Bound
(Indx_Typ
);
17176 if Compile_Time_Known_Value
(Lbd
)
17178 Compile_Time_Known_Value
(Hbd
)
17180 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
17190 -- If no null indexes, then type is not fully initialized
17196 elsif Is_Record_Type
(Typ
) then
17197 if Has_Defaulted_Discriminants
(Typ
)
17198 and then Is_Fully_Initialized_Variant
(Typ
)
17203 -- We consider bounded string types to be fully initialized, because
17204 -- otherwise we get false alarms when the Data component is not
17205 -- default-initialized.
17207 if Is_Bounded_String
(Typ
) then
17211 -- Controlled records are considered to be fully initialized if
17212 -- there is a user defined Initialize routine. This may not be
17213 -- entirely correct, but as the spec notes, we are guessing here
17214 -- what is best from the point of view of issuing warnings.
17216 if Is_Controlled
(Typ
) then
17218 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
17221 if Present
(Utyp
) then
17223 Init
: constant Entity_Id
:=
17224 (Find_Optional_Prim_Op
17225 (Underlying_Type
(Typ
), Name_Initialize
));
17229 and then Comes_From_Source
(Init
)
17230 and then not In_Predefined_Unit
(Init
)
17234 elsif Has_Null_Extension
(Typ
)
17236 Is_Fully_Initialized_Type
17237 (Etype
(Base_Type
(Typ
)))
17246 -- Otherwise see if all record components are initialized
17252 Comp
:= First_Component
(Typ
);
17253 while Present
(Comp
) loop
17254 if (No
(Parent
(Comp
))
17255 or else No
(Expression
(Parent
(Comp
))))
17256 and then not Is_Fully_Initialized_Type
(Etype
(Comp
))
17258 -- Special VM case for tag components, which need to be
17259 -- defined in this case, but are never initialized as VMs
17260 -- are using other dispatching mechanisms. Ignore this
17261 -- uninitialized case. Note that this applies both to the
17262 -- uTag entry and the main vtable pointer (CPP_Class case).
17264 and then (Tagged_Type_Expansion
or else not Is_Tag
(Comp
))
17269 Next_Component
(Comp
);
17273 -- No uninitialized components, so type is fully initialized.
17274 -- Note that this catches the case of no components as well.
17278 elsif Is_Concurrent_Type
(Typ
) then
17281 elsif Is_Private_Type
(Typ
) then
17283 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
17289 return Is_Fully_Initialized_Type
(U
);
17296 end Is_Fully_Initialized_Type
;
17298 ----------------------------------
17299 -- Is_Fully_Initialized_Variant --
17300 ----------------------------------
17302 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
17303 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
17304 Constraints
: constant List_Id
:= New_List
;
17305 Components
: constant Elist_Id
:= New_Elmt_List
;
17306 Comp_Elmt
: Elmt_Id
;
17308 Comp_List
: Node_Id
;
17310 Discr_Val
: Node_Id
;
17312 Report_Errors
: Boolean;
17313 pragma Warnings
(Off
, Report_Errors
);
17316 if Serious_Errors_Detected
> 0 then
17320 if Is_Record_Type
(Typ
)
17321 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
17322 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
17324 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
17326 Discr
:= First_Discriminant
(Typ
);
17327 while Present
(Discr
) loop
17328 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
17329 Discr_Val
:= Expression
(Parent
(Discr
));
17331 if Present
(Discr_Val
)
17332 and then Is_OK_Static_Expression
(Discr_Val
)
17334 Append_To
(Constraints
,
17335 Make_Component_Association
(Loc
,
17336 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
17337 Expression
=> New_Copy
(Discr_Val
)));
17345 Next_Discriminant
(Discr
);
17350 Comp_List
=> Comp_List
,
17351 Governed_By
=> Constraints
,
17352 Into
=> Components
,
17353 Report_Errors
=> Report_Errors
);
17355 -- Check that each component present is fully initialized
17357 Comp_Elmt
:= First_Elmt
(Components
);
17358 while Present
(Comp_Elmt
) loop
17359 Comp_Id
:= Node
(Comp_Elmt
);
17361 if Ekind
(Comp_Id
) = E_Component
17362 and then (No
(Parent
(Comp_Id
))
17363 or else No
(Expression
(Parent
(Comp_Id
))))
17364 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
17369 Next_Elmt
(Comp_Elmt
);
17374 elsif Is_Private_Type
(Typ
) then
17376 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
17382 return Is_Fully_Initialized_Variant
(U
);
17389 end Is_Fully_Initialized_Variant
;
17391 ------------------------------------
17392 -- Is_Generic_Declaration_Or_Body --
17393 ------------------------------------
17395 function Is_Generic_Declaration_Or_Body
(Decl
: Node_Id
) return Boolean is
17396 Spec_Decl
: Node_Id
;
17399 -- Package/subprogram body
17401 if Nkind
(Decl
) in N_Package_Body | N_Subprogram_Body
17402 and then Present
(Corresponding_Spec
(Decl
))
17404 Spec_Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(Decl
));
17406 -- Package/subprogram body stub
17408 elsif Nkind
(Decl
) in N_Package_Body_Stub | N_Subprogram_Body_Stub
17409 and then Present
(Corresponding_Spec_Of_Stub
(Decl
))
17412 Unit_Declaration_Node
(Corresponding_Spec_Of_Stub
(Decl
));
17420 -- Rather than inspecting the defining entity of the spec declaration,
17421 -- look at its Nkind. This takes care of the case where the analysis of
17422 -- a generic body modifies the Ekind of its spec to allow for recursive
17425 return Nkind
(Spec_Decl
) in N_Generic_Declaration
;
17426 end Is_Generic_Declaration_Or_Body
;
17428 ---------------------------
17429 -- Is_Independent_Object --
17430 ---------------------------
17432 function Is_Independent_Object
(N
: Node_Id
) return Boolean is
17433 function Is_Independent_Object_Entity
(Id
: Entity_Id
) return Boolean;
17434 -- Determine whether arbitrary entity Id denotes an object that is
17437 function Prefix_Has_Independent_Components
(P
: Node_Id
) return Boolean;
17438 -- Determine whether prefix P has independent components. This requires
17439 -- the presence of an Independent_Components aspect/pragma.
17441 ------------------------------------
17442 -- Is_Independent_Object_Entity --
17443 ------------------------------------
17445 function Is_Independent_Object_Entity
(Id
: Entity_Id
) return Boolean is
17449 and then (Is_Independent
(Id
)
17451 Is_Independent
(Etype
(Id
)));
17452 end Is_Independent_Object_Entity
;
17454 -------------------------------------
17455 -- Prefix_Has_Independent_Components --
17456 -------------------------------------
17458 function Prefix_Has_Independent_Components
(P
: Node_Id
) return Boolean
17460 Typ
: constant Entity_Id
:= Etype
(P
);
17463 if Is_Access_Type
(Typ
) then
17464 return Has_Independent_Components
(Designated_Type
(Typ
));
17466 elsif Has_Independent_Components
(Typ
) then
17469 elsif Is_Entity_Name
(P
)
17470 and then Has_Independent_Components
(Entity
(P
))
17477 end Prefix_Has_Independent_Components
;
17479 -- Start of processing for Is_Independent_Object
17482 if Is_Entity_Name
(N
) then
17483 return Is_Independent_Object_Entity
(Entity
(N
));
17485 elsif Is_Independent
(Etype
(N
)) then
17488 elsif Nkind
(N
) = N_Indexed_Component
then
17489 return Prefix_Has_Independent_Components
(Prefix
(N
));
17491 elsif Nkind
(N
) = N_Selected_Component
then
17492 return Prefix_Has_Independent_Components
(Prefix
(N
))
17493 or else Is_Independent
(Entity
(Selector_Name
(N
)));
17498 end Is_Independent_Object
;
17500 ----------------------------
17501 -- Is_Inherited_Operation --
17502 ----------------------------
17504 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
17505 pragma Assert
(Is_Overloadable
(E
));
17506 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
17508 return Kind
= N_Full_Type_Declaration
17509 or else Kind
= N_Private_Extension_Declaration
17510 or else Kind
= N_Subtype_Declaration
17511 or else (Ekind
(E
) = E_Enumeration_Literal
17512 and then Is_Derived_Type
(Etype
(E
)));
17513 end Is_Inherited_Operation
;
17515 -------------------------------------
17516 -- Is_Inherited_Operation_For_Type --
17517 -------------------------------------
17519 function Is_Inherited_Operation_For_Type
17521 Typ
: Entity_Id
) return Boolean
17524 -- Check that the operation has been created by the type declaration
17526 return Is_Inherited_Operation
(E
)
17527 and then Defining_Identifier
(Parent
(E
)) = Typ
;
17528 end Is_Inherited_Operation_For_Type
;
17530 --------------------------------------
17531 -- Is_Inlinable_Expression_Function --
17532 --------------------------------------
17534 function Is_Inlinable_Expression_Function
17535 (Subp
: Entity_Id
) return Boolean
17537 Return_Expr
: Node_Id
;
17540 if Is_Expression_Function_Or_Completion
(Subp
)
17541 and then Has_Pragma_Inline_Always
(Subp
)
17542 and then Needs_No_Actuals
(Subp
)
17543 and then No
(Contract
(Subp
))
17544 and then not Is_Dispatching_Operation
(Subp
)
17545 and then Needs_Finalization
(Etype
(Subp
))
17546 and then not Is_Class_Wide_Type
(Etype
(Subp
))
17547 and then not Has_Invariants
(Etype
(Subp
))
17548 and then Present
(Subprogram_Body
(Subp
))
17549 and then Was_Expression_Function
(Subprogram_Body
(Subp
))
17551 Return_Expr
:= Expression_Of_Expression_Function
(Subp
);
17553 -- The returned object must not have a qualified expression and its
17554 -- nominal subtype must be statically compatible with the result
17555 -- subtype of the expression function.
17558 Nkind
(Return_Expr
) = N_Identifier
17559 and then Etype
(Return_Expr
) = Etype
(Subp
);
17563 end Is_Inlinable_Expression_Function
;
17569 function Is_Iterator
(Typ
: Entity_Id
) return Boolean is
17570 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean;
17571 -- Determine whether type Iter_Typ is a predefined forward or reversible
17574 ----------------------
17575 -- Denotes_Iterator --
17576 ----------------------
17578 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean is
17580 -- Check that the name matches, and that the ultimate ancestor is in
17581 -- a predefined unit, i.e the one that declares iterator interfaces.
17584 Chars
(Iter_Typ
) in Name_Forward_Iterator | Name_Reversible_Iterator
17585 and then In_Predefined_Unit
(Root_Type
(Iter_Typ
));
17586 end Denotes_Iterator
;
17590 Iface_Elmt
: Elmt_Id
;
17593 -- Start of processing for Is_Iterator
17596 -- The type may be a subtype of a descendant of the proper instance of
17597 -- the predefined interface type, so we must use the root type of the
17598 -- given type. The same is done for Is_Reversible_Iterator.
17600 if Is_Class_Wide_Type
(Typ
)
17601 and then Denotes_Iterator
(Root_Type
(Typ
))
17605 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
17608 elsif Present
(Find_Value_Of_Aspect
(Typ
, Aspect_Iterable
)) then
17612 Collect_Interfaces
(Typ
, Ifaces
);
17614 Iface_Elmt
:= First_Elmt
(Ifaces
);
17615 while Present
(Iface_Elmt
) loop
17616 if Denotes_Iterator
(Node
(Iface_Elmt
)) then
17620 Next_Elmt
(Iface_Elmt
);
17627 ----------------------------
17628 -- Is_Iterator_Over_Array --
17629 ----------------------------
17631 function Is_Iterator_Over_Array
(N
: Node_Id
) return Boolean is
17632 Container
: constant Node_Id
:= Name
(N
);
17633 Container_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Container
));
17635 return Is_Array_Type
(Container_Typ
);
17636 end Is_Iterator_Over_Array
;
17638 --------------------------
17639 -- Known_To_Be_Assigned --
17640 --------------------------
17642 function Known_To_Be_Assigned
17644 Only_LHS
: Boolean := False) return Boolean
17646 function Known_Assn
(N
: Node_Id
) return Boolean is
17647 (Known_To_Be_Assigned
(N
, Only_LHS
));
17648 -- Local function to simplify the passing of parameters for recursive
17651 P
: constant Node_Id
:= Parent
(N
);
17652 Form
: Entity_Id
:= Empty
;
17653 Call
: Node_Id
:= Empty
;
17655 -- Start of processing for Known_To_Be_Assigned
17658 -- Check for out parameters
17660 Find_Actual
(N
, Form
, Call
);
17662 if Present
(Form
) then
17663 return Ekind
(Form
) /= E_In_Parameter
and then not Only_LHS
;
17666 -- Otherwise look at the parent
17670 -- Test left side of assignment
17672 when N_Assignment_Statement
=>
17673 return N
= Name
(P
);
17675 -- Test prefix of component or attribute. Note that the prefix of an
17676 -- explicit or implicit dereference cannot be an l-value. In the case
17677 -- of a 'Read attribute, the reference can be an actual in the
17678 -- argument list of the attribute.
17680 when N_Attribute_Reference
=>
17682 not Only_LHS
and then
17684 and then Name_Implies_Lvalue_Prefix
(Attribute_Name
(P
)))
17686 Attribute_Name
(P
) = Name_Read
);
17688 -- For an expanded name, the name is an lvalue if the expanded name
17689 -- is an lvalue, but the prefix is never an lvalue, since it is just
17690 -- the scope where the name is found.
17692 when N_Expanded_Name
=>
17693 if N
= Prefix
(P
) then
17694 return Known_Assn
(P
);
17699 -- For a selected component A.B, A is certainly an lvalue if A.B is.
17700 -- B is a little interesting, if we have A.B := 3, there is some
17701 -- discussion as to whether B is an lvalue or not, we choose to say
17702 -- it is. Note however that A is not an lvalue if it is of an access
17703 -- type since this is an implicit dereference.
17705 when N_Selected_Component
=>
17707 and then Present
(Etype
(N
))
17708 and then Is_Access_Type
(Etype
(N
))
17712 return Known_Assn
(P
);
17715 -- For an indexed component or slice, the index or slice bounds is
17716 -- never an lvalue. The prefix is an lvalue if the indexed component
17717 -- or slice is an lvalue, except if it is an access type, where we
17718 -- have an implicit dereference.
17720 when N_Indexed_Component | N_Slice
=>
17722 or else (Present
(Etype
(N
)) and then Is_Access_Type
(Etype
(N
)))
17726 return Known_Assn
(P
);
17729 -- Prefix of a reference is an lvalue if the reference is an lvalue
17731 when N_Reference
=>
17732 return Known_Assn
(P
);
17734 -- Prefix of explicit dereference is never an lvalue
17736 when N_Explicit_Dereference
=>
17739 -- Test for appearing in a conversion that itself appears in an
17740 -- lvalue context, since this should be an lvalue.
17742 when N_Type_Conversion
=>
17743 return Known_Assn
(P
);
17745 -- Test for appearance in object renaming declaration
17747 when N_Object_Renaming_Declaration
=>
17748 return not Only_LHS
;
17750 -- All other references are definitely not lvalues
17755 end Known_To_Be_Assigned
;
17757 -----------------------------
17758 -- Is_Library_Level_Entity --
17759 -----------------------------
17761 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
17763 -- The following is a small optimization, and it also properly handles
17764 -- discriminals, which in task bodies might appear in expressions before
17765 -- the corresponding procedure has been created, and which therefore do
17766 -- not have an assigned scope.
17768 if Is_Formal
(E
) then
17771 -- If we somehow got an empty value for Scope, the tree must be
17772 -- malformed. Rather than blow up we return True in this case.
17774 elsif No
(Scope
(E
)) then
17777 -- Handle loops since Enclosing_Dynamic_Scope skips them; required to
17778 -- properly handle entities local to quantified expressions in library
17779 -- level specifications.
17781 elsif Ekind
(Scope
(E
)) = E_Loop
then
17785 -- Normal test is simply that the enclosing dynamic scope is Standard
17787 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
17788 end Is_Library_Level_Entity
;
17790 --------------------------------
17791 -- Is_Limited_Class_Wide_Type --
17792 --------------------------------
17794 function Is_Limited_Class_Wide_Type
(Typ
: Entity_Id
) return Boolean is
17797 Is_Class_Wide_Type
(Typ
)
17798 and then (Is_Limited_Type
(Typ
) or else From_Limited_With
(Typ
));
17799 end Is_Limited_Class_Wide_Type
;
17801 ---------------------------------
17802 -- Is_Local_Variable_Reference --
17803 ---------------------------------
17805 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
17807 if not Is_Entity_Name
(Expr
) then
17812 Ent
: constant Entity_Id
:= Entity
(Expr
);
17813 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
17816 not in E_Variable | E_In_Out_Parameter | E_Out_Parameter
17820 return Present
(Sub
) and then Sub
= Current_Subprogram
;
17824 end Is_Local_Variable_Reference
;
17830 function Is_Master
(N
: Node_Id
) return Boolean is
17831 Disable_Subexpression_Masters
: constant Boolean := True;
17834 if Nkind
(N
) in N_Subprogram_Body | N_Task_Body | N_Entry_Body
17835 or else Is_Statement
(N
)
17840 -- We avoid returning True when the master is a subexpression described
17841 -- in RM 7.6.1(3/2) for the proposes of accessibility level calculation
17842 -- in Accessibility_Level_Helper.Innermost_Master_Scope_Depth ???
17844 if not Disable_Subexpression_Masters
17845 and then Nkind
(N
) in N_Subexpr
17848 Par
: Node_Id
:= N
;
17850 subtype N_Simple_Statement_Other_Than_Simple_Return
17851 is Node_Kind
with Static_Predicate
=>
17852 N_Simple_Statement_Other_Than_Simple_Return
17853 in N_Abort_Statement
17854 | N_Assignment_Statement
17856 | N_Delay_Statement
17857 | N_Entry_Call_Statement
17861 | N_Raise_Statement
17862 | N_Requeue_Statement
17864 | N_Procedure_Call_Statement
;
17866 while Present
(Par
) loop
17867 Par
:= Parent
(Par
);
17868 if Nkind
(Par
) in N_Subexpr |
17869 N_Simple_Statement_Other_Than_Simple_Return
17882 -----------------------
17883 -- Is_Name_Reference --
17884 -----------------------
17886 function Is_Name_Reference
(N
: Node_Id
) return Boolean is
17888 if Is_Entity_Name
(N
) then
17889 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
));
17893 when N_Indexed_Component
17897 Is_Name_Reference
(Prefix
(N
))
17898 or else Is_Access_Type
(Etype
(Prefix
(N
)));
17900 -- Attributes 'Input, 'Old and 'Result produce objects
17902 when N_Attribute_Reference
=>
17903 return Attribute_Name
(N
) in Name_Input | Name_Old | Name_Result
;
17905 when N_Selected_Component
=>
17907 Is_Name_Reference
(Selector_Name
(N
))
17909 (Is_Name_Reference
(Prefix
(N
))
17910 or else Is_Access_Type
(Etype
(Prefix
(N
))));
17912 when N_Explicit_Dereference
=>
17915 -- A view conversion of a tagged name is a name reference
17917 when N_Type_Conversion
=>
17919 Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
17920 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
17921 and then Is_Name_Reference
(Expression
(N
));
17923 -- An unchecked type conversion is considered to be a name if the
17924 -- operand is a name (this construction arises only as a result of
17925 -- expansion activities).
17927 when N_Unchecked_Type_Conversion
=>
17928 return Is_Name_Reference
(Expression
(N
));
17933 end Is_Name_Reference
;
17935 --------------------------
17936 -- Is_Newly_Constructed --
17937 --------------------------
17939 function Is_Newly_Constructed
17940 (Exp
: Node_Id
; Context_Requires_NC
: Boolean) return Boolean
17942 Original_Exp
: constant Node_Id
:= Original_Node
(Exp
);
17944 function Is_NC
(Exp
: Node_Id
) return Boolean is
17945 (Is_Newly_Constructed
(Exp
, Context_Requires_NC
));
17947 -- If the context requires that the expression shall be newly
17948 -- constructed, then "True" is a good result in the sense that the
17949 -- expression satisfies the requirements of the context (and "False"
17950 -- is analogously a bad result). If the context requires that the
17951 -- expression shall *not* be newly constructed, then things are
17952 -- reversed: "False" is the good value and "True" is the bad value.
17954 Good_Result
: constant Boolean := Context_Requires_NC
;
17955 Bad_Result
: constant Boolean := not Good_Result
;
17957 case Nkind
(Original_Exp
) is
17959 | N_Extension_Aggregate
17965 when N_Identifier
=>
17966 return Present
(Entity
(Original_Exp
))
17967 and then Ekind
(Entity
(Original_Exp
)) = E_Function
;
17969 when N_Qualified_Expression
=>
17970 return Is_NC
(Expression
(Original_Exp
));
17972 when N_Type_Conversion
17973 | N_Unchecked_Type_Conversion
17975 if Is_View_Conversion
(Original_Exp
) then
17976 return Is_NC
(Expression
(Original_Exp
));
17977 elsif not Comes_From_Source
(Exp
) then
17978 if Exp
/= Original_Exp
then
17979 return Is_NC
(Original_Exp
);
17981 return Is_NC
(Expression
(Original_Exp
));
17987 when N_Explicit_Dereference
17988 | N_Indexed_Component
17989 | N_Selected_Component
17991 return Nkind
(Exp
) = N_Function_Call
;
17993 -- A use of 'Input is a function call, hence allowed. Normally the
17994 -- attribute will be changed to a call, but the attribute by itself
17995 -- can occur with -gnatc.
17997 when N_Attribute_Reference
=>
17998 return Attribute_Name
(Original_Exp
) = Name_Input
;
18000 -- "return raise ..." is OK
18002 when N_Raise_Expression
=>
18003 return Good_Result
;
18005 -- For a case expression, all dependent expressions must be legal
18007 when N_Case_Expression
=>
18012 Alt
:= First
(Alternatives
(Original_Exp
));
18013 while Present
(Alt
) loop
18014 if Is_NC
(Expression
(Alt
)) = Bad_Result
then
18021 return Good_Result
;
18024 -- For an if expression, all dependent expressions must be legal
18026 when N_If_Expression
=>
18028 Then_Expr
: constant Node_Id
:=
18029 Next
(First
(Expressions
(Original_Exp
)));
18030 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
18032 if (Is_NC
(Then_Expr
) = Bad_Result
)
18033 or else (Is_NC
(Else_Expr
) = Bad_Result
)
18037 return Good_Result
;
18044 end Is_Newly_Constructed
;
18046 ------------------------------------
18047 -- Is_Non_Preelaborable_Construct --
18048 ------------------------------------
18050 function Is_Non_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
18052 -- NOTE: the routines within Is_Non_Preelaborable_Construct are
18053 -- intentionally unnested to avoid deep indentation of code.
18055 Non_Preelaborable
: exception;
18056 -- This exception is raised when the construct violates preelaborability
18057 -- to terminate the recursion.
18059 procedure Visit
(Nod
: Node_Id
);
18060 -- Semantically inspect construct Nod to determine whether it violates
18061 -- preelaborability. This routine raises Non_Preelaborable.
18063 procedure Visit_List
(List
: List_Id
);
18064 pragma Inline
(Visit_List
);
18065 -- Invoke Visit on each element of list List. This routine raises
18066 -- Non_Preelaborable.
18068 procedure Visit_Pragma
(Prag
: Node_Id
);
18069 pragma Inline
(Visit_Pragma
);
18070 -- Semantically inspect pragma Prag to determine whether it violates
18071 -- preelaborability. This routine raises Non_Preelaborable.
18073 procedure Visit_Subexpression
(Expr
: Node_Id
);
18074 pragma Inline
(Visit_Subexpression
);
18075 -- Semantically inspect expression Expr to determine whether it violates
18076 -- preelaborability. This routine raises Non_Preelaborable.
18082 procedure Visit
(Nod
: Node_Id
) is
18084 case Nkind
(Nod
) is
18088 when N_Component_Declaration
=>
18090 -- Defining_Identifier is left out because it is not relevant
18091 -- for preelaborability.
18093 Visit
(Component_Definition
(Nod
));
18094 Visit
(Expression
(Nod
));
18096 when N_Derived_Type_Definition
=>
18098 -- Interface_List is left out because it is not relevant for
18099 -- preelaborability.
18101 Visit
(Record_Extension_Part
(Nod
));
18102 Visit
(Subtype_Indication
(Nod
));
18104 when N_Entry_Declaration
=>
18106 -- A protected type with at leat one entry is not preelaborable
18107 -- while task types are never preelaborable. This renders entry
18108 -- declarations non-preelaborable.
18110 raise Non_Preelaborable
;
18112 when N_Full_Type_Declaration
=>
18114 -- Defining_Identifier and Discriminant_Specifications are left
18115 -- out because they are not relevant for preelaborability.
18117 Visit
(Type_Definition
(Nod
));
18119 when N_Function_Instantiation
18120 | N_Package_Instantiation
18121 | N_Procedure_Instantiation
18123 -- Defining_Unit_Name and Name are left out because they are
18124 -- not relevant for preelaborability.
18126 Visit_List
(Generic_Associations
(Nod
));
18128 when N_Object_Declaration
=>
18130 -- Defining_Identifier is left out because it is not relevant
18131 -- for preelaborability.
18133 Visit
(Object_Definition
(Nod
));
18135 if Has_Init_Expression
(Nod
) then
18136 Visit
(Expression
(Nod
));
18138 elsif not Constant_Present
(Nod
)
18139 and then not Has_Preelaborable_Initialization
18140 (Etype
(Defining_Entity
(Nod
)))
18142 raise Non_Preelaborable
;
18145 when N_Private_Extension_Declaration
18146 | N_Subtype_Declaration
18148 -- Defining_Identifier, Discriminant_Specifications, and
18149 -- Interface_List are left out because they are not relevant
18150 -- for preelaborability.
18152 Visit
(Subtype_Indication
(Nod
));
18154 when N_Protected_Type_Declaration
18155 | N_Single_Protected_Declaration
18157 -- Defining_Identifier, Discriminant_Specifications, and
18158 -- Interface_List are left out because they are not relevant
18159 -- for preelaborability.
18161 Visit
(Protected_Definition
(Nod
));
18163 -- A [single] task type is never preelaborable
18165 when N_Single_Task_Declaration
18166 | N_Task_Type_Declaration
18168 raise Non_Preelaborable
;
18173 Visit_Pragma
(Nod
);
18177 when N_Statement_Other_Than_Procedure_Call
=>
18178 if Nkind
(Nod
) /= N_Null_Statement
then
18179 raise Non_Preelaborable
;
18185 Visit_Subexpression
(Nod
);
18189 when N_Access_To_Object_Definition
=>
18190 Visit
(Subtype_Indication
(Nod
));
18192 when N_Case_Expression_Alternative
=>
18193 Visit
(Expression
(Nod
));
18194 Visit_List
(Discrete_Choices
(Nod
));
18196 when N_Component_Definition
=>
18197 Visit
(Access_Definition
(Nod
));
18198 Visit
(Subtype_Indication
(Nod
));
18200 when N_Component_List
=>
18201 Visit_List
(Component_Items
(Nod
));
18202 Visit
(Variant_Part
(Nod
));
18204 when N_Constrained_Array_Definition
=>
18205 Visit_List
(Discrete_Subtype_Definitions
(Nod
));
18206 Visit
(Component_Definition
(Nod
));
18208 when N_Delta_Constraint
18209 | N_Digits_Constraint
18211 -- Delta_Expression and Digits_Expression are left out because
18212 -- they are not relevant for preelaborability.
18214 Visit
(Range_Constraint
(Nod
));
18216 when N_Discriminant_Specification
=>
18218 -- Defining_Identifier and Expression are left out because they
18219 -- are not relevant for preelaborability.
18221 Visit
(Discriminant_Type
(Nod
));
18223 when N_Generic_Association
=>
18225 -- Selector_Name is left out because it is not relevant for
18226 -- preelaborability.
18228 Visit
(Explicit_Generic_Actual_Parameter
(Nod
));
18230 when N_Index_Or_Discriminant_Constraint
=>
18231 Visit_List
(Constraints
(Nod
));
18233 when N_Iterator_Specification
=>
18235 -- Defining_Identifier is left out because it is not relevant
18236 -- for preelaborability.
18238 Visit
(Name
(Nod
));
18239 Visit
(Subtype_Indication
(Nod
));
18241 when N_Loop_Parameter_Specification
=>
18243 -- Defining_Identifier is left out because it is not relevant
18244 -- for preelaborability.
18246 Visit
(Discrete_Subtype_Definition
(Nod
));
18248 when N_Parameter_Association
=>
18249 Visit
(Explicit_Actual_Parameter
(N
));
18251 when N_Protected_Definition
=>
18253 -- End_Label is left out because it is not relevant for
18254 -- preelaborability.
18256 Visit_List
(Private_Declarations
(Nod
));
18257 Visit_List
(Visible_Declarations
(Nod
));
18259 when N_Range_Constraint
=>
18260 Visit
(Range_Expression
(Nod
));
18262 when N_Record_Definition
18265 -- End_Label, Discrete_Choices, and Interface_List are left out
18266 -- because they are not relevant for preelaborability.
18268 Visit
(Component_List
(Nod
));
18270 when N_Subtype_Indication
=>
18272 -- Subtype_Mark is left out because it is not relevant for
18273 -- preelaborability.
18275 Visit
(Constraint
(Nod
));
18277 when N_Unconstrained_Array_Definition
=>
18279 -- Subtype_Marks is left out because it is not relevant for
18280 -- preelaborability.
18282 Visit
(Component_Definition
(Nod
));
18284 when N_Variant_Part
=>
18286 -- Name is left out because it is not relevant for
18287 -- preelaborability.
18289 Visit_List
(Variants
(Nod
));
18302 procedure Visit_List
(List
: List_Id
) is
18306 Nod
:= First
(List
);
18307 while Present
(Nod
) loop
18317 procedure Visit_Pragma
(Prag
: Node_Id
) is
18319 case Get_Pragma_Id
(Prag
) is
18321 | Pragma_Assert_And_Cut
18323 | Pragma_Async_Readers
18324 | Pragma_Async_Writers
18325 | Pragma_Attribute_Definition
18327 | Pragma_Constant_After_Elaboration
18329 | Pragma_Deadline_Floor
18330 | Pragma_Dispatching_Domain
18331 | Pragma_Effective_Reads
18332 | Pragma_Effective_Writes
18333 | Pragma_Extensions_Visible
18335 | Pragma_Secondary_Stack_Size
18337 | Pragma_Volatile_Function
18339 Visit_List
(Pragma_Argument_Associations
(Prag
));
18348 -------------------------
18349 -- Visit_Subexpression --
18350 -------------------------
18352 procedure Visit_Subexpression
(Expr
: Node_Id
) is
18353 procedure Visit_Aggregate
(Aggr
: Node_Id
);
18354 pragma Inline
(Visit_Aggregate
);
18355 -- Semantically inspect aggregate Aggr to determine whether it
18356 -- violates preelaborability.
18358 ---------------------
18359 -- Visit_Aggregate --
18360 ---------------------
18362 procedure Visit_Aggregate
(Aggr
: Node_Id
) is
18364 if not Is_Preelaborable_Aggregate
(Aggr
) then
18365 raise Non_Preelaborable
;
18367 end Visit_Aggregate
;
18369 -- Start of processing for Visit_Subexpression
18372 case Nkind
(Expr
) is
18374 | N_Qualified_Expression
18375 | N_Type_Conversion
18376 | N_Unchecked_Expression
18377 | N_Unchecked_Type_Conversion
18379 -- Subpool_Handle_Name and Subtype_Mark are left out because
18380 -- they are not relevant for preelaborability.
18382 Visit
(Expression
(Expr
));
18385 | N_Extension_Aggregate
18387 Visit_Aggregate
(Expr
);
18389 when N_Attribute_Reference
18390 | N_Explicit_Dereference
18393 -- Attribute_Name and Expressions are left out because they are
18394 -- not relevant for preelaborability.
18396 Visit
(Prefix
(Expr
));
18398 when N_Case_Expression
=>
18400 -- End_Span is left out because it is not relevant for
18401 -- preelaborability.
18403 Visit_List
(Alternatives
(Expr
));
18404 Visit
(Expression
(Expr
));
18406 when N_Delta_Aggregate
=>
18407 Visit_Aggregate
(Expr
);
18408 Visit
(Expression
(Expr
));
18410 when N_Expression_With_Actions
=>
18411 Visit_List
(Actions
(Expr
));
18412 Visit
(Expression
(Expr
));
18414 when N_Function_Call
=>
18416 -- Ada 2022 (AI12-0175): Calls to certain functions that are
18417 -- essentially unchecked conversions are preelaborable.
18419 if Ada_Version
>= Ada_2022
18420 and then Nkind
(Expr
) = N_Function_Call
18421 and then Is_Entity_Name
(Name
(Expr
))
18422 and then Is_Preelaborable_Function
(Entity
(Name
(Expr
)))
18424 Visit_List
(Parameter_Associations
(Expr
));
18426 raise Non_Preelaborable
;
18429 when N_If_Expression
=>
18430 Visit_List
(Expressions
(Expr
));
18432 when N_Quantified_Expression
=>
18433 Visit
(Condition
(Expr
));
18434 Visit
(Iterator_Specification
(Expr
));
18435 Visit
(Loop_Parameter_Specification
(Expr
));
18438 Visit
(High_Bound
(Expr
));
18439 Visit
(Low_Bound
(Expr
));
18442 Visit
(Discrete_Range
(Expr
));
18443 Visit
(Prefix
(Expr
));
18449 -- The evaluation of an object name is not preelaborable,
18450 -- unless the name is a static expression (checked further
18451 -- below), or statically denotes a discriminant.
18453 if Is_Entity_Name
(Expr
) then
18454 Object_Name
: declare
18455 Id
: constant Entity_Id
:= Entity
(Expr
);
18458 if Is_Object
(Id
) then
18459 if Ekind
(Id
) = E_Discriminant
then
18462 elsif Ekind
(Id
) in E_Constant | E_In_Parameter
18463 and then Present
(Discriminal_Link
(Id
))
18468 raise Non_Preelaborable
;
18473 -- A non-static expression is not preelaborable
18475 elsif not Is_OK_Static_Expression
(Expr
) then
18476 raise Non_Preelaborable
;
18479 end Visit_Subexpression
;
18481 -- Start of processing for Is_Non_Preelaborable_Construct
18486 -- At this point it is known that the construct is preelaborable
18492 -- The elaboration of the construct performs an action which violates
18493 -- preelaborability.
18495 when Non_Preelaborable
=>
18497 end Is_Non_Preelaborable_Construct
;
18499 ---------------------------------
18500 -- Is_Nontrivial_DIC_Procedure --
18501 ---------------------------------
18503 function Is_Nontrivial_DIC_Procedure
(Id
: Entity_Id
) return Boolean is
18504 Body_Decl
: Node_Id
;
18508 if Ekind
(Id
) = E_Procedure
and then Is_DIC_Procedure
(Id
) then
18510 Unit_Declaration_Node
18511 (Corresponding_Body
(Unit_Declaration_Node
(Id
)));
18513 -- The body of the Default_Initial_Condition procedure must contain
18514 -- at least one statement, otherwise the generation of the subprogram
18517 pragma Assert
(Present
(Handled_Statement_Sequence
(Body_Decl
)));
18519 -- To qualify as nontrivial, the first statement of the procedure
18520 -- must be a check in the form of an if statement. If the original
18521 -- Default_Initial_Condition expression was folded, then the first
18522 -- statement is not a check.
18524 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Body_Decl
)));
18527 Nkind
(Stmt
) = N_If_Statement
18528 and then Nkind
(Original_Node
(Stmt
)) = N_Pragma
;
18532 end Is_Nontrivial_DIC_Procedure
;
18534 -----------------------
18535 -- Is_Null_Extension --
18536 -----------------------
18538 function Is_Null_Extension
18539 (T
: Entity_Id
; Ignore_Privacy
: Boolean := False) return Boolean
18541 Type_Decl
: Node_Id
;
18542 Type_Def
: Node_Id
;
18544 pragma Assert
(not Is_Class_Wide_Type
(T
));
18546 if Ignore_Privacy
then
18547 Type_Decl
:= Parent
(Underlying_Type
(Base_Type
(T
)));
18549 Type_Decl
:= Parent
(Base_Type
(T
));
18550 if Nkind
(Type_Decl
) /= N_Full_Type_Declaration
then
18554 pragma Assert
(Nkind
(Type_Decl
) = N_Full_Type_Declaration
);
18555 Type_Def
:= Type_Definition
(Type_Decl
);
18556 if Present
(Discriminant_Specifications
(Type_Decl
))
18557 or else Nkind
(Type_Def
) /= N_Derived_Type_Definition
18558 or else not Is_Tagged_Type
(T
)
18559 or else No
(Record_Extension_Part
(Type_Def
))
18564 return Is_Null_Record_Definition
(Record_Extension_Part
(Type_Def
));
18565 end Is_Null_Extension
;
18567 --------------------------
18568 -- Is_Null_Extension_Of --
18569 --------------------------
18571 function Is_Null_Extension_Of
18572 (Descendant
, Ancestor
: Entity_Id
) return Boolean
18574 Ancestor_Type
: constant Entity_Id
18575 := Underlying_Type
(Base_Type
(Ancestor
));
18576 Descendant_Type
: Entity_Id
:= Underlying_Type
(Base_Type
(Descendant
));
18578 pragma Assert
(not Is_Class_Wide_Type
(Descendant
));
18579 pragma Assert
(not Is_Class_Wide_Type
(Ancestor
));
18580 pragma Assert
(Descendant_Type
/= Ancestor_Type
);
18582 while Descendant_Type
/= Ancestor_Type
loop
18583 if not Is_Null_Extension
18584 (Descendant_Type
, Ignore_Privacy
=> True)
18588 Descendant_Type
:= Etype
(Subtype_Indication
18589 (Type_Definition
(Parent
(Descendant_Type
))));
18590 Descendant_Type
:= Underlying_Type
(Base_Type
(Descendant_Type
));
18593 end Is_Null_Extension_Of
;
18595 -------------------------------
18596 -- Is_Null_Record_Definition --
18597 -------------------------------
18599 function Is_Null_Record_Definition
(Record_Def
: Node_Id
) return Boolean is
18602 -- Testing Null_Present is just an optimization, not required.
18604 if Null_Present
(Record_Def
) then
18606 elsif Present
(Variant_Part
(Component_List
(Record_Def
))) then
18608 elsif No
(Component_List
(Record_Def
)) then
18612 Item
:= First
(Component_Items
(Component_List
(Record_Def
)));
18614 while Present
(Item
) loop
18615 if Nkind
(Item
) = N_Component_Declaration
18616 and then Is_Internal_Name
(Chars
(Defining_Identifier
(Item
)))
18619 elsif Nkind
(Item
) = N_Pragma
then
18624 Item
:= Next
(Item
);
18628 end Is_Null_Record_Definition
;
18630 -------------------------
18631 -- Is_Null_Record_Type --
18632 -------------------------
18634 function Is_Null_Record_Type
18635 (T
: Entity_Id
; Ignore_Privacy
: Boolean := False) return Boolean
18638 Type_Def
: Node_Id
;
18640 if not Is_Record_Type
(T
) then
18644 if Ignore_Privacy
then
18645 Decl
:= Parent
(Underlying_Type
(Base_Type
(T
)));
18647 Decl
:= Parent
(Base_Type
(T
));
18648 if Nkind
(Decl
) /= N_Full_Type_Declaration
then
18652 pragma Assert
(Nkind
(Decl
) = N_Full_Type_Declaration
);
18653 Type_Def
:= Type_Definition
(Decl
);
18655 if Has_Discriminants
(Defining_Identifier
(Decl
)) then
18659 case Nkind
(Type_Def
) is
18660 when N_Record_Definition
=>
18661 return Is_Null_Record_Definition
(Type_Def
);
18662 when N_Derived_Type_Definition
=>
18663 if not Is_Null_Record_Type
18664 (Etype
(Subtype_Indication
(Type_Def
)),
18665 Ignore_Privacy
=> Ignore_Privacy
)
18668 elsif not Is_Tagged_Type
(T
) then
18671 return Is_Null_Extension
(T
, Ignore_Privacy
=> Ignore_Privacy
);
18676 end Is_Null_Record_Type
;
18678 ---------------------
18679 -- Is_Object_Image --
18680 ---------------------
18682 function Is_Object_Image
(Prefix
: Node_Id
) return Boolean is
18684 -- Here we test for the case that the prefix is not a type and assume
18685 -- if it is not then it must be a named value or an object reference.
18686 -- This is because the parser always checks that prefixes of attributes
18689 return not (Is_Entity_Name
(Prefix
)
18690 and then Is_Type
(Entity
(Prefix
))
18691 and then not Is_Current_Instance
(Prefix
));
18692 end Is_Object_Image
;
18694 -------------------------
18695 -- Is_Object_Reference --
18696 -------------------------
18698 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
18699 function Safe_Prefix
(N
: Node_Id
) return Node_Id
;
18700 -- Return Prefix (N) unless it has been rewritten as an
18701 -- N_Raise_xxx_Error node, in which case return its original node.
18707 function Safe_Prefix
(N
: Node_Id
) return Node_Id
is
18709 if Nkind
(Prefix
(N
)) in N_Raise_xxx_Error
then
18710 return Original_Node
(Prefix
(N
));
18717 -- AI12-0068: Note that a current instance reference in a type or
18718 -- subtype's aspect_specification is considered a value, not an object
18719 -- (see RM 8.6(18/5)).
18721 if Is_Entity_Name
(N
) then
18722 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
))
18723 and then not Is_Current_Instance_Reference_In_Type_Aspect
(N
);
18727 when N_Indexed_Component
18731 Is_Object_Reference
(Safe_Prefix
(N
))
18732 or else Is_Access_Type
(Etype
(Safe_Prefix
(N
)));
18734 -- In Ada 95, a function call is a constant object; a procedure
18737 -- Note that predefined operators are functions as well, and so
18738 -- are attributes that are (can be renamed as) functions.
18740 when N_Function_Call
18743 return Etype
(N
) /= Standard_Void_Type
;
18745 -- Attributes references 'Loop_Entry, 'Old, 'Priority and 'Result
18746 -- yield objects, even though they are not functions.
18748 when N_Attribute_Reference
=>
18750 Attribute_Name
(N
) in Name_Loop_Entry
18754 or else Is_Function_Attribute_Name
(Attribute_Name
(N
));
18756 when N_Selected_Component
=>
18758 Is_Object_Reference
(Selector_Name
(N
))
18760 (Is_Object_Reference
(Safe_Prefix
(N
))
18761 or else Is_Access_Type
(Etype
(Safe_Prefix
(N
))));
18763 -- An explicit dereference denotes an object, except that a
18764 -- conditional expression gets turned into an explicit dereference
18765 -- in some cases, and conditional expressions are not object
18768 when N_Explicit_Dereference
=>
18769 return Nkind
(Original_Node
(N
)) not in
18770 N_Case_Expression | N_If_Expression
;
18772 -- A view conversion of a tagged object is an object reference
18774 when N_Type_Conversion
=>
18775 if Ada_Version
<= Ada_2012
then
18776 -- A view conversion of a tagged object is an object
18778 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
18779 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
18780 and then Is_Object_Reference
(Expression
(N
));
18783 -- AI12-0226: In Ada 2022 a value conversion of an object is
18786 return Is_Object_Reference
(Expression
(N
));
18789 -- An unchecked type conversion is considered to be an object if
18790 -- the operand is an object (this construction arises only as a
18791 -- result of expansion activities).
18793 when N_Unchecked_Type_Conversion
=>
18796 -- AI05-0003: In Ada 2012 a qualified expression is a name.
18797 -- This allows disambiguation of function calls and the use
18798 -- of aggregates in more contexts.
18800 when N_Qualified_Expression
=>
18801 return Ada_Version
>= Ada_2012
18802 and then Is_Object_Reference
(Expression
(N
));
18804 -- In Ada 95 an aggregate is an object reference
18807 | N_Delta_Aggregate
18808 | N_Extension_Aggregate
18810 return Ada_Version
>= Ada_95
;
18812 -- A string literal is not an object reference, but it might come
18813 -- from rewriting of an object reference, e.g. from folding of an
18816 when N_String_Literal
=>
18817 return Is_Rewrite_Substitution
(N
)
18818 and then Is_Object_Reference
(Original_Node
(N
));
18820 -- AI12-0125: Target name represents a constant object
18822 when N_Target_Name
=>
18829 end Is_Object_Reference
;
18831 -----------------------------------
18832 -- Is_OK_Variable_For_Out_Formal --
18833 -----------------------------------
18835 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
18837 Note_Possible_Modification
(AV
, Sure
=> True);
18839 -- We must reject parenthesized variable names. Comes_From_Source is
18840 -- checked because there are currently cases where the compiler violates
18841 -- this rule (e.g. passing a task object to its controlled Initialize
18842 -- routine). This should be properly documented in sinfo???
18844 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
18847 -- A variable is always allowed
18849 elsif Is_Variable
(AV
) then
18852 -- Generalized indexing operations are rewritten as explicit
18853 -- dereferences, and it is only during resolution that we can
18854 -- check whether the context requires an access_to_variable type.
18856 elsif Nkind
(AV
) = N_Explicit_Dereference
18857 and then Present
(Etype
(Original_Node
(AV
)))
18858 and then Has_Implicit_Dereference
(Etype
(Original_Node
(AV
)))
18859 and then Ada_Version
>= Ada_2012
18861 return not Is_Access_Constant
(Etype
(Prefix
(AV
)));
18863 -- Unchecked conversions are allowed only if they come from the
18864 -- generated code, which sometimes uses unchecked conversions for out
18865 -- parameters in cases where code generation is unaffected. We tell
18866 -- source unchecked conversions by seeing if they are rewrites of
18867 -- an original Unchecked_Conversion function call, or of an explicit
18868 -- conversion of a function call or an aggregate (as may happen in the
18869 -- expansion of a packed array aggregate).
18871 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
18872 if Nkind
(Original_Node
(AV
)) in N_Function_Call | N_Aggregate
then
18875 elsif Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
then
18878 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
18879 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
18885 -- Normal type conversions are allowed if argument is a variable
18887 elsif Nkind
(AV
) = N_Type_Conversion
then
18888 if Is_Variable
(Expression
(AV
))
18889 and then Paren_Count
(Expression
(AV
)) = 0
18891 Note_Possible_Modification
(Expression
(AV
), Sure
=> True);
18894 -- We also allow a non-parenthesized expression that raises
18895 -- constraint error if it rewrites what used to be a variable
18897 elsif Raises_Constraint_Error
(Expression
(AV
))
18898 and then Paren_Count
(Expression
(AV
)) = 0
18899 and then Is_Variable
(Original_Node
(Expression
(AV
)))
18903 -- Type conversion of something other than a variable
18909 -- If this node is rewritten, then test the original form, if that is
18910 -- OK, then we consider the rewritten node OK (for example, if the
18911 -- original node is a conversion, then Is_Variable will not be true
18912 -- but we still want to allow the conversion if it converts a variable).
18914 elsif Is_Rewrite_Substitution
(AV
) then
18915 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
18917 -- All other non-variables are rejected
18922 end Is_OK_Variable_For_Out_Formal
;
18924 ----------------------------
18925 -- Is_OK_Volatile_Context --
18926 ----------------------------
18928 function Is_OK_Volatile_Context
18929 (Context
: Node_Id
;
18931 Check_Actuals
: Boolean) return Boolean
18933 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean;
18934 -- Determine whether an arbitrary node denotes a call to a protected
18935 -- entry, function, or procedure in prefixed form where the prefix is
18938 function Within_Check
(Nod
: Node_Id
) return Boolean;
18939 -- Determine whether an arbitrary node appears in a check node
18941 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean;
18942 -- Determine whether an arbitrary entity appears in a volatile function
18944 ---------------------------------
18945 -- Is_Protected_Operation_Call --
18946 ---------------------------------
18948 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean is
18953 -- A call to a protected operations retains its selected component
18954 -- form as opposed to other prefixed calls that are transformed in
18957 if Nkind
(Nod
) = N_Selected_Component
then
18958 Pref
:= Prefix
(Nod
);
18959 Subp
:= Selector_Name
(Nod
);
18963 and then Present
(Etype
(Pref
))
18964 and then Is_Protected_Type
(Etype
(Pref
))
18965 and then Is_Entity_Name
(Subp
)
18966 and then Present
(Entity
(Subp
))
18967 and then Ekind
(Entity
(Subp
)) in
18968 E_Entry | E_Entry_Family | E_Function | E_Procedure
;
18972 end Is_Protected_Operation_Call
;
18978 function Within_Check
(Nod
: Node_Id
) return Boolean is
18982 -- Climb the parent chain looking for a check node
18985 while Present
(Par
) loop
18986 if Nkind
(Par
) in N_Raise_xxx_Error
then
18989 -- Prevent the search from going too far
18991 elsif Is_Body_Or_Package_Declaration
(Par
) then
18995 Par
:= Parent
(Par
);
19001 ------------------------------
19002 -- Within_Volatile_Function --
19003 ------------------------------
19005 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean is
19006 pragma Assert
(Ekind
(Id
) = E_Return_Statement
);
19008 Func_Id
: constant Entity_Id
:= Return_Applies_To
(Id
);
19011 pragma Assert
(Ekind
(Func_Id
) in E_Function | E_Generic_Function
);
19013 return Is_Volatile_Function
(Func_Id
);
19014 end Within_Volatile_Function
;
19018 Obj_Id
: Entity_Id
;
19020 -- Start of processing for Is_OK_Volatile_Context
19023 -- Ignore context restriction when doing preanalysis, e.g. on a copy of
19024 -- an expression function, because this copy is not fully decorated and
19025 -- it is not possible to reliably decide the legality of the context.
19026 -- Any violations will be reported anyway when doing the full analysis.
19028 if not Full_Analysis
then
19032 -- For actual parameters within explicit parameter associations switch
19033 -- the context to the corresponding subprogram call.
19035 if Nkind
(Context
) = N_Parameter_Association
then
19036 return Is_OK_Volatile_Context
(Context
=> Parent
(Context
),
19037 Obj_Ref
=> Obj_Ref
,
19038 Check_Actuals
=> Check_Actuals
);
19040 -- The volatile object appears on either side of an assignment
19042 elsif Nkind
(Context
) = N_Assignment_Statement
then
19045 -- The volatile object is part of the initialization expression of
19048 elsif Nkind
(Context
) = N_Object_Declaration
19049 and then Present
(Expression
(Context
))
19050 and then Expression
(Context
) = Obj_Ref
19051 and then Nkind
(Parent
(Context
)) /= N_Expression_With_Actions
19053 Obj_Id
:= Defining_Entity
(Context
);
19055 -- The volatile object acts as the initialization expression of an
19056 -- extended return statement. This is valid context as long as the
19057 -- function is volatile.
19059 if Is_Return_Object
(Obj_Id
) then
19060 return Within_Volatile_Function
(Scope
(Obj_Id
));
19062 -- Otherwise this is a normal object initialization
19068 -- The volatile object acts as the name of a renaming declaration
19070 elsif Nkind
(Context
) = N_Object_Renaming_Declaration
19071 and then Name
(Context
) = Obj_Ref
19075 -- The volatile object appears as an actual parameter in a call to an
19076 -- instance of Unchecked_Conversion whose result is renamed.
19078 elsif Nkind
(Context
) = N_Function_Call
19079 and then Is_Entity_Name
(Name
(Context
))
19080 and then Is_Unchecked_Conversion_Instance
(Entity
(Name
(Context
)))
19081 and then Nkind
(Parent
(Context
)) = N_Object_Renaming_Declaration
19085 -- The volatile object is actually the prefix in a protected entry,
19086 -- function, or procedure call.
19088 elsif Is_Protected_Operation_Call
(Context
) then
19091 -- The volatile object appears as the expression of a simple return
19092 -- statement that applies to a volatile function.
19094 elsif Nkind
(Context
) = N_Simple_Return_Statement
19095 and then Expression
(Context
) = Obj_Ref
19098 Within_Volatile_Function
(Return_Statement_Entity
(Context
));
19100 -- The volatile object appears as the prefix of a name occurring in a
19101 -- non-interfering context.
19103 elsif Nkind
(Context
) in
19104 N_Attribute_Reference |
19105 N_Explicit_Dereference |
19106 N_Indexed_Component |
19107 N_Selected_Component |
19109 and then Prefix
(Context
) = Obj_Ref
19110 and then Is_OK_Volatile_Context
19111 (Context
=> Parent
(Context
),
19112 Obj_Ref
=> Context
,
19113 Check_Actuals
=> Check_Actuals
)
19117 -- The volatile object appears as the prefix of attributes Address,
19118 -- Alignment, Component_Size, First, First_Bit, Last, Last_Bit, Length,
19119 -- Position, Size, Storage_Size.
19121 elsif Nkind
(Context
) = N_Attribute_Reference
19122 and then Prefix
(Context
) = Obj_Ref
19123 and then Attribute_Name
(Context
) in Name_Address
19125 | Name_Component_Size
19133 | Name_Storage_Size
19137 -- The volatile object appears as the expression of a type conversion
19138 -- occurring in a non-interfering context.
19140 elsif Nkind
(Context
) in N_Qualified_Expression
19141 | N_Type_Conversion
19142 | N_Unchecked_Type_Conversion
19143 and then Expression
(Context
) = Obj_Ref
19144 and then Is_OK_Volatile_Context
19145 (Context
=> Parent
(Context
),
19146 Obj_Ref
=> Context
,
19147 Check_Actuals
=> Check_Actuals
)
19151 -- The volatile object appears as the expression in a delay statement
19153 elsif Nkind
(Context
) in N_Delay_Statement
then
19156 -- Allow references to volatile objects in various checks. This is not a
19157 -- direct SPARK 2014 requirement.
19159 elsif Within_Check
(Context
) then
19162 -- References to effectively volatile objects that appear as actual
19163 -- parameters in subprogram calls can be examined only after call itself
19164 -- has been resolved. Before that, assume such references to be legal.
19166 elsif Nkind
(Context
) in N_Subprogram_Call | N_Entry_Call_Statement
then
19167 if Check_Actuals
then
19170 Formal
: Entity_Id
;
19171 Subp
: constant Entity_Id
:= Get_Called_Entity
(Context
);
19173 Find_Actual
(Obj_Ref
, Formal
, Call
);
19174 pragma Assert
(Call
= Context
);
19176 -- An effectively volatile object may act as an actual when the
19177 -- corresponding formal is of a non-scalar effectively volatile
19178 -- type (SPARK RM 7.1.3(10)).
19180 if not Is_Scalar_Type
(Etype
(Formal
))
19181 and then Is_Effectively_Volatile_For_Reading
(Etype
(Formal
))
19185 -- An effectively volatile object may act as an actual in a
19186 -- call to an instance of Unchecked_Conversion. (SPARK RM
19189 elsif Is_Unchecked_Conversion_Instance
(Subp
) then
19202 end Is_OK_Volatile_Context
;
19204 ------------------------------------
19205 -- Is_Package_Contract_Annotation --
19206 ------------------------------------
19208 function Is_Package_Contract_Annotation
(Item
: Node_Id
) return Boolean is
19212 if Nkind
(Item
) = N_Aspect_Specification
then
19213 Nam
:= Chars
(Identifier
(Item
));
19215 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
19216 Nam
:= Pragma_Name
(Item
);
19219 return Nam
= Name_Abstract_State
19220 or else Nam
= Name_Initial_Condition
19221 or else Nam
= Name_Initializes
19222 or else Nam
= Name_Refined_State
;
19223 end Is_Package_Contract_Annotation
;
19225 -----------------------------------
19226 -- Is_Partially_Initialized_Type --
19227 -----------------------------------
19229 function Is_Partially_Initialized_Type
19231 Include_Implicit
: Boolean := True) return Boolean
19234 if Is_Scalar_Type
(Typ
) then
19235 return Has_Default_Aspect
(Base_Type
(Typ
));
19237 elsif Is_Access_Type
(Typ
) then
19238 return Include_Implicit
;
19240 elsif Is_Array_Type
(Typ
) then
19242 -- If component type is partially initialized, so is array type
19244 if Has_Default_Aspect
(Base_Type
(Typ
))
19245 or else Is_Partially_Initialized_Type
19246 (Component_Type
(Typ
), Include_Implicit
)
19250 -- Otherwise we are only partially initialized if we are fully
19251 -- initialized (this is the empty array case, no point in us
19252 -- duplicating that code here).
19255 return Is_Fully_Initialized_Type
(Typ
);
19258 elsif Is_Record_Type
(Typ
) then
19260 -- A discriminated type is always partially initialized if in
19263 if Has_Discriminants
(Typ
) and then Include_Implicit
then
19266 -- A tagged type is always partially initialized
19268 elsif Is_Tagged_Type
(Typ
) then
19271 -- Case of nondiscriminated record
19277 Component_Present
: Boolean := False;
19278 -- Set True if at least one component is present. If no
19279 -- components are present, then record type is fully
19280 -- initialized (another odd case, like the null array).
19283 -- Loop through components
19285 Comp
:= First_Component
(Typ
);
19286 while Present
(Comp
) loop
19287 Component_Present
:= True;
19289 -- If a component has an initialization expression then the
19290 -- enclosing record type is partially initialized
19292 if Present
(Parent
(Comp
))
19293 and then Present
(Expression
(Parent
(Comp
)))
19297 -- If a component is of a type which is itself partially
19298 -- initialized, then the enclosing record type is also.
19300 elsif Is_Partially_Initialized_Type
19301 (Etype
(Comp
), Include_Implicit
)
19306 Next_Component
(Comp
);
19309 -- No initialized components found. If we found any components
19310 -- they were all uninitialized so the result is false.
19312 if Component_Present
then
19315 -- But if we found no components, then all the components are
19316 -- initialized so we consider the type to be initialized.
19324 -- Concurrent types are always fully initialized
19326 elsif Is_Concurrent_Type
(Typ
) then
19329 -- For a private type, go to underlying type. If there is no underlying
19330 -- type then just assume this partially initialized. Not clear if this
19331 -- can happen in a non-error case, but no harm in testing for this.
19333 elsif Is_Private_Type
(Typ
) then
19335 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
19340 return Is_Partially_Initialized_Type
(U
, Include_Implicit
);
19344 -- For any other type (are there any?) assume partially initialized
19349 end Is_Partially_Initialized_Type
;
19351 ------------------------------------
19352 -- Is_Potentially_Persistent_Type --
19353 ------------------------------------
19355 function Is_Potentially_Persistent_Type
(T
: Entity_Id
) return Boolean is
19360 -- For private type, test corresponding full type
19362 if Is_Private_Type
(T
) then
19363 return Is_Potentially_Persistent_Type
(Full_View
(T
));
19365 -- Scalar types are potentially persistent
19367 elsif Is_Scalar_Type
(T
) then
19370 -- Record type is potentially persistent if not tagged and the types of
19371 -- all it components are potentially persistent, and no component has
19372 -- an initialization expression.
19374 elsif Is_Record_Type
(T
)
19375 and then not Is_Tagged_Type
(T
)
19376 and then not Is_Partially_Initialized_Type
(T
)
19378 Comp
:= First_Component
(T
);
19379 while Present
(Comp
) loop
19380 if not Is_Potentially_Persistent_Type
(Etype
(Comp
)) then
19383 Next_Entity
(Comp
);
19389 -- Array type is potentially persistent if its component type is
19390 -- potentially persistent and if all its constraints are static.
19392 elsif Is_Array_Type
(T
) then
19393 if not Is_Potentially_Persistent_Type
(Component_Type
(T
)) then
19397 Indx
:= First_Index
(T
);
19398 while Present
(Indx
) loop
19399 if not Is_OK_Static_Subtype
(Etype
(Indx
)) then
19408 -- All other types are not potentially persistent
19413 end Is_Potentially_Persistent_Type
;
19415 --------------------------------
19416 -- Is_Potentially_Unevaluated --
19417 --------------------------------
19419 function Is_Potentially_Unevaluated
(N
: Node_Id
) return Boolean is
19420 function Has_Null_Others_Choice
(Aggr
: Node_Id
) return Boolean;
19421 -- Aggr is an array aggregate with static bounds and an others clause;
19422 -- return True if the others choice of the given array aggregate does
19423 -- not cover any component (i.e. is null).
19425 function Immediate_Context_Implies_Is_Potentially_Unevaluated
19426 (Expr
: Node_Id
) return Boolean;
19427 -- Return True if the *immediate* context of this expression tells us
19428 -- that it is potentially unevaluated; return False if the *immediate*
19429 -- context doesn't provide an answer to this question and we need to
19432 function Non_Static_Or_Null_Range
(N
: Node_Id
) return Boolean;
19433 -- Return True if the given range is nonstatic or null
19435 ----------------------------
19436 -- Has_Null_Others_Choice --
19437 ----------------------------
19439 function Has_Null_Others_Choice
(Aggr
: Node_Id
) return Boolean is
19440 Idx
: constant Node_Id
:= First_Index
(Etype
(Aggr
));
19441 Hiv
: constant Uint
:= Expr_Value
(Type_High_Bound
(Etype
(Idx
)));
19442 Lov
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Etype
(Idx
)));
19446 Intervals
: constant Interval_Lists
.Discrete_Interval_List
:=
19447 Interval_Lists
.Aggregate_Intervals
(Aggr
);
19450 -- The others choice is null if, after normalization, we
19451 -- have a single interval covering the whole aggregate.
19453 return Intervals
'Length = 1
19455 Intervals
(Intervals
'First).Low
= Lov
19457 Intervals
(Intervals
'First).High
= Hiv
;
19460 -- If the aggregate is malformed (that is, indexes are not disjoint)
19461 -- then no action is needed at this stage; the error will be reported
19462 -- later by the frontend.
19465 when Interval_Lists
.Intervals_Error
=>
19467 end Has_Null_Others_Choice
;
19469 ----------------------------------------------------------
19470 -- Immediate_Context_Implies_Is_Potentially_Unevaluated --
19471 ----------------------------------------------------------
19473 function Immediate_Context_Implies_Is_Potentially_Unevaluated
19474 (Expr
: Node_Id
) return Boolean
19476 Par
: constant Node_Id
:= Parent
(Expr
);
19478 function Aggregate_Type
return Node_Id
is (Etype
(Parent
(Par
)));
19480 if Nkind
(Par
) = N_If_Expression
then
19481 return Is_Elsif
(Par
) or else Expr
/= First
(Expressions
(Par
));
19483 elsif Nkind
(Par
) = N_Case_Expression
then
19484 return Expr
/= Expression
(Par
);
19486 elsif Nkind
(Par
) in N_And_Then | N_Or_Else
then
19487 return Expr
= Right_Opnd
(Par
);
19489 elsif Nkind
(Par
) in N_In | N_Not_In
then
19491 -- If the membership includes several alternatives, only the first
19492 -- is definitely evaluated.
19494 if Present
(Alternatives
(Par
)) then
19495 return Expr
/= First
(Alternatives
(Par
));
19497 -- If this is a range membership both bounds are evaluated
19503 elsif Nkind
(Par
) = N_Quantified_Expression
then
19504 return Expr
= Condition
(Par
);
19506 elsif Nkind
(Par
) = N_Component_Association
19507 and then Expr
= Expression
(Par
)
19508 and then Nkind
(Parent
(Par
))
19509 in N_Aggregate | N_Delta_Aggregate | N_Extension_Aggregate
19510 and then Present
(Aggregate_Type
)
19511 and then Aggregate_Type
/= Any_Composite
19513 if Is_Array_Type
(Aggregate_Type
) then
19514 if Ada_Version
>= Ada_2022
then
19515 -- For Ada 2022, this predicate returns True for
19516 -- any "repeatedly evaluated" expression.
19522 In_Others_Choice
: Boolean := False;
19523 Array_Agg
: constant Node_Id
:= Parent
(Par
);
19525 -- The expression of an array_component_association is
19526 -- potentially unevaluated if the associated choice is a
19527 -- subtype_indication or range that defines a nonstatic or
19530 Choice
:= First
(Choices
(Par
));
19531 while Present
(Choice
) loop
19532 if Nkind
(Choice
) = N_Range
19533 and then Non_Static_Or_Null_Range
(Choice
)
19537 elsif Nkind
(Choice
) = N_Identifier
19538 and then Present
(Scalar_Range
(Etype
(Choice
)))
19540 Non_Static_Or_Null_Range
19541 (Scalar_Range
(Etype
(Choice
)))
19545 elsif Nkind
(Choice
) = N_Others_Choice
then
19546 In_Others_Choice
:= True;
19552 -- It is also potentially unevaluated if the associated
19553 -- choice is an others choice and the applicable index
19554 -- constraint is nonstatic or null.
19556 if In_Others_Choice
then
19557 if not Compile_Time_Known_Bounds
(Aggregate_Type
) then
19560 return Has_Null_Others_Choice
(Array_Agg
);
19565 elsif Is_Container_Aggregate
(Parent
(Par
)) then
19566 -- a component of a container aggregate
19575 end Immediate_Context_Implies_Is_Potentially_Unevaluated
;
19577 ------------------------------
19578 -- Non_Static_Or_Null_Range --
19579 ------------------------------
19581 function Non_Static_Or_Null_Range
(N
: Node_Id
) return Boolean is
19582 Low
, High
: Node_Id
;
19585 Get_Index_Bounds
(N
, Low
, High
);
19587 -- Check static bounds
19589 if not Compile_Time_Known_Value
(Low
)
19590 or else not Compile_Time_Known_Value
(High
)
19594 -- Check null range
19596 elsif Expr_Value
(High
) < Expr_Value
(Low
) then
19601 end Non_Static_Or_Null_Range
;
19608 -- Start of processing for Is_Potentially_Unevaluated
19614 -- A postcondition whose expression is a short-circuit is broken down
19615 -- into individual aspects for better exception reporting. The original
19616 -- short-circuit expression is rewritten as the second operand, and an
19617 -- occurrence of 'Old in that operand is potentially unevaluated.
19618 -- See sem_ch13.adb for details of this transformation. The reference
19619 -- to 'Old may appear within an expression, so we must look for the
19620 -- enclosing pragma argument in the tree that contains the reference.
19622 while Present
(Par
)
19623 and then Nkind
(Par
) /= N_Pragma_Argument_Association
19625 if Is_Rewrite_Substitution
(Par
)
19626 and then Nkind
(Original_Node
(Par
)) = N_And_Then
19631 Par
:= Parent
(Par
);
19634 -- Other cases; 'Old appears within other expression (not the top-level
19635 -- conjunct in a postcondition) with a potentially unevaluated operand.
19637 Par
:= Parent
(Expr
);
19639 while Present
(Par
)
19640 and then Nkind
(Par
) /= N_Pragma_Argument_Association
19642 if Comes_From_Source
(Par
)
19644 Immediate_Context_Implies_Is_Potentially_Unevaluated
(Expr
)
19648 -- For component associations continue climbing; it may be part of
19649 -- an array aggregate.
19651 elsif Nkind
(Par
) = N_Component_Association
then
19654 -- If the context is not an expression, or if is the result of
19655 -- expansion of an enclosing construct (such as another attribute)
19656 -- the predicate does not apply.
19658 elsif Nkind
(Par
) = N_Case_Expression_Alternative
then
19661 elsif Nkind
(Par
) not in N_Subexpr
19662 or else not Comes_From_Source
(Par
)
19668 Par
:= Parent
(Par
);
19672 end Is_Potentially_Unevaluated
;
19674 -----------------------------------------
19675 -- Is_Predefined_Dispatching_Operation --
19676 -----------------------------------------
19678 function Is_Predefined_Dispatching_Operation
19679 (E
: Entity_Id
) return Boolean
19681 TSS_Name
: TSS_Name_Type
;
19684 if not Is_Dispatching_Operation
(E
) then
19688 Get_Name_String
(Chars
(E
));
19690 -- Most predefined primitives have internally generated names. Equality
19691 -- must be treated differently; the predefined operation is recognized
19692 -- as a homogeneous binary operator that returns Boolean.
19694 if Name_Len
> TSS_Name_Type
'Last then
19697 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
19699 if Chars
(E
) in Name_uAssign | Name_uSize
19701 (Chars
(E
) = Name_Op_Eq
19702 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
19703 or else TSS_Name
= TSS_Deep_Adjust
19704 or else TSS_Name
= TSS_Deep_Finalize
19705 or else TSS_Name
= TSS_Stream_Input
19706 or else TSS_Name
= TSS_Stream_Output
19707 or else TSS_Name
= TSS_Stream_Read
19708 or else TSS_Name
= TSS_Stream_Write
19709 or else TSS_Name
= TSS_Put_Image
19710 or else Is_Predefined_Interface_Primitive
(E
)
19717 end Is_Predefined_Dispatching_Operation
;
19719 ---------------------------------------
19720 -- Is_Predefined_Interface_Primitive --
19721 ---------------------------------------
19723 function Is_Predefined_Interface_Primitive
(E
: Entity_Id
) return Boolean is
19725 -- In VM targets we don't restrict the functionality of this test to
19726 -- compiling in Ada 2005 mode since in VM targets any tagged type has
19727 -- these primitives.
19729 return (Ada_Version
>= Ada_2005
or else not Tagged_Type_Expansion
)
19730 and then Chars
(E
) in Name_uDisp_Asynchronous_Select
19731 | Name_uDisp_Conditional_Select
19732 | Name_uDisp_Get_Prim_Op_Kind
19733 | Name_uDisp_Get_Task_Id
19734 | Name_uDisp_Requeue
19735 | Name_uDisp_Timed_Select
;
19736 end Is_Predefined_Interface_Primitive
;
19738 ---------------------------------------
19739 -- Is_Predefined_Internal_Operation --
19740 ---------------------------------------
19742 function Is_Predefined_Internal_Operation
19743 (E
: Entity_Id
) return Boolean
19745 TSS_Name
: TSS_Name_Type
;
19748 if not Is_Dispatching_Operation
(E
) then
19752 Get_Name_String
(Chars
(E
));
19754 -- Most predefined primitives have internally generated names. Equality
19755 -- must be treated differently; the predefined operation is recognized
19756 -- as a homogeneous binary operator that returns Boolean.
19758 if Name_Len
> TSS_Name_Type
'Last then
19761 (Name_Buffer
(Name_Len
- TSS_Name
'Length + 1 .. Name_Len
));
19763 if Chars
(E
) in Name_uSize | Name_uAssign
19765 (Chars
(E
) = Name_Op_Eq
19766 and then Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
)))
19767 or else TSS_Name
= TSS_Deep_Adjust
19768 or else TSS_Name
= TSS_Deep_Finalize
19769 or else Is_Predefined_Interface_Primitive
(E
)
19776 end Is_Predefined_Internal_Operation
;
19778 --------------------------------
19779 -- Is_Preelaborable_Aggregate --
19780 --------------------------------
19782 function Is_Preelaborable_Aggregate
(Aggr
: Node_Id
) return Boolean is
19783 Aggr_Typ
: constant Entity_Id
:= Etype
(Aggr
);
19784 Array_Aggr
: constant Boolean := Is_Array_Type
(Aggr_Typ
);
19786 Anc_Part
: Node_Id
;
19789 Comp_Typ
: Entity_Id
:= Empty
; -- init to avoid warning
19794 Comp_Typ
:= Component_Type
(Aggr_Typ
);
19797 -- Inspect the ancestor part
19799 if Nkind
(Aggr
) = N_Extension_Aggregate
then
19800 Anc_Part
:= Ancestor_Part
(Aggr
);
19802 -- The ancestor denotes a subtype mark
19804 if Is_Entity_Name
(Anc_Part
)
19805 and then Is_Type
(Entity
(Anc_Part
))
19807 if not Has_Preelaborable_Initialization
(Entity
(Anc_Part
)) then
19811 -- Otherwise the ancestor denotes an expression
19813 elsif not Is_Preelaborable_Construct
(Anc_Part
) then
19818 -- Inspect the positional associations
19820 Expr
:= First
(Expressions
(Aggr
));
19821 while Present
(Expr
) loop
19822 if not Is_Preelaborable_Construct
(Expr
) then
19829 -- Inspect the named associations
19831 Assoc
:= First
(Component_Associations
(Aggr
));
19832 while Present
(Assoc
) loop
19834 -- Inspect the choices of the current named association
19836 Choice
:= First
(Choices
(Assoc
));
19837 while Present
(Choice
) loop
19840 -- For a choice to be preelaborable, it must denote either a
19841 -- static range or a static expression.
19843 if Nkind
(Choice
) = N_Others_Choice
then
19846 elsif Nkind
(Choice
) = N_Range
then
19847 if not Is_OK_Static_Range
(Choice
) then
19851 elsif not Is_OK_Static_Expression
(Choice
) then
19856 Comp_Typ
:= Etype
(Choice
);
19862 -- The type of the choice must have preelaborable initialization if
19863 -- the association carries a <>.
19865 pragma Assert
(Present
(Comp_Typ
));
19866 if Box_Present
(Assoc
) then
19867 if not Has_Preelaborable_Initialization
(Comp_Typ
) then
19871 -- The type of the expression must have preelaborable initialization
19873 elsif not Is_Preelaborable_Construct
(Expression
(Assoc
)) then
19880 -- At this point the aggregate is preelaborable
19883 end Is_Preelaborable_Aggregate
;
19885 --------------------------------
19886 -- Is_Preelaborable_Construct --
19887 --------------------------------
19889 function Is_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
19893 if Nkind
(N
) in N_Aggregate | N_Extension_Aggregate
then
19894 return Is_Preelaborable_Aggregate
(N
);
19896 -- Attributes are allowed in general, even if their prefix is a formal
19897 -- type. It seems that certain attributes known not to be static might
19898 -- not be allowed, but there are no rules to prevent them.
19900 elsif Nkind
(N
) = N_Attribute_Reference
then
19905 elsif Nkind
(N
) in N_Subexpr
and then Is_OK_Static_Expression
(N
) then
19908 elsif Nkind
(N
) = N_Qualified_Expression
then
19909 return Is_Preelaborable_Construct
(Expression
(N
));
19911 -- Names are preelaborable when they denote a discriminant of an
19912 -- enclosing type. Discriminals are also considered for this check.
19914 elsif Is_Entity_Name
(N
)
19915 and then Present
(Entity
(N
))
19917 (Ekind
(Entity
(N
)) = E_Discriminant
19918 or else (Ekind
(Entity
(N
)) in E_Constant | E_In_Parameter
19919 and then Present
(Discriminal_Link
(Entity
(N
)))))
19925 elsif Nkind
(N
) = N_Null
then
19928 -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially
19929 -- unchecked conversions are preelaborable.
19931 elsif Ada_Version
>= Ada_2022
19932 and then Nkind
(N
) = N_Function_Call
19933 and then Is_Entity_Name
(Name
(N
))
19934 and then Is_Preelaborable_Function
(Entity
(Name
(N
)))
19939 A
:= First_Actual
(N
);
19941 while Present
(A
) loop
19942 if not Is_Preelaborable_Construct
(A
) then
19952 -- Otherwise the construct is not preelaborable
19957 end Is_Preelaborable_Construct
;
19959 -------------------------------
19960 -- Is_Preelaborable_Function --
19961 -------------------------------
19963 function Is_Preelaborable_Function
(Id
: Entity_Id
) return Boolean is
19964 SATAC
: constant Rtsfind
.RTU_Id
:= System_Address_To_Access_Conversions
;
19965 Scop
: constant Entity_Id
:= Scope
(Id
);
19968 -- Small optimization: every allowed function has convention Intrinsic
19969 -- (see Analyze_Subprogram_Instantiation for the subtlety in the test).
19971 if not Is_Intrinsic_Subprogram
(Id
)
19972 and then Convention
(Id
) /= Convention_Intrinsic
19977 -- An instance of Unchecked_Conversion
19979 if Is_Unchecked_Conversion_Instance
(Id
) then
19983 -- A function declared in System.Storage_Elements
19985 if Is_RTU
(Scop
, System_Storage_Elements
) then
19989 -- The functions To_Pointer and To_Address declared in an instance of
19990 -- System.Address_To_Access_Conversions (they are the only ones).
19992 if Ekind
(Scop
) = E_Package
19993 and then Nkind
(Parent
(Scop
)) = N_Package_Specification
19994 and then Present
(Generic_Parent
(Parent
(Scop
)))
19995 and then Is_RTU
(Generic_Parent
(Parent
(Scop
)), SATAC
)
20001 end Is_Preelaborable_Function
;
20003 -----------------------------
20004 -- Is_Private_Library_Unit --
20005 -----------------------------
20007 function Is_Private_Library_Unit
(Unit
: Entity_Id
) return Boolean is
20008 Comp_Unit
: constant Node_Id
:= Parent
(Unit_Declaration_Node
(Unit
));
20010 return Nkind
(Comp_Unit
) = N_Compilation_Unit
20011 and then Private_Present
(Comp_Unit
);
20012 end Is_Private_Library_Unit
;
20014 ---------------------------------
20015 -- Is_Protected_Self_Reference --
20016 ---------------------------------
20018 function Is_Protected_Self_Reference
(N
: Node_Id
) return Boolean is
20020 function In_Access_Definition
(N
: Node_Id
) return Boolean;
20021 -- Returns true if N belongs to an access definition
20023 --------------------------
20024 -- In_Access_Definition --
20025 --------------------------
20027 function In_Access_Definition
(N
: Node_Id
) return Boolean is
20032 while Present
(P
) loop
20033 if Nkind
(P
) = N_Access_Definition
then
20041 end In_Access_Definition
;
20043 -- Start of processing for Is_Protected_Self_Reference
20046 -- Verify that prefix is analyzed and has the proper form. Note that
20047 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also
20048 -- produce the address of an entity, do not analyze their prefix
20049 -- because they denote entities that are not necessarily visible.
20050 -- Neither of them can apply to a protected type.
20052 return Ada_Version
>= Ada_2005
20053 and then Is_Entity_Name
(N
)
20054 and then Present
(Entity
(N
))
20055 and then Is_Protected_Type
(Entity
(N
))
20056 and then In_Open_Scopes
(Entity
(N
))
20057 and then not In_Access_Definition
(N
);
20058 end Is_Protected_Self_Reference
;
20060 -----------------------------
20061 -- Is_RCI_Pkg_Spec_Or_Body --
20062 -----------------------------
20064 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
20066 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
20067 -- Return True if the unit of Cunit is an RCI package declaration
20069 ---------------------------
20070 -- Is_RCI_Pkg_Decl_Cunit --
20071 ---------------------------
20073 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
20074 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
20077 if Nkind
(The_Unit
) /= N_Package_Declaration
then
20081 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
20082 end Is_RCI_Pkg_Decl_Cunit
;
20084 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
20087 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
20089 (Nkind
(Unit
(Cunit
)) = N_Package_Body
20090 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
20091 end Is_RCI_Pkg_Spec_Or_Body
;
20093 -----------------------------------------
20094 -- Is_Remote_Access_To_Class_Wide_Type --
20095 -----------------------------------------
20097 function Is_Remote_Access_To_Class_Wide_Type
20098 (E
: Entity_Id
) return Boolean
20101 -- A remote access to class-wide type is a general access to object type
20102 -- declared in the visible part of a Remote_Types or Remote_Call_
20105 return Ekind
(E
) = E_General_Access_Type
20106 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
20107 end Is_Remote_Access_To_Class_Wide_Type
;
20109 -----------------------------------------
20110 -- Is_Remote_Access_To_Subprogram_Type --
20111 -----------------------------------------
20113 function Is_Remote_Access_To_Subprogram_Type
20114 (E
: Entity_Id
) return Boolean
20117 return (Ekind
(E
) = E_Access_Subprogram_Type
20118 or else (Ekind
(E
) = E_Record_Type
20119 and then Present
(Corresponding_Remote_Type
(E
))))
20120 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
20121 end Is_Remote_Access_To_Subprogram_Type
;
20123 --------------------
20124 -- Is_Remote_Call --
20125 --------------------
20127 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
20129 if Nkind
(N
) not in N_Subprogram_Call
then
20131 -- An entry call cannot be remote
20135 elsif Nkind
(Name
(N
)) in N_Has_Entity
20136 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
20138 -- A subprogram declared in the spec of a RCI package is remote
20142 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
20143 and then Is_Remote_Access_To_Subprogram_Type
20144 (Etype
(Prefix
(Name
(N
))))
20146 -- The dereference of a RAS is a remote call
20150 elsif Present
(Controlling_Argument
(N
))
20151 and then Is_Remote_Access_To_Class_Wide_Type
20152 (Etype
(Controlling_Argument
(N
)))
20154 -- Any primitive operation call with a controlling argument of
20155 -- a RACW type is a remote call.
20160 -- All other calls are local calls
20163 end Is_Remote_Call
;
20165 ----------------------
20166 -- Is_Renamed_Entry --
20167 ----------------------
20169 function Is_Renamed_Entry
(Proc_Nam
: Entity_Id
) return Boolean is
20170 Orig_Node
: Node_Id
:= Empty
;
20171 Subp_Decl
: Node_Id
:=
20172 (if No
(Parent
(Proc_Nam
)) then Empty
else Parent
(Parent
(Proc_Nam
)));
20174 function Is_Entry
(Nam
: Node_Id
) return Boolean;
20175 -- Determine whether Nam is an entry. Traverse selectors if there are
20176 -- nested selected components.
20182 function Is_Entry
(Nam
: Node_Id
) return Boolean is
20184 if Nkind
(Nam
) = N_Selected_Component
then
20185 return Is_Entry
(Selector_Name
(Nam
));
20188 return Ekind
(Entity
(Nam
)) = E_Entry
;
20191 -- Start of processing for Is_Renamed_Entry
20194 if Present
(Alias
(Proc_Nam
)) then
20195 Subp_Decl
:= Parent
(Parent
(Alias
(Proc_Nam
)));
20198 -- Look for a rewritten subprogram renaming declaration
20200 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
20201 and then Present
(Original_Node
(Subp_Decl
))
20203 Orig_Node
:= Original_Node
(Subp_Decl
);
20206 -- The rewritten subprogram is actually an entry
20208 if Present
(Orig_Node
)
20209 and then Nkind
(Orig_Node
) = N_Subprogram_Renaming_Declaration
20210 and then Is_Entry
(Name
(Orig_Node
))
20216 end Is_Renamed_Entry
;
20218 ----------------------------
20219 -- Is_Reversible_Iterator --
20220 ----------------------------
20222 function Is_Reversible_Iterator
(Typ
: Entity_Id
) return Boolean is
20223 Ifaces_List
: Elist_Id
;
20224 Iface_Elmt
: Elmt_Id
;
20228 if Is_Class_Wide_Type
(Typ
)
20229 and then Chars
(Root_Type
(Typ
)) = Name_Reversible_Iterator
20230 and then In_Predefined_Unit
(Root_Type
(Typ
))
20234 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
20238 Collect_Interfaces
(Typ
, Ifaces_List
);
20240 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
20241 while Present
(Iface_Elmt
) loop
20242 Iface
:= Node
(Iface_Elmt
);
20243 if Chars
(Iface
) = Name_Reversible_Iterator
20244 and then In_Predefined_Unit
(Iface
)
20249 Next_Elmt
(Iface_Elmt
);
20254 end Is_Reversible_Iterator
;
20256 ---------------------------------
20257 -- Is_Single_Concurrent_Object --
20258 ---------------------------------
20260 function Is_Single_Concurrent_Object
(Id
: Entity_Id
) return Boolean is
20263 Is_Single_Protected_Object
(Id
) or else Is_Single_Task_Object
(Id
);
20264 end Is_Single_Concurrent_Object
;
20266 -------------------------------
20267 -- Is_Single_Concurrent_Type --
20268 -------------------------------
20270 function Is_Single_Concurrent_Type
(Id
: Entity_Id
) return Boolean is
20273 Ekind
(Id
) in E_Protected_Type | E_Task_Type
20274 and then Is_Single_Concurrent_Type_Declaration
20275 (Declaration_Node
(Id
));
20276 end Is_Single_Concurrent_Type
;
20278 -------------------------------------------
20279 -- Is_Single_Concurrent_Type_Declaration --
20280 -------------------------------------------
20282 function Is_Single_Concurrent_Type_Declaration
20283 (N
: Node_Id
) return Boolean
20286 return Nkind
(Original_Node
(N
)) in
20287 N_Single_Protected_Declaration | N_Single_Task_Declaration
;
20288 end Is_Single_Concurrent_Type_Declaration
;
20290 ---------------------------------------------
20291 -- Is_Single_Precision_Floating_Point_Type --
20292 ---------------------------------------------
20294 function Is_Single_Precision_Floating_Point_Type
20295 (E
: Entity_Id
) return Boolean is
20297 return Is_Floating_Point_Type
(E
)
20298 and then Machine_Radix_Value
(E
) = Uint_2
20299 and then Machine_Mantissa_Value
(E
) = Uint_24
20300 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_7
20301 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_7
);
20302 end Is_Single_Precision_Floating_Point_Type
;
20304 --------------------------------
20305 -- Is_Single_Protected_Object --
20306 --------------------------------
20308 function Is_Single_Protected_Object
(Id
: Entity_Id
) return Boolean is
20311 Ekind
(Id
) = E_Variable
20312 and then Ekind
(Etype
(Id
)) = E_Protected_Type
20313 and then Is_Single_Concurrent_Type
(Etype
(Id
));
20314 end Is_Single_Protected_Object
;
20316 ---------------------------
20317 -- Is_Single_Task_Object --
20318 ---------------------------
20320 function Is_Single_Task_Object
(Id
: Entity_Id
) return Boolean is
20323 Ekind
(Id
) = E_Variable
20324 and then Ekind
(Etype
(Id
)) = E_Task_Type
20325 and then Is_Single_Concurrent_Type
(Etype
(Id
));
20326 end Is_Single_Task_Object
;
20328 -----------------------------
20329 -- Is_Specific_Tagged_Type --
20330 -----------------------------
20332 function Is_Specific_Tagged_Type
(Typ
: Entity_Id
) return Boolean is
20333 Full_Typ
: Entity_Id
;
20336 -- Handle private types
20338 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
20339 Full_Typ
:= Full_View
(Typ
);
20344 -- A specific tagged type is a non-class-wide tagged type
20346 return Is_Tagged_Type
(Full_Typ
) and not Is_Class_Wide_Type
(Full_Typ
);
20347 end Is_Specific_Tagged_Type
;
20353 function Is_Statement
(N
: Node_Id
) return Boolean is
20356 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
20357 or else Nkind
(N
) = N_Procedure_Call_Statement
;
20360 --------------------------------------
20361 -- Is_Static_Discriminant_Component --
20362 --------------------------------------
20364 function Is_Static_Discriminant_Component
(N
: Node_Id
) return Boolean is
20366 return Nkind
(N
) = N_Selected_Component
20367 and then not Is_In_Discriminant_Check
(N
)
20368 and then Present
(Etype
(Prefix
(N
)))
20369 and then Ekind
(Etype
(Prefix
(N
))) = E_Record_Subtype
20370 and then Has_Static_Discriminants
(Etype
(Prefix
(N
)))
20371 and then Present
(Entity
(Selector_Name
(N
)))
20372 and then Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
20373 and then not In_Check_Node
(N
);
20374 end Is_Static_Discriminant_Component
;
20376 ------------------------
20377 -- Is_Static_Function --
20378 ------------------------
20380 function Is_Static_Function
(Subp
: Entity_Id
) return Boolean is
20382 -- Always return False for pre Ada 2022 to e.g. ignore the Static
20383 -- aspect in package Interfaces for Ada_Version < 2022 and also
20386 return Ada_Version
>= Ada_2022
20387 and then Has_Aspect
(Subp
, Aspect_Static
)
20389 (No
(Find_Value_Of_Aspect
(Subp
, Aspect_Static
))
20390 or else Is_True
(Static_Boolean
20391 (Find_Value_Of_Aspect
(Subp
, Aspect_Static
))));
20392 end Is_Static_Function
;
20394 -----------------------------
20395 -- Is_Static_Function_Call --
20396 -----------------------------
20398 function Is_Static_Function_Call
(Call
: Node_Id
) return Boolean is
20399 function Has_All_Static_Actuals
(Call
: Node_Id
) return Boolean;
20400 -- Return whether all actual parameters of Call are static expressions
20402 ----------------------------
20403 -- Has_All_Static_Actuals --
20404 ----------------------------
20406 function Has_All_Static_Actuals
(Call
: Node_Id
) return Boolean is
20407 Actual
: Node_Id
:= First_Actual
(Call
);
20408 String_Result
: constant Boolean :=
20409 Is_String_Type
(Etype
(Entity
(Name
(Call
))));
20412 while Present
(Actual
) loop
20413 if not Is_Static_Expression
(Actual
) then
20415 -- ??? In the string-returning case we want to avoid a call
20416 -- being made to Establish_Transient_Scope in Resolve_Call,
20417 -- but at the point where that's tested for (which now includes
20418 -- a call to test Is_Static_Function_Call), the actuals of the
20419 -- call haven't been resolved, so expressions of the actuals
20420 -- may not have been marked Is_Static_Expression yet, so we
20421 -- force them to be resolved here, so we can tell if they're
20422 -- static. Calling Resolve here is admittedly a kludge, and we
20423 -- limit this call to string-returning cases.
20425 if String_Result
then
20429 -- Test flag again in case it's now True due to above Resolve
20431 if not Is_Static_Expression
(Actual
) then
20436 Next_Actual
(Actual
);
20440 end Has_All_Static_Actuals
;
20443 return Nkind
(Call
) = N_Function_Call
20444 and then Is_Entity_Name
(Name
(Call
))
20445 and then Is_Static_Function
(Entity
(Name
(Call
)))
20446 and then Has_All_Static_Actuals
(Call
);
20447 end Is_Static_Function_Call
;
20449 -------------------------------------------
20450 -- Is_Subcomponent_Of_Full_Access_Object --
20451 -------------------------------------------
20453 function Is_Subcomponent_Of_Full_Access_Object
(N
: Node_Id
) return Boolean
20458 R
:= Get_Referenced_Object
(N
);
20460 while Nkind
(R
) in N_Indexed_Component | N_Selected_Component | N_Slice
20462 R
:= Get_Referenced_Object
(Prefix
(R
));
20464 -- If the prefix is an access value, only the designated type matters
20466 if Is_Access_Type
(Etype
(R
)) then
20467 if Is_Full_Access
(Designated_Type
(Etype
(R
))) then
20472 if Is_Full_Access_Object
(R
) then
20479 end Is_Subcomponent_Of_Full_Access_Object
;
20481 ---------------------------------------
20482 -- Is_Subprogram_Contract_Annotation --
20483 ---------------------------------------
20485 function Is_Subprogram_Contract_Annotation
20486 (Item
: Node_Id
) return Boolean
20491 if Nkind
(Item
) = N_Aspect_Specification
then
20492 Nam
:= Chars
(Identifier
(Item
));
20494 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
20495 Nam
:= Pragma_Name
(Item
);
20498 return Nam
= Name_Contract_Cases
20499 or else Nam
= Name_Depends
20500 or else Nam
= Name_Extensions_Visible
20501 or else Nam
= Name_Global
20502 or else Nam
= Name_Post
20503 or else Nam
= Name_Post_Class
20504 or else Nam
= Name_Postcondition
20505 or else Nam
= Name_Pre
20506 or else Nam
= Name_Pre_Class
20507 or else Nam
= Name_Precondition
20508 or else Nam
= Name_Refined_Depends
20509 or else Nam
= Name_Refined_Global
20510 or else Nam
= Name_Refined_Post
20511 or else Nam
= Name_Subprogram_Variant
20512 or else Nam
= Name_Test_Case
;
20513 end Is_Subprogram_Contract_Annotation
;
20515 --------------------------------------------------
20516 -- Is_Subprogram_Stub_Without_Prior_Declaration --
20517 --------------------------------------------------
20519 function Is_Subprogram_Stub_Without_Prior_Declaration
20520 (N
: Node_Id
) return Boolean
20523 pragma Assert
(Nkind
(N
) = N_Subprogram_Body_Stub
);
20525 case Ekind
(Defining_Entity
(N
)) is
20527 -- A subprogram stub without prior declaration serves as declaration
20528 -- for the actual subprogram body. As such, it has an attached
20529 -- defining entity of E_Function or E_Procedure.
20536 -- Otherwise, it is completes a [generic] subprogram declaration
20538 when E_Generic_Function
20539 | E_Generic_Procedure
20540 | E_Subprogram_Body
20545 raise Program_Error
;
20547 end Is_Subprogram_Stub_Without_Prior_Declaration
;
20549 ---------------------------
20550 -- Is_Suitable_Primitive --
20551 ---------------------------
20553 function Is_Suitable_Primitive
(Subp_Id
: Entity_Id
) return Boolean is
20555 -- The Default_Initial_Condition and invariant procedures must not be
20556 -- treated as primitive operations even when they apply to a tagged
20557 -- type. These routines must not act as targets of dispatching calls
20558 -- because they already utilize class-wide-precondition semantics to
20559 -- handle inheritance and overriding.
20561 if Ekind
(Subp_Id
) = E_Procedure
20562 and then (Is_DIC_Procedure
(Subp_Id
)
20564 Is_Invariant_Procedure
(Subp_Id
))
20570 end Is_Suitable_Primitive
;
20572 ----------------------------
20573 -- Is_Synchronized_Object --
20574 ----------------------------
20576 function Is_Synchronized_Object
(Id
: Entity_Id
) return Boolean is
20580 if Is_Object
(Id
) then
20582 -- The object is synchronized if it is of a type that yields a
20583 -- synchronized object.
20585 if Yields_Synchronized_Object
(Etype
(Id
)) then
20588 -- The object is synchronized if it is atomic and Async_Writers is
20591 elsif Is_Atomic_Object_Entity
(Id
)
20592 and then Async_Writers_Enabled
(Id
)
20596 -- A constant is a synchronized object by default, unless its type is
20597 -- access-to-variable type.
20599 elsif Ekind
(Id
) = E_Constant
20600 and then not Is_Access_Variable
(Etype
(Id
))
20604 -- A variable is a synchronized object if it is subject to pragma
20605 -- Constant_After_Elaboration.
20607 elsif Ekind
(Id
) = E_Variable
then
20608 Prag
:= Get_Pragma
(Id
, Pragma_Constant_After_Elaboration
);
20610 return Present
(Prag
) and then Is_Enabled_Pragma
(Prag
);
20614 -- Otherwise the input is not an object or it does not qualify as a
20615 -- synchronized object.
20618 end Is_Synchronized_Object
;
20620 ---------------------------------
20621 -- Is_Synchronized_Tagged_Type --
20622 ---------------------------------
20624 function Is_Synchronized_Tagged_Type
(E
: Entity_Id
) return Boolean is
20625 Kind
: constant Entity_Kind
:= Ekind
(Base_Type
(E
));
20628 -- A task or protected type derived from an interface is a tagged type.
20629 -- Such a tagged type is called a synchronized tagged type, as are
20630 -- synchronized interfaces and private extensions whose declaration
20631 -- includes the reserved word synchronized.
20633 return (Is_Tagged_Type
(E
)
20634 and then (Kind
= E_Task_Type
20636 Kind
= E_Protected_Type
))
20639 and then Is_Synchronized_Interface
(E
))
20641 (Ekind
(E
) = E_Record_Type_With_Private
20642 and then Nkind
(Parent
(E
)) = N_Private_Extension_Declaration
20643 and then (Synchronized_Present
(Parent
(E
))
20644 or else Is_Synchronized_Interface
(Etype
(E
))));
20645 end Is_Synchronized_Tagged_Type
;
20651 function Is_Transfer
(N
: Node_Id
) return Boolean is
20652 Kind
: constant Node_Kind
:= Nkind
(N
);
20655 if Kind
in N_Simple_Return_Statement
20656 | N_Extended_Return_Statement
20658 | N_Raise_Statement
20659 | N_Requeue_Statement
20663 elsif Kind
in N_Exit_Statement | N_Raise_xxx_Error
20664 and then No
(Condition
(N
))
20668 elsif Kind
= N_Procedure_Call_Statement
20669 and then Is_Entity_Name
(Name
(N
))
20670 and then Present
(Entity
(Name
(N
)))
20671 and then No_Return
(Entity
(Name
(N
)))
20675 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
20687 function Is_True
(U
: Opt_Ubool
) return Boolean is
20689 return No
(U
) or else U
= Uint_1
;
20692 ------------------------
20693 -- Is_Trivial_Boolean --
20694 ------------------------
20696 function Is_Trivial_Boolean
(N
: Node_Id
) return Boolean is
20698 return Comes_From_Source
(N
)
20699 and then Nkind
(N
) in N_Identifier | N_Expanded_Name
20700 and then Entity
(N
) in Standard_True | Standard_False
;
20701 end Is_Trivial_Boolean
;
20703 --------------------------------------
20704 -- Is_Unchecked_Conversion_Instance --
20705 --------------------------------------
20707 function Is_Unchecked_Conversion_Instance
(Id
: Entity_Id
) return Boolean is
20711 -- Look for a function whose generic parent is the predefined intrinsic
20712 -- function Unchecked_Conversion, or for one that renames such an
20715 if Ekind
(Id
) = E_Function
then
20716 Par
:= Parent
(Id
);
20718 if Nkind
(Par
) = N_Function_Specification
then
20719 Par
:= Generic_Parent
(Par
);
20721 if Present
(Par
) then
20723 Chars
(Par
) = Name_Unchecked_Conversion
20724 and then Is_Intrinsic_Subprogram
(Par
)
20725 and then In_Predefined_Unit
(Par
);
20728 Present
(Alias
(Id
))
20729 and then Is_Unchecked_Conversion_Instance
(Alias
(Id
));
20735 end Is_Unchecked_Conversion_Instance
;
20737 -------------------------------
20738 -- Is_Universal_Numeric_Type --
20739 -------------------------------
20741 function Is_Universal_Numeric_Type
(T
: Entity_Id
) return Boolean is
20743 return T
= Universal_Integer
or else T
= Universal_Real
;
20744 end Is_Universal_Numeric_Type
;
20746 ------------------------------
20747 -- Is_User_Defined_Equality --
20748 ------------------------------
20750 function Is_User_Defined_Equality
(Id
: Entity_Id
) return Boolean is
20751 F1
, F2
: Entity_Id
;
20754 -- An equality operator is a function that carries the name "=", returns
20755 -- Boolean, and has exactly two formal parameters of an identical type.
20757 if Ekind
(Id
) = E_Function
20758 and then Chars
(Id
) = Name_Op_Eq
20759 and then Base_Type
(Etype
(Id
)) = Standard_Boolean
20761 F1
:= First_Formal
(Id
);
20767 F2
:= Next_Formal
(F1
);
20769 return Present
(F2
)
20770 and then No
(Next_Formal
(F2
))
20771 and then Base_Type
(Etype
(F1
)) = Base_Type
(Etype
(F2
));
20776 end Is_User_Defined_Equality
;
20778 -----------------------------
20779 -- Is_User_Defined_Literal --
20780 -----------------------------
20782 function Is_User_Defined_Literal
20784 Typ
: Entity_Id
) return Boolean
20786 Literal_Aspect_Map
:
20787 constant array (N_Numeric_Or_String_Literal
) of Aspect_Id
:=
20788 (N_Integer_Literal
=> Aspect_Integer_Literal
,
20789 N_Interpolated_String_Literal
=> No_Aspect
,
20790 N_Real_Literal
=> Aspect_Real_Literal
,
20791 N_String_Literal
=> Aspect_String_Literal
);
20794 -- Return True when N is either a literal or a named number and the
20795 -- type has the appropriate user-defined literal aspect.
20797 return (Nkind
(N
) in N_Numeric_Or_String_Literal
20798 and then Has_Aspect
(Typ
, Literal_Aspect_Map
(Nkind
(N
))))
20800 (Is_Entity_Name
(N
)
20801 and then Present
(Entity
(N
))
20803 ((Ekind
(Entity
(N
)) = E_Named_Integer
20804 and then Has_Aspect
(Typ
, Aspect_Integer_Literal
))
20806 (Ekind
(Entity
(N
)) = E_Named_Real
20807 and then Has_Aspect
(Typ
, Aspect_Real_Literal
))));
20808 end Is_User_Defined_Literal
;
20810 --------------------------------------
20811 -- Is_Validation_Variable_Reference --
20812 --------------------------------------
20814 function Is_Validation_Variable_Reference
(N
: Node_Id
) return Boolean is
20815 Var
: constant Node_Id
:= Unqual_Conv
(N
);
20816 Var_Id
: Entity_Id
;
20821 if Is_Entity_Name
(Var
) then
20822 Var_Id
:= Entity
(Var
);
20827 and then Ekind
(Var_Id
) = E_Variable
20828 and then Present
(Validated_Object
(Var_Id
));
20829 end Is_Validation_Variable_Reference
;
20831 ----------------------------
20832 -- Is_Variable_Size_Array --
20833 ----------------------------
20835 function Is_Variable_Size_Array
(E
: Entity_Id
) return Boolean is
20839 pragma Assert
(Is_Array_Type
(E
));
20841 -- Check if some index is initialized with a non-constant value
20843 Idx
:= First_Index
(E
);
20844 while Present
(Idx
) loop
20845 if Nkind
(Idx
) = N_Range
then
20846 if not Is_Constant_Bound
(Low_Bound
(Idx
))
20847 or else not Is_Constant_Bound
(High_Bound
(Idx
))
20857 end Is_Variable_Size_Array
;
20859 -----------------------------
20860 -- Is_Variable_Size_Record --
20861 -----------------------------
20863 function Is_Variable_Size_Record
(E
: Entity_Id
) return Boolean is
20865 Comp_Typ
: Entity_Id
;
20868 pragma Assert
(Is_Record_Type
(E
));
20870 Comp
:= First_Component
(E
);
20871 while Present
(Comp
) loop
20872 Comp_Typ
:= Underlying_Type
(Etype
(Comp
));
20874 -- Recursive call if the record type has discriminants
20876 if Is_Record_Type
(Comp_Typ
)
20877 and then Has_Discriminants
(Comp_Typ
)
20878 and then Is_Variable_Size_Record
(Comp_Typ
)
20882 elsif Is_Array_Type
(Comp_Typ
)
20883 and then Is_Variable_Size_Array
(Comp_Typ
)
20888 Next_Component
(Comp
);
20892 end Is_Variable_Size_Record
;
20898 -- Should Is_Variable be refactored to better handle dereferences and
20899 -- technical debt ???
20901 function Is_Variable
20903 Use_Original_Node
: Boolean := True) return Boolean
20905 Orig_Node
: Node_Id
;
20907 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
20908 -- Within a protected function, the private components of the enclosing
20909 -- protected type are constants. A function nested within a (protected)
20910 -- procedure is not itself protected. Within the body of a protected
20911 -- function the current instance of the protected type is a constant.
20913 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
20914 -- Prefixes can involve implicit dereferences, in which case we must
20915 -- test for the case of a reference of a constant access type, which can
20916 -- can never be a variable.
20918 ---------------------------
20919 -- In_Protected_Function --
20920 ---------------------------
20922 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
20927 -- E is the current instance of a type
20929 if Is_Type
(E
) then
20938 if not Is_Protected_Type
(Prot
) then
20942 S
:= Current_Scope
;
20943 while Present
(S
) and then S
/= Prot
loop
20944 if Ekind
(S
) = E_Function
and then Scope
(S
) = Prot
then
20953 end In_Protected_Function
;
20955 ------------------------
20956 -- Is_Variable_Prefix --
20957 ------------------------
20959 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
20961 if Is_Access_Type
(Etype
(P
)) then
20962 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
20964 -- For the case of an indexed component whose prefix has a packed
20965 -- array type, the prefix has been rewritten into a type conversion.
20966 -- Determine variable-ness from the converted expression.
20968 elsif Nkind
(P
) = N_Type_Conversion
20969 and then not Comes_From_Source
(P
)
20970 and then Is_Packed_Array
(Etype
(P
))
20972 return Is_Variable
(Expression
(P
));
20975 return Is_Variable
(P
);
20977 end Is_Variable_Prefix
;
20979 -- Start of processing for Is_Variable
20982 -- Special check, allow x'Deref(expr) as a variable
20984 if Nkind
(N
) = N_Attribute_Reference
20985 and then Attribute_Name
(N
) = Name_Deref
20990 -- Check if we perform the test on the original node since this may be a
20991 -- test of syntactic categories which must not be disturbed by whatever
20992 -- rewriting might have occurred. For example, an aggregate, which is
20993 -- certainly NOT a variable, could be turned into a variable by
20996 if Use_Original_Node
then
20997 Orig_Node
:= Original_Node
(N
);
21002 -- Definitely OK if Assignment_OK is set. Since this is something that
21003 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
21005 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
21008 -- Normally we go to the original node, but there is one exception where
21009 -- we use the rewritten node, namely when it is an explicit dereference.
21010 -- The generated code may rewrite a prefix which is an access type with
21011 -- an explicit dereference. The dereference is a variable, even though
21012 -- the original node may not be (since it could be a constant of the
21015 -- In Ada 2005 we have a further case to consider: the prefix may be a
21016 -- function call given in prefix notation. The original node appears to
21017 -- be a selected component, but we need to examine the call.
21019 elsif Nkind
(N
) = N_Explicit_Dereference
21020 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
21021 and then Present
(Etype
(Orig_Node
))
21022 and then Is_Access_Type
(Etype
(Orig_Node
))
21024 -- Note that if the prefix is an explicit dereference that does not
21025 -- come from source, we must check for a rewritten function call in
21026 -- prefixed notation before other forms of rewriting, to prevent a
21030 (Nkind
(Orig_Node
) = N_Function_Call
21031 and then not Is_Access_Constant
(Etype
(Prefix
(N
))))
21033 Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
21035 -- Generalized indexing operations are rewritten as explicit
21036 -- dereferences, and it is only during resolution that we can
21037 -- check whether the context requires an access_to_variable type.
21039 elsif Nkind
(N
) = N_Explicit_Dereference
21040 and then Present
(Etype
(Orig_Node
))
21041 and then Has_Implicit_Dereference
(Etype
(Orig_Node
))
21042 and then Ada_Version
>= Ada_2012
21044 return not Is_Access_Constant
(Etype
(Prefix
(N
)));
21046 -- A function call is never a variable
21048 elsif Nkind
(N
) = N_Function_Call
then
21051 -- All remaining checks use the original node
21053 elsif Is_Entity_Name
(Orig_Node
)
21054 and then Present
(Entity
(Orig_Node
))
21057 E
: constant Entity_Id
:= Entity
(Orig_Node
);
21058 K
: constant Entity_Kind
:= Ekind
(E
);
21061 if Is_Loop_Parameter
(E
) then
21065 return (K
= E_Variable
21066 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
21067 or else (K
= E_Component
21068 and then not In_Protected_Function
(E
))
21069 or else (Present
(Etype
(E
))
21070 and then Is_Access_Variable
(Etype
(E
))
21071 and then Is_Dereferenced
(N
))
21072 or else K
= E_Out_Parameter
21073 or else K
= E_In_Out_Parameter
21074 or else K
= E_Generic_In_Out_Parameter
21076 -- Current instance of type. If this is a protected type, check
21077 -- we are not within the body of one of its protected functions.
21079 or else (Is_Type
(E
)
21080 and then In_Open_Scopes
(E
)
21081 and then not In_Protected_Function
(E
))
21083 or else (Is_Incomplete_Or_Private_Type
(E
)
21084 and then In_Open_Scopes
(Full_View
(E
)));
21088 case Nkind
(Orig_Node
) is
21089 when N_Indexed_Component
21092 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
21094 when N_Selected_Component
=>
21095 return (Is_Variable
(Selector_Name
(Orig_Node
))
21096 and then Is_Variable_Prefix
(Prefix
(Orig_Node
)))
21098 (Nkind
(N
) = N_Expanded_Name
21099 and then Scope
(Entity
(N
)) = Entity
(Prefix
(N
)));
21101 -- For an explicit dereference, the type of the prefix cannot
21102 -- be an access to constant or an access to subprogram.
21104 when N_Explicit_Dereference
=>
21106 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
21108 return Is_Access_Type
(Typ
)
21109 and then not Is_Access_Constant
(Root_Type
(Typ
))
21110 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
21113 -- The type conversion is the case where we do not deal with the
21114 -- context dependent special case of an actual parameter. Thus
21115 -- the type conversion is only considered a variable for the
21116 -- purposes of this routine if the target type is tagged. However,
21117 -- a type conversion is considered to be a variable if it does not
21118 -- come from source (this deals for example with the conversions
21119 -- of expressions to their actual subtypes).
21121 when N_Type_Conversion
=>
21122 return Is_Variable
(Expression
(Orig_Node
))
21124 (not Comes_From_Source
(Orig_Node
)
21126 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
21128 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
21130 -- GNAT allows an unchecked type conversion as a variable. This
21131 -- only affects the generation of internal expanded code, since
21132 -- calls to instantiations of Unchecked_Conversion are never
21133 -- considered variables (since they are function calls).
21135 when N_Unchecked_Type_Conversion
=>
21136 return Is_Variable
(Expression
(Orig_Node
));
21144 ------------------------
21145 -- Is_View_Conversion --
21146 ------------------------
21148 function Is_View_Conversion
(N
: Node_Id
) return Boolean is
21150 if Nkind
(N
) = N_Type_Conversion
21151 and then Nkind
(Unqual_Conv
(N
)) in N_Has_Etype
21153 if Is_Tagged_Type
(Etype
(N
))
21154 and then Is_Tagged_Type
(Etype
(Unqual_Conv
(N
)))
21158 elsif Is_Actual_Parameter
(N
)
21159 and then (Is_Actual_Out_Parameter
(N
)
21160 or else Is_Actual_In_Out_Parameter
(N
))
21167 end Is_View_Conversion
;
21169 ---------------------------
21170 -- Is_Visibly_Controlled --
21171 ---------------------------
21173 function Is_Visibly_Controlled
(T
: Entity_Id
) return Boolean is
21174 Root
: constant Entity_Id
:= Root_Type
(T
);
21176 return Chars
(Scope
(Root
)) = Name_Finalization
21177 and then Chars
(Scope
(Scope
(Root
))) = Name_Ada
21178 and then Scope
(Scope
(Scope
(Root
))) = Standard_Standard
;
21179 end Is_Visibly_Controlled
;
21181 ----------------------------------------
21182 -- Is_Volatile_Full_Access_Object_Ref --
21183 ----------------------------------------
21185 function Is_Volatile_Full_Access_Object_Ref
(N
: Node_Id
) return Boolean is
21186 function Is_VFA_Object_Entity
(Id
: Entity_Id
) return Boolean;
21187 -- Determine whether arbitrary entity Id denotes an object that is
21188 -- Volatile_Full_Access.
21190 ----------------------------
21191 -- Is_VFA_Object_Entity --
21192 ----------------------------
21194 function Is_VFA_Object_Entity
(Id
: Entity_Id
) return Boolean is
21198 and then (Is_Volatile_Full_Access
(Id
)
21200 Is_Volatile_Full_Access
(Etype
(Id
)));
21201 end Is_VFA_Object_Entity
;
21203 -- Start of processing for Is_Volatile_Full_Access_Object_Ref
21206 if Is_Entity_Name
(N
) then
21207 return Is_VFA_Object_Entity
(Entity
(N
));
21209 elsif Is_Volatile_Full_Access
(Etype
(N
)) then
21212 elsif Nkind
(N
) = N_Selected_Component
then
21213 return Is_Volatile_Full_Access
(Entity
(Selector_Name
(N
)));
21218 end Is_Volatile_Full_Access_Object_Ref
;
21220 --------------------------
21221 -- Is_Volatile_Function --
21222 --------------------------
21224 function Is_Volatile_Function
(Func_Id
: Entity_Id
) return Boolean is
21226 pragma Assert
(Ekind
(Func_Id
) in E_Function | E_Generic_Function
);
21228 -- A protected function is volatile
21230 if Nkind
(Parent
(Unit_Declaration_Node
(Func_Id
))) =
21231 N_Protected_Definition
21235 -- An instance of Ada.Unchecked_Conversion is a volatile function if
21236 -- either the source or the target are effectively volatile.
21238 elsif Is_Unchecked_Conversion_Instance
(Func_Id
)
21239 and then Has_Effectively_Volatile_Profile
(Func_Id
)
21243 -- Otherwise the function is treated as volatile if it is subject to
21244 -- enabled pragma Volatile_Function.
21248 Is_Enabled_Pragma
(Get_Pragma
(Func_Id
, Pragma_Volatile_Function
));
21250 end Is_Volatile_Function
;
21252 ----------------------------
21253 -- Is_Volatile_Object_Ref --
21254 ----------------------------
21256 function Is_Volatile_Object_Ref
(N
: Node_Id
) return Boolean is
21257 function Is_Volatile_Object_Entity
(Id
: Entity_Id
) return Boolean;
21258 -- Determine whether arbitrary entity Id denotes an object that is
21261 function Prefix_Has_Volatile_Components
(P
: Node_Id
) return Boolean;
21262 -- Determine whether prefix P has volatile components. This requires
21263 -- the presence of a Volatile_Components aspect/pragma or that P be
21264 -- itself a volatile object as per RM C.6(8).
21266 ---------------------------------
21267 -- Is_Volatile_Object_Entity --
21268 ---------------------------------
21270 function Is_Volatile_Object_Entity
(Id
: Entity_Id
) return Boolean is
21274 and then (Is_Volatile
(Id
) or else Is_Volatile
(Etype
(Id
)));
21275 end Is_Volatile_Object_Entity
;
21277 ------------------------------------
21278 -- Prefix_Has_Volatile_Components --
21279 ------------------------------------
21281 function Prefix_Has_Volatile_Components
(P
: Node_Id
) return Boolean is
21282 Typ
: constant Entity_Id
:= Etype
(P
);
21285 if Is_Access_Type
(Typ
) then
21287 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
21290 return Has_Volatile_Components
(Dtyp
)
21291 or else Is_Volatile
(Dtyp
);
21294 elsif Has_Volatile_Components
(Typ
) then
21297 elsif Is_Entity_Name
(P
)
21298 and then Has_Volatile_Component
(Entity
(P
))
21302 elsif Is_Volatile_Object_Ref
(P
) then
21308 end Prefix_Has_Volatile_Components
;
21310 -- Start of processing for Is_Volatile_Object_Ref
21313 if Is_Entity_Name
(N
) then
21314 return Is_Volatile_Object_Entity
(Entity
(N
));
21316 elsif Is_Volatile
(Etype
(N
)) then
21319 elsif Nkind
(N
) = N_Indexed_Component
then
21320 return Prefix_Has_Volatile_Components
(Prefix
(N
));
21322 elsif Nkind
(N
) = N_Selected_Component
then
21323 return Prefix_Has_Volatile_Components
(Prefix
(N
))
21324 or else Is_Volatile
(Entity
(Selector_Name
(N
)));
21329 end Is_Volatile_Object_Ref
;
21331 -----------------------------
21332 -- Iterate_Call_Parameters --
21333 -----------------------------
21335 procedure Iterate_Call_Parameters
(Call
: Node_Id
) is
21336 Actual
: Node_Id
:= First_Actual
(Call
);
21337 Formal
: Entity_Id
:= First_Formal
(Get_Called_Entity
(Call
));
21340 while Present
(Formal
) and then Present
(Actual
) loop
21341 Handle_Parameter
(Formal
, Actual
);
21343 Next_Formal
(Formal
);
21344 Next_Actual
(Actual
);
21347 pragma Assert
(No
(Formal
));
21348 pragma Assert
(No
(Actual
));
21349 end Iterate_Call_Parameters
;
21351 -------------------------
21352 -- Kill_Current_Values --
21353 -------------------------
21355 procedure Kill_Current_Values
21357 Last_Assignment_Only
: Boolean := False)
21360 if Is_Assignable
(Ent
) then
21361 Set_Last_Assignment
(Ent
, Empty
);
21364 if Is_Object
(Ent
) then
21365 if not Last_Assignment_Only
then
21367 Set_Current_Value
(Ent
, Empty
);
21369 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags
21370 -- for a constant. Once the constant is elaborated, its value is
21371 -- not changed, therefore the associated flags that describe the
21372 -- value should not be modified either.
21374 if Ekind
(Ent
) = E_Constant
then
21377 -- Non-constant entities
21380 if not Can_Never_Be_Null
(Ent
) then
21381 Set_Is_Known_Non_Null
(Ent
, False);
21384 Set_Is_Known_Null
(Ent
, False);
21386 -- Reset the Is_Known_Valid flag unless the type is always
21387 -- valid. This does not apply to a loop parameter because its
21388 -- bounds are defined by the loop header and therefore always
21391 if not Is_Known_Valid
(Etype
(Ent
))
21392 and then Ekind
(Ent
) /= E_Loop_Parameter
21394 Set_Is_Known_Valid
(Ent
, False);
21399 end Kill_Current_Values
;
21401 procedure Kill_Current_Values
(Last_Assignment_Only
: Boolean := False) is
21405 -- Kill all saved checks, a special case of killing saved values
21407 if not Last_Assignment_Only
then
21411 -- Loop through relevant scopes, which includes the current scope and
21412 -- any parent scopes if the current scope is a block or a package.
21414 S
:= Current_Scope
;
21417 -- Clear current values of all entities in current scope
21422 Ent
:= First_Entity
(S
);
21423 while Present
(Ent
) loop
21424 Kill_Current_Values
(Ent
, Last_Assignment_Only
);
21429 -- If this is a not a subprogram, deal with parents
21431 if not Is_Subprogram
(S
) then
21433 exit Scope_Loop
when S
= Standard_Standard
;
21437 end loop Scope_Loop
;
21438 end Kill_Current_Values
;
21440 --------------------------
21441 -- Kill_Size_Check_Code --
21442 --------------------------
21444 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
21446 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
21447 and then Present
(Size_Check_Code
(E
))
21449 Remove
(Size_Check_Code
(E
));
21450 Set_Size_Check_Code
(E
, Empty
);
21452 end Kill_Size_Check_Code
;
21454 --------------------
21455 -- Known_Non_Null --
21456 --------------------
21458 function Known_Non_Null
(N
: Node_Id
) return Boolean is
21459 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
21466 -- The expression yields a non-null value ignoring simple flow analysis
21468 if Status
= Is_Non_Null
then
21471 -- Otherwise check whether N is a reference to an entity that appears
21472 -- within a conditional construct.
21474 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
21476 -- First check if we are in decisive conditional
21478 Get_Current_Value_Condition
(N
, Op
, Val
);
21480 if Known_Null
(Val
) then
21481 if Op
= N_Op_Eq
then
21483 elsif Op
= N_Op_Ne
then
21488 -- If OK to do replacement, test Is_Known_Non_Null flag
21492 if OK_To_Do_Constant_Replacement
(Id
) then
21493 return Is_Known_Non_Null
(Id
);
21497 -- Otherwise it is not possible to determine whether N yields a non-null
21501 end Known_Non_Null
;
21507 function Known_Null
(N
: Node_Id
) return Boolean is
21508 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
21515 -- The expression yields a null value ignoring simple flow analysis
21517 if Status
= Is_Null
then
21520 -- Otherwise check whether N is a reference to an entity that appears
21521 -- within a conditional construct.
21523 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
21525 -- First check if we are in decisive conditional
21527 Get_Current_Value_Condition
(N
, Op
, Val
);
21529 -- If Get_Current_Value_Condition were to return Val = N, then the
21530 -- recursion below could be infinite.
21533 raise Program_Error
;
21536 if Known_Null
(Val
) then
21537 if Op
= N_Op_Eq
then
21539 elsif Op
= N_Op_Ne
then
21544 -- If OK to do replacement, test Is_Known_Null flag
21548 if OK_To_Do_Constant_Replacement
(Id
) then
21549 return Is_Known_Null
(Id
);
21553 -- Otherwise it is not possible to determine whether N yields a null
21559 ---------------------------
21560 -- Last_Source_Statement --
21561 ---------------------------
21563 function Last_Source_Statement
(HSS
: Node_Id
) return Node_Id
is
21567 N
:= Last
(Statements
(HSS
));
21568 while Present
(N
) loop
21569 exit when Comes_From_Source
(N
);
21574 end Last_Source_Statement
;
21576 -----------------------
21577 -- Mark_Coextensions --
21578 -----------------------
21580 procedure Mark_Coextensions
(Context_Nod
: Node_Id
; Root_Nod
: Node_Id
) is
21581 Is_Dynamic
: Boolean;
21582 -- Indicates whether the context causes nested coextensions to be
21583 -- dynamic or static
21585 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
;
21586 -- Recognize an allocator node and label it as a dynamic coextension
21588 --------------------
21589 -- Mark_Allocator --
21590 --------------------
21592 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
is
21594 if Nkind
(N
) = N_Allocator
then
21596 Set_Is_Static_Coextension
(N
, False);
21597 Set_Is_Dynamic_Coextension
(N
);
21599 -- If the allocator expression is potentially dynamic, it may
21600 -- be expanded out of order and require dynamic allocation
21601 -- anyway, so we treat the coextension itself as dynamic.
21602 -- Potential optimization ???
21604 elsif Nkind
(Expression
(N
)) = N_Qualified_Expression
21605 and then Nkind
(Expression
(Expression
(N
))) = N_Op_Concat
21607 Set_Is_Static_Coextension
(N
, False);
21608 Set_Is_Dynamic_Coextension
(N
);
21610 Set_Is_Dynamic_Coextension
(N
, False);
21611 Set_Is_Static_Coextension
(N
);
21616 end Mark_Allocator
;
21618 procedure Mark_Allocators
is new Traverse_Proc
(Mark_Allocator
);
21620 -- Start of processing for Mark_Coextensions
21623 -- An allocator that appears on the right-hand side of an assignment is
21624 -- treated as a potentially dynamic coextension when the right-hand side
21625 -- is an allocator or a qualified expression.
21627 -- Obj := new ...'(new Coextension ...);
21629 if Nkind
(Context_Nod
) = N_Assignment_Statement
then
21630 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) in
21631 N_Allocator | N_Qualified_Expression
;
21633 -- An allocator that appears within the expression of a simple return
21634 -- statement is treated as a potentially dynamic coextension when the
21635 -- expression is either aggregate, allocator, or qualified expression.
21637 -- return (new Coextension ...);
21638 -- return new ...'(new Coextension ...);
21640 elsif Nkind
(Context_Nod
) = N_Simple_Return_Statement
then
21641 Is_Dynamic
:= Nkind
(Expression
(Context_Nod
)) in
21642 N_Aggregate | N_Allocator | N_Qualified_Expression
;
21644 -- An alloctor that appears within the initialization expression of an
21645 -- object declaration is considered a potentially dynamic coextension
21646 -- when the initialization expression is an allocator or a qualified
21649 -- Obj : ... := new ...'(new Coextension ...);
21651 -- A similar case arises when the object declaration is part of an
21652 -- extended return statement.
21654 -- return Obj : ... := new ...'(new Coextension ...);
21655 -- return Obj : ... := (new Coextension ...);
21657 elsif Nkind
(Context_Nod
) = N_Object_Declaration
then
21658 Is_Dynamic
:= Nkind
(Root_Nod
) in N_Allocator | N_Qualified_Expression
21659 or else Nkind
(Parent
(Context_Nod
)) = N_Extended_Return_Statement
;
21661 -- This routine should not be called with constructs that cannot contain
21665 raise Program_Error
;
21668 Mark_Allocators
(Root_Nod
);
21669 end Mark_Coextensions
;
21671 ---------------------------------
21672 -- Mark_Elaboration_Attributes --
21673 ---------------------------------
21675 procedure Mark_Elaboration_Attributes
21676 (N_Id
: Node_Or_Entity_Id
;
21677 Checks
: Boolean := False;
21678 Level
: Boolean := False;
21679 Modes
: Boolean := False;
21680 Warnings
: Boolean := False)
21682 function Elaboration_Checks_OK
21683 (Target_Id
: Entity_Id
;
21684 Context_Id
: Entity_Id
) return Boolean;
21685 -- Determine whether elaboration checks are enabled for target Target_Id
21686 -- which resides within context Context_Id.
21688 procedure Mark_Elaboration_Attributes_Id
(Id
: Entity_Id
);
21689 -- Preserve relevant attributes of the context in arbitrary entity Id
21691 procedure Mark_Elaboration_Attributes_Node
(N
: Node_Id
);
21692 -- Preserve relevant attributes of the context in arbitrary node N
21694 ---------------------------
21695 -- Elaboration_Checks_OK --
21696 ---------------------------
21698 function Elaboration_Checks_OK
21699 (Target_Id
: Entity_Id
;
21700 Context_Id
: Entity_Id
) return Boolean
21702 Encl_Scop
: Entity_Id
;
21705 -- Elaboration checks are suppressed for the target
21707 if Elaboration_Checks_Suppressed
(Target_Id
) then
21711 -- Otherwise elaboration checks are OK for the target, but may be
21712 -- suppressed for the context where the target is declared.
21714 Encl_Scop
:= Context_Id
;
21715 while Present
(Encl_Scop
) and then Encl_Scop
/= Standard_Standard
loop
21716 if Elaboration_Checks_Suppressed
(Encl_Scop
) then
21720 Encl_Scop
:= Scope
(Encl_Scop
);
21723 -- Neither the target nor its declarative context have elaboration
21724 -- checks suppressed.
21727 end Elaboration_Checks_OK
;
21729 ------------------------------------
21730 -- Mark_Elaboration_Attributes_Id --
21731 ------------------------------------
21733 procedure Mark_Elaboration_Attributes_Id
(Id
: Entity_Id
) is
21735 -- Mark the status of elaboration checks in effect. Do not reset the
21736 -- status in case the entity is reanalyzed with checks suppressed.
21738 if Checks
and then not Is_Elaboration_Checks_OK_Id
(Id
) then
21739 Set_Is_Elaboration_Checks_OK_Id
(Id
,
21740 Elaboration_Checks_OK
21742 Context_Id
=> Scope
(Id
)));
21745 -- Mark the status of elaboration warnings in effect. Do not reset
21746 -- the status in case the entity is reanalyzed with warnings off.
21748 if Warnings
and then not Is_Elaboration_Warnings_OK_Id
(Id
) then
21749 Set_Is_Elaboration_Warnings_OK_Id
(Id
, Elab_Warnings
);
21751 end Mark_Elaboration_Attributes_Id
;
21753 --------------------------------------
21754 -- Mark_Elaboration_Attributes_Node --
21755 --------------------------------------
21757 procedure Mark_Elaboration_Attributes_Node
(N
: Node_Id
) is
21758 function Extract_Name
(N
: Node_Id
) return Node_Id
;
21759 -- Obtain the Name attribute of call or instantiation N
21765 function Extract_Name
(N
: Node_Id
) return Node_Id
is
21771 -- A call to an entry family appears in indexed form
21773 if Nkind
(Nam
) = N_Indexed_Component
then
21774 Nam
:= Prefix
(Nam
);
21777 -- The name may also appear in qualified form
21779 if Nkind
(Nam
) = N_Selected_Component
then
21780 Nam
:= Selector_Name
(Nam
);
21788 Context_Id
: Entity_Id
;
21791 -- Start of processing for Mark_Elaboration_Attributes_Node
21794 -- Mark the status of elaboration checks in effect. Do not reset the
21795 -- status in case the node is reanalyzed with checks suppressed.
21797 if Checks
and then not Is_Elaboration_Checks_OK_Node
(N
) then
21799 -- Assignments, attribute references, and variable references do
21800 -- not have a "declarative" context.
21802 Context_Id
:= Empty
;
21804 -- The status of elaboration checks for calls and instantiations
21805 -- depends on the most recent pragma Suppress/Unsuppress, as well
21806 -- as the suppression status of the context where the target is
21810 -- function Func ...;
21814 -- procedure Main is
21815 -- pragma Suppress (Elaboration_Checks, Pack);
21816 -- X : ... := Pack.Func;
21819 -- In the example above, the call to Func has elaboration checks
21820 -- enabled because there is no active general purpose suppression
21821 -- pragma, however the elaboration checks of Pack are explicitly
21822 -- suppressed. As a result the elaboration checks of the call must
21823 -- be disabled in order to preserve this dependency.
21825 if Nkind
(N
) in N_Entry_Call_Statement
21827 | N_Function_Instantiation
21828 | N_Package_Instantiation
21829 | N_Procedure_Call_Statement
21830 | N_Procedure_Instantiation
21832 Nam
:= Extract_Name
(N
);
21834 if Is_Entity_Name
(Nam
) and then Present
(Entity
(Nam
)) then
21835 Context_Id
:= Scope
(Entity
(Nam
));
21839 Set_Is_Elaboration_Checks_OK_Node
(N
,
21840 Elaboration_Checks_OK
21841 (Target_Id
=> Empty
,
21842 Context_Id
=> Context_Id
));
21845 -- Mark the enclosing level of the node. Do not reset the status in
21846 -- case the node is relocated and reanalyzed.
21848 if Level
and then not Is_Declaration_Level_Node
(N
) then
21849 Set_Is_Declaration_Level_Node
(N
,
21850 Find_Enclosing_Level
(N
) = Declaration_Level
);
21853 -- Mark the Ghost and SPARK mode in effect
21856 if Ghost_Mode
= Ignore
then
21857 Set_Is_Ignored_Ghost_Node
(N
);
21860 if SPARK_Mode
= On
then
21861 Set_Is_SPARK_Mode_On_Node
(N
);
21865 -- Mark the status of elaboration warnings in effect. Do not reset
21866 -- the status in case the node is reanalyzed with warnings off.
21868 if Warnings
and then not Is_Elaboration_Warnings_OK_Node
(N
) then
21869 Set_Is_Elaboration_Warnings_OK_Node
(N
, Elab_Warnings
);
21871 end Mark_Elaboration_Attributes_Node
;
21873 -- Start of processing for Mark_Elaboration_Attributes
21876 -- Do not capture any elaboration-related attributes when switch -gnatH
21877 -- (legacy elaboration checking mode enabled) is in effect because the
21878 -- attributes are useless to the legacy model.
21880 if Legacy_Elaboration_Checks
then
21884 if Nkind
(N_Id
) in N_Entity
then
21885 Mark_Elaboration_Attributes_Id
(N_Id
);
21887 Mark_Elaboration_Attributes_Node
(N_Id
);
21889 end Mark_Elaboration_Attributes
;
21891 ----------------------------------------
21892 -- Mark_Save_Invocation_Graph_Of_Body --
21893 ----------------------------------------
21895 procedure Mark_Save_Invocation_Graph_Of_Body
is
21896 Main
: constant Node_Id
:= Cunit
(Main_Unit
);
21897 Main_Unit
: constant Node_Id
:= Unit
(Main
);
21898 Aux_Id
: Entity_Id
;
21901 Set_Save_Invocation_Graph_Of_Body
(Main
);
21903 -- Assume that the main unit does not have a complimentary unit
21907 -- Obtain the complimentary unit of the main unit
21909 if Nkind
(Main_Unit
) in N_Generic_Package_Declaration
21910 | N_Generic_Subprogram_Declaration
21911 | N_Package_Declaration
21912 | N_Subprogram_Declaration
21914 Aux_Id
:= Corresponding_Body
(Main_Unit
);
21916 elsif Nkind
(Main_Unit
) in N_Package_Body
21917 | N_Subprogram_Body
21918 | N_Subprogram_Renaming_Declaration
21920 Aux_Id
:= Corresponding_Spec
(Main_Unit
);
21923 if Present
(Aux_Id
) then
21924 Set_Save_Invocation_Graph_Of_Body
21925 (Parent
(Unit_Declaration_Node
(Aux_Id
)));
21927 end Mark_Save_Invocation_Graph_Of_Body
;
21929 ----------------------------------
21930 -- Matching_Static_Array_Bounds --
21931 ----------------------------------
21933 function Matching_Static_Array_Bounds
21935 R_Typ
: Node_Id
) return Boolean
21937 L_Ndims
: constant Nat
:= Number_Dimensions
(L_Typ
);
21938 R_Ndims
: constant Nat
:= Number_Dimensions
(R_Typ
);
21940 L_Index
: Node_Id
:= Empty
; -- init to ...
21941 R_Index
: Node_Id
:= Empty
; -- ...avoid warnings
21950 if L_Ndims
/= R_Ndims
then
21954 -- Unconstrained types do not have static bounds
21956 if not Is_Constrained
(L_Typ
) or else not Is_Constrained
(R_Typ
) then
21960 -- First treat specially the first dimension, as the lower bound and
21961 -- length of string literals are not stored like those of arrays.
21963 if Ekind
(L_Typ
) = E_String_Literal_Subtype
then
21964 L_Low
:= String_Literal_Low_Bound
(L_Typ
);
21965 L_Len
:= String_Literal_Length
(L_Typ
);
21967 L_Index
:= First_Index
(L_Typ
);
21968 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
21970 if Is_OK_Static_Expression
(L_Low
)
21972 Is_OK_Static_Expression
(L_High
)
21974 if Expr_Value
(L_High
) < Expr_Value
(L_Low
) then
21977 L_Len
:= (Expr_Value
(L_High
) - Expr_Value
(L_Low
)) + 1;
21984 if Ekind
(R_Typ
) = E_String_Literal_Subtype
then
21985 R_Low
:= String_Literal_Low_Bound
(R_Typ
);
21986 R_Len
:= String_Literal_Length
(R_Typ
);
21988 R_Index
:= First_Index
(R_Typ
);
21989 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
21991 if Is_OK_Static_Expression
(R_Low
)
21993 Is_OK_Static_Expression
(R_High
)
21995 if Expr_Value
(R_High
) < Expr_Value
(R_Low
) then
21998 R_Len
:= (Expr_Value
(R_High
) - Expr_Value
(R_Low
)) + 1;
22005 if (Is_OK_Static_Expression
(L_Low
)
22007 Is_OK_Static_Expression
(R_Low
))
22008 and then Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
22009 and then L_Len
= R_Len
22016 -- Then treat all other dimensions
22018 for Indx
in 2 .. L_Ndims
loop
22022 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
22023 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
22025 if (Is_OK_Static_Expression
(L_Low
) and then
22026 Is_OK_Static_Expression
(L_High
) and then
22027 Is_OK_Static_Expression
(R_Low
) and then
22028 Is_OK_Static_Expression
(R_High
))
22029 and then (Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
22031 Expr_Value
(L_High
) = Expr_Value
(R_High
))
22039 -- If we fall through the loop, all indexes matched
22042 end Matching_Static_Array_Bounds
;
22048 function Might_Raise
(N
: Node_Id
) return Boolean is
22049 Result
: Boolean := False;
22051 function Process
(N
: Node_Id
) return Traverse_Result
;
22052 -- Set Result to True if we find something that could raise an exception
22058 function Process
(N
: Node_Id
) return Traverse_Result
is
22060 if Nkind
(N
) in N_Procedure_Call_Statement
22062 | N_Raise_Statement
22063 | N_Raise_xxx_Error
22064 | N_Raise_Expression
22073 procedure Set_Result
is new Traverse_Proc
(Process
);
22075 -- Start of processing for Might_Raise
22078 -- False if exceptions can't be propagated
22080 if No_Exception_Handlers_Set
then
22084 -- If the checks handled by the back end are not disabled, we cannot
22085 -- ensure that no exception will be raised.
22087 if not Access_Checks_Suppressed
(Empty
)
22088 or else not Discriminant_Checks_Suppressed
(Empty
)
22089 or else not Range_Checks_Suppressed
(Empty
)
22090 or else not Index_Checks_Suppressed
(Empty
)
22091 or else Opt
.Stack_Checking_Enabled
22100 ----------------------------------------
22101 -- Nearest_Class_Condition_Subprogram --
22102 ----------------------------------------
22104 function Nearest_Class_Condition_Subprogram
22105 (Kind
: Condition_Kind
;
22106 Spec_Id
: Entity_Id
) return Entity_Id
22108 Subp_Id
: constant Entity_Id
:= Ultimate_Alias
(Spec_Id
);
22111 -- Prevent cascaded errors
22113 if not Is_Dispatching_Operation
(Subp_Id
) then
22116 -- No need to search if this subprogram has class-wide postconditions
22118 elsif Present
(Class_Condition
(Kind
, Subp_Id
)) then
22122 -- Process the contracts of inherited subprograms, looking for
22123 -- class-wide pre/postconditions.
22126 Subps
: constant Subprogram_List
:= Inherited_Subprograms
(Subp_Id
);
22127 Subp_Id
: Entity_Id
;
22130 for Index
in Subps
'Range loop
22131 Subp_Id
:= Subps
(Index
);
22133 if Present
(Alias
(Subp_Id
)) then
22134 Subp_Id
:= Ultimate_Alias
(Subp_Id
);
22137 -- Wrappers of class-wide pre/postconditions reference the
22138 -- parent primitive that has the inherited contract.
22140 if Is_Wrapper
(Subp_Id
)
22141 and then Present
(LSP_Subprogram
(Subp_Id
))
22143 Subp_Id
:= LSP_Subprogram
(Subp_Id
);
22146 if Present
(Class_Condition
(Kind
, Subp_Id
)) then
22153 end Nearest_Class_Condition_Subprogram
;
22155 --------------------------------
22156 -- Nearest_Enclosing_Instance --
22157 --------------------------------
22159 function Nearest_Enclosing_Instance
(E
: Entity_Id
) return Entity_Id
is
22164 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
22165 if Is_Generic_Instance
(Inst
) then
22169 Inst
:= Scope
(Inst
);
22173 end Nearest_Enclosing_Instance
;
22175 ------------------------
22176 -- Needs_Finalization --
22177 ------------------------
22179 function Needs_Finalization
(Typ
: Entity_Id
) return Boolean is
22180 function Has_Some_Controlled_Component
22181 (Input_Typ
: Entity_Id
) return Boolean;
22182 -- Determine whether type Input_Typ has at least one controlled
22185 -----------------------------------
22186 -- Has_Some_Controlled_Component --
22187 -----------------------------------
22189 function Has_Some_Controlled_Component
22190 (Input_Typ
: Entity_Id
) return Boolean
22195 -- When a type is already frozen and has at least one controlled
22196 -- component, or is manually decorated, it is sufficient to inspect
22197 -- flag Has_Controlled_Component.
22199 if Has_Controlled_Component
(Input_Typ
) then
22202 -- Otherwise inspect the internals of the type
22204 elsif not Is_Frozen
(Input_Typ
) then
22205 if Is_Array_Type
(Input_Typ
) then
22206 return Needs_Finalization
(Component_Type
(Input_Typ
));
22208 elsif Is_Record_Type
(Input_Typ
) then
22209 Comp
:= First_Component
(Input_Typ
);
22210 while Present
(Comp
) loop
22211 if Needs_Finalization
(Etype
(Comp
)) then
22215 Next_Component
(Comp
);
22221 end Has_Some_Controlled_Component
;
22223 -- Start of processing for Needs_Finalization
22226 -- Certain run-time configurations and targets do not provide support
22227 -- for controlled types.
22229 if Restriction_Active
(No_Finalization
) then
22232 -- C++ types are not considered controlled. It is assumed that the non-
22233 -- Ada side will handle their clean up.
22235 elsif Convention
(Typ
) = Convention_CPP
then
22238 -- Class-wide types are treated as controlled because derivations from
22239 -- the root type may introduce controlled components.
22241 elsif Is_Class_Wide_Type
(Typ
) then
22244 -- Concurrent types are controlled as long as their corresponding record
22247 elsif Is_Concurrent_Type
(Typ
)
22248 and then Present
(Corresponding_Record_Type
(Typ
))
22249 and then Needs_Finalization
(Corresponding_Record_Type
(Typ
))
22253 -- Otherwise the type is controlled when it is either derived from type
22254 -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or
22255 -- contains at least one controlled component.
22259 Is_Controlled
(Typ
) or else Has_Some_Controlled_Component
(Typ
);
22261 end Needs_Finalization
;
22263 ----------------------
22264 -- Needs_One_Actual --
22265 ----------------------
22267 function Needs_One_Actual
(E
: Entity_Id
) return Boolean is
22268 Formal
: Entity_Id
;
22271 -- Ada 2005 or later, and formals present. The first formal must be
22272 -- of a type that supports prefix notation: a controlling argument,
22273 -- a class-wide type, or an access to such.
22275 if Ada_Version
>= Ada_2005
22276 and then Present
(First_Formal
(E
))
22277 and then No
(Default_Value
(First_Formal
(E
)))
22279 (Is_Controlling_Formal
(First_Formal
(E
))
22280 or else Is_Class_Wide_Type
(Etype
(First_Formal
(E
)))
22281 or else Is_Anonymous_Access_Type
(Etype
(First_Formal
(E
))))
22283 Formal
:= Next_Formal
(First_Formal
(E
));
22284 while Present
(Formal
) loop
22285 if No
(Default_Value
(Formal
)) then
22289 Next_Formal
(Formal
);
22294 -- Ada 83/95 or no formals
22299 end Needs_One_Actual
;
22301 ----------------------------
22302 -- Needs_Secondary_Stack --
22303 ----------------------------
22305 function Needs_Secondary_Stack
(Id
: Entity_Id
) return Boolean is
22306 pragma Assert
(if Present
(Id
) then Ekind
(Id
) in E_Void | Type_Kind
);
22308 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean;
22309 -- Called for untagged record and protected types. Return True if the
22310 -- size of function results is known in the caller for Typ.
22312 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean;
22313 -- Returns True if Typ is a nonlimited record with defaulted
22314 -- discriminants whose max size makes it unsuitable for allocating on
22315 -- the primary stack.
22317 ------------------------------
22318 -- Caller_Known_Size_Record --
22319 ------------------------------
22321 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean is
22322 pragma Assert
(if Present
(Typ
) then Typ
= Underlying_Type
(Typ
));
22324 function Depends_On_Discriminant
(Typ
: Entity_Id
) return Boolean;
22325 -- Called for untagged record and protected types. Return True if Typ
22326 -- depends on discriminants, either directly when it is unconstrained
22327 -- or indirectly when it is constrained by uplevel discriminants.
22329 -----------------------------
22330 -- Depends_On_Discriminant --
22331 -----------------------------
22333 function Depends_On_Discriminant
(Typ
: Entity_Id
) return Boolean is
22337 if Has_Discriminants
(Typ
) then
22338 if not Is_Constrained
(Typ
) then
22342 Cons
:= First_Elmt
(Discriminant_Constraint
(Typ
));
22343 while Present
(Cons
) loop
22344 if Nkind
(Node
(Cons
)) = N_Identifier
22345 and then Ekind
(Entity
(Node
(Cons
))) = E_Discriminant
22356 end Depends_On_Discriminant
;
22359 -- This is a protected type without Corresponding_Record_Type set,
22360 -- typically because expansion is disabled. The safe thing to do is
22361 -- to return True, so Needs_Secondary_Stack returns False.
22367 -- First see if we have a variant part and return False if it depends
22368 -- on discriminants.
22370 if Has_Variant_Part
(Typ
) and then Depends_On_Discriminant
(Typ
) then
22374 -- Then loop over components and return False if their subtype has a
22375 -- caller-unknown size, possibly recursively.
22377 -- ??? This is overly conservative, an array could be nested inside
22378 -- some other record that is constrained by nondiscriminants. That
22379 -- is, the recursive calls are too conservative.
22385 Comp
:= First_Component
(Typ
);
22386 while Present
(Comp
) loop
22388 Comp_Type
: constant Entity_Id
:=
22389 Underlying_Type
(Etype
(Comp
));
22392 if Is_Record_Type
(Comp_Type
) then
22393 if not Caller_Known_Size_Record
(Comp_Type
) then
22397 elsif Is_Protected_Type
(Comp_Type
) then
22398 if not Caller_Known_Size_Record
22399 (Corresponding_Record_Type
(Comp_Type
))
22404 elsif Is_Array_Type
(Comp_Type
) then
22405 if Size_Depends_On_Discriminant
(Comp_Type
) then
22411 Next_Component
(Comp
);
22416 end Caller_Known_Size_Record
;
22418 ------------------------------
22419 -- Large_Max_Size_Mutable --
22420 ------------------------------
22422 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean is
22423 pragma Assert
(Typ
= Underlying_Type
(Typ
));
22425 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean;
22426 -- Returns true if the discrete type T has a large range
22428 ----------------------------
22429 -- Is_Large_Discrete_Type --
22430 ----------------------------
22432 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean is
22433 Threshold
: constant Int
:= 16;
22434 -- Arbitrary threshold above which we consider it "large". We want
22435 -- a fairly large threshold, because these large types really
22436 -- shouldn't have default discriminants in the first place, in
22440 return UI_To_Int
(RM_Size
(T
)) > Threshold
;
22441 end Is_Large_Discrete_Type
;
22443 -- Start of processing for Large_Max_Size_Mutable
22446 if Is_Record_Type
(Typ
)
22447 and then not Is_Limited_View
(Typ
)
22448 and then Has_Defaulted_Discriminants
(Typ
)
22450 -- Loop through the components, looking for an array whose upper
22451 -- bound(s) depends on discriminants, where both the subtype of
22452 -- the discriminant and the index subtype are too large.
22458 Comp
:= First_Component
(Typ
);
22459 while Present
(Comp
) loop
22461 Comp_Type
: constant Entity_Id
:=
22462 Underlying_Type
(Etype
(Comp
));
22469 if Is_Array_Type
(Comp_Type
) then
22470 Indx
:= First_Index
(Comp_Type
);
22472 while Present
(Indx
) loop
22473 Ityp
:= Etype
(Indx
);
22474 Hi
:= Type_High_Bound
(Ityp
);
22476 if Nkind
(Hi
) = N_Identifier
22477 and then Ekind
(Entity
(Hi
)) = E_Discriminant
22478 and then Is_Large_Discrete_Type
(Ityp
)
22479 and then Is_Large_Discrete_Type
22480 (Etype
(Entity
(Hi
)))
22490 Next_Component
(Comp
);
22496 end Large_Max_Size_Mutable
;
22498 -- Local declarations
22500 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
22502 -- Start of processing for Needs_Secondary_Stack
22505 -- This is a private type which is not completed yet. This can only
22506 -- happen in a default expression (of a formal parameter or of a
22507 -- record component). The safe thing to do is to return False.
22513 -- Do not expand transient scope for non-existent procedure return or
22514 -- string literal types.
22516 if Typ
= Standard_Void_Type
22517 or else Ekind
(Typ
) = E_String_Literal_Subtype
22521 -- If Typ is a generic formal incomplete type, then we want to look at
22522 -- the actual type.
22524 elsif Ekind
(Typ
) = E_Record_Subtype
22525 and then Present
(Cloned_Subtype
(Typ
))
22527 return Needs_Secondary_Stack
(Cloned_Subtype
(Typ
));
22529 -- Class-wide types obviously have an unknown size. For specific tagged
22530 -- types, if a call returning one of them is dispatching on result, and
22531 -- this type is not returned on the secondary stack, then the call goes
22532 -- through a thunk that only moves the result from the primary onto the
22533 -- secondary stack, because the computation of the size of the result is
22534 -- possible but complex from the outside.
22536 elsif Is_Class_Wide_Type
(Typ
) then
22539 -- If the return slot of the back end cannot be accessed, then there
22540 -- is no way to call Adjust at the right time for the return object if
22541 -- the type needs finalization, so the return object must be allocated
22542 -- on the secondary stack.
22544 elsif not Back_End_Return_Slot
and then Needs_Finalization
(Typ
) then
22547 -- Definite subtypes have a known size. This includes all elementary
22548 -- types. Tasks have a known size even if they have discriminants, so
22549 -- we return False here, with one exception:
22550 -- For a type like:
22551 -- type T (Last : Natural := 0) is
22552 -- X : String (1 .. Last);
22554 -- we return True. That's because for "P(F(...));", where F returns T,
22555 -- we don't know the size of the result at the call site, so if we
22556 -- allocated it on the primary stack, we would have to allocate the
22557 -- maximum size, which is way too big.
22559 elsif Is_Definite_Subtype
(Typ
) or else Is_Task_Type
(Typ
) then
22560 return Large_Max_Size_Mutable
(Typ
);
22562 -- Indefinite (discriminated) record type
22564 elsif Is_Record_Type
(Typ
) then
22565 return not Caller_Known_Size_Record
(Typ
);
22567 -- Indefinite (discriminated) protected type
22569 elsif Is_Protected_Type
(Typ
) then
22570 return not Caller_Known_Size_Record
(Corresponding_Record_Type
(Typ
));
22572 -- Unconstrained array type
22575 pragma Assert
(Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
));
22578 end Needs_Secondary_Stack
;
22580 ---------------------------------
22581 -- Needs_Simple_Initialization --
22582 ---------------------------------
22584 function Needs_Simple_Initialization
22586 Consider_IS
: Boolean := True) return Boolean
22588 Consider_IS_NS
: constant Boolean :=
22589 Normalize_Scalars
or (Initialize_Scalars
and Consider_IS
);
22592 -- Never need initialization if it is suppressed
22594 if Initialization_Suppressed
(Typ
) then
22598 -- Check for private type, in which case test applies to the underlying
22599 -- type of the private type.
22601 if Is_Private_Type
(Typ
) then
22603 RT
: constant Entity_Id
:= Underlying_Type
(Typ
);
22605 if Present
(RT
) then
22606 return Needs_Simple_Initialization
(RT
);
22612 -- Scalar type with Default_Value aspect requires initialization
22614 elsif Is_Scalar_Type
(Typ
) and then Has_Default_Aspect
(Typ
) then
22617 -- Cases needing simple initialization are access types, and, if pragma
22618 -- Normalize_Scalars or Initialize_Scalars is in effect, then all scalar
22621 elsif Is_Access_Type
(Typ
)
22622 or else (Consider_IS_NS
and then Is_Scalar_Type
(Typ
))
22626 -- If Initialize/Normalize_Scalars is in effect, string objects also
22627 -- need initialization, unless they are created in the course of
22628 -- expanding an aggregate (since in the latter case they will be
22629 -- filled with appropriate initializing values before they are used).
22631 elsif Consider_IS_NS
22632 and then Is_Standard_String_Type
(Typ
)
22634 (not Is_Itype
(Typ
)
22635 or else Nkind
(Associated_Node_For_Itype
(Typ
)) /= N_Aggregate
)
22642 end Needs_Simple_Initialization
;
22644 -------------------------------------
22645 -- Needs_Variable_Reference_Marker --
22646 -------------------------------------
22648 function Needs_Variable_Reference_Marker
22650 Calls_OK
: Boolean) return Boolean
22652 function Within_Suitable_Context
(Ref
: Node_Id
) return Boolean;
22653 -- Deteremine whether variable reference Ref appears within a suitable
22654 -- context that allows the creation of a marker.
22656 -----------------------------
22657 -- Within_Suitable_Context --
22658 -----------------------------
22660 function Within_Suitable_Context
(Ref
: Node_Id
) return Boolean is
22665 while Present
(Par
) loop
22667 -- The context is not suitable when the reference appears within
22668 -- the formal part of an instantiation which acts as compilation
22669 -- unit because there is no proper list for the insertion of the
22672 if Nkind
(Par
) = N_Generic_Association
22673 and then Nkind
(Parent
(Par
)) in N_Generic_Instantiation
22674 and then Nkind
(Parent
(Parent
(Par
))) = N_Compilation_Unit
22678 -- The context is not suitable when the reference appears within
22679 -- a pragma. If the pragma has run-time semantics, the reference
22680 -- will be reconsidered once the pragma is expanded.
22682 elsif Nkind
(Par
) = N_Pragma
then
22685 -- The context is not suitable when the reference appears within a
22686 -- subprogram call, and the caller requests this behavior.
22689 and then Nkind
(Par
) in N_Entry_Call_Statement
22691 | N_Procedure_Call_Statement
22695 -- Prevent the search from going too far
22697 elsif Is_Body_Or_Package_Declaration
(Par
) then
22701 Par
:= Parent
(Par
);
22705 end Within_Suitable_Context
;
22710 Var_Id
: Entity_Id
;
22712 -- Start of processing for Needs_Variable_Reference_Marker
22715 -- No marker needs to be created when switch -gnatH (legacy elaboration
22716 -- checking mode enabled) is in effect because the legacy ABE mechanism
22717 -- does not use markers.
22719 if Legacy_Elaboration_Checks
then
22722 -- No marker needs to be created when the reference is preanalyzed
22723 -- because the marker will be inserted in the wrong place.
22725 elsif Preanalysis_Active
then
22728 -- Only references warrant a marker
22730 elsif Nkind
(N
) not in N_Expanded_Name | N_Identifier
then
22733 -- Only source references warrant a marker
22735 elsif not Comes_From_Source
(N
) then
22738 -- No marker needs to be created when the reference is erroneous, left
22739 -- in a bad state, or does not denote a variable.
22741 elsif not (Present
(Entity
(N
))
22742 and then Ekind
(Entity
(N
)) = E_Variable
22743 and then Entity
(N
) /= Any_Id
)
22748 Var_Id
:= Entity
(N
);
22749 Prag
:= SPARK_Pragma
(Var_Id
);
22751 -- Both the variable and reference must appear in SPARK_Mode On regions
22752 -- because this elaboration scenario falls under the SPARK rules.
22754 if not (Comes_From_Source
(Var_Id
)
22755 and then Present
(Prag
)
22756 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
22757 and then Is_SPARK_Mode_On_Node
(N
))
22761 -- No marker needs to be created when the reference does not appear
22762 -- within a suitable context (see body for details).
22764 -- Performance note: parent traversal
22766 elsif not Within_Suitable_Context
(N
) then
22770 -- At this point it is known that the variable reference will play a
22771 -- role in ABE diagnostics and requires a marker.
22774 end Needs_Variable_Reference_Marker
;
22776 ------------------------
22777 -- New_Copy_List_Tree --
22778 ------------------------
22780 function New_Copy_List_Tree
(List
: List_Id
) return List_Id
is
22785 if List
= No_List
then
22792 while Present
(E
) loop
22793 Append
(New_Copy_Tree
(E
), NL
);
22799 end New_Copy_List_Tree
;
22801 ----------------------------
22802 -- New_Copy_Separate_List --
22803 ----------------------------
22805 function New_Copy_Separate_List
(List
: List_Id
) return List_Id
is
22807 if List
= No_List
then
22812 List_Copy
: constant List_Id
:= New_List
;
22813 N
: Node_Id
:= First
(List
);
22816 while Present
(N
) loop
22817 Append
(New_Copy_Separate_Tree
(N
), List_Copy
);
22824 end New_Copy_Separate_List
;
22826 ----------------------------
22827 -- New_Copy_Separate_Tree --
22828 ----------------------------
22830 function New_Copy_Separate_Tree
(Source
: Node_Id
) return Node_Id
is
22831 function Search_Decl
(N
: Node_Id
) return Traverse_Result
;
22832 -- Subtree visitor which collects declarations
22834 procedure Search_Declarations
is new Traverse_Proc
(Search_Decl
);
22835 -- Subtree visitor instantiation
22843 function Search_Decl
(N
: Node_Id
) return Traverse_Result
is
22845 if Nkind
(N
) in N_Declaration
then
22846 Append_New_Elmt
(N
, Decls
);
22854 Source_Copy
: constant Node_Id
:= New_Copy_Tree
(Source
);
22856 -- Start of processing for New_Copy_Separate_Tree
22860 Search_Declarations
(Source_Copy
);
22862 -- Associate a new Entity with all the subtree declarations (keeping
22863 -- their original name).
22865 if Present
(Decls
) then
22872 Elmt
:= First_Elmt
(Decls
);
22873 while Present
(Elmt
) loop
22874 Decl
:= Node
(Elmt
);
22875 New_E
:= Make_Temporary
(Sloc
(Decl
), 'P');
22877 if Nkind
(Decl
) = N_Expression_Function
then
22878 Decl
:= Specification
(Decl
);
22881 if Nkind
(Decl
) in N_Function_Instantiation
22882 | N_Function_Specification
22883 | N_Generic_Function_Renaming_Declaration
22884 | N_Generic_Package_Renaming_Declaration
22885 | N_Generic_Procedure_Renaming_Declaration
22887 | N_Package_Instantiation
22888 | N_Package_Renaming_Declaration
22889 | N_Package_Specification
22890 | N_Procedure_Instantiation
22891 | N_Procedure_Specification
22893 Set_Chars
(New_E
, Chars
(Defining_Unit_Name
(Decl
)));
22894 Set_Defining_Unit_Name
(Decl
, New_E
);
22896 Set_Chars
(New_E
, Chars
(Defining_Identifier
(Decl
)));
22897 Set_Defining_Identifier
(Decl
, New_E
);
22905 return Source_Copy
;
22906 end New_Copy_Separate_Tree
;
22908 -------------------
22909 -- New_Copy_Tree --
22910 -------------------
22912 -- The following tables play a key role in replicating entities and Itypes.
22913 -- They are intentionally declared at the library level rather than within
22914 -- New_Copy_Tree to avoid elaborating them on each call. This performance
22915 -- optimization saves up to 2% of the entire compilation time spent in the
22916 -- front end. Care should be taken to reset the tables on each new call to
22919 NCT_Table_Max
: constant := 511;
22921 subtype NCT_Table_Index
is Nat
range 0 .. NCT_Table_Max
- 1;
22923 function NCT_Table_Hash
(Key
: Node_Or_Entity_Id
) return NCT_Table_Index
;
22924 -- Obtain the hash value of node or entity Key
22926 --------------------
22927 -- NCT_Table_Hash --
22928 --------------------
22930 function NCT_Table_Hash
(Key
: Node_Or_Entity_Id
) return NCT_Table_Index
is
22932 return NCT_Table_Index
(Key
mod NCT_Table_Max
);
22933 end NCT_Table_Hash
;
22935 ----------------------
22936 -- NCT_New_Entities --
22937 ----------------------
22939 -- The following table maps old entities and Itypes to their corresponding
22940 -- new entities and Itypes.
22944 package NCT_New_Entities
is new Simple_HTable
(
22945 Header_Num
=> NCT_Table_Index
,
22946 Element
=> Entity_Id
,
22947 No_Element
=> Empty
,
22949 Hash
=> NCT_Table_Hash
,
22952 ------------------------
22953 -- NCT_Pending_Itypes --
22954 ------------------------
22956 -- The following table maps old Associated_Node_For_Itype nodes to a set of
22957 -- new itypes. Given a set of old Itypes Aaa, Bbb, and Ccc, where all three
22958 -- have the same Associated_Node_For_Itype Ppp, and their corresponding new
22959 -- Itypes Xxx, Yyy, Zzz, the table contains the following mapping:
22961 -- Ppp -> (Xxx, Yyy, Zzz)
22963 -- The set is expressed as an Elist
22965 package NCT_Pending_Itypes
is new Simple_HTable
(
22966 Header_Num
=> NCT_Table_Index
,
22967 Element
=> Elist_Id
,
22968 No_Element
=> No_Elist
,
22970 Hash
=> NCT_Table_Hash
,
22973 NCT_Tables_In_Use
: Boolean := False;
22974 -- This flag keeps track of whether the two tables NCT_New_Entities and
22975 -- NCT_Pending_Itypes are in use. The flag is part of an optimization
22976 -- where certain operations are not performed if the tables are not in
22977 -- use. This saves up to 8% of the entire compilation time spent in the
22980 -------------------
22981 -- New_Copy_Tree --
22982 -------------------
22984 function New_Copy_Tree
22986 Map
: Elist_Id
:= No_Elist
;
22987 New_Sloc
: Source_Ptr
:= No_Location
;
22988 New_Scope
: Entity_Id
:= Empty
;
22989 Scopes_In_EWA_OK
: Boolean := False) return Node_Id
22991 -- This routine performs low-level tree manipulations and needs access
22992 -- to the internals of the tree.
22994 EWA_Level
: Nat
:= 0;
22995 -- This counter keeps track of how many N_Expression_With_Actions nodes
22996 -- are encountered during a depth-first traversal of the subtree. These
22997 -- nodes may define new entities in their Actions lists and thus require
22998 -- special processing.
23000 EWA_Inner_Scope_Level
: Nat
:= 0;
23001 -- This counter keeps track of how many scoping constructs appear within
23002 -- an N_Expression_With_Actions node.
23004 procedure Add_New_Entity
(Old_Id
: Entity_Id
; New_Id
: Entity_Id
);
23005 pragma Inline
(Add_New_Entity
);
23006 -- Add an entry in the NCT_New_Entities table which maps key Old_Id to
23007 -- value New_Id. Old_Id is an entity which appears within the Actions
23008 -- list of an N_Expression_With_Actions node, or within an entity map.
23009 -- New_Id is the corresponding new entity generated during Phase 1.
23011 procedure Add_Pending_Itype
(Assoc_Nod
: Node_Id
; Itype
: Entity_Id
);
23012 pragma Inline
(Add_Pending_Itype
);
23013 -- Add an entry in the NCT_Pending_Itypes which maps key Assoc_Nod to
23014 -- value Itype. Assoc_Nod is the associated node of an itype. Itype is
23017 procedure Build_NCT_Tables
(Entity_Map
: Elist_Id
);
23018 pragma Inline
(Build_NCT_Tables
);
23019 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with the
23020 -- information supplied in entity map Entity_Map. The format of the
23021 -- entity map must be as follows:
23023 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
23025 function Copy_Any_Node_With_Replacement
23026 (N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
;
23027 pragma Inline
(Copy_Any_Node_With_Replacement
);
23028 -- Replicate entity or node N by invoking one of the following routines:
23030 -- Copy_Node_With_Replacement
23031 -- Corresponding_Entity
23033 function Copy_Elist_With_Replacement
(List
: Elist_Id
) return Elist_Id
;
23034 -- Replicate the elements of entity list List
23036 function Copy_Field_With_Replacement
23038 Old_Par
: Node_Id
:= Empty
;
23039 New_Par
: Node_Id
:= Empty
;
23040 Semantic
: Boolean := False) return Union_Id
;
23041 -- Replicate field Field by invoking one of the following routines:
23043 -- Copy_Elist_With_Replacement
23044 -- Copy_List_With_Replacement
23045 -- Copy_Node_With_Replacement
23046 -- Corresponding_Entity
23048 -- If the field is not an entity list, entity, itype, syntactic list,
23049 -- or node, then the field is returned unchanged. The routine always
23050 -- replicates entities, itypes, and valid syntactic fields. Old_Par is
23051 -- the expected parent of a syntactic field. New_Par is the new parent
23052 -- associated with a replicated syntactic field. Flag Semantic should
23053 -- be set when the input is a semantic field.
23055 function Copy_List_With_Replacement
(List
: List_Id
) return List_Id
;
23056 -- Replicate the elements of syntactic list List
23058 function Copy_Node_With_Replacement
(N
: Node_Id
) return Node_Id
;
23059 -- Replicate node N
23061 function Corresponding_Entity
(Id
: Entity_Id
) return Entity_Id
;
23062 pragma Inline
(Corresponding_Entity
);
23063 -- Return the corresponding new entity of Id generated during Phase 1.
23064 -- If there is no such entity, return Id.
23066 function In_Entity_Map
23068 Entity_Map
: Elist_Id
) return Boolean;
23069 pragma Inline
(In_Entity_Map
);
23070 -- Determine whether entity Id is one of the old ids specified in entity
23071 -- map Entity_Map. The format of the entity map must be as follows:
23073 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
23075 procedure Update_CFS_Sloc
(N
: Node_Or_Entity_Id
);
23076 pragma Inline
(Update_CFS_Sloc
);
23077 -- Update the Comes_From_Source and Sloc attributes of node or entity N
23079 procedure Update_Named_Associations
23080 (Old_Call
: Node_Id
;
23081 New_Call
: Node_Id
);
23082 pragma Inline
(Update_Named_Associations
);
23083 -- Update semantic chain First/Next_Named_Association of call New_call
23084 -- based on call Old_Call.
23086 procedure Update_New_Entities
(Entity_Map
: Elist_Id
);
23087 pragma Inline
(Update_New_Entities
);
23088 -- Update the semantic attributes of all new entities generated during
23089 -- Phase 1 that do not appear in entity map Entity_Map. The format of
23090 -- the entity map must be as follows:
23092 -- Old_Id1, New_Id1, Old_Id2, New_Id2, .., Old_IdN, New_IdN
23094 procedure Update_Pending_Itypes
23095 (Old_Assoc
: Node_Id
;
23096 New_Assoc
: Node_Id
);
23097 pragma Inline
(Update_Pending_Itypes
);
23098 -- Update semantic attribute Associated_Node_For_Itype to refer to node
23099 -- New_Assoc for all itypes whose associated node is Old_Assoc.
23101 procedure Update_Semantic_Fields
(Id
: Entity_Id
);
23102 pragma Inline
(Update_Semantic_Fields
);
23103 -- Subsidiary to Update_New_Entities. Update semantic fields of entity
23106 procedure Visit_Any_Node
(N
: Node_Or_Entity_Id
);
23107 pragma Inline
(Visit_Any_Node
);
23108 -- Visit entity of node N by invoking one of the following routines:
23114 procedure Visit_Elist
(List
: Elist_Id
);
23115 -- Visit the elements of entity list List
23117 procedure Visit_Entity
(Id
: Entity_Id
);
23118 -- Visit entity Id. This action may create a new entity of Id and save
23119 -- it in table NCT_New_Entities.
23121 procedure Visit_Field
23123 Par_Nod
: Node_Id
:= Empty
;
23124 Semantic
: Boolean := False);
23125 -- Visit field Field by invoking one of the following routines:
23133 -- If the field is not an entity list, entity, itype, syntactic list,
23134 -- or node, then the field is not visited. The routine always visits
23135 -- valid syntactic fields. Par_Nod is the expected parent of the
23136 -- syntactic field. Flag Semantic should be set when the input is a
23139 procedure Visit_Itype
(Itype
: Entity_Id
);
23140 -- Visit itype Itype. This action may create a new entity for Itype and
23141 -- save it in table NCT_New_Entities. In addition, the routine may map
23142 -- the associated node of Itype to the new itype in NCT_Pending_Itypes.
23144 procedure Visit_List
(List
: List_Id
);
23145 -- Visit the elements of syntactic list List
23147 procedure Visit_Node
(N
: Node_Id
);
23150 procedure Visit_Semantic_Fields
(Id
: Entity_Id
);
23151 pragma Inline
(Visit_Semantic_Fields
);
23152 -- Subsidiary to Visit_Entity and Visit_Itype. Visit common semantic
23153 -- fields of entity or itype Id.
23155 --------------------
23156 -- Add_New_Entity --
23157 --------------------
23159 procedure Add_New_Entity
(Old_Id
: Entity_Id
; New_Id
: Entity_Id
) is
23161 pragma Assert
(Present
(Old_Id
));
23162 pragma Assert
(Present
(New_Id
));
23163 pragma Assert
(Nkind
(Old_Id
) in N_Entity
);
23164 pragma Assert
(Nkind
(New_Id
) in N_Entity
);
23166 NCT_Tables_In_Use
:= True;
23168 -- Sanity check the NCT_New_Entities table. No previous mapping with
23169 -- key Old_Id should exist.
23171 pragma Assert
(No
(NCT_New_Entities
.Get
(Old_Id
)));
23173 -- Establish the mapping
23175 -- Old_Id -> New_Id
23177 NCT_New_Entities
.Set
(Old_Id
, New_Id
);
23178 end Add_New_Entity
;
23180 -----------------------
23181 -- Add_Pending_Itype --
23182 -----------------------
23184 procedure Add_Pending_Itype
(Assoc_Nod
: Node_Id
; Itype
: Entity_Id
) is
23188 pragma Assert
(Present
(Assoc_Nod
));
23189 pragma Assert
(Present
(Itype
));
23190 pragma Assert
(Nkind
(Itype
) in N_Entity
);
23191 pragma Assert
(Is_Itype
(Itype
));
23193 NCT_Tables_In_Use
:= True;
23195 -- It is not possible to sanity check the NCT_Pendint_Itypes table
23196 -- directly because a single node may act as the associated node for
23197 -- multiple itypes.
23199 Itypes
:= NCT_Pending_Itypes
.Get
(Assoc_Nod
);
23201 if No
(Itypes
) then
23202 Itypes
:= New_Elmt_List
;
23203 NCT_Pending_Itypes
.Set
(Assoc_Nod
, Itypes
);
23206 -- Establish the mapping
23208 -- Assoc_Nod -> (Itype, ...)
23210 -- Avoid inserting the same itype multiple times. This involves a
23211 -- linear search, however the set of itypes with the same associated
23212 -- node is very small.
23214 Append_Unique_Elmt
(Itype
, Itypes
);
23215 end Add_Pending_Itype
;
23217 ----------------------
23218 -- Build_NCT_Tables --
23219 ----------------------
23221 procedure Build_NCT_Tables
(Entity_Map
: Elist_Id
) is
23223 Old_Id
: Entity_Id
;
23224 New_Id
: Entity_Id
;
23227 -- Nothing to do when there is no entity map
23229 if No
(Entity_Map
) then
23233 Elmt
:= First_Elmt
(Entity_Map
);
23234 while Present
(Elmt
) loop
23236 -- Extract the (Old_Id, New_Id) pair from the entity map
23238 Old_Id
:= Node
(Elmt
);
23241 New_Id
:= Node
(Elmt
);
23244 -- Establish the following mapping within table NCT_New_Entities
23246 -- Old_Id -> New_Id
23248 Add_New_Entity
(Old_Id
, New_Id
);
23250 -- Establish the following mapping within table NCT_Pending_Itypes
23251 -- when the new entity is an itype.
23253 -- Assoc_Nod -> (New_Id, ...)
23255 -- IMPORTANT: the associated node is that of the old itype because
23256 -- the node will be replicated in Phase 2.
23258 if Is_Itype
(Old_Id
) then
23260 (Assoc_Nod
=> Associated_Node_For_Itype
(Old_Id
),
23264 end Build_NCT_Tables
;
23266 ------------------------------------
23267 -- Copy_Any_Node_With_Replacement --
23268 ------------------------------------
23270 function Copy_Any_Node_With_Replacement
23271 (N
: Node_Or_Entity_Id
) return Node_Or_Entity_Id
23274 if Nkind
(N
) in N_Entity
then
23275 return Corresponding_Entity
(N
);
23277 return Copy_Node_With_Replacement
(N
);
23279 end Copy_Any_Node_With_Replacement
;
23281 ---------------------------------
23282 -- Copy_Elist_With_Replacement --
23283 ---------------------------------
23285 function Copy_Elist_With_Replacement
(List
: Elist_Id
) return Elist_Id
is
23290 -- Copy the contents of the old list. Note that the list itself may
23291 -- be empty, in which case the routine returns a new empty list. This
23292 -- avoids sharing lists between subtrees. The element of an entity
23293 -- list could be an entity or a node, hence the invocation of routine
23294 -- Copy_Any_Node_With_Replacement.
23296 if Present
(List
) then
23297 Result
:= New_Elmt_List
;
23299 Elmt
:= First_Elmt
(List
);
23300 while Present
(Elmt
) loop
23302 (Copy_Any_Node_With_Replacement
(Node
(Elmt
)), Result
);
23307 -- Otherwise the list does not exist
23310 Result
:= No_Elist
;
23314 end Copy_Elist_With_Replacement
;
23316 ---------------------------------
23317 -- Copy_Field_With_Replacement --
23318 ---------------------------------
23320 function Copy_Field_With_Replacement
23322 Old_Par
: Node_Id
:= Empty
;
23323 New_Par
: Node_Id
:= Empty
;
23324 Semantic
: Boolean := False) return Union_Id
23326 function Has_More_Ids
(N
: Node_Id
) return Boolean;
23327 -- Return True when N has attribute More_Ids set to True
23329 function Is_Syntactic_Node
return Boolean;
23330 -- Return True when Field is a syntactic node
23336 function Has_More_Ids
(N
: Node_Id
) return Boolean is
23338 if Nkind
(N
) in N_Component_Declaration
23339 | N_Discriminant_Specification
23340 | N_Exception_Declaration
23341 | N_Formal_Object_Declaration
23342 | N_Number_Declaration
23343 | N_Object_Declaration
23344 | N_Parameter_Specification
23345 | N_Use_Package_Clause
23346 | N_Use_Type_Clause
23348 return More_Ids
(N
);
23354 -----------------------
23355 -- Is_Syntactic_Node --
23356 -----------------------
23358 function Is_Syntactic_Node
return Boolean is
23359 Old_N
: constant Node_Id
:= Node_Id
(Field
);
23362 if Parent
(Old_N
) = Old_Par
then
23365 elsif not Has_More_Ids
(Old_Par
) then
23368 -- Perform the check using the last last id in the syntactic chain
23372 N
: Node_Id
:= Old_Par
;
23375 while Present
(N
) and then More_Ids
(N
) loop
23379 pragma Assert
(Prev_Ids
(N
));
23380 return Parent
(Old_N
) = N
;
23383 end Is_Syntactic_Node
;
23386 -- The field is empty
23388 if Field
= Union_Id
(Empty
) then
23391 -- The field is an entity/itype/node
23393 elsif Field
in Node_Range
then
23395 Old_N
: constant Node_Id
:= Node_Id
(Field
);
23396 Syntactic
: constant Boolean := Is_Syntactic_Node
;
23401 -- The field is an entity/itype
23403 if Nkind
(Old_N
) in N_Entity
then
23405 -- An entity/itype is always replicated
23407 New_N
:= Corresponding_Entity
(Old_N
);
23409 -- Update the parent pointer when the entity is a syntactic
23410 -- field. Note that itypes do not have parent pointers.
23412 if Syntactic
and then New_N
/= Old_N
then
23413 Set_Parent
(New_N
, New_Par
);
23416 -- The field is a node
23419 -- A node is replicated when it is either a syntactic field
23420 -- or when the caller treats it as a semantic attribute.
23422 if Syntactic
or else Semantic
then
23423 New_N
:= Copy_Node_With_Replacement
(Old_N
);
23425 -- Update the parent pointer when the node is a syntactic
23428 if Syntactic
and then New_N
/= Old_N
then
23429 Set_Parent
(New_N
, New_Par
);
23432 -- Otherwise the node is returned unchanged
23439 return Union_Id
(New_N
);
23442 -- The field is an entity list
23444 elsif Field
in Elist_Range
then
23445 return Union_Id
(Copy_Elist_With_Replacement
(Elist_Id
(Field
)));
23447 -- The field is a syntactic list
23449 elsif Field
in List_Range
then
23451 Old_List
: constant List_Id
:= List_Id
(Field
);
23452 Syntactic
: constant Boolean := Parent
(Old_List
) = Old_Par
;
23454 New_List
: List_Id
;
23457 -- A list is replicated when it is either a syntactic field or
23458 -- when the caller treats it as a semantic attribute.
23460 if Syntactic
or else Semantic
then
23461 New_List
:= Copy_List_With_Replacement
(Old_List
);
23463 -- Update the parent pointer when the list is a syntactic
23466 if Syntactic
and then New_List
/= Old_List
then
23467 Set_Parent
(New_List
, New_Par
);
23470 -- Otherwise the list is returned unchanged
23473 New_List
:= Old_List
;
23476 return Union_Id
(New_List
);
23479 -- Otherwise the field denotes an attribute that does not need to be
23480 -- replicated (Chars, literals, etc).
23485 end Copy_Field_With_Replacement
;
23487 --------------------------------
23488 -- Copy_List_With_Replacement --
23489 --------------------------------
23491 function Copy_List_With_Replacement
(List
: List_Id
) return List_Id
is
23496 -- Copy the contents of the old list. Note that the list itself may
23497 -- be empty, in which case the routine returns a new empty list. This
23498 -- avoids sharing lists between subtrees. The element of a syntactic
23499 -- list is always a node, never an entity or itype, hence the call to
23500 -- routine Copy_Node_With_Replacement.
23502 if Present
(List
) then
23503 Result
:= New_List
;
23505 Elmt
:= First
(List
);
23506 while Present
(Elmt
) loop
23507 Append
(Copy_Node_With_Replacement
(Elmt
), Result
);
23512 -- Otherwise the list does not exist
23519 end Copy_List_With_Replacement
;
23521 --------------------------------
23522 -- Copy_Node_With_Replacement --
23523 --------------------------------
23525 function Copy_Node_With_Replacement
(N
: Node_Id
) return Node_Id
is
23528 function Transform
(U
: Union_Id
) return Union_Id
;
23529 -- Copies one field, replacing N with Result
23535 function Transform
(U
: Union_Id
) return Union_Id
is
23537 return Copy_Field_With_Replacement
23540 New_Par
=> Result
);
23543 procedure Walk
is new Walk_Sinfo_Fields_Pairwise
(Transform
);
23545 -- Start of processing for Copy_Node_With_Replacement
23548 -- Assume that the node must be returned unchanged
23552 if N
> Empty_Or_Error
then
23553 pragma Assert
(Nkind
(N
) not in N_Entity
);
23555 Result
:= New_Copy
(N
);
23557 Walk
(Result
, Result
);
23559 -- Update the Comes_From_Source and Sloc attributes of the node
23560 -- in case the caller has supplied new values.
23562 Update_CFS_Sloc
(Result
);
23564 -- Update the Associated_Node_For_Itype attribute of all itypes
23565 -- created during Phase 1 whose associated node is N. As a result
23566 -- the Associated_Node_For_Itype refers to the replicated node.
23567 -- No action needs to be taken when the Associated_Node_For_Itype
23568 -- refers to an entity because this was already handled during
23569 -- Phase 1, in Visit_Itype.
23571 Update_Pending_Itypes
23573 New_Assoc
=> Result
);
23575 -- Update the First/Next_Named_Association chain for a replicated
23578 if Nkind
(N
) in N_Entry_Call_Statement
23580 | N_Procedure_Call_Statement
23582 Update_Named_Associations
23584 New_Call
=> Result
);
23586 -- Update the Renamed_Object attribute of a replicated object
23589 elsif Nkind
(N
) = N_Object_Renaming_Declaration
then
23590 Set_Renamed_Object_Of_Possibly_Void
23591 (Defining_Entity
(Result
), Name
(Result
));
23593 -- Update the Chars attribute of identifiers
23595 elsif Nkind
(N
) = N_Identifier
then
23597 -- The Entity field of identifiers that denote aspects is used
23598 -- to store arbitrary expressions (and hence we must check that
23599 -- they reference an actual entity before copying their Chars
23602 if Present
(Entity
(Result
))
23603 and then Nkind
(Entity
(Result
)) in N_Entity
23605 Set_Chars
(Result
, Chars
(Entity
(Result
)));
23609 if Has_Aspects
(N
) then
23610 Set_Aspect_Specifications
(Result
,
23611 Copy_List_With_Replacement
(Aspect_Specifications
(N
)));
23616 end Copy_Node_With_Replacement
;
23618 --------------------------
23619 -- Corresponding_Entity --
23620 --------------------------
23622 function Corresponding_Entity
(Id
: Entity_Id
) return Entity_Id
is
23623 New_Id
: Entity_Id
;
23624 Result
: Entity_Id
;
23627 -- Assume that the entity must be returned unchanged
23631 if Id
> Empty_Or_Error
then
23632 pragma Assert
(Nkind
(Id
) in N_Entity
);
23634 -- Determine whether the entity has a corresponding new entity
23635 -- generated during Phase 1 and if it does, use it.
23637 if NCT_Tables_In_Use
then
23638 New_Id
:= NCT_New_Entities
.Get
(Id
);
23640 if Present
(New_Id
) then
23647 end Corresponding_Entity
;
23649 -------------------
23650 -- In_Entity_Map --
23651 -------------------
23653 function In_Entity_Map
23655 Entity_Map
: Elist_Id
) return Boolean
23658 Old_Id
: Entity_Id
;
23661 -- The entity map contains pairs (Old_Id, New_Id). The advancement
23662 -- step always skips the New_Id portion of the pair.
23664 if Present
(Entity_Map
) then
23665 Elmt
:= First_Elmt
(Entity_Map
);
23666 while Present
(Elmt
) loop
23667 Old_Id
:= Node
(Elmt
);
23669 if Old_Id
= Id
then
23681 ---------------------
23682 -- Update_CFS_Sloc --
23683 ---------------------
23685 procedure Update_CFS_Sloc
(N
: Node_Or_Entity_Id
) is
23687 -- A new source location defaults the Comes_From_Source attribute
23689 if New_Sloc
/= No_Location
then
23690 Set_Comes_From_Source
(N
, Get_Comes_From_Source_Default
);
23691 Set_Sloc
(N
, New_Sloc
);
23693 end Update_CFS_Sloc
;
23695 -------------------------------
23696 -- Update_Named_Associations --
23697 -------------------------------
23699 procedure Update_Named_Associations
23700 (Old_Call
: Node_Id
;
23701 New_Call
: Node_Id
)
23704 New_Next
: Node_Id
;
23706 Old_Next
: Node_Id
;
23709 if No
(First_Named_Actual
(Old_Call
)) then
23713 -- Recreate the First/Next_Named_Actual chain of a call by traversing
23714 -- the chains of both the old and new calls in parallel.
23716 New_Act
:= First
(Parameter_Associations
(New_Call
));
23717 Old_Act
:= First
(Parameter_Associations
(Old_Call
));
23718 while Present
(Old_Act
) loop
23719 if Nkind
(Old_Act
) = N_Parameter_Association
23720 and then Explicit_Actual_Parameter
(Old_Act
)
23721 = First_Named_Actual
(Old_Call
)
23723 Set_First_Named_Actual
(New_Call
,
23724 Explicit_Actual_Parameter
(New_Act
));
23727 if Nkind
(Old_Act
) = N_Parameter_Association
23728 and then Present
(Next_Named_Actual
(Old_Act
))
23730 -- Scan the actual parameter list to find the next suitable
23731 -- named actual. Note that the list may be out of order.
23733 New_Next
:= First
(Parameter_Associations
(New_Call
));
23734 Old_Next
:= First
(Parameter_Associations
(Old_Call
));
23735 while Nkind
(Old_Next
) /= N_Parameter_Association
23736 or else Explicit_Actual_Parameter
(Old_Next
) /=
23737 Next_Named_Actual
(Old_Act
)
23743 Set_Next_Named_Actual
(New_Act
,
23744 Explicit_Actual_Parameter
(New_Next
));
23750 end Update_Named_Associations
;
23752 -------------------------
23753 -- Update_New_Entities --
23754 -------------------------
23756 procedure Update_New_Entities
(Entity_Map
: Elist_Id
) is
23757 New_Id
: Entity_Id
:= Empty
;
23758 Old_Id
: Entity_Id
:= Empty
;
23761 if NCT_Tables_In_Use
then
23762 NCT_New_Entities
.Get_First
(Old_Id
, New_Id
);
23764 -- Update the semantic fields of all new entities created during
23765 -- Phase 1 which were not supplied via an entity map.
23766 -- ??? Is there a better way of distinguishing those?
23768 while Present
(Old_Id
) and then Present
(New_Id
) loop
23769 if not (Present
(Entity_Map
)
23770 and then In_Entity_Map
(Old_Id
, Entity_Map
))
23772 Update_Semantic_Fields
(New_Id
);
23775 NCT_New_Entities
.Get_Next
(Old_Id
, New_Id
);
23778 end Update_New_Entities
;
23780 ---------------------------
23781 -- Update_Pending_Itypes --
23782 ---------------------------
23784 procedure Update_Pending_Itypes
23785 (Old_Assoc
: Node_Id
;
23786 New_Assoc
: Node_Id
)
23792 if NCT_Tables_In_Use
then
23793 Itypes
:= NCT_Pending_Itypes
.Get
(Old_Assoc
);
23795 -- Update the Associated_Node_For_Itype attribute for all itypes
23796 -- which originally refer to Old_Assoc to designate New_Assoc.
23798 if Present
(Itypes
) then
23799 Item
:= First_Elmt
(Itypes
);
23800 while Present
(Item
) loop
23801 Set_Associated_Node_For_Itype
(Node
(Item
), New_Assoc
);
23807 end Update_Pending_Itypes
;
23809 ----------------------------
23810 -- Update_Semantic_Fields --
23811 ----------------------------
23813 procedure Update_Semantic_Fields
(Id
: Entity_Id
) is
23815 -- Discriminant_Constraint
23817 if Is_Type
(Id
) and then Has_Discriminants
(Base_Type
(Id
)) then
23818 Set_Discriminant_Constraint
(Id
, Elist_Id
(
23819 Copy_Field_With_Replacement
23820 (Field
=> Union_Id
(Discriminant_Constraint
(Id
)),
23821 Semantic
=> True)));
23826 Set_Etype
(Id
, Node_Id
(
23827 Copy_Field_With_Replacement
23828 (Field
=> Union_Id
(Etype
(Id
)),
23829 Semantic
=> True)));
23832 -- Packed_Array_Impl_Type
23834 if Is_Array_Type
(Id
) then
23835 if Present
(First_Index
(Id
)) then
23836 Set_First_Index
(Id
, First
(List_Id
(
23837 Copy_Field_With_Replacement
23838 (Field
=> Union_Id
(List_Containing
(First_Index
(Id
))),
23839 Semantic
=> True))));
23842 if Is_Packed
(Id
) then
23843 Set_Packed_Array_Impl_Type
(Id
, Node_Id
(
23844 Copy_Field_With_Replacement
23845 (Field
=> Union_Id
(Packed_Array_Impl_Type
(Id
)),
23846 Semantic
=> True)));
23852 Set_Prev_Entity
(Id
, Node_Id
(
23853 Copy_Field_With_Replacement
23854 (Field
=> Union_Id
(Prev_Entity
(Id
)),
23855 Semantic
=> True)));
23859 Set_Next_Entity
(Id
, Node_Id
(
23860 Copy_Field_With_Replacement
23861 (Field
=> Union_Id
(Next_Entity
(Id
)),
23862 Semantic
=> True)));
23866 if Is_Discrete_Type
(Id
) then
23867 Set_Scalar_Range
(Id
, Node_Id
(
23868 Copy_Field_With_Replacement
23869 (Field
=> Union_Id
(Scalar_Range
(Id
)),
23870 Semantic
=> True)));
23875 -- Update the scope when the caller specified an explicit one
23877 if Present
(New_Scope
) then
23878 Set_Scope
(Id
, New_Scope
);
23880 Set_Scope
(Id
, Node_Id
(
23881 Copy_Field_With_Replacement
23882 (Field
=> Union_Id
(Scope
(Id
)),
23883 Semantic
=> True)));
23885 end Update_Semantic_Fields
;
23887 --------------------
23888 -- Visit_Any_Node --
23889 --------------------
23891 procedure Visit_Any_Node
(N
: Node_Or_Entity_Id
) is
23893 if Nkind
(N
) in N_Entity
then
23894 if Is_Itype
(N
) then
23902 end Visit_Any_Node
;
23908 procedure Visit_Elist
(List
: Elist_Id
) is
23912 -- The element of an entity list could be an entity, itype, or a
23913 -- node, hence the call to Visit_Any_Node.
23915 if Present
(List
) then
23916 Elmt
:= First_Elmt
(List
);
23917 while Present
(Elmt
) loop
23918 Visit_Any_Node
(Node
(Elmt
));
23929 procedure Visit_Entity
(Id
: Entity_Id
) is
23930 New_Id
: Entity_Id
;
23933 pragma Assert
(Nkind
(Id
) in N_Entity
);
23934 pragma Assert
(not Is_Itype
(Id
));
23936 -- Nothing to do when the entity is not defined in the Actions list
23937 -- of an N_Expression_With_Actions node.
23939 if EWA_Level
= 0 then
23942 -- Nothing to do when the entity is defined in a scoping construct
23943 -- within an N_Expression_With_Actions node, unless the caller has
23944 -- requested their replication.
23946 -- ??? should this restriction be eliminated?
23948 elsif EWA_Inner_Scope_Level
> 0 and then not Scopes_In_EWA_OK
then
23951 -- Nothing to do when the entity does not denote a construct that
23952 -- may appear within an N_Expression_With_Actions node. Relaxing
23953 -- this restriction leads to a performance penalty.
23955 -- ??? this list is flaky, and may hide dormant bugs
23956 -- Should functions be included???
23958 -- Quantified expressions contain an entity declaration that must
23959 -- always be replaced when the expander is active, even if it has
23960 -- not been analyzed yet like e.g. in predicates.
23962 elsif Ekind
(Id
) not in E_Block
23967 and then not Is_Entity_Of_Quantified_Expression
(Id
)
23968 and then not Is_Type
(Id
)
23972 -- Nothing to do when the entity was already visited
23974 elsif NCT_Tables_In_Use
23975 and then Present
(NCT_New_Entities
.Get
(Id
))
23979 -- Nothing to do when the declaration node of the entity is not in
23980 -- the subtree being replicated.
23982 elsif not In_Subtree
23983 (N
=> Declaration_Node
(Id
),
23989 -- Create a new entity by directly copying the old entity. This
23990 -- action causes all attributes of the old entity to be inherited.
23992 New_Id
:= New_Copy
(Id
);
23994 -- Create a new name for the new entity because the back end needs
23995 -- distinct names for debugging purposes, provided that the entity
23996 -- has already been analyzed.
23998 if Ekind
(Id
) /= E_Void
then
23999 Set_Chars
(New_Id
, New_Internal_Name
('T'));
24002 -- Update the Comes_From_Source and Sloc attributes of the entity in
24003 -- case the caller has supplied new values.
24005 Update_CFS_Sloc
(New_Id
);
24007 -- Establish the following mapping within table NCT_New_Entities:
24011 Add_New_Entity
(Id
, New_Id
);
24013 -- Deal with the semantic fields of entities. The fields are visited
24014 -- because they may mention entities which reside within the subtree
24017 Visit_Semantic_Fields
(Id
);
24024 procedure Visit_Field
24026 Par_Nod
: Node_Id
:= Empty
;
24027 Semantic
: Boolean := False)
24030 -- The field is empty
24032 if Field
= Union_Id
(Empty
) then
24035 -- The field is an entity/itype/node
24037 elsif Field
in Node_Range
then
24039 N
: constant Node_Id
:= Node_Id
(Field
);
24042 -- The field is an entity/itype
24044 if Nkind
(N
) in N_Entity
then
24046 -- Itypes are always visited
24048 if Is_Itype
(N
) then
24051 -- An entity is visited when it is either a syntactic field
24052 -- or when the caller treats it as a semantic attribute.
24054 elsif Parent
(N
) = Par_Nod
or else Semantic
then
24058 -- The field is a node
24061 -- A node is visited when it is either a syntactic field or
24062 -- when the caller treats it as a semantic attribute.
24064 if Parent
(N
) = Par_Nod
or else Semantic
then
24070 -- The field is an entity list
24072 elsif Field
in Elist_Range
then
24073 Visit_Elist
(Elist_Id
(Field
));
24075 -- The field is a syntax list
24077 elsif Field
in List_Range
then
24079 List
: constant List_Id
:= List_Id
(Field
);
24082 -- A syntax list is visited when it is either a syntactic field
24083 -- or when the caller treats it as a semantic attribute.
24085 if Parent
(List
) = Par_Nod
or else Semantic
then
24090 -- Otherwise the field denotes information which does not need to be
24091 -- visited (chars, literals, etc.).
24102 procedure Visit_Itype
(Itype
: Entity_Id
) is
24103 New_Assoc
: Node_Id
;
24104 New_Itype
: Entity_Id
;
24105 Old_Assoc
: Node_Id
;
24108 pragma Assert
(Nkind
(Itype
) in N_Entity
);
24109 pragma Assert
(Is_Itype
(Itype
));
24111 -- Itypes that describe the designated type of access to subprograms
24112 -- have the structure of subprogram declarations, with signatures,
24113 -- etc. Either we duplicate the signatures completely, or choose to
24114 -- share such itypes, which is fine because their elaboration will
24115 -- have no side effects.
24117 if Ekind
(Itype
) = E_Subprogram_Type
then
24120 -- Nothing to do if the itype was already visited
24122 elsif NCT_Tables_In_Use
24123 and then Present
(NCT_New_Entities
.Get
(Itype
))
24127 -- Nothing to do if the associated node of the itype is not within
24128 -- the subtree being replicated.
24130 elsif not In_Subtree
24131 (N
=> Associated_Node_For_Itype
(Itype
),
24137 -- Create a new itype by directly copying the old itype. This action
24138 -- causes all attributes of the old itype to be inherited.
24140 New_Itype
:= New_Copy
(Itype
);
24142 -- Create a new name for the new itype because the back end requires
24143 -- distinct names for debugging purposes.
24145 Set_Chars
(New_Itype
, New_Internal_Name
('T'));
24147 -- Update the Comes_From_Source and Sloc attributes of the itype in
24148 -- case the caller has supplied new values.
24150 Update_CFS_Sloc
(New_Itype
);
24152 -- Establish the following mapping within table NCT_New_Entities:
24154 -- Itype -> New_Itype
24156 Add_New_Entity
(Itype
, New_Itype
);
24158 -- The new itype must be unfrozen because the resulting subtree may
24159 -- be inserted anywhere and cause an earlier or later freezing.
24161 if Present
(Freeze_Node
(New_Itype
)) then
24162 Set_Freeze_Node
(New_Itype
, Empty
);
24163 Set_Is_Frozen
(New_Itype
, False);
24166 -- If a record subtype is simply copied, the entity list will be
24167 -- shared, so Cloned_Subtype must be set to indicate this.
24169 if Ekind
(Itype
) in E_Class_Wide_Subtype | E_Record_Subtype
then
24170 Set_Cloned_Subtype
(New_Itype
, Itype
);
24173 -- The associated node may denote an entity, in which case it may
24174 -- already have a new corresponding entity created during a prior
24175 -- call to Visit_Entity or Visit_Itype for the same subtree.
24178 -- Old_Assoc ---------> New_Assoc
24180 -- Created by Visit_Itype
24181 -- Itype -------------> New_Itype
24182 -- ANFI = Old_Assoc ANFI = Old_Assoc < must be updated
24184 -- In the example above, Old_Assoc is an arbitrary entity that was
24185 -- already visited for the same subtree and has a corresponding new
24186 -- entity New_Assoc. Old_Assoc was inherited by New_Itype by virtue
24187 -- of copying entities, however it must be updated to New_Assoc.
24189 Old_Assoc
:= Associated_Node_For_Itype
(Itype
);
24191 if Nkind
(Old_Assoc
) in N_Entity
then
24192 if NCT_Tables_In_Use
then
24193 New_Assoc
:= NCT_New_Entities
.Get
(Old_Assoc
);
24195 if Present
(New_Assoc
) then
24196 Set_Associated_Node_For_Itype
(New_Itype
, New_Assoc
);
24200 -- Otherwise the associated node denotes a node. Postpone the update
24201 -- until Phase 2 when the node is replicated. Establish the following
24202 -- mapping within table NCT_Pending_Itypes:
24204 -- Old_Assoc -> (New_Type, ...)
24207 Add_Pending_Itype
(Old_Assoc
, New_Itype
);
24210 -- Deal with the semantic fields of itypes. The fields are visited
24211 -- because they may mention entities that reside within the subtree
24214 Visit_Semantic_Fields
(Itype
);
24221 procedure Visit_List
(List
: List_Id
) is
24225 -- Note that the element of a syntactic list is always a node, never
24226 -- an entity or itype, hence the call to Visit_Node.
24228 if Present
(List
) then
24229 Elmt
:= First
(List
);
24230 while Present
(Elmt
) loop
24242 procedure Visit_Node
(N
: Node_Id
) is
24244 pragma Assert
(Nkind
(N
) not in N_Entity
);
24246 -- If the node is a quantified expression and expander is active,
24247 -- it contains an implicit declaration that may require a new entity
24248 -- when the condition has already been (pre)analyzed.
24250 if Nkind
(N
) = N_Expression_With_Actions
24252 (Nkind
(N
) = N_Quantified_Expression
and then Expander_Active
)
24254 EWA_Level
:= EWA_Level
+ 1;
24256 elsif EWA_Level
> 0
24257 and then Nkind
(N
) in N_Block_Statement
24258 | N_Subprogram_Body
24259 | N_Subprogram_Declaration
24261 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
+ 1;
24264 -- If the node is a block, we need to process all declarations
24265 -- in the block and make new entities for each.
24267 if Nkind
(N
) = N_Block_Statement
and then Present
(Declarations
(N
))
24270 Decl
: Node_Id
:= First
(Declarations
(N
));
24273 while Present
(Decl
) loop
24274 if Nkind
(Decl
) = N_Object_Declaration
then
24275 Add_New_Entity
(Defining_Identifier
(Decl
),
24276 New_Copy
(Defining_Identifier
(Decl
)));
24285 procedure Action
(U
: Union_Id
);
24286 procedure Action
(U
: Union_Id
) is
24288 Visit_Field
(Field
=> U
, Par_Nod
=> N
);
24291 procedure Walk
is new Walk_Sinfo_Fields
(Action
);
24297 and then Nkind
(N
) in N_Block_Statement
24298 | N_Subprogram_Body
24299 | N_Subprogram_Declaration
24301 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
- 1;
24303 elsif Nkind
(N
) = N_Expression_With_Actions
then
24304 EWA_Level
:= EWA_Level
- 1;
24308 ---------------------------
24309 -- Visit_Semantic_Fields --
24310 ---------------------------
24312 procedure Visit_Semantic_Fields
(Id
: Entity_Id
) is
24314 pragma Assert
(Nkind
(Id
) in N_Entity
);
24316 -- Discriminant_Constraint
24318 if Is_Type
(Id
) and then Has_Discriminants
(Base_Type
(Id
)) then
24320 (Field
=> Union_Id
(Discriminant_Constraint
(Id
)),
24327 (Field
=> Union_Id
(Etype
(Id
)),
24331 -- Packed_Array_Impl_Type
24333 if Is_Array_Type
(Id
) then
24334 if Present
(First_Index
(Id
)) then
24336 (Field
=> Union_Id
(List_Containing
(First_Index
(Id
))),
24340 if Is_Packed
(Id
) then
24342 (Field
=> Union_Id
(Packed_Array_Impl_Type
(Id
)),
24349 if Is_Discrete_Type
(Id
) then
24351 (Field
=> Union_Id
(Scalar_Range
(Id
)),
24354 end Visit_Semantic_Fields
;
24356 -- Start of processing for New_Copy_Tree
24359 -- Routine New_Copy_Tree performs a deep copy of a subtree by creating
24360 -- shallow copies for each node within, and then updating the child and
24361 -- parent pointers accordingly. This process is straightforward, however
24362 -- the routine must deal with the following complications:
24364 -- * Entities defined within N_Expression_With_Actions nodes must be
24365 -- replicated rather than shared to avoid introducing two identical
24366 -- symbols within the same scope. Note that no other expression can
24367 -- currently define entities.
24370 -- Source_Low : ...;
24371 -- Source_High : ...;
24373 -- <reference to Source_Low>
24374 -- <reference to Source_High>
24377 -- New_Copy_Tree handles this case by first creating new entities
24378 -- and then updating all existing references to point to these new
24385 -- <reference to New_Low>
24386 -- <reference to New_High>
24389 -- * Itypes defined within the subtree must be replicated to avoid any
24390 -- dependencies on invalid or inaccessible data.
24392 -- subtype Source_Itype is ... range Source_Low .. Source_High;
24394 -- New_Copy_Tree handles this case by first creating a new itype in
24395 -- the same fashion as entities, and then updating various relevant
24398 -- subtype New_Itype is ... range New_Low .. New_High;
24400 -- * The Associated_Node_For_Itype field of itypes must be updated to
24401 -- reference the proper replicated entity or node.
24403 -- * Semantic fields of entities such as Etype and Scope must be
24404 -- updated to reference the proper replicated entities.
24406 -- * Some semantic fields of nodes must be updated to reference
24407 -- the proper replicated nodes.
24409 -- Finally, quantified expressions contain an implicit declaration for
24410 -- the bound variable. Given that quantified expressions appearing
24411 -- in contracts are copied to create pragmas and eventually checking
24412 -- procedures, a new bound variable must be created for each copy, to
24413 -- prevent multiple declarations of the same symbol.
24415 -- To meet all these demands, routine New_Copy_Tree is split into two
24418 -- Phase 1 traverses the tree in order to locate entities and itypes
24419 -- defined within the subtree. New entities are generated and saved in
24420 -- table NCT_New_Entities. The semantic fields of all new entities and
24421 -- itypes are then updated accordingly.
24423 -- Phase 2 traverses the tree in order to replicate each node. Various
24424 -- semantic fields of nodes and entities are updated accordingly.
24426 -- Preparatory phase. Clear the contents of tables NCT_New_Entities and
24427 -- NCT_Pending_Itypes in case a previous call to New_Copy_Tree left some
24430 if NCT_Tables_In_Use
then
24431 NCT_Tables_In_Use
:= False;
24433 NCT_New_Entities
.Reset
;
24434 NCT_Pending_Itypes
.Reset
;
24437 -- Populate tables NCT_New_Entities and NCT_Pending_Itypes with data
24438 -- supplied by a linear entity map. The tables offer faster access to
24441 Build_NCT_Tables
(Map
);
24443 -- Execute Phase 1. Traverse the subtree and generate new entities for
24444 -- the following cases:
24446 -- * An entity defined within an N_Expression_With_Actions node
24448 -- * An itype referenced within the subtree where the associated node
24449 -- is also in the subtree.
24451 -- All new entities are accessible via table NCT_New_Entities, which
24452 -- contains mappings of the form:
24454 -- Old_Entity -> New_Entity
24455 -- Old_Itype -> New_Itype
24457 -- In addition, the associated nodes of all new itypes are mapped in
24458 -- table NCT_Pending_Itypes:
24460 -- Assoc_Nod -> (New_Itype1, New_Itype2, .., New_ItypeN)
24462 Visit_Any_Node
(Source
);
24464 -- Update the semantic attributes of all new entities generated during
24465 -- Phase 1 before starting Phase 2. The updates could be performed in
24466 -- routine Corresponding_Entity, however this may cause the same entity
24467 -- to be updated multiple times, effectively generating useless nodes.
24468 -- Keeping the updates separates from Phase 2 ensures that only one set
24469 -- of attributes is generated for an entity at any one time.
24471 Update_New_Entities
(Map
);
24473 -- Execute Phase 2. Replicate the source subtree one node at a time.
24474 -- The following transformations take place:
24476 -- * References to entities and itypes are updated to refer to the
24477 -- new entities and itypes generated during Phase 1.
24479 -- * All Associated_Node_For_Itype attributes of itypes are updated
24480 -- to refer to the new replicated Associated_Node_For_Itype.
24482 return Copy_Node_With_Replacement
(Source
);
24485 -------------------------
24486 -- New_External_Entity --
24487 -------------------------
24489 function New_External_Entity
24490 (Kind
: Entity_Kind
;
24491 Scope_Id
: Entity_Id
;
24492 Sloc_Value
: Source_Ptr
;
24493 Related_Id
: Entity_Id
;
24494 Suffix
: Character;
24495 Suffix_Index
: Int
:= 0;
24496 Prefix
: Character := ' ') return Entity_Id
24498 N
: constant Entity_Id
:=
24499 Make_Defining_Identifier
(Sloc_Value
,
24501 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
24504 Mutate_Ekind
(N
, Kind
);
24505 Set_Is_Internal
(N
, True);
24506 Append_Entity
(N
, Scope_Id
);
24507 Set_Public_Status
(N
);
24509 if Kind
in Type_Kind
then
24510 Reinit_Size_Align
(N
);
24514 end New_External_Entity
;
24516 -------------------------
24517 -- New_Internal_Entity --
24518 -------------------------
24520 function New_Internal_Entity
24521 (Kind
: Entity_Kind
;
24522 Scope_Id
: Entity_Id
;
24523 Sloc_Value
: Source_Ptr
;
24524 Id_Char
: Character) return Entity_Id
24526 N
: constant Entity_Id
:= Make_Temporary
(Sloc_Value
, Id_Char
);
24529 Mutate_Ekind
(N
, Kind
);
24530 Set_Is_Internal
(N
, True);
24531 Append_Entity
(N
, Scope_Id
);
24533 if Kind
in Type_Kind
then
24534 Reinit_Size_Align
(N
);
24538 end New_Internal_Entity
;
24544 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
24545 Par
: constant Node_Id
:= Parent
(Actual_Id
);
24549 -- If we are pointing at a positional parameter, it is a member of a
24550 -- node list (the list of parameters), and the next parameter is the
24551 -- next node on the list, unless we hit a parameter association, then
24552 -- we shift to using the chain whose head is the First_Named_Actual in
24553 -- the parent, and then is threaded using the Next_Named_Actual of the
24554 -- Parameter_Association. All this fiddling is because the original node
24555 -- list is in the textual call order, and what we need is the
24556 -- declaration order.
24558 if Is_List_Member
(Actual_Id
) then
24559 N
:= Next
(Actual_Id
);
24561 if Nkind
(N
) = N_Parameter_Association
then
24563 -- In case of a build-in-place call, the call will no longer be a
24564 -- call; it will have been rewritten.
24566 if Nkind
(Par
) in N_Entry_Call_Statement
24568 | N_Procedure_Call_Statement
24570 return First_Named_Actual
(Par
);
24572 -- In case of a call rewritten in GNATprove mode while "inlining
24573 -- for proof" go to the original call.
24575 elsif Nkind
(Par
) = N_Null_Statement
then
24579 Nkind
(Original_Node
(Par
)) in N_Subprogram_Call
);
24581 return First_Named_Actual
(Original_Node
(Par
));
24590 return Next_Named_Actual
(Parent
(Actual_Id
));
24594 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
24596 Actual_Id
:= Next_Actual
(Actual_Id
);
24603 function Next_Global
(Node
: Node_Id
) return Node_Id
is
24605 -- The global item may either be in a list, or by itself, in which case
24606 -- there is no next global item with the same mode.
24608 if Is_List_Member
(Node
) then
24609 return Next
(Node
);
24615 procedure Next_Global
(Node
: in out Node_Id
) is
24617 Node
:= Next_Global
(Node
);
24620 ------------------------
24621 -- No_Caching_Enabled --
24622 ------------------------
24624 function No_Caching_Enabled
(Id
: Entity_Id
) return Boolean is
24625 Prag
: constant Node_Id
:= Get_Pragma
(Id
, Pragma_No_Caching
);
24629 if Present
(Prag
) then
24630 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
24632 -- The pragma has an optional Boolean expression, the related
24633 -- property is enabled only when the expression evaluates to True.
24635 if Present
(Arg1
) then
24636 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
)));
24638 -- Otherwise the lack of expression enables the property by
24645 -- The property was never set in the first place
24650 end No_Caching_Enabled
;
24652 --------------------------
24653 -- No_Heap_Finalization --
24654 --------------------------
24656 function No_Heap_Finalization
(Typ
: Entity_Id
) return Boolean is
24658 if Ekind
(Typ
) in E_Access_Type | E_General_Access_Type
24659 and then Is_Library_Level_Entity
(Typ
)
24661 -- A global No_Heap_Finalization pragma applies to all library-level
24662 -- named access-to-object types.
24664 if Present
(No_Heap_Finalization_Pragma
) then
24667 -- The library-level named access-to-object type itself is subject to
24668 -- pragma No_Heap_Finalization.
24670 elsif Present
(Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
)) then
24676 end No_Heap_Finalization
;
24678 -----------------------
24679 -- Normalize_Actuals --
24680 -----------------------
24682 -- Chain actuals according to formals of subprogram. If there are no named
24683 -- associations, the chain is simply the list of Parameter Associations,
24684 -- since the order is the same as the declaration order. If there are named
24685 -- associations, then the First_Named_Actual field in the N_Function_Call
24686 -- or N_Procedure_Call_Statement node points to the Parameter_Association
24687 -- node for the parameter that comes first in declaration order. The
24688 -- remaining named parameters are then chained in declaration order using
24689 -- Next_Named_Actual.
24691 -- This routine also verifies that the number of actuals is compatible with
24692 -- the number and default values of formals, but performs no type checking
24693 -- (type checking is done by the caller).
24695 -- If the matching succeeds, Success is set to True and the caller proceeds
24696 -- with type-checking. If the match is unsuccessful, then Success is set to
24697 -- False, and the caller attempts a different interpretation, if there is
24700 -- If the flag Report is on, the call is not overloaded, and a failure to
24701 -- match can be reported here, rather than in the caller.
24703 procedure Normalize_Actuals
24707 Success
: out Boolean)
24709 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
24710 Actual
: Node_Id
:= Empty
;
24711 Formal
: Entity_Id
;
24712 Last
: Node_Id
:= Empty
;
24713 First_Named
: Node_Id
:= Empty
;
24716 Formals_To_Match
: Integer := 0;
24717 Actuals_To_Match
: Integer := 0;
24719 procedure Chain
(A
: Node_Id
);
24720 -- Add named actual at the proper place in the list, using the
24721 -- Next_Named_Actual link.
24723 function Reporting
return Boolean;
24724 -- Determines if an error is to be reported. To report an error, we
24725 -- need Report to be True, and also we do not report errors caused
24726 -- by calls to init procs that occur within other init procs. Such
24727 -- errors must always be cascaded errors, since if all the types are
24728 -- declared correctly, the compiler will certainly build decent calls.
24734 procedure Chain
(A
: Node_Id
) is
24738 -- Call node points to first actual in list
24740 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
24743 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
24747 Set_Next_Named_Actual
(Last
, Empty
);
24754 function Reporting
return Boolean is
24759 elsif not Within_Init_Proc
then
24762 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
24770 -- Start of processing for Normalize_Actuals
24773 if Is_Access_Type
(S
) then
24775 -- The name in the call is a function call that returns an access
24776 -- to subprogram. The designated type has the list of formals.
24778 Formal
:= First_Formal
(Designated_Type
(S
));
24780 Formal
:= First_Formal
(S
);
24783 while Present
(Formal
) loop
24784 Formals_To_Match
:= Formals_To_Match
+ 1;
24785 Next_Formal
(Formal
);
24788 -- Find if there is a named association, and verify that no positional
24789 -- associations appear after named ones.
24791 if Present
(Actuals
) then
24792 Actual
:= First
(Actuals
);
24795 while Present
(Actual
)
24796 and then Nkind
(Actual
) /= N_Parameter_Association
24798 Actuals_To_Match
:= Actuals_To_Match
+ 1;
24802 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
24804 -- Most common case: positional notation, no defaults
24809 elsif Actuals_To_Match
> Formals_To_Match
then
24811 -- Too many actuals: will not work
24814 if Is_Entity_Name
(Name
(N
)) then
24815 Error_Msg_N
("too many arguments in call to&", Name
(N
));
24817 Error_Msg_N
("too many arguments in call", N
);
24825 First_Named
:= Actual
;
24827 while Present
(Actual
) loop
24828 if Nkind
(Actual
) /= N_Parameter_Association
then
24830 ("positional parameters not allowed after named ones", Actual
);
24835 Actuals_To_Match
:= Actuals_To_Match
+ 1;
24841 if Present
(Actuals
) then
24842 Actual
:= First
(Actuals
);
24845 Formal
:= First_Formal
(S
);
24846 while Present
(Formal
) loop
24848 -- Match the formals in order. If the corresponding actual is
24849 -- positional, nothing to do. Else scan the list of named actuals
24850 -- to find the one with the right name.
24852 if Present
(Actual
)
24853 and then Nkind
(Actual
) /= N_Parameter_Association
24856 Actuals_To_Match
:= Actuals_To_Match
- 1;
24857 Formals_To_Match
:= Formals_To_Match
- 1;
24860 -- For named parameters, search the list of actuals to find
24861 -- one that matches the next formal name.
24863 Actual
:= First_Named
;
24865 while Present
(Actual
) loop
24866 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
24869 Actuals_To_Match
:= Actuals_To_Match
- 1;
24870 Formals_To_Match
:= Formals_To_Match
- 1;
24878 if Ekind
(Formal
) /= E_In_Parameter
24879 or else No
(Default_Value
(Formal
))
24882 if (Comes_From_Source
(S
)
24883 or else Sloc
(S
) = Standard_Location
)
24884 and then Is_Overloadable
(S
)
24888 Nkind
(Parent
(N
)) in N_Procedure_Call_Statement
24890 | N_Parameter_Association
24891 and then Ekind
(S
) /= E_Function
24893 Set_Etype
(N
, Etype
(S
));
24896 Error_Msg_Name_1
:= Chars
(S
);
24897 Error_Msg_Sloc
:= Sloc
(S
);
24899 ("missing argument for parameter & "
24900 & "in call to % declared #", N
, Formal
);
24903 elsif Is_Overloadable
(S
) then
24904 Error_Msg_Name_1
:= Chars
(S
);
24906 -- Point to type derivation that generated the
24909 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
24912 ("missing argument for parameter & "
24913 & "in call to % (inherited) #", N
, Formal
);
24917 ("missing argument for parameter &", N
, Formal
);
24925 Formals_To_Match
:= Formals_To_Match
- 1;
24930 Next_Formal
(Formal
);
24933 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
24940 -- Find some superfluous named actual that did not get
24941 -- attached to the list of associations.
24943 Actual
:= First
(Actuals
);
24944 while Present
(Actual
) loop
24945 if Nkind
(Actual
) = N_Parameter_Association
24946 and then Actual
/= Last
24947 and then No
(Next_Named_Actual
(Actual
))
24949 -- A validity check may introduce a copy of a call that
24950 -- includes an extra actual (for example for an unrelated
24951 -- accessibility check). Check that the extra actual matches
24952 -- some extra formal, which must exist already because
24953 -- subprogram must be frozen at this point.
24955 if Present
(Extra_Formals
(S
))
24956 and then not Comes_From_Source
(Actual
)
24957 and then Nkind
(Actual
) = N_Parameter_Association
24958 and then Chars
(Extra_Formals
(S
)) =
24959 Chars
(Selector_Name
(Actual
))
24964 ("unmatched actual & in call", Selector_Name
(Actual
));
24976 end Normalize_Actuals
;
24978 --------------------------------
24979 -- Note_Possible_Modification --
24980 --------------------------------
24982 procedure Note_Possible_Modification
(N
: Node_Id
; Sure
: Boolean) is
24983 Modification_Comes_From_Source
: constant Boolean :=
24984 Comes_From_Source
(Parent
(N
));
24990 -- Loop to find referenced entity, if there is one
24996 if Is_Entity_Name
(Exp
) then
24997 Ent
:= Entity
(Exp
);
24999 -- If the entity is missing, it is an undeclared identifier,
25000 -- and there is nothing to annotate.
25006 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
25008 P
: constant Node_Id
:= Prefix
(Exp
);
25011 -- In formal verification mode, keep track of all reads and
25012 -- writes through explicit dereferences.
25014 if GNATprove_Mode
then
25015 SPARK_Specific
.Generate_Dereference
(N
, 'm');
25018 if Nkind
(P
) = N_Selected_Component
25019 and then Present
(Entry_Formal
(Entity
(Selector_Name
(P
))))
25021 -- Case of a reference to an entry formal
25023 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
25025 elsif Nkind
(P
) = N_Identifier
25026 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
25027 and then Present
(Expression
(Parent
(Entity
(P
))))
25028 and then Nkind
(Expression
(Parent
(Entity
(P
)))) =
25031 -- Case of a reference to a value on which side effects have
25034 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
25042 elsif Nkind
(Exp
) in N_Type_Conversion | N_Unchecked_Type_Conversion
25044 Exp
:= Expression
(Exp
);
25047 elsif Nkind
(Exp
) in
25048 N_Slice | N_Indexed_Component | N_Selected_Component
25050 -- Special check, if the prefix is an access type, then return
25051 -- since we are modifying the thing pointed to, not the prefix.
25052 -- When we are expanding, most usually the prefix is replaced
25053 -- by an explicit dereference, and this test is not needed, but
25054 -- in some cases (notably -gnatc mode and generics) when we do
25055 -- not do full expansion, we need this special test.
25057 if Is_Access_Type
(Etype
(Prefix
(Exp
))) then
25060 -- Otherwise go to prefix and keep going
25063 Exp
:= Prefix
(Exp
);
25067 -- All other cases, not a modification
25073 -- Now look for entity being referenced
25075 if Present
(Ent
) then
25076 if Is_Object
(Ent
) then
25077 if Comes_From_Source
(Exp
)
25078 or else Modification_Comes_From_Source
25080 -- Give warning if pragma unmodified is given and we are
25081 -- sure this is a modification.
25083 if Has_Pragma_Unmodified
(Ent
) and then Sure
then
25085 -- Note that the entity may be present only as a result
25086 -- of pragma Unused.
25088 if Has_Pragma_Unused
(Ent
) then
25090 ("??aspect Unused specified for &!", N
, Ent
);
25093 ("??aspect Unmodified specified for &!", N
, Ent
);
25097 Set_Never_Set_In_Source
(Ent
, False);
25100 Set_Is_True_Constant
(Ent
, False);
25101 Set_Current_Value
(Ent
, Empty
);
25102 Set_Is_Known_Null
(Ent
, False);
25104 if not Can_Never_Be_Null
(Ent
) then
25105 Set_Is_Known_Non_Null
(Ent
, False);
25108 -- Follow renaming chain
25110 if Ekind
(Ent
) in E_Variable | E_Constant
25111 and then Present
(Renamed_Object
(Ent
))
25113 Exp
:= Renamed_Object
(Ent
);
25115 -- If the entity is the loop variable in an iteration over
25116 -- a container, retrieve container expression to indicate
25117 -- possible modification.
25119 if Present
(Related_Expression
(Ent
))
25120 and then Nkind
(Parent
(Related_Expression
(Ent
))) =
25121 N_Iterator_Specification
25123 Exp
:= Original_Node
(Related_Expression
(Ent
));
25128 -- The expression may be the renaming of a subcomponent of an
25129 -- array or container. The assignment to the subcomponent is
25130 -- a modification of the container.
25132 elsif Comes_From_Source
(Original_Node
(Exp
))
25133 and then Nkind
(Original_Node
(Exp
)) in
25134 N_Selected_Component | N_Indexed_Component
25136 Exp
:= Prefix
(Original_Node
(Exp
));
25140 -- Generate a reference only if the assignment comes from
25141 -- source. This excludes, for example, calls to a dispatching
25142 -- assignment operation when the left-hand side is tagged. In
25143 -- GNATprove mode, we need those references also on generated
25144 -- code, as these are used to compute the local effects of
25147 if Modification_Comes_From_Source
or GNATprove_Mode
then
25148 Generate_Reference
(Ent
, Exp
, 'm');
25150 -- If the target of the assignment is the bound variable
25151 -- in an iterator, indicate that the corresponding array
25152 -- or container is also modified.
25154 if Ada_Version
>= Ada_2012
25155 and then Nkind
(Parent
(Ent
)) = N_Iterator_Specification
25158 Domain
: constant Node_Id
:= Name
(Parent
(Ent
));
25161 -- ??? In the full version of the construct, the
25162 -- domain of iteration can be given by an expression.
25164 if Is_Entity_Name
(Domain
) then
25165 Generate_Reference
(Entity
(Domain
), Exp
, 'm');
25166 Set_Is_True_Constant
(Entity
(Domain
), False);
25167 Set_Never_Set_In_Source
(Entity
(Domain
), False);
25176 -- If we are sure this is a modification from source, and we know
25177 -- this modifies a constant, then give an appropriate warning.
25180 and then Modification_Comes_From_Source
25181 and then Overlays_Constant
(Ent
)
25182 and then Address_Clause_Overlay_Warnings
25185 Addr
: constant Node_Id
:= Address_Clause
(Ent
);
25190 Find_Overlaid_Entity
(Addr
, O_Ent
, Off
);
25192 Error_Msg_Sloc
:= Sloc
(Addr
);
25194 ("?o?constant& may be modified via address clause#",
25205 end Note_Possible_Modification
;
25211 function Null_Status
(N
: Node_Id
) return Null_Status_Kind
is
25212 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean;
25213 -- Determine whether definition Def carries a null exclusion
25215 function Null_Status_Of_Entity
(Id
: Entity_Id
) return Null_Status_Kind
;
25216 -- Determine the null status of arbitrary entity Id
25218 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
;
25219 -- Determine the null status of type Typ
25221 ---------------------------
25222 -- Is_Null_Excluding_Def --
25223 ---------------------------
25225 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean is
25227 return Nkind
(Def
) in N_Access_Definition
25228 | N_Access_Function_Definition
25229 | N_Access_Procedure_Definition
25230 | N_Access_To_Object_Definition
25231 | N_Component_Definition
25232 | N_Derived_Type_Definition
25233 and then Null_Exclusion_Present
(Def
);
25234 end Is_Null_Excluding_Def
;
25236 ---------------------------
25237 -- Null_Status_Of_Entity --
25238 ---------------------------
25240 function Null_Status_Of_Entity
25241 (Id
: Entity_Id
) return Null_Status_Kind
25243 Decl
: constant Node_Id
:= Declaration_Node
(Id
);
25247 -- The value of an imported or exported entity may be set externally
25248 -- regardless of a null exclusion. As a result, the value cannot be
25249 -- determined statically.
25251 if Is_Imported
(Id
) or else Is_Exported
(Id
) then
25254 elsif Nkind
(Decl
) in N_Component_Declaration
25255 | N_Discriminant_Specification
25256 | N_Formal_Object_Declaration
25257 | N_Object_Declaration
25258 | N_Object_Renaming_Declaration
25259 | N_Parameter_Specification
25261 -- A component declaration yields a non-null value when either
25262 -- its component definition or access definition carries a null
25265 if Nkind
(Decl
) = N_Component_Declaration
then
25266 Def
:= Component_Definition
(Decl
);
25268 if Is_Null_Excluding_Def
(Def
) then
25269 return Is_Non_Null
;
25272 Def
:= Access_Definition
(Def
);
25274 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25275 return Is_Non_Null
;
25278 -- A formal object declaration yields a non-null value if its
25279 -- access definition carries a null exclusion. If the object is
25280 -- default initialized, then the value depends on the expression.
25282 elsif Nkind
(Decl
) = N_Formal_Object_Declaration
then
25283 Def
:= Access_Definition
(Decl
);
25285 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25286 return Is_Non_Null
;
25289 -- A constant may yield a null or non-null value depending on its
25290 -- initialization expression.
25292 elsif Ekind
(Id
) = E_Constant
then
25293 return Null_Status
(Constant_Value
(Id
));
25295 -- The construct yields a non-null value when it has a null
25298 elsif Null_Exclusion_Present
(Decl
) then
25299 return Is_Non_Null
;
25301 -- An object renaming declaration yields a non-null value if its
25302 -- access definition carries a null exclusion. Otherwise the value
25303 -- depends on the renamed name.
25305 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
25306 Def
:= Access_Definition
(Decl
);
25308 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
25309 return Is_Non_Null
;
25312 return Null_Status
(Name
(Decl
));
25317 -- At this point the declaration of the entity does not carry a null
25318 -- exclusion and lacks an initialization expression. Check the status
25321 return Null_Status_Of_Type
(Etype
(Id
));
25322 end Null_Status_Of_Entity
;
25324 -------------------------
25325 -- Null_Status_Of_Type --
25326 -------------------------
25328 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
is
25333 -- Traverse the type chain looking for types with null exclusion
25336 while Present
(Curr
) and then Etype
(Curr
) /= Curr
loop
25337 Decl
:= Parent
(Curr
);
25339 -- Guard against itypes which do not always have declarations. A
25340 -- type yields a non-null value if it carries a null exclusion.
25342 if Present
(Decl
) then
25343 if Nkind
(Decl
) = N_Full_Type_Declaration
25344 and then Is_Null_Excluding_Def
(Type_Definition
(Decl
))
25346 return Is_Non_Null
;
25348 elsif Nkind
(Decl
) = N_Subtype_Declaration
25349 and then Null_Exclusion_Present
(Decl
)
25351 return Is_Non_Null
;
25355 Curr
:= Etype
(Curr
);
25358 -- The type chain does not contain any null excluding types
25361 end Null_Status_Of_Type
;
25363 -- Start of processing for Null_Status
25366 -- Prevent cascaded errors or infinite loops when trying to determine
25367 -- the null status of an erroneous construct.
25369 if Error_Posted
(N
) then
25372 -- An allocator always creates a non-null value
25374 elsif Nkind
(N
) = N_Allocator
then
25375 return Is_Non_Null
;
25377 -- Taking the 'Access of something yields a non-null value
25379 elsif Nkind
(N
) = N_Attribute_Reference
25380 and then Attribute_Name
(N
) in Name_Access
25381 | Name_Unchecked_Access
25382 | Name_Unrestricted_Access
25384 return Is_Non_Null
;
25386 -- "null" yields null
25388 elsif Nkind
(N
) = N_Null
then
25391 -- Check the status of the operand of a type conversion
25393 elsif Nkind
(N
) = N_Type_Conversion
then
25394 return Null_Status
(Expression
(N
));
25396 -- The input denotes a reference to an entity. Determine whether the
25397 -- entity or its type yields a null or non-null value.
25399 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
25400 return Null_Status_Of_Entity
(Entity
(N
));
25403 -- Otherwise it is not possible to determine the null status of the
25404 -- subexpression at compile time without resorting to simple flow
25410 --------------------------------------
25411 -- Null_To_Null_Address_Convert_OK --
25412 --------------------------------------
25414 function Null_To_Null_Address_Convert_OK
25416 Typ
: Entity_Id
:= Empty
) return Boolean
25419 if not Relaxed_RM_Semantics
then
25423 if Nkind
(N
) = N_Null
then
25424 return Present
(Typ
) and then Is_Descendant_Of_Address
(Typ
);
25426 elsif Nkind
(N
) in N_Op_Compare
then
25428 L
: constant Node_Id
:= Left_Opnd
(N
);
25429 R
: constant Node_Id
:= Right_Opnd
(N
);
25432 -- We check the Etype of the complementary operand since the
25433 -- N_Null node is not decorated at this stage.
25436 ((Nkind
(L
) = N_Null
25437 and then Is_Descendant_Of_Address
(Etype
(R
)))
25439 (Nkind
(R
) = N_Null
25440 and then Is_Descendant_Of_Address
(Etype
(L
))));
25445 end Null_To_Null_Address_Convert_OK
;
25447 ---------------------------------
25448 -- Number_Of_Elements_In_Array --
25449 ---------------------------------
25451 function Number_Of_Elements_In_Array
(T
: Entity_Id
) return Int
is
25459 pragma Assert
(Is_Array_Type
(T
));
25461 Indx
:= First_Index
(T
);
25462 while Present
(Indx
) loop
25463 Typ
:= Underlying_Type
(Etype
(Indx
));
25465 -- Never look at junk bounds of a generic type
25467 if Is_Generic_Type
(Typ
) then
25471 -- Check the array bounds are known at compile time and return zero
25472 -- if they are not.
25474 Low
:= Type_Low_Bound
(Typ
);
25475 High
:= Type_High_Bound
(Typ
);
25477 if not Compile_Time_Known_Value
(Low
) then
25479 elsif not Compile_Time_Known_Value
(High
) then
25483 Num
* UI_To_Int
((Expr_Value
(High
) - Expr_Value
(Low
) + 1));
25490 end Number_Of_Elements_In_Array
;
25492 ---------------------------------
25493 -- Original_Aspect_Pragma_Name --
25494 ---------------------------------
25496 function Original_Aspect_Pragma_Name
(N
: Node_Id
) return Name_Id
is
25498 Item_Nam
: Name_Id
;
25501 pragma Assert
(Nkind
(N
) in N_Aspect_Specification | N_Pragma
);
25505 -- The pragma was generated to emulate an aspect, use the original
25506 -- aspect specification.
25508 if Nkind
(Item
) = N_Pragma
and then From_Aspect_Specification
(Item
) then
25509 Item
:= Corresponding_Aspect
(Item
);
25512 -- Retrieve the name of the aspect/pragma. As assertion pragmas from
25513 -- a generic instantiation might have been rewritten into pragma Check,
25514 -- we look at the original node for Item. Note also that Pre, Pre_Class,
25515 -- Post and Post_Class rewrite their pragma identifier to preserve the
25516 -- original name, so we look at the original node for the identifier.
25517 -- ??? this is kludgey
25519 if Nkind
(Item
) = N_Pragma
then
25521 Chars
(Original_Node
(Pragma_Identifier
(Original_Node
(Item
))));
25523 if Item_Nam
= Name_Check
then
25524 -- Pragma "Check" preserves the original pragma name as its first
25527 Chars
(Expression
(First
(Pragma_Argument_Associations
25528 (Original_Node
(Item
)))));
25532 pragma Assert
(Nkind
(Item
) = N_Aspect_Specification
);
25533 Item_Nam
:= Chars
(Identifier
(Item
));
25536 -- Deal with 'Class by converting the name to its _XXX form
25538 if Class_Present
(Item
) then
25539 if Item_Nam
= Name_Invariant
then
25540 Item_Nam
:= Name_uInvariant
;
25542 elsif Item_Nam
= Name_Post
then
25543 Item_Nam
:= Name_uPost
;
25545 elsif Item_Nam
= Name_Pre
then
25546 Item_Nam
:= Name_uPre
;
25548 elsif Item_Nam
in Name_Type_Invariant | Name_Type_Invariant_Class
25550 Item_Nam
:= Name_uType_Invariant
;
25552 -- Nothing to do for other cases (e.g. a Check that derived from
25553 -- Pre_Class and has the flag set). Also we do nothing if the name
25554 -- is already in special _xxx form.
25560 end Original_Aspect_Pragma_Name
;
25562 --------------------------------------
25563 -- Original_Corresponding_Operation --
25564 --------------------------------------
25566 function Original_Corresponding_Operation
(S
: Entity_Id
) return Entity_Id
25568 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
25571 -- If S is an inherited primitive S2 the original corresponding
25572 -- operation of S is the original corresponding operation of S2
25574 if Present
(Alias
(S
))
25575 and then Find_Dispatching_Type
(Alias
(S
)) /= Typ
25577 return Original_Corresponding_Operation
(Alias
(S
));
25579 -- If S overrides an inherited subprogram S2 the original corresponding
25580 -- operation of S is the original corresponding operation of S2
25582 elsif Present
(Overridden_Operation
(S
)) then
25583 return Original_Corresponding_Operation
(Overridden_Operation
(S
));
25585 -- otherwise it is S itself
25590 end Original_Corresponding_Operation
;
25592 -----------------------------------
25593 -- Original_View_In_Visible_Part --
25594 -----------------------------------
25596 function Original_View_In_Visible_Part
25597 (Typ
: Entity_Id
) return Boolean
25599 Scop
: constant Entity_Id
:= Scope
(Typ
);
25602 -- The scope must be a package
25604 if not Is_Package_Or_Generic_Package
(Scop
) then
25608 -- A type with a private declaration has a private view declared in
25609 -- the visible part.
25611 if Has_Private_Declaration
(Typ
) then
25615 return List_Containing
(Parent
(Typ
)) =
25616 Visible_Declarations
(Package_Specification
(Scop
));
25617 end Original_View_In_Visible_Part
;
25619 -------------------
25620 -- Output_Entity --
25621 -------------------
25623 procedure Output_Entity
(Id
: Entity_Id
) is
25627 Scop
:= Scope
(Id
);
25629 -- The entity may lack a scope when it is in the process of being
25630 -- analyzed. Use the current scope as an approximation.
25633 Scop
:= Current_Scope
;
25636 Output_Name
(Chars
(Id
), Scop
);
25643 procedure Output_Name
(Nam
: Name_Id
; Scop
: Entity_Id
:= Current_Scope
) is
25647 (Get_Qualified_Name
25658 -- This would be trivial, simply a test for an identifier that was a
25659 -- reference to a formal, if it were not for the fact that a previous call
25660 -- to Expand_Entry_Parameter will have modified the reference to the
25661 -- identifier. A formal of a protected entity is rewritten as
25663 -- typ!(recobj).rec.all'Constrained
25665 -- where rec is a selector whose Entry_Formal link points to the formal
25667 -- If the type of the entry parameter has a representation clause, then an
25668 -- extra temp is involved (see below).
25670 -- For a formal of a task entity, the formal is rewritten as a local
25673 -- In addition, a formal that is marked volatile because it is aliased
25674 -- through an address clause is rewritten as dereference as well.
25676 function Param_Entity
(N
: Node_Id
) return Entity_Id
is
25677 Renamed_Obj
: Node_Id
;
25680 -- Simple reference case
25682 if Nkind
(N
) in N_Identifier | N_Expanded_Name
then
25683 if Is_Formal
(Entity
(N
)) then
25686 -- Handle renamings of formal parameters and formals of tasks that
25687 -- are rewritten as renamings.
25689 elsif Nkind
(Parent
(Entity
(N
))) = N_Object_Renaming_Declaration
then
25690 Renamed_Obj
:= Get_Referenced_Object
(Renamed_Object
(Entity
(N
)));
25692 if Is_Entity_Name
(Renamed_Obj
)
25693 and then Is_Formal
(Entity
(Renamed_Obj
))
25695 return Entity
(Renamed_Obj
);
25698 Nkind
(Parent
(Parent
(Entity
(N
)))) = N_Accept_Statement
25705 if Nkind
(N
) = N_Explicit_Dereference
then
25707 P
: Node_Id
:= Prefix
(N
);
25713 -- If the type of an entry parameter has a representation
25714 -- clause, then the prefix is not a selected component, but
25715 -- instead a reference to a temp pointing at the selected
25716 -- component. In this case, set P to be the initial value of
25719 if Nkind
(P
) = N_Identifier
then
25722 if Ekind
(E
) = E_Constant
then
25723 Decl
:= Parent
(E
);
25725 if Nkind
(Decl
) = N_Object_Declaration
then
25726 P
:= Expression
(Decl
);
25731 if Nkind
(P
) = N_Selected_Component
then
25732 S
:= Selector_Name
(P
);
25734 if Present
(Entry_Formal
(Entity
(S
))) then
25735 return Entry_Formal
(Entity
(S
));
25738 elsif Nkind
(Original_Node
(N
)) = N_Identifier
then
25739 return Param_Entity
(Original_Node
(N
));
25748 ----------------------
25749 -- Policy_In_Effect --
25750 ----------------------
25752 function Policy_In_Effect
(Policy
: Name_Id
) return Name_Id
is
25753 function Policy_In_List
(List
: Node_Id
) return Name_Id
;
25754 -- Determine the mode of a policy in a N_Pragma list
25756 --------------------
25757 -- Policy_In_List --
25758 --------------------
25760 function Policy_In_List
(List
: Node_Id
) return Name_Id
is
25767 while Present
(Prag
) loop
25768 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
25769 Arg2
:= Next
(Arg1
);
25771 Arg1
:= Get_Pragma_Arg
(Arg1
);
25772 Arg2
:= Get_Pragma_Arg
(Arg2
);
25774 -- The current Check_Policy pragma matches the requested policy or
25775 -- appears in the single argument form (Assertion, policy_id).
25777 if Chars
(Arg1
) in Name_Assertion | Policy
then
25778 return Chars
(Arg2
);
25781 Prag
:= Next_Pragma
(Prag
);
25785 end Policy_In_List
;
25791 -- Start of processing for Policy_In_Effect
25794 if not Is_Valid_Assertion_Kind
(Policy
) then
25795 raise Program_Error
;
25798 -- Inspect all policy pragmas that appear within scopes (if any)
25800 Kind
:= Policy_In_List
(Check_Policy_List
);
25802 -- Inspect all configuration policy pragmas (if any)
25804 if Kind
= No_Name
then
25805 Kind
:= Policy_In_List
(Check_Policy_List_Config
);
25808 -- The context lacks policy pragmas, determine the mode based on whether
25809 -- assertions are enabled at the configuration level. This ensures that
25810 -- the policy is preserved when analyzing generics.
25812 if Kind
= No_Name
then
25813 if Assertions_Enabled_Config
then
25814 Kind
:= Name_Check
;
25816 Kind
:= Name_Ignore
;
25820 -- In CodePeer mode and GNATprove mode, we need to consider all
25821 -- assertions, unless they are disabled. Force Name_Check on
25822 -- ignored assertions.
25824 if Kind
in Name_Ignore | Name_Off
25825 and then (CodePeer_Mode
or GNATprove_Mode
)
25827 Kind
:= Name_Check
;
25831 end Policy_In_Effect
;
25833 -------------------------------
25834 -- Preanalyze_Without_Errors --
25835 -------------------------------
25837 procedure Preanalyze_Without_Errors
(N
: Node_Id
) is
25838 Status
: constant Boolean := Get_Ignore_Errors
;
25840 Set_Ignore_Errors
(True);
25842 Set_Ignore_Errors
(Status
);
25843 end Preanalyze_Without_Errors
;
25845 -----------------------
25846 -- Predicate_Enabled --
25847 -----------------------
25849 function Predicate_Enabled
(Typ
: Entity_Id
) return Boolean is
25851 return Present
(Predicate_Function
(Typ
))
25852 and then not Predicates_Ignored
(Typ
)
25853 and then not Predicate_Checks_Suppressed
(Empty
);
25854 end Predicate_Enabled
;
25856 ----------------------------------
25857 -- Predicate_Failure_Expression --
25858 ----------------------------------
25860 function Predicate_Failure_Expression
25861 (Typ
: Entity_Id
; Inherited_OK
: Boolean) return Node_Id
25863 PF_Aspect
: constant Node_Id
:=
25864 Find_Aspect
(Typ
, Aspect_Predicate_Failure
);
25866 -- Check for Predicate_Failure aspect specification via an
25867 -- aspect_specification (as opposed to via a pragma).
25869 if Present
(PF_Aspect
) then
25870 if Inherited_OK
or else Entity
(PF_Aspect
) = Typ
then
25871 return Expression
(PF_Aspect
);
25877 -- Check for Predicate_Failure aspect specification via a pragma.
25880 Rep_Item
: Node_Id
:= First_Rep_Item
(Typ
);
25882 while Present
(Rep_Item
) loop
25883 if Nkind
(Rep_Item
) = N_Pragma
25884 and then Get_Pragma_Id
(Rep_Item
) = Pragma_Predicate_Failure
25887 Arg1
: constant Node_Id
:=
25889 (First
(Pragma_Argument_Associations
(Rep_Item
)));
25890 Arg2
: constant Node_Id
:=
25892 (Next
(First
(Pragma_Argument_Associations
(Rep_Item
))));
25894 if Inherited_OK
or else
25895 (Nkind
(Arg1
) in N_Has_Entity
25896 and then Entity
(Arg1
) = Typ
)
25903 Next_Rep_Item
(Rep_Item
);
25907 -- If we are interested in an inherited Predicate_Failure aspect
25908 -- and we have an ancestor to inherit from, then recursively check
25911 if Inherited_OK
and then Present
(Nearest_Ancestor
(Typ
)) then
25912 return Predicate_Failure_Expression
(Nearest_Ancestor
(Typ
),
25913 Inherited_OK
=> True);
25917 end Predicate_Failure_Expression
;
25919 ----------------------------------
25920 -- Predicate_Tests_On_Arguments --
25921 ----------------------------------
25923 function Predicate_Tests_On_Arguments
(Subp
: Entity_Id
) return Boolean is
25925 -- Always test predicates on indirect call
25927 if Ekind
(Subp
) = E_Subprogram_Type
then
25930 -- Do not test predicates on call to generated default Finalize, since
25931 -- we are not interested in whether something we are finalizing (and
25932 -- typically destroying) satisfies its predicates.
25934 elsif Chars
(Subp
) = Name_Finalize
25935 and then not Comes_From_Source
(Subp
)
25939 -- Do not test predicates on any internally generated routines
25941 elsif Is_Internal_Name
(Chars
(Subp
)) then
25944 -- Do not test predicates on call to Init_Proc, since if needed the
25945 -- predicate test will occur at some other point.
25947 elsif Is_Init_Proc
(Subp
) then
25950 -- Do not test predicates on call to predicate function, since this
25951 -- would cause infinite recursion.
25953 elsif Ekind
(Subp
) = E_Function
25954 and then Is_Predicate_Function
(Subp
)
25958 -- For now, no other exceptions
25963 end Predicate_Tests_On_Arguments
;
25965 -----------------------
25966 -- Private_Component --
25967 -----------------------
25969 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
25970 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
25972 function Trace_Components
25974 Check
: Boolean) return Entity_Id
;
25975 -- Recursive function that does the work, and checks against circular
25976 -- definition for each subcomponent type.
25978 ----------------------
25979 -- Trace_Components --
25980 ----------------------
25982 function Trace_Components
25984 Check
: Boolean) return Entity_Id
25986 Btype
: constant Entity_Id
:= Base_Type
(T
);
25987 Component
: Entity_Id
;
25989 Candidate
: Entity_Id
:= Empty
;
25992 if Check
and then Btype
= Ancestor
then
25993 Error_Msg_N
("circular type definition", Type_Id
);
25997 if Is_Private_Type
(Btype
) and then not Is_Generic_Type
(Btype
) then
25998 if Present
(Full_View
(Btype
))
25999 and then Is_Record_Type
(Full_View
(Btype
))
26000 and then not Is_Frozen
(Btype
)
26002 -- To indicate that the ancestor depends on a private type, the
26003 -- current Btype is sufficient. However, to check for circular
26004 -- definition we must recurse on the full view.
26006 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
26008 if Candidate
= Any_Type
then
26018 elsif Is_Array_Type
(Btype
) then
26019 return Trace_Components
(Component_Type
(Btype
), True);
26021 elsif Is_Record_Type
(Btype
) then
26022 Component
:= First_Entity
(Btype
);
26023 while Present
(Component
)
26024 and then Comes_From_Source
(Component
)
26026 -- Skip anonymous types generated by constrained components
26028 if not Is_Type
(Component
) then
26029 P
:= Trace_Components
(Etype
(Component
), True);
26031 if Present
(P
) then
26032 if P
= Any_Type
then
26040 Next_Entity
(Component
);
26048 end Trace_Components
;
26050 -- Start of processing for Private_Component
26053 return Trace_Components
(Type_Id
, False);
26054 end Private_Component
;
26056 ---------------------------
26057 -- Primitive_Names_Match --
26058 ---------------------------
26060 function Primitive_Names_Match
(E1
, E2
: Entity_Id
) return Boolean is
26061 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
;
26062 -- Given an internal name, returns the corresponding non-internal name
26064 ------------------------
26065 -- Non_Internal_Name --
26066 ------------------------
26068 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
is
26070 Get_Name_String
(Chars
(E
));
26071 Name_Len
:= Name_Len
- 1;
26073 end Non_Internal_Name
;
26075 -- Start of processing for Primitive_Names_Match
26078 pragma Assert
(Present
(E1
) and then Present
(E2
));
26080 return Chars
(E1
) = Chars
(E2
)
26082 (not Is_Internal_Name
(Chars
(E1
))
26083 and then Is_Internal_Name
(Chars
(E2
))
26084 and then Non_Internal_Name
(E2
) = Chars
(E1
))
26086 (not Is_Internal_Name
(Chars
(E2
))
26087 and then Is_Internal_Name
(Chars
(E1
))
26088 and then Non_Internal_Name
(E1
) = Chars
(E2
))
26090 (Is_Predefined_Dispatching_Operation
(E1
)
26091 and then Is_Predefined_Dispatching_Operation
(E2
)
26092 and then Same_TSS
(E1
, E2
))
26094 (Is_Init_Proc
(E1
) and then Is_Init_Proc
(E2
));
26095 end Primitive_Names_Match
;
26097 -----------------------
26098 -- Process_End_Label --
26099 -----------------------
26101 procedure Process_End_Label
26110 Label_Ref
: Boolean;
26111 -- Set True if reference to end label itself is required
26114 -- Gets set to the operator symbol or identifier that references the
26115 -- entity Ent. For the child unit case, this is the identifier from the
26116 -- designator. For other cases, this is simply Endl.
26118 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
);
26119 -- N is an identifier node that appears as a parent unit reference in
26120 -- the case where Ent is a child unit. This procedure generates an
26121 -- appropriate cross-reference entry. E is the corresponding entity.
26123 -------------------------
26124 -- Generate_Parent_Ref --
26125 -------------------------
26127 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
) is
26129 -- If names do not match, something weird, skip reference
26131 if Chars
(E
) = Chars
(N
) then
26133 -- Generate the reference. We do NOT consider this as a reference
26134 -- for unreferenced symbol purposes.
26136 Generate_Reference
(E
, N
, 'r', Set_Ref
=> False, Force
=> True);
26138 if Style_Check
then
26139 Style
.Check_Identifier
(N
, E
);
26142 end Generate_Parent_Ref
;
26144 -- Start of processing for Process_End_Label
26147 -- If no node, ignore. This happens in some error situations, and
26148 -- also for some internally generated structures where no end label
26149 -- references are required in any case.
26155 -- Nothing to do if no End_Label, happens for internally generated
26156 -- constructs where we don't want an end label reference anyway. Also
26157 -- nothing to do if Endl is a string literal, which means there was
26158 -- some prior error (bad operator symbol)
26160 Endl
:= End_Label
(N
);
26162 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
26166 -- Reference node is not in extended main source unit
26168 if not In_Extended_Main_Source_Unit
(N
) then
26170 -- Generally we do not collect references except for the extended
26171 -- main source unit. The one exception is the 'e' entry for a
26172 -- package spec, where it is useful for a client to have the
26173 -- ending information to define scopes.
26179 Label_Ref
:= False;
26181 -- For this case, we can ignore any parent references, but we
26182 -- need the package name itself for the 'e' entry.
26184 if Nkind
(Endl
) = N_Designator
then
26185 Endl
:= Identifier
(Endl
);
26189 -- Reference is in extended main source unit
26194 -- For designator, generate references for the parent entries
26196 if Nkind
(Endl
) = N_Designator
then
26198 -- Generate references for the prefix if the END line comes from
26199 -- source (otherwise we do not need these references) We climb the
26200 -- scope stack to find the expected entities.
26202 if Comes_From_Source
(Endl
) then
26203 Nam
:= Name
(Endl
);
26204 Scop
:= Current_Scope
;
26205 while Nkind
(Nam
) = N_Selected_Component
loop
26206 Scop
:= Scope
(Scop
);
26207 exit when No
(Scop
);
26208 Generate_Parent_Ref
(Selector_Name
(Nam
), Scop
);
26209 Nam
:= Prefix
(Nam
);
26212 if Present
(Scop
) then
26213 Generate_Parent_Ref
(Nam
, Scope
(Scop
));
26217 Endl
:= Identifier
(Endl
);
26221 -- If the end label is not for the given entity, then either we have
26222 -- some previous error, or this is a generic instantiation for which
26223 -- we do not need to make a cross-reference in this case anyway. In
26224 -- either case we simply ignore the call.
26226 if Chars
(Ent
) /= Chars
(Endl
) then
26230 -- If label was really there, then generate a normal reference and then
26231 -- adjust the location in the end label to point past the name (which
26232 -- should almost always be the semicolon).
26234 Loc
:= Sloc
(Endl
);
26236 if Comes_From_Source
(Endl
) then
26238 -- If a label reference is required, then do the style check and
26239 -- generate an l-type cross-reference entry for the label
26242 if Style_Check
then
26243 Style
.Check_Identifier
(Endl
, Ent
);
26246 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
26249 -- Set the location to point past the label (normally this will
26250 -- mean the semicolon immediately following the label). This is
26251 -- done for the sake of the 'e' or 't' entry generated below.
26253 Get_Decoded_Name_String
(Chars
(Endl
));
26254 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
26257 -- Now generate the e/t reference
26259 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
26261 -- Restore Sloc, in case modified above, since we have an identifier
26262 -- and the normal Sloc should be left set in the tree.
26264 Set_Sloc
(Endl
, Loc
);
26265 end Process_End_Label
;
26267 --------------------------------
26268 -- Propagate_Concurrent_Flags --
26269 --------------------------------
26271 procedure Propagate_Concurrent_Flags
26273 Comp_Typ
: Entity_Id
)
26276 if Has_Task
(Comp_Typ
) then
26277 Set_Has_Task
(Typ
);
26280 if Has_Protected
(Comp_Typ
) then
26281 Set_Has_Protected
(Typ
);
26284 if Has_Timing_Event
(Comp_Typ
) then
26285 Set_Has_Timing_Event
(Typ
);
26287 end Propagate_Concurrent_Flags
;
26289 ------------------------------
26290 -- Propagate_DIC_Attributes --
26291 ------------------------------
26293 procedure Propagate_DIC_Attributes
26295 From_Typ
: Entity_Id
)
26297 DIC_Proc
: Entity_Id
;
26298 Partial_DIC_Proc
: Entity_Id
;
26301 if Present
(Typ
) and then Present
(From_Typ
) then
26302 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26304 -- Nothing to do if both the source and the destination denote the
26307 if From_Typ
= Typ
then
26310 -- Nothing to do when the destination denotes an incomplete type
26311 -- because the DIC is associated with the current instance of a
26312 -- private type, thus it can never apply to an incomplete type.
26314 elsif Is_Incomplete_Type
(Typ
) then
26318 DIC_Proc
:= DIC_Procedure
(From_Typ
);
26319 Partial_DIC_Proc
:= Partial_DIC_Procedure
(From_Typ
);
26321 -- The setting of the attributes is intentionally conservative. This
26322 -- prevents accidental clobbering of enabled attributes. We need to
26323 -- call Base_Type twice, because it is sometimes not set to an actual
26326 if Has_Inherited_DIC
(From_Typ
) then
26327 Set_Has_Inherited_DIC
(Base_Type
(Base_Type
(Typ
)));
26330 if Has_Own_DIC
(From_Typ
) then
26331 Set_Has_Own_DIC
(Base_Type
(Base_Type
(Typ
)));
26334 if Present
(DIC_Proc
) and then No
(DIC_Procedure
(Typ
)) then
26335 Set_DIC_Procedure
(Typ
, DIC_Proc
);
26338 if Present
(Partial_DIC_Proc
)
26339 and then No
(Partial_DIC_Procedure
(Typ
))
26341 Set_Partial_DIC_Procedure
(Typ
, Partial_DIC_Proc
);
26344 end Propagate_DIC_Attributes
;
26346 ------------------------------------
26347 -- Propagate_Invariant_Attributes --
26348 ------------------------------------
26350 procedure Propagate_Invariant_Attributes
26352 From_Typ
: Entity_Id
)
26354 Full_IP
: Entity_Id
;
26355 Part_IP
: Entity_Id
;
26358 if Present
(Typ
) and then Present
(From_Typ
) then
26359 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26361 -- Nothing to do if both the source and the destination denote the
26364 if From_Typ
= Typ
then
26368 Full_IP
:= Invariant_Procedure
(From_Typ
);
26369 Part_IP
:= Partial_Invariant_Procedure
(From_Typ
);
26371 -- The setting of the attributes is intentionally conservative. This
26372 -- prevents accidental clobbering of enabled attributes. We need to
26373 -- call Base_Type twice, because it is sometimes not set to an actual
26376 if Has_Inheritable_Invariants
(From_Typ
) then
26377 Set_Has_Inheritable_Invariants
(Base_Type
(Base_Type
(Typ
)));
26380 if Has_Inherited_Invariants
(From_Typ
) then
26381 Set_Has_Inherited_Invariants
(Base_Type
(Base_Type
(Typ
)));
26384 if Has_Own_Invariants
(From_Typ
) then
26385 Set_Has_Own_Invariants
(Base_Type
(Base_Type
(Typ
)));
26388 if Present
(Full_IP
) and then No
(Invariant_Procedure
(Typ
)) then
26389 Set_Invariant_Procedure
(Typ
, Full_IP
);
26392 if Present
(Part_IP
) and then No
(Partial_Invariant_Procedure
(Typ
))
26394 Set_Partial_Invariant_Procedure
(Typ
, Part_IP
);
26397 end Propagate_Invariant_Attributes
;
26399 ------------------------------------
26400 -- Propagate_Predicate_Attributes --
26401 ------------------------------------
26403 procedure Propagate_Predicate_Attributes
26405 From_Typ
: Entity_Id
)
26407 Pred_Func
: Entity_Id
;
26409 if Present
(Typ
) and then Present
(From_Typ
) then
26410 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
26412 -- Nothing to do if both the source and the destination denote the
26415 if From_Typ
= Typ
then
26419 Pred_Func
:= Predicate_Function
(From_Typ
);
26421 -- The setting of the attributes is intentionally conservative. This
26422 -- prevents accidental clobbering of enabled attributes.
26424 if Has_Predicates
(From_Typ
) then
26425 Set_Has_Predicates
(Typ
);
26428 if Present
(Pred_Func
) and then No
(Predicate_Function
(Typ
)) then
26429 Set_Predicate_Function
(Typ
, Pred_Func
);
26432 end Propagate_Predicate_Attributes
;
26434 ---------------------------------------
26435 -- Record_Possible_Part_Of_Reference --
26436 ---------------------------------------
26438 procedure Record_Possible_Part_Of_Reference
26439 (Var_Id
: Entity_Id
;
26442 Encap
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
26446 -- The variable is a constituent of a single protected/task type. Such
26447 -- a variable acts as a component of the type and must appear within a
26448 -- specific region (SPARK RM 9(3)). Instead of recording the reference,
26449 -- verify its legality now.
26451 if Present
(Encap
) and then Is_Single_Concurrent_Object
(Encap
) then
26452 Check_Part_Of_Reference
(Var_Id
, Ref
);
26454 -- The variable is subject to pragma Part_Of and may eventually become a
26455 -- constituent of a single protected/task type. Record the reference to
26456 -- verify its placement when the contract of the variable is analyzed.
26458 elsif Present
(Get_Pragma
(Var_Id
, Pragma_Part_Of
)) then
26459 Refs
:= Part_Of_References
(Var_Id
);
26462 Refs
:= New_Elmt_List
;
26463 Set_Part_Of_References
(Var_Id
, Refs
);
26466 Append_Elmt
(Ref
, Refs
);
26468 end Record_Possible_Part_Of_Reference
;
26474 function Referenced
(Id
: Entity_Id
; Expr
: Node_Id
) return Boolean is
26475 Seen
: Boolean := False;
26477 function Is_Reference
(N
: Node_Id
) return Traverse_Result
;
26478 -- Determine whether node N denotes a reference to Id. If this is the
26479 -- case, set global flag Seen to True and stop the traversal.
26485 function Is_Reference
(N
: Node_Id
) return Traverse_Result
is
26487 if Is_Entity_Name
(N
)
26488 and then Present
(Entity
(N
))
26489 and then Entity
(N
) = Id
26498 procedure Inspect_Expression
is new Traverse_Proc
(Is_Reference
);
26500 -- Start of processing for Referenced
26503 Inspect_Expression
(Expr
);
26507 ------------------------------------
26508 -- References_Generic_Formal_Type --
26509 ------------------------------------
26511 function References_Generic_Formal_Type
(N
: Node_Id
) return Boolean is
26513 function Process
(N
: Node_Id
) return Traverse_Result
;
26514 -- Process one node in search for generic formal type
26520 function Process
(N
: Node_Id
) return Traverse_Result
is
26522 if Nkind
(N
) in N_Has_Entity
then
26524 E
: constant Entity_Id
:= Entity
(N
);
26526 if Present
(E
) then
26527 if Is_Generic_Type
(E
) then
26529 elsif Present
(Etype
(E
))
26530 and then Is_Generic_Type
(Etype
(E
))
26541 function Traverse
is new Traverse_Func
(Process
);
26542 -- Traverse tree to look for generic type
26545 if Inside_A_Generic
then
26546 return Traverse
(N
) = Abandon
;
26550 end References_Generic_Formal_Type
;
26552 -------------------------------
26553 -- Remove_Entity_And_Homonym --
26554 -------------------------------
26556 procedure Remove_Entity_And_Homonym
(Id
: Entity_Id
) is
26558 Remove_Entity
(Id
);
26559 Remove_Homonym
(Id
);
26560 end Remove_Entity_And_Homonym
;
26562 --------------------
26563 -- Remove_Homonym --
26564 --------------------
26566 procedure Remove_Homonym
(Id
: Entity_Id
) is
26568 Prev
: Entity_Id
:= Empty
;
26571 if Id
= Current_Entity
(Id
) then
26572 if Present
(Homonym
(Id
)) then
26573 Set_Current_Entity
(Homonym
(Id
));
26575 Set_Name_Entity_Id
(Chars
(Id
), Empty
);
26579 Hom
:= Current_Entity
(Id
);
26580 while Present
(Hom
) and then Hom
/= Id
loop
26582 Hom
:= Homonym
(Hom
);
26585 -- If Id is not on the homonym chain, nothing to do
26587 if Present
(Hom
) then
26588 Set_Homonym
(Prev
, Homonym
(Id
));
26591 end Remove_Homonym
;
26593 ------------------------------
26594 -- Remove_Overloaded_Entity --
26595 ------------------------------
26597 procedure Remove_Overloaded_Entity
(Id
: Entity_Id
) is
26598 procedure Remove_Primitive_Of
(Typ
: Entity_Id
);
26599 -- Remove primitive subprogram Id from the list of primitives that
26600 -- belong to type Typ.
26602 -------------------------
26603 -- Remove_Primitive_Of --
26604 -------------------------
26606 procedure Remove_Primitive_Of
(Typ
: Entity_Id
) is
26610 if Is_Tagged_Type
(Typ
) then
26611 Prims
:= Direct_Primitive_Operations
(Typ
);
26613 if Present
(Prims
) then
26614 Remove
(Prims
, Id
);
26617 end Remove_Primitive_Of
;
26621 Formal
: Entity_Id
;
26623 -- Start of processing for Remove_Overloaded_Entity
26626 Remove_Entity_And_Homonym
(Id
);
26628 -- The entity denotes a primitive subprogram. Remove it from the list of
26629 -- primitives of the associated controlling type.
26631 if Ekind
(Id
) in E_Function | E_Procedure
and then Is_Primitive
(Id
) then
26632 Formal
:= First_Formal
(Id
);
26633 while Present
(Formal
) loop
26634 if Is_Controlling_Formal
(Formal
) then
26635 Remove_Primitive_Of
(Etype
(Formal
));
26639 Next_Formal
(Formal
);
26642 if Ekind
(Id
) = E_Function
and then Has_Controlling_Result
(Id
) then
26643 Remove_Primitive_Of
(Etype
(Id
));
26646 end Remove_Overloaded_Entity
;
26648 ---------------------
26649 -- Rep_To_Pos_Flag --
26650 ---------------------
26652 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
26654 return New_Occurrence_Of
26655 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
26656 end Rep_To_Pos_Flag
;
26658 --------------------
26659 -- Require_Entity --
26660 --------------------
26662 procedure Require_Entity
(N
: Node_Id
) is
26664 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
26665 if Total_Errors_Detected
/= 0 then
26666 Set_Entity
(N
, Any_Id
);
26668 raise Program_Error
;
26671 end Require_Entity
;
26673 ------------------------------
26674 -- Requires_Transient_Scope --
26675 ------------------------------
26677 function Requires_Transient_Scope
(Typ
: Entity_Id
) return Boolean is
26679 return Needs_Secondary_Stack
(Typ
) or else Needs_Finalization
(Typ
);
26680 end Requires_Transient_Scope
;
26682 --------------------------
26683 -- Reset_Analyzed_Flags --
26684 --------------------------
26686 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
26687 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
;
26688 -- Function used to reset Analyzed flags in tree. Note that we do
26689 -- not reset Analyzed flags in entities, since there is no need to
26690 -- reanalyze entities, and indeed, it is wrong to do so, since it
26691 -- can result in generating auxiliary stuff more than once.
26693 --------------------
26694 -- Clear_Analyzed --
26695 --------------------
26697 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
is
26699 if Nkind
(N
) not in N_Entity
then
26700 Set_Analyzed
(N
, False);
26704 end Clear_Analyzed
;
26706 procedure Reset_Analyzed
is new Traverse_Proc
(Clear_Analyzed
);
26708 -- Start of processing for Reset_Analyzed_Flags
26711 Reset_Analyzed
(N
);
26712 end Reset_Analyzed_Flags
;
26714 ------------------------
26715 -- Restore_SPARK_Mode --
26716 ------------------------
26718 procedure Restore_SPARK_Mode
26719 (Mode
: SPARK_Mode_Type
;
26723 SPARK_Mode
:= Mode
;
26724 SPARK_Mode_Pragma
:= Prag
;
26725 end Restore_SPARK_Mode
;
26727 --------------------------------
26728 -- Returns_Unconstrained_Type --
26729 --------------------------------
26731 function Returns_Unconstrained_Type
(Subp
: Entity_Id
) return Boolean is
26733 return Ekind
(Subp
) = E_Function
26734 and then not Is_Scalar_Type
(Etype
(Subp
))
26735 and then not Is_Access_Type
(Etype
(Subp
))
26736 and then not Is_Constrained
(Etype
(Subp
));
26737 end Returns_Unconstrained_Type
;
26739 ----------------------------
26740 -- Root_Type_Of_Full_View --
26741 ----------------------------
26743 function Root_Type_Of_Full_View
(T
: Entity_Id
) return Entity_Id
is
26744 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
26747 -- The root type of the full view may itself be a private type. Keep
26748 -- looking for the ultimate derivation parent.
26750 if Is_Private_Type
(Rtyp
) and then Present
(Full_View
(Rtyp
)) then
26751 return Root_Type_Of_Full_View
(Full_View
(Rtyp
));
26755 end Root_Type_Of_Full_View
;
26757 ---------------------------
26758 -- Safe_To_Capture_Value --
26759 ---------------------------
26761 function Safe_To_Capture_Value
26764 Cond
: Boolean := False) return Boolean
26767 -- The only entities for which we track constant values are variables
26768 -- that are not renamings, constants and formal parameters, so check
26769 -- if we have this case.
26771 -- Note: it may seem odd to track constant values for constants, but in
26772 -- fact this routine is used for other purposes than simply capturing
26773 -- the value. In particular, the setting of Known[_Non]_Null and
26776 if (Ekind
(Ent
) = E_Variable
and then No
(Renamed_Object
(Ent
)))
26778 Ekind
(Ent
) = E_Constant
26784 -- For conditionals, we also allow loop parameters
26786 elsif Cond
and then Ekind
(Ent
) = E_Loop_Parameter
then
26789 -- For all other cases, not just unsafe, but impossible to capture
26790 -- Current_Value, since the above are the only entities which have
26791 -- Current_Value fields.
26797 -- Skip if volatile or aliased, since funny things might be going on in
26798 -- these cases which we cannot necessarily track. Also skip any variable
26799 -- for which an address clause is given, or whose address is taken. Also
26800 -- never capture value of library level variables (an attempt to do so
26801 -- can occur in the case of package elaboration code).
26803 if Treat_As_Volatile
(Ent
)
26804 or else Is_Aliased
(Ent
)
26805 or else Present
(Address_Clause
(Ent
))
26806 or else Address_Taken
(Ent
)
26807 or else (Is_Library_Level_Entity
(Ent
)
26808 and then Ekind
(Ent
) = E_Variable
)
26813 -- OK, all above conditions are met. We also require that the scope of
26814 -- the reference be the same as the scope of the entity, not counting
26815 -- packages and blocks and loops.
26818 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
26819 R_Scope
: Entity_Id
;
26822 R_Scope
:= Current_Scope
;
26823 while R_Scope
/= Standard_Standard
loop
26824 exit when R_Scope
= E_Scope
;
26826 if Ekind
(R_Scope
) not in E_Package | E_Block | E_Loop
then
26829 R_Scope
:= Scope
(R_Scope
);
26834 -- We also require that the reference does not appear in a context
26835 -- where it is not sure to be executed (i.e. a conditional context
26836 -- or an exception handler). We skip this if Cond is True, since the
26837 -- capturing of values from conditional tests handles this ok.
26839 if Cond
or else No
(N
) then
26850 -- Seems dubious that case expressions are not handled here ???
26853 while Present
(P
) loop
26854 if Is_Body
(P
) then
26857 elsif Nkind
(P
) = N_If_Statement
26858 or else Nkind
(P
) = N_Case_Statement
26859 or else (Nkind
(P
) in N_Short_Circuit
26860 and then Desc
= Right_Opnd
(P
))
26861 or else (Nkind
(P
) = N_If_Expression
26862 and then Desc
/= First
(Expressions
(P
)))
26863 or else Nkind
(P
) = N_Exception_Handler
26864 or else Nkind
(P
) = N_Selective_Accept
26865 or else Nkind
(P
) = N_Conditional_Entry_Call
26866 or else Nkind
(P
) = N_Timed_Entry_Call
26867 or else Nkind
(P
) = N_Asynchronous_Select
26875 -- A special Ada 2012 case: the original node may be part
26876 -- of the else_actions of a conditional expression, in which
26877 -- case it might not have been expanded yet, and appears in
26878 -- a non-syntactic list of actions. In that case it is clearly
26879 -- not safe to save a value.
26882 and then Is_List_Member
(Desc
)
26883 and then No
(Parent
(List_Containing
(Desc
)))
26891 -- OK, looks safe to set value
26894 end Safe_To_Capture_Value
;
26900 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
26901 K1
: constant Node_Kind
:= Nkind
(N1
);
26902 K2
: constant Node_Kind
:= Nkind
(N2
);
26905 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
26906 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
26908 return Chars
(N1
) = Chars
(N2
);
26910 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
26911 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
26913 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
26914 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
26925 function Same_Object
(Node1
, Node2
: Node_Id
) return Boolean is
26926 N1
: constant Node_Id
:= Original_Node
(Node1
);
26927 N2
: constant Node_Id
:= Original_Node
(Node2
);
26928 -- We do the tests on original nodes, since we are most interested
26929 -- in the original source, not any expansion that got in the way.
26931 K1
: constant Node_Kind
:= Nkind
(N1
);
26932 K2
: constant Node_Kind
:= Nkind
(N2
);
26935 -- First case, both are entities with same entity
26937 if K1
in N_Has_Entity
and then K2
in N_Has_Entity
then
26939 EN1
: constant Entity_Id
:= Entity
(N1
);
26940 EN2
: constant Entity_Id
:= Entity
(N2
);
26942 if Present
(EN1
) and then Present
(EN2
)
26943 and then (Ekind
(EN1
) in E_Variable | E_Constant
26944 or else Is_Formal
(EN1
))
26952 -- Second case, selected component with same selector, same record
26954 if K1
= N_Selected_Component
26955 and then K2
= N_Selected_Component
26956 and then Chars
(Selector_Name
(N1
)) = Chars
(Selector_Name
(N2
))
26958 return Same_Object
(Prefix
(N1
), Prefix
(N2
));
26960 -- Third case, indexed component with same subscripts, same array
26962 elsif K1
= N_Indexed_Component
26963 and then K2
= N_Indexed_Component
26964 and then Same_Object
(Prefix
(N1
), Prefix
(N2
))
26969 E1
:= First
(Expressions
(N1
));
26970 E2
:= First
(Expressions
(N2
));
26971 while Present
(E1
) loop
26972 if not Same_Value
(E1
, E2
) then
26983 -- Fourth case, slice of same array with same bounds
26986 and then K2
= N_Slice
26987 and then Nkind
(Discrete_Range
(N1
)) = N_Range
26988 and then Nkind
(Discrete_Range
(N2
)) = N_Range
26989 and then Same_Value
(Low_Bound
(Discrete_Range
(N1
)),
26990 Low_Bound
(Discrete_Range
(N2
)))
26991 and then Same_Value
(High_Bound
(Discrete_Range
(N1
)),
26992 High_Bound
(Discrete_Range
(N2
)))
26994 return Same_Name
(Prefix
(N1
), Prefix
(N2
));
26996 -- All other cases, not clearly the same object
27003 ---------------------------------
27004 -- Same_Or_Aliased_Subprograms --
27005 ---------------------------------
27007 function Same_Or_Aliased_Subprograms
27009 E
: Entity_Id
) return Boolean
27011 Subp_Alias
: constant Entity_Id
:= Alias
(S
);
27012 Subp
: Entity_Id
:= E
;
27014 -- During expansion of subprograms with postconditions the original
27015 -- subprogram's declarations and statements get wrapped into a local
27016 -- _Wrapped_Statements subprogram.
27018 if Chars
(Subp
) = Name_uWrapped_Statements
then
27019 Subp
:= Enclosing_Subprogram
(Subp
);
27023 or else (Present
(Subp_Alias
) and then Subp_Alias
= Subp
);
27024 end Same_Or_Aliased_Subprograms
;
27030 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
27035 elsif not Is_Constrained
(T1
)
27036 and then not Is_Constrained
(T2
)
27037 and then Base_Type
(T1
) = Base_Type
(T2
)
27041 -- For now don't bother with case of identical constraints, to be
27042 -- fiddled with later on perhaps (this is only used for optimization
27043 -- purposes, so it is not critical to do a best possible job)
27054 function Same_Value
(Node1
, Node2
: Node_Id
) return Boolean is
27056 if Compile_Time_Known_Value
(Node1
)
27057 and then Compile_Time_Known_Value
(Node2
)
27059 -- Handle properly compile-time expressions that are not
27062 if Is_String_Type
(Etype
(Node1
)) then
27063 return Expr_Value_S
(Node1
) = Expr_Value_S
(Node2
);
27066 return Expr_Value
(Node1
) = Expr_Value
(Node2
);
27069 elsif Same_Object
(Node1
, Node2
) then
27076 --------------------
27077 -- Set_SPARK_Mode --
27078 --------------------
27080 procedure Set_SPARK_Mode
(Context
: Entity_Id
) is
27082 -- Do not consider illegal or partially decorated constructs
27084 if Ekind
(Context
) = E_Void
or else Error_Posted
(Context
) then
27087 elsif Present
(SPARK_Pragma
(Context
)) then
27089 (Mode
=> Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Context
)),
27090 Prag
=> SPARK_Pragma
(Context
));
27092 end Set_SPARK_Mode
;
27094 -------------------------
27095 -- Scalar_Part_Present --
27096 -------------------------
27098 function Scalar_Part_Present
(Typ
: Entity_Id
) return Boolean is
27099 Val_Typ
: constant Entity_Id
:= Validated_View
(Typ
);
27103 if Is_Scalar_Type
(Val_Typ
) then
27106 elsif Is_Array_Type
(Val_Typ
) then
27107 return Scalar_Part_Present
(Component_Type
(Val_Typ
));
27109 elsif Is_Record_Type
(Val_Typ
) then
27110 Field
:= First_Component_Or_Discriminant
(Val_Typ
);
27111 while Present
(Field
) loop
27112 if Scalar_Part_Present
(Etype
(Field
)) then
27116 Next_Component_Or_Discriminant
(Field
);
27121 end Scalar_Part_Present
;
27123 ------------------------
27124 -- Scope_Is_Transient --
27125 ------------------------
27127 function Scope_Is_Transient
return Boolean is
27129 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
27130 end Scope_Is_Transient
;
27136 function Scope_Within
27137 (Inner
: Entity_Id
;
27138 Outer
: Entity_Id
) return Boolean
27144 while Present
(Curr
) and then Curr
/= Standard_Standard
loop
27145 Curr
:= Scope
(Curr
);
27147 if Curr
= Outer
then
27150 -- A selective accept body appears within a task type, but the
27151 -- enclosing subprogram is the procedure of the task body.
27153 elsif Ekind
(Implementation_Base_Type
(Curr
)) = E_Task_Type
27155 Outer
= Task_Body_Procedure
(Implementation_Base_Type
(Curr
))
27159 -- Ditto for the body of a protected operation
27161 elsif Is_Subprogram
(Curr
)
27162 and then Outer
= Protected_Body_Subprogram
(Curr
)
27166 -- Outside of its scope, a synchronized type may just be private
27168 elsif Is_Private_Type
(Curr
)
27169 and then Present
(Full_View
(Curr
))
27170 and then Is_Concurrent_Type
(Full_View
(Curr
))
27172 return Scope_Within
(Full_View
(Curr
), Outer
);
27179 --------------------------
27180 -- Scope_Within_Or_Same --
27181 --------------------------
27183 function Scope_Within_Or_Same
27184 (Inner
: Entity_Id
;
27185 Outer
: Entity_Id
) return Boolean
27187 Curr
: Entity_Id
:= Inner
;
27190 -- Similar to the above, but check for scope identity first
27192 while Present
(Curr
) and then Curr
/= Standard_Standard
loop
27193 if Curr
= Outer
then
27196 elsif Ekind
(Implementation_Base_Type
(Curr
)) = E_Task_Type
27198 Outer
= Task_Body_Procedure
(Implementation_Base_Type
(Curr
))
27202 elsif Is_Subprogram
(Curr
)
27203 and then Outer
= Protected_Body_Subprogram
(Curr
)
27207 elsif Is_Private_Type
(Curr
)
27208 and then Present
(Full_View
(Curr
))
27210 if Full_View
(Curr
) = Outer
then
27213 return Scope_Within
(Full_View
(Curr
), Outer
);
27217 Curr
:= Scope
(Curr
);
27221 end Scope_Within_Or_Same
;
27223 ------------------------
27224 -- Set_Current_Entity --
27225 ------------------------
27227 -- The given entity is to be set as the currently visible definition of its
27228 -- associated name (i.e. the Node_Id associated with its name). All we have
27229 -- to do is to get the name from the identifier, and then set the
27230 -- associated Node_Id to point to the given entity.
27232 procedure Set_Current_Entity
(E
: Entity_Id
) is
27234 Set_Name_Entity_Id
(Chars
(E
), E
);
27235 end Set_Current_Entity
;
27237 ---------------------------
27238 -- Set_Debug_Info_Needed --
27239 ---------------------------
27241 procedure Set_Debug_Info_Needed
(T
: Entity_Id
) is
27243 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
);
27244 pragma Inline
(Set_Debug_Info_Needed_If_Not_Set
);
27245 -- Used to set debug info in a related node if not set already
27247 --------------------------------------
27248 -- Set_Debug_Info_Needed_If_Not_Set --
27249 --------------------------------------
27251 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
) is
27253 if Present
(E
) and then not Needs_Debug_Info
(E
) then
27254 Set_Debug_Info_Needed
(E
);
27256 -- For a private type, indicate that the full view also needs
27257 -- debug information.
27260 and then Is_Private_Type
(E
)
27261 and then Present
(Full_View
(E
))
27263 Set_Debug_Info_Needed
(Full_View
(E
));
27266 end Set_Debug_Info_Needed_If_Not_Set
;
27268 -- Start of processing for Set_Debug_Info_Needed
27271 -- Nothing to do if there is no available entity
27276 -- Nothing to do for an entity with suppressed debug information
27278 elsif Debug_Info_Off
(T
) then
27281 -- Nothing to do for an ignored Ghost entity because the entity will be
27282 -- eliminated from the tree.
27284 elsif Is_Ignored_Ghost_Entity
(T
) then
27287 -- Nothing to do if entity comes from a predefined file. Library files
27288 -- are compiled without debug information, but inlined bodies of these
27289 -- routines may appear in user code, and debug information on them ends
27290 -- up complicating debugging the user code.
27292 elsif In_Inlined_Body
and then In_Predefined_Unit
(T
) then
27293 Set_Needs_Debug_Info
(T
, False);
27296 -- Set flag in entity itself. Note that we will go through the following
27297 -- circuitry even if the flag is already set on T. That's intentional,
27298 -- it makes sure that the flag will be set in subsidiary entities.
27300 Set_Needs_Debug_Info
(T
);
27302 -- Set flag on subsidiary entities if not set already
27304 if Is_Object
(T
) then
27305 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
27307 elsif Is_Type
(T
) then
27308 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
27310 if Is_Record_Type
(T
) then
27312 Ent
: Entity_Id
:= First_Entity
(T
);
27314 while Present
(Ent
) loop
27315 Set_Debug_Info_Needed_If_Not_Set
(Ent
);
27320 -- For a class wide subtype, we also need debug information
27321 -- for the equivalent type.
27323 if Ekind
(T
) = E_Class_Wide_Subtype
then
27324 Set_Debug_Info_Needed_If_Not_Set
(Equivalent_Type
(T
));
27327 elsif Is_Array_Type
(T
) then
27328 Set_Debug_Info_Needed_If_Not_Set
(Component_Type
(T
));
27331 Indx
: Node_Id
:= First_Index
(T
);
27333 while Present
(Indx
) loop
27334 Set_Debug_Info_Needed_If_Not_Set
(Etype
(Indx
));
27339 -- For a packed array type, we also need debug information for
27340 -- the type used to represent the packed array. Conversely, we
27341 -- also need it for the former if we need it for the latter.
27343 if Is_Packed
(T
) then
27344 Set_Debug_Info_Needed_If_Not_Set
(Packed_Array_Impl_Type
(T
));
27347 if Is_Packed_Array_Impl_Type
(T
) then
27348 Set_Debug_Info_Needed_If_Not_Set
(Original_Array_Type
(T
));
27351 elsif Is_Access_Type
(T
) then
27352 Set_Debug_Info_Needed_If_Not_Set
(Directly_Designated_Type
(T
));
27354 elsif Is_Private_Type
(T
) then
27356 FV
: constant Entity_Id
:= Full_View
(T
);
27359 Set_Debug_Info_Needed_If_Not_Set
(FV
);
27361 -- If the full view is itself a derived private type, we need
27362 -- debug information on its underlying type.
27365 and then Is_Private_Type
(FV
)
27366 and then Present
(Underlying_Full_View
(FV
))
27368 Set_Needs_Debug_Info
(Underlying_Full_View
(FV
));
27372 elsif Is_Protected_Type
(T
) then
27373 Set_Debug_Info_Needed_If_Not_Set
(Corresponding_Record_Type
(T
));
27375 elsif Is_Scalar_Type
(T
) then
27377 -- If the subrange bounds are materialized by dedicated constant
27378 -- objects, also include them in the debug info to make sure the
27379 -- debugger can properly use them.
27381 if Present
(Scalar_Range
(T
))
27382 and then Nkind
(Scalar_Range
(T
)) = N_Range
27385 Low_Bnd
: constant Node_Id
:= Type_Low_Bound
(T
);
27386 High_Bnd
: constant Node_Id
:= Type_High_Bound
(T
);
27389 if Is_Entity_Name
(Low_Bnd
) then
27390 Set_Debug_Info_Needed_If_Not_Set
(Entity
(Low_Bnd
));
27393 if Is_Entity_Name
(High_Bnd
) then
27394 Set_Debug_Info_Needed_If_Not_Set
(Entity
(High_Bnd
));
27400 end Set_Debug_Info_Needed
;
27402 --------------------------------
27403 -- Set_Debug_Info_Defining_Id --
27404 --------------------------------
27406 procedure Set_Debug_Info_Defining_Id
(N
: Node_Id
) is
27408 if Comes_From_Source
(Defining_Identifier
(N
))
27409 or else Debug_Generated_Code
27411 Set_Debug_Info_Needed
(Defining_Identifier
(N
));
27413 end Set_Debug_Info_Defining_Id
;
27415 ----------------------------
27416 -- Set_Entity_With_Checks --
27417 ----------------------------
27419 procedure Set_Entity_With_Checks
(N
: Node_Id
; Val
: Entity_Id
) is
27420 Val_Actual
: Entity_Id
;
27422 Post_Node
: Node_Id
;
27425 -- Unconditionally set the entity
27427 Set_Entity
(N
, Val
);
27429 -- The node to post on is the selector in the case of an expanded name,
27430 -- and otherwise the node itself.
27432 if Nkind
(N
) = N_Expanded_Name
then
27433 Post_Node
:= Selector_Name
(N
);
27438 -- Check for violation of No_Fixed_IO
27440 if Restriction_Check_Required
(No_Fixed_IO
)
27442 ((RTU_Loaded
(Ada_Text_IO
)
27443 and then (Is_RTE
(Val
, RE_Decimal_IO
)
27445 Is_RTE
(Val
, RE_Fixed_IO
)))
27448 (RTU_Loaded
(Ada_Wide_Text_IO
)
27449 and then (Is_RTE
(Val
, RO_WT_Decimal_IO
)
27451 Is_RTE
(Val
, RO_WT_Fixed_IO
)))
27454 (RTU_Loaded
(Ada_Wide_Wide_Text_IO
)
27455 and then (Is_RTE
(Val
, RO_WW_Decimal_IO
)
27457 Is_RTE
(Val
, RO_WW_Fixed_IO
))))
27459 -- A special extra check, don't complain about a reference from within
27460 -- the Ada.Interrupts package itself!
27462 and then not In_Same_Extended_Unit
(N
, Val
)
27464 Check_Restriction
(No_Fixed_IO
, Post_Node
);
27467 -- Remaining checks are only done on source nodes. Note that we test
27468 -- for violation of No_Fixed_IO even on non-source nodes, because the
27469 -- cases for checking violations of this restriction are instantiations
27470 -- where the reference in the instance has Comes_From_Source False.
27472 if not Comes_From_Source
(N
) then
27476 -- Check for violation of No_Abort_Statements, which is triggered by
27477 -- call to Ada.Task_Identification.Abort_Task.
27479 if Restriction_Check_Required
(No_Abort_Statements
)
27480 and then (Is_RTE
(Val
, RE_Abort_Task
))
27482 -- A special extra check, don't complain about a reference from within
27483 -- the Ada.Task_Identification package itself!
27485 and then not In_Same_Extended_Unit
(N
, Val
)
27487 Check_Restriction
(No_Abort_Statements
, Post_Node
);
27490 if Val
= Standard_Long_Long_Integer
then
27491 Check_Restriction
(No_Long_Long_Integers
, Post_Node
);
27494 -- Check for violation of No_Dynamic_Attachment
27496 if Restriction_Check_Required
(No_Dynamic_Attachment
)
27497 and then RTU_Loaded
(Ada_Interrupts
)
27498 and then (Is_RTE
(Val
, RE_Is_Reserved
) or else
27499 Is_RTE
(Val
, RE_Is_Attached
) or else
27500 Is_RTE
(Val
, RE_Current_Handler
) or else
27501 Is_RTE
(Val
, RE_Attach_Handler
) or else
27502 Is_RTE
(Val
, RE_Exchange_Handler
) or else
27503 Is_RTE
(Val
, RE_Detach_Handler
) or else
27504 Is_RTE
(Val
, RE_Reference
))
27506 -- A special extra check, don't complain about a reference from within
27507 -- the Ada.Interrupts package itself!
27509 and then not In_Same_Extended_Unit
(N
, Val
)
27511 Check_Restriction
(No_Dynamic_Attachment
, Post_Node
);
27514 -- Check for No_Implementation_Identifiers
27516 if Restriction_Check_Required
(No_Implementation_Identifiers
) then
27518 -- We have an implementation defined entity if it is marked as
27519 -- implementation defined, or is defined in a package marked as
27520 -- implementation defined. However, library packages themselves
27521 -- are excluded (we don't want to flag Interfaces itself, just
27522 -- the entities within it).
27524 if (Is_Implementation_Defined
(Val
)
27526 (Present
(Scope
(Val
))
27527 and then Is_Implementation_Defined
(Scope
(Val
))))
27528 and then not (Is_Package_Or_Generic_Package
(Val
)
27529 and then Is_Library_Level_Entity
(Val
))
27531 Check_Restriction
(No_Implementation_Identifiers
, Post_Node
);
27535 -- Do the style check
27538 and then not Suppress_Style_Checks
(Val
)
27539 and then not In_Instance
27541 if Nkind
(N
) = N_Identifier
then
27543 elsif Nkind
(N
) = N_Expanded_Name
then
27544 Nod
:= Selector_Name
(N
);
27549 -- A special situation arises for derived operations, where we want
27550 -- to do the check against the parent (since the Sloc of the derived
27551 -- operation points to the derived type declaration itself).
27554 while not Comes_From_Source
(Val_Actual
)
27555 and then Nkind
(Val_Actual
) in N_Entity
27556 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
27557 or else Is_Subprogram_Or_Generic_Subprogram
(Val_Actual
))
27558 and then Present
(Alias
(Val_Actual
))
27560 Val_Actual
:= Alias
(Val_Actual
);
27563 -- Renaming declarations for generic actuals do not come from source,
27564 -- and have a different name from that of the entity they rename, so
27565 -- there is no style check to perform here.
27567 if Chars
(Nod
) = Chars
(Val_Actual
) then
27568 Style
.Check_Identifier
(Nod
, Val_Actual
);
27571 end Set_Entity_With_Checks
;
27573 ------------------------------
27574 -- Set_Invalid_Scalar_Value --
27575 ------------------------------
27577 procedure Set_Invalid_Scalar_Value
27578 (Scal_Typ
: Float_Scalar_Id
;
27581 Slot
: Ureal
renames Invalid_Floats
(Scal_Typ
);
27584 -- Detect an attempt to set a different value for the same scalar type
27586 pragma Assert
(Slot
= No_Ureal
);
27588 end Set_Invalid_Scalar_Value
;
27590 ------------------------------
27591 -- Set_Invalid_Scalar_Value --
27592 ------------------------------
27594 procedure Set_Invalid_Scalar_Value
27595 (Scal_Typ
: Integer_Scalar_Id
;
27598 Slot
: Uint
renames Invalid_Integers
(Scal_Typ
);
27601 -- Detect an attempt to set a different value for the same scalar type
27603 pragma Assert
(No
(Slot
));
27605 end Set_Invalid_Scalar_Value
;
27607 ------------------------
27608 -- Set_Name_Entity_Id --
27609 ------------------------
27611 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
27613 Set_Name_Table_Int
(Id
, Int
(Val
));
27614 end Set_Name_Entity_Id
;
27616 ---------------------
27617 -- Set_Next_Actual --
27618 ---------------------
27620 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
27622 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
27623 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
27625 end Set_Next_Actual
;
27627 ----------------------------------
27628 -- Set_Optimize_Alignment_Flags --
27629 ----------------------------------
27631 procedure Set_Optimize_Alignment_Flags
(E
: Entity_Id
) is
27633 if Optimize_Alignment
= 'S' then
27634 Set_Optimize_Alignment_Space
(E
);
27635 elsif Optimize_Alignment
= 'T' then
27636 Set_Optimize_Alignment_Time
(E
);
27638 end Set_Optimize_Alignment_Flags
;
27640 -----------------------
27641 -- Set_Public_Status --
27642 -----------------------
27644 procedure Set_Public_Status
(Id
: Entity_Id
) is
27645 S
: constant Entity_Id
:= Current_Scope
;
27647 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean;
27648 -- Determines if E is defined within handled statement sequence or
27649 -- an if statement, returns True if so, False otherwise.
27651 ----------------------
27652 -- Within_HSS_Or_If --
27653 ----------------------
27655 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean is
27658 N
:= Declaration_Node
(E
);
27666 N_Handled_Sequence_Of_Statements | N_If_Statement
27671 end Within_HSS_Or_If
;
27673 -- Start of processing for Set_Public_Status
27676 -- Everything in the scope of Standard is public
27678 if S
= Standard_Standard
then
27679 Set_Is_Public
(Id
);
27681 -- Entity is definitely not public if enclosing scope is not public
27683 elsif not Is_Public
(S
) then
27686 -- An object or function declaration that occurs in a handled sequence
27687 -- of statements or within an if statement is the declaration for a
27688 -- temporary object or local subprogram generated by the expander. It
27689 -- never needs to be made public and furthermore, making it public can
27690 -- cause back end problems.
27692 elsif Nkind
(Parent
(Id
)) in
27693 N_Object_Declaration | N_Function_Specification
27694 and then Within_HSS_Or_If
(Id
)
27698 -- Entities in public packages or records are public
27700 elsif Ekind
(S
) = E_Package
or Is_Record_Type
(S
) then
27701 Set_Is_Public
(Id
);
27703 -- The bounds of an entry family declaration can generate object
27704 -- declarations that are visible to the back-end, e.g. in the
27705 -- the declaration of a composite type that contains tasks.
27707 elsif Is_Concurrent_Type
(S
)
27708 and then not Has_Completion
(S
)
27709 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
27711 Set_Is_Public
(Id
);
27713 end Set_Public_Status
;
27715 -----------------------------
27716 -- Set_Referenced_Modified --
27717 -----------------------------
27719 procedure Set_Referenced_Modified
(N
: Node_Id
; Out_Param
: Boolean) is
27723 -- Deal with indexed or selected component where prefix is modified
27725 if Nkind
(N
) in N_Indexed_Component | N_Selected_Component
then
27726 Pref
:= Prefix
(N
);
27728 -- If prefix is access type, then it is the designated object that is
27729 -- being modified, which means we have no entity to set the flag on.
27731 if No
(Etype
(Pref
)) or else Is_Access_Type
(Etype
(Pref
)) then
27734 -- Otherwise chase the prefix
27737 Set_Referenced_Modified
(Pref
, Out_Param
);
27740 -- Otherwise see if we have an entity name (only other case to process)
27742 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
27743 Set_Referenced_As_LHS
(Entity
(N
), not Out_Param
);
27744 Set_Referenced_As_Out_Parameter
(Entity
(N
), Out_Param
);
27746 end Set_Referenced_Modified
;
27752 procedure Set_Rep_Info
(T1
: Entity_Id
; T2
: Entity_Id
) is
27754 Set_Is_Atomic
(T1
, Is_Atomic
(T2
));
27755 Set_Is_Independent
(T1
, Is_Independent
(T2
));
27756 Set_Is_Volatile_Full_Access
(T1
, Is_Volatile_Full_Access
(T2
));
27758 if Is_Base_Type
(T1
) then
27759 Set_Is_Volatile
(T1
, Is_Volatile
(T2
));
27763 ----------------------------
27764 -- Set_Scope_Is_Transient --
27765 ----------------------------
27767 procedure Set_Scope_Is_Transient
(V
: Boolean := True) is
27769 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= V
;
27770 end Set_Scope_Is_Transient
;
27772 -------------------
27773 -- Set_Size_Info --
27774 -------------------
27776 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
27778 -- We copy Esize, but not RM_Size, since in general RM_Size is
27779 -- subtype specific and does not get inherited by all subtypes.
27781 Copy_Esize
(To
=> T1
, From
=> T2
);
27782 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
27784 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
27786 Is_Discrete_Or_Fixed_Point_Type
(T2
)
27788 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
27791 Copy_Alignment
(To
=> T1
, From
=> T2
);
27794 ------------------------------
27795 -- Should_Ignore_Pragma_Par --
27796 ------------------------------
27798 function Should_Ignore_Pragma_Par
(Prag_Name
: Name_Id
) return Boolean is
27799 pragma Assert
(Compiler_State
= Parsing
);
27800 -- This one can't work during semantic analysis, because we don't have a
27801 -- correct Current_Source_File.
27803 Result
: constant Boolean :=
27804 Get_Name_Table_Boolean3
(Prag_Name
)
27805 and then not Is_Internal_File_Name
27806 (File_Name
(Current_Source_File
));
27809 end Should_Ignore_Pragma_Par
;
27811 ------------------------------
27812 -- Should_Ignore_Pragma_Sem --
27813 ------------------------------
27815 function Should_Ignore_Pragma_Sem
(N
: Node_Id
) return Boolean is
27816 pragma Assert
(Compiler_State
= Analyzing
);
27817 Prag_Name
: constant Name_Id
:= Pragma_Name
(N
);
27818 Result
: constant Boolean :=
27819 Get_Name_Table_Boolean3
(Prag_Name
)
27820 and then not In_Internal_Unit
(N
);
27824 end Should_Ignore_Pragma_Sem
;
27826 --------------------
27827 -- Static_Boolean --
27828 --------------------
27830 function Static_Boolean
(N
: Node_Id
) return Opt_Ubool
is
27832 Analyze_And_Resolve
(N
, Standard_Boolean
);
27835 or else Error_Posted
(N
)
27836 or else Etype
(N
) = Any_Type
27841 if Is_OK_Static_Expression
(N
) then
27842 if not Raises_Constraint_Error
(N
) then
27843 return Expr_Value
(N
);
27848 elsif Etype
(N
) = Any_Type
then
27852 Flag_Non_Static_Expr
27853 ("static boolean expression required here", N
);
27856 end Static_Boolean
;
27858 --------------------
27859 -- Static_Integer --
27860 --------------------
27862 function Static_Integer
(N
: Node_Id
) return Uint
is
27864 Analyze_And_Resolve
(N
, Any_Integer
);
27867 or else Error_Posted
(N
)
27868 or else Etype
(N
) = Any_Type
27873 if Is_OK_Static_Expression
(N
) then
27874 if not Raises_Constraint_Error
(N
) then
27875 return Expr_Value
(N
);
27880 elsif Etype
(N
) = Any_Type
then
27884 Flag_Non_Static_Expr
27885 ("static integer expression required here", N
);
27888 end Static_Integer
;
27890 -------------------------------
27891 -- Statically_Denotes_Entity --
27892 -------------------------------
27894 function Statically_Denotes_Entity
(N
: Node_Id
) return Boolean is
27897 if not Is_Entity_Name
(N
) then
27904 Nkind
(Parent
(E
)) /= N_Object_Renaming_Declaration
27905 or else Is_Prival
(E
)
27906 or else Statically_Denotes_Entity
(Renamed_Object
(E
));
27907 end Statically_Denotes_Entity
;
27909 -------------------------------
27910 -- Statically_Denotes_Object --
27911 -------------------------------
27913 function Statically_Denotes_Object
(N
: Node_Id
) return Boolean is
27915 return Statically_Denotes_Entity
(N
)
27916 and then Is_Object_Reference
(N
);
27917 end Statically_Denotes_Object
;
27919 --------------------------
27920 -- Statically_Different --
27921 --------------------------
27923 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
27924 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
27925 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
27927 return Is_Entity_Name
(R1
)
27928 and then Is_Entity_Name
(R2
)
27929 and then Entity
(R1
) /= Entity
(R2
)
27930 and then not Is_Formal
(Entity
(R1
))
27931 and then not Is_Formal
(Entity
(R2
));
27932 end Statically_Different
;
27934 -----------------------------
27935 -- Statically_Names_Object --
27936 -----------------------------
27938 function Statically_Names_Object
(N
: Node_Id
) return Boolean is
27940 if Statically_Denotes_Object
(N
) then
27942 elsif Is_Entity_Name
(N
) then
27944 E
: constant Entity_Id
:= Entity
(N
);
27946 return Nkind
(Parent
(E
)) = N_Object_Renaming_Declaration
27947 and then Statically_Names_Object
(Renamed_Object
(E
));
27952 when N_Indexed_Component
=>
27953 if Is_Access_Type
(Etype
(Prefix
(N
))) then
27954 -- treat implicit dereference same as explicit
27958 if not Is_Constrained
(Etype
(Prefix
(N
))) then
27963 Indx
: Node_Id
:= First_Index
(Etype
(Prefix
(N
)));
27964 Expr
: Node_Id
:= First
(Expressions
(N
));
27965 Index_Subtype
: Node_Id
;
27968 Index_Subtype
:= Etype
(Indx
);
27970 if not Is_Static_Subtype
(Index_Subtype
) then
27973 if not Is_OK_Static_Expression
(Expr
) then
27978 Index_Value
: constant Uint
:= Expr_Value
(Expr
);
27979 Low_Value
: constant Uint
:=
27980 Expr_Value
(Type_Low_Bound
(Index_Subtype
));
27981 High_Value
: constant Uint
:=
27982 Expr_Value
(Type_High_Bound
(Index_Subtype
));
27984 if (Index_Value
< Low_Value
)
27985 or (Index_Value
> High_Value
)
27992 Expr
:= Next
(Expr
);
27993 pragma Assert
((Present
(Indx
) = Present
(Expr
))
27994 or else (Serious_Errors_Detected
> 0));
27995 exit when not (Present
(Indx
) and Present
(Expr
));
27999 when N_Selected_Component
=>
28000 if Is_Access_Type
(Etype
(Prefix
(N
))) then
28001 -- treat implicit dereference same as explicit
28005 if Ekind
(Entity
(Selector_Name
(N
))) not in
28006 E_Component | E_Discriminant
28012 Comp
: constant Entity_Id
:=
28013 Original_Record_Component
(Entity
(Selector_Name
(N
)));
28015 -- AI12-0373 confirms that we should not call
28016 -- Has_Discriminant_Dependent_Constraint here which would be
28019 if Is_Declared_Within_Variant
(Comp
) then
28024 when others => -- includes N_Slice, N_Explicit_Dereference
28028 pragma Assert
(Present
(Prefix
(N
)));
28030 return Statically_Names_Object
(Prefix
(N
));
28031 end Statically_Names_Object
;
28033 ---------------------------------
28034 -- String_From_Numeric_Literal --
28035 ---------------------------------
28037 function String_From_Numeric_Literal
(N
: Node_Id
) return String_Id
is
28038 Loc
: constant Source_Ptr
:= Sloc
(N
);
28039 Sbuffer
: constant Source_Buffer_Ptr
:=
28040 Source_Text
(Get_Source_File_Index
(Loc
));
28041 Src_Ptr
: Source_Ptr
:= Loc
;
28043 C
: Character := Sbuffer
(Src_Ptr
);
28044 -- Current source program character
28046 function Belongs_To_Numeric_Literal
(C
: Character) return Boolean;
28047 -- Return True if C belongs to the numeric literal
28049 --------------------------------
28050 -- Belongs_To_Numeric_Literal --
28051 --------------------------------
28053 function Belongs_To_Numeric_Literal
(C
: Character) return Boolean is
28056 when '0' .. '9' |
'_' |
'.' |
'e' |
'#' |
'A' .. 'F' =>
28059 -- Make sure '+' or '-' is part of an exponent
28063 Prev_C
: constant Character := Sbuffer
(Src_Ptr
- 1);
28065 return Prev_C
in 'e' |
'E';
28068 -- Other characters cannot belong to a numeric literal
28073 end Belongs_To_Numeric_Literal
;
28075 -- Start of processing for String_From_Numeric_Literal
28079 while Belongs_To_Numeric_Literal
(C
) loop
28080 Store_String_Char
(C
);
28081 Src_Ptr
:= Src_Ptr
+ 1;
28082 C
:= Sbuffer
(Src_Ptr
);
28086 end String_From_Numeric_Literal
;
28088 --------------------------------------
28089 -- Subject_To_Loop_Entry_Attributes --
28090 --------------------------------------
28092 function Subject_To_Loop_Entry_Attributes
(N
: Node_Id
) return Boolean is
28098 -- The expansion mechanism transform a loop subject to at least one
28099 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
28100 -- the conditional part.
28102 if Nkind
(Stmt
) in N_Block_Statement | N_If_Statement
28103 and then Nkind
(Original_Node
(N
)) = N_Loop_Statement
28105 Stmt
:= Original_Node
(N
);
28109 Nkind
(Stmt
) = N_Loop_Statement
28110 and then Present
(Identifier
(Stmt
))
28111 and then Present
(Entity
(Identifier
(Stmt
)))
28112 and then Has_Loop_Entry_Attributes
(Entity
(Identifier
(Stmt
)));
28113 end Subject_To_Loop_Entry_Attributes
;
28115 ---------------------
28116 -- Subprogram_Name --
28117 ---------------------
28119 function Subprogram_Name
(N
: Node_Id
) return String is
28120 Buf
: Bounded_String
;
28121 Ent
: Node_Id
:= N
;
28125 while Present
(Ent
) loop
28126 case Nkind
(Ent
) is
28127 when N_Subprogram_Body
=>
28128 Ent
:= Defining_Unit_Name
(Specification
(Ent
));
28131 when N_Subprogram_Declaration
=>
28132 Nod
:= Corresponding_Body
(Ent
);
28134 if Present
(Nod
) then
28137 Ent
:= Defining_Unit_Name
(Specification
(Ent
));
28142 when N_Subprogram_Instantiation
28144 | N_Package_Specification
28146 Ent
:= Defining_Unit_Name
(Ent
);
28149 when N_Protected_Type_Declaration
=>
28150 Ent
:= Corresponding_Body
(Ent
);
28153 when N_Protected_Body
28156 Ent
:= Defining_Identifier
(Ent
);
28163 Ent
:= Parent
(Ent
);
28167 return "unknown subprogram:unknown file:0:0";
28170 -- If the subprogram is a child unit, use its simple name to start the
28171 -- construction of the fully qualified name.
28173 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
28174 Ent
:= Defining_Identifier
(Ent
);
28177 Append_Entity_Name
(Buf
, Ent
);
28179 -- Append homonym number if needed
28181 if Nkind
(N
) in N_Entity
and then Has_Homonym
(N
) then
28183 H
: Entity_Id
:= Homonym
(N
);
28187 while Present
(H
) loop
28188 if Scope
(H
) = Scope
(N
) then
28202 -- Append source location of Ent to Buf so that the string will
28203 -- look like "subp:file:line:col".
28206 Loc
: constant Source_Ptr
:= Sloc
(Ent
);
28209 Append
(Buf
, Reference_Name
(Get_Source_File_Index
(Loc
)));
28211 Append
(Buf
, Nat
(Get_Logical_Line_Number
(Loc
)));
28213 Append
(Buf
, Nat
(Get_Column_Number
(Loc
)));
28217 end Subprogram_Name
;
28219 -------------------------------
28220 -- Support_Atomic_Primitives --
28221 -------------------------------
28223 function Support_Atomic_Primitives
(Typ
: Entity_Id
) return Boolean is
28227 -- Verify the alignment of Typ is known
28229 if not Known_Alignment
(Typ
) then
28233 if Known_Static_Esize
(Typ
) then
28234 Size
:= UI_To_Int
(Esize
(Typ
));
28236 -- If the Esize (Object_Size) is unknown at compile time, look at the
28237 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
28239 elsif Known_Static_RM_Size
(Typ
) then
28240 Size
:= UI_To_Int
(RM_Size
(Typ
));
28242 -- Otherwise, the size is considered to be unknown.
28248 -- Check that the size of the component is 8, 16, 32, or 64 bits and
28249 -- that Typ is properly aligned.
28252 when 8 |
16 |
32 |
64 =>
28253 return Size
= UI_To_Int
(Alignment
(Typ
)) * 8;
28258 end Support_Atomic_Primitives
;
28264 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
28266 if Debug_Flag_W
then
28267 for J
in 0 .. Scope_Stack
.Last
loop
28272 Write_Name
(Chars
(E
));
28273 Write_Str
(" from ");
28274 Write_Location
(Sloc
(N
));
28279 -----------------------
28280 -- Transfer_Entities --
28281 -----------------------
28283 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
28284 procedure Set_Public_Status_Of
(Id
: Entity_Id
);
28285 -- Set the Is_Public attribute of arbitrary entity Id by calling routine
28286 -- Set_Public_Status. If successful and Id denotes a record type, set
28287 -- the Is_Public attribute of its fields.
28289 --------------------------
28290 -- Set_Public_Status_Of --
28291 --------------------------
28293 procedure Set_Public_Status_Of
(Id
: Entity_Id
) is
28297 if not Is_Public
(Id
) then
28298 Set_Public_Status
(Id
);
28300 -- When the input entity is a public record type, ensure that all
28301 -- its internal fields are also exposed to the linker. The fields
28302 -- of a class-wide type are never made public.
28305 and then Is_Record_Type
(Id
)
28306 and then not Is_Class_Wide_Type
(Id
)
28308 Field
:= First_Entity
(Id
);
28309 while Present
(Field
) loop
28310 Set_Is_Public
(Field
);
28311 Next_Entity
(Field
);
28315 end Set_Public_Status_Of
;
28319 Full_Id
: Entity_Id
;
28322 -- Start of processing for Transfer_Entities
28325 Id
:= First_Entity
(From
);
28327 if Present
(Id
) then
28329 -- Merge the entity chain of the source scope with that of the
28330 -- destination scope.
28332 if Present
(Last_Entity
(To
)) then
28333 Link_Entities
(Last_Entity
(To
), Id
);
28335 Set_First_Entity
(To
, Id
);
28338 Set_Last_Entity
(To
, Last_Entity
(From
));
28340 -- Inspect the entities of the source scope and update their Scope
28343 while Present
(Id
) loop
28344 Set_Scope
(Id
, To
);
28345 Set_Public_Status_Of
(Id
);
28347 -- Handle an internally generated full view for a private type
28349 if Is_Private_Type
(Id
)
28350 and then Present
(Full_View
(Id
))
28351 and then Is_Itype
(Full_View
(Id
))
28353 Full_Id
:= Full_View
(Id
);
28355 Set_Scope
(Full_Id
, To
);
28356 Set_Public_Status_Of
(Full_Id
);
28362 Set_First_Entity
(From
, Empty
);
28363 Set_Last_Entity
(From
, Empty
);
28365 end Transfer_Entities
;
28367 ------------------------
28368 -- Traverse_More_Func --
28369 ------------------------
28371 function Traverse_More_Func
(Node
: Node_Id
) return Traverse_Final_Result
is
28373 Processing_Itype
: Boolean := False;
28374 -- Set to True while traversing the nodes under an Itype, to prevent
28375 -- looping on Itype handling during that traversal.
28377 function Process_More
(N
: Node_Id
) return Traverse_Result
;
28378 -- Wrapper over the Process callback to handle parts of the AST that
28379 -- are not normally traversed as syntactic children.
28381 function Traverse_Rec
(N
: Node_Id
) return Traverse_Final_Result
;
28382 -- Main recursive traversal implemented as an instantiation of
28383 -- Traverse_Func over a modified Process callback.
28389 function Process_More
(N
: Node_Id
) return Traverse_Result
is
28391 procedure Traverse_More
(N
: Node_Id
;
28392 Res
: in out Traverse_Result
);
28393 procedure Traverse_More
(L
: List_Id
;
28394 Res
: in out Traverse_Result
);
28395 -- Traverse a node or list and update the traversal result to value
28396 -- Abandon when needed.
28398 -------------------
28399 -- Traverse_More --
28400 -------------------
28402 procedure Traverse_More
(N
: Node_Id
;
28403 Res
: in out Traverse_Result
)
28406 -- Do not process any more nodes if Abandon was reached
28408 if Res
= Abandon
then
28412 if Traverse_Rec
(N
) = Abandon
then
28417 procedure Traverse_More
(L
: List_Id
;
28418 Res
: in out Traverse_Result
)
28420 N
: Node_Id
:= First
(L
);
28423 -- Do not process any more nodes if Abandon was reached
28425 if Res
= Abandon
then
28429 while Present
(N
) loop
28430 Traverse_More
(N
, Res
);
28438 Result
: Traverse_Result
;
28440 -- Start of processing for Process_More
28443 -- Initial callback to Process. Return immediately on Skip/Abandon.
28444 -- Otherwise update the value of Node for further processing of
28445 -- non-syntactic children.
28447 Result
:= Process
(N
);
28450 when OK
=> Node
:= N
;
28451 when OK_Orig
=> Node
:= Original_Node
(N
);
28452 when Skip
=> return Skip
;
28453 when Abandon
=> return Abandon
;
28456 -- Process the relevant semantic children which are a logical part of
28457 -- the AST under this node before returning for the processing of
28458 -- syntactic children.
28460 -- Start with all non-syntactic lists of action nodes
28462 case Nkind
(Node
) is
28463 when N_Component_Association
=>
28464 Traverse_More
(Loop_Actions
(Node
), Result
);
28466 when N_Elsif_Part
=>
28467 Traverse_More
(Condition_Actions
(Node
), Result
);
28469 when N_Short_Circuit
=>
28470 Traverse_More
(Actions
(Node
), Result
);
28472 when N_Case_Expression_Alternative
=>
28473 Traverse_More
(Actions
(Node
), Result
);
28475 when N_Iterated_Component_Association
=>
28476 Traverse_More
(Loop_Actions
(Node
), Result
);
28478 when N_Iterated_Element_Association
=>
28479 Traverse_More
(Loop_Actions
(Node
), Result
);
28481 when N_Iteration_Scheme
=>
28482 Traverse_More
(Condition_Actions
(Node
), Result
);
28484 when N_If_Expression
=>
28485 Traverse_More
(Then_Actions
(Node
), Result
);
28486 Traverse_More
(Else_Actions
(Node
), Result
);
28488 -- Various nodes have a field Actions as a syntactic node,
28489 -- so it will be traversed in the regular syntactic traversal.
28491 when N_Compilation_Unit_Aux
28492 | N_Compound_Statement
28493 | N_Expression_With_Actions
28502 -- If Process_Itypes is True, process unattached nodes which come
28503 -- from Itypes. This only concerns currently ranges of scalar
28504 -- (possibly as index) types. This traversal is protected against
28505 -- looping with Processing_Itype.
28508 and then not Processing_Itype
28509 and then Nkind
(Node
) in N_Has_Etype
28510 and then Present
(Etype
(Node
))
28511 and then Is_Itype
(Etype
(Node
))
28514 Typ
: constant Entity_Id
:= Etype
(Node
);
28516 Processing_Itype
:= True;
28518 case Ekind
(Typ
) is
28519 when Scalar_Kind
=>
28520 Traverse_More
(Scalar_Range
(Typ
), Result
);
28524 Index
: Node_Id
:= First_Index
(Typ
);
28527 while Present
(Index
) loop
28528 if Nkind
(Index
) in N_Has_Entity
then
28529 Rng
:= Scalar_Range
(Entity
(Index
));
28534 Traverse_More
(Rng
, Result
);
28535 Next_Index
(Index
);
28542 Processing_Itype
:= False;
28549 -- Define Traverse_Rec as a renaming of the instantiation, as an
28550 -- instantiation cannot complete a previous spec.
28552 function Traverse_Recursive
is new Traverse_Func
(Process_More
);
28553 function Traverse_Rec
(N
: Node_Id
) return Traverse_Final_Result
28554 renames Traverse_Recursive
;
28556 -- Start of processing for Traverse_More_Func
28559 return Traverse_Rec
(Node
);
28560 end Traverse_More_Func
;
28562 ------------------------
28563 -- Traverse_More_Proc --
28564 ------------------------
28566 procedure Traverse_More_Proc
(Node
: Node_Id
) is
28567 function Traverse
is new Traverse_More_Func
(Process
, Process_Itypes
);
28568 Discard
: Traverse_Final_Result
;
28569 pragma Warnings
(Off
, Discard
);
28571 Discard
:= Traverse
(Node
);
28572 end Traverse_More_Proc
;
28574 ------------------------------------
28575 -- Type_Without_Stream_Operation --
28576 ------------------------------------
28578 function Type_Without_Stream_Operation
28580 Op
: TSS_Name_Type
:= TSS_Null
) return Entity_Id
28582 BT
: constant Entity_Id
:= Base_Type
(T
);
28583 Op_Missing
: Boolean;
28586 if not Restriction_Active
(No_Default_Stream_Attributes
) then
28590 if Is_Elementary_Type
(T
) then
28591 if Op
= TSS_Null
then
28593 No
(TSS
(BT
, TSS_Stream_Read
))
28594 or else No
(TSS
(BT
, TSS_Stream_Write
));
28597 Op_Missing
:= No
(TSS
(BT
, Op
));
28606 elsif Is_Array_Type
(T
) then
28607 return Type_Without_Stream_Operation
(Component_Type
(T
), Op
);
28609 elsif Is_Record_Type
(T
) then
28615 Comp
:= First_Component
(T
);
28616 while Present
(Comp
) loop
28617 C_Typ
:= Type_Without_Stream_Operation
(Etype
(Comp
), Op
);
28619 if Present
(C_Typ
) then
28623 Next_Component
(Comp
);
28629 elsif Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
28630 return Type_Without_Stream_Operation
(Full_View
(T
), Op
);
28634 end Type_Without_Stream_Operation
;
28636 ------------------------------
28637 -- Ultimate_Overlaid_Entity --
28638 ------------------------------
28640 function Ultimate_Overlaid_Entity
(E
: Entity_Id
) return Entity_Id
is
28642 Alias
: Entity_Id
:= E
;
28646 -- Currently this routine is only called for stand-alone objects that
28647 -- have been analysed, since the analysis of the Address aspect is often
28650 pragma Assert
(Ekind
(E
) in E_Constant | E_Variable
);
28653 Address
:= Address_Clause
(Alias
);
28654 if Present
(Address
) then
28655 Find_Overlaid_Entity
(Address
, Alias
, Offset
);
28656 if Present
(Alias
) then
28661 elsif Alias
= E
then
28667 end Ultimate_Overlaid_Entity
;
28669 ---------------------
28670 -- Ultimate_Prefix --
28671 ---------------------
28673 function Ultimate_Prefix
(N
: Node_Id
) return Node_Id
is
28678 while Nkind
(Pref
) in N_Explicit_Dereference
28679 | N_Indexed_Component
28680 | N_Selected_Component
28683 Pref
:= Prefix
(Pref
);
28687 end Ultimate_Prefix
;
28689 ----------------------------
28690 -- Unique_Defining_Entity --
28691 ----------------------------
28693 function Unique_Defining_Entity
(N
: Node_Id
) return Entity_Id
is
28695 return Unique_Entity
(Defining_Entity
(N
));
28696 end Unique_Defining_Entity
;
28698 -------------------
28699 -- Unique_Entity --
28700 -------------------
28702 function Unique_Entity
(E
: Entity_Id
) return Entity_Id
is
28703 U
: Entity_Id
:= E
;
28709 if Present
(Full_View
(E
)) then
28710 U
:= Full_View
(E
);
28714 if Nkind
(Parent
(E
)) = N_Entry_Body
then
28716 Prot_Item
: Entity_Id
;
28717 Prot_Type
: Entity_Id
;
28720 if Ekind
(E
) = E_Entry
then
28721 Prot_Type
:= Scope
(E
);
28723 -- Bodies of entry families are nested within an extra scope
28724 -- that contains an entry index declaration.
28727 Prot_Type
:= Scope
(Scope
(E
));
28730 -- A protected type may be declared as a private type, in
28731 -- which case we need to get its full view.
28733 if Is_Private_Type
(Prot_Type
) then
28734 Prot_Type
:= Full_View
(Prot_Type
);
28737 -- Full view may not be present on error, in which case
28738 -- return E by default.
28740 if Present
(Prot_Type
) then
28741 pragma Assert
(Ekind
(Prot_Type
) = E_Protected_Type
);
28743 -- Traverse the entity list of the protected type and
28744 -- locate an entry declaration which matches the entry
28747 Prot_Item
:= First_Entity
(Prot_Type
);
28748 while Present
(Prot_Item
) loop
28749 if Ekind
(Prot_Item
) in Entry_Kind
28750 and then Corresponding_Body
(Parent
(Prot_Item
)) = E
28756 Next_Entity
(Prot_Item
);
28762 when Formal_Kind
=>
28763 if Present
(Spec_Entity
(E
)) then
28764 U
:= Spec_Entity
(E
);
28767 when E_Package_Body
=>
28770 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
28774 if Nkind
(P
) = N_Package_Body
28775 and then Present
(Corresponding_Spec
(P
))
28777 U
:= Corresponding_Spec
(P
);
28779 elsif Nkind
(P
) = N_Package_Body_Stub
28780 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28782 U
:= Corresponding_Spec_Of_Stub
(P
);
28785 when E_Protected_Body
=>
28788 if Nkind
(P
) = N_Protected_Body
28789 and then Present
(Corresponding_Spec
(P
))
28791 U
:= Corresponding_Spec
(P
);
28793 elsif Nkind
(P
) = N_Protected_Body_Stub
28794 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28796 U
:= Corresponding_Spec_Of_Stub
(P
);
28798 if Is_Single_Protected_Object
(U
) then
28803 if Is_Private_Type
(U
) then
28804 U
:= Full_View
(U
);
28807 when E_Subprogram_Body
=>
28810 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
28816 if Nkind
(P
) = N_Subprogram_Body
28817 and then Present
(Corresponding_Spec
(P
))
28819 U
:= Corresponding_Spec
(P
);
28821 elsif Nkind
(P
) = N_Subprogram_Body_Stub
28822 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28824 U
:= Corresponding_Spec_Of_Stub
(P
);
28826 elsif Nkind
(P
) = N_Subprogram_Renaming_Declaration
then
28827 U
:= Corresponding_Spec
(P
);
28830 when E_Task_Body
=>
28833 if Nkind
(P
) = N_Task_Body
28834 and then Present
(Corresponding_Spec
(P
))
28836 U
:= Corresponding_Spec
(P
);
28838 elsif Nkind
(P
) = N_Task_Body_Stub
28839 and then Present
(Corresponding_Spec_Of_Stub
(P
))
28841 U
:= Corresponding_Spec_Of_Stub
(P
);
28843 if Is_Single_Task_Object
(U
) then
28848 if Is_Private_Type
(U
) then
28849 U
:= Full_View
(U
);
28853 if Present
(Full_View
(E
)) then
28854 U
:= Full_View
(E
);
28868 function Unique_Name
(E
: Entity_Id
) return String is
28870 -- Local subprograms
28872 function Add_Homonym_Suffix
(E
: Entity_Id
) return String;
28874 function This_Name
return String;
28876 ------------------------
28877 -- Add_Homonym_Suffix --
28878 ------------------------
28880 function Add_Homonym_Suffix
(E
: Entity_Id
) return String is
28882 -- Names in E_Subprogram_Body or E_Package_Body entities are not
28883 -- reliable, as they may not include the overloading suffix.
28884 -- Instead, when looking for the name of E or one of its enclosing
28885 -- scope, we get the name of the corresponding Unique_Entity.
28887 U
: constant Entity_Id
:= Unique_Entity
(E
);
28888 Nam
: constant String := Get_Name_String
(Chars
(U
));
28891 -- If E has homonyms but is not fully qualified, as done in
28892 -- GNATprove mode, append the homonym number on the fly. Strip the
28893 -- leading space character in the image of natural numbers. Also do
28894 -- not print the homonym value of 1.
28896 if Has_Homonym
(U
) then
28898 N
: constant Pos
:= Homonym_Number
(U
);
28899 S
: constant String := N
'Img;
28902 return Nam
& "__" & S
(2 .. S
'Last);
28908 end Add_Homonym_Suffix
;
28914 function This_Name
return String is
28916 return Add_Homonym_Suffix
(E
);
28921 U
: constant Entity_Id
:= Unique_Entity
(E
);
28923 -- Start of processing for Unique_Name
28926 if E
= Standard_Standard
28927 or else Has_Fully_Qualified_Name
(E
)
28931 elsif Ekind
(E
) = E_Enumeration_Literal
then
28932 return Unique_Name
(Etype
(E
)) & "__" & This_Name
;
28936 S
: constant Entity_Id
:= Scope
(U
);
28937 pragma Assert
(Present
(S
));
28940 -- Prefix names of predefined types with standard__, but leave
28941 -- names of user-defined packages and subprograms without prefix
28942 -- (even if technically they are nested in the Standard package).
28944 if S
= Standard_Standard
then
28945 if Ekind
(U
) = E_Package
or else Is_Subprogram
(U
) then
28948 return Unique_Name
(S
) & "__" & This_Name
;
28951 -- For intances of generic subprograms use the name of the related
28952 -- instance and skip the scope of its wrapper package.
28954 elsif Is_Wrapper_Package
(S
) then
28955 pragma Assert
(Scope
(S
) = Scope
(Related_Instance
(S
)));
28956 -- Wrapper package and the instantiation are in the same scope
28959 Related_Name
: constant String :=
28960 Add_Homonym_Suffix
(Related_Instance
(S
));
28961 Enclosing_Name
: constant String :=
28962 Unique_Name
(Scope
(S
)) & "__" & Related_Name
;
28965 if Is_Subprogram
(U
)
28966 and then not Is_Generic_Actual_Subprogram
(U
)
28968 return Enclosing_Name
;
28970 return Enclosing_Name
& "__" & This_Name
;
28974 elsif Is_Child_Unit
(U
) then
28975 return Child_Prefix
& Unique_Name
(S
) & "__" & This_Name
;
28977 return Unique_Name
(S
) & "__" & This_Name
;
28983 ---------------------
28984 -- Unit_Is_Visible --
28985 ---------------------
28987 function Unit_Is_Visible
(U
: Entity_Id
) return Boolean is
28988 Curr
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
28989 Curr_Entity
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
28991 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean;
28992 -- For a child unit, check whether unit appears in a with_clause
28995 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean;
28996 -- Scan the context clause of one compilation unit looking for a
28997 -- with_clause for the unit in question.
28999 ----------------------------
29000 -- Unit_In_Parent_Context --
29001 ----------------------------
29003 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean is
29005 if Unit_In_Context
(Par_Unit
) then
29008 elsif Is_Child_Unit
(Defining_Entity
(Unit
(Par_Unit
))) then
29009 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Par_Unit
)));
29014 end Unit_In_Parent_Context
;
29016 ---------------------
29017 -- Unit_In_Context --
29018 ---------------------
29020 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean is
29024 Clause
:= First
(Context_Items
(Comp_Unit
));
29025 while Present
(Clause
) loop
29026 if Nkind
(Clause
) = N_With_Clause
then
29027 if Library_Unit
(Clause
) = U
then
29030 -- The with_clause may denote a renaming of the unit we are
29031 -- looking for, eg. Text_IO which renames Ada.Text_IO.
29034 Renamed_Entity
(Entity
(Name
(Clause
))) =
29035 Defining_Entity
(Unit
(U
))
29045 end Unit_In_Context
;
29047 -- Start of processing for Unit_Is_Visible
29050 -- The currrent unit is directly visible
29055 elsif Unit_In_Context
(Curr
) then
29058 -- If the current unit is a body, check the context of the spec
29060 elsif Nkind
(Unit
(Curr
)) = N_Package_Body
29062 (Nkind
(Unit
(Curr
)) = N_Subprogram_Body
29063 and then not Acts_As_Spec
(Unit
(Curr
)))
29065 if Unit_In_Context
(Library_Unit
(Curr
)) then
29070 -- If the spec is a child unit, examine the parents
29072 if Is_Child_Unit
(Curr_Entity
) then
29073 if Nkind
(Unit
(Curr
)) in N_Unit_Body
then
29075 Unit_In_Parent_Context
29076 (Parent_Spec
(Unit
(Library_Unit
(Curr
))));
29078 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Curr
)));
29084 end Unit_Is_Visible
;
29086 ------------------------------
29087 -- Universal_Interpretation --
29088 ------------------------------
29090 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
29091 Index
: Interp_Index
;
29095 -- The argument may be a formal parameter of an operator or subprogram
29096 -- with multiple interpretations, or else an expression for an actual.
29098 if Nkind
(Opnd
) = N_Defining_Identifier
29099 or else not Is_Overloaded
(Opnd
)
29101 if Is_Universal_Numeric_Type
(Etype
(Opnd
)) then
29102 return Etype
(Opnd
);
29108 Get_First_Interp
(Opnd
, Index
, It
);
29109 while Present
(It
.Typ
) loop
29110 if Is_Universal_Numeric_Type
(It
.Typ
) then
29114 Get_Next_Interp
(Index
, It
);
29119 end Universal_Interpretation
;
29125 function Unqualify
(Expr
: Node_Id
) return Node_Id
is
29127 -- Recurse to handle unlikely case of multiple levels of qualification
29129 if Nkind
(Expr
) = N_Qualified_Expression
then
29130 return Unqualify
(Expression
(Expr
));
29132 -- Normal case, not a qualified expression
29143 function Unqual_Conv
(Expr
: Node_Id
) return Node_Id
is
29145 -- Recurse to handle unlikely case of multiple levels of qualification
29146 -- and/or conversion.
29148 if Nkind
(Expr
) in N_Qualified_Expression
29149 | N_Type_Conversion
29150 | N_Unchecked_Type_Conversion
29152 return Unqual_Conv
(Expression
(Expr
));
29154 -- Normal case, not a qualified expression
29161 --------------------
29162 -- Validated_View --
29163 --------------------
29165 function Validated_View
(Typ
: Entity_Id
) return Entity_Id
is
29167 -- Scalar types can be always validated. In fast, switiching to the base
29168 -- type would drop the range constraints and force validation to use a
29169 -- larger type than necessary.
29171 if Is_Scalar_Type
(Typ
) then
29174 -- Array types can be validated even when they are derived, because
29175 -- validation only requires their bounds and component types to be
29176 -- accessible. In fact, switching to the parent type would pollute
29177 -- expansion of attribute Valid_Scalars with unnecessary conversion
29178 -- that might not be eliminated by the frontend.
29180 elsif Is_Array_Type
(Typ
) then
29183 -- For other types, in particular for record subtypes, we switch to the
29186 elsif not Is_Base_Type
(Typ
) then
29187 return Validated_View
(Base_Type
(Typ
));
29189 -- Obtain the full view of the input type by stripping away concurrency,
29190 -- derivations, and privacy.
29192 elsif Is_Concurrent_Type
(Typ
) then
29193 if Present
(Corresponding_Record_Type
(Typ
)) then
29194 return Corresponding_Record_Type
(Typ
);
29199 elsif Is_Derived_Type
(Typ
) then
29200 return Validated_View
(Etype
(Typ
));
29202 elsif Is_Private_Type
(Typ
) then
29203 if Present
(Underlying_Full_View
(Typ
)) then
29204 return Validated_View
(Underlying_Full_View
(Typ
));
29206 elsif Present
(Full_View
(Typ
)) then
29207 return Validated_View
(Full_View
(Typ
));
29215 end Validated_View
;
29217 -----------------------
29218 -- Visible_Ancestors --
29219 -----------------------
29221 function Visible_Ancestors
(Typ
: Entity_Id
) return Elist_Id
is
29227 pragma Assert
(Is_Record_Type
(Typ
) and then Is_Tagged_Type
(Typ
));
29229 -- Collect all the parents and progenitors of Typ. If the full-view of
29230 -- private parents and progenitors is available then it is used to
29231 -- generate the list of visible ancestors; otherwise their partial
29232 -- view is added to the resulting list.
29237 Use_Full_View
=> True);
29241 Ifaces_List
=> List_2
,
29242 Exclude_Parents
=> True,
29243 Use_Full_View
=> True);
29245 -- Join the two lists. Avoid duplications because an interface may
29246 -- simultaneously be parent and progenitor of a type.
29248 Elmt
:= First_Elmt
(List_2
);
29249 while Present
(Elmt
) loop
29250 Append_Unique_Elmt
(Node
(Elmt
), List_1
);
29255 end Visible_Ancestors
;
29257 ---------------------------
29258 -- Warn_On_Hiding_Entity --
29259 ---------------------------
29261 procedure Warn_On_Hiding_Entity
29263 Hidden
, Visible
: Entity_Id
;
29264 On_Use_Clause
: Boolean)
29267 -- Don't warn for record components since they always have a well
29268 -- defined scope which does not confuse other uses. Note that in
29269 -- some cases, Ekind has not been set yet.
29271 if Ekind
(Hidden
) /= E_Component
29272 and then Ekind
(Hidden
) /= E_Discriminant
29273 and then Nkind
(Parent
(Hidden
)) /= N_Component_Declaration
29274 and then Ekind
(Visible
) /= E_Component
29275 and then Ekind
(Visible
) /= E_Discriminant
29276 and then Nkind
(Parent
(Visible
)) /= N_Component_Declaration
29278 -- Don't warn for one character variables. It is too common to use
29279 -- such variables as locals and will just cause too many false hits.
29281 and then Length_Of_Name
(Chars
(Hidden
)) /= 1
29283 -- Don't warn for non-source entities
29285 and then Comes_From_Source
(Hidden
)
29286 and then Comes_From_Source
(Visible
)
29288 -- Don't warn within a generic instantiation
29290 and then not In_Instance
29292 -- Don't warn unless entity in question is in extended main source
29294 and then In_Extended_Main_Source_Unit
(Visible
)
29296 -- Finally, in the case of a declaration, the hidden entity must
29297 -- be either immediately visible or use visible (i.e. from a used
29298 -- package). In the case of a use clause, the visible entity must
29299 -- be immediately visible.
29302 (if On_Use_Clause
then
29303 Is_Immediately_Visible
(Visible
)
29305 (Is_Immediately_Visible
(Hidden
)
29307 Is_Potentially_Use_Visible
(Hidden
)))
29309 if On_Use_Clause
then
29310 Error_Msg_Sloc
:= Sloc
(Visible
);
29311 Error_Msg_NE
("visible declaration of&# hides homonym "
29312 & "from use clause?h?", N
, Hidden
);
29314 Error_Msg_Sloc
:= Sloc
(Hidden
);
29315 Error_Msg_NE
("declaration hides &#?h?", N
, Visible
);
29318 end Warn_On_Hiding_Entity
;
29320 ----------------------
29321 -- Within_Init_Proc --
29322 ----------------------
29324 function Within_Init_Proc
return Boolean is
29328 S
:= Current_Scope
;
29329 while not Is_Overloadable
(S
) loop
29330 if S
= Standard_Standard
then
29337 return Is_Init_Proc
(S
);
29338 end Within_Init_Proc
;
29340 ---------------------------
29341 -- Within_Protected_Type --
29342 ---------------------------
29344 function Within_Protected_Type
(E
: Entity_Id
) return Boolean is
29345 Scop
: Entity_Id
:= Scope
(E
);
29348 while Present
(Scop
) loop
29349 if Ekind
(Scop
) = E_Protected_Type
then
29353 Scop
:= Scope
(Scop
);
29357 end Within_Protected_Type
;
29363 function Within_Scope
(E
: Entity_Id
; S
: Entity_Id
) return Boolean is
29365 return Scope_Within_Or_Same
(Scope
(E
), S
);
29372 procedure Wrong_Type
(Expr
: Node_Id
; Expected_Type
: Entity_Id
) is
29373 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
29374 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
29376 Err_Msg_Exp_Typ
: Entity_Id
:= Expected_Type
;
29377 -- Type entity used when printing errors concerning the expected type
29379 Matching_Field
: Entity_Id
;
29380 -- Entity to give a more precise suggestion on how to write a one-
29381 -- element positional aggregate.
29383 function Has_One_Matching_Field
return Boolean;
29384 -- Determines if Expec_Type is a record type with a single component or
29385 -- discriminant whose type matches the found type or is one dimensional
29386 -- array whose component type matches the found type. In the case of
29387 -- one discriminant, we ignore the variant parts. That's not accurate,
29388 -- but good enough for the warning.
29390 ----------------------------
29391 -- Has_One_Matching_Field --
29392 ----------------------------
29394 function Has_One_Matching_Field
return Boolean is
29398 Matching_Field
:= Empty
;
29400 if Is_Array_Type
(Expec_Type
)
29401 and then Number_Dimensions
(Expec_Type
) = 1
29402 and then Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
29404 -- Use type name if available. This excludes multidimensional
29405 -- arrays and anonymous arrays.
29407 if Comes_From_Source
(Expec_Type
) then
29408 Matching_Field
:= Expec_Type
;
29410 -- For an assignment, use name of target
29412 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
29413 and then Is_Entity_Name
(Name
(Parent
(Expr
)))
29415 Matching_Field
:= Entity
(Name
(Parent
(Expr
)));
29420 elsif not Is_Record_Type
(Expec_Type
) then
29424 E
:= First_Entity
(Expec_Type
);
29429 elsif Ekind
(E
) not in E_Discriminant | E_Component
29430 or else Chars
(E
) in Name_uTag | Name_uParent
29439 if not Covers
(Etype
(E
), Found_Type
) then
29442 elsif Present
(Next_Entity
(E
))
29443 and then (Ekind
(E
) = E_Component
29444 or else Ekind
(Next_Entity
(E
)) = E_Discriminant
)
29449 Matching_Field
:= E
;
29453 end Has_One_Matching_Field
;
29455 -- Start of processing for Wrong_Type
29458 -- Don't output message if either type is Any_Type, or if a message
29459 -- has already been posted for this node. We need to do the latter
29460 -- check explicitly (it is ordinarily done in Errout), because we
29461 -- are using ! to force the output of the error messages.
29463 if Expec_Type
= Any_Type
29464 or else Found_Type
= Any_Type
29465 or else Error_Posted
(Expr
)
29469 -- If one of the types is a Taft-Amendment type and the other it its
29470 -- completion, it must be an illegal use of a TAT in the spec, for
29471 -- which an error was already emitted. Avoid cascaded errors.
29473 elsif Is_Incomplete_Type
(Expec_Type
)
29474 and then Has_Completion_In_Body
(Expec_Type
)
29475 and then Full_View
(Expec_Type
) = Etype
(Expr
)
29479 elsif Is_Incomplete_Type
(Etype
(Expr
))
29480 and then Has_Completion_In_Body
(Etype
(Expr
))
29481 and then Full_View
(Etype
(Expr
)) = Expec_Type
29485 -- In an instance, there is an ongoing problem with completion of
29486 -- types derived from private types. Their structure is what Gigi
29487 -- expects, but the Etype is the parent type rather than the derived
29488 -- private type itself. Do not flag error in this case. The private
29489 -- completion is an entity without a parent, like an Itype. Similarly,
29490 -- full and partial views may be incorrect in the instance.
29491 -- There is no simple way to insure that it is consistent ???
29493 -- A similar view discrepancy can happen in an inlined body, for the
29494 -- same reason: inserted body may be outside of the original package
29495 -- and only partial views are visible at the point of insertion.
29497 -- If In_Generic_Actual (Expr) is True then we cannot assume that
29498 -- the successful semantic analysis of the generic guarantees anything
29499 -- useful about type checking of this instance, so we ignore
29500 -- In_Instance in that case. There may be cases where this is not
29501 -- right (the symptom would probably be rejecting something
29502 -- that ought to be accepted) but we don't currently have any
29503 -- concrete examples of this.
29505 elsif (In_Instance
and then not In_Generic_Actual
(Expr
))
29506 or else In_Inlined_Body
29508 if Etype
(Etype
(Expr
)) = Etype
(Expected_Type
)
29510 (Has_Private_Declaration
(Expected_Type
)
29511 or else Has_Private_Declaration
(Etype
(Expr
)))
29512 and then No
(Parent
(Expected_Type
))
29516 elsif Nkind
(Parent
(Expr
)) = N_Qualified_Expression
29517 and then Entity
(Subtype_Mark
(Parent
(Expr
))) = Expected_Type
29521 elsif Is_Private_Type
(Expected_Type
)
29522 and then Present
(Full_View
(Expected_Type
))
29523 and then Covers
(Full_View
(Expected_Type
), Etype
(Expr
))
29527 -- Conversely, type of expression may be the private one
29529 elsif Is_Private_Type
(Base_Type
(Etype
(Expr
)))
29530 and then Full_View
(Base_Type
(Etype
(Expr
))) = Expected_Type
29536 -- Avoid printing internally generated subtypes in error messages and
29537 -- instead use the corresponding first subtype in such cases.
29539 if not Comes_From_Source
(Err_Msg_Exp_Typ
)
29540 or else not Comes_From_Source
(Declaration_Node
(Err_Msg_Exp_Typ
))
29542 Err_Msg_Exp_Typ
:= First_Subtype
(Err_Msg_Exp_Typ
);
29545 -- An interesting special check. If the expression is parenthesized
29546 -- and its type corresponds to the type of the sole component of the
29547 -- expected record type, or to the component type of the expected one
29548 -- dimensional array type, then assume we have a bad aggregate attempt.
29550 if Nkind
(Expr
) in N_Subexpr
29551 and then Paren_Count
(Expr
) /= 0
29552 and then Has_One_Matching_Field
29554 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
29556 if Present
(Matching_Field
) then
29557 if Is_Array_Type
(Expec_Type
) then
29559 ("\write instead `&''First ='> ...`", Expr
, Matching_Field
);
29562 ("\write instead `& ='> ...`", Expr
, Matching_Field
);
29566 -- Another special check, if we are looking for a pool-specific access
29567 -- type and we found an E_Access_Attribute_Type, then we have the case
29568 -- of an Access attribute being used in a context which needs a pool-
29569 -- specific type, which is never allowed. The one extra check we make
29570 -- is that the expected designated type covers the Found_Type.
29572 elsif Is_Access_Type
(Expec_Type
)
29573 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
29574 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
29575 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
29577 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
29580 ("result must be general access type!", Expr
);
29581 Error_Msg_NE
-- CODEFIX
29582 ("\add ALL to }!", Expr
, Err_Msg_Exp_Typ
);
29584 -- Another special check, if the expected type is an integer type,
29585 -- but the expression is of type System.Address, and the parent is
29586 -- an addition or subtraction operation whose left operand is the
29587 -- expression in question and whose right operand is of an integral
29588 -- type, then this is an attempt at address arithmetic, so give
29589 -- appropriate message.
29591 elsif Is_Integer_Type
(Expec_Type
)
29592 and then Is_RTE
(Found_Type
, RE_Address
)
29593 and then Nkind
(Parent
(Expr
)) in N_Op_Add | N_Op_Subtract
29594 and then Expr
= Left_Opnd
(Parent
(Expr
))
29595 and then Is_Integer_Type
(Etype
(Right_Opnd
(Parent
(Expr
))))
29598 ("address arithmetic not predefined in package System",
29601 ("\possible missing with/use of System.Storage_Elements",
29605 -- If the expected type is an anonymous access type, as for access
29606 -- parameters and discriminants, the error is on the designated types.
29608 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
29609 if Comes_From_Source
(Expec_Type
) then
29610 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
29613 ("expected an access type with designated}",
29614 Expr
, Designated_Type
(Expec_Type
));
29617 if Is_Access_Type
(Found_Type
)
29618 and then not Comes_From_Source
(Found_Type
)
29621 ("\\found an access type with designated}!",
29622 Expr
, Designated_Type
(Found_Type
));
29624 if From_Limited_With
(Found_Type
) then
29625 Error_Msg_NE
("\\found incomplete}!", Expr
, Found_Type
);
29626 Error_Msg_Qual_Level
:= 99;
29627 Error_Msg_NE
-- CODEFIX
29628 ("\\missing `WITH &;", Expr
, Scope
(Found_Type
));
29629 Error_Msg_Qual_Level
:= 0;
29631 Error_Msg_NE
("found}!", Expr
, Found_Type
);
29635 -- Normal case of one type found, some other type expected
29638 -- If the names of the two types are the same, see if some number
29639 -- of levels of qualification will help. Don't try more than three
29640 -- levels, and if we get to standard, it's no use (and probably
29641 -- represents an error in the compiler) Also do not bother with
29642 -- internal scope names.
29645 Expec_Scope
: Entity_Id
;
29646 Found_Scope
: Entity_Id
;
29649 Expec_Scope
:= Expec_Type
;
29650 Found_Scope
:= Found_Type
;
29652 for Levels
in Nat
range 0 .. 3 loop
29653 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
29654 Error_Msg_Qual_Level
:= Levels
;
29658 Expec_Scope
:= Scope
(Expec_Scope
);
29659 Found_Scope
:= Scope
(Found_Scope
);
29661 exit when Expec_Scope
= Standard_Standard
29662 or else Found_Scope
= Standard_Standard
29663 or else not Comes_From_Source
(Expec_Scope
)
29664 or else not Comes_From_Source
(Found_Scope
);
29668 if Is_Record_Type
(Expec_Type
)
29669 and then Present
(Corresponding_Remote_Type
(Expec_Type
))
29671 Error_Msg_NE
("expected}!", Expr
,
29672 Corresponding_Remote_Type
(Expec_Type
));
29674 Error_Msg_NE
("expected}!", Expr
, Err_Msg_Exp_Typ
);
29677 if Is_Entity_Name
(Expr
)
29678 and then Is_Package_Or_Generic_Package
(Entity
(Expr
))
29680 Error_Msg_N
("\\found package name!", Expr
);
29682 elsif Is_Entity_Name
(Expr
)
29683 and then Ekind
(Entity
(Expr
)) in E_Procedure | E_Generic_Procedure
29685 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
29687 ("found procedure name, possibly missing Access attribute!",
29691 ("\\found procedure name instead of function!", Expr
);
29694 elsif Nkind
(Expr
) = N_Function_Call
29695 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
29696 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
29697 and then No
(Parameter_Associations
(Expr
))
29700 ("found function name, possibly missing Access attribute!",
29703 -- Catch common error: a prefix or infix operator which is not
29704 -- directly visible because the type isn't.
29706 elsif Nkind
(Expr
) in N_Op
29707 and then Is_Overloaded
(Expr
)
29708 and then not Is_Immediately_Visible
(Expec_Type
)
29709 and then not Is_Potentially_Use_Visible
(Expec_Type
)
29710 and then not In_Use
(Expec_Type
)
29711 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
29714 ("operator of the type is not directly visible!", Expr
);
29716 elsif Ekind
(Found_Type
) = E_Void
29717 and then Present
(Parent
(Found_Type
))
29718 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
29720 Error_Msg_NE
("\\found premature usage of}!", Expr
, Found_Type
);
29723 Error_Msg_NE
("\\found}!", Expr
, Found_Type
);
29726 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
29727 -- of the same modular type, and (M1 and M2) = 0 was intended.
29729 if Expec_Type
= Standard_Boolean
29730 and then Is_Modular_Integer_Type
(Found_Type
)
29731 and then Nkind
(Parent
(Expr
)) in N_Op_And | N_Op_Or | N_Op_Xor
29732 and then Nkind
(Right_Opnd
(Parent
(Expr
))) in N_Op_Compare
29735 Op
: constant Node_Id
:= Right_Opnd
(Parent
(Expr
));
29736 L
: constant Node_Id
:= Left_Opnd
(Op
);
29737 R
: constant Node_Id
:= Right_Opnd
(Op
);
29740 -- The case for the message is when the left operand of the
29741 -- comparison is the same modular type, or when it is an
29742 -- integer literal (or other universal integer expression),
29743 -- which would have been typed as the modular type if the
29744 -- parens had been there.
29746 if (Etype
(L
) = Found_Type
29748 Etype
(L
) = Universal_Integer
)
29749 and then Is_Integer_Type
(Etype
(R
))
29752 ("\\possible missing parens for modular operation", Expr
);
29757 -- Reset error message qualification indication
29759 Error_Msg_Qual_Level
:= 0;
29763 --------------------------------
29764 -- Yields_Synchronized_Object --
29765 --------------------------------
29767 function Yields_Synchronized_Object
(Typ
: Entity_Id
) return Boolean is
29768 Has_Sync_Comp
: Boolean := False;
29772 -- An array type yields a synchronized object if its component type
29773 -- yields a synchronized object.
29775 if Is_Array_Type
(Typ
) then
29776 return Yields_Synchronized_Object
(Component_Type
(Typ
));
29778 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object
29779 -- yields a synchronized object by default.
29781 elsif Is_Descendant_Of_Suspension_Object
(Typ
) then
29784 -- A protected type yields a synchronized object by default
29786 elsif Is_Protected_Type
(Typ
) then
29789 -- A record type or type extension yields a synchronized object when its
29790 -- discriminants (if any) lack default values and all components are of
29791 -- a type that yields a synchronized object.
29793 elsif Is_Record_Type
(Typ
) then
29795 -- Inspect all entities defined in the scope of the type, looking for
29796 -- components of a type that does not yield a synchronized object or
29797 -- for discriminants with default values.
29799 Id
:= First_Entity
(Typ
);
29800 while Present
(Id
) loop
29801 if Comes_From_Source
(Id
) then
29802 if Ekind
(Id
) = E_Component
then
29803 if Yields_Synchronized_Object
(Etype
(Id
)) then
29804 Has_Sync_Comp
:= True;
29806 -- The component does not yield a synchronized object
29812 elsif Ekind
(Id
) = E_Discriminant
29813 and then Present
(Expression
(Parent
(Id
)))
29822 -- Ensure that the parent type of a type extension yields a
29823 -- synchronized object.
29825 if Etype
(Typ
) /= Typ
29826 and then not Is_Private_Type
(Etype
(Typ
))
29827 and then not Yields_Synchronized_Object
(Etype
(Typ
))
29832 -- If we get here, then all discriminants lack default values and all
29833 -- components are of a type that yields a synchronized object.
29835 return Has_Sync_Comp
;
29837 -- A synchronized interface type yields a synchronized object by default
29839 elsif Is_Synchronized_Interface
(Typ
) then
29842 -- A task type yields a synchronized object by default
29844 elsif Is_Task_Type
(Typ
) then
29847 -- A private type yields a synchronized object if its underlying type
29850 elsif Is_Private_Type
(Typ
)
29851 and then Present
(Underlying_Type
(Typ
))
29853 return Yields_Synchronized_Object
(Underlying_Type
(Typ
));
29855 -- Otherwise the type does not yield a synchronized object
29860 end Yields_Synchronized_Object
;
29862 ---------------------------
29863 -- Yields_Universal_Type --
29864 ---------------------------
29866 function Yields_Universal_Type
(N
: Node_Id
) return Boolean is
29868 -- Integer and real literals are of a universal type
29870 if Nkind
(N
) in N_Integer_Literal | N_Real_Literal
then
29873 -- The values of certain attributes are of a universal type
29875 elsif Nkind
(N
) = N_Attribute_Reference
then
29877 Universal_Type_Attribute
(Get_Attribute_Id
(Attribute_Name
(N
)));
29879 -- ??? There are possibly other cases to consider
29884 end Yields_Universal_Type
;
29886 package body Interval_Lists
is
29888 procedure Check_Consistency
(Intervals
: Discrete_Interval_List
);
29889 -- Check that list is sorted, lacks null intervals, and has gaps
29890 -- between intervals.
29892 function Chosen_Interval
(Choice
: Node_Id
) return Discrete_Interval
;
29893 -- Given an element of a Discrete_Choices list, a
29894 -- Static_Discrete_Predicate list, or an Others_Discrete_Choices
29895 -- list (but not an N_Others_Choice node) return the corresponding
29896 -- interval. If an element that does not represent a single
29897 -- contiguous interval due to a static predicate (or which
29898 -- represents a single contiguous interval whose bounds depend on
29899 -- a static predicate) is encountered, then that is an error on the
29900 -- part of whoever built the list in question.
29902 function In_Interval
29903 (Value
: Uint
; Interval
: Discrete_Interval
) return Boolean;
29904 -- Does the given value lie within the given interval?
29906 procedure Normalize_Interval_List
29907 (List
: in out Discrete_Interval_List
; Last
: out Nat
);
29908 -- Perform sorting and merging as required by Check_Consistency
29910 -------------------------
29911 -- Aggregate_Intervals --
29912 -------------------------
29914 function Aggregate_Intervals
(N
: Node_Id
) return Discrete_Interval_List
29916 pragma Assert
(Nkind
(N
) = N_Aggregate
29917 and then Is_Array_Type
(Etype
(N
)));
29919 function Unmerged_Intervals_Count
return Nat
;
29920 -- Count the number of intervals given in the aggregate N; the others
29921 -- choice (if present) is not taken into account.
29923 ------------------------------
29924 -- Unmerged_Intervals_Count --
29925 ------------------------------
29927 function Unmerged_Intervals_Count
return Nat
is
29932 Comp
:= First
(Component_Associations
(N
));
29933 while Present
(Comp
) loop
29934 Choice
:= First
(Choices
(Comp
));
29936 while Present
(Choice
) loop
29937 if Nkind
(Choice
) /= N_Others_Choice
then
29938 Count
:= Count
+ 1;
29948 end Unmerged_Intervals_Count
;
29953 Max_I
: constant Nat
:= Unmerged_Intervals_Count
;
29954 Intervals
: Discrete_Interval_List
(1 .. Max_I
);
29957 -- Start of processing for Aggregate_Intervals
29960 -- No action needed if there are no intervals
29966 -- Internally store all the unsorted intervals
29968 Comp
:= First
(Component_Associations
(N
));
29969 while Present
(Comp
) loop
29971 Choice_Intervals
: constant Discrete_Interval_List
29972 := Choice_List_Intervals
(Choices
(Comp
));
29974 for J
in Choice_Intervals
'Range loop
29975 Num_I
:= Num_I
+ 1;
29976 Intervals
(Num_I
) := Choice_Intervals
(J
);
29983 -- Normalize the lists sorting and merging the intervals
29986 Aggr_Intervals
: Discrete_Interval_List
(1 .. Num_I
)
29987 := Intervals
(1 .. Num_I
);
29989 Normalize_Interval_List
(Aggr_Intervals
, Num_I
);
29990 Check_Consistency
(Aggr_Intervals
(1 .. Num_I
));
29991 return Aggr_Intervals
(1 .. Num_I
);
29993 end Aggregate_Intervals
;
29995 ------------------------
29996 -- Check_Consistency --
29997 ------------------------
29999 procedure Check_Consistency
(Intervals
: Discrete_Interval_List
) is
30001 if Serious_Errors_Detected
> 0 then
30005 -- low bound is 1 and high bound equals length
30006 pragma Assert
(Intervals
'First = 1 and Intervals
'Last >= 0);
30007 for Idx
in Intervals
'Range loop
30008 -- each interval is non-null
30009 pragma Assert
(Intervals
(Idx
).Low
<= Intervals
(Idx
).High
);
30010 if Idx
/= Intervals
'First then
30011 -- intervals are sorted with non-empty gaps between them
30013 (Intervals
(Idx
- 1).High
< (Intervals
(Idx
).Low
- 1));
30017 end Check_Consistency
;
30019 ---------------------------
30020 -- Choice_List_Intervals --
30021 ---------------------------
30023 function Choice_List_Intervals
30024 (Discrete_Choices
: List_Id
) return Discrete_Interval_List
30026 function Unmerged_Choice_Count
return Nat
;
30027 -- The number of intervals before adjacent intervals are merged
30029 ---------------------------
30030 -- Unmerged_Choice_Count --
30031 ---------------------------
30033 function Unmerged_Choice_Count
return Nat
is
30034 Choice
: Node_Id
:= First
(Discrete_Choices
);
30037 while Present
(Choice
) loop
30038 -- Non-contiguous choices involving static predicates
30039 -- have already been normalized away.
30041 if Nkind
(Choice
) = N_Others_Choice
then
30043 Count
+ List_Length
(Others_Discrete_Choices
(Choice
));
30045 Count
:= Count
+ 1; -- an ordinary expression or range
30051 end Unmerged_Choice_Count
;
30055 Choice
: Node_Id
:= First
(Discrete_Choices
);
30056 Result
: Discrete_Interval_List
(1 .. Unmerged_Choice_Count
);
30059 -- Start of processing for Choice_List_Intervals
30062 while Present
(Choice
) loop
30063 if Nkind
(Choice
) = N_Others_Choice
then
30065 Others_Choice
: Node_Id
30066 := First
(Others_Discrete_Choices
(Choice
));
30068 while Present
(Others_Choice
) loop
30069 Count
:= Count
+ 1;
30070 Result
(Count
) := Chosen_Interval
(Others_Choice
);
30071 Next
(Others_Choice
);
30075 Count
:= Count
+ 1;
30076 Result
(Count
) := Chosen_Interval
(Choice
);
30082 pragma Assert
(Count
= Result
'Last);
30083 Normalize_Interval_List
(Result
, Count
);
30084 Check_Consistency
(Result
(1 .. Count
));
30085 return Result
(1 .. Count
);
30086 end Choice_List_Intervals
;
30088 ---------------------
30089 -- Chosen_Interval --
30090 ---------------------
30092 function Chosen_Interval
(Choice
: Node_Id
) return Discrete_Interval
is
30094 case Nkind
(Choice
) is
30096 return (Low
=> Expr_Value
(Low_Bound
(Choice
)),
30097 High
=> Expr_Value
(High_Bound
(Choice
)));
30099 when N_Subtype_Indication
=>
30101 Range_Exp
: constant Node_Id
30102 := Range_Expression
(Constraint
(Choice
));
30104 return (Low
=> Expr_Value
(Low_Bound
(Range_Exp
)),
30105 High
=> Expr_Value
(High_Bound
(Range_Exp
)));
30108 when N_Others_Choice
=>
30109 raise Program_Error
;
30112 if Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
))
30115 (Low
=> Expr_Value
(Type_Low_Bound
(Entity
(Choice
))),
30116 High
=> Expr_Value
(Type_High_Bound
(Entity
(Choice
))));
30119 return (Low | High
=> Expr_Value
(Choice
));
30122 end Chosen_Interval
;
30128 function In_Interval
30129 (Value
: Uint
; Interval
: Discrete_Interval
) return Boolean is
30131 return Value
>= Interval
.Low
and then Value
<= Interval
.High
;
30139 (Subset
, Of_Set
: Discrete_Interval_List
) return Boolean
30141 -- Returns True iff for each interval of Subset we can find
30142 -- a single interval of Of_Set which contains the Subset interval.
30144 if Of_Set
'Length = 0 then
30145 return Subset
'Length = 0;
30149 Set_Index
: Pos
range Of_Set
'Range := Of_Set
'First;
30152 for Ss_Idx
in Subset
'Range loop
30153 while not In_Interval
30154 (Value
=> Subset
(Ss_Idx
).Low
,
30155 Interval
=> Of_Set
(Set_Index
))
30157 if Set_Index
= Of_Set
'Last then
30161 Set_Index
:= Set_Index
+ 1;
30165 (Value
=> Subset
(Ss_Idx
).High
,
30166 Interval
=> Of_Set
(Set_Index
))
30176 -----------------------------
30177 -- Normalize_Interval_List --
30178 -----------------------------
30180 procedure Normalize_Interval_List
30181 (List
: in out Discrete_Interval_List
; Last
: out Nat
)
30183 Temp_0
: Discrete_Interval
:= (others => Uint_0
);
30184 -- Cope with Heap_Sort_G idiosyncrasies.
30186 function Is_Null
(Idx
: Pos
) return Boolean;
30187 -- True iff List (Idx) defines a null range
30189 function Lt_Interval
(Idx1
, Idx2
: Natural) return Boolean;
30190 -- Compare two list elements
30192 procedure Merge_Intervals
(Null_Interval_Count
: out Nat
);
30193 -- Merge contiguous ranges by replacing one with merged range and
30194 -- the other with a null value. Return a count of the null intervals,
30195 -- both preexisting and those introduced by merging.
30197 procedure Move_Interval
(From
, To
: Natural);
30198 -- Copy interval from one location to another
30200 function Read_Interval
(From
: Natural) return Discrete_Interval
;
30201 -- Normal array indexing unless From = 0
30203 ----------------------
30204 -- Interval_Sorting --
30205 ----------------------
30207 package Interval_Sorting
is
30208 new Gnat
.Heap_Sort_G
(Move_Interval
, Lt_Interval
);
30214 function Is_Null
(Idx
: Pos
) return Boolean is
30216 return List
(Idx
).Low
> List
(Idx
).High
;
30223 function Lt_Interval
(Idx1
, Idx2
: Natural) return Boolean is
30224 Elem1
: constant Discrete_Interval
:= Read_Interval
(Idx1
);
30225 Elem2
: constant Discrete_Interval
:= Read_Interval
(Idx2
);
30226 Null_1
: constant Boolean := Elem1
.Low
> Elem1
.High
;
30227 Null_2
: constant Boolean := Elem2
.Low
> Elem2
.High
;
30229 if Null_1
/= Null_2
then
30230 -- So that sorting moves null intervals to high end
30233 elsif Elem1
.Low
/= Elem2
.Low
then
30234 return Elem1
.Low
< Elem2
.Low
;
30237 return Elem1
.High
< Elem2
.High
;
30241 ---------------------
30242 -- Merge_Intervals --
30243 ---------------------
30245 procedure Merge_Intervals
(Null_Interval_Count
: out Nat
) is
30246 Not_Null
: Pos
range List
'Range;
30247 -- Index of the most recently examined non-null interval
30249 Null_Interval
: constant Discrete_Interval
30250 := (Low
=> Uint_1
, High
=> Uint_0
); -- any null range ok here
30252 if List
'Length = 0 or else Is_Null
(List
'First) then
30253 Null_Interval_Count
:= List
'Length;
30254 -- no non-null elements, so no merge candidates
30258 Null_Interval_Count
:= 0;
30259 Not_Null
:= List
'First;
30261 for Idx
in List
'First + 1 .. List
'Last loop
30262 if Is_Null
(Idx
) then
30264 -- all remaining elements are null
30266 Null_Interval_Count
:=
30267 Null_Interval_Count
+ List
(Idx
.. List
'Last)'Length;
30270 elsif List
(Idx
).Low
= List
(Not_Null
).High
+ 1 then
30272 -- Merge the two intervals into one; discard the other
30274 List
(Not_Null
).High
:= List
(Idx
).High
;
30275 List
(Idx
) := Null_Interval
;
30276 Null_Interval_Count
:= Null_Interval_Count
+ 1;
30279 if List
(Idx
).Low
<= List
(Not_Null
).High
then
30280 raise Intervals_Error
;
30283 pragma Assert
(List
(Idx
).Low
> List
(Not_Null
).High
);
30287 end Merge_Intervals
;
30289 -------------------
30290 -- Move_Interval --
30291 -------------------
30293 procedure Move_Interval
(From
, To
: Natural) is
30294 Rhs
: constant Discrete_Interval
:= Read_Interval
(From
);
30299 List
(Pos
(To
)) := Rhs
;
30303 -------------------
30304 -- Read_Interval --
30305 -------------------
30307 function Read_Interval
(From
: Natural) return Discrete_Interval
is
30312 return List
(Pos
(From
));
30316 -- Start of processing for Normalize_Interval_Lists
30319 Interval_Sorting
.Sort
(Natural (List
'Last));
30322 Null_Interval_Count
: Nat
;
30325 Merge_Intervals
(Null_Interval_Count
);
30326 Last
:= List
'Last - Null_Interval_Count
;
30328 if Null_Interval_Count
/= 0 then
30329 -- Move null intervals introduced during merging to high end
30330 Interval_Sorting
.Sort
(Natural (List
'Last));
30333 end Normalize_Interval_List
;
30335 --------------------
30336 -- Type_Intervals --
30337 --------------------
30339 function Type_Intervals
(Typ
: Entity_Id
) return Discrete_Interval_List
30342 if Has_Static_Predicate
(Typ
) then
30344 -- No sorting or merging needed
30345 SDP_List
: constant List_Id
:= Static_Discrete_Predicate
(Typ
);
30346 Range_Or_Expr
: Node_Id
:= First
(SDP_List
);
30347 Result
: Discrete_Interval_List
(1 .. List_Length
(SDP_List
));
30350 for Idx
in Result
'Range loop
30351 Result
(Idx
) := Chosen_Interval
(Range_Or_Expr
);
30352 Next
(Range_Or_Expr
);
30355 pragma Assert
(No
(Range_Or_Expr
));
30356 Check_Consistency
(Result
);
30361 Low
: constant Uint
:= Expr_Value
(Type_Low_Bound
(Typ
));
30362 High
: constant Uint
:= Expr_Value
(Type_High_Bound
(Typ
));
30366 Null_Array
: Discrete_Interval_List
(1 .. 0);
30371 return (1 => (Low
=> Low
, High
=> High
));
30375 end Type_Intervals
;
30377 end Interval_Lists
;
30379 package body Old_Attr_Util
is
30380 package body Conditional_Evaluation
is
30381 type Determining_Expr_Context
is
30382 (No_Context
, If_Expr
, Case_Expr
, Short_Circuit_Op
, Membership_Test
);
30384 -- Determining_Expr_Context enumeration elements (except for
30385 -- No_Context) correspond to the list items in RM 6.1.1 definition
30386 -- of "determining expression".
30388 type Determining_Expr
30389 (Context
: Determining_Expr_Context
:= No_Context
)
30391 Expr
: Node_Id
:= Empty
;
30393 when Short_Circuit_Op
=>
30394 Is_And_Then
: Boolean;
30396 Is_Then_Part
: Boolean;
30398 Alternatives
: Node_Id
;
30399 when Membership_Test
=>
30400 -- Given a subexpression of <exp4> in a membership test
30401 -- <exp1> in <exp2> | <exp3> | <exp4> | <exp5>
30402 -- the corresponding determining expression value would
30403 -- have First_Non_Preceding = <exp4> (See RM 6.1.1).
30404 First_Non_Preceding
: Node_Id
;
30410 type Determining_Expression_List
is
30411 array (Positive range <>) of Determining_Expr
;
30413 function Determining_Condition
(Det
: Determining_Expr
)
30415 -- Given a determining expression, build a Boolean-valued
30416 -- condition that incorporates that expression into condition
30417 -- suitable for deciding whether to initialize a 'Old constant.
30418 -- Polarity is "True => initialize the constant".
30420 function Determining_Expressions
30421 (Expr
: Node_Id
; Expr_Trailer
: Node_Id
:= Empty
)
30422 return Determining_Expression_List
;
30423 -- Given a conditionally evaluated expression, return its
30424 -- determining expressions.
30425 -- See RM 6.1.1 for definition of term "determining expressions".
30426 -- Tests should be performed in the order they occur in the
30427 -- array, with short circuiting.
30428 -- A determining expression need not be of a boolean type (e.g.,
30429 -- it might be the determining expression of a case expression).
30430 -- The Expr_Trailer parameter should be defaulted for nonrecursive
30433 function Is_Conditionally_Evaluated
(Expr
: Node_Id
) return Boolean;
30434 -- See RM 6.1.1 for definition of term "conditionally evaluated".
30436 function Is_Known_On_Entry
(Expr
: Node_Id
) return Boolean;
30437 -- See RM 6.1.1 for definition of term "known on entry".
30439 --------------------------------------
30440 -- Conditional_Evaluation_Condition --
30441 --------------------------------------
30443 function Conditional_Evaluation_Condition
30444 (Expr
: Node_Id
) return Node_Id
30446 Determiners
: constant Determining_Expression_List
:=
30447 Determining_Expressions
(Expr
);
30448 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
30449 Result
: Node_Id
:=
30450 New_Occurrence_Of
(Standard_True
, Loc
);
30452 pragma Assert
(Determiners
'Length > 0 or else
30453 Is_Anonymous_Access_Type
(Etype
(Expr
)));
30455 for I
in Determiners
'Range loop
30456 Result
:= Make_And_Then
30458 Left_Opnd
=> Result
,
30460 Determining_Condition
(Determiners
(I
)));
30463 end Conditional_Evaluation_Condition
;
30465 ---------------------------
30466 -- Determining_Condition --
30467 ---------------------------
30469 function Determining_Condition
(Det
: Determining_Expr
) return Node_Id
30471 Loc
: constant Source_Ptr
:= Sloc
(Det
.Expr
);
30473 case Det
.Context
is
30474 when Short_Circuit_Op
=>
30475 if Det
.Is_And_Then
then
30476 return New_Copy_Tree
(Det
.Expr
);
30478 return Make_Op_Not
(Loc
, New_Copy_Tree
(Det
.Expr
));
30482 if Det
.Is_Then_Part
then
30483 return New_Copy_Tree
(Det
.Expr
);
30485 return Make_Op_Not
(Loc
, New_Copy_Tree
(Det
.Expr
));
30490 Alts
: List_Id
:= Discrete_Choices
(Det
.Alternatives
);
30492 if Nkind
(First
(Alts
)) = N_Others_Choice
then
30493 Alts
:= Others_Discrete_Choices
(First
(Alts
));
30496 return Make_In
(Loc
,
30497 Left_Opnd
=> New_Copy_Tree
(Det
.Expr
),
30498 Right_Opnd
=> Empty
,
30499 Alternatives
=> New_Copy_List
(Alts
));
30502 when Membership_Test
=>
30504 function Copy_Prefix
30505 (List
: List_Id
; Suffix_Start
: Node_Id
)
30507 -- Given a list and a member of that list, returns
30508 -- a copy (similar to Nlists.New_Copy_List) of the
30509 -- prefix of the list up to but not including
30516 function Copy_Prefix
30517 (List
: List_Id
; Suffix_Start
: Node_Id
)
30520 Result
: constant List_Id
:= New_List
;
30521 Elem
: Node_Id
:= First
(List
);
30523 while Elem
/= Suffix_Start
loop
30524 Append
(New_Copy
(Elem
), Result
);
30526 pragma Assert
(Present
(Elem
));
30532 return Make_In
(Loc
,
30533 Left_Opnd
=> New_Copy_Tree
(Left_Opnd
(Det
.Expr
)),
30534 Right_Opnd
=> Empty
,
30535 Alternatives
=> Copy_Prefix
30536 (Alternatives
(Det
.Expr
),
30537 Det
.First_Non_Preceding
));
30541 raise Program_Error
;
30543 end Determining_Condition
;
30545 -----------------------------
30546 -- Determining_Expressions --
30547 -----------------------------
30549 function Determining_Expressions
30550 (Expr
: Node_Id
; Expr_Trailer
: Node_Id
:= Empty
)
30551 return Determining_Expression_List
30553 Par
: Node_Id
:= Expr
;
30554 Trailer
: Node_Id
:= Expr_Trailer
;
30555 Next_Element
: Determining_Expr
;
30557 -- We want to stop climbing up the tree when we reach the
30558 -- postcondition expression. An aspect_specification is
30559 -- transformed into a pragma, so reaching a pragma is our
30560 -- termination condition. This relies on the fact that
30561 -- pragmas are not allowed in declare expressions (or any
30562 -- other kind of expression).
30565 Next_Element
.Expr
:= Empty
;
30567 case Nkind
(Par
) is
30568 when N_Short_Circuit
=>
30569 if Trailer
= Right_Opnd
(Par
) then
30571 (Expr
=> Left_Opnd
(Par
),
30572 Context
=> Short_Circuit_Op
,
30573 Is_And_Then
=> Nkind
(Par
) = N_And_Then
);
30576 when N_If_Expression
=>
30577 -- For an expression like
30578 -- (if C1 then ... elsif C2 then ... else Foo'Old)
30579 -- the RM says are two determining expressions,
30580 -- C1 and C2. Our treatment here (where we only add
30581 -- one determining expression to the list) is ok because
30582 -- we will see two if-expressions, one within the other.
30584 if Trailer
/= First
(Expressions
(Par
)) then
30586 (Expr
=> First
(Expressions
(Par
)),
30587 Context
=> If_Expr
,
30589 Trailer
= Next
(First
(Expressions
(Par
))));
30592 when N_Case_Expression_Alternative
=>
30593 pragma Assert
(Nkind
(Parent
(Par
)) = N_Case_Expression
);
30596 (Expr
=> Expression
(Parent
(Par
)),
30597 Context
=> Case_Expr
,
30598 Alternatives
=> Par
);
30600 when N_Membership_Test
=>
30601 if Trailer
/= Left_Opnd
(Par
)
30602 and then Is_Non_Empty_List
(Alternatives
(Par
))
30603 and then Trailer
/= First
(Alternatives
(Par
))
30605 pragma Assert
(No
(Right_Opnd
(Par
)));
30607 (Is_List_Member
(Trailer
)
30608 and then List_Containing
(Trailer
)
30609 = Alternatives
(Par
));
30611 -- This one is different than the others
30612 -- because one element in the array result
30613 -- may represent multiple determining
30614 -- expressions (i.e. every member of the list
30615 -- Alternatives (Par)
30616 -- up to but not including Trailer).
30620 Context
=> Membership_Test
,
30621 First_Non_Preceding
=> Trailer
);
30626 Previous
: constant Node_Id
:= Prev
(Par
);
30627 Prev_Expr
: Node_Id
;
30629 if Nkind
(Previous
) = N_Pragma
and then
30630 Split_PPC
(Previous
)
30632 -- A source-level postcondition of
30633 -- A and then B and then C
30635 -- pragma Postcondition (A);
30636 -- pragma Postcondition (B);
30637 -- pragma Postcondition (C);
30638 -- with Split_PPC set to True on all but the
30639 -- last pragma. We account for that here.
30643 (Pragma_Argument_Associations
(Previous
)));
30645 -- This Analyze call is needed in the case when
30646 -- Sem_Attr.Analyze_Attribute calls
30647 -- Eligible_For_Conditional_Evaluation. Without
30648 -- it, we end up passing an unanalyzed expression
30649 -- to Is_Known_On_Entry and that doesn't work.
30651 Analyze
(Prev_Expr
);
30654 (Expr
=> Prev_Expr
,
30655 Context
=> Short_Circuit_Op
,
30656 Is_And_Then
=> True);
30658 return Determining_Expressions
(Prev_Expr
)
30662 (Get_Pragma_Id
(Pragma_Name
(Par
)) in
30663 Pragma_Post | Pragma_Postcondition
30664 | Pragma_Post_Class | Pragma_Refined_Post
30665 | Pragma_Check | Pragma_Contract_Cases
);
30667 return (1 .. 0 => <>); -- recursion terminates here
30672 -- This case should be impossible, but if it does
30673 -- happen somehow then we don't want an infinite loop.
30674 raise Program_Error
;
30681 Par
:= Parent
(Par
);
30683 if Present
(Next_Element
.Expr
) then
30684 return Determining_Expressions
30685 (Expr
=> Par
, Expr_Trailer
=> Trailer
)
30689 end Determining_Expressions
;
30691 -----------------------------------------
30692 -- Eligible_For_Conditional_Evaluation --
30693 -----------------------------------------
30695 function Eligible_For_Conditional_Evaluation
30696 (Expr
: Node_Id
) return Boolean
30699 if Is_Anonymous_Access_Type
(Etype
(Expr
)) then
30700 -- The code in exp_attr.adb that also builds declarations
30701 -- for 'Old constants doesn't handle the anonymous access
30702 -- type case correctly, so we avoid that problem by
30703 -- returning True here.
30706 elsif Ada_Version
< Ada_2022
then
30709 elsif Inside_Class_Condition_Preanalysis
then
30710 -- No need to evaluate it during preanalysis of a class-wide
30711 -- pre/postcondition since the expression is not installed yet
30712 -- on its definite context.
30715 elsif not Is_Conditionally_Evaluated
(Expr
) then
30719 Determiners
: constant Determining_Expression_List
:=
30720 Determining_Expressions
(Expr
);
30722 pragma Assert
(Determiners
'Length > 0);
30724 for Idx
in Determiners
'Range loop
30725 if not Is_Known_On_Entry
(Determiners
(Idx
).Expr
) then
30732 end Eligible_For_Conditional_Evaluation
;
30734 --------------------------------
30735 -- Is_Conditionally_Evaluated --
30736 --------------------------------
30738 function Is_Conditionally_Evaluated
(Expr
: Node_Id
) return Boolean
30740 -- There are three possibilities - the expression is
30741 -- unconditionally evaluated, repeatedly evaluated, or
30742 -- conditionally evaluated (see RM 6.1.1). So we implement
30743 -- this test by testing for the other two.
30745 function Is_Repeatedly_Evaluated
(Expr
: Node_Id
) return Boolean;
30746 -- See RM 6.1.1 for definition of "repeatedly evaluated".
30748 -----------------------------
30749 -- Is_Repeatedly_Evaluated --
30750 -----------------------------
30752 function Is_Repeatedly_Evaluated
(Expr
: Node_Id
) return Boolean is
30753 Par
: Node_Id
:= Expr
;
30754 Trailer
: Node_Id
:= Empty
;
30756 -- There are three ways that an expression can be repeatedly
30759 -- An aspect_specification is transformed into a pragma, so
30760 -- reaching a pragma is our termination condition. We want to
30761 -- stop when we reach the postcondition expression.
30763 while Nkind
(Par
) /= N_Pragma
loop
30764 pragma Assert
(Present
(Par
));
30766 -- test for case 1:
30767 -- A subexpression of a predicate of a
30768 -- quantified_expression.
30770 if Nkind
(Par
) = N_Quantified_Expression
30771 and then Trailer
= Condition
(Par
)
30774 elsif Nkind
(Par
) = N_Expression_With_Actions
30776 Nkind
(Original_Node
(Par
)) = N_Quantified_Expression
30781 -- test for cases 2 and 3:
30782 -- A subexpression of the expression of an
30783 -- array_component_association or of
30784 -- a container_element_associatiation.
30786 if Nkind
(Par
) = N_Component_Association
30787 and then Trailer
= Expression
(Par
)
30789 -- determine whether Par is part of an array aggregate
30790 -- or a container aggregate
30792 Rover
: Node_Id
:= Par
;
30794 while Nkind
(Rover
) not in N_Has_Etype
loop
30795 pragma Assert
(Present
(Rover
));
30796 Rover
:= Parent
(Rover
);
30798 if Present
(Etype
(Rover
)) then
30799 if Is_Array_Type
(Etype
(Rover
))
30800 or else Is_Container_Aggregate
(Rover
)
30809 Par
:= Parent
(Par
);
30813 end Is_Repeatedly_Evaluated
;
30816 if not Is_Potentially_Unevaluated
(Expr
) then
30817 -- the expression is unconditionally evaluated
30819 elsif Is_Repeatedly_Evaluated
(Expr
) then
30824 end Is_Conditionally_Evaluated
;
30826 -----------------------
30827 -- Is_Known_On_Entry --
30828 -----------------------
30830 function Is_Known_On_Entry
(Expr
: Node_Id
) return Boolean is
30831 -- ??? This implementation is incomplete. See RM 6.1.1
30832 -- for details. In particular, this function *should* return
30833 -- True for a function call (or a user-defined literal, which
30834 -- is equivalent to a function call) if all actual parameters
30835 -- (including defaulted params) are known on entry and the
30836 -- function has "Globals => null" specified; the current
30837 -- implementation will incorrectly return False in this case.
30839 function All_Exps_Known_On_Entry
30840 (Expr_List
: List_Id
) return Boolean;
30841 -- Given a list of expressions, returns False iff
30842 -- Is_Known_On_Entry is False for at least one list element.
30844 -----------------------------
30845 -- All_Exps_Known_On_Entry --
30846 -----------------------------
30848 function All_Exps_Known_On_Entry
30849 (Expr_List
: List_Id
) return Boolean
30851 Expr
: Node_Id
:= First
(Expr_List
);
30853 while Present
(Expr
) loop
30854 if not Is_Known_On_Entry
(Expr
) then
30860 end All_Exps_Known_On_Entry
;
30863 if Is_Static_Expression
(Expr
) then
30867 if Is_Attribute_Old
(Expr
) then
30872 Pref
: Node_Id
:= Expr
;
30875 case Nkind
(Pref
) is
30876 when N_Selected_Component
=>
30879 when N_Indexed_Component
=>
30880 if not All_Exps_Known_On_Entry
(Expressions
(Pref
))
30886 return False; -- just to be clear about this case
30892 Pref
:= Prefix
(Pref
);
30895 if Is_Entity_Name
(Pref
)
30896 and then Is_Constant_Object
(Entity
(Pref
))
30899 Obj
: constant Entity_Id
:= Entity
(Pref
);
30900 Obj_Typ
: constant Entity_Id
:= Etype
(Obj
);
30902 case Ekind
(Obj
) is
30903 when E_In_Parameter
=>
30904 if not Is_Elementary_Type
(Obj_Typ
) then
30906 elsif Is_Aliased
(Obj
) then
30911 -- return False for a deferred constant
30912 if Present
(Full_View
(Obj
)) then
30916 -- return False if not "all views are constant".
30917 if Is_Immutably_Limited_Type
(Obj_Typ
)
30918 or Needs_Finalization
(Obj_Typ
)
30931 -- ??? Cope with a malformed tree. Code to cope with a
30932 -- nonstatic use of an enumeration literal should not be
30934 if Is_Entity_Name
(Pref
)
30935 and then Ekind
(Entity
(Pref
)) = E_Enumeration_Literal
30941 case Nkind
(Expr
) is
30943 return Is_Known_On_Entry
(Right_Opnd
(Expr
));
30945 when N_Binary_Op
=>
30946 return Is_Known_On_Entry
(Left_Opnd
(Expr
))
30947 and then Is_Known_On_Entry
(Right_Opnd
(Expr
));
30949 when N_Type_Conversion | N_Qualified_Expression
=>
30950 return Is_Known_On_Entry
(Expression
(Expr
));
30952 when N_If_Expression
=>
30953 if not All_Exps_Known_On_Entry
(Expressions
(Expr
)) then
30957 when N_Case_Expression
=>
30958 if not Is_Known_On_Entry
(Expression
(Expr
)) then
30963 Alt
: Node_Id
:= First
(Alternatives
(Expr
));
30965 while Present
(Alt
) loop
30966 if not Is_Known_On_Entry
(Expression
(Alt
)) then
30980 end Is_Known_On_Entry
;
30982 end Conditional_Evaluation
;
30984 package body Indirect_Temps
is
30986 Indirect_Temp_Access_Type_Char
: constant Character := 'K';
30987 -- The character passed to Make_Temporary when declaring
30988 -- the access type that is used in the implementation of an
30989 -- indirect temporary.
30991 --------------------------
30992 -- Indirect_Temp_Needed --
30993 --------------------------
30995 function Indirect_Temp_Needed
(Typ
: Entity_Id
) return Boolean is
30997 -- There should be no correctness issues if the only cases where
30998 -- this function returns False are cases where Typ is an
30999 -- anonymous access type and we need to generate a saooaaat (a
31000 -- stand-alone object of an anonymous access type) in order get
31001 -- accessibility right. In other cases where this function
31002 -- returns False, there would be no correctness problems with
31003 -- returning True instead; however, returning False when we can
31004 -- generally results in simpler code.
31008 -- If Typ is not definite, then we cannot generate
31011 or else not Is_Definite_Subtype
(Typ
)
31013 -- If Typ is tagged, then generating
31015 -- might generate an object with the wrong tag. If we had
31016 -- a predicate that indicated whether the nominal tag is
31017 -- trustworthy, we could use that predicate here.
31019 or else Is_Tagged_Type
(Typ
)
31021 -- If Typ needs finalization, then generating an implicit
31023 -- declaration could have user-visible side effects.
31025 or else Needs_Finalization
(Typ
)
31027 -- In the anonymous access type case, we need to
31028 -- generate a saooaaat. We don't want the code in
31029 -- in exp_attr.adb that deals with the case where this
31030 -- function returns False to have to deal with that case
31031 -- (just to avoid code duplication). So we cheat a little
31032 -- bit and return True here for an anonymous access type.
31034 or else Is_Anonymous_Access_Type
(Typ
);
31036 -- ??? Unimplemented - spec description says:
31037 -- For an unconstrained-but-definite discriminated subtype,
31038 -- returns True if the potential difference in size between an
31039 -- unconstrained object and a constrained object is large.
31042 -- type Typ (Len : Natural := 0) is
31043 -- record F : String (1 .. Len); end record;
31045 -- See Large_Max_Size_Mutable function elsewhere in this file,
31046 -- currently declared inside of Needs_Secondary_Stack, so it
31047 -- would have to be moved if we want it to be callable from here.
31049 end Indirect_Temp_Needed
;
31051 ---------------------------
31052 -- Declare_Indirect_Temp --
31053 ---------------------------
31055 procedure Declare_Indirect_Temp
31056 (Attr_Prefix
: Node_Id
; Indirect_Temp
: out Entity_Id
)
31058 Loc
: constant Source_Ptr
:= Sloc
(Attr_Prefix
);
31059 Prefix_Type
: constant Entity_Id
:= Etype
(Attr_Prefix
);
31060 Temp_Id
: constant Entity_Id
:=
31061 Make_Temporary
(Loc
, 'P', Attr_Prefix
);
31063 procedure Declare_Indirect_Temp_Via_Allocation
;
31064 -- Handle the usual case.
31066 -------------------------------------------
31067 -- Declare_Indirect_Temp_Via_Allocation --
31068 -------------------------------------------
31070 procedure Declare_Indirect_Temp_Via_Allocation
is
31071 Access_Type_Id
: constant Entity_Id
31073 (Loc
, Indirect_Temp_Access_Type_Char
, Attr_Prefix
);
31075 Temp_Decl
: constant Node_Id
:=
31076 Make_Object_Declaration
(Loc
,
31077 Defining_Identifier
=> Temp_Id
,
31078 Object_Definition
=>
31079 New_Occurrence_Of
(Access_Type_Id
, Loc
));
31081 Allocate_Class_Wide
: constant Boolean :=
31082 Is_Specific_Tagged_Type
(Prefix_Type
);
31083 -- If True then access type designates the class-wide type in
31084 -- order to preserve (at run time) the value of the underlying
31086 -- ??? We could do better here (in the case where Prefix_Type
31087 -- is tagged and specific) if we had a predicate which takes an
31088 -- expression and returns True iff the expression is of
31089 -- a specific tagged type and the underlying tag (at run time)
31090 -- is statically known to match that of the specific type.
31091 -- In that case, Allocate_Class_Wide could safely be False.
31093 function Designated_Subtype_Mark
return Node_Id
;
31094 -- Usually, a subtype mark indicating the subtype of the
31095 -- attribute prefix. If that subtype is a specific tagged
31096 -- type, then returns the corresponding class-wide type.
31097 -- If the prefix is of an anonymous access type, then returns
31098 -- the designated type of that type.
31100 -----------------------------
31101 -- Designated_Subtype_Mark --
31102 -----------------------------
31104 function Designated_Subtype_Mark
return Node_Id
is
31105 Typ
: Entity_Id
:= Prefix_Type
;
31107 if Allocate_Class_Wide
then
31108 if Is_Private_Type
(Typ
)
31109 and then Present
(Full_View
(Typ
))
31111 Typ
:= Full_View
(Typ
);
31113 Typ
:= Class_Wide_Type
(Typ
);
31116 return New_Occurrence_Of
(Typ
, Loc
);
31117 end Designated_Subtype_Mark
;
31119 Access_Type_Def
: constant Node_Id
31120 := Make_Access_To_Object_Definition
31121 (Loc
, Subtype_Indication
=> Designated_Subtype_Mark
);
31123 Access_Type_Decl
: constant Node_Id
31124 := Make_Full_Type_Declaration
31125 (Loc
, Access_Type_Id
,
31126 Type_Definition
=> Access_Type_Def
);
31128 Mutate_Ekind
(Temp_Id
, E_Variable
);
31129 Set_Etype
(Temp_Id
, Access_Type_Id
);
31130 Mutate_Ekind
(Access_Type_Id
, E_Access_Type
);
31132 if Append_Decls_In_Reverse_Order
then
31133 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31134 Append_Item
(Access_Type_Decl
, Is_Eval_Stmt
=> False);
31136 Append_Item
(Access_Type_Decl
, Is_Eval_Stmt
=> False);
31137 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31140 -- When a type associated with an indirect temporary gets
31141 -- created for a 'Old attribute reference we need to mark
31142 -- the type as such. This allows, for example, finalization
31143 -- masters associated with them to be finalized in the correct
31144 -- order after postcondition checks.
31146 if Attribute_Name
(Parent
(Attr_Prefix
)) = Name_Old
then
31147 Set_Stores_Attribute_Old_Prefix
(Access_Type_Id
);
31150 Analyze
(Access_Type_Decl
);
31151 Analyze
(Temp_Decl
);
31154 (Is_Access_Type_For_Indirect_Temp
(Access_Type_Id
));
31157 Expression
: Node_Id
:= Attr_Prefix
;
31158 Allocator
: Node_Id
;
31160 if Allocate_Class_Wide
then
31161 -- generate T'Class'(T'Class (<prefix>))
31163 Make_Type_Conversion
(Loc
,
31164 Subtype_Mark
=> Designated_Subtype_Mark
,
31165 Expression
=> Expression
);
31169 Make_Allocator
(Loc
,
31170 Make_Qualified_Expression
31172 Subtype_Mark
=> Designated_Subtype_Mark
,
31173 Expression
=> Expression
));
31175 -- Allocate saved prefix value on the secondary stack
31176 -- in order to avoid introducing a storage leak. This
31177 -- allocated object is never explicitly reclaimed.
31179 -- ??? Emit storage leak warning if RE_SS_Pool
31182 if RTE_Available
(RE_SS_Pool
) then
31183 Set_Storage_Pool
(Allocator
, RTE
(RE_SS_Pool
));
31184 Set_Procedure_To_Call
31185 (Allocator
, RTE
(RE_SS_Allocate
));
31186 Set_Uses_Sec_Stack
(Current_Scope
);
31190 (Make_Assignment_Statement
(Loc
,
31191 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
31192 Expression
=> Allocator
),
31193 Is_Eval_Stmt
=> True);
31195 end Declare_Indirect_Temp_Via_Allocation
;
31198 Indirect_Temp
:= Temp_Id
;
31200 if Is_Anonymous_Access_Type
(Prefix_Type
) then
31201 -- In the anonymous access type case, we do not want a level
31202 -- indirection (which would result in declaring an
31203 -- access-to-access type); that would result in correctness
31204 -- problems - the accessibility level of the type of the
31205 -- 'Old constant would be wrong (See 6.1.1.). So in that case,
31206 -- we do not generate an allocator. Instead we generate
31207 -- Temp : access Designated := null;
31208 -- which is unconditionally elaborated and then
31209 -- Temp := <attribute prefix>;
31210 -- which is conditionally executed.
31213 Temp_Decl
: constant Node_Id
:=
31214 Make_Object_Declaration
(Loc
,
31215 Defining_Identifier
=> Temp_Id
,
31216 Object_Definition
=>
31217 Make_Access_Definition
31219 Constant_Present
=>
31220 Is_Access_Constant
(Prefix_Type
),
31223 (Designated_Type
(Prefix_Type
), Loc
)));
31225 Append_Item
(Temp_Decl
, Is_Eval_Stmt
=> False);
31226 Analyze
(Temp_Decl
);
31228 (Make_Assignment_Statement
(Loc
,
31229 Name
=> New_Occurrence_Of
(Temp_Id
, Loc
),
31230 Expression
=> Attr_Prefix
),
31231 Is_Eval_Stmt
=> True);
31235 Declare_Indirect_Temp_Via_Allocation
;
31237 end Declare_Indirect_Temp
;
31239 -------------------------
31240 -- Indirect_Temp_Value --
31241 -------------------------
31243 function Indirect_Temp_Value
31246 Loc
: Source_Ptr
) return Node_Id
31250 if Is_Anonymous_Access_Type
(Typ
) then
31251 -- No indirection in this case; just evaluate the temp.
31252 Result
:= New_Occurrence_Of
(Temp
, Loc
);
31253 Set_Etype
(Result
, Etype
(Temp
));
31256 Result
:= Make_Explicit_Dereference
(Loc
,
31257 New_Occurrence_Of
(Temp
, Loc
));
31259 Set_Etype
(Result
, Designated_Type
(Etype
(Temp
)));
31261 if Is_Specific_Tagged_Type
(Typ
) then
31262 -- The designated type of the access type is class-wide, so
31263 -- convert to the specific type.
31266 Make_Type_Conversion
(Loc
,
31267 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
31268 Expression
=> Result
);
31270 Set_Etype
(Result
, Typ
);
31275 end Indirect_Temp_Value
;
31277 function Is_Access_Type_For_Indirect_Temp
31278 (T
: Entity_Id
) return Boolean is
31280 if Is_Access_Type
(T
)
31281 and then not Comes_From_Source
(T
)
31282 and then Is_Internal_Name
(Chars
(T
))
31283 and then Nkind
(Scope
(T
)) in N_Entity
31284 and then Ekind
(Scope
(T
))
31285 in E_Entry | E_Entry_Family | E_Function | E_Procedure
31287 (Present
(Wrapped_Statements
(Scope
(T
)))
31288 or else Present
(Contract
(Scope
(T
))))
31290 -- ??? Should define a flag for this. We could incorrectly
31291 -- return True if other clients of Make_Temporary happen to
31292 -- pass in the same character.
31294 Name
: constant String := Get_Name_String
(Chars
(T
));
31296 if Name
(Name
'First) = Indirect_Temp_Access_Type_Char
then
31303 end Is_Access_Type_For_Indirect_Temp
;
31305 end Indirect_Temps
;
31308 package body Storage_Model_Support
is
31310 -----------------------------------------
31311 -- Has_Designated_Storage_Model_Aspect --
31312 -----------------------------------------
31314 function Has_Designated_Storage_Model_Aspect
31315 (Typ
: Entity_Id
) return Boolean
31318 return Has_Aspect
(Typ
, Aspect_Designated_Storage_Model
);
31319 end Has_Designated_Storage_Model_Aspect
;
31321 -----------------------------------
31322 -- Has_Storage_Model_Type_Aspect --
31323 -----------------------------------
31325 function Has_Storage_Model_Type_Aspect
(Typ
: Entity_Id
) return Boolean
31328 return Has_Aspect
(Typ
, Aspect_Storage_Model_Type
);
31329 end Has_Storage_Model_Type_Aspect
;
31331 --------------------------
31332 -- Storage_Model_Object --
31333 --------------------------
31335 function Storage_Model_Object
(Typ
: Entity_Id
) return Entity_Id
is
31337 pragma Assert
(Has_Designated_Storage_Model_Aspect
(Typ
));
31341 (Find_Value_Of_Aspect
(Typ
, Aspect_Designated_Storage_Model
));
31342 end Storage_Model_Object
;
31344 ------------------------
31345 -- Storage_Model_Type --
31346 ------------------------
31348 function Storage_Model_Type
(Obj
: Entity_Id
) return Entity_Id
is
31350 pragma Assert
(Has_Storage_Model_Type_Aspect
(Etype
(Obj
)));
31352 return Etype
(Obj
);
31353 end Storage_Model_Type
;
31355 -----------------------------------
31356 -- Get_Storage_Model_Type_Entity --
31357 -----------------------------------
31359 function Get_Storage_Model_Type_Entity
31360 (SM_Obj_Or_Type
: Entity_Id
;
31361 Nam
: Name_Id
) return Entity_Id
31363 Typ
: constant Entity_Id
:= (if Is_Object
(SM_Obj_Or_Type
) then
31364 Storage_Model_Type
(SM_Obj_Or_Type
)
31370 Nam
in Name_Address_Type
31371 | Name_Null_Address
31376 | Name_Storage_Size
);
31379 SMT_Aspect_Value
: constant Node_Id
:=
31380 Find_Value_Of_Aspect
(Typ
, Aspect_Storage_Model_Type
);
31383 -- When the aspect has an aggregate expression, search through it
31384 -- to locate a match for the name of the given "subaspect" and return
31385 -- the entity of the aggregate association's expression.
31387 if Present
(SMT_Aspect_Value
) then
31388 Assoc
:= First
(Component_Associations
(SMT_Aspect_Value
));
31389 while Present
(Assoc
) loop
31390 if Chars
(First
(Choices
(Assoc
))) = Nam
then
31391 return Entity
(Expression
(Assoc
));
31398 -- The aggregate argument of Storage_Model_Type is optional, and when
31399 -- not present the aspect defaults to the native storage model, where
31400 -- the address type is System.Address. In that case, we return
31401 -- System.Address for Name_Address_Type and System.Null_Address for
31402 -- Name_Null_Address, but return Empty for other cases, and leave it
31403 -- to the back end to map those to the appropriate native operations.
31405 if Nam
= Name_Address_Type
then
31406 return RTE
(RE_Address
);
31408 elsif Nam
= Name_Null_Address
then
31409 return RTE
(RE_Null_Address
);
31414 end Get_Storage_Model_Type_Entity
;
31416 --------------------------------
31417 -- Storage_Model_Address_Type --
31418 --------------------------------
31420 function Storage_Model_Address_Type
31421 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31425 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Address_Type
);
31426 end Storage_Model_Address_Type
;
31428 --------------------------------
31429 -- Storage_Model_Null_Address --
31430 --------------------------------
31432 function Storage_Model_Null_Address
31433 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31437 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Null_Address
);
31438 end Storage_Model_Null_Address
;
31440 ----------------------------
31441 -- Storage_Model_Allocate --
31442 ----------------------------
31444 function Storage_Model_Allocate
31445 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31448 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Allocate
);
31449 end Storage_Model_Allocate
;
31451 ------------------------------
31452 -- Storage_Model_Deallocate --
31453 ------------------------------
31455 function Storage_Model_Deallocate
31456 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31460 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Deallocate
);
31461 end Storage_Model_Deallocate
;
31463 -----------------------------
31464 -- Storage_Model_Copy_From --
31465 -----------------------------
31467 function Storage_Model_Copy_From
31468 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31471 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Copy_From
);
31472 end Storage_Model_Copy_From
;
31474 ---------------------------
31475 -- Storage_Model_Copy_To --
31476 ---------------------------
31478 function Storage_Model_Copy_To
31479 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31482 return Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Copy_To
);
31483 end Storage_Model_Copy_To
;
31485 --------------------------------
31486 -- Storage_Model_Storage_Size --
31487 --------------------------------
31489 function Storage_Model_Storage_Size
31490 (SM_Obj_Or_Type
: Entity_Id
) return Entity_Id
31494 Get_Storage_Model_Type_Entity
(SM_Obj_Or_Type
, Name_Storage_Size
);
31495 end Storage_Model_Storage_Size
;
31497 end Storage_Model_Support
;
31500 Erroutc
.Subprogram_Name_Ptr
:= Subprogram_Name
'Access;