1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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 Treepr
; -- ???For debugging code below
28 with Aspects
; use Aspects
;
29 with Atree
; use Atree
;
30 with Casing
; use Casing
;
31 with Checks
; use Checks
;
32 with Debug
; use Debug
;
33 with Elists
; use Elists
;
34 with Errout
; use Errout
;
35 with Exp_Ch11
; use Exp_Ch11
;
36 with Exp_Disp
; use Exp_Disp
;
37 with Exp_Util
; use Exp_Util
;
38 with Fname
; use Fname
;
39 with Freeze
; use Freeze
;
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_Ch6
; use Sem_Ch6
;
53 with Sem_Ch8
; use Sem_Ch8
;
54 with Sem_Disp
; use Sem_Disp
;
55 with Sem_Eval
; use Sem_Eval
;
56 with Sem_Prag
; use Sem_Prag
;
57 with Sem_Res
; use Sem_Res
;
58 with Sem_Warn
; use Sem_Warn
;
59 with Sem_Type
; use Sem_Type
;
60 with Sinfo
; use Sinfo
;
61 with Sinput
; use Sinput
;
62 with Stand
; use Stand
;
64 with Stringt
; use Stringt
;
65 with Targparm
; use Targparm
;
66 with Tbuild
; use Tbuild
;
67 with Ttypes
; use Ttypes
;
68 with Uname
; use Uname
;
70 with GNAT
.HTable
; use GNAT
.HTable
;
72 package body Sem_Util
is
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
78 function Build_Component_Subtype
81 T
: Entity_Id
) return Node_Id
;
82 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
83 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
84 -- Loc is the source location, T is the original subtype.
86 function Has_Enabled_Property
88 Property
: Name_Id
) return Boolean;
89 -- Subsidiary to routines Async_xxx_Enabled and Effective_xxx_Enabled.
90 -- Determine whether an abstract state or a variable denoted by entity
91 -- Item_Id has enabled property Property.
93 function Has_Null_Extension
(T
: Entity_Id
) return Boolean;
94 -- T is a derived tagged type. Check whether the type extension is null.
95 -- If the parent type is fully initialized, T can be treated as such.
97 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean;
98 -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
99 -- with discriminants whose default values are static, examine only the
100 -- components in the selected variant to determine whether all of them
103 type Null_Status_Kind
is
105 -- This value indicates that a subexpression is known to have a null
106 -- value at compile time.
109 -- This value indicates that a subexpression is known to have a non-null
110 -- value at compile time.
113 -- This value indicates that it cannot be determined at compile time
114 -- whether a subexpression yields a null or non-null value.
116 function Null_Status
(N
: Node_Id
) return Null_Status_Kind
;
117 -- Determine whether subexpression N of an access type yields a null value,
118 -- a non-null value, or the value cannot be determined at compile time. The
119 -- routine does not take simple flow diagnostics into account, it relies on
120 -- static facts such as the presence of null exclusions.
122 function Old_Requires_Transient_Scope
(Id
: Entity_Id
) return Boolean;
123 function New_Requires_Transient_Scope
(Id
: Entity_Id
) return Boolean;
124 -- ???We retain the old and new algorithms for Requires_Transient_Scope for
125 -- the time being. New_Requires_Transient_Scope is used by default; the
126 -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope
127 -- instead. The intent is to use this temporarily to measure before/after
128 -- efficiency. Note: when this temporary code is removed, the documentation
129 -- of dQ in debug.adb should be removed.
131 procedure Results_Differ
135 -- ???Debugging code. Called when the Old_Val and New_Val differ. This
136 -- routine will be removed eventially when New_Requires_Transient_Scope
137 -- becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is
140 ------------------------------
141 -- Abstract_Interface_List --
142 ------------------------------
144 function Abstract_Interface_List
(Typ
: Entity_Id
) return List_Id
is
148 if Is_Concurrent_Type
(Typ
) then
150 -- If we are dealing with a synchronized subtype, go to the base
151 -- type, whose declaration has the interface list.
153 -- Shouldn't this be Declaration_Node???
155 Nod
:= Parent
(Base_Type
(Typ
));
157 if Nkind
(Nod
) = N_Full_Type_Declaration
then
161 elsif Ekind
(Typ
) = E_Record_Type_With_Private
then
162 if Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
then
163 Nod
:= Type_Definition
(Parent
(Typ
));
165 elsif Nkind
(Parent
(Typ
)) = N_Private_Type_Declaration
then
166 if Present
(Full_View
(Typ
))
168 Nkind
(Parent
(Full_View
(Typ
))) = N_Full_Type_Declaration
170 Nod
:= Type_Definition
(Parent
(Full_View
(Typ
)));
172 -- If the full-view is not available we cannot do anything else
173 -- here (the source has errors).
179 -- Support for generic formals with interfaces is still missing ???
181 elsif Nkind
(Parent
(Typ
)) = N_Formal_Type_Declaration
then
186 (Nkind
(Parent
(Typ
)) = N_Private_Extension_Declaration
);
190 elsif Ekind
(Typ
) = E_Record_Subtype
then
191 Nod
:= Type_Definition
(Parent
(Etype
(Typ
)));
193 elsif Ekind
(Typ
) = E_Record_Subtype_With_Private
then
195 -- Recurse, because parent may still be a private extension. Also
196 -- note that the full view of the subtype or the full view of its
197 -- base type may (both) be unavailable.
199 return Abstract_Interface_List
(Etype
(Typ
));
201 else pragma Assert
((Ekind
(Typ
)) = E_Record_Type
);
202 if Nkind
(Parent
(Typ
)) = N_Formal_Type_Declaration
then
203 Nod
:= Formal_Type_Definition
(Parent
(Typ
));
205 Nod
:= Type_Definition
(Parent
(Typ
));
209 return Interface_List
(Nod
);
210 end Abstract_Interface_List
;
212 --------------------------------
213 -- Add_Access_Type_To_Process --
214 --------------------------------
216 procedure Add_Access_Type_To_Process
(E
: Entity_Id
; A
: Entity_Id
) is
220 Ensure_Freeze_Node
(E
);
221 L
:= Access_Types_To_Process
(Freeze_Node
(E
));
225 Set_Access_Types_To_Process
(Freeze_Node
(E
), L
);
229 end Add_Access_Type_To_Process
;
231 --------------------------
232 -- Add_Block_Identifier --
233 --------------------------
235 procedure Add_Block_Identifier
(N
: Node_Id
; Id
: out Entity_Id
) is
236 Loc
: constant Source_Ptr
:= Sloc
(N
);
239 pragma Assert
(Nkind
(N
) = N_Block_Statement
);
241 -- The block already has a label, return its entity
243 if Present
(Identifier
(N
)) then
244 Id
:= Entity
(Identifier
(N
));
246 -- Create a new block label and set its attributes
249 Id
:= New_Internal_Entity
(E_Block
, Current_Scope
, Loc
, 'B');
250 Set_Etype
(Id
, Standard_Void_Type
);
253 Set_Identifier
(N
, New_Occurrence_Of
(Id
, Loc
));
254 Set_Block_Node
(Id
, Identifier
(N
));
256 end Add_Block_Identifier
;
258 ----------------------------
259 -- Add_Global_Declaration --
260 ----------------------------
262 procedure Add_Global_Declaration
(N
: Node_Id
) is
263 Aux_Node
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Current_Sem_Unit
));
266 if No
(Declarations
(Aux_Node
)) then
267 Set_Declarations
(Aux_Node
, New_List
);
270 Append_To
(Declarations
(Aux_Node
), N
);
272 end Add_Global_Declaration
;
274 --------------------------------
275 -- Address_Integer_Convert_OK --
276 --------------------------------
278 function Address_Integer_Convert_OK
(T1
, T2
: Entity_Id
) return Boolean is
280 if Allow_Integer_Address
281 and then ((Is_Descendant_Of_Address
(T1
)
282 and then Is_Private_Type
(T1
)
283 and then Is_Integer_Type
(T2
))
285 (Is_Descendant_Of_Address
(T2
)
286 and then Is_Private_Type
(T2
)
287 and then Is_Integer_Type
(T1
)))
293 end Address_Integer_Convert_OK
;
299 function Address_Value
(N
: Node_Id
) return Node_Id
is
304 -- For constant, get constant expression
306 if Is_Entity_Name
(Expr
)
307 and then Ekind
(Entity
(Expr
)) = E_Constant
309 Expr
:= Constant_Value
(Entity
(Expr
));
311 -- For unchecked conversion, get result to convert
313 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
314 Expr
:= Expression
(Expr
);
316 -- For (common case) of To_Address call, get argument
318 elsif Nkind
(Expr
) = N_Function_Call
319 and then Is_Entity_Name
(Name
(Expr
))
320 and then Is_RTE
(Entity
(Name
(Expr
)), RE_To_Address
)
322 Expr
:= First
(Parameter_Associations
(Expr
));
324 if Nkind
(Expr
) = N_Parameter_Association
then
325 Expr
:= Explicit_Actual_Parameter
(Expr
);
328 -- We finally have the real expression
342 -- For now, just 8/16/32/64
344 function Addressable
(V
: Uint
) return Boolean is
346 return V
= Uint_8
or else
352 function Addressable
(V
: Int
) return Boolean is
360 ---------------------------------
361 -- Aggregate_Constraint_Checks --
362 ---------------------------------
364 procedure Aggregate_Constraint_Checks
366 Check_Typ
: Entity_Id
)
368 Exp_Typ
: constant Entity_Id
:= Etype
(Exp
);
371 if Raises_Constraint_Error
(Exp
) then
375 -- Ada 2005 (AI-230): Generate a conversion to an anonymous access
376 -- component's type to force the appropriate accessibility checks.
378 -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to
379 -- force the corresponding run-time check
381 if Is_Access_Type
(Check_Typ
)
382 and then Is_Local_Anonymous_Access
(Check_Typ
)
384 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
385 Analyze_And_Resolve
(Exp
, Check_Typ
);
386 Check_Unset_Reference
(Exp
);
389 -- What follows is really expansion activity, so check that expansion
390 -- is on and is allowed. In GNATprove mode, we also want check flags to
391 -- be added in the tree, so that the formal verification can rely on
392 -- those to be present. In GNATprove mode for formal verification, some
393 -- treatment typically only done during expansion needs to be performed
394 -- on the tree, but it should not be applied inside generics. Otherwise,
395 -- this breaks the name resolution mechanism for generic instances.
397 if not Expander_Active
398 and (Inside_A_Generic
or not Full_Analysis
or not GNATprove_Mode
)
403 if Is_Access_Type
(Check_Typ
)
404 and then Can_Never_Be_Null
(Check_Typ
)
405 and then not Can_Never_Be_Null
(Exp_Typ
)
407 Install_Null_Excluding_Check
(Exp
);
410 -- First check if we have to insert discriminant checks
412 if Has_Discriminants
(Exp_Typ
) then
413 Apply_Discriminant_Check
(Exp
, Check_Typ
);
415 -- Next emit length checks for array aggregates
417 elsif Is_Array_Type
(Exp_Typ
) then
418 Apply_Length_Check
(Exp
, Check_Typ
);
420 -- Finally emit scalar and string checks. If we are dealing with a
421 -- scalar literal we need to check by hand because the Etype of
422 -- literals is not necessarily correct.
424 elsif Is_Scalar_Type
(Exp_Typ
)
425 and then Compile_Time_Known_Value
(Exp
)
427 if Is_Out_Of_Range
(Exp
, Base_Type
(Check_Typ
)) then
428 Apply_Compile_Time_Constraint_Error
429 (Exp
, "value not in range of}??", CE_Range_Check_Failed
,
430 Ent
=> Base_Type
(Check_Typ
),
431 Typ
=> Base_Type
(Check_Typ
));
433 elsif Is_Out_Of_Range
(Exp
, Check_Typ
) then
434 Apply_Compile_Time_Constraint_Error
435 (Exp
, "value not in range of}??", CE_Range_Check_Failed
,
439 elsif not Range_Checks_Suppressed
(Check_Typ
) then
440 Apply_Scalar_Range_Check
(Exp
, Check_Typ
);
443 -- Verify that target type is also scalar, to prevent view anomalies
444 -- in instantiations.
446 elsif (Is_Scalar_Type
(Exp_Typ
)
447 or else Nkind
(Exp
) = N_String_Literal
)
448 and then Is_Scalar_Type
(Check_Typ
)
449 and then Exp_Typ
/= Check_Typ
451 if Is_Entity_Name
(Exp
)
452 and then Ekind
(Entity
(Exp
)) = E_Constant
454 -- If expression is a constant, it is worthwhile checking whether
455 -- it is a bound of the type.
457 if (Is_Entity_Name
(Type_Low_Bound
(Check_Typ
))
458 and then Entity
(Exp
) = Entity
(Type_Low_Bound
(Check_Typ
)))
460 (Is_Entity_Name
(Type_High_Bound
(Check_Typ
))
461 and then Entity
(Exp
) = Entity
(Type_High_Bound
(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 -- Could use a comment on this case ???
474 Rewrite
(Exp
, Convert_To
(Check_Typ
, Relocate_Node
(Exp
)));
475 Analyze_And_Resolve
(Exp
, Check_Typ
);
476 Check_Unset_Reference
(Exp
);
480 end Aggregate_Constraint_Checks
;
482 -----------------------
483 -- Alignment_In_Bits --
484 -----------------------
486 function Alignment_In_Bits
(E
: Entity_Id
) return Uint
is
488 return Alignment
(E
) * System_Storage_Unit
;
489 end Alignment_In_Bits
;
491 --------------------------------------
492 -- All_Composite_Constraints_Static --
493 --------------------------------------
495 function All_Composite_Constraints_Static
496 (Constr
: Node_Id
) return Boolean
499 if No
(Constr
) or else Error_Posted
(Constr
) then
503 case Nkind
(Constr
) is
505 if Nkind
(Constr
) in N_Has_Entity
506 and then Present
(Entity
(Constr
))
508 if Is_Type
(Entity
(Constr
)) then
510 not Is_Discrete_Type
(Entity
(Constr
))
511 or else Is_OK_Static_Subtype
(Entity
(Constr
));
514 elsif Nkind
(Constr
) = N_Range
then
516 Is_OK_Static_Expression
(Low_Bound
(Constr
))
518 Is_OK_Static_Expression
(High_Bound
(Constr
));
520 elsif Nkind
(Constr
) = N_Attribute_Reference
521 and then Attribute_Name
(Constr
) = Name_Range
524 Is_OK_Static_Expression
525 (Type_Low_Bound
(Etype
(Prefix
(Constr
))))
527 Is_OK_Static_Expression
528 (Type_High_Bound
(Etype
(Prefix
(Constr
))));
532 not Present
(Etype
(Constr
)) -- previous error
533 or else not Is_Discrete_Type
(Etype
(Constr
))
534 or else Is_OK_Static_Expression
(Constr
);
536 when N_Discriminant_Association
=>
537 return All_Composite_Constraints_Static
(Expression
(Constr
));
539 when N_Range_Constraint
=>
541 All_Composite_Constraints_Static
(Range_Expression
(Constr
));
543 when N_Index_Or_Discriminant_Constraint
=>
545 One_Cstr
: Entity_Id
;
547 One_Cstr
:= First
(Constraints
(Constr
));
548 while Present
(One_Cstr
) loop
549 if not All_Composite_Constraints_Static
(One_Cstr
) then
559 when N_Subtype_Indication
=>
561 All_Composite_Constraints_Static
(Subtype_Mark
(Constr
))
563 All_Composite_Constraints_Static
(Constraint
(Constr
));
568 end All_Composite_Constraints_Static
;
570 ---------------------------------
571 -- Append_Inherited_Subprogram --
572 ---------------------------------
574 procedure Append_Inherited_Subprogram
(S
: Entity_Id
) is
575 Par
: constant Entity_Id
:= Alias
(S
);
576 -- The parent subprogram
578 Scop
: constant Entity_Id
:= Scope
(Par
);
579 -- The scope of definition of the parent subprogram
581 Typ
: constant Entity_Id
:= Defining_Entity
(Parent
(S
));
582 -- The derived type of which S is a primitive operation
588 if Ekind
(Current_Scope
) = E_Package
589 and then In_Private_Part
(Current_Scope
)
590 and then Has_Private_Declaration
(Typ
)
591 and then Is_Tagged_Type
(Typ
)
592 and then Scop
= Current_Scope
594 -- The inherited operation is available at the earliest place after
595 -- the derived type declaration ( RM 7.3.1 (6/1)). This is only
596 -- relevant for type extensions. If the parent operation appears
597 -- after the type extension, the operation is not visible.
600 (Visible_Declarations
601 (Package_Specification
(Current_Scope
)));
602 while Present
(Decl
) loop
603 if Nkind
(Decl
) = N_Private_Extension_Declaration
604 and then Defining_Entity
(Decl
) = Typ
606 if Sloc
(Decl
) > Sloc
(Par
) then
607 Next_E
:= Next_Entity
(Par
);
608 Set_Next_Entity
(Par
, S
);
609 Set_Next_Entity
(S
, Next_E
);
621 -- If partial view is not a type extension, or it appears before the
622 -- subprogram declaration, insert normally at end of entity list.
624 Append_Entity
(S
, Current_Scope
);
625 end Append_Inherited_Subprogram
;
627 -----------------------------------------
628 -- Apply_Compile_Time_Constraint_Error --
629 -----------------------------------------
631 procedure Apply_Compile_Time_Constraint_Error
634 Reason
: RT_Exception_Code
;
635 Ent
: Entity_Id
:= Empty
;
636 Typ
: Entity_Id
:= Empty
;
637 Loc
: Source_Ptr
:= No_Location
;
638 Rep
: Boolean := True;
639 Warn
: Boolean := False)
641 Stat
: constant Boolean := Is_Static_Expression
(N
);
642 R_Stat
: constant Node_Id
:=
643 Make_Raise_Constraint_Error
(Sloc
(N
), Reason
=> Reason
);
654 (Compile_Time_Constraint_Error
(N
, Msg
, Ent
, Loc
, Warn
=> Warn
));
656 -- In GNATprove mode, do not replace the node with an exception raised.
657 -- In such a case, either the call to Compile_Time_Constraint_Error
658 -- issues an error which stops analysis, or it issues a warning in
659 -- a few cases where a suitable check flag is set for GNATprove to
660 -- generate a check message.
662 if not Rep
or GNATprove_Mode
then
666 -- Now we replace the node by an N_Raise_Constraint_Error node
667 -- This does not need reanalyzing, so set it as analyzed now.
670 Set_Analyzed
(N
, True);
673 Set_Raises_Constraint_Error
(N
);
675 -- Now deal with possible local raise handling
677 Possible_Local_Raise
(N
, Standard_Constraint_Error
);
679 -- If the original expression was marked as static, the result is
680 -- still marked as static, but the Raises_Constraint_Error flag is
681 -- always set so that further static evaluation is not attempted.
684 Set_Is_Static_Expression
(N
);
686 end Apply_Compile_Time_Constraint_Error
;
688 ---------------------------
689 -- Async_Readers_Enabled --
690 ---------------------------
692 function Async_Readers_Enabled
(Id
: Entity_Id
) return Boolean is
694 return Has_Enabled_Property
(Id
, Name_Async_Readers
);
695 end Async_Readers_Enabled
;
697 ---------------------------
698 -- Async_Writers_Enabled --
699 ---------------------------
701 function Async_Writers_Enabled
(Id
: Entity_Id
) return Boolean is
703 return Has_Enabled_Property
(Id
, Name_Async_Writers
);
704 end Async_Writers_Enabled
;
706 --------------------------------------
707 -- Available_Full_View_Of_Component --
708 --------------------------------------
710 function Available_Full_View_Of_Component
(T
: Entity_Id
) return Boolean is
711 ST
: constant Entity_Id
:= Scope
(T
);
712 SCT
: constant Entity_Id
:= Scope
(Component_Type
(T
));
714 return In_Open_Scopes
(ST
)
715 and then In_Open_Scopes
(SCT
)
716 and then Scope_Depth
(ST
) >= Scope_Depth
(SCT
);
717 end Available_Full_View_Of_Component
;
723 procedure Bad_Attribute
726 Warn
: Boolean := False)
729 Error_Msg_Warn
:= Warn
;
730 Error_Msg_N
("unrecognized attribute&<<", N
);
732 -- Check for possible misspelling
734 Error_Msg_Name_1
:= First_Attribute_Name
;
735 while Error_Msg_Name_1
<= Last_Attribute_Name
loop
736 if Is_Bad_Spelling_Of
(Nam
, Error_Msg_Name_1
) then
737 Error_Msg_N
-- CODEFIX
738 ("\possible misspelling of %<<", N
);
742 Error_Msg_Name_1
:= Error_Msg_Name_1
+ 1;
746 --------------------------------
747 -- Bad_Predicated_Subtype_Use --
748 --------------------------------
750 procedure Bad_Predicated_Subtype_Use
754 Suggest_Static
: Boolean := False)
759 -- Avoid cascaded errors
761 if Error_Posted
(N
) then
765 if Inside_A_Generic
then
766 Gen
:= Current_Scope
;
767 while Present
(Gen
) and then Ekind
(Gen
) /= E_Generic_Package
loop
775 if Is_Generic_Formal
(Typ
) and then Is_Discrete_Type
(Typ
) then
776 Set_No_Predicate_On_Actual
(Typ
);
779 elsif Has_Predicates
(Typ
) then
780 if Is_Generic_Actual_Type
(Typ
) then
782 -- The restriction on loop parameters is only that the type
783 -- should have no dynamic predicates.
785 if Nkind
(Parent
(N
)) = N_Loop_Parameter_Specification
786 and then not Has_Dynamic_Predicate_Aspect
(Typ
)
787 and then Is_OK_Static_Subtype
(Typ
)
792 Gen
:= Current_Scope
;
793 while not Is_Generic_Instance
(Gen
) loop
797 pragma Assert
(Present
(Gen
));
799 if Ekind
(Gen
) = E_Package
and then In_Package_Body
(Gen
) then
800 Error_Msg_Warn
:= SPARK_Mode
/= On
;
801 Error_Msg_FE
(Msg
& "<<", N
, Typ
);
802 Error_Msg_F
("\Program_Error [<<", N
);
805 Make_Raise_Program_Error
(Sloc
(N
),
806 Reason
=> PE_Bad_Predicated_Generic_Type
));
809 Error_Msg_FE
(Msg
& "<<", N
, Typ
);
813 Error_Msg_FE
(Msg
, N
, Typ
);
816 -- Emit an optional suggestion on how to remedy the error if the
817 -- context warrants it.
819 if Suggest_Static
and then Has_Static_Predicate
(Typ
) then
820 Error_Msg_FE
("\predicate of & should be marked static", N
, Typ
);
823 end Bad_Predicated_Subtype_Use
;
825 -----------------------------------------
826 -- Bad_Unordered_Enumeration_Reference --
827 -----------------------------------------
829 function Bad_Unordered_Enumeration_Reference
831 T
: Entity_Id
) return Boolean
834 return Is_Enumeration_Type
(T
)
835 and then Warn_On_Unordered_Enumeration_Type
836 and then not Is_Generic_Type
(T
)
837 and then Comes_From_Source
(N
)
838 and then not Has_Pragma_Ordered
(T
)
839 and then not In_Same_Extended_Unit
(N
, T
);
840 end Bad_Unordered_Enumeration_Reference
;
842 --------------------------
843 -- Build_Actual_Subtype --
844 --------------------------
846 function Build_Actual_Subtype
848 N
: Node_Or_Entity_Id
) return Node_Id
851 -- Normally Sloc (N), but may point to corresponding body in some cases
853 Constraints
: List_Id
;
859 Disc_Type
: Entity_Id
;
865 if Nkind
(N
) = N_Defining_Identifier
then
866 Obj
:= New_Occurrence_Of
(N
, Loc
);
868 -- If this is a formal parameter of a subprogram declaration, and
869 -- we are compiling the body, we want the declaration for the
870 -- actual subtype to carry the source position of the body, to
871 -- prevent anomalies in gdb when stepping through the code.
873 if Is_Formal
(N
) then
875 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(N
));
877 if Nkind
(Decl
) = N_Subprogram_Declaration
878 and then Present
(Corresponding_Body
(Decl
))
880 Loc
:= Sloc
(Corresponding_Body
(Decl
));
889 if Is_Array_Type
(T
) then
890 Constraints
:= New_List
;
891 for J
in 1 .. Number_Dimensions
(T
) loop
893 -- Build an array subtype declaration with the nominal subtype and
894 -- the bounds of the actual. Add the declaration in front of the
895 -- local declarations for the subprogram, for analysis before any
896 -- reference to the formal in the body.
899 Make_Attribute_Reference
(Loc
,
901 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
902 Attribute_Name
=> Name_First
,
903 Expressions
=> New_List
(
904 Make_Integer_Literal
(Loc
, J
)));
907 Make_Attribute_Reference
(Loc
,
909 Duplicate_Subexpr_No_Checks
(Obj
, Name_Req
=> True),
910 Attribute_Name
=> Name_Last
,
911 Expressions
=> New_List
(
912 Make_Integer_Literal
(Loc
, J
)));
914 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
917 -- If the type has unknown discriminants there is no constrained
918 -- subtype to build. This is never called for a formal or for a
919 -- lhs, so returning the type is ok ???
921 elsif Has_Unknown_Discriminants
(T
) then
925 Constraints
:= New_List
;
927 -- Type T is a generic derived type, inherit the discriminants from
930 if Is_Private_Type
(T
)
931 and then No
(Full_View
(T
))
933 -- T was flagged as an error if it was declared as a formal
934 -- derived type with known discriminants. In this case there
935 -- is no need to look at the parent type since T already carries
936 -- its own discriminants.
938 and then not Error_Posted
(T
)
940 Disc_Type
:= Etype
(Base_Type
(T
));
945 Discr
:= First_Discriminant
(Disc_Type
);
946 while Present
(Discr
) loop
947 Append_To
(Constraints
,
948 Make_Selected_Component
(Loc
,
950 Duplicate_Subexpr_No_Checks
(Obj
),
951 Selector_Name
=> New_Occurrence_Of
(Discr
, Loc
)));
952 Next_Discriminant
(Discr
);
956 Subt
:= Make_Temporary
(Loc
, 'S', Related_Node
=> N
);
957 Set_Is_Internal
(Subt
);
960 Make_Subtype_Declaration
(Loc
,
961 Defining_Identifier
=> Subt
,
962 Subtype_Indication
=>
963 Make_Subtype_Indication
(Loc
,
964 Subtype_Mark
=> New_Occurrence_Of
(T
, Loc
),
966 Make_Index_Or_Discriminant_Constraint
(Loc
,
967 Constraints
=> Constraints
)));
969 Mark_Rewrite_Insertion
(Decl
);
971 end Build_Actual_Subtype
;
973 ---------------------------------------
974 -- Build_Actual_Subtype_Of_Component --
975 ---------------------------------------
977 function Build_Actual_Subtype_Of_Component
979 N
: Node_Id
) return Node_Id
981 Loc
: constant Source_Ptr
:= Sloc
(N
);
982 P
: constant Node_Id
:= Prefix
(N
);
985 Index_Typ
: Entity_Id
;
987 Desig_Typ
: Entity_Id
;
988 -- This is either a copy of T, or if T is an access type, then it is
989 -- the directly designated type of this access type.
991 function Build_Actual_Array_Constraint
return List_Id
;
992 -- If one or more of the bounds of the component depends on
993 -- discriminants, build actual constraint using the discriminants
996 function Build_Actual_Record_Constraint
return List_Id
;
997 -- Similar to previous one, for discriminated components constrained
998 -- by the discriminant of the enclosing object.
1000 -----------------------------------
1001 -- Build_Actual_Array_Constraint --
1002 -----------------------------------
1004 function Build_Actual_Array_Constraint
return List_Id
is
1005 Constraints
: constant List_Id
:= New_List
;
1013 Indx
:= First_Index
(Desig_Typ
);
1014 while Present
(Indx
) loop
1015 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
1016 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
1018 if Denotes_Discriminant
(Old_Lo
) then
1020 Make_Selected_Component
(Loc
,
1021 Prefix
=> New_Copy_Tree
(P
),
1022 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Lo
), Loc
));
1025 Lo
:= New_Copy_Tree
(Old_Lo
);
1027 -- The new bound will be reanalyzed in the enclosing
1028 -- declaration. For literal bounds that come from a type
1029 -- declaration, the type of the context must be imposed, so
1030 -- insure that analysis will take place. For non-universal
1031 -- types this is not strictly necessary.
1033 Set_Analyzed
(Lo
, False);
1036 if Denotes_Discriminant
(Old_Hi
) then
1038 Make_Selected_Component
(Loc
,
1039 Prefix
=> New_Copy_Tree
(P
),
1040 Selector_Name
=> New_Occurrence_Of
(Entity
(Old_Hi
), Loc
));
1043 Hi
:= New_Copy_Tree
(Old_Hi
);
1044 Set_Analyzed
(Hi
, False);
1047 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
1052 end Build_Actual_Array_Constraint
;
1054 ------------------------------------
1055 -- Build_Actual_Record_Constraint --
1056 ------------------------------------
1058 function Build_Actual_Record_Constraint
return List_Id
is
1059 Constraints
: constant List_Id
:= New_List
;
1064 D
:= First_Elmt
(Discriminant_Constraint
(Desig_Typ
));
1065 while Present
(D
) loop
1066 if Denotes_Discriminant
(Node
(D
)) then
1067 D_Val
:= Make_Selected_Component
(Loc
,
1068 Prefix
=> New_Copy_Tree
(P
),
1069 Selector_Name
=> New_Occurrence_Of
(Entity
(Node
(D
)), Loc
));
1072 D_Val
:= New_Copy_Tree
(Node
(D
));
1075 Append
(D_Val
, Constraints
);
1080 end Build_Actual_Record_Constraint
;
1082 -- Start of processing for Build_Actual_Subtype_Of_Component
1085 -- Why the test for Spec_Expression mode here???
1087 if In_Spec_Expression
then
1090 -- More comments for the rest of this body would be good ???
1092 elsif Nkind
(N
) = N_Explicit_Dereference
then
1093 if Is_Composite_Type
(T
)
1094 and then not Is_Constrained
(T
)
1095 and then not (Is_Class_Wide_Type
(T
)
1096 and then Is_Constrained
(Root_Type
(T
)))
1097 and then not Has_Unknown_Discriminants
(T
)
1099 -- If the type of the dereference is already constrained, it is an
1102 if Is_Array_Type
(Etype
(N
))
1103 and then Is_Constrained
(Etype
(N
))
1107 Remove_Side_Effects
(P
);
1108 return Build_Actual_Subtype
(T
, N
);
1115 if Ekind
(T
) = E_Access_Subtype
then
1116 Desig_Typ
:= Designated_Type
(T
);
1121 if Ekind
(Desig_Typ
) = E_Array_Subtype
then
1122 Id
:= First_Index
(Desig_Typ
);
1123 while Present
(Id
) loop
1124 Index_Typ
:= Underlying_Type
(Etype
(Id
));
1126 if Denotes_Discriminant
(Type_Low_Bound
(Index_Typ
))
1128 Denotes_Discriminant
(Type_High_Bound
(Index_Typ
))
1130 Remove_Side_Effects
(P
);
1132 Build_Component_Subtype
1133 (Build_Actual_Array_Constraint
, Loc
, Base_Type
(T
));
1139 elsif Is_Composite_Type
(Desig_Typ
)
1140 and then Has_Discriminants
(Desig_Typ
)
1141 and then not Has_Unknown_Discriminants
(Desig_Typ
)
1143 if Is_Private_Type
(Desig_Typ
)
1144 and then No
(Discriminant_Constraint
(Desig_Typ
))
1146 Desig_Typ
:= Full_View
(Desig_Typ
);
1149 D
:= First_Elmt
(Discriminant_Constraint
(Desig_Typ
));
1150 while Present
(D
) loop
1151 if Denotes_Discriminant
(Node
(D
)) then
1152 Remove_Side_Effects
(P
);
1154 Build_Component_Subtype
(
1155 Build_Actual_Record_Constraint
, Loc
, Base_Type
(T
));
1162 -- If none of the above, the actual and nominal subtypes are the same
1165 end Build_Actual_Subtype_Of_Component
;
1167 ---------------------------------
1168 -- Build_Class_Wide_Clone_Body --
1169 ---------------------------------
1171 procedure Build_Class_Wide_Clone_Body
1172 (Spec_Id
: Entity_Id
;
1175 Loc
: constant Source_Ptr
:= Sloc
(Bod
);
1176 Clone_Id
: constant Entity_Id
:= Class_Wide_Clone
(Spec_Id
);
1177 Clone_Body
: Node_Id
;
1180 -- The declaration of the class-wide clone was created when the
1181 -- corresponding class-wide condition was analyzed.
1184 Make_Subprogram_Body
(Loc
,
1186 Copy_Subprogram_Spec
(Parent
(Clone_Id
)),
1187 Declarations
=> Declarations
(Bod
),
1188 Handled_Statement_Sequence
=> Handled_Statement_Sequence
(Bod
));
1190 -- The new operation is internal and overriding indicators do not apply
1191 -- (the original primitive may have carried one).
1193 Set_Must_Override
(Specification
(Clone_Body
), False);
1194 Insert_Before
(Bod
, Clone_Body
);
1195 Analyze
(Clone_Body
);
1196 end Build_Class_Wide_Clone_Body
;
1198 ---------------------------------
1199 -- Build_Class_Wide_Clone_Call --
1200 ---------------------------------
1202 function Build_Class_Wide_Clone_Call
1205 Spec_Id
: Entity_Id
;
1206 Spec
: Node_Id
) return Node_Id
1208 Clone_Id
: constant Entity_Id
:= Class_Wide_Clone
(Spec_Id
);
1209 Par_Type
: constant Entity_Id
:= Find_Dispatching_Type
(Spec_Id
);
1215 New_F_Spec
: Entity_Id
;
1216 New_Formal
: Entity_Id
;
1219 Actuals
:= Empty_List
;
1220 Formal
:= First_Formal
(Spec_Id
);
1221 New_F_Spec
:= First
(Parameter_Specifications
(Spec
));
1223 -- Build parameter association for call to class-wide clone.
1225 while Present
(Formal
) loop
1226 New_Formal
:= Defining_Identifier
(New_F_Spec
);
1228 -- If controlling argument and operation is inherited, add conversion
1229 -- to parent type for the call.
1231 if Etype
(Formal
) = Par_Type
1232 and then not Is_Empty_List
(Decls
)
1235 Make_Type_Conversion
(Loc
,
1236 New_Occurrence_Of
(Par_Type
, Loc
),
1237 New_Occurrence_Of
(New_Formal
, Loc
)));
1240 Append_To
(Actuals
, New_Occurrence_Of
(New_Formal
, Loc
));
1243 Next_Formal
(Formal
);
1247 if Ekind
(Spec_Id
) = E_Procedure
then
1249 Make_Procedure_Call_Statement
(Loc
,
1250 Name
=> New_Occurrence_Of
(Clone_Id
, Loc
),
1251 Parameter_Associations
=> Actuals
);
1254 Make_Simple_Return_Statement
(Loc
,
1256 Make_Function_Call
(Loc
,
1257 Name
=> New_Occurrence_Of
(Clone_Id
, Loc
),
1258 Parameter_Associations
=> Actuals
));
1262 Make_Subprogram_Body
(Loc
,
1264 Copy_Subprogram_Spec
(Spec
),
1265 Declarations
=> Decls
,
1266 Handled_Statement_Sequence
=>
1267 Make_Handled_Sequence_Of_Statements
(Loc
,
1268 Statements
=> New_List
(Call
),
1269 End_Label
=> Make_Identifier
(Loc
, Chars
(Spec_Id
))));
1272 end Build_Class_Wide_Clone_Call
;
1274 ---------------------------------
1275 -- Build_Class_Wide_Clone_Decl --
1276 ---------------------------------
1278 procedure Build_Class_Wide_Clone_Decl
(Spec_Id
: Entity_Id
) is
1279 Loc
: constant Source_Ptr
:= Sloc
(Spec_Id
);
1280 Clone_Id
: constant Entity_Id
:=
1281 Make_Defining_Identifier
(Loc
,
1282 New_External_Name
(Chars
(Spec_Id
), Suffix
=> "CL"));
1288 Spec
:= Copy_Subprogram_Spec
(Parent
(Spec_Id
));
1289 Set_Must_Override
(Spec
, False);
1290 Set_Must_Not_Override
(Spec
, False);
1291 Set_Defining_Unit_Name
(Spec
, Clone_Id
);
1293 Decl
:= Make_Subprogram_Declaration
(Loc
, Spec
);
1294 Append
(Decl
, List_Containing
(Unit_Declaration_Node
(Spec_Id
)));
1296 -- Link clone to original subprogram, for use when building body and
1297 -- wrapper call to inherited operation.
1299 Set_Class_Wide_Clone
(Spec_Id
, Clone_Id
);
1300 end Build_Class_Wide_Clone_Decl
;
1302 -----------------------------
1303 -- Build_Component_Subtype --
1304 -----------------------------
1306 function Build_Component_Subtype
1309 T
: Entity_Id
) return Node_Id
1315 -- Unchecked_Union components do not require component subtypes
1317 if Is_Unchecked_Union
(T
) then
1321 Subt
:= Make_Temporary
(Loc
, 'S');
1322 Set_Is_Internal
(Subt
);
1325 Make_Subtype_Declaration
(Loc
,
1326 Defining_Identifier
=> Subt
,
1327 Subtype_Indication
=>
1328 Make_Subtype_Indication
(Loc
,
1329 Subtype_Mark
=> New_Occurrence_Of
(Base_Type
(T
), Loc
),
1331 Make_Index_Or_Discriminant_Constraint
(Loc
,
1332 Constraints
=> C
)));
1334 Mark_Rewrite_Insertion
(Decl
);
1336 end Build_Component_Subtype
;
1338 ---------------------------
1339 -- Build_Default_Subtype --
1340 ---------------------------
1342 function Build_Default_Subtype
1344 N
: Node_Id
) return Entity_Id
1346 Loc
: constant Source_Ptr
:= Sloc
(N
);
1350 -- The base type that is to be constrained by the defaults
1353 if not Has_Discriminants
(T
) or else Is_Constrained
(T
) then
1357 Bas
:= Base_Type
(T
);
1359 -- If T is non-private but its base type is private, this is the
1360 -- completion of a subtype declaration whose parent type is private
1361 -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants
1362 -- are to be found in the full view of the base. Check that the private
1363 -- status of T and its base differ.
1365 if Is_Private_Type
(Bas
)
1366 and then not Is_Private_Type
(T
)
1367 and then Present
(Full_View
(Bas
))
1369 Bas
:= Full_View
(Bas
);
1372 Disc
:= First_Discriminant
(T
);
1374 if No
(Discriminant_Default_Value
(Disc
)) then
1379 Act
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
1380 Constraints
: constant List_Id
:= New_List
;
1384 while Present
(Disc
) loop
1385 Append_To
(Constraints
,
1386 New_Copy_Tree
(Discriminant_Default_Value
(Disc
)));
1387 Next_Discriminant
(Disc
);
1391 Make_Subtype_Declaration
(Loc
,
1392 Defining_Identifier
=> Act
,
1393 Subtype_Indication
=>
1394 Make_Subtype_Indication
(Loc
,
1395 Subtype_Mark
=> New_Occurrence_Of
(Bas
, Loc
),
1397 Make_Index_Or_Discriminant_Constraint
(Loc
,
1398 Constraints
=> Constraints
)));
1400 Insert_Action
(N
, Decl
);
1402 -- If the context is a component declaration the subtype declaration
1403 -- will be analyzed when the enclosing type is frozen, otherwise do
1406 if Ekind
(Current_Scope
) /= E_Record_Type
then
1412 end Build_Default_Subtype
;
1414 --------------------------------------------
1415 -- Build_Discriminal_Subtype_Of_Component --
1416 --------------------------------------------
1418 function Build_Discriminal_Subtype_Of_Component
1419 (T
: Entity_Id
) return Node_Id
1421 Loc
: constant Source_Ptr
:= Sloc
(T
);
1425 function Build_Discriminal_Array_Constraint
return List_Id
;
1426 -- If one or more of the bounds of the component depends on
1427 -- discriminants, build actual constraint using the discriminants
1430 function Build_Discriminal_Record_Constraint
return List_Id
;
1431 -- Similar to previous one, for discriminated components constrained by
1432 -- the discriminant of the enclosing object.
1434 ----------------------------------------
1435 -- Build_Discriminal_Array_Constraint --
1436 ----------------------------------------
1438 function Build_Discriminal_Array_Constraint
return List_Id
is
1439 Constraints
: constant List_Id
:= New_List
;
1447 Indx
:= First_Index
(T
);
1448 while Present
(Indx
) loop
1449 Old_Lo
:= Type_Low_Bound
(Etype
(Indx
));
1450 Old_Hi
:= Type_High_Bound
(Etype
(Indx
));
1452 if Denotes_Discriminant
(Old_Lo
) then
1453 Lo
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Lo
)), Loc
);
1456 Lo
:= New_Copy_Tree
(Old_Lo
);
1459 if Denotes_Discriminant
(Old_Hi
) then
1460 Hi
:= New_Occurrence_Of
(Discriminal
(Entity
(Old_Hi
)), Loc
);
1463 Hi
:= New_Copy_Tree
(Old_Hi
);
1466 Append
(Make_Range
(Loc
, Lo
, Hi
), Constraints
);
1471 end Build_Discriminal_Array_Constraint
;
1473 -----------------------------------------
1474 -- Build_Discriminal_Record_Constraint --
1475 -----------------------------------------
1477 function Build_Discriminal_Record_Constraint
return List_Id
is
1478 Constraints
: constant List_Id
:= New_List
;
1483 D
:= First_Elmt
(Discriminant_Constraint
(T
));
1484 while Present
(D
) loop
1485 if Denotes_Discriminant
(Node
(D
)) then
1487 New_Occurrence_Of
(Discriminal
(Entity
(Node
(D
))), Loc
);
1489 D_Val
:= New_Copy_Tree
(Node
(D
));
1492 Append
(D_Val
, Constraints
);
1497 end Build_Discriminal_Record_Constraint
;
1499 -- Start of processing for Build_Discriminal_Subtype_Of_Component
1502 if Ekind
(T
) = E_Array_Subtype
then
1503 Id
:= First_Index
(T
);
1504 while Present
(Id
) loop
1505 if Denotes_Discriminant
(Type_Low_Bound
(Etype
(Id
)))
1507 Denotes_Discriminant
(Type_High_Bound
(Etype
(Id
)))
1509 return Build_Component_Subtype
1510 (Build_Discriminal_Array_Constraint
, Loc
, T
);
1516 elsif Ekind
(T
) = E_Record_Subtype
1517 and then Has_Discriminants
(T
)
1518 and then not Has_Unknown_Discriminants
(T
)
1520 D
:= First_Elmt
(Discriminant_Constraint
(T
));
1521 while Present
(D
) loop
1522 if Denotes_Discriminant
(Node
(D
)) then
1523 return Build_Component_Subtype
1524 (Build_Discriminal_Record_Constraint
, Loc
, T
);
1531 -- If none of the above, the actual and nominal subtypes are the same
1534 end Build_Discriminal_Subtype_Of_Component
;
1536 ------------------------------
1537 -- Build_Elaboration_Entity --
1538 ------------------------------
1540 procedure Build_Elaboration_Entity
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
1541 Loc
: constant Source_Ptr
:= Sloc
(N
);
1543 Elab_Ent
: Entity_Id
;
1545 procedure Set_Package_Name
(Ent
: Entity_Id
);
1546 -- Given an entity, sets the fully qualified name of the entity in
1547 -- Name_Buffer, with components separated by double underscores. This
1548 -- is a recursive routine that climbs the scope chain to Standard.
1550 ----------------------
1551 -- Set_Package_Name --
1552 ----------------------
1554 procedure Set_Package_Name
(Ent
: Entity_Id
) is
1556 if Scope
(Ent
) /= Standard_Standard
then
1557 Set_Package_Name
(Scope
(Ent
));
1560 Nam
: constant String := Get_Name_String
(Chars
(Ent
));
1562 Name_Buffer
(Name_Len
+ 1) := '_';
1563 Name_Buffer
(Name_Len
+ 2) := '_';
1564 Name_Buffer
(Name_Len
+ 3 .. Name_Len
+ Nam
'Length + 2) := Nam
;
1565 Name_Len
:= Name_Len
+ Nam
'Length + 2;
1569 Get_Name_String
(Chars
(Ent
));
1571 end Set_Package_Name
;
1573 -- Start of processing for Build_Elaboration_Entity
1576 -- Ignore call if already constructed
1578 if Present
(Elaboration_Entity
(Spec_Id
)) then
1581 -- Ignore in ASIS mode, elaboration entity is not in source and plays
1582 -- no role in analysis.
1584 elsif ASIS_Mode
then
1587 -- Do not generate an elaboration entity in GNATprove move because the
1588 -- elaboration counter is a form of expansion.
1590 elsif GNATprove_Mode
then
1593 -- See if we need elaboration entity
1595 -- We always need an elaboration entity when preserving control flow, as
1596 -- we want to remain explicit about the unit's elaboration order.
1598 elsif Opt
.Suppress_Control_Flow_Optimizations
then
1601 -- We always need an elaboration entity for the dynamic elaboration
1602 -- model, since it is needed to properly generate the PE exception for
1603 -- access before elaboration.
1605 elsif Dynamic_Elaboration_Checks
then
1608 -- For the static model, we don't need the elaboration counter if this
1609 -- unit is sure to have no elaboration code, since that means there
1610 -- is no elaboration unit to be called. Note that we can't just decide
1611 -- after the fact by looking to see whether there was elaboration code,
1612 -- because that's too late to make this decision.
1614 elsif Restriction_Active
(No_Elaboration_Code
) then
1617 -- Similarly, for the static model, we can skip the elaboration counter
1618 -- if we have the No_Multiple_Elaboration restriction, since for the
1619 -- static model, that's the only purpose of the counter (to avoid
1620 -- multiple elaboration).
1622 elsif Restriction_Active
(No_Multiple_Elaboration
) then
1626 -- Here we need the elaboration entity
1628 -- Construct name of elaboration entity as xxx_E, where xxx is the unit
1629 -- name with dots replaced by double underscore. We have to manually
1630 -- construct this name, since it will be elaborated in the outer scope,
1631 -- and thus will not have the unit name automatically prepended.
1633 Set_Package_Name
(Spec_Id
);
1634 Add_Str_To_Name_Buffer
("_E");
1636 -- Create elaboration counter
1638 Elab_Ent
:= Make_Defining_Identifier
(Loc
, Chars
=> Name_Find
);
1639 Set_Elaboration_Entity
(Spec_Id
, Elab_Ent
);
1642 Make_Object_Declaration
(Loc
,
1643 Defining_Identifier
=> Elab_Ent
,
1644 Object_Definition
=>
1645 New_Occurrence_Of
(Standard_Short_Integer
, Loc
),
1646 Expression
=> Make_Integer_Literal
(Loc
, Uint_0
));
1648 Push_Scope
(Standard_Standard
);
1649 Add_Global_Declaration
(Decl
);
1652 -- Reset True_Constant indication, since we will indeed assign a value
1653 -- to the variable in the binder main. We also kill the Current_Value
1654 -- and Last_Assignment fields for the same reason.
1656 Set_Is_True_Constant
(Elab_Ent
, False);
1657 Set_Current_Value
(Elab_Ent
, Empty
);
1658 Set_Last_Assignment
(Elab_Ent
, Empty
);
1660 -- We do not want any further qualification of the name (if we did not
1661 -- do this, we would pick up the name of the generic package in the case
1662 -- of a library level generic instantiation).
1664 Set_Has_Qualified_Name
(Elab_Ent
);
1665 Set_Has_Fully_Qualified_Name
(Elab_Ent
);
1666 end Build_Elaboration_Entity
;
1668 --------------------------------
1669 -- Build_Explicit_Dereference --
1670 --------------------------------
1672 procedure Build_Explicit_Dereference
1676 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
1681 -- An entity of a type with a reference aspect is overloaded with
1682 -- both interpretations: with and without the dereference. Now that
1683 -- the dereference is made explicit, set the type of the node properly,
1684 -- to prevent anomalies in the backend. Same if the expression is an
1685 -- overloaded function call whose return type has a reference aspect.
1687 if Is_Entity_Name
(Expr
) then
1688 Set_Etype
(Expr
, Etype
(Entity
(Expr
)));
1690 -- The designated entity will not be examined again when resolving
1691 -- the dereference, so generate a reference to it now.
1693 Generate_Reference
(Entity
(Expr
), Expr
);
1695 elsif Nkind
(Expr
) = N_Function_Call
then
1697 -- If the name of the indexing function is overloaded, locate the one
1698 -- whose return type has an implicit dereference on the desired
1699 -- discriminant, and set entity and type of function call.
1701 if Is_Overloaded
(Name
(Expr
)) then
1702 Get_First_Interp
(Name
(Expr
), I
, It
);
1704 while Present
(It
.Nam
) loop
1705 if Ekind
((It
.Typ
)) = E_Record_Type
1706 and then First_Entity
((It
.Typ
)) = Disc
1708 Set_Entity
(Name
(Expr
), It
.Nam
);
1709 Set_Etype
(Name
(Expr
), Etype
(It
.Nam
));
1713 Get_Next_Interp
(I
, It
);
1717 -- Set type of call from resolved function name.
1719 Set_Etype
(Expr
, Etype
(Name
(Expr
)));
1722 Set_Is_Overloaded
(Expr
, False);
1724 -- The expression will often be a generalized indexing that yields a
1725 -- container element that is then dereferenced, in which case the
1726 -- generalized indexing call is also non-overloaded.
1728 if Nkind
(Expr
) = N_Indexed_Component
1729 and then Present
(Generalized_Indexing
(Expr
))
1731 Set_Is_Overloaded
(Generalized_Indexing
(Expr
), False);
1735 Make_Explicit_Dereference
(Loc
,
1737 Make_Selected_Component
(Loc
,
1738 Prefix
=> Relocate_Node
(Expr
),
1739 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
))));
1740 Set_Etype
(Prefix
(Expr
), Etype
(Disc
));
1741 Set_Etype
(Expr
, Designated_Type
(Etype
(Disc
)));
1742 end Build_Explicit_Dereference
;
1744 ---------------------------
1745 -- Build_Overriding_Spec --
1746 ---------------------------
1748 function Build_Overriding_Spec
1750 Typ
: Entity_Id
) return Node_Id
1752 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
1753 Par_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Op
);
1754 Spec
: constant Node_Id
:= Specification
(Unit_Declaration_Node
(Op
));
1756 Formal_Spec
: Node_Id
;
1757 Formal_Type
: Node_Id
;
1761 New_Spec
:= Copy_Subprogram_Spec
(Spec
);
1763 Formal_Spec
:= First
(Parameter_Specifications
(New_Spec
));
1764 while Present
(Formal_Spec
) loop
1765 Formal_Type
:= Parameter_Type
(Formal_Spec
);
1767 if Is_Entity_Name
(Formal_Type
)
1768 and then Entity
(Formal_Type
) = Par_Typ
1770 Rewrite
(Formal_Type
, New_Occurrence_Of
(Typ
, Loc
));
1773 -- Nothing needs to be done for access parameters
1779 end Build_Overriding_Spec
;
1781 -----------------------------------
1782 -- Cannot_Raise_Constraint_Error --
1783 -----------------------------------
1785 function Cannot_Raise_Constraint_Error
(Expr
: Node_Id
) return Boolean is
1787 if Compile_Time_Known_Value
(Expr
) then
1790 elsif Do_Range_Check
(Expr
) then
1793 elsif Raises_Constraint_Error
(Expr
) then
1797 case Nkind
(Expr
) is
1798 when N_Identifier
=>
1801 when N_Expanded_Name
=>
1804 when N_Selected_Component
=>
1805 return not Do_Discriminant_Check
(Expr
);
1807 when N_Attribute_Reference
=>
1808 if Do_Overflow_Check
(Expr
) then
1811 elsif No
(Expressions
(Expr
)) then
1819 N
:= First
(Expressions
(Expr
));
1820 while Present
(N
) loop
1821 if Cannot_Raise_Constraint_Error
(N
) then
1832 when N_Type_Conversion
=>
1833 if Do_Overflow_Check
(Expr
)
1834 or else Do_Length_Check
(Expr
)
1835 or else Do_Tag_Check
(Expr
)
1839 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
1842 when N_Unchecked_Type_Conversion
=>
1843 return Cannot_Raise_Constraint_Error
(Expression
(Expr
));
1846 if Do_Overflow_Check
(Expr
) then
1849 return Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
1856 if Do_Division_Check
(Expr
)
1858 Do_Overflow_Check
(Expr
)
1863 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
1865 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
1884 | N_Op_Shift_Right_Arithmetic
1888 if Do_Overflow_Check
(Expr
) then
1892 Cannot_Raise_Constraint_Error
(Left_Opnd
(Expr
))
1894 Cannot_Raise_Constraint_Error
(Right_Opnd
(Expr
));
1901 end Cannot_Raise_Constraint_Error
;
1903 -----------------------------
1904 -- Check_Part_Of_Reference --
1905 -----------------------------
1907 procedure Check_Part_Of_Reference
(Var_Id
: Entity_Id
; Ref
: Node_Id
) is
1908 Conc_Typ
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
1910 OK_Use
: Boolean := False;
1913 Spec_Id
: Entity_Id
;
1916 -- Traverse the parent chain looking for a suitable context for the
1917 -- reference to the concurrent constituent.
1919 Par
:= Parent
(Ref
);
1920 while Present
(Par
) loop
1921 if Nkind
(Par
) = N_Pragma
then
1922 Prag_Nam
:= Pragma_Name
(Par
);
1924 -- A concurrent constituent is allowed to appear in pragmas
1925 -- Initial_Condition and Initializes as this is part of the
1926 -- elaboration checks for the constituent (SPARK RM 9.3).
1928 if Nam_In
(Prag_Nam
, Name_Initial_Condition
, Name_Initializes
) then
1932 -- When the reference appears within pragma Depends or Global,
1933 -- check whether the pragma applies to a single task type. Note
1934 -- that the pragma is not encapsulated by the type definition,
1935 -- but this is still a valid context.
1937 elsif Nam_In
(Prag_Nam
, Name_Depends
, Name_Global
) then
1938 Decl
:= Find_Related_Declaration_Or_Body
(Par
);
1940 if Nkind
(Decl
) = N_Object_Declaration
1941 and then Defining_Entity
(Decl
) = Conc_Typ
1948 -- The reference appears somewhere in the definition of the single
1949 -- protected/task type (SPARK RM 9.3).
1951 elsif Nkind_In
(Par
, N_Single_Protected_Declaration
,
1952 N_Single_Task_Declaration
)
1953 and then Defining_Entity
(Par
) = Conc_Typ
1958 -- The reference appears within the expanded declaration or the body
1959 -- of the single protected/task type (SPARK RM 9.3).
1961 elsif Nkind_In
(Par
, N_Protected_Body
,
1962 N_Protected_Type_Declaration
,
1964 N_Task_Type_Declaration
)
1966 Spec_Id
:= Unique_Defining_Entity
(Par
);
1968 if Present
(Anonymous_Object
(Spec_Id
))
1969 and then Anonymous_Object
(Spec_Id
) = Conc_Typ
1975 -- The reference has been relocated within an internally generated
1976 -- package or subprogram. Assume that the reference is legal as the
1977 -- real check was already performed in the original context of the
1980 elsif Nkind_In
(Par
, N_Package_Body
,
1981 N_Package_Declaration
,
1983 N_Subprogram_Declaration
)
1984 and then not Comes_From_Source
(Par
)
1986 -- Continue to examine the context if the reference appears in a
1987 -- subprogram body which was previously an expression function.
1989 if Nkind
(Par
) = N_Subprogram_Body
1990 and then Was_Expression_Function
(Par
)
1994 -- Otherwise the reference is legal
2001 -- The reference has been relocated to an inlined body for GNATprove.
2002 -- Assume that the reference is legal as the real check was already
2003 -- performed in the original context of the reference.
2005 elsif GNATprove_Mode
2006 and then Nkind
(Par
) = N_Subprogram_Body
2007 and then Chars
(Defining_Entity
(Par
)) = Name_uParent
2013 Par
:= Parent
(Par
);
2016 -- The reference is illegal as it appears outside the definition or
2017 -- body of the single protected/task type.
2021 ("reference to variable & cannot appear in this context",
2023 Error_Msg_Name_1
:= Chars
(Var_Id
);
2025 if Ekind
(Conc_Typ
) = E_Protected_Type
then
2027 ("\% is constituent of single protected type &", Ref
, Conc_Typ
);
2030 ("\% is constituent of single task type &", Ref
, Conc_Typ
);
2033 end Check_Part_Of_Reference
;
2035 -----------------------------------------
2036 -- Check_Dynamically_Tagged_Expression --
2037 -----------------------------------------
2039 procedure Check_Dynamically_Tagged_Expression
2042 Related_Nod
: Node_Id
)
2045 pragma Assert
(Is_Tagged_Type
(Typ
));
2047 -- In order to avoid spurious errors when analyzing the expanded code,
2048 -- this check is done only for nodes that come from source and for
2049 -- actuals of generic instantiations.
2051 if (Comes_From_Source
(Related_Nod
)
2052 or else In_Generic_Actual
(Expr
))
2053 and then (Is_Class_Wide_Type
(Etype
(Expr
))
2054 or else Is_Dynamically_Tagged
(Expr
))
2055 and then Is_Tagged_Type
(Typ
)
2056 and then not Is_Class_Wide_Type
(Typ
)
2058 Error_Msg_N
("dynamically tagged expression not allowed!", Expr
);
2060 end Check_Dynamically_Tagged_Expression
;
2062 --------------------------
2063 -- Check_Fully_Declared --
2064 --------------------------
2066 procedure Check_Fully_Declared
(T
: Entity_Id
; N
: Node_Id
) is
2068 if Ekind
(T
) = E_Incomplete_Type
then
2070 -- Ada 2005 (AI-50217): If the type is available through a limited
2071 -- with_clause, verify that its full view has been analyzed.
2073 if From_Limited_With
(T
)
2074 and then Present
(Non_Limited_View
(T
))
2075 and then Ekind
(Non_Limited_View
(T
)) /= E_Incomplete_Type
2077 -- The non-limited view is fully declared
2083 ("premature usage of incomplete}", N
, First_Subtype
(T
));
2086 -- Need comments for these tests ???
2088 elsif Has_Private_Component
(T
)
2089 and then not Is_Generic_Type
(Root_Type
(T
))
2090 and then not In_Spec_Expression
2092 -- Special case: if T is the anonymous type created for a single
2093 -- task or protected object, use the name of the source object.
2095 if Is_Concurrent_Type
(T
)
2096 and then not Comes_From_Source
(T
)
2097 and then Nkind
(N
) = N_Object_Declaration
2100 ("type of& has incomplete component",
2101 N
, Defining_Identifier
(N
));
2104 ("premature usage of incomplete}",
2105 N
, First_Subtype
(T
));
2108 end Check_Fully_Declared
;
2110 -------------------------------------------
2111 -- Check_Function_With_Address_Parameter --
2112 -------------------------------------------
2114 procedure Check_Function_With_Address_Parameter
(Subp_Id
: Entity_Id
) is
2119 F
:= First_Formal
(Subp_Id
);
2120 while Present
(F
) loop
2123 if Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
2127 if Is_Descendant_Of_Address
(T
) or else Is_Limited_Type
(T
) then
2128 Set_Is_Pure
(Subp_Id
, False);
2134 end Check_Function_With_Address_Parameter
;
2136 -------------------------------------
2137 -- Check_Function_Writable_Actuals --
2138 -------------------------------------
2140 procedure Check_Function_Writable_Actuals
(N
: Node_Id
) is
2141 Writable_Actuals_List
: Elist_Id
:= No_Elist
;
2142 Identifiers_List
: Elist_Id
:= No_Elist
;
2143 Aggr_Error_Node
: Node_Id
:= Empty
;
2144 Error_Node
: Node_Id
:= Empty
;
2146 procedure Collect_Identifiers
(N
: Node_Id
);
2147 -- In a single traversal of subtree N collect in Writable_Actuals_List
2148 -- all the actuals of functions with writable actuals, and in the list
2149 -- Identifiers_List collect all the identifiers that are not actuals of
2150 -- functions with writable actuals. If a writable actual is referenced
2151 -- twice as writable actual then Error_Node is set to reference its
2152 -- second occurrence, the error is reported, and the tree traversal
2155 function Get_Function_Id
(Call
: Node_Id
) return Entity_Id
;
2156 -- Return the entity associated with the function call
2158 procedure Preanalyze_Without_Errors
(N
: Node_Id
);
2159 -- Preanalyze N without reporting errors. Very dubious, you can't just
2160 -- go analyzing things more than once???
2162 -------------------------
2163 -- Collect_Identifiers --
2164 -------------------------
2166 procedure Collect_Identifiers
(N
: Node_Id
) is
2168 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
2169 -- Process a single node during the tree traversal to collect the
2170 -- writable actuals of functions and all the identifiers which are
2171 -- not writable actuals of functions.
2173 function Contains
(List
: Elist_Id
; N
: Node_Id
) return Boolean;
2174 -- Returns True if List has a node whose Entity is Entity (N)
2180 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
2181 Is_Writable_Actual
: Boolean := False;
2185 if Nkind
(N
) = N_Identifier
then
2187 -- No analysis possible if the entity is not decorated
2189 if No
(Entity
(N
)) then
2192 -- Don't collect identifiers of packages, called functions, etc
2194 elsif Ekind_In
(Entity
(N
), E_Package
,
2201 -- For rewritten nodes, continue the traversal in the original
2202 -- subtree. Needed to handle aggregates in original expressions
2203 -- extracted from the tree by Remove_Side_Effects.
2205 elsif Is_Rewrite_Substitution
(N
) then
2206 Collect_Identifiers
(Original_Node
(N
));
2209 -- For now we skip aggregate discriminants, since they require
2210 -- performing the analysis in two phases to identify conflicts:
2211 -- first one analyzing discriminants and second one analyzing
2212 -- the rest of components (since at run time, discriminants are
2213 -- evaluated prior to components): too much computation cost
2214 -- to identify a corner case???
2216 elsif Nkind
(Parent
(N
)) = N_Component_Association
2217 and then Nkind_In
(Parent
(Parent
(N
)),
2219 N_Extension_Aggregate
)
2222 Choice
: constant Node_Id
:= First
(Choices
(Parent
(N
)));
2225 if Ekind
(Entity
(N
)) = E_Discriminant
then
2228 elsif Expression
(Parent
(N
)) = N
2229 and then Nkind
(Choice
) = N_Identifier
2230 and then Ekind
(Entity
(Choice
)) = E_Discriminant
2236 -- Analyze if N is a writable actual of a function
2238 elsif Nkind
(Parent
(N
)) = N_Function_Call
then
2240 Call
: constant Node_Id
:= Parent
(N
);
2245 Id
:= Get_Function_Id
(Call
);
2247 -- In case of previous error, no check is possible
2253 if Ekind_In
(Id
, E_Function
, E_Generic_Function
)
2254 and then Has_Out_Or_In_Out_Parameter
(Id
)
2256 Formal
:= First_Formal
(Id
);
2257 Actual
:= First_Actual
(Call
);
2258 while Present
(Actual
) and then Present
(Formal
) loop
2260 if Ekind_In
(Formal
, E_Out_Parameter
,
2263 Is_Writable_Actual
:= True;
2269 Next_Formal
(Formal
);
2270 Next_Actual
(Actual
);
2276 if Is_Writable_Actual
then
2278 -- Skip checking the error in non-elementary types since
2279 -- RM 6.4.1(6.15/3) is restricted to elementary types, but
2280 -- store this actual in Writable_Actuals_List since it is
2281 -- needed to perform checks on other constructs that have
2282 -- arbitrary order of evaluation (for example, aggregates).
2284 if not Is_Elementary_Type
(Etype
(N
)) then
2285 if not Contains
(Writable_Actuals_List
, N
) then
2286 Append_New_Elmt
(N
, To
=> Writable_Actuals_List
);
2289 -- Second occurrence of an elementary type writable actual
2291 elsif Contains
(Writable_Actuals_List
, N
) then
2293 -- Report the error on the second occurrence of the
2294 -- identifier. We cannot assume that N is the second
2295 -- occurrence (according to their location in the
2296 -- sources), since Traverse_Func walks through Field2
2297 -- last (see comment in the body of Traverse_Func).
2303 Elmt
:= First_Elmt
(Writable_Actuals_List
);
2304 while Present
(Elmt
)
2305 and then Entity
(Node
(Elmt
)) /= Entity
(N
)
2310 if Sloc
(N
) > Sloc
(Node
(Elmt
)) then
2313 Error_Node
:= Node
(Elmt
);
2317 ("value may be affected by call to & "
2318 & "because order of evaluation is arbitrary",
2323 -- First occurrence of a elementary type writable actual
2326 Append_New_Elmt
(N
, To
=> Writable_Actuals_List
);
2330 if Identifiers_List
= No_Elist
then
2331 Identifiers_List
:= New_Elmt_List
;
2334 Append_Unique_Elmt
(N
, Identifiers_List
);
2347 N
: Node_Id
) return Boolean
2349 pragma Assert
(Nkind
(N
) in N_Has_Entity
);
2354 if List
= No_Elist
then
2358 Elmt
:= First_Elmt
(List
);
2359 while Present
(Elmt
) loop
2360 if Entity
(Node
(Elmt
)) = Entity
(N
) then
2374 procedure Do_Traversal
is new Traverse_Proc
(Check_Node
);
2375 -- The traversal procedure
2377 -- Start of processing for Collect_Identifiers
2380 if Present
(Error_Node
) then
2384 if Nkind
(N
) in N_Subexpr
and then Is_OK_Static_Expression
(N
) then
2389 end Collect_Identifiers
;
2391 ---------------------
2392 -- Get_Function_Id --
2393 ---------------------
2395 function Get_Function_Id
(Call
: Node_Id
) return Entity_Id
is
2396 Nam
: constant Node_Id
:= Name
(Call
);
2400 if Nkind
(Nam
) = N_Explicit_Dereference
then
2402 pragma Assert
(Ekind
(Id
) = E_Subprogram_Type
);
2404 elsif Nkind
(Nam
) = N_Selected_Component
then
2405 Id
:= Entity
(Selector_Name
(Nam
));
2407 elsif Nkind
(Nam
) = N_Indexed_Component
then
2408 Id
:= Entity
(Selector_Name
(Prefix
(Nam
)));
2415 end Get_Function_Id
;
2417 -------------------------------
2418 -- Preanalyze_Without_Errors --
2419 -------------------------------
2421 procedure Preanalyze_Without_Errors
(N
: Node_Id
) is
2422 Status
: constant Boolean := Get_Ignore_Errors
;
2424 Set_Ignore_Errors
(True);
2426 Set_Ignore_Errors
(Status
);
2427 end Preanalyze_Without_Errors
;
2429 -- Start of processing for Check_Function_Writable_Actuals
2432 -- The check only applies to Ada 2012 code on which Check_Actuals has
2433 -- been set, and only to constructs that have multiple constituents
2434 -- whose order of evaluation is not specified by the language.
2436 if Ada_Version
< Ada_2012
2437 or else not Check_Actuals
(N
)
2438 or else (not (Nkind
(N
) in N_Op
)
2439 and then not (Nkind
(N
) in N_Membership_Test
)
2440 and then not Nkind_In
(N
, N_Range
,
2442 N_Extension_Aggregate
,
2443 N_Full_Type_Declaration
,
2445 N_Procedure_Call_Statement
,
2446 N_Entry_Call_Statement
))
2447 or else (Nkind
(N
) = N_Full_Type_Declaration
2448 and then not Is_Record_Type
(Defining_Identifier
(N
)))
2450 -- In addition, this check only applies to source code, not to code
2451 -- generated by constraint checks.
2453 or else not Comes_From_Source
(N
)
2458 -- If a construct C has two or more direct constituents that are names
2459 -- or expressions whose evaluation may occur in an arbitrary order, at
2460 -- least one of which contains a function call with an in out or out
2461 -- parameter, then the construct is legal only if: for each name N that
2462 -- is passed as a parameter of mode in out or out to some inner function
2463 -- call C2 (not including the construct C itself), there is no other
2464 -- name anywhere within a direct constituent of the construct C other
2465 -- than the one containing C2, that is known to refer to the same
2466 -- object (RM 6.4.1(6.17/3)).
2470 Collect_Identifiers
(Low_Bound
(N
));
2471 Collect_Identifiers
(High_Bound
(N
));
2473 when N_Membership_Test
2480 Collect_Identifiers
(Left_Opnd
(N
));
2482 if Present
(Right_Opnd
(N
)) then
2483 Collect_Identifiers
(Right_Opnd
(N
));
2486 if Nkind_In
(N
, N_In
, N_Not_In
)
2487 and then Present
(Alternatives
(N
))
2489 Expr
:= First
(Alternatives
(N
));
2490 while Present
(Expr
) loop
2491 Collect_Identifiers
(Expr
);
2498 when N_Full_Type_Declaration
=>
2500 function Get_Record_Part
(N
: Node_Id
) return Node_Id
;
2501 -- Return the record part of this record type definition
2503 function Get_Record_Part
(N
: Node_Id
) return Node_Id
is
2504 Type_Def
: constant Node_Id
:= Type_Definition
(N
);
2506 if Nkind
(Type_Def
) = N_Derived_Type_Definition
then
2507 return Record_Extension_Part
(Type_Def
);
2511 end Get_Record_Part
;
2514 Def_Id
: Entity_Id
:= Defining_Identifier
(N
);
2515 Rec
: Node_Id
:= Get_Record_Part
(N
);
2518 -- No need to perform any analysis if the record has no
2521 if No
(Rec
) or else No
(Component_List
(Rec
)) then
2525 -- Collect the identifiers starting from the deepest
2526 -- derivation. Done to report the error in the deepest
2530 if Present
(Component_List
(Rec
)) then
2531 Comp
:= First
(Component_Items
(Component_List
(Rec
)));
2532 while Present
(Comp
) loop
2533 if Nkind
(Comp
) = N_Component_Declaration
2534 and then Present
(Expression
(Comp
))
2536 Collect_Identifiers
(Expression
(Comp
));
2543 exit when No
(Underlying_Type
(Etype
(Def_Id
)))
2544 or else Base_Type
(Underlying_Type
(Etype
(Def_Id
)))
2547 Def_Id
:= Base_Type
(Underlying_Type
(Etype
(Def_Id
)));
2548 Rec
:= Get_Record_Part
(Parent
(Def_Id
));
2552 when N_Entry_Call_Statement
2556 Id
: constant Entity_Id
:= Get_Function_Id
(N
);
2561 Formal
:= First_Formal
(Id
);
2562 Actual
:= First_Actual
(N
);
2563 while Present
(Actual
) and then Present
(Formal
) loop
2564 if Ekind_In
(Formal
, E_Out_Parameter
,
2567 Collect_Identifiers
(Actual
);
2570 Next_Formal
(Formal
);
2571 Next_Actual
(Actual
);
2576 | N_Extension_Aggregate
2581 Comp_Expr
: Node_Id
;
2584 -- Handle the N_Others_Choice of array aggregates with static
2585 -- bounds. There is no need to perform this analysis in
2586 -- aggregates without static bounds since we cannot evaluate
2587 -- if the N_Others_Choice covers several elements. There is
2588 -- no need to handle the N_Others choice of record aggregates
2589 -- since at this stage it has been already expanded by
2590 -- Resolve_Record_Aggregate.
2592 if Is_Array_Type
(Etype
(N
))
2593 and then Nkind
(N
) = N_Aggregate
2594 and then Present
(Aggregate_Bounds
(N
))
2595 and then Compile_Time_Known_Bounds
(Etype
(N
))
2596 and then Expr_Value
(High_Bound
(Aggregate_Bounds
(N
)))
2598 Expr_Value
(Low_Bound
(Aggregate_Bounds
(N
)))
2601 Count_Components
: Uint
:= Uint_0
;
2602 Num_Components
: Uint
;
2603 Others_Assoc
: Node_Id
;
2604 Others_Choice
: Node_Id
:= Empty
;
2605 Others_Box_Present
: Boolean := False;
2608 -- Count positional associations
2610 if Present
(Expressions
(N
)) then
2611 Comp_Expr
:= First
(Expressions
(N
));
2612 while Present
(Comp_Expr
) loop
2613 Count_Components
:= Count_Components
+ 1;
2618 -- Count the rest of elements and locate the N_Others
2621 Assoc
:= First
(Component_Associations
(N
));
2622 while Present
(Assoc
) loop
2623 Choice
:= First
(Choices
(Assoc
));
2624 while Present
(Choice
) loop
2625 if Nkind
(Choice
) = N_Others_Choice
then
2626 Others_Assoc
:= Assoc
;
2627 Others_Choice
:= Choice
;
2628 Others_Box_Present
:= Box_Present
(Assoc
);
2630 -- Count several components
2632 elsif Nkind_In
(Choice
, N_Range
,
2633 N_Subtype_Indication
)
2634 or else (Is_Entity_Name
(Choice
)
2635 and then Is_Type
(Entity
(Choice
)))
2640 Get_Index_Bounds
(Choice
, L
, H
);
2642 (Compile_Time_Known_Value
(L
)
2643 and then Compile_Time_Known_Value
(H
));
2646 + Expr_Value
(H
) - Expr_Value
(L
) + 1;
2649 -- Count single component. No other case available
2650 -- since we are handling an aggregate with static
2654 pragma Assert
(Is_OK_Static_Expression
(Choice
)
2655 or else Nkind
(Choice
) = N_Identifier
2656 or else Nkind
(Choice
) = N_Integer_Literal
);
2658 Count_Components
:= Count_Components
+ 1;
2668 Expr_Value
(High_Bound
(Aggregate_Bounds
(N
))) -
2669 Expr_Value
(Low_Bound
(Aggregate_Bounds
(N
))) + 1;
2671 pragma Assert
(Count_Components
<= Num_Components
);
2673 -- Handle the N_Others choice if it covers several
2676 if Present
(Others_Choice
)
2677 and then (Num_Components
- Count_Components
) > 1
2679 if not Others_Box_Present
then
2681 -- At this stage, if expansion is active, the
2682 -- expression of the others choice has not been
2683 -- analyzed. Hence we generate a duplicate and
2684 -- we analyze it silently to have available the
2685 -- minimum decoration required to collect the
2688 if not Expander_Active
then
2689 Comp_Expr
:= Expression
(Others_Assoc
);
2692 New_Copy_Tree
(Expression
(Others_Assoc
));
2693 Preanalyze_Without_Errors
(Comp_Expr
);
2696 Collect_Identifiers
(Comp_Expr
);
2698 if Writable_Actuals_List
/= No_Elist
then
2700 -- As suggested by Robert, at current stage we
2701 -- report occurrences of this case as warnings.
2704 ("writable function parameter may affect "
2705 & "value in other component because order "
2706 & "of evaluation is unspecified??",
2707 Node
(First_Elmt
(Writable_Actuals_List
)));
2713 -- For an array aggregate, a discrete_choice_list that has
2714 -- a nonstatic range is considered as two or more separate
2715 -- occurrences of the expression (RM 6.4.1(20/3)).
2717 elsif Is_Array_Type
(Etype
(N
))
2718 and then Nkind
(N
) = N_Aggregate
2719 and then Present
(Aggregate_Bounds
(N
))
2720 and then not Compile_Time_Known_Bounds
(Etype
(N
))
2722 -- Collect identifiers found in the dynamic bounds
2725 Count_Components
: Natural := 0;
2726 Low
, High
: Node_Id
;
2729 Assoc
:= First
(Component_Associations
(N
));
2730 while Present
(Assoc
) loop
2731 Choice
:= First
(Choices
(Assoc
));
2732 while Present
(Choice
) loop
2733 if Nkind_In
(Choice
, N_Range
,
2734 N_Subtype_Indication
)
2735 or else (Is_Entity_Name
(Choice
)
2736 and then Is_Type
(Entity
(Choice
)))
2738 Get_Index_Bounds
(Choice
, Low
, High
);
2740 if not Compile_Time_Known_Value
(Low
) then
2741 Collect_Identifiers
(Low
);
2743 if No
(Aggr_Error_Node
) then
2744 Aggr_Error_Node
:= Low
;
2748 if not Compile_Time_Known_Value
(High
) then
2749 Collect_Identifiers
(High
);
2751 if No
(Aggr_Error_Node
) then
2752 Aggr_Error_Node
:= High
;
2756 -- The RM rule is violated if there is more than
2757 -- a single choice in a component association.
2760 Count_Components
:= Count_Components
+ 1;
2762 if No
(Aggr_Error_Node
)
2763 and then Count_Components
> 1
2765 Aggr_Error_Node
:= Choice
;
2768 if not Compile_Time_Known_Value
(Choice
) then
2769 Collect_Identifiers
(Choice
);
2781 -- Handle ancestor part of extension aggregates
2783 if Nkind
(N
) = N_Extension_Aggregate
then
2784 Collect_Identifiers
(Ancestor_Part
(N
));
2787 -- Handle positional associations
2789 if Present
(Expressions
(N
)) then
2790 Comp_Expr
:= First
(Expressions
(N
));
2791 while Present
(Comp_Expr
) loop
2792 if not Is_OK_Static_Expression
(Comp_Expr
) then
2793 Collect_Identifiers
(Comp_Expr
);
2800 -- Handle discrete associations
2802 if Present
(Component_Associations
(N
)) then
2803 Assoc
:= First
(Component_Associations
(N
));
2804 while Present
(Assoc
) loop
2806 if not Box_Present
(Assoc
) then
2807 Choice
:= First
(Choices
(Assoc
));
2808 while Present
(Choice
) loop
2810 -- For now we skip discriminants since it requires
2811 -- performing the analysis in two phases: first one
2812 -- analyzing discriminants and second one analyzing
2813 -- the rest of components since discriminants are
2814 -- evaluated prior to components: too much extra
2815 -- work to detect a corner case???
2817 if Nkind
(Choice
) in N_Has_Entity
2818 and then Present
(Entity
(Choice
))
2819 and then Ekind
(Entity
(Choice
)) = E_Discriminant
2823 elsif Box_Present
(Assoc
) then
2827 if not Analyzed
(Expression
(Assoc
)) then
2829 New_Copy_Tree
(Expression
(Assoc
));
2830 Set_Parent
(Comp_Expr
, Parent
(N
));
2831 Preanalyze_Without_Errors
(Comp_Expr
);
2833 Comp_Expr
:= Expression
(Assoc
);
2836 Collect_Identifiers
(Comp_Expr
);
2852 -- No further action needed if we already reported an error
2854 if Present
(Error_Node
) then
2858 -- Check violation of RM 6.20/3 in aggregates
2860 if Present
(Aggr_Error_Node
)
2861 and then Writable_Actuals_List
/= No_Elist
2864 ("value may be affected by call in other component because they "
2865 & "are evaluated in unspecified order",
2866 Node
(First_Elmt
(Writable_Actuals_List
)));
2870 -- Check if some writable argument of a function is referenced
2872 if Writable_Actuals_List
/= No_Elist
2873 and then Identifiers_List
/= No_Elist
2880 Elmt_1
:= First_Elmt
(Writable_Actuals_List
);
2881 while Present
(Elmt_1
) loop
2882 Elmt_2
:= First_Elmt
(Identifiers_List
);
2883 while Present
(Elmt_2
) loop
2884 if Entity
(Node
(Elmt_1
)) = Entity
(Node
(Elmt_2
)) then
2885 case Nkind
(Parent
(Node
(Elmt_2
))) is
2887 | N_Component_Association
2888 | N_Component_Declaration
2891 ("value may be affected by call in other "
2892 & "component because they are evaluated "
2893 & "in unspecified order",
2900 ("value may be affected by call in other "
2901 & "alternative because they are evaluated "
2902 & "in unspecified order",
2907 ("value of actual may be affected by call in "
2908 & "other actual because they are evaluated "
2909 & "in unspecified order",
2921 end Check_Function_Writable_Actuals
;
2923 --------------------------------
2924 -- Check_Implicit_Dereference --
2925 --------------------------------
2927 procedure Check_Implicit_Dereference
(N
: Node_Id
; Typ
: Entity_Id
) is
2933 if Nkind
(N
) = N_Indexed_Component
2934 and then Present
(Generalized_Indexing
(N
))
2936 Nam
:= Generalized_Indexing
(N
);
2941 if Ada_Version
< Ada_2012
2942 or else not Has_Implicit_Dereference
(Base_Type
(Typ
))
2946 elsif not Comes_From_Source
(N
)
2947 and then Nkind
(N
) /= N_Indexed_Component
2951 elsif Is_Entity_Name
(Nam
) and then Is_Type
(Entity
(Nam
)) then
2955 Disc
:= First_Discriminant
(Typ
);
2956 while Present
(Disc
) loop
2957 if Has_Implicit_Dereference
(Disc
) then
2958 Desig
:= Designated_Type
(Etype
(Disc
));
2959 Add_One_Interp
(Nam
, Disc
, Desig
);
2961 -- If the node is a generalized indexing, add interpretation
2962 -- to that node as well, for subsequent resolution.
2964 if Nkind
(N
) = N_Indexed_Component
then
2965 Add_One_Interp
(N
, Disc
, Desig
);
2968 -- If the operation comes from a generic unit and the context
2969 -- is a selected component, the selector name may be global
2970 -- and set in the instance already. Remove the entity to
2971 -- force resolution of the selected component, and the
2972 -- generation of an explicit dereference if needed.
2975 and then Nkind
(Parent
(Nam
)) = N_Selected_Component
2977 Set_Entity
(Selector_Name
(Parent
(Nam
)), Empty
);
2983 Next_Discriminant
(Disc
);
2986 end Check_Implicit_Dereference
;
2988 ----------------------------------
2989 -- Check_Internal_Protected_Use --
2990 ----------------------------------
2992 procedure Check_Internal_Protected_Use
(N
: Node_Id
; Nam
: Entity_Id
) is
3000 while Present
(S
) loop
3001 if S
= Standard_Standard
then
3004 elsif Ekind
(S
) = E_Function
3005 and then Ekind
(Scope
(S
)) = E_Protected_Type
3015 and then Scope
(Nam
) = Prot
3016 and then Ekind
(Nam
) /= E_Function
3018 -- An indirect function call (e.g. a callback within a protected
3019 -- function body) is not statically illegal. If the access type is
3020 -- anonymous and is the type of an access parameter, the scope of Nam
3021 -- will be the protected type, but it is not a protected operation.
3023 if Ekind
(Nam
) = E_Subprogram_Type
3024 and then Nkind
(Associated_Node_For_Itype
(Nam
)) =
3025 N_Function_Specification
3029 elsif Nkind
(N
) = N_Subprogram_Renaming_Declaration
then
3031 ("within protected function cannot use protected procedure in "
3032 & "renaming or as generic actual", N
);
3034 elsif Nkind
(N
) = N_Attribute_Reference
then
3036 ("within protected function cannot take access of protected "
3041 ("within protected function, protected object is constant", N
);
3043 ("\cannot call operation that may modify it", N
);
3047 -- Verify that an internal call does not appear within a precondition
3048 -- of a protected operation. This implements AI12-0166.
3049 -- The precondition aspect has been rewritten as a pragma Precondition
3050 -- and we check whether the scope of the called subprogram is the same
3051 -- as that of the entity to which the aspect applies.
3053 if Convention
(Nam
) = Convention_Protected
then
3059 while Present
(P
) loop
3060 if Nkind
(P
) = N_Pragma
3061 and then Chars
(Pragma_Identifier
(P
)) = Name_Precondition
3062 and then From_Aspect_Specification
(P
)
3064 Scope
(Entity
(Corresponding_Aspect
(P
))) = Scope
(Nam
)
3067 ("internal call cannot appear in precondition of "
3068 & "protected operation", N
);
3071 elsif Nkind
(P
) = N_Pragma
3072 and then Chars
(Pragma_Identifier
(P
)) = Name_Contract_Cases
3074 -- Check whether call is in a case guard. It is legal in a
3078 while Present
(P
) loop
3079 if Nkind
(Parent
(P
)) = N_Component_Association
3080 and then P
/= Expression
(Parent
(P
))
3083 ("internal call cannot appear in case guard in a "
3084 & "contract case", N
);
3092 elsif Nkind
(P
) = N_Parameter_Specification
3093 and then Scope
(Current_Scope
) = Scope
(Nam
)
3094 and then Nkind_In
(Parent
(P
), N_Entry_Declaration
,
3095 N_Subprogram_Declaration
)
3098 ("internal call cannot appear in default for formal of "
3099 & "protected operation", N
);
3107 end Check_Internal_Protected_Use
;
3109 ---------------------------------------
3110 -- Check_Later_Vs_Basic_Declarations --
3111 ---------------------------------------
3113 procedure Check_Later_Vs_Basic_Declarations
3115 During_Parsing
: Boolean)
3117 Body_Sloc
: Source_Ptr
;
3120 function Is_Later_Declarative_Item
(Decl
: Node_Id
) return Boolean;
3121 -- Return whether Decl is considered as a declarative item.
3122 -- When During_Parsing is True, the semantics of Ada 83 is followed.
3123 -- When During_Parsing is False, the semantics of SPARK is followed.
3125 -------------------------------
3126 -- Is_Later_Declarative_Item --
3127 -------------------------------
3129 function Is_Later_Declarative_Item
(Decl
: Node_Id
) return Boolean is
3131 if Nkind
(Decl
) in N_Later_Decl_Item
then
3134 elsif Nkind
(Decl
) = N_Pragma
then
3137 elsif During_Parsing
then
3140 -- In SPARK, a package declaration is not considered as a later
3141 -- declarative item.
3143 elsif Nkind
(Decl
) = N_Package_Declaration
then
3146 -- In SPARK, a renaming is considered as a later declarative item
3148 elsif Nkind
(Decl
) in N_Renaming_Declaration
then
3154 end Is_Later_Declarative_Item
;
3156 -- Start of processing for Check_Later_Vs_Basic_Declarations
3159 Decl
:= First
(Decls
);
3161 -- Loop through sequence of basic declarative items
3163 Outer
: while Present
(Decl
) loop
3164 if not Nkind_In
(Decl
, N_Subprogram_Body
, N_Package_Body
, N_Task_Body
)
3165 and then Nkind
(Decl
) not in N_Body_Stub
3169 -- Once a body is encountered, we only allow later declarative
3170 -- items. The inner loop checks the rest of the list.
3173 Body_Sloc
:= Sloc
(Decl
);
3175 Inner
: while Present
(Decl
) loop
3176 if not Is_Later_Declarative_Item
(Decl
) then
3177 if During_Parsing
then
3178 if Ada_Version
= Ada_83
then
3179 Error_Msg_Sloc
:= Body_Sloc
;
3181 ("(Ada 83) decl cannot appear after body#", Decl
);
3184 Error_Msg_Sloc
:= Body_Sloc
;
3185 Check_SPARK_05_Restriction
3186 ("decl cannot appear after body#", Decl
);
3194 end Check_Later_Vs_Basic_Declarations
;
3196 ---------------------------
3197 -- Check_No_Hidden_State --
3198 ---------------------------
3200 procedure Check_No_Hidden_State
(Id
: Entity_Id
) is
3201 function Has_Null_Abstract_State
(Pkg
: Entity_Id
) return Boolean;
3202 -- Determine whether the entity of a package denoted by Pkg has a null
3205 -----------------------------
3206 -- Has_Null_Abstract_State --
3207 -----------------------------
3209 function Has_Null_Abstract_State
(Pkg
: Entity_Id
) return Boolean is
3210 States
: constant Elist_Id
:= Abstract_States
(Pkg
);
3213 -- Check first available state of related package. A null abstract
3214 -- state always appears as the sole element of the state list.
3218 and then Is_Null_State
(Node
(First_Elmt
(States
)));
3219 end Has_Null_Abstract_State
;
3223 Context
: Entity_Id
:= Empty
;
3224 Not_Visible
: Boolean := False;
3227 -- Start of processing for Check_No_Hidden_State
3230 pragma Assert
(Ekind_In
(Id
, E_Abstract_State
, E_Variable
));
3232 -- Find the proper context where the object or state appears
3235 while Present
(Scop
) loop
3238 -- Keep track of the context's visibility
3240 Not_Visible
:= Not_Visible
or else In_Private_Part
(Context
);
3242 -- Prevent the search from going too far
3244 if Context
= Standard_Standard
then
3247 -- Objects and states that appear immediately within a subprogram or
3248 -- inside a construct nested within a subprogram do not introduce a
3249 -- hidden state. They behave as local variable declarations.
3251 elsif Is_Subprogram
(Context
) then
3254 -- When examining a package body, use the entity of the spec as it
3255 -- carries the abstract state declarations.
3257 elsif Ekind
(Context
) = E_Package_Body
then
3258 Context
:= Spec_Entity
(Context
);
3261 -- Stop the traversal when a package subject to a null abstract state
3264 if Ekind_In
(Context
, E_Generic_Package
, E_Package
)
3265 and then Has_Null_Abstract_State
(Context
)
3270 Scop
:= Scope
(Scop
);
3273 -- At this point we know that there is at least one package with a null
3274 -- abstract state in visibility. Emit an error message unconditionally
3275 -- if the entity being processed is a state because the placement of the
3276 -- related package is irrelevant. This is not the case for objects as
3277 -- the intermediate context matters.
3279 if Present
(Context
)
3280 and then (Ekind
(Id
) = E_Abstract_State
or else Not_Visible
)
3282 Error_Msg_N
("cannot introduce hidden state &", Id
);
3283 Error_Msg_NE
("\package & has null abstract state", Id
, Context
);
3285 end Check_No_Hidden_State
;
3287 ----------------------------------------
3288 -- Check_Nonvolatile_Function_Profile --
3289 ----------------------------------------
3291 procedure Check_Nonvolatile_Function_Profile
(Func_Id
: Entity_Id
) is
3295 -- Inspect all formal parameters
3297 Formal
:= First_Formal
(Func_Id
);
3298 while Present
(Formal
) loop
3299 if Is_Effectively_Volatile
(Etype
(Formal
)) then
3301 ("nonvolatile function & cannot have a volatile parameter",
3305 Next_Formal
(Formal
);
3308 -- Inspect the return type
3310 if Is_Effectively_Volatile
(Etype
(Func_Id
)) then
3312 ("nonvolatile function & cannot have a volatile return type",
3313 Result_Definition
(Parent
(Func_Id
)), Func_Id
);
3315 end Check_Nonvolatile_Function_Profile
;
3317 ------------------------------------------
3318 -- Check_Potentially_Blocking_Operation --
3319 ------------------------------------------
3321 procedure Check_Potentially_Blocking_Operation
(N
: Node_Id
) is
3325 -- N is one of the potentially blocking operations listed in 9.5.1(8).
3326 -- When pragma Detect_Blocking is active, the run time will raise
3327 -- Program_Error. Here we only issue a warning, since we generally
3328 -- support the use of potentially blocking operations in the absence
3331 -- Indirect blocking through a subprogram call cannot be diagnosed
3332 -- statically without interprocedural analysis, so we do not attempt
3335 S
:= Scope
(Current_Scope
);
3336 while Present
(S
) and then S
/= Standard_Standard
loop
3337 if Is_Protected_Type
(S
) then
3339 ("potentially blocking operation in protected operation??", N
);
3345 end Check_Potentially_Blocking_Operation
;
3347 ---------------------------------
3348 -- Check_Result_And_Post_State --
3349 ---------------------------------
3351 procedure Check_Result_And_Post_State
(Subp_Id
: Entity_Id
) is
3352 procedure Check_Result_And_Post_State_In_Pragma
3354 Result_Seen
: in out Boolean);
3355 -- Determine whether pragma Prag mentions attribute 'Result and whether
3356 -- the pragma contains an expression that evaluates differently in pre-
3357 -- and post-state. Prag is a [refined] postcondition or a contract-cases
3358 -- pragma. Result_Seen is set when the pragma mentions attribute 'Result
3360 function Has_In_Out_Parameter
(Subp_Id
: Entity_Id
) return Boolean;
3361 -- Determine whether subprogram Subp_Id contains at least one IN OUT
3362 -- formal parameter.
3364 -------------------------------------------
3365 -- Check_Result_And_Post_State_In_Pragma --
3366 -------------------------------------------
3368 procedure Check_Result_And_Post_State_In_Pragma
3370 Result_Seen
: in out Boolean)
3372 procedure Check_Conjunct
(Expr
: Node_Id
);
3373 -- Check an individual conjunct in a conjunction of Boolean
3374 -- expressions, connected by "and" or "and then" operators.
3376 procedure Check_Conjuncts
(Expr
: Node_Id
);
3377 -- Apply the post-state check to every conjunct in an expression, in
3378 -- case this is a conjunction of Boolean expressions. Otherwise apply
3379 -- it to the expression as a whole.
3381 procedure Check_Expression
(Expr
: Node_Id
);
3382 -- Perform the 'Result and post-state checks on a given expression
3384 function Is_Function_Result
(N
: Node_Id
) return Traverse_Result
;
3385 -- Attempt to find attribute 'Result in a subtree denoted by N
3387 function Is_Trivial_Boolean
(N
: Node_Id
) return Boolean;
3388 -- Determine whether source node N denotes "True" or "False"
3390 function Mentions_Post_State
(N
: Node_Id
) return Boolean;
3391 -- Determine whether a subtree denoted by N mentions any construct
3392 -- that denotes a post-state.
3394 procedure Check_Function_Result
is
3395 new Traverse_Proc
(Is_Function_Result
);
3397 --------------------
3398 -- Check_Conjunct --
3399 --------------------
3401 procedure Check_Conjunct
(Expr
: Node_Id
) is
3402 function Adjust_Message
(Msg
: String) return String;
3403 -- Prepend a prefix to the input message Msg denoting that the
3404 -- message applies to a conjunct in the expression, when this
3407 function Applied_On_Conjunct
return Boolean;
3408 -- Returns True if the message applies to a conjunct in the
3409 -- expression, instead of the whole expression.
3411 --------------------
3412 -- Adjust_Message --
3413 --------------------
3415 function Adjust_Message
(Msg
: String) return String is
3417 if Applied_On_Conjunct
then
3418 return "conjunct in " & Msg
;
3424 -------------------------
3425 -- Applied_On_Conjunct --
3426 -------------------------
3428 function Applied_On_Conjunct
return Boolean is
3430 -- Expr is the conjunct of an enclosing "and" expression
3432 return Nkind
(Parent
(Expr
)) in N_Subexpr
3434 -- or Expr is a conjunct of an enclosing "and then"
3435 -- expression in a postcondition aspect that was split into
3436 -- multiple pragmas. The first conjunct has the "and then"
3437 -- expression as Original_Node, and other conjuncts have
3438 -- Split_PCC set to True.
3440 or else Nkind
(Original_Node
(Expr
)) = N_And_Then
3441 or else Split_PPC
(Prag
);
3442 end Applied_On_Conjunct
;
3447 -- Error node when reporting a warning on a (refined)
3450 -- Start of processing for Check_Conjunct
3453 if Applied_On_Conjunct
then
3459 if not Is_Trivial_Boolean
(Expr
)
3460 and then not Mentions_Post_State
(Expr
)
3462 if Pragma_Name
(Prag
) = Name_Contract_Cases
then
3463 Error_Msg_NE
(Adjust_Message
3464 ("contract case does not check the outcome of calling "
3465 & "&?T?"), Expr
, Subp_Id
);
3467 elsif Pragma_Name
(Prag
) = Name_Refined_Post
then
3468 Error_Msg_NE
(Adjust_Message
3469 ("refined postcondition does not check the outcome of "
3470 & "calling &?T?"), Err_Node
, Subp_Id
);
3473 Error_Msg_NE
(Adjust_Message
3474 ("postcondition does not check the outcome of calling "
3475 & "&?T?"), Err_Node
, Subp_Id
);
3480 ---------------------
3481 -- Check_Conjuncts --
3482 ---------------------
3484 procedure Check_Conjuncts
(Expr
: Node_Id
) is
3486 if Nkind_In
(Expr
, N_Op_And
, N_And_Then
) then
3487 Check_Conjuncts
(Left_Opnd
(Expr
));
3488 Check_Conjuncts
(Right_Opnd
(Expr
));
3490 Check_Conjunct
(Expr
);
3492 end Check_Conjuncts
;
3494 ----------------------
3495 -- Check_Expression --
3496 ----------------------
3498 procedure Check_Expression
(Expr
: Node_Id
) is
3500 if not Is_Trivial_Boolean
(Expr
) then
3501 Check_Function_Result
(Expr
);
3502 Check_Conjuncts
(Expr
);
3504 end Check_Expression
;
3506 ------------------------
3507 -- Is_Function_Result --
3508 ------------------------
3510 function Is_Function_Result
(N
: Node_Id
) return Traverse_Result
is
3512 if Is_Attribute_Result
(N
) then
3513 Result_Seen
:= True;
3516 -- Continue the traversal
3521 end Is_Function_Result
;
3523 ------------------------
3524 -- Is_Trivial_Boolean --
3525 ------------------------
3527 function Is_Trivial_Boolean
(N
: Node_Id
) return Boolean is
3530 Comes_From_Source
(N
)
3531 and then Is_Entity_Name
(N
)
3532 and then (Entity
(N
) = Standard_True
3534 Entity
(N
) = Standard_False
);
3535 end Is_Trivial_Boolean
;
3537 -------------------------
3538 -- Mentions_Post_State --
3539 -------------------------
3541 function Mentions_Post_State
(N
: Node_Id
) return Boolean is
3542 Post_State_Seen
: Boolean := False;
3544 function Is_Post_State
(N
: Node_Id
) return Traverse_Result
;
3545 -- Attempt to find a construct that denotes a post-state. If this
3546 -- is the case, set flag Post_State_Seen.
3552 function Is_Post_State
(N
: Node_Id
) return Traverse_Result
is
3556 if Nkind_In
(N
, N_Explicit_Dereference
, N_Function_Call
) then
3557 Post_State_Seen
:= True;
3560 elsif Nkind_In
(N
, N_Expanded_Name
, N_Identifier
) then
3563 -- Treat an undecorated reference as OK
3567 -- A reference to an assignable entity is considered a
3568 -- change in the post-state of a subprogram.
3570 or else Ekind_In
(Ent
, E_Generic_In_Out_Parameter
,
3575 -- The reference may be modified through a dereference
3577 or else (Is_Access_Type
(Etype
(Ent
))
3578 and then Nkind
(Parent
(N
)) =
3579 N_Selected_Component
)
3581 Post_State_Seen
:= True;
3585 elsif Nkind
(N
) = N_Attribute_Reference
then
3586 if Attribute_Name
(N
) = Name_Old
then
3589 elsif Attribute_Name
(N
) = Name_Result
then
3590 Post_State_Seen
:= True;
3598 procedure Find_Post_State
is new Traverse_Proc
(Is_Post_State
);
3600 -- Start of processing for Mentions_Post_State
3603 Find_Post_State
(N
);
3605 return Post_State_Seen
;
3606 end Mentions_Post_State
;
3610 Expr
: constant Node_Id
:=
3612 (First
(Pragma_Argument_Associations
(Prag
)));
3613 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
3616 -- Start of processing for Check_Result_And_Post_State_In_Pragma
3619 -- Examine all consequences
3621 if Nam
= Name_Contract_Cases
then
3622 CCase
:= First
(Component_Associations
(Expr
));
3623 while Present
(CCase
) loop
3624 Check_Expression
(Expression
(CCase
));
3629 -- Examine the expression of a postcondition
3631 else pragma Assert
(Nam_In
(Nam
, Name_Postcondition
,
3632 Name_Refined_Post
));
3633 Check_Expression
(Expr
);
3635 end Check_Result_And_Post_State_In_Pragma
;
3637 --------------------------
3638 -- Has_In_Out_Parameter --
3639 --------------------------
3641 function Has_In_Out_Parameter
(Subp_Id
: Entity_Id
) return Boolean is
3645 -- Traverse the formals looking for an IN OUT parameter
3647 Formal
:= First_Formal
(Subp_Id
);
3648 while Present
(Formal
) loop
3649 if Ekind
(Formal
) = E_In_Out_Parameter
then
3653 Next_Formal
(Formal
);
3657 end Has_In_Out_Parameter
;
3661 Items
: constant Node_Id
:= Contract
(Subp_Id
);
3662 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
3663 Case_Prag
: Node_Id
:= Empty
;
3664 Post_Prag
: Node_Id
:= Empty
;
3666 Seen_In_Case
: Boolean := False;
3667 Seen_In_Post
: Boolean := False;
3668 Spec_Id
: Entity_Id
;
3670 -- Start of processing for Check_Result_And_Post_State
3673 -- The lack of attribute 'Result or a post-state is classified as a
3674 -- suspicious contract. Do not perform the check if the corresponding
3675 -- swich is not set.
3677 if not Warn_On_Suspicious_Contract
then
3680 -- Nothing to do if there is no contract
3682 elsif No
(Items
) then
3686 -- Retrieve the entity of the subprogram spec (if any)
3688 if Nkind
(Subp_Decl
) = N_Subprogram_Body
3689 and then Present
(Corresponding_Spec
(Subp_Decl
))
3691 Spec_Id
:= Corresponding_Spec
(Subp_Decl
);
3693 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
3694 and then Present
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
3696 Spec_Id
:= Corresponding_Spec_Of_Stub
(Subp_Decl
);
3702 -- Examine all postconditions for attribute 'Result and a post-state
3704 Prag
:= Pre_Post_Conditions
(Items
);
3705 while Present
(Prag
) loop
3706 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
3707 Name_Postcondition
, Name_Refined_Post
)
3708 and then not Error_Posted
(Prag
)
3711 Check_Result_And_Post_State_In_Pragma
(Prag
, Seen_In_Post
);
3714 Prag
:= Next_Pragma
(Prag
);
3717 -- Examine the contract cases of the subprogram for attribute 'Result
3718 -- and a post-state.
3720 Prag
:= Contract_Test_Cases
(Items
);
3721 while Present
(Prag
) loop
3722 if Pragma_Name
(Prag
) = Name_Contract_Cases
3723 and then not Error_Posted
(Prag
)
3726 Check_Result_And_Post_State_In_Pragma
(Prag
, Seen_In_Case
);
3729 Prag
:= Next_Pragma
(Prag
);
3732 -- Do not emit any errors if the subprogram is not a function
3734 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
3737 -- Regardless of whether the function has postconditions or contract
3738 -- cases, or whether they mention attribute 'Result, an IN OUT formal
3739 -- parameter is always treated as a result.
3741 elsif Has_In_Out_Parameter
(Spec_Id
) then
3744 -- The function has both a postcondition and contract cases and they do
3745 -- not mention attribute 'Result.
3747 elsif Present
(Case_Prag
)
3748 and then not Seen_In_Case
3749 and then Present
(Post_Prag
)
3750 and then not Seen_In_Post
3753 ("neither postcondition nor contract cases mention function "
3754 & "result?T?", Post_Prag
);
3756 -- The function has contract cases only and they do not mention
3757 -- attribute 'Result.
3759 elsif Present
(Case_Prag
) and then not Seen_In_Case
then
3760 Error_Msg_N
("contract cases do not mention result?T?", Case_Prag
);
3762 -- The function has postconditions only and they do not mention
3763 -- attribute 'Result.
3765 elsif Present
(Post_Prag
) and then not Seen_In_Post
then
3767 ("postcondition does not mention function result?T?", Post_Prag
);
3769 end Check_Result_And_Post_State
;
3771 -----------------------------
3772 -- Check_State_Refinements --
3773 -----------------------------
3775 procedure Check_State_Refinements
3777 Is_Main_Unit
: Boolean := False)
3779 procedure Check_Package
(Pack
: Node_Id
);
3780 -- Verify that all abstract states of a [generic] package denoted by its
3781 -- declarative node Pack have proper refinement. Recursively verify the
3782 -- visible and private declarations of the [generic] package for other
3785 procedure Check_Packages_In
(Decls
: List_Id
);
3786 -- Seek out [generic] package declarations within declarative list Decls
3787 -- and verify the status of their abstract state refinement.
3789 function SPARK_Mode_Is_Off
(N
: Node_Id
) return Boolean;
3790 -- Determine whether construct N is subject to pragma SPARK_Mode Off
3796 procedure Check_Package
(Pack
: Node_Id
) is
3797 Body_Id
: constant Entity_Id
:= Corresponding_Body
(Pack
);
3798 Spec
: constant Node_Id
:= Specification
(Pack
);
3799 States
: constant Elist_Id
:=
3800 Abstract_States
(Defining_Entity
(Pack
));
3802 State_Elmt
: Elmt_Id
;
3803 State_Id
: Entity_Id
;
3806 -- Do not verify proper state refinement when the package is subject
3807 -- to pragma SPARK_Mode Off because this disables the requirement for
3808 -- state refinement.
3810 if SPARK_Mode_Is_Off
(Pack
) then
3813 -- State refinement can only occur in a completing packge body. Do
3814 -- not verify proper state refinement when the body is subject to
3815 -- pragma SPARK_Mode Off because this disables the requirement for
3816 -- state refinement.
3818 elsif Present
(Body_Id
)
3819 and then SPARK_Mode_Is_Off
(Unit_Declaration_Node
(Body_Id
))
3823 -- Do not verify proper state refinement when the package is an
3824 -- instance as this check was already performed in the generic.
3826 elsif Present
(Generic_Parent
(Spec
)) then
3829 -- Otherwise examine the contents of the package
3832 if Present
(States
) then
3833 State_Elmt
:= First_Elmt
(States
);
3834 while Present
(State_Elmt
) loop
3835 State_Id
:= Node
(State_Elmt
);
3837 -- Emit an error when a non-null state lacks any form of
3840 if not Is_Null_State
(State_Id
)
3841 and then not Has_Null_Refinement
(State_Id
)
3842 and then not Has_Non_Null_Refinement
(State_Id
)
3844 Error_Msg_N
("state & requires refinement", State_Id
);
3847 Next_Elmt
(State_Elmt
);
3851 Check_Packages_In
(Visible_Declarations
(Spec
));
3852 Check_Packages_In
(Private_Declarations
(Spec
));
3856 -----------------------
3857 -- Check_Packages_In --
3858 -----------------------
3860 procedure Check_Packages_In
(Decls
: List_Id
) is
3864 if Present
(Decls
) then
3865 Decl
:= First
(Decls
);
3866 while Present
(Decl
) loop
3867 if Nkind_In
(Decl
, N_Generic_Package_Declaration
,
3868 N_Package_Declaration
)
3870 Check_Package
(Decl
);
3876 end Check_Packages_In
;
3878 -----------------------
3879 -- SPARK_Mode_Is_Off --
3880 -----------------------
3882 function SPARK_Mode_Is_Off
(N
: Node_Id
) return Boolean is
3883 Id
: constant Entity_Id
:= Defining_Entity
(N
);
3884 Prag
: constant Node_Id
:= SPARK_Pragma
(Id
);
3887 -- Default the mode to "off" when the context is an instance and all
3888 -- SPARK_Mode pragmas found within are to be ignored.
3890 if Ignore_SPARK_Mode_Pragmas
(Id
) then
3896 and then Get_SPARK_Mode_From_Annotation
(Prag
) = Off
;
3898 end SPARK_Mode_Is_Off
;
3900 -- Start of processing for Check_State_Refinements
3903 -- A block may declare a nested package
3905 if Nkind
(Context
) = N_Block_Statement
then
3906 Check_Packages_In
(Declarations
(Context
));
3908 -- An entry, protected, subprogram, or task body may declare a nested
3911 elsif Nkind_In
(Context
, N_Entry_Body
,
3916 -- Do not verify proper state refinement when the body is subject to
3917 -- pragma SPARK_Mode Off because this disables the requirement for
3918 -- state refinement.
3920 if not SPARK_Mode_Is_Off
(Context
) then
3921 Check_Packages_In
(Declarations
(Context
));
3924 -- A package body may declare a nested package
3926 elsif Nkind
(Context
) = N_Package_Body
then
3927 Check_Package
(Unit_Declaration_Node
(Corresponding_Spec
(Context
)));
3929 -- Do not verify proper state refinement when the body is subject to
3930 -- pragma SPARK_Mode Off because this disables the requirement for
3931 -- state refinement.
3933 if not SPARK_Mode_Is_Off
(Context
) then
3934 Check_Packages_In
(Declarations
(Context
));
3937 -- A library level [generic] package may declare a nested package
3939 elsif Nkind_In
(Context
, N_Generic_Package_Declaration
,
3940 N_Package_Declaration
)
3941 and then Is_Main_Unit
3943 Check_Package
(Context
);
3945 end Check_State_Refinements
;
3947 ------------------------------
3948 -- Check_Unprotected_Access --
3949 ------------------------------
3951 procedure Check_Unprotected_Access
3955 Cont_Encl_Typ
: Entity_Id
;
3956 Pref_Encl_Typ
: Entity_Id
;
3958 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
;
3959 -- Check whether Obj is a private component of a protected object.
3960 -- Return the protected type where the component resides, Empty
3963 function Is_Public_Operation
return Boolean;
3964 -- Verify that the enclosing operation is callable from outside the
3965 -- protected object, to minimize false positives.
3967 ------------------------------
3968 -- Enclosing_Protected_Type --
3969 ------------------------------
3971 function Enclosing_Protected_Type
(Obj
: Node_Id
) return Entity_Id
is
3973 if Is_Entity_Name
(Obj
) then
3975 Ent
: Entity_Id
:= Entity
(Obj
);
3978 -- The object can be a renaming of a private component, use
3979 -- the original record component.
3981 if Is_Prival
(Ent
) then
3982 Ent
:= Prival_Link
(Ent
);
3985 if Is_Protected_Type
(Scope
(Ent
)) then
3991 -- For indexed and selected components, recursively check the prefix
3993 if Nkind_In
(Obj
, N_Indexed_Component
, N_Selected_Component
) then
3994 return Enclosing_Protected_Type
(Prefix
(Obj
));
3996 -- The object does not denote a protected component
4001 end Enclosing_Protected_Type
;
4003 -------------------------
4004 -- Is_Public_Operation --
4005 -------------------------
4007 function Is_Public_Operation
return Boolean is
4013 while Present
(S
) and then S
/= Pref_Encl_Typ
loop
4014 if Scope
(S
) = Pref_Encl_Typ
then
4015 E
:= First_Entity
(Pref_Encl_Typ
);
4017 and then E
/= First_Private_Entity
(Pref_Encl_Typ
)
4031 end Is_Public_Operation
;
4033 -- Start of processing for Check_Unprotected_Access
4036 if Nkind
(Expr
) = N_Attribute_Reference
4037 and then Attribute_Name
(Expr
) = Name_Unchecked_Access
4039 Cont_Encl_Typ
:= Enclosing_Protected_Type
(Context
);
4040 Pref_Encl_Typ
:= Enclosing_Protected_Type
(Prefix
(Expr
));
4042 -- Check whether we are trying to export a protected component to a
4043 -- context with an equal or lower access level.
4045 if Present
(Pref_Encl_Typ
)
4046 and then No
(Cont_Encl_Typ
)
4047 and then Is_Public_Operation
4048 and then Scope_Depth
(Pref_Encl_Typ
) >=
4049 Object_Access_Level
(Context
)
4052 ("??possible unprotected access to protected data", Expr
);
4055 end Check_Unprotected_Access
;
4057 ------------------------------
4058 -- Check_Unused_Body_States --
4059 ------------------------------
4061 procedure Check_Unused_Body_States
(Body_Id
: Entity_Id
) is
4062 procedure Process_Refinement_Clause
4065 -- Inspect all constituents of refinement clause Clause and remove any
4066 -- matches from body state list States.
4068 procedure Report_Unused_Body_States
(States
: Elist_Id
);
4069 -- Emit errors for each abstract state or object found in list States
4071 -------------------------------
4072 -- Process_Refinement_Clause --
4073 -------------------------------
4075 procedure Process_Refinement_Clause
4079 procedure Process_Constituent
(Constit
: Node_Id
);
4080 -- Remove constituent Constit from body state list States
4082 -------------------------
4083 -- Process_Constituent --
4084 -------------------------
4086 procedure Process_Constituent
(Constit
: Node_Id
) is
4087 Constit_Id
: Entity_Id
;
4090 -- Guard against illegal constituents. Only abstract states and
4091 -- objects can appear on the right hand side of a refinement.
4093 if Is_Entity_Name
(Constit
) then
4094 Constit_Id
:= Entity_Of
(Constit
);
4096 if Present
(Constit_Id
)
4097 and then Ekind_In
(Constit_Id
, E_Abstract_State
,
4101 Remove
(States
, Constit_Id
);
4104 end Process_Constituent
;
4110 -- Start of processing for Process_Refinement_Clause
4113 if Nkind
(Clause
) = N_Component_Association
then
4114 Constit
:= Expression
(Clause
);
4116 -- Multiple constituents appear as an aggregate
4118 if Nkind
(Constit
) = N_Aggregate
then
4119 Constit
:= First
(Expressions
(Constit
));
4120 while Present
(Constit
) loop
4121 Process_Constituent
(Constit
);
4125 -- Various forms of a single constituent
4128 Process_Constituent
(Constit
);
4131 end Process_Refinement_Clause
;
4133 -------------------------------
4134 -- Report_Unused_Body_States --
4135 -------------------------------
4137 procedure Report_Unused_Body_States
(States
: Elist_Id
) is
4138 Posted
: Boolean := False;
4139 State_Elmt
: Elmt_Id
;
4140 State_Id
: Entity_Id
;
4143 if Present
(States
) then
4144 State_Elmt
:= First_Elmt
(States
);
4145 while Present
(State_Elmt
) loop
4146 State_Id
:= Node
(State_Elmt
);
4148 -- Constants are part of the hidden state of a package, but the
4149 -- compiler cannot determine whether they have variable input
4150 -- (SPARK RM 7.1.1(2)) and cannot classify them properly as a
4151 -- hidden state. Do not emit an error when a constant does not
4152 -- participate in a state refinement, even though it acts as a
4155 if Ekind
(State_Id
) = E_Constant
then
4158 -- Generate an error message of the form:
4160 -- body of package ... has unused hidden states
4161 -- abstract state ... defined at ...
4162 -- variable ... defined at ...
4168 ("body of package & has unused hidden states", Body_Id
);
4171 Error_Msg_Sloc
:= Sloc
(State_Id
);
4173 if Ekind
(State_Id
) = E_Abstract_State
then
4175 ("\abstract state & defined #", Body_Id
, State_Id
);
4178 SPARK_Msg_NE
("\variable & defined #", Body_Id
, State_Id
);
4182 Next_Elmt
(State_Elmt
);
4185 end Report_Unused_Body_States
;
4189 Prag
: constant Node_Id
:= Get_Pragma
(Body_Id
, Pragma_Refined_State
);
4190 Spec_Id
: constant Entity_Id
:= Spec_Entity
(Body_Id
);
4194 -- Start of processing for Check_Unused_Body_States
4197 -- Inspect the clauses of pragma Refined_State and determine whether all
4198 -- visible states declared within the package body participate in the
4201 if Present
(Prag
) then
4202 Clause
:= Expression
(Get_Argument
(Prag
, Spec_Id
));
4203 States
:= Collect_Body_States
(Body_Id
);
4205 -- Multiple non-null state refinements appear as an aggregate
4207 if Nkind
(Clause
) = N_Aggregate
then
4208 Clause
:= First
(Component_Associations
(Clause
));
4209 while Present
(Clause
) loop
4210 Process_Refinement_Clause
(Clause
, States
);
4214 -- Various forms of a single state refinement
4217 Process_Refinement_Clause
(Clause
, States
);
4220 -- Ensure that all abstract states and objects declared in the
4221 -- package body state space are utilized as constituents.
4223 Report_Unused_Body_States
(States
);
4225 end Check_Unused_Body_States
;
4231 function Choice_List
(N
: Node_Id
) return List_Id
is
4233 if Nkind
(N
) = N_Iterated_Component_Association
then
4234 return Discrete_Choices
(N
);
4240 -------------------------
4241 -- Collect_Body_States --
4242 -------------------------
4244 function Collect_Body_States
(Body_Id
: Entity_Id
) return Elist_Id
is
4245 function Is_Visible_Object
(Obj_Id
: Entity_Id
) return Boolean;
4246 -- Determine whether object Obj_Id is a suitable visible state of a
4249 procedure Collect_Visible_States
4250 (Pack_Id
: Entity_Id
;
4251 States
: in out Elist_Id
);
4252 -- Gather the entities of all abstract states and objects declared in
4253 -- the visible state space of package Pack_Id.
4255 ----------------------------
4256 -- Collect_Visible_States --
4257 ----------------------------
4259 procedure Collect_Visible_States
4260 (Pack_Id
: Entity_Id
;
4261 States
: in out Elist_Id
)
4263 Item_Id
: Entity_Id
;
4266 -- Traverse the entity chain of the package and inspect all visible
4269 Item_Id
:= First_Entity
(Pack_Id
);
4270 while Present
(Item_Id
) and then not In_Private_Part
(Item_Id
) loop
4272 -- Do not consider internally generated items as those cannot be
4273 -- named and participate in refinement.
4275 if not Comes_From_Source
(Item_Id
) then
4278 elsif Ekind
(Item_Id
) = E_Abstract_State
then
4279 Append_New_Elmt
(Item_Id
, States
);
4281 elsif Ekind_In
(Item_Id
, E_Constant
, E_Variable
)
4282 and then Is_Visible_Object
(Item_Id
)
4284 Append_New_Elmt
(Item_Id
, States
);
4286 -- Recursively gather the visible states of a nested package
4288 elsif Ekind
(Item_Id
) = E_Package
then
4289 Collect_Visible_States
(Item_Id
, States
);
4292 Next_Entity
(Item_Id
);
4294 end Collect_Visible_States
;
4296 -----------------------
4297 -- Is_Visible_Object --
4298 -----------------------
4300 function Is_Visible_Object
(Obj_Id
: Entity_Id
) return Boolean is
4302 -- Objects that map generic formals to their actuals are not visible
4303 -- from outside the generic instantiation.
4305 if Present
(Corresponding_Generic_Association
4306 (Declaration_Node
(Obj_Id
)))
4310 -- Constituents of a single protected/task type act as components of
4311 -- the type and are not visible from outside the type.
4313 elsif Ekind
(Obj_Id
) = E_Variable
4314 and then Present
(Encapsulating_State
(Obj_Id
))
4315 and then Is_Single_Concurrent_Object
(Encapsulating_State
(Obj_Id
))
4322 end Is_Visible_Object
;
4326 Body_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Body_Id
);
4328 Item_Id
: Entity_Id
;
4329 States
: Elist_Id
:= No_Elist
;
4331 -- Start of processing for Collect_Body_States
4334 -- Inspect the declarations of the body looking for source objects,
4335 -- packages and package instantiations. Note that even though this
4336 -- processing is very similar to Collect_Visible_States, a package
4337 -- body does not have a First/Next_Entity list.
4339 Decl
:= First
(Declarations
(Body_Decl
));
4340 while Present
(Decl
) loop
4342 -- Capture source objects as internally generated temporaries cannot
4343 -- be named and participate in refinement.
4345 if Nkind
(Decl
) = N_Object_Declaration
then
4346 Item_Id
:= Defining_Entity
(Decl
);
4348 if Comes_From_Source
(Item_Id
)
4349 and then Is_Visible_Object
(Item_Id
)
4351 Append_New_Elmt
(Item_Id
, States
);
4354 -- Capture the visible abstract states and objects of a source
4355 -- package [instantiation].
4357 elsif Nkind
(Decl
) = N_Package_Declaration
then
4358 Item_Id
:= Defining_Entity
(Decl
);
4360 if Comes_From_Source
(Item_Id
) then
4361 Collect_Visible_States
(Item_Id
, States
);
4369 end Collect_Body_States
;
4371 ------------------------
4372 -- Collect_Interfaces --
4373 ------------------------
4375 procedure Collect_Interfaces
4377 Ifaces_List
: out Elist_Id
;
4378 Exclude_Parents
: Boolean := False;
4379 Use_Full_View
: Boolean := True)
4381 procedure Collect
(Typ
: Entity_Id
);
4382 -- Subsidiary subprogram used to traverse the whole list
4383 -- of directly and indirectly implemented interfaces
4389 procedure Collect
(Typ
: Entity_Id
) is
4390 Ancestor
: Entity_Id
;
4398 -- Handle private types and subtypes
4401 and then Is_Private_Type
(Typ
)
4402 and then Present
(Full_View
(Typ
))
4404 Full_T
:= Full_View
(Typ
);
4406 if Ekind
(Full_T
) = E_Record_Subtype
then
4407 Full_T
:= Etype
(Typ
);
4409 if Present
(Full_View
(Full_T
)) then
4410 Full_T
:= Full_View
(Full_T
);
4415 -- Include the ancestor if we are generating the whole list of
4416 -- abstract interfaces.
4418 if Etype
(Full_T
) /= Typ
4420 -- Protect the frontend against wrong sources. For example:
4423 -- type A is tagged null record;
4424 -- type B is new A with private;
4425 -- type C is new A with private;
4427 -- type B is new C with null record;
4428 -- type C is new B with null record;
4431 and then Etype
(Full_T
) /= T
4433 Ancestor
:= Etype
(Full_T
);
4436 if Is_Interface
(Ancestor
) and then not Exclude_Parents
then
4437 Append_Unique_Elmt
(Ancestor
, Ifaces_List
);
4441 -- Traverse the graph of ancestor interfaces
4443 if Is_Non_Empty_List
(Abstract_Interface_List
(Full_T
)) then
4444 Id
:= First
(Abstract_Interface_List
(Full_T
));
4445 while Present
(Id
) loop
4446 Iface
:= Etype
(Id
);
4448 -- Protect against wrong uses. For example:
4449 -- type I is interface;
4450 -- type O is tagged null record;
4451 -- type Wrong is new I and O with null record; -- ERROR
4453 if Is_Interface
(Iface
) then
4455 and then Etype
(T
) /= T
4456 and then Interface_Present_In_Ancestor
(Etype
(T
), Iface
)
4461 Append_Unique_Elmt
(Iface
, Ifaces_List
);
4470 -- Start of processing for Collect_Interfaces
4473 pragma Assert
(Is_Tagged_Type
(T
) or else Is_Concurrent_Type
(T
));
4474 Ifaces_List
:= New_Elmt_List
;
4476 end Collect_Interfaces
;
4478 ----------------------------------
4479 -- Collect_Interface_Components --
4480 ----------------------------------
4482 procedure Collect_Interface_Components
4483 (Tagged_Type
: Entity_Id
;
4484 Components_List
: out Elist_Id
)
4486 procedure Collect
(Typ
: Entity_Id
);
4487 -- Subsidiary subprogram used to climb to the parents
4493 procedure Collect
(Typ
: Entity_Id
) is
4494 Tag_Comp
: Entity_Id
;
4495 Parent_Typ
: Entity_Id
;
4498 -- Handle private types
4500 if Present
(Full_View
(Etype
(Typ
))) then
4501 Parent_Typ
:= Full_View
(Etype
(Typ
));
4503 Parent_Typ
:= Etype
(Typ
);
4506 if Parent_Typ
/= Typ
4508 -- Protect the frontend against wrong sources. For example:
4511 -- type A is tagged null record;
4512 -- type B is new A with private;
4513 -- type C is new A with private;
4515 -- type B is new C with null record;
4516 -- type C is new B with null record;
4519 and then Parent_Typ
/= Tagged_Type
4521 Collect
(Parent_Typ
);
4524 -- Collect the components containing tags of secondary dispatch
4527 Tag_Comp
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
4528 while Present
(Tag_Comp
) loop
4529 pragma Assert
(Present
(Related_Type
(Tag_Comp
)));
4530 Append_Elmt
(Tag_Comp
, Components_List
);
4532 Tag_Comp
:= Next_Tag_Component
(Tag_Comp
);
4536 -- Start of processing for Collect_Interface_Components
4539 pragma Assert
(Ekind
(Tagged_Type
) = E_Record_Type
4540 and then Is_Tagged_Type
(Tagged_Type
));
4542 Components_List
:= New_Elmt_List
;
4543 Collect
(Tagged_Type
);
4544 end Collect_Interface_Components
;
4546 -----------------------------
4547 -- Collect_Interfaces_Info --
4548 -----------------------------
4550 procedure Collect_Interfaces_Info
4552 Ifaces_List
: out Elist_Id
;
4553 Components_List
: out Elist_Id
;
4554 Tags_List
: out Elist_Id
)
4556 Comps_List
: Elist_Id
;
4557 Comp_Elmt
: Elmt_Id
;
4558 Comp_Iface
: Entity_Id
;
4559 Iface_Elmt
: Elmt_Id
;
4562 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
;
4563 -- Search for the secondary tag associated with the interface type
4564 -- Iface that is implemented by T.
4570 function Search_Tag
(Iface
: Entity_Id
) return Entity_Id
is
4573 if not Is_CPP_Class
(T
) then
4574 ADT
:= Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
))));
4576 ADT
:= Next_Elmt
(First_Elmt
(Access_Disp_Table
(T
)));
4580 and then Is_Tag
(Node
(ADT
))
4581 and then Related_Type
(Node
(ADT
)) /= Iface
4583 -- Skip secondary dispatch table referencing thunks to user
4584 -- defined primitives covered by this interface.
4586 pragma Assert
(Has_Suffix
(Node
(ADT
), 'P'));
4589 -- Skip secondary dispatch tables of Ada types
4591 if not Is_CPP_Class
(T
) then
4593 -- Skip secondary dispatch table referencing thunks to
4594 -- predefined primitives.
4596 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Y'));
4599 -- Skip secondary dispatch table referencing user-defined
4600 -- primitives covered by this interface.
4602 pragma Assert
(Has_Suffix
(Node
(ADT
), 'D'));
4605 -- Skip secondary dispatch table referencing predefined
4608 pragma Assert
(Has_Suffix
(Node
(ADT
), 'Z'));
4613 pragma Assert
(Is_Tag
(Node
(ADT
)));
4617 -- Start of processing for Collect_Interfaces_Info
4620 Collect_Interfaces
(T
, Ifaces_List
);
4621 Collect_Interface_Components
(T
, Comps_List
);
4623 -- Search for the record component and tag associated with each
4624 -- interface type of T.
4626 Components_List
:= New_Elmt_List
;
4627 Tags_List
:= New_Elmt_List
;
4629 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
4630 while Present
(Iface_Elmt
) loop
4631 Iface
:= Node
(Iface_Elmt
);
4633 -- Associate the primary tag component and the primary dispatch table
4634 -- with all the interfaces that are parents of T
4636 if Is_Ancestor
(Iface
, T
, Use_Full_View
=> True) then
4637 Append_Elmt
(First_Tag_Component
(T
), Components_List
);
4638 Append_Elmt
(Node
(First_Elmt
(Access_Disp_Table
(T
))), Tags_List
);
4640 -- Otherwise search for the tag component and secondary dispatch
4644 Comp_Elmt
:= First_Elmt
(Comps_List
);
4645 while Present
(Comp_Elmt
) loop
4646 Comp_Iface
:= Related_Type
(Node
(Comp_Elmt
));
4648 if Comp_Iface
= Iface
4649 or else Is_Ancestor
(Iface
, Comp_Iface
, Use_Full_View
=> True)
4651 Append_Elmt
(Node
(Comp_Elmt
), Components_List
);
4652 Append_Elmt
(Search_Tag
(Comp_Iface
), Tags_List
);
4656 Next_Elmt
(Comp_Elmt
);
4658 pragma Assert
(Present
(Comp_Elmt
));
4661 Next_Elmt
(Iface_Elmt
);
4663 end Collect_Interfaces_Info
;
4665 ---------------------
4666 -- Collect_Parents --
4667 ---------------------
4669 procedure Collect_Parents
4671 List
: out Elist_Id
;
4672 Use_Full_View
: Boolean := True)
4674 Current_Typ
: Entity_Id
:= T
;
4675 Parent_Typ
: Entity_Id
;
4678 List
:= New_Elmt_List
;
4680 -- No action if the if the type has no parents
4682 if T
= Etype
(T
) then
4687 Parent_Typ
:= Etype
(Current_Typ
);
4689 if Is_Private_Type
(Parent_Typ
)
4690 and then Present
(Full_View
(Parent_Typ
))
4691 and then Use_Full_View
4693 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
4696 Append_Elmt
(Parent_Typ
, List
);
4698 exit when Parent_Typ
= Current_Typ
;
4699 Current_Typ
:= Parent_Typ
;
4701 end Collect_Parents
;
4703 ----------------------------------
4704 -- Collect_Primitive_Operations --
4705 ----------------------------------
4707 function Collect_Primitive_Operations
(T
: Entity_Id
) return Elist_Id
is
4708 B_Type
: constant Entity_Id
:= Base_Type
(T
);
4709 B_Decl
: constant Node_Id
:= Original_Node
(Parent
(B_Type
));
4710 B_Scope
: Entity_Id
:= Scope
(B_Type
);
4714 Is_Type_In_Pkg
: Boolean;
4715 Formal_Derived
: Boolean := False;
4718 function Match
(E
: Entity_Id
) return Boolean;
4719 -- True if E's base type is B_Type, or E is of an anonymous access type
4720 -- and the base type of its designated type is B_Type.
4726 function Match
(E
: Entity_Id
) return Boolean is
4727 Etyp
: Entity_Id
:= Etype
(E
);
4730 if Ekind
(Etyp
) = E_Anonymous_Access_Type
then
4731 Etyp
:= Designated_Type
(Etyp
);
4734 -- In Ada 2012 a primitive operation may have a formal of an
4735 -- incomplete view of the parent type.
4737 return Base_Type
(Etyp
) = B_Type
4739 (Ada_Version
>= Ada_2012
4740 and then Ekind
(Etyp
) = E_Incomplete_Type
4741 and then Full_View
(Etyp
) = B_Type
);
4744 -- Start of processing for Collect_Primitive_Operations
4747 -- For tagged types, the primitive operations are collected as they
4748 -- are declared, and held in an explicit list which is simply returned.
4750 if Is_Tagged_Type
(B_Type
) then
4751 return Primitive_Operations
(B_Type
);
4753 -- An untagged generic type that is a derived type inherits the
4754 -- primitive operations of its parent type. Other formal types only
4755 -- have predefined operators, which are not explicitly represented.
4757 elsif Is_Generic_Type
(B_Type
) then
4758 if Nkind
(B_Decl
) = N_Formal_Type_Declaration
4759 and then Nkind
(Formal_Type_Definition
(B_Decl
)) =
4760 N_Formal_Derived_Type_Definition
4762 Formal_Derived
:= True;
4764 return New_Elmt_List
;
4768 Op_List
:= New_Elmt_List
;
4770 if B_Scope
= Standard_Standard
then
4771 if B_Type
= Standard_String
then
4772 Append_Elmt
(Standard_Op_Concat
, Op_List
);
4774 elsif B_Type
= Standard_Wide_String
then
4775 Append_Elmt
(Standard_Op_Concatw
, Op_List
);
4781 -- Locate the primitive subprograms of the type
4784 -- The primitive operations appear after the base type, except
4785 -- if the derivation happens within the private part of B_Scope
4786 -- and the type is a private type, in which case both the type
4787 -- and some primitive operations may appear before the base
4788 -- type, and the list of candidates starts after the type.
4790 if In_Open_Scopes
(B_Scope
)
4791 and then Scope
(T
) = B_Scope
4792 and then In_Private_Part
(B_Scope
)
4794 Id
:= Next_Entity
(T
);
4796 -- In Ada 2012, If the type has an incomplete partial view, there
4797 -- may be primitive operations declared before the full view, so
4798 -- we need to start scanning from the incomplete view, which is
4799 -- earlier on the entity chain.
4801 elsif Nkind
(Parent
(B_Type
)) = N_Full_Type_Declaration
4802 and then Present
(Incomplete_View
(Parent
(B_Type
)))
4804 Id
:= Defining_Entity
(Incomplete_View
(Parent
(B_Type
)));
4806 -- If T is a derived from a type with an incomplete view declared
4807 -- elsewhere, that incomplete view is irrelevant, we want the
4808 -- operations in the scope of T.
4810 if Scope
(Id
) /= Scope
(B_Type
) then
4811 Id
:= Next_Entity
(B_Type
);
4815 Id
:= Next_Entity
(B_Type
);
4818 -- Set flag if this is a type in a package spec
4821 Is_Package_Or_Generic_Package
(B_Scope
)
4823 Nkind
(Parent
(Declaration_Node
(First_Subtype
(T
)))) /=
4826 while Present
(Id
) loop
4828 -- Test whether the result type or any of the parameter types of
4829 -- each subprogram following the type match that type when the
4830 -- type is declared in a package spec, is a derived type, or the
4831 -- subprogram is marked as primitive. (The Is_Primitive test is
4832 -- needed to find primitives of nonderived types in declarative
4833 -- parts that happen to override the predefined "=" operator.)
4835 -- Note that generic formal subprograms are not considered to be
4836 -- primitive operations and thus are never inherited.
4838 if Is_Overloadable
(Id
)
4839 and then (Is_Type_In_Pkg
4840 or else Is_Derived_Type
(B_Type
)
4841 or else Is_Primitive
(Id
))
4842 and then Nkind
(Parent
(Parent
(Id
)))
4843 not in N_Formal_Subprogram_Declaration
4851 Formal
:= First_Formal
(Id
);
4852 while Present
(Formal
) loop
4853 if Match
(Formal
) then
4858 Next_Formal
(Formal
);
4862 -- For a formal derived type, the only primitives are the ones
4863 -- inherited from the parent type. Operations appearing in the
4864 -- package declaration are not primitive for it.
4867 and then (not Formal_Derived
or else Present
(Alias
(Id
)))
4869 -- In the special case of an equality operator aliased to
4870 -- an overriding dispatching equality belonging to the same
4871 -- type, we don't include it in the list of primitives.
4872 -- This avoids inheriting multiple equality operators when
4873 -- deriving from untagged private types whose full type is
4874 -- tagged, which can otherwise cause ambiguities. Note that
4875 -- this should only happen for this kind of untagged parent
4876 -- type, since normally dispatching operations are inherited
4877 -- using the type's Primitive_Operations list.
4879 if Chars
(Id
) = Name_Op_Eq
4880 and then Is_Dispatching_Operation
(Id
)
4881 and then Present
(Alias
(Id
))
4882 and then Present
(Overridden_Operation
(Alias
(Id
)))
4883 and then Base_Type
(Etype
(First_Entity
(Id
))) =
4884 Base_Type
(Etype
(First_Entity
(Alias
(Id
))))
4888 -- Include the subprogram in the list of primitives
4891 Append_Elmt
(Id
, Op_List
);
4898 -- For a type declared in System, some of its operations may
4899 -- appear in the target-specific extension to System.
4902 and then B_Scope
= RTU_Entity
(System
)
4903 and then Present_System_Aux
4905 B_Scope
:= System_Aux_Id
;
4906 Id
:= First_Entity
(System_Aux_Id
);
4912 end Collect_Primitive_Operations
;
4914 -----------------------------------
4915 -- Compile_Time_Constraint_Error --
4916 -----------------------------------
4918 function Compile_Time_Constraint_Error
4921 Ent
: Entity_Id
:= Empty
;
4922 Loc
: Source_Ptr
:= No_Location
;
4923 Warn
: Boolean := False) return Node_Id
4925 Msgc
: String (1 .. Msg
'Length + 3);
4926 -- Copy of message, with room for possible ?? or << and ! at end
4932 -- Start of processing for Compile_Time_Constraint_Error
4935 -- If this is a warning, convert it into an error if we are in code
4936 -- subject to SPARK_Mode being set On, unless Warn is True to force a
4937 -- warning. The rationale is that a compile-time constraint error should
4938 -- lead to an error instead of a warning when SPARK_Mode is On, but in
4939 -- a few cases we prefer to issue a warning and generate both a suitable
4940 -- run-time error in GNAT and a suitable check message in GNATprove.
4941 -- Those cases are those that likely correspond to deactivated SPARK
4942 -- code, so that this kind of code can be compiled and analyzed instead
4943 -- of being rejected.
4945 Error_Msg_Warn
:= Warn
or SPARK_Mode
/= On
;
4947 -- A static constraint error in an instance body is not a fatal error.
4948 -- we choose to inhibit the message altogether, because there is no
4949 -- obvious node (for now) on which to post it. On the other hand the
4950 -- offending node must be replaced with a constraint_error in any case.
4952 -- No messages are generated if we already posted an error on this node
4954 if not Error_Posted
(N
) then
4955 if Loc
/= No_Location
then
4961 -- Copy message to Msgc, converting any ? in the message into <
4962 -- instead, so that we have an error in GNATprove mode.
4966 for J
in 1 .. Msgl
loop
4967 if Msg
(J
) = '?' and then (J
= 1 or else Msg
(J
- 1) /= ''') then
4970 Msgc
(J
) := Msg
(J
);
4974 -- Message is a warning, even in Ada 95 case
4976 if Msg
(Msg
'Last) = '?' or else Msg
(Msg
'Last) = '<' then
4979 -- In Ada 83, all messages are warnings. In the private part and the
4980 -- body of an instance, constraint_checks are only warnings. We also
4981 -- make this a warning if the Warn parameter is set.
4984 or else (Ada_Version
= Ada_83
and then Comes_From_Source
(N
))
4985 or else In_Instance_Not_Visible
4993 -- Otherwise we have a real error message (Ada 95 static case) and we
4994 -- make this an unconditional message. Note that in the warning case
4995 -- we do not make the message unconditional, it seems reasonable to
4996 -- delete messages like this (about exceptions that will be raised)
5005 -- One more test, skip the warning if the related expression is
5006 -- statically unevaluated, since we don't want to warn about what
5007 -- will happen when something is evaluated if it never will be
5010 if not Is_Statically_Unevaluated
(N
) then
5011 if Present
(Ent
) then
5012 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Ent
, Eloc
);
5014 Error_Msg_NEL
(Msgc
(1 .. Msgl
), N
, Etype
(N
), Eloc
);
5019 -- Check whether the context is an Init_Proc
5021 if Inside_Init_Proc
then
5023 Conc_Typ
: constant Entity_Id
:=
5024 Corresponding_Concurrent_Type
5025 (Entity
(Parameter_Type
(First
5026 (Parameter_Specifications
5027 (Parent
(Current_Scope
))))));
5030 -- Don't complain if the corresponding concurrent type
5031 -- doesn't come from source (i.e. a single task/protected
5034 if Present
(Conc_Typ
)
5035 and then not Comes_From_Source
(Conc_Typ
)
5038 ("\& [<<", N
, Standard_Constraint_Error
, Eloc
);
5041 if GNATprove_Mode
then
5043 ("\& would have been raised for objects of this "
5044 & "type", N
, Standard_Constraint_Error
, Eloc
);
5047 ("\& will be raised for objects of this type??",
5048 N
, Standard_Constraint_Error
, Eloc
);
5054 Error_Msg_NEL
("\& [<<", N
, Standard_Constraint_Error
, Eloc
);
5058 Error_Msg
("\static expression fails Constraint_Check", Eloc
);
5059 Set_Error_Posted
(N
);
5065 end Compile_Time_Constraint_Error
;
5067 -----------------------
5068 -- Conditional_Delay --
5069 -----------------------
5071 procedure Conditional_Delay
(New_Ent
, Old_Ent
: Entity_Id
) is
5073 if Has_Delayed_Freeze
(Old_Ent
) and then not Is_Frozen
(Old_Ent
) then
5074 Set_Has_Delayed_Freeze
(New_Ent
);
5076 end Conditional_Delay
;
5078 ----------------------------
5079 -- Contains_Refined_State --
5080 ----------------------------
5082 function Contains_Refined_State
(Prag
: Node_Id
) return Boolean is
5083 function Has_State_In_Dependency
(List
: Node_Id
) return Boolean;
5084 -- Determine whether a dependency list mentions a state with a visible
5087 function Has_State_In_Global
(List
: Node_Id
) return Boolean;
5088 -- Determine whether a global list mentions a state with a visible
5091 function Is_Refined_State
(Item
: Node_Id
) return Boolean;
5092 -- Determine whether Item is a reference to an abstract state with a
5093 -- visible refinement.
5095 -----------------------------
5096 -- Has_State_In_Dependency --
5097 -----------------------------
5099 function Has_State_In_Dependency
(List
: Node_Id
) return Boolean is
5104 -- A null dependency list does not mention any states
5106 if Nkind
(List
) = N_Null
then
5109 -- Dependency clauses appear as component associations of an
5112 elsif Nkind
(List
) = N_Aggregate
5113 and then Present
(Component_Associations
(List
))
5115 Clause
:= First
(Component_Associations
(List
));
5116 while Present
(Clause
) loop
5118 -- Inspect the outputs of a dependency clause
5120 Output
:= First
(Choices
(Clause
));
5121 while Present
(Output
) loop
5122 if Is_Refined_State
(Output
) then
5129 -- Inspect the outputs of a dependency clause
5131 if Is_Refined_State
(Expression
(Clause
)) then
5138 -- If we get here, then none of the dependency clauses mention a
5139 -- state with visible refinement.
5143 -- An illegal pragma managed to sneak in
5146 raise Program_Error
;
5148 end Has_State_In_Dependency
;
5150 -------------------------
5151 -- Has_State_In_Global --
5152 -------------------------
5154 function Has_State_In_Global
(List
: Node_Id
) return Boolean is
5158 -- A null global list does not mention any states
5160 if Nkind
(List
) = N_Null
then
5163 -- Simple global list or moded global list declaration
5165 elsif Nkind
(List
) = N_Aggregate
then
5167 -- The declaration of a simple global list appear as a collection
5170 if Present
(Expressions
(List
)) then
5171 Item
:= First
(Expressions
(List
));
5172 while Present
(Item
) loop
5173 if Is_Refined_State
(Item
) then
5180 -- The declaration of a moded global list appears as a collection
5181 -- of component associations where individual choices denote
5185 Item
:= First
(Component_Associations
(List
));
5186 while Present
(Item
) loop
5187 if Has_State_In_Global
(Expression
(Item
)) then
5195 -- If we get here, then the simple/moded global list did not
5196 -- mention any states with a visible refinement.
5200 -- Single global item declaration
5202 elsif Is_Entity_Name
(List
) then
5203 return Is_Refined_State
(List
);
5205 -- An illegal pragma managed to sneak in
5208 raise Program_Error
;
5210 end Has_State_In_Global
;
5212 ----------------------
5213 -- Is_Refined_State --
5214 ----------------------
5216 function Is_Refined_State
(Item
: Node_Id
) return Boolean is
5218 Item_Id
: Entity_Id
;
5221 if Nkind
(Item
) = N_Null
then
5224 -- States cannot be subject to attribute 'Result. This case arises
5225 -- in dependency relations.
5227 elsif Nkind
(Item
) = N_Attribute_Reference
5228 and then Attribute_Name
(Item
) = Name_Result
5232 -- Multiple items appear as an aggregate. This case arises in
5233 -- dependency relations.
5235 elsif Nkind
(Item
) = N_Aggregate
5236 and then Present
(Expressions
(Item
))
5238 Elmt
:= First
(Expressions
(Item
));
5239 while Present
(Elmt
) loop
5240 if Is_Refined_State
(Elmt
) then
5247 -- If we get here, then none of the inputs or outputs reference a
5248 -- state with visible refinement.
5255 Item_Id
:= Entity_Of
(Item
);
5259 and then Ekind
(Item_Id
) = E_Abstract_State
5260 and then Has_Visible_Refinement
(Item_Id
);
5262 end Is_Refined_State
;
5266 Arg
: constant Node_Id
:=
5267 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(Prag
)));
5268 Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
5270 -- Start of processing for Contains_Refined_State
5273 if Nam
= Name_Depends
then
5274 return Has_State_In_Dependency
(Arg
);
5276 else pragma Assert
(Nam
= Name_Global
);
5277 return Has_State_In_Global
(Arg
);
5279 end Contains_Refined_State
;
5281 -------------------------
5282 -- Copy_Component_List --
5283 -------------------------
5285 function Copy_Component_List
5287 Loc
: Source_Ptr
) return List_Id
5290 Comps
: constant List_Id
:= New_List
;
5293 Comp
:= First_Component
(Underlying_Type
(R_Typ
));
5294 while Present
(Comp
) loop
5295 if Comes_From_Source
(Comp
) then
5297 Comp_Decl
: constant Node_Id
:= Declaration_Node
(Comp
);
5300 Make_Component_Declaration
(Loc
,
5301 Defining_Identifier
=>
5302 Make_Defining_Identifier
(Loc
, Chars
(Comp
)),
5303 Component_Definition
=>
5305 (Component_Definition
(Comp_Decl
), New_Sloc
=> Loc
)));
5309 Next_Component
(Comp
);
5313 end Copy_Component_List
;
5315 -------------------------
5316 -- Copy_Parameter_List --
5317 -------------------------
5319 function Copy_Parameter_List
(Subp_Id
: Entity_Id
) return List_Id
is
5320 Loc
: constant Source_Ptr
:= Sloc
(Subp_Id
);
5325 if No
(First_Formal
(Subp_Id
)) then
5329 Formal
:= First_Formal
(Subp_Id
);
5330 while Present
(Formal
) loop
5332 Make_Parameter_Specification
(Loc
,
5333 Defining_Identifier
=>
5334 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
5335 In_Present
=> In_Present
(Parent
(Formal
)),
5336 Out_Present
=> Out_Present
(Parent
(Formal
)),
5338 New_Occurrence_Of
(Etype
(Formal
), Loc
),
5340 New_Copy_Tree
(Expression
(Parent
(Formal
)))));
5342 Next_Formal
(Formal
);
5347 end Copy_Parameter_List
;
5349 ----------------------------
5350 -- Copy_SPARK_Mode_Aspect --
5351 ----------------------------
5353 procedure Copy_SPARK_Mode_Aspect
(From
: Node_Id
; To
: Node_Id
) is
5354 pragma Assert
(not Has_Aspects
(To
));
5358 if Has_Aspects
(From
) then
5359 Asp
:= Find_Aspect
(Defining_Entity
(From
), Aspect_SPARK_Mode
);
5361 if Present
(Asp
) then
5362 Set_Aspect_Specifications
(To
, New_List
(New_Copy_Tree
(Asp
)));
5363 Set_Has_Aspects
(To
, True);
5366 end Copy_SPARK_Mode_Aspect
;
5368 --------------------------
5369 -- Copy_Subprogram_Spec --
5370 --------------------------
5372 function Copy_Subprogram_Spec
(Spec
: Node_Id
) return Node_Id
is
5374 Formal_Spec
: Node_Id
;
5378 -- The structure of the original tree must be replicated without any
5379 -- alterations. Use New_Copy_Tree for this purpose.
5381 Result
:= New_Copy_Tree
(Spec
);
5383 -- However, the spec of a null procedure carries the corresponding null
5384 -- statement of the body (created by the parser), and this cannot be
5385 -- shared with the new subprogram spec.
5387 if Nkind
(Result
) = N_Procedure_Specification
then
5388 Set_Null_Statement
(Result
, Empty
);
5391 -- Create a new entity for the defining unit name
5393 Def_Id
:= Defining_Unit_Name
(Result
);
5394 Set_Defining_Unit_Name
(Result
,
5395 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
5397 -- Create new entities for the formal parameters
5399 if Present
(Parameter_Specifications
(Result
)) then
5400 Formal_Spec
:= First
(Parameter_Specifications
(Result
));
5401 while Present
(Formal_Spec
) loop
5402 Def_Id
:= Defining_Identifier
(Formal_Spec
);
5403 Set_Defining_Identifier
(Formal_Spec
,
5404 Make_Defining_Identifier
(Sloc
(Def_Id
), Chars
(Def_Id
)));
5411 end Copy_Subprogram_Spec
;
5413 --------------------------------
5414 -- Corresponding_Generic_Type --
5415 --------------------------------
5417 function Corresponding_Generic_Type
(T
: Entity_Id
) return Entity_Id
is
5423 if not Is_Generic_Actual_Type
(T
) then
5426 -- If the actual is the actual of an enclosing instance, resolution
5427 -- was correct in the generic.
5429 elsif Nkind
(Parent
(T
)) = N_Subtype_Declaration
5430 and then Is_Entity_Name
(Subtype_Indication
(Parent
(T
)))
5432 Is_Generic_Actual_Type
(Entity
(Subtype_Indication
(Parent
(T
))))
5439 if Is_Wrapper_Package
(Inst
) then
5440 Inst
:= Related_Instance
(Inst
);
5445 (Specification
(Unit_Declaration_Node
(Inst
)));
5447 -- Generic actual has the same name as the corresponding formal
5449 Typ
:= First_Entity
(Gen
);
5450 while Present
(Typ
) loop
5451 if Chars
(Typ
) = Chars
(T
) then
5460 end Corresponding_Generic_Type
;
5462 --------------------
5463 -- Current_Entity --
5464 --------------------
5466 -- The currently visible definition for a given identifier is the
5467 -- one most chained at the start of the visibility chain, i.e. the
5468 -- one that is referenced by the Node_Id value of the name of the
5469 -- given identifier.
5471 function Current_Entity
(N
: Node_Id
) return Entity_Id
is
5473 return Get_Name_Entity_Id
(Chars
(N
));
5476 -----------------------------
5477 -- Current_Entity_In_Scope --
5478 -----------------------------
5480 function Current_Entity_In_Scope
(N
: Node_Id
) return Entity_Id
is
5482 CS
: constant Entity_Id
:= Current_Scope
;
5484 Transient_Case
: constant Boolean := Scope_Is_Transient
;
5487 E
:= Get_Name_Entity_Id
(Chars
(N
));
5489 and then Scope
(E
) /= CS
5490 and then (not Transient_Case
or else Scope
(E
) /= Scope
(CS
))
5496 end Current_Entity_In_Scope
;
5502 function Current_Scope
return Entity_Id
is
5504 if Scope_Stack
.Last
= -1 then
5505 return Standard_Standard
;
5508 C
: constant Entity_Id
:=
5509 Scope_Stack
.Table
(Scope_Stack
.Last
).Entity
;
5514 return Standard_Standard
;
5520 ----------------------------
5521 -- Current_Scope_No_Loops --
5522 ----------------------------
5524 function Current_Scope_No_Loops
return Entity_Id
is
5528 -- Examine the scope stack starting from the current scope and skip any
5529 -- internally generated loops.
5532 while Present
(S
) and then S
/= Standard_Standard
loop
5533 if Ekind
(S
) = E_Loop
and then not Comes_From_Source
(S
) then
5541 end Current_Scope_No_Loops
;
5543 ------------------------
5544 -- Current_Subprogram --
5545 ------------------------
5547 function Current_Subprogram
return Entity_Id
is
5548 Scop
: constant Entity_Id
:= Current_Scope
;
5550 if Is_Subprogram_Or_Generic_Subprogram
(Scop
) then
5553 return Enclosing_Subprogram
(Scop
);
5555 end Current_Subprogram
;
5557 ----------------------------------
5558 -- Deepest_Type_Access_Level --
5559 ----------------------------------
5561 function Deepest_Type_Access_Level
(Typ
: Entity_Id
) return Uint
is
5563 if Ekind
(Typ
) = E_Anonymous_Access_Type
5564 and then not Is_Local_Anonymous_Access
(Typ
)
5565 and then Nkind
(Associated_Node_For_Itype
(Typ
)) = N_Object_Declaration
5567 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
5571 Scope_Depth
(Enclosing_Dynamic_Scope
5572 (Defining_Identifier
5573 (Associated_Node_For_Itype
(Typ
))));
5575 -- For generic formal type, return Int'Last (infinite).
5576 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
5578 elsif Is_Generic_Type
(Root_Type
(Typ
)) then
5579 return UI_From_Int
(Int
'Last);
5582 return Type_Access_Level
(Typ
);
5584 end Deepest_Type_Access_Level
;
5586 ---------------------
5587 -- Defining_Entity --
5588 ---------------------
5590 function Defining_Entity
5592 Empty_On_Errors
: Boolean := False) return Entity_Id
5594 Err
: Entity_Id
:= Empty
;
5598 when N_Abstract_Subprogram_Declaration
5599 | N_Expression_Function
5600 | N_Formal_Subprogram_Declaration
5601 | N_Generic_Package_Declaration
5602 | N_Generic_Subprogram_Declaration
5603 | N_Package_Declaration
5605 | N_Subprogram_Body_Stub
5606 | N_Subprogram_Declaration
5607 | N_Subprogram_Renaming_Declaration
5609 return Defining_Entity
(Specification
(N
));
5611 when N_Component_Declaration
5612 | N_Defining_Program_Unit_Name
5613 | N_Discriminant_Specification
5615 | N_Entry_Declaration
5616 | N_Entry_Index_Specification
5617 | N_Exception_Declaration
5618 | N_Exception_Renaming_Declaration
5619 | N_Formal_Object_Declaration
5620 | N_Formal_Package_Declaration
5621 | N_Formal_Type_Declaration
5622 | N_Full_Type_Declaration
5623 | N_Implicit_Label_Declaration
5624 | N_Incomplete_Type_Declaration
5625 | N_Iterator_Specification
5626 | N_Loop_Parameter_Specification
5627 | N_Number_Declaration
5628 | N_Object_Declaration
5629 | N_Object_Renaming_Declaration
5630 | N_Package_Body_Stub
5631 | N_Parameter_Specification
5632 | N_Private_Extension_Declaration
5633 | N_Private_Type_Declaration
5635 | N_Protected_Body_Stub
5636 | N_Protected_Type_Declaration
5637 | N_Single_Protected_Declaration
5638 | N_Single_Task_Declaration
5639 | N_Subtype_Declaration
5642 | N_Task_Type_Declaration
5644 return Defining_Identifier
(N
);
5647 return Defining_Entity
(Proper_Body
(N
));
5649 when N_Function_Instantiation
5650 | N_Function_Specification
5651 | N_Generic_Function_Renaming_Declaration
5652 | N_Generic_Package_Renaming_Declaration
5653 | N_Generic_Procedure_Renaming_Declaration
5655 | N_Package_Instantiation
5656 | N_Package_Renaming_Declaration
5657 | N_Package_Specification
5658 | N_Procedure_Instantiation
5659 | N_Procedure_Specification
5662 Nam
: constant Node_Id
:= Defining_Unit_Name
(N
);
5665 if Nkind
(Nam
) in N_Entity
then
5668 -- For Error, make up a name and attach to declaration so we
5669 -- can continue semantic analysis.
5671 elsif Nam
= Error
then
5672 if Empty_On_Errors
then
5675 Err
:= Make_Temporary
(Sloc
(N
), 'T');
5676 Set_Defining_Unit_Name
(N
, Err
);
5681 -- If not an entity, get defining identifier
5684 return Defining_Identifier
(Nam
);
5688 when N_Block_Statement
5691 return Entity
(Identifier
(N
));
5694 if Empty_On_Errors
then
5697 raise Program_Error
;
5700 end Defining_Entity
;
5702 --------------------------
5703 -- Denotes_Discriminant --
5704 --------------------------
5706 function Denotes_Discriminant
5708 Check_Concurrent
: Boolean := False) return Boolean
5713 if not Is_Entity_Name
(N
) or else No
(Entity
(N
)) then
5719 -- If we are checking for a protected type, the discriminant may have
5720 -- been rewritten as the corresponding discriminal of the original type
5721 -- or of the corresponding concurrent record, depending on whether we
5722 -- are in the spec or body of the protected type.
5724 return Ekind
(E
) = E_Discriminant
5727 and then Ekind
(E
) = E_In_Parameter
5728 and then Present
(Discriminal_Link
(E
))
5730 (Is_Concurrent_Type
(Scope
(Discriminal_Link
(E
)))
5732 Is_Concurrent_Record_Type
(Scope
(Discriminal_Link
(E
)))));
5733 end Denotes_Discriminant
;
5735 -------------------------
5736 -- Denotes_Same_Object --
5737 -------------------------
5739 function Denotes_Same_Object
(A1
, A2
: Node_Id
) return Boolean is
5740 Obj1
: Node_Id
:= A1
;
5741 Obj2
: Node_Id
:= A2
;
5743 function Has_Prefix
(N
: Node_Id
) return Boolean;
5744 -- Return True if N has attribute Prefix
5746 function Is_Renaming
(N
: Node_Id
) return Boolean;
5747 -- Return true if N names a renaming entity
5749 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean;
5750 -- For renamings, return False if the prefix of any dereference within
5751 -- the renamed object_name is a variable, or any expression within the
5752 -- renamed object_name contains references to variables or calls on
5753 -- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
5759 function Has_Prefix
(N
: Node_Id
) return Boolean is
5763 N_Attribute_Reference
,
5765 N_Explicit_Dereference
,
5766 N_Indexed_Component
,
5768 N_Selected_Component
,
5776 function Is_Renaming
(N
: Node_Id
) return Boolean is
5778 return Is_Entity_Name
(N
)
5779 and then Present
(Renamed_Entity
(Entity
(N
)));
5782 -----------------------
5783 -- Is_Valid_Renaming --
5784 -----------------------
5786 function Is_Valid_Renaming
(N
: Node_Id
) return Boolean is
5788 function Check_Renaming
(N
: Node_Id
) return Boolean;
5789 -- Recursive function used to traverse all the prefixes of N
5791 function Check_Renaming
(N
: Node_Id
) return Boolean is
5794 and then not Check_Renaming
(Renamed_Entity
(Entity
(N
)))
5799 if Nkind
(N
) = N_Indexed_Component
then
5804 Indx
:= First
(Expressions
(N
));
5805 while Present
(Indx
) loop
5806 if not Is_OK_Static_Expression
(Indx
) then
5815 if Has_Prefix
(N
) then
5817 P
: constant Node_Id
:= Prefix
(N
);
5820 if Nkind
(N
) = N_Explicit_Dereference
5821 and then Is_Variable
(P
)
5825 elsif Is_Entity_Name
(P
)
5826 and then Ekind
(Entity
(P
)) = E_Function
5830 elsif Nkind
(P
) = N_Function_Call
then
5834 -- Recursion to continue traversing the prefix of the
5835 -- renaming expression
5837 return Check_Renaming
(P
);
5844 -- Start of processing for Is_Valid_Renaming
5847 return Check_Renaming
(N
);
5848 end Is_Valid_Renaming
;
5850 -- Start of processing for Denotes_Same_Object
5853 -- Both names statically denote the same stand-alone object or parameter
5854 -- (RM 6.4.1(6.5/3))
5856 if Is_Entity_Name
(Obj1
)
5857 and then Is_Entity_Name
(Obj2
)
5858 and then Entity
(Obj1
) = Entity
(Obj2
)
5863 -- For renamings, the prefix of any dereference within the renamed
5864 -- object_name is not a variable, and any expression within the
5865 -- renamed object_name contains no references to variables nor
5866 -- calls on nonstatic functions (RM 6.4.1(6.10/3)).
5868 if Is_Renaming
(Obj1
) then
5869 if Is_Valid_Renaming
(Obj1
) then
5870 Obj1
:= Renamed_Entity
(Entity
(Obj1
));
5876 if Is_Renaming
(Obj2
) then
5877 if Is_Valid_Renaming
(Obj2
) then
5878 Obj2
:= Renamed_Entity
(Entity
(Obj2
));
5884 -- No match if not same node kind (such cases are handled by
5885 -- Denotes_Same_Prefix)
5887 if Nkind
(Obj1
) /= Nkind
(Obj2
) then
5890 -- After handling valid renamings, one of the two names statically
5891 -- denoted a renaming declaration whose renamed object_name is known
5892 -- to denote the same object as the other (RM 6.4.1(6.10/3))
5894 elsif Is_Entity_Name
(Obj1
) then
5895 if Is_Entity_Name
(Obj2
) then
5896 return Entity
(Obj1
) = Entity
(Obj2
);
5901 -- Both names are selected_components, their prefixes are known to
5902 -- denote the same object, and their selector_names denote the same
5903 -- component (RM 6.4.1(6.6/3)).
5905 elsif Nkind
(Obj1
) = N_Selected_Component
then
5906 return Denotes_Same_Object
(Prefix
(Obj1
), Prefix
(Obj2
))
5908 Entity
(Selector_Name
(Obj1
)) = Entity
(Selector_Name
(Obj2
));
5910 -- Both names are dereferences and the dereferenced names are known to
5911 -- denote the same object (RM 6.4.1(6.7/3))
5913 elsif Nkind
(Obj1
) = N_Explicit_Dereference
then
5914 return Denotes_Same_Object
(Prefix
(Obj1
), Prefix
(Obj2
));
5916 -- Both names are indexed_components, their prefixes are known to denote
5917 -- the same object, and each of the pairs of corresponding index values
5918 -- are either both static expressions with the same static value or both
5919 -- names that are known to denote the same object (RM 6.4.1(6.8/3))
5921 elsif Nkind
(Obj1
) = N_Indexed_Component
then
5922 if not Denotes_Same_Object
(Prefix
(Obj1
), Prefix
(Obj2
)) then
5930 Indx1
:= First
(Expressions
(Obj1
));
5931 Indx2
:= First
(Expressions
(Obj2
));
5932 while Present
(Indx1
) loop
5934 -- Indexes must denote the same static value or same object
5936 if Is_OK_Static_Expression
(Indx1
) then
5937 if not Is_OK_Static_Expression
(Indx2
) then
5940 elsif Expr_Value
(Indx1
) /= Expr_Value
(Indx2
) then
5944 elsif not Denotes_Same_Object
(Indx1
, Indx2
) then
5956 -- Both names are slices, their prefixes are known to denote the same
5957 -- object, and the two slices have statically matching index constraints
5958 -- (RM 6.4.1(6.9/3))
5960 elsif Nkind
(Obj1
) = N_Slice
5961 and then Denotes_Same_Object
(Prefix
(Obj1
), Prefix
(Obj2
))
5964 Lo1
, Lo2
, Hi1
, Hi2
: Node_Id
;
5967 Get_Index_Bounds
(Etype
(Obj1
), Lo1
, Hi1
);
5968 Get_Index_Bounds
(Etype
(Obj2
), Lo2
, Hi2
);
5970 -- Check whether bounds are statically identical. There is no
5971 -- attempt to detect partial overlap of slices.
5973 return Denotes_Same_Object
(Lo1
, Lo2
)
5975 Denotes_Same_Object
(Hi1
, Hi2
);
5978 -- In the recursion, literals appear as indexes
5980 elsif Nkind
(Obj1
) = N_Integer_Literal
5982 Nkind
(Obj2
) = N_Integer_Literal
5984 return Intval
(Obj1
) = Intval
(Obj2
);
5989 end Denotes_Same_Object
;
5991 -------------------------
5992 -- Denotes_Same_Prefix --
5993 -------------------------
5995 function Denotes_Same_Prefix
(A1
, A2
: Node_Id
) return Boolean is
5997 if Is_Entity_Name
(A1
) then
5998 if Nkind_In
(A2
, N_Selected_Component
, N_Indexed_Component
)
5999 and then not Is_Access_Type
(Etype
(A1
))
6001 return Denotes_Same_Object
(A1
, Prefix
(A2
))
6002 or else Denotes_Same_Prefix
(A1
, Prefix
(A2
));
6007 elsif Is_Entity_Name
(A2
) then
6008 return Denotes_Same_Prefix
(A1
=> A2
, A2
=> A1
);
6010 elsif Nkind_In
(A1
, N_Selected_Component
, N_Indexed_Component
, N_Slice
)
6012 Nkind_In
(A2
, N_Selected_Component
, N_Indexed_Component
, N_Slice
)
6015 Root1
, Root2
: Node_Id
;
6016 Depth1
, Depth2
: Nat
:= 0;
6019 Root1
:= Prefix
(A1
);
6020 while not Is_Entity_Name
(Root1
) loop
6022 (Root1
, N_Selected_Component
, N_Indexed_Component
)
6026 Root1
:= Prefix
(Root1
);
6029 Depth1
:= Depth1
+ 1;
6032 Root2
:= Prefix
(A2
);
6033 while not Is_Entity_Name
(Root2
) loop
6034 if not Nkind_In
(Root2
, N_Selected_Component
,
6035 N_Indexed_Component
)
6039 Root2
:= Prefix
(Root2
);
6042 Depth2
:= Depth2
+ 1;
6045 -- If both have the same depth and they do not denote the same
6046 -- object, they are disjoint and no warning is needed.
6048 if Depth1
= Depth2
then
6051 elsif Depth1
> Depth2
then
6052 Root1
:= Prefix
(A1
);
6053 for J
in 1 .. Depth1
- Depth2
- 1 loop
6054 Root1
:= Prefix
(Root1
);
6057 return Denotes_Same_Object
(Root1
, A2
);
6060 Root2
:= Prefix
(A2
);
6061 for J
in 1 .. Depth2
- Depth1
- 1 loop
6062 Root2
:= Prefix
(Root2
);
6065 return Denotes_Same_Object
(A1
, Root2
);
6072 end Denotes_Same_Prefix
;
6074 ----------------------
6075 -- Denotes_Variable --
6076 ----------------------
6078 function Denotes_Variable
(N
: Node_Id
) return Boolean is
6080 return Is_Variable
(N
) and then Paren_Count
(N
) = 0;
6081 end Denotes_Variable
;
6083 -----------------------------
6084 -- Depends_On_Discriminant --
6085 -----------------------------
6087 function Depends_On_Discriminant
(N
: Node_Id
) return Boolean is
6092 Get_Index_Bounds
(N
, L
, H
);
6093 return Denotes_Discriminant
(L
) or else Denotes_Discriminant
(H
);
6094 end Depends_On_Discriminant
;
6096 -------------------------
6097 -- Designate_Same_Unit --
6098 -------------------------
6100 function Designate_Same_Unit
6102 Name2
: Node_Id
) return Boolean
6104 K1
: constant Node_Kind
:= Nkind
(Name1
);
6105 K2
: constant Node_Kind
:= Nkind
(Name2
);
6107 function Prefix_Node
(N
: Node_Id
) return Node_Id
;
6108 -- Returns the parent unit name node of a defining program unit name
6109 -- or the prefix if N is a selected component or an expanded name.
6111 function Select_Node
(N
: Node_Id
) return Node_Id
;
6112 -- Returns the defining identifier node of a defining program unit
6113 -- name or the selector node if N is a selected component or an
6120 function Prefix_Node
(N
: Node_Id
) return Node_Id
is
6122 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
6133 function Select_Node
(N
: Node_Id
) return Node_Id
is
6135 if Nkind
(N
) = N_Defining_Program_Unit_Name
then
6136 return Defining_Identifier
(N
);
6138 return Selector_Name
(N
);
6142 -- Start of processing for Designate_Same_Unit
6145 if Nkind_In
(K1
, N_Identifier
, N_Defining_Identifier
)
6147 Nkind_In
(K2
, N_Identifier
, N_Defining_Identifier
)
6149 return Chars
(Name1
) = Chars
(Name2
);
6151 elsif Nkind_In
(K1
, N_Expanded_Name
,
6152 N_Selected_Component
,
6153 N_Defining_Program_Unit_Name
)
6155 Nkind_In
(K2
, N_Expanded_Name
,
6156 N_Selected_Component
,
6157 N_Defining_Program_Unit_Name
)
6160 (Chars
(Select_Node
(Name1
)) = Chars
(Select_Node
(Name2
)))
6162 Designate_Same_Unit
(Prefix_Node
(Name1
), Prefix_Node
(Name2
));
6167 end Designate_Same_Unit
;
6169 ---------------------------------------------
6170 -- Diagnose_Iterated_Component_Association --
6171 ---------------------------------------------
6173 procedure Diagnose_Iterated_Component_Association
(N
: Node_Id
) is
6174 Def_Id
: constant Entity_Id
:= Defining_Identifier
(N
);
6178 -- Determine whether the iterated component association appears within
6179 -- an aggregate. If this is the case, raise Program_Error because the
6180 -- iterated component association cannot be left in the tree as is and
6181 -- must always be processed by the related aggregate.
6184 while Present
(Aggr
) loop
6185 if Nkind
(Aggr
) = N_Aggregate
then
6186 raise Program_Error
;
6188 -- Prevent the search from going too far
6190 elsif Is_Body_Or_Package_Declaration
(Aggr
) then
6194 Aggr
:= Parent
(Aggr
);
6197 -- At this point it is known that the iterated component association is
6198 -- not within an aggregate. This is really a quantified expression with
6199 -- a missing "all" or "some" quantifier.
6201 Error_Msg_N
("missing quantifier", Def_Id
);
6203 -- Rewrite the iterated component association as True to prevent any
6206 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Sloc
(N
)));
6208 end Diagnose_Iterated_Component_Association
;
6210 ---------------------------------
6211 -- Dynamic_Accessibility_Level --
6212 ---------------------------------
6214 function Dynamic_Accessibility_Level
(Expr
: Node_Id
) return Node_Id
is
6215 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6217 function Make_Level_Literal
(Level
: Uint
) return Node_Id
;
6218 -- Construct an integer literal representing an accessibility level
6219 -- with its type set to Natural.
6221 ------------------------
6222 -- Make_Level_Literal --
6223 ------------------------
6225 function Make_Level_Literal
(Level
: Uint
) return Node_Id
is
6226 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Level
);
6229 Set_Etype
(Result
, Standard_Natural
);
6231 end Make_Level_Literal
;
6237 -- Start of processing for Dynamic_Accessibility_Level
6240 if Is_Entity_Name
(Expr
) then
6243 if Present
(Renamed_Object
(E
)) then
6244 return Dynamic_Accessibility_Level
(Renamed_Object
(E
));
6247 if Is_Formal
(E
) or else Ekind_In
(E
, E_Variable
, E_Constant
) then
6248 if Present
(Extra_Accessibility
(E
)) then
6249 return New_Occurrence_Of
(Extra_Accessibility
(E
), Loc
);
6254 -- Unimplemented: Ptr.all'Access, where Ptr has Extra_Accessibility ???
6256 case Nkind
(Expr
) is
6258 -- For access discriminant, the level of the enclosing object
6260 when N_Selected_Component
=>
6261 if Ekind
(Entity
(Selector_Name
(Expr
))) = E_Discriminant
6262 and then Ekind
(Etype
(Entity
(Selector_Name
(Expr
)))) =
6263 E_Anonymous_Access_Type
6265 return Make_Level_Literal
(Object_Access_Level
(Expr
));
6268 when N_Attribute_Reference
=>
6269 case Get_Attribute_Id
(Attribute_Name
(Expr
)) is
6271 -- For X'Access, the level of the prefix X
6273 when Attribute_Access
=>
6274 return Make_Level_Literal
6275 (Object_Access_Level
(Prefix
(Expr
)));
6277 -- Treat the unchecked attributes as library-level
6279 when Attribute_Unchecked_Access
6280 | Attribute_Unrestricted_Access
6282 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
6284 -- No other access-valued attributes
6287 raise Program_Error
;
6292 -- Unimplemented: depends on context. As an actual parameter where
6293 -- formal type is anonymous, use
6294 -- Scope_Depth (Current_Scope) + 1.
6295 -- For other cases, see 3.10.2(14/3) and following. ???
6299 when N_Type_Conversion
=>
6300 if not Is_Local_Anonymous_Access
(Etype
(Expr
)) then
6302 -- Handle type conversions introduced for a rename of an
6303 -- Ada 2012 stand-alone object of an anonymous access type.
6305 return Dynamic_Accessibility_Level
(Expression
(Expr
));
6312 return Make_Level_Literal
(Type_Access_Level
(Etype
(Expr
)));
6313 end Dynamic_Accessibility_Level
;
6315 ------------------------
6316 -- Discriminated_Size --
6317 ------------------------
6319 function Discriminated_Size
(Comp
: Entity_Id
) return Boolean is
6320 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean;
6321 -- Check whether the bound of an index is non-static and does denote
6322 -- a discriminant, in which case any object of the type (protected or
6323 -- otherwise) will have a non-static size.
6325 ----------------------
6326 -- Non_Static_Bound --
6327 ----------------------
6329 function Non_Static_Bound
(Bound
: Node_Id
) return Boolean is
6331 if Is_OK_Static_Expression
(Bound
) then
6334 -- If the bound is given by a discriminant it is non-static
6335 -- (A static constraint replaces the reference with the value).
6336 -- In an protected object the discriminant has been replaced by
6337 -- the corresponding discriminal within the protected operation.
6339 elsif Is_Entity_Name
(Bound
)
6341 (Ekind
(Entity
(Bound
)) = E_Discriminant
6342 or else Present
(Discriminal_Link
(Entity
(Bound
))))
6349 end Non_Static_Bound
;
6353 Typ
: constant Entity_Id
:= Etype
(Comp
);
6356 -- Start of processing for Discriminated_Size
6359 if not Is_Array_Type
(Typ
) then
6363 if Ekind
(Typ
) = E_Array_Subtype
then
6364 Index
:= First_Index
(Typ
);
6365 while Present
(Index
) loop
6366 if Non_Static_Bound
(Low_Bound
(Index
))
6367 or else Non_Static_Bound
(High_Bound
(Index
))
6379 end Discriminated_Size
;
6381 -----------------------------------
6382 -- Effective_Extra_Accessibility --
6383 -----------------------------------
6385 function Effective_Extra_Accessibility
(Id
: Entity_Id
) return Entity_Id
is
6387 if Present
(Renamed_Object
(Id
))
6388 and then Is_Entity_Name
(Renamed_Object
(Id
))
6390 return Effective_Extra_Accessibility
(Entity
(Renamed_Object
(Id
)));
6392 return Extra_Accessibility
(Id
);
6394 end Effective_Extra_Accessibility
;
6396 -----------------------------
6397 -- Effective_Reads_Enabled --
6398 -----------------------------
6400 function Effective_Reads_Enabled
(Id
: Entity_Id
) return Boolean is
6402 return Has_Enabled_Property
(Id
, Name_Effective_Reads
);
6403 end Effective_Reads_Enabled
;
6405 ------------------------------
6406 -- Effective_Writes_Enabled --
6407 ------------------------------
6409 function Effective_Writes_Enabled
(Id
: Entity_Id
) return Boolean is
6411 return Has_Enabled_Property
(Id
, Name_Effective_Writes
);
6412 end Effective_Writes_Enabled
;
6414 ------------------------------
6415 -- Enclosing_Comp_Unit_Node --
6416 ------------------------------
6418 function Enclosing_Comp_Unit_Node
(N
: Node_Id
) return Node_Id
is
6419 Current_Node
: Node_Id
;
6423 while Present
(Current_Node
)
6424 and then Nkind
(Current_Node
) /= N_Compilation_Unit
6426 Current_Node
:= Parent
(Current_Node
);
6429 if Nkind
(Current_Node
) /= N_Compilation_Unit
then
6432 return Current_Node
;
6434 end Enclosing_Comp_Unit_Node
;
6436 --------------------------
6437 -- Enclosing_CPP_Parent --
6438 --------------------------
6440 function Enclosing_CPP_Parent
(Typ
: Entity_Id
) return Entity_Id
is
6441 Parent_Typ
: Entity_Id
:= Typ
;
6444 while not Is_CPP_Class
(Parent_Typ
)
6445 and then Etype
(Parent_Typ
) /= Parent_Typ
6447 Parent_Typ
:= Etype
(Parent_Typ
);
6449 if Is_Private_Type
(Parent_Typ
) then
6450 Parent_Typ
:= Full_View
(Base_Type
(Parent_Typ
));
6454 pragma Assert
(Is_CPP_Class
(Parent_Typ
));
6456 end Enclosing_CPP_Parent
;
6458 ---------------------------
6459 -- Enclosing_Declaration --
6460 ---------------------------
6462 function Enclosing_Declaration
(N
: Node_Id
) return Node_Id
is
6463 Decl
: Node_Id
:= N
;
6466 while Present
(Decl
)
6467 and then not (Nkind
(Decl
) in N_Declaration
6469 Nkind
(Decl
) in N_Later_Decl_Item
)
6471 Decl
:= Parent
(Decl
);
6475 end Enclosing_Declaration
;
6477 ----------------------------
6478 -- Enclosing_Generic_Body --
6479 ----------------------------
6481 function Enclosing_Generic_Body
6482 (N
: Node_Id
) return Node_Id
6490 while Present
(P
) loop
6491 if Nkind
(P
) = N_Package_Body
6492 or else Nkind
(P
) = N_Subprogram_Body
6494 Spec
:= Corresponding_Spec
(P
);
6496 if Present
(Spec
) then
6497 Decl
:= Unit_Declaration_Node
(Spec
);
6499 if Nkind
(Decl
) = N_Generic_Package_Declaration
6500 or else Nkind
(Decl
) = N_Generic_Subprogram_Declaration
6511 end Enclosing_Generic_Body
;
6513 ----------------------------
6514 -- Enclosing_Generic_Unit --
6515 ----------------------------
6517 function Enclosing_Generic_Unit
6518 (N
: Node_Id
) return Node_Id
6526 while Present
(P
) loop
6527 if Nkind
(P
) = N_Generic_Package_Declaration
6528 or else Nkind
(P
) = N_Generic_Subprogram_Declaration
6532 elsif Nkind
(P
) = N_Package_Body
6533 or else Nkind
(P
) = N_Subprogram_Body
6535 Spec
:= Corresponding_Spec
(P
);
6537 if Present
(Spec
) then
6538 Decl
:= Unit_Declaration_Node
(Spec
);
6540 if Nkind
(Decl
) = N_Generic_Package_Declaration
6541 or else Nkind
(Decl
) = N_Generic_Subprogram_Declaration
6552 end Enclosing_Generic_Unit
;
6554 -------------------------------
6555 -- Enclosing_Lib_Unit_Entity --
6556 -------------------------------
6558 function Enclosing_Lib_Unit_Entity
6559 (E
: Entity_Id
:= Current_Scope
) return Entity_Id
6561 Unit_Entity
: Entity_Id
;
6564 -- Look for enclosing library unit entity by following scope links.
6565 -- Equivalent to, but faster than indexing through the scope stack.
6568 while (Present
(Scope
(Unit_Entity
))
6569 and then Scope
(Unit_Entity
) /= Standard_Standard
)
6570 and not Is_Child_Unit
(Unit_Entity
)
6572 Unit_Entity
:= Scope
(Unit_Entity
);
6576 end Enclosing_Lib_Unit_Entity
;
6578 -----------------------------
6579 -- Enclosing_Lib_Unit_Node --
6580 -----------------------------
6582 function Enclosing_Lib_Unit_Node
(N
: Node_Id
) return Node_Id
is
6583 Encl_Unit
: Node_Id
;
6586 Encl_Unit
:= Enclosing_Comp_Unit_Node
(N
);
6587 while Present
(Encl_Unit
)
6588 and then Nkind
(Unit
(Encl_Unit
)) = N_Subunit
6590 Encl_Unit
:= Library_Unit
(Encl_Unit
);
6593 pragma Assert
(Nkind
(Encl_Unit
) = N_Compilation_Unit
);
6595 end Enclosing_Lib_Unit_Node
;
6597 -----------------------
6598 -- Enclosing_Package --
6599 -----------------------
6601 function Enclosing_Package
(E
: Entity_Id
) return Entity_Id
is
6602 Dynamic_Scope
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(E
);
6605 if Dynamic_Scope
= Standard_Standard
then
6606 return Standard_Standard
;
6608 elsif Dynamic_Scope
= Empty
then
6611 elsif Ekind_In
(Dynamic_Scope
, E_Package
, E_Package_Body
,
6614 return Dynamic_Scope
;
6617 return Enclosing_Package
(Dynamic_Scope
);
6619 end Enclosing_Package
;
6621 -------------------------------------
6622 -- Enclosing_Package_Or_Subprogram --
6623 -------------------------------------
6625 function Enclosing_Package_Or_Subprogram
(E
: Entity_Id
) return Entity_Id
is
6630 while Present
(S
) loop
6631 if Is_Package_Or_Generic_Package
(S
)
6632 or else Ekind
(S
) = E_Package_Body
6636 elsif Is_Subprogram_Or_Generic_Subprogram
(S
)
6637 or else Ekind
(S
) = E_Subprogram_Body
6647 end Enclosing_Package_Or_Subprogram
;
6649 --------------------------
6650 -- Enclosing_Subprogram --
6651 --------------------------
6653 function Enclosing_Subprogram
(E
: Entity_Id
) return Entity_Id
is
6654 Dynamic_Scope
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(E
);
6657 if Dynamic_Scope
= Standard_Standard
then
6660 elsif Dynamic_Scope
= Empty
then
6663 elsif Ekind
(Dynamic_Scope
) = E_Subprogram_Body
then
6664 return Corresponding_Spec
(Parent
(Parent
(Dynamic_Scope
)));
6666 elsif Ekind
(Dynamic_Scope
) = E_Block
6667 or else Ekind
(Dynamic_Scope
) = E_Return_Statement
6669 return Enclosing_Subprogram
(Dynamic_Scope
);
6671 elsif Ekind
(Dynamic_Scope
) = E_Task_Type
then
6672 return Get_Task_Body_Procedure
(Dynamic_Scope
);
6674 elsif Ekind
(Dynamic_Scope
) = E_Limited_Private_Type
6675 and then Present
(Full_View
(Dynamic_Scope
))
6676 and then Ekind
(Full_View
(Dynamic_Scope
)) = E_Task_Type
6678 return Get_Task_Body_Procedure
(Full_View
(Dynamic_Scope
));
6680 -- No body is generated if the protected operation is eliminated
6682 elsif Convention
(Dynamic_Scope
) = Convention_Protected
6683 and then not Is_Eliminated
(Dynamic_Scope
)
6684 and then Present
(Protected_Body_Subprogram
(Dynamic_Scope
))
6686 return Protected_Body_Subprogram
(Dynamic_Scope
);
6689 return Dynamic_Scope
;
6691 end Enclosing_Subprogram
;
6693 ------------------------
6694 -- Ensure_Freeze_Node --
6695 ------------------------
6697 procedure Ensure_Freeze_Node
(E
: Entity_Id
) is
6700 if No
(Freeze_Node
(E
)) then
6701 FN
:= Make_Freeze_Entity
(Sloc
(E
));
6702 Set_Has_Delayed_Freeze
(E
);
6703 Set_Freeze_Node
(E
, FN
);
6704 Set_Access_Types_To_Process
(FN
, No_Elist
);
6705 Set_TSS_Elist
(FN
, No_Elist
);
6708 end Ensure_Freeze_Node
;
6714 procedure Enter_Name
(Def_Id
: Entity_Id
) is
6715 C
: constant Entity_Id
:= Current_Entity
(Def_Id
);
6716 E
: constant Entity_Id
:= Current_Entity_In_Scope
(Def_Id
);
6717 S
: constant Entity_Id
:= Current_Scope
;
6720 Generate_Definition
(Def_Id
);
6722 -- Add new name to current scope declarations. Check for duplicate
6723 -- declaration, which may or may not be a genuine error.
6727 -- Case of previous entity entered because of a missing declaration
6728 -- or else a bad subtype indication. Best is to use the new entity,
6729 -- and make the previous one invisible.
6731 if Etype
(E
) = Any_Type
then
6732 Set_Is_Immediately_Visible
(E
, False);
6734 -- Case of renaming declaration constructed for package instances.
6735 -- if there is an explicit declaration with the same identifier,
6736 -- the renaming is not immediately visible any longer, but remains
6737 -- visible through selected component notation.
6739 elsif Nkind
(Parent
(E
)) = N_Package_Renaming_Declaration
6740 and then not Comes_From_Source
(E
)
6742 Set_Is_Immediately_Visible
(E
, False);
6744 -- The new entity may be the package renaming, which has the same
6745 -- same name as a generic formal which has been seen already.
6747 elsif Nkind
(Parent
(Def_Id
)) = N_Package_Renaming_Declaration
6748 and then not Comes_From_Source
(Def_Id
)
6750 Set_Is_Immediately_Visible
(E
, False);
6752 -- For a fat pointer corresponding to a remote access to subprogram,
6753 -- we use the same identifier as the RAS type, so that the proper
6754 -- name appears in the stub. This type is only retrieved through
6755 -- the RAS type and never by visibility, and is not added to the
6756 -- visibility list (see below).
6758 elsif Nkind
(Parent
(Def_Id
)) = N_Full_Type_Declaration
6759 and then Ekind
(Def_Id
) = E_Record_Type
6760 and then Present
(Corresponding_Remote_Type
(Def_Id
))
6764 -- Case of an implicit operation or derived literal. The new entity
6765 -- hides the implicit one, which is removed from all visibility,
6766 -- i.e. the entity list of its scope, and homonym chain of its name.
6768 elsif (Is_Overloadable
(E
) and then Is_Inherited_Operation
(E
))
6769 or else Is_Internal
(E
)
6772 Decl
: constant Node_Id
:= Parent
(E
);
6774 Prev_Vis
: Entity_Id
;
6777 -- If E is an implicit declaration, it cannot be the first
6778 -- entity in the scope.
6780 Prev
:= First_Entity
(Current_Scope
);
6781 while Present
(Prev
) and then Next_Entity
(Prev
) /= E
loop
6787 -- If E is not on the entity chain of the current scope,
6788 -- it is an implicit declaration in the generic formal
6789 -- part of a generic subprogram. When analyzing the body,
6790 -- the generic formals are visible but not on the entity
6791 -- chain of the subprogram. The new entity will become
6792 -- the visible one in the body.
6795 (Nkind
(Parent
(Decl
)) = N_Generic_Subprogram_Declaration
);
6799 Set_Next_Entity
(Prev
, Next_Entity
(E
));
6801 if No
(Next_Entity
(Prev
)) then
6802 Set_Last_Entity
(Current_Scope
, Prev
);
6805 if E
= Current_Entity
(E
) then
6809 Prev_Vis
:= Current_Entity
(E
);
6810 while Homonym
(Prev_Vis
) /= E
loop
6811 Prev_Vis
:= Homonym
(Prev_Vis
);
6815 if Present
(Prev_Vis
) then
6817 -- Skip E in the visibility chain
6819 Set_Homonym
(Prev_Vis
, Homonym
(E
));
6822 Set_Name_Entity_Id
(Chars
(E
), Homonym
(E
));
6827 -- This section of code could use a comment ???
6829 elsif Present
(Etype
(E
))
6830 and then Is_Concurrent_Type
(Etype
(E
))
6835 -- If the homograph is a protected component renaming, it should not
6836 -- be hiding the current entity. Such renamings are treated as weak
6839 elsif Is_Prival
(E
) then
6840 Set_Is_Immediately_Visible
(E
, False);
6842 -- In this case the current entity is a protected component renaming.
6843 -- Perform minimal decoration by setting the scope and return since
6844 -- the prival should not be hiding other visible entities.
6846 elsif Is_Prival
(Def_Id
) then
6847 Set_Scope
(Def_Id
, Current_Scope
);
6850 -- Analogous to privals, the discriminal generated for an entry index
6851 -- parameter acts as a weak declaration. Perform minimal decoration
6852 -- to avoid bogus errors.
6854 elsif Is_Discriminal
(Def_Id
)
6855 and then Ekind
(Discriminal_Link
(Def_Id
)) = E_Entry_Index_Parameter
6857 Set_Scope
(Def_Id
, Current_Scope
);
6860 -- In the body or private part of an instance, a type extension may
6861 -- introduce a component with the same name as that of an actual. The
6862 -- legality rule is not enforced, but the semantics of the full type
6863 -- with two components of same name are not clear at this point???
6865 elsif In_Instance_Not_Visible
then
6868 -- When compiling a package body, some child units may have become
6869 -- visible. They cannot conflict with local entities that hide them.
6871 elsif Is_Child_Unit
(E
)
6872 and then In_Open_Scopes
(Scope
(E
))
6873 and then not Is_Immediately_Visible
(E
)
6877 -- Conversely, with front-end inlining we may compile the parent body
6878 -- first, and a child unit subsequently. The context is now the
6879 -- parent spec, and body entities are not visible.
6881 elsif Is_Child_Unit
(Def_Id
)
6882 and then Is_Package_Body_Entity
(E
)
6883 and then not In_Package_Body
(Current_Scope
)
6887 -- Case of genuine duplicate declaration
6890 Error_Msg_Sloc
:= Sloc
(E
);
6892 -- If the previous declaration is an incomplete type declaration
6893 -- this may be an attempt to complete it with a private type. The
6894 -- following avoids confusing cascaded errors.
6896 if Nkind
(Parent
(E
)) = N_Incomplete_Type_Declaration
6897 and then Nkind
(Parent
(Def_Id
)) = N_Private_Type_Declaration
6900 ("incomplete type cannot be completed with a private " &
6901 "declaration", Parent
(Def_Id
));
6902 Set_Is_Immediately_Visible
(E
, False);
6903 Set_Full_View
(E
, Def_Id
);
6905 -- An inherited component of a record conflicts with a new
6906 -- discriminant. The discriminant is inserted first in the scope,
6907 -- but the error should be posted on it, not on the component.
6909 elsif Ekind
(E
) = E_Discriminant
6910 and then Present
(Scope
(Def_Id
))
6911 and then Scope
(Def_Id
) /= Current_Scope
6913 Error_Msg_Sloc
:= Sloc
(Def_Id
);
6914 Error_Msg_N
("& conflicts with declaration#", E
);
6917 -- If the name of the unit appears in its own context clause, a
6918 -- dummy package with the name has already been created, and the
6919 -- error emitted. Try to continue quietly.
6921 elsif Error_Posted
(E
)
6922 and then Sloc
(E
) = No_Location
6923 and then Nkind
(Parent
(E
)) = N_Package_Specification
6924 and then Current_Scope
= Standard_Standard
6926 Set_Scope
(Def_Id
, Current_Scope
);
6930 Error_Msg_N
("& conflicts with declaration#", Def_Id
);
6932 -- Avoid cascaded messages with duplicate components in
6935 if Ekind_In
(E
, E_Component
, E_Discriminant
) then
6940 if Nkind
(Parent
(Parent
(Def_Id
))) =
6941 N_Generic_Subprogram_Declaration
6943 Defining_Entity
(Specification
(Parent
(Parent
(Def_Id
))))
6945 Error_Msg_N
("\generic units cannot be overloaded", Def_Id
);
6948 -- If entity is in standard, then we are in trouble, because it
6949 -- means that we have a library package with a duplicated name.
6950 -- That's hard to recover from, so abort.
6952 if S
= Standard_Standard
then
6953 raise Unrecoverable_Error
;
6955 -- Otherwise we continue with the declaration. Having two
6956 -- identical declarations should not cause us too much trouble.
6964 -- If we fall through, declaration is OK, at least OK enough to continue
6966 -- If Def_Id is a discriminant or a record component we are in the midst
6967 -- of inheriting components in a derived record definition. Preserve
6968 -- their Ekind and Etype.
6970 if Ekind_In
(Def_Id
, E_Discriminant
, E_Component
) then
6973 -- If a type is already set, leave it alone (happens when a type
6974 -- declaration is reanalyzed following a call to the optimizer).
6976 elsif Present
(Etype
(Def_Id
)) then
6979 -- Otherwise, the kind E_Void insures that premature uses of the entity
6980 -- will be detected. Any_Type insures that no cascaded errors will occur
6983 Set_Ekind
(Def_Id
, E_Void
);
6984 Set_Etype
(Def_Id
, Any_Type
);
6987 -- Inherited discriminants and components in derived record types are
6988 -- immediately visible. Itypes are not.
6990 -- Unless the Itype is for a record type with a corresponding remote
6991 -- type (what is that about, it was not commented ???)
6993 if Ekind_In
(Def_Id
, E_Discriminant
, E_Component
)
6995 ((not Is_Record_Type
(Def_Id
)
6996 or else No
(Corresponding_Remote_Type
(Def_Id
)))
6997 and then not Is_Itype
(Def_Id
))
6999 Set_Is_Immediately_Visible
(Def_Id
);
7000 Set_Current_Entity
(Def_Id
);
7003 Set_Homonym
(Def_Id
, C
);
7004 Append_Entity
(Def_Id
, S
);
7005 Set_Public_Status
(Def_Id
);
7007 -- Declaring a homonym is not allowed in SPARK ...
7009 if Present
(C
) and then Restriction_Check_Required
(SPARK_05
) then
7011 Enclosing_Subp
: constant Node_Id
:= Enclosing_Subprogram
(Def_Id
);
7012 Enclosing_Pack
: constant Node_Id
:= Enclosing_Package
(Def_Id
);
7013 Other_Scope
: constant Node_Id
:= Enclosing_Dynamic_Scope
(C
);
7016 -- ... unless the new declaration is in a subprogram, and the
7017 -- visible declaration is a variable declaration or a parameter
7018 -- specification outside that subprogram.
7020 if Present
(Enclosing_Subp
)
7021 and then Nkind_In
(Parent
(C
), N_Object_Declaration
,
7022 N_Parameter_Specification
)
7023 and then not Scope_Within_Or_Same
(Other_Scope
, Enclosing_Subp
)
7027 -- ... or the new declaration is in a package, and the visible
7028 -- declaration occurs outside that package.
7030 elsif Present
(Enclosing_Pack
)
7031 and then not Scope_Within_Or_Same
(Other_Scope
, Enclosing_Pack
)
7035 -- ... or the new declaration is a component declaration in a
7036 -- record type definition.
7038 elsif Nkind
(Parent
(Def_Id
)) = N_Component_Declaration
then
7041 -- Don't issue error for non-source entities
7043 elsif Comes_From_Source
(Def_Id
)
7044 and then Comes_From_Source
(C
)
7046 Error_Msg_Sloc
:= Sloc
(C
);
7047 Check_SPARK_05_Restriction
7048 ("redeclaration of identifier &#", Def_Id
);
7053 -- Warn if new entity hides an old one
7055 if Warn_On_Hiding
and then Present
(C
)
7057 -- Don't warn for record components since they always have a well
7058 -- defined scope which does not confuse other uses. Note that in
7059 -- some cases, Ekind has not been set yet.
7061 and then Ekind
(C
) /= E_Component
7062 and then Ekind
(C
) /= E_Discriminant
7063 and then Nkind
(Parent
(C
)) /= N_Component_Declaration
7064 and then Ekind
(Def_Id
) /= E_Component
7065 and then Ekind
(Def_Id
) /= E_Discriminant
7066 and then Nkind
(Parent
(Def_Id
)) /= N_Component_Declaration
7068 -- Don't warn for one character variables. It is too common to use
7069 -- such variables as locals and will just cause too many false hits.
7071 and then Length_Of_Name
(Chars
(C
)) /= 1
7073 -- Don't warn for non-source entities
7075 and then Comes_From_Source
(C
)
7076 and then Comes_From_Source
(Def_Id
)
7078 -- Don't warn unless entity in question is in extended main source
7080 and then In_Extended_Main_Source_Unit
(Def_Id
)
7082 -- Finally, the hidden entity must be either immediately visible or
7083 -- use visible (i.e. from a used package).
7086 (Is_Immediately_Visible
(C
)
7088 Is_Potentially_Use_Visible
(C
))
7090 Error_Msg_Sloc
:= Sloc
(C
);
7091 Error_Msg_N
("declaration hides &#?h?", Def_Id
);
7099 function Entity_Of
(N
: Node_Id
) return Entity_Id
is
7105 if Is_Entity_Name
(N
) then
7108 -- Follow a possible chain of renamings to reach the root renamed
7112 and then Is_Object
(Id
)
7113 and then Present
(Renamed_Object
(Id
))
7115 if Is_Entity_Name
(Renamed_Object
(Id
)) then
7116 Id
:= Entity
(Renamed_Object
(Id
));
7127 --------------------------
7128 -- Explain_Limited_Type --
7129 --------------------------
7131 procedure Explain_Limited_Type
(T
: Entity_Id
; N
: Node_Id
) is
7135 -- For array, component type must be limited
7137 if Is_Array_Type
(T
) then
7138 Error_Msg_Node_2
:= T
;
7140 ("\component type& of type& is limited", N
, Component_Type
(T
));
7141 Explain_Limited_Type
(Component_Type
(T
), N
);
7143 elsif Is_Record_Type
(T
) then
7145 -- No need for extra messages if explicit limited record
7147 if Is_Limited_Record
(Base_Type
(T
)) then
7151 -- Otherwise find a limited component. Check only components that
7152 -- come from source, or inherited components that appear in the
7153 -- source of the ancestor.
7155 C
:= First_Component
(T
);
7156 while Present
(C
) loop
7157 if Is_Limited_Type
(Etype
(C
))
7159 (Comes_From_Source
(C
)
7161 (Present
(Original_Record_Component
(C
))
7163 Comes_From_Source
(Original_Record_Component
(C
))))
7165 Error_Msg_Node_2
:= T
;
7166 Error_Msg_NE
("\component& of type& has limited type", N
, C
);
7167 Explain_Limited_Type
(Etype
(C
), N
);
7174 -- The type may be declared explicitly limited, even if no component
7175 -- of it is limited, in which case we fall out of the loop.
7178 end Explain_Limited_Type
;
7180 ---------------------------------------
7181 -- Expression_Of_Expression_Function --
7182 ---------------------------------------
7184 function Expression_Of_Expression_Function
7185 (Subp
: Entity_Id
) return Node_Id
7187 Expr_Func
: Node_Id
;
7190 pragma Assert
(Is_Expression_Function_Or_Completion
(Subp
));
7192 if Nkind
(Original_Node
(Subprogram_Spec
(Subp
))) =
7193 N_Expression_Function
7195 Expr_Func
:= Original_Node
(Subprogram_Spec
(Subp
));
7197 elsif Nkind
(Original_Node
(Subprogram_Body
(Subp
))) =
7198 N_Expression_Function
7200 Expr_Func
:= Original_Node
(Subprogram_Body
(Subp
));
7203 pragma Assert
(False);
7207 return Original_Node
(Expression
(Expr_Func
));
7208 end Expression_Of_Expression_Function
;
7210 -------------------------------
7211 -- Extensions_Visible_Status --
7212 -------------------------------
7214 function Extensions_Visible_Status
7215 (Id
: Entity_Id
) return Extensions_Visible_Mode
7224 -- When a formal parameter is subject to Extensions_Visible, the pragma
7225 -- is stored in the contract of related subprogram.
7227 if Is_Formal
(Id
) then
7230 elsif Is_Subprogram_Or_Generic_Subprogram
(Id
) then
7233 -- No other construct carries this pragma
7236 return Extensions_Visible_None
;
7239 Prag
:= Get_Pragma
(Subp
, Pragma_Extensions_Visible
);
7241 -- In certain cases analysis may request the Extensions_Visible status
7242 -- of an expression function before the pragma has been analyzed yet.
7243 -- Inspect the declarative items after the expression function looking
7244 -- for the pragma (if any).
7246 if No
(Prag
) and then Is_Expression_Function
(Subp
) then
7247 Decl
:= Next
(Unit_Declaration_Node
(Subp
));
7248 while Present
(Decl
) loop
7249 if Nkind
(Decl
) = N_Pragma
7250 and then Pragma_Name
(Decl
) = Name_Extensions_Visible
7255 -- A source construct ends the region where Extensions_Visible may
7256 -- appear, stop the traversal. An expanded expression function is
7257 -- no longer a source construct, but it must still be recognized.
7259 elsif Comes_From_Source
(Decl
)
7261 (Nkind_In
(Decl
, N_Subprogram_Body
,
7262 N_Subprogram_Declaration
)
7263 and then Is_Expression_Function
(Defining_Entity
(Decl
)))
7272 -- Extract the value from the Boolean expression (if any)
7274 if Present
(Prag
) then
7275 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
7277 if Present
(Arg
) then
7278 Expr
:= Get_Pragma_Arg
(Arg
);
7280 -- When the associated subprogram is an expression function, the
7281 -- argument of the pragma may not have been analyzed.
7283 if not Analyzed
(Expr
) then
7284 Preanalyze_And_Resolve
(Expr
, Standard_Boolean
);
7287 -- Guard against cascading errors when the argument of pragma
7288 -- Extensions_Visible is not a valid static Boolean expression.
7290 if Error_Posted
(Expr
) then
7291 return Extensions_Visible_None
;
7293 elsif Is_True
(Expr_Value
(Expr
)) then
7294 return Extensions_Visible_True
;
7297 return Extensions_Visible_False
;
7300 -- Otherwise the aspect or pragma defaults to True
7303 return Extensions_Visible_True
;
7306 -- Otherwise aspect or pragma Extensions_Visible is not inherited or
7307 -- directly specified. In SPARK code, its value defaults to "False".
7309 elsif SPARK_Mode
= On
then
7310 return Extensions_Visible_False
;
7312 -- In non-SPARK code, aspect or pragma Extensions_Visible defaults to
7316 return Extensions_Visible_True
;
7318 end Extensions_Visible_Status
;
7324 procedure Find_Actual
7326 Formal
: out Entity_Id
;
7329 Context
: constant Node_Id
:= Parent
(N
);
7334 if Nkind_In
(Context
, N_Indexed_Component
, N_Selected_Component
)
7335 and then N
= Prefix
(Context
)
7337 Find_Actual
(Context
, Formal
, Call
);
7340 elsif Nkind
(Context
) = N_Parameter_Association
7341 and then N
= Explicit_Actual_Parameter
(Context
)
7343 Call
:= Parent
(Context
);
7345 elsif Nkind_In
(Context
, N_Entry_Call_Statement
,
7347 N_Procedure_Call_Statement
)
7357 -- If we have a call to a subprogram look for the parameter. Note that
7358 -- we exclude overloaded calls, since we don't know enough to be sure
7359 -- of giving the right answer in this case.
7361 if Nkind_In
(Call
, N_Entry_Call_Statement
,
7363 N_Procedure_Call_Statement
)
7365 Call_Nam
:= Name
(Call
);
7367 -- A call to a protected or task entry appears as a selected
7368 -- component rather than an expanded name.
7370 if Nkind
(Call_Nam
) = N_Selected_Component
then
7371 Call_Nam
:= Selector_Name
(Call_Nam
);
7374 if Is_Entity_Name
(Call_Nam
)
7375 and then Present
(Entity
(Call_Nam
))
7376 and then Is_Overloadable
(Entity
(Call_Nam
))
7377 and then not Is_Overloaded
(Call_Nam
)
7379 -- If node is name in call it is not an actual
7381 if N
= Call_Nam
then
7387 -- Fall here if we are definitely a parameter
7389 Actual
:= First_Actual
(Call
);
7390 Formal
:= First_Formal
(Entity
(Call_Nam
));
7391 while Present
(Formal
) and then Present
(Actual
) loop
7395 -- An actual that is the prefix in a prefixed call may have
7396 -- been rewritten in the call, after the deferred reference
7397 -- was collected. Check if sloc and kinds and names match.
7399 elsif Sloc
(Actual
) = Sloc
(N
)
7400 and then Nkind
(Actual
) = N_Identifier
7401 and then Nkind
(Actual
) = Nkind
(N
)
7402 and then Chars
(Actual
) = Chars
(N
)
7407 Actual
:= Next_Actual
(Actual
);
7408 Formal
:= Next_Formal
(Formal
);
7414 -- Fall through here if we did not find matching actual
7420 ---------------------------
7421 -- Find_Body_Discriminal --
7422 ---------------------------
7424 function Find_Body_Discriminal
7425 (Spec_Discriminant
: Entity_Id
) return Entity_Id
7431 -- If expansion is suppressed, then the scope can be the concurrent type
7432 -- itself rather than a corresponding concurrent record type.
7434 if Is_Concurrent_Type
(Scope
(Spec_Discriminant
)) then
7435 Tsk
:= Scope
(Spec_Discriminant
);
7438 pragma Assert
(Is_Concurrent_Record_Type
(Scope
(Spec_Discriminant
)));
7440 Tsk
:= Corresponding_Concurrent_Type
(Scope
(Spec_Discriminant
));
7443 -- Find discriminant of original concurrent type, and use its current
7444 -- discriminal, which is the renaming within the task/protected body.
7446 Disc
:= First_Discriminant
(Tsk
);
7447 while Present
(Disc
) loop
7448 if Chars
(Disc
) = Chars
(Spec_Discriminant
) then
7449 return Discriminal
(Disc
);
7452 Next_Discriminant
(Disc
);
7455 -- That loop should always succeed in finding a matching entry and
7456 -- returning. Fatal error if not.
7458 raise Program_Error
;
7459 end Find_Body_Discriminal
;
7461 -------------------------------------
7462 -- Find_Corresponding_Discriminant --
7463 -------------------------------------
7465 function Find_Corresponding_Discriminant
7467 Typ
: Entity_Id
) return Entity_Id
7469 Par_Disc
: Entity_Id
;
7470 Old_Disc
: Entity_Id
;
7471 New_Disc
: Entity_Id
;
7474 Par_Disc
:= Original_Record_Component
(Original_Discriminant
(Id
));
7476 -- The original type may currently be private, and the discriminant
7477 -- only appear on its full view.
7479 if Is_Private_Type
(Scope
(Par_Disc
))
7480 and then not Has_Discriminants
(Scope
(Par_Disc
))
7481 and then Present
(Full_View
(Scope
(Par_Disc
)))
7483 Old_Disc
:= First_Discriminant
(Full_View
(Scope
(Par_Disc
)));
7485 Old_Disc
:= First_Discriminant
(Scope
(Par_Disc
));
7488 if Is_Class_Wide_Type
(Typ
) then
7489 New_Disc
:= First_Discriminant
(Root_Type
(Typ
));
7491 New_Disc
:= First_Discriminant
(Typ
);
7494 while Present
(Old_Disc
) and then Present
(New_Disc
) loop
7495 if Old_Disc
= Par_Disc
then
7499 Next_Discriminant
(Old_Disc
);
7500 Next_Discriminant
(New_Disc
);
7503 -- Should always find it
7505 raise Program_Error
;
7506 end Find_Corresponding_Discriminant
;
7508 ----------------------------------
7509 -- Find_Enclosing_Iterator_Loop --
7510 ----------------------------------
7512 function Find_Enclosing_Iterator_Loop
(Id
: Entity_Id
) return Entity_Id
is
7517 -- Traverse the scope chain looking for an iterator loop. Such loops are
7518 -- usually transformed into blocks, hence the use of Original_Node.
7521 while Present
(S
) and then S
/= Standard_Standard
loop
7522 if Ekind
(S
) = E_Loop
7523 and then Nkind
(Parent
(S
)) = N_Implicit_Label_Declaration
7525 Constr
:= Original_Node
(Label_Construct
(Parent
(S
)));
7527 if Nkind
(Constr
) = N_Loop_Statement
7528 and then Present
(Iteration_Scheme
(Constr
))
7529 and then Nkind
(Iterator_Specification
7530 (Iteration_Scheme
(Constr
))) =
7531 N_Iterator_Specification
7541 end Find_Enclosing_Iterator_Loop
;
7543 ------------------------------------
7544 -- Find_Loop_In_Conditional_Block --
7545 ------------------------------------
7547 function Find_Loop_In_Conditional_Block
(N
: Node_Id
) return Node_Id
is
7553 if Nkind
(Stmt
) = N_If_Statement
then
7554 Stmt
:= First
(Then_Statements
(Stmt
));
7557 pragma Assert
(Nkind
(Stmt
) = N_Block_Statement
);
7559 -- Inspect the statements of the conditional block. In general the loop
7560 -- should be the first statement in the statement sequence of the block,
7561 -- but the finalization machinery may have introduced extra object
7564 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Stmt
)));
7565 while Present
(Stmt
) loop
7566 if Nkind
(Stmt
) = N_Loop_Statement
then
7573 -- The expansion of attribute 'Loop_Entry produced a malformed block
7575 raise Program_Error
;
7576 end Find_Loop_In_Conditional_Block
;
7578 --------------------------
7579 -- Find_Overlaid_Entity --
7580 --------------------------
7582 procedure Find_Overlaid_Entity
7584 Ent
: out Entity_Id
;
7590 -- We are looking for one of the two following forms:
7592 -- for X'Address use Y'Address
7596 -- Const : constant Address := expr;
7598 -- for X'Address use Const;
7600 -- In the second case, the expr is either Y'Address, or recursively a
7601 -- constant that eventually references Y'Address.
7606 if Nkind
(N
) = N_Attribute_Definition_Clause
7607 and then Chars
(N
) = Name_Address
7609 Expr
:= Expression
(N
);
7611 -- This loop checks the form of the expression for Y'Address,
7612 -- using recursion to deal with intermediate constants.
7615 -- Check for Y'Address
7617 if Nkind
(Expr
) = N_Attribute_Reference
7618 and then Attribute_Name
(Expr
) = Name_Address
7620 Expr
:= Prefix
(Expr
);
7623 -- Check for Const where Const is a constant entity
7625 elsif Is_Entity_Name
(Expr
)
7626 and then Ekind
(Entity
(Expr
)) = E_Constant
7628 Expr
:= Constant_Value
(Entity
(Expr
));
7630 -- Anything else does not need checking
7637 -- This loop checks the form of the prefix for an entity, using
7638 -- recursion to deal with intermediate components.
7641 -- Check for Y where Y is an entity
7643 if Is_Entity_Name
(Expr
) then
7644 Ent
:= Entity
(Expr
);
7647 -- Check for components
7650 Nkind_In
(Expr
, N_Selected_Component
, N_Indexed_Component
)
7652 Expr
:= Prefix
(Expr
);
7655 -- Anything else does not need checking
7662 end Find_Overlaid_Entity
;
7664 -------------------------
7665 -- Find_Parameter_Type --
7666 -------------------------
7668 function Find_Parameter_Type
(Param
: Node_Id
) return Entity_Id
is
7670 if Nkind
(Param
) /= N_Parameter_Specification
then
7673 -- For an access parameter, obtain the type from the formal entity
7674 -- itself, because access to subprogram nodes do not carry a type.
7675 -- Shouldn't we always use the formal entity ???
7677 elsif Nkind
(Parameter_Type
(Param
)) = N_Access_Definition
then
7678 return Etype
(Defining_Identifier
(Param
));
7681 return Etype
(Parameter_Type
(Param
));
7683 end Find_Parameter_Type
;
7685 -----------------------------------
7686 -- Find_Placement_In_State_Space --
7687 -----------------------------------
7689 procedure Find_Placement_In_State_Space
7690 (Item_Id
: Entity_Id
;
7691 Placement
: out State_Space_Kind
;
7692 Pack_Id
: out Entity_Id
)
7694 Context
: Entity_Id
;
7697 -- Assume that the item does not appear in the state space of a package
7699 Placement
:= Not_In_Package
;
7702 -- Climb the scope stack and examine the enclosing context
7704 Context
:= Scope
(Item_Id
);
7705 while Present
(Context
) and then Context
/= Standard_Standard
loop
7706 if Ekind
(Context
) = E_Package
then
7709 -- A package body is a cut off point for the traversal as the item
7710 -- cannot be visible to the outside from this point on. Note that
7711 -- this test must be done first as a body is also classified as a
7714 if In_Package_Body
(Context
) then
7715 Placement
:= Body_State_Space
;
7718 -- The private part of a package is a cut off point for the
7719 -- traversal as the item cannot be visible to the outside from
7722 elsif In_Private_Part
(Context
) then
7723 Placement
:= Private_State_Space
;
7726 -- When the item appears in the visible state space of a package,
7727 -- continue to climb the scope stack as this may not be the final
7731 Placement
:= Visible_State_Space
;
7733 -- The visible state space of a child unit acts as the proper
7734 -- placement of an item.
7736 if Is_Child_Unit
(Context
) then
7741 -- The item or its enclosing package appear in a construct that has
7745 Placement
:= Not_In_Package
;
7749 Context
:= Scope
(Context
);
7751 end Find_Placement_In_State_Space
;
7753 ------------------------
7754 -- Find_Specific_Type --
7755 ------------------------
7757 function Find_Specific_Type
(CW
: Entity_Id
) return Entity_Id
is
7758 Typ
: Entity_Id
:= Root_Type
(CW
);
7761 if Ekind
(Typ
) = E_Incomplete_Type
then
7762 if From_Limited_With
(Typ
) then
7763 Typ
:= Non_Limited_View
(Typ
);
7765 Typ
:= Full_View
(Typ
);
7769 if Is_Private_Type
(Typ
)
7770 and then not Is_Tagged_Type
(Typ
)
7771 and then Present
(Full_View
(Typ
))
7773 return Full_View
(Typ
);
7777 end Find_Specific_Type
;
7779 -----------------------------
7780 -- Find_Static_Alternative --
7781 -----------------------------
7783 function Find_Static_Alternative
(N
: Node_Id
) return Node_Id
is
7784 Expr
: constant Node_Id
:= Expression
(N
);
7785 Val
: constant Uint
:= Expr_Value
(Expr
);
7790 Alt
:= First
(Alternatives
(N
));
7793 if Nkind
(Alt
) /= N_Pragma
then
7794 Choice
:= First
(Discrete_Choices
(Alt
));
7795 while Present
(Choice
) loop
7797 -- Others choice, always matches
7799 if Nkind
(Choice
) = N_Others_Choice
then
7802 -- Range, check if value is in the range
7804 elsif Nkind
(Choice
) = N_Range
then
7806 Val
>= Expr_Value
(Low_Bound
(Choice
))
7808 Val
<= Expr_Value
(High_Bound
(Choice
));
7810 -- Choice is a subtype name. Note that we know it must
7811 -- be a static subtype, since otherwise it would have
7812 -- been diagnosed as illegal.
7814 elsif Is_Entity_Name
(Choice
)
7815 and then Is_Type
(Entity
(Choice
))
7817 exit Search
when Is_In_Range
(Expr
, Etype
(Choice
),
7818 Assume_Valid
=> False);
7820 -- Choice is a subtype indication
7822 elsif Nkind
(Choice
) = N_Subtype_Indication
then
7824 C
: constant Node_Id
:= Constraint
(Choice
);
7825 R
: constant Node_Id
:= Range_Expression
(C
);
7829 Val
>= Expr_Value
(Low_Bound
(R
))
7831 Val
<= Expr_Value
(High_Bound
(R
));
7834 -- Choice is a simple expression
7837 exit Search
when Val
= Expr_Value
(Choice
);
7845 pragma Assert
(Present
(Alt
));
7848 -- The above loop *must* terminate by finding a match, since we know the
7849 -- case statement is valid, and the value of the expression is known at
7850 -- compile time. When we fall out of the loop, Alt points to the
7851 -- alternative that we know will be selected at run time.
7854 end Find_Static_Alternative
;
7860 function First_Actual
(Node
: Node_Id
) return Node_Id
is
7864 if No
(Parameter_Associations
(Node
)) then
7868 N
:= First
(Parameter_Associations
(Node
));
7870 if Nkind
(N
) = N_Parameter_Association
then
7871 return First_Named_Actual
(Node
);
7881 function Fix_Msg
(Id
: Entity_Id
; Msg
: String) return String is
7882 Is_Task
: constant Boolean :=
7883 Ekind_In
(Id
, E_Task_Body
, E_Task_Type
)
7884 or else Is_Single_Task_Object
(Id
);
7885 Msg_Last
: constant Natural := Msg
'Last;
7886 Msg_Index
: Natural;
7887 Res
: String (Msg
'Range) := (others => ' ');
7888 Res_Index
: Natural;
7891 -- Copy all characters from the input message Msg to result Res with
7892 -- suitable replacements.
7894 Msg_Index
:= Msg
'First;
7895 Res_Index
:= Res
'First;
7896 while Msg_Index
<= Msg_Last
loop
7898 -- Replace "subprogram" with a different word
7900 if Msg_Index
<= Msg_Last
- 10
7901 and then Msg
(Msg_Index
.. Msg_Index
+ 9) = "subprogram"
7903 if Ekind_In
(Id
, E_Entry
, E_Entry_Family
) then
7904 Res
(Res_Index
.. Res_Index
+ 4) := "entry";
7905 Res_Index
:= Res_Index
+ 5;
7908 Res
(Res_Index
.. Res_Index
+ 8) := "task type";
7909 Res_Index
:= Res_Index
+ 9;
7912 Res
(Res_Index
.. Res_Index
+ 9) := "subprogram";
7913 Res_Index
:= Res_Index
+ 10;
7916 Msg_Index
:= Msg_Index
+ 10;
7918 -- Replace "protected" with a different word
7920 elsif Msg_Index
<= Msg_Last
- 9
7921 and then Msg
(Msg_Index
.. Msg_Index
+ 8) = "protected"
7924 Res
(Res_Index
.. Res_Index
+ 3) := "task";
7925 Res_Index
:= Res_Index
+ 4;
7926 Msg_Index
:= Msg_Index
+ 9;
7928 -- Otherwise copy the character
7931 Res
(Res_Index
) := Msg
(Msg_Index
);
7932 Msg_Index
:= Msg_Index
+ 1;
7933 Res_Index
:= Res_Index
+ 1;
7937 return Res
(Res
'First .. Res_Index
- 1);
7940 -------------------------
7941 -- From_Nested_Package --
7942 -------------------------
7944 function From_Nested_Package
(T
: Entity_Id
) return Boolean is
7945 Pack
: constant Entity_Id
:= Scope
(T
);
7949 Ekind
(Pack
) = E_Package
7950 and then not Is_Frozen
(Pack
)
7951 and then not Scope_Within_Or_Same
(Current_Scope
, Pack
)
7952 and then In_Open_Scopes
(Scope
(Pack
));
7953 end From_Nested_Package
;
7955 -----------------------
7956 -- Gather_Components --
7957 -----------------------
7959 procedure Gather_Components
7961 Comp_List
: Node_Id
;
7962 Governed_By
: List_Id
;
7964 Report_Errors
: out Boolean)
7968 Discrete_Choice
: Node_Id
;
7969 Comp_Item
: Node_Id
;
7971 Discrim
: Entity_Id
;
7972 Discrim_Name
: Node_Id
;
7973 Discrim_Value
: Node_Id
;
7976 Report_Errors
:= False;
7978 if No
(Comp_List
) or else Null_Present
(Comp_List
) then
7981 elsif Present
(Component_Items
(Comp_List
)) then
7982 Comp_Item
:= First
(Component_Items
(Comp_List
));
7988 while Present
(Comp_Item
) loop
7990 -- Skip the tag of a tagged record, the interface tags, as well
7991 -- as all items that are not user components (anonymous types,
7992 -- rep clauses, Parent field, controller field).
7994 if Nkind
(Comp_Item
) = N_Component_Declaration
then
7996 Comp
: constant Entity_Id
:= Defining_Identifier
(Comp_Item
);
7998 if not Is_Tag
(Comp
) and then Chars
(Comp
) /= Name_uParent
then
7999 Append_Elmt
(Comp
, Into
);
8007 if No
(Variant_Part
(Comp_List
)) then
8010 Discrim_Name
:= Name
(Variant_Part
(Comp_List
));
8011 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(Comp_List
)));
8014 -- Look for the discriminant that governs this variant part.
8015 -- The discriminant *must* be in the Governed_By List
8017 Assoc
:= First
(Governed_By
);
8018 Find_Constraint
: loop
8019 Discrim
:= First
(Choices
(Assoc
));
8020 exit Find_Constraint
when Chars
(Discrim_Name
) = Chars
(Discrim
)
8021 or else (Present
(Corresponding_Discriminant
(Entity
(Discrim
)))
8023 Chars
(Corresponding_Discriminant
(Entity
(Discrim
))) =
8024 Chars
(Discrim_Name
))
8025 or else Chars
(Original_Record_Component
(Entity
(Discrim
)))
8026 = Chars
(Discrim_Name
);
8028 if No
(Next
(Assoc
)) then
8029 if not Is_Constrained
(Typ
)
8030 and then Is_Derived_Type
(Typ
)
8031 and then Present
(Stored_Constraint
(Typ
))
8033 -- If the type is a tagged type with inherited discriminants,
8034 -- use the stored constraint on the parent in order to find
8035 -- the values of discriminants that are otherwise hidden by an
8036 -- explicit constraint. Renamed discriminants are handled in
8039 -- If several parent discriminants are renamed by a single
8040 -- discriminant of the derived type, the call to obtain the
8041 -- Corresponding_Discriminant field only retrieves the last
8042 -- of them. We recover the constraint on the others from the
8043 -- Stored_Constraint as well.
8050 D
:= First_Discriminant
(Etype
(Typ
));
8051 C
:= First_Elmt
(Stored_Constraint
(Typ
));
8052 while Present
(D
) and then Present
(C
) loop
8053 if Chars
(Discrim_Name
) = Chars
(D
) then
8054 if Is_Entity_Name
(Node
(C
))
8055 and then Entity
(Node
(C
)) = Entity
(Discrim
)
8057 -- D is renamed by Discrim, whose value is given in
8064 Make_Component_Association
(Sloc
(Typ
),
8066 (New_Occurrence_Of
(D
, Sloc
(Typ
))),
8067 Duplicate_Subexpr_No_Checks
(Node
(C
)));
8069 exit Find_Constraint
;
8072 Next_Discriminant
(D
);
8079 if No
(Next
(Assoc
)) then
8080 Error_Msg_NE
(" missing value for discriminant&",
8081 First
(Governed_By
), Discrim_Name
);
8082 Report_Errors
:= True;
8087 end loop Find_Constraint
;
8089 Discrim_Value
:= Expression
(Assoc
);
8091 if not Is_OK_Static_Expression
(Discrim_Value
) then
8093 -- If the variant part is governed by a discriminant of the type
8094 -- this is an error. If the variant part and the discriminant are
8095 -- inherited from an ancestor this is legal (AI05-120) unless the
8096 -- components are being gathered for an aggregate, in which case
8097 -- the caller must check Report_Errors.
8099 if Scope
(Original_Record_Component
8100 ((Entity
(First
(Choices
(Assoc
)))))) = Typ
8103 ("value for discriminant & must be static!",
8104 Discrim_Value
, Discrim
);
8105 Why_Not_Static
(Discrim_Value
);
8108 Report_Errors
:= True;
8112 Search_For_Discriminant_Value
: declare
8118 UI_Discrim_Value
: constant Uint
:= Expr_Value
(Discrim_Value
);
8121 Find_Discrete_Value
: while Present
(Variant
) loop
8122 Discrete_Choice
:= First
(Discrete_Choices
(Variant
));
8123 while Present
(Discrete_Choice
) loop
8124 exit Find_Discrete_Value
when
8125 Nkind
(Discrete_Choice
) = N_Others_Choice
;
8127 Get_Index_Bounds
(Discrete_Choice
, Low
, High
);
8129 UI_Low
:= Expr_Value
(Low
);
8130 UI_High
:= Expr_Value
(High
);
8132 exit Find_Discrete_Value
when
8133 UI_Low
<= UI_Discrim_Value
8135 UI_High
>= UI_Discrim_Value
;
8137 Next
(Discrete_Choice
);
8140 Next_Non_Pragma
(Variant
);
8141 end loop Find_Discrete_Value
;
8142 end Search_For_Discriminant_Value
;
8144 -- The case statement must include a variant that corresponds to the
8145 -- value of the discriminant, unless the discriminant type has a
8146 -- static predicate. In that case the absence of an others_choice that
8147 -- would cover this value becomes a run-time error (3.8,1 (21.1/2)).
8150 and then not Has_Static_Predicate
(Etype
(Discrim_Name
))
8153 ("value of discriminant & is out of range", Discrim_Value
, Discrim
);
8154 Report_Errors
:= True;
8158 -- If we have found the corresponding choice, recursively add its
8159 -- components to the Into list. The nested components are part of
8160 -- the same record type.
8162 if Present
(Variant
) then
8164 (Typ
, Component_List
(Variant
), Governed_By
, Into
, Report_Errors
);
8166 end Gather_Components
;
8168 ------------------------
8169 -- Get_Actual_Subtype --
8170 ------------------------
8172 function Get_Actual_Subtype
(N
: Node_Id
) return Entity_Id
is
8173 Typ
: constant Entity_Id
:= Etype
(N
);
8174 Utyp
: Entity_Id
:= Underlying_Type
(Typ
);
8183 -- If what we have is an identifier that references a subprogram
8184 -- formal, or a variable or constant object, then we get the actual
8185 -- subtype from the referenced entity if one has been built.
8187 if Nkind
(N
) = N_Identifier
8189 (Is_Formal
(Entity
(N
))
8190 or else Ekind
(Entity
(N
)) = E_Constant
8191 or else Ekind
(Entity
(N
)) = E_Variable
)
8192 and then Present
(Actual_Subtype
(Entity
(N
)))
8194 return Actual_Subtype
(Entity
(N
));
8196 -- Actual subtype of unchecked union is always itself. We never need
8197 -- the "real" actual subtype. If we did, we couldn't get it anyway
8198 -- because the discriminant is not available. The restrictions on
8199 -- Unchecked_Union are designed to make sure that this is OK.
8201 elsif Is_Unchecked_Union
(Base_Type
(Utyp
)) then
8204 -- Here for the unconstrained case, we must find actual subtype
8205 -- No actual subtype is available, so we must build it on the fly.
8207 -- Checking the type, not the underlying type, for constrainedness
8208 -- seems to be necessary. Maybe all the tests should be on the type???
8210 elsif (not Is_Constrained
(Typ
))
8211 and then (Is_Array_Type
(Utyp
)
8212 or else (Is_Record_Type
(Utyp
)
8213 and then Has_Discriminants
(Utyp
)))
8214 and then not Has_Unknown_Discriminants
(Utyp
)
8215 and then not (Ekind
(Utyp
) = E_String_Literal_Subtype
)
8217 -- Nothing to do if in spec expression (why not???)
8219 if In_Spec_Expression
then
8222 elsif Is_Private_Type
(Typ
) and then not Has_Discriminants
(Typ
) then
8224 -- If the type has no discriminants, there is no subtype to
8225 -- build, even if the underlying type is discriminated.
8229 -- Else build the actual subtype
8232 Decl
:= Build_Actual_Subtype
(Typ
, N
);
8233 Atyp
:= Defining_Identifier
(Decl
);
8235 -- If Build_Actual_Subtype generated a new declaration then use it
8239 -- The actual subtype is an Itype, so analyze the declaration,
8240 -- but do not attach it to the tree, to get the type defined.
8242 Set_Parent
(Decl
, N
);
8243 Set_Is_Itype
(Atyp
);
8244 Analyze
(Decl
, Suppress
=> All_Checks
);
8245 Set_Associated_Node_For_Itype
(Atyp
, N
);
8246 Set_Has_Delayed_Freeze
(Atyp
, False);
8248 -- We need to freeze the actual subtype immediately. This is
8249 -- needed, because otherwise this Itype will not get frozen
8250 -- at all, and it is always safe to freeze on creation because
8251 -- any associated types must be frozen at this point.
8253 Freeze_Itype
(Atyp
, N
);
8256 -- Otherwise we did not build a declaration, so return original
8263 -- For all remaining cases, the actual subtype is the same as
8264 -- the nominal type.
8269 end Get_Actual_Subtype
;
8271 -------------------------------------
8272 -- Get_Actual_Subtype_If_Available --
8273 -------------------------------------
8275 function Get_Actual_Subtype_If_Available
(N
: Node_Id
) return Entity_Id
is
8276 Typ
: constant Entity_Id
:= Etype
(N
);
8279 -- If what we have is an identifier that references a subprogram
8280 -- formal, or a variable or constant object, then we get the actual
8281 -- subtype from the referenced entity if one has been built.
8283 if Nkind
(N
) = N_Identifier
8285 (Is_Formal
(Entity
(N
))
8286 or else Ekind
(Entity
(N
)) = E_Constant
8287 or else Ekind
(Entity
(N
)) = E_Variable
)
8288 and then Present
(Actual_Subtype
(Entity
(N
)))
8290 return Actual_Subtype
(Entity
(N
));
8292 -- Otherwise the Etype of N is returned unchanged
8297 end Get_Actual_Subtype_If_Available
;
8299 ------------------------
8300 -- Get_Body_From_Stub --
8301 ------------------------
8303 function Get_Body_From_Stub
(N
: Node_Id
) return Node_Id
is
8305 return Proper_Body
(Unit
(Library_Unit
(N
)));
8306 end Get_Body_From_Stub
;
8308 ---------------------
8309 -- Get_Cursor_Type --
8310 ---------------------
8312 function Get_Cursor_Type
8314 Typ
: Entity_Id
) return Entity_Id
8318 First_Op
: Entity_Id
;
8322 -- If error already detected, return
8324 if Error_Posted
(Aspect
) then
8328 -- The cursor type for an Iterable aspect is the return type of a
8329 -- non-overloaded First primitive operation. Locate association for
8332 Assoc
:= First
(Component_Associations
(Expression
(Aspect
)));
8334 while Present
(Assoc
) loop
8335 if Chars
(First
(Choices
(Assoc
))) = Name_First
then
8336 First_Op
:= Expression
(Assoc
);
8343 if First_Op
= Any_Id
then
8344 Error_Msg_N
("aspect Iterable must specify First operation", Aspect
);
8350 -- Locate function with desired name and profile in scope of type
8351 -- In the rare case where the type is an integer type, a base type
8352 -- is created for it, check that the base type of the first formal
8353 -- of First matches the base type of the domain.
8355 Func
:= First_Entity
(Scope
(Typ
));
8356 while Present
(Func
) loop
8357 if Chars
(Func
) = Chars
(First_Op
)
8358 and then Ekind
(Func
) = E_Function
8359 and then Present
(First_Formal
(Func
))
8360 and then Base_Type
(Etype
(First_Formal
(Func
))) = Base_Type
(Typ
)
8361 and then No
(Next_Formal
(First_Formal
(Func
)))
8363 if Cursor
/= Any_Type
then
8365 ("Operation First for iterable type must be unique", Aspect
);
8368 Cursor
:= Etype
(Func
);
8375 -- If not found, no way to resolve remaining primitives.
8377 if Cursor
= Any_Type
then
8379 ("No legal primitive operation First for Iterable type", Aspect
);
8383 end Get_Cursor_Type
;
8385 function Get_Cursor_Type
(Typ
: Entity_Id
) return Entity_Id
is
8387 return Etype
(Get_Iterable_Type_Primitive
(Typ
, Name_First
));
8388 end Get_Cursor_Type
;
8390 -------------------------------
8391 -- Get_Default_External_Name --
8392 -------------------------------
8394 function Get_Default_External_Name
(E
: Node_Or_Entity_Id
) return Node_Id
is
8396 Get_Decoded_Name_String
(Chars
(E
));
8398 if Opt
.External_Name_Imp_Casing
= Uppercase
then
8399 Set_Casing
(All_Upper_Case
);
8401 Set_Casing
(All_Lower_Case
);
8405 Make_String_Literal
(Sloc
(E
),
8406 Strval
=> String_From_Name_Buffer
);
8407 end Get_Default_External_Name
;
8409 --------------------------
8410 -- Get_Enclosing_Object --
8411 --------------------------
8413 function Get_Enclosing_Object
(N
: Node_Id
) return Entity_Id
is
8415 if Is_Entity_Name
(N
) then
8419 when N_Indexed_Component
8420 | N_Selected_Component
8423 -- If not generating code, a dereference may be left implicit.
8424 -- In thoses cases, return Empty.
8426 if Is_Access_Type
(Etype
(Prefix
(N
))) then
8429 return Get_Enclosing_Object
(Prefix
(N
));
8432 when N_Type_Conversion
=>
8433 return Get_Enclosing_Object
(Expression
(N
));
8439 end Get_Enclosing_Object
;
8441 ---------------------------
8442 -- Get_Enum_Lit_From_Pos --
8443 ---------------------------
8445 function Get_Enum_Lit_From_Pos
8448 Loc
: Source_Ptr
) return Node_Id
8450 Btyp
: Entity_Id
:= Base_Type
(T
);
8455 -- In the case where the literal is of type Character, Wide_Character
8456 -- or Wide_Wide_Character or of a type derived from them, there needs
8457 -- to be some special handling since there is no explicit chain of
8458 -- literals to search. Instead, an N_Character_Literal node is created
8459 -- with the appropriate Char_Code and Chars fields.
8461 if Is_Standard_Character_Type
(T
) then
8462 Set_Character_Literal_Name
(UI_To_CC
(Pos
));
8465 Make_Character_Literal
(Loc
,
8467 Char_Literal_Value
=> Pos
);
8469 -- For all other cases, we have a complete table of literals, and
8470 -- we simply iterate through the chain of literal until the one
8471 -- with the desired position value is found.
8474 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
8475 Btyp
:= Full_View
(Btyp
);
8478 Lit
:= First_Literal
(Btyp
);
8479 for J
in 1 .. UI_To_Int
(Pos
) loop
8482 -- If Lit is Empty, Pos is not in range, so raise Constraint_Error
8483 -- inside the loop to avoid calling Next_Literal on Empty.
8486 raise Constraint_Error
;
8490 -- Create a new node from Lit, with source location provided by Loc
8491 -- if not equal to No_Location, or by copying the source location of
8496 if LLoc
= No_Location
then
8500 return New_Occurrence_Of
(Lit
, LLoc
);
8502 end Get_Enum_Lit_From_Pos
;
8504 ------------------------
8505 -- Get_Generic_Entity --
8506 ------------------------
8508 function Get_Generic_Entity
(N
: Node_Id
) return Entity_Id
is
8509 Ent
: constant Entity_Id
:= Entity
(Name
(N
));
8511 if Present
(Renamed_Object
(Ent
)) then
8512 return Renamed_Object
(Ent
);
8516 end Get_Generic_Entity
;
8518 -------------------------------------
8519 -- Get_Incomplete_View_Of_Ancestor --
8520 -------------------------------------
8522 function Get_Incomplete_View_Of_Ancestor
(E
: Entity_Id
) return Entity_Id
is
8523 Cur_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
8524 Par_Scope
: Entity_Id
;
8525 Par_Type
: Entity_Id
;
8528 -- The incomplete view of an ancestor is only relevant for private
8529 -- derived types in child units.
8531 if not Is_Derived_Type
(E
)
8532 or else not Is_Child_Unit
(Cur_Unit
)
8537 Par_Scope
:= Scope
(Cur_Unit
);
8538 if No
(Par_Scope
) then
8542 Par_Type
:= Etype
(Base_Type
(E
));
8544 -- Traverse list of ancestor types until we find one declared in
8545 -- a parent or grandparent unit (two levels seem sufficient).
8547 while Present
(Par_Type
) loop
8548 if Scope
(Par_Type
) = Par_Scope
8549 or else Scope
(Par_Type
) = Scope
(Par_Scope
)
8553 elsif not Is_Derived_Type
(Par_Type
) then
8557 Par_Type
:= Etype
(Base_Type
(Par_Type
));
8561 -- If none found, there is no relevant ancestor type.
8565 end Get_Incomplete_View_Of_Ancestor
;
8567 ----------------------
8568 -- Get_Index_Bounds --
8569 ----------------------
8571 procedure Get_Index_Bounds
8575 Use_Full_View
: Boolean := False)
8577 function Scalar_Range_Of_Type
(Typ
: Entity_Id
) return Node_Id
;
8578 -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and
8579 -- Typ qualifies, the scalar range is obtained from the full view of the
8582 --------------------------
8583 -- Scalar_Range_Of_Type --
8584 --------------------------
8586 function Scalar_Range_Of_Type
(Typ
: Entity_Id
) return Node_Id
is
8587 T
: Entity_Id
:= Typ
;
8590 if Use_Full_View
and then Present
(Full_View
(T
)) then
8594 return Scalar_Range
(T
);
8595 end Scalar_Range_Of_Type
;
8599 Kind
: constant Node_Kind
:= Nkind
(N
);
8602 -- Start of processing for Get_Index_Bounds
8605 if Kind
= N_Range
then
8607 H
:= High_Bound
(N
);
8609 elsif Kind
= N_Subtype_Indication
then
8610 Rng
:= Range_Expression
(Constraint
(N
));
8618 L
:= Low_Bound
(Range_Expression
(Constraint
(N
)));
8619 H
:= High_Bound
(Range_Expression
(Constraint
(N
)));
8622 elsif Is_Entity_Name
(N
) and then Is_Type
(Entity
(N
)) then
8623 Rng
:= Scalar_Range_Of_Type
(Entity
(N
));
8625 if Error_Posted
(Rng
) then
8629 elsif Nkind
(Rng
) = N_Subtype_Indication
then
8630 Get_Index_Bounds
(Rng
, L
, H
);
8633 L
:= Low_Bound
(Rng
);
8634 H
:= High_Bound
(Rng
);
8638 -- N is an expression, indicating a range with one value
8643 end Get_Index_Bounds
;
8645 -----------------------------
8646 -- Get_Interfacing_Aspects --
8647 -----------------------------
8649 procedure Get_Interfacing_Aspects
8650 (Iface_Asp
: Node_Id
;
8651 Conv_Asp
: out Node_Id
;
8652 EN_Asp
: out Node_Id
;
8653 Expo_Asp
: out Node_Id
;
8654 Imp_Asp
: out Node_Id
;
8655 LN_Asp
: out Node_Id
;
8656 Do_Checks
: Boolean := False)
8658 procedure Save_Or_Duplication_Error
8660 To
: in out Node_Id
);
8661 -- Save the value of aspect Asp in node To. If To already has a value,
8662 -- then this is considered a duplicate use of aspect. Emit an error if
8663 -- flag Do_Checks is set.
8665 -------------------------------
8666 -- Save_Or_Duplication_Error --
8667 -------------------------------
8669 procedure Save_Or_Duplication_Error
8671 To
: in out Node_Id
)
8674 -- Detect an extra aspect and issue an error
8676 if Present
(To
) then
8678 Error_Msg_Name_1
:= Chars
(Identifier
(Asp
));
8679 Error_Msg_Sloc
:= Sloc
(To
);
8680 Error_Msg_N
("aspect % previously given #", Asp
);
8683 -- Otherwise capture the aspect
8688 end Save_Or_Duplication_Error
;
8695 -- The following variables capture each individual aspect
8697 Conv
: Node_Id
:= Empty
;
8698 EN
: Node_Id
:= Empty
;
8699 Expo
: Node_Id
:= Empty
;
8700 Imp
: Node_Id
:= Empty
;
8701 LN
: Node_Id
:= Empty
;
8703 -- Start of processing for Get_Interfacing_Aspects
8706 -- The input interfacing aspect should reside in an aspect specification
8709 pragma Assert
(Is_List_Member
(Iface_Asp
));
8711 -- Examine the aspect specifications of the related entity. Find and
8712 -- capture all interfacing aspects. Detect duplicates and emit errors
8715 Asp
:= First
(List_Containing
(Iface_Asp
));
8716 while Present
(Asp
) loop
8717 Asp_Id
:= Get_Aspect_Id
(Asp
);
8719 if Asp_Id
= Aspect_Convention
then
8720 Save_Or_Duplication_Error
(Asp
, Conv
);
8722 elsif Asp_Id
= Aspect_External_Name
then
8723 Save_Or_Duplication_Error
(Asp
, EN
);
8725 elsif Asp_Id
= Aspect_Export
then
8726 Save_Or_Duplication_Error
(Asp
, Expo
);
8728 elsif Asp_Id
= Aspect_Import
then
8729 Save_Or_Duplication_Error
(Asp
, Imp
);
8731 elsif Asp_Id
= Aspect_Link_Name
then
8732 Save_Or_Duplication_Error
(Asp
, LN
);
8743 end Get_Interfacing_Aspects
;
8745 ---------------------------------
8746 -- Get_Iterable_Type_Primitive --
8747 ---------------------------------
8749 function Get_Iterable_Type_Primitive
8751 Nam
: Name_Id
) return Entity_Id
8753 Funcs
: constant Node_Id
:= Find_Value_Of_Aspect
(Typ
, Aspect_Iterable
);
8761 Assoc
:= First
(Component_Associations
(Funcs
));
8762 while Present
(Assoc
) loop
8763 if Chars
(First
(Choices
(Assoc
))) = Nam
then
8764 return Entity
(Expression
(Assoc
));
8767 Assoc
:= Next
(Assoc
);
8772 end Get_Iterable_Type_Primitive
;
8774 ----------------------------------
8775 -- Get_Library_Unit_Name_string --
8776 ----------------------------------
8778 procedure Get_Library_Unit_Name_String
(Decl_Node
: Node_Id
) is
8779 Unit_Name_Id
: constant Unit_Name_Type
:= Get_Unit_Name
(Decl_Node
);
8782 Get_Unit_Name_String
(Unit_Name_Id
);
8784 -- Remove seven last character (" (spec)" or " (body)")
8786 Name_Len
:= Name_Len
- 7;
8787 pragma Assert
(Name_Buffer
(Name_Len
+ 1) = ' ');
8788 end Get_Library_Unit_Name_String
;
8790 --------------------------
8791 -- Get_Max_Queue_Length --
8792 --------------------------
8794 function Get_Max_Queue_Length
(Id
: Entity_Id
) return Uint
is
8795 pragma Assert
(Is_Entry
(Id
));
8796 Prag
: constant Entity_Id
:= Get_Pragma
(Id
, Pragma_Max_Queue_Length
);
8799 -- A value of 0 represents no maximum specified, and entries and entry
8800 -- families with no Max_Queue_Length aspect or pragma default to it.
8802 if not Present
(Prag
) then
8806 return Intval
(Expression
(First
(Pragma_Argument_Associations
(Prag
))));
8807 end Get_Max_Queue_Length
;
8809 ------------------------
8810 -- Get_Name_Entity_Id --
8811 ------------------------
8813 function Get_Name_Entity_Id
(Id
: Name_Id
) return Entity_Id
is
8815 return Entity_Id
(Get_Name_Table_Int
(Id
));
8816 end Get_Name_Entity_Id
;
8818 ------------------------------
8819 -- Get_Name_From_CTC_Pragma --
8820 ------------------------------
8822 function Get_Name_From_CTC_Pragma
(N
: Node_Id
) return String_Id
is
8823 Arg
: constant Node_Id
:=
8824 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
8826 return Strval
(Expr_Value_S
(Arg
));
8827 end Get_Name_From_CTC_Pragma
;
8829 -----------------------
8830 -- Get_Parent_Entity --
8831 -----------------------
8833 function Get_Parent_Entity
(Unit
: Node_Id
) return Entity_Id
is
8835 if Nkind
(Unit
) = N_Package_Body
8836 and then Nkind
(Original_Node
(Unit
)) = N_Package_Instantiation
8838 return Defining_Entity
8839 (Specification
(Instance_Spec
(Original_Node
(Unit
))));
8840 elsif Nkind
(Unit
) = N_Package_Instantiation
then
8841 return Defining_Entity
(Specification
(Instance_Spec
(Unit
)));
8843 return Defining_Entity
(Unit
);
8845 end Get_Parent_Entity
;
8851 function Get_Pragma_Id
(N
: Node_Id
) return Pragma_Id
is
8853 return Get_Pragma_Id
(Pragma_Name_Unmapped
(N
));
8856 ------------------------
8857 -- Get_Qualified_Name --
8858 ------------------------
8860 function Get_Qualified_Name
8862 Suffix
: Entity_Id
:= Empty
) return Name_Id
8864 Suffix_Nam
: Name_Id
:= No_Name
;
8867 if Present
(Suffix
) then
8868 Suffix_Nam
:= Chars
(Suffix
);
8871 return Get_Qualified_Name
(Chars
(Id
), Suffix_Nam
, Scope
(Id
));
8872 end Get_Qualified_Name
;
8874 function Get_Qualified_Name
8876 Suffix
: Name_Id
:= No_Name
;
8877 Scop
: Entity_Id
:= Current_Scope
) return Name_Id
8879 procedure Add_Scope
(S
: Entity_Id
);
8880 -- Add the fully qualified form of scope S to the name buffer. The
8888 procedure Add_Scope
(S
: Entity_Id
) is
8893 elsif S
= Standard_Standard
then
8897 Add_Scope
(Scope
(S
));
8898 Get_Name_String_And_Append
(Chars
(S
));
8899 Add_Str_To_Name_Buffer
("__");
8903 -- Start of processing for Get_Qualified_Name
8909 -- Append the base name after all scopes have been chained
8911 Get_Name_String_And_Append
(Nam
);
8913 -- Append the suffix (if present)
8915 if Suffix
/= No_Name
then
8916 Add_Str_To_Name_Buffer
("__");
8917 Get_Name_String_And_Append
(Suffix
);
8921 end Get_Qualified_Name
;
8923 -----------------------
8924 -- Get_Reason_String --
8925 -----------------------
8927 procedure Get_Reason_String
(N
: Node_Id
) is
8929 if Nkind
(N
) = N_String_Literal
then
8930 Store_String_Chars
(Strval
(N
));
8932 elsif Nkind
(N
) = N_Op_Concat
then
8933 Get_Reason_String
(Left_Opnd
(N
));
8934 Get_Reason_String
(Right_Opnd
(N
));
8936 -- If not of required form, error
8940 ("Reason for pragma Warnings has wrong form", N
);
8942 ("\must be string literal or concatenation of string literals", N
);
8945 end Get_Reason_String
;
8947 --------------------------------
8948 -- Get_Reference_Discriminant --
8949 --------------------------------
8951 function Get_Reference_Discriminant
(Typ
: Entity_Id
) return Entity_Id
is
8955 D
:= First_Discriminant
(Typ
);
8956 while Present
(D
) loop
8957 if Has_Implicit_Dereference
(D
) then
8960 Next_Discriminant
(D
);
8964 end Get_Reference_Discriminant
;
8966 ---------------------------
8967 -- Get_Referenced_Object --
8968 ---------------------------
8970 function Get_Referenced_Object
(N
: Node_Id
) return Node_Id
is
8975 while Is_Entity_Name
(R
)
8976 and then Present
(Renamed_Object
(Entity
(R
)))
8978 R
:= Renamed_Object
(Entity
(R
));
8982 end Get_Referenced_Object
;
8984 ------------------------
8985 -- Get_Renamed_Entity --
8986 ------------------------
8988 function Get_Renamed_Entity
(E
: Entity_Id
) return Entity_Id
is
8993 while Present
(Renamed_Entity
(R
)) loop
8994 R
:= Renamed_Entity
(R
);
8998 end Get_Renamed_Entity
;
9000 -----------------------
9001 -- Get_Return_Object --
9002 -----------------------
9004 function Get_Return_Object
(N
: Node_Id
) return Entity_Id
is
9008 Decl
:= First
(Return_Object_Declarations
(N
));
9009 while Present
(Decl
) loop
9010 exit when Nkind
(Decl
) = N_Object_Declaration
9011 and then Is_Return_Object
(Defining_Identifier
(Decl
));
9015 pragma Assert
(Present
(Decl
));
9016 return Defining_Identifier
(Decl
);
9017 end Get_Return_Object
;
9019 ---------------------------
9020 -- Get_Subprogram_Entity --
9021 ---------------------------
9023 function Get_Subprogram_Entity
(Nod
: Node_Id
) return Entity_Id
is
9025 Subp_Id
: Entity_Id
;
9028 if Nkind
(Nod
) = N_Accept_Statement
then
9029 Subp
:= Entry_Direct_Name
(Nod
);
9031 elsif Nkind
(Nod
) = N_Slice
then
9032 Subp
:= Prefix
(Nod
);
9038 -- Strip the subprogram call
9041 if Nkind_In
(Subp
, N_Explicit_Dereference
,
9042 N_Indexed_Component
,
9043 N_Selected_Component
)
9045 Subp
:= Prefix
(Subp
);
9047 elsif Nkind_In
(Subp
, N_Type_Conversion
,
9048 N_Unchecked_Type_Conversion
)
9050 Subp
:= Expression
(Subp
);
9057 -- Extract the entity of the subprogram call
9059 if Is_Entity_Name
(Subp
) then
9060 Subp_Id
:= Entity
(Subp
);
9062 if Ekind
(Subp_Id
) = E_Access_Subprogram_Type
then
9063 Subp_Id
:= Directly_Designated_Type
(Subp_Id
);
9066 if Is_Subprogram
(Subp_Id
) then
9072 -- The search did not find a construct that denotes a subprogram
9077 end Get_Subprogram_Entity
;
9079 -----------------------------
9080 -- Get_Task_Body_Procedure --
9081 -----------------------------
9083 function Get_Task_Body_Procedure
(E
: Entity_Id
) return Node_Id
is
9085 -- Note: A task type may be the completion of a private type with
9086 -- discriminants. When performing elaboration checks on a task
9087 -- declaration, the current view of the type may be the private one,
9088 -- and the procedure that holds the body of the task is held in its
9091 -- This is an odd function, why not have Task_Body_Procedure do
9092 -- the following digging???
9094 return Task_Body_Procedure
(Underlying_Type
(Root_Type
(E
)));
9095 end Get_Task_Body_Procedure
;
9097 -------------------------
9098 -- Get_User_Defined_Eq --
9099 -------------------------
9101 function Get_User_Defined_Eq
(E
: Entity_Id
) return Entity_Id
is
9106 Prim
:= First_Elmt
(Collect_Primitive_Operations
(E
));
9107 while Present
(Prim
) loop
9110 if Chars
(Op
) = Name_Op_Eq
9111 and then Etype
(Op
) = Standard_Boolean
9112 and then Etype
(First_Formal
(Op
)) = E
9113 and then Etype
(Next_Formal
(First_Formal
(Op
))) = E
9122 end Get_User_Defined_Eq
;
9130 Priv_Typ
: out Entity_Id
;
9131 Full_Typ
: out Entity_Id
;
9132 Full_Base
: out Entity_Id
;
9133 CRec_Typ
: out Entity_Id
)
9135 IP_View
: Entity_Id
;
9138 -- Assume that none of the views can be recovered
9145 -- The input type is the corresponding record type of a protected or a
9148 if Ekind
(Typ
) = E_Record_Type
9149 and then Is_Concurrent_Record_Type
(Typ
)
9152 Full_Typ
:= Corresponding_Concurrent_Type
(CRec_Typ
);
9153 Full_Base
:= Base_Type
(Full_Typ
);
9154 Priv_Typ
:= Incomplete_Or_Partial_View
(Full_Typ
);
9156 -- Otherwise the input type denotes an arbitrary type
9159 IP_View
:= Incomplete_Or_Partial_View
(Typ
);
9161 -- The input type denotes the full view of a private type
9163 if Present
(IP_View
) then
9164 Priv_Typ
:= IP_View
;
9167 -- The input type is a private type
9169 elsif Is_Private_Type
(Typ
) then
9171 Full_Typ
:= Full_View
(Priv_Typ
);
9173 -- Otherwise the input type does not have any views
9179 if Present
(Full_Typ
) then
9180 Full_Base
:= Base_Type
(Full_Typ
);
9182 if Ekind_In
(Full_Typ
, E_Protected_Type
, E_Task_Type
) then
9183 CRec_Typ
:= Corresponding_Record_Type
(Full_Typ
);
9189 -----------------------
9190 -- Has_Access_Values --
9191 -----------------------
9193 function Has_Access_Values
(T
: Entity_Id
) return Boolean is
9194 Typ
: constant Entity_Id
:= Underlying_Type
(T
);
9197 -- Case of a private type which is not completed yet. This can only
9198 -- happen in the case of a generic format type appearing directly, or
9199 -- as a component of the type to which this function is being applied
9200 -- at the top level. Return False in this case, since we certainly do
9201 -- not know that the type contains access types.
9206 elsif Is_Access_Type
(Typ
) then
9209 elsif Is_Array_Type
(Typ
) then
9210 return Has_Access_Values
(Component_Type
(Typ
));
9212 elsif Is_Record_Type
(Typ
) then
9217 -- Loop to Check components
9219 Comp
:= First_Component_Or_Discriminant
(Typ
);
9220 while Present
(Comp
) loop
9222 -- Check for access component, tag field does not count, even
9223 -- though it is implemented internally using an access type.
9225 if Has_Access_Values
(Etype
(Comp
))
9226 and then Chars
(Comp
) /= Name_uTag
9231 Next_Component_Or_Discriminant
(Comp
);
9240 end Has_Access_Values
;
9242 ------------------------------
9243 -- Has_Compatible_Alignment --
9244 ------------------------------
9246 function Has_Compatible_Alignment
9249 Layout_Done
: Boolean) return Alignment_Result
9251 function Has_Compatible_Alignment_Internal
9254 Layout_Done
: Boolean;
9255 Default
: Alignment_Result
) return Alignment_Result
;
9256 -- This is the internal recursive function that actually does the work.
9257 -- There is one additional parameter, which says what the result should
9258 -- be if no alignment information is found, and there is no definite
9259 -- indication of compatible alignments. At the outer level, this is set
9260 -- to Unknown, but for internal recursive calls in the case where types
9261 -- are known to be correct, it is set to Known_Compatible.
9263 ---------------------------------------
9264 -- Has_Compatible_Alignment_Internal --
9265 ---------------------------------------
9267 function Has_Compatible_Alignment_Internal
9270 Layout_Done
: Boolean;
9271 Default
: Alignment_Result
) return Alignment_Result
9273 Result
: Alignment_Result
:= Known_Compatible
;
9274 -- Holds the current status of the result. Note that once a value of
9275 -- Known_Incompatible is set, it is sticky and does not get changed
9276 -- to Unknown (the value in Result only gets worse as we go along,
9279 Offs
: Uint
:= No_Uint
;
9280 -- Set to a factor of the offset from the base object when Expr is a
9281 -- selected or indexed component, based on Component_Bit_Offset and
9282 -- Component_Size respectively. A negative value is used to represent
9283 -- a value which is not known at compile time.
9285 procedure Check_Prefix
;
9286 -- Checks the prefix recursively in the case where the expression
9287 -- is an indexed or selected component.
9289 procedure Set_Result
(R
: Alignment_Result
);
9290 -- If R represents a worse outcome (unknown instead of known
9291 -- compatible, or known incompatible), then set Result to R.
9297 procedure Check_Prefix
is
9299 -- The subtlety here is that in doing a recursive call to check
9300 -- the prefix, we have to decide what to do in the case where we
9301 -- don't find any specific indication of an alignment problem.
9303 -- At the outer level, we normally set Unknown as the result in
9304 -- this case, since we can only set Known_Compatible if we really
9305 -- know that the alignment value is OK, but for the recursive
9306 -- call, in the case where the types match, and we have not
9307 -- specified a peculiar alignment for the object, we are only
9308 -- concerned about suspicious rep clauses, the default case does
9309 -- not affect us, since the compiler will, in the absence of such
9310 -- rep clauses, ensure that the alignment is correct.
9312 if Default
= Known_Compatible
9314 (Etype
(Obj
) = Etype
(Expr
)
9315 and then (Unknown_Alignment
(Obj
)
9317 Alignment
(Obj
) = Alignment
(Etype
(Obj
))))
9320 (Has_Compatible_Alignment_Internal
9321 (Obj
, Prefix
(Expr
), Layout_Done
, Known_Compatible
));
9323 -- In all other cases, we need a full check on the prefix
9327 (Has_Compatible_Alignment_Internal
9328 (Obj
, Prefix
(Expr
), Layout_Done
, Unknown
));
9336 procedure Set_Result
(R
: Alignment_Result
) is
9343 -- Start of processing for Has_Compatible_Alignment_Internal
9346 -- If Expr is a selected component, we must make sure there is no
9347 -- potentially troublesome component clause and that the record is
9348 -- not packed if the layout is not done.
9350 if Nkind
(Expr
) = N_Selected_Component
then
9352 -- Packing generates unknown alignment if layout is not done
9354 if Is_Packed
(Etype
(Prefix
(Expr
))) and then not Layout_Done
then
9355 Set_Result
(Unknown
);
9358 -- Check prefix and component offset
9361 Offs
:= Component_Bit_Offset
(Entity
(Selector_Name
(Expr
)));
9363 -- If Expr is an indexed component, we must make sure there is no
9364 -- potentially troublesome Component_Size clause and that the array
9365 -- is not bit-packed if the layout is not done.
9367 elsif Nkind
(Expr
) = N_Indexed_Component
then
9369 Typ
: constant Entity_Id
:= Etype
(Prefix
(Expr
));
9372 -- Packing generates unknown alignment if layout is not done
9374 if Is_Bit_Packed_Array
(Typ
) and then not Layout_Done
then
9375 Set_Result
(Unknown
);
9378 -- Check prefix and component offset (or at least size)
9381 Offs
:= Indexed_Component_Bit_Offset
(Expr
);
9382 if Offs
= No_Uint
then
9383 Offs
:= Component_Size
(Typ
);
9388 -- If we have a null offset, the result is entirely determined by
9389 -- the base object and has already been computed recursively.
9391 if Offs
= Uint_0
then
9394 -- Case where we know the alignment of the object
9396 elsif Known_Alignment
(Obj
) then
9398 ObjA
: constant Uint
:= Alignment
(Obj
);
9399 ExpA
: Uint
:= No_Uint
;
9400 SizA
: Uint
:= No_Uint
;
9403 -- If alignment of Obj is 1, then we are always OK
9406 Set_Result
(Known_Compatible
);
9408 -- Alignment of Obj is greater than 1, so we need to check
9411 -- If we have an offset, see if it is compatible
9413 if Offs
/= No_Uint
and Offs
> Uint_0
then
9414 if Offs
mod (System_Storage_Unit
* ObjA
) /= 0 then
9415 Set_Result
(Known_Incompatible
);
9418 -- See if Expr is an object with known alignment
9420 elsif Is_Entity_Name
(Expr
)
9421 and then Known_Alignment
(Entity
(Expr
))
9423 ExpA
:= Alignment
(Entity
(Expr
));
9425 -- Otherwise, we can use the alignment of the type of
9426 -- Expr given that we already checked for
9427 -- discombobulating rep clauses for the cases of indexed
9428 -- and selected components above.
9430 elsif Known_Alignment
(Etype
(Expr
)) then
9431 ExpA
:= Alignment
(Etype
(Expr
));
9433 -- Otherwise the alignment is unknown
9436 Set_Result
(Default
);
9439 -- If we got an alignment, see if it is acceptable
9441 if ExpA
/= No_Uint
and then ExpA
< ObjA
then
9442 Set_Result
(Known_Incompatible
);
9445 -- If Expr is not a piece of a larger object, see if size
9446 -- is given. If so, check that it is not too small for the
9447 -- required alignment.
9449 if Offs
/= No_Uint
then
9452 -- See if Expr is an object with known size
9454 elsif Is_Entity_Name
(Expr
)
9455 and then Known_Static_Esize
(Entity
(Expr
))
9457 SizA
:= Esize
(Entity
(Expr
));
9459 -- Otherwise, we check the object size of the Expr type
9461 elsif Known_Static_Esize
(Etype
(Expr
)) then
9462 SizA
:= Esize
(Etype
(Expr
));
9465 -- If we got a size, see if it is a multiple of the Obj
9466 -- alignment, if not, then the alignment cannot be
9467 -- acceptable, since the size is always a multiple of the
9470 if SizA
/= No_Uint
then
9471 if SizA
mod (ObjA
* Ttypes
.System_Storage_Unit
) /= 0 then
9472 Set_Result
(Known_Incompatible
);
9478 -- If we do not know required alignment, any non-zero offset is a
9479 -- potential problem (but certainly may be OK, so result is unknown).
9481 elsif Offs
/= No_Uint
then
9482 Set_Result
(Unknown
);
9484 -- If we can't find the result by direct comparison of alignment
9485 -- values, then there is still one case that we can determine known
9486 -- result, and that is when we can determine that the types are the
9487 -- same, and no alignments are specified. Then we known that the
9488 -- alignments are compatible, even if we don't know the alignment
9489 -- value in the front end.
9491 elsif Etype
(Obj
) = Etype
(Expr
) then
9493 -- Types are the same, but we have to check for possible size
9494 -- and alignments on the Expr object that may make the alignment
9495 -- different, even though the types are the same.
9497 if Is_Entity_Name
(Expr
) then
9499 -- First check alignment of the Expr object. Any alignment less
9500 -- than Maximum_Alignment is worrisome since this is the case
9501 -- where we do not know the alignment of Obj.
9503 if Known_Alignment
(Entity
(Expr
))
9504 and then UI_To_Int
(Alignment
(Entity
(Expr
))) <
9505 Ttypes
.Maximum_Alignment
9507 Set_Result
(Unknown
);
9509 -- Now check size of Expr object. Any size that is not an
9510 -- even multiple of Maximum_Alignment is also worrisome
9511 -- since it may cause the alignment of the object to be less
9512 -- than the alignment of the type.
9514 elsif Known_Static_Esize
(Entity
(Expr
))
9516 (UI_To_Int
(Esize
(Entity
(Expr
))) mod
9517 (Ttypes
.Maximum_Alignment
* Ttypes
.System_Storage_Unit
))
9520 Set_Result
(Unknown
);
9522 -- Otherwise same type is decisive
9525 Set_Result
(Known_Compatible
);
9529 -- Another case to deal with is when there is an explicit size or
9530 -- alignment clause when the types are not the same. If so, then the
9531 -- result is Unknown. We don't need to do this test if the Default is
9532 -- Unknown, since that result will be set in any case.
9534 elsif Default
/= Unknown
9535 and then (Has_Size_Clause
(Etype
(Expr
))
9537 Has_Alignment_Clause
(Etype
(Expr
)))
9539 Set_Result
(Unknown
);
9541 -- If no indication found, set default
9544 Set_Result
(Default
);
9547 -- Return worst result found
9550 end Has_Compatible_Alignment_Internal
;
9552 -- Start of processing for Has_Compatible_Alignment
9555 -- If Obj has no specified alignment, then set alignment from the type
9556 -- alignment. Perhaps we should always do this, but for sure we should
9557 -- do it when there is an address clause since we can do more if the
9558 -- alignment is known.
9560 if Unknown_Alignment
(Obj
) then
9561 Set_Alignment
(Obj
, Alignment
(Etype
(Obj
)));
9564 -- Now do the internal call that does all the work
9567 Has_Compatible_Alignment_Internal
(Obj
, Expr
, Layout_Done
, Unknown
);
9568 end Has_Compatible_Alignment
;
9570 ----------------------
9571 -- Has_Declarations --
9572 ----------------------
9574 function Has_Declarations
(N
: Node_Id
) return Boolean is
9576 return Nkind_In
(Nkind
(N
), N_Accept_Statement
,
9578 N_Compilation_Unit_Aux
,
9584 N_Package_Specification
);
9585 end Has_Declarations
;
9587 ---------------------------------
9588 -- Has_Defaulted_Discriminants --
9589 ---------------------------------
9591 function Has_Defaulted_Discriminants
(Typ
: Entity_Id
) return Boolean is
9593 return Has_Discriminants
(Typ
)
9594 and then Present
(First_Discriminant
(Typ
))
9595 and then Present
(Discriminant_Default_Value
9596 (First_Discriminant
(Typ
)));
9597 end Has_Defaulted_Discriminants
;
9603 function Has_Denormals
(E
: Entity_Id
) return Boolean is
9605 return Is_Floating_Point_Type
(E
) and then Denorm_On_Target
;
9608 -------------------------------------------
9609 -- Has_Discriminant_Dependent_Constraint --
9610 -------------------------------------------
9612 function Has_Discriminant_Dependent_Constraint
9613 (Comp
: Entity_Id
) return Boolean
9615 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
9616 Subt_Indic
: Node_Id
;
9621 -- Discriminants can't depend on discriminants
9623 if Ekind
(Comp
) = E_Discriminant
then
9627 Subt_Indic
:= Subtype_Indication
(Component_Definition
(Comp_Decl
));
9629 if Nkind
(Subt_Indic
) = N_Subtype_Indication
then
9630 Constr
:= Constraint
(Subt_Indic
);
9632 if Nkind
(Constr
) = N_Index_Or_Discriminant_Constraint
then
9633 Assn
:= First
(Constraints
(Constr
));
9634 while Present
(Assn
) loop
9635 case Nkind
(Assn
) is
9638 | N_Subtype_Indication
9640 if Depends_On_Discriminant
(Assn
) then
9644 when N_Discriminant_Association
=>
9645 if Depends_On_Discriminant
(Expression
(Assn
)) then
9660 end Has_Discriminant_Dependent_Constraint
;
9662 --------------------------------------
9663 -- Has_Effectively_Volatile_Profile --
9664 --------------------------------------
9666 function Has_Effectively_Volatile_Profile
9667 (Subp_Id
: Entity_Id
) return Boolean
9672 -- Inspect the formal parameters looking for an effectively volatile
9675 Formal
:= First_Formal
(Subp_Id
);
9676 while Present
(Formal
) loop
9677 if Is_Effectively_Volatile
(Etype
(Formal
)) then
9681 Next_Formal
(Formal
);
9684 -- Inspect the return type of functions
9686 if Ekind_In
(Subp_Id
, E_Function
, E_Generic_Function
)
9687 and then Is_Effectively_Volatile
(Etype
(Subp_Id
))
9693 end Has_Effectively_Volatile_Profile
;
9695 --------------------------
9696 -- Has_Enabled_Property --
9697 --------------------------
9699 function Has_Enabled_Property
9700 (Item_Id
: Entity_Id
;
9701 Property
: Name_Id
) return Boolean
9703 function Protected_Object_Has_Enabled_Property
return Boolean;
9704 -- Determine whether a protected object denoted by Item_Id has the
9705 -- property enabled.
9707 function State_Has_Enabled_Property
return Boolean;
9708 -- Determine whether a state denoted by Item_Id has the property enabled
9710 function Variable_Has_Enabled_Property
return Boolean;
9711 -- Determine whether a variable denoted by Item_Id has the property
9714 -------------------------------------------
9715 -- Protected_Object_Has_Enabled_Property --
9716 -------------------------------------------
9718 function Protected_Object_Has_Enabled_Property
return Boolean is
9719 Constits
: constant Elist_Id
:= Part_Of_Constituents
(Item_Id
);
9720 Constit_Elmt
: Elmt_Id
;
9721 Constit_Id
: Entity_Id
;
9724 -- Protected objects always have the properties Async_Readers and
9725 -- Async_Writers (SPARK RM 7.1.2(16)).
9727 if Property
= Name_Async_Readers
9728 or else Property
= Name_Async_Writers
9732 -- Protected objects that have Part_Of components also inherit their
9733 -- properties Effective_Reads and Effective_Writes
9734 -- (SPARK RM 7.1.2(16)).
9736 elsif Present
(Constits
) then
9737 Constit_Elmt
:= First_Elmt
(Constits
);
9738 while Present
(Constit_Elmt
) loop
9739 Constit_Id
:= Node
(Constit_Elmt
);
9741 if Has_Enabled_Property
(Constit_Id
, Property
) then
9745 Next_Elmt
(Constit_Elmt
);
9750 end Protected_Object_Has_Enabled_Property
;
9752 --------------------------------
9753 -- State_Has_Enabled_Property --
9754 --------------------------------
9756 function State_Has_Enabled_Property
return Boolean is
9757 Decl
: constant Node_Id
:= Parent
(Item_Id
);
9765 -- The declaration of an external abstract state appears as an
9766 -- extension aggregate. If this is not the case, properties can never
9769 if Nkind
(Decl
) /= N_Extension_Aggregate
then
9773 -- When External appears as a simple option, it automatically enables
9776 Opt
:= First
(Expressions
(Decl
));
9777 while Present
(Opt
) loop
9778 if Nkind
(Opt
) = N_Identifier
9779 and then Chars
(Opt
) = Name_External
9787 -- When External specifies particular properties, inspect those and
9788 -- find the desired one (if any).
9790 Opt
:= First
(Component_Associations
(Decl
));
9791 while Present
(Opt
) loop
9792 Opt_Nam
:= First
(Choices
(Opt
));
9794 if Nkind
(Opt_Nam
) = N_Identifier
9795 and then Chars
(Opt_Nam
) = Name_External
9797 Props
:= Expression
(Opt
);
9799 -- Multiple properties appear as an aggregate
9801 if Nkind
(Props
) = N_Aggregate
then
9803 -- Simple property form
9805 Prop
:= First
(Expressions
(Props
));
9806 while Present
(Prop
) loop
9807 if Chars
(Prop
) = Property
then
9814 -- Property with expression form
9816 Prop
:= First
(Component_Associations
(Props
));
9817 while Present
(Prop
) loop
9818 Prop_Nam
:= First
(Choices
(Prop
));
9820 -- The property can be represented in two ways:
9821 -- others => <value>
9822 -- <property> => <value>
9824 if Nkind
(Prop_Nam
) = N_Others_Choice
9825 or else (Nkind
(Prop_Nam
) = N_Identifier
9826 and then Chars
(Prop_Nam
) = Property
)
9828 return Is_True
(Expr_Value
(Expression
(Prop
)));
9837 return Chars
(Props
) = Property
;
9845 end State_Has_Enabled_Property
;
9847 -----------------------------------
9848 -- Variable_Has_Enabled_Property --
9849 -----------------------------------
9851 function Variable_Has_Enabled_Property
return Boolean is
9852 function Is_Enabled
(Prag
: Node_Id
) return Boolean;
9853 -- Determine whether property pragma Prag (if present) denotes an
9854 -- enabled property.
9860 function Is_Enabled
(Prag
: Node_Id
) return Boolean is
9864 if Present
(Prag
) then
9865 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
9867 -- The pragma has an optional Boolean expression, the related
9868 -- property is enabled only when the expression evaluates to
9871 if Present
(Arg1
) then
9872 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
)));
9874 -- Otherwise the lack of expression enables the property by
9881 -- The property was never set in the first place
9890 AR
: constant Node_Id
:=
9891 Get_Pragma
(Item_Id
, Pragma_Async_Readers
);
9892 AW
: constant Node_Id
:=
9893 Get_Pragma
(Item_Id
, Pragma_Async_Writers
);
9894 ER
: constant Node_Id
:=
9895 Get_Pragma
(Item_Id
, Pragma_Effective_Reads
);
9896 EW
: constant Node_Id
:=
9897 Get_Pragma
(Item_Id
, Pragma_Effective_Writes
);
9899 -- Start of processing for Variable_Has_Enabled_Property
9902 -- A non-effectively volatile object can never possess external
9905 if not Is_Effectively_Volatile
(Item_Id
) then
9908 -- External properties related to variables come in two flavors -
9909 -- explicit and implicit. The explicit case is characterized by the
9910 -- presence of a property pragma with an optional Boolean flag. The
9911 -- property is enabled when the flag evaluates to True or the flag is
9912 -- missing altogether.
9914 elsif Property
= Name_Async_Readers
and then Is_Enabled
(AR
) then
9917 elsif Property
= Name_Async_Writers
and then Is_Enabled
(AW
) then
9920 elsif Property
= Name_Effective_Reads
and then Is_Enabled
(ER
) then
9923 elsif Property
= Name_Effective_Writes
and then Is_Enabled
(EW
) then
9926 -- The implicit case lacks all property pragmas
9928 elsif No
(AR
) and then No
(AW
) and then No
(ER
) and then No
(EW
) then
9929 if Is_Protected_Type
(Etype
(Item_Id
)) then
9930 return Protected_Object_Has_Enabled_Property
;
9938 end Variable_Has_Enabled_Property
;
9940 -- Start of processing for Has_Enabled_Property
9943 -- Abstract states and variables have a flexible scheme of specifying
9944 -- external properties.
9946 if Ekind
(Item_Id
) = E_Abstract_State
then
9947 return State_Has_Enabled_Property
;
9949 elsif Ekind
(Item_Id
) = E_Variable
then
9950 return Variable_Has_Enabled_Property
;
9952 -- By default, protected objects only have the properties Async_Readers
9953 -- and Async_Writers. If they have Part_Of components, they also inherit
9954 -- their properties Effective_Reads and Effective_Writes
9955 -- (SPARK RM 7.1.2(16)).
9957 elsif Ekind
(Item_Id
) = E_Protected_Object
then
9958 return Protected_Object_Has_Enabled_Property
;
9960 -- Otherwise a property is enabled when the related item is effectively
9964 return Is_Effectively_Volatile
(Item_Id
);
9966 end Has_Enabled_Property
;
9968 -------------------------------------
9969 -- Has_Full_Default_Initialization --
9970 -------------------------------------
9972 function Has_Full_Default_Initialization
(Typ
: Entity_Id
) return Boolean is
9977 -- A type subject to pragma Default_Initial_Condition is fully default
9978 -- initialized when the pragma appears with a non-null argument. Since
9979 -- any type may act as the full view of a private type, this check must
9980 -- be performed prior to the specialized tests below.
9982 if Has_DIC
(Typ
) then
9983 Prag
:= Get_Pragma
(Typ
, Pragma_Default_Initial_Condition
);
9984 pragma Assert
(Present
(Prag
));
9986 return Is_Verifiable_DIC_Pragma
(Prag
);
9989 -- A scalar type is fully default initialized if it is subject to aspect
9992 if Is_Scalar_Type
(Typ
) then
9993 return Has_Default_Aspect
(Typ
);
9995 -- An array type is fully default initialized if its element type is
9996 -- scalar and the array type carries aspect Default_Component_Value or
9997 -- the element type is fully default initialized.
9999 elsif Is_Array_Type
(Typ
) then
10001 Has_Default_Aspect
(Typ
)
10002 or else Has_Full_Default_Initialization
(Component_Type
(Typ
));
10004 -- A protected type, record type, or type extension is fully default
10005 -- initialized if all its components either carry an initialization
10006 -- expression or have a type that is fully default initialized. The
10007 -- parent type of a type extension must be fully default initialized.
10009 elsif Is_Record_Type
(Typ
) or else Is_Protected_Type
(Typ
) then
10011 -- Inspect all entities defined in the scope of the type, looking for
10012 -- uninitialized components.
10014 Comp
:= First_Entity
(Typ
);
10015 while Present
(Comp
) loop
10016 if Ekind
(Comp
) = E_Component
10017 and then Comes_From_Source
(Comp
)
10018 and then No
(Expression
(Parent
(Comp
)))
10019 and then not Has_Full_Default_Initialization
(Etype
(Comp
))
10024 Next_Entity
(Comp
);
10027 -- Ensure that the parent type of a type extension is fully default
10030 if Etype
(Typ
) /= Typ
10031 and then not Has_Full_Default_Initialization
(Etype
(Typ
))
10036 -- If we get here, then all components and parent portion are fully
10037 -- default initialized.
10041 -- A task type is fully default initialized by default
10043 elsif Is_Task_Type
(Typ
) then
10046 -- Otherwise the type is not fully default initialized
10051 end Has_Full_Default_Initialization
;
10053 --------------------
10054 -- Has_Infinities --
10055 --------------------
10057 function Has_Infinities
(E
: Entity_Id
) return Boolean is
10060 Is_Floating_Point_Type
(E
)
10061 and then Nkind
(Scalar_Range
(E
)) = N_Range
10062 and then Includes_Infinities
(Scalar_Range
(E
));
10063 end Has_Infinities
;
10065 --------------------
10066 -- Has_Interfaces --
10067 --------------------
10069 function Has_Interfaces
10071 Use_Full_View
: Boolean := True) return Boolean
10073 Typ
: Entity_Id
:= Base_Type
(T
);
10076 -- Handle concurrent types
10078 if Is_Concurrent_Type
(Typ
) then
10079 Typ
:= Corresponding_Record_Type
(Typ
);
10082 if not Present
(Typ
)
10083 or else not Is_Record_Type
(Typ
)
10084 or else not Is_Tagged_Type
(Typ
)
10089 -- Handle private types
10091 if Use_Full_View
and then Present
(Full_View
(Typ
)) then
10092 Typ
:= Full_View
(Typ
);
10095 -- Handle concurrent record types
10097 if Is_Concurrent_Record_Type
(Typ
)
10098 and then Is_Non_Empty_List
(Abstract_Interface_List
(Typ
))
10104 if Is_Interface
(Typ
)
10106 (Is_Record_Type
(Typ
)
10107 and then Present
(Interfaces
(Typ
))
10108 and then not Is_Empty_Elmt_List
(Interfaces
(Typ
)))
10113 exit when Etype
(Typ
) = Typ
10115 -- Handle private types
10117 or else (Present
(Full_View
(Etype
(Typ
)))
10118 and then Full_View
(Etype
(Typ
)) = Typ
)
10120 -- Protect frontend against wrong sources with cyclic derivations
10122 or else Etype
(Typ
) = T
;
10124 -- Climb to the ancestor type handling private types
10126 if Present
(Full_View
(Etype
(Typ
))) then
10127 Typ
:= Full_View
(Etype
(Typ
));
10129 Typ
:= Etype
(Typ
);
10134 end Has_Interfaces
;
10136 --------------------------
10137 -- Has_Max_Queue_Length --
10138 --------------------------
10140 function Has_Max_Queue_Length
(Id
: Entity_Id
) return Boolean is
10143 Ekind
(Id
) = E_Entry
10144 and then Present
(Get_Pragma
(Id
, Pragma_Max_Queue_Length
));
10145 end Has_Max_Queue_Length
;
10147 ---------------------------------
10148 -- Has_No_Obvious_Side_Effects --
10149 ---------------------------------
10151 function Has_No_Obvious_Side_Effects
(N
: Node_Id
) return Boolean is
10153 -- For now handle literals, constants, and non-volatile variables and
10154 -- expressions combining these with operators or short circuit forms.
10156 if Nkind
(N
) in N_Numeric_Or_String_Literal
then
10159 elsif Nkind
(N
) = N_Character_Literal
then
10162 elsif Nkind
(N
) in N_Unary_Op
then
10163 return Has_No_Obvious_Side_Effects
(Right_Opnd
(N
));
10165 elsif Nkind
(N
) in N_Binary_Op
or else Nkind
(N
) in N_Short_Circuit
then
10166 return Has_No_Obvious_Side_Effects
(Left_Opnd
(N
))
10168 Has_No_Obvious_Side_Effects
(Right_Opnd
(N
));
10170 elsif Nkind
(N
) = N_Expression_With_Actions
10171 and then Is_Empty_List
(Actions
(N
))
10173 return Has_No_Obvious_Side_Effects
(Expression
(N
));
10175 elsif Nkind
(N
) in N_Has_Entity
then
10176 return Present
(Entity
(N
))
10177 and then Ekind_In
(Entity
(N
), E_Variable
,
10179 E_Enumeration_Literal
,
10182 E_In_Out_Parameter
)
10183 and then not Is_Volatile
(Entity
(N
));
10188 end Has_No_Obvious_Side_Effects
;
10190 -----------------------------
10191 -- Has_Non_Null_Refinement --
10192 -----------------------------
10194 function Has_Non_Null_Refinement
(Id
: Entity_Id
) return Boolean is
10195 Constits
: Elist_Id
;
10198 pragma Assert
(Ekind
(Id
) = E_Abstract_State
);
10199 Constits
:= Refinement_Constituents
(Id
);
10201 -- For a refinement to be non-null, the first constituent must be
10202 -- anything other than null.
10206 and then Nkind
(Node
(First_Elmt
(Constits
))) /= N_Null
;
10207 end Has_Non_Null_Refinement
;
10209 ----------------------------------
10210 -- Has_Non_Trivial_Precondition --
10211 ----------------------------------
10213 function Has_Non_Trivial_Precondition
(P
: Entity_Id
) return Boolean is
10214 Cont
: constant Node_Id
:= Find_Aspect
(P
, Aspect_Pre
);
10216 return Present
(Cont
)
10217 and then Class_Present
(Cont
)
10218 and then not Is_Entity_Name
(Expression
(Cont
));
10219 end Has_Non_Trivial_Precondition
;
10221 -------------------
10222 -- Has_Null_Body --
10223 -------------------
10225 function Has_Null_Body
(Proc_Id
: Entity_Id
) return Boolean is
10226 Body_Id
: Entity_Id
;
10233 Spec
:= Parent
(Proc_Id
);
10234 Decl
:= Parent
(Spec
);
10236 -- Retrieve the entity of the procedure body (e.g. invariant proc).
10238 if Nkind
(Spec
) = N_Procedure_Specification
10239 and then Nkind
(Decl
) = N_Subprogram_Declaration
10241 Body_Id
:= Corresponding_Body
(Decl
);
10243 -- The body acts as a spec
10246 Body_Id
:= Proc_Id
;
10249 -- The body will be generated later
10251 if No
(Body_Id
) then
10255 Spec
:= Parent
(Body_Id
);
10256 Decl
:= Parent
(Spec
);
10259 (Nkind
(Spec
) = N_Procedure_Specification
10260 and then Nkind
(Decl
) = N_Subprogram_Body
);
10262 Stmt1
:= First
(Statements
(Handled_Statement_Sequence
(Decl
)));
10264 -- Look for a null statement followed by an optional return
10267 if Nkind
(Stmt1
) = N_Null_Statement
then
10268 Stmt2
:= Next
(Stmt1
);
10270 if Present
(Stmt2
) then
10271 return Nkind
(Stmt2
) = N_Simple_Return_Statement
;
10280 ------------------------
10281 -- Has_Null_Exclusion --
10282 ------------------------
10284 function Has_Null_Exclusion
(N
: Node_Id
) return Boolean is
10287 when N_Access_Definition
10288 | N_Access_Function_Definition
10289 | N_Access_Procedure_Definition
10290 | N_Access_To_Object_Definition
10292 | N_Derived_Type_Definition
10293 | N_Function_Specification
10294 | N_Subtype_Declaration
10296 return Null_Exclusion_Present
(N
);
10298 when N_Component_Definition
10299 | N_Formal_Object_Declaration
10300 | N_Object_Renaming_Declaration
10302 if Present
(Subtype_Mark
(N
)) then
10303 return Null_Exclusion_Present
(N
);
10304 else pragma Assert
(Present
(Access_Definition
(N
)));
10305 return Null_Exclusion_Present
(Access_Definition
(N
));
10308 when N_Discriminant_Specification
=>
10309 if Nkind
(Discriminant_Type
(N
)) = N_Access_Definition
then
10310 return Null_Exclusion_Present
(Discriminant_Type
(N
));
10312 return Null_Exclusion_Present
(N
);
10315 when N_Object_Declaration
=>
10316 if Nkind
(Object_Definition
(N
)) = N_Access_Definition
then
10317 return Null_Exclusion_Present
(Object_Definition
(N
));
10319 return Null_Exclusion_Present
(N
);
10322 when N_Parameter_Specification
=>
10323 if Nkind
(Parameter_Type
(N
)) = N_Access_Definition
then
10324 return Null_Exclusion_Present
(Parameter_Type
(N
));
10326 return Null_Exclusion_Present
(N
);
10332 end Has_Null_Exclusion
;
10334 ------------------------
10335 -- Has_Null_Extension --
10336 ------------------------
10338 function Has_Null_Extension
(T
: Entity_Id
) return Boolean is
10339 B
: constant Entity_Id
:= Base_Type
(T
);
10344 if Nkind
(Parent
(B
)) = N_Full_Type_Declaration
10345 and then Present
(Record_Extension_Part
(Type_Definition
(Parent
(B
))))
10347 Ext
:= Record_Extension_Part
(Type_Definition
(Parent
(B
)));
10349 if Present
(Ext
) then
10350 if Null_Present
(Ext
) then
10353 Comps
:= Component_List
(Ext
);
10355 -- The null component list is rewritten during analysis to
10356 -- include the parent component. Any other component indicates
10357 -- that the extension was not originally null.
10359 return Null_Present
(Comps
)
10360 or else No
(Next
(First
(Component_Items
(Comps
))));
10369 end Has_Null_Extension
;
10371 -------------------------
10372 -- Has_Null_Refinement --
10373 -------------------------
10375 function Has_Null_Refinement
(Id
: Entity_Id
) return Boolean is
10376 Constits
: Elist_Id
;
10379 pragma Assert
(Ekind
(Id
) = E_Abstract_State
);
10380 Constits
:= Refinement_Constituents
(Id
);
10382 -- For a refinement to be null, the state's sole constituent must be a
10387 and then Nkind
(Node
(First_Elmt
(Constits
))) = N_Null
;
10388 end Has_Null_Refinement
;
10390 -------------------------------
10391 -- Has_Overriding_Initialize --
10392 -------------------------------
10394 function Has_Overriding_Initialize
(T
: Entity_Id
) return Boolean is
10395 BT
: constant Entity_Id
:= Base_Type
(T
);
10399 if Is_Controlled
(BT
) then
10400 if Is_RTU
(Scope
(BT
), Ada_Finalization
) then
10403 elsif Present
(Primitive_Operations
(BT
)) then
10404 P
:= First_Elmt
(Primitive_Operations
(BT
));
10405 while Present
(P
) loop
10407 Init
: constant Entity_Id
:= Node
(P
);
10408 Formal
: constant Entity_Id
:= First_Formal
(Init
);
10410 if Ekind
(Init
) = E_Procedure
10411 and then Chars
(Init
) = Name_Initialize
10412 and then Comes_From_Source
(Init
)
10413 and then Present
(Formal
)
10414 and then Etype
(Formal
) = BT
10415 and then No
(Next_Formal
(Formal
))
10416 and then (Ada_Version
< Ada_2012
10417 or else not Null_Present
(Parent
(Init
)))
10427 -- Here if type itself does not have a non-null Initialize operation:
10428 -- check immediate ancestor.
10430 if Is_Derived_Type
(BT
)
10431 and then Has_Overriding_Initialize
(Etype
(BT
))
10438 end Has_Overriding_Initialize
;
10440 --------------------------------------
10441 -- Has_Preelaborable_Initialization --
10442 --------------------------------------
10444 function Has_Preelaborable_Initialization
(E
: Entity_Id
) return Boolean is
10447 procedure Check_Components
(E
: Entity_Id
);
10448 -- Check component/discriminant chain, sets Has_PE False if a component
10449 -- or discriminant does not meet the preelaborable initialization rules.
10451 ----------------------
10452 -- Check_Components --
10453 ----------------------
10455 procedure Check_Components
(E
: Entity_Id
) is
10459 function Is_Preelaborable_Expression
(N
: Node_Id
) return Boolean;
10460 -- Returns True if and only if the expression denoted by N does not
10461 -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)).
10463 ---------------------------------
10464 -- Is_Preelaborable_Expression --
10465 ---------------------------------
10467 function Is_Preelaborable_Expression
(N
: Node_Id
) return Boolean is
10471 Comp_Type
: Entity_Id
;
10472 Is_Array_Aggr
: Boolean;
10475 if Is_OK_Static_Expression
(N
) then
10478 elsif Nkind
(N
) = N_Null
then
10481 -- Attributes are allowed in general, even if their prefix is a
10482 -- formal type. (It seems that certain attributes known not to be
10483 -- static might not be allowed, but there are no rules to prevent
10486 elsif Nkind
(N
) = N_Attribute_Reference
then
10489 -- The name of a discriminant evaluated within its parent type is
10490 -- defined to be preelaborable (10.2.1(8)). Note that we test for
10491 -- names that denote discriminals as well as discriminants to
10492 -- catch references occurring within init procs.
10494 elsif Is_Entity_Name
(N
)
10496 (Ekind
(Entity
(N
)) = E_Discriminant
10497 or else (Ekind_In
(Entity
(N
), E_Constant
, E_In_Parameter
)
10498 and then Present
(Discriminal_Link
(Entity
(N
)))))
10502 elsif Nkind
(N
) = N_Qualified_Expression
then
10503 return Is_Preelaborable_Expression
(Expression
(N
));
10505 -- For aggregates we have to check that each of the associations
10506 -- is preelaborable.
10508 elsif Nkind_In
(N
, N_Aggregate
, N_Extension_Aggregate
) then
10509 Is_Array_Aggr
:= Is_Array_Type
(Etype
(N
));
10511 if Is_Array_Aggr
then
10512 Comp_Type
:= Component_Type
(Etype
(N
));
10515 -- Check the ancestor part of extension aggregates, which must
10516 -- be either the name of a type that has preelaborable init or
10517 -- an expression that is preelaborable.
10519 if Nkind
(N
) = N_Extension_Aggregate
then
10521 Anc_Part
: constant Node_Id
:= Ancestor_Part
(N
);
10524 if Is_Entity_Name
(Anc_Part
)
10525 and then Is_Type
(Entity
(Anc_Part
))
10527 if not Has_Preelaborable_Initialization
10528 (Entity
(Anc_Part
))
10533 elsif not Is_Preelaborable_Expression
(Anc_Part
) then
10539 -- Check positional associations
10541 Exp
:= First
(Expressions
(N
));
10542 while Present
(Exp
) loop
10543 if not Is_Preelaborable_Expression
(Exp
) then
10550 -- Check named associations
10552 Assn
:= First
(Component_Associations
(N
));
10553 while Present
(Assn
) loop
10554 Choice
:= First
(Choices
(Assn
));
10555 while Present
(Choice
) loop
10556 if Is_Array_Aggr
then
10557 if Nkind
(Choice
) = N_Others_Choice
then
10560 elsif Nkind
(Choice
) = N_Range
then
10561 if not Is_OK_Static_Range
(Choice
) then
10565 elsif not Is_OK_Static_Expression
(Choice
) then
10570 Comp_Type
:= Etype
(Choice
);
10576 -- If the association has a <> at this point, then we have
10577 -- to check whether the component's type has preelaborable
10578 -- initialization. Note that this only occurs when the
10579 -- association's corresponding component does not have a
10580 -- default expression, the latter case having already been
10581 -- expanded as an expression for the association.
10583 if Box_Present
(Assn
) then
10584 if not Has_Preelaborable_Initialization
(Comp_Type
) then
10588 -- In the expression case we check whether the expression
10589 -- is preelaborable.
10592 not Is_Preelaborable_Expression
(Expression
(Assn
))
10600 -- If we get here then aggregate as a whole is preelaborable
10604 -- All other cases are not preelaborable
10609 end Is_Preelaborable_Expression
;
10611 -- Start of processing for Check_Components
10614 -- Loop through entities of record or protected type
10617 while Present
(Ent
) loop
10619 -- We are interested only in components and discriminants
10623 case Ekind
(Ent
) is
10624 when E_Component
=>
10626 -- Get default expression if any. If there is no declaration
10627 -- node, it means we have an internal entity. The parent and
10628 -- tag fields are examples of such entities. For such cases,
10629 -- we just test the type of the entity.
10631 if Present
(Declaration_Node
(Ent
)) then
10632 Exp
:= Expression
(Declaration_Node
(Ent
));
10635 when E_Discriminant
=>
10637 -- Note: for a renamed discriminant, the Declaration_Node
10638 -- may point to the one from the ancestor, and have a
10639 -- different expression, so use the proper attribute to
10640 -- retrieve the expression from the derived constraint.
10642 Exp
:= Discriminant_Default_Value
(Ent
);
10645 goto Check_Next_Entity
;
10648 -- A component has PI if it has no default expression and the
10649 -- component type has PI.
10652 if not Has_Preelaborable_Initialization
(Etype
(Ent
)) then
10657 -- Require the default expression to be preelaborable
10659 elsif not Is_Preelaborable_Expression
(Exp
) then
10664 <<Check_Next_Entity
>>
10667 end Check_Components
;
10669 -- Start of processing for Has_Preelaborable_Initialization
10672 -- Immediate return if already marked as known preelaborable init. This
10673 -- covers types for which this function has already been called once
10674 -- and returned True (in which case the result is cached), and also
10675 -- types to which a pragma Preelaborable_Initialization applies.
10677 if Known_To_Have_Preelab_Init
(E
) then
10681 -- If the type is a subtype representing a generic actual type, then
10682 -- test whether its base type has preelaborable initialization since
10683 -- the subtype representing the actual does not inherit this attribute
10684 -- from the actual or formal. (but maybe it should???)
10686 if Is_Generic_Actual_Type
(E
) then
10687 return Has_Preelaborable_Initialization
(Base_Type
(E
));
10690 -- All elementary types have preelaborable initialization
10692 if Is_Elementary_Type
(E
) then
10695 -- Array types have PI if the component type has PI
10697 elsif Is_Array_Type
(E
) then
10698 Has_PE
:= Has_Preelaborable_Initialization
(Component_Type
(E
));
10700 -- A derived type has preelaborable initialization if its parent type
10701 -- has preelaborable initialization and (in the case of a derived record
10702 -- extension) if the non-inherited components all have preelaborable
10703 -- initialization. However, a user-defined controlled type with an
10704 -- overriding Initialize procedure does not have preelaborable
10707 elsif Is_Derived_Type
(E
) then
10709 -- If the derived type is a private extension then it doesn't have
10710 -- preelaborable initialization.
10712 if Ekind
(Base_Type
(E
)) = E_Record_Type_With_Private
then
10716 -- First check whether ancestor type has preelaborable initialization
10718 Has_PE
:= Has_Preelaborable_Initialization
(Etype
(Base_Type
(E
)));
10720 -- If OK, check extension components (if any)
10722 if Has_PE
and then Is_Record_Type
(E
) then
10723 Check_Components
(First_Entity
(E
));
10726 -- Check specifically for 10.2.1(11.4/2) exception: a controlled type
10727 -- with a user defined Initialize procedure does not have PI. If
10728 -- the type is untagged, the control primitives come from a component
10729 -- that has already been checked.
10732 and then Is_Controlled
(E
)
10733 and then Is_Tagged_Type
(E
)
10734 and then Has_Overriding_Initialize
(E
)
10739 -- Private types not derived from a type having preelaborable init and
10740 -- that are not marked with pragma Preelaborable_Initialization do not
10741 -- have preelaborable initialization.
10743 elsif Is_Private_Type
(E
) then
10746 -- Record type has PI if it is non private and all components have PI
10748 elsif Is_Record_Type
(E
) then
10750 Check_Components
(First_Entity
(E
));
10752 -- Protected types must not have entries, and components must meet
10753 -- same set of rules as for record components.
10755 elsif Is_Protected_Type
(E
) then
10756 if Has_Entries
(E
) then
10760 Check_Components
(First_Entity
(E
));
10761 Check_Components
(First_Private_Entity
(E
));
10764 -- Type System.Address always has preelaborable initialization
10766 elsif Is_RTE
(E
, RE_Address
) then
10769 -- In all other cases, type does not have preelaborable initialization
10775 -- If type has preelaborable initialization, cache result
10778 Set_Known_To_Have_Preelab_Init
(E
);
10782 end Has_Preelaborable_Initialization
;
10784 ---------------------------
10785 -- Has_Private_Component --
10786 ---------------------------
10788 function Has_Private_Component
(Type_Id
: Entity_Id
) return Boolean is
10789 Btype
: Entity_Id
:= Base_Type
(Type_Id
);
10790 Component
: Entity_Id
;
10793 if Error_Posted
(Type_Id
)
10794 or else Error_Posted
(Btype
)
10799 if Is_Class_Wide_Type
(Btype
) then
10800 Btype
:= Root_Type
(Btype
);
10803 if Is_Private_Type
(Btype
) then
10805 UT
: constant Entity_Id
:= Underlying_Type
(Btype
);
10808 if No
(Full_View
(Btype
)) then
10809 return not Is_Generic_Type
(Btype
)
10811 not Is_Generic_Type
(Root_Type
(Btype
));
10813 return not Is_Generic_Type
(Root_Type
(Full_View
(Btype
)));
10816 return not Is_Frozen
(UT
) and then Has_Private_Component
(UT
);
10820 elsif Is_Array_Type
(Btype
) then
10821 return Has_Private_Component
(Component_Type
(Btype
));
10823 elsif Is_Record_Type
(Btype
) then
10824 Component
:= First_Component
(Btype
);
10825 while Present
(Component
) loop
10826 if Has_Private_Component
(Etype
(Component
)) then
10830 Next_Component
(Component
);
10835 elsif Is_Protected_Type
(Btype
)
10836 and then Present
(Corresponding_Record_Type
(Btype
))
10838 return Has_Private_Component
(Corresponding_Record_Type
(Btype
));
10843 end Has_Private_Component
;
10845 ----------------------
10846 -- Has_Signed_Zeros --
10847 ----------------------
10849 function Has_Signed_Zeros
(E
: Entity_Id
) return Boolean is
10851 return Is_Floating_Point_Type
(E
) and then Signed_Zeros_On_Target
;
10852 end Has_Signed_Zeros
;
10854 ------------------------------
10855 -- Has_Significant_Contract --
10856 ------------------------------
10858 function Has_Significant_Contract
(Subp_Id
: Entity_Id
) return Boolean is
10859 Subp_Nam
: constant Name_Id
:= Chars
(Subp_Id
);
10862 -- _Finalizer procedure
10864 if Subp_Nam
= Name_uFinalizer
then
10867 -- _Postconditions procedure
10869 elsif Subp_Nam
= Name_uPostconditions
then
10872 -- Predicate function
10874 elsif Ekind
(Subp_Id
) = E_Function
10875 and then Is_Predicate_Function
(Subp_Id
)
10881 elsif Get_TSS_Name
(Subp_Id
) /= TSS_Null
then
10887 end Has_Significant_Contract
;
10889 -----------------------------
10890 -- Has_Static_Array_Bounds --
10891 -----------------------------
10893 function Has_Static_Array_Bounds
(Typ
: Node_Id
) return Boolean is
10894 Ndims
: constant Nat
:= Number_Dimensions
(Typ
);
10901 -- Unconstrained types do not have static bounds
10903 if not Is_Constrained
(Typ
) then
10907 -- First treat string literals specially, as the lower bound and length
10908 -- of string literals are not stored like those of arrays.
10910 -- A string literal always has static bounds
10912 if Ekind
(Typ
) = E_String_Literal_Subtype
then
10916 -- Treat all dimensions in turn
10918 Index
:= First_Index
(Typ
);
10919 for Indx
in 1 .. Ndims
loop
10921 -- In case of an illegal index which is not a discrete type, return
10922 -- that the type is not static.
10924 if not Is_Discrete_Type
(Etype
(Index
))
10925 or else Etype
(Index
) = Any_Type
10930 Get_Index_Bounds
(Index
, Low
, High
);
10932 if Error_Posted
(Low
) or else Error_Posted
(High
) then
10936 if Is_OK_Static_Expression
(Low
)
10938 Is_OK_Static_Expression
(High
)
10948 -- If we fall through the loop, all indexes matched
10951 end Has_Static_Array_Bounds
;
10957 function Has_Stream
(T
: Entity_Id
) return Boolean is
10964 elsif Is_RTE
(Root_Type
(T
), RE_Root_Stream_Type
) then
10967 elsif Is_Array_Type
(T
) then
10968 return Has_Stream
(Component_Type
(T
));
10970 elsif Is_Record_Type
(T
) then
10971 E
:= First_Component
(T
);
10972 while Present
(E
) loop
10973 if Has_Stream
(Etype
(E
)) then
10976 Next_Component
(E
);
10982 elsif Is_Private_Type
(T
) then
10983 return Has_Stream
(Underlying_Type
(T
));
10994 function Has_Suffix
(E
: Entity_Id
; Suffix
: Character) return Boolean is
10996 Get_Name_String
(Chars
(E
));
10997 return Name_Buffer
(Name_Len
) = Suffix
;
11004 function Add_Suffix
(E
: Entity_Id
; Suffix
: Character) return Name_Id
is
11006 Get_Name_String
(Chars
(E
));
11007 Add_Char_To_Name_Buffer
(Suffix
);
11011 -------------------
11012 -- Remove_Suffix --
11013 -------------------
11015 function Remove_Suffix
(E
: Entity_Id
; Suffix
: Character) return Name_Id
is
11017 pragma Assert
(Has_Suffix
(E
, Suffix
));
11018 Get_Name_String
(Chars
(E
));
11019 Name_Len
:= Name_Len
- 1;
11023 ----------------------------------
11024 -- Replace_Null_By_Null_Address --
11025 ----------------------------------
11027 procedure Replace_Null_By_Null_Address
(N
: Node_Id
) is
11028 procedure Replace_Null_Operand
(Op
: Node_Id
; Other_Op
: Node_Id
);
11029 -- Replace operand Op with a reference to Null_Address when the operand
11030 -- denotes a null Address. Other_Op denotes the other operand.
11032 --------------------------
11033 -- Replace_Null_Operand --
11034 --------------------------
11036 procedure Replace_Null_Operand
(Op
: Node_Id
; Other_Op
: Node_Id
) is
11038 -- Check the type of the complementary operand since the N_Null node
11039 -- has not been decorated yet.
11041 if Nkind
(Op
) = N_Null
11042 and then Is_Descendant_Of_Address
(Etype
(Other_Op
))
11044 Rewrite
(Op
, New_Occurrence_Of
(RTE
(RE_Null_Address
), Sloc
(Op
)));
11046 end Replace_Null_Operand
;
11048 -- Start of processing for Replace_Null_By_Null_Address
11051 pragma Assert
(Relaxed_RM_Semantics
);
11052 pragma Assert
(Nkind_In
(N
, N_Null
,
11060 if Nkind
(N
) = N_Null
then
11061 Rewrite
(N
, New_Occurrence_Of
(RTE
(RE_Null_Address
), Sloc
(N
)));
11065 L
: constant Node_Id
:= Left_Opnd
(N
);
11066 R
: constant Node_Id
:= Right_Opnd
(N
);
11069 Replace_Null_Operand
(L
, Other_Op
=> R
);
11070 Replace_Null_Operand
(R
, Other_Op
=> L
);
11073 end Replace_Null_By_Null_Address
;
11075 --------------------------
11076 -- Has_Tagged_Component --
11077 --------------------------
11079 function Has_Tagged_Component
(Typ
: Entity_Id
) return Boolean is
11083 if Is_Private_Type
(Typ
) and then Present
(Underlying_Type
(Typ
)) then
11084 return Has_Tagged_Component
(Underlying_Type
(Typ
));
11086 elsif Is_Array_Type
(Typ
) then
11087 return Has_Tagged_Component
(Component_Type
(Typ
));
11089 elsif Is_Tagged_Type
(Typ
) then
11092 elsif Is_Record_Type
(Typ
) then
11093 Comp
:= First_Component
(Typ
);
11094 while Present
(Comp
) loop
11095 if Has_Tagged_Component
(Etype
(Comp
)) then
11099 Next_Component
(Comp
);
11107 end Has_Tagged_Component
;
11109 -----------------------------
11110 -- Has_Undefined_Reference --
11111 -----------------------------
11113 function Has_Undefined_Reference
(Expr
: Node_Id
) return Boolean is
11114 Has_Undef_Ref
: Boolean := False;
11115 -- Flag set when expression Expr contains at least one undefined
11118 function Is_Undefined_Reference
(N
: Node_Id
) return Traverse_Result
;
11119 -- Determine whether N denotes a reference and if it does, whether it is
11122 ----------------------------
11123 -- Is_Undefined_Reference --
11124 ----------------------------
11126 function Is_Undefined_Reference
(N
: Node_Id
) return Traverse_Result
is
11128 if Is_Entity_Name
(N
)
11129 and then Present
(Entity
(N
))
11130 and then Entity
(N
) = Any_Id
11132 Has_Undef_Ref
:= True;
11137 end Is_Undefined_Reference
;
11139 procedure Find_Undefined_References
is
11140 new Traverse_Proc
(Is_Undefined_Reference
);
11142 -- Start of processing for Has_Undefined_Reference
11145 Find_Undefined_References
(Expr
);
11147 return Has_Undef_Ref
;
11148 end Has_Undefined_Reference
;
11150 ----------------------------
11151 -- Has_Volatile_Component --
11152 ----------------------------
11154 function Has_Volatile_Component
(Typ
: Entity_Id
) return Boolean is
11158 if Has_Volatile_Components
(Typ
) then
11161 elsif Is_Array_Type
(Typ
) then
11162 return Is_Volatile
(Component_Type
(Typ
));
11164 elsif Is_Record_Type
(Typ
) then
11165 Comp
:= First_Component
(Typ
);
11166 while Present
(Comp
) loop
11167 if Is_Volatile_Object
(Comp
) then
11171 Comp
:= Next_Component
(Comp
);
11176 end Has_Volatile_Component
;
11178 -------------------------
11179 -- Implementation_Kind --
11180 -------------------------
11182 function Implementation_Kind
(Subp
: Entity_Id
) return Name_Id
is
11183 Impl_Prag
: constant Node_Id
:= Get_Rep_Pragma
(Subp
, Name_Implemented
);
11186 pragma Assert
(Present
(Impl_Prag
));
11187 Arg
:= Last
(Pragma_Argument_Associations
(Impl_Prag
));
11188 return Chars
(Get_Pragma_Arg
(Arg
));
11189 end Implementation_Kind
;
11191 --------------------------
11192 -- Implements_Interface --
11193 --------------------------
11195 function Implements_Interface
11196 (Typ_Ent
: Entity_Id
;
11197 Iface_Ent
: Entity_Id
;
11198 Exclude_Parents
: Boolean := False) return Boolean
11200 Ifaces_List
: Elist_Id
;
11202 Iface
: Entity_Id
:= Base_Type
(Iface_Ent
);
11203 Typ
: Entity_Id
:= Base_Type
(Typ_Ent
);
11206 if Is_Class_Wide_Type
(Typ
) then
11207 Typ
:= Root_Type
(Typ
);
11210 if not Has_Interfaces
(Typ
) then
11214 if Is_Class_Wide_Type
(Iface
) then
11215 Iface
:= Root_Type
(Iface
);
11218 Collect_Interfaces
(Typ
, Ifaces_List
);
11220 Elmt
:= First_Elmt
(Ifaces_List
);
11221 while Present
(Elmt
) loop
11222 if Is_Ancestor
(Node
(Elmt
), Typ
, Use_Full_View
=> True)
11223 and then Exclude_Parents
11227 elsif Node
(Elmt
) = Iface
then
11235 end Implements_Interface
;
11237 ------------------------------------
11238 -- In_Assertion_Expression_Pragma --
11239 ------------------------------------
11241 function In_Assertion_Expression_Pragma
(N
: Node_Id
) return Boolean is
11243 Prag
: Node_Id
:= Empty
;
11246 -- Climb the parent chain looking for an enclosing pragma
11249 while Present
(Par
) loop
11250 if Nkind
(Par
) = N_Pragma
then
11254 -- Precondition-like pragmas are expanded into if statements, check
11255 -- the original node instead.
11257 elsif Nkind
(Original_Node
(Par
)) = N_Pragma
then
11258 Prag
:= Original_Node
(Par
);
11261 -- The expansion of attribute 'Old generates a constant to capture
11262 -- the result of the prefix. If the parent traversal reaches
11263 -- one of these constants, then the node technically came from a
11264 -- postcondition-like pragma. Note that the Ekind is not tested here
11265 -- because N may be the expression of an object declaration which is
11266 -- currently being analyzed. Such objects carry Ekind of E_Void.
11268 elsif Nkind
(Par
) = N_Object_Declaration
11269 and then Constant_Present
(Par
)
11270 and then Stores_Attribute_Old_Prefix
(Defining_Entity
(Par
))
11274 -- Prevent the search from going too far
11276 elsif Is_Body_Or_Package_Declaration
(Par
) then
11280 Par
:= Parent
(Par
);
11285 and then Assertion_Expression_Pragma
(Get_Pragma_Id
(Prag
));
11286 end In_Assertion_Expression_Pragma
;
11288 ----------------------
11289 -- In_Generic_Scope --
11290 ----------------------
11292 function In_Generic_Scope
(E
: Entity_Id
) return Boolean is
11297 while Present
(S
) and then S
/= Standard_Standard
loop
11298 if Is_Generic_Unit
(S
) then
11306 end In_Generic_Scope
;
11312 function In_Instance
return Boolean is
11313 Curr_Unit
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
11317 S
:= Current_Scope
;
11318 while Present
(S
) and then S
/= Standard_Standard
loop
11319 if Is_Generic_Instance
(S
) then
11321 -- A child instance is always compiled in the context of a parent
11322 -- instance. Nevertheless, the actuals are not analyzed in an
11323 -- instance context. We detect this case by examining the current
11324 -- compilation unit, which must be a child instance, and checking
11325 -- that it is not currently on the scope stack.
11327 if Is_Child_Unit
(Curr_Unit
)
11328 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
11329 N_Package_Instantiation
11330 and then not In_Open_Scopes
(Curr_Unit
)
11344 ----------------------
11345 -- In_Instance_Body --
11346 ----------------------
11348 function In_Instance_Body
return Boolean is
11352 S
:= Current_Scope
;
11353 while Present
(S
) and then S
/= Standard_Standard
loop
11354 if Ekind_In
(S
, E_Function
, E_Procedure
)
11355 and then Is_Generic_Instance
(S
)
11359 elsif Ekind
(S
) = E_Package
11360 and then In_Package_Body
(S
)
11361 and then Is_Generic_Instance
(S
)
11370 end In_Instance_Body
;
11372 -----------------------------
11373 -- In_Instance_Not_Visible --
11374 -----------------------------
11376 function In_Instance_Not_Visible
return Boolean is
11380 S
:= Current_Scope
;
11381 while Present
(S
) and then S
/= Standard_Standard
loop
11382 if Ekind_In
(S
, E_Function
, E_Procedure
)
11383 and then Is_Generic_Instance
(S
)
11387 elsif Ekind
(S
) = E_Package
11388 and then (In_Package_Body
(S
) or else In_Private_Part
(S
))
11389 and then Is_Generic_Instance
(S
)
11398 end In_Instance_Not_Visible
;
11400 ------------------------------
11401 -- In_Instance_Visible_Part --
11402 ------------------------------
11404 function In_Instance_Visible_Part
return Boolean is
11408 S
:= Current_Scope
;
11409 while Present
(S
) and then S
/= Standard_Standard
loop
11410 if Ekind
(S
) = E_Package
11411 and then Is_Generic_Instance
(S
)
11412 and then not In_Package_Body
(S
)
11413 and then not In_Private_Part
(S
)
11422 end In_Instance_Visible_Part
;
11424 ---------------------
11425 -- In_Package_Body --
11426 ---------------------
11428 function In_Package_Body
return Boolean is
11432 S
:= Current_Scope
;
11433 while Present
(S
) and then S
/= Standard_Standard
loop
11434 if Ekind
(S
) = E_Package
and then In_Package_Body
(S
) then
11442 end In_Package_Body
;
11444 --------------------------
11445 -- In_Pragma_Expression --
11446 --------------------------
11448 function In_Pragma_Expression
(N
: Node_Id
; Nam
: Name_Id
) return Boolean is
11455 elsif Nkind
(P
) = N_Pragma
and then Pragma_Name
(P
) = Nam
then
11461 end In_Pragma_Expression
;
11463 ---------------------------
11464 -- In_Pre_Post_Condition --
11465 ---------------------------
11467 function In_Pre_Post_Condition
(N
: Node_Id
) return Boolean is
11469 Prag
: Node_Id
:= Empty
;
11470 Prag_Id
: Pragma_Id
;
11473 -- Climb the parent chain looking for an enclosing pragma
11476 while Present
(Par
) loop
11477 if Nkind
(Par
) = N_Pragma
then
11481 -- Prevent the search from going too far
11483 elsif Is_Body_Or_Package_Declaration
(Par
) then
11487 Par
:= Parent
(Par
);
11490 if Present
(Prag
) then
11491 Prag_Id
:= Get_Pragma_Id
(Prag
);
11494 Prag_Id
= Pragma_Post
11495 or else Prag_Id
= Pragma_Post_Class
11496 or else Prag_Id
= Pragma_Postcondition
11497 or else Prag_Id
= Pragma_Pre
11498 or else Prag_Id
= Pragma_Pre_Class
11499 or else Prag_Id
= Pragma_Precondition
;
11501 -- Otherwise the node is not enclosed by a pre/postcondition pragma
11506 end In_Pre_Post_Condition
;
11508 -------------------------------------
11509 -- In_Reverse_Storage_Order_Object --
11510 -------------------------------------
11512 function In_Reverse_Storage_Order_Object
(N
: Node_Id
) return Boolean is
11514 Btyp
: Entity_Id
:= Empty
;
11517 -- Climb up indexed components
11521 case Nkind
(Pref
) is
11522 when N_Selected_Component
=>
11523 Pref
:= Prefix
(Pref
);
11526 when N_Indexed_Component
=>
11527 Pref
:= Prefix
(Pref
);
11535 if Present
(Pref
) then
11536 Btyp
:= Base_Type
(Etype
(Pref
));
11539 return Present
(Btyp
)
11540 and then (Is_Record_Type
(Btyp
) or else Is_Array_Type
(Btyp
))
11541 and then Reverse_Storage_Order
(Btyp
);
11542 end In_Reverse_Storage_Order_Object
;
11544 --------------------------------------
11545 -- In_Subprogram_Or_Concurrent_Unit --
11546 --------------------------------------
11548 function In_Subprogram_Or_Concurrent_Unit
return Boolean is
11553 -- Use scope chain to check successively outer scopes
11555 E
:= Current_Scope
;
11559 if K
in Subprogram_Kind
11560 or else K
in Concurrent_Kind
11561 or else K
in Generic_Subprogram_Kind
11565 elsif E
= Standard_Standard
then
11571 end In_Subprogram_Or_Concurrent_Unit
;
11573 ---------------------
11574 -- In_Visible_Part --
11575 ---------------------
11577 function In_Visible_Part
(Scope_Id
: Entity_Id
) return Boolean is
11579 return Is_Package_Or_Generic_Package
(Scope_Id
)
11580 and then In_Open_Scopes
(Scope_Id
)
11581 and then not In_Package_Body
(Scope_Id
)
11582 and then not In_Private_Part
(Scope_Id
);
11583 end In_Visible_Part
;
11585 --------------------------------
11586 -- Incomplete_Or_Partial_View --
11587 --------------------------------
11589 function Incomplete_Or_Partial_View
(Id
: Entity_Id
) return Entity_Id
is
11590 function Inspect_Decls
11592 Taft
: Boolean := False) return Entity_Id
;
11593 -- Check whether a declarative region contains the incomplete or partial
11596 -------------------
11597 -- Inspect_Decls --
11598 -------------------
11600 function Inspect_Decls
11602 Taft
: Boolean := False) return Entity_Id
11608 Decl
:= First
(Decls
);
11609 while Present
(Decl
) loop
11612 -- The partial view of a Taft-amendment type is an incomplete
11616 if Nkind
(Decl
) = N_Incomplete_Type_Declaration
then
11617 Match
:= Defining_Identifier
(Decl
);
11620 -- Otherwise look for a private type whose full view matches the
11621 -- input type. Note that this checks full_type_declaration nodes
11622 -- to account for derivations from a private type where the type
11623 -- declaration hold the partial view and the full view is an
11626 elsif Nkind_In
(Decl
, N_Full_Type_Declaration
,
11627 N_Private_Extension_Declaration
,
11628 N_Private_Type_Declaration
)
11630 Match
:= Defining_Identifier
(Decl
);
11633 -- Guard against unanalyzed entities
11636 and then Is_Type
(Match
)
11637 and then Present
(Full_View
(Match
))
11638 and then Full_View
(Match
) = Id
11653 -- Start of processing for Incomplete_Or_Partial_View
11656 -- Deferred constant or incomplete type case
11658 Prev
:= Current_Entity_In_Scope
(Id
);
11661 and then (Is_Incomplete_Type
(Prev
) or else Ekind
(Prev
) = E_Constant
)
11662 and then Present
(Full_View
(Prev
))
11663 and then Full_View
(Prev
) = Id
11668 -- Private or Taft amendment type case
11671 Pkg
: constant Entity_Id
:= Scope
(Id
);
11672 Pkg_Decl
: Node_Id
:= Pkg
;
11676 and then Ekind_In
(Pkg
, E_Generic_Package
, E_Package
)
11678 while Nkind
(Pkg_Decl
) /= N_Package_Specification
loop
11679 Pkg_Decl
:= Parent
(Pkg_Decl
);
11682 -- It is knows that Typ has a private view, look for it in the
11683 -- visible declarations of the enclosing scope. A special case
11684 -- of this is when the two views have been exchanged - the full
11685 -- appears earlier than the private.
11687 if Has_Private_Declaration
(Id
) then
11688 Prev
:= Inspect_Decls
(Visible_Declarations
(Pkg_Decl
));
11690 -- Exchanged view case, look in the private declarations
11693 Prev
:= Inspect_Decls
(Private_Declarations
(Pkg_Decl
));
11698 -- Otherwise if this is the package body, then Typ is a potential
11699 -- Taft amendment type. The incomplete view should be located in
11700 -- the private declarations of the enclosing scope.
11702 elsif In_Package_Body
(Pkg
) then
11703 return Inspect_Decls
(Private_Declarations
(Pkg_Decl
), True);
11708 -- The type has no incomplete or private view
11711 end Incomplete_Or_Partial_View
;
11713 ----------------------------------
11714 -- Indexed_Component_Bit_Offset --
11715 ----------------------------------
11717 function Indexed_Component_Bit_Offset
(N
: Node_Id
) return Uint
is
11718 Exp
: constant Node_Id
:= First
(Expressions
(N
));
11719 Typ
: constant Entity_Id
:= Etype
(Prefix
(N
));
11720 Off
: constant Uint
:= Component_Size
(Typ
);
11724 -- Return early if the component size is not known or variable
11726 if Off
= No_Uint
or else Off
< Uint_0
then
11730 -- Deal with the degenerate case of an empty component
11732 if Off
= Uint_0
then
11736 -- Check that both the index value and the low bound are known
11738 if not Compile_Time_Known_Value
(Exp
) then
11742 Ind
:= First_Index
(Typ
);
11747 if Nkind
(Ind
) = N_Subtype_Indication
then
11748 Ind
:= Constraint
(Ind
);
11750 if Nkind
(Ind
) = N_Range_Constraint
then
11751 Ind
:= Range_Expression
(Ind
);
11755 if Nkind
(Ind
) /= N_Range
11756 or else not Compile_Time_Known_Value
(Low_Bound
(Ind
))
11761 -- Return the scaled offset
11763 return Off
* (Expr_Value
(Exp
) - Expr_Value
(Low_Bound
((Ind
))));
11764 end Indexed_Component_Bit_Offset
;
11766 ----------------------------
11767 -- Inherit_Rep_Item_Chain --
11768 ----------------------------
11770 procedure Inherit_Rep_Item_Chain
(Typ
: Entity_Id
; From_Typ
: Entity_Id
) is
11772 Next_Item
: Node_Id
;
11775 -- There are several inheritance scenarios to consider depending on
11776 -- whether both types have rep item chains and whether the destination
11777 -- type already inherits part of the source type's rep item chain.
11779 -- 1) The source type lacks a rep item chain
11780 -- From_Typ ---> Empty
11782 -- Typ --------> Item (or Empty)
11784 -- In this case inheritance cannot take place because there are no items
11787 -- 2) The destination type lacks a rep item chain
11788 -- From_Typ ---> Item ---> ...
11790 -- Typ --------> Empty
11792 -- Inheritance takes place by setting the First_Rep_Item of the
11793 -- destination type to the First_Rep_Item of the source type.
11794 -- From_Typ ---> Item ---> ...
11796 -- Typ -----------+
11798 -- 3.1) Both source and destination types have at least one rep item.
11799 -- The destination type does NOT inherit a rep item from the source
11801 -- From_Typ ---> Item ---> Item
11803 -- Typ --------> Item ---> Item
11805 -- Inheritance takes place by setting the Next_Rep_Item of the last item
11806 -- of the destination type to the First_Rep_Item of the source type.
11807 -- From_Typ -------------------> Item ---> Item
11809 -- Typ --------> Item ---> Item --+
11811 -- 3.2) Both source and destination types have at least one rep item.
11812 -- The destination type DOES inherit part of the rep item chain of the
11814 -- From_Typ ---> Item ---> Item ---> Item
11816 -- Typ --------> Item ------+
11818 -- This rare case arises when the full view of a private extension must
11819 -- inherit the rep item chain from the full view of its parent type and
11820 -- the full view of the parent type contains extra rep items. Currently
11821 -- only invariants may lead to such form of inheritance.
11823 -- type From_Typ is tagged private
11824 -- with Type_Invariant'Class => Item_2;
11826 -- type Typ is new From_Typ with private
11827 -- with Type_Invariant => Item_4;
11829 -- At this point the rep item chains contain the following items
11831 -- From_Typ -----------> Item_2 ---> Item_3
11833 -- Typ --------> Item_4 --+
11835 -- The full views of both types may introduce extra invariants
11837 -- type From_Typ is tagged null record
11838 -- with Type_Invariant => Item_1;
11840 -- type Typ is new From_Typ with null record;
11842 -- The full view of Typ would have to inherit any new rep items added to
11843 -- the full view of From_Typ.
11845 -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
11847 -- Typ --------> Item_4 --+
11849 -- To achieve this form of inheritance, the destination type must first
11850 -- sever the link between its own rep chain and that of the source type,
11851 -- then inheritance 3.1 takes place.
11853 -- Case 1: The source type lacks a rep item chain
11855 if No
(First_Rep_Item
(From_Typ
)) then
11858 -- Case 2: The destination type lacks a rep item chain
11860 elsif No
(First_Rep_Item
(Typ
)) then
11861 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
11863 -- Case 3: Both the source and destination types have at least one rep
11864 -- item. Traverse the rep item chain of the destination type to find the
11869 Next_Item
:= First_Rep_Item
(Typ
);
11870 while Present
(Next_Item
) loop
11872 -- Detect a link between the destination type's rep chain and that
11873 -- of the source type. There are two possibilities:
11878 -- From_Typ ---> Item_1 --->
11880 -- Typ -----------+
11887 -- From_Typ ---> Item_1 ---> Item_2 --->
11889 -- Typ --------> Item_3 ------+
11893 if Has_Rep_Item
(From_Typ
, Next_Item
) then
11898 Next_Item
:= Next_Rep_Item
(Next_Item
);
11901 -- Inherit the source type's rep item chain
11903 if Present
(Item
) then
11904 Set_Next_Rep_Item
(Item
, First_Rep_Item
(From_Typ
));
11906 Set_First_Rep_Item
(Typ
, First_Rep_Item
(From_Typ
));
11909 end Inherit_Rep_Item_Chain
;
11911 ---------------------------------
11912 -- Insert_Explicit_Dereference --
11913 ---------------------------------
11915 procedure Insert_Explicit_Dereference
(N
: Node_Id
) is
11916 New_Prefix
: constant Node_Id
:= Relocate_Node
(N
);
11917 Ent
: Entity_Id
:= Empty
;
11924 Save_Interps
(N
, New_Prefix
);
11927 Make_Explicit_Dereference
(Sloc
(Parent
(N
)),
11928 Prefix
=> New_Prefix
));
11930 Set_Etype
(N
, Designated_Type
(Etype
(New_Prefix
)));
11932 if Is_Overloaded
(New_Prefix
) then
11934 -- The dereference is also overloaded, and its interpretations are
11935 -- the designated types of the interpretations of the original node.
11937 Set_Etype
(N
, Any_Type
);
11939 Get_First_Interp
(New_Prefix
, I
, It
);
11940 while Present
(It
.Nam
) loop
11943 if Is_Access_Type
(T
) then
11944 Add_One_Interp
(N
, Designated_Type
(T
), Designated_Type
(T
));
11947 Get_Next_Interp
(I
, It
);
11953 -- Prefix is unambiguous: mark the original prefix (which might
11954 -- Come_From_Source) as a reference, since the new (relocated) one
11955 -- won't be taken into account.
11957 if Is_Entity_Name
(New_Prefix
) then
11958 Ent
:= Entity
(New_Prefix
);
11959 Pref
:= New_Prefix
;
11961 -- For a retrieval of a subcomponent of some composite object,
11962 -- retrieve the ultimate entity if there is one.
11964 elsif Nkind_In
(New_Prefix
, N_Selected_Component
,
11965 N_Indexed_Component
)
11967 Pref
:= Prefix
(New_Prefix
);
11968 while Present
(Pref
)
11969 and then Nkind_In
(Pref
, N_Selected_Component
,
11970 N_Indexed_Component
)
11972 Pref
:= Prefix
(Pref
);
11975 if Present
(Pref
) and then Is_Entity_Name
(Pref
) then
11976 Ent
:= Entity
(Pref
);
11980 -- Place the reference on the entity node
11982 if Present
(Ent
) then
11983 Generate_Reference
(Ent
, Pref
);
11986 end Insert_Explicit_Dereference
;
11988 ------------------------------------------
11989 -- Inspect_Deferred_Constant_Completion --
11990 ------------------------------------------
11992 procedure Inspect_Deferred_Constant_Completion
(Decls
: List_Id
) is
11996 Decl
:= First
(Decls
);
11997 while Present
(Decl
) loop
11999 -- Deferred constant signature
12001 if Nkind
(Decl
) = N_Object_Declaration
12002 and then Constant_Present
(Decl
)
12003 and then No
(Expression
(Decl
))
12005 -- No need to check internally generated constants
12007 and then Comes_From_Source
(Decl
)
12009 -- The constant is not completed. A full object declaration or a
12010 -- pragma Import complete a deferred constant.
12012 and then not Has_Completion
(Defining_Identifier
(Decl
))
12015 ("constant declaration requires initialization expression",
12016 Defining_Identifier
(Decl
));
12019 Decl
:= Next
(Decl
);
12021 end Inspect_Deferred_Constant_Completion
;
12023 -----------------------------
12024 -- Install_Generic_Formals --
12025 -----------------------------
12027 procedure Install_Generic_Formals
(Subp_Id
: Entity_Id
) is
12031 pragma Assert
(Is_Generic_Subprogram
(Subp_Id
));
12033 E
:= First_Entity
(Subp_Id
);
12034 while Present
(E
) loop
12035 Install_Entity
(E
);
12038 end Install_Generic_Formals
;
12040 ------------------------
12041 -- Install_SPARK_Mode --
12042 ------------------------
12044 procedure Install_SPARK_Mode
(Mode
: SPARK_Mode_Type
; Prag
: Node_Id
) is
12046 SPARK_Mode
:= Mode
;
12047 SPARK_Mode_Pragma
:= Prag
;
12048 end Install_SPARK_Mode
;
12050 -----------------------------
12051 -- Is_Actual_Out_Parameter --
12052 -----------------------------
12054 function Is_Actual_Out_Parameter
(N
: Node_Id
) return Boolean is
12055 Formal
: Entity_Id
;
12058 Find_Actual
(N
, Formal
, Call
);
12059 return Present
(Formal
) and then Ekind
(Formal
) = E_Out_Parameter
;
12060 end Is_Actual_Out_Parameter
;
12062 -------------------------
12063 -- Is_Actual_Parameter --
12064 -------------------------
12066 function Is_Actual_Parameter
(N
: Node_Id
) return Boolean is
12067 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
12071 when N_Parameter_Association
=>
12072 return N
= Explicit_Actual_Parameter
(Parent
(N
));
12074 when N_Subprogram_Call
=>
12075 return Is_List_Member
(N
)
12077 List_Containing
(N
) = Parameter_Associations
(Parent
(N
));
12082 end Is_Actual_Parameter
;
12084 --------------------------------
12085 -- Is_Actual_Tagged_Parameter --
12086 --------------------------------
12088 function Is_Actual_Tagged_Parameter
(N
: Node_Id
) return Boolean is
12089 Formal
: Entity_Id
;
12092 Find_Actual
(N
, Formal
, Call
);
12093 return Present
(Formal
) and then Is_Tagged_Type
(Etype
(Formal
));
12094 end Is_Actual_Tagged_Parameter
;
12096 ---------------------
12097 -- Is_Aliased_View --
12098 ---------------------
12100 function Is_Aliased_View
(Obj
: Node_Id
) return Boolean is
12104 if Is_Entity_Name
(Obj
) then
12111 or else (Present
(Renamed_Object
(E
))
12112 and then Is_Aliased_View
(Renamed_Object
(E
)))))
12114 or else ((Is_Formal
(E
)
12115 or else Ekind_In
(E
, E_Generic_In_Out_Parameter
,
12116 E_Generic_In_Parameter
))
12117 and then Is_Tagged_Type
(Etype
(E
)))
12119 or else (Is_Concurrent_Type
(E
) and then In_Open_Scopes
(E
))
12121 -- Current instance of type, either directly or as rewritten
12122 -- reference to the current object.
12124 or else (Is_Entity_Name
(Original_Node
(Obj
))
12125 and then Present
(Entity
(Original_Node
(Obj
)))
12126 and then Is_Type
(Entity
(Original_Node
(Obj
))))
12128 or else (Is_Type
(E
) and then E
= Current_Scope
)
12130 or else (Is_Incomplete_Or_Private_Type
(E
)
12131 and then Full_View
(E
) = Current_Scope
)
12133 -- Ada 2012 AI05-0053: the return object of an extended return
12134 -- statement is aliased if its type is immutably limited.
12136 or else (Is_Return_Object
(E
)
12137 and then Is_Limited_View
(Etype
(E
)));
12139 elsif Nkind
(Obj
) = N_Selected_Component
then
12140 return Is_Aliased
(Entity
(Selector_Name
(Obj
)));
12142 elsif Nkind
(Obj
) = N_Indexed_Component
then
12143 return Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
12145 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
12146 and then Has_Aliased_Components
12147 (Designated_Type
(Etype
(Prefix
(Obj
)))));
12149 elsif Nkind_In
(Obj
, N_Unchecked_Type_Conversion
, N_Type_Conversion
) then
12150 return Is_Tagged_Type
(Etype
(Obj
))
12151 and then Is_Aliased_View
(Expression
(Obj
));
12153 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
12154 return Nkind
(Original_Node
(Obj
)) /= N_Function_Call
;
12159 end Is_Aliased_View
;
12161 -------------------------
12162 -- Is_Ancestor_Package --
12163 -------------------------
12165 function Is_Ancestor_Package
12167 E2
: Entity_Id
) return Boolean
12173 while Present
(Par
) and then Par
/= Standard_Standard
loop
12178 Par
:= Scope
(Par
);
12182 end Is_Ancestor_Package
;
12184 ----------------------
12185 -- Is_Atomic_Object --
12186 ----------------------
12188 function Is_Atomic_Object
(N
: Node_Id
) return Boolean is
12190 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean;
12191 -- Determines if given object has atomic components
12193 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean;
12194 -- If prefix is an implicit dereference, examine designated type
12196 ----------------------
12197 -- Is_Atomic_Prefix --
12198 ----------------------
12200 function Is_Atomic_Prefix
(N
: Node_Id
) return Boolean is
12202 if Is_Access_Type
(Etype
(N
)) then
12204 Has_Atomic_Components
(Designated_Type
(Etype
(N
)));
12206 return Object_Has_Atomic_Components
(N
);
12208 end Is_Atomic_Prefix
;
12210 ----------------------------------
12211 -- Object_Has_Atomic_Components --
12212 ----------------------------------
12214 function Object_Has_Atomic_Components
(N
: Node_Id
) return Boolean is
12216 if Has_Atomic_Components
(Etype
(N
))
12217 or else Is_Atomic
(Etype
(N
))
12221 elsif Is_Entity_Name
(N
)
12222 and then (Has_Atomic_Components
(Entity
(N
))
12223 or else Is_Atomic
(Entity
(N
)))
12227 elsif Nkind
(N
) = N_Selected_Component
12228 and then Is_Atomic
(Entity
(Selector_Name
(N
)))
12232 elsif Nkind
(N
) = N_Indexed_Component
12233 or else Nkind
(N
) = N_Selected_Component
12235 return Is_Atomic_Prefix
(Prefix
(N
));
12240 end Object_Has_Atomic_Components
;
12242 -- Start of processing for Is_Atomic_Object
12245 -- Predicate is not relevant to subprograms
12247 if Is_Entity_Name
(N
) and then Is_Overloadable
(Entity
(N
)) then
12250 elsif Is_Atomic
(Etype
(N
))
12251 or else (Is_Entity_Name
(N
) and then Is_Atomic
(Entity
(N
)))
12255 elsif Nkind
(N
) = N_Selected_Component
12256 and then Is_Atomic
(Entity
(Selector_Name
(N
)))
12260 elsif Nkind
(N
) = N_Indexed_Component
12261 or else Nkind
(N
) = N_Selected_Component
12263 return Is_Atomic_Prefix
(Prefix
(N
));
12268 end Is_Atomic_Object
;
12270 -----------------------------
12271 -- Is_Atomic_Or_VFA_Object --
12272 -----------------------------
12274 function Is_Atomic_Or_VFA_Object
(N
: Node_Id
) return Boolean is
12276 return Is_Atomic_Object
(N
)
12277 or else (Is_Object_Reference
(N
)
12278 and then Is_Entity_Name
(N
)
12279 and then (Is_Volatile_Full_Access
(Entity
(N
))
12281 Is_Volatile_Full_Access
(Etype
(Entity
(N
)))));
12282 end Is_Atomic_Or_VFA_Object
;
12284 -------------------------
12285 -- Is_Attribute_Result --
12286 -------------------------
12288 function Is_Attribute_Result
(N
: Node_Id
) return Boolean is
12290 return Nkind
(N
) = N_Attribute_Reference
12291 and then Attribute_Name
(N
) = Name_Result
;
12292 end Is_Attribute_Result
;
12294 -------------------------
12295 -- Is_Attribute_Update --
12296 -------------------------
12298 function Is_Attribute_Update
(N
: Node_Id
) return Boolean is
12300 return Nkind
(N
) = N_Attribute_Reference
12301 and then Attribute_Name
(N
) = Name_Update
;
12302 end Is_Attribute_Update
;
12304 ------------------------------------
12305 -- Is_Body_Or_Package_Declaration --
12306 ------------------------------------
12308 function Is_Body_Or_Package_Declaration
(N
: Node_Id
) return Boolean is
12310 return Nkind_In
(N
, N_Entry_Body
,
12312 N_Package_Declaration
,
12316 end Is_Body_Or_Package_Declaration
;
12318 -----------------------
12319 -- Is_Bounded_String --
12320 -----------------------
12322 function Is_Bounded_String
(T
: Entity_Id
) return Boolean is
12323 Under
: constant Entity_Id
:= Underlying_Type
(Root_Type
(T
));
12326 -- Check whether T is ultimately derived from Ada.Strings.Superbounded.
12327 -- Super_String, or one of the [Wide_]Wide_ versions. This will
12328 -- be True for all the Bounded_String types in instances of the
12329 -- Generic_Bounded_Length generics, and for types derived from those.
12331 return Present
(Under
)
12332 and then (Is_RTE
(Root_Type
(Under
), RO_SU_Super_String
) or else
12333 Is_RTE
(Root_Type
(Under
), RO_WI_Super_String
) or else
12334 Is_RTE
(Root_Type
(Under
), RO_WW_Super_String
));
12335 end Is_Bounded_String
;
12337 -------------------------
12338 -- Is_Child_Or_Sibling --
12339 -------------------------
12341 function Is_Child_Or_Sibling
12342 (Pack_1
: Entity_Id
;
12343 Pack_2
: Entity_Id
) return Boolean
12345 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
;
12346 -- Given an arbitrary package, return the number of "climbs" necessary
12347 -- to reach scope Standard_Standard.
12349 procedure Equalize_Depths
12350 (Pack
: in out Entity_Id
;
12351 Depth
: in out Nat
;
12352 Depth_To_Reach
: Nat
);
12353 -- Given an arbitrary package, its depth and a target depth to reach,
12354 -- climb the scope chain until the said depth is reached. The pointer
12355 -- to the package and its depth a modified during the climb.
12357 ----------------------------
12358 -- Distance_From_Standard --
12359 ----------------------------
12361 function Distance_From_Standard
(Pack
: Entity_Id
) return Nat
is
12368 while Present
(Scop
) and then Scop
/= Standard_Standard
loop
12370 Scop
:= Scope
(Scop
);
12374 end Distance_From_Standard
;
12376 ---------------------
12377 -- Equalize_Depths --
12378 ---------------------
12380 procedure Equalize_Depths
12381 (Pack
: in out Entity_Id
;
12382 Depth
: in out Nat
;
12383 Depth_To_Reach
: Nat
)
12386 -- The package must be at a greater or equal depth
12388 if Depth
< Depth_To_Reach
then
12389 raise Program_Error
;
12392 -- Climb the scope chain until the desired depth is reached
12394 while Present
(Pack
) and then Depth
/= Depth_To_Reach
loop
12395 Pack
:= Scope
(Pack
);
12396 Depth
:= Depth
- 1;
12398 end Equalize_Depths
;
12402 P_1
: Entity_Id
:= Pack_1
;
12403 P_1_Child
: Boolean := False;
12404 P_1_Depth
: Nat
:= Distance_From_Standard
(P_1
);
12405 P_2
: Entity_Id
:= Pack_2
;
12406 P_2_Child
: Boolean := False;
12407 P_2_Depth
: Nat
:= Distance_From_Standard
(P_2
);
12409 -- Start of processing for Is_Child_Or_Sibling
12413 (Ekind
(Pack_1
) = E_Package
and then Ekind
(Pack_2
) = E_Package
);
12415 -- Both packages denote the same entity, therefore they cannot be
12416 -- children or siblings.
12421 -- One of the packages is at a deeper level than the other. Note that
12422 -- both may still come from different hierarchies.
12430 elsif P_1_Depth
> P_2_Depth
then
12433 Depth
=> P_1_Depth
,
12434 Depth_To_Reach
=> P_2_Depth
);
12443 elsif P_2_Depth
> P_1_Depth
then
12446 Depth
=> P_2_Depth
,
12447 Depth_To_Reach
=> P_1_Depth
);
12451 -- At this stage the package pointers have been elevated to the same
12452 -- depth. If the related entities are the same, then one package is a
12453 -- potential child of the other:
12457 -- X became P_1 P_2 or vice versa
12463 return Is_Child_Unit
(Pack_1
);
12465 else pragma Assert
(P_2_Child
);
12466 return Is_Child_Unit
(Pack_2
);
12469 -- The packages may come from the same package chain or from entirely
12470 -- different hierarcies. To determine this, climb the scope stack until
12471 -- a common root is found.
12473 -- (root) (root 1) (root 2)
12478 while Present
(P_1
) and then Present
(P_2
) loop
12480 -- The two packages may be siblings
12483 return Is_Child_Unit
(Pack_1
) and then Is_Child_Unit
(Pack_2
);
12486 P_1
:= Scope
(P_1
);
12487 P_2
:= Scope
(P_2
);
12492 end Is_Child_Or_Sibling
;
12494 -----------------------------
12495 -- Is_Concurrent_Interface --
12496 -----------------------------
12498 function Is_Concurrent_Interface
(T
: Entity_Id
) return Boolean is
12500 return Is_Interface
(T
)
12502 (Is_Protected_Interface
(T
)
12503 or else Is_Synchronized_Interface
(T
)
12504 or else Is_Task_Interface
(T
));
12505 end Is_Concurrent_Interface
;
12507 -----------------------
12508 -- Is_Constant_Bound --
12509 -----------------------
12511 function Is_Constant_Bound
(Exp
: Node_Id
) return Boolean is
12513 if Compile_Time_Known_Value
(Exp
) then
12516 elsif Is_Entity_Name
(Exp
) and then Present
(Entity
(Exp
)) then
12517 return Is_Constant_Object
(Entity
(Exp
))
12518 or else Ekind
(Entity
(Exp
)) = E_Enumeration_Literal
;
12520 elsif Nkind
(Exp
) in N_Binary_Op
then
12521 return Is_Constant_Bound
(Left_Opnd
(Exp
))
12522 and then Is_Constant_Bound
(Right_Opnd
(Exp
))
12523 and then Scope
(Entity
(Exp
)) = Standard_Standard
;
12528 end Is_Constant_Bound
;
12530 ---------------------------
12531 -- Is_Container_Element --
12532 ---------------------------
12534 function Is_Container_Element
(Exp
: Node_Id
) return Boolean is
12535 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
12536 Pref
: constant Node_Id
:= Prefix
(Exp
);
12539 -- Call to an indexing aspect
12541 Cont_Typ
: Entity_Id
;
12542 -- The type of the container being accessed
12544 Elem_Typ
: Entity_Id
;
12545 -- Its element type
12547 Indexing
: Entity_Id
;
12548 Is_Const
: Boolean;
12549 -- Indicates that constant indexing is used, and the element is thus
12552 Ref_Typ
: Entity_Id
;
12553 -- The reference type returned by the indexing operation
12556 -- If C is a container, in a context that imposes the element type of
12557 -- that container, the indexing notation C (X) is rewritten as:
12559 -- Indexing (C, X).Discr.all
12561 -- where Indexing is one of the indexing aspects of the container.
12562 -- If the context does not require a reference, the construct can be
12567 -- First, verify that the construct has the proper form
12569 if not Expander_Active
then
12572 elsif Nkind
(Pref
) /= N_Selected_Component
then
12575 elsif Nkind
(Prefix
(Pref
)) /= N_Function_Call
then
12579 Call
:= Prefix
(Pref
);
12580 Ref_Typ
:= Etype
(Call
);
12583 if not Has_Implicit_Dereference
(Ref_Typ
)
12584 or else No
(First
(Parameter_Associations
(Call
)))
12585 or else not Is_Entity_Name
(Name
(Call
))
12590 -- Retrieve type of container object, and its iterator aspects
12592 Cont_Typ
:= Etype
(First
(Parameter_Associations
(Call
)));
12593 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Constant_Indexing
);
12596 if No
(Indexing
) then
12598 -- Container should have at least one indexing operation
12602 elsif Entity
(Name
(Call
)) /= Entity
(Indexing
) then
12604 -- This may be a variable indexing operation
12606 Indexing
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Variable_Indexing
);
12609 or else Entity
(Name
(Call
)) /= Entity
(Indexing
)
12618 Elem_Typ
:= Find_Value_Of_Aspect
(Cont_Typ
, Aspect_Iterator_Element
);
12620 if No
(Elem_Typ
) or else Entity
(Elem_Typ
) /= Etype
(Exp
) then
12624 -- Check that the expression is not the target of an assignment, in
12625 -- which case the rewriting is not possible.
12627 if not Is_Const
then
12633 while Present
(Par
)
12635 if Nkind
(Parent
(Par
)) = N_Assignment_Statement
12636 and then Par
= Name
(Parent
(Par
))
12640 -- A renaming produces a reference, and the transformation
12643 elsif Nkind
(Parent
(Par
)) = N_Object_Renaming_Declaration
then
12647 (Nkind
(Parent
(Par
)), N_Function_Call
,
12648 N_Procedure_Call_Statement
,
12649 N_Entry_Call_Statement
)
12651 -- Check that the element is not part of an actual for an
12652 -- in-out parameter.
12659 F
:= First_Formal
(Entity
(Name
(Parent
(Par
))));
12660 A
:= First
(Parameter_Associations
(Parent
(Par
)));
12661 while Present
(F
) loop
12662 if A
= Par
and then Ekind
(F
) /= E_In_Parameter
then
12671 -- E_In_Parameter in a call: element is not modified.
12676 Par
:= Parent
(Par
);
12681 -- The expression has the proper form and the context requires the
12682 -- element type. Retrieve the Element function of the container and
12683 -- rewrite the construct as a call to it.
12689 Op
:= First_Elmt
(Primitive_Operations
(Cont_Typ
));
12690 while Present
(Op
) loop
12691 exit when Chars
(Node
(Op
)) = Name_Element
;
12700 Make_Function_Call
(Loc
,
12701 Name
=> New_Occurrence_Of
(Node
(Op
), Loc
),
12702 Parameter_Associations
=> Parameter_Associations
(Call
)));
12703 Analyze_And_Resolve
(Exp
, Entity
(Elem_Typ
));
12707 end Is_Container_Element
;
12709 ----------------------------
12710 -- Is_Contract_Annotation --
12711 ----------------------------
12713 function Is_Contract_Annotation
(Item
: Node_Id
) return Boolean is
12715 return Is_Package_Contract_Annotation
(Item
)
12717 Is_Subprogram_Contract_Annotation
(Item
);
12718 end Is_Contract_Annotation
;
12720 --------------------------------------
12721 -- Is_Controlling_Limited_Procedure --
12722 --------------------------------------
12724 function Is_Controlling_Limited_Procedure
12725 (Proc_Nam
: Entity_Id
) return Boolean
12727 Param_Typ
: Entity_Id
:= Empty
;
12730 if Ekind
(Proc_Nam
) = E_Procedure
12731 and then Present
(Parameter_Specifications
(Parent
(Proc_Nam
)))
12733 Param_Typ
:= Etype
(Parameter_Type
(First
(
12734 Parameter_Specifications
(Parent
(Proc_Nam
)))));
12736 -- In this case where an Itype was created, the procedure call has been
12739 elsif Present
(Associated_Node_For_Itype
(Proc_Nam
))
12740 and then Present
(Original_Node
(Associated_Node_For_Itype
(Proc_Nam
)))
12742 Present
(Parameter_Associations
12743 (Associated_Node_For_Itype
(Proc_Nam
)))
12746 Etype
(First
(Parameter_Associations
12747 (Associated_Node_For_Itype
(Proc_Nam
))));
12750 if Present
(Param_Typ
) then
12752 Is_Interface
(Param_Typ
)
12753 and then Is_Limited_Record
(Param_Typ
);
12757 end Is_Controlling_Limited_Procedure
;
12759 -----------------------------
12760 -- Is_CPP_Constructor_Call --
12761 -----------------------------
12763 function Is_CPP_Constructor_Call
(N
: Node_Id
) return Boolean is
12765 return Nkind
(N
) = N_Function_Call
12766 and then Is_CPP_Class
(Etype
(Etype
(N
)))
12767 and then Is_Constructor
(Entity
(Name
(N
)))
12768 and then Is_Imported
(Entity
(Name
(N
)));
12769 end Is_CPP_Constructor_Call
;
12771 -------------------------
12772 -- Is_Current_Instance --
12773 -------------------------
12775 function Is_Current_Instance
(N
: Node_Id
) return Boolean is
12776 Typ
: constant Entity_Id
:= Entity
(N
);
12780 -- Simplest case: entity is a concurrent type and we are currently
12781 -- inside the body. This will eventually be expanded into a
12782 -- call to Self (for tasks) or _object (for protected objects).
12784 if Is_Concurrent_Type
(Typ
) and then In_Open_Scopes
(Typ
) then
12788 -- Check whether the context is a (sub)type declaration for the
12792 while Present
(P
) loop
12793 if Nkind_In
(P
, N_Full_Type_Declaration
,
12794 N_Private_Type_Declaration
,
12795 N_Subtype_Declaration
)
12796 and then Comes_From_Source
(P
)
12797 and then Defining_Entity
(P
) = Typ
12801 -- A subtype name may appear in an aspect specification for a
12802 -- Predicate_Failure aspect, for which we do not construct a
12803 -- wrapper procedure. The subtype will be replaced by the
12804 -- expression being tested when the corresponding predicate
12805 -- check is expanded.
12807 elsif Nkind
(P
) = N_Aspect_Specification
12808 and then Nkind
(Parent
(P
)) = N_Subtype_Declaration
12812 elsif Nkind
(P
) = N_Pragma
12814 Get_Pragma_Id
(P
) = Pragma_Predicate_Failure
12823 -- In any other context this is not a current occurrence
12826 end Is_Current_Instance
;
12828 --------------------
12829 -- Is_Declaration --
12830 --------------------
12832 function Is_Declaration
(N
: Node_Id
) return Boolean is
12835 Is_Declaration_Other_Than_Renaming
(N
)
12836 or else Is_Renaming_Declaration
(N
);
12837 end Is_Declaration
;
12839 ----------------------------------------
12840 -- Is_Declaration_Other_Than_Renaming --
12841 ----------------------------------------
12843 function Is_Declaration_Other_Than_Renaming
(N
: Node_Id
) return Boolean is
12846 when N_Abstract_Subprogram_Declaration
12847 | N_Exception_Declaration
12848 | N_Expression_Function
12849 | N_Full_Type_Declaration
12850 | N_Generic_Package_Declaration
12851 | N_Generic_Subprogram_Declaration
12852 | N_Number_Declaration
12853 | N_Object_Declaration
12854 | N_Package_Declaration
12855 | N_Private_Extension_Declaration
12856 | N_Private_Type_Declaration
12857 | N_Subprogram_Declaration
12858 | N_Subtype_Declaration
12865 end Is_Declaration_Other_Than_Renaming
;
12867 --------------------------------
12868 -- Is_Declared_Within_Variant --
12869 --------------------------------
12871 function Is_Declared_Within_Variant
(Comp
: Entity_Id
) return Boolean is
12872 Comp_Decl
: constant Node_Id
:= Parent
(Comp
);
12873 Comp_List
: constant Node_Id
:= Parent
(Comp_Decl
);
12875 return Nkind
(Parent
(Comp_List
)) = N_Variant
;
12876 end Is_Declared_Within_Variant
;
12878 ----------------------------------------------
12879 -- Is_Dependent_Component_Of_Mutable_Object --
12880 ----------------------------------------------
12882 function Is_Dependent_Component_Of_Mutable_Object
12883 (Object
: Node_Id
) return Boolean
12886 Prefix_Type
: Entity_Id
;
12887 P_Aliased
: Boolean := False;
12890 Deref
: Node_Id
:= Object
;
12891 -- Dereference node, in something like X.all.Y(2)
12893 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
12896 -- Find the dereference node if any
12898 while Nkind_In
(Deref
, N_Indexed_Component
,
12899 N_Selected_Component
,
12902 Deref
:= Prefix
(Deref
);
12905 -- Ada 2005: If we have a component or slice of a dereference,
12906 -- something like X.all.Y (2), and the type of X is access-to-constant,
12907 -- Is_Variable will return False, because it is indeed a constant
12908 -- view. But it might be a view of a variable object, so we want the
12909 -- following condition to be True in that case.
12911 if Is_Variable
(Object
)
12912 or else (Ada_Version
>= Ada_2005
12913 and then Nkind
(Deref
) = N_Explicit_Dereference
)
12915 if Nkind
(Object
) = N_Selected_Component
then
12916 P
:= Prefix
(Object
);
12917 Prefix_Type
:= Etype
(P
);
12919 if Is_Entity_Name
(P
) then
12920 if Ekind
(Entity
(P
)) = E_Generic_In_Out_Parameter
then
12921 Prefix_Type
:= Base_Type
(Prefix_Type
);
12924 if Is_Aliased
(Entity
(P
)) then
12928 -- A discriminant check on a selected component may be expanded
12929 -- into a dereference when removing side-effects. Recover the
12930 -- original node and its type, which may be unconstrained.
12932 elsif Nkind
(P
) = N_Explicit_Dereference
12933 and then not (Comes_From_Source
(P
))
12935 P
:= Original_Node
(P
);
12936 Prefix_Type
:= Etype
(P
);
12939 -- Check for prefix being an aliased component???
12945 -- A heap object is constrained by its initial value
12947 -- Ada 2005 (AI-363): Always assume the object could be mutable in
12948 -- the dereferenced case, since the access value might denote an
12949 -- unconstrained aliased object, whereas in Ada 95 the designated
12950 -- object is guaranteed to be constrained. A worst-case assumption
12951 -- has to apply in Ada 2005 because we can't tell at compile
12952 -- time whether the object is "constrained by its initial value",
12953 -- despite the fact that 3.10.2(26/2) and 8.5.1(5/2) are semantic
12954 -- rules (these rules are acknowledged to need fixing). We don't
12955 -- impose this more stringent checking for earlier Ada versions or
12956 -- when Relaxed_RM_Semantics applies (the latter for CodePeer's
12957 -- benefit, though it's unclear on why using -gnat95 would not be
12960 if Ada_Version
< Ada_2005
or else Relaxed_RM_Semantics
then
12961 if Is_Access_Type
(Prefix_Type
)
12962 or else Nkind
(P
) = N_Explicit_Dereference
12967 else pragma Assert
(Ada_Version
>= Ada_2005
);
12968 if Is_Access_Type
(Prefix_Type
) then
12970 -- If the access type is pool-specific, and there is no
12971 -- constrained partial view of the designated type, then the
12972 -- designated object is known to be constrained.
12974 if Ekind
(Prefix_Type
) = E_Access_Type
12975 and then not Object_Type_Has_Constrained_Partial_View
12976 (Typ
=> Designated_Type
(Prefix_Type
),
12977 Scop
=> Current_Scope
)
12981 -- Otherwise (general access type, or there is a constrained
12982 -- partial view of the designated type), we need to check
12983 -- based on the designated type.
12986 Prefix_Type
:= Designated_Type
(Prefix_Type
);
12992 Original_Record_Component
(Entity
(Selector_Name
(Object
)));
12994 -- As per AI-0017, the renaming is illegal in a generic body, even
12995 -- if the subtype is indefinite.
12997 -- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
12999 if not Is_Constrained
(Prefix_Type
)
13000 and then (Is_Definite_Subtype
(Prefix_Type
)
13002 (Is_Generic_Type
(Prefix_Type
)
13003 and then Ekind
(Current_Scope
) = E_Generic_Package
13004 and then In_Package_Body
(Current_Scope
)))
13006 and then (Is_Declared_Within_Variant
(Comp
)
13007 or else Has_Discriminant_Dependent_Constraint
(Comp
))
13008 and then (not P_Aliased
or else Ada_Version
>= Ada_2005
)
13012 -- If the prefix is of an access type at this point, then we want
13013 -- to return False, rather than calling this function recursively
13014 -- on the access object (which itself might be a discriminant-
13015 -- dependent component of some other object, but that isn't
13016 -- relevant to checking the object passed to us). This avoids
13017 -- issuing wrong errors when compiling with -gnatc, where there
13018 -- can be implicit dereferences that have not been expanded.
13020 elsif Is_Access_Type
(Etype
(Prefix
(Object
))) then
13025 Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
13028 elsif Nkind
(Object
) = N_Indexed_Component
13029 or else Nkind
(Object
) = N_Slice
13031 return Is_Dependent_Component_Of_Mutable_Object
(Prefix
(Object
));
13033 -- A type conversion that Is_Variable is a view conversion:
13034 -- go back to the denoted object.
13036 elsif Nkind
(Object
) = N_Type_Conversion
then
13038 Is_Dependent_Component_Of_Mutable_Object
(Expression
(Object
));
13043 end Is_Dependent_Component_Of_Mutable_Object
;
13045 ---------------------
13046 -- Is_Dereferenced --
13047 ---------------------
13049 function Is_Dereferenced
(N
: Node_Id
) return Boolean is
13050 P
: constant Node_Id
:= Parent
(N
);
13052 return Nkind_In
(P
, N_Selected_Component
,
13053 N_Explicit_Dereference
,
13054 N_Indexed_Component
,
13056 and then Prefix
(P
) = N
;
13057 end Is_Dereferenced
;
13059 ----------------------
13060 -- Is_Descendant_Of --
13061 ----------------------
13063 function Is_Descendant_Of
(T1
: Entity_Id
; T2
: Entity_Id
) return Boolean is
13068 pragma Assert
(Nkind
(T1
) in N_Entity
);
13069 pragma Assert
(Nkind
(T2
) in N_Entity
);
13071 T
:= Base_Type
(T1
);
13073 -- Immediate return if the types match
13078 -- Comment needed here ???
13080 elsif Ekind
(T
) = E_Class_Wide_Type
then
13081 return Etype
(T
) = T2
;
13089 -- Done if we found the type we are looking for
13094 -- Done if no more derivations to check
13101 -- Following test catches error cases resulting from prev errors
13103 elsif No
(Etyp
) then
13106 elsif Is_Private_Type
(T
) and then Etyp
= Full_View
(T
) then
13109 elsif Is_Private_Type
(Etyp
) and then Full_View
(Etyp
) = T
then
13113 T
:= Base_Type
(Etyp
);
13116 end Is_Descendant_Of
;
13118 ----------------------------------------
13119 -- Is_Descendant_Of_Suspension_Object --
13120 ----------------------------------------
13122 function Is_Descendant_Of_Suspension_Object
13123 (Typ
: Entity_Id
) return Boolean
13125 Cur_Typ
: Entity_Id
;
13126 Par_Typ
: Entity_Id
;
13129 -- Climb the type derivation chain checking each parent type against
13130 -- Suspension_Object.
13132 Cur_Typ
:= Base_Type
(Typ
);
13133 while Present
(Cur_Typ
) loop
13134 Par_Typ
:= Etype
(Cur_Typ
);
13136 -- The current type is a match
13138 if Is_Suspension_Object
(Cur_Typ
) then
13141 -- Stop the traversal once the root of the derivation chain has been
13142 -- reached. In that case the current type is its own base type.
13144 elsif Cur_Typ
= Par_Typ
then
13148 Cur_Typ
:= Base_Type
(Par_Typ
);
13152 end Is_Descendant_Of_Suspension_Object
;
13154 ---------------------------------------------
13155 -- Is_Double_Precision_Floating_Point_Type --
13156 ---------------------------------------------
13158 function Is_Double_Precision_Floating_Point_Type
13159 (E
: Entity_Id
) return Boolean is
13161 return Is_Floating_Point_Type
(E
)
13162 and then Machine_Radix_Value
(E
) = Uint_2
13163 and then Machine_Mantissa_Value
(E
) = UI_From_Int
(53)
13164 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_10
13165 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_10
);
13166 end Is_Double_Precision_Floating_Point_Type
;
13168 -----------------------------
13169 -- Is_Effectively_Volatile --
13170 -----------------------------
13172 function Is_Effectively_Volatile
(Id
: Entity_Id
) return Boolean is
13174 if Is_Type
(Id
) then
13176 -- An arbitrary type is effectively volatile when it is subject to
13177 -- pragma Atomic or Volatile.
13179 if Is_Volatile
(Id
) then
13182 -- An array type is effectively volatile when it is subject to pragma
13183 -- Atomic_Components or Volatile_Components or its component type is
13184 -- effectively volatile.
13186 elsif Is_Array_Type
(Id
) then
13188 Anc
: Entity_Id
:= Base_Type
(Id
);
13190 if Is_Private_Type
(Anc
) then
13191 Anc
:= Full_View
(Anc
);
13194 -- Test for presence of ancestor, as the full view of a private
13195 -- type may be missing in case of error.
13198 Has_Volatile_Components
(Id
)
13201 and then Is_Effectively_Volatile
(Component_Type
(Anc
)));
13204 -- A protected type is always volatile
13206 elsif Is_Protected_Type
(Id
) then
13209 -- A descendant of Ada.Synchronous_Task_Control.Suspension_Object is
13210 -- automatically volatile.
13212 elsif Is_Descendant_Of_Suspension_Object
(Id
) then
13215 -- Otherwise the type is not effectively volatile
13221 -- Otherwise Id denotes an object
13226 or else Has_Volatile_Components
(Id
)
13227 or else Is_Effectively_Volatile
(Etype
(Id
));
13229 end Is_Effectively_Volatile
;
13231 ------------------------------------
13232 -- Is_Effectively_Volatile_Object --
13233 ------------------------------------
13235 function Is_Effectively_Volatile_Object
(N
: Node_Id
) return Boolean is
13237 if Is_Entity_Name
(N
) then
13238 return Is_Effectively_Volatile
(Entity
(N
));
13240 elsif Nkind
(N
) = N_Indexed_Component
then
13241 return Is_Effectively_Volatile_Object
(Prefix
(N
));
13243 elsif Nkind
(N
) = N_Selected_Component
then
13245 Is_Effectively_Volatile_Object
(Prefix
(N
))
13247 Is_Effectively_Volatile_Object
(Selector_Name
(N
));
13252 end Is_Effectively_Volatile_Object
;
13254 -------------------
13255 -- Is_Entry_Body --
13256 -------------------
13258 function Is_Entry_Body
(Id
: Entity_Id
) return Boolean is
13261 Ekind_In
(Id
, E_Entry
, E_Entry_Family
)
13262 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Body
;
13265 --------------------------
13266 -- Is_Entry_Declaration --
13267 --------------------------
13269 function Is_Entry_Declaration
(Id
: Entity_Id
) return Boolean is
13272 Ekind_In
(Id
, E_Entry
, E_Entry_Family
)
13273 and then Nkind
(Unit_Declaration_Node
(Id
)) = N_Entry_Declaration
;
13274 end Is_Entry_Declaration
;
13276 ------------------------------------
13277 -- Is_Expanded_Priority_Attribute --
13278 ------------------------------------
13280 function Is_Expanded_Priority_Attribute
(E
: Entity_Id
) return Boolean is
13283 Nkind
(E
) = N_Function_Call
13284 and then not Configurable_Run_Time_Mode
13285 and then (Entity
(Name
(E
)) = RTE
(RE_Get_Ceiling
)
13286 or else Entity
(Name
(E
)) = RTE
(RO_PE_Get_Ceiling
));
13287 end Is_Expanded_Priority_Attribute
;
13289 ----------------------------
13290 -- Is_Expression_Function --
13291 ----------------------------
13293 function Is_Expression_Function
(Subp
: Entity_Id
) return Boolean is
13295 if Ekind_In
(Subp
, E_Function
, E_Subprogram_Body
) then
13297 Nkind
(Original_Node
(Unit_Declaration_Node
(Subp
))) =
13298 N_Expression_Function
;
13302 end Is_Expression_Function
;
13304 ------------------------------------------
13305 -- Is_Expression_Function_Or_Completion --
13306 ------------------------------------------
13308 function Is_Expression_Function_Or_Completion
13309 (Subp
: Entity_Id
) return Boolean
13311 Subp_Decl
: Node_Id
;
13314 if Ekind
(Subp
) = E_Function
then
13315 Subp_Decl
:= Unit_Declaration_Node
(Subp
);
13317 -- The function declaration is either an expression function or is
13318 -- completed by an expression function body.
13321 Is_Expression_Function
(Subp
)
13322 or else (Nkind
(Subp_Decl
) = N_Subprogram_Declaration
13323 and then Present
(Corresponding_Body
(Subp_Decl
))
13324 and then Is_Expression_Function
13325 (Corresponding_Body
(Subp_Decl
)));
13327 elsif Ekind
(Subp
) = E_Subprogram_Body
then
13328 return Is_Expression_Function
(Subp
);
13333 end Is_Expression_Function_Or_Completion
;
13335 -----------------------
13336 -- Is_EVF_Expression --
13337 -----------------------
13339 function Is_EVF_Expression
(N
: Node_Id
) return Boolean is
13340 Orig_N
: constant Node_Id
:= Original_Node
(N
);
13346 -- Detect a reference to a formal parameter of a specific tagged type
13347 -- whose related subprogram is subject to pragma Expresions_Visible with
13350 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
13355 and then Is_Specific_Tagged_Type
(Etype
(Id
))
13356 and then Extensions_Visible_Status
(Id
) =
13357 Extensions_Visible_False
;
13359 -- A case expression is an EVF expression when it contains at least one
13360 -- EVF dependent_expression. Note that a case expression may have been
13361 -- expanded, hence the use of Original_Node.
13363 elsif Nkind
(Orig_N
) = N_Case_Expression
then
13364 Alt
:= First
(Alternatives
(Orig_N
));
13365 while Present
(Alt
) loop
13366 if Is_EVF_Expression
(Expression
(Alt
)) then
13373 -- An if expression is an EVF expression when it contains at least one
13374 -- EVF dependent_expression. Note that an if expression may have been
13375 -- expanded, hence the use of Original_Node.
13377 elsif Nkind
(Orig_N
) = N_If_Expression
then
13378 Expr
:= Next
(First
(Expressions
(Orig_N
)));
13379 while Present
(Expr
) loop
13380 if Is_EVF_Expression
(Expr
) then
13387 -- A qualified expression or a type conversion is an EVF expression when
13388 -- its operand is an EVF expression.
13390 elsif Nkind_In
(N
, N_Qualified_Expression
,
13391 N_Unchecked_Type_Conversion
,
13394 return Is_EVF_Expression
(Expression
(N
));
13396 -- Attributes 'Loop_Entry, 'Old, and 'Update are EVF expressions when
13397 -- their prefix denotes an EVF expression.
13399 elsif Nkind
(N
) = N_Attribute_Reference
13400 and then Nam_In
(Attribute_Name
(N
), Name_Loop_Entry
,
13404 return Is_EVF_Expression
(Prefix
(N
));
13408 end Is_EVF_Expression
;
13414 function Is_False
(U
: Uint
) return Boolean is
13419 ---------------------------
13420 -- Is_Fixed_Model_Number --
13421 ---------------------------
13423 function Is_Fixed_Model_Number
(U
: Ureal
; T
: Entity_Id
) return Boolean is
13424 S
: constant Ureal
:= Small_Value
(T
);
13425 M
: Urealp
.Save_Mark
;
13430 R
:= (U
= UR_Trunc
(U
/ S
) * S
);
13431 Urealp
.Release
(M
);
13433 end Is_Fixed_Model_Number
;
13435 -------------------------------
13436 -- Is_Fully_Initialized_Type --
13437 -------------------------------
13439 function Is_Fully_Initialized_Type
(Typ
: Entity_Id
) return Boolean is
13443 if Is_Scalar_Type
(Typ
) then
13445 -- A scalar type with an aspect Default_Value is fully initialized
13447 -- Note: Iniitalize/Normalize_Scalars also ensure full initialization
13448 -- of a scalar type, but we don't take that into account here, since
13449 -- we don't want these to affect warnings.
13451 return Has_Default_Aspect
(Typ
);
13453 elsif Is_Access_Type
(Typ
) then
13456 elsif Is_Array_Type
(Typ
) then
13457 if Is_Fully_Initialized_Type
(Component_Type
(Typ
))
13458 or else (Ada_Version
>= Ada_2012
and then Has_Default_Aspect
(Typ
))
13463 -- An interesting case, if we have a constrained type one of whose
13464 -- bounds is known to be null, then there are no elements to be
13465 -- initialized, so all the elements are initialized.
13467 if Is_Constrained
(Typ
) then
13470 Indx_Typ
: Entity_Id
;
13471 Lbd
, Hbd
: Node_Id
;
13474 Indx
:= First_Index
(Typ
);
13475 while Present
(Indx
) loop
13476 if Etype
(Indx
) = Any_Type
then
13479 -- If index is a range, use directly
13481 elsif Nkind
(Indx
) = N_Range
then
13482 Lbd
:= Low_Bound
(Indx
);
13483 Hbd
:= High_Bound
(Indx
);
13486 Indx_Typ
:= Etype
(Indx
);
13488 if Is_Private_Type
(Indx_Typ
) then
13489 Indx_Typ
:= Full_View
(Indx_Typ
);
13492 if No
(Indx_Typ
) or else Etype
(Indx_Typ
) = Any_Type
then
13495 Lbd
:= Type_Low_Bound
(Indx_Typ
);
13496 Hbd
:= Type_High_Bound
(Indx_Typ
);
13500 if Compile_Time_Known_Value
(Lbd
)
13502 Compile_Time_Known_Value
(Hbd
)
13504 if Expr_Value
(Hbd
) < Expr_Value
(Lbd
) then
13514 -- If no null indexes, then type is not fully initialized
13520 elsif Is_Record_Type
(Typ
) then
13521 if Has_Discriminants
(Typ
)
13523 Present
(Discriminant_Default_Value
(First_Discriminant
(Typ
)))
13524 and then Is_Fully_Initialized_Variant
(Typ
)
13529 -- We consider bounded string types to be fully initialized, because
13530 -- otherwise we get false alarms when the Data component is not
13531 -- default-initialized.
13533 if Is_Bounded_String
(Typ
) then
13537 -- Controlled records are considered to be fully initialized if
13538 -- there is a user defined Initialize routine. This may not be
13539 -- entirely correct, but as the spec notes, we are guessing here
13540 -- what is best from the point of view of issuing warnings.
13542 if Is_Controlled
(Typ
) then
13544 Utyp
: constant Entity_Id
:= Underlying_Type
(Typ
);
13547 if Present
(Utyp
) then
13549 Init
: constant Entity_Id
:=
13550 (Find_Optional_Prim_Op
13551 (Underlying_Type
(Typ
), Name_Initialize
));
13555 and then Comes_From_Source
(Init
)
13556 and then not In_Predefined_Unit
(Init
)
13560 elsif Has_Null_Extension
(Typ
)
13562 Is_Fully_Initialized_Type
13563 (Etype
(Base_Type
(Typ
)))
13572 -- Otherwise see if all record components are initialized
13578 Ent
:= First_Entity
(Typ
);
13579 while Present
(Ent
) loop
13580 if Ekind
(Ent
) = E_Component
13581 and then (No
(Parent
(Ent
))
13582 or else No
(Expression
(Parent
(Ent
))))
13583 and then not Is_Fully_Initialized_Type
(Etype
(Ent
))
13585 -- Special VM case for tag components, which need to be
13586 -- defined in this case, but are never initialized as VMs
13587 -- are using other dispatching mechanisms. Ignore this
13588 -- uninitialized case. Note that this applies both to the
13589 -- uTag entry and the main vtable pointer (CPP_Class case).
13591 and then (Tagged_Type_Expansion
or else not Is_Tag
(Ent
))
13600 -- No uninitialized components, so type is fully initialized.
13601 -- Note that this catches the case of no components as well.
13605 elsif Is_Concurrent_Type
(Typ
) then
13608 elsif Is_Private_Type
(Typ
) then
13610 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
13616 return Is_Fully_Initialized_Type
(U
);
13623 end Is_Fully_Initialized_Type
;
13625 ----------------------------------
13626 -- Is_Fully_Initialized_Variant --
13627 ----------------------------------
13629 function Is_Fully_Initialized_Variant
(Typ
: Entity_Id
) return Boolean is
13630 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
13631 Constraints
: constant List_Id
:= New_List
;
13632 Components
: constant Elist_Id
:= New_Elmt_List
;
13633 Comp_Elmt
: Elmt_Id
;
13635 Comp_List
: Node_Id
;
13637 Discr_Val
: Node_Id
;
13639 Report_Errors
: Boolean;
13640 pragma Warnings
(Off
, Report_Errors
);
13643 if Serious_Errors_Detected
> 0 then
13647 if Is_Record_Type
(Typ
)
13648 and then Nkind
(Parent
(Typ
)) = N_Full_Type_Declaration
13649 and then Nkind
(Type_Definition
(Parent
(Typ
))) = N_Record_Definition
13651 Comp_List
:= Component_List
(Type_Definition
(Parent
(Typ
)));
13653 Discr
:= First_Discriminant
(Typ
);
13654 while Present
(Discr
) loop
13655 if Nkind
(Parent
(Discr
)) = N_Discriminant_Specification
then
13656 Discr_Val
:= Expression
(Parent
(Discr
));
13658 if Present
(Discr_Val
)
13659 and then Is_OK_Static_Expression
(Discr_Val
)
13661 Append_To
(Constraints
,
13662 Make_Component_Association
(Loc
,
13663 Choices
=> New_List
(New_Occurrence_Of
(Discr
, Loc
)),
13664 Expression
=> New_Copy
(Discr_Val
)));
13672 Next_Discriminant
(Discr
);
13677 Comp_List
=> Comp_List
,
13678 Governed_By
=> Constraints
,
13679 Into
=> Components
,
13680 Report_Errors
=> Report_Errors
);
13682 -- Check that each component present is fully initialized
13684 Comp_Elmt
:= First_Elmt
(Components
);
13685 while Present
(Comp_Elmt
) loop
13686 Comp_Id
:= Node
(Comp_Elmt
);
13688 if Ekind
(Comp_Id
) = E_Component
13689 and then (No
(Parent
(Comp_Id
))
13690 or else No
(Expression
(Parent
(Comp_Id
))))
13691 and then not Is_Fully_Initialized_Type
(Etype
(Comp_Id
))
13696 Next_Elmt
(Comp_Elmt
);
13701 elsif Is_Private_Type
(Typ
) then
13703 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
13709 return Is_Fully_Initialized_Variant
(U
);
13716 end Is_Fully_Initialized_Variant
;
13718 ------------------------------------
13719 -- Is_Generic_Declaration_Or_Body --
13720 ------------------------------------
13722 function Is_Generic_Declaration_Or_Body
(Decl
: Node_Id
) return Boolean is
13723 Spec_Decl
: Node_Id
;
13726 -- Package/subprogram body
13728 if Nkind_In
(Decl
, N_Package_Body
, N_Subprogram_Body
)
13729 and then Present
(Corresponding_Spec
(Decl
))
13731 Spec_Decl
:= Unit_Declaration_Node
(Corresponding_Spec
(Decl
));
13733 -- Package/subprogram body stub
13735 elsif Nkind_In
(Decl
, N_Package_Body_Stub
, N_Subprogram_Body_Stub
)
13736 and then Present
(Corresponding_Spec_Of_Stub
(Decl
))
13739 Unit_Declaration_Node
(Corresponding_Spec_Of_Stub
(Decl
));
13747 -- Rather than inspecting the defining entity of the spec declaration,
13748 -- look at its Nkind. This takes care of the case where the analysis of
13749 -- a generic body modifies the Ekind of its spec to allow for recursive
13753 Nkind_In
(Spec_Decl
, N_Generic_Package_Declaration
,
13754 N_Generic_Subprogram_Declaration
);
13755 end Is_Generic_Declaration_Or_Body
;
13757 ----------------------------
13758 -- Is_Inherited_Operation --
13759 ----------------------------
13761 function Is_Inherited_Operation
(E
: Entity_Id
) return Boolean is
13762 pragma Assert
(Is_Overloadable
(E
));
13763 Kind
: constant Node_Kind
:= Nkind
(Parent
(E
));
13765 return Kind
= N_Full_Type_Declaration
13766 or else Kind
= N_Private_Extension_Declaration
13767 or else Kind
= N_Subtype_Declaration
13768 or else (Ekind
(E
) = E_Enumeration_Literal
13769 and then Is_Derived_Type
(Etype
(E
)));
13770 end Is_Inherited_Operation
;
13772 -------------------------------------
13773 -- Is_Inherited_Operation_For_Type --
13774 -------------------------------------
13776 function Is_Inherited_Operation_For_Type
13778 Typ
: Entity_Id
) return Boolean
13781 -- Check that the operation has been created by the type declaration
13783 return Is_Inherited_Operation
(E
)
13784 and then Defining_Identifier
(Parent
(E
)) = Typ
;
13785 end Is_Inherited_Operation_For_Type
;
13787 --------------------------------------
13788 -- Is_Inlinable_Expression_Function --
13789 --------------------------------------
13791 function Is_Inlinable_Expression_Function
13792 (Subp
: Entity_Id
) return Boolean
13794 Return_Expr
: Node_Id
;
13797 if Is_Expression_Function_Or_Completion
(Subp
)
13798 and then Has_Pragma_Inline_Always
(Subp
)
13799 and then Needs_No_Actuals
(Subp
)
13800 and then No
(Contract
(Subp
))
13801 and then not Is_Dispatching_Operation
(Subp
)
13802 and then Needs_Finalization
(Etype
(Subp
))
13803 and then not Is_Class_Wide_Type
(Etype
(Subp
))
13804 and then not (Has_Invariants
(Etype
(Subp
)))
13805 and then Present
(Subprogram_Body
(Subp
))
13806 and then Was_Expression_Function
(Subprogram_Body
(Subp
))
13808 Return_Expr
:= Expression_Of_Expression_Function
(Subp
);
13810 -- The returned object must not have a qualified expression and its
13811 -- nominal subtype must be statically compatible with the result
13812 -- subtype of the expression function.
13815 Nkind
(Return_Expr
) = N_Identifier
13816 and then Etype
(Return_Expr
) = Etype
(Subp
);
13820 end Is_Inlinable_Expression_Function
;
13826 function Is_Iterator
(Typ
: Entity_Id
) return Boolean is
13827 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean;
13828 -- Determine whether type Iter_Typ is a predefined forward or reversible
13831 ----------------------
13832 -- Denotes_Iterator --
13833 ----------------------
13835 function Denotes_Iterator
(Iter_Typ
: Entity_Id
) return Boolean is
13837 -- Check that the name matches, and that the ultimate ancestor is in
13838 -- a predefined unit, i.e the one that declares iterator interfaces.
13841 Nam_In
(Chars
(Iter_Typ
), Name_Forward_Iterator
,
13842 Name_Reversible_Iterator
)
13843 and then In_Predefined_Unit
(Root_Type
(Iter_Typ
));
13844 end Denotes_Iterator
;
13848 Iface_Elmt
: Elmt_Id
;
13851 -- Start of processing for Is_Iterator
13854 -- The type may be a subtype of a descendant of the proper instance of
13855 -- the predefined interface type, so we must use the root type of the
13856 -- given type. The same is done for Is_Reversible_Iterator.
13858 if Is_Class_Wide_Type
(Typ
)
13859 and then Denotes_Iterator
(Root_Type
(Typ
))
13863 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
13866 elsif Present
(Find_Value_Of_Aspect
(Typ
, Aspect_Iterable
)) then
13870 Collect_Interfaces
(Typ
, Ifaces
);
13872 Iface_Elmt
:= First_Elmt
(Ifaces
);
13873 while Present
(Iface_Elmt
) loop
13874 if Denotes_Iterator
(Node
(Iface_Elmt
)) then
13878 Next_Elmt
(Iface_Elmt
);
13885 ----------------------------
13886 -- Is_Iterator_Over_Array --
13887 ----------------------------
13889 function Is_Iterator_Over_Array
(N
: Node_Id
) return Boolean is
13890 Container
: constant Node_Id
:= Name
(N
);
13891 Container_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Container
));
13893 return Is_Array_Type
(Container_Typ
);
13894 end Is_Iterator_Over_Array
;
13900 -- We seem to have a lot of overlapping functions that do similar things
13901 -- (testing for left hand sides or lvalues???).
13903 function Is_LHS
(N
: Node_Id
) return Is_LHS_Result
is
13904 P
: constant Node_Id
:= Parent
(N
);
13907 -- Return True if we are the left hand side of an assignment statement
13909 if Nkind
(P
) = N_Assignment_Statement
then
13910 if Name
(P
) = N
then
13916 -- Case of prefix of indexed or selected component or slice
13918 elsif Nkind_In
(P
, N_Indexed_Component
, N_Selected_Component
, N_Slice
)
13919 and then N
= Prefix
(P
)
13921 -- Here we have the case where the parent P is N.Q or N(Q .. R).
13922 -- If P is an LHS, then N is also effectively an LHS, but there
13923 -- is an important exception. If N is of an access type, then
13924 -- what we really have is N.all.Q (or N.all(Q .. R)). In either
13925 -- case this makes N.all a left hand side but not N itself.
13927 -- If we don't know the type yet, this is the case where we return
13928 -- Unknown, since the answer depends on the type which is unknown.
13930 if No
(Etype
(N
)) then
13933 -- We have an Etype set, so we can check it
13935 elsif Is_Access_Type
(Etype
(N
)) then
13938 -- OK, not access type case, so just test whole expression
13944 -- All other cases are not left hand sides
13951 -----------------------------
13952 -- Is_Library_Level_Entity --
13953 -----------------------------
13955 function Is_Library_Level_Entity
(E
: Entity_Id
) return Boolean is
13957 -- The following is a small optimization, and it also properly handles
13958 -- discriminals, which in task bodies might appear in expressions before
13959 -- the corresponding procedure has been created, and which therefore do
13960 -- not have an assigned scope.
13962 if Is_Formal
(E
) then
13966 -- Normal test is simply that the enclosing dynamic scope is Standard
13968 return Enclosing_Dynamic_Scope
(E
) = Standard_Standard
;
13969 end Is_Library_Level_Entity
;
13971 --------------------------------
13972 -- Is_Limited_Class_Wide_Type --
13973 --------------------------------
13975 function Is_Limited_Class_Wide_Type
(Typ
: Entity_Id
) return Boolean is
13978 Is_Class_Wide_Type
(Typ
)
13979 and then (Is_Limited_Type
(Typ
) or else From_Limited_With
(Typ
));
13980 end Is_Limited_Class_Wide_Type
;
13982 ---------------------------------
13983 -- Is_Local_Variable_Reference --
13984 ---------------------------------
13986 function Is_Local_Variable_Reference
(Expr
: Node_Id
) return Boolean is
13988 if not Is_Entity_Name
(Expr
) then
13993 Ent
: constant Entity_Id
:= Entity
(Expr
);
13994 Sub
: constant Entity_Id
:= Enclosing_Subprogram
(Ent
);
13996 if not Ekind_In
(Ent
, E_Variable
, E_In_Out_Parameter
) then
13999 return Present
(Sub
) and then Sub
= Current_Subprogram
;
14003 end Is_Local_Variable_Reference
;
14005 -----------------------
14006 -- Is_Name_Reference --
14007 -----------------------
14009 function Is_Name_Reference
(N
: Node_Id
) return Boolean is
14011 if Is_Entity_Name
(N
) then
14012 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
));
14016 when N_Indexed_Component
14020 Is_Name_Reference
(Prefix
(N
))
14021 or else Is_Access_Type
(Etype
(Prefix
(N
)));
14023 -- Attributes 'Input, 'Old and 'Result produce objects
14025 when N_Attribute_Reference
=>
14027 Nam_In
(Attribute_Name
(N
), Name_Input
, Name_Old
, Name_Result
);
14029 when N_Selected_Component
=>
14031 Is_Name_Reference
(Selector_Name
(N
))
14033 (Is_Name_Reference
(Prefix
(N
))
14034 or else Is_Access_Type
(Etype
(Prefix
(N
))));
14036 when N_Explicit_Dereference
=>
14039 -- A view conversion of a tagged name is a name reference
14041 when N_Type_Conversion
=>
14043 Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
14044 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
14045 and then Is_Name_Reference
(Expression
(N
));
14047 -- An unchecked type conversion is considered to be a name if the
14048 -- operand is a name (this construction arises only as a result of
14049 -- expansion activities).
14051 when N_Unchecked_Type_Conversion
=>
14052 return Is_Name_Reference
(Expression
(N
));
14057 end Is_Name_Reference
;
14059 ---------------------------------
14060 -- Is_Nontrivial_DIC_Procedure --
14061 ---------------------------------
14063 function Is_Nontrivial_DIC_Procedure
(Id
: Entity_Id
) return Boolean is
14064 Body_Decl
: Node_Id
;
14068 if Ekind
(Id
) = E_Procedure
and then Is_DIC_Procedure
(Id
) then
14070 Unit_Declaration_Node
14071 (Corresponding_Body
(Unit_Declaration_Node
(Id
)));
14073 -- The body of the Default_Initial_Condition procedure must contain
14074 -- at least one statement, otherwise the generation of the subprogram
14077 pragma Assert
(Present
(Handled_Statement_Sequence
(Body_Decl
)));
14079 -- To qualify as nontrivial, the first statement of the procedure
14080 -- must be a check in the form of an if statement. If the original
14081 -- Default_Initial_Condition expression was folded, then the first
14082 -- statement is not a check.
14084 Stmt
:= First
(Statements
(Handled_Statement_Sequence
(Body_Decl
)));
14087 Nkind
(Stmt
) = N_If_Statement
14088 and then Nkind
(Original_Node
(Stmt
)) = N_Pragma
;
14092 end Is_Nontrivial_DIC_Procedure
;
14094 -------------------------
14095 -- Is_Null_Record_Type --
14096 -------------------------
14098 function Is_Null_Record_Type
(T
: Entity_Id
) return Boolean is
14099 Decl
: constant Node_Id
:= Parent
(T
);
14101 return Nkind
(Decl
) = N_Full_Type_Declaration
14102 and then Nkind
(Type_Definition
(Decl
)) = N_Record_Definition
14104 (No
(Component_List
(Type_Definition
(Decl
)))
14105 or else Null_Present
(Component_List
(Type_Definition
(Decl
))));
14106 end Is_Null_Record_Type
;
14108 -------------------------
14109 -- Is_Object_Reference --
14110 -------------------------
14112 function Is_Object_Reference
(N
: Node_Id
) return Boolean is
14113 function Is_Internally_Generated_Renaming
(N
: Node_Id
) return Boolean;
14114 -- Determine whether N is the name of an internally-generated renaming
14116 --------------------------------------
14117 -- Is_Internally_Generated_Renaming --
14118 --------------------------------------
14120 function Is_Internally_Generated_Renaming
(N
: Node_Id
) return Boolean is
14125 while Present
(P
) loop
14126 if Nkind
(P
) = N_Object_Renaming_Declaration
then
14127 return not Comes_From_Source
(P
);
14128 elsif Is_List_Member
(P
) then
14136 end Is_Internally_Generated_Renaming
;
14138 -- Start of processing for Is_Object_Reference
14141 if Is_Entity_Name
(N
) then
14142 return Present
(Entity
(N
)) and then Is_Object
(Entity
(N
));
14146 when N_Indexed_Component
14150 Is_Object_Reference
(Prefix
(N
))
14151 or else Is_Access_Type
(Etype
(Prefix
(N
)));
14153 -- In Ada 95, a function call is a constant object; a procedure
14156 when N_Function_Call
=>
14157 return Etype
(N
) /= Standard_Void_Type
;
14159 -- Attributes 'Input, 'Loop_Entry, 'Old, and 'Result produce
14162 when N_Attribute_Reference
=>
14164 Nam_In
(Attribute_Name
(N
), Name_Input
,
14169 when N_Selected_Component
=>
14171 Is_Object_Reference
(Selector_Name
(N
))
14173 (Is_Object_Reference
(Prefix
(N
))
14174 or else Is_Access_Type
(Etype
(Prefix
(N
))));
14176 -- An explicit dereference denotes an object, except that a
14177 -- conditional expression gets turned into an explicit dereference
14178 -- in some cases, and conditional expressions are not object
14181 when N_Explicit_Dereference
=>
14182 return not Nkind_In
(Original_Node
(N
), N_Case_Expression
,
14185 -- A view conversion of a tagged object is an object reference
14187 when N_Type_Conversion
=>
14188 return Is_Tagged_Type
(Etype
(Subtype_Mark
(N
)))
14189 and then Is_Tagged_Type
(Etype
(Expression
(N
)))
14190 and then Is_Object_Reference
(Expression
(N
));
14192 -- An unchecked type conversion is considered to be an object if
14193 -- the operand is an object (this construction arises only as a
14194 -- result of expansion activities).
14196 when N_Unchecked_Type_Conversion
=>
14199 -- Allow string literals to act as objects as long as they appear
14200 -- in internally-generated renamings. The expansion of iterators
14201 -- may generate such renamings when the range involves a string
14204 when N_String_Literal
=>
14205 return Is_Internally_Generated_Renaming
(Parent
(N
));
14207 -- AI05-0003: In Ada 2012 a qualified expression is a name.
14208 -- This allows disambiguation of function calls and the use
14209 -- of aggregates in more contexts.
14211 when N_Qualified_Expression
=>
14212 if Ada_Version
< Ada_2012
then
14215 return Is_Object_Reference
(Expression
(N
))
14216 or else Nkind
(Expression
(N
)) = N_Aggregate
;
14223 end Is_Object_Reference
;
14225 -----------------------------------
14226 -- Is_OK_Variable_For_Out_Formal --
14227 -----------------------------------
14229 function Is_OK_Variable_For_Out_Formal
(AV
: Node_Id
) return Boolean is
14231 Note_Possible_Modification
(AV
, Sure
=> True);
14233 -- We must reject parenthesized variable names. Comes_From_Source is
14234 -- checked because there are currently cases where the compiler violates
14235 -- this rule (e.g. passing a task object to its controlled Initialize
14236 -- routine). This should be properly documented in sinfo???
14238 if Paren_Count
(AV
) > 0 and then Comes_From_Source
(AV
) then
14241 -- A variable is always allowed
14243 elsif Is_Variable
(AV
) then
14246 -- Generalized indexing operations are rewritten as explicit
14247 -- dereferences, and it is only during resolution that we can
14248 -- check whether the context requires an access_to_variable type.
14250 elsif Nkind
(AV
) = N_Explicit_Dereference
14251 and then Ada_Version
>= Ada_2012
14252 and then Nkind
(Original_Node
(AV
)) = N_Indexed_Component
14253 and then Present
(Etype
(Original_Node
(AV
)))
14254 and then Has_Implicit_Dereference
(Etype
(Original_Node
(AV
)))
14256 return not Is_Access_Constant
(Etype
(Prefix
(AV
)));
14258 -- Unchecked conversions are allowed only if they come from the
14259 -- generated code, which sometimes uses unchecked conversions for out
14260 -- parameters in cases where code generation is unaffected. We tell
14261 -- source unchecked conversions by seeing if they are rewrites of
14262 -- an original Unchecked_Conversion function call, or of an explicit
14263 -- conversion of a function call or an aggregate (as may happen in the
14264 -- expansion of a packed array aggregate).
14266 elsif Nkind
(AV
) = N_Unchecked_Type_Conversion
then
14267 if Nkind_In
(Original_Node
(AV
), N_Function_Call
, N_Aggregate
) then
14270 elsif Comes_From_Source
(AV
)
14271 and then Nkind
(Original_Node
(Expression
(AV
))) = N_Function_Call
14275 elsif Nkind
(Original_Node
(AV
)) = N_Type_Conversion
then
14276 return Is_OK_Variable_For_Out_Formal
(Expression
(AV
));
14282 -- Normal type conversions are allowed if argument is a variable
14284 elsif Nkind
(AV
) = N_Type_Conversion
then
14285 if Is_Variable
(Expression
(AV
))
14286 and then Paren_Count
(Expression
(AV
)) = 0
14288 Note_Possible_Modification
(Expression
(AV
), Sure
=> True);
14291 -- We also allow a non-parenthesized expression that raises
14292 -- constraint error if it rewrites what used to be a variable
14294 elsif Raises_Constraint_Error
(Expression
(AV
))
14295 and then Paren_Count
(Expression
(AV
)) = 0
14296 and then Is_Variable
(Original_Node
(Expression
(AV
)))
14300 -- Type conversion of something other than a variable
14306 -- If this node is rewritten, then test the original form, if that is
14307 -- OK, then we consider the rewritten node OK (for example, if the
14308 -- original node is a conversion, then Is_Variable will not be true
14309 -- but we still want to allow the conversion if it converts a variable).
14311 elsif Original_Node
(AV
) /= AV
then
14313 -- In Ada 2012, the explicit dereference may be a rewritten call to a
14314 -- Reference function.
14316 if Ada_Version
>= Ada_2012
14317 and then Nkind
(Original_Node
(AV
)) = N_Function_Call
14319 Has_Implicit_Dereference
(Etype
(Name
(Original_Node
(AV
))))
14322 -- Check that this is not a constant reference.
14324 return not Is_Access_Constant
(Etype
(Prefix
(AV
)));
14326 elsif Has_Implicit_Dereference
(Etype
(Original_Node
(AV
))) then
14328 not Is_Access_Constant
(Etype
14329 (Get_Reference_Discriminant
(Etype
(Original_Node
(AV
)))));
14332 return Is_OK_Variable_For_Out_Formal
(Original_Node
(AV
));
14335 -- All other non-variables are rejected
14340 end Is_OK_Variable_For_Out_Formal
;
14342 ----------------------------
14343 -- Is_OK_Volatile_Context --
14344 ----------------------------
14346 function Is_OK_Volatile_Context
14347 (Context
: Node_Id
;
14348 Obj_Ref
: Node_Id
) return Boolean
14350 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean;
14351 -- Determine whether an arbitrary node denotes a call to a protected
14352 -- entry, function, or procedure in prefixed form where the prefix is
14355 function Within_Check
(Nod
: Node_Id
) return Boolean;
14356 -- Determine whether an arbitrary node appears in a check node
14358 function Within_Subprogram_Call
(Nod
: Node_Id
) return Boolean;
14359 -- Determine whether an arbitrary node appears in an entry, function, or
14362 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean;
14363 -- Determine whether an arbitrary entity appears in a volatile function
14365 ---------------------------------
14366 -- Is_Protected_Operation_Call --
14367 ---------------------------------
14369 function Is_Protected_Operation_Call
(Nod
: Node_Id
) return Boolean is
14374 -- A call to a protected operations retains its selected component
14375 -- form as opposed to other prefixed calls that are transformed in
14378 if Nkind
(Nod
) = N_Selected_Component
then
14379 Pref
:= Prefix
(Nod
);
14380 Subp
:= Selector_Name
(Nod
);
14384 and then Present
(Etype
(Pref
))
14385 and then Is_Protected_Type
(Etype
(Pref
))
14386 and then Is_Entity_Name
(Subp
)
14387 and then Present
(Entity
(Subp
))
14388 and then Ekind_In
(Entity
(Subp
), E_Entry
,
14395 end Is_Protected_Operation_Call
;
14401 function Within_Check
(Nod
: Node_Id
) return Boolean is
14405 -- Climb the parent chain looking for a check node
14408 while Present
(Par
) loop
14409 if Nkind
(Par
) in N_Raise_xxx_Error
then
14412 -- Prevent the search from going too far
14414 elsif Is_Body_Or_Package_Declaration
(Par
) then
14418 Par
:= Parent
(Par
);
14424 ----------------------------
14425 -- Within_Subprogram_Call --
14426 ----------------------------
14428 function Within_Subprogram_Call
(Nod
: Node_Id
) return Boolean is
14432 -- Climb the parent chain looking for a function or procedure call
14435 while Present
(Par
) loop
14436 if Nkind_In
(Par
, N_Entry_Call_Statement
,
14438 N_Procedure_Call_Statement
)
14442 -- Prevent the search from going too far
14444 elsif Is_Body_Or_Package_Declaration
(Par
) then
14448 Par
:= Parent
(Par
);
14452 end Within_Subprogram_Call
;
14454 ------------------------------
14455 -- Within_Volatile_Function --
14456 ------------------------------
14458 function Within_Volatile_Function
(Id
: Entity_Id
) return Boolean is
14459 Func_Id
: Entity_Id
;
14462 -- Traverse the scope stack looking for a [generic] function
14465 while Present
(Func_Id
) and then Func_Id
/= Standard_Standard
loop
14466 if Ekind_In
(Func_Id
, E_Function
, E_Generic_Function
) then
14467 return Is_Volatile_Function
(Func_Id
);
14470 Func_Id
:= Scope
(Func_Id
);
14474 end Within_Volatile_Function
;
14478 Obj_Id
: Entity_Id
;
14480 -- Start of processing for Is_OK_Volatile_Context
14483 -- The volatile object appears on either side of an assignment
14485 if Nkind
(Context
) = N_Assignment_Statement
then
14488 -- The volatile object is part of the initialization expression of
14491 elsif Nkind
(Context
) = N_Object_Declaration
14492 and then Present
(Expression
(Context
))
14493 and then Expression
(Context
) = Obj_Ref
14495 Obj_Id
:= Defining_Entity
(Context
);
14497 -- The volatile object acts as the initialization expression of an
14498 -- extended return statement. This is valid context as long as the
14499 -- function is volatile.
14501 if Is_Return_Object
(Obj_Id
) then
14502 return Within_Volatile_Function
(Obj_Id
);
14504 -- Otherwise this is a normal object initialization
14510 -- The volatile object acts as the name of a renaming declaration
14512 elsif Nkind
(Context
) = N_Object_Renaming_Declaration
14513 and then Name
(Context
) = Obj_Ref
14517 -- The volatile object appears as an actual parameter in a call to an
14518 -- instance of Unchecked_Conversion whose result is renamed.
14520 elsif Nkind
(Context
) = N_Function_Call
14521 and then Is_Entity_Name
(Name
(Context
))
14522 and then Is_Unchecked_Conversion_Instance
(Entity
(Name
(Context
)))
14523 and then Nkind
(Parent
(Context
)) = N_Object_Renaming_Declaration
14527 -- The volatile object is actually the prefix in a protected entry,
14528 -- function, or procedure call.
14530 elsif Is_Protected_Operation_Call
(Context
) then
14533 -- The volatile object appears as the expression of a simple return
14534 -- statement that applies to a volatile function.
14536 elsif Nkind
(Context
) = N_Simple_Return_Statement
14537 and then Expression
(Context
) = Obj_Ref
14540 Within_Volatile_Function
(Return_Statement_Entity
(Context
));
14542 -- The volatile object appears as the prefix of a name occurring in a
14543 -- non-interfering context.
14545 elsif Nkind_In
(Context
, N_Attribute_Reference
,
14546 N_Explicit_Dereference
,
14547 N_Indexed_Component
,
14548 N_Selected_Component
,
14550 and then Prefix
(Context
) = Obj_Ref
14551 and then Is_OK_Volatile_Context
14552 (Context
=> Parent
(Context
),
14553 Obj_Ref
=> Context
)
14557 -- The volatile object appears as the prefix of attributes Address,
14558 -- Alignment, Component_Size, First_Bit, Last_Bit, Position, Size,
14561 elsif Nkind
(Context
) = N_Attribute_Reference
14562 and then Prefix
(Context
) = Obj_Ref
14563 and then Nam_In
(Attribute_Name
(Context
), Name_Address
,
14565 Name_Component_Size
,
14574 -- The volatile object appears as the expression of a type conversion
14575 -- occurring in a non-interfering context.
14577 elsif Nkind_In
(Context
, N_Type_Conversion
,
14578 N_Unchecked_Type_Conversion
)
14579 and then Expression
(Context
) = Obj_Ref
14580 and then Is_OK_Volatile_Context
14581 (Context
=> Parent
(Context
),
14582 Obj_Ref
=> Context
)
14586 -- The volatile object appears as the expression in a delay statement
14588 elsif Nkind
(Context
) in N_Delay_Statement
then
14591 -- Allow references to volatile objects in various checks. This is not a
14592 -- direct SPARK 2014 requirement.
14594 elsif Within_Check
(Context
) then
14597 -- Assume that references to effectively volatile objects that appear
14598 -- as actual parameters in a subprogram call are always legal. A full
14599 -- legality check is done when the actuals are resolved (see routine
14600 -- Resolve_Actuals).
14602 elsif Within_Subprogram_Call
(Context
) then
14605 -- Otherwise the context is not suitable for an effectively volatile
14611 end Is_OK_Volatile_Context
;
14613 ------------------------------------
14614 -- Is_Package_Contract_Annotation --
14615 ------------------------------------
14617 function Is_Package_Contract_Annotation
(Item
: Node_Id
) return Boolean is
14621 if Nkind
(Item
) = N_Aspect_Specification
then
14622 Nam
:= Chars
(Identifier
(Item
));
14624 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
14625 Nam
:= Pragma_Name
(Item
);
14628 return Nam
= Name_Abstract_State
14629 or else Nam
= Name_Initial_Condition
14630 or else Nam
= Name_Initializes
14631 or else Nam
= Name_Refined_State
;
14632 end Is_Package_Contract_Annotation
;
14634 -----------------------------------
14635 -- Is_Partially_Initialized_Type --
14636 -----------------------------------
14638 function Is_Partially_Initialized_Type
14640 Include_Implicit
: Boolean := True) return Boolean
14643 if Is_Scalar_Type
(Typ
) then
14646 elsif Is_Access_Type
(Typ
) then
14647 return Include_Implicit
;
14649 elsif Is_Array_Type
(Typ
) then
14651 -- If component type is partially initialized, so is array type
14653 if Is_Partially_Initialized_Type
14654 (Component_Type
(Typ
), Include_Implicit
)
14658 -- Otherwise we are only partially initialized if we are fully
14659 -- initialized (this is the empty array case, no point in us
14660 -- duplicating that code here).
14663 return Is_Fully_Initialized_Type
(Typ
);
14666 elsif Is_Record_Type
(Typ
) then
14668 -- A discriminated type is always partially initialized if in
14671 if Has_Discriminants
(Typ
) and then Include_Implicit
then
14674 -- A tagged type is always partially initialized
14676 elsif Is_Tagged_Type
(Typ
) then
14679 -- Case of non-discriminated record
14685 Component_Present
: Boolean := False;
14686 -- Set True if at least one component is present. If no
14687 -- components are present, then record type is fully
14688 -- initialized (another odd case, like the null array).
14691 -- Loop through components
14693 Ent
:= First_Entity
(Typ
);
14694 while Present
(Ent
) loop
14695 if Ekind
(Ent
) = E_Component
then
14696 Component_Present
:= True;
14698 -- If a component has an initialization expression then
14699 -- the enclosing record type is partially initialized
14701 if Present
(Parent
(Ent
))
14702 and then Present
(Expression
(Parent
(Ent
)))
14706 -- If a component is of a type which is itself partially
14707 -- initialized, then the enclosing record type is also.
14709 elsif Is_Partially_Initialized_Type
14710 (Etype
(Ent
), Include_Implicit
)
14719 -- No initialized components found. If we found any components
14720 -- they were all uninitialized so the result is false.
14722 if Component_Present
then
14725 -- But if we found no components, then all the components are
14726 -- initialized so we consider the type to be initialized.
14734 -- Concurrent types are always fully initialized
14736 elsif Is_Concurrent_Type
(Typ
) then
14739 -- For a private type, go to underlying type. If there is no underlying
14740 -- type then just assume this partially initialized. Not clear if this
14741 -- can happen in a non-error case, but no harm in testing for this.
14743 elsif Is_Private_Type
(Typ
) then
14745 U
: constant Entity_Id
:= Underlying_Type
(Typ
);
14750 return Is_Partially_Initialized_Type
(U
, Include_Implicit
);
14754 -- For any other type (are there any?) assume partially initialized
14759 end Is_Partially_Initialized_Type
;
14761 ------------------------------------
14762 -- Is_Potentially_Persistent_Type --
14763 ------------------------------------
14765 function Is_Potentially_Persistent_Type
(T
: Entity_Id
) return Boolean is
14770 -- For private type, test corresponding full type
14772 if Is_Private_Type
(T
) then
14773 return Is_Potentially_Persistent_Type
(Full_View
(T
));
14775 -- Scalar types are potentially persistent
14777 elsif Is_Scalar_Type
(T
) then
14780 -- Record type is potentially persistent if not tagged and the types of
14781 -- all it components are potentially persistent, and no component has
14782 -- an initialization expression.
14784 elsif Is_Record_Type
(T
)
14785 and then not Is_Tagged_Type
(T
)
14786 and then not Is_Partially_Initialized_Type
(T
)
14788 Comp
:= First_Component
(T
);
14789 while Present
(Comp
) loop
14790 if not Is_Potentially_Persistent_Type
(Etype
(Comp
)) then
14793 Next_Entity
(Comp
);
14799 -- Array type is potentially persistent if its component type is
14800 -- potentially persistent and if all its constraints are static.
14802 elsif Is_Array_Type
(T
) then
14803 if not Is_Potentially_Persistent_Type
(Component_Type
(T
)) then
14807 Indx
:= First_Index
(T
);
14808 while Present
(Indx
) loop
14809 if not Is_OK_Static_Subtype
(Etype
(Indx
)) then
14818 -- All other types are not potentially persistent
14823 end Is_Potentially_Persistent_Type
;
14825 --------------------------------
14826 -- Is_Potentially_Unevaluated --
14827 --------------------------------
14829 function Is_Potentially_Unevaluated
(N
: Node_Id
) return Boolean is
14837 -- A postcondition whose expression is a short-circuit is broken down
14838 -- into individual aspects for better exception reporting. The original
14839 -- short-circuit expression is rewritten as the second operand, and an
14840 -- occurrence of 'Old in that operand is potentially unevaluated.
14841 -- See Sem_ch13.adb for details of this transformation.
14843 if Nkind
(Original_Node
(Par
)) = N_And_Then
then
14847 while not Nkind_In
(Par
, N_If_Expression
,
14853 N_Quantified_Expression
)
14856 Par
:= Parent
(Par
);
14858 -- If the context is not an expression, or if is the result of
14859 -- expansion of an enclosing construct (such as another attribute)
14860 -- the predicate does not apply.
14862 if Nkind
(Par
) = N_Case_Expression_Alternative
then
14865 elsif Nkind
(Par
) not in N_Subexpr
14866 or else not Comes_From_Source
(Par
)
14872 if Nkind
(Par
) = N_If_Expression
then
14873 return Is_Elsif
(Par
) or else Expr
/= First
(Expressions
(Par
));
14875 elsif Nkind
(Par
) = N_Case_Expression
then
14876 return Expr
/= Expression
(Par
);
14878 elsif Nkind_In
(Par
, N_And_Then
, N_Or_Else
) then
14879 return Expr
= Right_Opnd
(Par
);
14881 elsif Nkind_In
(Par
, N_In
, N_Not_In
) then
14883 -- If the membership includes several alternatives, only the first is
14884 -- definitely evaluated.
14886 if Present
(Alternatives
(Par
)) then
14887 return Expr
/= First
(Alternatives
(Par
));
14889 -- If this is a range membership both bounds are evaluated
14895 elsif Nkind
(Par
) = N_Quantified_Expression
then
14896 return Expr
= Condition
(Par
);
14901 end Is_Potentially_Unevaluated
;
14903 ---------------------------------
14904 -- Is_Protected_Self_Reference --
14905 ---------------------------------
14907 function Is_Protected_Self_Reference
(N
: Node_Id
) return Boolean is
14909 function In_Access_Definition
(N
: Node_Id
) return Boolean;
14910 -- Returns true if N belongs to an access definition
14912 --------------------------
14913 -- In_Access_Definition --
14914 --------------------------
14916 function In_Access_Definition
(N
: Node_Id
) return Boolean is
14921 while Present
(P
) loop
14922 if Nkind
(P
) = N_Access_Definition
then
14930 end In_Access_Definition
;
14932 -- Start of processing for Is_Protected_Self_Reference
14935 -- Verify that prefix is analyzed and has the proper form. Note that
14936 -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also
14937 -- produce the address of an entity, do not analyze their prefix
14938 -- because they denote entities that are not necessarily visible.
14939 -- Neither of them can apply to a protected type.
14941 return Ada_Version
>= Ada_2005
14942 and then Is_Entity_Name
(N
)
14943 and then Present
(Entity
(N
))
14944 and then Is_Protected_Type
(Entity
(N
))
14945 and then In_Open_Scopes
(Entity
(N
))
14946 and then not In_Access_Definition
(N
);
14947 end Is_Protected_Self_Reference
;
14949 -----------------------------
14950 -- Is_RCI_Pkg_Spec_Or_Body --
14951 -----------------------------
14953 function Is_RCI_Pkg_Spec_Or_Body
(Cunit
: Node_Id
) return Boolean is
14955 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean;
14956 -- Return True if the unit of Cunit is an RCI package declaration
14958 ---------------------------
14959 -- Is_RCI_Pkg_Decl_Cunit --
14960 ---------------------------
14962 function Is_RCI_Pkg_Decl_Cunit
(Cunit
: Node_Id
) return Boolean is
14963 The_Unit
: constant Node_Id
:= Unit
(Cunit
);
14966 if Nkind
(The_Unit
) /= N_Package_Declaration
then
14970 return Is_Remote_Call_Interface
(Defining_Entity
(The_Unit
));
14971 end Is_RCI_Pkg_Decl_Cunit
;
14973 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
14976 return Is_RCI_Pkg_Decl_Cunit
(Cunit
)
14978 (Nkind
(Unit
(Cunit
)) = N_Package_Body
14979 and then Is_RCI_Pkg_Decl_Cunit
(Library_Unit
(Cunit
)));
14980 end Is_RCI_Pkg_Spec_Or_Body
;
14982 -----------------------------------------
14983 -- Is_Remote_Access_To_Class_Wide_Type --
14984 -----------------------------------------
14986 function Is_Remote_Access_To_Class_Wide_Type
14987 (E
: Entity_Id
) return Boolean
14990 -- A remote access to class-wide type is a general access to object type
14991 -- declared in the visible part of a Remote_Types or Remote_Call_
14994 return Ekind
(E
) = E_General_Access_Type
14995 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
14996 end Is_Remote_Access_To_Class_Wide_Type
;
14998 -----------------------------------------
14999 -- Is_Remote_Access_To_Subprogram_Type --
15000 -----------------------------------------
15002 function Is_Remote_Access_To_Subprogram_Type
15003 (E
: Entity_Id
) return Boolean
15006 return (Ekind
(E
) = E_Access_Subprogram_Type
15007 or else (Ekind
(E
) = E_Record_Type
15008 and then Present
(Corresponding_Remote_Type
(E
))))
15009 and then (Is_Remote_Call_Interface
(E
) or else Is_Remote_Types
(E
));
15010 end Is_Remote_Access_To_Subprogram_Type
;
15012 --------------------
15013 -- Is_Remote_Call --
15014 --------------------
15016 function Is_Remote_Call
(N
: Node_Id
) return Boolean is
15018 if Nkind
(N
) not in N_Subprogram_Call
then
15020 -- An entry call cannot be remote
15024 elsif Nkind
(Name
(N
)) in N_Has_Entity
15025 and then Is_Remote_Call_Interface
(Entity
(Name
(N
)))
15027 -- A subprogram declared in the spec of a RCI package is remote
15031 elsif Nkind
(Name
(N
)) = N_Explicit_Dereference
15032 and then Is_Remote_Access_To_Subprogram_Type
15033 (Etype
(Prefix
(Name
(N
))))
15035 -- The dereference of a RAS is a remote call
15039 elsif Present
(Controlling_Argument
(N
))
15040 and then Is_Remote_Access_To_Class_Wide_Type
15041 (Etype
(Controlling_Argument
(N
)))
15043 -- Any primitive operation call with a controlling argument of
15044 -- a RACW type is a remote call.
15049 -- All other calls are local calls
15052 end Is_Remote_Call
;
15054 ----------------------
15055 -- Is_Renamed_Entry --
15056 ----------------------
15058 function Is_Renamed_Entry
(Proc_Nam
: Entity_Id
) return Boolean is
15059 Orig_Node
: Node_Id
:= Empty
;
15060 Subp_Decl
: Node_Id
:= Parent
(Parent
(Proc_Nam
));
15062 function Is_Entry
(Nam
: Node_Id
) return Boolean;
15063 -- Determine whether Nam is an entry. Traverse selectors if there are
15064 -- nested selected components.
15070 function Is_Entry
(Nam
: Node_Id
) return Boolean is
15072 if Nkind
(Nam
) = N_Selected_Component
then
15073 return Is_Entry
(Selector_Name
(Nam
));
15076 return Ekind
(Entity
(Nam
)) = E_Entry
;
15079 -- Start of processing for Is_Renamed_Entry
15082 if Present
(Alias
(Proc_Nam
)) then
15083 Subp_Decl
:= Parent
(Parent
(Alias
(Proc_Nam
)));
15086 -- Look for a rewritten subprogram renaming declaration
15088 if Nkind
(Subp_Decl
) = N_Subprogram_Declaration
15089 and then Present
(Original_Node
(Subp_Decl
))
15091 Orig_Node
:= Original_Node
(Subp_Decl
);
15094 -- The rewritten subprogram is actually an entry
15096 if Present
(Orig_Node
)
15097 and then Nkind
(Orig_Node
) = N_Subprogram_Renaming_Declaration
15098 and then Is_Entry
(Name
(Orig_Node
))
15104 end Is_Renamed_Entry
;
15106 -----------------------------
15107 -- Is_Renaming_Declaration --
15108 -----------------------------
15110 function Is_Renaming_Declaration
(N
: Node_Id
) return Boolean is
15113 when N_Exception_Renaming_Declaration
15114 | N_Generic_Function_Renaming_Declaration
15115 | N_Generic_Package_Renaming_Declaration
15116 | N_Generic_Procedure_Renaming_Declaration
15117 | N_Object_Renaming_Declaration
15118 | N_Package_Renaming_Declaration
15119 | N_Subprogram_Renaming_Declaration
15126 end Is_Renaming_Declaration
;
15128 ----------------------------
15129 -- Is_Reversible_Iterator --
15130 ----------------------------
15132 function Is_Reversible_Iterator
(Typ
: Entity_Id
) return Boolean is
15133 Ifaces_List
: Elist_Id
;
15134 Iface_Elmt
: Elmt_Id
;
15138 if Is_Class_Wide_Type
(Typ
)
15139 and then Chars
(Root_Type
(Typ
)) = Name_Reversible_Iterator
15140 and then In_Predefined_Unit
(Root_Type
(Typ
))
15144 elsif not Is_Tagged_Type
(Typ
) or else not Is_Derived_Type
(Typ
) then
15148 Collect_Interfaces
(Typ
, Ifaces_List
);
15150 Iface_Elmt
:= First_Elmt
(Ifaces_List
);
15151 while Present
(Iface_Elmt
) loop
15152 Iface
:= Node
(Iface_Elmt
);
15153 if Chars
(Iface
) = Name_Reversible_Iterator
15154 and then In_Predefined_Unit
(Iface
)
15159 Next_Elmt
(Iface_Elmt
);
15164 end Is_Reversible_Iterator
;
15166 ----------------------
15167 -- Is_Selector_Name --
15168 ----------------------
15170 function Is_Selector_Name
(N
: Node_Id
) return Boolean is
15172 if not Is_List_Member
(N
) then
15174 P
: constant Node_Id
:= Parent
(N
);
15176 return Nkind_In
(P
, N_Expanded_Name
,
15177 N_Generic_Association
,
15178 N_Parameter_Association
,
15179 N_Selected_Component
)
15180 and then Selector_Name
(P
) = N
;
15185 L
: constant List_Id
:= List_Containing
(N
);
15186 P
: constant Node_Id
:= Parent
(L
);
15188 return (Nkind
(P
) = N_Discriminant_Association
15189 and then Selector_Names
(P
) = L
)
15191 (Nkind
(P
) = N_Component_Association
15192 and then Choices
(P
) = L
);
15195 end Is_Selector_Name
;
15197 ---------------------------------
15198 -- Is_Single_Concurrent_Object --
15199 ---------------------------------
15201 function Is_Single_Concurrent_Object
(Id
: Entity_Id
) return Boolean is
15204 Is_Single_Protected_Object
(Id
) or else Is_Single_Task_Object
(Id
);
15205 end Is_Single_Concurrent_Object
;
15207 -------------------------------
15208 -- Is_Single_Concurrent_Type --
15209 -------------------------------
15211 function Is_Single_Concurrent_Type
(Id
: Entity_Id
) return Boolean is
15214 Ekind_In
(Id
, E_Protected_Type
, E_Task_Type
)
15215 and then Is_Single_Concurrent_Type_Declaration
15216 (Declaration_Node
(Id
));
15217 end Is_Single_Concurrent_Type
;
15219 -------------------------------------------
15220 -- Is_Single_Concurrent_Type_Declaration --
15221 -------------------------------------------
15223 function Is_Single_Concurrent_Type_Declaration
15224 (N
: Node_Id
) return Boolean
15227 return Nkind_In
(Original_Node
(N
), N_Single_Protected_Declaration
,
15228 N_Single_Task_Declaration
);
15229 end Is_Single_Concurrent_Type_Declaration
;
15231 ---------------------------------------------
15232 -- Is_Single_Precision_Floating_Point_Type --
15233 ---------------------------------------------
15235 function Is_Single_Precision_Floating_Point_Type
15236 (E
: Entity_Id
) return Boolean is
15238 return Is_Floating_Point_Type
(E
)
15239 and then Machine_Radix_Value
(E
) = Uint_2
15240 and then Machine_Mantissa_Value
(E
) = Uint_24
15241 and then Machine_Emax_Value
(E
) = Uint_2
** Uint_7
15242 and then Machine_Emin_Value
(E
) = Uint_3
- (Uint_2
** Uint_7
);
15243 end Is_Single_Precision_Floating_Point_Type
;
15245 --------------------------------
15246 -- Is_Single_Protected_Object --
15247 --------------------------------
15249 function Is_Single_Protected_Object
(Id
: Entity_Id
) return Boolean is
15252 Ekind
(Id
) = E_Variable
15253 and then Ekind
(Etype
(Id
)) = E_Protected_Type
15254 and then Is_Single_Concurrent_Type
(Etype
(Id
));
15255 end Is_Single_Protected_Object
;
15257 ---------------------------
15258 -- Is_Single_Task_Object --
15259 ---------------------------
15261 function Is_Single_Task_Object
(Id
: Entity_Id
) return Boolean is
15264 Ekind
(Id
) = E_Variable
15265 and then Ekind
(Etype
(Id
)) = E_Task_Type
15266 and then Is_Single_Concurrent_Type
(Etype
(Id
));
15267 end Is_Single_Task_Object
;
15269 -------------------------------------
15270 -- Is_SPARK_05_Initialization_Expr --
15271 -------------------------------------
15273 function Is_SPARK_05_Initialization_Expr
(N
: Node_Id
) return Boolean is
15276 Comp_Assn
: Node_Id
;
15277 Orig_N
: constant Node_Id
:= Original_Node
(N
);
15282 if not Comes_From_Source
(Orig_N
) then
15286 pragma Assert
(Nkind
(Orig_N
) in N_Subexpr
);
15288 case Nkind
(Orig_N
) is
15289 when N_Character_Literal
15290 | N_Integer_Literal
15296 when N_Expanded_Name
15299 if Is_Entity_Name
(Orig_N
)
15300 and then Present
(Entity
(Orig_N
)) -- needed in some cases
15302 case Ekind
(Entity
(Orig_N
)) is
15304 | E_Enumeration_Literal
15311 if Is_Type
(Entity
(Orig_N
)) then
15319 when N_Qualified_Expression
15320 | N_Type_Conversion
15322 Is_Ok
:= Is_SPARK_05_Initialization_Expr
(Expression
(Orig_N
));
15325 Is_Ok
:= Is_SPARK_05_Initialization_Expr
(Right_Opnd
(Orig_N
));
15328 | N_Membership_Test
15331 Is_Ok
:= Is_SPARK_05_Initialization_Expr
(Left_Opnd
(Orig_N
))
15333 Is_SPARK_05_Initialization_Expr
(Right_Opnd
(Orig_N
));
15336 | N_Extension_Aggregate
15338 if Nkind
(Orig_N
) = N_Extension_Aggregate
then
15340 Is_SPARK_05_Initialization_Expr
(Ancestor_Part
(Orig_N
));
15343 Expr
:= First
(Expressions
(Orig_N
));
15344 while Present
(Expr
) loop
15345 if not Is_SPARK_05_Initialization_Expr
(Expr
) then
15353 Comp_Assn
:= First
(Component_Associations
(Orig_N
));
15354 while Present
(Comp_Assn
) loop
15355 Expr
:= Expression
(Comp_Assn
);
15357 -- Note: test for Present here needed for box assocation
15360 and then not Is_SPARK_05_Initialization_Expr
(Expr
)
15369 when N_Attribute_Reference
=>
15370 if Nkind
(Prefix
(Orig_N
)) in N_Subexpr
then
15371 Is_Ok
:= Is_SPARK_05_Initialization_Expr
(Prefix
(Orig_N
));
15374 Expr
:= First
(Expressions
(Orig_N
));
15375 while Present
(Expr
) loop
15376 if not Is_SPARK_05_Initialization_Expr
(Expr
) then
15384 -- Selected components might be expanded named not yet resolved, so
15385 -- default on the safe side. (Eg on sparklex.ads)
15387 when N_Selected_Component
=>
15396 end Is_SPARK_05_Initialization_Expr
;
15398 ----------------------------------
15399 -- Is_SPARK_05_Object_Reference --
15400 ----------------------------------
15402 function Is_SPARK_05_Object_Reference
(N
: Node_Id
) return Boolean is
15404 if Is_Entity_Name
(N
) then
15405 return Present
(Entity
(N
))
15407 (Ekind_In
(Entity
(N
), E_Constant
, E_Variable
)
15408 or else Ekind
(Entity
(N
)) in Formal_Kind
);
15412 when N_Selected_Component
=>
15413 return Is_SPARK_05_Object_Reference
(Prefix
(N
));
15419 end Is_SPARK_05_Object_Reference
;
15421 -----------------------------
15422 -- Is_Specific_Tagged_Type --
15423 -----------------------------
15425 function Is_Specific_Tagged_Type
(Typ
: Entity_Id
) return Boolean is
15426 Full_Typ
: Entity_Id
;
15429 -- Handle private types
15431 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
15432 Full_Typ
:= Full_View
(Typ
);
15437 -- A specific tagged type is a non-class-wide tagged type
15439 return Is_Tagged_Type
(Full_Typ
) and not Is_Class_Wide_Type
(Full_Typ
);
15440 end Is_Specific_Tagged_Type
;
15446 function Is_Statement
(N
: Node_Id
) return Boolean is
15449 Nkind
(N
) in N_Statement_Other_Than_Procedure_Call
15450 or else Nkind
(N
) = N_Procedure_Call_Statement
;
15453 ---------------------------------------
15454 -- Is_Subprogram_Contract_Annotation --
15455 ---------------------------------------
15457 function Is_Subprogram_Contract_Annotation
15458 (Item
: Node_Id
) return Boolean
15463 if Nkind
(Item
) = N_Aspect_Specification
then
15464 Nam
:= Chars
(Identifier
(Item
));
15466 else pragma Assert
(Nkind
(Item
) = N_Pragma
);
15467 Nam
:= Pragma_Name
(Item
);
15470 return Nam
= Name_Contract_Cases
15471 or else Nam
= Name_Depends
15472 or else Nam
= Name_Extensions_Visible
15473 or else Nam
= Name_Global
15474 or else Nam
= Name_Post
15475 or else Nam
= Name_Post_Class
15476 or else Nam
= Name_Postcondition
15477 or else Nam
= Name_Pre
15478 or else Nam
= Name_Pre_Class
15479 or else Nam
= Name_Precondition
15480 or else Nam
= Name_Refined_Depends
15481 or else Nam
= Name_Refined_Global
15482 or else Nam
= Name_Refined_Post
15483 or else Nam
= Name_Test_Case
;
15484 end Is_Subprogram_Contract_Annotation
;
15486 --------------------------------------------------
15487 -- Is_Subprogram_Stub_Without_Prior_Declaration --
15488 --------------------------------------------------
15490 function Is_Subprogram_Stub_Without_Prior_Declaration
15491 (N
: Node_Id
) return Boolean
15494 -- A subprogram stub without prior declaration serves as declaration for
15495 -- the actual subprogram body. As such, it has an attached defining
15496 -- entity of E_[Generic_]Function or E_[Generic_]Procedure.
15498 return Nkind
(N
) = N_Subprogram_Body_Stub
15499 and then Ekind
(Defining_Entity
(N
)) /= E_Subprogram_Body
;
15500 end Is_Subprogram_Stub_Without_Prior_Declaration
;
15502 --------------------------
15503 -- Is_Suspension_Object --
15504 --------------------------
15506 function Is_Suspension_Object
(Id
: Entity_Id
) return Boolean is
15508 -- This approach does an exact name match rather than to rely on
15509 -- RTSfind. Routine Is_Effectively_Volatile is used by clients of the
15510 -- front end at point where all auxiliary tables are locked and any
15511 -- modifications to them are treated as violations. Do not tamper with
15512 -- the tables, instead examine the Chars fields of all the scopes of Id.
15515 Chars
(Id
) = Name_Suspension_Object
15516 and then Present
(Scope
(Id
))
15517 and then Chars
(Scope
(Id
)) = Name_Synchronous_Task_Control
15518 and then Present
(Scope
(Scope
(Id
)))
15519 and then Chars
(Scope
(Scope
(Id
))) = Name_Ada
15520 and then Present
(Scope
(Scope
(Scope
(Id
))))
15521 and then Scope
(Scope
(Scope
(Id
))) = Standard_Standard
;
15522 end Is_Suspension_Object
;
15524 ----------------------------
15525 -- Is_Synchronized_Object --
15526 ----------------------------
15528 function Is_Synchronized_Object
(Id
: Entity_Id
) return Boolean is
15532 if Is_Object
(Id
) then
15534 -- The object is synchronized if it is of a type that yields a
15535 -- synchronized object.
15537 if Yields_Synchronized_Object
(Etype
(Id
)) then
15540 -- The object is synchronized if it is atomic and Async_Writers is
15543 elsif Is_Atomic
(Id
) and then Async_Writers_Enabled
(Id
) then
15546 -- A constant is a synchronized object by default
15548 elsif Ekind
(Id
) = E_Constant
then
15551 -- A variable is a synchronized object if it is subject to pragma
15552 -- Constant_After_Elaboration.
15554 elsif Ekind
(Id
) = E_Variable
then
15555 Prag
:= Get_Pragma
(Id
, Pragma_Constant_After_Elaboration
);
15557 return Present
(Prag
) and then Is_Enabled_Pragma
(Prag
);
15561 -- Otherwise the input is not an object or it does not qualify as a
15562 -- synchronized object.
15565 end Is_Synchronized_Object
;
15567 ---------------------------------
15568 -- Is_Synchronized_Tagged_Type --
15569 ---------------------------------
15571 function Is_Synchronized_Tagged_Type
(E
: Entity_Id
) return Boolean is
15572 Kind
: constant Entity_Kind
:= Ekind
(Base_Type
(E
));
15575 -- A task or protected type derived from an interface is a tagged type.
15576 -- Such a tagged type is called a synchronized tagged type, as are
15577 -- synchronized interfaces and private extensions whose declaration
15578 -- includes the reserved word synchronized.
15580 return (Is_Tagged_Type
(E
)
15581 and then (Kind
= E_Task_Type
15583 Kind
= E_Protected_Type
))
15586 and then Is_Synchronized_Interface
(E
))
15588 (Ekind
(E
) = E_Record_Type_With_Private
15589 and then Nkind
(Parent
(E
)) = N_Private_Extension_Declaration
15590 and then (Synchronized_Present
(Parent
(E
))
15591 or else Is_Synchronized_Interface
(Etype
(E
))));
15592 end Is_Synchronized_Tagged_Type
;
15598 function Is_Transfer
(N
: Node_Id
) return Boolean is
15599 Kind
: constant Node_Kind
:= Nkind
(N
);
15602 if Kind
= N_Simple_Return_Statement
15604 Kind
= N_Extended_Return_Statement
15606 Kind
= N_Goto_Statement
15608 Kind
= N_Raise_Statement
15610 Kind
= N_Requeue_Statement
15614 elsif (Kind
= N_Exit_Statement
or else Kind
in N_Raise_xxx_Error
)
15615 and then No
(Condition
(N
))
15619 elsif Kind
= N_Procedure_Call_Statement
15620 and then Is_Entity_Name
(Name
(N
))
15621 and then Present
(Entity
(Name
(N
)))
15622 and then No_Return
(Entity
(Name
(N
)))
15626 elsif Nkind
(Original_Node
(N
)) = N_Raise_Statement
then
15638 function Is_True
(U
: Uint
) return Boolean is
15643 --------------------------------------
15644 -- Is_Unchecked_Conversion_Instance --
15645 --------------------------------------
15647 function Is_Unchecked_Conversion_Instance
(Id
: Entity_Id
) return Boolean is
15651 -- Look for a function whose generic parent is the predefined intrinsic
15652 -- function Unchecked_Conversion, or for one that renames such an
15655 if Ekind
(Id
) = E_Function
then
15656 Par
:= Parent
(Id
);
15658 if Nkind
(Par
) = N_Function_Specification
then
15659 Par
:= Generic_Parent
(Par
);
15661 if Present
(Par
) then
15663 Chars
(Par
) = Name_Unchecked_Conversion
15664 and then Is_Intrinsic_Subprogram
(Par
)
15665 and then In_Predefined_Unit
(Par
);
15668 Present
(Alias
(Id
))
15669 and then Is_Unchecked_Conversion_Instance
(Alias
(Id
));
15675 end Is_Unchecked_Conversion_Instance
;
15677 -------------------------------
15678 -- Is_Universal_Numeric_Type --
15679 -------------------------------
15681 function Is_Universal_Numeric_Type
(T
: Entity_Id
) return Boolean is
15683 return T
= Universal_Integer
or else T
= Universal_Real
;
15684 end Is_Universal_Numeric_Type
;
15686 --------------------------------------
15687 -- Is_Validation_Variable_Reference --
15688 --------------------------------------
15690 function Is_Validation_Variable_Reference
(N
: Node_Id
) return Boolean is
15692 Var_Id
: Entity_Id
;
15697 -- Use the expression when the context qualifies a reference in some
15700 while Nkind_In
(Var
, N_Qualified_Expression
,
15702 N_Unchecked_Type_Conversion
)
15704 Var
:= Expression
(Var
);
15709 if Is_Entity_Name
(Var
) then
15710 Var_Id
:= Entity
(Var
);
15715 and then Ekind
(Var_Id
) = E_Variable
15716 and then Present
(Validated_Object
(Var_Id
));
15717 end Is_Validation_Variable_Reference
;
15719 ----------------------------
15720 -- Is_Variable_Size_Array --
15721 ----------------------------
15723 function Is_Variable_Size_Array
(E
: Entity_Id
) return Boolean is
15727 pragma Assert
(Is_Array_Type
(E
));
15729 -- Check if some index is initialized with a non-constant value
15731 Idx
:= First_Index
(E
);
15732 while Present
(Idx
) loop
15733 if Nkind
(Idx
) = N_Range
then
15734 if not Is_Constant_Bound
(Low_Bound
(Idx
))
15735 or else not Is_Constant_Bound
(High_Bound
(Idx
))
15741 Idx
:= Next_Index
(Idx
);
15745 end Is_Variable_Size_Array
;
15747 -----------------------------
15748 -- Is_Variable_Size_Record --
15749 -----------------------------
15751 function Is_Variable_Size_Record
(E
: Entity_Id
) return Boolean is
15753 Comp_Typ
: Entity_Id
;
15756 pragma Assert
(Is_Record_Type
(E
));
15758 Comp
:= First_Entity
(E
);
15759 while Present
(Comp
) loop
15760 Comp_Typ
:= Etype
(Comp
);
15762 -- Recursive call if the record type has discriminants
15764 if Is_Record_Type
(Comp_Typ
)
15765 and then Has_Discriminants
(Comp_Typ
)
15766 and then Is_Variable_Size_Record
(Comp_Typ
)
15770 elsif Is_Array_Type
(Comp_Typ
)
15771 and then Is_Variable_Size_Array
(Comp_Typ
)
15776 Next_Entity
(Comp
);
15780 end Is_Variable_Size_Record
;
15786 function Is_Variable
15788 Use_Original_Node
: Boolean := True) return Boolean
15790 Orig_Node
: Node_Id
;
15792 function In_Protected_Function
(E
: Entity_Id
) return Boolean;
15793 -- Within a protected function, the private components of the enclosing
15794 -- protected type are constants. A function nested within a (protected)
15795 -- procedure is not itself protected. Within the body of a protected
15796 -- function the current instance of the protected type is a constant.
15798 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean;
15799 -- Prefixes can involve implicit dereferences, in which case we must
15800 -- test for the case of a reference of a constant access type, which can
15801 -- can never be a variable.
15803 ---------------------------
15804 -- In_Protected_Function --
15805 ---------------------------
15807 function In_Protected_Function
(E
: Entity_Id
) return Boolean is
15812 -- E is the current instance of a type
15814 if Is_Type
(E
) then
15823 if not Is_Protected_Type
(Prot
) then
15827 S
:= Current_Scope
;
15828 while Present
(S
) and then S
/= Prot
loop
15829 if Ekind
(S
) = E_Function
and then Scope
(S
) = Prot
then
15838 end In_Protected_Function
;
15840 ------------------------
15841 -- Is_Variable_Prefix --
15842 ------------------------
15844 function Is_Variable_Prefix
(P
: Node_Id
) return Boolean is
15846 if Is_Access_Type
(Etype
(P
)) then
15847 return not Is_Access_Constant
(Root_Type
(Etype
(P
)));
15849 -- For the case of an indexed component whose prefix has a packed
15850 -- array type, the prefix has been rewritten into a type conversion.
15851 -- Determine variable-ness from the converted expression.
15853 elsif Nkind
(P
) = N_Type_Conversion
15854 and then not Comes_From_Source
(P
)
15855 and then Is_Array_Type
(Etype
(P
))
15856 and then Is_Packed
(Etype
(P
))
15858 return Is_Variable
(Expression
(P
));
15861 return Is_Variable
(P
);
15863 end Is_Variable_Prefix
;
15865 -- Start of processing for Is_Variable
15868 -- Special check, allow x'Deref(expr) as a variable
15870 if Nkind
(N
) = N_Attribute_Reference
15871 and then Attribute_Name
(N
) = Name_Deref
15876 -- Check if we perform the test on the original node since this may be a
15877 -- test of syntactic categories which must not be disturbed by whatever
15878 -- rewriting might have occurred. For example, an aggregate, which is
15879 -- certainly NOT a variable, could be turned into a variable by
15882 if Use_Original_Node
then
15883 Orig_Node
:= Original_Node
(N
);
15888 -- Definitely OK if Assignment_OK is set. Since this is something that
15889 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
15891 if Nkind
(N
) in N_Subexpr
and then Assignment_OK
(N
) then
15894 -- Normally we go to the original node, but there is one exception where
15895 -- we use the rewritten node, namely when it is an explicit dereference.
15896 -- The generated code may rewrite a prefix which is an access type with
15897 -- an explicit dereference. The dereference is a variable, even though
15898 -- the original node may not be (since it could be a constant of the
15901 -- In Ada 2005 we have a further case to consider: the prefix may be a
15902 -- function call given in prefix notation. The original node appears to
15903 -- be a selected component, but we need to examine the call.
15905 elsif Nkind
(N
) = N_Explicit_Dereference
15906 and then Nkind
(Orig_Node
) /= N_Explicit_Dereference
15907 and then Present
(Etype
(Orig_Node
))
15908 and then Is_Access_Type
(Etype
(Orig_Node
))
15910 -- Note that if the prefix is an explicit dereference that does not
15911 -- come from source, we must check for a rewritten function call in
15912 -- prefixed notation before other forms of rewriting, to prevent a
15916 (Nkind
(Orig_Node
) = N_Function_Call
15917 and then not Is_Access_Constant
(Etype
(Prefix
(N
))))
15919 Is_Variable_Prefix
(Original_Node
(Prefix
(N
)));
15921 -- in Ada 2012, the dereference may have been added for a type with
15922 -- a declared implicit dereference aspect. Check that it is not an
15923 -- access to constant.
15925 elsif Nkind
(N
) = N_Explicit_Dereference
15926 and then Present
(Etype
(Orig_Node
))
15927 and then Ada_Version
>= Ada_2012
15928 and then Has_Implicit_Dereference
(Etype
(Orig_Node
))
15930 return not Is_Access_Constant
(Etype
(Prefix
(N
)));
15932 -- A function call is never a variable
15934 elsif Nkind
(N
) = N_Function_Call
then
15937 -- All remaining checks use the original node
15939 elsif Is_Entity_Name
(Orig_Node
)
15940 and then Present
(Entity
(Orig_Node
))
15943 E
: constant Entity_Id
:= Entity
(Orig_Node
);
15944 K
: constant Entity_Kind
:= Ekind
(E
);
15947 return (K
= E_Variable
15948 and then Nkind
(Parent
(E
)) /= N_Exception_Handler
)
15949 or else (K
= E_Component
15950 and then not In_Protected_Function
(E
))
15951 or else K
= E_Out_Parameter
15952 or else K
= E_In_Out_Parameter
15953 or else K
= E_Generic_In_Out_Parameter
15955 -- Current instance of type. If this is a protected type, check
15956 -- we are not within the body of one of its protected functions.
15958 or else (Is_Type
(E
)
15959 and then In_Open_Scopes
(E
)
15960 and then not In_Protected_Function
(E
))
15962 or else (Is_Incomplete_Or_Private_Type
(E
)
15963 and then In_Open_Scopes
(Full_View
(E
)));
15967 case Nkind
(Orig_Node
) is
15968 when N_Indexed_Component
15971 return Is_Variable_Prefix
(Prefix
(Orig_Node
));
15973 when N_Selected_Component
=>
15974 return (Is_Variable
(Selector_Name
(Orig_Node
))
15975 and then Is_Variable_Prefix
(Prefix
(Orig_Node
)))
15977 (Nkind
(N
) = N_Expanded_Name
15978 and then Scope
(Entity
(N
)) = Entity
(Prefix
(N
)));
15980 -- For an explicit dereference, the type of the prefix cannot
15981 -- be an access to constant or an access to subprogram.
15983 when N_Explicit_Dereference
=>
15985 Typ
: constant Entity_Id
:= Etype
(Prefix
(Orig_Node
));
15987 return Is_Access_Type
(Typ
)
15988 and then not Is_Access_Constant
(Root_Type
(Typ
))
15989 and then Ekind
(Typ
) /= E_Access_Subprogram_Type
;
15992 -- The type conversion is the case where we do not deal with the
15993 -- context dependent special case of an actual parameter. Thus
15994 -- the type conversion is only considered a variable for the
15995 -- purposes of this routine if the target type is tagged. However,
15996 -- a type conversion is considered to be a variable if it does not
15997 -- come from source (this deals for example with the conversions
15998 -- of expressions to their actual subtypes).
16000 when N_Type_Conversion
=>
16001 return Is_Variable
(Expression
(Orig_Node
))
16003 (not Comes_From_Source
(Orig_Node
)
16005 (Is_Tagged_Type
(Etype
(Subtype_Mark
(Orig_Node
)))
16007 Is_Tagged_Type
(Etype
(Expression
(Orig_Node
)))));
16009 -- GNAT allows an unchecked type conversion as a variable. This
16010 -- only affects the generation of internal expanded code, since
16011 -- calls to instantiations of Unchecked_Conversion are never
16012 -- considered variables (since they are function calls).
16014 when N_Unchecked_Type_Conversion
=>
16015 return Is_Variable
(Expression
(Orig_Node
));
16023 ------------------------------
16024 -- Is_Verifiable_DIC_Pragma --
16025 ------------------------------
16027 function Is_Verifiable_DIC_Pragma
(Prag
: Node_Id
) return Boolean is
16028 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
16031 -- To qualify as verifiable, a DIC pragma must have a non-null argument
16035 and then Nkind
(Get_Pragma_Arg
(First
(Args
))) /= N_Null
;
16036 end Is_Verifiable_DIC_Pragma
;
16038 ---------------------------
16039 -- Is_Visibly_Controlled --
16040 ---------------------------
16042 function Is_Visibly_Controlled
(T
: Entity_Id
) return Boolean is
16043 Root
: constant Entity_Id
:= Root_Type
(T
);
16045 return Chars
(Scope
(Root
)) = Name_Finalization
16046 and then Chars
(Scope
(Scope
(Root
))) = Name_Ada
16047 and then Scope
(Scope
(Scope
(Root
))) = Standard_Standard
;
16048 end Is_Visibly_Controlled
;
16050 --------------------------
16051 -- Is_Volatile_Function --
16052 --------------------------
16054 function Is_Volatile_Function
(Func_Id
: Entity_Id
) return Boolean is
16056 pragma Assert
(Ekind_In
(Func_Id
, E_Function
, E_Generic_Function
));
16058 -- A function declared within a protected type is volatile
16060 if Is_Protected_Type
(Scope
(Func_Id
)) then
16063 -- An instance of Ada.Unchecked_Conversion is a volatile function if
16064 -- either the source or the target are effectively volatile.
16066 elsif Is_Unchecked_Conversion_Instance
(Func_Id
)
16067 and then Has_Effectively_Volatile_Profile
(Func_Id
)
16071 -- Otherwise the function is treated as volatile if it is subject to
16072 -- enabled pragma Volatile_Function.
16076 Is_Enabled_Pragma
(Get_Pragma
(Func_Id
, Pragma_Volatile_Function
));
16078 end Is_Volatile_Function
;
16080 ------------------------
16081 -- Is_Volatile_Object --
16082 ------------------------
16084 function Is_Volatile_Object
(N
: Node_Id
) return Boolean is
16085 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean;
16086 -- If prefix is an implicit dereference, examine designated type
16088 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean;
16089 -- Determines if given object has volatile components
16091 ------------------------
16092 -- Is_Volatile_Prefix --
16093 ------------------------
16095 function Is_Volatile_Prefix
(N
: Node_Id
) return Boolean is
16096 Typ
: constant Entity_Id
:= Etype
(N
);
16099 if Is_Access_Type
(Typ
) then
16101 Dtyp
: constant Entity_Id
:= Designated_Type
(Typ
);
16104 return Is_Volatile
(Dtyp
)
16105 or else Has_Volatile_Components
(Dtyp
);
16109 return Object_Has_Volatile_Components
(N
);
16111 end Is_Volatile_Prefix
;
16113 ------------------------------------
16114 -- Object_Has_Volatile_Components --
16115 ------------------------------------
16117 function Object_Has_Volatile_Components
(N
: Node_Id
) return Boolean is
16118 Typ
: constant Entity_Id
:= Etype
(N
);
16121 if Is_Volatile
(Typ
)
16122 or else Has_Volatile_Components
(Typ
)
16126 elsif Is_Entity_Name
(N
)
16127 and then (Has_Volatile_Components
(Entity
(N
))
16128 or else Is_Volatile
(Entity
(N
)))
16132 elsif Nkind
(N
) = N_Indexed_Component
16133 or else Nkind
(N
) = N_Selected_Component
16135 return Is_Volatile_Prefix
(Prefix
(N
));
16140 end Object_Has_Volatile_Components
;
16142 -- Start of processing for Is_Volatile_Object
16145 if Nkind
(N
) = N_Defining_Identifier
then
16146 return Is_Volatile
(N
) or else Is_Volatile
(Etype
(N
));
16148 elsif Nkind
(N
) = N_Expanded_Name
then
16149 return Is_Volatile_Object
(Entity
(N
));
16151 elsif Is_Volatile
(Etype
(N
))
16152 or else (Is_Entity_Name
(N
) and then Is_Volatile
(Entity
(N
)))
16156 elsif Nkind_In
(N
, N_Indexed_Component
, N_Selected_Component
)
16157 and then Is_Volatile_Prefix
(Prefix
(N
))
16161 elsif Nkind
(N
) = N_Selected_Component
16162 and then Is_Volatile
(Entity
(Selector_Name
(N
)))
16169 end Is_Volatile_Object
;
16171 ---------------------------
16172 -- Itype_Has_Declaration --
16173 ---------------------------
16175 function Itype_Has_Declaration
(Id
: Entity_Id
) return Boolean is
16177 pragma Assert
(Is_Itype
(Id
));
16178 return Present
(Parent
(Id
))
16179 and then Nkind_In
(Parent
(Id
), N_Full_Type_Declaration
,
16180 N_Subtype_Declaration
)
16181 and then Defining_Entity
(Parent
(Id
)) = Id
;
16182 end Itype_Has_Declaration
;
16184 -------------------------
16185 -- Kill_Current_Values --
16186 -------------------------
16188 procedure Kill_Current_Values
16190 Last_Assignment_Only
: Boolean := False)
16193 if Is_Assignable
(Ent
) then
16194 Set_Last_Assignment
(Ent
, Empty
);
16197 if Is_Object
(Ent
) then
16198 if not Last_Assignment_Only
then
16200 Set_Current_Value
(Ent
, Empty
);
16202 -- Do not reset the Is_Known_[Non_]Null and Is_Known_Valid flags
16203 -- for a constant. Once the constant is elaborated, its value is
16204 -- not changed, therefore the associated flags that describe the
16205 -- value should not be modified either.
16207 if Ekind
(Ent
) = E_Constant
then
16210 -- Non-constant entities
16213 if not Can_Never_Be_Null
(Ent
) then
16214 Set_Is_Known_Non_Null
(Ent
, False);
16217 Set_Is_Known_Null
(Ent
, False);
16219 -- Reset the Is_Known_Valid flag unless the type is always
16220 -- valid. This does not apply to a loop parameter because its
16221 -- bounds are defined by the loop header and therefore always
16224 if not Is_Known_Valid
(Etype
(Ent
))
16225 and then Ekind
(Ent
) /= E_Loop_Parameter
16227 Set_Is_Known_Valid
(Ent
, False);
16232 end Kill_Current_Values
;
16234 procedure Kill_Current_Values
(Last_Assignment_Only
: Boolean := False) is
16237 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
);
16238 -- Clear current value for entity E and all entities chained to E
16240 ------------------------------------------
16241 -- Kill_Current_Values_For_Entity_Chain --
16242 ------------------------------------------
16244 procedure Kill_Current_Values_For_Entity_Chain
(E
: Entity_Id
) is
16248 while Present
(Ent
) loop
16249 Kill_Current_Values
(Ent
, Last_Assignment_Only
);
16252 end Kill_Current_Values_For_Entity_Chain
;
16254 -- Start of processing for Kill_Current_Values
16257 -- Kill all saved checks, a special case of killing saved values
16259 if not Last_Assignment_Only
then
16263 -- Loop through relevant scopes, which includes the current scope and
16264 -- any parent scopes if the current scope is a block or a package.
16266 S
:= Current_Scope
;
16269 -- Clear current values of all entities in current scope
16271 Kill_Current_Values_For_Entity_Chain
(First_Entity
(S
));
16273 -- If scope is a package, also clear current values of all private
16274 -- entities in the scope.
16276 if Is_Package_Or_Generic_Package
(S
)
16277 or else Is_Concurrent_Type
(S
)
16279 Kill_Current_Values_For_Entity_Chain
(First_Private_Entity
(S
));
16282 -- If this is a not a subprogram, deal with parents
16284 if not Is_Subprogram
(S
) then
16286 exit Scope_Loop
when S
= Standard_Standard
;
16290 end loop Scope_Loop
;
16291 end Kill_Current_Values
;
16293 --------------------------
16294 -- Kill_Size_Check_Code --
16295 --------------------------
16297 procedure Kill_Size_Check_Code
(E
: Entity_Id
) is
16299 if (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
16300 and then Present
(Size_Check_Code
(E
))
16302 Remove
(Size_Check_Code
(E
));
16303 Set_Size_Check_Code
(E
, Empty
);
16305 end Kill_Size_Check_Code
;
16307 --------------------
16308 -- Known_Non_Null --
16309 --------------------
16311 function Known_Non_Null
(N
: Node_Id
) return Boolean is
16312 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
16319 -- The expression yields a non-null value ignoring simple flow analysis
16321 if Status
= Is_Non_Null
then
16324 -- Otherwise check whether N is a reference to an entity that appears
16325 -- within a conditional construct.
16327 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
16329 -- First check if we are in decisive conditional
16331 Get_Current_Value_Condition
(N
, Op
, Val
);
16333 if Known_Null
(Val
) then
16334 if Op
= N_Op_Eq
then
16336 elsif Op
= N_Op_Ne
then
16341 -- If OK to do replacement, test Is_Known_Non_Null flag
16345 if OK_To_Do_Constant_Replacement
(Id
) then
16346 return Is_Known_Non_Null
(Id
);
16350 -- Otherwise it is not possible to determine whether N yields a non-null
16354 end Known_Non_Null
;
16360 function Known_Null
(N
: Node_Id
) return Boolean is
16361 Status
: constant Null_Status_Kind
:= Null_Status
(N
);
16368 -- The expression yields a null value ignoring simple flow analysis
16370 if Status
= Is_Null
then
16373 -- Otherwise check whether N is a reference to an entity that appears
16374 -- within a conditional construct.
16376 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
16378 -- First check if we are in decisive conditional
16380 Get_Current_Value_Condition
(N
, Op
, Val
);
16382 if Known_Null
(Val
) then
16383 if Op
= N_Op_Eq
then
16385 elsif Op
= N_Op_Ne
then
16390 -- If OK to do replacement, test Is_Known_Null flag
16394 if OK_To_Do_Constant_Replacement
(Id
) then
16395 return Is_Known_Null
(Id
);
16399 -- Otherwise it is not possible to determine whether N yields a null
16405 --------------------------
16406 -- Known_To_Be_Assigned --
16407 --------------------------
16409 function Known_To_Be_Assigned
(N
: Node_Id
) return Boolean is
16410 P
: constant Node_Id
:= Parent
(N
);
16415 -- Test left side of assignment
16417 when N_Assignment_Statement
=>
16418 return N
= Name
(P
);
16420 -- Function call arguments are never lvalues
16422 when N_Function_Call
=>
16425 -- Positional parameter for procedure or accept call
16427 when N_Accept_Statement
16428 | N_Procedure_Call_Statement
16436 Proc
:= Get_Subprogram_Entity
(P
);
16442 -- If we are not a list member, something is strange, so
16443 -- be conservative and return False.
16445 if not Is_List_Member
(N
) then
16449 -- We are going to find the right formal by stepping forward
16450 -- through the formals, as we step backwards in the actuals.
16452 Form
:= First_Formal
(Proc
);
16455 -- If no formal, something is weird, so be conservative
16456 -- and return False.
16463 exit when No
(Act
);
16464 Next_Formal
(Form
);
16467 return Ekind
(Form
) /= E_In_Parameter
;
16470 -- Named parameter for procedure or accept call
16472 when N_Parameter_Association
=>
16478 Proc
:= Get_Subprogram_Entity
(Parent
(P
));
16484 -- Loop through formals to find the one that matches
16486 Form
:= First_Formal
(Proc
);
16488 -- If no matching formal, that's peculiar, some kind of
16489 -- previous error, so return False to be conservative.
16490 -- Actually this also happens in legal code in the case
16491 -- where P is a parameter association for an Extra_Formal???
16497 -- Else test for match
16499 if Chars
(Form
) = Chars
(Selector_Name
(P
)) then
16500 return Ekind
(Form
) /= E_In_Parameter
;
16503 Next_Formal
(Form
);
16507 -- Test for appearing in a conversion that itself appears
16508 -- in an lvalue context, since this should be an lvalue.
16510 when N_Type_Conversion
=>
16511 return Known_To_Be_Assigned
(P
);
16513 -- All other references are definitely not known to be modifications
16518 end Known_To_Be_Assigned
;
16520 ---------------------------
16521 -- Last_Source_Statement --
16522 ---------------------------
16524 function Last_Source_Statement
(HSS
: Node_Id
) return Node_Id
is
16528 N
:= Last
(Statements
(HSS
));
16529 while Present
(N
) loop
16530 exit when Comes_From_Source
(N
);
16535 end Last_Source_Statement
;
16537 ----------------------------------
16538 -- Matching_Static_Array_Bounds --
16539 ----------------------------------
16541 function Matching_Static_Array_Bounds
16543 R_Typ
: Node_Id
) return Boolean
16545 L_Ndims
: constant Nat
:= Number_Dimensions
(L_Typ
);
16546 R_Ndims
: constant Nat
:= Number_Dimensions
(R_Typ
);
16558 if L_Ndims
/= R_Ndims
then
16562 -- Unconstrained types do not have static bounds
16564 if not Is_Constrained
(L_Typ
) or else not Is_Constrained
(R_Typ
) then
16568 -- First treat specially the first dimension, as the lower bound and
16569 -- length of string literals are not stored like those of arrays.
16571 if Ekind
(L_Typ
) = E_String_Literal_Subtype
then
16572 L_Low
:= String_Literal_Low_Bound
(L_Typ
);
16573 L_Len
:= String_Literal_Length
(L_Typ
);
16575 L_Index
:= First_Index
(L_Typ
);
16576 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
16578 if Is_OK_Static_Expression
(L_Low
)
16580 Is_OK_Static_Expression
(L_High
)
16582 if Expr_Value
(L_High
) < Expr_Value
(L_Low
) then
16585 L_Len
:= (Expr_Value
(L_High
) - Expr_Value
(L_Low
)) + 1;
16592 if Ekind
(R_Typ
) = E_String_Literal_Subtype
then
16593 R_Low
:= String_Literal_Low_Bound
(R_Typ
);
16594 R_Len
:= String_Literal_Length
(R_Typ
);
16596 R_Index
:= First_Index
(R_Typ
);
16597 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
16599 if Is_OK_Static_Expression
(R_Low
)
16601 Is_OK_Static_Expression
(R_High
)
16603 if Expr_Value
(R_High
) < Expr_Value
(R_Low
) then
16606 R_Len
:= (Expr_Value
(R_High
) - Expr_Value
(R_Low
)) + 1;
16613 if (Is_OK_Static_Expression
(L_Low
)
16615 Is_OK_Static_Expression
(R_Low
))
16616 and then Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
16617 and then L_Len
= R_Len
16624 -- Then treat all other dimensions
16626 for Indx
in 2 .. L_Ndims
loop
16630 Get_Index_Bounds
(L_Index
, L_Low
, L_High
);
16631 Get_Index_Bounds
(R_Index
, R_Low
, R_High
);
16633 if (Is_OK_Static_Expression
(L_Low
) and then
16634 Is_OK_Static_Expression
(L_High
) and then
16635 Is_OK_Static_Expression
(R_Low
) and then
16636 Is_OK_Static_Expression
(R_High
))
16637 and then (Expr_Value
(L_Low
) = Expr_Value
(R_Low
)
16639 Expr_Value
(L_High
) = Expr_Value
(R_High
))
16647 -- If we fall through the loop, all indexes matched
16650 end Matching_Static_Array_Bounds
;
16652 -------------------
16653 -- May_Be_Lvalue --
16654 -------------------
16656 function May_Be_Lvalue
(N
: Node_Id
) return Boolean is
16657 P
: constant Node_Id
:= Parent
(N
);
16662 -- Test left side of assignment
16664 when N_Assignment_Statement
=>
16665 return N
= Name
(P
);
16667 -- Test prefix of component or attribute. Note that the prefix of an
16668 -- explicit or implicit dereference cannot be an l-value. In the case
16669 -- of a 'Read attribute, the reference can be an actual in the
16670 -- argument list of the attribute.
16672 when N_Attribute_Reference
=>
16673 return (N
= Prefix
(P
)
16674 and then Name_Implies_Lvalue_Prefix
(Attribute_Name
(P
)))
16676 Attribute_Name
(P
) = Name_Read
;
16678 -- For an expanded name, the name is an lvalue if the expanded name
16679 -- is an lvalue, but the prefix is never an lvalue, since it is just
16680 -- the scope where the name is found.
16682 when N_Expanded_Name
=>
16683 if N
= Prefix
(P
) then
16684 return May_Be_Lvalue
(P
);
16689 -- For a selected component A.B, A is certainly an lvalue if A.B is.
16690 -- B is a little interesting, if we have A.B := 3, there is some
16691 -- discussion as to whether B is an lvalue or not, we choose to say
16692 -- it is. Note however that A is not an lvalue if it is of an access
16693 -- type since this is an implicit dereference.
16695 when N_Selected_Component
=>
16697 and then Present
(Etype
(N
))
16698 and then Is_Access_Type
(Etype
(N
))
16702 return May_Be_Lvalue
(P
);
16705 -- For an indexed component or slice, the index or slice bounds is
16706 -- never an lvalue. The prefix is an lvalue if the indexed component
16707 -- or slice is an lvalue, except if it is an access type, where we
16708 -- have an implicit dereference.
16710 when N_Indexed_Component
16714 or else (Present
(Etype
(N
)) and then Is_Access_Type
(Etype
(N
)))
16718 return May_Be_Lvalue
(P
);
16721 -- Prefix of a reference is an lvalue if the reference is an lvalue
16723 when N_Reference
=>
16724 return May_Be_Lvalue
(P
);
16726 -- Prefix of explicit dereference is never an lvalue
16728 when N_Explicit_Dereference
=>
16731 -- Positional parameter for subprogram, entry, or accept call.
16732 -- In older versions of Ada function call arguments are never
16733 -- lvalues. In Ada 2012 functions can have in-out parameters.
16735 when N_Accept_Statement
16736 | N_Entry_Call_Statement
16737 | N_Subprogram_Call
16739 if Nkind
(P
) = N_Function_Call
and then Ada_Version
< Ada_2012
then
16743 -- The following mechanism is clumsy and fragile. A single flag
16744 -- set in Resolve_Actuals would be preferable ???
16752 Proc
:= Get_Subprogram_Entity
(P
);
16758 -- If we are not a list member, something is strange, so be
16759 -- conservative and return True.
16761 if not Is_List_Member
(N
) then
16765 -- We are going to find the right formal by stepping forward
16766 -- through the formals, as we step backwards in the actuals.
16768 Form
:= First_Formal
(Proc
);
16771 -- If no formal, something is weird, so be conservative and
16779 exit when No
(Act
);
16780 Next_Formal
(Form
);
16783 return Ekind
(Form
) /= E_In_Parameter
;
16786 -- Named parameter for procedure or accept call
16788 when N_Parameter_Association
=>
16794 Proc
:= Get_Subprogram_Entity
(Parent
(P
));
16800 -- Loop through formals to find the one that matches
16802 Form
:= First_Formal
(Proc
);
16804 -- If no matching formal, that's peculiar, some kind of
16805 -- previous error, so return True to be conservative.
16806 -- Actually happens with legal code for an unresolved call
16807 -- where we may get the wrong homonym???
16813 -- Else test for match
16815 if Chars
(Form
) = Chars
(Selector_Name
(P
)) then
16816 return Ekind
(Form
) /= E_In_Parameter
;
16819 Next_Formal
(Form
);
16823 -- Test for appearing in a conversion that itself appears in an
16824 -- lvalue context, since this should be an lvalue.
16826 when N_Type_Conversion
=>
16827 return May_Be_Lvalue
(P
);
16829 -- Test for appearance in object renaming declaration
16831 when N_Object_Renaming_Declaration
=>
16834 -- All other references are definitely not lvalues
16841 -----------------------
16842 -- Mark_Coextensions --
16843 -----------------------
16845 procedure Mark_Coextensions
(Context_Nod
: Node_Id
; Root_Nod
: Node_Id
) is
16846 Is_Dynamic
: Boolean;
16847 -- Indicates whether the context causes nested coextensions to be
16848 -- dynamic or static
16850 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
;
16851 -- Recognize an allocator node and label it as a dynamic coextension
16853 --------------------
16854 -- Mark_Allocator --
16855 --------------------
16857 function Mark_Allocator
(N
: Node_Id
) return Traverse_Result
is
16859 if Nkind
(N
) = N_Allocator
then
16861 Set_Is_Dynamic_Coextension
(N
);
16863 -- If the allocator expression is potentially dynamic, it may
16864 -- be expanded out of order and require dynamic allocation
16865 -- anyway, so we treat the coextension itself as dynamic.
16866 -- Potential optimization ???
16868 elsif Nkind
(Expression
(N
)) = N_Qualified_Expression
16869 and then Nkind
(Expression
(Expression
(N
))) = N_Op_Concat
16871 Set_Is_Dynamic_Coextension
(N
);
16873 Set_Is_Static_Coextension
(N
);
16878 end Mark_Allocator
;
16880 procedure Mark_Allocators
is new Traverse_Proc
(Mark_Allocator
);
16882 -- Start of processing for Mark_Coextensions
16885 -- An allocator that appears on the right-hand side of an assignment is
16886 -- treated as a potentially dynamic coextension when the right-hand side
16887 -- is an allocator or a qualified expression.
16889 -- Obj := new ...'(new Coextension ...);
16891 if Nkind
(Context_Nod
) = N_Assignment_Statement
then
16893 Nkind_In
(Expression
(Context_Nod
), N_Allocator
,
16894 N_Qualified_Expression
);
16896 -- An allocator that appears within the expression of a simple return
16897 -- statement is treated as a potentially dynamic coextension when the
16898 -- expression is either aggregate, allocator, or qualified expression.
16900 -- return (new Coextension ...);
16901 -- return new ...'(new Coextension ...);
16903 elsif Nkind
(Context_Nod
) = N_Simple_Return_Statement
then
16905 Nkind_In
(Expression
(Context_Nod
), N_Aggregate
,
16907 N_Qualified_Expression
);
16909 -- An allocator that appears within the initialization expression of an
16910 -- object declaration is considered a potentially dynamic coextension
16911 -- when the initialization expression is an allocator or a qualified
16914 -- Obj : ... := new ...'(new Coextension ...);
16916 -- A similar case arises when the object declaration is part of an
16917 -- extended return statement.
16919 -- return Obj : ... := new ...'(new Coextension ...);
16920 -- return Obj : ... := (new Coextension ...);
16922 elsif Nkind
(Context_Nod
) = N_Object_Declaration
then
16924 Nkind_In
(Root_Nod
, N_Allocator
, N_Qualified_Expression
)
16926 Nkind
(Parent
(Context_Nod
)) = N_Extended_Return_Statement
;
16928 -- This routine should not be called with constructs that cannot contain
16932 raise Program_Error
;
16935 Mark_Allocators
(Root_Nod
);
16936 end Mark_Coextensions
;
16942 function Might_Raise
(N
: Node_Id
) return Boolean is
16943 Result
: Boolean := False;
16945 function Process
(N
: Node_Id
) return Traverse_Result
;
16946 -- Set Result to True if we find something that could raise an exception
16952 function Process
(N
: Node_Id
) return Traverse_Result
is
16954 if Nkind_In
(N
, N_Procedure_Call_Statement
,
16957 N_Raise_Constraint_Error
,
16958 N_Raise_Program_Error
,
16959 N_Raise_Storage_Error
)
16968 procedure Set_Result
is new Traverse_Proc
(Process
);
16970 -- Start of processing for Might_Raise
16973 -- False if exceptions can't be propagated
16975 if No_Exception_Handlers_Set
then
16979 -- If the checks handled by the back end are not disabled, we cannot
16980 -- ensure that no exception will be raised.
16982 if not Access_Checks_Suppressed
(Empty
)
16983 or else not Discriminant_Checks_Suppressed
(Empty
)
16984 or else not Range_Checks_Suppressed
(Empty
)
16985 or else not Index_Checks_Suppressed
(Empty
)
16986 or else Opt
.Stack_Checking_Enabled
16995 --------------------------------
16996 -- Nearest_Enclosing_Instance --
16997 --------------------------------
16999 function Nearest_Enclosing_Instance
(E
: Entity_Id
) return Entity_Id
is
17004 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
17005 if Is_Generic_Instance
(Inst
) then
17009 Inst
:= Scope
(Inst
);
17013 end Nearest_Enclosing_Instance
;
17015 ----------------------
17016 -- Needs_One_Actual --
17017 ----------------------
17019 function Needs_One_Actual
(E
: Entity_Id
) return Boolean is
17020 Formal
: Entity_Id
;
17023 -- Ada 2005 or later, and formals present
17025 if Ada_Version
>= Ada_2005
17026 and then Present
(First_Formal
(E
))
17027 and then No
(Default_Value
(First_Formal
(E
)))
17029 Formal
:= Next_Formal
(First_Formal
(E
));
17030 while Present
(Formal
) loop
17031 if No
(Default_Value
(Formal
)) then
17035 Next_Formal
(Formal
);
17040 -- Ada 83/95 or no formals
17045 end Needs_One_Actual
;
17047 ------------------------
17048 -- New_Copy_List_Tree --
17049 ------------------------
17051 function New_Copy_List_Tree
(List
: List_Id
) return List_Id
is
17056 if List
= No_List
then
17063 while Present
(E
) loop
17064 Append
(New_Copy_Tree
(E
), NL
);
17070 end New_Copy_List_Tree
;
17072 --------------------------------------------------
17073 -- New_Copy_Tree Auxiliary Data and Subprograms --
17074 --------------------------------------------------
17076 use Atree
.Unchecked_Access
;
17077 use Atree_Private_Part
;
17079 -- Our approach here requires a two pass traversal of the tree. The
17080 -- first pass visits all nodes that eventually will be copied looking
17081 -- for defining Itypes. If any defining Itypes are found, then they are
17082 -- copied, and an entry is added to the replacement map. In the second
17083 -- phase, the tree is copied, using the replacement map to replace any
17084 -- Itype references within the copied tree.
17086 -- The following hash tables are used to speed up access to the map. They
17087 -- are declared at library level to avoid elaborating them for every call
17088 -- to New_Copy_Tree. This can save up to 2% of the entire compilation time
17089 -- spent in the front end.
17091 subtype NCT_Header_Num
is Int
range 0 .. 511;
17092 -- Defines range of headers in hash tables (512 headers)
17094 function New_Copy_Hash
(E
: Entity_Id
) return NCT_Header_Num
;
17095 -- Hash function used for hash operations
17097 -------------------
17098 -- New_Copy_Hash --
17099 -------------------
17101 function New_Copy_Hash
(E
: Entity_Id
) return NCT_Header_Num
is
17103 return Nat
(E
) mod (NCT_Header_Num
'Last + 1);
17110 -- The hash table NCT_Assoc associates old entities in the table with their
17111 -- corresponding new entities (i.e. the pairs of entries presented in the
17112 -- original Map argument are Key-Element pairs).
17114 package NCT_Assoc
is new Simple_HTable
(
17115 Header_Num
=> NCT_Header_Num
,
17116 Element
=> Entity_Id
,
17117 No_Element
=> Empty
,
17119 Hash
=> New_Copy_Hash
,
17120 Equal
=> Types
."=");
17122 ---------------------
17123 -- NCT_Itype_Assoc --
17124 ---------------------
17126 -- The hash table NCT_Itype_Assoc contains entries only for those old
17127 -- nodes which have a non-empty Associated_Node_For_Itype set. The key
17128 -- is the associated node, and the element is the new node itself (NOT
17129 -- the associated node for the new node).
17131 package NCT_Itype_Assoc
is new Simple_HTable
(
17132 Header_Num
=> NCT_Header_Num
,
17133 Element
=> Node_Or_Entity_Id
,
17134 No_Element
=> Empty
,
17136 Hash
=> New_Copy_Hash
,
17137 Equal
=> Types
."=");
17139 -------------------
17140 -- New_Copy_Tree --
17141 -------------------
17143 function New_Copy_Tree
17145 Map
: Elist_Id
:= No_Elist
;
17146 New_Sloc
: Source_Ptr
:= No_Location
;
17147 New_Scope
: Entity_Id
:= Empty
) return Node_Id
17149 EWA_Level
: Nat
:= 0;
17150 -- By default, copying of defining identifiers is prohibited because
17151 -- this would introduce an entirely new entity into the tree. The
17152 -- exception to this general rule is declaration of constants and
17153 -- variables located in Expression_With_Action nodes.
17155 EWA_Inner_Scope_Level
: Nat
:= 0;
17156 -- Level of internal scope of defined in EWAs. Used to avoid creating
17157 -- variables for declarations located in blocks or subprograms defined
17158 -- in Expression_With_Action nodes.
17160 NCT_Hash_Tables_Used
: Boolean := False;
17161 -- Set to True if hash tables are in use. It is intended to speed up the
17162 -- common case, which is no hash tables in use. This can save up to 8%
17163 -- of the entire compilation time spent in the front end.
17165 function Assoc
(N
: Node_Or_Entity_Id
) return Node_Id
;
17166 -- Called during second phase to map entities into their corresponding
17167 -- copies using the hash table. If the argument is not an entity, or is
17168 -- not in the hash table, then it is returned unchanged.
17170 procedure Build_NCT_Hash_Tables
;
17171 -- Builds hash tables
17173 function Copy_Elist_With_Replacement
17174 (Old_Elist
: Elist_Id
) return Elist_Id
;
17175 -- Called during second phase to copy element list doing replacements
17177 procedure Copy_Entity_With_Replacement
(New_Entity
: Entity_Id
);
17178 -- Called during the second phase to process a copied Entity. The actual
17179 -- copy happened during the first phase (so that we could make the entry
17180 -- in the mapping), but we still have to deal with the descendants of
17181 -- the copied Entity and copy them where necessary.
17183 function Copy_List_With_Replacement
(Old_List
: List_Id
) return List_Id
;
17184 -- Called during second phase to copy list doing replacements
17186 function Copy_Node_With_Replacement
(Old_Node
: Node_Id
) return Node_Id
;
17187 -- Called during second phase to copy node doing replacements
17189 function In_Map
(E
: Entity_Id
) return Boolean;
17190 -- Return True if E is one of the old entities specified in the set of
17191 -- mappings to be applied to entities in the tree (i.e. Map).
17193 procedure Visit_Elist
(E
: Elist_Id
);
17194 -- Called during first phase to visit all elements of an Elist
17196 procedure Visit_Entity
(Old_Entity
: Entity_Id
);
17197 -- Called during first phase to visit subsidiary fields of a defining
17198 -- entity which is not an itype, and also create a copy and make an
17199 -- entry in the replacement map for the new copy.
17201 procedure Visit_Field
(F
: Union_Id
; N
: Node_Id
);
17202 -- Visit a single field, recursing to call Visit_Node or Visit_List if
17203 -- the field is a syntactic descendant of the current node (i.e. its
17204 -- parent is Node N).
17206 procedure Visit_Itype
(Old_Itype
: Entity_Id
);
17207 -- Called during first phase to visit subsidiary fields of a defining
17208 -- Itype, and also create a copy and make an entry in the replacement
17209 -- map for the new copy.
17211 procedure Visit_List
(L
: List_Id
);
17212 -- Called during first phase to visit all elements of a List
17214 procedure Visit_Node
(N
: Node_Or_Entity_Id
);
17215 -- Called during first phase to visit a node and all its subtrees
17221 function Assoc
(N
: Node_Or_Entity_Id
) return Node_Id
is
17225 if Nkind
(N
) not in N_Entity
or else not NCT_Hash_Tables_Used
then
17229 Ent
:= NCT_Assoc
.Get
(Entity_Id
(N
));
17231 if Present
(Ent
) then
17239 ---------------------------
17240 -- Build_NCT_Hash_Tables --
17241 ---------------------------
17243 procedure Build_NCT_Hash_Tables
is
17254 -- Clear both hash tables associated with entry replication since
17255 -- multiple calls to New_Copy_Tree could cause multiple collisions
17256 -- and produce long linked lists in individual buckets.
17259 NCT_Itype_Assoc
.Reset
;
17261 Elmt
:= First_Elmt
(Map
);
17262 while Present
(Elmt
) loop
17264 -- Extract a (key, value) pair from the map
17266 Key
:= Node
(Elmt
);
17268 Value
:= Node
(Elmt
);
17270 -- Add the pair in the association hash table
17272 NCT_Assoc
.Set
(Key
, Value
);
17274 -- Add a link between the associated node of the old Itype and the
17275 -- new Itype, for updating later when node is copied.
17277 if Is_Type
(Key
) then
17278 Assoc
:= Associated_Node_For_Itype
(Key
);
17280 if Present
(Assoc
) then
17281 NCT_Itype_Assoc
.Set
(Assoc
, Value
);
17288 NCT_Hash_Tables_Used
:= True;
17289 end Build_NCT_Hash_Tables
;
17291 ---------------------------------
17292 -- Copy_Elist_With_Replacement --
17293 ---------------------------------
17295 function Copy_Elist_With_Replacement
17296 (Old_Elist
: Elist_Id
) return Elist_Id
17299 New_Elist
: Elist_Id
;
17302 if No
(Old_Elist
) then
17306 New_Elist
:= New_Elmt_List
;
17308 M
:= First_Elmt
(Old_Elist
);
17309 while Present
(M
) loop
17310 Append_Elmt
(Copy_Node_With_Replacement
(Node
(M
)), New_Elist
);
17316 end Copy_Elist_With_Replacement
;
17318 ----------------------------------
17319 -- Copy_Entity_With_Replacement --
17320 ----------------------------------
17322 -- This routine exactly parallels its phase one analog Visit_Itype
17324 procedure Copy_Entity_With_Replacement
(New_Entity
: Entity_Id
) is
17326 -- Translate Next_Entity, Scope, and Etype fields, in case they
17327 -- reference entities that have been mapped into copies.
17329 Set_Next_Entity
(New_Entity
, Assoc
(Next_Entity
(New_Entity
)));
17330 Set_Etype
(New_Entity
, Assoc
(Etype
(New_Entity
)));
17332 if Present
(New_Scope
) then
17333 Set_Scope
(New_Entity
, New_Scope
);
17335 Set_Scope
(New_Entity
, Assoc
(Scope
(New_Entity
)));
17338 -- Copy referenced fields
17340 if Is_Discrete_Type
(New_Entity
) then
17341 Set_Scalar_Range
(New_Entity
,
17342 Copy_Node_With_Replacement
(Scalar_Range
(New_Entity
)));
17344 elsif Has_Discriminants
(Base_Type
(New_Entity
)) then
17345 Set_Discriminant_Constraint
(New_Entity
,
17346 Copy_Elist_With_Replacement
17347 (Discriminant_Constraint
(New_Entity
)));
17349 elsif Is_Array_Type
(New_Entity
) then
17350 if Present
(First_Index
(New_Entity
)) then
17351 Set_First_Index
(New_Entity
,
17352 First
(Copy_List_With_Replacement
17353 (List_Containing
(First_Index
(New_Entity
)))));
17356 if Is_Packed
(New_Entity
) then
17357 Set_Packed_Array_Impl_Type
(New_Entity
,
17358 Copy_Node_With_Replacement
17359 (Packed_Array_Impl_Type
(New_Entity
)));
17362 end Copy_Entity_With_Replacement
;
17364 --------------------------------
17365 -- Copy_List_With_Replacement --
17366 --------------------------------
17368 function Copy_List_With_Replacement
17369 (Old_List
: List_Id
) return List_Id
17371 New_List
: List_Id
;
17375 if Old_List
= No_List
then
17379 New_List
:= Empty_List
;
17381 E
:= First
(Old_List
);
17382 while Present
(E
) loop
17383 Append
(Copy_Node_With_Replacement
(E
), New_List
);
17389 end Copy_List_With_Replacement
;
17391 --------------------------------
17392 -- Copy_Node_With_Replacement --
17393 --------------------------------
17395 function Copy_Node_With_Replacement
17396 (Old_Node
: Node_Id
) return Node_Id
17398 New_Node
: Node_Id
;
17400 procedure Adjust_Named_Associations
17401 (Old_Node
: Node_Id
;
17402 New_Node
: Node_Id
);
17403 -- If a call node has named associations, these are chained through
17404 -- the First_Named_Actual, Next_Named_Actual links. These must be
17405 -- propagated separately to the new parameter list, because these
17406 -- are not syntactic fields.
17408 function Copy_Field_With_Replacement
17409 (Field
: Union_Id
) return Union_Id
;
17410 -- Given Field, which is a field of Old_Node, return a copy of it
17411 -- if it is a syntactic field (i.e. its parent is Node), setting
17412 -- the parent of the copy to poit to New_Node. Otherwise returns
17413 -- the field (possibly mapped if it is an entity).
17415 -------------------------------
17416 -- Adjust_Named_Associations --
17417 -------------------------------
17419 procedure Adjust_Named_Associations
17420 (Old_Node
: Node_Id
;
17421 New_Node
: Node_Id
)
17426 Old_Next
: Node_Id
;
17427 New_Next
: Node_Id
;
17430 Old_E
:= First
(Parameter_Associations
(Old_Node
));
17431 New_E
:= First
(Parameter_Associations
(New_Node
));
17432 while Present
(Old_E
) loop
17433 if Nkind
(Old_E
) = N_Parameter_Association
17434 and then Present
(Next_Named_Actual
(Old_E
))
17436 if First_Named_Actual
(Old_Node
) =
17437 Explicit_Actual_Parameter
(Old_E
)
17439 Set_First_Named_Actual
17440 (New_Node
, Explicit_Actual_Parameter
(New_E
));
17443 -- Now scan parameter list from the beginning, to locate
17444 -- next named actual, which can be out of order.
17446 Old_Next
:= First
(Parameter_Associations
(Old_Node
));
17447 New_Next
:= First
(Parameter_Associations
(New_Node
));
17448 while Nkind
(Old_Next
) /= N_Parameter_Association
17449 or else Explicit_Actual_Parameter
(Old_Next
) /=
17450 Next_Named_Actual
(Old_E
)
17456 Set_Next_Named_Actual
17457 (New_E
, Explicit_Actual_Parameter
(New_Next
));
17463 end Adjust_Named_Associations
;
17465 ---------------------------------
17466 -- Copy_Field_With_Replacement --
17467 ---------------------------------
17469 function Copy_Field_With_Replacement
17470 (Field
: Union_Id
) return Union_Id
17473 if Field
= Union_Id
(Empty
) then
17476 elsif Field
in Node_Range
then
17478 Old_N
: constant Node_Id
:= Node_Id
(Field
);
17482 -- If syntactic field, as indicated by the parent pointer
17483 -- being set, then copy the referenced node recursively.
17485 if Parent
(Old_N
) = Old_Node
then
17486 New_N
:= Copy_Node_With_Replacement
(Old_N
);
17488 if New_N
/= Old_N
then
17489 Set_Parent
(New_N
, New_Node
);
17492 -- For semantic fields, update possible entity reference
17493 -- from the replacement map.
17496 New_N
:= Assoc
(Old_N
);
17499 return Union_Id
(New_N
);
17502 elsif Field
in List_Range
then
17504 Old_L
: constant List_Id
:= List_Id
(Field
);
17508 -- If syntactic field, as indicated by the parent pointer,
17509 -- then recursively copy the entire referenced list.
17511 if Parent
(Old_L
) = Old_Node
then
17512 New_L
:= Copy_List_With_Replacement
(Old_L
);
17513 Set_Parent
(New_L
, New_Node
);
17515 -- For semantic list, just returned unchanged
17521 return Union_Id
(New_L
);
17524 -- Anything other than a list or a node is returned unchanged
17529 end Copy_Field_With_Replacement
;
17531 -- Start of processing for Copy_Node_With_Replacement
17534 if Old_Node
<= Empty_Or_Error
then
17537 elsif Nkind
(Old_Node
) in N_Entity
then
17538 return Assoc
(Old_Node
);
17541 New_Node
:= New_Copy
(Old_Node
);
17543 -- If the node we are copying is the associated node of a
17544 -- previously copied Itype, then adjust the associated node
17545 -- of the copy of that Itype accordingly.
17548 Ent
: constant Entity_Id
:= NCT_Itype_Assoc
.Get
(Old_Node
);
17551 if Present
(Ent
) then
17552 Set_Associated_Node_For_Itype
(Ent
, New_Node
);
17556 -- Recursively copy descendants
17559 (New_Node
, Copy_Field_With_Replacement
(Field1
(New_Node
)));
17561 (New_Node
, Copy_Field_With_Replacement
(Field2
(New_Node
)));
17563 (New_Node
, Copy_Field_With_Replacement
(Field3
(New_Node
)));
17565 (New_Node
, Copy_Field_With_Replacement
(Field4
(New_Node
)));
17567 (New_Node
, Copy_Field_With_Replacement
(Field5
(New_Node
)));
17569 -- Adjust Sloc of new node if necessary
17571 if New_Sloc
/= No_Location
then
17572 Set_Sloc
(New_Node
, New_Sloc
);
17574 -- If we adjust the Sloc, then we are essentially making a
17575 -- completely new node, so the Comes_From_Source flag should
17576 -- be reset to the proper default value.
17578 Set_Comes_From_Source
17579 (New_Node
, Default_Node
.Comes_From_Source
);
17582 -- If the node is a call and has named associations, set the
17583 -- corresponding links in the copy.
17585 if Nkind_In
(Old_Node
, N_Entry_Call_Statement
,
17587 N_Procedure_Call_Statement
)
17588 and then Present
(First_Named_Actual
(Old_Node
))
17590 Adjust_Named_Associations
(Old_Node
, New_Node
);
17593 -- Reset First_Real_Statement for Handled_Sequence_Of_Statements.
17594 -- The replacement mechanism applies to entities, and is not used
17595 -- here. Eventually we may need a more general graph-copying
17596 -- routine. For now, do a sequential search to find desired node.
17598 if Nkind
(Old_Node
) = N_Handled_Sequence_Of_Statements
17599 and then Present
(First_Real_Statement
(Old_Node
))
17602 Old_F
: constant Node_Id
:= First_Real_Statement
(Old_Node
);
17606 N1
:= First
(Statements
(Old_Node
));
17607 N2
:= First
(Statements
(New_Node
));
17609 while N1
/= Old_F
loop
17614 Set_First_Real_Statement
(New_Node
, N2
);
17619 -- All done, return copied node
17622 end Copy_Node_With_Replacement
;
17628 function In_Map
(E
: Entity_Id
) return Boolean is
17633 if Present
(Map
) then
17634 Elmt
:= First_Elmt
(Map
);
17635 while Present
(Elmt
) loop
17636 Ent
:= Node
(Elmt
);
17654 procedure Visit_Elist
(E
: Elist_Id
) is
17657 if Present
(E
) then
17658 Elmt
:= First_Elmt
(E
);
17660 while Elmt
/= No_Elmt
loop
17661 Visit_Node
(Node
(Elmt
));
17671 procedure Visit_Entity
(Old_Entity
: Entity_Id
) is
17675 pragma Assert
(not Is_Itype
(Old_Entity
));
17676 pragma Assert
(Nkind
(Old_Entity
) in N_Entity
);
17678 -- Do not duplicate an entity when it is declared within an inner
17679 -- scope enclosed by an expression with actions.
17681 if EWA_Inner_Scope_Level
> 0 then
17684 -- Entity duplication is currently performed only for objects and
17685 -- types. Relaxing this restriction leads to a performance penalty.
17687 elsif Ekind_In
(Old_Entity
, E_Constant
, E_Variable
) then
17690 elsif Is_Type
(Old_Entity
) then
17697 New_E
:= New_Copy
(Old_Entity
);
17699 -- The new entity has all the attributes of the old one, however it
17700 -- requires a new name for debugging purposes.
17702 Set_Chars
(New_E
, New_Internal_Name
('T'));
17704 -- Add new association to map
17706 NCT_Assoc
.Set
(Old_Entity
, New_E
);
17707 NCT_Hash_Tables_Used
:= True;
17709 -- Visit descendants that eventually get copied
17711 Visit_Field
(Union_Id
(Etype
(Old_Entity
)), Old_Entity
);
17718 procedure Visit_Field
(F
: Union_Id
; N
: Node_Id
) is
17720 if F
= Union_Id
(Empty
) then
17723 elsif F
in Node_Range
then
17725 -- Copy node if it is syntactic, i.e. its parent pointer is
17726 -- set to point to the field that referenced it (certain
17727 -- Itypes will also meet this criterion, which is fine, since
17728 -- these are clearly Itypes that do need to be copied, since
17729 -- we are copying their parent.)
17731 if Parent
(Node_Id
(F
)) = N
then
17732 Visit_Node
(Node_Id
(F
));
17735 -- Another case, if we are pointing to an Itype, then we want
17736 -- to copy it if its associated node is somewhere in the tree
17739 -- Note: the exclusion of self-referential copies is just an
17740 -- optimization, since the search of the already copied list
17741 -- would catch it, but it is a common case (Etype pointing to
17742 -- itself for an Itype that is a base type).
17744 elsif Nkind
(Node_Id
(F
)) in N_Entity
17745 and then Is_Itype
(Entity_Id
(F
))
17746 and then Node_Id
(F
) /= N
17752 P
:= Associated_Node_For_Itype
(Node_Id
(F
));
17753 while Present
(P
) loop
17755 Visit_Node
(Node_Id
(F
));
17762 -- An Itype whose parent is not being copied definitely
17763 -- should NOT be copied, since it does not belong in any
17764 -- sense to the copied subtree.
17770 elsif F
in List_Range
and then Parent
(List_Id
(F
)) = N
then
17771 Visit_List
(List_Id
(F
));
17780 procedure Visit_Itype
(Old_Itype
: Entity_Id
) is
17781 New_Itype
: Entity_Id
;
17785 -- Itypes that describe the designated type of access to subprograms
17786 -- have the structure of subprogram declarations, with signatures,
17787 -- etc. Either we duplicate the signatures completely, or choose to
17788 -- share such itypes, which is fine because their elaboration will
17789 -- have no side effects.
17791 if Ekind
(Old_Itype
) = E_Subprogram_Type
then
17795 New_Itype
:= New_Copy
(Old_Itype
);
17797 -- The new Itype has all the attributes of the old one, and we
17798 -- just copy the contents of the entity. However, the back-end
17799 -- needs different names for debugging purposes, so we create a
17800 -- new internal name for it in all cases.
17802 Set_Chars
(New_Itype
, New_Internal_Name
('T'));
17804 -- If our associated node is an entity that has already been copied,
17805 -- then set the associated node of the copy to point to the right
17806 -- copy. If we have copied an Itype that is itself the associated
17807 -- node of some previously copied Itype, then we set the right
17808 -- pointer in the other direction.
17810 Ent
:= NCT_Assoc
.Get
(Associated_Node_For_Itype
(Old_Itype
));
17812 if Present
(Ent
) then
17813 Set_Associated_Node_For_Itype
(New_Itype
, Ent
);
17816 Ent
:= NCT_Itype_Assoc
.Get
(Old_Itype
);
17818 if Present
(Ent
) then
17819 Set_Associated_Node_For_Itype
(Ent
, New_Itype
);
17821 -- If the hash table has no association for this Itype and its
17822 -- associated node, enter one now.
17825 NCT_Itype_Assoc
.Set
17826 (Associated_Node_For_Itype
(Old_Itype
), New_Itype
);
17829 if Present
(Freeze_Node
(New_Itype
)) then
17830 Set_Is_Frozen
(New_Itype
, False);
17831 Set_Freeze_Node
(New_Itype
, Empty
);
17834 -- Add new association to map
17836 NCT_Assoc
.Set
(Old_Itype
, New_Itype
);
17837 NCT_Hash_Tables_Used
:= True;
17839 -- If a record subtype is simply copied, the entity list will be
17840 -- shared. Thus cloned_Subtype must be set to indicate the sharing.
17842 if Ekind_In
(Old_Itype
, E_Class_Wide_Subtype
, E_Record_Subtype
) then
17843 Set_Cloned_Subtype
(New_Itype
, Old_Itype
);
17846 -- Visit descendants that eventually get copied
17848 Visit_Field
(Union_Id
(Etype
(Old_Itype
)), Old_Itype
);
17850 if Is_Discrete_Type
(Old_Itype
) then
17851 Visit_Field
(Union_Id
(Scalar_Range
(Old_Itype
)), Old_Itype
);
17853 elsif Has_Discriminants
(Base_Type
(Old_Itype
)) then
17854 -- ??? This should involve call to Visit_Field
17855 Visit_Elist
(Discriminant_Constraint
(Old_Itype
));
17857 elsif Is_Array_Type
(Old_Itype
) then
17858 if Present
(First_Index
(Old_Itype
)) then
17860 (Union_Id
(List_Containing
(First_Index
(Old_Itype
))),
17864 if Is_Packed
(Old_Itype
) then
17866 (Union_Id
(Packed_Array_Impl_Type
(Old_Itype
)), Old_Itype
);
17875 procedure Visit_List
(L
: List_Id
) is
17878 if L
/= No_List
then
17881 while Present
(N
) loop
17892 procedure Visit_Node
(N
: Node_Or_Entity_Id
) is
17894 if Nkind
(N
) = N_Expression_With_Actions
then
17895 EWA_Level
:= EWA_Level
+ 1;
17897 elsif EWA_Level
> 0
17898 and then Nkind_In
(N
, N_Block_Statement
,
17900 N_Subprogram_Declaration
)
17902 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
+ 1;
17904 -- Handle case of an Itype, which must be copied
17906 elsif Nkind
(N
) in N_Entity
and then Is_Itype
(N
) then
17908 -- Nothing to do if already in the list. This can happen with an
17909 -- Itype entity that appears more than once in the tree. Note that
17910 -- we do not want to visit descendants in this case.
17912 if Present
(NCT_Assoc
.Get
(Entity_Id
(N
))) then
17918 -- Handle defining entities in Expression_With_Action nodes
17920 elsif Nkind
(N
) in N_Entity
and then EWA_Level
> 0 then
17922 -- Nothing to do if already in the hash table
17924 if Present
(NCT_Assoc
.Get
(Entity_Id
(N
))) then
17931 -- Visit descendants
17933 Visit_Field
(Field1
(N
), N
);
17934 Visit_Field
(Field2
(N
), N
);
17935 Visit_Field
(Field3
(N
), N
);
17936 Visit_Field
(Field4
(N
), N
);
17937 Visit_Field
(Field5
(N
), N
);
17940 and then Nkind_In
(N
, N_Block_Statement
,
17942 N_Subprogram_Declaration
)
17944 EWA_Inner_Scope_Level
:= EWA_Inner_Scope_Level
- 1;
17946 elsif Nkind
(N
) = N_Expression_With_Actions
then
17947 EWA_Level
:= EWA_Level
- 1;
17951 -- Start of processing for New_Copy_Tree
17954 Build_NCT_Hash_Tables
;
17956 -- Hash table set up if required, now start phase one by visiting top
17957 -- node (we will recursively visit the descendants).
17959 Visit_Node
(Source
);
17961 -- Now the second phase of the copy can start. First we process all the
17962 -- mapped entities, copying their descendants.
17964 if NCT_Hash_Tables_Used
then
17966 Old_E
: Entity_Id
:= Empty
;
17970 NCT_Assoc
.Get_First
(Old_E
, New_E
);
17971 while Present
(New_E
) loop
17973 -- Skip entities that were not created in the first phase
17974 -- (that is, old entities specified by the caller in the set of
17975 -- mappings to be applied to the tree).
17977 if Is_Itype
(New_E
)
17979 or else not In_Map
(Old_E
)
17981 Copy_Entity_With_Replacement
(New_E
);
17984 NCT_Assoc
.Get_Next
(Old_E
, New_E
);
17989 -- Now we can copy the actual tree
17992 Result
: constant Node_Id
:= Copy_Node_With_Replacement
(Source
);
17995 if NCT_Hash_Tables_Used
then
17997 NCT_Itype_Assoc
.Reset
;
18004 -------------------------
18005 -- New_External_Entity --
18006 -------------------------
18008 function New_External_Entity
18009 (Kind
: Entity_Kind
;
18010 Scope_Id
: Entity_Id
;
18011 Sloc_Value
: Source_Ptr
;
18012 Related_Id
: Entity_Id
;
18013 Suffix
: Character;
18014 Suffix_Index
: Nat
:= 0;
18015 Prefix
: Character := ' ') return Entity_Id
18017 N
: constant Entity_Id
:=
18018 Make_Defining_Identifier
(Sloc_Value
,
18020 (Chars
(Related_Id
), Suffix
, Suffix_Index
, Prefix
));
18023 Set_Ekind
(N
, Kind
);
18024 Set_Is_Internal
(N
, True);
18025 Append_Entity
(N
, Scope_Id
);
18026 Set_Public_Status
(N
);
18028 if Kind
in Type_Kind
then
18029 Init_Size_Align
(N
);
18033 end New_External_Entity
;
18035 -------------------------
18036 -- New_Internal_Entity --
18037 -------------------------
18039 function New_Internal_Entity
18040 (Kind
: Entity_Kind
;
18041 Scope_Id
: Entity_Id
;
18042 Sloc_Value
: Source_Ptr
;
18043 Id_Char
: Character) return Entity_Id
18045 N
: constant Entity_Id
:= Make_Temporary
(Sloc_Value
, Id_Char
);
18048 Set_Ekind
(N
, Kind
);
18049 Set_Is_Internal
(N
, True);
18050 Append_Entity
(N
, Scope_Id
);
18052 if Kind
in Type_Kind
then
18053 Init_Size_Align
(N
);
18057 end New_Internal_Entity
;
18063 function Next_Actual
(Actual_Id
: Node_Id
) return Node_Id
is
18067 -- If we are pointing at a positional parameter, it is a member of a
18068 -- node list (the list of parameters), and the next parameter is the
18069 -- next node on the list, unless we hit a parameter association, then
18070 -- we shift to using the chain whose head is the First_Named_Actual in
18071 -- the parent, and then is threaded using the Next_Named_Actual of the
18072 -- Parameter_Association. All this fiddling is because the original node
18073 -- list is in the textual call order, and what we need is the
18074 -- declaration order.
18076 if Is_List_Member
(Actual_Id
) then
18077 N
:= Next
(Actual_Id
);
18079 if Nkind
(N
) = N_Parameter_Association
then
18080 return First_Named_Actual
(Parent
(Actual_Id
));
18086 return Next_Named_Actual
(Parent
(Actual_Id
));
18090 procedure Next_Actual
(Actual_Id
: in out Node_Id
) is
18092 Actual_Id
:= Next_Actual
(Actual_Id
);
18095 ----------------------------------
18096 -- New_Requires_Transient_Scope --
18097 ----------------------------------
18099 function New_Requires_Transient_Scope
(Id
: Entity_Id
) return Boolean is
18100 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean;
18101 -- This is called for untagged records and protected types, with
18102 -- nondefaulted discriminants. Returns True if the size of function
18103 -- results is known at the call site, False otherwise. Returns False
18104 -- if there is a variant part that depends on the discriminants of
18105 -- this type, or if there is an array constrained by the discriminants
18106 -- of this type. ???Currently, this is overly conservative (the array
18107 -- could be nested inside some other record that is constrained by
18108 -- nondiscriminants). That is, the recursive calls are too conservative.
18110 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean;
18111 -- Returns True if Typ is a nonlimited record with defaulted
18112 -- discriminants whose max size makes it unsuitable for allocating on
18113 -- the primary stack.
18115 ------------------------------
18116 -- Caller_Known_Size_Record --
18117 ------------------------------
18119 function Caller_Known_Size_Record
(Typ
: Entity_Id
) return Boolean is
18120 pragma Assert
(Typ
= Underlying_Type
(Typ
));
18123 if Has_Variant_Part
(Typ
) and then not Is_Definite_Subtype
(Typ
) then
18131 Comp
:= First_Entity
(Typ
);
18132 while Present
(Comp
) loop
18134 -- Only look at E_Component entities. No need to look at
18135 -- E_Discriminant entities, and we must ignore internal
18136 -- subtypes generated for constrained components.
18138 if Ekind
(Comp
) = E_Component
then
18140 Comp_Type
: constant Entity_Id
:=
18141 Underlying_Type
(Etype
(Comp
));
18144 if Is_Record_Type
(Comp_Type
)
18146 Is_Protected_Type
(Comp_Type
)
18148 if not Caller_Known_Size_Record
(Comp_Type
) then
18152 elsif Is_Array_Type
(Comp_Type
) then
18153 if Size_Depends_On_Discriminant
(Comp_Type
) then
18160 Next_Entity
(Comp
);
18165 end Caller_Known_Size_Record
;
18167 ------------------------------
18168 -- Large_Max_Size_Mutable --
18169 ------------------------------
18171 function Large_Max_Size_Mutable
(Typ
: Entity_Id
) return Boolean is
18172 pragma Assert
(Typ
= Underlying_Type
(Typ
));
18174 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean;
18175 -- Returns true if the discrete type T has a large range
18177 ----------------------------
18178 -- Is_Large_Discrete_Type --
18179 ----------------------------
18181 function Is_Large_Discrete_Type
(T
: Entity_Id
) return Boolean is
18182 Threshold
: constant Int
:= 16;
18183 -- Arbitrary threshold above which we consider it "large". We want
18184 -- a fairly large threshold, because these large types really
18185 -- shouldn't have default discriminants in the first place, in
18189 return UI_To_Int
(RM_Size
(T
)) > Threshold
;
18190 end Is_Large_Discrete_Type
;
18192 -- Start of processing for Large_Max_Size_Mutable
18195 if Is_Record_Type
(Typ
)
18196 and then not Is_Limited_View
(Typ
)
18197 and then Has_Defaulted_Discriminants
(Typ
)
18199 -- Loop through the components, looking for an array whose upper
18200 -- bound(s) depends on discriminants, where both the subtype of
18201 -- the discriminant and the index subtype are too large.
18207 Comp
:= First_Entity
(Typ
);
18208 while Present
(Comp
) loop
18209 if Ekind
(Comp
) = E_Component
then
18211 Comp_Type
: constant Entity_Id
:=
18212 Underlying_Type
(Etype
(Comp
));
18219 if Is_Array_Type
(Comp_Type
) then
18220 Indx
:= First_Index
(Comp_Type
);
18222 while Present
(Indx
) loop
18223 Ityp
:= Etype
(Indx
);
18224 Hi
:= Type_High_Bound
(Ityp
);
18226 if Nkind
(Hi
) = N_Identifier
18227 and then Ekind
(Entity
(Hi
)) = E_Discriminant
18228 and then Is_Large_Discrete_Type
(Ityp
)
18229 and then Is_Large_Discrete_Type
18230 (Etype
(Entity
(Hi
)))
18241 Next_Entity
(Comp
);
18247 end Large_Max_Size_Mutable
;
18249 -- Local declarations
18251 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
18253 -- Start of processing for New_Requires_Transient_Scope
18256 -- This is a private type which is not completed yet. This can only
18257 -- happen in a default expression (of a formal parameter or of a
18258 -- record component). Do not expand transient scope in this case.
18263 -- Do not expand transient scope for non-existent procedure return or
18264 -- string literal types.
18266 elsif Typ
= Standard_Void_Type
18267 or else Ekind
(Typ
) = E_String_Literal_Subtype
18271 -- If Typ is a generic formal incomplete type, then we want to look at
18272 -- the actual type.
18274 elsif Ekind
(Typ
) = E_Record_Subtype
18275 and then Present
(Cloned_Subtype
(Typ
))
18277 return New_Requires_Transient_Scope
(Cloned_Subtype
(Typ
));
18279 -- Functions returning specific tagged types may dispatch on result, so
18280 -- their returned value is allocated on the secondary stack, even in the
18281 -- definite case. We must treat nondispatching functions the same way,
18282 -- because access-to-function types can point at both, so the calling
18283 -- conventions must be compatible. Is_Tagged_Type includes controlled
18284 -- types and class-wide types. Controlled type temporaries need
18287 -- ???It's not clear why we need to return noncontrolled types with
18288 -- controlled components on the secondary stack.
18290 elsif Is_Tagged_Type
(Typ
) or else Has_Controlled_Component
(Typ
) then
18293 -- Untagged definite subtypes are known size. This includes all
18294 -- elementary [sub]types. Tasks are known size even if they have
18295 -- discriminants. So we return False here, with one exception:
18296 -- For a type like:
18297 -- type T (Last : Natural := 0) is
18298 -- X : String (1 .. Last);
18300 -- we return True. That's because for "P(F(...));", where F returns T,
18301 -- we don't know the size of the result at the call site, so if we
18302 -- allocated it on the primary stack, we would have to allocate the
18303 -- maximum size, which is way too big.
18305 elsif Is_Definite_Subtype
(Typ
) or else Is_Task_Type
(Typ
) then
18306 return Large_Max_Size_Mutable
(Typ
);
18308 -- Indefinite (discriminated) untagged record or protected type
18310 elsif Is_Record_Type
(Typ
) or else Is_Protected_Type
(Typ
) then
18311 return not Caller_Known_Size_Record
(Typ
);
18313 -- Unconstrained array
18316 pragma Assert
(Is_Array_Type
(Typ
) and not Is_Definite_Subtype
(Typ
));
18319 end New_Requires_Transient_Scope
;
18321 --------------------------
18322 -- No_Heap_Finalization --
18323 --------------------------
18325 function No_Heap_Finalization
(Typ
: Entity_Id
) return Boolean is
18327 if Ekind_In
(Typ
, E_Access_Type
, E_General_Access_Type
)
18328 and then Is_Library_Level_Entity
(Typ
)
18330 -- A global No_Heap_Finalization pragma applies to all library-level
18331 -- named access-to-object types.
18333 if Present
(No_Heap_Finalization_Pragma
) then
18336 -- The library-level named access-to-object type itself is subject to
18337 -- pragma No_Heap_Finalization.
18339 elsif Present
(Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
)) then
18345 end No_Heap_Finalization
;
18347 -----------------------
18348 -- Normalize_Actuals --
18349 -----------------------
18351 -- Chain actuals according to formals of subprogram. If there are no named
18352 -- associations, the chain is simply the list of Parameter Associations,
18353 -- since the order is the same as the declaration order. If there are named
18354 -- associations, then the First_Named_Actual field in the N_Function_Call
18355 -- or N_Procedure_Call_Statement node points to the Parameter_Association
18356 -- node for the parameter that comes first in declaration order. The
18357 -- remaining named parameters are then chained in declaration order using
18358 -- Next_Named_Actual.
18360 -- This routine also verifies that the number of actuals is compatible with
18361 -- the number and default values of formals, but performs no type checking
18362 -- (type checking is done by the caller).
18364 -- If the matching succeeds, Success is set to True and the caller proceeds
18365 -- with type-checking. If the match is unsuccessful, then Success is set to
18366 -- False, and the caller attempts a different interpretation, if there is
18369 -- If the flag Report is on, the call is not overloaded, and a failure to
18370 -- match can be reported here, rather than in the caller.
18372 procedure Normalize_Actuals
18376 Success
: out Boolean)
18378 Actuals
: constant List_Id
:= Parameter_Associations
(N
);
18379 Actual
: Node_Id
:= Empty
;
18380 Formal
: Entity_Id
;
18381 Last
: Node_Id
:= Empty
;
18382 First_Named
: Node_Id
:= Empty
;
18385 Formals_To_Match
: Integer := 0;
18386 Actuals_To_Match
: Integer := 0;
18388 procedure Chain
(A
: Node_Id
);
18389 -- Add named actual at the proper place in the list, using the
18390 -- Next_Named_Actual link.
18392 function Reporting
return Boolean;
18393 -- Determines if an error is to be reported. To report an error, we
18394 -- need Report to be True, and also we do not report errors caused
18395 -- by calls to init procs that occur within other init procs. Such
18396 -- errors must always be cascaded errors, since if all the types are
18397 -- declared correctly, the compiler will certainly build decent calls.
18403 procedure Chain
(A
: Node_Id
) is
18407 -- Call node points to first actual in list
18409 Set_First_Named_Actual
(N
, Explicit_Actual_Parameter
(A
));
18412 Set_Next_Named_Actual
(Last
, Explicit_Actual_Parameter
(A
));
18416 Set_Next_Named_Actual
(Last
, Empty
);
18423 function Reporting
return Boolean is
18428 elsif not Within_Init_Proc
then
18431 elsif Is_Init_Proc
(Entity
(Name
(N
))) then
18439 -- Start of processing for Normalize_Actuals
18442 if Is_Access_Type
(S
) then
18444 -- The name in the call is a function call that returns an access
18445 -- to subprogram. The designated type has the list of formals.
18447 Formal
:= First_Formal
(Designated_Type
(S
));
18449 Formal
:= First_Formal
(S
);
18452 while Present
(Formal
) loop
18453 Formals_To_Match
:= Formals_To_Match
+ 1;
18454 Next_Formal
(Formal
);
18457 -- Find if there is a named association, and verify that no positional
18458 -- associations appear after named ones.
18460 if Present
(Actuals
) then
18461 Actual
:= First
(Actuals
);
18464 while Present
(Actual
)
18465 and then Nkind
(Actual
) /= N_Parameter_Association
18467 Actuals_To_Match
:= Actuals_To_Match
+ 1;
18471 if No
(Actual
) and Actuals_To_Match
= Formals_To_Match
then
18473 -- Most common case: positional notation, no defaults
18478 elsif Actuals_To_Match
> Formals_To_Match
then
18480 -- Too many actuals: will not work
18483 if Is_Entity_Name
(Name
(N
)) then
18484 Error_Msg_N
("too many arguments in call to&", Name
(N
));
18486 Error_Msg_N
("too many arguments in call", N
);
18494 First_Named
:= Actual
;
18496 while Present
(Actual
) loop
18497 if Nkind
(Actual
) /= N_Parameter_Association
then
18499 ("positional parameters not allowed after named ones", Actual
);
18504 Actuals_To_Match
:= Actuals_To_Match
+ 1;
18510 if Present
(Actuals
) then
18511 Actual
:= First
(Actuals
);
18514 Formal
:= First_Formal
(S
);
18515 while Present
(Formal
) loop
18517 -- Match the formals in order. If the corresponding actual is
18518 -- positional, nothing to do. Else scan the list of named actuals
18519 -- to find the one with the right name.
18521 if Present
(Actual
)
18522 and then Nkind
(Actual
) /= N_Parameter_Association
18525 Actuals_To_Match
:= Actuals_To_Match
- 1;
18526 Formals_To_Match
:= Formals_To_Match
- 1;
18529 -- For named parameters, search the list of actuals to find
18530 -- one that matches the next formal name.
18532 Actual
:= First_Named
;
18534 while Present
(Actual
) loop
18535 if Chars
(Selector_Name
(Actual
)) = Chars
(Formal
) then
18538 Actuals_To_Match
:= Actuals_To_Match
- 1;
18539 Formals_To_Match
:= Formals_To_Match
- 1;
18547 if Ekind
(Formal
) /= E_In_Parameter
18548 or else No
(Default_Value
(Formal
))
18551 if (Comes_From_Source
(S
)
18552 or else Sloc
(S
) = Standard_Location
)
18553 and then Is_Overloadable
(S
)
18557 Nkind_In
(Parent
(N
), N_Procedure_Call_Statement
,
18559 N_Parameter_Association
)
18560 and then Ekind
(S
) /= E_Function
18562 Set_Etype
(N
, Etype
(S
));
18565 Error_Msg_Name_1
:= Chars
(S
);
18566 Error_Msg_Sloc
:= Sloc
(S
);
18568 ("missing argument for parameter & "
18569 & "in call to % declared #", N
, Formal
);
18572 elsif Is_Overloadable
(S
) then
18573 Error_Msg_Name_1
:= Chars
(S
);
18575 -- Point to type derivation that generated the
18578 Error_Msg_Sloc
:= Sloc
(Parent
(S
));
18581 ("missing argument for parameter & "
18582 & "in call to % (inherited) #", N
, Formal
);
18586 ("missing argument for parameter &", N
, Formal
);
18594 Formals_To_Match
:= Formals_To_Match
- 1;
18599 Next_Formal
(Formal
);
18602 if Formals_To_Match
= 0 and then Actuals_To_Match
= 0 then
18609 -- Find some superfluous named actual that did not get
18610 -- attached to the list of associations.
18612 Actual
:= First
(Actuals
);
18613 while Present
(Actual
) loop
18614 if Nkind
(Actual
) = N_Parameter_Association
18615 and then Actual
/= Last
18616 and then No
(Next_Named_Actual
(Actual
))
18618 -- A validity check may introduce a copy of a call that
18619 -- includes an extra actual (for example for an unrelated
18620 -- accessibility check). Check that the extra actual matches
18621 -- some extra formal, which must exist already because
18622 -- subprogram must be frozen at this point.
18624 if Present
(Extra_Formals
(S
))
18625 and then not Comes_From_Source
(Actual
)
18626 and then Nkind
(Actual
) = N_Parameter_Association
18627 and then Chars
(Extra_Formals
(S
)) =
18628 Chars
(Selector_Name
(Actual
))
18633 ("unmatched actual & in call", Selector_Name
(Actual
));
18645 end Normalize_Actuals
;
18647 --------------------------------
18648 -- Note_Possible_Modification --
18649 --------------------------------
18651 procedure Note_Possible_Modification
(N
: Node_Id
; Sure
: Boolean) is
18652 Modification_Comes_From_Source
: constant Boolean :=
18653 Comes_From_Source
(Parent
(N
));
18659 -- Loop to find referenced entity, if there is one
18665 if Is_Entity_Name
(Exp
) then
18666 Ent
:= Entity
(Exp
);
18668 -- If the entity is missing, it is an undeclared identifier,
18669 -- and there is nothing to annotate.
18675 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
18677 P
: constant Node_Id
:= Prefix
(Exp
);
18680 -- In formal verification mode, keep track of all reads and
18681 -- writes through explicit dereferences.
18683 if GNATprove_Mode
then
18684 SPARK_Specific
.Generate_Dereference
(N
, 'm');
18687 if Nkind
(P
) = N_Selected_Component
18688 and then Present
(Entry_Formal
(Entity
(Selector_Name
(P
))))
18690 -- Case of a reference to an entry formal
18692 Ent
:= Entry_Formal
(Entity
(Selector_Name
(P
)));
18694 elsif Nkind
(P
) = N_Identifier
18695 and then Nkind
(Parent
(Entity
(P
))) = N_Object_Declaration
18696 and then Present
(Expression
(Parent
(Entity
(P
))))
18697 and then Nkind
(Expression
(Parent
(Entity
(P
)))) =
18700 -- Case of a reference to a value on which side effects have
18703 Exp
:= Prefix
(Expression
(Parent
(Entity
(P
))));
18711 elsif Nkind_In
(Exp
, N_Type_Conversion
,
18712 N_Unchecked_Type_Conversion
)
18714 Exp
:= Expression
(Exp
);
18717 elsif Nkind_In
(Exp
, N_Slice
,
18718 N_Indexed_Component
,
18719 N_Selected_Component
)
18721 -- Special check, if the prefix is an access type, then return
18722 -- since we are modifying the thing pointed to, not the prefix.
18723 -- When we are expanding, most usually the prefix is replaced
18724 -- by an explicit dereference, and this test is not needed, but
18725 -- in some cases (notably -gnatc mode and generics) when we do
18726 -- not do full expansion, we need this special test.
18728 if Is_Access_Type
(Etype
(Prefix
(Exp
))) then
18731 -- Otherwise go to prefix and keep going
18734 Exp
:= Prefix
(Exp
);
18738 -- All other cases, not a modification
18744 -- Now look for entity being referenced
18746 if Present
(Ent
) then
18747 if Is_Object
(Ent
) then
18748 if Comes_From_Source
(Exp
)
18749 or else Modification_Comes_From_Source
18751 -- Give warning if pragma unmodified is given and we are
18752 -- sure this is a modification.
18754 if Has_Pragma_Unmodified
(Ent
) and then Sure
then
18756 -- Note that the entity may be present only as a result
18757 -- of pragma Unused.
18759 if Has_Pragma_Unused
(Ent
) then
18760 Error_Msg_NE
("??pragma Unused given for &!", N
, Ent
);
18763 ("??pragma Unmodified given for &!", N
, Ent
);
18767 Set_Never_Set_In_Source
(Ent
, False);
18770 Set_Is_True_Constant
(Ent
, False);
18771 Set_Current_Value
(Ent
, Empty
);
18772 Set_Is_Known_Null
(Ent
, False);
18774 if not Can_Never_Be_Null
(Ent
) then
18775 Set_Is_Known_Non_Null
(Ent
, False);
18778 -- Follow renaming chain
18780 if (Ekind
(Ent
) = E_Variable
or else Ekind
(Ent
) = E_Constant
)
18781 and then Present
(Renamed_Object
(Ent
))
18783 Exp
:= Renamed_Object
(Ent
);
18785 -- If the entity is the loop variable in an iteration over
18786 -- a container, retrieve container expression to indicate
18787 -- possible modification.
18789 if Present
(Related_Expression
(Ent
))
18790 and then Nkind
(Parent
(Related_Expression
(Ent
))) =
18791 N_Iterator_Specification
18793 Exp
:= Original_Node
(Related_Expression
(Ent
));
18798 -- The expression may be the renaming of a subcomponent of an
18799 -- array or container. The assignment to the subcomponent is
18800 -- a modification of the container.
18802 elsif Comes_From_Source
(Original_Node
(Exp
))
18803 and then Nkind_In
(Original_Node
(Exp
), N_Selected_Component
,
18804 N_Indexed_Component
)
18806 Exp
:= Prefix
(Original_Node
(Exp
));
18810 -- Generate a reference only if the assignment comes from
18811 -- source. This excludes, for example, calls to a dispatching
18812 -- assignment operation when the left-hand side is tagged. In
18813 -- GNATprove mode, we need those references also on generated
18814 -- code, as these are used to compute the local effects of
18817 if Modification_Comes_From_Source
or GNATprove_Mode
then
18818 Generate_Reference
(Ent
, Exp
, 'm');
18820 -- If the target of the assignment is the bound variable
18821 -- in an iterator, indicate that the corresponding array
18822 -- or container is also modified.
18824 if Ada_Version
>= Ada_2012
18825 and then Nkind
(Parent
(Ent
)) = N_Iterator_Specification
18828 Domain
: constant Node_Id
:= Name
(Parent
(Ent
));
18831 -- TBD : in the full version of the construct, the
18832 -- domain of iteration can be given by an expression.
18834 if Is_Entity_Name
(Domain
) then
18835 Generate_Reference
(Entity
(Domain
), Exp
, 'm');
18836 Set_Is_True_Constant
(Entity
(Domain
), False);
18837 Set_Never_Set_In_Source
(Entity
(Domain
), False);
18846 -- If we are sure this is a modification from source, and we know
18847 -- this modifies a constant, then give an appropriate warning.
18850 and then Modification_Comes_From_Source
18851 and then Overlays_Constant
(Ent
)
18852 and then Address_Clause_Overlay_Warnings
18855 Addr
: constant Node_Id
:= Address_Clause
(Ent
);
18860 Find_Overlaid_Entity
(Addr
, O_Ent
, Off
);
18862 Error_Msg_Sloc
:= Sloc
(Addr
);
18864 ("??constant& may be modified via address clause#",
18875 end Note_Possible_Modification
;
18881 function Null_Status
(N
: Node_Id
) return Null_Status_Kind
is
18882 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean;
18883 -- Determine whether definition Def carries a null exclusion
18885 function Null_Status_Of_Entity
(Id
: Entity_Id
) return Null_Status_Kind
;
18886 -- Determine the null status of arbitrary entity Id
18888 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
;
18889 -- Determine the null status of type Typ
18891 ---------------------------
18892 -- Is_Null_Excluding_Def --
18893 ---------------------------
18895 function Is_Null_Excluding_Def
(Def
: Node_Id
) return Boolean is
18898 Nkind_In
(Def
, N_Access_Definition
,
18899 N_Access_Function_Definition
,
18900 N_Access_Procedure_Definition
,
18901 N_Access_To_Object_Definition
,
18902 N_Component_Definition
,
18903 N_Derived_Type_Definition
)
18904 and then Null_Exclusion_Present
(Def
);
18905 end Is_Null_Excluding_Def
;
18907 ---------------------------
18908 -- Null_Status_Of_Entity --
18909 ---------------------------
18911 function Null_Status_Of_Entity
18912 (Id
: Entity_Id
) return Null_Status_Kind
18914 Decl
: constant Node_Id
:= Declaration_Node
(Id
);
18918 -- The value of an imported or exported entity may be set externally
18919 -- regardless of a null exclusion. As a result, the value cannot be
18920 -- determined statically.
18922 if Is_Imported
(Id
) or else Is_Exported
(Id
) then
18925 elsif Nkind_In
(Decl
, N_Component_Declaration
,
18926 N_Discriminant_Specification
,
18927 N_Formal_Object_Declaration
,
18928 N_Object_Declaration
,
18929 N_Object_Renaming_Declaration
,
18930 N_Parameter_Specification
)
18932 -- A component declaration yields a non-null value when either
18933 -- its component definition or access definition carries a null
18936 if Nkind
(Decl
) = N_Component_Declaration
then
18937 Def
:= Component_Definition
(Decl
);
18939 if Is_Null_Excluding_Def
(Def
) then
18940 return Is_Non_Null
;
18943 Def
:= Access_Definition
(Def
);
18945 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
18946 return Is_Non_Null
;
18949 -- A formal object declaration yields a non-null value if its
18950 -- access definition carries a null exclusion. If the object is
18951 -- default initialized, then the value depends on the expression.
18953 elsif Nkind
(Decl
) = N_Formal_Object_Declaration
then
18954 Def
:= Access_Definition
(Decl
);
18956 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
18957 return Is_Non_Null
;
18960 -- A constant may yield a null or non-null value depending on its
18961 -- initialization expression.
18963 elsif Ekind
(Id
) = E_Constant
then
18964 return Null_Status
(Constant_Value
(Id
));
18966 -- The construct yields a non-null value when it has a null
18969 elsif Null_Exclusion_Present
(Decl
) then
18970 return Is_Non_Null
;
18972 -- An object renaming declaration yields a non-null value if its
18973 -- access definition carries a null exclusion. Otherwise the value
18974 -- depends on the renamed name.
18976 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
18977 Def
:= Access_Definition
(Decl
);
18979 if Present
(Def
) and then Is_Null_Excluding_Def
(Def
) then
18980 return Is_Non_Null
;
18983 return Null_Status
(Name
(Decl
));
18988 -- At this point the declaration of the entity does not carry a null
18989 -- exclusion and lacks an initialization expression. Check the status
18992 return Null_Status_Of_Type
(Etype
(Id
));
18993 end Null_Status_Of_Entity
;
18995 -------------------------
18996 -- Null_Status_Of_Type --
18997 -------------------------
18999 function Null_Status_Of_Type
(Typ
: Entity_Id
) return Null_Status_Kind
is
19004 -- Traverse the type chain looking for types with null exclusion
19007 while Present
(Curr
) and then Etype
(Curr
) /= Curr
loop
19008 Decl
:= Parent
(Curr
);
19010 -- Guard against itypes which do not always have declarations. A
19011 -- type yields a non-null value if it carries a null exclusion.
19013 if Present
(Decl
) then
19014 if Nkind
(Decl
) = N_Full_Type_Declaration
19015 and then Is_Null_Excluding_Def
(Type_Definition
(Decl
))
19017 return Is_Non_Null
;
19019 elsif Nkind
(Decl
) = N_Subtype_Declaration
19020 and then Null_Exclusion_Present
(Decl
)
19022 return Is_Non_Null
;
19026 Curr
:= Etype
(Curr
);
19029 -- The type chain does not contain any null excluding types
19032 end Null_Status_Of_Type
;
19034 -- Start of processing for Null_Status
19037 -- An allocator always creates a non-null value
19039 if Nkind
(N
) = N_Allocator
then
19040 return Is_Non_Null
;
19042 -- Taking the 'Access of something yields a non-null value
19044 elsif Nkind
(N
) = N_Attribute_Reference
19045 and then Nam_In
(Attribute_Name
(N
), Name_Access
,
19046 Name_Unchecked_Access
,
19047 Name_Unrestricted_Access
)
19049 return Is_Non_Null
;
19051 -- "null" yields null
19053 elsif Nkind
(N
) = N_Null
then
19056 -- Check the status of the operand of a type conversion
19058 elsif Nkind
(N
) = N_Type_Conversion
then
19059 return Null_Status
(Expression
(N
));
19061 -- The input denotes a reference to an entity. Determine whether the
19062 -- entity or its type yields a null or non-null value.
19064 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
19065 return Null_Status_Of_Entity
(Entity
(N
));
19068 -- Otherwise it is not possible to determine the null status of the
19069 -- subexpression at compile time without resorting to simple flow
19075 --------------------------------------
19076 -- Null_To_Null_Address_Convert_OK --
19077 --------------------------------------
19079 function Null_To_Null_Address_Convert_OK
19081 Typ
: Entity_Id
:= Empty
) return Boolean
19084 if not Relaxed_RM_Semantics
then
19088 if Nkind
(N
) = N_Null
then
19089 return Present
(Typ
) and then Is_Descendant_Of_Address
(Typ
);
19091 elsif Nkind_In
(N
, N_Op_Eq
, N_Op_Ge
, N_Op_Gt
, N_Op_Le
, N_Op_Lt
, N_Op_Ne
)
19094 L
: constant Node_Id
:= Left_Opnd
(N
);
19095 R
: constant Node_Id
:= Right_Opnd
(N
);
19098 -- We check the Etype of the complementary operand since the
19099 -- N_Null node is not decorated at this stage.
19102 ((Nkind
(L
) = N_Null
19103 and then Is_Descendant_Of_Address
(Etype
(R
)))
19105 (Nkind
(R
) = N_Null
19106 and then Is_Descendant_Of_Address
(Etype
(L
))));
19111 end Null_To_Null_Address_Convert_OK
;
19113 -------------------------
19114 -- Object_Access_Level --
19115 -------------------------
19117 -- Returns the static accessibility level of the view denoted by Obj. Note
19118 -- that the value returned is the result of a call to Scope_Depth. Only
19119 -- scope depths associated with dynamic scopes can actually be returned.
19120 -- Since only relative levels matter for accessibility checking, the fact
19121 -- that the distance between successive levels of accessibility is not
19122 -- always one is immaterial (invariant: if level(E2) is deeper than
19123 -- level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
19125 function Object_Access_Level
(Obj
: Node_Id
) return Uint
is
19126 function Is_Interface_Conversion
(N
: Node_Id
) return Boolean;
19127 -- Determine whether N is a construct of the form
19128 -- Some_Type (Operand._tag'Address)
19129 -- This construct appears in the context of dispatching calls.
19131 function Reference_To
(Obj
: Node_Id
) return Node_Id
;
19132 -- An explicit dereference is created when removing side-effects from
19133 -- expressions for constraint checking purposes. In this case a local
19134 -- access type is created for it. The correct access level is that of
19135 -- the original source node. We detect this case by noting that the
19136 -- prefix of the dereference is created by an object declaration whose
19137 -- initial expression is a reference.
19139 -----------------------------
19140 -- Is_Interface_Conversion --
19141 -----------------------------
19143 function Is_Interface_Conversion
(N
: Node_Id
) return Boolean is
19145 return Nkind
(N
) = N_Unchecked_Type_Conversion
19146 and then Nkind
(Expression
(N
)) = N_Attribute_Reference
19147 and then Attribute_Name
(Expression
(N
)) = Name_Address
;
19148 end Is_Interface_Conversion
;
19154 function Reference_To
(Obj
: Node_Id
) return Node_Id
is
19155 Pref
: constant Node_Id
:= Prefix
(Obj
);
19157 if Is_Entity_Name
(Pref
)
19158 and then Nkind
(Parent
(Entity
(Pref
))) = N_Object_Declaration
19159 and then Present
(Expression
(Parent
(Entity
(Pref
))))
19160 and then Nkind
(Expression
(Parent
(Entity
(Pref
)))) = N_Reference
19162 return (Prefix
(Expression
(Parent
(Entity
(Pref
)))));
19172 -- Start of processing for Object_Access_Level
19175 if Nkind
(Obj
) = N_Defining_Identifier
19176 or else Is_Entity_Name
(Obj
)
19178 if Nkind
(Obj
) = N_Defining_Identifier
then
19184 if Is_Prival
(E
) then
19185 E
:= Prival_Link
(E
);
19188 -- If E is a type then it denotes a current instance. For this case
19189 -- we add one to the normal accessibility level of the type to ensure
19190 -- that current instances are treated as always being deeper than
19191 -- than the level of any visible named access type (see 3.10.2(21)).
19193 if Is_Type
(E
) then
19194 return Type_Access_Level
(E
) + 1;
19196 elsif Present
(Renamed_Object
(E
)) then
19197 return Object_Access_Level
(Renamed_Object
(E
));
19199 -- Similarly, if E is a component of the current instance of a
19200 -- protected type, any instance of it is assumed to be at a deeper
19201 -- level than the type. For a protected object (whose type is an
19202 -- anonymous protected type) its components are at the same level
19203 -- as the type itself.
19205 elsif not Is_Overloadable
(E
)
19206 and then Ekind
(Scope
(E
)) = E_Protected_Type
19207 and then Comes_From_Source
(Scope
(E
))
19209 return Type_Access_Level
(Scope
(E
)) + 1;
19212 -- Aliased formals of functions take their access level from the
19213 -- point of call, i.e. require a dynamic check. For static check
19214 -- purposes, this is smaller than the level of the subprogram
19215 -- itself. For procedures the aliased makes no difference.
19218 and then Is_Aliased
(E
)
19219 and then Ekind
(Scope
(E
)) = E_Function
19221 return Type_Access_Level
(Etype
(E
));
19224 return Scope_Depth
(Enclosing_Dynamic_Scope
(E
));
19228 elsif Nkind_In
(Obj
, N_Indexed_Component
, N_Selected_Component
) then
19229 if Is_Access_Type
(Etype
(Prefix
(Obj
))) then
19230 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
19232 return Object_Access_Level
(Prefix
(Obj
));
19235 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
19237 -- If the prefix is a selected access discriminant then we make a
19238 -- recursive call on the prefix, which will in turn check the level
19239 -- of the prefix object of the selected discriminant.
19241 -- In Ada 2012, if the discriminant has implicit dereference and
19242 -- the context is a selected component, treat this as an object of
19243 -- unknown scope (see below). This is necessary in compile-only mode;
19244 -- otherwise expansion will already have transformed the prefix into
19247 if Nkind
(Prefix
(Obj
)) = N_Selected_Component
19248 and then Ekind
(Etype
(Prefix
(Obj
))) = E_Anonymous_Access_Type
19250 Ekind
(Entity
(Selector_Name
(Prefix
(Obj
)))) = E_Discriminant
19252 (not Has_Implicit_Dereference
19253 (Entity
(Selector_Name
(Prefix
(Obj
))))
19254 or else Nkind
(Parent
(Obj
)) /= N_Selected_Component
)
19256 return Object_Access_Level
(Prefix
(Obj
));
19258 -- Detect an interface conversion in the context of a dispatching
19259 -- call. Use the original form of the conversion to find the access
19260 -- level of the operand.
19262 elsif Is_Interface
(Etype
(Obj
))
19263 and then Is_Interface_Conversion
(Prefix
(Obj
))
19264 and then Nkind
(Original_Node
(Obj
)) = N_Type_Conversion
19266 return Object_Access_Level
(Original_Node
(Obj
));
19268 elsif not Comes_From_Source
(Obj
) then
19270 Ref
: constant Node_Id
:= Reference_To
(Obj
);
19272 if Present
(Ref
) then
19273 return Object_Access_Level
(Ref
);
19275 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
19280 return Type_Access_Level
(Etype
(Prefix
(Obj
)));
19283 elsif Nkind_In
(Obj
, N_Type_Conversion
, N_Unchecked_Type_Conversion
) then
19284 return Object_Access_Level
(Expression
(Obj
));
19286 elsif Nkind
(Obj
) = N_Function_Call
then
19288 -- Function results are objects, so we get either the access level of
19289 -- the function or, in the case of an indirect call, the level of the
19290 -- access-to-subprogram type. (This code is used for Ada 95, but it
19291 -- looks wrong, because it seems that we should be checking the level
19292 -- of the call itself, even for Ada 95. However, using the Ada 2005
19293 -- version of the code causes regressions in several tests that are
19294 -- compiled with -gnat95. ???)
19296 if Ada_Version
< Ada_2005
then
19297 if Is_Entity_Name
(Name
(Obj
)) then
19298 return Subprogram_Access_Level
(Entity
(Name
(Obj
)));
19300 return Type_Access_Level
(Etype
(Prefix
(Name
(Obj
))));
19303 -- For Ada 2005, the level of the result object of a function call is
19304 -- defined to be the level of the call's innermost enclosing master.
19305 -- We determine that by querying the depth of the innermost enclosing
19309 Return_Master_Scope_Depth_Of_Call
: declare
19310 function Innermost_Master_Scope_Depth
19311 (N
: Node_Id
) return Uint
;
19312 -- Returns the scope depth of the given node's innermost
19313 -- enclosing dynamic scope (effectively the accessibility
19314 -- level of the innermost enclosing master).
19316 ----------------------------------
19317 -- Innermost_Master_Scope_Depth --
19318 ----------------------------------
19320 function Innermost_Master_Scope_Depth
19321 (N
: Node_Id
) return Uint
19323 Node_Par
: Node_Id
:= Parent
(N
);
19326 -- Locate the nearest enclosing node (by traversing Parents)
19327 -- that Defining_Entity can be applied to, and return the
19328 -- depth of that entity's nearest enclosing dynamic scope.
19330 while Present
(Node_Par
) loop
19331 case Nkind
(Node_Par
) is
19332 when N_Abstract_Subprogram_Declaration
19333 | N_Block_Statement
19335 | N_Component_Declaration
19337 | N_Entry_Declaration
19338 | N_Exception_Declaration
19339 | N_Formal_Object_Declaration
19340 | N_Formal_Package_Declaration
19341 | N_Formal_Subprogram_Declaration
19342 | N_Formal_Type_Declaration
19343 | N_Full_Type_Declaration
19344 | N_Function_Specification
19345 | N_Generic_Declaration
19346 | N_Generic_Instantiation
19347 | N_Implicit_Label_Declaration
19348 | N_Incomplete_Type_Declaration
19349 | N_Loop_Parameter_Specification
19350 | N_Number_Declaration
19351 | N_Object_Declaration
19352 | N_Package_Declaration
19353 | N_Package_Specification
19354 | N_Parameter_Specification
19355 | N_Private_Extension_Declaration
19356 | N_Private_Type_Declaration
19357 | N_Procedure_Specification
19359 | N_Protected_Type_Declaration
19360 | N_Renaming_Declaration
19361 | N_Single_Protected_Declaration
19362 | N_Single_Task_Declaration
19363 | N_Subprogram_Declaration
19364 | N_Subtype_Declaration
19366 | N_Task_Type_Declaration
19369 (Nearest_Dynamic_Scope
19370 (Defining_Entity
(Node_Par
)));
19376 Node_Par
:= Parent
(Node_Par
);
19379 pragma Assert
(False);
19381 -- Should never reach the following return
19383 return Scope_Depth
(Current_Scope
) + 1;
19384 end Innermost_Master_Scope_Depth
;
19386 -- Start of processing for Return_Master_Scope_Depth_Of_Call
19389 return Innermost_Master_Scope_Depth
(Obj
);
19390 end Return_Master_Scope_Depth_Of_Call
;
19393 -- For convenience we handle qualified expressions, even though they
19394 -- aren't technically object names.
19396 elsif Nkind
(Obj
) = N_Qualified_Expression
then
19397 return Object_Access_Level
(Expression
(Obj
));
19399 -- Ditto for aggregates. They have the level of the temporary that
19400 -- will hold their value.
19402 elsif Nkind
(Obj
) = N_Aggregate
then
19403 return Object_Access_Level
(Current_Scope
);
19405 -- Otherwise return the scope level of Standard. (If there are cases
19406 -- that fall through to this point they will be treated as having
19407 -- global accessibility for now. ???)
19410 return Scope_Depth
(Standard_Standard
);
19412 end Object_Access_Level
;
19414 ----------------------------------
19415 -- Old_Requires_Transient_Scope --
19416 ----------------------------------
19418 function Old_Requires_Transient_Scope
(Id
: Entity_Id
) return Boolean is
19419 Typ
: constant Entity_Id
:= Underlying_Type
(Id
);
19422 -- This is a private type which is not completed yet. This can only
19423 -- happen in a default expression (of a formal parameter or of a
19424 -- record component). Do not expand transient scope in this case.
19429 -- Do not expand transient scope for non-existent procedure return
19431 elsif Typ
= Standard_Void_Type
then
19434 -- Elementary types do not require a transient scope
19436 elsif Is_Elementary_Type
(Typ
) then
19439 -- Generally, indefinite subtypes require a transient scope, since the
19440 -- back end cannot generate temporaries, since this is not a valid type
19441 -- for declaring an object. It might be possible to relax this in the
19442 -- future, e.g. by declaring the maximum possible space for the type.
19444 elsif not Is_Definite_Subtype
(Typ
) then
19447 -- Functions returning tagged types may dispatch on result so their
19448 -- returned value is allocated on the secondary stack. Controlled
19449 -- type temporaries need finalization.
19451 elsif Is_Tagged_Type
(Typ
) or else Has_Controlled_Component
(Typ
) then
19456 elsif Is_Record_Type
(Typ
) then
19461 Comp
:= First_Entity
(Typ
);
19462 while Present
(Comp
) loop
19463 if Ekind
(Comp
) = E_Component
then
19465 -- ???It's not clear we need a full recursive call to
19466 -- Old_Requires_Transient_Scope here. Note that the
19467 -- following can't happen.
19469 pragma Assert
(Is_Definite_Subtype
(Etype
(Comp
)));
19470 pragma Assert
(not Has_Controlled_Component
(Etype
(Comp
)));
19472 if Old_Requires_Transient_Scope
(Etype
(Comp
)) then
19477 Next_Entity
(Comp
);
19483 -- String literal types never require transient scope
19485 elsif Ekind
(Typ
) = E_String_Literal_Subtype
then
19488 -- Array type. Note that we already know that this is a constrained
19489 -- array, since unconstrained arrays will fail the indefinite test.
19491 elsif Is_Array_Type
(Typ
) then
19493 -- If component type requires a transient scope, the array does too
19495 if Old_Requires_Transient_Scope
(Component_Type
(Typ
)) then
19498 -- Otherwise, we only need a transient scope if the size depends on
19499 -- the value of one or more discriminants.
19502 return Size_Depends_On_Discriminant
(Typ
);
19505 -- All other cases do not require a transient scope
19508 pragma Assert
(Is_Protected_Type
(Typ
) or else Is_Task_Type
(Typ
));
19511 end Old_Requires_Transient_Scope
;
19513 ---------------------------------
19514 -- Original_Aspect_Pragma_Name --
19515 ---------------------------------
19517 function Original_Aspect_Pragma_Name
(N
: Node_Id
) return Name_Id
is
19519 Item_Nam
: Name_Id
;
19522 pragma Assert
(Nkind_In
(N
, N_Aspect_Specification
, N_Pragma
));
19526 -- The pragma was generated to emulate an aspect, use the original
19527 -- aspect specification.
19529 if Nkind
(Item
) = N_Pragma
and then From_Aspect_Specification
(Item
) then
19530 Item
:= Corresponding_Aspect
(Item
);
19533 -- Retrieve the name of the aspect/pragma. Note that Pre, Pre_Class,
19534 -- Post and Post_Class rewrite their pragma identifier to preserve the
19536 -- ??? this is kludgey
19538 if Nkind
(Item
) = N_Pragma
then
19539 Item_Nam
:= Chars
(Original_Node
(Pragma_Identifier
(Item
)));
19542 pragma Assert
(Nkind
(Item
) = N_Aspect_Specification
);
19543 Item_Nam
:= Chars
(Identifier
(Item
));
19546 -- Deal with 'Class by converting the name to its _XXX form
19548 if Class_Present
(Item
) then
19549 if Item_Nam
= Name_Invariant
then
19550 Item_Nam
:= Name_uInvariant
;
19552 elsif Item_Nam
= Name_Post
then
19553 Item_Nam
:= Name_uPost
;
19555 elsif Item_Nam
= Name_Pre
then
19556 Item_Nam
:= Name_uPre
;
19558 elsif Nam_In
(Item_Nam
, Name_Type_Invariant
,
19559 Name_Type_Invariant_Class
)
19561 Item_Nam
:= Name_uType_Invariant
;
19563 -- Nothing to do for other cases (e.g. a Check that derived from
19564 -- Pre_Class and has the flag set). Also we do nothing if the name
19565 -- is already in special _xxx form.
19571 end Original_Aspect_Pragma_Name
;
19573 --------------------------------------
19574 -- Original_Corresponding_Operation --
19575 --------------------------------------
19577 function Original_Corresponding_Operation
(S
: Entity_Id
) return Entity_Id
19579 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(S
);
19582 -- If S is an inherited primitive S2 the original corresponding
19583 -- operation of S is the original corresponding operation of S2
19585 if Present
(Alias
(S
))
19586 and then Find_Dispatching_Type
(Alias
(S
)) /= Typ
19588 return Original_Corresponding_Operation
(Alias
(S
));
19590 -- If S overrides an inherited subprogram S2 the original corresponding
19591 -- operation of S is the original corresponding operation of S2
19593 elsif Present
(Overridden_Operation
(S
)) then
19594 return Original_Corresponding_Operation
(Overridden_Operation
(S
));
19596 -- otherwise it is S itself
19601 end Original_Corresponding_Operation
;
19603 -------------------
19604 -- Output_Entity --
19605 -------------------
19607 procedure Output_Entity
(Id
: Entity_Id
) is
19611 Scop
:= Scope
(Id
);
19613 -- The entity may lack a scope when it is in the process of being
19614 -- analyzed. Use the current scope as an approximation.
19617 Scop
:= Current_Scope
;
19620 Output_Name
(Chars
(Id
), Scop
);
19627 procedure Output_Name
(Nam
: Name_Id
; Scop
: Entity_Id
:= Current_Scope
) is
19631 (Get_Qualified_Name
19638 ----------------------
19639 -- Policy_In_Effect --
19640 ----------------------
19642 function Policy_In_Effect
(Policy
: Name_Id
) return Name_Id
is
19643 function Policy_In_List
(List
: Node_Id
) return Name_Id
;
19644 -- Determine the mode of a policy in a N_Pragma list
19646 --------------------
19647 -- Policy_In_List --
19648 --------------------
19650 function Policy_In_List
(List
: Node_Id
) return Name_Id
is
19657 while Present
(Prag
) loop
19658 Arg1
:= First
(Pragma_Argument_Associations
(Prag
));
19659 Arg2
:= Next
(Arg1
);
19661 Arg1
:= Get_Pragma_Arg
(Arg1
);
19662 Arg2
:= Get_Pragma_Arg
(Arg2
);
19664 -- The current Check_Policy pragma matches the requested policy or
19665 -- appears in the single argument form (Assertion, policy_id).
19667 if Nam_In
(Chars
(Arg1
), Name_Assertion
, Policy
) then
19668 return Chars
(Arg2
);
19671 Prag
:= Next_Pragma
(Prag
);
19675 end Policy_In_List
;
19681 -- Start of processing for Policy_In_Effect
19684 if not Is_Valid_Assertion_Kind
(Policy
) then
19685 raise Program_Error
;
19688 -- Inspect all policy pragmas that appear within scopes (if any)
19690 Kind
:= Policy_In_List
(Check_Policy_List
);
19692 -- Inspect all configuration policy pragmas (if any)
19694 if Kind
= No_Name
then
19695 Kind
:= Policy_In_List
(Check_Policy_List_Config
);
19698 -- The context lacks policy pragmas, determine the mode based on whether
19699 -- assertions are enabled at the configuration level. This ensures that
19700 -- the policy is preserved when analyzing generics.
19702 if Kind
= No_Name
then
19703 if Assertions_Enabled_Config
then
19704 Kind
:= Name_Check
;
19706 Kind
:= Name_Ignore
;
19711 end Policy_In_Effect
;
19713 ----------------------------------
19714 -- Predicate_Tests_On_Arguments --
19715 ----------------------------------
19717 function Predicate_Tests_On_Arguments
(Subp
: Entity_Id
) return Boolean is
19719 -- Always test predicates on indirect call
19721 if Ekind
(Subp
) = E_Subprogram_Type
then
19724 -- Do not test predicates on call to generated default Finalize, since
19725 -- we are not interested in whether something we are finalizing (and
19726 -- typically destroying) satisfies its predicates.
19728 elsif Chars
(Subp
) = Name_Finalize
19729 and then not Comes_From_Source
(Subp
)
19733 -- Do not test predicates on any internally generated routines
19735 elsif Is_Internal_Name
(Chars
(Subp
)) then
19738 -- Do not test predicates on call to Init_Proc, since if needed the
19739 -- predicate test will occur at some other point.
19741 elsif Is_Init_Proc
(Subp
) then
19744 -- Do not test predicates on call to predicate function, since this
19745 -- would cause infinite recursion.
19747 elsif Ekind
(Subp
) = E_Function
19748 and then (Is_Predicate_Function
(Subp
)
19750 Is_Predicate_Function_M
(Subp
))
19754 -- For now, no other exceptions
19759 end Predicate_Tests_On_Arguments
;
19761 -----------------------
19762 -- Private_Component --
19763 -----------------------
19765 function Private_Component
(Type_Id
: Entity_Id
) return Entity_Id
is
19766 Ancestor
: constant Entity_Id
:= Base_Type
(Type_Id
);
19768 function Trace_Components
19770 Check
: Boolean) return Entity_Id
;
19771 -- Recursive function that does the work, and checks against circular
19772 -- definition for each subcomponent type.
19774 ----------------------
19775 -- Trace_Components --
19776 ----------------------
19778 function Trace_Components
19780 Check
: Boolean) return Entity_Id
19782 Btype
: constant Entity_Id
:= Base_Type
(T
);
19783 Component
: Entity_Id
;
19785 Candidate
: Entity_Id
:= Empty
;
19788 if Check
and then Btype
= Ancestor
then
19789 Error_Msg_N
("circular type definition", Type_Id
);
19793 if Is_Private_Type
(Btype
) and then not Is_Generic_Type
(Btype
) then
19794 if Present
(Full_View
(Btype
))
19795 and then Is_Record_Type
(Full_View
(Btype
))
19796 and then not Is_Frozen
(Btype
)
19798 -- To indicate that the ancestor depends on a private type, the
19799 -- current Btype is sufficient. However, to check for circular
19800 -- definition we must recurse on the full view.
19802 Candidate
:= Trace_Components
(Full_View
(Btype
), True);
19804 if Candidate
= Any_Type
then
19814 elsif Is_Array_Type
(Btype
) then
19815 return Trace_Components
(Component_Type
(Btype
), True);
19817 elsif Is_Record_Type
(Btype
) then
19818 Component
:= First_Entity
(Btype
);
19819 while Present
(Component
)
19820 and then Comes_From_Source
(Component
)
19822 -- Skip anonymous types generated by constrained components
19824 if not Is_Type
(Component
) then
19825 P
:= Trace_Components
(Etype
(Component
), True);
19827 if Present
(P
) then
19828 if P
= Any_Type
then
19836 Next_Entity
(Component
);
19844 end Trace_Components
;
19846 -- Start of processing for Private_Component
19849 return Trace_Components
(Type_Id
, False);
19850 end Private_Component
;
19852 ---------------------------
19853 -- Primitive_Names_Match --
19854 ---------------------------
19856 function Primitive_Names_Match
(E1
, E2
: Entity_Id
) return Boolean is
19857 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
;
19858 -- Given an internal name, returns the corresponding non-internal name
19860 ------------------------
19861 -- Non_Internal_Name --
19862 ------------------------
19864 function Non_Internal_Name
(E
: Entity_Id
) return Name_Id
is
19866 Get_Name_String
(Chars
(E
));
19867 Name_Len
:= Name_Len
- 1;
19869 end Non_Internal_Name
;
19871 -- Start of processing for Primitive_Names_Match
19874 pragma Assert
(Present
(E1
) and then Present
(E2
));
19876 return Chars
(E1
) = Chars
(E2
)
19878 (not Is_Internal_Name
(Chars
(E1
))
19879 and then Is_Internal_Name
(Chars
(E2
))
19880 and then Non_Internal_Name
(E2
) = Chars
(E1
))
19882 (not Is_Internal_Name
(Chars
(E2
))
19883 and then Is_Internal_Name
(Chars
(E1
))
19884 and then Non_Internal_Name
(E1
) = Chars
(E2
))
19886 (Is_Predefined_Dispatching_Operation
(E1
)
19887 and then Is_Predefined_Dispatching_Operation
(E2
)
19888 and then Same_TSS
(E1
, E2
))
19890 (Is_Init_Proc
(E1
) and then Is_Init_Proc
(E2
));
19891 end Primitive_Names_Match
;
19893 -----------------------
19894 -- Process_End_Label --
19895 -----------------------
19897 procedure Process_End_Label
19906 Label_Ref
: Boolean;
19907 -- Set True if reference to end label itself is required
19910 -- Gets set to the operator symbol or identifier that references the
19911 -- entity Ent. For the child unit case, this is the identifier from the
19912 -- designator. For other cases, this is simply Endl.
19914 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
);
19915 -- N is an identifier node that appears as a parent unit reference in
19916 -- the case where Ent is a child unit. This procedure generates an
19917 -- appropriate cross-reference entry. E is the corresponding entity.
19919 -------------------------
19920 -- Generate_Parent_Ref --
19921 -------------------------
19923 procedure Generate_Parent_Ref
(N
: Node_Id
; E
: Entity_Id
) is
19925 -- If names do not match, something weird, skip reference
19927 if Chars
(E
) = Chars
(N
) then
19929 -- Generate the reference. We do NOT consider this as a reference
19930 -- for unreferenced symbol purposes.
19932 Generate_Reference
(E
, N
, 'r', Set_Ref
=> False, Force
=> True);
19934 if Style_Check
then
19935 Style
.Check_Identifier
(N
, E
);
19938 end Generate_Parent_Ref
;
19940 -- Start of processing for Process_End_Label
19943 -- If no node, ignore. This happens in some error situations, and
19944 -- also for some internally generated structures where no end label
19945 -- references are required in any case.
19951 -- Nothing to do if no End_Label, happens for internally generated
19952 -- constructs where we don't want an end label reference anyway. Also
19953 -- nothing to do if Endl is a string literal, which means there was
19954 -- some prior error (bad operator symbol)
19956 Endl
:= End_Label
(N
);
19958 if No
(Endl
) or else Nkind
(Endl
) = N_String_Literal
then
19962 -- Reference node is not in extended main source unit
19964 if not In_Extended_Main_Source_Unit
(N
) then
19966 -- Generally we do not collect references except for the extended
19967 -- main source unit. The one exception is the 'e' entry for a
19968 -- package spec, where it is useful for a client to have the
19969 -- ending information to define scopes.
19975 Label_Ref
:= False;
19977 -- For this case, we can ignore any parent references, but we
19978 -- need the package name itself for the 'e' entry.
19980 if Nkind
(Endl
) = N_Designator
then
19981 Endl
:= Identifier
(Endl
);
19985 -- Reference is in extended main source unit
19990 -- For designator, generate references for the parent entries
19992 if Nkind
(Endl
) = N_Designator
then
19994 -- Generate references for the prefix if the END line comes from
19995 -- source (otherwise we do not need these references) We climb the
19996 -- scope stack to find the expected entities.
19998 if Comes_From_Source
(Endl
) then
19999 Nam
:= Name
(Endl
);
20000 Scop
:= Current_Scope
;
20001 while Nkind
(Nam
) = N_Selected_Component
loop
20002 Scop
:= Scope
(Scop
);
20003 exit when No
(Scop
);
20004 Generate_Parent_Ref
(Selector_Name
(Nam
), Scop
);
20005 Nam
:= Prefix
(Nam
);
20008 if Present
(Scop
) then
20009 Generate_Parent_Ref
(Nam
, Scope
(Scop
));
20013 Endl
:= Identifier
(Endl
);
20017 -- If the end label is not for the given entity, then either we have
20018 -- some previous error, or this is a generic instantiation for which
20019 -- we do not need to make a cross-reference in this case anyway. In
20020 -- either case we simply ignore the call.
20022 if Chars
(Ent
) /= Chars
(Endl
) then
20026 -- If label was really there, then generate a normal reference and then
20027 -- adjust the location in the end label to point past the name (which
20028 -- should almost always be the semicolon).
20030 Loc
:= Sloc
(Endl
);
20032 if Comes_From_Source
(Endl
) then
20034 -- If a label reference is required, then do the style check and
20035 -- generate an l-type cross-reference entry for the label
20038 if Style_Check
then
20039 Style
.Check_Identifier
(Endl
, Ent
);
20042 Generate_Reference
(Ent
, Endl
, 'l', Set_Ref
=> False);
20045 -- Set the location to point past the label (normally this will
20046 -- mean the semicolon immediately following the label). This is
20047 -- done for the sake of the 'e' or 't' entry generated below.
20049 Get_Decoded_Name_String
(Chars
(Endl
));
20050 Set_Sloc
(Endl
, Sloc
(Endl
) + Source_Ptr
(Name_Len
));
20053 -- In SPARK mode, no missing label is allowed for packages and
20054 -- subprogram bodies. Detect those cases by testing whether
20055 -- Process_End_Label was called for a body (Typ = 't') or a package.
20057 if Restriction_Check_Required
(SPARK_05
)
20058 and then (Typ
= 't' or else Ekind
(Ent
) = E_Package
)
20060 Error_Msg_Node_1
:= Endl
;
20061 Check_SPARK_05_Restriction
20062 ("`END &` required", Endl
, Force
=> True);
20066 -- Now generate the e/t reference
20068 Generate_Reference
(Ent
, Endl
, Typ
, Set_Ref
=> False, Force
=> True);
20070 -- Restore Sloc, in case modified above, since we have an identifier
20071 -- and the normal Sloc should be left set in the tree.
20073 Set_Sloc
(Endl
, Loc
);
20074 end Process_End_Label
;
20076 --------------------------------
20077 -- Propagate_Concurrent_Flags --
20078 --------------------------------
20080 procedure Propagate_Concurrent_Flags
20082 Comp_Typ
: Entity_Id
)
20085 if Has_Task
(Comp_Typ
) then
20086 Set_Has_Task
(Typ
);
20089 if Has_Protected
(Comp_Typ
) then
20090 Set_Has_Protected
(Typ
);
20093 if Has_Timing_Event
(Comp_Typ
) then
20094 Set_Has_Timing_Event
(Typ
);
20096 end Propagate_Concurrent_Flags
;
20098 ------------------------------
20099 -- Propagate_DIC_Attributes --
20100 ------------------------------
20102 procedure Propagate_DIC_Attributes
20104 From_Typ
: Entity_Id
)
20106 DIC_Proc
: Entity_Id
;
20109 if Present
(Typ
) and then Present
(From_Typ
) then
20110 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
20112 -- Nothing to do if both the source and the destination denote the
20115 if From_Typ
= Typ
then
20119 DIC_Proc
:= DIC_Procedure
(From_Typ
);
20121 -- The setting of the attributes is intentionally conservative. This
20122 -- prevents accidental clobbering of enabled attributes.
20124 if Has_Inherited_DIC
(From_Typ
)
20125 and then not Has_Inherited_DIC
(Typ
)
20127 Set_Has_Inherited_DIC
(Typ
);
20130 if Has_Own_DIC
(From_Typ
) and then not Has_Own_DIC
(Typ
) then
20131 Set_Has_Own_DIC
(Typ
);
20134 if Present
(DIC_Proc
) and then No
(DIC_Procedure
(Typ
)) then
20135 Set_DIC_Procedure
(Typ
, DIC_Proc
);
20138 end Propagate_DIC_Attributes
;
20140 ------------------------------------
20141 -- Propagate_Invariant_Attributes --
20142 ------------------------------------
20144 procedure Propagate_Invariant_Attributes
20146 From_Typ
: Entity_Id
)
20148 Full_IP
: Entity_Id
;
20149 Part_IP
: Entity_Id
;
20152 if Present
(Typ
) and then Present
(From_Typ
) then
20153 pragma Assert
(Is_Type
(Typ
) and then Is_Type
(From_Typ
));
20155 -- Nothing to do if both the source and the destination denote the
20158 if From_Typ
= Typ
then
20162 Full_IP
:= Invariant_Procedure
(From_Typ
);
20163 Part_IP
:= Partial_Invariant_Procedure
(From_Typ
);
20165 -- The setting of the attributes is intentionally conservative. This
20166 -- prevents accidental clobbering of enabled attributes.
20168 if Has_Inheritable_Invariants
(From_Typ
)
20169 and then not Has_Inheritable_Invariants
(Typ
)
20171 Set_Has_Inheritable_Invariants
(Typ
, True);
20174 if Has_Inherited_Invariants
(From_Typ
)
20175 and then not Has_Inherited_Invariants
(Typ
)
20177 Set_Has_Inherited_Invariants
(Typ
, True);
20180 if Has_Own_Invariants
(From_Typ
)
20181 and then not Has_Own_Invariants
(Typ
)
20183 Set_Has_Own_Invariants
(Typ
, True);
20186 if Present
(Full_IP
) and then No
(Invariant_Procedure
(Typ
)) then
20187 Set_Invariant_Procedure
(Typ
, Full_IP
);
20190 if Present
(Part_IP
) and then No
(Partial_Invariant_Procedure
(Typ
))
20192 Set_Partial_Invariant_Procedure
(Typ
, Part_IP
);
20195 end Propagate_Invariant_Attributes
;
20197 ---------------------------------------
20198 -- Record_Possible_Part_Of_Reference --
20199 ---------------------------------------
20201 procedure Record_Possible_Part_Of_Reference
20202 (Var_Id
: Entity_Id
;
20205 Encap
: constant Entity_Id
:= Encapsulating_State
(Var_Id
);
20209 -- The variable is a constituent of a single protected/task type. Such
20210 -- a variable acts as a component of the type and must appear within a
20211 -- specific region (SPARK RM 9.3). Instead of recording the reference,
20212 -- verify its legality now.
20214 if Present
(Encap
) and then Is_Single_Concurrent_Object
(Encap
) then
20215 Check_Part_Of_Reference
(Var_Id
, Ref
);
20217 -- The variable is subject to pragma Part_Of and may eventually become a
20218 -- constituent of a single protected/task type. Record the reference to
20219 -- verify its placement when the contract of the variable is analyzed.
20221 elsif Present
(Get_Pragma
(Var_Id
, Pragma_Part_Of
)) then
20222 Refs
:= Part_Of_References
(Var_Id
);
20225 Refs
:= New_Elmt_List
;
20226 Set_Part_Of_References
(Var_Id
, Refs
);
20229 Append_Elmt
(Ref
, Refs
);
20231 end Record_Possible_Part_Of_Reference
;
20237 function Referenced
(Id
: Entity_Id
; Expr
: Node_Id
) return Boolean is
20238 Seen
: Boolean := False;
20240 function Is_Reference
(N
: Node_Id
) return Traverse_Result
;
20241 -- Determine whether node N denotes a reference to Id. If this is the
20242 -- case, set global flag Seen to True and stop the traversal.
20248 function Is_Reference
(N
: Node_Id
) return Traverse_Result
is
20250 if Is_Entity_Name
(N
)
20251 and then Present
(Entity
(N
))
20252 and then Entity
(N
) = Id
20261 procedure Inspect_Expression
is new Traverse_Proc
(Is_Reference
);
20263 -- Start of processing for Referenced
20266 Inspect_Expression
(Expr
);
20270 ------------------------------------
20271 -- References_Generic_Formal_Type --
20272 ------------------------------------
20274 function References_Generic_Formal_Type
(N
: Node_Id
) return Boolean is
20276 function Process
(N
: Node_Id
) return Traverse_Result
;
20277 -- Process one node in search for generic formal type
20283 function Process
(N
: Node_Id
) return Traverse_Result
is
20285 if Nkind
(N
) in N_Has_Entity
then
20287 E
: constant Entity_Id
:= Entity
(N
);
20289 if Present
(E
) then
20290 if Is_Generic_Type
(E
) then
20292 elsif Present
(Etype
(E
))
20293 and then Is_Generic_Type
(Etype
(E
))
20304 function Traverse
is new Traverse_Func
(Process
);
20305 -- Traverse tree to look for generic type
20308 if Inside_A_Generic
then
20309 return Traverse
(N
) = Abandon
;
20313 end References_Generic_Formal_Type
;
20315 --------------------
20316 -- Remove_Homonym --
20317 --------------------
20319 procedure Remove_Homonym
(E
: Entity_Id
) is
20320 Prev
: Entity_Id
:= Empty
;
20324 if E
= Current_Entity
(E
) then
20325 if Present
(Homonym
(E
)) then
20326 Set_Current_Entity
(Homonym
(E
));
20328 Set_Name_Entity_Id
(Chars
(E
), Empty
);
20332 H
:= Current_Entity
(E
);
20333 while Present
(H
) and then H
/= E
loop
20338 -- If E is not on the homonym chain, nothing to do
20340 if Present
(H
) then
20341 Set_Homonym
(Prev
, Homonym
(E
));
20344 end Remove_Homonym
;
20346 ------------------------------
20347 -- Remove_Overloaded_Entity --
20348 ------------------------------
20350 procedure Remove_Overloaded_Entity
(Id
: Entity_Id
) is
20351 procedure Remove_Primitive_Of
(Typ
: Entity_Id
);
20352 -- Remove primitive subprogram Id from the list of primitives that
20353 -- belong to type Typ.
20355 -------------------------
20356 -- Remove_Primitive_Of --
20357 -------------------------
20359 procedure Remove_Primitive_Of
(Typ
: Entity_Id
) is
20363 if Is_Tagged_Type
(Typ
) then
20364 Prims
:= Direct_Primitive_Operations
(Typ
);
20366 if Present
(Prims
) then
20367 Remove
(Prims
, Id
);
20370 end Remove_Primitive_Of
;
20374 Scop
: constant Entity_Id
:= Scope
(Id
);
20375 Formal
: Entity_Id
;
20376 Prev_Id
: Entity_Id
;
20378 -- Start of processing for Remove_Overloaded_Entity
20381 -- Remove the entity from the homonym chain. When the entity is the
20382 -- head of the chain, associate the entry in the name table with its
20383 -- homonym effectively making it the new head of the chain.
20385 if Current_Entity
(Id
) = Id
then
20386 Set_Name_Entity_Id
(Chars
(Id
), Homonym
(Id
));
20388 -- Otherwise link the previous and next homonyms
20391 Prev_Id
:= Current_Entity
(Id
);
20392 while Present
(Prev_Id
) and then Homonym
(Prev_Id
) /= Id
loop
20393 Prev_Id
:= Homonym
(Prev_Id
);
20396 Set_Homonym
(Prev_Id
, Homonym
(Id
));
20399 -- Remove the entity from the scope entity chain. When the entity is
20400 -- the head of the chain, set the next entity as the new head of the
20403 if First_Entity
(Scop
) = Id
then
20405 Set_First_Entity
(Scop
, Next_Entity
(Id
));
20407 -- Otherwise the entity is either in the middle of the chain or it acts
20408 -- as its tail. Traverse and link the previous and next entities.
20411 Prev_Id
:= First_Entity
(Scop
);
20412 while Present
(Prev_Id
) and then Next_Entity
(Prev_Id
) /= Id
loop
20413 Next_Entity
(Prev_Id
);
20416 Set_Next_Entity
(Prev_Id
, Next_Entity
(Id
));
20419 -- Handle the case where the entity acts as the tail of the scope entity
20422 if Last_Entity
(Scop
) = Id
then
20423 Set_Last_Entity
(Scop
, Prev_Id
);
20426 -- The entity denotes a primitive subprogram. Remove it from the list of
20427 -- primitives of the associated controlling type.
20429 if Ekind_In
(Id
, E_Function
, E_Procedure
) and then Is_Primitive
(Id
) then
20430 Formal
:= First_Formal
(Id
);
20431 while Present
(Formal
) loop
20432 if Is_Controlling_Formal
(Formal
) then
20433 Remove_Primitive_Of
(Etype
(Formal
));
20437 Next_Formal
(Formal
);
20440 if Ekind
(Id
) = E_Function
and then Has_Controlling_Result
(Id
) then
20441 Remove_Primitive_Of
(Etype
(Id
));
20444 end Remove_Overloaded_Entity
;
20446 ---------------------
20447 -- Rep_To_Pos_Flag --
20448 ---------------------
20450 function Rep_To_Pos_Flag
(E
: Entity_Id
; Loc
: Source_Ptr
) return Node_Id
is
20452 return New_Occurrence_Of
20453 (Boolean_Literals
(not Range_Checks_Suppressed
(E
)), Loc
);
20454 end Rep_To_Pos_Flag
;
20456 --------------------
20457 -- Require_Entity --
20458 --------------------
20460 procedure Require_Entity
(N
: Node_Id
) is
20462 if Is_Entity_Name
(N
) and then No
(Entity
(N
)) then
20463 if Total_Errors_Detected
/= 0 then
20464 Set_Entity
(N
, Any_Id
);
20466 raise Program_Error
;
20469 end Require_Entity
;
20471 ------------------------------
20472 -- Requires_Transient_Scope --
20473 ------------------------------
20475 -- A transient scope is required when variable-sized temporaries are
20476 -- allocated on the secondary stack, or when finalization actions must be
20477 -- generated before the next instruction.
20479 function Requires_Transient_Scope
(Id
: Entity_Id
) return Boolean is
20480 Old_Result
: constant Boolean := Old_Requires_Transient_Scope
(Id
);
20483 if Debug_Flag_QQ
then
20488 New_Result
: constant Boolean := New_Requires_Transient_Scope
(Id
);
20491 -- Assert that we're not putting things on the secondary stack if we
20492 -- didn't before; we are trying to AVOID secondary stack when
20495 if not Old_Result
then
20496 pragma Assert
(not New_Result
);
20500 if New_Result
/= Old_Result
then
20501 Results_Differ
(Id
, Old_Result
, New_Result
);
20506 end Requires_Transient_Scope
;
20508 --------------------
20509 -- Results_Differ --
20510 --------------------
20512 procedure Results_Differ
20518 if False then -- False to disable; True for debugging
20519 Treepr
.Print_Tree_Node
(Id
);
20521 if Old_Val
= New_Val
then
20522 raise Program_Error
;
20525 end Results_Differ
;
20527 --------------------------
20528 -- Reset_Analyzed_Flags --
20529 --------------------------
20531 procedure Reset_Analyzed_Flags
(N
: Node_Id
) is
20532 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
;
20533 -- Function used to reset Analyzed flags in tree. Note that we do
20534 -- not reset Analyzed flags in entities, since there is no need to
20535 -- reanalyze entities, and indeed, it is wrong to do so, since it
20536 -- can result in generating auxiliary stuff more than once.
20538 --------------------
20539 -- Clear_Analyzed --
20540 --------------------
20542 function Clear_Analyzed
(N
: Node_Id
) return Traverse_Result
is
20544 if Nkind
(N
) not in N_Entity
then
20545 Set_Analyzed
(N
, False);
20549 end Clear_Analyzed
;
20551 procedure Reset_Analyzed
is new Traverse_Proc
(Clear_Analyzed
);
20553 -- Start of processing for Reset_Analyzed_Flags
20556 Reset_Analyzed
(N
);
20557 end Reset_Analyzed_Flags
;
20559 ------------------------
20560 -- Restore_SPARK_Mode --
20561 ------------------------
20563 procedure Restore_SPARK_Mode
20564 (Mode
: SPARK_Mode_Type
;
20568 SPARK_Mode
:= Mode
;
20569 SPARK_Mode_Pragma
:= Prag
;
20570 end Restore_SPARK_Mode
;
20572 --------------------------------
20573 -- Returns_Unconstrained_Type --
20574 --------------------------------
20576 function Returns_Unconstrained_Type
(Subp
: Entity_Id
) return Boolean is
20578 return Ekind
(Subp
) = E_Function
20579 and then not Is_Scalar_Type
(Etype
(Subp
))
20580 and then not Is_Access_Type
(Etype
(Subp
))
20581 and then not Is_Constrained
(Etype
(Subp
));
20582 end Returns_Unconstrained_Type
;
20584 ----------------------------
20585 -- Root_Type_Of_Full_View --
20586 ----------------------------
20588 function Root_Type_Of_Full_View
(T
: Entity_Id
) return Entity_Id
is
20589 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
20592 -- The root type of the full view may itself be a private type. Keep
20593 -- looking for the ultimate derivation parent.
20595 if Is_Private_Type
(Rtyp
) and then Present
(Full_View
(Rtyp
)) then
20596 return Root_Type_Of_Full_View
(Full_View
(Rtyp
));
20600 end Root_Type_Of_Full_View
;
20602 ---------------------------
20603 -- Safe_To_Capture_Value --
20604 ---------------------------
20606 function Safe_To_Capture_Value
20609 Cond
: Boolean := False) return Boolean
20612 -- The only entities for which we track constant values are variables
20613 -- which are not renamings, constants, out parameters, and in out
20614 -- parameters, so check if we have this case.
20616 -- Note: it may seem odd to track constant values for constants, but in
20617 -- fact this routine is used for other purposes than simply capturing
20618 -- the value. In particular, the setting of Known[_Non]_Null.
20620 if (Ekind
(Ent
) = E_Variable
and then No
(Renamed_Object
(Ent
)))
20622 Ekind_In
(Ent
, E_Constant
, E_Out_Parameter
, E_In_Out_Parameter
)
20626 -- For conditionals, we also allow loop parameters and all formals,
20627 -- including in parameters.
20629 elsif Cond
and then Ekind_In
(Ent
, E_Loop_Parameter
, E_In_Parameter
) then
20632 -- For all other cases, not just unsafe, but impossible to capture
20633 -- Current_Value, since the above are the only entities which have
20634 -- Current_Value fields.
20640 -- Skip if volatile or aliased, since funny things might be going on in
20641 -- these cases which we cannot necessarily track. Also skip any variable
20642 -- for which an address clause is given, or whose address is taken. Also
20643 -- never capture value of library level variables (an attempt to do so
20644 -- can occur in the case of package elaboration code).
20646 if Treat_As_Volatile
(Ent
)
20647 or else Is_Aliased
(Ent
)
20648 or else Present
(Address_Clause
(Ent
))
20649 or else Address_Taken
(Ent
)
20650 or else (Is_Library_Level_Entity
(Ent
)
20651 and then Ekind
(Ent
) = E_Variable
)
20656 -- OK, all above conditions are met. We also require that the scope of
20657 -- the reference be the same as the scope of the entity, not counting
20658 -- packages and blocks and loops.
20661 E_Scope
: constant Entity_Id
:= Scope
(Ent
);
20662 R_Scope
: Entity_Id
;
20665 R_Scope
:= Current_Scope
;
20666 while R_Scope
/= Standard_Standard
loop
20667 exit when R_Scope
= E_Scope
;
20669 if not Ekind_In
(R_Scope
, E_Package
, E_Block
, E_Loop
) then
20672 R_Scope
:= Scope
(R_Scope
);
20677 -- We also require that the reference does not appear in a context
20678 -- where it is not sure to be executed (i.e. a conditional context
20679 -- or an exception handler). We skip this if Cond is True, since the
20680 -- capturing of values from conditional tests handles this ok.
20693 -- Seems dubious that case expressions are not handled here ???
20696 while Present
(P
) loop
20697 if Nkind
(P
) = N_If_Statement
20698 or else Nkind
(P
) = N_Case_Statement
20699 or else (Nkind
(P
) in N_Short_Circuit
20700 and then Desc
= Right_Opnd
(P
))
20701 or else (Nkind
(P
) = N_If_Expression
20702 and then Desc
/= First
(Expressions
(P
)))
20703 or else Nkind
(P
) = N_Exception_Handler
20704 or else Nkind
(P
) = N_Selective_Accept
20705 or else Nkind
(P
) = N_Conditional_Entry_Call
20706 or else Nkind
(P
) = N_Timed_Entry_Call
20707 or else Nkind
(P
) = N_Asynchronous_Select
20715 -- A special Ada 2012 case: the original node may be part
20716 -- of the else_actions of a conditional expression, in which
20717 -- case it might not have been expanded yet, and appears in
20718 -- a non-syntactic list of actions. In that case it is clearly
20719 -- not safe to save a value.
20722 and then Is_List_Member
(Desc
)
20723 and then No
(Parent
(List_Containing
(Desc
)))
20731 -- OK, looks safe to set value
20734 end Safe_To_Capture_Value
;
20740 function Same_Name
(N1
, N2
: Node_Id
) return Boolean is
20741 K1
: constant Node_Kind
:= Nkind
(N1
);
20742 K2
: constant Node_Kind
:= Nkind
(N2
);
20745 if (K1
= N_Identifier
or else K1
= N_Defining_Identifier
)
20746 and then (K2
= N_Identifier
or else K2
= N_Defining_Identifier
)
20748 return Chars
(N1
) = Chars
(N2
);
20750 elsif (K1
= N_Selected_Component
or else K1
= N_Expanded_Name
)
20751 and then (K2
= N_Selected_Component
or else K2
= N_Expanded_Name
)
20753 return Same_Name
(Selector_Name
(N1
), Selector_Name
(N2
))
20754 and then Same_Name
(Prefix
(N1
), Prefix
(N2
));
20765 function Same_Object
(Node1
, Node2
: Node_Id
) return Boolean is
20766 N1
: constant Node_Id
:= Original_Node
(Node1
);
20767 N2
: constant Node_Id
:= Original_Node
(Node2
);
20768 -- We do the tests on original nodes, since we are most interested
20769 -- in the original source, not any expansion that got in the way.
20771 K1
: constant Node_Kind
:= Nkind
(N1
);
20772 K2
: constant Node_Kind
:= Nkind
(N2
);
20775 -- First case, both are entities with same entity
20777 if K1
in N_Has_Entity
and then K2
in N_Has_Entity
then
20779 EN1
: constant Entity_Id
:= Entity
(N1
);
20780 EN2
: constant Entity_Id
:= Entity
(N2
);
20782 if Present
(EN1
) and then Present
(EN2
)
20783 and then (Ekind_In
(EN1
, E_Variable
, E_Constant
)
20784 or else Is_Formal
(EN1
))
20792 -- Second case, selected component with same selector, same record
20794 if K1
= N_Selected_Component
20795 and then K2
= N_Selected_Component
20796 and then Chars
(Selector_Name
(N1
)) = Chars
(Selector_Name
(N2
))
20798 return Same_Object
(Prefix
(N1
), Prefix
(N2
));
20800 -- Third case, indexed component with same subscripts, same array
20802 elsif K1
= N_Indexed_Component
20803 and then K2
= N_Indexed_Component
20804 and then Same_Object
(Prefix
(N1
), Prefix
(N2
))
20809 E1
:= First
(Expressions
(N1
));
20810 E2
:= First
(Expressions
(N2
));
20811 while Present
(E1
) loop
20812 if not Same_Value
(E1
, E2
) then
20823 -- Fourth case, slice of same array with same bounds
20826 and then K2
= N_Slice
20827 and then Nkind
(Discrete_Range
(N1
)) = N_Range
20828 and then Nkind
(Discrete_Range
(N2
)) = N_Range
20829 and then Same_Value
(Low_Bound
(Discrete_Range
(N1
)),
20830 Low_Bound
(Discrete_Range
(N2
)))
20831 and then Same_Value
(High_Bound
(Discrete_Range
(N1
)),
20832 High_Bound
(Discrete_Range
(N2
)))
20834 return Same_Name
(Prefix
(N1
), Prefix
(N2
));
20836 -- All other cases, not clearly the same object
20847 function Same_Type
(T1
, T2
: Entity_Id
) return Boolean is
20852 elsif not Is_Constrained
(T1
)
20853 and then not Is_Constrained
(T2
)
20854 and then Base_Type
(T1
) = Base_Type
(T2
)
20858 -- For now don't bother with case of identical constraints, to be
20859 -- fiddled with later on perhaps (this is only used for optimization
20860 -- purposes, so it is not critical to do a best possible job)
20871 function Same_Value
(Node1
, Node2
: Node_Id
) return Boolean is
20873 if Compile_Time_Known_Value
(Node1
)
20874 and then Compile_Time_Known_Value
(Node2
)
20876 -- Handle properly compile-time expressions that are not
20879 if Is_String_Type
(Etype
(Node1
)) then
20880 return Expr_Value_S
(Node1
) = Expr_Value_S
(Node2
);
20883 return Expr_Value
(Node1
) = Expr_Value
(Node2
);
20886 elsif Same_Object
(Node1
, Node2
) then
20893 --------------------
20894 -- Set_SPARK_Mode --
20895 --------------------
20897 procedure Set_SPARK_Mode
(Context
: Entity_Id
) is
20899 -- Do not consider illegal or partially decorated constructs
20901 if Ekind
(Context
) = E_Void
or else Error_Posted
(Context
) then
20904 elsif Present
(SPARK_Pragma
(Context
)) then
20906 (Mode
=> Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Context
)),
20907 Prag
=> SPARK_Pragma
(Context
));
20909 end Set_SPARK_Mode
;
20911 -------------------------
20912 -- Scalar_Part_Present --
20913 -------------------------
20915 function Scalar_Part_Present
(T
: Entity_Id
) return Boolean is
20919 if Is_Scalar_Type
(T
) then
20922 elsif Is_Array_Type
(T
) then
20923 return Scalar_Part_Present
(Component_Type
(T
));
20925 elsif Is_Record_Type
(T
) or else Has_Discriminants
(T
) then
20926 C
:= First_Component_Or_Discriminant
(T
);
20927 while Present
(C
) loop
20928 if Scalar_Part_Present
(Etype
(C
)) then
20931 Next_Component_Or_Discriminant
(C
);
20937 end Scalar_Part_Present
;
20939 ------------------------
20940 -- Scope_Is_Transient --
20941 ------------------------
20943 function Scope_Is_Transient
return Boolean is
20945 return Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
;
20946 end Scope_Is_Transient
;
20952 function Scope_Within
(Scope1
, Scope2
: Entity_Id
) return Boolean is
20957 while Scop
/= Standard_Standard
loop
20958 Scop
:= Scope
(Scop
);
20960 if Scop
= Scope2
then
20968 --------------------------
20969 -- Scope_Within_Or_Same --
20970 --------------------------
20972 function Scope_Within_Or_Same
(Scope1
, Scope2
: Entity_Id
) return Boolean is
20977 while Scop
/= Standard_Standard
loop
20978 if Scop
= Scope2
then
20981 Scop
:= Scope
(Scop
);
20986 end Scope_Within_Or_Same
;
20988 --------------------
20989 -- Set_Convention --
20990 --------------------
20992 procedure Set_Convention
(E
: Entity_Id
; Val
: Snames
.Convention_Id
) is
20994 Basic_Set_Convention
(E
, Val
);
20997 and then Is_Access_Subprogram_Type
(Base_Type
(E
))
20998 and then Has_Foreign_Convention
(E
)
21001 -- A pragma Convention in an instance may apply to the subtype
21002 -- created for a formal, in which case we have already verified
21003 -- that conventions of actual and formal match and there is nothing
21004 -- to flag on the subtype.
21006 if In_Instance
then
21009 Set_Can_Use_Internal_Rep
(E
, False);
21013 -- If E is an object or component, and the type of E is an anonymous
21014 -- access type with no convention set, then also set the convention of
21015 -- the anonymous access type. We do not do this for anonymous protected
21016 -- types, since protected types always have the default convention.
21018 if Present
(Etype
(E
))
21019 and then (Is_Object
(E
)
21020 or else Ekind
(E
) = E_Component
21022 -- Allow E_Void (happens for pragma Convention appearing
21023 -- in the middle of a record applying to a component)
21025 or else Ekind
(E
) = E_Void
)
21028 Typ
: constant Entity_Id
:= Etype
(E
);
21031 if Ekind_In
(Typ
, E_Anonymous_Access_Type
,
21032 E_Anonymous_Access_Subprogram_Type
)
21033 and then not Has_Convention_Pragma
(Typ
)
21035 Basic_Set_Convention
(Typ
, Val
);
21036 Set_Has_Convention_Pragma
(Typ
);
21038 -- And for the access subprogram type, deal similarly with the
21039 -- designated E_Subprogram_Type if it is also internal (which
21042 if Ekind
(Typ
) = E_Anonymous_Access_Subprogram_Type
then
21044 Dtype
: constant Entity_Id
:= Designated_Type
(Typ
);
21046 if Ekind
(Dtype
) = E_Subprogram_Type
21047 and then Is_Itype
(Dtype
)
21048 and then not Has_Convention_Pragma
(Dtype
)
21050 Basic_Set_Convention
(Dtype
, Val
);
21051 Set_Has_Convention_Pragma
(Dtype
);
21058 end Set_Convention
;
21060 ------------------------
21061 -- Set_Current_Entity --
21062 ------------------------
21064 -- The given entity is to be set as the currently visible definition of its
21065 -- associated name (i.e. the Node_Id associated with its name). All we have
21066 -- to do is to get the name from the identifier, and then set the
21067 -- associated Node_Id to point to the given entity.
21069 procedure Set_Current_Entity
(E
: Entity_Id
) is
21071 Set_Name_Entity_Id
(Chars
(E
), E
);
21072 end Set_Current_Entity
;
21074 ---------------------------
21075 -- Set_Debug_Info_Needed --
21076 ---------------------------
21078 procedure Set_Debug_Info_Needed
(T
: Entity_Id
) is
21080 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
);
21081 pragma Inline
(Set_Debug_Info_Needed_If_Not_Set
);
21082 -- Used to set debug info in a related node if not set already
21084 --------------------------------------
21085 -- Set_Debug_Info_Needed_If_Not_Set --
21086 --------------------------------------
21088 procedure Set_Debug_Info_Needed_If_Not_Set
(E
: Entity_Id
) is
21090 if Present
(E
) and then not Needs_Debug_Info
(E
) then
21091 Set_Debug_Info_Needed
(E
);
21093 -- For a private type, indicate that the full view also needs
21094 -- debug information.
21097 and then Is_Private_Type
(E
)
21098 and then Present
(Full_View
(E
))
21100 Set_Debug_Info_Needed
(Full_View
(E
));
21103 end Set_Debug_Info_Needed_If_Not_Set
;
21105 -- Start of processing for Set_Debug_Info_Needed
21108 -- Nothing to do if argument is Empty or has Debug_Info_Off set, which
21109 -- indicates that Debug_Info_Needed is never required for the entity.
21110 -- Nothing to do if entity comes from a predefined file. Library files
21111 -- are compiled without debug information, but inlined bodies of these
21112 -- routines may appear in user code, and debug information on them ends
21113 -- up complicating debugging the user code.
21116 or else Debug_Info_Off
(T
)
21120 elsif In_Inlined_Body
and then In_Predefined_Unit
(T
) then
21121 Set_Needs_Debug_Info
(T
, False);
21124 -- Set flag in entity itself. Note that we will go through the following
21125 -- circuitry even if the flag is already set on T. That's intentional,
21126 -- it makes sure that the flag will be set in subsidiary entities.
21128 Set_Needs_Debug_Info
(T
);
21130 -- Set flag on subsidiary entities if not set already
21132 if Is_Object
(T
) then
21133 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
21135 elsif Is_Type
(T
) then
21136 Set_Debug_Info_Needed_If_Not_Set
(Etype
(T
));
21138 if Is_Record_Type
(T
) then
21140 Ent
: Entity_Id
:= First_Entity
(T
);
21142 while Present
(Ent
) loop
21143 Set_Debug_Info_Needed_If_Not_Set
(Ent
);
21148 -- For a class wide subtype, we also need debug information
21149 -- for the equivalent type.
21151 if Ekind
(T
) = E_Class_Wide_Subtype
then
21152 Set_Debug_Info_Needed_If_Not_Set
(Equivalent_Type
(T
));
21155 elsif Is_Array_Type
(T
) then
21156 Set_Debug_Info_Needed_If_Not_Set
(Component_Type
(T
));
21159 Indx
: Node_Id
:= First_Index
(T
);
21161 while Present
(Indx
) loop
21162 Set_Debug_Info_Needed_If_Not_Set
(Etype
(Indx
));
21163 Indx
:= Next_Index
(Indx
);
21167 -- For a packed array type, we also need debug information for
21168 -- the type used to represent the packed array. Conversely, we
21169 -- also need it for the former if we need it for the latter.
21171 if Is_Packed
(T
) then
21172 Set_Debug_Info_Needed_If_Not_Set
(Packed_Array_Impl_Type
(T
));
21175 if Is_Packed_Array_Impl_Type
(T
) then
21176 Set_Debug_Info_Needed_If_Not_Set
(Original_Array_Type
(T
));
21179 elsif Is_Access_Type
(T
) then
21180 Set_Debug_Info_Needed_If_Not_Set
(Directly_Designated_Type
(T
));
21182 elsif Is_Private_Type
(T
) then
21184 FV
: constant Entity_Id
:= Full_View
(T
);
21187 Set_Debug_Info_Needed_If_Not_Set
(FV
);
21189 -- If the full view is itself a derived private type, we need
21190 -- debug information on its underlying type.
21193 and then Is_Private_Type
(FV
)
21194 and then Present
(Underlying_Full_View
(FV
))
21196 Set_Needs_Debug_Info
(Underlying_Full_View
(FV
));
21200 elsif Is_Protected_Type
(T
) then
21201 Set_Debug_Info_Needed_If_Not_Set
(Corresponding_Record_Type
(T
));
21203 elsif Is_Scalar_Type
(T
) then
21205 -- If the subrange bounds are materialized by dedicated constant
21206 -- objects, also include them in the debug info to make sure the
21207 -- debugger can properly use them.
21209 if Present
(Scalar_Range
(T
))
21210 and then Nkind
(Scalar_Range
(T
)) = N_Range
21213 Low_Bnd
: constant Node_Id
:= Type_Low_Bound
(T
);
21214 High_Bnd
: constant Node_Id
:= Type_High_Bound
(T
);
21217 if Is_Entity_Name
(Low_Bnd
) then
21218 Set_Debug_Info_Needed_If_Not_Set
(Entity
(Low_Bnd
));
21221 if Is_Entity_Name
(High_Bnd
) then
21222 Set_Debug_Info_Needed_If_Not_Set
(Entity
(High_Bnd
));
21228 end Set_Debug_Info_Needed
;
21230 ----------------------------
21231 -- Set_Entity_With_Checks --
21232 ----------------------------
21234 procedure Set_Entity_With_Checks
(N
: Node_Id
; Val
: Entity_Id
) is
21235 Val_Actual
: Entity_Id
;
21237 Post_Node
: Node_Id
;
21240 -- Unconditionally set the entity
21242 Set_Entity
(N
, Val
);
21244 -- The node to post on is the selector in the case of an expanded name,
21245 -- and otherwise the node itself.
21247 if Nkind
(N
) = N_Expanded_Name
then
21248 Post_Node
:= Selector_Name
(N
);
21253 -- Check for violation of No_Fixed_IO
21255 if Restriction_Check_Required
(No_Fixed_IO
)
21257 ((RTU_Loaded
(Ada_Text_IO
)
21258 and then (Is_RTE
(Val
, RE_Decimal_IO
)
21260 Is_RTE
(Val
, RE_Fixed_IO
)))
21263 (RTU_Loaded
(Ada_Wide_Text_IO
)
21264 and then (Is_RTE
(Val
, RO_WT_Decimal_IO
)
21266 Is_RTE
(Val
, RO_WT_Fixed_IO
)))
21269 (RTU_Loaded
(Ada_Wide_Wide_Text_IO
)
21270 and then (Is_RTE
(Val
, RO_WW_Decimal_IO
)
21272 Is_RTE
(Val
, RO_WW_Fixed_IO
))))
21274 -- A special extra check, don't complain about a reference from within
21275 -- the Ada.Interrupts package itself!
21277 and then not In_Same_Extended_Unit
(N
, Val
)
21279 Check_Restriction
(No_Fixed_IO
, Post_Node
);
21282 -- Remaining checks are only done on source nodes. Note that we test
21283 -- for violation of No_Fixed_IO even on non-source nodes, because the
21284 -- cases for checking violations of this restriction are instantiations
21285 -- where the reference in the instance has Comes_From_Source False.
21287 if not Comes_From_Source
(N
) then
21291 -- Check for violation of No_Abort_Statements, which is triggered by
21292 -- call to Ada.Task_Identification.Abort_Task.
21294 if Restriction_Check_Required
(No_Abort_Statements
)
21295 and then (Is_RTE
(Val
, RE_Abort_Task
))
21297 -- A special extra check, don't complain about a reference from within
21298 -- the Ada.Task_Identification package itself!
21300 and then not In_Same_Extended_Unit
(N
, Val
)
21302 Check_Restriction
(No_Abort_Statements
, Post_Node
);
21305 if Val
= Standard_Long_Long_Integer
then
21306 Check_Restriction
(No_Long_Long_Integers
, Post_Node
);
21309 -- Check for violation of No_Dynamic_Attachment
21311 if Restriction_Check_Required
(No_Dynamic_Attachment
)
21312 and then RTU_Loaded
(Ada_Interrupts
)
21313 and then (Is_RTE
(Val
, RE_Is_Reserved
) or else
21314 Is_RTE
(Val
, RE_Is_Attached
) or else
21315 Is_RTE
(Val
, RE_Current_Handler
) or else
21316 Is_RTE
(Val
, RE_Attach_Handler
) or else
21317 Is_RTE
(Val
, RE_Exchange_Handler
) or else
21318 Is_RTE
(Val
, RE_Detach_Handler
) or else
21319 Is_RTE
(Val
, RE_Reference
))
21321 -- A special extra check, don't complain about a reference from within
21322 -- the Ada.Interrupts package itself!
21324 and then not In_Same_Extended_Unit
(N
, Val
)
21326 Check_Restriction
(No_Dynamic_Attachment
, Post_Node
);
21329 -- Check for No_Implementation_Identifiers
21331 if Restriction_Check_Required
(No_Implementation_Identifiers
) then
21333 -- We have an implementation defined entity if it is marked as
21334 -- implementation defined, or is defined in a package marked as
21335 -- implementation defined. However, library packages themselves
21336 -- are excluded (we don't want to flag Interfaces itself, just
21337 -- the entities within it).
21339 if (Is_Implementation_Defined
(Val
)
21341 (Present
(Scope
(Val
))
21342 and then Is_Implementation_Defined
(Scope
(Val
))))
21343 and then not (Ekind_In
(Val
, E_Package
, E_Generic_Package
)
21344 and then Is_Library_Level_Entity
(Val
))
21346 Check_Restriction
(No_Implementation_Identifiers
, Post_Node
);
21350 -- Do the style check
21353 and then not Suppress_Style_Checks
(Val
)
21354 and then not In_Instance
21356 if Nkind
(N
) = N_Identifier
then
21358 elsif Nkind
(N
) = N_Expanded_Name
then
21359 Nod
:= Selector_Name
(N
);
21364 -- A special situation arises for derived operations, where we want
21365 -- to do the check against the parent (since the Sloc of the derived
21366 -- operation points to the derived type declaration itself).
21369 while not Comes_From_Source
(Val_Actual
)
21370 and then Nkind
(Val_Actual
) in N_Entity
21371 and then (Ekind
(Val_Actual
) = E_Enumeration_Literal
21372 or else Is_Subprogram_Or_Generic_Subprogram
(Val_Actual
))
21373 and then Present
(Alias
(Val_Actual
))
21375 Val_Actual
:= Alias
(Val_Actual
);
21378 -- Renaming declarations for generic actuals do not come from source,
21379 -- and have a different name from that of the entity they rename, so
21380 -- there is no style check to perform here.
21382 if Chars
(Nod
) = Chars
(Val_Actual
) then
21383 Style
.Check_Identifier
(Nod
, Val_Actual
);
21387 Set_Entity
(N
, Val
);
21388 end Set_Entity_With_Checks
;
21390 ------------------------
21391 -- Set_Name_Entity_Id --
21392 ------------------------
21394 procedure Set_Name_Entity_Id
(Id
: Name_Id
; Val
: Entity_Id
) is
21396 Set_Name_Table_Int
(Id
, Int
(Val
));
21397 end Set_Name_Entity_Id
;
21399 ---------------------
21400 -- Set_Next_Actual --
21401 ---------------------
21403 procedure Set_Next_Actual
(Ass1_Id
: Node_Id
; Ass2_Id
: Node_Id
) is
21405 if Nkind
(Parent
(Ass1_Id
)) = N_Parameter_Association
then
21406 Set_First_Named_Actual
(Parent
(Ass1_Id
), Ass2_Id
);
21408 end Set_Next_Actual
;
21410 ----------------------------------
21411 -- Set_Optimize_Alignment_Flags --
21412 ----------------------------------
21414 procedure Set_Optimize_Alignment_Flags
(E
: Entity_Id
) is
21416 if Optimize_Alignment
= 'S' then
21417 Set_Optimize_Alignment_Space
(E
);
21418 elsif Optimize_Alignment
= 'T' then
21419 Set_Optimize_Alignment_Time
(E
);
21421 end Set_Optimize_Alignment_Flags
;
21423 -----------------------
21424 -- Set_Public_Status --
21425 -----------------------
21427 procedure Set_Public_Status
(Id
: Entity_Id
) is
21428 S
: constant Entity_Id
:= Current_Scope
;
21430 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean;
21431 -- Determines if E is defined within handled statement sequence or
21432 -- an if statement, returns True if so, False otherwise.
21434 ----------------------
21435 -- Within_HSS_Or_If --
21436 ----------------------
21438 function Within_HSS_Or_If
(E
: Entity_Id
) return Boolean is
21441 N
:= Declaration_Node
(E
);
21448 elsif Nkind_In
(N
, N_Handled_Sequence_Of_Statements
,
21454 end Within_HSS_Or_If
;
21456 -- Start of processing for Set_Public_Status
21459 -- Everything in the scope of Standard is public
21461 if S
= Standard_Standard
then
21462 Set_Is_Public
(Id
);
21464 -- Entity is definitely not public if enclosing scope is not public
21466 elsif not Is_Public
(S
) then
21469 -- An object or function declaration that occurs in a handled sequence
21470 -- of statements or within an if statement is the declaration for a
21471 -- temporary object or local subprogram generated by the expander. It
21472 -- never needs to be made public and furthermore, making it public can
21473 -- cause back end problems.
21475 elsif Nkind_In
(Parent
(Id
), N_Object_Declaration
,
21476 N_Function_Specification
)
21477 and then Within_HSS_Or_If
(Id
)
21481 -- Entities in public packages or records are public
21483 elsif Ekind
(S
) = E_Package
or Is_Record_Type
(S
) then
21484 Set_Is_Public
(Id
);
21486 -- The bounds of an entry family declaration can generate object
21487 -- declarations that are visible to the back-end, e.g. in the
21488 -- the declaration of a composite type that contains tasks.
21490 elsif Is_Concurrent_Type
(S
)
21491 and then not Has_Completion
(S
)
21492 and then Nkind
(Parent
(Id
)) = N_Object_Declaration
21494 Set_Is_Public
(Id
);
21496 end Set_Public_Status
;
21498 -----------------------------
21499 -- Set_Referenced_Modified --
21500 -----------------------------
21502 procedure Set_Referenced_Modified
(N
: Node_Id
; Out_Param
: Boolean) is
21506 -- Deal with indexed or selected component where prefix is modified
21508 if Nkind_In
(N
, N_Indexed_Component
, N_Selected_Component
) then
21509 Pref
:= Prefix
(N
);
21511 -- If prefix is access type, then it is the designated object that is
21512 -- being modified, which means we have no entity to set the flag on.
21514 if No
(Etype
(Pref
)) or else Is_Access_Type
(Etype
(Pref
)) then
21517 -- Otherwise chase the prefix
21520 Set_Referenced_Modified
(Pref
, Out_Param
);
21523 -- Otherwise see if we have an entity name (only other case to process)
21525 elsif Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
21526 Set_Referenced_As_LHS
(Entity
(N
), not Out_Param
);
21527 Set_Referenced_As_Out_Parameter
(Entity
(N
), Out_Param
);
21529 end Set_Referenced_Modified
;
21531 ----------------------------
21532 -- Set_Scope_Is_Transient --
21533 ----------------------------
21535 procedure Set_Scope_Is_Transient
(V
: Boolean := True) is
21537 Scope_Stack
.Table
(Scope_Stack
.Last
).Is_Transient
:= V
;
21538 end Set_Scope_Is_Transient
;
21540 -------------------
21541 -- Set_Size_Info --
21542 -------------------
21544 procedure Set_Size_Info
(T1
, T2
: Entity_Id
) is
21546 -- We copy Esize, but not RM_Size, since in general RM_Size is
21547 -- subtype specific and does not get inherited by all subtypes.
21549 Set_Esize
(T1
, Esize
(T2
));
21550 Set_Has_Biased_Representation
(T1
, Has_Biased_Representation
(T2
));
21552 if Is_Discrete_Or_Fixed_Point_Type
(T1
)
21554 Is_Discrete_Or_Fixed_Point_Type
(T2
)
21556 Set_Is_Unsigned_Type
(T1
, Is_Unsigned_Type
(T2
));
21559 Set_Alignment
(T1
, Alignment
(T2
));
21562 ------------------------------
21563 -- Should_Ignore_Pragma_Par --
21564 ------------------------------
21566 function Should_Ignore_Pragma_Par
(Prag_Name
: Name_Id
) return Boolean is
21567 pragma Assert
(Compiler_State
= Parsing
);
21568 -- This one can't work during semantic analysis, because we don't have a
21569 -- correct Current_Source_File.
21571 Result
: constant Boolean :=
21572 Get_Name_Table_Boolean3
(Prag_Name
)
21573 and then not Is_Internal_File_Name
21574 (File_Name
(Current_Source_File
));
21577 end Should_Ignore_Pragma_Par
;
21579 ------------------------------
21580 -- Should_Ignore_Pragma_Sem --
21581 ------------------------------
21583 function Should_Ignore_Pragma_Sem
(N
: Node_Id
) return Boolean is
21584 pragma Assert
(Compiler_State
= Analyzing
);
21585 Prag_Name
: constant Name_Id
:= Pragma_Name
(N
);
21586 Result
: constant Boolean :=
21587 Get_Name_Table_Boolean3
(Prag_Name
)
21588 and then not In_Internal_Unit
(N
);
21592 end Should_Ignore_Pragma_Sem
;
21594 --------------------
21595 -- Static_Boolean --
21596 --------------------
21598 function Static_Boolean
(N
: Node_Id
) return Uint
is
21600 Analyze_And_Resolve
(N
, Standard_Boolean
);
21603 or else Error_Posted
(N
)
21604 or else Etype
(N
) = Any_Type
21609 if Is_OK_Static_Expression
(N
) then
21610 if not Raises_Constraint_Error
(N
) then
21611 return Expr_Value
(N
);
21616 elsif Etype
(N
) = Any_Type
then
21620 Flag_Non_Static_Expr
21621 ("static boolean expression required here", N
);
21624 end Static_Boolean
;
21626 --------------------
21627 -- Static_Integer --
21628 --------------------
21630 function Static_Integer
(N
: Node_Id
) return Uint
is
21632 Analyze_And_Resolve
(N
, Any_Integer
);
21635 or else Error_Posted
(N
)
21636 or else Etype
(N
) = Any_Type
21641 if Is_OK_Static_Expression
(N
) then
21642 if not Raises_Constraint_Error
(N
) then
21643 return Expr_Value
(N
);
21648 elsif Etype
(N
) = Any_Type
then
21652 Flag_Non_Static_Expr
21653 ("static integer expression required here", N
);
21656 end Static_Integer
;
21658 --------------------------
21659 -- Statically_Different --
21660 --------------------------
21662 function Statically_Different
(E1
, E2
: Node_Id
) return Boolean is
21663 R1
: constant Node_Id
:= Get_Referenced_Object
(E1
);
21664 R2
: constant Node_Id
:= Get_Referenced_Object
(E2
);
21666 return Is_Entity_Name
(R1
)
21667 and then Is_Entity_Name
(R2
)
21668 and then Entity
(R1
) /= Entity
(R2
)
21669 and then not Is_Formal
(Entity
(R1
))
21670 and then not Is_Formal
(Entity
(R2
));
21671 end Statically_Different
;
21673 --------------------------------------
21674 -- Subject_To_Loop_Entry_Attributes --
21675 --------------------------------------
21677 function Subject_To_Loop_Entry_Attributes
(N
: Node_Id
) return Boolean is
21683 -- The expansion mechanism transform a loop subject to at least one
21684 -- 'Loop_Entry attribute into a conditional block. Infinite loops lack
21685 -- the conditional part.
21687 if Nkind_In
(Stmt
, N_Block_Statement
, N_If_Statement
)
21688 and then Nkind
(Original_Node
(N
)) = N_Loop_Statement
21690 Stmt
:= Original_Node
(N
);
21694 Nkind
(Stmt
) = N_Loop_Statement
21695 and then Present
(Identifier
(Stmt
))
21696 and then Present
(Entity
(Identifier
(Stmt
)))
21697 and then Has_Loop_Entry_Attributes
(Entity
(Identifier
(Stmt
)));
21698 end Subject_To_Loop_Entry_Attributes
;
21700 -----------------------------
21701 -- Subprogram_Access_Level --
21702 -----------------------------
21704 function Subprogram_Access_Level
(Subp
: Entity_Id
) return Uint
is
21706 if Present
(Alias
(Subp
)) then
21707 return Subprogram_Access_Level
(Alias
(Subp
));
21709 return Scope_Depth
(Enclosing_Dynamic_Scope
(Subp
));
21711 end Subprogram_Access_Level
;
21713 -------------------------------
21714 -- Support_Atomic_Primitives --
21715 -------------------------------
21717 function Support_Atomic_Primitives
(Typ
: Entity_Id
) return Boolean is
21721 -- Verify the alignment of Typ is known
21723 if not Known_Alignment
(Typ
) then
21727 if Known_Static_Esize
(Typ
) then
21728 Size
:= UI_To_Int
(Esize
(Typ
));
21730 -- If the Esize (Object_Size) is unknown at compile time, look at the
21731 -- RM_Size (Value_Size) which may have been set by an explicit rep item.
21733 elsif Known_Static_RM_Size
(Typ
) then
21734 Size
:= UI_To_Int
(RM_Size
(Typ
));
21736 -- Otherwise, the size is considered to be unknown.
21742 -- Check that the size of the component is 8, 16, 32, or 64 bits and
21743 -- that Typ is properly aligned.
21746 when 8 |
16 |
32 |
64 =>
21747 return Size
= UI_To_Int
(Alignment
(Typ
)) * 8;
21752 end Support_Atomic_Primitives
;
21758 procedure Trace_Scope
(N
: Node_Id
; E
: Entity_Id
; Msg
: String) is
21760 if Debug_Flag_W
then
21761 for J
in 0 .. Scope_Stack
.Last
loop
21766 Write_Name
(Chars
(E
));
21767 Write_Str
(" from ");
21768 Write_Location
(Sloc
(N
));
21773 -----------------------
21774 -- Transfer_Entities --
21775 -----------------------
21777 procedure Transfer_Entities
(From
: Entity_Id
; To
: Entity_Id
) is
21778 procedure Set_Public_Status_Of
(Id
: Entity_Id
);
21779 -- Set the Is_Public attribute of arbitrary entity Id by calling routine
21780 -- Set_Public_Status. If successful and Id denotes a record type, set
21781 -- the Is_Public attribute of its fields.
21783 --------------------------
21784 -- Set_Public_Status_Of --
21785 --------------------------
21787 procedure Set_Public_Status_Of
(Id
: Entity_Id
) is
21791 if not Is_Public
(Id
) then
21792 Set_Public_Status
(Id
);
21794 -- When the input entity is a public record type, ensure that all
21795 -- its internal fields are also exposed to the linker. The fields
21796 -- of a class-wide type are never made public.
21799 and then Is_Record_Type
(Id
)
21800 and then not Is_Class_Wide_Type
(Id
)
21802 Field
:= First_Entity
(Id
);
21803 while Present
(Field
) loop
21804 Set_Is_Public
(Field
);
21805 Next_Entity
(Field
);
21809 end Set_Public_Status_Of
;
21813 Full_Id
: Entity_Id
;
21816 -- Start of processing for Transfer_Entities
21819 Id
:= First_Entity
(From
);
21821 if Present
(Id
) then
21823 -- Merge the entity chain of the source scope with that of the
21824 -- destination scope.
21826 if Present
(Last_Entity
(To
)) then
21827 Set_Next_Entity
(Last_Entity
(To
), Id
);
21829 Set_First_Entity
(To
, Id
);
21832 Set_Last_Entity
(To
, Last_Entity
(From
));
21834 -- Inspect the entities of the source scope and update their Scope
21837 while Present
(Id
) loop
21838 Set_Scope
(Id
, To
);
21839 Set_Public_Status_Of
(Id
);
21841 -- Handle an internally generated full view for a private type
21843 if Is_Private_Type
(Id
)
21844 and then Present
(Full_View
(Id
))
21845 and then Is_Itype
(Full_View
(Id
))
21847 Full_Id
:= Full_View
(Id
);
21849 Set_Scope
(Full_Id
, To
);
21850 Set_Public_Status_Of
(Full_Id
);
21856 Set_First_Entity
(From
, Empty
);
21857 Set_Last_Entity
(From
, Empty
);
21859 end Transfer_Entities
;
21861 -----------------------
21862 -- Type_Access_Level --
21863 -----------------------
21865 function Type_Access_Level
(Typ
: Entity_Id
) return Uint
is
21869 Btyp
:= Base_Type
(Typ
);
21871 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
21872 -- simply use the level where the type is declared. This is true for
21873 -- stand-alone object declarations, and for anonymous access types
21874 -- associated with components the level is the same as that of the
21875 -- enclosing composite type. However, special treatment is needed for
21876 -- the cases of access parameters, return objects of an anonymous access
21877 -- type, and, in Ada 95, access discriminants of limited types.
21879 if Is_Access_Type
(Btyp
) then
21880 if Ekind
(Btyp
) = E_Anonymous_Access_Type
then
21882 -- If the type is a nonlocal anonymous access type (such as for
21883 -- an access parameter) we treat it as being declared at the
21884 -- library level to ensure that names such as X.all'access don't
21885 -- fail static accessibility checks.
21887 if not Is_Local_Anonymous_Access
(Typ
) then
21888 return Scope_Depth
(Standard_Standard
);
21890 -- If this is a return object, the accessibility level is that of
21891 -- the result subtype of the enclosing function. The test here is
21892 -- little complicated, because we have to account for extended
21893 -- return statements that have been rewritten as blocks, in which
21894 -- case we have to find and the Is_Return_Object attribute of the
21895 -- itype's associated object. It would be nice to find a way to
21896 -- simplify this test, but it doesn't seem worthwhile to add a new
21897 -- flag just for purposes of this test. ???
21899 elsif Ekind
(Scope
(Btyp
)) = E_Return_Statement
21902 and then Nkind
(Associated_Node_For_Itype
(Btyp
)) =
21903 N_Object_Declaration
21904 and then Is_Return_Object
21905 (Defining_Identifier
21906 (Associated_Node_For_Itype
(Btyp
))))
21912 Scop
:= Scope
(Scope
(Btyp
));
21913 while Present
(Scop
) loop
21914 exit when Ekind
(Scop
) = E_Function
;
21915 Scop
:= Scope
(Scop
);
21918 -- Treat the return object's type as having the level of the
21919 -- function's result subtype (as per RM05-6.5(5.3/2)).
21921 return Type_Access_Level
(Etype
(Scop
));
21926 Btyp
:= Root_Type
(Btyp
);
21928 -- The accessibility level of anonymous access types associated with
21929 -- discriminants is that of the current instance of the type, and
21930 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
21932 -- AI-402: access discriminants have accessibility based on the
21933 -- object rather than the type in Ada 2005, so the above paragraph
21936 -- ??? Needs completion with rules from AI-416
21938 if Ada_Version
<= Ada_95
21939 and then Ekind
(Typ
) = E_Anonymous_Access_Type
21940 and then Present
(Associated_Node_For_Itype
(Typ
))
21941 and then Nkind
(Associated_Node_For_Itype
(Typ
)) =
21942 N_Discriminant_Specification
21944 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
)) + 1;
21948 -- Return library level for a generic formal type. This is done because
21949 -- RM(10.3.2) says that "The statically deeper relationship does not
21950 -- apply to ... a descendant of a generic formal type". Rather than
21951 -- checking at each point where a static accessibility check is
21952 -- performed to see if we are dealing with a formal type, this rule is
21953 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
21954 -- return extreme values for a formal type; Deepest_Type_Access_Level
21955 -- returns Int'Last. By calling the appropriate function from among the
21956 -- two, we ensure that the static accessibility check will pass if we
21957 -- happen to run into a formal type. More specifically, we should call
21958 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
21959 -- call occurs as part of a static accessibility check and the error
21960 -- case is the case where the type's level is too shallow (as opposed
21963 if Is_Generic_Type
(Root_Type
(Btyp
)) then
21964 return Scope_Depth
(Standard_Standard
);
21967 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
));
21968 end Type_Access_Level
;
21970 ------------------------------------
21971 -- Type_Without_Stream_Operation --
21972 ------------------------------------
21974 function Type_Without_Stream_Operation
21976 Op
: TSS_Name_Type
:= TSS_Null
) return Entity_Id
21978 BT
: constant Entity_Id
:= Base_Type
(T
);
21979 Op_Missing
: Boolean;
21982 if not Restriction_Active
(No_Default_Stream_Attributes
) then
21986 if Is_Elementary_Type
(T
) then
21987 if Op
= TSS_Null
then
21989 No
(TSS
(BT
, TSS_Stream_Read
))
21990 or else No
(TSS
(BT
, TSS_Stream_Write
));
21993 Op_Missing
:= No
(TSS
(BT
, Op
));
22002 elsif Is_Array_Type
(T
) then
22003 return Type_Without_Stream_Operation
(Component_Type
(T
), Op
);
22005 elsif Is_Record_Type
(T
) then
22011 Comp
:= First_Component
(T
);
22012 while Present
(Comp
) loop
22013 C_Typ
:= Type_Without_Stream_Operation
(Etype
(Comp
), Op
);
22015 if Present
(C_Typ
) then
22019 Next_Component
(Comp
);
22025 elsif Is_Private_Type
(T
) and then Present
(Full_View
(T
)) then
22026 return Type_Without_Stream_Operation
(Full_View
(T
), Op
);
22030 end Type_Without_Stream_Operation
;
22032 ----------------------------
22033 -- Unique_Defining_Entity --
22034 ----------------------------
22036 function Unique_Defining_Entity
(N
: Node_Id
) return Entity_Id
is
22038 return Unique_Entity
(Defining_Entity
(N
));
22039 end Unique_Defining_Entity
;
22041 -------------------
22042 -- Unique_Entity --
22043 -------------------
22045 function Unique_Entity
(E
: Entity_Id
) return Entity_Id
is
22046 U
: Entity_Id
:= E
;
22052 if Present
(Full_View
(E
)) then
22053 U
:= Full_View
(E
);
22057 if Nkind
(Parent
(E
)) = N_Entry_Body
then
22059 Prot_Item
: Entity_Id
;
22060 Prot_Type
: Entity_Id
;
22063 if Ekind
(E
) = E_Entry
then
22064 Prot_Type
:= Scope
(E
);
22066 -- Bodies of entry families are nested within an extra scope
22067 -- that contains an entry index declaration
22070 Prot_Type
:= Scope
(Scope
(E
));
22073 -- A protected type may be declared as a private type, in
22074 -- which case we need to get its full view.
22076 if Is_Private_Type
(Prot_Type
) then
22077 Prot_Type
:= Full_View
(Prot_Type
);
22080 -- Full view may not be present on error, in which case
22081 -- return E by default.
22083 if Present
(Prot_Type
) then
22084 pragma Assert
(Ekind
(Prot_Type
) = E_Protected_Type
);
22086 -- Traverse the entity list of the protected type and
22087 -- locate an entry declaration which matches the entry
22090 Prot_Item
:= First_Entity
(Prot_Type
);
22091 while Present
(Prot_Item
) loop
22092 if Ekind
(Prot_Item
) in Entry_Kind
22093 and then Corresponding_Body
(Parent
(Prot_Item
)) = E
22099 Next_Entity
(Prot_Item
);
22105 when Formal_Kind
=>
22106 if Present
(Spec_Entity
(E
)) then
22107 U
:= Spec_Entity
(E
);
22110 when E_Package_Body
=>
22113 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
22117 if Nkind
(P
) = N_Package_Body
22118 and then Present
(Corresponding_Spec
(P
))
22120 U
:= Corresponding_Spec
(P
);
22122 elsif Nkind
(P
) = N_Package_Body_Stub
22123 and then Present
(Corresponding_Spec_Of_Stub
(P
))
22125 U
:= Corresponding_Spec_Of_Stub
(P
);
22128 when E_Protected_Body
=>
22131 if Nkind
(P
) = N_Protected_Body
22132 and then Present
(Corresponding_Spec
(P
))
22134 U
:= Corresponding_Spec
(P
);
22136 elsif Nkind
(P
) = N_Protected_Body_Stub
22137 and then Present
(Corresponding_Spec_Of_Stub
(P
))
22139 U
:= Corresponding_Spec_Of_Stub
(P
);
22141 if Is_Single_Protected_Object
(U
) then
22146 if Is_Private_Type
(U
) then
22147 U
:= Full_View
(U
);
22150 when E_Subprogram_Body
=>
22153 if Nkind
(P
) = N_Defining_Program_Unit_Name
then
22159 if Nkind
(P
) = N_Subprogram_Body
22160 and then Present
(Corresponding_Spec
(P
))
22162 U
:= Corresponding_Spec
(P
);
22164 elsif Nkind
(P
) = N_Subprogram_Body_Stub
22165 and then Present
(Corresponding_Spec_Of_Stub
(P
))
22167 U
:= Corresponding_Spec_Of_Stub
(P
);
22169 elsif Nkind
(P
) = N_Subprogram_Renaming_Declaration
then
22170 U
:= Corresponding_Spec
(P
);
22173 when E_Task_Body
=>
22176 if Nkind
(P
) = N_Task_Body
22177 and then Present
(Corresponding_Spec
(P
))
22179 U
:= Corresponding_Spec
(P
);
22181 elsif Nkind
(P
) = N_Task_Body_Stub
22182 and then Present
(Corresponding_Spec_Of_Stub
(P
))
22184 U
:= Corresponding_Spec_Of_Stub
(P
);
22186 if Is_Single_Task_Object
(U
) then
22191 if Is_Private_Type
(U
) then
22192 U
:= Full_View
(U
);
22196 if Present
(Full_View
(E
)) then
22197 U
:= Full_View
(E
);
22211 function Unique_Name
(E
: Entity_Id
) return String is
22213 -- Names in E_Subprogram_Body or E_Package_Body entities are not
22214 -- reliable, as they may not include the overloading suffix. Instead,
22215 -- when looking for the name of E or one of its enclosing scope, we get
22216 -- the name of the corresponding Unique_Entity.
22218 U
: constant Entity_Id
:= Unique_Entity
(E
);
22220 function This_Name
return String;
22226 function This_Name
return String is
22228 return Get_Name_String
(Chars
(U
));
22231 -- Start of processing for Unique_Name
22234 if E
= Standard_Standard
22235 or else Has_Fully_Qualified_Name
(E
)
22239 elsif Ekind
(E
) = E_Enumeration_Literal
then
22240 return Unique_Name
(Etype
(E
)) & "__" & This_Name
;
22244 S
: constant Entity_Id
:= Scope
(U
);
22245 pragma Assert
(Present
(S
));
22248 -- Prefix names of predefined types with standard__, but leave
22249 -- names of user-defined packages and subprograms without prefix
22250 -- (even if technically they are nested in the Standard package).
22252 if S
= Standard_Standard
then
22253 if Ekind
(U
) = E_Package
or else Is_Subprogram
(U
) then
22256 return Unique_Name
(S
) & "__" & This_Name
;
22259 -- For intances of generic subprograms use the name of the related
22260 -- instace and skip the scope of its wrapper package.
22262 elsif Is_Wrapper_Package
(S
) then
22263 pragma Assert
(Scope
(S
) = Scope
(Related_Instance
(S
)));
22264 -- Wrapper package and the instantiation are in the same scope
22267 Enclosing_Name
: constant String :=
22268 Unique_Name
(Scope
(S
)) & "__" &
22269 Get_Name_String
(Chars
(Related_Instance
(S
)));
22272 if Is_Subprogram
(U
)
22273 and then not Is_Generic_Actual_Subprogram
(U
)
22275 return Enclosing_Name
;
22277 return Enclosing_Name
& "__" & This_Name
;
22282 return Unique_Name
(S
) & "__" & This_Name
;
22288 ---------------------
22289 -- Unit_Is_Visible --
22290 ---------------------
22292 function Unit_Is_Visible
(U
: Entity_Id
) return Boolean is
22293 Curr
: constant Node_Id
:= Cunit
(Current_Sem_Unit
);
22294 Curr_Entity
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
22296 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean;
22297 -- For a child unit, check whether unit appears in a with_clause
22300 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean;
22301 -- Scan the context clause of one compilation unit looking for a
22302 -- with_clause for the unit in question.
22304 ----------------------------
22305 -- Unit_In_Parent_Context --
22306 ----------------------------
22308 function Unit_In_Parent_Context
(Par_Unit
: Node_Id
) return Boolean is
22310 if Unit_In_Context
(Par_Unit
) then
22313 elsif Is_Child_Unit
(Defining_Entity
(Unit
(Par_Unit
))) then
22314 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Par_Unit
)));
22319 end Unit_In_Parent_Context
;
22321 ---------------------
22322 -- Unit_In_Context --
22323 ---------------------
22325 function Unit_In_Context
(Comp_Unit
: Node_Id
) return Boolean is
22329 Clause
:= First
(Context_Items
(Comp_Unit
));
22330 while Present
(Clause
) loop
22331 if Nkind
(Clause
) = N_With_Clause
then
22332 if Library_Unit
(Clause
) = U
then
22335 -- The with_clause may denote a renaming of the unit we are
22336 -- looking for, eg. Text_IO which renames Ada.Text_IO.
22339 Renamed_Entity
(Entity
(Name
(Clause
))) =
22340 Defining_Entity
(Unit
(U
))
22350 end Unit_In_Context
;
22352 -- Start of processing for Unit_Is_Visible
22355 -- The currrent unit is directly visible
22360 elsif Unit_In_Context
(Curr
) then
22363 -- If the current unit is a body, check the context of the spec
22365 elsif Nkind
(Unit
(Curr
)) = N_Package_Body
22367 (Nkind
(Unit
(Curr
)) = N_Subprogram_Body
22368 and then not Acts_As_Spec
(Unit
(Curr
)))
22370 if Unit_In_Context
(Library_Unit
(Curr
)) then
22375 -- If the spec is a child unit, examine the parents
22377 if Is_Child_Unit
(Curr_Entity
) then
22378 if Nkind
(Unit
(Curr
)) in N_Unit_Body
then
22380 Unit_In_Parent_Context
22381 (Parent_Spec
(Unit
(Library_Unit
(Curr
))));
22383 return Unit_In_Parent_Context
(Parent_Spec
(Unit
(Curr
)));
22389 end Unit_Is_Visible
;
22391 ------------------------------
22392 -- Universal_Interpretation --
22393 ------------------------------
22395 function Universal_Interpretation
(Opnd
: Node_Id
) return Entity_Id
is
22396 Index
: Interp_Index
;
22400 -- The argument may be a formal parameter of an operator or subprogram
22401 -- with multiple interpretations, or else an expression for an actual.
22403 if Nkind
(Opnd
) = N_Defining_Identifier
22404 or else not Is_Overloaded
(Opnd
)
22406 if Etype
(Opnd
) = Universal_Integer
22407 or else Etype
(Opnd
) = Universal_Real
22409 return Etype
(Opnd
);
22415 Get_First_Interp
(Opnd
, Index
, It
);
22416 while Present
(It
.Typ
) loop
22417 if It
.Typ
= Universal_Integer
22418 or else It
.Typ
= Universal_Real
22423 Get_Next_Interp
(Index
, It
);
22428 end Universal_Interpretation
;
22434 function Unqualify
(Expr
: Node_Id
) return Node_Id
is
22436 -- Recurse to handle unlikely case of multiple levels of qualification
22438 if Nkind
(Expr
) = N_Qualified_Expression
then
22439 return Unqualify
(Expression
(Expr
));
22441 -- Normal case, not a qualified expression
22448 -----------------------
22449 -- Visible_Ancestors --
22450 -----------------------
22452 function Visible_Ancestors
(Typ
: Entity_Id
) return Elist_Id
is
22458 pragma Assert
(Is_Record_Type
(Typ
) and then Is_Tagged_Type
(Typ
));
22460 -- Collect all the parents and progenitors of Typ. If the full-view of
22461 -- private parents and progenitors is available then it is used to
22462 -- generate the list of visible ancestors; otherwise their partial
22463 -- view is added to the resulting list.
22468 Use_Full_View
=> True);
22472 Ifaces_List
=> List_2
,
22473 Exclude_Parents
=> True,
22474 Use_Full_View
=> True);
22476 -- Join the two lists. Avoid duplications because an interface may
22477 -- simultaneously be parent and progenitor of a type.
22479 Elmt
:= First_Elmt
(List_2
);
22480 while Present
(Elmt
) loop
22481 Append_Unique_Elmt
(Node
(Elmt
), List_1
);
22486 end Visible_Ancestors
;
22488 ----------------------
22489 -- Within_Init_Proc --
22490 ----------------------
22492 function Within_Init_Proc
return Boolean is
22496 S
:= Current_Scope
;
22497 while not Is_Overloadable
(S
) loop
22498 if S
= Standard_Standard
then
22505 return Is_Init_Proc
(S
);
22506 end Within_Init_Proc
;
22512 function Within_Scope
(E
: Entity_Id
; S
: Entity_Id
) return Boolean is
22514 return Scope_Within_Or_Same
(Scope
(E
), S
);
22521 procedure Wrong_Type
(Expr
: Node_Id
; Expected_Type
: Entity_Id
) is
22522 Found_Type
: constant Entity_Id
:= First_Subtype
(Etype
(Expr
));
22523 Expec_Type
: constant Entity_Id
:= First_Subtype
(Expected_Type
);
22525 Matching_Field
: Entity_Id
;
22526 -- Entity to give a more precise suggestion on how to write a one-
22527 -- element positional aggregate.
22529 function Has_One_Matching_Field
return Boolean;
22530 -- Determines if Expec_Type is a record type with a single component or
22531 -- discriminant whose type matches the found type or is one dimensional
22532 -- array whose component type matches the found type. In the case of
22533 -- one discriminant, we ignore the variant parts. That's not accurate,
22534 -- but good enough for the warning.
22536 ----------------------------
22537 -- Has_One_Matching_Field --
22538 ----------------------------
22540 function Has_One_Matching_Field
return Boolean is
22544 Matching_Field
:= Empty
;
22546 if Is_Array_Type
(Expec_Type
)
22547 and then Number_Dimensions
(Expec_Type
) = 1
22548 and then Covers
(Etype
(Component_Type
(Expec_Type
)), Found_Type
)
22550 -- Use type name if available. This excludes multidimensional
22551 -- arrays and anonymous arrays.
22553 if Comes_From_Source
(Expec_Type
) then
22554 Matching_Field
:= Expec_Type
;
22556 -- For an assignment, use name of target
22558 elsif Nkind
(Parent
(Expr
)) = N_Assignment_Statement
22559 and then Is_Entity_Name
(Name
(Parent
(Expr
)))
22561 Matching_Field
:= Entity
(Name
(Parent
(Expr
)));
22566 elsif not Is_Record_Type
(Expec_Type
) then
22570 E
:= First_Entity
(Expec_Type
);
22575 elsif not Ekind_In
(E
, E_Discriminant
, E_Component
)
22576 or else Nam_In
(Chars
(E
), Name_uTag
, Name_uParent
)
22585 if not Covers
(Etype
(E
), Found_Type
) then
22588 elsif Present
(Next_Entity
(E
))
22589 and then (Ekind
(E
) = E_Component
22590 or else Ekind
(Next_Entity
(E
)) = E_Discriminant
)
22595 Matching_Field
:= E
;
22599 end Has_One_Matching_Field
;
22601 -- Start of processing for Wrong_Type
22604 -- Don't output message if either type is Any_Type, or if a message
22605 -- has already been posted for this node. We need to do the latter
22606 -- check explicitly (it is ordinarily done in Errout), because we
22607 -- are using ! to force the output of the error messages.
22609 if Expec_Type
= Any_Type
22610 or else Found_Type
= Any_Type
22611 or else Error_Posted
(Expr
)
22615 -- If one of the types is a Taft-Amendment type and the other it its
22616 -- completion, it must be an illegal use of a TAT in the spec, for
22617 -- which an error was already emitted. Avoid cascaded errors.
22619 elsif Is_Incomplete_Type
(Expec_Type
)
22620 and then Has_Completion_In_Body
(Expec_Type
)
22621 and then Full_View
(Expec_Type
) = Etype
(Expr
)
22625 elsif Is_Incomplete_Type
(Etype
(Expr
))
22626 and then Has_Completion_In_Body
(Etype
(Expr
))
22627 and then Full_View
(Etype
(Expr
)) = Expec_Type
22631 -- In an instance, there is an ongoing problem with completion of
22632 -- type derived from private types. Their structure is what Gigi
22633 -- expects, but the Etype is the parent type rather than the
22634 -- derived private type itself. Do not flag error in this case. The
22635 -- private completion is an entity without a parent, like an Itype.
22636 -- Similarly, full and partial views may be incorrect in the instance.
22637 -- There is no simple way to insure that it is consistent ???
22639 -- A similar view discrepancy can happen in an inlined body, for the
22640 -- same reason: inserted body may be outside of the original package
22641 -- and only partial views are visible at the point of insertion.
22643 elsif In_Instance
or else In_Inlined_Body
then
22644 if Etype
(Etype
(Expr
)) = Etype
(Expected_Type
)
22646 (Has_Private_Declaration
(Expected_Type
)
22647 or else Has_Private_Declaration
(Etype
(Expr
)))
22648 and then No
(Parent
(Expected_Type
))
22652 elsif Nkind
(Parent
(Expr
)) = N_Qualified_Expression
22653 and then Entity
(Subtype_Mark
(Parent
(Expr
))) = Expected_Type
22657 elsif Is_Private_Type
(Expected_Type
)
22658 and then Present
(Full_View
(Expected_Type
))
22659 and then Covers
(Full_View
(Expected_Type
), Etype
(Expr
))
22663 -- Conversely, type of expression may be the private one
22665 elsif Is_Private_Type
(Base_Type
(Etype
(Expr
)))
22666 and then Full_View
(Base_Type
(Etype
(Expr
))) = Expected_Type
22672 -- An interesting special check. If the expression is parenthesized
22673 -- and its type corresponds to the type of the sole component of the
22674 -- expected record type, or to the component type of the expected one
22675 -- dimensional array type, then assume we have a bad aggregate attempt.
22677 if Nkind
(Expr
) in N_Subexpr
22678 and then Paren_Count
(Expr
) /= 0
22679 and then Has_One_Matching_Field
22681 Error_Msg_N
("positional aggregate cannot have one component", Expr
);
22683 if Present
(Matching_Field
) then
22684 if Is_Array_Type
(Expec_Type
) then
22686 ("\write instead `&''First ='> ...`", Expr
, Matching_Field
);
22689 ("\write instead `& ='> ...`", Expr
, Matching_Field
);
22693 -- Another special check, if we are looking for a pool-specific access
22694 -- type and we found an E_Access_Attribute_Type, then we have the case
22695 -- of an Access attribute being used in a context which needs a pool-
22696 -- specific type, which is never allowed. The one extra check we make
22697 -- is that the expected designated type covers the Found_Type.
22699 elsif Is_Access_Type
(Expec_Type
)
22700 and then Ekind
(Found_Type
) = E_Access_Attribute_Type
22701 and then Ekind
(Base_Type
(Expec_Type
)) /= E_General_Access_Type
22702 and then Ekind
(Base_Type
(Expec_Type
)) /= E_Anonymous_Access_Type
22704 (Designated_Type
(Expec_Type
), Designated_Type
(Found_Type
))
22706 Error_Msg_N
-- CODEFIX
22707 ("result must be general access type!", Expr
);
22708 Error_Msg_NE
-- CODEFIX
22709 ("add ALL to }!", Expr
, Expec_Type
);
22711 -- Another special check, if the expected type is an integer type,
22712 -- but the expression is of type System.Address, and the parent is
22713 -- an addition or subtraction operation whose left operand is the
22714 -- expression in question and whose right operand is of an integral
22715 -- type, then this is an attempt at address arithmetic, so give
22716 -- appropriate message.
22718 elsif Is_Integer_Type
(Expec_Type
)
22719 and then Is_RTE
(Found_Type
, RE_Address
)
22720 and then Nkind_In
(Parent
(Expr
), N_Op_Add
, N_Op_Subtract
)
22721 and then Expr
= Left_Opnd
(Parent
(Expr
))
22722 and then Is_Integer_Type
(Etype
(Right_Opnd
(Parent
(Expr
))))
22725 ("address arithmetic not predefined in package System",
22728 ("\possible missing with/use of System.Storage_Elements",
22732 -- If the expected type is an anonymous access type, as for access
22733 -- parameters and discriminants, the error is on the designated types.
22735 elsif Ekind
(Expec_Type
) = E_Anonymous_Access_Type
then
22736 if Comes_From_Source
(Expec_Type
) then
22737 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
22740 ("expected an access type with designated}",
22741 Expr
, Designated_Type
(Expec_Type
));
22744 if Is_Access_Type
(Found_Type
)
22745 and then not Comes_From_Source
(Found_Type
)
22748 ("\\found an access type with designated}!",
22749 Expr
, Designated_Type
(Found_Type
));
22751 if From_Limited_With
(Found_Type
) then
22752 Error_Msg_NE
("\\found incomplete}!", Expr
, Found_Type
);
22753 Error_Msg_Qual_Level
:= 99;
22754 Error_Msg_NE
-- CODEFIX
22755 ("\\missing `WITH &;", Expr
, Scope
(Found_Type
));
22756 Error_Msg_Qual_Level
:= 0;
22758 Error_Msg_NE
("found}!", Expr
, Found_Type
);
22762 -- Normal case of one type found, some other type expected
22765 -- If the names of the two types are the same, see if some number
22766 -- of levels of qualification will help. Don't try more than three
22767 -- levels, and if we get to standard, it's no use (and probably
22768 -- represents an error in the compiler) Also do not bother with
22769 -- internal scope names.
22772 Expec_Scope
: Entity_Id
;
22773 Found_Scope
: Entity_Id
;
22776 Expec_Scope
:= Expec_Type
;
22777 Found_Scope
:= Found_Type
;
22779 for Levels
in Nat
range 0 .. 3 loop
22780 if Chars
(Expec_Scope
) /= Chars
(Found_Scope
) then
22781 Error_Msg_Qual_Level
:= Levels
;
22785 Expec_Scope
:= Scope
(Expec_Scope
);
22786 Found_Scope
:= Scope
(Found_Scope
);
22788 exit when Expec_Scope
= Standard_Standard
22789 or else Found_Scope
= Standard_Standard
22790 or else not Comes_From_Source
(Expec_Scope
)
22791 or else not Comes_From_Source
(Found_Scope
);
22795 if Is_Record_Type
(Expec_Type
)
22796 and then Present
(Corresponding_Remote_Type
(Expec_Type
))
22798 Error_Msg_NE
("expected}!", Expr
,
22799 Corresponding_Remote_Type
(Expec_Type
));
22801 Error_Msg_NE
("expected}!", Expr
, Expec_Type
);
22804 if Is_Entity_Name
(Expr
)
22805 and then Is_Package_Or_Generic_Package
(Entity
(Expr
))
22807 Error_Msg_N
("\\found package name!", Expr
);
22809 elsif Is_Entity_Name
(Expr
)
22810 and then Ekind_In
(Entity
(Expr
), E_Procedure
, E_Generic_Procedure
)
22812 if Ekind
(Expec_Type
) = E_Access_Subprogram_Type
then
22814 ("found procedure name, possibly missing Access attribute!",
22818 ("\\found procedure name instead of function!", Expr
);
22821 elsif Nkind
(Expr
) = N_Function_Call
22822 and then Ekind
(Expec_Type
) = E_Access_Subprogram_Type
22823 and then Etype
(Designated_Type
(Expec_Type
)) = Etype
(Expr
)
22824 and then No
(Parameter_Associations
(Expr
))
22827 ("found function name, possibly missing Access attribute!",
22830 -- Catch common error: a prefix or infix operator which is not
22831 -- directly visible because the type isn't.
22833 elsif Nkind
(Expr
) in N_Op
22834 and then Is_Overloaded
(Expr
)
22835 and then not Is_Immediately_Visible
(Expec_Type
)
22836 and then not Is_Potentially_Use_Visible
(Expec_Type
)
22837 and then not In_Use
(Expec_Type
)
22838 and then Has_Compatible_Type
(Right_Opnd
(Expr
), Expec_Type
)
22841 ("operator of the type is not directly visible!", Expr
);
22843 elsif Ekind
(Found_Type
) = E_Void
22844 and then Present
(Parent
(Found_Type
))
22845 and then Nkind
(Parent
(Found_Type
)) = N_Full_Type_Declaration
22847 Error_Msg_NE
("\\found premature usage of}!", Expr
, Found_Type
);
22850 Error_Msg_NE
("\\found}!", Expr
, Found_Type
);
22853 -- A special check for cases like M1 and M2 = 0 where M1 and M2 are
22854 -- of the same modular type, and (M1 and M2) = 0 was intended.
22856 if Expec_Type
= Standard_Boolean
22857 and then Is_Modular_Integer_Type
(Found_Type
)
22858 and then Nkind_In
(Parent
(Expr
), N_Op_And
, N_Op_Or
, N_Op_Xor
)
22859 and then Nkind
(Right_Opnd
(Parent
(Expr
))) in N_Op_Compare
22862 Op
: constant Node_Id
:= Right_Opnd
(Parent
(Expr
));
22863 L
: constant Node_Id
:= Left_Opnd
(Op
);
22864 R
: constant Node_Id
:= Right_Opnd
(Op
);
22867 -- The case for the message is when the left operand of the
22868 -- comparison is the same modular type, or when it is an
22869 -- integer literal (or other universal integer expression),
22870 -- which would have been typed as the modular type if the
22871 -- parens had been there.
22873 if (Etype
(L
) = Found_Type
22875 Etype
(L
) = Universal_Integer
)
22876 and then Is_Integer_Type
(Etype
(R
))
22879 ("\\possible missing parens for modular operation", Expr
);
22884 -- Reset error message qualification indication
22886 Error_Msg_Qual_Level
:= 0;
22890 --------------------------------
22891 -- Yields_Synchronized_Object --
22892 --------------------------------
22894 function Yields_Synchronized_Object
(Typ
: Entity_Id
) return Boolean is
22895 Has_Sync_Comp
: Boolean := False;
22899 -- An array type yields a synchronized object if its component type
22900 -- yields a synchronized object.
22902 if Is_Array_Type
(Typ
) then
22903 return Yields_Synchronized_Object
(Component_Type
(Typ
));
22905 -- A descendant of type Ada.Synchronous_Task_Control.Suspension_Object
22906 -- yields a synchronized object by default.
22908 elsif Is_Descendant_Of_Suspension_Object
(Typ
) then
22911 -- A protected type yields a synchronized object by default
22913 elsif Is_Protected_Type
(Typ
) then
22916 -- A record type or type extension yields a synchronized object when its
22917 -- discriminants (if any) lack default values and all components are of
22918 -- a type that yelds a synchronized object.
22920 elsif Is_Record_Type
(Typ
) then
22922 -- Inspect all entities defined in the scope of the type, looking for
22923 -- components of a type that does not yeld a synchronized object or
22924 -- for discriminants with default values.
22926 Id
:= First_Entity
(Typ
);
22927 while Present
(Id
) loop
22928 if Comes_From_Source
(Id
) then
22929 if Ekind
(Id
) = E_Component
then
22930 if Yields_Synchronized_Object
(Etype
(Id
)) then
22931 Has_Sync_Comp
:= True;
22933 -- The component does not yield a synchronized object
22939 elsif Ekind
(Id
) = E_Discriminant
22940 and then Present
(Expression
(Parent
(Id
)))
22949 -- Ensure that the parent type of a type extension yields a
22950 -- synchronized object.
22952 if Etype
(Typ
) /= Typ
22953 and then not Yields_Synchronized_Object
(Etype
(Typ
))
22958 -- If we get here, then all discriminants lack default values and all
22959 -- components are of a type that yields a synchronized object.
22961 return Has_Sync_Comp
;
22963 -- A synchronized interface type yields a synchronized object by default
22965 elsif Is_Synchronized_Interface
(Typ
) then
22968 -- A task type yelds a synchronized object by default
22970 elsif Is_Task_Type
(Typ
) then
22973 -- Otherwise the type does not yield a synchronized object
22978 end Yields_Synchronized_Object
;
22980 ---------------------------
22981 -- Yields_Universal_Type --
22982 ---------------------------
22984 function Yields_Universal_Type
(N
: Node_Id
) return Boolean is
22986 -- Integer and real literals are of a universal type
22988 if Nkind_In
(N
, N_Integer_Literal
, N_Real_Literal
) then
22991 -- The values of certain attributes are of a universal type
22993 elsif Nkind
(N
) = N_Attribute_Reference
then
22995 Universal_Type_Attribute
(Get_Attribute_Id
(Attribute_Name
(N
)));
22997 -- ??? There are possibly other cases to consider
23002 end Yields_Universal_Type
;