1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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 Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Casing
; use Casing
;
29 with Checks
; use Checks
;
30 with Debug
; use Debug
;
31 with Einfo
; use Einfo
;
32 with Elists
; use Elists
;
33 with Errout
; use Errout
;
34 with Exp_Aggr
; use Exp_Aggr
;
35 with Exp_Ch6
; use Exp_Ch6
;
36 with Exp_Ch7
; use Exp_Ch7
;
37 with Exp_Ch11
; use Exp_Ch11
;
38 with Ghost
; use Ghost
;
39 with Inline
; use Inline
;
40 with Itypes
; use Itypes
;
42 with Nlists
; use Nlists
;
43 with Nmake
; use Nmake
;
45 with Restrict
; use Restrict
;
46 with Rident
; use Rident
;
48 with Sem_Aux
; use Sem_Aux
;
49 with Sem_Ch3
; use Sem_Ch3
;
50 with Sem_Ch6
; use Sem_Ch6
;
51 with Sem_Ch8
; use Sem_Ch8
;
52 with Sem_Ch12
; use Sem_Ch12
;
53 with Sem_Ch13
; use Sem_Ch13
;
54 with Sem_Disp
; use Sem_Disp
;
55 with Sem_Eval
; use Sem_Eval
;
56 with Sem_Res
; use Sem_Res
;
57 with Sem_Type
; use Sem_Type
;
58 with Sem_Util
; use Sem_Util
;
59 with Snames
; use Snames
;
60 with Stand
; use Stand
;
61 with Stringt
; use Stringt
;
62 with Targparm
; use Targparm
;
63 with Tbuild
; use Tbuild
;
64 with Ttypes
; use Ttypes
;
65 with Urealp
; use Urealp
;
66 with Validsw
; use Validsw
;
68 with GNAT
.HTable
; use GNAT
.HTable
;
70 package body Exp_Util
is
72 ---------------------------------------------------------
73 -- Handling of inherited class-wide pre/postconditions --
74 ---------------------------------------------------------
76 -- Following AI12-0113, the expression for a class-wide condition is
77 -- transformed for a subprogram that inherits it, by replacing calls
78 -- to primitive operations of the original controlling type into the
79 -- corresponding overriding operations of the derived type. The following
80 -- hash table manages this mapping, and is expanded on demand whenever
81 -- such inherited expression needs to be constructed.
83 -- The mapping is also used to check whether an inherited operation has
84 -- a condition that depends on overridden operations. For such an
85 -- operation we must create a wrapper that is then treated as a normal
86 -- overriding. In SPARK mode such operations are illegal.
88 -- For a given root type there may be several type extensions with their
89 -- own overriding operations, so at various times a given operation of
90 -- the root will be mapped into different overridings. The root type is
91 -- also mapped into the current type extension to indicate that its
92 -- operations are mapped into the overriding operations of that current
95 Primitives_Mapping_Size
: constant := 511;
97 subtype Num_Primitives
is Integer range 0 .. Primitives_Mapping_Size
- 1;
98 function Entity_Hash
(E
: Entity_Id
) return Num_Primitives
;
100 package Primitives_Mapping
is new GNAT
.HTable
.Simple_HTable
101 (Header_Num
=> Num_Primitives
,
103 Element
=> Entity_Id
,
108 -----------------------
109 -- Local Subprograms --
110 -----------------------
112 function Build_Task_Array_Image
116 Dyn
: Boolean := False) return Node_Id
;
117 -- Build function to generate the image string for a task that is an array
118 -- component, concatenating the images of each index. To avoid storage
119 -- leaks, the string is built with successive slice assignments. The flag
120 -- Dyn indicates whether this is called for the initialization procedure of
121 -- an array of tasks, or for the name of a dynamically created task that is
122 -- assigned to an indexed component.
124 function Build_Task_Image_Function
128 Res
: Entity_Id
) return Node_Id
;
129 -- Common processing for Task_Array_Image and Task_Record_Image. Build
130 -- function body that computes image.
132 procedure Build_Task_Image_Prefix
141 -- Common processing for Task_Array_Image and Task_Record_Image. Create
142 -- local variables and assign prefix of name to result string.
144 function Build_Task_Record_Image
147 Dyn
: Boolean := False) return Node_Id
;
148 -- Build function to generate the image string for a task that is a record
149 -- component. Concatenate name of variable with that of selector. The flag
150 -- Dyn indicates whether this is called for the initialization procedure of
151 -- record with task components, or for a dynamically created task that is
152 -- assigned to a selected component.
154 procedure Evaluate_Slice_Bounds
(Slice
: Node_Id
);
155 -- Force evaluation of bounds of a slice, which may be given by a range
156 -- or by a subtype indication with or without a constraint.
158 function Find_DIC_Type
(Typ
: Entity_Id
) return Entity_Id
;
159 -- Subsidiary to all Build_DIC_Procedure_xxx routines. Find the type which
160 -- defines the Default_Initial_Condition pragma of type Typ. This is either
161 -- Typ itself or a parent type when the pragma is inherited.
163 function Make_CW_Equivalent_Type
165 E
: Node_Id
) return Entity_Id
;
166 -- T is a class-wide type entity, E is the initial expression node that
167 -- constrains T in case such as: " X: T := E" or "new T'(E)". This function
168 -- returns the entity of the Equivalent type and inserts on the fly the
169 -- necessary declaration such as:
171 -- type anon is record
172 -- _parent : Root_Type (T); constrained with E discriminants (if any)
173 -- Extension : String (1 .. expr to match size of E);
176 -- This record is compatible with any object of the class of T thanks to
177 -- the first field and has the same size as E thanks to the second.
179 function Make_Literal_Range
181 Literal_Typ
: Entity_Id
) return Node_Id
;
182 -- Produce a Range node whose bounds are:
183 -- Low_Bound (Literal_Type) ..
184 -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
185 -- this is used for expanding declarations like X : String := "sdfgdfg";
187 -- If the index type of the target array is not integer, we generate:
188 -- Low_Bound (Literal_Type) ..
190 -- (Literal_Type'Pos (Low_Bound (Literal_Type))
191 -- + (Length (Literal_Typ) -1))
193 function Make_Non_Empty_Check
195 N
: Node_Id
) return Node_Id
;
196 -- Produce a boolean expression checking that the unidimensional array
197 -- node N is not empty.
199 function New_Class_Wide_Subtype
201 N
: Node_Id
) return Entity_Id
;
202 -- Create an implicit subtype of CW_Typ attached to node N
204 function Requires_Cleanup_Actions
207 Nested_Constructs
: Boolean) return Boolean;
208 -- Given a list L, determine whether it contains one of the following:
210 -- 1) controlled objects
211 -- 2) library-level tagged types
213 -- Lib_Level is True when the list comes from a construct at the library
214 -- level, and False otherwise. Nested_Constructs is True when any nested
215 -- packages declared in L must be processed, and False otherwise.
217 -------------------------------------
218 -- Activate_Atomic_Synchronization --
219 -------------------------------------
221 procedure Activate_Atomic_Synchronization
(N
: Node_Id
) is
225 case Nkind
(Parent
(N
)) is
227 -- Check for cases of appearing in the prefix of a construct where we
228 -- don't need atomic synchronization for this kind of usage.
231 -- Nothing to do if we are the prefix of an attribute, since we
232 -- do not want an atomic sync operation for things like 'Size.
234 N_Attribute_Reference
236 -- The N_Reference node is like an attribute
240 -- Nothing to do for a reference to a component (or components)
241 -- of a composite object. Only reads and updates of the object
242 -- as a whole require atomic synchronization (RM C.6 (15)).
244 | N_Indexed_Component
245 | N_Selected_Component
248 -- For all the above cases, nothing to do if we are the prefix
250 if Prefix
(Parent
(N
)) = N
then
258 -- Nothing to do for the identifier in an object renaming declaration,
259 -- the renaming itself does not need atomic synchronization.
261 if Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
then
265 -- Go ahead and set the flag
267 Set_Atomic_Sync_Required
(N
);
269 -- Generate info message if requested
271 if Warn_On_Atomic_Synchronization
then
277 | N_Selected_Component
279 Msg_Node
:= Selector_Name
(N
);
281 when N_Explicit_Dereference
282 | N_Indexed_Component
287 pragma Assert
(False);
291 if Present
(Msg_Node
) then
293 ("info: atomic synchronization set for &?N?", Msg_Node
);
296 ("info: atomic synchronization set?N?", N
);
299 end Activate_Atomic_Synchronization
;
301 ----------------------
302 -- Adjust_Condition --
303 ----------------------
305 procedure Adjust_Condition
(N
: Node_Id
) is
312 Loc
: constant Source_Ptr
:= Sloc
(N
);
313 T
: constant Entity_Id
:= Etype
(N
);
317 -- Defend against a call where the argument has no type, or has a
318 -- type that is not Boolean. This can occur because of prior errors.
320 if No
(T
) or else not Is_Boolean_Type
(T
) then
324 -- Apply validity checking if needed
326 if Validity_Checks_On
and Validity_Check_Tests
then
330 -- Immediate return if standard boolean, the most common case,
331 -- where nothing needs to be done.
333 if Base_Type
(T
) = Standard_Boolean
then
337 -- Case of zero/non-zero semantics or non-standard enumeration
338 -- representation. In each case, we rewrite the node as:
340 -- ityp!(N) /= False'Enum_Rep
342 -- where ityp is an integer type with large enough size to hold any
345 if Nonzero_Is_True
(T
) or else Has_Non_Standard_Rep
(T
) then
346 if Esize
(T
) <= Esize
(Standard_Integer
) then
347 Ti
:= Standard_Integer
;
349 Ti
:= Standard_Long_Long_Integer
;
354 Left_Opnd
=> Unchecked_Convert_To
(Ti
, N
),
356 Make_Attribute_Reference
(Loc
,
357 Attribute_Name
=> Name_Enum_Rep
,
359 New_Occurrence_Of
(First_Literal
(T
), Loc
))));
360 Analyze_And_Resolve
(N
, Standard_Boolean
);
363 Rewrite
(N
, Convert_To
(Standard_Boolean
, N
));
364 Analyze_And_Resolve
(N
, Standard_Boolean
);
367 end Adjust_Condition
;
369 ------------------------
370 -- Adjust_Result_Type --
371 ------------------------
373 procedure Adjust_Result_Type
(N
: Node_Id
; T
: Entity_Id
) is
375 -- Ignore call if current type is not Standard.Boolean
377 if Etype
(N
) /= Standard_Boolean
then
381 -- If result is already of correct type, nothing to do. Note that
382 -- this will get the most common case where everything has a type
383 -- of Standard.Boolean.
385 if Base_Type
(T
) = Standard_Boolean
then
390 KP
: constant Node_Kind
:= Nkind
(Parent
(N
));
393 -- If result is to be used as a Condition in the syntax, no need
394 -- to convert it back, since if it was changed to Standard.Boolean
395 -- using Adjust_Condition, that is just fine for this usage.
397 if KP
in N_Raise_xxx_Error
or else KP
in N_Has_Condition
then
400 -- If result is an operand of another logical operation, no need
401 -- to reset its type, since Standard.Boolean is just fine, and
402 -- such operations always do Adjust_Condition on their operands.
404 elsif KP
in N_Op_Boolean
405 or else KP
in N_Short_Circuit
406 or else KP
= N_Op_Not
410 -- Otherwise we perform a conversion from the current type, which
411 -- must be Standard.Boolean, to the desired type. Use the base
412 -- type to prevent spurious constraint checks that are extraneous
413 -- to the transformation. The type and its base have the same
414 -- representation, standard or otherwise.
418 Rewrite
(N
, Convert_To
(Base_Type
(T
), N
));
419 Analyze_And_Resolve
(N
, Base_Type
(T
));
423 end Adjust_Result_Type
;
425 --------------------------
426 -- Append_Freeze_Action --
427 --------------------------
429 procedure Append_Freeze_Action
(T
: Entity_Id
; N
: Node_Id
) is
433 Ensure_Freeze_Node
(T
);
434 Fnode
:= Freeze_Node
(T
);
436 if No
(Actions
(Fnode
)) then
437 Set_Actions
(Fnode
, New_List
(N
));
439 Append
(N
, Actions
(Fnode
));
442 end Append_Freeze_Action
;
444 ---------------------------
445 -- Append_Freeze_Actions --
446 ---------------------------
448 procedure Append_Freeze_Actions
(T
: Entity_Id
; L
: List_Id
) is
456 Ensure_Freeze_Node
(T
);
457 Fnode
:= Freeze_Node
(T
);
459 if No
(Actions
(Fnode
)) then
460 Set_Actions
(Fnode
, L
);
462 Append_List
(L
, Actions
(Fnode
));
464 end Append_Freeze_Actions
;
466 ------------------------------------
467 -- Build_Allocate_Deallocate_Proc --
468 ------------------------------------
470 procedure Build_Allocate_Deallocate_Proc
472 Is_Allocate
: Boolean)
474 Desig_Typ
: Entity_Id
;
477 Proc_To_Call
: Node_Id
:= Empty
;
480 function Find_Object
(E
: Node_Id
) return Node_Id
;
481 -- Given an arbitrary expression of an allocator, try to find an object
482 -- reference in it, otherwise return the original expression.
484 function Is_Allocate_Deallocate_Proc
(Subp
: Entity_Id
) return Boolean;
485 -- Determine whether subprogram Subp denotes a custom allocate or
492 function Find_Object
(E
: Node_Id
) return Node_Id
is
496 pragma Assert
(Is_Allocate
);
500 if Nkind
(Expr
) = N_Explicit_Dereference
then
501 Expr
:= Prefix
(Expr
);
503 elsif Nkind
(Expr
) = N_Qualified_Expression
then
504 Expr
:= Expression
(Expr
);
506 elsif Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
508 -- When interface class-wide types are involved in allocation,
509 -- the expander introduces several levels of address arithmetic
510 -- to perform dispatch table displacement. In this scenario the
511 -- object appears as:
513 -- Tag_Ptr (Base_Address (<object>'Address))
515 -- Detect this case and utilize the whole expression as the
516 -- "object" since it now points to the proper dispatch table.
518 if Is_RTE
(Etype
(Expr
), RE_Tag_Ptr
) then
521 -- Continue to strip the object
524 Expr
:= Expression
(Expr
);
535 ---------------------------------
536 -- Is_Allocate_Deallocate_Proc --
537 ---------------------------------
539 function Is_Allocate_Deallocate_Proc
(Subp
: Entity_Id
) return Boolean is
541 -- Look for a subprogram body with only one statement which is a
542 -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
544 if Ekind
(Subp
) = E_Procedure
545 and then Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Body
548 HSS
: constant Node_Id
:=
549 Handled_Statement_Sequence
(Parent
(Parent
(Subp
)));
553 if Present
(Statements
(HSS
))
554 and then Nkind
(First
(Statements
(HSS
))) =
555 N_Procedure_Call_Statement
557 Proc
:= Entity
(Name
(First
(Statements
(HSS
))));
560 Is_RTE
(Proc
, RE_Allocate_Any_Controlled
)
561 or else Is_RTE
(Proc
, RE_Deallocate_Any_Controlled
);
567 end Is_Allocate_Deallocate_Proc
;
569 -- Start of processing for Build_Allocate_Deallocate_Proc
572 -- Obtain the attributes of the allocation / deallocation
574 if Nkind
(N
) = N_Free_Statement
then
575 Expr
:= Expression
(N
);
576 Ptr_Typ
:= Base_Type
(Etype
(Expr
));
577 Proc_To_Call
:= Procedure_To_Call
(N
);
580 if Nkind
(N
) = N_Object_Declaration
then
581 Expr
:= Expression
(N
);
586 -- In certain cases an allocator with a qualified expression may
587 -- be relocated and used as the initialization expression of a
591 -- Obj : Ptr_Typ := new Desig_Typ'(...);
594 -- Tmp : Ptr_Typ := new Desig_Typ'(...);
595 -- Obj : Ptr_Typ := Tmp;
597 -- Since the allocator is always marked as analyzed to avoid infinite
598 -- expansion, it will never be processed by this routine given that
599 -- the designated type needs finalization actions. Detect this case
600 -- and complete the expansion of the allocator.
602 if Nkind
(Expr
) = N_Identifier
603 and then Nkind
(Parent
(Entity
(Expr
))) = N_Object_Declaration
604 and then Nkind
(Expression
(Parent
(Entity
(Expr
)))) = N_Allocator
606 Build_Allocate_Deallocate_Proc
(Parent
(Entity
(Expr
)), True);
610 -- The allocator may have been rewritten into something else in which
611 -- case the expansion performed by this routine does not apply.
613 if Nkind
(Expr
) /= N_Allocator
then
617 Ptr_Typ
:= Base_Type
(Etype
(Expr
));
618 Proc_To_Call
:= Procedure_To_Call
(Expr
);
621 Pool_Id
:= Associated_Storage_Pool
(Ptr_Typ
);
622 Desig_Typ
:= Available_View
(Designated_Type
(Ptr_Typ
));
624 -- Handle concurrent types
626 if Is_Concurrent_Type
(Desig_Typ
)
627 and then Present
(Corresponding_Record_Type
(Desig_Typ
))
629 Desig_Typ
:= Corresponding_Record_Type
(Desig_Typ
);
632 -- Do not process allocations / deallocations without a pool
637 -- Do not process allocations on / deallocations from the secondary
640 elsif Is_RTE
(Pool_Id
, RE_SS_Pool
) then
643 -- Optimize the case where we are using the default Global_Pool_Object,
644 -- and we don't need the heavy finalization machinery.
646 elsif Pool_Id
= RTE
(RE_Global_Pool_Object
)
647 and then not Needs_Finalization
(Desig_Typ
)
651 -- Do not replicate the machinery if the allocator / free has already
652 -- been expanded and has a custom Allocate / Deallocate.
654 elsif Present
(Proc_To_Call
)
655 and then Is_Allocate_Deallocate_Proc
(Proc_To_Call
)
660 if Needs_Finalization
(Desig_Typ
) then
662 -- Certain run-time configurations and targets do not provide support
663 -- for controlled types.
665 if Restriction_Active
(No_Finalization
) then
668 -- Do nothing if the access type may never allocate / deallocate
671 elsif No_Pool_Assigned
(Ptr_Typ
) then
675 -- The allocation / deallocation of a controlled object must be
676 -- chained on / detached from a finalization master.
678 pragma Assert
(Present
(Finalization_Master
(Ptr_Typ
)));
680 -- The only other kind of allocation / deallocation supported by this
681 -- routine is on / from a subpool.
683 elsif Nkind
(Expr
) = N_Allocator
684 and then No
(Subpool_Handle_Name
(Expr
))
690 Loc
: constant Source_Ptr
:= Sloc
(N
);
691 Addr_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
692 Alig_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'L');
693 Proc_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
694 Size_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
697 Fin_Addr_Id
: Entity_Id
;
698 Fin_Mas_Act
: Node_Id
;
699 Fin_Mas_Id
: Entity_Id
;
700 Proc_To_Call
: Entity_Id
;
701 Subpool
: Node_Id
:= Empty
;
704 -- Step 1: Construct all the actuals for the call to library routine
705 -- Allocate_Any_Controlled / Deallocate_Any_Controlled.
709 Actuals
:= New_List
(New_Occurrence_Of
(Pool_Id
, Loc
));
715 if Nkind
(Expr
) = N_Allocator
then
716 Subpool
:= Subpool_Handle_Name
(Expr
);
719 -- If a subpool is present it can be an arbitrary name, so make
720 -- the actual by copying the tree.
722 if Present
(Subpool
) then
723 Append_To
(Actuals
, New_Copy_Tree
(Subpool
, New_Sloc
=> Loc
));
725 Append_To
(Actuals
, Make_Null
(Loc
));
728 -- c) Finalization master
730 if Needs_Finalization
(Desig_Typ
) then
731 Fin_Mas_Id
:= Finalization_Master
(Ptr_Typ
);
732 Fin_Mas_Act
:= New_Occurrence_Of
(Fin_Mas_Id
, Loc
);
734 -- Handle the case where the master is actually a pointer to a
735 -- master. This case arises in build-in-place functions.
737 if Is_Access_Type
(Etype
(Fin_Mas_Id
)) then
738 Append_To
(Actuals
, Fin_Mas_Act
);
741 Make_Attribute_Reference
(Loc
,
742 Prefix
=> Fin_Mas_Act
,
743 Attribute_Name
=> Name_Unrestricted_Access
));
746 Append_To
(Actuals
, Make_Null
(Loc
));
749 -- d) Finalize_Address
751 -- Primitive Finalize_Address is never generated in CodePeer mode
752 -- since it contains an Unchecked_Conversion.
754 if Needs_Finalization
(Desig_Typ
) and then not CodePeer_Mode
then
755 Fin_Addr_Id
:= Finalize_Address
(Desig_Typ
);
756 pragma Assert
(Present
(Fin_Addr_Id
));
759 Make_Attribute_Reference
(Loc
,
760 Prefix
=> New_Occurrence_Of
(Fin_Addr_Id
, Loc
),
761 Attribute_Name
=> Name_Unrestricted_Access
));
763 Append_To
(Actuals
, Make_Null
(Loc
));
771 Append_To
(Actuals
, New_Occurrence_Of
(Addr_Id
, Loc
));
772 Append_To
(Actuals
, New_Occurrence_Of
(Size_Id
, Loc
));
774 if Is_Allocate
or else not Is_Class_Wide_Type
(Desig_Typ
) then
775 Append_To
(Actuals
, New_Occurrence_Of
(Alig_Id
, Loc
));
777 -- For deallocation of class-wide types we obtain the value of
778 -- alignment from the Type Specific Record of the deallocated object.
779 -- This is needed because the frontend expansion of class-wide types
780 -- into equivalent types confuses the back end.
786 -- ... because 'Alignment applied to class-wide types is expanded
787 -- into the code that reads the value of alignment from the TSD
788 -- (see Expand_N_Attribute_Reference)
791 Unchecked_Convert_To
(RTE
(RE_Storage_Offset
),
792 Make_Attribute_Reference
(Loc
,
794 Make_Explicit_Dereference
(Loc
, Relocate_Node
(Expr
)),
795 Attribute_Name
=> Name_Alignment
)));
800 if Needs_Finalization
(Desig_Typ
) then
802 Flag_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F');
809 Temp
:= Find_Object
(Expression
(Expr
));
814 -- Processing for allocations where the expression is a subtype
818 and then Is_Entity_Name
(Temp
)
819 and then Is_Type
(Entity
(Temp
))
824 (Needs_Finalization
(Entity
(Temp
))), Loc
);
826 -- The allocation / deallocation of a class-wide object relies
827 -- on a runtime check to determine whether the object is truly
828 -- controlled or not. Depending on this check, the finalization
829 -- machinery will request or reclaim extra storage reserved for
832 elsif Is_Class_Wide_Type
(Desig_Typ
) then
834 -- Detect a special case where interface class-wide types
835 -- are involved as the object appears as:
837 -- Tag_Ptr (Base_Address (<object>'Address))
839 -- The expression already yields the proper tag, generate:
843 if Is_RTE
(Etype
(Temp
), RE_Tag_Ptr
) then
845 Make_Explicit_Dereference
(Loc
,
846 Prefix
=> Relocate_Node
(Temp
));
848 -- In the default case, obtain the tag of the object about
849 -- to be allocated / deallocated. Generate:
855 Make_Attribute_Reference
(Loc
,
856 Prefix
=> Relocate_Node
(Temp
),
857 Attribute_Name
=> Name_Tag
);
861 -- Needs_Finalization (<Param>)
864 Make_Function_Call
(Loc
,
866 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
867 Parameter_Associations
=> New_List
(Param
));
869 -- Processing for generic actuals
871 elsif Is_Generic_Actual_Type
(Desig_Typ
) then
873 New_Occurrence_Of
(Boolean_Literals
874 (Needs_Finalization
(Base_Type
(Desig_Typ
))), Loc
);
876 -- The object does not require any specialized checks, it is
877 -- known to be controlled.
880 Flag_Expr
:= New_Occurrence_Of
(Standard_True
, Loc
);
883 -- Create the temporary which represents the finalization state
884 -- of the expression. Generate:
886 -- F : constant Boolean := <Flag_Expr>;
889 Make_Object_Declaration
(Loc
,
890 Defining_Identifier
=> Flag_Id
,
891 Constant_Present
=> True,
893 New_Occurrence_Of
(Standard_Boolean
, Loc
),
894 Expression
=> Flag_Expr
));
896 Append_To
(Actuals
, New_Occurrence_Of
(Flag_Id
, Loc
));
899 -- The object is not controlled
902 Append_To
(Actuals
, New_Occurrence_Of
(Standard_False
, Loc
));
909 New_Occurrence_Of
(Boolean_Literals
(Present
(Subpool
)), Loc
));
912 -- Step 2: Build a wrapper Allocate / Deallocate which internally
913 -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
915 -- Select the proper routine to call
918 Proc_To_Call
:= RTE
(RE_Allocate_Any_Controlled
);
920 Proc_To_Call
:= RTE
(RE_Deallocate_Any_Controlled
);
923 -- Create a custom Allocate / Deallocate routine which has identical
924 -- profile to that of System.Storage_Pools.
927 Make_Subprogram_Body
(Loc
,
932 Make_Procedure_Specification
(Loc
,
933 Defining_Unit_Name
=> Proc_Id
,
934 Parameter_Specifications
=> New_List
(
936 -- P : Root_Storage_Pool
938 Make_Parameter_Specification
(Loc
,
939 Defining_Identifier
=> Make_Temporary
(Loc
, 'P'),
941 New_Occurrence_Of
(RTE
(RE_Root_Storage_Pool
), Loc
)),
945 Make_Parameter_Specification
(Loc
,
946 Defining_Identifier
=> Addr_Id
,
947 Out_Present
=> Is_Allocate
,
949 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)),
953 Make_Parameter_Specification
(Loc
,
954 Defining_Identifier
=> Size_Id
,
956 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
)),
960 Make_Parameter_Specification
(Loc
,
961 Defining_Identifier
=> Alig_Id
,
963 New_Occurrence_Of
(RTE
(RE_Storage_Count
), Loc
)))),
965 Declarations
=> No_List
,
967 Handled_Statement_Sequence
=>
968 Make_Handled_Sequence_Of_Statements
(Loc
,
969 Statements
=> New_List
(
970 Make_Procedure_Call_Statement
(Loc
,
971 Name
=> New_Occurrence_Of
(Proc_To_Call
, Loc
),
972 Parameter_Associations
=> Actuals
)))));
974 -- The newly generated Allocate / Deallocate becomes the default
975 -- procedure to call when the back end processes the allocation /
979 Set_Procedure_To_Call
(Expr
, Proc_Id
);
981 Set_Procedure_To_Call
(N
, Proc_Id
);
984 end Build_Allocate_Deallocate_Proc
;
986 -------------------------------
987 -- Build_Abort_Undefer_Block --
988 -------------------------------
990 function Build_Abort_Undefer_Block
993 Context
: Node_Id
) return Node_Id
995 Exceptions_OK
: constant Boolean :=
996 not Restriction_Active
(No_Exception_Propagation
);
1004 -- The block should be generated only when undeferring abort in the
1005 -- context of a potential exception.
1007 pragma Assert
(Abort_Allowed
and Exceptions_OK
);
1013 -- Abort_Undefer_Direct;
1016 AUD
:= RTE
(RE_Abort_Undefer_Direct
);
1019 Make_Handled_Sequence_Of_Statements
(Loc
,
1020 Statements
=> Stmts
,
1021 At_End_Proc
=> New_Occurrence_Of
(AUD
, Loc
));
1024 Make_Block_Statement
(Loc
,
1025 Handled_Statement_Sequence
=> HSS
);
1026 Set_Is_Abort_Block
(Blk
);
1028 Add_Block_Identifier
(Blk
, Blk_Id
);
1029 Expand_At_End_Handler
(HSS
, Blk_Id
);
1031 -- Present the Abort_Undefer_Direct function to the back end to inline
1032 -- the call to the routine.
1034 Add_Inlined_Body
(AUD
, Context
);
1037 end Build_Abort_Undefer_Block
;
1039 ---------------------------------
1040 -- Build_Class_Wide_Expression --
1041 ---------------------------------
1043 procedure Build_Class_Wide_Expression
1046 Par_Subp
: Entity_Id
;
1047 Adjust_Sloc
: Boolean)
1049 function Replace_Entity
(N
: Node_Id
) return Traverse_Result
;
1050 -- Replace reference to formal of inherited operation or to primitive
1051 -- operation of root type, with corresponding entity for derived type,
1052 -- when constructing the class-wide condition of an overriding
1055 --------------------
1056 -- Replace_Entity --
1057 --------------------
1059 function Replace_Entity
(N
: Node_Id
) return Traverse_Result
is
1064 Adjust_Inherited_Pragma_Sloc
(N
);
1067 if Nkind
(N
) = N_Identifier
1068 and then Present
(Entity
(N
))
1070 (Is_Formal
(Entity
(N
)) or else Is_Subprogram
(Entity
(N
)))
1072 (Nkind
(Parent
(N
)) /= N_Attribute_Reference
1073 or else Attribute_Name
(Parent
(N
)) /= Name_Class
)
1075 -- The replacement does not apply to dispatching calls within the
1076 -- condition, but only to calls whose static tag is that of the
1079 if Is_Subprogram
(Entity
(N
))
1080 and then Nkind
(Parent
(N
)) = N_Function_Call
1081 and then Present
(Controlling_Argument
(Parent
(N
)))
1086 -- Determine whether entity has a renaming
1088 New_E
:= Primitives_Mapping
.Get
(Entity
(N
));
1090 if Present
(New_E
) then
1091 Rewrite
(N
, New_Occurrence_Of
(New_E
, Sloc
(N
)));
1094 -- Check that there are no calls left to abstract operations if
1095 -- the current subprogram is not abstract.
1097 if Nkind
(Parent
(N
)) = N_Function_Call
1098 and then N
= Name
(Parent
(N
))
1100 if not Is_Abstract_Subprogram
(Subp
)
1101 and then Is_Abstract_Subprogram
(Entity
(N
))
1103 Error_Msg_Sloc
:= Sloc
(Current_Scope
);
1105 ("cannot call abstract subprogram in inherited condition "
1106 & "for&#", N
, Current_Scope
);
1108 -- In SPARK mode, reject an inherited condition for an
1109 -- inherited operation if it contains a call to an overriding
1110 -- operation, because this implies that the pre/postconditions
1111 -- of the inherited operation have changed silently.
1113 elsif SPARK_Mode
= On
1114 and then Warn_On_Suspicious_Contract
1115 and then Present
(Alias
(Subp
))
1116 and then Present
(New_E
)
1117 and then Comes_From_Source
(New_E
)
1120 ("cannot modify inherited condition (SPARK RM 6.1.1(1))",
1122 Error_Msg_Sloc
:= Sloc
(New_E
);
1123 Error_Msg_Node_2
:= Subp
;
1125 ("\overriding of&# forces overriding of&",
1126 Parent
(Subp
), New_E
);
1130 -- Update type of function call node, which should be the same as
1131 -- the function's return type.
1133 if Is_Subprogram
(Entity
(N
))
1134 and then Nkind
(Parent
(N
)) = N_Function_Call
1136 Set_Etype
(Parent
(N
), Etype
(Entity
(N
)));
1139 -- The whole expression will be reanalyzed
1141 elsif Nkind
(N
) in N_Has_Etype
then
1142 Set_Analyzed
(N
, False);
1148 procedure Replace_Condition_Entities
is
1149 new Traverse_Proc
(Replace_Entity
);
1153 Par_Formal
: Entity_Id
;
1154 Subp_Formal
: Entity_Id
;
1156 -- Start of processing for Build_Class_Wide_Expression
1159 -- Add mapping from old formals to new formals
1161 Par_Formal
:= First_Formal
(Par_Subp
);
1162 Subp_Formal
:= First_Formal
(Subp
);
1164 while Present
(Par_Formal
) and then Present
(Subp_Formal
) loop
1165 Primitives_Mapping
.Set
(Par_Formal
, Subp_Formal
);
1166 Next_Formal
(Par_Formal
);
1167 Next_Formal
(Subp_Formal
);
1170 Replace_Condition_Entities
(Prag
);
1171 end Build_Class_Wide_Expression
;
1173 --------------------
1174 -- Build_DIC_Call --
1175 --------------------
1177 function Build_DIC_Call
1180 Typ
: Entity_Id
) return Node_Id
1182 Proc_Id
: constant Entity_Id
:= DIC_Procedure
(Typ
);
1183 Formal_Typ
: constant Entity_Id
:= Etype
(First_Formal
(Proc_Id
));
1187 Make_Procedure_Call_Statement
(Loc
,
1188 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
1189 Parameter_Associations
=> New_List
(
1190 Make_Unchecked_Type_Conversion
(Loc
,
1191 Subtype_Mark
=> New_Occurrence_Of
(Formal_Typ
, Loc
),
1192 Expression
=> New_Occurrence_Of
(Obj_Id
, Loc
))));
1195 ------------------------------
1196 -- Build_DIC_Procedure_Body --
1197 ------------------------------
1199 -- WARNING: This routine manages Ghost regions. Return statements must be
1200 -- replaced by gotos which jump to the end of the routine and restore the
1203 procedure Build_DIC_Procedure_Body
(Typ
: Entity_Id
) is
1204 procedure Add_DIC_Check
1205 (DIC_Prag
: Node_Id
;
1207 Stmts
: in out List_Id
);
1208 -- Subsidiary to all Add_xxx_DIC routines. Add a runtime check to verify
1209 -- assertion expression DIC_Expr of pragma DIC_Prag. All generated code
1210 -- is added to list Stmts.
1212 procedure Add_Inherited_DIC
1213 (DIC_Prag
: Node_Id
;
1214 Par_Typ
: Entity_Id
;
1215 Deriv_Typ
: Entity_Id
;
1216 Stmts
: in out List_Id
);
1217 -- Add a runtime check to verify the assertion expression of inherited
1218 -- pragma DIC_Prag. Par_Typ is parent type, which is also the owner of
1219 -- the DIC pragma. Deriv_Typ is the derived type inheriting the DIC
1220 -- pragma. All generated code is added to list Stmts.
1222 procedure Add_Inherited_Tagged_DIC
1223 (DIC_Prag
: Node_Id
;
1224 Par_Typ
: Entity_Id
;
1225 Deriv_Typ
: Entity_Id
;
1226 Stmts
: in out List_Id
);
1227 -- Add a runtime check to verify assertion expression DIC_Expr of
1228 -- inherited pragma DIC_Prag. This routine applies class-wide pre- and
1229 -- postcondition-like runtime semantics to the check. Par_Typ is the
1230 -- parent type whose DIC pragma is being inherited. Deriv_Typ is the
1231 -- derived type inheriting the DIC pragma. All generated code is added
1234 procedure Add_Own_DIC
1235 (DIC_Prag
: Node_Id
;
1236 DIC_Typ
: Entity_Id
;
1237 Stmts
: in out List_Id
);
1238 -- Add a runtime check to verify the assertion expression of pragma
1239 -- DIC_Prag. DIC_Typ is the owner of the DIC pragma. All generated code
1240 -- is added to list Stmts.
1242 procedure Replace_Object_And_Primitive_References
1244 Par_Typ
: Entity_Id
;
1245 Deriv_Typ
: Entity_Id
;
1246 Par_Obj
: Entity_Id
:= Empty
;
1247 Deriv_Obj
: Entity_Id
:= Empty
);
1248 -- Expr denotes an arbitrary expression. Par_Typ is a parent type in a
1249 -- type hierarchy. Deriv_Typ is a type derived from Par_Typ. Par_Obj is
1250 -- the formal parameter which emulates the current instance of Par_Typ.
1251 -- Deriv_Obj is the formal parameter which emulates the current instance
1252 -- of Deriv_Typ. Perform the following substitutions:
1254 -- * Replace a reference to Par_Obj with a reference to Deriv_Obj if
1257 -- * Replace a call to an overridden parent primitive with a call to
1258 -- the overriding derived type primitive.
1260 -- * Replace a call to an inherited parent primitive with a call to
1261 -- the internally-generated inherited derived type primitive.
1263 procedure Replace_Type_References
1266 Obj_Id
: Entity_Id
);
1267 -- Substitute all references of the current instance of type Typ with
1268 -- references to formal parameter Obj_Id within expression Expr.
1274 procedure Add_DIC_Check
1275 (DIC_Prag
: Node_Id
;
1277 Stmts
: in out List_Id
)
1279 Loc
: constant Source_Ptr
:= Sloc
(DIC_Prag
);
1280 Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(DIC_Prag
);
1283 -- The DIC pragma is ignored, nothing left to do
1285 if Is_Ignored
(DIC_Prag
) then
1288 -- Otherwise the DIC expression must be checked at runtime. Generate:
1290 -- pragma Check (<Nam>, <DIC_Expr>);
1293 Append_New_To
(Stmts
,
1295 Pragma_Identifier
=>
1296 Make_Identifier
(Loc
, Name_Check
),
1298 Pragma_Argument_Associations
=> New_List
(
1299 Make_Pragma_Argument_Association
(Loc
,
1300 Expression
=> Make_Identifier
(Loc
, Nam
)),
1302 Make_Pragma_Argument_Association
(Loc
,
1303 Expression
=> DIC_Expr
))));
1307 -----------------------
1308 -- Add_Inherited_DIC --
1309 -----------------------
1311 procedure Add_Inherited_DIC
1312 (DIC_Prag
: Node_Id
;
1313 Par_Typ
: Entity_Id
;
1314 Deriv_Typ
: Entity_Id
;
1315 Stmts
: in out List_Id
)
1317 Deriv_Proc
: constant Entity_Id
:= DIC_Procedure
(Deriv_Typ
);
1318 Deriv_Obj
: constant Entity_Id
:= First_Entity
(Deriv_Proc
);
1319 Par_Proc
: constant Entity_Id
:= DIC_Procedure
(Par_Typ
);
1320 Par_Obj
: constant Entity_Id
:= First_Entity
(Par_Proc
);
1321 Loc
: constant Source_Ptr
:= Sloc
(DIC_Prag
);
1324 pragma Assert
(Present
(Deriv_Proc
) and then Present
(Par_Proc
));
1326 -- Verify the inherited DIC assertion expression by calling the DIC
1327 -- procedure of the parent type.
1330 -- <Par_Typ>DIC (Par_Typ (_object));
1332 Append_New_To
(Stmts
,
1333 Make_Procedure_Call_Statement
(Loc
,
1334 Name
=> New_Occurrence_Of
(Par_Proc
, Loc
),
1335 Parameter_Associations
=> New_List
(
1337 (Typ
=> Etype
(Par_Obj
),
1338 Expr
=> New_Occurrence_Of
(Deriv_Obj
, Loc
)))));
1339 end Add_Inherited_DIC
;
1341 ------------------------------
1342 -- Add_Inherited_Tagged_DIC --
1343 ------------------------------
1345 procedure Add_Inherited_Tagged_DIC
1346 (DIC_Prag
: Node_Id
;
1347 Par_Typ
: Entity_Id
;
1348 Deriv_Typ
: Entity_Id
;
1349 Stmts
: in out List_Id
)
1351 Deriv_Decl
: constant Node_Id
:= Declaration_Node
(Deriv_Typ
);
1352 Deriv_Proc
: constant Entity_Id
:= DIC_Procedure
(Deriv_Typ
);
1353 DIC_Args
: constant List_Id
:=
1354 Pragma_Argument_Associations
(DIC_Prag
);
1355 DIC_Arg
: constant Node_Id
:= First
(DIC_Args
);
1356 DIC_Expr
: constant Node_Id
:= Expression_Copy
(DIC_Arg
);
1357 Par_Proc
: constant Entity_Id
:= DIC_Procedure
(Par_Typ
);
1362 -- The processing of an inherited DIC assertion expression starts off
1363 -- with a copy of the original parent expression where all references
1364 -- to the parent type have already been replaced with references to
1365 -- the _object formal parameter of the parent type's DIC procedure.
1367 pragma Assert
(Present
(DIC_Expr
));
1368 Expr
:= New_Copy_Tree
(DIC_Expr
);
1370 -- Perform the following substitutions:
1372 -- * Replace a reference to the _object parameter of the parent
1373 -- type's DIC procedure with a reference to the _object parameter
1374 -- of the derived types' DIC procedure.
1376 -- * Replace a call to an overridden parent primitive with a call
1377 -- to the overriding derived type primitive.
1379 -- * Replace a call to an inherited parent primitive with a call to
1380 -- the internally-generated inherited derived type primitive.
1382 -- Note that primitives defined in the private part are automatically
1383 -- handled by the overriding/inheritance mechanism and do not require
1384 -- an extra replacement pass.
1386 pragma Assert
(Present
(Deriv_Proc
) and then Present
(Par_Proc
));
1388 Replace_Object_And_Primitive_References
1391 Deriv_Typ
=> Deriv_Typ
,
1392 Par_Obj
=> First_Formal
(Par_Proc
),
1393 Deriv_Obj
=> First_Formal
(Deriv_Proc
));
1395 -- Preanalyze the DIC expression to detect errors and at the same
1396 -- time capture the visibility of the proper package part.
1398 Set_Parent
(Expr
, Deriv_Decl
);
1399 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
1401 -- Once the DIC assertion expression is fully processed, add a check
1402 -- to the statements of the DIC procedure.
1405 (DIC_Prag
=> DIC_Prag
,
1408 end Add_Inherited_Tagged_DIC
;
1414 procedure Add_Own_DIC
1415 (DIC_Prag
: Node_Id
;
1416 DIC_Typ
: Entity_Id
;
1417 Stmts
: in out List_Id
)
1419 DIC_Args
: constant List_Id
:=
1420 Pragma_Argument_Associations
(DIC_Prag
);
1421 DIC_Arg
: constant Node_Id
:= First
(DIC_Args
);
1422 DIC_Asp
: constant Node_Id
:= Corresponding_Aspect
(DIC_Prag
);
1423 DIC_Expr
: constant Node_Id
:= Get_Pragma_Arg
(DIC_Arg
);
1424 DIC_Proc
: constant Entity_Id
:= DIC_Procedure
(DIC_Typ
);
1425 Obj_Id
: constant Entity_Id
:= First_Formal
(DIC_Proc
);
1427 procedure Preanalyze_Own_DIC_For_ASIS
;
1428 -- Preanalyze the original DIC expression of an aspect or a source
1431 ---------------------------------
1432 -- Preanalyze_Own_DIC_For_ASIS --
1433 ---------------------------------
1435 procedure Preanalyze_Own_DIC_For_ASIS
is
1436 Expr
: Node_Id
:= Empty
;
1439 -- The DIC pragma is a source construct, preanalyze the original
1440 -- expression of the pragma.
1442 if Comes_From_Source
(DIC_Prag
) then
1445 -- Otherwise preanalyze the expression of the corresponding aspect
1447 elsif Present
(DIC_Asp
) then
1448 Expr
:= Expression
(DIC_Asp
);
1451 -- The expression must be subjected to the same substitutions as
1452 -- the copy used in the generation of the runtime check.
1454 if Present
(Expr
) then
1455 Replace_Type_References
1460 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
1462 end Preanalyze_Own_DIC_For_ASIS
;
1466 Typ_Decl
: constant Node_Id
:= Declaration_Node
(DIC_Typ
);
1470 -- Start of processing for Add_Own_DIC
1473 Expr
:= New_Copy_Tree
(DIC_Expr
);
1475 -- Perform the following substitution:
1477 -- * Replace the current instance of DIC_Typ with a reference to
1478 -- the _object formal parameter of the DIC procedure.
1480 Replace_Type_References
1485 -- Preanalyze the DIC expression to detect errors and at the same
1486 -- time capture the visibility of the proper package part.
1488 Set_Parent
(Expr
, Typ_Decl
);
1489 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
1491 -- Save a copy of the expression with all replacements and analysis
1492 -- already taken place in case a derived type inherits the pragma.
1493 -- The copy will be used as the foundation of the derived type's own
1494 -- version of the DIC assertion expression.
1496 if Is_Tagged_Type
(DIC_Typ
) then
1497 Set_Expression_Copy
(DIC_Arg
, New_Copy_Tree
(Expr
));
1500 -- If the pragma comes from an aspect specification, replace the
1501 -- saved expression because all type references must be substituted
1502 -- for the call to Preanalyze_Spec_Expression in Check_Aspect_At_xxx
1505 if Present
(DIC_Asp
) then
1506 Set_Entity
(Identifier
(DIC_Asp
), New_Copy_Tree
(Expr
));
1509 -- Preanalyze the original DIC expression for ASIS
1512 Preanalyze_Own_DIC_For_ASIS
;
1515 -- Once the DIC assertion expression is fully processed, add a check
1516 -- to the statements of the DIC procedure.
1519 (DIC_Prag
=> DIC_Prag
,
1524 ---------------------------------------------
1525 -- Replace_Object_And_Primitive_References --
1526 ---------------------------------------------
1528 procedure Replace_Object_And_Primitive_References
1530 Par_Typ
: Entity_Id
;
1531 Deriv_Typ
: Entity_Id
;
1532 Par_Obj
: Entity_Id
:= Empty
;
1533 Deriv_Obj
: Entity_Id
:= Empty
)
1535 function Replace_Ref
(Ref
: Node_Id
) return Traverse_Result
;
1536 -- Substitute a reference to an entity with a reference to the
1537 -- corresponding entity stored in in table Primitives_Mapping.
1543 function Replace_Ref
(Ref
: Node_Id
) return Traverse_Result
is
1544 Context
: constant Node_Id
:= Parent
(Ref
);
1545 Loc
: constant Source_Ptr
:= Sloc
(Ref
);
1549 Result
: Traverse_Result
;
1554 -- The current node denotes a reference
1556 if Nkind
(Ref
) in N_Has_Entity
and then Present
(Entity
(Ref
)) then
1557 Ref_Id
:= Entity
(Ref
);
1558 New_Id
:= Primitives_Mapping
.Get
(Ref_Id
);
1560 -- The reference mentions a parent type primitive which has a
1561 -- corresponding derived type primitive.
1563 if Present
(New_Id
) then
1564 New_Ref
:= New_Occurrence_Of
(New_Id
, Loc
);
1566 -- The reference mentions the _object parameter of the parent
1567 -- type's DIC procedure.
1569 elsif Present
(Par_Obj
)
1570 and then Present
(Deriv_Obj
)
1571 and then Ref_Id
= Par_Obj
1573 New_Ref
:= New_Occurrence_Of
(Deriv_Obj
, Loc
);
1575 -- The reference to _object acts as an actual parameter in a
1576 -- subprogram call which may be invoking a primitive of the
1579 -- Primitive (... _object ...);
1581 -- The parent type primitive may not be overridden nor
1582 -- inherited when it is declared after the derived type
1585 -- type Parent is tagged private;
1586 -- type Child is new Parent with private;
1587 -- procedure Primitive (Obj : Parent);
1589 -- In this scenario the _object parameter is converted to
1592 if Nkind_In
(Context
, N_Function_Call
,
1593 N_Procedure_Call_Statement
)
1595 No
(Primitives_Mapping
.Get
(Entity
(Name
(Context
))))
1597 New_Ref
:= Convert_To
(Par_Typ
, New_Ref
);
1599 -- Do not process the generated type conversion because
1600 -- both the parent type and the derived type are in the
1601 -- Primitives_Mapping table. This will clobber the type
1602 -- conversion by resetting its subtype mark.
1607 -- Otherwise there is nothing to replace
1613 if Present
(New_Ref
) then
1614 Rewrite
(Ref
, New_Ref
);
1616 -- Update the return type when the context of the reference
1617 -- acts as the name of a function call. Note that the update
1618 -- should not be performed when the reference appears as an
1619 -- actual in the call.
1621 if Nkind
(Context
) = N_Function_Call
1622 and then Name
(Context
) = Ref
1624 Set_Etype
(Context
, Etype
(New_Id
));
1629 -- Reanalyze the reference due to potential replacements
1631 if Nkind
(Ref
) in N_Has_Etype
then
1632 Set_Analyzed
(Ref
, False);
1638 procedure Replace_Refs
is new Traverse_Proc
(Replace_Ref
);
1640 -- Start of processing for Replace_Object_And_Primitive_References
1643 -- Map each primitive operation of the parent type to the proper
1644 -- primitive of the derived type.
1646 Update_Primitives_Mapping_Of_Types
1647 (Par_Typ
=> Par_Typ
,
1648 Deriv_Typ
=> Deriv_Typ
);
1650 -- Inspect the input expression and perform substitutions where
1653 Replace_Refs
(Expr
);
1654 end Replace_Object_And_Primitive_References
;
1656 -----------------------------
1657 -- Replace_Type_References --
1658 -----------------------------
1660 procedure Replace_Type_References
1665 procedure Replace_Type_Ref
(N
: Node_Id
);
1666 -- Substitute a single reference of the current instance of type Typ
1667 -- with a reference to Obj_Id.
1669 ----------------------
1670 -- Replace_Type_Ref --
1671 ----------------------
1673 procedure Replace_Type_Ref
(N
: Node_Id
) is
1677 -- Decorate the reference to Typ even though it may be rewritten
1678 -- further down. This is done for two reasons:
1680 -- 1) ASIS has all necessary semantic information in the
1683 -- 2) Routines which examine properties of the Original_Node
1684 -- have some semantic information.
1686 if Nkind
(N
) = N_Identifier
then
1687 Set_Entity
(N
, Typ
);
1690 elsif Nkind
(N
) = N_Selected_Component
then
1691 Analyze
(Prefix
(N
));
1692 Set_Entity
(Selector_Name
(N
), Typ
);
1693 Set_Etype
(Selector_Name
(N
), Typ
);
1696 -- Perform the following substitution:
1700 Ref
:= Make_Identifier
(Sloc
(N
), Chars
(Obj_Id
));
1701 Set_Entity
(Ref
, Obj_Id
);
1702 Set_Etype
(Ref
, Typ
);
1706 Set_Comes_From_Source
(N
, True);
1707 end Replace_Type_Ref
;
1709 procedure Replace_Type_Refs
is
1710 new Replace_Type_References_Generic
(Replace_Type_Ref
);
1712 -- Start of processing for Replace_Type_References
1715 Replace_Type_Refs
(Expr
, Typ
);
1716 end Replace_Type_References
;
1720 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
1723 DIC_Typ
: Entity_Id
;
1724 Dummy_1
: Entity_Id
;
1725 Dummy_2
: Entity_Id
;
1726 Mode
: Ghost_Mode_Type
;
1727 Proc_Body
: Node_Id
;
1728 Proc_Body_Id
: Entity_Id
;
1729 Proc_Decl
: Node_Id
;
1730 Proc_Id
: Entity_Id
;
1731 Stmts
: List_Id
:= No_List
;
1733 Work_Typ
: Entity_Id
;
1736 -- Start of processing for Build_DIC_Procedure_Body
1739 Work_Typ
:= Base_Type
(Typ
);
1741 -- Do not process class-wide types as these are Itypes, but lack a first
1742 -- subtype (see below).
1744 if Is_Class_Wide_Type
(Work_Typ
) then
1747 -- Do not process the underlying full view of a private type. There is
1748 -- no way to get back to the partial view, plus the body will be built
1749 -- by the full view or the base type.
1751 elsif Is_Underlying_Full_View
(Work_Typ
) then
1754 -- Use the first subtype when dealing with various base types
1756 elsif Is_Itype
(Work_Typ
) then
1757 Work_Typ
:= First_Subtype
(Work_Typ
);
1759 -- The input denotes the corresponding record type of a protected or a
1760 -- task type. Work with the concurrent type because the corresponding
1761 -- record type may not be visible to clients of the type.
1763 elsif Ekind
(Work_Typ
) = E_Record_Type
1764 and then Is_Concurrent_Record_Type
(Work_Typ
)
1766 Work_Typ
:= Corresponding_Concurrent_Type
(Work_Typ
);
1769 -- The working type may be subject to pragma Ghost. Set the mode now to
1770 -- ensure that the DIC procedure is properly marked as Ghost.
1772 Set_Ghost_Mode
(Work_Typ
, Mode
);
1774 -- The working type must be either define a DIC pragma of its own or
1775 -- inherit one from a parent type.
1777 pragma Assert
(Has_DIC
(Work_Typ
));
1779 -- Recover the type which defines the DIC pragma. This is either the
1780 -- working type itself or a parent type when the pragma is inherited.
1782 DIC_Typ
:= Find_DIC_Type
(Work_Typ
);
1783 pragma Assert
(Present
(DIC_Typ
));
1785 DIC_Prag
:= Get_Pragma
(DIC_Typ
, Pragma_Default_Initial_Condition
);
1786 pragma Assert
(Present
(DIC_Prag
));
1788 -- Nothing to do if pragma DIC appears without an argument or its sole
1789 -- argument is "null".
1791 if not Is_Verifiable_DIC_Pragma
(DIC_Prag
) then
1795 -- The working type may lack a DIC procedure declaration. This may be
1796 -- due to several reasons:
1798 -- * The working type's own DIC pragma does not contain a verifiable
1799 -- assertion expression. In this case there is no need to build a
1800 -- DIC procedure because there is nothing to check.
1802 -- * The working type derives from a parent type. In this case a DIC
1803 -- procedure should be built only when the inherited DIC pragma has
1804 -- a verifiable assertion expression.
1806 Proc_Id
:= DIC_Procedure
(Work_Typ
);
1808 -- Build a DIC procedure declaration when the working type derives from
1811 if No
(Proc_Id
) then
1812 Build_DIC_Procedure_Declaration
(Work_Typ
);
1813 Proc_Id
:= DIC_Procedure
(Work_Typ
);
1816 -- At this point there should be a DIC procedure declaration
1818 pragma Assert
(Present
(Proc_Id
));
1819 Proc_Decl
:= Unit_Declaration_Node
(Proc_Id
);
1821 -- Nothing to do if the DIC procedure already has a body
1823 if Present
(Corresponding_Body
(Proc_Decl
)) then
1827 -- Emulate the environment of the DIC procedure by installing its scope
1828 -- and formal parameters.
1830 Push_Scope
(Proc_Id
);
1831 Install_Formals
(Proc_Id
);
1833 -- The working type defines its own DIC pragma. Replace the current
1834 -- instance of the working type with the formal of the DIC procedure.
1835 -- Note that there is no need to consider inherited DIC pragmas from
1836 -- parent types because the working type's DIC pragma "hides" all
1837 -- inherited DIC pragmas.
1839 if Has_Own_DIC
(Work_Typ
) then
1840 pragma Assert
(DIC_Typ
= Work_Typ
);
1843 (DIC_Prag
=> DIC_Prag
,
1847 -- Otherwise the working type inherits a DIC pragma from a parent type
1850 pragma Assert
(Has_Inherited_DIC
(Work_Typ
));
1851 pragma Assert
(DIC_Typ
/= Work_Typ
);
1853 -- The working type is tagged. The verification of the assertion
1854 -- expression is subject to the same semantics as class-wide pre-
1855 -- and postconditions.
1857 if Is_Tagged_Type
(Work_Typ
) then
1858 Add_Inherited_Tagged_DIC
1859 (DIC_Prag
=> DIC_Prag
,
1861 Deriv_Typ
=> Work_Typ
,
1864 -- Otherwise the working type is not tagged. Verify the assertion
1865 -- expression of the inherited DIC pragma by directly calling the
1866 -- DIC procedure of the parent type.
1870 (DIC_Prag
=> DIC_Prag
,
1872 Deriv_Typ
=> Work_Typ
,
1879 -- Produce an empty completing body in the following cases:
1880 -- * Assertions are disabled
1881 -- * The DIC Assertion_Policy is Ignore
1882 -- * Pragma DIC appears without an argument
1883 -- * Pragma DIC appears with argument "null"
1886 Stmts
:= New_List
(Make_Null_Statement
(Loc
));
1890 -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
1893 -- end <Work_Typ>DIC;
1896 Make_Subprogram_Body
(Loc
,
1898 Copy_Subprogram_Spec
(Parent
(Proc_Id
)),
1899 Declarations
=> Empty_List
,
1900 Handled_Statement_Sequence
=>
1901 Make_Handled_Sequence_Of_Statements
(Loc
,
1902 Statements
=> Stmts
));
1903 Proc_Body_Id
:= Defining_Entity
(Proc_Body
);
1905 -- Perform minor decoration in case the body is not analyzed
1907 Set_Ekind
(Proc_Body_Id
, E_Subprogram_Body
);
1908 Set_Etype
(Proc_Body_Id
, Standard_Void_Type
);
1909 Set_Scope
(Proc_Body_Id
, Current_Scope
);
1911 -- Link both spec and body to avoid generating duplicates
1913 Set_Corresponding_Body
(Proc_Decl
, Proc_Body_Id
);
1914 Set_Corresponding_Spec
(Proc_Body
, Proc_Id
);
1916 -- The body should not be inserted into the tree when the context is
1917 -- ASIS or a generic unit because it is not part of the template. Note
1918 -- that the body must still be generated in order to resolve the DIC
1919 -- assertion expression.
1921 if ASIS_Mode
or Inside_A_Generic
then
1924 -- Semi-insert the body into the tree for GNATprove by setting its
1925 -- Parent field. This allows for proper upstream tree traversals.
1927 elsif GNATprove_Mode
then
1928 Set_Parent
(Proc_Body
, Parent
(Declaration_Node
(Work_Typ
)));
1930 -- Otherwise the body is part of the freezing actions of the working
1934 Append_Freeze_Action
(Work_Typ
, Proc_Body
);
1938 Restore_Ghost_Mode
(Mode
);
1939 end Build_DIC_Procedure_Body
;
1941 -------------------------------------
1942 -- Build_DIC_Procedure_Declaration --
1943 -------------------------------------
1945 -- WARNING: This routine manages Ghost regions. Return statements must be
1946 -- replaced by gotos which jump to the end of the routine and restore the
1949 procedure Build_DIC_Procedure_Declaration
(Typ
: Entity_Id
) is
1950 Loc
: constant Source_Ptr
:= Sloc
(Typ
);
1953 DIC_Typ
: Entity_Id
;
1954 Mode
: Ghost_Mode_Type
;
1955 Proc_Decl
: Node_Id
;
1956 Proc_Id
: Entity_Id
;
1959 CRec_Typ
: Entity_Id
;
1960 -- The corresponding record type of Full_Typ
1962 Full_Base
: Entity_Id
;
1963 -- The base type of Full_Typ
1965 Full_Typ
: Entity_Id
;
1966 -- The full view of working type
1969 -- The _object formal parameter of the DIC procedure
1971 Priv_Typ
: Entity_Id
;
1972 -- The partial view of working type
1974 Work_Typ
: Entity_Id
;
1978 Work_Typ
:= Base_Type
(Typ
);
1980 -- Do not process class-wide types as these are Itypes, but lack a first
1981 -- subtype (see below).
1983 if Is_Class_Wide_Type
(Work_Typ
) then
1986 -- Do not process the underlying full view of a private type. There is
1987 -- no way to get back to the partial view, plus the body will be built
1988 -- by the full view or the base type.
1990 elsif Is_Underlying_Full_View
(Work_Typ
) then
1993 -- Use the first subtype when dealing with various base types
1995 elsif Is_Itype
(Work_Typ
) then
1996 Work_Typ
:= First_Subtype
(Work_Typ
);
1998 -- The input denotes the corresponding record type of a protected or a
1999 -- task type. Work with the concurrent type because the corresponding
2000 -- record type may not be visible to clients of the type.
2002 elsif Ekind
(Work_Typ
) = E_Record_Type
2003 and then Is_Concurrent_Record_Type
(Work_Typ
)
2005 Work_Typ
:= Corresponding_Concurrent_Type
(Work_Typ
);
2008 -- The working type may be subject to pragma Ghost. Set the mode now to
2009 -- ensure that the DIC procedure is properly marked as Ghost.
2011 Set_Ghost_Mode
(Work_Typ
, Mode
);
2013 -- The type must be either subject to a DIC pragma or inherit one from a
2016 pragma Assert
(Has_DIC
(Work_Typ
));
2018 -- Recover the type which defines the DIC pragma. This is either the
2019 -- working type itself or a parent type when the pragma is inherited.
2021 DIC_Typ
:= Find_DIC_Type
(Work_Typ
);
2022 pragma Assert
(Present
(DIC_Typ
));
2024 DIC_Prag
:= Get_Pragma
(DIC_Typ
, Pragma_Default_Initial_Condition
);
2025 pragma Assert
(Present
(DIC_Prag
));
2027 -- Nothing to do if pragma DIC appears without an argument or its sole
2028 -- argument is "null".
2030 if not Is_Verifiable_DIC_Pragma
(DIC_Prag
) then
2033 -- Nothing to do if the type already has a DIC procedure
2035 elsif Present
(DIC_Procedure
(Work_Typ
)) then
2040 Make_Defining_Identifier
(Loc
,
2042 New_External_Name
(Chars
(Work_Typ
), "Default_Initial_Condition"));
2044 -- Perform minor decoration in case the declaration is not analyzed
2046 Set_Ekind
(Proc_Id
, E_Procedure
);
2047 Set_Etype
(Proc_Id
, Standard_Void_Type
);
2048 Set_Scope
(Proc_Id
, Current_Scope
);
2050 Set_Is_DIC_Procedure
(Proc_Id
);
2051 Set_DIC_Procedure
(Work_Typ
, Proc_Id
);
2053 -- The DIC procedure requires debug info when the assertion expression
2054 -- is subject to Source Coverage Obligations.
2056 if Opt
.Generate_SCO
then
2057 Set_Needs_Debug_Info
(Proc_Id
);
2060 -- Obtain all views of the input type
2062 Get_Views
(Work_Typ
, Priv_Typ
, Full_Typ
, Full_Base
, CRec_Typ
);
2064 -- Associate the DIC procedure and various relevant flags with all views
2066 Propagate_DIC_Attributes
(Priv_Typ
, From_Typ
=> Work_Typ
);
2067 Propagate_DIC_Attributes
(Full_Typ
, From_Typ
=> Work_Typ
);
2068 Propagate_DIC_Attributes
(Full_Base
, From_Typ
=> Work_Typ
);
2069 Propagate_DIC_Attributes
(CRec_Typ
, From_Typ
=> Work_Typ
);
2071 -- The declaration of the DIC procedure must be inserted after the
2072 -- declaration of the partial view as this allows for proper external
2075 if Present
(Priv_Typ
) then
2076 Typ_Decl
:= Declaration_Node
(Priv_Typ
);
2078 -- Derived types with the full view as parent do not have a partial
2079 -- view. Insert the DIC procedure after the derived type.
2082 Typ_Decl
:= Declaration_Node
(Full_Typ
);
2085 -- The type should have a declarative node
2087 pragma Assert
(Present
(Typ_Decl
));
2089 -- Create the formal parameter which emulates the variable-like behavior
2090 -- of the type's current instance.
2092 Obj_Id
:= Make_Defining_Identifier
(Loc
, Chars
=> Name_uObject
);
2094 -- Perform minor decoration in case the declaration is not analyzed
2096 Set_Ekind
(Obj_Id
, E_In_Parameter
);
2097 Set_Etype
(Obj_Id
, Work_Typ
);
2098 Set_Scope
(Obj_Id
, Proc_Id
);
2100 Set_First_Entity
(Proc_Id
, Obj_Id
);
2103 -- procedure <Work_Typ>DIC (_object : <Work_Typ>);
2106 Make_Subprogram_Declaration
(Loc
,
2108 Make_Procedure_Specification
(Loc
,
2109 Defining_Unit_Name
=> Proc_Id
,
2110 Parameter_Specifications
=> New_List
(
2111 Make_Parameter_Specification
(Loc
,
2112 Defining_Identifier
=> Obj_Id
,
2114 New_Occurrence_Of
(Work_Typ
, Loc
)))));
2116 -- The declaration should not be inserted into the tree when the context
2117 -- is ASIS or a generic unit because it is not part of the template.
2119 if ASIS_Mode
or Inside_A_Generic
then
2122 -- Semi-insert the declaration into the tree for GNATprove by setting
2123 -- its Parent field. This allows for proper upstream tree traversals.
2125 elsif GNATprove_Mode
then
2126 Set_Parent
(Proc_Decl
, Parent
(Typ_Decl
));
2128 -- Otherwise insert the declaration
2131 Insert_After_And_Analyze
(Typ_Decl
, Proc_Decl
);
2135 Restore_Ghost_Mode
(Mode
);
2136 end Build_DIC_Procedure_Declaration
;
2138 --------------------------
2139 -- Build_Procedure_Form --
2140 --------------------------
2142 procedure Build_Procedure_Form
(N
: Node_Id
) is
2143 Loc
: constant Source_Ptr
:= Sloc
(N
);
2144 Subp
: constant Entity_Id
:= Defining_Entity
(N
);
2146 Func_Formal
: Entity_Id
;
2147 Proc_Formals
: List_Id
;
2148 Proc_Decl
: Node_Id
;
2151 -- No action needed if this transformation was already done, or in case
2152 -- of subprogram renaming declarations.
2154 if Nkind
(Specification
(N
)) = N_Procedure_Specification
2155 or else Nkind
(N
) = N_Subprogram_Renaming_Declaration
2160 -- Ditto when dealing with an expression function, where both the
2161 -- original expression and the generated declaration end up being
2164 if Rewritten_For_C
(Subp
) then
2168 Proc_Formals
:= New_List
;
2170 -- Create a list of formal parameters with the same types as the
2173 Func_Formal
:= First_Formal
(Subp
);
2174 while Present
(Func_Formal
) loop
2175 Append_To
(Proc_Formals
,
2176 Make_Parameter_Specification
(Loc
,
2177 Defining_Identifier
=>
2178 Make_Defining_Identifier
(Loc
, Chars
(Func_Formal
)),
2180 New_Occurrence_Of
(Etype
(Func_Formal
), Loc
)));
2182 Next_Formal
(Func_Formal
);
2185 -- Add an extra out parameter to carry the function result
2188 Name_Buffer
(1 .. Name_Len
) := "RESULT";
2189 Append_To
(Proc_Formals
,
2190 Make_Parameter_Specification
(Loc
,
2191 Defining_Identifier
=>
2192 Make_Defining_Identifier
(Loc
, Chars
=> Name_Find
),
2193 Out_Present
=> True,
2194 Parameter_Type
=> New_Occurrence_Of
(Etype
(Subp
), Loc
)));
2196 -- The new procedure declaration is inserted immediately after the
2197 -- function declaration. The processing in Build_Procedure_Body_Form
2198 -- relies on this order.
2201 Make_Subprogram_Declaration
(Loc
,
2203 Make_Procedure_Specification
(Loc
,
2204 Defining_Unit_Name
=>
2205 Make_Defining_Identifier
(Loc
, Chars
(Subp
)),
2206 Parameter_Specifications
=> Proc_Formals
));
2208 Insert_After_And_Analyze
(Unit_Declaration_Node
(Subp
), Proc_Decl
);
2210 -- Entity of procedure must remain invisible so that it does not
2211 -- overload subsequent references to the original function.
2213 Set_Is_Immediately_Visible
(Defining_Entity
(Proc_Decl
), False);
2215 -- Mark the function as having a procedure form and link the function
2216 -- and its internally built procedure.
2218 Set_Rewritten_For_C
(Subp
);
2219 Set_Corresponding_Procedure
(Subp
, Defining_Entity
(Proc_Decl
));
2220 Set_Corresponding_Function
(Defining_Entity
(Proc_Decl
), Subp
);
2221 end Build_Procedure_Form
;
2223 ------------------------
2224 -- Build_Runtime_Call --
2225 ------------------------
2227 function Build_Runtime_Call
(Loc
: Source_Ptr
; RE
: RE_Id
) return Node_Id
is
2229 -- If entity is not available, we can skip making the call (this avoids
2230 -- junk duplicated error messages in a number of cases).
2232 if not RTE_Available
(RE
) then
2233 return Make_Null_Statement
(Loc
);
2236 Make_Procedure_Call_Statement
(Loc
,
2237 Name
=> New_Occurrence_Of
(RTE
(RE
), Loc
));
2239 end Build_Runtime_Call
;
2241 ------------------------
2242 -- Build_SS_Mark_Call --
2243 ------------------------
2245 function Build_SS_Mark_Call
2247 Mark
: Entity_Id
) return Node_Id
2251 -- Mark : constant Mark_Id := SS_Mark;
2254 Make_Object_Declaration
(Loc
,
2255 Defining_Identifier
=> Mark
,
2256 Constant_Present
=> True,
2257 Object_Definition
=>
2258 New_Occurrence_Of
(RTE
(RE_Mark_Id
), Loc
),
2260 Make_Function_Call
(Loc
,
2261 Name
=> New_Occurrence_Of
(RTE
(RE_SS_Mark
), Loc
)));
2262 end Build_SS_Mark_Call
;
2264 ---------------------------
2265 -- Build_SS_Release_Call --
2266 ---------------------------
2268 function Build_SS_Release_Call
2270 Mark
: Entity_Id
) return Node_Id
2274 -- SS_Release (Mark);
2277 Make_Procedure_Call_Statement
(Loc
,
2279 New_Occurrence_Of
(RTE
(RE_SS_Release
), Loc
),
2280 Parameter_Associations
=> New_List
(
2281 New_Occurrence_Of
(Mark
, Loc
)));
2282 end Build_SS_Release_Call
;
2284 ----------------------------
2285 -- Build_Task_Array_Image --
2286 ----------------------------
2288 -- This function generates the body for a function that constructs the
2289 -- image string for a task that is an array component. The function is
2290 -- local to the init proc for the array type, and is called for each one
2291 -- of the components. The constructed image has the form of an indexed
2292 -- component, whose prefix is the outer variable of the array type.
2293 -- The n-dimensional array type has known indexes Index, Index2...
2295 -- Id_Ref is an indexed component form created by the enclosing init proc.
2296 -- Its successive indexes are Val1, Val2, ... which are the loop variables
2297 -- in the loops that call the individual task init proc on each component.
2299 -- The generated function has the following structure:
2301 -- function F return String is
2302 -- Pref : string renames Task_Name;
2303 -- T1 : String := Index1'Image (Val1);
2305 -- Tn : String := indexn'image (Valn);
2306 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
2307 -- -- Len includes commas and the end parentheses.
2308 -- Res : String (1..Len);
2309 -- Pos : Integer := Pref'Length;
2312 -- Res (1 .. Pos) := Pref;
2314 -- Res (Pos) := '(';
2316 -- Res (Pos .. Pos + T1'Length - 1) := T1;
2317 -- Pos := Pos + T1'Length;
2318 -- Res (Pos) := '.';
2321 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
2322 -- Res (Len) := ')';
2327 -- Needless to say, multidimensional arrays of tasks are rare enough that
2328 -- the bulkiness of this code is not really a concern.
2330 function Build_Task_Array_Image
2334 Dyn
: Boolean := False) return Node_Id
2336 Dims
: constant Nat
:= Number_Dimensions
(A_Type
);
2337 -- Number of dimensions for array of tasks
2339 Temps
: array (1 .. Dims
) of Entity_Id
;
2340 -- Array of temporaries to hold string for each index
2346 -- Total length of generated name
2349 -- Running index for substring assignments
2351 Pref
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
2352 -- Name of enclosing variable, prefix of resulting name
2355 -- String to hold result
2358 -- Value of successive indexes
2361 -- Expression to compute total size of string
2364 -- Entity for name at one index position
2366 Decls
: constant List_Id
:= New_List
;
2367 Stats
: constant List_Id
:= New_List
;
2370 -- For a dynamic task, the name comes from the target variable. For a
2371 -- static one it is a formal of the enclosing init proc.
2374 Get_Name_String
(Chars
(Entity
(Prefix
(Id_Ref
))));
2376 Make_Object_Declaration
(Loc
,
2377 Defining_Identifier
=> Pref
,
2378 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
2380 Make_String_Literal
(Loc
,
2381 Strval
=> String_From_Name_Buffer
)));
2385 Make_Object_Renaming_Declaration
(Loc
,
2386 Defining_Identifier
=> Pref
,
2387 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
2388 Name
=> Make_Identifier
(Loc
, Name_uTask_Name
)));
2391 Indx
:= First_Index
(A_Type
);
2392 Val
:= First
(Expressions
(Id_Ref
));
2394 for J
in 1 .. Dims
loop
2395 T
:= Make_Temporary
(Loc
, 'T');
2399 Make_Object_Declaration
(Loc
,
2400 Defining_Identifier
=> T
,
2401 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
2403 Make_Attribute_Reference
(Loc
,
2404 Attribute_Name
=> Name_Image
,
2405 Prefix
=> New_Occurrence_Of
(Etype
(Indx
), Loc
),
2406 Expressions
=> New_List
(New_Copy_Tree
(Val
)))));
2412 Sum
:= Make_Integer_Literal
(Loc
, Dims
+ 1);
2418 Make_Attribute_Reference
(Loc
,
2419 Attribute_Name
=> Name_Length
,
2420 Prefix
=> New_Occurrence_Of
(Pref
, Loc
),
2421 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1))));
2423 for J
in 1 .. Dims
loop
2428 Make_Attribute_Reference
(Loc
,
2429 Attribute_Name
=> Name_Length
,
2431 New_Occurrence_Of
(Temps
(J
), Loc
),
2432 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1))));
2435 Build_Task_Image_Prefix
(Loc
, Len
, Res
, Pos
, Pref
, Sum
, Decls
, Stats
);
2437 Set_Character_Literal_Name
(Char_Code
(Character'Pos ('(')));
2440 Make_Assignment_Statement
(Loc
,
2442 Make_Indexed_Component
(Loc
,
2443 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
2444 Expressions
=> New_List
(New_Occurrence_Of
(Pos
, Loc
))),
2446 Make_Character_Literal
(Loc
,
2448 Char_Literal_Value
=> UI_From_Int
(Character'Pos ('(')))));
2451 Make_Assignment_Statement
(Loc
,
2452 Name
=> New_Occurrence_Of
(Pos
, Loc
),
2455 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
2456 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
2458 for J
in 1 .. Dims
loop
2461 Make_Assignment_Statement
(Loc
,
2464 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
2467 Low_Bound
=> New_Occurrence_Of
(Pos
, Loc
),
2469 Make_Op_Subtract
(Loc
,
2472 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
2474 Make_Attribute_Reference
(Loc
,
2475 Attribute_Name
=> Name_Length
,
2477 New_Occurrence_Of
(Temps
(J
), Loc
),
2479 New_List
(Make_Integer_Literal
(Loc
, 1)))),
2480 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
2482 Expression
=> New_Occurrence_Of
(Temps
(J
), Loc
)));
2486 Make_Assignment_Statement
(Loc
,
2487 Name
=> New_Occurrence_Of
(Pos
, Loc
),
2490 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
2492 Make_Attribute_Reference
(Loc
,
2493 Attribute_Name
=> Name_Length
,
2494 Prefix
=> New_Occurrence_Of
(Temps
(J
), Loc
),
2496 New_List
(Make_Integer_Literal
(Loc
, 1))))));
2498 Set_Character_Literal_Name
(Char_Code
(Character'Pos (',')));
2501 Make_Assignment_Statement
(Loc
,
2502 Name
=> Make_Indexed_Component
(Loc
,
2503 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
2504 Expressions
=> New_List
(New_Occurrence_Of
(Pos
, Loc
))),
2506 Make_Character_Literal
(Loc
,
2508 Char_Literal_Value
=> UI_From_Int
(Character'Pos (',')))));
2511 Make_Assignment_Statement
(Loc
,
2512 Name
=> New_Occurrence_Of
(Pos
, Loc
),
2515 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
2516 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
2520 Set_Character_Literal_Name
(Char_Code
(Character'Pos (')')));
2523 Make_Assignment_Statement
(Loc
,
2525 Make_Indexed_Component
(Loc
,
2526 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
2527 Expressions
=> New_List
(New_Occurrence_Of
(Len
, Loc
))),
2529 Make_Character_Literal
(Loc
,
2531 Char_Literal_Value
=> UI_From_Int
(Character'Pos (')')))));
2532 return Build_Task_Image_Function
(Loc
, Decls
, Stats
, Res
);
2533 end Build_Task_Array_Image
;
2535 ----------------------------
2536 -- Build_Task_Image_Decls --
2537 ----------------------------
2539 function Build_Task_Image_Decls
2543 In_Init_Proc
: Boolean := False) return List_Id
2545 Decls
: constant List_Id
:= New_List
;
2546 T_Id
: Entity_Id
:= Empty
;
2548 Expr
: Node_Id
:= Empty
;
2549 Fun
: Node_Id
:= Empty
;
2550 Is_Dyn
: constant Boolean :=
2551 Nkind
(Parent
(Id_Ref
)) = N_Assignment_Statement
2553 Nkind
(Expression
(Parent
(Id_Ref
))) = N_Allocator
;
2556 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
2557 -- generate a dummy declaration only.
2559 if Restriction_Active
(No_Implicit_Heap_Allocations
)
2560 or else Global_Discard_Names
2562 T_Id
:= Make_Temporary
(Loc
, 'J');
2567 Make_Object_Declaration
(Loc
,
2568 Defining_Identifier
=> T_Id
,
2569 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
2571 Make_String_Literal
(Loc
,
2572 Strval
=> String_From_Name_Buffer
)));
2575 if Nkind
(Id_Ref
) = N_Identifier
2576 or else Nkind
(Id_Ref
) = N_Defining_Identifier
2578 -- For a simple variable, the image of the task is built from
2579 -- the name of the variable. To avoid possible conflict with the
2580 -- anonymous type created for a single protected object, add a
2584 Make_Defining_Identifier
(Loc
,
2585 New_External_Name
(Chars
(Id_Ref
), 'T', 1));
2587 Get_Name_String
(Chars
(Id_Ref
));
2590 Make_String_Literal
(Loc
,
2591 Strval
=> String_From_Name_Buffer
);
2593 elsif Nkind
(Id_Ref
) = N_Selected_Component
then
2595 Make_Defining_Identifier
(Loc
,
2596 New_External_Name
(Chars
(Selector_Name
(Id_Ref
)), 'T'));
2597 Fun
:= Build_Task_Record_Image
(Loc
, Id_Ref
, Is_Dyn
);
2599 elsif Nkind
(Id_Ref
) = N_Indexed_Component
then
2601 Make_Defining_Identifier
(Loc
,
2602 New_External_Name
(Chars
(A_Type
), 'N'));
2604 Fun
:= Build_Task_Array_Image
(Loc
, Id_Ref
, A_Type
, Is_Dyn
);
2608 if Present
(Fun
) then
2609 Append
(Fun
, Decls
);
2610 Expr
:= Make_Function_Call
(Loc
,
2611 Name
=> New_Occurrence_Of
(Defining_Entity
(Fun
), Loc
));
2613 if not In_Init_Proc
then
2614 Set_Uses_Sec_Stack
(Defining_Entity
(Fun
));
2618 Decl
:= Make_Object_Declaration
(Loc
,
2619 Defining_Identifier
=> T_Id
,
2620 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
2621 Constant_Present
=> True,
2622 Expression
=> Expr
);
2624 Append
(Decl
, Decls
);
2626 end Build_Task_Image_Decls
;
2628 -------------------------------
2629 -- Build_Task_Image_Function --
2630 -------------------------------
2632 function Build_Task_Image_Function
2636 Res
: Entity_Id
) return Node_Id
2642 Make_Simple_Return_Statement
(Loc
,
2643 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
2645 Spec
:= Make_Function_Specification
(Loc
,
2646 Defining_Unit_Name
=> Make_Temporary
(Loc
, 'F'),
2647 Result_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
));
2649 -- Calls to 'Image use the secondary stack, which must be cleaned up
2650 -- after the task name is built.
2652 return Make_Subprogram_Body
(Loc
,
2653 Specification
=> Spec
,
2654 Declarations
=> Decls
,
2655 Handled_Statement_Sequence
=>
2656 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stats
));
2657 end Build_Task_Image_Function
;
2659 -----------------------------
2660 -- Build_Task_Image_Prefix --
2661 -----------------------------
2663 procedure Build_Task_Image_Prefix
2665 Len
: out Entity_Id
;
2666 Res
: out Entity_Id
;
2667 Pos
: out Entity_Id
;
2674 Len
:= Make_Temporary
(Loc
, 'L', Sum
);
2677 Make_Object_Declaration
(Loc
,
2678 Defining_Identifier
=> Len
,
2679 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
2680 Expression
=> Sum
));
2682 Res
:= Make_Temporary
(Loc
, 'R');
2685 Make_Object_Declaration
(Loc
,
2686 Defining_Identifier
=> Res
,
2687 Object_Definition
=>
2688 Make_Subtype_Indication
(Loc
,
2689 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
2691 Make_Index_Or_Discriminant_Constraint
(Loc
,
2695 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
2696 High_Bound
=> New_Occurrence_Of
(Len
, Loc
)))))));
2698 -- Indicate that the result is an internal temporary, so it does not
2699 -- receive a bogus initialization when declaration is expanded. This
2700 -- is both efficient, and prevents anomalies in the handling of
2701 -- dynamic objects on the secondary stack.
2703 Set_Is_Internal
(Res
);
2704 Pos
:= Make_Temporary
(Loc
, 'P');
2707 Make_Object_Declaration
(Loc
,
2708 Defining_Identifier
=> Pos
,
2709 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
)));
2711 -- Pos := Prefix'Length;
2714 Make_Assignment_Statement
(Loc
,
2715 Name
=> New_Occurrence_Of
(Pos
, Loc
),
2717 Make_Attribute_Reference
(Loc
,
2718 Attribute_Name
=> Name_Length
,
2719 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
2720 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1)))));
2722 -- Res (1 .. Pos) := Prefix;
2725 Make_Assignment_Statement
(Loc
,
2728 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
2731 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
2732 High_Bound
=> New_Occurrence_Of
(Pos
, Loc
))),
2734 Expression
=> New_Occurrence_Of
(Prefix
, Loc
)));
2737 Make_Assignment_Statement
(Loc
,
2738 Name
=> New_Occurrence_Of
(Pos
, Loc
),
2741 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
2742 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
2743 end Build_Task_Image_Prefix
;
2745 -----------------------------
2746 -- Build_Task_Record_Image --
2747 -----------------------------
2749 function Build_Task_Record_Image
2752 Dyn
: Boolean := False) return Node_Id
2755 -- Total length of generated name
2758 -- Index into result
2761 -- String to hold result
2763 Pref
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
2764 -- Name of enclosing variable, prefix of resulting name
2767 -- Expression to compute total size of string
2770 -- Entity for selector name
2772 Decls
: constant List_Id
:= New_List
;
2773 Stats
: constant List_Id
:= New_List
;
2776 -- For a dynamic task, the name comes from the target variable. For a
2777 -- static one it is a formal of the enclosing init proc.
2780 Get_Name_String
(Chars
(Entity
(Prefix
(Id_Ref
))));
2782 Make_Object_Declaration
(Loc
,
2783 Defining_Identifier
=> Pref
,
2784 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
2786 Make_String_Literal
(Loc
,
2787 Strval
=> String_From_Name_Buffer
)));
2791 Make_Object_Renaming_Declaration
(Loc
,
2792 Defining_Identifier
=> Pref
,
2793 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
2794 Name
=> Make_Identifier
(Loc
, Name_uTask_Name
)));
2797 Sel
:= Make_Temporary
(Loc
, 'S');
2799 Get_Name_String
(Chars
(Selector_Name
(Id_Ref
)));
2802 Make_Object_Declaration
(Loc
,
2803 Defining_Identifier
=> Sel
,
2804 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
2806 Make_String_Literal
(Loc
,
2807 Strval
=> String_From_Name_Buffer
)));
2809 Sum
:= Make_Integer_Literal
(Loc
, Nat
(Name_Len
+ 1));
2815 Make_Attribute_Reference
(Loc
,
2816 Attribute_Name
=> Name_Length
,
2818 New_Occurrence_Of
(Pref
, Loc
),
2819 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1))));
2821 Build_Task_Image_Prefix
(Loc
, Len
, Res
, Pos
, Pref
, Sum
, Decls
, Stats
);
2823 Set_Character_Literal_Name
(Char_Code
(Character'Pos ('.')));
2825 -- Res (Pos) := '.';
2828 Make_Assignment_Statement
(Loc
,
2829 Name
=> Make_Indexed_Component
(Loc
,
2830 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
2831 Expressions
=> New_List
(New_Occurrence_Of
(Pos
, Loc
))),
2833 Make_Character_Literal
(Loc
,
2835 Char_Literal_Value
=>
2836 UI_From_Int
(Character'Pos ('.')))));
2839 Make_Assignment_Statement
(Loc
,
2840 Name
=> New_Occurrence_Of
(Pos
, Loc
),
2843 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
2844 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
2846 -- Res (Pos .. Len) := Selector;
2849 Make_Assignment_Statement
(Loc
,
2850 Name
=> Make_Slice
(Loc
,
2851 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
2854 Low_Bound
=> New_Occurrence_Of
(Pos
, Loc
),
2855 High_Bound
=> New_Occurrence_Of
(Len
, Loc
))),
2856 Expression
=> New_Occurrence_Of
(Sel
, Loc
)));
2858 return Build_Task_Image_Function
(Loc
, Decls
, Stats
, Res
);
2859 end Build_Task_Record_Image
;
2861 ---------------------------------------
2862 -- Build_Transient_Object_Statements --
2863 ---------------------------------------
2865 procedure Build_Transient_Object_Statements
2866 (Obj_Decl
: Node_Id
;
2867 Fin_Call
: out Node_Id
;
2868 Hook_Assign
: out Node_Id
;
2869 Hook_Clear
: out Node_Id
;
2870 Hook_Decl
: out Node_Id
;
2871 Ptr_Decl
: out Node_Id
;
2872 Finalize_Obj
: Boolean := True)
2874 Loc
: constant Source_Ptr
:= Sloc
(Obj_Decl
);
2875 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2876 Obj_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Obj_Id
));
2878 Desig_Typ
: Entity_Id
;
2879 Hook_Expr
: Node_Id
;
2880 Hook_Id
: Entity_Id
;
2882 Ptr_Typ
: Entity_Id
;
2885 -- Recover the type of the object
2887 Desig_Typ
:= Obj_Typ
;
2889 if Is_Access_Type
(Desig_Typ
) then
2890 Desig_Typ
:= Available_View
(Designated_Type
(Desig_Typ
));
2893 -- Create an access type which provides a reference to the transient
2894 -- object. Generate:
2896 -- type Ptr_Typ is access all Desig_Typ;
2898 Ptr_Typ
:= Make_Temporary
(Loc
, 'A');
2899 Set_Ekind
(Ptr_Typ
, E_General_Access_Type
);
2900 Set_Directly_Designated_Type
(Ptr_Typ
, Desig_Typ
);
2903 Make_Full_Type_Declaration
(Loc
,
2904 Defining_Identifier
=> Ptr_Typ
,
2906 Make_Access_To_Object_Definition
(Loc
,
2907 All_Present
=> True,
2908 Subtype_Indication
=> New_Occurrence_Of
(Desig_Typ
, Loc
)));
2910 -- Create a temporary check which acts as a hook to the transient
2911 -- object. Generate:
2913 -- Hook : Ptr_Typ := null;
2915 Hook_Id
:= Make_Temporary
(Loc
, 'T');
2916 Set_Ekind
(Hook_Id
, E_Variable
);
2917 Set_Etype
(Hook_Id
, Ptr_Typ
);
2920 Make_Object_Declaration
(Loc
,
2921 Defining_Identifier
=> Hook_Id
,
2922 Object_Definition
=> New_Occurrence_Of
(Ptr_Typ
, Loc
),
2923 Expression
=> Make_Null
(Loc
));
2925 -- Mark the temporary as a hook. This signals the machinery in
2926 -- Build_Finalizer to recognize this special case.
2928 Set_Status_Flag_Or_Transient_Decl
(Hook_Id
, Obj_Decl
);
2930 -- Hook the transient object to the temporary. Generate:
2932 -- Hook := Ptr_Typ (Obj_Id);
2934 -- Hool := Obj_Id'Unrestricted_Access;
2936 if Is_Access_Type
(Obj_Typ
) then
2938 Unchecked_Convert_To
(Ptr_Typ
, New_Occurrence_Of
(Obj_Id
, Loc
));
2941 Make_Attribute_Reference
(Loc
,
2942 Prefix
=> New_Occurrence_Of
(Obj_Id
, Loc
),
2943 Attribute_Name
=> Name_Unrestricted_Access
);
2947 Make_Assignment_Statement
(Loc
,
2948 Name
=> New_Occurrence_Of
(Hook_Id
, Loc
),
2949 Expression
=> Hook_Expr
);
2951 -- Crear the hook prior to finalizing the object. Generate:
2956 Make_Assignment_Statement
(Loc
,
2957 Name
=> New_Occurrence_Of
(Hook_Id
, Loc
),
2958 Expression
=> Make_Null
(Loc
));
2960 -- Finalize the object. Generate:
2962 -- [Deep_]Finalize (Obj_Ref[.all]);
2964 if Finalize_Obj
then
2965 Obj_Ref
:= New_Occurrence_Of
(Obj_Id
, Loc
);
2967 if Is_Access_Type
(Obj_Typ
) then
2968 Obj_Ref
:= Make_Explicit_Dereference
(Loc
, Obj_Ref
);
2969 Set_Etype
(Obj_Ref
, Desig_Typ
);
2974 (Obj_Ref
=> Obj_Ref
,
2977 -- Otherwise finalize the hook. Generate:
2979 -- [Deep_]Finalize (Hook.all);
2985 Make_Explicit_Dereference
(Loc
,
2986 Prefix
=> New_Occurrence_Of
(Hook_Id
, Loc
)),
2989 end Build_Transient_Object_Statements
;
2991 -----------------------------
2992 -- Check_Float_Op_Overflow --
2993 -----------------------------
2995 procedure Check_Float_Op_Overflow
(N
: Node_Id
) is
2997 -- Return if no check needed
2999 if not Is_Floating_Point_Type
(Etype
(N
))
3000 or else not (Do_Overflow_Check
(N
) and then Check_Float_Overflow
)
3002 -- In CodePeer_Mode, rely on the overflow check flag being set instead
3003 -- and do not expand the code for float overflow checking.
3005 or else CodePeer_Mode
3010 -- Otherwise we replace the expression by
3012 -- do Tnn : constant ftype := expression;
3013 -- constraint_error when not Tnn'Valid;
3017 Loc
: constant Source_Ptr
:= Sloc
(N
);
3018 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
3019 Typ
: constant Entity_Id
:= Etype
(N
);
3022 -- Turn off the Do_Overflow_Check flag, since we are doing that work
3023 -- right here. We also set the node as analyzed to prevent infinite
3024 -- recursion from repeating the operation in the expansion.
3026 Set_Do_Overflow_Check
(N
, False);
3027 Set_Analyzed
(N
, True);
3029 -- Do the rewrite to include the check
3032 Make_Expression_With_Actions
(Loc
,
3033 Actions
=> New_List
(
3034 Make_Object_Declaration
(Loc
,
3035 Defining_Identifier
=> Tnn
,
3036 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
3037 Constant_Present
=> True,
3038 Expression
=> Relocate_Node
(N
)),
3039 Make_Raise_Constraint_Error
(Loc
,
3043 Make_Attribute_Reference
(Loc
,
3044 Prefix
=> New_Occurrence_Of
(Tnn
, Loc
),
3045 Attribute_Name
=> Name_Valid
)),
3046 Reason
=> CE_Overflow_Check_Failed
)),
3047 Expression
=> New_Occurrence_Of
(Tnn
, Loc
)));
3049 Analyze_And_Resolve
(N
, Typ
);
3051 end Check_Float_Op_Overflow
;
3053 ----------------------------------
3054 -- Component_May_Be_Bit_Aligned --
3055 ----------------------------------
3057 function Component_May_Be_Bit_Aligned
(Comp
: Entity_Id
) return Boolean is
3061 -- If no component clause, then everything is fine, since the back end
3062 -- never bit-misaligns by default, even if there is a pragma Packed for
3065 if No
(Comp
) or else No
(Component_Clause
(Comp
)) then
3069 UT
:= Underlying_Type
(Etype
(Comp
));
3071 -- It is only array and record types that cause trouble
3073 if not Is_Record_Type
(UT
) and then not Is_Array_Type
(UT
) then
3076 -- If we know that we have a small (64 bits or less) record or small
3077 -- bit-packed array, then everything is fine, since the back end can
3078 -- handle these cases correctly.
3080 elsif Esize
(Comp
) <= 64
3081 and then (Is_Record_Type
(UT
) or else Is_Bit_Packed_Array
(UT
))
3085 -- Otherwise if the component is not byte aligned, we know we have the
3086 -- nasty unaligned case.
3088 elsif Normalized_First_Bit
(Comp
) /= Uint_0
3089 or else Esize
(Comp
) mod System_Storage_Unit
/= Uint_0
3093 -- If we are large and byte aligned, then OK at this level
3098 end Component_May_Be_Bit_Aligned
;
3100 ----------------------------------------
3101 -- Containing_Package_With_Ext_Axioms --
3102 ----------------------------------------
3104 function Containing_Package_With_Ext_Axioms
3105 (E
: Entity_Id
) return Entity_Id
3108 -- E is the package or generic package which is externally axiomatized
3110 if Ekind_In
(E
, E_Generic_Package
, E_Package
)
3111 and then Has_Annotate_Pragma_For_External_Axiomatization
(E
)
3116 -- If E's scope is axiomatized, E is axiomatized
3118 if Present
(Scope
(E
)) then
3120 First_Ax_Parent_Scope
: constant Entity_Id
:=
3121 Containing_Package_With_Ext_Axioms
(Scope
(E
));
3123 if Present
(First_Ax_Parent_Scope
) then
3124 return First_Ax_Parent_Scope
;
3129 -- Otherwise, if E is a package instance, it is axiomatized if the
3130 -- corresponding generic package is axiomatized.
3132 if Ekind
(E
) = E_Package
then
3134 Par
: constant Node_Id
:= Parent
(E
);
3138 if Nkind
(Par
) = N_Defining_Program_Unit_Name
then
3139 Decl
:= Parent
(Par
);
3144 if Present
(Generic_Parent
(Decl
)) then
3146 Containing_Package_With_Ext_Axioms
(Generic_Parent
(Decl
));
3152 end Containing_Package_With_Ext_Axioms
;
3154 -------------------------------
3155 -- Convert_To_Actual_Subtype --
3156 -------------------------------
3158 procedure Convert_To_Actual_Subtype
(Exp
: Entity_Id
) is
3162 Act_ST
:= Get_Actual_Subtype
(Exp
);
3164 if Act_ST
= Etype
(Exp
) then
3167 Rewrite
(Exp
, Convert_To
(Act_ST
, Relocate_Node
(Exp
)));
3168 Analyze_And_Resolve
(Exp
, Act_ST
);
3170 end Convert_To_Actual_Subtype
;
3172 -----------------------------------
3173 -- Corresponding_Runtime_Package --
3174 -----------------------------------
3176 function Corresponding_Runtime_Package
(Typ
: Entity_Id
) return RTU_Id
is
3177 function Has_One_Entry_And_No_Queue
(T
: Entity_Id
) return Boolean;
3178 -- Return True if protected type T has one entry and the maximum queue
3181 --------------------------------
3182 -- Has_One_Entry_And_No_Queue --
3183 --------------------------------
3185 function Has_One_Entry_And_No_Queue
(T
: Entity_Id
) return Boolean is
3187 Is_First
: Boolean := True;
3190 Item
:= First_Entity
(T
);
3191 while Present
(Item
) loop
3192 if Is_Entry
(Item
) then
3194 -- The protected type has more than one entry
3196 if not Is_First
then
3200 -- The queue length is not one
3202 if not Restriction_Active
(No_Entry_Queue
)
3203 and then Get_Max_Queue_Length
(Item
) /= Uint_1
3215 end Has_One_Entry_And_No_Queue
;
3219 Pkg_Id
: RTU_Id
:= RTU_Null
;
3221 -- Start of processing for Corresponding_Runtime_Package
3224 pragma Assert
(Is_Concurrent_Type
(Typ
));
3226 if Ekind
(Typ
) in Protected_Kind
then
3227 if Has_Entries
(Typ
)
3229 -- A protected type without entries that covers an interface and
3230 -- overrides the abstract routines with protected procedures is
3231 -- considered equivalent to a protected type with entries in the
3232 -- context of dispatching select statements. It is sufficient to
3233 -- check for the presence of an interface list in the declaration
3234 -- node to recognize this case.
3236 or else Present
(Interface_List
(Parent
(Typ
)))
3238 -- Protected types with interrupt handlers (when not using a
3239 -- restricted profile) are also considered equivalent to
3240 -- protected types with entries. The types which are used
3241 -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection)
3242 -- are derived from Protection_Entries.
3244 or else (Has_Attach_Handler
(Typ
) and then not Restricted_Profile
)
3245 or else Has_Interrupt_Handler
(Typ
)
3248 or else Restriction_Active
(No_Select_Statements
) = False
3249 or else not Has_One_Entry_And_No_Queue
(Typ
)
3250 or else (Has_Attach_Handler
(Typ
)
3251 and then not Restricted_Profile
)
3253 Pkg_Id
:= System_Tasking_Protected_Objects_Entries
;
3255 Pkg_Id
:= System_Tasking_Protected_Objects_Single_Entry
;
3259 Pkg_Id
:= System_Tasking_Protected_Objects
;
3264 end Corresponding_Runtime_Package
;
3266 -----------------------------------
3267 -- Current_Sem_Unit_Declarations --
3268 -----------------------------------
3270 function Current_Sem_Unit_Declarations
return List_Id
is
3271 U
: Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
3275 -- If the current unit is a package body, locate the visible
3276 -- declarations of the package spec.
3278 if Nkind
(U
) = N_Package_Body
then
3279 U
:= Unit
(Library_Unit
(Cunit
(Current_Sem_Unit
)));
3282 if Nkind
(U
) = N_Package_Declaration
then
3283 U
:= Specification
(U
);
3284 Decls
:= Visible_Declarations
(U
);
3288 Set_Visible_Declarations
(U
, Decls
);
3292 Decls
:= Declarations
(U
);
3296 Set_Declarations
(U
, Decls
);
3301 end Current_Sem_Unit_Declarations
;
3303 -----------------------
3304 -- Duplicate_Subexpr --
3305 -----------------------
3307 function Duplicate_Subexpr
3309 Name_Req
: Boolean := False;
3310 Renaming_Req
: Boolean := False) return Node_Id
3313 Remove_Side_Effects
(Exp
, Name_Req
, Renaming_Req
);
3314 return New_Copy_Tree
(Exp
);
3315 end Duplicate_Subexpr
;
3317 ---------------------------------
3318 -- Duplicate_Subexpr_No_Checks --
3319 ---------------------------------
3321 function Duplicate_Subexpr_No_Checks
3323 Name_Req
: Boolean := False;
3324 Renaming_Req
: Boolean := False;
3325 Related_Id
: Entity_Id
:= Empty
;
3326 Is_Low_Bound
: Boolean := False;
3327 Is_High_Bound
: Boolean := False) return Node_Id
3334 Name_Req
=> Name_Req
,
3335 Renaming_Req
=> Renaming_Req
,
3336 Related_Id
=> Related_Id
,
3337 Is_Low_Bound
=> Is_Low_Bound
,
3338 Is_High_Bound
=> Is_High_Bound
);
3340 New_Exp
:= New_Copy_Tree
(Exp
);
3341 Remove_Checks
(New_Exp
);
3343 end Duplicate_Subexpr_No_Checks
;
3345 -----------------------------------
3346 -- Duplicate_Subexpr_Move_Checks --
3347 -----------------------------------
3349 function Duplicate_Subexpr_Move_Checks
3351 Name_Req
: Boolean := False;
3352 Renaming_Req
: Boolean := False) return Node_Id
3357 Remove_Side_Effects
(Exp
, Name_Req
, Renaming_Req
);
3358 New_Exp
:= New_Copy_Tree
(Exp
);
3359 Remove_Checks
(Exp
);
3361 end Duplicate_Subexpr_Move_Checks
;
3363 --------------------
3364 -- Ensure_Defined --
3365 --------------------
3367 procedure Ensure_Defined
(Typ
: Entity_Id
; N
: Node_Id
) is
3371 -- An itype reference must only be created if this is a local itype, so
3372 -- that gigi can elaborate it on the proper objstack.
3374 if Is_Itype
(Typ
) and then Scope
(Typ
) = Current_Scope
then
3375 IR
:= Make_Itype_Reference
(Sloc
(N
));
3376 Set_Itype
(IR
, Typ
);
3377 Insert_Action
(N
, IR
);
3385 function Entity_Hash
(E
: Entity_Id
) return Num_Primitives
is
3387 return Num_Primitives
(E
mod Primitives_Mapping_Size
);
3390 --------------------
3391 -- Entry_Names_OK --
3392 --------------------
3394 function Entry_Names_OK
return Boolean is
3397 not Restricted_Profile
3398 and then not Global_Discard_Names
3399 and then not Restriction_Active
(No_Implicit_Heap_Allocations
)
3400 and then not Restriction_Active
(No_Local_Allocators
);
3407 procedure Evaluate_Name
(Nam
: Node_Id
) is
3408 K
: constant Node_Kind
:= Nkind
(Nam
);
3411 -- For an explicit dereference, we simply force the evaluation of the
3412 -- name expression. The dereference provides a value that is the address
3413 -- for the renamed object, and it is precisely this value that we want
3416 if K
= N_Explicit_Dereference
then
3417 Force_Evaluation
(Prefix
(Nam
));
3419 -- For a selected component, we simply evaluate the prefix
3421 elsif K
= N_Selected_Component
then
3422 Evaluate_Name
(Prefix
(Nam
));
3424 -- For an indexed component, or an attribute reference, we evaluate the
3425 -- prefix, which is itself a name, recursively, and then force the
3426 -- evaluation of all the subscripts (or attribute expressions).
3428 elsif Nkind_In
(K
, N_Indexed_Component
, N_Attribute_Reference
) then
3429 Evaluate_Name
(Prefix
(Nam
));
3435 E
:= First
(Expressions
(Nam
));
3436 while Present
(E
) loop
3437 Force_Evaluation
(E
);
3439 if Original_Node
(E
) /= E
then
3440 Set_Do_Range_Check
(E
, Do_Range_Check
(Original_Node
(E
)));
3447 -- For a slice, we evaluate the prefix, as for the indexed component
3448 -- case and then, if there is a range present, either directly or as the
3449 -- constraint of a discrete subtype indication, we evaluate the two
3450 -- bounds of this range.
3452 elsif K
= N_Slice
then
3453 Evaluate_Name
(Prefix
(Nam
));
3454 Evaluate_Slice_Bounds
(Nam
);
3456 -- For a type conversion, the expression of the conversion must be the
3457 -- name of an object, and we simply need to evaluate this name.
3459 elsif K
= N_Type_Conversion
then
3460 Evaluate_Name
(Expression
(Nam
));
3462 -- For a function call, we evaluate the call
3464 elsif K
= N_Function_Call
then
3465 Force_Evaluation
(Nam
);
3467 -- The remaining cases are direct name, operator symbol and character
3468 -- literal. In all these cases, we do nothing, since we want to
3469 -- reevaluate each time the renamed object is used.
3476 ---------------------------
3477 -- Evaluate_Slice_Bounds --
3478 ---------------------------
3480 procedure Evaluate_Slice_Bounds
(Slice
: Node_Id
) is
3481 DR
: constant Node_Id
:= Discrete_Range
(Slice
);
3486 if Nkind
(DR
) = N_Range
then
3487 Force_Evaluation
(Low_Bound
(DR
));
3488 Force_Evaluation
(High_Bound
(DR
));
3490 elsif Nkind
(DR
) = N_Subtype_Indication
then
3491 Constr
:= Constraint
(DR
);
3493 if Nkind
(Constr
) = N_Range_Constraint
then
3494 Rexpr
:= Range_Expression
(Constr
);
3496 Force_Evaluation
(Low_Bound
(Rexpr
));
3497 Force_Evaluation
(High_Bound
(Rexpr
));
3500 end Evaluate_Slice_Bounds
;
3502 ---------------------
3503 -- Evolve_And_Then --
3504 ---------------------
3506 procedure Evolve_And_Then
(Cond
: in out Node_Id
; Cond1
: Node_Id
) is
3512 Make_And_Then
(Sloc
(Cond1
),
3514 Right_Opnd
=> Cond1
);
3516 end Evolve_And_Then
;
3518 --------------------
3519 -- Evolve_Or_Else --
3520 --------------------
3522 procedure Evolve_Or_Else
(Cond
: in out Node_Id
; Cond1
: Node_Id
) is
3528 Make_Or_Else
(Sloc
(Cond1
),
3530 Right_Opnd
=> Cond1
);
3534 -----------------------------------------
3535 -- Expand_Static_Predicates_In_Choices --
3536 -----------------------------------------
3538 procedure Expand_Static_Predicates_In_Choices
(N
: Node_Id
) is
3539 pragma Assert
(Nkind_In
(N
, N_Case_Statement_Alternative
, N_Variant
));
3541 Choices
: constant List_Id
:= Discrete_Choices
(N
);
3549 Choice
:= First
(Choices
);
3550 while Present
(Choice
) loop
3551 Next_C
:= Next
(Choice
);
3553 -- Check for name of subtype with static predicate
3555 if Is_Entity_Name
(Choice
)
3556 and then Is_Type
(Entity
(Choice
))
3557 and then Has_Predicates
(Entity
(Choice
))
3559 -- Loop through entries in predicate list, converting to choices
3560 -- and inserting in the list before the current choice. Note that
3561 -- if the list is empty, corresponding to a False predicate, then
3562 -- no choices are inserted.
3564 P
:= First
(Static_Discrete_Predicate
(Entity
(Choice
)));
3565 while Present
(P
) loop
3567 -- If low bound and high bounds are equal, copy simple choice
3569 if Expr_Value
(Low_Bound
(P
)) = Expr_Value
(High_Bound
(P
)) then
3570 C
:= New_Copy
(Low_Bound
(P
));
3572 -- Otherwise copy a range
3578 -- Change Sloc to referencing choice (rather than the Sloc of
3579 -- the predicate declaration element itself).
3581 Set_Sloc
(C
, Sloc
(Choice
));
3582 Insert_Before
(Choice
, C
);
3586 -- Delete the predicated entry
3591 -- Move to next choice to check
3595 end Expand_Static_Predicates_In_Choices
;
3597 ------------------------------
3598 -- Expand_Subtype_From_Expr --
3599 ------------------------------
3601 -- This function is applicable for both static and dynamic allocation of
3602 -- objects which are constrained by an initial expression. Basically it
3603 -- transforms an unconstrained subtype indication into a constrained one.
3605 -- The expression may also be transformed in certain cases in order to
3606 -- avoid multiple evaluation. In the static allocation case, the general
3611 -- is transformed into
3613 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
3615 -- Here are the main cases :
3617 -- <if Expr is a Slice>
3618 -- Val : T ([Index_Subtype (Expr)]) := Expr;
3620 -- <elsif Expr is a String Literal>
3621 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
3623 -- <elsif Expr is Constrained>
3624 -- subtype T is Type_Of_Expr
3627 -- <elsif Expr is an entity_name>
3628 -- Val : T (constraints taken from Expr) := Expr;
3631 -- type Axxx is access all T;
3632 -- Rval : Axxx := Expr'ref;
3633 -- Val : T (constraints taken from Rval) := Rval.all;
3635 -- ??? note: when the Expression is allocated in the secondary stack
3636 -- we could use it directly instead of copying it by declaring
3637 -- Val : T (...) renames Rval.all
3639 procedure Expand_Subtype_From_Expr
3641 Unc_Type
: Entity_Id
;
3642 Subtype_Indic
: Node_Id
;
3644 Related_Id
: Entity_Id
:= Empty
)
3646 Loc
: constant Source_Ptr
:= Sloc
(N
);
3647 Exp_Typ
: constant Entity_Id
:= Etype
(Exp
);
3651 -- In general we cannot build the subtype if expansion is disabled,
3652 -- because internal entities may not have been defined. However, to
3653 -- avoid some cascaded errors, we try to continue when the expression is
3654 -- an array (or string), because it is safe to compute the bounds. It is
3655 -- in fact required to do so even in a generic context, because there
3656 -- may be constants that depend on the bounds of a string literal, both
3657 -- standard string types and more generally arrays of characters.
3659 -- In GNATprove mode, these extra subtypes are not needed
3661 if GNATprove_Mode
then
3665 if not Expander_Active
3666 and then (No
(Etype
(Exp
)) or else not Is_String_Type
(Etype
(Exp
)))
3671 if Nkind
(Exp
) = N_Slice
then
3673 Slice_Type
: constant Entity_Id
:= Etype
(First_Index
(Exp_Typ
));
3676 Rewrite
(Subtype_Indic
,
3677 Make_Subtype_Indication
(Loc
,
3678 Subtype_Mark
=> New_Occurrence_Of
(Unc_Type
, Loc
),
3680 Make_Index_Or_Discriminant_Constraint
(Loc
,
3681 Constraints
=> New_List
3682 (New_Occurrence_Of
(Slice_Type
, Loc
)))));
3684 -- This subtype indication may be used later for constraint checks
3685 -- we better make sure that if a variable was used as a bound of
3686 -- of the original slice, its value is frozen.
3688 Evaluate_Slice_Bounds
(Exp
);
3691 elsif Ekind
(Exp_Typ
) = E_String_Literal_Subtype
then
3692 Rewrite
(Subtype_Indic
,
3693 Make_Subtype_Indication
(Loc
,
3694 Subtype_Mark
=> New_Occurrence_Of
(Unc_Type
, Loc
),
3696 Make_Index_Or_Discriminant_Constraint
(Loc
,
3697 Constraints
=> New_List
(
3698 Make_Literal_Range
(Loc
,
3699 Literal_Typ
=> Exp_Typ
)))));
3701 -- If the type of the expression is an internally generated type it
3702 -- may not be necessary to create a new subtype. However there are two
3703 -- exceptions: references to the current instances, and aliased array
3704 -- object declarations for which the back end has to create a template.
3706 elsif Is_Constrained
(Exp_Typ
)
3707 and then not Is_Class_Wide_Type
(Unc_Type
)
3709 (Nkind
(N
) /= N_Object_Declaration
3710 or else not Is_Entity_Name
(Expression
(N
))
3711 or else not Comes_From_Source
(Entity
(Expression
(N
)))
3712 or else not Is_Array_Type
(Exp_Typ
)
3713 or else not Aliased_Present
(N
))
3715 if Is_Itype
(Exp_Typ
) then
3717 -- Within an initialization procedure, a selected component
3718 -- denotes a component of the enclosing record, and it appears as
3719 -- an actual in a call to its own initialization procedure. If
3720 -- this component depends on the outer discriminant, we must
3721 -- generate the proper actual subtype for it.
3723 if Nkind
(Exp
) = N_Selected_Component
3724 and then Within_Init_Proc
3727 Decl
: constant Node_Id
:=
3728 Build_Actual_Subtype_Of_Component
(Exp_Typ
, Exp
);
3730 if Present
(Decl
) then
3731 Insert_Action
(N
, Decl
);
3732 T
:= Defining_Identifier
(Decl
);
3738 -- No need to generate a new subtype
3745 T
:= Make_Temporary
(Loc
, 'T');
3748 Make_Subtype_Declaration
(Loc
,
3749 Defining_Identifier
=> T
,
3750 Subtype_Indication
=> New_Occurrence_Of
(Exp_Typ
, Loc
)));
3752 -- This type is marked as an itype even though it has an explicit
3753 -- declaration since otherwise Is_Generic_Actual_Type can get
3754 -- set, resulting in the generation of spurious errors. (See
3755 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
3758 Set_Associated_Node_For_Itype
(T
, Exp
);
3761 Rewrite
(Subtype_Indic
, New_Occurrence_Of
(T
, Loc
));
3763 -- Nothing needs to be done for private types with unknown discriminants
3764 -- if the underlying type is not an unconstrained composite type or it
3765 -- is an unchecked union.
3767 elsif Is_Private_Type
(Unc_Type
)
3768 and then Has_Unknown_Discriminants
(Unc_Type
)
3769 and then (not Is_Composite_Type
(Underlying_Type
(Unc_Type
))
3770 or else Is_Constrained
(Underlying_Type
(Unc_Type
))
3771 or else Is_Unchecked_Union
(Underlying_Type
(Unc_Type
)))
3775 -- Case of derived type with unknown discriminants where the parent type
3776 -- also has unknown discriminants.
3778 elsif Is_Record_Type
(Unc_Type
)
3779 and then not Is_Class_Wide_Type
(Unc_Type
)
3780 and then Has_Unknown_Discriminants
(Unc_Type
)
3781 and then Has_Unknown_Discriminants
(Underlying_Type
(Unc_Type
))
3783 -- Nothing to be done if no underlying record view available
3785 -- If this is a limited type derived from a type with unknown
3786 -- discriminants, do not expand either, so that subsequent expansion
3787 -- of the call can add build-in-place parameters to call.
3789 if No
(Underlying_Record_View
(Unc_Type
))
3790 or else Is_Limited_Type
(Unc_Type
)
3794 -- Otherwise use the Underlying_Record_View to create the proper
3795 -- constrained subtype for an object of a derived type with unknown
3799 Remove_Side_Effects
(Exp
);
3800 Rewrite
(Subtype_Indic
,
3801 Make_Subtype_From_Expr
(Exp
, Underlying_Record_View
(Unc_Type
)));
3804 -- Renamings of class-wide interface types require no equivalent
3805 -- constrained type declarations because we only need to reference
3806 -- the tag component associated with the interface. The same is
3807 -- presumably true for class-wide types in general, so this test
3808 -- is broadened to include all class-wide renamings, which also
3809 -- avoids cases of unbounded recursion in Remove_Side_Effects.
3810 -- (Is this really correct, or are there some cases of class-wide
3811 -- renamings that require action in this procedure???)
3814 and then Nkind
(N
) = N_Object_Renaming_Declaration
3815 and then Is_Class_Wide_Type
(Unc_Type
)
3819 -- In Ada 95 nothing to be done if the type of the expression is limited
3820 -- because in this case the expression cannot be copied, and its use can
3821 -- only be by reference.
3823 -- In Ada 2005 the context can be an object declaration whose expression
3824 -- is a function that returns in place. If the nominal subtype has
3825 -- unknown discriminants, the call still provides constraints on the
3826 -- object, and we have to create an actual subtype from it.
3828 -- If the type is class-wide, the expression is dynamically tagged and
3829 -- we do not create an actual subtype either. Ditto for an interface.
3830 -- For now this applies only if the type is immutably limited, and the
3831 -- function being called is build-in-place. This will have to be revised
3832 -- when build-in-place functions are generalized to other types.
3834 elsif Is_Limited_View
(Exp_Typ
)
3836 (Is_Class_Wide_Type
(Exp_Typ
)
3837 or else Is_Interface
(Exp_Typ
)
3838 or else not Has_Unknown_Discriminants
(Exp_Typ
)
3839 or else not Is_Composite_Type
(Unc_Type
))
3843 -- For limited objects initialized with build in place function calls,
3844 -- nothing to be done; otherwise we prematurely introduce an N_Reference
3845 -- node in the expression initializing the object, which breaks the
3846 -- circuitry that detects and adds the additional arguments to the
3849 elsif Is_Build_In_Place_Function_Call
(Exp
) then
3853 Remove_Side_Effects
(Exp
);
3854 Rewrite
(Subtype_Indic
,
3855 Make_Subtype_From_Expr
(Exp
, Unc_Type
, Related_Id
));
3857 end Expand_Subtype_From_Expr
;
3859 ----------------------
3860 -- Finalize_Address --
3861 ----------------------
3863 function Finalize_Address
(Typ
: Entity_Id
) return Entity_Id
is
3864 Utyp
: Entity_Id
:= Typ
;
3867 -- Handle protected class-wide or task class-wide types
3869 if Is_Class_Wide_Type
(Utyp
) then
3870 if Is_Concurrent_Type
(Root_Type
(Utyp
)) then
3871 Utyp
:= Root_Type
(Utyp
);
3873 elsif Is_Private_Type
(Root_Type
(Utyp
))
3874 and then Present
(Full_View
(Root_Type
(Utyp
)))
3875 and then Is_Concurrent_Type
(Full_View
(Root_Type
(Utyp
)))
3877 Utyp
:= Full_View
(Root_Type
(Utyp
));
3881 -- Handle private types
3883 if Is_Private_Type
(Utyp
) and then Present
(Full_View
(Utyp
)) then
3884 Utyp
:= Full_View
(Utyp
);
3887 -- Handle protected and task types
3889 if Is_Concurrent_Type
(Utyp
)
3890 and then Present
(Corresponding_Record_Type
(Utyp
))
3892 Utyp
:= Corresponding_Record_Type
(Utyp
);
3895 Utyp
:= Underlying_Type
(Base_Type
(Utyp
));
3897 -- Deal with untagged derivation of private views. If the parent is
3898 -- now known to be protected, the finalization routine is the one
3899 -- defined on the corresponding record of the ancestor (corresponding
3900 -- records do not automatically inherit operations, but maybe they
3903 if Is_Untagged_Derivation
(Typ
) then
3904 if Is_Protected_Type
(Typ
) then
3905 Utyp
:= Corresponding_Record_Type
(Root_Type
(Base_Type
(Typ
)));
3908 Utyp
:= Underlying_Type
(Root_Type
(Base_Type
(Typ
)));
3910 if Is_Protected_Type
(Utyp
) then
3911 Utyp
:= Corresponding_Record_Type
(Utyp
);
3916 -- If the underlying_type is a subtype, we are dealing with the
3917 -- completion of a private type. We need to access the base type and
3918 -- generate a conversion to it.
3920 if Utyp
/= Base_Type
(Utyp
) then
3921 pragma Assert
(Is_Private_Type
(Typ
));
3923 Utyp
:= Base_Type
(Utyp
);
3926 -- When dealing with an internally built full view for a type with
3927 -- unknown discriminants, use the original record type.
3929 if Is_Underlying_Record_View
(Utyp
) then
3930 Utyp
:= Etype
(Utyp
);
3933 return TSS
(Utyp
, TSS_Finalize_Address
);
3934 end Finalize_Address
;
3940 function Find_DIC_Type
(Typ
: Entity_Id
) return Entity_Id
is
3941 Curr_Typ
: Entity_Id
;
3942 -- The current type being examined in the parent hierarchy traversal
3944 DIC_Typ
: Entity_Id
;
3945 -- The type which carries the DIC pragma. This variable denotes the
3946 -- partial view when private types are involved.
3948 Par_Typ
: Entity_Id
;
3949 -- The parent type of the current type. This variable denotes the full
3950 -- view when private types are involved.
3953 -- The input type defines its own DIC pragma, therefore it is the owner
3955 if Has_Own_DIC
(Typ
) then
3958 -- Otherwise the DIC pragma is inherited from a parent type
3961 pragma Assert
(Has_Inherited_DIC
(Typ
));
3963 -- Climb the parent chain
3967 -- Inspect the parent type. Do not consider subtypes as they
3968 -- inherit the DIC attributes from their base types.
3970 DIC_Typ
:= Base_Type
(Etype
(Curr_Typ
));
3972 -- Look at the full view of a private type because the type may
3973 -- have a hidden parent introduced in the full view.
3977 if Is_Private_Type
(Par_Typ
)
3978 and then Present
(Full_View
(Par_Typ
))
3980 Par_Typ
:= Full_View
(Par_Typ
);
3983 -- Stop the climb once the nearest parent type which defines a DIC
3984 -- pragma of its own is encountered or when the root of the parent
3985 -- chain is reached.
3987 exit when Has_Own_DIC
(DIC_Typ
) or else Curr_Typ
= Par_Typ
;
3989 Curr_Typ
:= Par_Typ
;
3996 ------------------------
3997 -- Find_Interface_ADT --
3998 ------------------------
4000 function Find_Interface_ADT
4002 Iface
: Entity_Id
) return Elmt_Id
4005 Typ
: Entity_Id
:= T
;
4008 pragma Assert
(Is_Interface
(Iface
));
4010 -- Handle private types
4012 if Has_Private_Declaration
(Typ
) and then Present
(Full_View
(Typ
)) then
4013 Typ
:= Full_View
(Typ
);
4016 -- Handle access types
4018 if Is_Access_Type
(Typ
) then
4019 Typ
:= Designated_Type
(Typ
);
4022 -- Handle task and protected types implementing interfaces
4024 if Is_Concurrent_Type
(Typ
) then
4025 Typ
:= Corresponding_Record_Type
(Typ
);
4029 (not Is_Class_Wide_Type
(Typ
)
4030 and then Ekind
(Typ
) /= E_Incomplete_Type
);
4032 if Is_Ancestor
(Iface
, Typ
, Use_Full_View
=> True) then
4033 return First_Elmt
(Access_Disp_Table
(Typ
));
4036 ADT
:= Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
4038 and then Present
(Related_Type
(Node
(ADT
)))
4039 and then Related_Type
(Node
(ADT
)) /= Iface
4040 and then not Is_Ancestor
(Iface
, Related_Type
(Node
(ADT
)),
4041 Use_Full_View
=> True)
4046 pragma Assert
(Present
(Related_Type
(Node
(ADT
))));
4049 end Find_Interface_ADT
;
4051 ------------------------
4052 -- Find_Interface_Tag --
4053 ------------------------
4055 function Find_Interface_Tag
4057 Iface
: Entity_Id
) return Entity_Id
4060 Found
: Boolean := False;
4061 Typ
: Entity_Id
:= T
;
4063 procedure Find_Tag
(Typ
: Entity_Id
);
4064 -- Internal subprogram used to recursively climb to the ancestors
4070 procedure Find_Tag
(Typ
: Entity_Id
) is
4075 -- This routine does not handle the case in which the interface is an
4076 -- ancestor of Typ. That case is handled by the enclosing subprogram.
4078 pragma Assert
(Typ
/= Iface
);
4080 -- Climb to the root type handling private types
4082 if Present
(Full_View
(Etype
(Typ
))) then
4083 if Full_View
(Etype
(Typ
)) /= Typ
then
4084 Find_Tag
(Full_View
(Etype
(Typ
)));
4087 elsif Etype
(Typ
) /= Typ
then
4088 Find_Tag
(Etype
(Typ
));
4091 -- Traverse the list of interfaces implemented by the type
4094 and then Present
(Interfaces
(Typ
))
4095 and then not (Is_Empty_Elmt_List
(Interfaces
(Typ
)))
4097 -- Skip the tag associated with the primary table
4099 pragma Assert
(Etype
(First_Tag_Component
(Typ
)) = RTE
(RE_Tag
));
4100 AI_Tag
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
4101 pragma Assert
(Present
(AI_Tag
));
4103 AI_Elmt
:= First_Elmt
(Interfaces
(Typ
));
4104 while Present
(AI_Elmt
) loop
4105 AI
:= Node
(AI_Elmt
);
4108 or else Is_Ancestor
(Iface
, AI
, Use_Full_View
=> True)
4114 AI_Tag
:= Next_Tag_Component
(AI_Tag
);
4115 Next_Elmt
(AI_Elmt
);
4120 -- Start of processing for Find_Interface_Tag
4123 pragma Assert
(Is_Interface
(Iface
));
4125 -- Handle access types
4127 if Is_Access_Type
(Typ
) then
4128 Typ
:= Designated_Type
(Typ
);
4131 -- Handle class-wide types
4133 if Is_Class_Wide_Type
(Typ
) then
4134 Typ
:= Root_Type
(Typ
);
4137 -- Handle private types
4139 if Has_Private_Declaration
(Typ
) and then Present
(Full_View
(Typ
)) then
4140 Typ
:= Full_View
(Typ
);
4143 -- Handle entities from the limited view
4145 if Ekind
(Typ
) = E_Incomplete_Type
then
4146 pragma Assert
(Present
(Non_Limited_View
(Typ
)));
4147 Typ
:= Non_Limited_View
(Typ
);
4150 -- Handle task and protected types implementing interfaces
4152 if Is_Concurrent_Type
(Typ
) then
4153 Typ
:= Corresponding_Record_Type
(Typ
);
4156 -- If the interface is an ancestor of the type, then it shared the
4157 -- primary dispatch table.
4159 if Is_Ancestor
(Iface
, Typ
, Use_Full_View
=> True) then
4160 pragma Assert
(Etype
(First_Tag_Component
(Typ
)) = RTE
(RE_Tag
));
4161 return First_Tag_Component
(Typ
);
4163 -- Otherwise we need to search for its associated tag component
4167 pragma Assert
(Found
);
4170 end Find_Interface_Tag
;
4172 ---------------------------
4173 -- Find_Optional_Prim_Op --
4174 ---------------------------
4176 function Find_Optional_Prim_Op
4177 (T
: Entity_Id
; Name
: Name_Id
) return Entity_Id
4180 Typ
: Entity_Id
:= T
;
4184 if Is_Class_Wide_Type
(Typ
) then
4185 Typ
:= Root_Type
(Typ
);
4188 Typ
:= Underlying_Type
(Typ
);
4190 -- Loop through primitive operations
4192 Prim
:= First_Elmt
(Primitive_Operations
(Typ
));
4193 while Present
(Prim
) loop
4196 -- We can retrieve primitive operations by name if it is an internal
4197 -- name. For equality we must check that both of its operands have
4198 -- the same type, to avoid confusion with user-defined equalities
4199 -- than may have a non-symmetric signature.
4201 exit when Chars
(Op
) = Name
4204 or else Etype
(First_Formal
(Op
)) = Etype
(Last_Formal
(Op
)));
4209 return Node
(Prim
); -- Empty if not found
4210 end Find_Optional_Prim_Op
;
4212 ---------------------------
4213 -- Find_Optional_Prim_Op --
4214 ---------------------------
4216 function Find_Optional_Prim_Op
4218 Name
: TSS_Name_Type
) return Entity_Id
4220 Inher_Op
: Entity_Id
:= Empty
;
4221 Own_Op
: Entity_Id
:= Empty
;
4222 Prim_Elmt
: Elmt_Id
;
4223 Prim_Id
: Entity_Id
;
4224 Typ
: Entity_Id
:= T
;
4227 if Is_Class_Wide_Type
(Typ
) then
4228 Typ
:= Root_Type
(Typ
);
4231 Typ
:= Underlying_Type
(Typ
);
4233 -- This search is based on the assertion that the dispatching version
4234 -- of the TSS routine always precedes the real primitive.
4236 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
4237 while Present
(Prim_Elmt
) loop
4238 Prim_Id
:= Node
(Prim_Elmt
);
4240 if Is_TSS
(Prim_Id
, Name
) then
4241 if Present
(Alias
(Prim_Id
)) then
4242 Inher_Op
:= Prim_Id
;
4248 Next_Elmt
(Prim_Elmt
);
4251 if Present
(Own_Op
) then
4253 elsif Present
(Inher_Op
) then
4258 end Find_Optional_Prim_Op
;
4264 function Find_Prim_Op
4265 (T
: Entity_Id
; Name
: Name_Id
) return Entity_Id
4267 Result
: constant Entity_Id
:= Find_Optional_Prim_Op
(T
, Name
);
4270 raise Program_Error
;
4280 function Find_Prim_Op
4282 Name
: TSS_Name_Type
) return Entity_Id
4284 Result
: constant Entity_Id
:= Find_Optional_Prim_Op
(T
, Name
);
4287 raise Program_Error
;
4293 ----------------------------
4294 -- Find_Protection_Object --
4295 ----------------------------
4297 function Find_Protection_Object
(Scop
: Entity_Id
) return Entity_Id
is
4302 while Present
(S
) loop
4303 if Ekind_In
(S
, E_Entry
, E_Entry_Family
, E_Function
, E_Procedure
)
4304 and then Present
(Protection_Object
(S
))
4306 return Protection_Object
(S
);
4312 -- If we do not find a Protection object in the scope chain, then
4313 -- something has gone wrong, most likely the object was never created.
4315 raise Program_Error
;
4316 end Find_Protection_Object
;
4318 --------------------------
4319 -- Find_Protection_Type --
4320 --------------------------
4322 function Find_Protection_Type
(Conc_Typ
: Entity_Id
) return Entity_Id
is
4324 Typ
: Entity_Id
:= Conc_Typ
;
4327 if Is_Concurrent_Type
(Typ
) then
4328 Typ
:= Corresponding_Record_Type
(Typ
);
4331 -- Since restriction violations are not considered serious errors, the
4332 -- expander remains active, but may leave the corresponding record type
4333 -- malformed. In such cases, component _object is not available so do
4336 if not Analyzed
(Typ
) then
4340 Comp
:= First_Component
(Typ
);
4341 while Present
(Comp
) loop
4342 if Chars
(Comp
) = Name_uObject
then
4343 return Base_Type
(Etype
(Comp
));
4346 Next_Component
(Comp
);
4349 -- The corresponding record of a protected type should always have an
4352 raise Program_Error
;
4353 end Find_Protection_Type
;
4355 -----------------------
4356 -- Find_Hook_Context --
4357 -----------------------
4359 function Find_Hook_Context
(N
: Node_Id
) return Node_Id
is
4363 Wrapped_Node
: Node_Id
;
4364 -- Note: if we are in a transient scope, we want to reuse it as
4365 -- the context for actions insertion, if possible. But if N is itself
4366 -- part of the stored actions for the current transient scope,
4367 -- then we need to insert at the appropriate (inner) location in
4368 -- the not as an action on Node_To_Be_Wrapped.
4370 In_Cond_Expr
: constant Boolean := Within_Case_Or_If_Expression
(N
);
4373 -- When the node is inside a case/if expression, the lifetime of any
4374 -- temporary controlled object is extended. Find a suitable insertion
4375 -- node by locating the topmost case or if expressions.
4377 if In_Cond_Expr
then
4380 while Present
(Par
) loop
4381 if Nkind_In
(Original_Node
(Par
), N_Case_Expression
,
4386 -- Prevent the search from going too far
4388 elsif Is_Body_Or_Package_Declaration
(Par
) then
4392 Par
:= Parent
(Par
);
4395 -- The topmost case or if expression is now recovered, but it may
4396 -- still not be the correct place to add generated code. Climb to
4397 -- find a parent that is part of a declarative or statement list,
4398 -- and is not a list of actuals in a call.
4401 while Present
(Par
) loop
4402 if Is_List_Member
(Par
)
4403 and then not Nkind_In
(Par
, N_Component_Association
,
4404 N_Discriminant_Association
,
4405 N_Parameter_Association
,
4406 N_Pragma_Argument_Association
)
4407 and then not Nkind_In
(Parent
(Par
), N_Function_Call
,
4408 N_Procedure_Call_Statement
,
4409 N_Entry_Call_Statement
)
4414 -- Prevent the search from going too far
4416 elsif Is_Body_Or_Package_Declaration
(Par
) then
4420 Par
:= Parent
(Par
);
4427 while Present
(Par
) loop
4429 -- Keep climbing past various operators
4431 if Nkind
(Parent
(Par
)) in N_Op
4432 or else Nkind_In
(Parent
(Par
), N_And_Then
, N_Or_Else
)
4434 Par
:= Parent
(Par
);
4442 -- The node may be located in a pragma in which case return the
4445 -- pragma Precondition (... and then Ctrl_Func_Call ...);
4447 -- Similar case occurs when the node is related to an object
4448 -- declaration or assignment:
4450 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
4452 -- Another case to consider is when the node is part of a return
4455 -- return ... and then Ctrl_Func_Call ...;
4457 -- Another case is when the node acts as a formal in a procedure
4460 -- Proc (... and then Ctrl_Func_Call ...);
4462 if Scope_Is_Transient
then
4463 Wrapped_Node
:= Node_To_Be_Wrapped
;
4465 Wrapped_Node
:= Empty
;
4468 while Present
(Par
) loop
4469 if Par
= Wrapped_Node
4470 or else Nkind_In
(Par
, N_Assignment_Statement
,
4471 N_Object_Declaration
,
4473 N_Procedure_Call_Statement
,
4474 N_Simple_Return_Statement
)
4478 -- Prevent the search from going too far
4480 elsif Is_Body_Or_Package_Declaration
(Par
) then
4484 Par
:= Parent
(Par
);
4487 -- Return the topmost short circuit operator
4491 end Find_Hook_Context
;
4493 ------------------------------
4494 -- Following_Address_Clause --
4495 ------------------------------
4497 function Following_Address_Clause
(D
: Node_Id
) return Node_Id
is
4498 Id
: constant Entity_Id
:= Defining_Identifier
(D
);
4502 function Check_Decls
(D
: Node_Id
) return Node_Id
;
4503 -- This internal function differs from the main function in that it
4504 -- gets called to deal with a following package private part, and
4505 -- it checks declarations starting with D (the main function checks
4506 -- declarations following D). If D is Empty, then Empty is returned.
4512 function Check_Decls
(D
: Node_Id
) return Node_Id
is
4517 while Present
(Decl
) loop
4518 if Nkind
(Decl
) = N_At_Clause
4519 and then Chars
(Identifier
(Decl
)) = Chars
(Id
)
4523 elsif Nkind
(Decl
) = N_Attribute_Definition_Clause
4524 and then Chars
(Decl
) = Name_Address
4525 and then Chars
(Name
(Decl
)) = Chars
(Id
)
4533 -- Otherwise not found, return Empty
4538 -- Start of processing for Following_Address_Clause
4541 -- If parser detected no address clause for the identifier in question,
4542 -- then the answer is a quick NO, without the need for a search.
4544 if not Get_Name_Table_Boolean1
(Chars
(Id
)) then
4548 -- Otherwise search current declarative unit
4550 Result
:= Check_Decls
(Next
(D
));
4552 if Present
(Result
) then
4556 -- Check for possible package private part following
4560 if Nkind
(Par
) = N_Package_Specification
4561 and then Visible_Declarations
(Par
) = List_Containing
(D
)
4562 and then Present
(Private_Declarations
(Par
))
4564 -- Private part present, check declarations there
4566 return Check_Decls
(First
(Private_Declarations
(Par
)));
4569 -- No private part, clause not found, return Empty
4573 end Following_Address_Clause
;
4575 ----------------------
4576 -- Force_Evaluation --
4577 ----------------------
4579 procedure Force_Evaluation
4581 Name_Req
: Boolean := False;
4582 Related_Id
: Entity_Id
:= Empty
;
4583 Is_Low_Bound
: Boolean := False;
4584 Is_High_Bound
: Boolean := False;
4585 Mode
: Force_Evaluation_Mode
:= Relaxed
)
4590 Name_Req
=> Name_Req
,
4591 Variable_Ref
=> True,
4592 Renaming_Req
=> False,
4593 Related_Id
=> Related_Id
,
4594 Is_Low_Bound
=> Is_Low_Bound
,
4595 Is_High_Bound
=> Is_High_Bound
,
4596 Check_Side_Effects
=>
4597 Is_Static_Expression
(Exp
)
4598 or else Mode
= Relaxed
);
4599 end Force_Evaluation
;
4601 ---------------------------------
4602 -- Fully_Qualified_Name_String --
4603 ---------------------------------
4605 function Fully_Qualified_Name_String
4607 Append_NUL
: Boolean := True) return String_Id
4609 procedure Internal_Full_Qualified_Name
(E
: Entity_Id
);
4610 -- Compute recursively the qualified name without NUL at the end, adding
4611 -- it to the currently started string being generated
4613 ----------------------------------
4614 -- Internal_Full_Qualified_Name --
4615 ----------------------------------
4617 procedure Internal_Full_Qualified_Name
(E
: Entity_Id
) is
4621 -- Deal properly with child units
4623 if Nkind
(E
) = N_Defining_Program_Unit_Name
then
4624 Ent
:= Defining_Identifier
(E
);
4629 -- Compute qualification recursively (only "Standard" has no scope)
4631 if Present
(Scope
(Scope
(Ent
))) then
4632 Internal_Full_Qualified_Name
(Scope
(Ent
));
4633 Store_String_Char
(Get_Char_Code
('.'));
4636 -- Every entity should have a name except some expanded blocks
4637 -- don't bother about those.
4639 if Chars
(Ent
) = No_Name
then
4643 -- Generates the entity name in upper case
4645 Get_Decoded_Name_String
(Chars
(Ent
));
4647 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
4649 end Internal_Full_Qualified_Name
;
4651 -- Start of processing for Full_Qualified_Name
4655 Internal_Full_Qualified_Name
(E
);
4658 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
4662 end Fully_Qualified_Name_String
;
4664 ------------------------
4665 -- Generate_Poll_Call --
4666 ------------------------
4668 procedure Generate_Poll_Call
(N
: Node_Id
) is
4670 -- No poll call if polling not active
4672 if not Polling_Required
then
4675 -- Otherwise generate require poll call
4678 Insert_Before_And_Analyze
(N
,
4679 Make_Procedure_Call_Statement
(Sloc
(N
),
4680 Name
=> New_Occurrence_Of
(RTE
(RE_Poll
), Sloc
(N
))));
4682 end Generate_Poll_Call
;
4684 ---------------------------------
4685 -- Get_Current_Value_Condition --
4686 ---------------------------------
4688 -- Note: the implementation of this procedure is very closely tied to the
4689 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
4690 -- interpret Current_Value fields set by the Set procedure, so the two
4691 -- procedures need to be closely coordinated.
4693 procedure Get_Current_Value_Condition
4698 Loc
: constant Source_Ptr
:= Sloc
(Var
);
4699 Ent
: constant Entity_Id
:= Entity
(Var
);
4701 procedure Process_Current_Value_Condition
4704 -- N is an expression which holds either True (S = True) or False (S =
4705 -- False) in the condition. This procedure digs out the expression and
4706 -- if it refers to Ent, sets Op and Val appropriately.
4708 -------------------------------------
4709 -- Process_Current_Value_Condition --
4710 -------------------------------------
4712 procedure Process_Current_Value_Condition
4717 Prev_Cond
: Node_Id
;
4727 -- Deal with NOT operators, inverting sense
4729 while Nkind
(Cond
) = N_Op_Not
loop
4730 Cond
:= Right_Opnd
(Cond
);
4734 -- Deal with conversions, qualifications, and expressions with
4737 while Nkind_In
(Cond
,
4739 N_Qualified_Expression
,
4740 N_Expression_With_Actions
)
4742 Cond
:= Expression
(Cond
);
4745 exit when Cond
= Prev_Cond
;
4748 -- Deal with AND THEN and AND cases
4750 if Nkind_In
(Cond
, N_And_Then
, N_Op_And
) then
4752 -- Don't ever try to invert a condition that is of the form of an
4753 -- AND or AND THEN (since we are not doing sufficiently general
4754 -- processing to allow this).
4756 if Sens
= False then
4762 -- Recursively process AND and AND THEN branches
4764 Process_Current_Value_Condition
(Left_Opnd
(Cond
), True);
4766 if Op
/= N_Empty
then
4770 Process_Current_Value_Condition
(Right_Opnd
(Cond
), True);
4773 -- Case of relational operator
4775 elsif Nkind
(Cond
) in N_Op_Compare
then
4778 -- Invert sense of test if inverted test
4780 if Sens
= False then
4782 when N_Op_Eq
=> Op
:= N_Op_Ne
;
4783 when N_Op_Ne
=> Op
:= N_Op_Eq
;
4784 when N_Op_Lt
=> Op
:= N_Op_Ge
;
4785 when N_Op_Gt
=> Op
:= N_Op_Le
;
4786 when N_Op_Le
=> Op
:= N_Op_Gt
;
4787 when N_Op_Ge
=> Op
:= N_Op_Lt
;
4788 when others => raise Program_Error
;
4792 -- Case of entity op value
4794 if Is_Entity_Name
(Left_Opnd
(Cond
))
4795 and then Ent
= Entity
(Left_Opnd
(Cond
))
4796 and then Compile_Time_Known_Value
(Right_Opnd
(Cond
))
4798 Val
:= Right_Opnd
(Cond
);
4800 -- Case of value op entity
4802 elsif Is_Entity_Name
(Right_Opnd
(Cond
))
4803 and then Ent
= Entity
(Right_Opnd
(Cond
))
4804 and then Compile_Time_Known_Value
(Left_Opnd
(Cond
))
4806 Val
:= Left_Opnd
(Cond
);
4808 -- We are effectively swapping operands
4811 when N_Op_Eq
=> null;
4812 when N_Op_Ne
=> null;
4813 when N_Op_Lt
=> Op
:= N_Op_Gt
;
4814 when N_Op_Gt
=> Op
:= N_Op_Lt
;
4815 when N_Op_Le
=> Op
:= N_Op_Ge
;
4816 when N_Op_Ge
=> Op
:= N_Op_Le
;
4817 when others => raise Program_Error
;
4826 elsif Nkind_In
(Cond
,
4828 N_Qualified_Expression
,
4829 N_Expression_With_Actions
)
4831 Cond
:= Expression
(Cond
);
4833 -- Case of Boolean variable reference, return as though the
4834 -- reference had said var = True.
4837 if Is_Entity_Name
(Cond
) and then Ent
= Entity
(Cond
) then
4838 Val
:= New_Occurrence_Of
(Standard_True
, Sloc
(Cond
));
4840 if Sens
= False then
4847 end Process_Current_Value_Condition
;
4849 -- Start of processing for Get_Current_Value_Condition
4855 -- Immediate return, nothing doing, if this is not an object
4857 if Ekind
(Ent
) not in Object_Kind
then
4861 -- Otherwise examine current value
4864 CV
: constant Node_Id
:= Current_Value
(Ent
);
4869 -- If statement. Condition is known true in THEN section, known False
4870 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
4872 if Nkind
(CV
) = N_If_Statement
then
4874 -- Before start of IF statement
4876 if Loc
< Sloc
(CV
) then
4879 -- After end of IF statement
4881 elsif Loc
>= Sloc
(CV
) + Text_Ptr
(UI_To_Int
(End_Span
(CV
))) then
4885 -- At this stage we know that we are within the IF statement, but
4886 -- unfortunately, the tree does not record the SLOC of the ELSE so
4887 -- we cannot use a simple SLOC comparison to distinguish between
4888 -- the then/else statements, so we have to climb the tree.
4895 while Parent
(N
) /= CV
loop
4898 -- If we fall off the top of the tree, then that's odd, but
4899 -- perhaps it could occur in some error situation, and the
4900 -- safest response is simply to assume that the outcome of
4901 -- the condition is unknown. No point in bombing during an
4902 -- attempt to optimize things.
4909 -- Now we have N pointing to a node whose parent is the IF
4910 -- statement in question, so now we can tell if we are within
4911 -- the THEN statements.
4913 if Is_List_Member
(N
)
4914 and then List_Containing
(N
) = Then_Statements
(CV
)
4918 -- If the variable reference does not come from source, we
4919 -- cannot reliably tell whether it appears in the else part.
4920 -- In particular, if it appears in generated code for a node
4921 -- that requires finalization, it may be attached to a list
4922 -- that has not been yet inserted into the code. For now,
4923 -- treat it as unknown.
4925 elsif not Comes_From_Source
(N
) then
4928 -- Otherwise we must be in ELSIF or ELSE part
4935 -- ELSIF part. Condition is known true within the referenced
4936 -- ELSIF, known False in any subsequent ELSIF or ELSE part,
4937 -- and unknown before the ELSE part or after the IF statement.
4939 elsif Nkind
(CV
) = N_Elsif_Part
then
4941 -- if the Elsif_Part had condition_actions, the elsif has been
4942 -- rewritten as a nested if, and the original elsif_part is
4943 -- detached from the tree, so there is no way to obtain useful
4944 -- information on the current value of the variable.
4945 -- Can this be improved ???
4947 if No
(Parent
(CV
)) then
4953 -- If the tree has been otherwise rewritten there is nothing
4954 -- else to be done either.
4956 if Nkind
(Stm
) /= N_If_Statement
then
4960 -- Before start of ELSIF part
4962 if Loc
< Sloc
(CV
) then
4965 -- After end of IF statement
4967 elsif Loc
>= Sloc
(Stm
) +
4968 Text_Ptr
(UI_To_Int
(End_Span
(Stm
)))
4973 -- Again we lack the SLOC of the ELSE, so we need to climb the
4974 -- tree to see if we are within the ELSIF part in question.
4981 while Parent
(N
) /= Stm
loop
4984 -- If we fall off the top of the tree, then that's odd, but
4985 -- perhaps it could occur in some error situation, and the
4986 -- safest response is simply to assume that the outcome of
4987 -- the condition is unknown. No point in bombing during an
4988 -- attempt to optimize things.
4995 -- Now we have N pointing to a node whose parent is the IF
4996 -- statement in question, so see if is the ELSIF part we want.
4997 -- the THEN statements.
5002 -- Otherwise we must be in subsequent ELSIF or ELSE part
5009 -- Iteration scheme of while loop. The condition is known to be
5010 -- true within the body of the loop.
5012 elsif Nkind
(CV
) = N_Iteration_Scheme
then
5014 Loop_Stmt
: constant Node_Id
:= Parent
(CV
);
5017 -- Before start of body of loop
5019 if Loc
< Sloc
(Loop_Stmt
) then
5022 -- After end of LOOP statement
5024 elsif Loc
>= Sloc
(End_Label
(Loop_Stmt
)) then
5027 -- We are within the body of the loop
5034 -- All other cases of Current_Value settings
5040 -- If we fall through here, then we have a reportable condition, Sens
5041 -- is True if the condition is true and False if it needs inverting.
5043 Process_Current_Value_Condition
(Condition
(CV
), Sens
);
5045 end Get_Current_Value_Condition
;
5047 ---------------------
5048 -- Get_Stream_Size --
5049 ---------------------
5051 function Get_Stream_Size
(E
: Entity_Id
) return Uint
is
5053 -- If we have a Stream_Size clause for this type use it
5055 if Has_Stream_Size_Clause
(E
) then
5056 return Static_Integer
(Expression
(Stream_Size_Clause
(E
)));
5058 -- Otherwise the Stream_Size if the size of the type
5063 end Get_Stream_Size
;
5065 ---------------------------
5066 -- Has_Access_Constraint --
5067 ---------------------------
5069 function Has_Access_Constraint
(E
: Entity_Id
) return Boolean is
5071 T
: constant Entity_Id
:= Etype
(E
);
5074 if Has_Per_Object_Constraint
(E
) and then Has_Discriminants
(T
) then
5075 Disc
:= First_Discriminant
(T
);
5076 while Present
(Disc
) loop
5077 if Is_Access_Type
(Etype
(Disc
)) then
5081 Next_Discriminant
(Disc
);
5088 end Has_Access_Constraint
;
5090 -----------------------------------------------------
5091 -- Has_Annotate_Pragma_For_External_Axiomatization --
5092 -----------------------------------------------------
5094 function Has_Annotate_Pragma_For_External_Axiomatization
5095 (E
: Entity_Id
) return Boolean
5097 function Is_Annotate_Pragma_For_External_Axiomatization
5098 (N
: Node_Id
) return Boolean;
5099 -- Returns whether N is
5100 -- pragma Annotate (GNATprove, External_Axiomatization);
5102 ----------------------------------------------------
5103 -- Is_Annotate_Pragma_For_External_Axiomatization --
5104 ----------------------------------------------------
5106 -- The general form of pragma Annotate is
5108 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
5109 -- ARG ::= NAME | EXPRESSION
5111 -- The first two arguments are by convention intended to refer to an
5112 -- external tool and a tool-specific function. These arguments are
5115 -- The following is used to annotate a package specification which
5116 -- GNATprove should treat specially, because the axiomatization of
5117 -- this unit is given by the user instead of being automatically
5120 -- pragma Annotate (GNATprove, External_Axiomatization);
5122 function Is_Annotate_Pragma_For_External_Axiomatization
5123 (N
: Node_Id
) return Boolean
5125 Name_GNATprove
: constant String :=
5127 Name_External_Axiomatization
: constant String :=
5128 "external_axiomatization";
5132 if Nkind
(N
) = N_Pragma
5133 and then Get_Pragma_Id
(N
) = Pragma_Annotate
5134 and then List_Length
(Pragma_Argument_Associations
(N
)) = 2
5137 Arg1
: constant Node_Id
:=
5138 First
(Pragma_Argument_Associations
(N
));
5139 Arg2
: constant Node_Id
:= Next
(Arg1
);
5144 -- Fill in Name_Buffer with Name_GNATprove first, and then with
5145 -- Name_External_Axiomatization so that Name_Find returns the
5146 -- corresponding name. This takes care of all possible casings.
5149 Add_Str_To_Name_Buffer
(Name_GNATprove
);
5153 Add_Str_To_Name_Buffer
(Name_External_Axiomatization
);
5156 return Chars
(Get_Pragma_Arg
(Arg1
)) = Nam1
5158 Chars
(Get_Pragma_Arg
(Arg2
)) = Nam2
;
5164 end Is_Annotate_Pragma_For_External_Axiomatization
;
5169 Vis_Decls
: List_Id
;
5172 -- Start of processing for Has_Annotate_Pragma_For_External_Axiomatization
5175 if Nkind
(Parent
(E
)) = N_Defining_Program_Unit_Name
then
5176 Decl
:= Parent
(Parent
(E
));
5181 Vis_Decls
:= Visible_Declarations
(Decl
);
5183 N
:= First
(Vis_Decls
);
5184 while Present
(N
) loop
5186 -- Skip declarations generated by the frontend. Skip all pragmas
5187 -- that are not the desired Annotate pragma. Stop the search on
5188 -- the first non-pragma source declaration.
5190 if Comes_From_Source
(N
) then
5191 if Nkind
(N
) = N_Pragma
then
5192 if Is_Annotate_Pragma_For_External_Axiomatization
(N
) then
5204 end Has_Annotate_Pragma_For_External_Axiomatization
;
5206 --------------------
5207 -- Homonym_Number --
5208 --------------------
5210 function Homonym_Number
(Subp
: Entity_Id
) return Nat
is
5216 Hom
:= Homonym
(Subp
);
5217 while Present
(Hom
) loop
5218 if Scope
(Hom
) = Scope
(Subp
) then
5222 Hom
:= Homonym
(Hom
);
5228 -----------------------------------
5229 -- In_Library_Level_Package_Body --
5230 -----------------------------------
5232 function In_Library_Level_Package_Body
(Id
: Entity_Id
) return Boolean is
5234 -- First determine whether the entity appears at the library level, then
5235 -- look at the containing unit.
5237 if Is_Library_Level_Entity
(Id
) then
5239 Container
: constant Node_Id
:= Cunit
(Get_Source_Unit
(Id
));
5242 return Nkind
(Unit
(Container
)) = N_Package_Body
;
5247 end In_Library_Level_Package_Body
;
5249 ------------------------------
5250 -- In_Unconditional_Context --
5251 ------------------------------
5253 function In_Unconditional_Context
(Node
: Node_Id
) return Boolean is
5258 while Present
(P
) loop
5260 when N_Subprogram_Body
=> return True;
5261 when N_If_Statement
=> return False;
5262 when N_Loop_Statement
=> return False;
5263 when N_Case_Statement
=> return False;
5264 when others => P
:= Parent
(P
);
5269 end In_Unconditional_Context
;
5275 procedure Insert_Action
(Assoc_Node
: Node_Id
; Ins_Action
: Node_Id
) is
5277 if Present
(Ins_Action
) then
5278 Insert_Actions
(Assoc_Node
, New_List
(Ins_Action
));
5282 -- Version with check(s) suppressed
5284 procedure Insert_Action
5285 (Assoc_Node
: Node_Id
; Ins_Action
: Node_Id
; Suppress
: Check_Id
)
5288 Insert_Actions
(Assoc_Node
, New_List
(Ins_Action
), Suppress
);
5291 -------------------------
5292 -- Insert_Action_After --
5293 -------------------------
5295 procedure Insert_Action_After
5296 (Assoc_Node
: Node_Id
;
5297 Ins_Action
: Node_Id
)
5300 Insert_Actions_After
(Assoc_Node
, New_List
(Ins_Action
));
5301 end Insert_Action_After
;
5303 --------------------
5304 -- Insert_Actions --
5305 --------------------
5307 procedure Insert_Actions
(Assoc_Node
: Node_Id
; Ins_Actions
: List_Id
) is
5311 Wrapped_Node
: Node_Id
:= Empty
;
5314 if No
(Ins_Actions
) or else Is_Empty_List
(Ins_Actions
) then
5318 -- Ignore insert of actions from inside default expression (or other
5319 -- similar "spec expression") in the special spec-expression analyze
5320 -- mode. Any insertions at this point have no relevance, since we are
5321 -- only doing the analyze to freeze the types of any static expressions.
5322 -- See section "Handling of Default Expressions" in the spec of package
5323 -- Sem for further details.
5325 if In_Spec_Expression
then
5329 -- If the action derives from stuff inside a record, then the actions
5330 -- are attached to the current scope, to be inserted and analyzed on
5331 -- exit from the scope. The reason for this is that we may also be
5332 -- generating freeze actions at the same time, and they must eventually
5333 -- be elaborated in the correct order.
5335 if Is_Record_Type
(Current_Scope
)
5336 and then not Is_Frozen
(Current_Scope
)
5338 if No
(Scope_Stack
.Table
5339 (Scope_Stack
.Last
).Pending_Freeze_Actions
)
5341 Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
:=
5346 Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
);
5352 -- We now intend to climb up the tree to find the right point to
5353 -- insert the actions. We start at Assoc_Node, unless this node is a
5354 -- subexpression in which case we start with its parent. We do this for
5355 -- two reasons. First it speeds things up. Second, if Assoc_Node is
5356 -- itself one of the special nodes like N_And_Then, then we assume that
5357 -- an initial request to insert actions for such a node does not expect
5358 -- the actions to get deposited in the node for later handling when the
5359 -- node is expanded, since clearly the node is being dealt with by the
5360 -- caller. Note that in the subexpression case, N is always the child we
5363 -- N_Raise_xxx_Error is an annoying special case, it is a statement
5364 -- if it has type Standard_Void_Type, and a subexpression otherwise.
5365 -- Procedure calls, and similarly procedure attribute references, are
5368 if Nkind
(Assoc_Node
) in N_Subexpr
5369 and then (Nkind
(Assoc_Node
) not in N_Raise_xxx_Error
5370 or else Etype
(Assoc_Node
) /= Standard_Void_Type
)
5371 and then Nkind
(Assoc_Node
) /= N_Procedure_Call_Statement
5372 and then (Nkind
(Assoc_Node
) /= N_Attribute_Reference
5373 or else not Is_Procedure_Attribute_Name
5374 (Attribute_Name
(Assoc_Node
)))
5377 P
:= Parent
(Assoc_Node
);
5379 -- Non-subexpression case. Note that N is initially Empty in this case
5380 -- (N is only guaranteed Non-Empty in the subexpr case).
5387 -- Capture root of the transient scope
5389 if Scope_Is_Transient
then
5390 Wrapped_Node
:= Node_To_Be_Wrapped
;
5394 pragma Assert
(Present
(P
));
5396 -- Make sure that inserted actions stay in the transient scope
5398 if Present
(Wrapped_Node
) and then N
= Wrapped_Node
then
5399 Store_Before_Actions_In_Scope
(Ins_Actions
);
5405 -- Case of right operand of AND THEN or OR ELSE. Put the actions
5406 -- in the Actions field of the right operand. They will be moved
5407 -- out further when the AND THEN or OR ELSE operator is expanded.
5408 -- Nothing special needs to be done for the left operand since
5409 -- in that case the actions are executed unconditionally.
5411 when N_Short_Circuit
=>
5412 if N
= Right_Opnd
(P
) then
5414 -- We are now going to either append the actions to the
5415 -- actions field of the short-circuit operation. We will
5416 -- also analyze the actions now.
5418 -- This analysis is really too early, the proper thing would
5419 -- be to just park them there now, and only analyze them if
5420 -- we find we really need them, and to it at the proper
5421 -- final insertion point. However attempting to this proved
5422 -- tricky, so for now we just kill current values before and
5423 -- after the analyze call to make sure we avoid peculiar
5424 -- optimizations from this out of order insertion.
5426 Kill_Current_Values
;
5428 -- If P has already been expanded, we can't park new actions
5429 -- on it, so we need to expand them immediately, introducing
5430 -- an Expression_With_Actions. N can't be an expression
5431 -- with actions, or else then the actions would have been
5432 -- inserted at an inner level.
5434 if Analyzed
(P
) then
5435 pragma Assert
(Nkind
(N
) /= N_Expression_With_Actions
);
5437 Make_Expression_With_Actions
(Sloc
(N
),
5438 Actions
=> Ins_Actions
,
5439 Expression
=> Relocate_Node
(N
)));
5440 Analyze_And_Resolve
(N
);
5442 elsif Present
(Actions
(P
)) then
5443 Insert_List_After_And_Analyze
5444 (Last
(Actions
(P
)), Ins_Actions
);
5446 Set_Actions
(P
, Ins_Actions
);
5447 Analyze_List
(Actions
(P
));
5450 Kill_Current_Values
;
5455 -- Then or Else dependent expression of an if expression. Add
5456 -- actions to Then_Actions or Else_Actions field as appropriate.
5457 -- The actions will be moved further out when the if is expanded.
5459 when N_If_Expression
=>
5461 ThenX
: constant Node_Id
:= Next
(First
(Expressions
(P
)));
5462 ElseX
: constant Node_Id
:= Next
(ThenX
);
5465 -- If the enclosing expression is already analyzed, as
5466 -- is the case for nested elaboration checks, insert the
5467 -- conditional further out.
5469 if Analyzed
(P
) then
5472 -- Actions belong to the then expression, temporarily place
5473 -- them as Then_Actions of the if expression. They will be
5474 -- moved to the proper place later when the if expression
5477 elsif N
= ThenX
then
5478 if Present
(Then_Actions
(P
)) then
5479 Insert_List_After_And_Analyze
5480 (Last
(Then_Actions
(P
)), Ins_Actions
);
5482 Set_Then_Actions
(P
, Ins_Actions
);
5483 Analyze_List
(Then_Actions
(P
));
5488 -- Actions belong to the else expression, temporarily place
5489 -- them as Else_Actions of the if expression. They will be
5490 -- moved to the proper place later when the if expression
5493 elsif N
= ElseX
then
5494 if Present
(Else_Actions
(P
)) then
5495 Insert_List_After_And_Analyze
5496 (Last
(Else_Actions
(P
)), Ins_Actions
);
5498 Set_Else_Actions
(P
, Ins_Actions
);
5499 Analyze_List
(Else_Actions
(P
));
5504 -- Actions belong to the condition. In this case they are
5505 -- unconditionally executed, and so we can continue the
5506 -- search for the proper insert point.
5513 -- Alternative of case expression, we place the action in the
5514 -- Actions field of the case expression alternative, this will
5515 -- be handled when the case expression is expanded.
5517 when N_Case_Expression_Alternative
=>
5518 if Present
(Actions
(P
)) then
5519 Insert_List_After_And_Analyze
5520 (Last
(Actions
(P
)), Ins_Actions
);
5522 Set_Actions
(P
, Ins_Actions
);
5523 Analyze_List
(Actions
(P
));
5528 -- Case of appearing within an Expressions_With_Actions node. When
5529 -- the new actions come from the expression of the expression with
5530 -- actions, they must be added to the existing actions. The other
5531 -- alternative is when the new actions are related to one of the
5532 -- existing actions of the expression with actions, and should
5533 -- never reach here: if actions are inserted on a statement
5534 -- within the Actions of an expression with actions, or on some
5535 -- sub-expression of such a statement, then the outermost proper
5536 -- insertion point is right before the statement, and we should
5537 -- never climb up as far as the N_Expression_With_Actions itself.
5539 when N_Expression_With_Actions
=>
5540 if N
= Expression
(P
) then
5541 if Is_Empty_List
(Actions
(P
)) then
5542 Append_List_To
(Actions
(P
), Ins_Actions
);
5543 Analyze_List
(Actions
(P
));
5545 Insert_List_After_And_Analyze
5546 (Last
(Actions
(P
)), Ins_Actions
);
5552 raise Program_Error
;
5555 -- Case of appearing in the condition of a while expression or
5556 -- elsif. We insert the actions into the Condition_Actions field.
5557 -- They will be moved further out when the while loop or elsif
5561 | N_Iteration_Scheme
5563 if N
= Condition
(P
) then
5564 if Present
(Condition_Actions
(P
)) then
5565 Insert_List_After_And_Analyze
5566 (Last
(Condition_Actions
(P
)), Ins_Actions
);
5568 Set_Condition_Actions
(P
, Ins_Actions
);
5570 -- Set the parent of the insert actions explicitly. This
5571 -- is not a syntactic field, but we need the parent field
5572 -- set, in particular so that freeze can understand that
5573 -- it is dealing with condition actions, and properly
5574 -- insert the freezing actions.
5576 Set_Parent
(Ins_Actions
, P
);
5577 Analyze_List
(Condition_Actions
(P
));
5583 -- Statements, declarations, pragmas, representation clauses
5588 N_Procedure_Call_Statement
5589 | N_Statement_Other_Than_Procedure_Call
5595 -- Representation_Clause
5598 | N_Attribute_Definition_Clause
5599 | N_Enumeration_Representation_Clause
5600 | N_Record_Representation_Clause
5604 | N_Abstract_Subprogram_Declaration
5606 | N_Exception_Declaration
5607 | N_Exception_Renaming_Declaration
5608 | N_Expression_Function
5609 | N_Formal_Abstract_Subprogram_Declaration
5610 | N_Formal_Concrete_Subprogram_Declaration
5611 | N_Formal_Object_Declaration
5612 | N_Formal_Type_Declaration
5613 | N_Full_Type_Declaration
5614 | N_Function_Instantiation
5615 | N_Generic_Function_Renaming_Declaration
5616 | N_Generic_Package_Declaration
5617 | N_Generic_Package_Renaming_Declaration
5618 | N_Generic_Procedure_Renaming_Declaration
5619 | N_Generic_Subprogram_Declaration
5620 | N_Implicit_Label_Declaration
5621 | N_Incomplete_Type_Declaration
5622 | N_Number_Declaration
5623 | N_Object_Declaration
5624 | N_Object_Renaming_Declaration
5626 | N_Package_Body_Stub
5627 | N_Package_Declaration
5628 | N_Package_Instantiation
5629 | N_Package_Renaming_Declaration
5630 | N_Private_Extension_Declaration
5631 | N_Private_Type_Declaration
5632 | N_Procedure_Instantiation
5634 | N_Protected_Body_Stub
5635 | N_Protected_Type_Declaration
5636 | N_Single_Task_Declaration
5638 | N_Subprogram_Body_Stub
5639 | N_Subprogram_Declaration
5640 | N_Subprogram_Renaming_Declaration
5641 | N_Subtype_Declaration
5644 | N_Task_Type_Declaration
5646 -- Use clauses can appear in lists of declarations
5648 | N_Use_Package_Clause
5651 -- Freeze entity behaves like a declaration or statement
5654 | N_Freeze_Generic_Entity
5656 -- Do not insert here if the item is not a list member (this
5657 -- happens for example with a triggering statement, and the
5658 -- proper approach is to insert before the entire select).
5660 if not Is_List_Member
(P
) then
5663 -- Do not insert if parent of P is an N_Component_Association
5664 -- node (i.e. we are in the context of an N_Aggregate or
5665 -- N_Extension_Aggregate node. In this case we want to insert
5666 -- before the entire aggregate.
5668 elsif Nkind
(Parent
(P
)) = N_Component_Association
then
5671 -- Do not insert if the parent of P is either an N_Variant node
5672 -- or an N_Record_Definition node, meaning in either case that
5673 -- P is a member of a component list, and that therefore the
5674 -- actions should be inserted outside the complete record
5677 elsif Nkind_In
(Parent
(P
), N_Variant
, N_Record_Definition
) then
5680 -- Do not insert freeze nodes within the loop generated for
5681 -- an aggregate, because they may be elaborated too late for
5682 -- subsequent use in the back end: within a package spec the
5683 -- loop is part of the elaboration procedure and is only
5684 -- elaborated during the second pass.
5686 -- If the loop comes from source, or the entity is local to the
5687 -- loop itself it must remain within.
5689 elsif Nkind
(Parent
(P
)) = N_Loop_Statement
5690 and then not Comes_From_Source
(Parent
(P
))
5691 and then Nkind
(First
(Ins_Actions
)) = N_Freeze_Entity
5693 Scope
(Entity
(First
(Ins_Actions
))) /= Current_Scope
5697 -- Otherwise we can go ahead and do the insertion
5699 elsif P
= Wrapped_Node
then
5700 Store_Before_Actions_In_Scope
(Ins_Actions
);
5704 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
5708 -- A special case, N_Raise_xxx_Error can act either as a statement
5709 -- or a subexpression. We tell the difference by looking at the
5710 -- Etype. It is set to Standard_Void_Type in the statement case.
5712 when N_Raise_xxx_Error
=>
5713 if Etype
(P
) = Standard_Void_Type
then
5714 if P
= Wrapped_Node
then
5715 Store_Before_Actions_In_Scope
(Ins_Actions
);
5717 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
5722 -- In the subexpression case, keep climbing
5728 -- If a component association appears within a loop created for
5729 -- an array aggregate, attach the actions to the association so
5730 -- they can be subsequently inserted within the loop. For other
5731 -- component associations insert outside of the aggregate. For
5732 -- an association that will generate a loop, its Loop_Actions
5733 -- attribute is already initialized (see exp_aggr.adb).
5735 -- The list of Loop_Actions can in turn generate additional ones,
5736 -- that are inserted before the associated node. If the associated
5737 -- node is outside the aggregate, the new actions are collected
5738 -- at the end of the Loop_Actions, to respect the order in which
5739 -- they are to be elaborated.
5741 when N_Component_Association
5742 | N_Iterated_Component_Association
5744 if Nkind
(Parent
(P
)) = N_Aggregate
5745 and then Present
(Loop_Actions
(P
))
5747 if Is_Empty_List
(Loop_Actions
(P
)) then
5748 Set_Loop_Actions
(P
, Ins_Actions
);
5749 Analyze_List
(Ins_Actions
);
5755 -- Check whether these actions were generated by a
5756 -- declaration that is part of the Loop_Actions for
5757 -- the component_association.
5760 while Present
(Decl
) loop
5761 exit when Parent
(Decl
) = P
5762 and then Is_List_Member
(Decl
)
5764 List_Containing
(Decl
) = Loop_Actions
(P
);
5765 Decl
:= Parent
(Decl
);
5768 if Present
(Decl
) then
5769 Insert_List_Before_And_Analyze
5770 (Decl
, Ins_Actions
);
5772 Insert_List_After_And_Analyze
5773 (Last
(Loop_Actions
(P
)), Ins_Actions
);
5784 -- Another special case, an attribute denoting a procedure call
5786 when N_Attribute_Reference
=>
5787 if Is_Procedure_Attribute_Name
(Attribute_Name
(P
)) then
5788 if P
= Wrapped_Node
then
5789 Store_Before_Actions_In_Scope
(Ins_Actions
);
5791 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
5796 -- In the subexpression case, keep climbing
5802 -- A contract node should not belong to the tree
5805 raise Program_Error
;
5807 -- For all other node types, keep climbing tree
5809 when N_Abortable_Part
5810 | N_Accept_Alternative
5811 | N_Access_Definition
5812 | N_Access_Function_Definition
5813 | N_Access_Procedure_Definition
5814 | N_Access_To_Object_Definition
5817 | N_Aspect_Specification
5819 | N_Case_Statement_Alternative
5820 | N_Character_Literal
5821 | N_Compilation_Unit
5822 | N_Compilation_Unit_Aux
5823 | N_Component_Clause
5824 | N_Component_Declaration
5825 | N_Component_Definition
5827 | N_Constrained_Array_Definition
5828 | N_Decimal_Fixed_Point_Definition
5829 | N_Defining_Character_Literal
5830 | N_Defining_Identifier
5831 | N_Defining_Operator_Symbol
5832 | N_Defining_Program_Unit_Name
5833 | N_Delay_Alternative
5835 | N_Delta_Constraint
5836 | N_Derived_Type_Definition
5838 | N_Digits_Constraint
5839 | N_Discriminant_Association
5840 | N_Discriminant_Specification
5842 | N_Entry_Body_Formal_Part
5843 | N_Entry_Call_Alternative
5844 | N_Entry_Declaration
5845 | N_Entry_Index_Specification
5846 | N_Enumeration_Type_Definition
5848 | N_Exception_Handler
5850 | N_Explicit_Dereference
5851 | N_Extension_Aggregate
5852 | N_Floating_Point_Definition
5853 | N_Formal_Decimal_Fixed_Point_Definition
5854 | N_Formal_Derived_Type_Definition
5855 | N_Formal_Discrete_Type_Definition
5856 | N_Formal_Floating_Point_Definition
5857 | N_Formal_Modular_Type_Definition
5858 | N_Formal_Ordinary_Fixed_Point_Definition
5859 | N_Formal_Package_Declaration
5860 | N_Formal_Private_Type_Definition
5861 | N_Formal_Incomplete_Type_Definition
5862 | N_Formal_Signed_Integer_Type_Definition
5864 | N_Function_Specification
5865 | N_Generic_Association
5866 | N_Handled_Sequence_Of_Statements
5869 | N_Index_Or_Discriminant_Constraint
5870 | N_Indexed_Component
5872 | N_Iterator_Specification
5875 | N_Loop_Parameter_Specification
5877 | N_Modular_Type_Definition
5903 | N_Op_Shift_Right_Arithmetic
5907 | N_Ordinary_Fixed_Point_Definition
5909 | N_Package_Specification
5910 | N_Parameter_Association
5911 | N_Parameter_Specification
5912 | N_Pop_Constraint_Error_Label
5913 | N_Pop_Program_Error_Label
5914 | N_Pop_Storage_Error_Label
5915 | N_Pragma_Argument_Association
5916 | N_Procedure_Specification
5917 | N_Protected_Definition
5918 | N_Push_Constraint_Error_Label
5919 | N_Push_Program_Error_Label
5920 | N_Push_Storage_Error_Label
5921 | N_Qualified_Expression
5922 | N_Quantified_Expression
5923 | N_Raise_Expression
5925 | N_Range_Constraint
5927 | N_Real_Range_Specification
5928 | N_Record_Definition
5930 | N_SCIL_Dispatch_Table_Tag_Init
5931 | N_SCIL_Dispatching_Call
5932 | N_SCIL_Membership_Test
5933 | N_Selected_Component
5934 | N_Signed_Integer_Type_Definition
5935 | N_Single_Protected_Declaration
5938 | N_Subtype_Indication
5942 | N_Terminate_Alternative
5943 | N_Triggering_Alternative
5945 | N_Unchecked_Expression
5946 | N_Unchecked_Type_Conversion
5947 | N_Unconstrained_Array_Definition
5952 | N_Validate_Unchecked_Conversion
5958 -- If we fall through above tests, keep climbing tree
5962 if Nkind
(Parent
(N
)) = N_Subunit
then
5964 -- This is the proper body corresponding to a stub. Insertion must
5965 -- be done at the point of the stub, which is in the declarative
5966 -- part of the parent unit.
5968 P
:= Corresponding_Stub
(Parent
(N
));
5976 -- Version with check(s) suppressed
5978 procedure Insert_Actions
5979 (Assoc_Node
: Node_Id
;
5980 Ins_Actions
: List_Id
;
5981 Suppress
: Check_Id
)
5984 if Suppress
= All_Checks
then
5986 Sva
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
5988 Scope_Suppress
.Suppress
:= (others => True);
5989 Insert_Actions
(Assoc_Node
, Ins_Actions
);
5990 Scope_Suppress
.Suppress
:= Sva
;
5995 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
5997 Scope_Suppress
.Suppress
(Suppress
) := True;
5998 Insert_Actions
(Assoc_Node
, Ins_Actions
);
5999 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
6004 --------------------------
6005 -- Insert_Actions_After --
6006 --------------------------
6008 procedure Insert_Actions_After
6009 (Assoc_Node
: Node_Id
;
6010 Ins_Actions
: List_Id
)
6013 if Scope_Is_Transient
and then Assoc_Node
= Node_To_Be_Wrapped
then
6014 Store_After_Actions_In_Scope
(Ins_Actions
);
6016 Insert_List_After_And_Analyze
(Assoc_Node
, Ins_Actions
);
6018 end Insert_Actions_After
;
6020 ------------------------
6021 -- Insert_Declaration --
6022 ------------------------
6024 procedure Insert_Declaration
(N
: Node_Id
; Decl
: Node_Id
) is
6028 pragma Assert
(Nkind
(N
) in N_Subexpr
);
6030 -- Climb until we find a procedure or a package
6034 pragma Assert
(Present
(Parent
(P
)));
6037 if Is_List_Member
(P
) then
6038 exit when Nkind_In
(Parent
(P
), N_Package_Specification
,
6041 -- Special handling for handled sequence of statements, we must
6042 -- insert in the statements not the exception handlers!
6044 if Nkind
(Parent
(P
)) = N_Handled_Sequence_Of_Statements
then
6045 P
:= First
(Statements
(Parent
(P
)));
6051 -- Now do the insertion
6053 Insert_Before
(P
, Decl
);
6055 end Insert_Declaration
;
6057 ---------------------------------
6058 -- Insert_Library_Level_Action --
6059 ---------------------------------
6061 procedure Insert_Library_Level_Action
(N
: Node_Id
) is
6062 Aux
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Main_Unit
));
6065 Push_Scope
(Cunit_Entity
(Main_Unit
));
6066 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
6068 if No
(Actions
(Aux
)) then
6069 Set_Actions
(Aux
, New_List
(N
));
6071 Append
(N
, Actions
(Aux
));
6076 end Insert_Library_Level_Action
;
6078 ----------------------------------
6079 -- Insert_Library_Level_Actions --
6080 ----------------------------------
6082 procedure Insert_Library_Level_Actions
(L
: List_Id
) is
6083 Aux
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Main_Unit
));
6086 if Is_Non_Empty_List
(L
) then
6087 Push_Scope
(Cunit_Entity
(Main_Unit
));
6088 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
6090 if No
(Actions
(Aux
)) then
6091 Set_Actions
(Aux
, L
);
6094 Insert_List_After_And_Analyze
(Last
(Actions
(Aux
)), L
);
6099 end Insert_Library_Level_Actions
;
6101 ----------------------
6102 -- Inside_Init_Proc --
6103 ----------------------
6105 function Inside_Init_Proc
return Boolean is
6110 while Present
(S
) and then S
/= Standard_Standard
loop
6111 if Is_Init_Proc
(S
) then
6119 end Inside_Init_Proc
;
6121 ----------------------------
6122 -- Is_All_Null_Statements --
6123 ----------------------------
6125 function Is_All_Null_Statements
(L
: List_Id
) return Boolean is
6130 while Present
(Stm
) loop
6131 if Nkind
(Stm
) /= N_Null_Statement
then
6139 end Is_All_Null_Statements
;
6141 --------------------------------------------------
6142 -- Is_Displacement_Of_Object_Or_Function_Result --
6143 --------------------------------------------------
6145 function Is_Displacement_Of_Object_Or_Function_Result
6146 (Obj_Id
: Entity_Id
) return Boolean
6148 function Is_Controlled_Function_Call
(N
: Node_Id
) return Boolean;
6149 -- Determine if particular node denotes a controlled function call. The
6150 -- call may have been heavily expanded.
6152 function Is_Displace_Call
(N
: Node_Id
) return Boolean;
6153 -- Determine whether a particular node is a call to Ada.Tags.Displace.
6154 -- The call might be nested within other actions such as conversions.
6156 function Is_Source_Object
(N
: Node_Id
) return Boolean;
6157 -- Determine whether a particular node denotes a source object
6159 ---------------------------------
6160 -- Is_Controlled_Function_Call --
6161 ---------------------------------
6163 function Is_Controlled_Function_Call
(N
: Node_Id
) return Boolean is
6164 Expr
: Node_Id
:= Original_Node
(N
);
6167 -- When a function call appears in Object.Operation format, the
6168 -- original representation has several possible forms depending on
6169 -- the availability and form of actual parameters:
6171 -- Obj.Func N_Selected_Component
6172 -- Obj.Func (Actual) N_Indexed_Component
6173 -- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
6174 -- N_Selected_Component
6177 if Nkind
(Expr
) = N_Function_Call
then
6178 Expr
:= Name
(Expr
);
6180 -- "Obj.Func (Actual)" case
6182 elsif Nkind
(Expr
) = N_Indexed_Component
then
6183 Expr
:= Prefix
(Expr
);
6185 -- "Obj.Func" or "Obj.Func (Formal => Actual) case
6187 elsif Nkind
(Expr
) = N_Selected_Component
then
6188 Expr
:= Selector_Name
(Expr
);
6196 Nkind
(Expr
) in N_Has_Entity
6197 and then Present
(Entity
(Expr
))
6198 and then Ekind
(Entity
(Expr
)) = E_Function
6199 and then Needs_Finalization
(Etype
(Entity
(Expr
)));
6200 end Is_Controlled_Function_Call
;
6202 ----------------------
6203 -- Is_Displace_Call --
6204 ----------------------
6206 function Is_Displace_Call
(N
: Node_Id
) return Boolean is
6207 Call
: Node_Id
:= N
;
6210 -- Strip various actions which may precede a call to Displace
6213 if Nkind
(Call
) = N_Explicit_Dereference
then
6214 Call
:= Prefix
(Call
);
6216 elsif Nkind_In
(Call
, N_Type_Conversion
,
6217 N_Unchecked_Type_Conversion
)
6219 Call
:= Expression
(Call
);
6228 and then Nkind
(Call
) = N_Function_Call
6229 and then Is_RTE
(Entity
(Name
(Call
)), RE_Displace
);
6230 end Is_Displace_Call
;
6232 ----------------------
6233 -- Is_Source_Object --
6234 ----------------------
6236 function Is_Source_Object
(N
: Node_Id
) return Boolean is
6240 and then Nkind
(N
) in N_Has_Entity
6241 and then Is_Object
(Entity
(N
))
6242 and then Comes_From_Source
(N
);
6243 end Is_Source_Object
;
6247 Decl
: constant Node_Id
:= Parent
(Obj_Id
);
6248 Obj_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Obj_Id
));
6249 Orig_Decl
: constant Node_Id
:= Original_Node
(Decl
);
6251 -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
6256 -- Obj : CW_Type := Function_Call (...);
6260 -- Tmp : ... := Function_Call (...)'reference;
6261 -- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp));
6263 -- where the return type of the function and the class-wide type require
6264 -- dispatch table pointer displacement.
6268 -- Obj : CW_Type := Src_Obj;
6272 -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
6274 -- where the type of the source object and the class-wide type require
6275 -- dispatch table pointer displacement.
6278 Nkind
(Decl
) = N_Object_Renaming_Declaration
6279 and then Nkind
(Orig_Decl
) = N_Object_Declaration
6280 and then Comes_From_Source
(Orig_Decl
)
6281 and then Is_Class_Wide_Type
(Obj_Typ
)
6282 and then Is_Displace_Call
(Renamed_Object
(Obj_Id
))
6284 (Is_Controlled_Function_Call
(Expression
(Orig_Decl
))
6285 or else Is_Source_Object
(Expression
(Orig_Decl
)));
6286 end Is_Displacement_Of_Object_Or_Function_Result
;
6288 ------------------------------
6289 -- Is_Finalizable_Transient --
6290 ------------------------------
6292 function Is_Finalizable_Transient
6294 Rel_Node
: Node_Id
) return Boolean
6296 Obj_Id
: constant Entity_Id
:= Defining_Identifier
(Decl
);
6297 Obj_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Obj_Id
));
6299 function Initialized_By_Access
(Trans_Id
: Entity_Id
) return Boolean;
6300 -- Determine whether transient object Trans_Id is initialized either
6301 -- by a function call which returns an access type or simply renames
6304 function Initialized_By_Aliased_BIP_Func_Call
6305 (Trans_Id
: Entity_Id
) return Boolean;
6306 -- Determine whether transient object Trans_Id is initialized by a
6307 -- build-in-place function call where the BIPalloc parameter is of
6308 -- value 1 and BIPaccess is not null. This case creates an aliasing
6309 -- between the returned value and the value denoted by BIPaccess.
6312 (Trans_Id
: Entity_Id
;
6313 First_Stmt
: Node_Id
) return Boolean;
6314 -- Determine whether transient object Trans_Id has been renamed or
6315 -- aliased through 'reference in the statement list starting from
6318 function Is_Allocated
(Trans_Id
: Entity_Id
) return Boolean;
6319 -- Determine whether transient object Trans_Id is allocated on the heap
6321 function Is_Iterated_Container
6322 (Trans_Id
: Entity_Id
;
6323 First_Stmt
: Node_Id
) return Boolean;
6324 -- Determine whether transient object Trans_Id denotes a container which
6325 -- is in the process of being iterated in the statement list starting
6328 ---------------------------
6329 -- Initialized_By_Access --
6330 ---------------------------
6332 function Initialized_By_Access
(Trans_Id
: Entity_Id
) return Boolean is
6333 Expr
: constant Node_Id
:= Expression
(Parent
(Trans_Id
));
6338 and then Nkind
(Expr
) /= N_Reference
6339 and then Is_Access_Type
(Etype
(Expr
));
6340 end Initialized_By_Access
;
6342 ------------------------------------------
6343 -- Initialized_By_Aliased_BIP_Func_Call --
6344 ------------------------------------------
6346 function Initialized_By_Aliased_BIP_Func_Call
6347 (Trans_Id
: Entity_Id
) return Boolean
6349 Call
: Node_Id
:= Expression
(Parent
(Trans_Id
));
6352 -- Build-in-place calls usually appear in 'reference format
6354 if Nkind
(Call
) = N_Reference
then
6355 Call
:= Prefix
(Call
);
6358 if Is_Build_In_Place_Function_Call
(Call
) then
6360 Access_Nam
: Name_Id
:= No_Name
;
6361 Access_OK
: Boolean := False;
6363 Alloc_Nam
: Name_Id
:= No_Name
;
6364 Alloc_OK
: Boolean := False;
6366 Func_Id
: Entity_Id
;
6370 -- Examine all parameter associations of the function call
6372 Param
:= First
(Parameter_Associations
(Call
));
6373 while Present
(Param
) loop
6374 if Nkind
(Param
) = N_Parameter_Association
6375 and then Nkind
(Selector_Name
(Param
)) = N_Identifier
6377 Actual
:= Explicit_Actual_Parameter
(Param
);
6378 Formal
:= Selector_Name
(Param
);
6380 -- Construct the names of formals BIPaccess and BIPalloc
6381 -- using the function name retrieved from an arbitrary
6384 if Access_Nam
= No_Name
6385 and then Alloc_Nam
= No_Name
6386 and then Present
(Entity
(Formal
))
6388 Func_Id
:= Scope
(Entity
(Formal
));
6391 New_External_Name
(Chars
(Func_Id
),
6392 BIP_Formal_Suffix
(BIP_Object_Access
));
6395 New_External_Name
(Chars
(Func_Id
),
6396 BIP_Formal_Suffix
(BIP_Alloc_Form
));
6399 -- A match for BIPaccess => Temp has been found
6401 if Chars
(Formal
) = Access_Nam
6402 and then Nkind
(Actual
) /= N_Null
6407 -- A match for BIPalloc => 1 has been found
6409 if Chars
(Formal
) = Alloc_Nam
6410 and then Nkind
(Actual
) = N_Integer_Literal
6411 and then Intval
(Actual
) = Uint_1
6420 return Access_OK
and Alloc_OK
;
6425 end Initialized_By_Aliased_BIP_Func_Call
;
6432 (Trans_Id
: Entity_Id
;
6433 First_Stmt
: Node_Id
) return Boolean
6435 function Find_Renamed_Object
(Ren_Decl
: Node_Id
) return Entity_Id
;
6436 -- Given an object renaming declaration, retrieve the entity of the
6437 -- renamed name. Return Empty if the renamed name is anything other
6438 -- than a variable or a constant.
6440 -------------------------
6441 -- Find_Renamed_Object --
6442 -------------------------
6444 function Find_Renamed_Object
(Ren_Decl
: Node_Id
) return Entity_Id
is
6445 Ren_Obj
: Node_Id
:= Empty
;
6447 function Find_Object
(N
: Node_Id
) return Traverse_Result
;
6448 -- Try to detect an object which is either a constant or a
6455 function Find_Object
(N
: Node_Id
) return Traverse_Result
is
6457 -- Stop the search once a constant or a variable has been
6460 if Nkind
(N
) = N_Identifier
6461 and then Present
(Entity
(N
))
6462 and then Ekind_In
(Entity
(N
), E_Constant
, E_Variable
)
6464 Ren_Obj
:= Entity
(N
);
6471 procedure Search
is new Traverse_Proc
(Find_Object
);
6475 Typ
: constant Entity_Id
:= Etype
(Defining_Identifier
(Ren_Decl
));
6477 -- Start of processing for Find_Renamed_Object
6480 -- Actions related to dispatching calls may appear as renamings of
6481 -- tags. Do not process this type of renaming because it does not
6482 -- use the actual value of the object.
6484 if not Is_RTE
(Typ
, RE_Tag_Ptr
) then
6485 Search
(Name
(Ren_Decl
));
6489 end Find_Renamed_Object
;
6494 Ren_Obj
: Entity_Id
;
6497 -- Start of processing for Is_Aliased
6500 -- A controlled transient object is not considered aliased when it
6501 -- appears inside an expression_with_actions node even when there are
6502 -- explicit aliases of it:
6505 -- Trans_Id : Ctrl_Typ ...; -- transient object
6506 -- Alias : ... := Trans_Id; -- object is aliased
6507 -- Val : constant Boolean :=
6508 -- ... Alias ...; -- aliasing ends
6509 -- <finalize Trans_Id> -- object safe to finalize
6512 -- Expansion ensures that all aliases are encapsulated in the actions
6513 -- list and do not leak to the expression by forcing the evaluation
6514 -- of the expression.
6516 if Nkind
(Rel_Node
) = N_Expression_With_Actions
then
6519 -- Otherwise examine the statements after the controlled transient
6520 -- object and look for various forms of aliasing.
6524 while Present
(Stmt
) loop
6525 if Nkind
(Stmt
) = N_Object_Declaration
then
6526 Expr
:= Expression
(Stmt
);
6528 -- Aliasing of the form:
6529 -- Obj : ... := Trans_Id'reference;
6532 and then Nkind
(Expr
) = N_Reference
6533 and then Nkind
(Prefix
(Expr
)) = N_Identifier
6534 and then Entity
(Prefix
(Expr
)) = Trans_Id
6539 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
then
6540 Ren_Obj
:= Find_Renamed_Object
(Stmt
);
6542 -- Aliasing of the form:
6543 -- Obj : ... renames ... Trans_Id ...;
6545 if Present
(Ren_Obj
) and then Ren_Obj
= Trans_Id
then
6561 function Is_Allocated
(Trans_Id
: Entity_Id
) return Boolean is
6562 Expr
: constant Node_Id
:= Expression
(Parent
(Trans_Id
));
6565 Is_Access_Type
(Etype
(Trans_Id
))
6566 and then Present
(Expr
)
6567 and then Nkind
(Expr
) = N_Allocator
;
6570 ---------------------------
6571 -- Is_Iterated_Container --
6572 ---------------------------
6574 function Is_Iterated_Container
6575 (Trans_Id
: Entity_Id
;
6576 First_Stmt
: Node_Id
) return Boolean
6586 -- It is not possible to iterate over containers in non-Ada 2012 code
6588 if Ada_Version
< Ada_2012
then
6592 Typ
:= Etype
(Trans_Id
);
6594 -- Handle access type created for secondary stack use
6596 if Is_Access_Type
(Typ
) then
6597 Typ
:= Designated_Type
(Typ
);
6600 -- Look for aspect Default_Iterator. It may be part of a type
6601 -- declaration for a container, or inherited from a base type
6604 Aspect
:= Find_Value_Of_Aspect
(Typ
, Aspect_Default_Iterator
);
6606 if Present
(Aspect
) then
6607 Iter
:= Entity
(Aspect
);
6609 -- Examine the statements following the container object and
6610 -- look for a call to the default iterate routine where the
6611 -- first parameter is the transient. Such a call appears as:
6613 -- It : Access_To_CW_Iterator :=
6614 -- Iterate (Tran_Id.all, ...)'reference;
6617 while Present
(Stmt
) loop
6619 -- Detect an object declaration which is initialized by a
6620 -- secondary stack function call.
6622 if Nkind
(Stmt
) = N_Object_Declaration
6623 and then Present
(Expression
(Stmt
))
6624 and then Nkind
(Expression
(Stmt
)) = N_Reference
6625 and then Nkind
(Prefix
(Expression
(Stmt
))) = N_Function_Call
6627 Call
:= Prefix
(Expression
(Stmt
));
6629 -- The call must invoke the default iterate routine of
6630 -- the container and the transient object must appear as
6631 -- the first actual parameter. Skip any calls whose names
6632 -- are not entities.
6634 if Is_Entity_Name
(Name
(Call
))
6635 and then Entity
(Name
(Call
)) = Iter
6636 and then Present
(Parameter_Associations
(Call
))
6638 Param
:= First
(Parameter_Associations
(Call
));
6640 if Nkind
(Param
) = N_Explicit_Dereference
6641 and then Entity
(Prefix
(Param
)) = Trans_Id
6653 end Is_Iterated_Container
;
6657 Desig
: Entity_Id
:= Obj_Typ
;
6659 -- Start of processing for Is_Finalizable_Transient
6662 -- Handle access types
6664 if Is_Access_Type
(Desig
) then
6665 Desig
:= Available_View
(Designated_Type
(Desig
));
6669 Ekind_In
(Obj_Id
, E_Constant
, E_Variable
)
6670 and then Needs_Finalization
(Desig
)
6671 and then Requires_Transient_Scope
(Desig
)
6672 and then Nkind
(Rel_Node
) /= N_Simple_Return_Statement
6674 -- Do not consider a transient object that was already processed
6676 and then not Is_Finalized_Transient
(Obj_Id
)
6678 -- Do not consider renamed or 'reference-d transient objects because
6679 -- the act of renaming extends the object's lifetime.
6681 and then not Is_Aliased
(Obj_Id
, Decl
)
6683 -- Do not consider transient objects allocated on the heap since
6684 -- they are attached to a finalization master.
6686 and then not Is_Allocated
(Obj_Id
)
6688 -- If the transient object is a pointer, check that it is not
6689 -- initialized by a function that returns a pointer or acts as a
6690 -- renaming of another pointer.
6693 (not Is_Access_Type
(Obj_Typ
)
6694 or else not Initialized_By_Access
(Obj_Id
))
6696 -- Do not consider transient objects which act as indirect aliases
6697 -- of build-in-place function results.
6699 and then not Initialized_By_Aliased_BIP_Func_Call
(Obj_Id
)
6701 -- Do not consider conversions of tags to class-wide types
6703 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
6705 -- Do not consider iterators because those are treated as normal
6706 -- controlled objects and are processed by the usual finalization
6707 -- machinery. This avoids the double finalization of an iterator.
6709 and then not Is_Iterator
(Desig
)
6711 -- Do not consider containers in the context of iterator loops. Such
6712 -- transient objects must exist for as long as the loop is around,
6713 -- otherwise any operation carried out by the iterator will fail.
6715 and then not Is_Iterated_Container
(Obj_Id
, Decl
);
6716 end Is_Finalizable_Transient
;
6718 ---------------------------------
6719 -- Is_Fully_Repped_Tagged_Type --
6720 ---------------------------------
6722 function Is_Fully_Repped_Tagged_Type
(T
: Entity_Id
) return Boolean is
6723 U
: constant Entity_Id
:= Underlying_Type
(T
);
6727 if No
(U
) or else not Is_Tagged_Type
(U
) then
6729 elsif Has_Discriminants
(U
) then
6731 elsif not Has_Specified_Layout
(U
) then
6735 -- Here we have a tagged type, see if it has any unlayed out fields
6736 -- other than a possible tag and parent fields. If so, we return False.
6738 Comp
:= First_Component
(U
);
6739 while Present
(Comp
) loop
6740 if not Is_Tag
(Comp
)
6741 and then Chars
(Comp
) /= Name_uParent
6742 and then No
(Component_Clause
(Comp
))
6746 Next_Component
(Comp
);
6750 -- All components are layed out
6753 end Is_Fully_Repped_Tagged_Type
;
6755 ----------------------------------
6756 -- Is_Library_Level_Tagged_Type --
6757 ----------------------------------
6759 function Is_Library_Level_Tagged_Type
(Typ
: Entity_Id
) return Boolean is
6761 return Is_Tagged_Type
(Typ
) and then Is_Library_Level_Entity
(Typ
);
6762 end Is_Library_Level_Tagged_Type
;
6764 --------------------------
6765 -- Is_Non_BIP_Func_Call --
6766 --------------------------
6768 function Is_Non_BIP_Func_Call
(Expr
: Node_Id
) return Boolean is
6770 -- The expected call is of the format
6772 -- Func_Call'reference
6775 Nkind
(Expr
) = N_Reference
6776 and then Nkind
(Prefix
(Expr
)) = N_Function_Call
6777 and then not Is_Build_In_Place_Function_Call
(Prefix
(Expr
));
6778 end Is_Non_BIP_Func_Call
;
6780 ------------------------------------
6781 -- Is_Object_Access_BIP_Func_Call --
6782 ------------------------------------
6784 function Is_Object_Access_BIP_Func_Call
6786 Obj_Id
: Entity_Id
) return Boolean
6788 Access_Nam
: Name_Id
:= No_Name
;
6795 -- Build-in-place calls usually appear in 'reference format. Note that
6796 -- the accessibility check machinery may add an extra 'reference due to
6797 -- side effect removal.
6800 while Nkind
(Call
) = N_Reference
loop
6801 Call
:= Prefix
(Call
);
6804 if Nkind_In
(Call
, N_Qualified_Expression
,
6805 N_Unchecked_Type_Conversion
)
6807 Call
:= Expression
(Call
);
6810 if Is_Build_In_Place_Function_Call
(Call
) then
6812 -- Examine all parameter associations of the function call
6814 Param
:= First
(Parameter_Associations
(Call
));
6815 while Present
(Param
) loop
6816 if Nkind
(Param
) = N_Parameter_Association
6817 and then Nkind
(Selector_Name
(Param
)) = N_Identifier
6819 Formal
:= Selector_Name
(Param
);
6820 Actual
:= Explicit_Actual_Parameter
(Param
);
6822 -- Construct the name of formal BIPaccess. It is much easier to
6823 -- extract the name of the function using an arbitrary formal's
6824 -- scope rather than the Name field of Call.
6826 if Access_Nam
= No_Name
and then Present
(Entity
(Formal
)) then
6829 (Chars
(Scope
(Entity
(Formal
))),
6830 BIP_Formal_Suffix
(BIP_Object_Access
));
6833 -- A match for BIPaccess => Obj_Id'Unrestricted_Access has been
6836 if Chars
(Formal
) = Access_Nam
6837 and then Nkind
(Actual
) = N_Attribute_Reference
6838 and then Attribute_Name
(Actual
) = Name_Unrestricted_Access
6839 and then Nkind
(Prefix
(Actual
)) = N_Identifier
6840 and then Entity
(Prefix
(Actual
)) = Obj_Id
6851 end Is_Object_Access_BIP_Func_Call
;
6853 ----------------------------------
6854 -- Is_Possibly_Unaligned_Object --
6855 ----------------------------------
6857 function Is_Possibly_Unaligned_Object
(N
: Node_Id
) return Boolean is
6858 T
: constant Entity_Id
:= Etype
(N
);
6861 -- If renamed object, apply test to underlying object
6863 if Is_Entity_Name
(N
)
6864 and then Is_Object
(Entity
(N
))
6865 and then Present
(Renamed_Object
(Entity
(N
)))
6867 return Is_Possibly_Unaligned_Object
(Renamed_Object
(Entity
(N
)));
6870 -- Tagged and controlled types and aliased types are always aligned, as
6871 -- are concurrent types.
6874 or else Has_Controlled_Component
(T
)
6875 or else Is_Concurrent_Type
(T
)
6876 or else Is_Tagged_Type
(T
)
6877 or else Is_Controlled
(T
)
6882 -- If this is an element of a packed array, may be unaligned
6884 if Is_Ref_To_Bit_Packed_Array
(N
) then
6888 -- Case of indexed component reference: test whether prefix is unaligned
6890 if Nkind
(N
) = N_Indexed_Component
then
6891 return Is_Possibly_Unaligned_Object
(Prefix
(N
));
6893 -- Case of selected component reference
6895 elsif Nkind
(N
) = N_Selected_Component
then
6897 P
: constant Node_Id
:= Prefix
(N
);
6898 C
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
6903 -- If component reference is for an array with non-static bounds,
6904 -- then it is always aligned: we can only process unaligned arrays
6905 -- with static bounds (more precisely compile time known bounds).
6907 if Is_Array_Type
(T
)
6908 and then not Compile_Time_Known_Bounds
(T
)
6913 -- If component is aliased, it is definitely properly aligned
6915 if Is_Aliased
(C
) then
6919 -- If component is for a type implemented as a scalar, and the
6920 -- record is packed, and the component is other than the first
6921 -- component of the record, then the component may be unaligned.
6923 if Is_Packed
(Etype
(P
))
6924 and then Represented_As_Scalar
(Etype
(C
))
6925 and then First_Entity
(Scope
(C
)) /= C
6930 -- Compute maximum possible alignment for T
6932 -- If alignment is known, then that settles things
6934 if Known_Alignment
(T
) then
6935 M
:= UI_To_Int
(Alignment
(T
));
6937 -- If alignment is not known, tentatively set max alignment
6940 M
:= Ttypes
.Maximum_Alignment
;
6942 -- We can reduce this if the Esize is known since the default
6943 -- alignment will never be more than the smallest power of 2
6944 -- that does not exceed this Esize value.
6946 if Known_Esize
(T
) then
6947 S
:= UI_To_Int
(Esize
(T
));
6949 while (M
/ 2) >= S
loop
6955 -- The following code is historical, it used to be present but it
6956 -- is too cautious, because the front-end does not know the proper
6957 -- default alignments for the target. Also, if the alignment is
6958 -- not known, the front end can't know in any case. If a copy is
6959 -- needed, the back-end will take care of it. This whole section
6960 -- including this comment can be removed later ???
6962 -- If the component reference is for a record that has a specified
6963 -- alignment, and we either know it is too small, or cannot tell,
6964 -- then the component may be unaligned.
6966 -- What is the following commented out code ???
6968 -- if Known_Alignment (Etype (P))
6969 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
6970 -- and then M > Alignment (Etype (P))
6975 -- Case of component clause present which may specify an
6976 -- unaligned position.
6978 if Present
(Component_Clause
(C
)) then
6980 -- Otherwise we can do a test to make sure that the actual
6981 -- start position in the record, and the length, are both
6982 -- consistent with the required alignment. If not, we know
6983 -- that we are unaligned.
6986 Align_In_Bits
: constant Nat
:= M
* System_Storage_Unit
;
6988 if Component_Bit_Offset
(C
) mod Align_In_Bits
/= 0
6989 or else Esize
(C
) mod Align_In_Bits
/= 0
6996 -- Otherwise, for a component reference, test prefix
6998 return Is_Possibly_Unaligned_Object
(P
);
7001 -- If not a component reference, must be aligned
7006 end Is_Possibly_Unaligned_Object
;
7008 ---------------------------------
7009 -- Is_Possibly_Unaligned_Slice --
7010 ---------------------------------
7012 function Is_Possibly_Unaligned_Slice
(N
: Node_Id
) return Boolean is
7014 -- Go to renamed object
7016 if Is_Entity_Name
(N
)
7017 and then Is_Object
(Entity
(N
))
7018 and then Present
(Renamed_Object
(Entity
(N
)))
7020 return Is_Possibly_Unaligned_Slice
(Renamed_Object
(Entity
(N
)));
7023 -- The reference must be a slice
7025 if Nkind
(N
) /= N_Slice
then
7029 -- We only need to worry if the target has strict alignment
7031 if not Target_Strict_Alignment
then
7035 -- If it is a slice, then look at the array type being sliced
7038 Sarr
: constant Node_Id
:= Prefix
(N
);
7039 -- Prefix of the slice, i.e. the array being sliced
7041 Styp
: constant Entity_Id
:= Etype
(Prefix
(N
));
7042 -- Type of the array being sliced
7048 -- The problems arise if the array object that is being sliced
7049 -- is a component of a record or array, and we cannot guarantee
7050 -- the alignment of the array within its containing object.
7052 -- To investigate this, we look at successive prefixes to see
7053 -- if we have a worrisome indexed or selected component.
7057 -- Case of array is part of an indexed component reference
7059 if Nkind
(Pref
) = N_Indexed_Component
then
7060 Ptyp
:= Etype
(Prefix
(Pref
));
7062 -- The only problematic case is when the array is packed, in
7063 -- which case we really know nothing about the alignment of
7064 -- individual components.
7066 if Is_Bit_Packed_Array
(Ptyp
) then
7070 -- Case of array is part of a selected component reference
7072 elsif Nkind
(Pref
) = N_Selected_Component
then
7073 Ptyp
:= Etype
(Prefix
(Pref
));
7075 -- We are definitely in trouble if the record in question
7076 -- has an alignment, and either we know this alignment is
7077 -- inconsistent with the alignment of the slice, or we don't
7078 -- know what the alignment of the slice should be.
7080 if Known_Alignment
(Ptyp
)
7081 and then (Unknown_Alignment
(Styp
)
7082 or else Alignment
(Styp
) > Alignment
(Ptyp
))
7087 -- We are in potential trouble if the record type is packed.
7088 -- We could special case when we know that the array is the
7089 -- first component, but that's not such a simple case ???
7091 if Is_Packed
(Ptyp
) then
7095 -- We are in trouble if there is a component clause, and
7096 -- either we do not know the alignment of the slice, or
7097 -- the alignment of the slice is inconsistent with the
7098 -- bit position specified by the component clause.
7101 Field
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
7103 if Present
(Component_Clause
(Field
))
7105 (Unknown_Alignment
(Styp
)
7107 (Component_Bit_Offset
(Field
) mod
7108 (System_Storage_Unit
* Alignment
(Styp
))) /= 0)
7114 -- For cases other than selected or indexed components we know we
7115 -- are OK, since no issues arise over alignment.
7121 -- We processed an indexed component or selected component
7122 -- reference that looked safe, so keep checking prefixes.
7124 Pref
:= Prefix
(Pref
);
7127 end Is_Possibly_Unaligned_Slice
;
7129 -------------------------------
7130 -- Is_Related_To_Func_Return --
7131 -------------------------------
7133 function Is_Related_To_Func_Return
(Id
: Entity_Id
) return Boolean is
7134 Expr
: constant Node_Id
:= Related_Expression
(Id
);
7138 and then Nkind
(Expr
) = N_Explicit_Dereference
7139 and then Nkind
(Parent
(Expr
)) = N_Simple_Return_Statement
;
7140 end Is_Related_To_Func_Return
;
7142 --------------------------------
7143 -- Is_Ref_To_Bit_Packed_Array --
7144 --------------------------------
7146 function Is_Ref_To_Bit_Packed_Array
(N
: Node_Id
) return Boolean is
7151 if Is_Entity_Name
(N
)
7152 and then Is_Object
(Entity
(N
))
7153 and then Present
(Renamed_Object
(Entity
(N
)))
7155 return Is_Ref_To_Bit_Packed_Array
(Renamed_Object
(Entity
(N
)));
7158 if Nkind_In
(N
, N_Indexed_Component
, N_Selected_Component
) then
7159 if Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
7162 Result
:= Is_Ref_To_Bit_Packed_Array
(Prefix
(N
));
7165 if Result
and then Nkind
(N
) = N_Indexed_Component
then
7166 Expr
:= First
(Expressions
(N
));
7167 while Present
(Expr
) loop
7168 Force_Evaluation
(Expr
);
7178 end Is_Ref_To_Bit_Packed_Array
;
7180 --------------------------------
7181 -- Is_Ref_To_Bit_Packed_Slice --
7182 --------------------------------
7184 function Is_Ref_To_Bit_Packed_Slice
(N
: Node_Id
) return Boolean is
7186 if Nkind
(N
) = N_Type_Conversion
then
7187 return Is_Ref_To_Bit_Packed_Slice
(Expression
(N
));
7189 elsif Is_Entity_Name
(N
)
7190 and then Is_Object
(Entity
(N
))
7191 and then Present
(Renamed_Object
(Entity
(N
)))
7193 return Is_Ref_To_Bit_Packed_Slice
(Renamed_Object
(Entity
(N
)));
7195 elsif Nkind
(N
) = N_Slice
7196 and then Is_Bit_Packed_Array
(Etype
(Prefix
(N
)))
7200 elsif Nkind_In
(N
, N_Indexed_Component
, N_Selected_Component
) then
7201 return Is_Ref_To_Bit_Packed_Slice
(Prefix
(N
));
7206 end Is_Ref_To_Bit_Packed_Slice
;
7208 -----------------------
7209 -- Is_Renamed_Object --
7210 -----------------------
7212 function Is_Renamed_Object
(N
: Node_Id
) return Boolean is
7213 Pnod
: constant Node_Id
:= Parent
(N
);
7214 Kind
: constant Node_Kind
:= Nkind
(Pnod
);
7216 if Kind
= N_Object_Renaming_Declaration
then
7218 elsif Nkind_In
(Kind
, N_Indexed_Component
, N_Selected_Component
) then
7219 return Is_Renamed_Object
(Pnod
);
7223 end Is_Renamed_Object
;
7225 --------------------------------------
7226 -- Is_Secondary_Stack_BIP_Func_Call --
7227 --------------------------------------
7229 function Is_Secondary_Stack_BIP_Func_Call
(Expr
: Node_Id
) return Boolean is
7230 Alloc_Nam
: Name_Id
:= No_Name
;
7232 Call
: Node_Id
:= Expr
;
7237 -- Build-in-place calls usually appear in 'reference format. Note that
7238 -- the accessibility check machinery may add an extra 'reference due to
7239 -- side effect removal.
7241 while Nkind
(Call
) = N_Reference
loop
7242 Call
:= Prefix
(Call
);
7245 if Nkind_In
(Call
, N_Qualified_Expression
,
7246 N_Unchecked_Type_Conversion
)
7248 Call
:= Expression
(Call
);
7251 if Is_Build_In_Place_Function_Call
(Call
) then
7253 -- Examine all parameter associations of the function call
7255 Param
:= First
(Parameter_Associations
(Call
));
7256 while Present
(Param
) loop
7257 if Nkind
(Param
) = N_Parameter_Association
7258 and then Nkind
(Selector_Name
(Param
)) = N_Identifier
7260 Formal
:= Selector_Name
(Param
);
7261 Actual
:= Explicit_Actual_Parameter
(Param
);
7263 -- Construct the name of formal BIPalloc. It is much easier to
7264 -- extract the name of the function using an arbitrary formal's
7265 -- scope rather than the Name field of Call.
7267 if Alloc_Nam
= No_Name
and then Present
(Entity
(Formal
)) then
7270 (Chars
(Scope
(Entity
(Formal
))),
7271 BIP_Formal_Suffix
(BIP_Alloc_Form
));
7274 -- A match for BIPalloc => 2 has been found
7276 if Chars
(Formal
) = Alloc_Nam
7277 and then Nkind
(Actual
) = N_Integer_Literal
7278 and then Intval
(Actual
) = Uint_2
7289 end Is_Secondary_Stack_BIP_Func_Call
;
7291 -------------------------------------
7292 -- Is_Tag_To_Class_Wide_Conversion --
7293 -------------------------------------
7295 function Is_Tag_To_Class_Wide_Conversion
7296 (Obj_Id
: Entity_Id
) return Boolean
7298 Expr
: constant Node_Id
:= Expression
(Parent
(Obj_Id
));
7302 Is_Class_Wide_Type
(Etype
(Obj_Id
))
7303 and then Present
(Expr
)
7304 and then Nkind
(Expr
) = N_Unchecked_Type_Conversion
7305 and then Etype
(Expression
(Expr
)) = RTE
(RE_Tag
);
7306 end Is_Tag_To_Class_Wide_Conversion
;
7308 ----------------------------
7309 -- Is_Untagged_Derivation --
7310 ----------------------------
7312 function Is_Untagged_Derivation
(T
: Entity_Id
) return Boolean is
7314 return (not Is_Tagged_Type
(T
) and then Is_Derived_Type
(T
))
7316 (Is_Private_Type
(T
) and then Present
(Full_View
(T
))
7317 and then not Is_Tagged_Type
(Full_View
(T
))
7318 and then Is_Derived_Type
(Full_View
(T
))
7319 and then Etype
(Full_View
(T
)) /= T
);
7320 end Is_Untagged_Derivation
;
7322 ---------------------------
7323 -- Is_Volatile_Reference --
7324 ---------------------------
7326 function Is_Volatile_Reference
(N
: Node_Id
) return Boolean is
7328 -- Only source references are to be treated as volatile, internally
7329 -- generated stuff cannot have volatile external effects.
7331 if not Comes_From_Source
(N
) then
7334 -- Never true for reference to a type
7336 elsif Is_Entity_Name
(N
) and then Is_Type
(Entity
(N
)) then
7339 -- Never true for a compile time known constant
7341 elsif Compile_Time_Known_Value
(N
) then
7344 -- True if object reference with volatile type
7346 elsif Is_Volatile_Object
(N
) then
7349 -- True if reference to volatile entity
7351 elsif Is_Entity_Name
(N
) then
7352 return Treat_As_Volatile
(Entity
(N
));
7354 -- True for slice of volatile array
7356 elsif Nkind
(N
) = N_Slice
then
7357 return Is_Volatile_Reference
(Prefix
(N
));
7359 -- True if volatile component
7361 elsif Nkind_In
(N
, N_Indexed_Component
, N_Selected_Component
) then
7362 if (Is_Entity_Name
(Prefix
(N
))
7363 and then Has_Volatile_Components
(Entity
(Prefix
(N
))))
7364 or else (Present
(Etype
(Prefix
(N
)))
7365 and then Has_Volatile_Components
(Etype
(Prefix
(N
))))
7369 return Is_Volatile_Reference
(Prefix
(N
));
7377 end Is_Volatile_Reference
;
7379 --------------------
7380 -- Kill_Dead_Code --
7381 --------------------
7383 procedure Kill_Dead_Code
(N
: Node_Id
; Warn
: Boolean := False) is
7384 W
: Boolean := Warn
;
7385 -- Set False if warnings suppressed
7389 Remove_Warning_Messages
(N
);
7391 -- Generate warning if appropriate
7395 -- We suppress the warning if this code is under control of an
7396 -- if statement, whose condition is a simple identifier, and
7397 -- either we are in an instance, or warnings off is set for this
7398 -- identifier. The reason for killing it in the instance case is
7399 -- that it is common and reasonable for code to be deleted in
7400 -- instances for various reasons.
7402 -- Could we use Is_Statically_Unevaluated here???
7404 if Nkind
(Parent
(N
)) = N_If_Statement
then
7406 C
: constant Node_Id
:= Condition
(Parent
(N
));
7408 if Nkind
(C
) = N_Identifier
7411 or else (Present
(Entity
(C
))
7412 and then Has_Warnings_Off
(Entity
(C
))))
7419 -- Generate warning if not suppressed
7423 ("?t?this code can never be executed and has been deleted!",
7428 -- Recurse into block statements and bodies to process declarations
7431 if Nkind
(N
) = N_Block_Statement
7432 or else Nkind
(N
) = N_Subprogram_Body
7433 or else Nkind
(N
) = N_Package_Body
7435 Kill_Dead_Code
(Declarations
(N
), False);
7436 Kill_Dead_Code
(Statements
(Handled_Statement_Sequence
(N
)));
7438 if Nkind
(N
) = N_Subprogram_Body
then
7439 Set_Is_Eliminated
(Defining_Entity
(N
));
7442 elsif Nkind
(N
) = N_Package_Declaration
then
7443 Kill_Dead_Code
(Visible_Declarations
(Specification
(N
)));
7444 Kill_Dead_Code
(Private_Declarations
(Specification
(N
)));
7446 -- ??? After this point, Delete_Tree has been called on all
7447 -- declarations in Specification (N), so references to entities
7448 -- therein look suspicious.
7451 E
: Entity_Id
:= First_Entity
(Defining_Entity
(N
));
7454 while Present
(E
) loop
7455 if Ekind
(E
) = E_Operator
then
7456 Set_Is_Eliminated
(E
);
7463 -- Recurse into composite statement to kill individual statements in
7464 -- particular instantiations.
7466 elsif Nkind
(N
) = N_If_Statement
then
7467 Kill_Dead_Code
(Then_Statements
(N
));
7468 Kill_Dead_Code
(Elsif_Parts
(N
));
7469 Kill_Dead_Code
(Else_Statements
(N
));
7471 elsif Nkind
(N
) = N_Loop_Statement
then
7472 Kill_Dead_Code
(Statements
(N
));
7474 elsif Nkind
(N
) = N_Case_Statement
then
7478 Alt
:= First
(Alternatives
(N
));
7479 while Present
(Alt
) loop
7480 Kill_Dead_Code
(Statements
(Alt
));
7485 elsif Nkind
(N
) = N_Case_Statement_Alternative
then
7486 Kill_Dead_Code
(Statements
(N
));
7488 -- Deal with dead instances caused by deleting instantiations
7490 elsif Nkind
(N
) in N_Generic_Instantiation
then
7491 Remove_Dead_Instance
(N
);
7496 -- Case where argument is a list of nodes to be killed
7498 procedure Kill_Dead_Code
(L
: List_Id
; Warn
: Boolean := False) is
7505 if Is_Non_Empty_List
(L
) then
7507 while Present
(N
) loop
7508 Kill_Dead_Code
(N
, W
);
7515 ------------------------
7516 -- Known_Non_Negative --
7517 ------------------------
7519 function Known_Non_Negative
(Opnd
: Node_Id
) return Boolean is
7521 if Is_OK_Static_Expression
(Opnd
) and then Expr_Value
(Opnd
) >= 0 then
7526 Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Opnd
));
7529 Is_OK_Static_Expression
(Lo
) and then Expr_Value
(Lo
) >= 0;
7532 end Known_Non_Negative
;
7534 --------------------
7535 -- Known_Non_Null --
7536 --------------------
7538 function Known_Non_Null
(N
: Node_Id
) return Boolean is
7540 -- Checks for case where N is an entity reference
7542 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
7544 E
: constant Entity_Id
:= Entity
(N
);
7549 -- First check if we are in decisive conditional
7551 Get_Current_Value_Condition
(N
, Op
, Val
);
7553 if Known_Null
(Val
) then
7554 if Op
= N_Op_Eq
then
7556 elsif Op
= N_Op_Ne
then
7561 -- If OK to do replacement, test Is_Known_Non_Null flag
7563 if OK_To_Do_Constant_Replacement
(E
) then
7564 return Is_Known_Non_Null
(E
);
7566 -- Otherwise if not safe to do replacement, then say so
7573 -- True if access attribute
7575 elsif Nkind
(N
) = N_Attribute_Reference
7576 and then Nam_In
(Attribute_Name
(N
), Name_Access
,
7577 Name_Unchecked_Access
,
7578 Name_Unrestricted_Access
)
7582 -- True if allocator
7584 elsif Nkind
(N
) = N_Allocator
then
7587 -- For a conversion, true if expression is known non-null
7589 elsif Nkind
(N
) = N_Type_Conversion
then
7590 return Known_Non_Null
(Expression
(N
));
7592 -- Above are all cases where the value could be determined to be
7593 -- non-null. In all other cases, we don't know, so return False.
7604 function Known_Null
(N
: Node_Id
) return Boolean is
7606 -- Checks for case where N is an entity reference
7608 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
7610 E
: constant Entity_Id
:= Entity
(N
);
7615 -- Constant null value is for sure null
7617 if Ekind
(E
) = E_Constant
7618 and then Known_Null
(Constant_Value
(E
))
7623 -- First check if we are in decisive conditional
7625 Get_Current_Value_Condition
(N
, Op
, Val
);
7627 if Known_Null
(Val
) then
7628 if Op
= N_Op_Eq
then
7630 elsif Op
= N_Op_Ne
then
7635 -- If OK to do replacement, test Is_Known_Null flag
7637 if OK_To_Do_Constant_Replacement
(E
) then
7638 return Is_Known_Null
(E
);
7640 -- Otherwise if not safe to do replacement, then say so
7647 -- True if explicit reference to null
7649 elsif Nkind
(N
) = N_Null
then
7652 -- For a conversion, true if expression is known null
7654 elsif Nkind
(N
) = N_Type_Conversion
then
7655 return Known_Null
(Expression
(N
));
7657 -- Above are all cases where the value could be determined to be null.
7658 -- In all other cases, we don't know, so return False.
7665 -----------------------------
7666 -- Make_CW_Equivalent_Type --
7667 -----------------------------
7669 -- Create a record type used as an equivalent of any member of the class
7670 -- which takes its size from exp.
7672 -- Generate the following code:
7674 -- type Equiv_T is record
7675 -- _parent : T (List of discriminant constraints taken from Exp);
7676 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
7679 -- ??? Note that this type does not guarantee same alignment as all
7682 function Make_CW_Equivalent_Type
7684 E
: Node_Id
) return Entity_Id
7686 Loc
: constant Source_Ptr
:= Sloc
(E
);
7687 Root_Typ
: constant Entity_Id
:= Root_Type
(T
);
7688 List_Def
: constant List_Id
:= Empty_List
;
7689 Comp_List
: constant List_Id
:= New_List
;
7690 Equiv_Type
: Entity_Id
;
7691 Range_Type
: Entity_Id
;
7692 Str_Type
: Entity_Id
;
7693 Constr_Root
: Entity_Id
;
7697 -- If the root type is already constrained, there are no discriminants
7698 -- in the expression.
7700 if not Has_Discriminants
(Root_Typ
)
7701 or else Is_Constrained
(Root_Typ
)
7703 Constr_Root
:= Root_Typ
;
7705 -- At this point in the expansion, non-limited view of the type
7706 -- must be available, otherwise the error will be reported later.
7708 if From_Limited_With
(Constr_Root
)
7709 and then Present
(Non_Limited_View
(Constr_Root
))
7711 Constr_Root
:= Non_Limited_View
(Constr_Root
);
7715 Constr_Root
:= Make_Temporary
(Loc
, 'R');
7717 -- subtype cstr__n is T (List of discr constraints taken from Exp)
7719 Append_To
(List_Def
,
7720 Make_Subtype_Declaration
(Loc
,
7721 Defining_Identifier
=> Constr_Root
,
7722 Subtype_Indication
=> Make_Subtype_From_Expr
(E
, Root_Typ
)));
7725 -- Generate the range subtype declaration
7727 Range_Type
:= Make_Temporary
(Loc
, 'G');
7729 if not Is_Interface
(Root_Typ
) then
7731 -- subtype rg__xx is
7732 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
7735 Make_Op_Subtract
(Loc
,
7737 Make_Attribute_Reference
(Loc
,
7739 OK_Convert_To
(T
, Duplicate_Subexpr_No_Checks
(E
)),
7740 Attribute_Name
=> Name_Size
),
7742 Make_Attribute_Reference
(Loc
,
7743 Prefix
=> New_Occurrence_Of
(Constr_Root
, Loc
),
7744 Attribute_Name
=> Name_Object_Size
));
7746 -- subtype rg__xx is
7747 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
7750 Make_Attribute_Reference
(Loc
,
7752 OK_Convert_To
(T
, Duplicate_Subexpr_No_Checks
(E
)),
7753 Attribute_Name
=> Name_Size
);
7756 Set_Paren_Count
(Sizexpr
, 1);
7758 Append_To
(List_Def
,
7759 Make_Subtype_Declaration
(Loc
,
7760 Defining_Identifier
=> Range_Type
,
7761 Subtype_Indication
=>
7762 Make_Subtype_Indication
(Loc
,
7763 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
7764 Constraint
=> Make_Range_Constraint
(Loc
,
7767 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
7769 Make_Op_Divide
(Loc
,
7770 Left_Opnd
=> Sizexpr
,
7771 Right_Opnd
=> Make_Integer_Literal
(Loc
,
7772 Intval
=> System_Storage_Unit
)))))));
7774 -- subtype str__nn is Storage_Array (rg__x);
7776 Str_Type
:= Make_Temporary
(Loc
, 'S');
7777 Append_To
(List_Def
,
7778 Make_Subtype_Declaration
(Loc
,
7779 Defining_Identifier
=> Str_Type
,
7780 Subtype_Indication
=>
7781 Make_Subtype_Indication
(Loc
,
7782 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Storage_Array
), Loc
),
7784 Make_Index_Or_Discriminant_Constraint
(Loc
,
7786 New_List
(New_Occurrence_Of
(Range_Type
, Loc
))))));
7788 -- type Equiv_T is record
7789 -- [ _parent : Tnn; ]
7793 Equiv_Type
:= Make_Temporary
(Loc
, 'T');
7794 Set_Ekind
(Equiv_Type
, E_Record_Type
);
7795 Set_Parent_Subtype
(Equiv_Type
, Constr_Root
);
7797 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
7798 -- treatment for this type. In particular, even though _parent's type
7799 -- is a controlled type or contains controlled components, we do not
7800 -- want to set Has_Controlled_Component on it to avoid making it gain
7801 -- an unwanted _controller component.
7803 Set_Is_Class_Wide_Equivalent_Type
(Equiv_Type
);
7805 -- A class-wide equivalent type does not require initialization
7807 Set_Suppress_Initialization
(Equiv_Type
);
7809 if not Is_Interface
(Root_Typ
) then
7810 Append_To
(Comp_List
,
7811 Make_Component_Declaration
(Loc
,
7812 Defining_Identifier
=>
7813 Make_Defining_Identifier
(Loc
, Name_uParent
),
7814 Component_Definition
=>
7815 Make_Component_Definition
(Loc
,
7816 Aliased_Present
=> False,
7817 Subtype_Indication
=> New_Occurrence_Of
(Constr_Root
, Loc
))));
7820 Append_To
(Comp_List
,
7821 Make_Component_Declaration
(Loc
,
7822 Defining_Identifier
=> Make_Temporary
(Loc
, 'C'),
7823 Component_Definition
=>
7824 Make_Component_Definition
(Loc
,
7825 Aliased_Present
=> False,
7826 Subtype_Indication
=> New_Occurrence_Of
(Str_Type
, Loc
))));
7828 Append_To
(List_Def
,
7829 Make_Full_Type_Declaration
(Loc
,
7830 Defining_Identifier
=> Equiv_Type
,
7832 Make_Record_Definition
(Loc
,
7834 Make_Component_List
(Loc
,
7835 Component_Items
=> Comp_List
,
7836 Variant_Part
=> Empty
))));
7838 -- Suppress all checks during the analysis of the expanded code to avoid
7839 -- the generation of spurious warnings under ZFP run-time.
7841 Insert_Actions
(E
, List_Def
, Suppress
=> All_Checks
);
7843 end Make_CW_Equivalent_Type
;
7845 -------------------------
7846 -- Make_Invariant_Call --
7847 -------------------------
7849 function Make_Invariant_Call
(Expr
: Node_Id
) return Node_Id
is
7850 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
7851 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Expr
));
7853 Proc_Id
: Entity_Id
;
7856 pragma Assert
(Has_Invariants
(Typ
));
7858 Proc_Id
:= Invariant_Procedure
(Typ
);
7859 pragma Assert
(Present
(Proc_Id
));
7862 Make_Procedure_Call_Statement
(Loc
,
7863 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
7864 Parameter_Associations
=> New_List
(Relocate_Node
(Expr
)));
7865 end Make_Invariant_Call
;
7867 ------------------------
7868 -- Make_Literal_Range --
7869 ------------------------
7871 function Make_Literal_Range
7873 Literal_Typ
: Entity_Id
) return Node_Id
7875 Lo
: constant Node_Id
:=
7876 New_Copy_Tree
(String_Literal_Low_Bound
(Literal_Typ
));
7877 Index
: constant Entity_Id
:= Etype
(Lo
);
7880 Length_Expr
: constant Node_Id
:=
7881 Make_Op_Subtract
(Loc
,
7883 Make_Integer_Literal
(Loc
,
7884 Intval
=> String_Literal_Length
(Literal_Typ
)),
7886 Make_Integer_Literal
(Loc
, 1));
7889 Set_Analyzed
(Lo
, False);
7891 if Is_Integer_Type
(Index
) then
7894 Left_Opnd
=> New_Copy_Tree
(Lo
),
7895 Right_Opnd
=> Length_Expr
);
7898 Make_Attribute_Reference
(Loc
,
7899 Attribute_Name
=> Name_Val
,
7900 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
7901 Expressions
=> New_List
(
7904 Make_Attribute_Reference
(Loc
,
7905 Attribute_Name
=> Name_Pos
,
7906 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
7907 Expressions
=> New_List
(New_Copy_Tree
(Lo
))),
7908 Right_Opnd
=> Length_Expr
)));
7915 end Make_Literal_Range
;
7917 --------------------------
7918 -- Make_Non_Empty_Check --
7919 --------------------------
7921 function Make_Non_Empty_Check
7923 N
: Node_Id
) return Node_Id
7929 Make_Attribute_Reference
(Loc
,
7930 Attribute_Name
=> Name_Length
,
7931 Prefix
=> Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True)),
7933 Make_Integer_Literal
(Loc
, 0));
7934 end Make_Non_Empty_Check
;
7936 -------------------------
7937 -- Make_Predicate_Call --
7938 -------------------------
7940 -- WARNING: This routine manages Ghost regions. Return statements must be
7941 -- replaced by gotos which jump to the end of the routine and restore the
7944 function Make_Predicate_Call
7947 Mem
: Boolean := False) return Node_Id
7949 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
7952 Func_Id
: Entity_Id
;
7953 Mode
: Ghost_Mode_Type
;
7956 pragma Assert
(Present
(Predicate_Function
(Typ
)));
7958 -- The related type may be subject to pragma Ghost. Set the mode now to
7959 -- ensure that the call is properly marked as Ghost.
7961 Set_Ghost_Mode
(Typ
, Mode
);
7963 -- Call special membership version if requested and available
7965 if Mem
and then Present
(Predicate_Function_M
(Typ
)) then
7966 Func_Id
:= Predicate_Function_M
(Typ
);
7968 Func_Id
:= Predicate_Function
(Typ
);
7971 -- Case of calling normal predicate function
7974 Make_Function_Call
(Loc
,
7975 Name
=> New_Occurrence_Of
(Func_Id
, Loc
),
7976 Parameter_Associations
=> New_List
(Relocate_Node
(Expr
)));
7978 Restore_Ghost_Mode
(Mode
);
7980 end Make_Predicate_Call
;
7982 --------------------------
7983 -- Make_Predicate_Check --
7984 --------------------------
7986 function Make_Predicate_Check
7988 Expr
: Node_Id
) return Node_Id
7990 procedure Replace_Subtype_Reference
(N
: Node_Id
);
7991 -- Replace current occurrences of the subtype to which a dynamic
7992 -- predicate applies, by the expression that triggers a predicate
7993 -- check. This is needed for aspect Predicate_Failure, for which
7994 -- we do not generate a wrapper procedure, but simply modify the
7995 -- expression for the pragma of the predicate check.
7997 --------------------------------
7998 -- Replace_Subtype_Reference --
7999 --------------------------------
8001 procedure Replace_Subtype_Reference
(N
: Node_Id
) is
8003 Rewrite
(N
, New_Copy_Tree
(Expr
));
8005 -- We want to treat the node as if it comes from source, so
8006 -- that ASIS will not ignore it.
8008 Set_Comes_From_Source
(N
, True);
8009 end Replace_Subtype_Reference
;
8011 procedure Replace_Subtype_References
is
8012 new Replace_Type_References_Generic
(Replace_Subtype_Reference
);
8016 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
8018 Fail_Expr
: Node_Id
;
8021 -- Start of processing for Make_Predicate_Check
8024 -- If predicate checks are suppressed, then return a null statement. For
8025 -- this call, we check only the scope setting. If the caller wants to
8026 -- check a specific entity's setting, they must do it manually.
8028 if Predicate_Checks_Suppressed
(Empty
) then
8029 return Make_Null_Statement
(Loc
);
8032 -- Do not generate a check within an internal subprogram (stream
8033 -- functions and the like, including including predicate functions).
8035 if Within_Internal_Subprogram
then
8036 return Make_Null_Statement
(Loc
);
8039 -- Compute proper name to use, we need to get this right so that the
8040 -- right set of check policies apply to the Check pragma we are making.
8042 if Has_Dynamic_Predicate_Aspect
(Typ
) then
8043 Nam
:= Name_Dynamic_Predicate
;
8044 elsif Has_Static_Predicate_Aspect
(Typ
) then
8045 Nam
:= Name_Static_Predicate
;
8047 Nam
:= Name_Predicate
;
8050 Arg_List
:= New_List
(
8051 Make_Pragma_Argument_Association
(Loc
,
8052 Expression
=> Make_Identifier
(Loc
, Nam
)),
8053 Make_Pragma_Argument_Association
(Loc
,
8054 Expression
=> Make_Predicate_Call
(Typ
, Expr
)));
8056 -- If subtype has Predicate_Failure defined, add the correponding
8057 -- expression as an additional pragma parameter, after replacing
8058 -- current instances with the expression being checked.
8060 if Has_Aspect
(Typ
, Aspect_Predicate_Failure
) then
8063 (Expression
(Find_Aspect
(Typ
, Aspect_Predicate_Failure
)));
8064 Replace_Subtype_References
(Fail_Expr
, Typ
);
8066 Append_To
(Arg_List
,
8067 Make_Pragma_Argument_Association
(Loc
,
8068 Expression
=> Fail_Expr
));
8073 Chars
=> Name_Check
,
8074 Pragma_Argument_Associations
=> Arg_List
);
8075 end Make_Predicate_Check
;
8077 ----------------------------
8078 -- Make_Subtype_From_Expr --
8079 ----------------------------
8081 -- 1. If Expr is an unconstrained array expression, creates
8082 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
8084 -- 2. If Expr is a unconstrained discriminated type expression, creates
8085 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
8087 -- 3. If Expr is class-wide, creates an implicit class-wide subtype
8089 function Make_Subtype_From_Expr
8091 Unc_Typ
: Entity_Id
;
8092 Related_Id
: Entity_Id
:= Empty
) return Node_Id
8094 List_Constr
: constant List_Id
:= New_List
;
8095 Loc
: constant Source_Ptr
:= Sloc
(E
);
8098 Full_Subtyp
: Entity_Id
;
8099 High_Bound
: Entity_Id
;
8100 Index_Typ
: Entity_Id
;
8101 Low_Bound
: Entity_Id
;
8102 Priv_Subtyp
: Entity_Id
;
8106 if Is_Private_Type
(Unc_Typ
)
8107 and then Has_Unknown_Discriminants
(Unc_Typ
)
8109 -- The caller requests a unique external name for both the private
8110 -- and the full subtype.
8112 if Present
(Related_Id
) then
8114 Make_Defining_Identifier
(Loc
,
8115 Chars
=> New_External_Name
(Chars
(Related_Id
), 'C'));
8117 Make_Defining_Identifier
(Loc
,
8118 Chars
=> New_External_Name
(Chars
(Related_Id
), 'P'));
8121 Full_Subtyp
:= Make_Temporary
(Loc
, 'C');
8122 Priv_Subtyp
:= Make_Temporary
(Loc
, 'P');
8125 -- Prepare the subtype completion. Use the base type to find the
8126 -- underlying type because the type may be a generic actual or an
8127 -- explicit subtype.
8129 Utyp
:= Underlying_Type
(Base_Type
(Unc_Typ
));
8132 Unchecked_Convert_To
(Utyp
, Duplicate_Subexpr_No_Checks
(E
));
8133 Set_Parent
(Full_Exp
, Parent
(E
));
8136 Make_Subtype_Declaration
(Loc
,
8137 Defining_Identifier
=> Full_Subtyp
,
8138 Subtype_Indication
=> Make_Subtype_From_Expr
(Full_Exp
, Utyp
)));
8140 -- Define the dummy private subtype
8142 Set_Ekind
(Priv_Subtyp
, Subtype_Kind
(Ekind
(Unc_Typ
)));
8143 Set_Etype
(Priv_Subtyp
, Base_Type
(Unc_Typ
));
8144 Set_Scope
(Priv_Subtyp
, Full_Subtyp
);
8145 Set_Is_Constrained
(Priv_Subtyp
);
8146 Set_Is_Tagged_Type
(Priv_Subtyp
, Is_Tagged_Type
(Unc_Typ
));
8147 Set_Is_Itype
(Priv_Subtyp
);
8148 Set_Associated_Node_For_Itype
(Priv_Subtyp
, E
);
8150 if Is_Tagged_Type
(Priv_Subtyp
) then
8152 (Base_Type
(Priv_Subtyp
), Class_Wide_Type
(Unc_Typ
));
8153 Set_Direct_Primitive_Operations
(Priv_Subtyp
,
8154 Direct_Primitive_Operations
(Unc_Typ
));
8157 Set_Full_View
(Priv_Subtyp
, Full_Subtyp
);
8159 return New_Occurrence_Of
(Priv_Subtyp
, Loc
);
8161 elsif Is_Array_Type
(Unc_Typ
) then
8162 Index_Typ
:= First_Index
(Unc_Typ
);
8163 for J
in 1 .. Number_Dimensions
(Unc_Typ
) loop
8165 -- Capture the bounds of each index constraint in case the context
8166 -- is an object declaration of an unconstrained type initialized
8167 -- by a function call:
8169 -- Obj : Unconstr_Typ := Func_Call;
8171 -- This scenario requires secondary scope management and the index
8172 -- constraint cannot depend on the temporary used to capture the
8173 -- result of the function call.
8176 -- Temp : Unconstr_Typ_Ptr := Func_Call'reference;
8177 -- subtype S is Unconstr_Typ (Temp.all'First .. Temp.all'Last);
8178 -- Obj : S := Temp.all;
8179 -- SS_Release; -- Temp is gone at this point, bounds of S are
8183 -- Low_Bound : constant Base_Type (Index_Typ) := E'First (J);
8185 Low_Bound
:= Make_Temporary
(Loc
, 'B');
8187 Make_Object_Declaration
(Loc
,
8188 Defining_Identifier
=> Low_Bound
,
8189 Object_Definition
=>
8190 New_Occurrence_Of
(Base_Type
(Etype
(Index_Typ
)), Loc
),
8191 Constant_Present
=> True,
8193 Make_Attribute_Reference
(Loc
,
8194 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
8195 Attribute_Name
=> Name_First
,
8196 Expressions
=> New_List
(
8197 Make_Integer_Literal
(Loc
, J
)))));
8200 -- High_Bound : constant Base_Type (Index_Typ) := E'Last (J);
8202 High_Bound
:= Make_Temporary
(Loc
, 'B');
8204 Make_Object_Declaration
(Loc
,
8205 Defining_Identifier
=> High_Bound
,
8206 Object_Definition
=>
8207 New_Occurrence_Of
(Base_Type
(Etype
(Index_Typ
)), Loc
),
8208 Constant_Present
=> True,
8210 Make_Attribute_Reference
(Loc
,
8211 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
8212 Attribute_Name
=> Name_Last
,
8213 Expressions
=> New_List
(
8214 Make_Integer_Literal
(Loc
, J
)))));
8216 Append_To
(List_Constr
,
8218 Low_Bound
=> New_Occurrence_Of
(Low_Bound
, Loc
),
8219 High_Bound
=> New_Occurrence_Of
(High_Bound
, Loc
)));
8221 Index_Typ
:= Next_Index
(Index_Typ
);
8224 elsif Is_Class_Wide_Type
(Unc_Typ
) then
8226 CW_Subtype
: Entity_Id
;
8227 EQ_Typ
: Entity_Id
:= Empty
;
8230 -- A class-wide equivalent type is not needed on VM targets
8231 -- because the VM back-ends handle the class-wide object
8232 -- initialization itself (and doesn't need or want the
8233 -- additional intermediate type to handle the assignment).
8235 if Expander_Active
and then Tagged_Type_Expansion
then
8237 -- If this is the class-wide type of a completion that is a
8238 -- record subtype, set the type of the class-wide type to be
8239 -- the full base type, for use in the expanded code for the
8240 -- equivalent type. Should this be done earlier when the
8241 -- completion is analyzed ???
8243 if Is_Private_Type
(Etype
(Unc_Typ
))
8245 Ekind
(Full_View
(Etype
(Unc_Typ
))) = E_Record_Subtype
8247 Set_Etype
(Unc_Typ
, Base_Type
(Full_View
(Etype
(Unc_Typ
))));
8250 EQ_Typ
:= Make_CW_Equivalent_Type
(Unc_Typ
, E
);
8253 CW_Subtype
:= New_Class_Wide_Subtype
(Unc_Typ
, E
);
8254 Set_Equivalent_Type
(CW_Subtype
, EQ_Typ
);
8255 Set_Cloned_Subtype
(CW_Subtype
, Base_Type
(Unc_Typ
));
8257 return New_Occurrence_Of
(CW_Subtype
, Loc
);
8260 -- Indefinite record type with discriminants
8263 D
:= First_Discriminant
(Unc_Typ
);
8264 while Present
(D
) loop
8265 Append_To
(List_Constr
,
8266 Make_Selected_Component
(Loc
,
8267 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
8268 Selector_Name
=> New_Occurrence_Of
(D
, Loc
)));
8270 Next_Discriminant
(D
);
8275 Make_Subtype_Indication
(Loc
,
8276 Subtype_Mark
=> New_Occurrence_Of
(Unc_Typ
, Loc
),
8278 Make_Index_Or_Discriminant_Constraint
(Loc
,
8279 Constraints
=> List_Constr
));
8280 end Make_Subtype_From_Expr
;
8282 ----------------------------
8283 -- Matching_Standard_Type --
8284 ----------------------------
8286 function Matching_Standard_Type
(Typ
: Entity_Id
) return Entity_Id
is
8287 pragma Assert
(Is_Scalar_Type
(Typ
));
8288 Siz
: constant Uint
:= Esize
(Typ
);
8291 -- Floating-point cases
8293 if Is_Floating_Point_Type
(Typ
) then
8294 if Siz
<= Esize
(Standard_Short_Float
) then
8295 return Standard_Short_Float
;
8296 elsif Siz
<= Esize
(Standard_Float
) then
8297 return Standard_Float
;
8298 elsif Siz
<= Esize
(Standard_Long_Float
) then
8299 return Standard_Long_Float
;
8300 elsif Siz
<= Esize
(Standard_Long_Long_Float
) then
8301 return Standard_Long_Long_Float
;
8303 raise Program_Error
;
8306 -- Integer cases (includes fixed-point types)
8308 -- Unsigned integer cases (includes normal enumeration types)
8310 elsif Is_Unsigned_Type
(Typ
) then
8311 if Siz
<= Esize
(Standard_Short_Short_Unsigned
) then
8312 return Standard_Short_Short_Unsigned
;
8313 elsif Siz
<= Esize
(Standard_Short_Unsigned
) then
8314 return Standard_Short_Unsigned
;
8315 elsif Siz
<= Esize
(Standard_Unsigned
) then
8316 return Standard_Unsigned
;
8317 elsif Siz
<= Esize
(Standard_Long_Unsigned
) then
8318 return Standard_Long_Unsigned
;
8319 elsif Siz
<= Esize
(Standard_Long_Long_Unsigned
) then
8320 return Standard_Long_Long_Unsigned
;
8322 raise Program_Error
;
8325 -- Signed integer cases
8328 if Siz
<= Esize
(Standard_Short_Short_Integer
) then
8329 return Standard_Short_Short_Integer
;
8330 elsif Siz
<= Esize
(Standard_Short_Integer
) then
8331 return Standard_Short_Integer
;
8332 elsif Siz
<= Esize
(Standard_Integer
) then
8333 return Standard_Integer
;
8334 elsif Siz
<= Esize
(Standard_Long_Integer
) then
8335 return Standard_Long_Integer
;
8336 elsif Siz
<= Esize
(Standard_Long_Long_Integer
) then
8337 return Standard_Long_Long_Integer
;
8339 raise Program_Error
;
8342 end Matching_Standard_Type
;
8344 -----------------------------
8345 -- May_Generate_Large_Temp --
8346 -----------------------------
8348 -- At the current time, the only types that we return False for (i.e. where
8349 -- we decide we know they cannot generate large temps) are ones where we
8350 -- know the size is 256 bits or less at compile time, and we are still not
8351 -- doing a thorough job on arrays and records ???
8353 function May_Generate_Large_Temp
(Typ
: Entity_Id
) return Boolean is
8355 if not Size_Known_At_Compile_Time
(Typ
) then
8358 elsif Esize
(Typ
) /= 0 and then Esize
(Typ
) <= 256 then
8361 elsif Is_Array_Type
(Typ
)
8362 and then Present
(Packed_Array_Impl_Type
(Typ
))
8364 return May_Generate_Large_Temp
(Packed_Array_Impl_Type
(Typ
));
8366 -- We could do more here to find other small types ???
8371 end May_Generate_Large_Temp
;
8373 ------------------------
8374 -- Needs_Finalization --
8375 ------------------------
8377 function Needs_Finalization
(T
: Entity_Id
) return Boolean is
8378 function Has_Some_Controlled_Component
(Rec
: Entity_Id
) return Boolean;
8379 -- If type is not frozen yet, check explicitly among its components,
8380 -- because the Has_Controlled_Component flag is not necessarily set.
8382 -----------------------------------
8383 -- Has_Some_Controlled_Component --
8384 -----------------------------------
8386 function Has_Some_Controlled_Component
8387 (Rec
: Entity_Id
) return Boolean
8392 if Has_Controlled_Component
(Rec
) then
8395 elsif not Is_Frozen
(Rec
) then
8396 if Is_Record_Type
(Rec
) then
8397 Comp
:= First_Entity
(Rec
);
8399 while Present
(Comp
) loop
8400 if not Is_Type
(Comp
)
8401 and then Needs_Finalization
(Etype
(Comp
))
8414 and then Needs_Finalization
(Component_Type
(Rec
));
8419 end Has_Some_Controlled_Component
;
8421 -- Start of processing for Needs_Finalization
8424 -- Certain run-time configurations and targets do not provide support
8425 -- for controlled types.
8427 if Restriction_Active
(No_Finalization
) then
8430 -- C++ types are not considered controlled. It is assumed that the
8431 -- non-Ada side will handle their clean up.
8433 elsif Convention
(T
) = Convention_CPP
then
8436 -- Never needs finalization if Disable_Controlled set
8438 elsif Disable_Controlled
(T
) then
8441 elsif Is_Class_Wide_Type
(T
) and then Disable_Controlled
(Etype
(T
)) then
8445 -- Class-wide types are treated as controlled because derivations
8446 -- from the root type can introduce controlled components.
8448 return Is_Class_Wide_Type
(T
)
8449 or else Is_Controlled
(T
)
8450 or else Has_Some_Controlled_Component
(T
)
8452 (Is_Concurrent_Type
(T
)
8453 and then Present
(Corresponding_Record_Type
(T
))
8454 and then Needs_Finalization
(Corresponding_Record_Type
(T
)));
8456 end Needs_Finalization
;
8458 ----------------------------
8459 -- Needs_Constant_Address --
8460 ----------------------------
8462 function Needs_Constant_Address
8464 Typ
: Entity_Id
) return Boolean
8468 -- If we have no initialization of any kind, then we don't need to place
8469 -- any restrictions on the address clause, because the object will be
8470 -- elaborated after the address clause is evaluated. This happens if the
8471 -- declaration has no initial expression, or the type has no implicit
8472 -- initialization, or the object is imported.
8474 -- The same holds for all initialized scalar types and all access types.
8475 -- Packed bit arrays of size up to 64 are represented using a modular
8476 -- type with an initialization (to zero) and can be processed like other
8477 -- initialized scalar types.
8479 -- If the type is controlled, code to attach the object to a
8480 -- finalization chain is generated at the point of declaration, and
8481 -- therefore the elaboration of the object cannot be delayed: the
8482 -- address expression must be a constant.
8484 if No
(Expression
(Decl
))
8485 and then not Needs_Finalization
(Typ
)
8487 (not Has_Non_Null_Base_Init_Proc
(Typ
)
8488 or else Is_Imported
(Defining_Identifier
(Decl
)))
8492 elsif (Present
(Expression
(Decl
)) and then Is_Scalar_Type
(Typ
))
8493 or else Is_Access_Type
(Typ
)
8495 (Is_Bit_Packed_Array
(Typ
)
8496 and then Is_Modular_Integer_Type
(Packed_Array_Impl_Type
(Typ
)))
8502 -- Otherwise, we require the address clause to be constant because
8503 -- the call to the initialization procedure (or the attach code) has
8504 -- to happen at the point of the declaration.
8506 -- Actually the IP call has been moved to the freeze actions anyway,
8507 -- so maybe we can relax this restriction???
8511 end Needs_Constant_Address
;
8513 ----------------------------
8514 -- New_Class_Wide_Subtype --
8515 ----------------------------
8517 function New_Class_Wide_Subtype
8518 (CW_Typ
: Entity_Id
;
8519 N
: Node_Id
) return Entity_Id
8521 Res
: constant Entity_Id
:= Create_Itype
(E_Void
, N
);
8522 Res_Name
: constant Name_Id
:= Chars
(Res
);
8523 Res_Scope
: constant Entity_Id
:= Scope
(Res
);
8526 Copy_Node
(CW_Typ
, Res
);
8527 Set_Comes_From_Source
(Res
, False);
8528 Set_Sloc
(Res
, Sloc
(N
));
8530 Set_Associated_Node_For_Itype
(Res
, N
);
8531 Set_Is_Public
(Res
, False); -- By default, may be changed below.
8532 Set_Public_Status
(Res
);
8533 Set_Chars
(Res
, Res_Name
);
8534 Set_Scope
(Res
, Res_Scope
);
8535 Set_Ekind
(Res
, E_Class_Wide_Subtype
);
8536 Set_Next_Entity
(Res
, Empty
);
8537 Set_Etype
(Res
, Base_Type
(CW_Typ
));
8538 Set_Is_Frozen
(Res
, False);
8539 Set_Freeze_Node
(Res
, Empty
);
8541 end New_Class_Wide_Subtype
;
8543 --------------------------------
8544 -- Non_Limited_Designated_Type --
8545 ---------------------------------
8547 function Non_Limited_Designated_Type
(T
: Entity_Id
) return Entity_Id
is
8548 Desig
: constant Entity_Id
:= Designated_Type
(T
);
8550 if Has_Non_Limited_View
(Desig
) then
8551 return Non_Limited_View
(Desig
);
8555 end Non_Limited_Designated_Type
;
8557 -----------------------------------
8558 -- OK_To_Do_Constant_Replacement --
8559 -----------------------------------
8561 function OK_To_Do_Constant_Replacement
(E
: Entity_Id
) return Boolean is
8562 ES
: constant Entity_Id
:= Scope
(E
);
8566 -- Do not replace statically allocated objects, because they may be
8567 -- modified outside the current scope.
8569 if Is_Statically_Allocated
(E
) then
8572 -- Do not replace aliased or volatile objects, since we don't know what
8573 -- else might change the value.
8575 elsif Is_Aliased
(E
) or else Treat_As_Volatile
(E
) then
8578 -- Debug flag -gnatdM disconnects this optimization
8580 elsif Debug_Flag_MM
then
8583 -- Otherwise check scopes
8586 CS
:= Current_Scope
;
8589 -- If we are in right scope, replacement is safe
8594 -- Packages do not affect the determination of safety
8596 elsif Ekind
(CS
) = E_Package
then
8597 exit when CS
= Standard_Standard
;
8600 -- Blocks do not affect the determination of safety
8602 elsif Ekind
(CS
) = E_Block
then
8605 -- Loops do not affect the determination of safety. Note that we
8606 -- kill all current values on entry to a loop, so we are just
8607 -- talking about processing within a loop here.
8609 elsif Ekind
(CS
) = E_Loop
then
8612 -- Otherwise, the reference is dubious, and we cannot be sure that
8613 -- it is safe to do the replacement.
8622 end OK_To_Do_Constant_Replacement
;
8624 ------------------------------------
8625 -- Possible_Bit_Aligned_Component --
8626 ------------------------------------
8628 function Possible_Bit_Aligned_Component
(N
: Node_Id
) return Boolean is
8630 -- Do not process an unanalyzed node because it is not yet decorated and
8631 -- most checks performed below will fail.
8633 if not Analyzed
(N
) then
8639 -- Case of indexed component
8641 when N_Indexed_Component
=>
8643 P
: constant Node_Id
:= Prefix
(N
);
8644 Ptyp
: constant Entity_Id
:= Etype
(P
);
8647 -- If we know the component size and it is less than 64, then
8648 -- we are definitely OK. The back end always does assignment of
8649 -- misaligned small objects correctly.
8651 if Known_Static_Component_Size
(Ptyp
)
8652 and then Component_Size
(Ptyp
) <= 64
8656 -- Otherwise, we need to test the prefix, to see if we are
8657 -- indexing from a possibly unaligned component.
8660 return Possible_Bit_Aligned_Component
(P
);
8664 -- Case of selected component
8666 when N_Selected_Component
=>
8668 P
: constant Node_Id
:= Prefix
(N
);
8669 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
8672 -- If there is no component clause, then we are in the clear
8673 -- since the back end will never misalign a large component
8674 -- unless it is forced to do so. In the clear means we need
8675 -- only the recursive test on the prefix.
8677 if Component_May_Be_Bit_Aligned
(Comp
) then
8680 return Possible_Bit_Aligned_Component
(P
);
8684 -- For a slice, test the prefix, if that is possibly misaligned,
8685 -- then for sure the slice is.
8688 return Possible_Bit_Aligned_Component
(Prefix
(N
));
8690 -- For an unchecked conversion, check whether the expression may
8693 when N_Unchecked_Type_Conversion
=>
8694 return Possible_Bit_Aligned_Component
(Expression
(N
));
8696 -- If we have none of the above, it means that we have fallen off the
8697 -- top testing prefixes recursively, and we now have a stand alone
8698 -- object, where we don't have a problem, unless this is a renaming,
8699 -- in which case we need to look into the renamed object.
8702 if Is_Entity_Name
(N
)
8703 and then Present
(Renamed_Object
(Entity
(N
)))
8706 Possible_Bit_Aligned_Component
(Renamed_Object
(Entity
(N
)));
8711 end Possible_Bit_Aligned_Component
;
8713 -----------------------------------------------
8714 -- Process_Statements_For_Controlled_Objects --
8715 -----------------------------------------------
8717 procedure Process_Statements_For_Controlled_Objects
(N
: Node_Id
) is
8718 Loc
: constant Source_Ptr
:= Sloc
(N
);
8720 function Are_Wrapped
(L
: List_Id
) return Boolean;
8721 -- Determine whether list L contains only one statement which is a block
8723 function Wrap_Statements_In_Block
8725 Scop
: Entity_Id
:= Current_Scope
) return Node_Id
;
8726 -- Given a list of statements L, wrap it in a block statement and return
8727 -- the generated node. Scop is either the current scope or the scope of
8728 -- the context (if applicable).
8734 function Are_Wrapped
(L
: List_Id
) return Boolean is
8735 Stmt
: constant Node_Id
:= First
(L
);
8739 and then No
(Next
(Stmt
))
8740 and then Nkind
(Stmt
) = N_Block_Statement
;
8743 ------------------------------
8744 -- Wrap_Statements_In_Block --
8745 ------------------------------
8747 function Wrap_Statements_In_Block
8749 Scop
: Entity_Id
:= Current_Scope
) return Node_Id
8751 Block_Id
: Entity_Id
;
8752 Block_Nod
: Node_Id
;
8753 Iter_Loop
: Entity_Id
;
8757 Make_Block_Statement
(Loc
,
8758 Declarations
=> No_List
,
8759 Handled_Statement_Sequence
=>
8760 Make_Handled_Sequence_Of_Statements
(Loc
,
8763 -- Create a label for the block in case the block needs to manage the
8764 -- secondary stack. A label allows for flag Uses_Sec_Stack to be set.
8766 Add_Block_Identifier
(Block_Nod
, Block_Id
);
8768 -- When wrapping the statements of an iterator loop, check whether
8769 -- the loop requires secondary stack management and if so, propagate
8770 -- the appropriate flags to the block. This ensures that the cursor
8771 -- is properly cleaned up at each iteration of the loop.
8773 Iter_Loop
:= Find_Enclosing_Iterator_Loop
(Scop
);
8775 if Present
(Iter_Loop
) then
8776 Set_Uses_Sec_Stack
(Block_Id
, Uses_Sec_Stack
(Iter_Loop
));
8778 -- Secondary stack reclamation is suppressed when the associated
8779 -- iterator loop contains a return statement which uses the stack.
8781 Set_Sec_Stack_Needed_For_Return
8782 (Block_Id
, Sec_Stack_Needed_For_Return
(Iter_Loop
));
8786 end Wrap_Statements_In_Block
;
8792 -- Start of processing for Process_Statements_For_Controlled_Objects
8795 -- Whenever a non-handled statement list is wrapped in a block, the
8796 -- block must be explicitly analyzed to redecorate all entities in the
8797 -- list and ensure that a finalizer is properly built.
8800 when N_Conditional_Entry_Call
8803 | N_Selective_Accept
8805 -- Check the "then statements" for elsif parts and if statements
8807 if Nkind_In
(N
, N_Elsif_Part
, N_If_Statement
)
8808 and then not Is_Empty_List
(Then_Statements
(N
))
8809 and then not Are_Wrapped
(Then_Statements
(N
))
8810 and then Requires_Cleanup_Actions
8811 (Then_Statements
(N
), False, False)
8813 Block
:= Wrap_Statements_In_Block
(Then_Statements
(N
));
8814 Set_Then_Statements
(N
, New_List
(Block
));
8819 -- Check the "else statements" for conditional entry calls, if
8820 -- statements and selective accepts.
8822 if Nkind_In
(N
, N_Conditional_Entry_Call
,
8825 and then not Is_Empty_List
(Else_Statements
(N
))
8826 and then not Are_Wrapped
(Else_Statements
(N
))
8827 and then Requires_Cleanup_Actions
8828 (Else_Statements
(N
), False, False)
8830 Block
:= Wrap_Statements_In_Block
(Else_Statements
(N
));
8831 Set_Else_Statements
(N
, New_List
(Block
));
8836 when N_Abortable_Part
8837 | N_Accept_Alternative
8838 | N_Case_Statement_Alternative
8839 | N_Delay_Alternative
8840 | N_Entry_Call_Alternative
8841 | N_Exception_Handler
8843 | N_Triggering_Alternative
8845 if not Is_Empty_List
(Statements
(N
))
8846 and then not Are_Wrapped
(Statements
(N
))
8847 and then Requires_Cleanup_Actions
(Statements
(N
), False, False)
8849 if Nkind
(N
) = N_Loop_Statement
8850 and then Present
(Identifier
(N
))
8853 Wrap_Statements_In_Block
8854 (L
=> Statements
(N
),
8855 Scop
=> Entity
(Identifier
(N
)));
8857 Block
:= Wrap_Statements_In_Block
(Statements
(N
));
8860 Set_Statements
(N
, New_List
(Block
));
8867 end Process_Statements_For_Controlled_Objects
;
8873 function Power_Of_Two
(N
: Node_Id
) return Nat
is
8874 Typ
: constant Entity_Id
:= Etype
(N
);
8875 pragma Assert
(Is_Integer_Type
(Typ
));
8877 Siz
: constant Nat
:= UI_To_Int
(Esize
(Typ
));
8881 if not Compile_Time_Known_Value
(N
) then
8885 Val
:= Expr_Value
(N
);
8886 for J
in 1 .. Siz
- 1 loop
8887 if Val
= Uint_2
** J
then
8896 ----------------------
8897 -- Remove_Init_Call --
8898 ----------------------
8900 function Remove_Init_Call
8902 Rep_Clause
: Node_Id
) return Node_Id
8904 Par
: constant Node_Id
:= Parent
(Var
);
8905 Typ
: constant Entity_Id
:= Etype
(Var
);
8907 Init_Proc
: Entity_Id
;
8908 -- Initialization procedure for Typ
8910 function Find_Init_Call_In_List
(From
: Node_Id
) return Node_Id
;
8911 -- Look for init call for Var starting at From and scanning the
8912 -- enclosing list until Rep_Clause or the end of the list is reached.
8914 ----------------------------
8915 -- Find_Init_Call_In_List --
8916 ----------------------------
8918 function Find_Init_Call_In_List
(From
: Node_Id
) return Node_Id
is
8919 Init_Call
: Node_Id
;
8923 while Present
(Init_Call
) and then Init_Call
/= Rep_Clause
loop
8924 if Nkind
(Init_Call
) = N_Procedure_Call_Statement
8925 and then Is_Entity_Name
(Name
(Init_Call
))
8926 and then Entity
(Name
(Init_Call
)) = Init_Proc
8935 end Find_Init_Call_In_List
;
8937 Init_Call
: Node_Id
;
8939 -- Start of processing for Find_Init_Call
8942 if Present
(Initialization_Statements
(Var
)) then
8943 Init_Call
:= Initialization_Statements
(Var
);
8944 Set_Initialization_Statements
(Var
, Empty
);
8946 elsif not Has_Non_Null_Base_Init_Proc
(Typ
) then
8948 -- No init proc for the type, so obviously no call to be found
8953 -- We might be able to handle other cases below by just properly
8954 -- setting Initialization_Statements at the point where the init proc
8955 -- call is generated???
8957 Init_Proc
:= Base_Init_Proc
(Typ
);
8959 -- First scan the list containing the declaration of Var
8961 Init_Call
:= Find_Init_Call_In_List
(From
=> Next
(Par
));
8963 -- If not found, also look on Var's freeze actions list, if any,
8964 -- since the init call may have been moved there (case of an address
8965 -- clause applying to Var).
8967 if No
(Init_Call
) and then Present
(Freeze_Node
(Var
)) then
8969 Find_Init_Call_In_List
(First
(Actions
(Freeze_Node
(Var
))));
8972 -- If the initialization call has actuals that use the secondary
8973 -- stack, the call may have been wrapped into a temporary block, in
8974 -- which case the block itself has to be removed.
8976 if No
(Init_Call
) and then Nkind
(Next
(Par
)) = N_Block_Statement
then
8978 Blk
: constant Node_Id
:= Next
(Par
);
8981 (Find_Init_Call_In_List
8982 (First
(Statements
(Handled_Statement_Sequence
(Blk
)))))
8990 if Present
(Init_Call
) then
8994 end Remove_Init_Call
;
8996 -------------------------
8997 -- Remove_Side_Effects --
8998 -------------------------
9000 procedure Remove_Side_Effects
9002 Name_Req
: Boolean := False;
9003 Renaming_Req
: Boolean := False;
9004 Variable_Ref
: Boolean := False;
9005 Related_Id
: Entity_Id
:= Empty
;
9006 Is_Low_Bound
: Boolean := False;
9007 Is_High_Bound
: Boolean := False;
9008 Check_Side_Effects
: Boolean := True)
9010 function Build_Temporary
9013 Related_Nod
: Node_Id
:= Empty
) return Entity_Id
;
9014 -- Create an external symbol of the form xxx_FIRST/_LAST if Related_Nod
9015 -- is present (xxx is taken from the Chars field of Related_Nod),
9016 -- otherwise it generates an internal temporary.
9018 ---------------------
9019 -- Build_Temporary --
9020 ---------------------
9022 function Build_Temporary
9025 Related_Nod
: Node_Id
:= Empty
) return Entity_Id
9030 -- The context requires an external symbol
9032 if Present
(Related_Id
) then
9033 if Is_Low_Bound
then
9034 Temp_Nam
:= New_External_Name
(Chars
(Related_Id
), "_FIRST");
9035 else pragma Assert
(Is_High_Bound
);
9036 Temp_Nam
:= New_External_Name
(Chars
(Related_Id
), "_LAST");
9039 return Make_Defining_Identifier
(Loc
, Temp_Nam
);
9041 -- Otherwise generate an internal temporary
9044 return Make_Temporary
(Loc
, Id
, Related_Nod
);
9046 end Build_Temporary
;
9050 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
9051 Exp_Type
: constant Entity_Id
:= Etype
(Exp
);
9052 Svg_Suppress
: constant Suppress_Record
:= Scope_Suppress
;
9056 Ptr_Typ_Decl
: Node_Id
;
9057 Ref_Type
: Entity_Id
;
9060 -- Start of processing for Remove_Side_Effects
9063 -- Handle cases in which there is nothing to do. In GNATprove mode,
9064 -- removal of side effects is useful for the light expansion of
9065 -- renamings. This removal should only occur when not inside a
9066 -- generic and not doing a pre-analysis.
9068 if not Expander_Active
9069 and (Inside_A_Generic
or not Full_Analysis
or not GNATprove_Mode
)
9073 -- Cannot generate temporaries if the invocation to remove side effects
9074 -- was issued too early and the type of the expression is not resolved
9075 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
9076 -- Remove_Side_Effects).
9079 or else Ekind
(Exp_Type
) = E_Access_Attribute_Type
9083 -- Nothing to do if prior expansion determined that a function call does
9084 -- not require side effect removal.
9086 elsif Nkind
(Exp
) = N_Function_Call
9087 and then No_Side_Effect_Removal
(Exp
)
9091 -- No action needed for side-effect free expressions
9093 elsif Check_Side_Effects
9094 and then Side_Effect_Free
(Exp
, Name_Req
, Variable_Ref
)
9099 -- The remaining processing is done with all checks suppressed
9101 -- Note: from now on, don't use return statements, instead do a goto
9102 -- Leave, to ensure that we properly restore Scope_Suppress.Suppress.
9104 Scope_Suppress
.Suppress
:= (others => True);
9106 -- If this is an elementary or a small not by-reference record type, and
9107 -- we need to capture the value, just make a constant; this is cheap and
9108 -- objects of both kinds of types can be bit aligned, so it might not be
9109 -- possible to generate a reference to them. Likewise if this is not a
9110 -- name reference, except for a type conversion because we would enter
9111 -- an infinite recursion with Checks.Apply_Predicate_Check if the target
9112 -- type has predicates (and type conversions need a specific treatment
9113 -- anyway, see below). Also do it if we have a volatile reference and
9114 -- Name_Req is not set (see comments for Side_Effect_Free).
9116 if (Is_Elementary_Type
(Exp_Type
)
9117 or else (Is_Record_Type
(Exp_Type
)
9118 and then Known_Static_RM_Size
(Exp_Type
)
9119 and then RM_Size
(Exp_Type
) <= 64
9120 and then not Has_Discriminants
(Exp_Type
)
9121 and then not Is_By_Reference_Type
(Exp_Type
)))
9122 and then (Variable_Ref
9123 or else (not Is_Name_Reference
(Exp
)
9124 and then Nkind
(Exp
) /= N_Type_Conversion
)
9125 or else (not Name_Req
9126 and then Is_Volatile_Reference
(Exp
)))
9128 Def_Id
:= Build_Temporary
(Loc
, 'R', Exp
);
9129 Set_Etype
(Def_Id
, Exp_Type
);
9130 Res
:= New_Occurrence_Of
(Def_Id
, Loc
);
9132 -- If the expression is a packed reference, it must be reanalyzed and
9133 -- expanded, depending on context. This is the case for actuals where
9134 -- a constraint check may capture the actual before expansion of the
9135 -- call is complete.
9137 if Nkind
(Exp
) = N_Indexed_Component
9138 and then Is_Packed
(Etype
(Prefix
(Exp
)))
9140 Set_Analyzed
(Exp
, False);
9141 Set_Analyzed
(Prefix
(Exp
), False);
9145 -- Rnn : Exp_Type renames Expr;
9147 if Renaming_Req
then
9149 Make_Object_Renaming_Declaration
(Loc
,
9150 Defining_Identifier
=> Def_Id
,
9151 Subtype_Mark
=> New_Occurrence_Of
(Exp_Type
, Loc
),
9152 Name
=> Relocate_Node
(Exp
));
9155 -- Rnn : constant Exp_Type := Expr;
9159 Make_Object_Declaration
(Loc
,
9160 Defining_Identifier
=> Def_Id
,
9161 Object_Definition
=> New_Occurrence_Of
(Exp_Type
, Loc
),
9162 Constant_Present
=> True,
9163 Expression
=> Relocate_Node
(Exp
));
9165 Set_Assignment_OK
(E
);
9168 Insert_Action
(Exp
, E
);
9170 -- If the expression has the form v.all then we can just capture the
9171 -- pointer, and then do an explicit dereference on the result, but
9172 -- this is not right if this is a volatile reference.
9174 elsif Nkind
(Exp
) = N_Explicit_Dereference
9175 and then not Is_Volatile_Reference
(Exp
)
9177 Def_Id
:= Build_Temporary
(Loc
, 'R', Exp
);
9179 Make_Explicit_Dereference
(Loc
, New_Occurrence_Of
(Def_Id
, Loc
));
9182 Make_Object_Declaration
(Loc
,
9183 Defining_Identifier
=> Def_Id
,
9184 Object_Definition
=>
9185 New_Occurrence_Of
(Etype
(Prefix
(Exp
)), Loc
),
9186 Constant_Present
=> True,
9187 Expression
=> Relocate_Node
(Prefix
(Exp
))));
9189 -- Similar processing for an unchecked conversion of an expression of
9190 -- the form v.all, where we want the same kind of treatment.
9192 elsif Nkind
(Exp
) = N_Unchecked_Type_Conversion
9193 and then Nkind
(Expression
(Exp
)) = N_Explicit_Dereference
9195 Remove_Side_Effects
(Expression
(Exp
), Name_Req
, Variable_Ref
);
9198 -- If this is a type conversion, leave the type conversion and remove
9199 -- the side effects in the expression. This is important in several
9200 -- circumstances: for change of representations, and also when this is a
9201 -- view conversion to a smaller object, where gigi can end up creating
9202 -- its own temporary of the wrong size.
9204 elsif Nkind
(Exp
) = N_Type_Conversion
then
9205 Remove_Side_Effects
(Expression
(Exp
), Name_Req
, Variable_Ref
);
9207 -- Generating C code the type conversion of an access to constrained
9208 -- array type into an access to unconstrained array type involves
9209 -- initializing a fat pointer and the expression must be free of
9210 -- side effects to safely compute its bounds.
9212 if Modify_Tree_For_C
9213 and then Is_Access_Type
(Etype
(Exp
))
9214 and then Is_Array_Type
(Designated_Type
(Etype
(Exp
)))
9215 and then not Is_Constrained
(Designated_Type
(Etype
(Exp
)))
9217 Def_Id
:= Build_Temporary
(Loc
, 'R', Exp
);
9218 Set_Etype
(Def_Id
, Exp_Type
);
9219 Res
:= New_Occurrence_Of
(Def_Id
, Loc
);
9222 Make_Object_Declaration
(Loc
,
9223 Defining_Identifier
=> Def_Id
,
9224 Object_Definition
=> New_Occurrence_Of
(Exp_Type
, Loc
),
9225 Constant_Present
=> True,
9226 Expression
=> Relocate_Node
(Exp
)));
9231 -- If this is an unchecked conversion that Gigi can't handle, make
9232 -- a copy or a use a renaming to capture the value.
9234 elsif Nkind
(Exp
) = N_Unchecked_Type_Conversion
9235 and then not Safe_Unchecked_Type_Conversion
(Exp
)
9237 if CW_Or_Has_Controlled_Part
(Exp_Type
) then
9239 -- Use a renaming to capture the expression, rather than create
9240 -- a controlled temporary.
9242 Def_Id
:= Build_Temporary
(Loc
, 'R', Exp
);
9243 Res
:= New_Occurrence_Of
(Def_Id
, Loc
);
9246 Make_Object_Renaming_Declaration
(Loc
,
9247 Defining_Identifier
=> Def_Id
,
9248 Subtype_Mark
=> New_Occurrence_Of
(Exp_Type
, Loc
),
9249 Name
=> Relocate_Node
(Exp
)));
9252 Def_Id
:= Build_Temporary
(Loc
, 'R', Exp
);
9253 Set_Etype
(Def_Id
, Exp_Type
);
9254 Res
:= New_Occurrence_Of
(Def_Id
, Loc
);
9257 Make_Object_Declaration
(Loc
,
9258 Defining_Identifier
=> Def_Id
,
9259 Object_Definition
=> New_Occurrence_Of
(Exp_Type
, Loc
),
9260 Constant_Present
=> not Is_Variable
(Exp
),
9261 Expression
=> Relocate_Node
(Exp
));
9263 Set_Assignment_OK
(E
);
9264 Insert_Action
(Exp
, E
);
9267 -- For expressions that denote names, we can use a renaming scheme.
9268 -- This is needed for correctness in the case of a volatile object of
9269 -- a non-volatile type because the Make_Reference call of the "default"
9270 -- approach would generate an illegal access value (an access value
9271 -- cannot designate such an object - see Analyze_Reference).
9273 elsif Is_Name_Reference
(Exp
)
9275 -- We skip using this scheme if we have an object of a volatile
9276 -- type and we do not have Name_Req set true (see comments for
9277 -- Side_Effect_Free).
9279 and then (Name_Req
or else not Treat_As_Volatile
(Exp_Type
))
9281 Def_Id
:= Build_Temporary
(Loc
, 'R', Exp
);
9282 Res
:= New_Occurrence_Of
(Def_Id
, Loc
);
9285 Make_Object_Renaming_Declaration
(Loc
,
9286 Defining_Identifier
=> Def_Id
,
9287 Subtype_Mark
=> New_Occurrence_Of
(Exp_Type
, Loc
),
9288 Name
=> Relocate_Node
(Exp
)));
9290 -- If this is a packed reference, or a selected component with
9291 -- a non-standard representation, a reference to the temporary
9292 -- will be replaced by a copy of the original expression (see
9293 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
9294 -- elaborated by gigi, and is of course not to be replaced in-line
9295 -- by the expression it renames, which would defeat the purpose of
9296 -- removing the side-effect.
9298 if Nkind_In
(Exp
, N_Selected_Component
, N_Indexed_Component
)
9299 and then Has_Non_Standard_Rep
(Etype
(Prefix
(Exp
)))
9303 Set_Is_Renaming_Of_Object
(Def_Id
, False);
9306 -- Avoid generating a variable-sized temporary, by generating the
9307 -- reference just for the function call. The transformation could be
9308 -- refined to apply only when the array component is constrained by a
9311 elsif Nkind
(Exp
) = N_Selected_Component
9312 and then Nkind
(Prefix
(Exp
)) = N_Function_Call
9313 and then Is_Array_Type
(Exp_Type
)
9315 Remove_Side_Effects
(Prefix
(Exp
), Name_Req
, Variable_Ref
);
9318 -- Otherwise we generate a reference to the expression
9321 -- An expression which is in SPARK mode is considered side effect
9322 -- free if the resulting value is captured by a variable or a
9326 and then Nkind
(Parent
(Exp
)) = N_Object_Declaration
9330 -- When generating C code we cannot consider side effect free object
9331 -- declarations that have discriminants and are initialized by means
9332 -- of a function call since on this target there is no secondary
9333 -- stack to store the return value and the expander may generate an
9334 -- extra call to the function to compute the discriminant value. In
9335 -- addition, for targets that have secondary stack, the expansion of
9336 -- functions with side effects involves the generation of an access
9337 -- type to capture the return value stored in the secondary stack;
9338 -- by contrast when generating C code such expansion generates an
9339 -- internal object declaration (no access type involved) which must
9340 -- be identified here to avoid entering into a never-ending loop
9341 -- generating internal object declarations.
9343 elsif Modify_Tree_For_C
9344 and then Nkind
(Parent
(Exp
)) = N_Object_Declaration
9346 (Nkind
(Exp
) /= N_Function_Call
9347 or else not Has_Discriminants
(Exp_Type
)
9348 or else Is_Internal_Name
9349 (Chars
(Defining_Identifier
(Parent
(Exp
)))))
9354 -- Special processing for function calls that return a limited type.
9355 -- We need to build a declaration that will enable build-in-place
9356 -- expansion of the call. This is not done if the context is already
9357 -- an object declaration, to prevent infinite recursion.
9359 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
9360 -- to accommodate functions returning limited objects by reference.
9362 if Ada_Version
>= Ada_2005
9363 and then Nkind
(Exp
) = N_Function_Call
9364 and then Is_Limited_View
(Etype
(Exp
))
9365 and then Nkind
(Parent
(Exp
)) /= N_Object_Declaration
9368 Obj
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F', Exp
);
9373 Make_Object_Declaration
(Loc
,
9374 Defining_Identifier
=> Obj
,
9375 Object_Definition
=> New_Occurrence_Of
(Exp_Type
, Loc
),
9376 Expression
=> Relocate_Node
(Exp
));
9378 Insert_Action
(Exp
, Decl
);
9379 Set_Etype
(Obj
, Exp_Type
);
9380 Rewrite
(Exp
, New_Occurrence_Of
(Obj
, Loc
));
9385 Def_Id
:= Build_Temporary
(Loc
, 'R', Exp
);
9387 -- The regular expansion of functions with side effects involves the
9388 -- generation of an access type to capture the return value found on
9389 -- the secondary stack. Since SPARK (and why) cannot process access
9390 -- types, use a different approach which ignores the secondary stack
9391 -- and "copies" the returned object.
9392 -- When generating C code, no need for a 'reference since the
9393 -- secondary stack is not supported.
9395 if GNATprove_Mode
or Modify_Tree_For_C
then
9396 Res
:= New_Occurrence_Of
(Def_Id
, Loc
);
9397 Ref_Type
:= Exp_Type
;
9399 -- Regular expansion utilizing an access type and 'reference
9403 Make_Explicit_Dereference
(Loc
,
9404 Prefix
=> New_Occurrence_Of
(Def_Id
, Loc
));
9407 -- type Ann is access all <Exp_Type>;
9409 Ref_Type
:= Make_Temporary
(Loc
, 'A');
9412 Make_Full_Type_Declaration
(Loc
,
9413 Defining_Identifier
=> Ref_Type
,
9415 Make_Access_To_Object_Definition
(Loc
,
9416 All_Present
=> True,
9417 Subtype_Indication
=>
9418 New_Occurrence_Of
(Exp_Type
, Loc
)));
9420 Insert_Action
(Exp
, Ptr_Typ_Decl
);
9424 if Nkind
(E
) = N_Explicit_Dereference
then
9425 New_Exp
:= Relocate_Node
(Prefix
(E
));
9428 E
:= Relocate_Node
(E
);
9430 -- Do not generate a 'reference in SPARK mode or C generation
9431 -- since the access type is not created in the first place.
9433 if GNATprove_Mode
or Modify_Tree_For_C
then
9436 -- Otherwise generate reference, marking the value as non-null
9437 -- since we know it cannot be null and we don't want a check.
9440 New_Exp
:= Make_Reference
(Loc
, E
);
9441 Set_Is_Known_Non_Null
(Def_Id
);
9445 if Is_Delayed_Aggregate
(E
) then
9447 -- The expansion of nested aggregates is delayed until the
9448 -- enclosing aggregate is expanded. As aggregates are often
9449 -- qualified, the predicate applies to qualified expressions as
9450 -- well, indicating that the enclosing aggregate has not been
9451 -- expanded yet. At this point the aggregate is part of a
9452 -- stand-alone declaration, and must be fully expanded.
9454 if Nkind
(E
) = N_Qualified_Expression
then
9455 Set_Expansion_Delayed
(Expression
(E
), False);
9456 Set_Analyzed
(Expression
(E
), False);
9458 Set_Expansion_Delayed
(E
, False);
9461 Set_Analyzed
(E
, False);
9464 -- Generating C code of object declarations that have discriminants
9465 -- and are initialized by means of a function call we propagate the
9466 -- discriminants of the parent type to the internally built object.
9467 -- This is needed to avoid generating an extra call to the called
9470 -- For example, if we generate here the following declaration, it
9471 -- will be expanded later adding an extra call to evaluate the value
9472 -- of the discriminant (needed to compute the size of the object).
9474 -- type Rec (D : Integer) is ...
9475 -- Obj : constant Rec := SomeFunc;
9477 if Modify_Tree_For_C
9478 and then Nkind
(Parent
(Exp
)) = N_Object_Declaration
9479 and then Has_Discriminants
(Exp_Type
)
9480 and then Nkind
(Exp
) = N_Function_Call
9483 Make_Object_Declaration
(Loc
,
9484 Defining_Identifier
=> Def_Id
,
9485 Object_Definition
=> New_Copy_Tree
9486 (Object_Definition
(Parent
(Exp
))),
9487 Constant_Present
=> True,
9488 Expression
=> New_Exp
));
9491 Make_Object_Declaration
(Loc
,
9492 Defining_Identifier
=> Def_Id
,
9493 Object_Definition
=> New_Occurrence_Of
(Ref_Type
, Loc
),
9494 Constant_Present
=> True,
9495 Expression
=> New_Exp
));
9499 -- Preserve the Assignment_OK flag in all copies, since at least one
9500 -- copy may be used in a context where this flag must be set (otherwise
9501 -- why would the flag be set in the first place).
9503 Set_Assignment_OK
(Res
, Assignment_OK
(Exp
));
9505 -- Finally rewrite the original expression and we are done
9508 Analyze_And_Resolve
(Exp
, Exp_Type
);
9511 Scope_Suppress
:= Svg_Suppress
;
9512 end Remove_Side_Effects
;
9514 ---------------------------
9515 -- Represented_As_Scalar --
9516 ---------------------------
9518 function Represented_As_Scalar
(T
: Entity_Id
) return Boolean is
9519 UT
: constant Entity_Id
:= Underlying_Type
(T
);
9521 return Is_Scalar_Type
(UT
)
9522 or else (Is_Bit_Packed_Array
(UT
)
9523 and then Is_Scalar_Type
(Packed_Array_Impl_Type
(UT
)));
9524 end Represented_As_Scalar
;
9526 ------------------------------
9527 -- Requires_Cleanup_Actions --
9528 ------------------------------
9530 function Requires_Cleanup_Actions
9532 Lib_Level
: Boolean) return Boolean
9534 At_Lib_Level
: constant Boolean :=
9536 and then Nkind_In
(N
, N_Package_Body
,
9537 N_Package_Specification
);
9538 -- N is at the library level if the top-most context is a package and
9539 -- the path taken to reach N does not inlcude non-package constructs.
9543 when N_Accept_Statement
9552 Requires_Cleanup_Actions
(Declarations
(N
), At_Lib_Level
, True)
9554 (Present
(Handled_Statement_Sequence
(N
))
9556 Requires_Cleanup_Actions
9557 (Statements
(Handled_Statement_Sequence
(N
)),
9558 At_Lib_Level
, True));
9560 when N_Package_Specification
=>
9562 Requires_Cleanup_Actions
9563 (Visible_Declarations
(N
), At_Lib_Level
, True)
9565 Requires_Cleanup_Actions
9566 (Private_Declarations
(N
), At_Lib_Level
, True);
9571 end Requires_Cleanup_Actions
;
9573 ------------------------------
9574 -- Requires_Cleanup_Actions --
9575 ------------------------------
9577 function Requires_Cleanup_Actions
9579 Lib_Level
: Boolean;
9580 Nested_Constructs
: Boolean) return Boolean
9585 Obj_Typ
: Entity_Id
;
9586 Pack_Id
: Entity_Id
;
9591 or else Is_Empty_List
(L
)
9597 while Present
(Decl
) loop
9599 -- Library-level tagged types
9601 if Nkind
(Decl
) = N_Full_Type_Declaration
then
9602 Typ
:= Defining_Identifier
(Decl
);
9604 -- Ignored Ghost types do not need any cleanup actions because
9605 -- they will not appear in the final tree.
9607 if Is_Ignored_Ghost_Entity
(Typ
) then
9610 elsif Is_Tagged_Type
(Typ
)
9611 and then Is_Library_Level_Entity
(Typ
)
9612 and then Convention
(Typ
) = Convention_Ada
9613 and then Present
(Access_Disp_Table
(Typ
))
9614 and then RTE_Available
(RE_Unregister_Tag
)
9615 and then not Is_Abstract_Type
(Typ
)
9616 and then not No_Run_Time_Mode
9621 -- Regular object declarations
9623 elsif Nkind
(Decl
) = N_Object_Declaration
then
9624 Obj_Id
:= Defining_Identifier
(Decl
);
9625 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
9626 Expr
:= Expression
(Decl
);
9628 -- Bypass any form of processing for objects which have their
9629 -- finalization disabled. This applies only to objects at the
9632 if Lib_Level
and then Finalize_Storage_Only
(Obj_Typ
) then
9635 -- Finalization of transient objects are treated separately in
9636 -- order to handle sensitive cases. These include:
9638 -- * Aggregate expansion
9639 -- * If, case, and expression with actions expansion
9640 -- * Transient scopes
9642 -- If one of those contexts has marked the transient object as
9643 -- ignored, do not generate finalization actions for it.
9645 elsif Is_Finalized_Transient
(Obj_Id
)
9646 or else Is_Ignored_Transient
(Obj_Id
)
9650 -- Ignored Ghost objects do not need any cleanup actions because
9651 -- they will not appear in the final tree.
9653 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
9656 -- The expansion of iterator loops generates an object declaration
9657 -- where the Ekind is explicitly set to loop parameter. This is to
9658 -- ensure that the loop parameter behaves as a constant from user
9659 -- code point of view. Such object are never controlled and do not
9660 -- require cleanup actions. An iterator loop over a container of
9661 -- controlled objects does not produce such object declarations.
9663 elsif Ekind
(Obj_Id
) = E_Loop_Parameter
then
9666 -- The object is of the form:
9667 -- Obj : [constant] Typ [:= Expr];
9669 -- Do not process tag-to-class-wide conversions because they do
9670 -- not yield an object. Do not process the incomplete view of a
9671 -- deferred constant. Note that an object initialized by means
9672 -- of a build-in-place function call may appear as a deferred
9673 -- constant after expansion activities. These kinds of objects
9674 -- must be finalized.
9676 elsif not Is_Imported
(Obj_Id
)
9677 and then Needs_Finalization
(Obj_Typ
)
9678 and then not Is_Tag_To_Class_Wide_Conversion
(Obj_Id
)
9679 and then not (Ekind
(Obj_Id
) = E_Constant
9680 and then not Has_Completion
(Obj_Id
)
9681 and then No
(BIP_Initialization_Call
(Obj_Id
)))
9685 -- The object is of the form:
9686 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
9688 -- Obj : Access_Typ :=
9689 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
9691 elsif Is_Access_Type
(Obj_Typ
)
9692 and then Needs_Finalization
9693 (Available_View
(Designated_Type
(Obj_Typ
)))
9694 and then Present
(Expr
)
9696 (Is_Secondary_Stack_BIP_Func_Call
(Expr
)
9698 (Is_Non_BIP_Func_Call
(Expr
)
9699 and then not Is_Related_To_Func_Return
(Obj_Id
)))
9703 -- Processing for "hook" objects generated for transient objects
9704 -- declared inside an Expression_With_Actions.
9706 elsif Is_Access_Type
(Obj_Typ
)
9707 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
9708 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
9709 N_Object_Declaration
9713 -- Processing for intermediate results of if expressions where
9714 -- one of the alternatives uses a controlled function call.
9716 elsif Is_Access_Type
(Obj_Typ
)
9717 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
9718 and then Nkind
(Status_Flag_Or_Transient_Decl
(Obj_Id
)) =
9719 N_Defining_Identifier
9720 and then Present
(Expr
)
9721 and then Nkind
(Expr
) = N_Null
9725 -- Simple protected objects which use type System.Tasking.
9726 -- Protected_Objects.Protection to manage their locks should be
9727 -- treated as controlled since they require manual cleanup.
9729 elsif Ekind
(Obj_Id
) = E_Variable
9730 and then (Is_Simple_Protected_Type
(Obj_Typ
)
9731 or else Has_Simple_Protected_Object
(Obj_Typ
))
9736 -- Specific cases of object renamings
9738 elsif Nkind
(Decl
) = N_Object_Renaming_Declaration
then
9739 Obj_Id
:= Defining_Identifier
(Decl
);
9740 Obj_Typ
:= Base_Type
(Etype
(Obj_Id
));
9742 -- Bypass any form of processing for objects which have their
9743 -- finalization disabled. This applies only to objects at the
9746 if Lib_Level
and then Finalize_Storage_Only
(Obj_Typ
) then
9749 -- Ignored Ghost object renamings do not need any cleanup actions
9750 -- because they will not appear in the final tree.
9752 elsif Is_Ignored_Ghost_Entity
(Obj_Id
) then
9755 -- Return object of a build-in-place function. This case is
9756 -- recognized and marked by the expansion of an extended return
9757 -- statement (see Expand_N_Extended_Return_Statement).
9759 elsif Needs_Finalization
(Obj_Typ
)
9760 and then Is_Return_Object
(Obj_Id
)
9761 and then Present
(Status_Flag_Or_Transient_Decl
(Obj_Id
))
9765 -- Detect a case where a source object has been initialized by
9766 -- a controlled function call or another object which was later
9767 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
9769 -- Obj1 : CW_Type := Src_Obj;
9770 -- Obj2 : CW_Type := Function_Call (...);
9772 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
9773 -- Tmp : ... := Function_Call (...)'reference;
9774 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
9776 elsif Is_Displacement_Of_Object_Or_Function_Result
(Obj_Id
) then
9780 -- Inspect the freeze node of an access-to-controlled type and look
9781 -- for a delayed finalization master. This case arises when the
9782 -- freeze actions are inserted at a later time than the expansion of
9783 -- the context. Since Build_Finalizer is never called on a single
9784 -- construct twice, the master will be ultimately left out and never
9785 -- finalized. This is also needed for freeze actions of designated
9786 -- types themselves, since in some cases the finalization master is
9787 -- associated with a designated type's freeze node rather than that
9788 -- of the access type (see handling for freeze actions in
9789 -- Build_Finalization_Master).
9791 elsif Nkind
(Decl
) = N_Freeze_Entity
9792 and then Present
(Actions
(Decl
))
9794 Typ
:= Entity
(Decl
);
9796 -- Freeze nodes for ignored Ghost types do not need cleanup
9797 -- actions because they will never appear in the final tree.
9799 if Is_Ignored_Ghost_Entity
(Typ
) then
9802 elsif ((Is_Access_Type
(Typ
)
9803 and then not Is_Access_Subprogram_Type
(Typ
)
9804 and then Needs_Finalization
9805 (Available_View
(Designated_Type
(Typ
))))
9806 or else (Is_Type
(Typ
) and then Needs_Finalization
(Typ
)))
9807 and then Requires_Cleanup_Actions
9808 (Actions
(Decl
), Lib_Level
, Nested_Constructs
)
9813 -- Nested package declarations
9815 elsif Nested_Constructs
9816 and then Nkind
(Decl
) = N_Package_Declaration
9818 Pack_Id
:= Defining_Entity
(Decl
);
9820 -- Do not inspect an ignored Ghost package because all code found
9821 -- within will not appear in the final tree.
9823 if Is_Ignored_Ghost_Entity
(Pack_Id
) then
9826 elsif Ekind
(Pack_Id
) /= E_Generic_Package
9827 and then Requires_Cleanup_Actions
9828 (Specification
(Decl
), Lib_Level
)
9833 -- Nested package bodies
9835 elsif Nested_Constructs
and then Nkind
(Decl
) = N_Package_Body
then
9837 -- Do not inspect an ignored Ghost package body because all code
9838 -- found within will not appear in the final tree.
9840 if Is_Ignored_Ghost_Entity
(Defining_Entity
(Decl
)) then
9843 elsif Ekind
(Corresponding_Spec
(Decl
)) /= E_Generic_Package
9844 and then Requires_Cleanup_Actions
(Decl
, Lib_Level
)
9849 elsif Nkind
(Decl
) = N_Block_Statement
9852 -- Handle a rare case caused by a controlled transient object
9853 -- created as part of a record init proc. The variable is wrapped
9854 -- in a block, but the block is not associated with a transient
9859 -- Handle the case where the original context has been wrapped in
9860 -- a block to avoid interference between exception handlers and
9861 -- At_End handlers. Treat the block as transparent and process its
9864 or else Is_Finalization_Wrapper
(Decl
))
9866 if Requires_Cleanup_Actions
(Decl
, Lib_Level
) then
9875 end Requires_Cleanup_Actions
;
9877 ------------------------------------
9878 -- Safe_Unchecked_Type_Conversion --
9879 ------------------------------------
9881 -- Note: this function knows quite a bit about the exact requirements of
9882 -- Gigi with respect to unchecked type conversions, and its code must be
9883 -- coordinated with any changes in Gigi in this area.
9885 -- The above requirements should be documented in Sinfo ???
9887 function Safe_Unchecked_Type_Conversion
(Exp
: Node_Id
) return Boolean is
9892 Pexp
: constant Node_Id
:= Parent
(Exp
);
9895 -- If the expression is the RHS of an assignment or object declaration
9896 -- we are always OK because there will always be a target.
9898 -- Object renaming declarations, (generated for view conversions of
9899 -- actuals in inlined calls), like object declarations, provide an
9900 -- explicit type, and are safe as well.
9902 if (Nkind
(Pexp
) = N_Assignment_Statement
9903 and then Expression
(Pexp
) = Exp
)
9904 or else Nkind_In
(Pexp
, N_Object_Declaration
,
9905 N_Object_Renaming_Declaration
)
9909 -- If the expression is the prefix of an N_Selected_Component we should
9910 -- also be OK because GCC knows to look inside the conversion except if
9911 -- the type is discriminated. We assume that we are OK anyway if the
9912 -- type is not set yet or if it is controlled since we can't afford to
9913 -- introduce a temporary in this case.
9915 elsif Nkind
(Pexp
) = N_Selected_Component
9916 and then Prefix
(Pexp
) = Exp
9918 if No
(Etype
(Pexp
)) then
9922 not Has_Discriminants
(Etype
(Pexp
))
9923 or else Is_Constrained
(Etype
(Pexp
));
9927 -- Set the output type, this comes from Etype if it is set, otherwise we
9928 -- take it from the subtype mark, which we assume was already fully
9931 if Present
(Etype
(Exp
)) then
9932 Otyp
:= Etype
(Exp
);
9934 Otyp
:= Entity
(Subtype_Mark
(Exp
));
9937 -- The input type always comes from the expression, and we assume this
9938 -- is indeed always analyzed, so we can simply get the Etype.
9940 Ityp
:= Etype
(Expression
(Exp
));
9942 -- Initialize alignments to unknown so far
9947 -- Replace a concurrent type by its corresponding record type and each
9948 -- type by its underlying type and do the tests on those. The original
9949 -- type may be a private type whose completion is a concurrent type, so
9950 -- find the underlying type first.
9952 if Present
(Underlying_Type
(Otyp
)) then
9953 Otyp
:= Underlying_Type
(Otyp
);
9956 if Present
(Underlying_Type
(Ityp
)) then
9957 Ityp
:= Underlying_Type
(Ityp
);
9960 if Is_Concurrent_Type
(Otyp
) then
9961 Otyp
:= Corresponding_Record_Type
(Otyp
);
9964 if Is_Concurrent_Type
(Ityp
) then
9965 Ityp
:= Corresponding_Record_Type
(Ityp
);
9968 -- If the base types are the same, we know there is no problem since
9969 -- this conversion will be a noop.
9971 if Implementation_Base_Type
(Otyp
) = Implementation_Base_Type
(Ityp
) then
9974 -- Same if this is an upwards conversion of an untagged type, and there
9975 -- are no constraints involved (could be more general???)
9977 elsif Etype
(Ityp
) = Otyp
9978 and then not Is_Tagged_Type
(Ityp
)
9979 and then not Has_Discriminants
(Ityp
)
9980 and then No
(First_Rep_Item
(Base_Type
(Ityp
)))
9984 -- If the expression has an access type (object or subprogram) we assume
9985 -- that the conversion is safe, because the size of the target is safe,
9986 -- even if it is a record (which might be treated as having unknown size
9989 elsif Is_Access_Type
(Ityp
) then
9992 -- If the size of output type is known at compile time, there is never
9993 -- a problem. Note that unconstrained records are considered to be of
9994 -- known size, but we can't consider them that way here, because we are
9995 -- talking about the actual size of the object.
9997 -- We also make sure that in addition to the size being known, we do not
9998 -- have a case which might generate an embarrassingly large temp in
9999 -- stack checking mode.
10001 elsif Size_Known_At_Compile_Time
(Otyp
)
10003 (not Stack_Checking_Enabled
10004 or else not May_Generate_Large_Temp
(Otyp
))
10005 and then not (Is_Record_Type
(Otyp
) and then not Is_Constrained
(Otyp
))
10009 -- If either type is tagged, then we know the alignment is OK so Gigi
10010 -- will be able to use pointer punning.
10012 elsif Is_Tagged_Type
(Otyp
) or else Is_Tagged_Type
(Ityp
) then
10015 -- If either type is a limited record type, we cannot do a copy, so say
10016 -- safe since there's nothing else we can do.
10018 elsif Is_Limited_Record
(Otyp
) or else Is_Limited_Record
(Ityp
) then
10021 -- Conversions to and from packed array types are always ignored and
10024 elsif Is_Packed_Array_Impl_Type
(Otyp
)
10025 or else Is_Packed_Array_Impl_Type
(Ityp
)
10030 -- The only other cases known to be safe is if the input type's
10031 -- alignment is known to be at least the maximum alignment for the
10032 -- target or if both alignments are known and the output type's
10033 -- alignment is no stricter than the input's. We can use the component
10034 -- type alignment for an array if a type is an unpacked array type.
10036 if Present
(Alignment_Clause
(Otyp
)) then
10037 Oalign
:= Expr_Value
(Expression
(Alignment_Clause
(Otyp
)));
10039 elsif Is_Array_Type
(Otyp
)
10040 and then Present
(Alignment_Clause
(Component_Type
(Otyp
)))
10042 Oalign
:= Expr_Value
(Expression
(Alignment_Clause
10043 (Component_Type
(Otyp
))));
10046 if Present
(Alignment_Clause
(Ityp
)) then
10047 Ialign
:= Expr_Value
(Expression
(Alignment_Clause
(Ityp
)));
10049 elsif Is_Array_Type
(Ityp
)
10050 and then Present
(Alignment_Clause
(Component_Type
(Ityp
)))
10052 Ialign
:= Expr_Value
(Expression
(Alignment_Clause
10053 (Component_Type
(Ityp
))));
10056 if Ialign
/= No_Uint
and then Ialign
> Maximum_Alignment
then
10059 elsif Ialign
/= No_Uint
10060 and then Oalign
/= No_Uint
10061 and then Ialign
<= Oalign
10065 -- Otherwise, Gigi cannot handle this and we must make a temporary
10070 end Safe_Unchecked_Type_Conversion
;
10072 ---------------------------------
10073 -- Set_Current_Value_Condition --
10074 ---------------------------------
10076 -- Note: the implementation of this procedure is very closely tied to the
10077 -- implementation of Get_Current_Value_Condition. Here we set required
10078 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
10079 -- them, so they must have a consistent view.
10081 procedure Set_Current_Value_Condition
(Cnode
: Node_Id
) is
10083 procedure Set_Entity_Current_Value
(N
: Node_Id
);
10084 -- If N is an entity reference, where the entity is of an appropriate
10085 -- kind, then set the current value of this entity to Cnode, unless
10086 -- there is already a definite value set there.
10088 procedure Set_Expression_Current_Value
(N
: Node_Id
);
10089 -- If N is of an appropriate form, sets an appropriate entry in current
10090 -- value fields of relevant entities. Multiple entities can be affected
10091 -- in the case of an AND or AND THEN.
10093 ------------------------------
10094 -- Set_Entity_Current_Value --
10095 ------------------------------
10097 procedure Set_Entity_Current_Value
(N
: Node_Id
) is
10099 if Is_Entity_Name
(N
) then
10101 Ent
: constant Entity_Id
:= Entity
(N
);
10104 -- Don't capture if not safe to do so
10106 if not Safe_To_Capture_Value
(N
, Ent
, Cond
=> True) then
10110 -- Here we have a case where the Current_Value field may need
10111 -- to be set. We set it if it is not already set to a compile
10112 -- time expression value.
10114 -- Note that this represents a decision that one condition
10115 -- blots out another previous one. That's certainly right if
10116 -- they occur at the same level. If the second one is nested,
10117 -- then the decision is neither right nor wrong (it would be
10118 -- equally OK to leave the outer one in place, or take the new
10119 -- inner one. Really we should record both, but our data
10120 -- structures are not that elaborate.
10122 if Nkind
(Current_Value
(Ent
)) not in N_Subexpr
then
10123 Set_Current_Value
(Ent
, Cnode
);
10127 end Set_Entity_Current_Value
;
10129 ----------------------------------
10130 -- Set_Expression_Current_Value --
10131 ----------------------------------
10133 procedure Set_Expression_Current_Value
(N
: Node_Id
) is
10139 -- Loop to deal with (ignore for now) any NOT operators present. The
10140 -- presence of NOT operators will be handled properly when we call
10141 -- Get_Current_Value_Condition.
10143 while Nkind
(Cond
) = N_Op_Not
loop
10144 Cond
:= Right_Opnd
(Cond
);
10147 -- For an AND or AND THEN, recursively process operands
10149 if Nkind
(Cond
) = N_Op_And
or else Nkind
(Cond
) = N_And_Then
then
10150 Set_Expression_Current_Value
(Left_Opnd
(Cond
));
10151 Set_Expression_Current_Value
(Right_Opnd
(Cond
));
10155 -- Check possible relational operator
10157 if Nkind
(Cond
) in N_Op_Compare
then
10158 if Compile_Time_Known_Value
(Right_Opnd
(Cond
)) then
10159 Set_Entity_Current_Value
(Left_Opnd
(Cond
));
10160 elsif Compile_Time_Known_Value
(Left_Opnd
(Cond
)) then
10161 Set_Entity_Current_Value
(Right_Opnd
(Cond
));
10164 elsif Nkind_In
(Cond
,
10166 N_Qualified_Expression
,
10167 N_Expression_With_Actions
)
10169 Set_Expression_Current_Value
(Expression
(Cond
));
10171 -- Check possible boolean variable reference
10174 Set_Entity_Current_Value
(Cond
);
10176 end Set_Expression_Current_Value
;
10178 -- Start of processing for Set_Current_Value_Condition
10181 Set_Expression_Current_Value
(Condition
(Cnode
));
10182 end Set_Current_Value_Condition
;
10184 --------------------------
10185 -- Set_Elaboration_Flag --
10186 --------------------------
10188 procedure Set_Elaboration_Flag
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
10189 Loc
: constant Source_Ptr
:= Sloc
(N
);
10190 Ent
: constant Entity_Id
:= Elaboration_Entity
(Spec_Id
);
10194 if Present
(Ent
) then
10196 -- Nothing to do if at the compilation unit level, because in this
10197 -- case the flag is set by the binder generated elaboration routine.
10199 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
10202 -- Here we do need to generate an assignment statement
10205 Check_Restriction
(No_Elaboration_Code
, N
);
10207 Make_Assignment_Statement
(Loc
,
10208 Name
=> New_Occurrence_Of
(Ent
, Loc
),
10209 Expression
=> Make_Integer_Literal
(Loc
, Uint_1
));
10211 if Nkind
(Parent
(N
)) = N_Subunit
then
10212 Insert_After
(Corresponding_Stub
(Parent
(N
)), Asn
);
10214 Insert_After
(N
, Asn
);
10219 -- Kill current value indication. This is necessary because the
10220 -- tests of this flag are inserted out of sequence and must not
10221 -- pick up bogus indications of the wrong constant value.
10223 Set_Current_Value
(Ent
, Empty
);
10225 -- If the subprogram is in the current declarative part and
10226 -- 'access has been applied to it, generate an elaboration
10227 -- check at the beginning of the declarations of the body.
10229 if Nkind
(N
) = N_Subprogram_Body
10230 and then Address_Taken
(Spec_Id
)
10232 Ekind_In
(Scope
(Spec_Id
), E_Block
, E_Procedure
, E_Function
)
10235 Loc
: constant Source_Ptr
:= Sloc
(N
);
10236 Decls
: constant List_Id
:= Declarations
(N
);
10240 -- No need to generate this check if first entry in the
10241 -- declaration list is a raise of Program_Error now.
10244 and then Nkind
(First
(Decls
)) = N_Raise_Program_Error
10249 -- Otherwise generate the check
10252 Make_Raise_Program_Error
(Loc
,
10255 Left_Opnd
=> New_Occurrence_Of
(Ent
, Loc
),
10256 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)),
10257 Reason
=> PE_Access_Before_Elaboration
);
10260 Set_Declarations
(N
, New_List
(Chk
));
10262 Prepend
(Chk
, Decls
);
10270 end Set_Elaboration_Flag
;
10272 ----------------------------
10273 -- Set_Renamed_Subprogram --
10274 ----------------------------
10276 procedure Set_Renamed_Subprogram
(N
: Node_Id
; E
: Entity_Id
) is
10278 -- If input node is an identifier, we can just reset it
10280 if Nkind
(N
) = N_Identifier
then
10281 Set_Chars
(N
, Chars
(E
));
10284 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
10288 CS
: constant Boolean := Comes_From_Source
(N
);
10290 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
(E
)));
10292 Set_Comes_From_Source
(N
, CS
);
10293 Set_Analyzed
(N
, True);
10296 end Set_Renamed_Subprogram
;
10298 ----------------------
10299 -- Side_Effect_Free --
10300 ----------------------
10302 function Side_Effect_Free
10304 Name_Req
: Boolean := False;
10305 Variable_Ref
: Boolean := False) return Boolean
10307 Typ
: constant Entity_Id
:= Etype
(N
);
10308 -- Result type of the expression
10310 function Safe_Prefixed_Reference
(N
: Node_Id
) return Boolean;
10311 -- The argument N is a construct where the Prefix is dereferenced if it
10312 -- is an access type and the result is a variable. The call returns True
10313 -- if the construct is side effect free (not considering side effects in
10314 -- other than the prefix which are to be tested by the caller).
10316 function Within_In_Parameter
(N
: Node_Id
) return Boolean;
10317 -- Determines if N is a subcomponent of a composite in-parameter. If so,
10318 -- N is not side-effect free when the actual is global and modifiable
10319 -- indirectly from within a subprogram, because it may be passed by
10320 -- reference. The front-end must be conservative here and assume that
10321 -- this may happen with any array or record type. On the other hand, we
10322 -- cannot create temporaries for all expressions for which this
10323 -- condition is true, for various reasons that might require clearing up
10324 -- ??? For example, discriminant references that appear out of place, or
10325 -- spurious type errors with class-wide expressions. As a result, we
10326 -- limit the transformation to loop bounds, which is so far the only
10327 -- case that requires it.
10329 -----------------------------
10330 -- Safe_Prefixed_Reference --
10331 -----------------------------
10333 function Safe_Prefixed_Reference
(N
: Node_Id
) return Boolean is
10335 -- If prefix is not side effect free, definitely not safe
10337 if not Side_Effect_Free
(Prefix
(N
), Name_Req
, Variable_Ref
) then
10340 -- If the prefix is of an access type that is not access-to-constant,
10341 -- then this construct is a variable reference, which means it is to
10342 -- be considered to have side effects if Variable_Ref is set True.
10344 elsif Is_Access_Type
(Etype
(Prefix
(N
)))
10345 and then not Is_Access_Constant
(Etype
(Prefix
(N
)))
10346 and then Variable_Ref
10348 -- Exception is a prefix that is the result of a previous removal
10349 -- of side-effects.
10351 return Is_Entity_Name
(Prefix
(N
))
10352 and then not Comes_From_Source
(Prefix
(N
))
10353 and then Ekind
(Entity
(Prefix
(N
))) = E_Constant
10354 and then Is_Internal_Name
(Chars
(Entity
(Prefix
(N
))));
10356 -- If the prefix is an explicit dereference then this construct is a
10357 -- variable reference, which means it is to be considered to have
10358 -- side effects if Variable_Ref is True.
10360 -- We do NOT exclude dereferences of access-to-constant types because
10361 -- we handle them as constant view of variables.
10363 elsif Nkind
(Prefix
(N
)) = N_Explicit_Dereference
10364 and then Variable_Ref
10368 -- Note: The following test is the simplest way of solving a complex
10369 -- problem uncovered by the following test (Side effect on loop bound
10370 -- that is a subcomponent of a global variable:
10372 -- with Text_Io; use Text_Io;
10373 -- procedure Tloop is
10376 -- V : Natural := 4;
10377 -- S : String (1..5) := (others => 'a');
10384 -- with procedure Action;
10385 -- procedure Loop_G (Arg : X; Msg : String)
10387 -- procedure Loop_G (Arg : X; Msg : String) is
10389 -- Put_Line ("begin loop_g " & Msg & " will loop till: "
10390 -- & Natural'Image (Arg.V));
10391 -- for Index in 1 .. Arg.V loop
10392 -- Text_Io.Put_Line
10393 -- (Natural'Image (Index) & " " & Arg.S (Index));
10394 -- if Index > 2 then
10398 -- Put_Line ("end loop_g " & Msg);
10401 -- procedure Loop1 is new Loop_G (Modi);
10402 -- procedure Modi is
10405 -- Loop1 (X1, "from modi");
10409 -- Loop1 (X1, "initial");
10412 -- The output of the above program should be:
10414 -- begin loop_g initial will loop till: 4
10418 -- begin loop_g from modi will loop till: 1
10420 -- end loop_g from modi
10422 -- begin loop_g from modi will loop till: 1
10424 -- end loop_g from modi
10425 -- end loop_g initial
10427 -- If a loop bound is a subcomponent of a global variable, a
10428 -- modification of that variable within the loop may incorrectly
10429 -- affect the execution of the loop.
10431 elsif Nkind
(Parent
(Parent
(N
))) = N_Loop_Parameter_Specification
10432 and then Within_In_Parameter
(Prefix
(N
))
10433 and then Variable_Ref
10437 -- All other cases are side effect free
10442 end Safe_Prefixed_Reference
;
10444 -------------------------
10445 -- Within_In_Parameter --
10446 -------------------------
10448 function Within_In_Parameter
(N
: Node_Id
) return Boolean is
10450 if not Comes_From_Source
(N
) then
10453 elsif Is_Entity_Name
(N
) then
10454 return Ekind
(Entity
(N
)) = E_In_Parameter
;
10456 elsif Nkind_In
(N
, N_Indexed_Component
, N_Selected_Component
) then
10457 return Within_In_Parameter
(Prefix
(N
));
10462 end Within_In_Parameter
;
10464 -- Start of processing for Side_Effect_Free
10467 -- If volatile reference, always consider it to have side effects
10469 if Is_Volatile_Reference
(N
) then
10473 -- Note on checks that could raise Constraint_Error. Strictly, if we
10474 -- take advantage of 11.6, these checks do not count as side effects.
10475 -- However, we would prefer to consider that they are side effects,
10476 -- since the back end CSE does not work very well on expressions which
10477 -- can raise Constraint_Error. On the other hand if we don't consider
10478 -- them to be side effect free, then we get some awkward expansions
10479 -- in -gnato mode, resulting in code insertions at a point where we
10480 -- do not have a clear model for performing the insertions.
10482 -- Special handling for entity names
10484 if Is_Entity_Name
(N
) then
10486 -- A type reference is always side effect free
10488 if Is_Type
(Entity
(N
)) then
10491 -- Variables are considered to be a side effect if Variable_Ref
10492 -- is set or if we have a volatile reference and Name_Req is off.
10493 -- If Name_Req is True then we can't help returning a name which
10494 -- effectively allows multiple references in any case.
10496 elsif Is_Variable
(N
, Use_Original_Node
=> False) then
10497 return not Variable_Ref
10498 and then (not Is_Volatile_Reference
(N
) or else Name_Req
);
10500 -- Any other entity (e.g. a subtype name) is definitely side
10507 -- A value known at compile time is always side effect free
10509 elsif Compile_Time_Known_Value
(N
) then
10512 -- A variable renaming is not side-effect free, because the renaming
10513 -- will function like a macro in the front-end in some cases, and an
10514 -- assignment can modify the component designated by N, so we need to
10515 -- create a temporary for it.
10517 -- The guard testing for Entity being present is needed at least in
10518 -- the case of rewritten predicate expressions, and may well also be
10519 -- appropriate elsewhere. Obviously we can't go testing the entity
10520 -- field if it does not exist, so it's reasonable to say that this is
10521 -- not the renaming case if it does not exist.
10523 elsif Is_Entity_Name
(Original_Node
(N
))
10524 and then Present
(Entity
(Original_Node
(N
)))
10525 and then Is_Renaming_Of_Object
(Entity
(Original_Node
(N
)))
10526 and then Ekind
(Entity
(Original_Node
(N
))) /= E_Constant
10529 RO
: constant Node_Id
:=
10530 Renamed_Object
(Entity
(Original_Node
(N
)));
10533 -- If the renamed object is an indexed component, or an
10534 -- explicit dereference, then the designated object could
10535 -- be modified by an assignment.
10537 if Nkind_In
(RO
, N_Indexed_Component
,
10538 N_Explicit_Dereference
)
10542 -- A selected component must have a safe prefix
10544 elsif Nkind
(RO
) = N_Selected_Component
then
10545 return Safe_Prefixed_Reference
(RO
);
10547 -- In all other cases, designated object cannot be changed so
10548 -- we are side effect free.
10555 -- Remove_Side_Effects generates an object renaming declaration to
10556 -- capture the expression of a class-wide expression. In VM targets
10557 -- the frontend performs no expansion for dispatching calls to
10558 -- class- wide types since they are handled by the VM. Hence, we must
10559 -- locate here if this node corresponds to a previous invocation of
10560 -- Remove_Side_Effects to avoid a never ending loop in the frontend.
10562 elsif not Tagged_Type_Expansion
10563 and then not Comes_From_Source
(N
)
10564 and then Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
10565 and then Is_Class_Wide_Type
(Typ
)
10569 -- Generating C the type conversion of an access to constrained array
10570 -- type into an access to unconstrained array type involves initializing
10571 -- a fat pointer and the expression cannot be assumed to be free of side
10572 -- effects since it must referenced several times to compute its bounds.
10574 elsif Modify_Tree_For_C
10575 and then Nkind
(N
) = N_Type_Conversion
10576 and then Is_Access_Type
(Typ
)
10577 and then Is_Array_Type
(Designated_Type
(Typ
))
10578 and then not Is_Constrained
(Designated_Type
(Typ
))
10583 -- For other than entity names and compile time known values,
10584 -- check the node kind for special processing.
10588 -- An attribute reference is side effect free if its expressions
10589 -- are side effect free and its prefix is side effect free or
10590 -- is an entity reference.
10592 -- Is this right? what about x'first where x is a variable???
10594 when N_Attribute_Reference
=>
10596 Side_Effect_Free
(Expressions
(N
), Name_Req
, Variable_Ref
)
10597 and then Attribute_Name
(N
) /= Name_Input
10598 and then (Is_Entity_Name
(Prefix
(N
))
10599 or else Side_Effect_Free
10600 (Prefix
(N
), Name_Req
, Variable_Ref
));
10602 -- A binary operator is side effect free if and both operands are
10603 -- side effect free. For this purpose binary operators include
10604 -- membership tests and short circuit forms.
10607 | N_Membership_Test
10610 return Side_Effect_Free
(Left_Opnd
(N
), Name_Req
, Variable_Ref
)
10612 Side_Effect_Free
(Right_Opnd
(N
), Name_Req
, Variable_Ref
);
10614 -- An explicit dereference is side effect free only if it is
10615 -- a side effect free prefixed reference.
10617 when N_Explicit_Dereference
=>
10618 return Safe_Prefixed_Reference
(N
);
10620 -- An expression with action is side effect free if its expression
10621 -- is side effect free and it has no actions.
10623 when N_Expression_With_Actions
=>
10625 Is_Empty_List
(Actions
(N
))
10626 and then Side_Effect_Free
10627 (Expression
(N
), Name_Req
, Variable_Ref
);
10629 -- A call to _rep_to_pos is side effect free, since we generate
10630 -- this pure function call ourselves. Moreover it is critically
10631 -- important to make this exception, since otherwise we can have
10632 -- discriminants in array components which don't look side effect
10633 -- free in the case of an array whose index type is an enumeration
10634 -- type with an enumeration rep clause.
10636 -- All other function calls are not side effect free
10638 when N_Function_Call
=>
10640 Nkind
(Name
(N
)) = N_Identifier
10641 and then Is_TSS
(Name
(N
), TSS_Rep_To_Pos
)
10642 and then Side_Effect_Free
10643 (First
(Parameter_Associations
(N
)),
10644 Name_Req
, Variable_Ref
);
10646 -- An IF expression is side effect free if it's of a scalar type, and
10647 -- all its components are all side effect free (conditions and then
10648 -- actions and else actions). We restrict to scalar types, since it
10649 -- is annoying to deal with things like (if A then B else C)'First
10650 -- where the type involved is a string type.
10652 when N_If_Expression
=>
10654 Is_Scalar_Type
(Typ
)
10655 and then Side_Effect_Free
10656 (Expressions
(N
), Name_Req
, Variable_Ref
);
10658 -- An indexed component is side effect free if it is a side
10659 -- effect free prefixed reference and all the indexing
10660 -- expressions are side effect free.
10662 when N_Indexed_Component
=>
10664 Side_Effect_Free
(Expressions
(N
), Name_Req
, Variable_Ref
)
10665 and then Safe_Prefixed_Reference
(N
);
10667 -- A type qualification is side effect free if the expression
10668 -- is side effect free.
10670 when N_Qualified_Expression
=>
10671 return Side_Effect_Free
(Expression
(N
), Name_Req
, Variable_Ref
);
10673 -- A selected component is side effect free only if it is a side
10674 -- effect free prefixed reference.
10676 when N_Selected_Component
=>
10677 return Safe_Prefixed_Reference
(N
);
10679 -- A range is side effect free if the bounds are side effect free
10682 return Side_Effect_Free
(Low_Bound
(N
), Name_Req
, Variable_Ref
)
10684 Side_Effect_Free
(High_Bound
(N
), Name_Req
, Variable_Ref
);
10686 -- A slice is side effect free if it is a side effect free
10687 -- prefixed reference and the bounds are side effect free.
10691 Side_Effect_Free
(Discrete_Range
(N
), Name_Req
, Variable_Ref
)
10692 and then Safe_Prefixed_Reference
(N
);
10694 -- A type conversion is side effect free if the expression to be
10695 -- converted is side effect free.
10697 when N_Type_Conversion
=>
10698 return Side_Effect_Free
(Expression
(N
), Name_Req
, Variable_Ref
);
10700 -- A unary operator is side effect free if the operand
10701 -- is side effect free.
10704 return Side_Effect_Free
(Right_Opnd
(N
), Name_Req
, Variable_Ref
);
10706 -- An unchecked type conversion is side effect free only if it
10707 -- is safe and its argument is side effect free.
10709 when N_Unchecked_Type_Conversion
=>
10711 Safe_Unchecked_Type_Conversion
(N
)
10712 and then Side_Effect_Free
10713 (Expression
(N
), Name_Req
, Variable_Ref
);
10715 -- An unchecked expression is side effect free if its expression
10716 -- is side effect free.
10718 when N_Unchecked_Expression
=>
10719 return Side_Effect_Free
(Expression
(N
), Name_Req
, Variable_Ref
);
10721 -- A literal is side effect free
10723 when N_Character_Literal
10724 | N_Integer_Literal
10730 -- We consider that anything else has side effects. This is a bit
10731 -- crude, but we are pretty close for most common cases, and we
10732 -- are certainly correct (i.e. we never return True when the
10733 -- answer should be False).
10738 end Side_Effect_Free
;
10740 -- A list is side effect free if all elements of the list are side
10743 function Side_Effect_Free
10745 Name_Req
: Boolean := False;
10746 Variable_Ref
: Boolean := False) return Boolean
10751 if L
= No_List
or else L
= Error_List
then
10756 while Present
(N
) loop
10757 if not Side_Effect_Free
(N
, Name_Req
, Variable_Ref
) then
10766 end Side_Effect_Free
;
10768 ----------------------------------
10769 -- Silly_Boolean_Array_Not_Test --
10770 ----------------------------------
10772 -- This procedure implements an odd and silly test. We explicitly check
10773 -- for the case where the 'First of the component type is equal to the
10774 -- 'Last of this component type, and if this is the case, we make sure
10775 -- that constraint error is raised. The reason is that the NOT is bound
10776 -- to cause CE in this case, and we will not otherwise catch it.
10778 -- No such check is required for AND and OR, since for both these cases
10779 -- False op False = False, and True op True = True. For the XOR case,
10780 -- see Silly_Boolean_Array_Xor_Test.
10782 -- Believe it or not, this was reported as a bug. Note that nearly always,
10783 -- the test will evaluate statically to False, so the code will be
10784 -- statically removed, and no extra overhead caused.
10786 procedure Silly_Boolean_Array_Not_Test
(N
: Node_Id
; T
: Entity_Id
) is
10787 Loc
: constant Source_Ptr
:= Sloc
(N
);
10788 CT
: constant Entity_Id
:= Component_Type
(T
);
10791 -- The check we install is
10793 -- constraint_error when
10794 -- component_type'first = component_type'last
10795 -- and then array_type'Length /= 0)
10797 -- We need the last guard because we don't want to raise CE for empty
10798 -- arrays since no out of range values result. (Empty arrays with a
10799 -- component type of True .. True -- very useful -- even the ACATS
10800 -- does not test that marginal case).
10803 Make_Raise_Constraint_Error
(Loc
,
10805 Make_And_Then
(Loc
,
10809 Make_Attribute_Reference
(Loc
,
10810 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
10811 Attribute_Name
=> Name_First
),
10814 Make_Attribute_Reference
(Loc
,
10815 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
10816 Attribute_Name
=> Name_Last
)),
10818 Right_Opnd
=> Make_Non_Empty_Check
(Loc
, Right_Opnd
(N
))),
10819 Reason
=> CE_Range_Check_Failed
));
10820 end Silly_Boolean_Array_Not_Test
;
10822 ----------------------------------
10823 -- Silly_Boolean_Array_Xor_Test --
10824 ----------------------------------
10826 -- This procedure implements an odd and silly test. We explicitly check
10827 -- for the XOR case where the component type is True .. True, since this
10828 -- will raise constraint error. A special check is required since CE
10829 -- will not be generated otherwise (cf Expand_Packed_Not).
10831 -- No such check is required for AND and OR, since for both these cases
10832 -- False op False = False, and True op True = True, and no check is
10833 -- required for the case of False .. False, since False xor False = False.
10834 -- See also Silly_Boolean_Array_Not_Test
10836 procedure Silly_Boolean_Array_Xor_Test
(N
: Node_Id
; T
: Entity_Id
) is
10837 Loc
: constant Source_Ptr
:= Sloc
(N
);
10838 CT
: constant Entity_Id
:= Component_Type
(T
);
10841 -- The check we install is
10843 -- constraint_error when
10844 -- Boolean (component_type'First)
10845 -- and then Boolean (component_type'Last)
10846 -- and then array_type'Length /= 0)
10848 -- We need the last guard because we don't want to raise CE for empty
10849 -- arrays since no out of range values result (Empty arrays with a
10850 -- component type of True .. True -- very useful -- even the ACATS
10851 -- does not test that marginal case).
10854 Make_Raise_Constraint_Error
(Loc
,
10856 Make_And_Then
(Loc
,
10858 Make_And_Then
(Loc
,
10860 Convert_To
(Standard_Boolean
,
10861 Make_Attribute_Reference
(Loc
,
10862 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
10863 Attribute_Name
=> Name_First
)),
10866 Convert_To
(Standard_Boolean
,
10867 Make_Attribute_Reference
(Loc
,
10868 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
10869 Attribute_Name
=> Name_Last
))),
10871 Right_Opnd
=> Make_Non_Empty_Check
(Loc
, Right_Opnd
(N
))),
10872 Reason
=> CE_Range_Check_Failed
));
10873 end Silly_Boolean_Array_Xor_Test
;
10875 --------------------------
10876 -- Target_Has_Fixed_Ops --
10877 --------------------------
10879 Integer_Sized_Small
: Ureal
;
10880 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
10881 -- called (we don't want to compute it more than once).
10883 Long_Integer_Sized_Small
: Ureal
;
10884 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
10885 -- is called (we don't want to compute it more than once)
10887 First_Time_For_THFO
: Boolean := True;
10888 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
10890 function Target_Has_Fixed_Ops
10891 (Left_Typ
: Entity_Id
;
10892 Right_Typ
: Entity_Id
;
10893 Result_Typ
: Entity_Id
) return Boolean
10895 function Is_Fractional_Type
(Typ
: Entity_Id
) return Boolean;
10896 -- Return True if the given type is a fixed-point type with a small
10897 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
10898 -- an absolute value less than 1.0. This is currently limited to
10899 -- fixed-point types that map to Integer or Long_Integer.
10901 ------------------------
10902 -- Is_Fractional_Type --
10903 ------------------------
10905 function Is_Fractional_Type
(Typ
: Entity_Id
) return Boolean is
10907 if Esize
(Typ
) = Standard_Integer_Size
then
10908 return Small_Value
(Typ
) = Integer_Sized_Small
;
10910 elsif Esize
(Typ
) = Standard_Long_Integer_Size
then
10911 return Small_Value
(Typ
) = Long_Integer_Sized_Small
;
10916 end Is_Fractional_Type
;
10918 -- Start of processing for Target_Has_Fixed_Ops
10921 -- Return False if Fractional_Fixed_Ops_On_Target is false
10923 if not Fractional_Fixed_Ops_On_Target
then
10927 -- Here the target has Fractional_Fixed_Ops, if first time, compute
10928 -- standard constants used by Is_Fractional_Type.
10930 if First_Time_For_THFO
then
10931 First_Time_For_THFO
:= False;
10933 Integer_Sized_Small
:=
10936 Den
=> UI_From_Int
(Standard_Integer_Size
- 1),
10939 Long_Integer_Sized_Small
:=
10942 Den
=> UI_From_Int
(Standard_Long_Integer_Size
- 1),
10946 -- Return True if target supports fixed-by-fixed multiply/divide for
10947 -- fractional fixed-point types (see Is_Fractional_Type) and the operand
10948 -- and result types are equivalent fractional types.
10950 return Is_Fractional_Type
(Base_Type
(Left_Typ
))
10951 and then Is_Fractional_Type
(Base_Type
(Right_Typ
))
10952 and then Is_Fractional_Type
(Base_Type
(Result_Typ
))
10953 and then Esize
(Left_Typ
) = Esize
(Right_Typ
)
10954 and then Esize
(Left_Typ
) = Esize
(Result_Typ
);
10955 end Target_Has_Fixed_Ops
;
10957 ------------------------------------------
10958 -- Type_May_Have_Bit_Aligned_Components --
10959 ------------------------------------------
10961 function Type_May_Have_Bit_Aligned_Components
10962 (Typ
: Entity_Id
) return Boolean
10965 -- Array type, check component type
10967 if Is_Array_Type
(Typ
) then
10969 Type_May_Have_Bit_Aligned_Components
(Component_Type
(Typ
));
10971 -- Record type, check components
10973 elsif Is_Record_Type
(Typ
) then
10978 E
:= First_Component_Or_Discriminant
(Typ
);
10979 while Present
(E
) loop
10980 if Component_May_Be_Bit_Aligned
(E
)
10981 or else Type_May_Have_Bit_Aligned_Components
(Etype
(E
))
10986 Next_Component_Or_Discriminant
(E
);
10992 -- Type other than array or record is always OK
10997 end Type_May_Have_Bit_Aligned_Components
;
10999 -------------------------------
11000 -- Update_Primitives_Mapping --
11001 -------------------------------
11003 procedure Update_Primitives_Mapping
11004 (Inher_Id
: Entity_Id
;
11005 Subp_Id
: Entity_Id
)
11008 Update_Primitives_Mapping_Of_Types
11009 (Par_Typ
=> Find_Dispatching_Type
(Inher_Id
),
11010 Deriv_Typ
=> Find_Dispatching_Type
(Subp_Id
));
11011 end Update_Primitives_Mapping
;
11013 ----------------------------------------
11014 -- Update_Primitives_Mapping_Of_Types --
11015 ----------------------------------------
11017 procedure Update_Primitives_Mapping_Of_Types
11018 (Par_Typ
: Entity_Id
;
11019 Deriv_Typ
: Entity_Id
)
11021 procedure Add_Primitive
(Prim
: Entity_Id
);
11022 -- Find a primitive in the inheritance/overriding chain starting from
11023 -- Prim whose dispatching type is parent type Par_Typ and add a mapping
11024 -- between the result and primitive Prim.
11026 -------------------
11027 -- Add_Primitive --
11028 -------------------
11030 procedure Add_Primitive
(Prim
: Entity_Id
) is
11031 function Ancestor_Primitive
(Subp
: Entity_Id
) return Entity_Id
;
11032 -- Return the next ancestor primitive in the inheritance/overriding
11033 -- chain of subprogram Subp. Return Empty if no such primitive is
11036 ------------------------
11037 -- Ancestor_Primitive --
11038 ------------------------
11040 function Ancestor_Primitive
(Subp
: Entity_Id
) return Entity_Id
is
11041 Inher_Prim
: constant Entity_Id
:= Alias
(Subp
);
11042 Over_Prim
: constant Entity_Id
:= Overridden_Operation
(Subp
);
11045 -- The current subprogram overrides an ancestor primitive
11047 if Present
(Over_Prim
) then
11050 -- The current subprogram is an internally generated alias of an
11051 -- inherited ancestor primitive.
11053 elsif Present
(Inher_Prim
) then
11056 -- Otherwise the current subprogram is the root of the inheritance
11057 -- or overriding chain.
11062 end Ancestor_Primitive
;
11066 Par_Prim
: Entity_Id
;
11068 -- Start of processing for Add_Primitive
11071 -- Inspect both the inheritance chain through the Alias attribute and
11072 -- the overriding chain through the Overridden_Operation looking for
11073 -- an ancestor primitive with the appropriate dispatching type.
11076 while Present
(Par_Prim
) loop
11077 exit when Find_Dispatching_Type
(Par_Prim
) = Par_Typ
;
11078 Par_Prim
:= Ancestor_Primitive
(Par_Prim
);
11081 -- Create a mapping of the form:
11083 -- Parent type primitive -> derived type primitive
11085 if Present
(Par_Prim
) then
11086 Primitives_Mapping
.Set
(Par_Prim
, Prim
);
11092 Deriv_Prim
: Entity_Id
;
11093 Par_Prim
: Entity_Id
;
11094 Par_Prims
: Elist_Id
;
11095 Prim_Elmt
: Elmt_Id
;
11097 -- Start of processing for Update_Primitives_Mapping_Of_Types
11100 -- Nothing to do if there are no types to work with
11102 if No
(Par_Typ
) or else No
(Deriv_Typ
) then
11105 -- Nothing to do if the mapping already exists
11107 elsif Primitives_Mapping
.Get
(Par_Typ
) = Deriv_Typ
then
11111 -- Create a mapping of the form:
11113 -- Parent type -> Derived type
11115 -- to prevent any subsequent attempts to produce the same relations.
11117 Primitives_Mapping
.Set
(Par_Typ
, Deriv_Typ
);
11119 -- Inspect the primitives of the derived type and determine whether they
11120 -- relate to the primitives of the parent type. If there is a meaningful
11121 -- relation, create a mapping of the form:
11123 -- Parent type primitive -> Derived type primitive
11125 if Present
(Direct_Primitive_Operations
(Deriv_Typ
)) then
11126 Prim_Elmt
:= First_Elmt
(Direct_Primitive_Operations
(Deriv_Typ
));
11127 while Present
(Prim_Elmt
) loop
11128 Deriv_Prim
:= Node
(Prim_Elmt
);
11130 if Is_Subprogram
(Deriv_Prim
)
11131 and then Find_Dispatching_Type
(Deriv_Prim
) = Deriv_Typ
11133 Add_Primitive
(Deriv_Prim
);
11136 Next_Elmt
(Prim_Elmt
);
11140 -- If the parent operation is an interface operation, the overriding
11141 -- indicator is not present. Instead, we get from the interface
11142 -- operation the primitive of the current type that implements it.
11144 if Is_Interface
(Par_Typ
) then
11145 Par_Prims
:= Collect_Primitive_Operations
(Par_Typ
);
11147 if Present
(Par_Prims
) then
11148 Prim_Elmt
:= First_Elmt
(Par_Prims
);
11150 while Present
(Prim_Elmt
) loop
11151 Par_Prim
:= Node
(Prim_Elmt
);
11153 Find_Primitive_Covering_Interface
(Deriv_Typ
, Par_Prim
);
11155 if Present
(Deriv_Prim
) then
11156 Primitives_Mapping
.Set
(Par_Prim
, Deriv_Prim
);
11159 Next_Elmt
(Prim_Elmt
);
11163 end Update_Primitives_Mapping_Of_Types
;
11165 ----------------------------------
11166 -- Within_Case_Or_If_Expression --
11167 ----------------------------------
11169 function Within_Case_Or_If_Expression
(N
: Node_Id
) return Boolean is
11173 -- Locate an enclosing case or if expression. Note that these constructs
11174 -- can be expanded into Expression_With_Actions, hence the test of the
11178 while Present
(Par
) loop
11179 if Nkind_In
(Original_Node
(Par
), N_Case_Expression
,
11184 -- Prevent the search from going too far
11186 elsif Is_Body_Or_Package_Declaration
(Par
) then
11190 Par
:= Parent
(Par
);
11194 end Within_Case_Or_If_Expression
;
11196 --------------------------------
11197 -- Within_Internal_Subprogram --
11198 --------------------------------
11200 function Within_Internal_Subprogram
return Boolean is
11204 S
:= Current_Scope
;
11205 while Present
(S
) and then not Is_Subprogram
(S
) loop
11210 and then Get_TSS_Name
(S
) /= TSS_Null
11211 and then not Is_Predicate_Function
(S
)
11212 and then not Is_Predicate_Function_M
(S
);
11213 end Within_Internal_Subprogram
;