1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, 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 Inline; use Inline;
38 with Itypes; use Itypes;
40 with Nlists; use Nlists;
41 with Nmake; use Nmake;
43 with Restrict; use Restrict;
44 with Rident; use Rident;
46 with Sem_Aux; use Sem_Aux;
47 with Sem_Ch8; use Sem_Ch8;
48 with Sem_Eval; use Sem_Eval;
49 with Sem_Res; use Sem_Res;
50 with Sem_Type; use Sem_Type;
51 with Sem_Util; use Sem_Util;
52 with Snames; use Snames;
53 with Stand; use Stand;
54 with Stringt; use Stringt;
55 with Targparm; use Targparm;
56 with Tbuild; use Tbuild;
57 with Ttypes; use Ttypes;
58 with Urealp; use Urealp;
59 with Validsw; use Validsw;
61 package body Exp_Util is
63 -----------------------
64 -- Local Subprograms --
65 -----------------------
67 function Build_Task_Array_Image
71 Dyn : Boolean := False) return Node_Id;
72 -- Build function to generate the image string for a task that is an array
73 -- component, concatenating the images of each index. To avoid storage
74 -- leaks, the string is built with successive slice assignments. The flag
75 -- Dyn indicates whether this is called for the initialization procedure of
76 -- an array of tasks, or for the name of a dynamically created task that is
77 -- assigned to an indexed component.
79 function Build_Task_Image_Function
83 Res : Entity_Id) return Node_Id;
84 -- Common processing for Task_Array_Image and Task_Record_Image. Build
85 -- function body that computes image.
87 procedure Build_Task_Image_Prefix
96 -- Common processing for Task_Array_Image and Task_Record_Image. Create
97 -- local variables and assign prefix of name to result string.
99 function Build_Task_Record_Image
102 Dyn : Boolean := False) return Node_Id;
103 -- Build function to generate the image string for a task that is a record
104 -- component. Concatenate name of variable with that of selector. The flag
105 -- Dyn indicates whether this is called for the initialization procedure of
106 -- record with task components, or for a dynamically created task that is
107 -- assigned to a selected component.
109 procedure Evaluate_Slice_Bounds (Slice : Node_Id);
110 -- Force evaluation of bounds of a slice, which may be given by a range
111 -- or by a subtype indication with or without a constraint.
113 function Make_CW_Equivalent_Type
115 E : Node_Id) return Entity_Id;
116 -- T is a class-wide type entity, E is the initial expression node that
117 -- constrains T in case such as: " X: T := E" or "new T'(E)". This function
118 -- returns the entity of the Equivalent type and inserts on the fly the
119 -- necessary declaration such as:
121 -- type anon is record
122 -- _parent : Root_Type (T); constrained with E discriminants (if any)
123 -- Extension : String (1 .. expr to match size of E);
126 -- This record is compatible with any object of the class of T thanks to
127 -- the first field and has the same size as E thanks to the second.
129 function Make_Literal_Range
131 Literal_Typ : Entity_Id) return Node_Id;
132 -- Produce a Range node whose bounds are:
133 -- Low_Bound (Literal_Type) ..
134 -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
135 -- this is used for expanding declarations like X : String := "sdfgdfg";
137 -- If the index type of the target array is not integer, we generate:
138 -- Low_Bound (Literal_Type) ..
140 -- (Literal_Type'Pos (Low_Bound (Literal_Type))
141 -- + (Length (Literal_Typ) -1))
143 function Make_Non_Empty_Check
145 N : Node_Id) return Node_Id;
146 -- Produce a boolean expression checking that the unidimensional array
147 -- node N is not empty.
149 function New_Class_Wide_Subtype
151 N : Node_Id) return Entity_Id;
152 -- Create an implicit subtype of CW_Typ attached to node N
154 function Requires_Cleanup_Actions
157 Nested_Constructs : Boolean) return Boolean;
158 -- Given a list L, determine whether it contains one of the following:
160 -- 1) controlled objects
161 -- 2) library-level tagged types
163 -- Lib_Level is True when the list comes from a construct at the library
164 -- level, and False otherwise. Nested_Constructs is True when any nested
165 -- packages declared in L must be processed, and False otherwise.
167 -------------------------------------
168 -- Activate_Atomic_Synchronization --
169 -------------------------------------
171 procedure Activate_Atomic_Synchronization (N : Node_Id) is
175 case Nkind (Parent (N)) is
177 -- Check for cases of appearing in the prefix of a construct where
178 -- we don't need atomic synchronization for this kind of usage.
181 -- Nothing to do if we are the prefix of an attribute, since we
182 -- do not want an atomic sync operation for things like 'Size.
184 N_Attribute_Reference |
186 -- The N_Reference node is like an attribute
190 -- Nothing to do for a reference to a component (or components)
191 -- of a composite object. Only reads and updates of the object
192 -- as a whole require atomic synchronization (RM C.6 (15)).
194 N_Indexed_Component |
195 N_Selected_Component |
198 -- For all the above cases, nothing to do if we are the prefix
200 if Prefix (Parent (N)) = N then
207 -- Go ahead and set the flag
209 Set_Atomic_Sync_Required (N);
211 -- Generate info message if requested
213 if Warn_On_Atomic_Synchronization then
218 when N_Selected_Component | N_Expanded_Name =>
219 Msg_Node := Selector_Name (N);
221 when N_Explicit_Dereference | N_Indexed_Component =>
225 pragma Assert (False);
229 if Present (Msg_Node) then
231 ("info: atomic synchronization set for &?N?", Msg_Node);
234 ("info: atomic synchronization set?N?", N);
237 end Activate_Atomic_Synchronization;
239 ----------------------
240 -- Adjust_Condition --
241 ----------------------
243 procedure Adjust_Condition (N : Node_Id) is
250 Loc : constant Source_Ptr := Sloc (N);
251 T : constant Entity_Id := Etype (N);
255 -- Defend against a call where the argument has no type, or has a
256 -- type that is not Boolean. This can occur because of prior errors.
258 if No (T) or else not Is_Boolean_Type (T) then
262 -- Apply validity checking if needed
264 if Validity_Checks_On and Validity_Check_Tests then
268 -- Immediate return if standard boolean, the most common case,
269 -- where nothing needs to be done.
271 if Base_Type (T) = Standard_Boolean then
275 -- Case of zero/non-zero semantics or non-standard enumeration
276 -- representation. In each case, we rewrite the node as:
278 -- ityp!(N) /= False'Enum_Rep
280 -- where ityp is an integer type with large enough size to hold any
283 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
284 if Esize (T) <= Esize (Standard_Integer) then
285 Ti := Standard_Integer;
287 Ti := Standard_Long_Long_Integer;
292 Left_Opnd => Unchecked_Convert_To (Ti, N),
294 Make_Attribute_Reference (Loc,
295 Attribute_Name => Name_Enum_Rep,
297 New_Occurrence_Of (First_Literal (T), Loc))));
298 Analyze_And_Resolve (N, Standard_Boolean);
301 Rewrite (N, Convert_To (Standard_Boolean, N));
302 Analyze_And_Resolve (N, Standard_Boolean);
305 end Adjust_Condition;
307 ------------------------
308 -- Adjust_Result_Type --
309 ------------------------
311 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
313 -- Ignore call if current type is not Standard.Boolean
315 if Etype (N) /= Standard_Boolean then
319 -- If result is already of correct type, nothing to do. Note that
320 -- this will get the most common case where everything has a type
321 -- of Standard.Boolean.
323 if Base_Type (T) = Standard_Boolean then
328 KP : constant Node_Kind := Nkind (Parent (N));
331 -- If result is to be used as a Condition in the syntax, no need
332 -- to convert it back, since if it was changed to Standard.Boolean
333 -- using Adjust_Condition, that is just fine for this usage.
335 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
338 -- If result is an operand of another logical operation, no need
339 -- to reset its type, since Standard.Boolean is just fine, and
340 -- such operations always do Adjust_Condition on their operands.
342 elsif KP in N_Op_Boolean
343 or else KP in N_Short_Circuit
344 or else KP = N_Op_Not
348 -- Otherwise we perform a conversion from the current type, which
349 -- must be Standard.Boolean, to the desired type.
353 Rewrite (N, Convert_To (T, N));
354 Analyze_And_Resolve (N, T);
358 end Adjust_Result_Type;
360 --------------------------
361 -- Append_Freeze_Action --
362 --------------------------
364 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
368 Ensure_Freeze_Node (T);
369 Fnode := Freeze_Node (T);
371 if No (Actions (Fnode)) then
372 Set_Actions (Fnode, New_List (N));
374 Append (N, Actions (Fnode));
377 end Append_Freeze_Action;
379 ---------------------------
380 -- Append_Freeze_Actions --
381 ---------------------------
383 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
391 Ensure_Freeze_Node (T);
392 Fnode := Freeze_Node (T);
394 if No (Actions (Fnode)) then
395 Set_Actions (Fnode, L);
397 Append_List (L, Actions (Fnode));
399 end Append_Freeze_Actions;
401 ------------------------------------
402 -- Build_Allocate_Deallocate_Proc --
403 ------------------------------------
405 procedure Build_Allocate_Deallocate_Proc
407 Is_Allocate : Boolean)
409 Desig_Typ : Entity_Id;
412 Proc_To_Call : Node_Id := Empty;
415 function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
416 -- Locate TSS primitive Finalize_Address in type Typ
418 function Find_Object (E : Node_Id) return Node_Id;
419 -- Given an arbitrary expression of an allocator, try to find an object
420 -- reference in it, otherwise return the original expression.
422 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
423 -- Determine whether subprogram Subp denotes a custom allocate or
426 ---------------------------
427 -- Find_Finalize_Address --
428 ---------------------------
430 function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id is
431 Utyp : Entity_Id := Typ;
434 -- Handle protected class-wide or task class-wide types
436 if Is_Class_Wide_Type (Utyp) then
437 if Is_Concurrent_Type (Root_Type (Utyp)) then
438 Utyp := Root_Type (Utyp);
440 elsif Is_Private_Type (Root_Type (Utyp))
441 and then Present (Full_View (Root_Type (Utyp)))
442 and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
444 Utyp := Full_View (Root_Type (Utyp));
448 -- Handle private types
450 if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
451 Utyp := Full_View (Utyp);
454 -- Handle protected and task types
456 if Is_Concurrent_Type (Utyp)
457 and then Present (Corresponding_Record_Type (Utyp))
459 Utyp := Corresponding_Record_Type (Utyp);
462 Utyp := Underlying_Type (Base_Type (Utyp));
464 -- Deal with non-tagged derivation of private views. If the parent is
465 -- now known to be protected, the finalization routine is the one
466 -- defined on the corresponding record of the ancestor (corresponding
467 -- records do not automatically inherit operations, but maybe they
470 if Is_Untagged_Derivation (Typ) then
471 if Is_Protected_Type (Typ) then
472 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
474 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
476 if Is_Protected_Type (Utyp) then
477 Utyp := Corresponding_Record_Type (Utyp);
482 -- If the underlying_type is a subtype, we are dealing with the
483 -- completion of a private type. We need to access the base type and
484 -- generate a conversion to it.
486 if Utyp /= Base_Type (Utyp) then
487 pragma Assert (Is_Private_Type (Typ));
489 Utyp := Base_Type (Utyp);
492 -- When dealing with an internally built full view for a type with
493 -- unknown discriminants, use the original record type.
495 if Is_Underlying_Record_View (Utyp) then
496 Utyp := Etype (Utyp);
499 return TSS (Utyp, TSS_Finalize_Address);
500 end Find_Finalize_Address;
506 function Find_Object (E : Node_Id) return Node_Id is
510 pragma Assert (Is_Allocate);
514 if Nkind (Expr) = N_Explicit_Dereference then
515 Expr := Prefix (Expr);
517 elsif Nkind (Expr) = N_Qualified_Expression then
518 Expr := Expression (Expr);
520 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
522 -- When interface class-wide types are involved in allocation,
523 -- the expander introduces several levels of address arithmetic
524 -- to perform dispatch table displacement. In this scenario the
525 -- object appears as:
527 -- Tag_Ptr (Base_Address (<object>'Address))
529 -- Detect this case and utilize the whole expression as the
530 -- "object" since it now points to the proper dispatch table.
532 if Is_RTE (Etype (Expr), RE_Tag_Ptr) then
535 -- Continue to strip the object
538 Expr := Expression (Expr);
549 ---------------------------------
550 -- Is_Allocate_Deallocate_Proc --
551 ---------------------------------
553 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
555 -- Look for a subprogram body with only one statement which is a
556 -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
558 if Ekind (Subp) = E_Procedure
559 and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
562 HSS : constant Node_Id :=
563 Handled_Statement_Sequence (Parent (Parent (Subp)));
567 if Present (Statements (HSS))
568 and then Nkind (First (Statements (HSS))) =
569 N_Procedure_Call_Statement
571 Proc := Entity (Name (First (Statements (HSS))));
574 Is_RTE (Proc, RE_Allocate_Any_Controlled)
575 or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
581 end Is_Allocate_Deallocate_Proc;
583 -- Start of processing for Build_Allocate_Deallocate_Proc
586 -- Obtain the attributes of the allocation / deallocation
588 if Nkind (N) = N_Free_Statement then
589 Expr := Expression (N);
590 Ptr_Typ := Base_Type (Etype (Expr));
591 Proc_To_Call := Procedure_To_Call (N);
594 if Nkind (N) = N_Object_Declaration then
595 Expr := Expression (N);
600 -- In certain cases an allocator with a qualified expression may
601 -- be relocated and used as the initialization expression of a
605 -- Obj : Ptr_Typ := new Desig_Typ'(...);
608 -- Tmp : Ptr_Typ := new Desig_Typ'(...);
609 -- Obj : Ptr_Typ := Tmp;
611 -- Since the allocator is always marked as analyzed to avoid infinite
612 -- expansion, it will never be processed by this routine given that
613 -- the designated type needs finalization actions. Detect this case
614 -- and complete the expansion of the allocator.
616 if Nkind (Expr) = N_Identifier
617 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
618 and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
620 Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
624 -- The allocator may have been rewritten into something else in which
625 -- case the expansion performed by this routine does not apply.
627 if Nkind (Expr) /= N_Allocator then
631 Ptr_Typ := Base_Type (Etype (Expr));
632 Proc_To_Call := Procedure_To_Call (Expr);
635 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
636 Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
638 -- Handle concurrent types
640 if Is_Concurrent_Type (Desig_Typ)
641 and then Present (Corresponding_Record_Type (Desig_Typ))
643 Desig_Typ := Corresponding_Record_Type (Desig_Typ);
646 -- Do not process allocations / deallocations without a pool
651 -- Do not process allocations on / deallocations from the secondary
654 elsif Is_RTE (Pool_Id, RE_SS_Pool) then
657 -- Do not replicate the machinery if the allocator / free has already
658 -- been expanded and has a custom Allocate / Deallocate.
660 elsif Present (Proc_To_Call)
661 and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
666 if Needs_Finalization (Desig_Typ) then
668 -- Certain run-time configurations and targets do not provide support
669 -- for controlled types.
671 if Restriction_Active (No_Finalization) then
674 -- Do nothing if the access type may never allocate / deallocate
677 elsif No_Pool_Assigned (Ptr_Typ) then
680 -- Access-to-controlled types are not supported on .NET/JVM since
681 -- these targets cannot support pools and address arithmetic.
683 elsif VM_Target /= No_VM then
687 -- The allocation / deallocation of a controlled object must be
688 -- chained on / detached from a finalization master.
690 pragma Assert (Present (Finalization_Master (Ptr_Typ)));
692 -- The only other kind of allocation / deallocation supported by this
693 -- routine is on / from a subpool.
695 elsif Nkind (Expr) = N_Allocator
696 and then No (Subpool_Handle_Name (Expr))
702 Loc : constant Source_Ptr := Sloc (N);
703 Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
704 Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
705 Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
706 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
709 Fin_Addr_Id : Entity_Id;
710 Fin_Mas_Act : Node_Id;
711 Fin_Mas_Id : Entity_Id;
712 Proc_To_Call : Entity_Id;
713 Subpool : Node_Id := Empty;
716 -- Step 1: Construct all the actuals for the call to library routine
717 -- Allocate_Any_Controlled / Deallocate_Any_Controlled.
721 Actuals := New_List (New_Occurrence_Of (Pool_Id, Loc));
727 if Nkind (Expr) = N_Allocator then
728 Subpool := Subpool_Handle_Name (Expr);
731 -- If a subpool is present it can be an arbitrary name, so make
732 -- the actual by copying the tree.
734 if Present (Subpool) then
735 Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
737 Append_To (Actuals, Make_Null (Loc));
740 -- c) Finalization master
742 if Needs_Finalization (Desig_Typ) then
743 Fin_Mas_Id := Finalization_Master (Ptr_Typ);
744 Fin_Mas_Act := New_Occurrence_Of (Fin_Mas_Id, Loc);
746 -- Handle the case where the master is actually a pointer to a
747 -- master. This case arises in build-in-place functions.
749 if Is_Access_Type (Etype (Fin_Mas_Id)) then
750 Append_To (Actuals, Fin_Mas_Act);
753 Make_Attribute_Reference (Loc,
754 Prefix => Fin_Mas_Act,
755 Attribute_Name => Name_Unrestricted_Access));
758 Append_To (Actuals, Make_Null (Loc));
761 -- d) Finalize_Address
763 -- Primitive Finalize_Address is never generated in CodePeer mode
764 -- since it contains an Unchecked_Conversion.
766 if Needs_Finalization (Desig_Typ) and then not CodePeer_Mode then
767 Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
768 pragma Assert (Present (Fin_Addr_Id));
771 Make_Attribute_Reference (Loc,
772 Prefix => New_Occurrence_Of (Fin_Addr_Id, Loc),
773 Attribute_Name => Name_Unrestricted_Access));
775 Append_To (Actuals, Make_Null (Loc));
783 Append_To (Actuals, New_Occurrence_Of (Addr_Id, Loc));
784 Append_To (Actuals, New_Occurrence_Of (Size_Id, Loc));
786 if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then
787 Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc));
789 -- For deallocation of class wide types we obtain the value of
790 -- alignment from the Type Specific Record of the deallocated object.
791 -- This is needed because the frontend expansion of class-wide types
792 -- into equivalent types confuses the backend.
798 -- ... because 'Alignment applied to class-wide types is expanded
799 -- into the code that reads the value of alignment from the TSD
800 -- (see Expand_N_Attribute_Reference)
803 Unchecked_Convert_To (RTE (RE_Storage_Offset),
804 Make_Attribute_Reference (Loc,
806 Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
807 Attribute_Name => Name_Alignment)));
812 if Needs_Finalization (Desig_Typ) then
814 Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
821 Temp := Find_Object (Expression (Expr));
826 -- Processing for allocations where the expression is a subtype
830 and then Is_Entity_Name (Temp)
831 and then Is_Type (Entity (Temp))
836 (Needs_Finalization (Entity (Temp))), Loc);
838 -- The allocation / deallocation of a class-wide object relies
839 -- on a runtime check to determine whether the object is truly
840 -- controlled or not. Depending on this check, the finalization
841 -- machinery will request or reclaim extra storage reserved for
844 elsif Is_Class_Wide_Type (Desig_Typ) then
846 -- Detect a special case where interface class-wide types
847 -- are involved as the object appears as:
849 -- Tag_Ptr (Base_Address (<object>'Address))
851 -- The expression already yields the proper tag, generate:
855 if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
857 Make_Explicit_Dereference (Loc,
858 Prefix => Relocate_Node (Temp));
860 -- In the default case, obtain the tag of the object about
861 -- to be allocated / deallocated. Generate:
867 Make_Attribute_Reference (Loc,
868 Prefix => Relocate_Node (Temp),
869 Attribute_Name => Name_Tag);
873 -- Needs_Finalization (<Param>)
876 Make_Function_Call (Loc,
878 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
879 Parameter_Associations => New_List (Param));
881 -- Processing for generic actuals
883 elsif Is_Generic_Actual_Type (Desig_Typ) then
885 New_Occurrence_Of (Boolean_Literals
886 (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
888 -- The object does not require any specialized checks, it is
889 -- known to be controlled.
892 Flag_Expr := New_Occurrence_Of (Standard_True, Loc);
895 -- Create the temporary which represents the finalization state
896 -- of the expression. Generate:
898 -- F : constant Boolean := <Flag_Expr>;
901 Make_Object_Declaration (Loc,
902 Defining_Identifier => Flag_Id,
903 Constant_Present => True,
905 New_Occurrence_Of (Standard_Boolean, Loc),
906 Expression => Flag_Expr));
908 Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc));
911 -- The object is not controlled
914 Append_To (Actuals, New_Occurrence_Of (Standard_False, Loc));
921 New_Occurrence_Of (Boolean_Literals (Present (Subpool)), Loc));
924 -- Step 2: Build a wrapper Allocate / Deallocate which internally
925 -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
927 -- Select the proper routine to call
930 Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
932 Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
935 -- Create a custom Allocate / Deallocate routine which has identical
936 -- profile to that of System.Storage_Pools.
939 Make_Subprogram_Body (Loc,
944 Make_Procedure_Specification (Loc,
945 Defining_Unit_Name => Proc_Id,
946 Parameter_Specifications => New_List (
948 -- P : Root_Storage_Pool
950 Make_Parameter_Specification (Loc,
951 Defining_Identifier => Make_Temporary (Loc, 'P'),
953 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)),
957 Make_Parameter_Specification (Loc,
958 Defining_Identifier => Addr_Id,
959 Out_Present => Is_Allocate,
961 New_Occurrence_Of (RTE (RE_Address), Loc)),
965 Make_Parameter_Specification (Loc,
966 Defining_Identifier => Size_Id,
968 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)),
972 Make_Parameter_Specification (Loc,
973 Defining_Identifier => Alig_Id,
975 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)))),
977 Declarations => No_List,
979 Handled_Statement_Sequence =>
980 Make_Handled_Sequence_Of_Statements (Loc,
981 Statements => New_List (
982 Make_Procedure_Call_Statement (Loc,
983 Name => New_Occurrence_Of (Proc_To_Call, Loc),
984 Parameter_Associations => Actuals)))));
986 -- The newly generated Allocate / Deallocate becomes the default
987 -- procedure to call when the back end processes the allocation /
991 Set_Procedure_To_Call (Expr, Proc_Id);
993 Set_Procedure_To_Call (N, Proc_Id);
996 end Build_Allocate_Deallocate_Proc;
998 ------------------------
999 -- Build_Runtime_Call --
1000 ------------------------
1002 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
1004 -- If entity is not available, we can skip making the call (this avoids
1005 -- junk duplicated error messages in a number of cases).
1007 if not RTE_Available (RE) then
1008 return Make_Null_Statement (Loc);
1011 Make_Procedure_Call_Statement (Loc,
1012 Name => New_Occurrence_Of (RTE (RE), Loc));
1014 end Build_Runtime_Call;
1016 ----------------------------
1017 -- Build_Task_Array_Image --
1018 ----------------------------
1020 -- This function generates the body for a function that constructs the
1021 -- image string for a task that is an array component. The function is
1022 -- local to the init proc for the array type, and is called for each one
1023 -- of the components. The constructed image has the form of an indexed
1024 -- component, whose prefix is the outer variable of the array type.
1025 -- The n-dimensional array type has known indexes Index, Index2...
1027 -- Id_Ref is an indexed component form created by the enclosing init proc.
1028 -- Its successive indexes are Val1, Val2, ... which are the loop variables
1029 -- in the loops that call the individual task init proc on each component.
1031 -- The generated function has the following structure:
1033 -- function F return String is
1034 -- Pref : string renames Task_Name;
1035 -- T1 : String := Index1'Image (Val1);
1037 -- Tn : String := indexn'image (Valn);
1038 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
1039 -- -- Len includes commas and the end parentheses.
1040 -- Res : String (1..Len);
1041 -- Pos : Integer := Pref'Length;
1044 -- Res (1 .. Pos) := Pref;
1046 -- Res (Pos) := '(';
1048 -- Res (Pos .. Pos + T1'Length - 1) := T1;
1049 -- Pos := Pos + T1'Length;
1050 -- Res (Pos) := '.';
1053 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
1054 -- Res (Len) := ')';
1059 -- Needless to say, multidimensional arrays of tasks are rare enough that
1060 -- the bulkiness of this code is not really a concern.
1062 function Build_Task_Array_Image
1066 Dyn : Boolean := False) return Node_Id
1068 Dims : constant Nat := Number_Dimensions (A_Type);
1069 -- Number of dimensions for array of tasks
1071 Temps : array (1 .. Dims) of Entity_Id;
1072 -- Array of temporaries to hold string for each index
1078 -- Total length of generated name
1081 -- Running index for substring assignments
1083 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
1084 -- Name of enclosing variable, prefix of resulting name
1087 -- String to hold result
1090 -- Value of successive indexes
1093 -- Expression to compute total size of string
1096 -- Entity for name at one index position
1098 Decls : constant List_Id := New_List;
1099 Stats : constant List_Id := New_List;
1102 -- For a dynamic task, the name comes from the target variable. For a
1103 -- static one it is a formal of the enclosing init proc.
1106 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
1108 Make_Object_Declaration (Loc,
1109 Defining_Identifier => Pref,
1110 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1112 Make_String_Literal (Loc,
1113 Strval => String_From_Name_Buffer)));
1117 Make_Object_Renaming_Declaration (Loc,
1118 Defining_Identifier => Pref,
1119 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1120 Name => Make_Identifier (Loc, Name_uTask_Name)));
1123 Indx := First_Index (A_Type);
1124 Val := First (Expressions (Id_Ref));
1126 for J in 1 .. Dims loop
1127 T := Make_Temporary (Loc, 'T');
1131 Make_Object_Declaration (Loc,
1132 Defining_Identifier => T,
1133 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1135 Make_Attribute_Reference (Loc,
1136 Attribute_Name => Name_Image,
1137 Prefix => New_Occurrence_Of (Etype (Indx), Loc),
1138 Expressions => New_List (New_Copy_Tree (Val)))));
1144 Sum := Make_Integer_Literal (Loc, Dims + 1);
1150 Make_Attribute_Reference (Loc,
1151 Attribute_Name => Name_Length,
1152 Prefix => New_Occurrence_Of (Pref, Loc),
1153 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1155 for J in 1 .. Dims loop
1160 Make_Attribute_Reference (Loc,
1161 Attribute_Name => Name_Length,
1163 New_Occurrence_Of (Temps (J), Loc),
1164 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1167 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
1169 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
1172 Make_Assignment_Statement (Loc,
1174 Make_Indexed_Component (Loc,
1175 Prefix => New_Occurrence_Of (Res, Loc),
1176 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1178 Make_Character_Literal (Loc,
1180 Char_Literal_Value => UI_From_Int (Character'Pos ('(')))));
1183 Make_Assignment_Statement (Loc,
1184 Name => New_Occurrence_Of (Pos, Loc),
1187 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1188 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1190 for J in 1 .. Dims loop
1193 Make_Assignment_Statement (Loc,
1196 Prefix => New_Occurrence_Of (Res, Loc),
1199 Low_Bound => New_Occurrence_Of (Pos, Loc),
1201 Make_Op_Subtract (Loc,
1204 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1206 Make_Attribute_Reference (Loc,
1207 Attribute_Name => Name_Length,
1209 New_Occurrence_Of (Temps (J), Loc),
1211 New_List (Make_Integer_Literal (Loc, 1)))),
1212 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
1214 Expression => New_Occurrence_Of (Temps (J), Loc)));
1218 Make_Assignment_Statement (Loc,
1219 Name => New_Occurrence_Of (Pos, Loc),
1222 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1224 Make_Attribute_Reference (Loc,
1225 Attribute_Name => Name_Length,
1226 Prefix => New_Occurrence_Of (Temps (J), Loc),
1228 New_List (Make_Integer_Literal (Loc, 1))))));
1230 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
1233 Make_Assignment_Statement (Loc,
1234 Name => Make_Indexed_Component (Loc,
1235 Prefix => New_Occurrence_Of (Res, Loc),
1236 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1238 Make_Character_Literal (Loc,
1240 Char_Literal_Value => UI_From_Int (Character'Pos (',')))));
1243 Make_Assignment_Statement (Loc,
1244 Name => New_Occurrence_Of (Pos, Loc),
1247 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1248 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1252 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
1255 Make_Assignment_Statement (Loc,
1257 Make_Indexed_Component (Loc,
1258 Prefix => New_Occurrence_Of (Res, Loc),
1259 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
1261 Make_Character_Literal (Loc,
1263 Char_Literal_Value => UI_From_Int (Character'Pos (')')))));
1264 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
1265 end Build_Task_Array_Image;
1267 ----------------------------
1268 -- Build_Task_Image_Decls --
1269 ----------------------------
1271 function Build_Task_Image_Decls
1275 In_Init_Proc : Boolean := False) return List_Id
1277 Decls : constant List_Id := New_List;
1278 T_Id : Entity_Id := Empty;
1280 Expr : Node_Id := Empty;
1281 Fun : Node_Id := Empty;
1282 Is_Dyn : constant Boolean :=
1283 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
1285 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
1288 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
1289 -- generate a dummy declaration only.
1291 if Restriction_Active (No_Implicit_Heap_Allocations)
1292 or else Global_Discard_Names
1294 T_Id := Make_Temporary (Loc, 'J');
1299 Make_Object_Declaration (Loc,
1300 Defining_Identifier => T_Id,
1301 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1303 Make_String_Literal (Loc,
1304 Strval => String_From_Name_Buffer)));
1307 if Nkind (Id_Ref) = N_Identifier
1308 or else Nkind (Id_Ref) = N_Defining_Identifier
1310 -- For a simple variable, the image of the task is built from
1311 -- the name of the variable. To avoid possible conflict with the
1312 -- anonymous type created for a single protected object, add a
1316 Make_Defining_Identifier (Loc,
1317 New_External_Name (Chars (Id_Ref), 'T', 1));
1319 Get_Name_String (Chars (Id_Ref));
1322 Make_String_Literal (Loc,
1323 Strval => String_From_Name_Buffer);
1325 elsif Nkind (Id_Ref) = N_Selected_Component then
1327 Make_Defining_Identifier (Loc,
1328 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
1329 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
1331 elsif Nkind (Id_Ref) = N_Indexed_Component then
1333 Make_Defining_Identifier (Loc,
1334 New_External_Name (Chars (A_Type), 'N'));
1336 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
1340 if Present (Fun) then
1341 Append (Fun, Decls);
1342 Expr := Make_Function_Call (Loc,
1343 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
1345 if not In_Init_Proc and then VM_Target = No_VM then
1346 Set_Uses_Sec_Stack (Defining_Entity (Fun));
1350 Decl := Make_Object_Declaration (Loc,
1351 Defining_Identifier => T_Id,
1352 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1353 Constant_Present => True,
1354 Expression => Expr);
1356 Append (Decl, Decls);
1358 end Build_Task_Image_Decls;
1360 -------------------------------
1361 -- Build_Task_Image_Function --
1362 -------------------------------
1364 function Build_Task_Image_Function
1368 Res : Entity_Id) return Node_Id
1374 Make_Simple_Return_Statement (Loc,
1375 Expression => New_Occurrence_Of (Res, Loc)));
1377 Spec := Make_Function_Specification (Loc,
1378 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
1379 Result_Definition => New_Occurrence_Of (Standard_String, Loc));
1381 -- Calls to 'Image use the secondary stack, which must be cleaned up
1382 -- after the task name is built.
1384 return Make_Subprogram_Body (Loc,
1385 Specification => Spec,
1386 Declarations => Decls,
1387 Handled_Statement_Sequence =>
1388 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
1389 end Build_Task_Image_Function;
1391 -----------------------------
1392 -- Build_Task_Image_Prefix --
1393 -----------------------------
1395 procedure Build_Task_Image_Prefix
1397 Len : out Entity_Id;
1398 Res : out Entity_Id;
1399 Pos : out Entity_Id;
1406 Len := Make_Temporary (Loc, 'L', Sum);
1409 Make_Object_Declaration (Loc,
1410 Defining_Identifier => Len,
1411 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
1412 Expression => Sum));
1414 Res := Make_Temporary (Loc, 'R');
1417 Make_Object_Declaration (Loc,
1418 Defining_Identifier => Res,
1419 Object_Definition =>
1420 Make_Subtype_Indication (Loc,
1421 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1423 Make_Index_Or_Discriminant_Constraint (Loc,
1427 Low_Bound => Make_Integer_Literal (Loc, 1),
1428 High_Bound => New_Occurrence_Of (Len, Loc)))))));
1430 -- Indicate that the result is an internal temporary, so it does not
1431 -- receive a bogus initialization when declaration is expanded. This
1432 -- is both efficient, and prevents anomalies in the handling of
1433 -- dynamic objects on the secondary stack.
1435 Set_Is_Internal (Res);
1436 Pos := Make_Temporary (Loc, 'P');
1439 Make_Object_Declaration (Loc,
1440 Defining_Identifier => Pos,
1441 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
1443 -- Pos := Prefix'Length;
1446 Make_Assignment_Statement (Loc,
1447 Name => New_Occurrence_Of (Pos, Loc),
1449 Make_Attribute_Reference (Loc,
1450 Attribute_Name => Name_Length,
1451 Prefix => New_Occurrence_Of (Prefix, Loc),
1452 Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
1454 -- Res (1 .. Pos) := Prefix;
1457 Make_Assignment_Statement (Loc,
1460 Prefix => New_Occurrence_Of (Res, Loc),
1463 Low_Bound => Make_Integer_Literal (Loc, 1),
1464 High_Bound => New_Occurrence_Of (Pos, Loc))),
1466 Expression => New_Occurrence_Of (Prefix, Loc)));
1469 Make_Assignment_Statement (Loc,
1470 Name => New_Occurrence_Of (Pos, Loc),
1473 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1474 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1475 end Build_Task_Image_Prefix;
1477 -----------------------------
1478 -- Build_Task_Record_Image --
1479 -----------------------------
1481 function Build_Task_Record_Image
1484 Dyn : Boolean := False) return Node_Id
1487 -- Total length of generated name
1490 -- Index into result
1493 -- String to hold result
1495 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
1496 -- Name of enclosing variable, prefix of resulting name
1499 -- Expression to compute total size of string
1502 -- Entity for selector name
1504 Decls : constant List_Id := New_List;
1505 Stats : constant List_Id := New_List;
1508 -- For a dynamic task, the name comes from the target variable. For a
1509 -- static one it is a formal of the enclosing init proc.
1512 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
1514 Make_Object_Declaration (Loc,
1515 Defining_Identifier => Pref,
1516 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1518 Make_String_Literal (Loc,
1519 Strval => String_From_Name_Buffer)));
1523 Make_Object_Renaming_Declaration (Loc,
1524 Defining_Identifier => Pref,
1525 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1526 Name => Make_Identifier (Loc, Name_uTask_Name)));
1529 Sel := Make_Temporary (Loc, 'S');
1531 Get_Name_String (Chars (Selector_Name (Id_Ref)));
1534 Make_Object_Declaration (Loc,
1535 Defining_Identifier => Sel,
1536 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1538 Make_String_Literal (Loc,
1539 Strval => String_From_Name_Buffer)));
1541 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
1547 Make_Attribute_Reference (Loc,
1548 Attribute_Name => Name_Length,
1550 New_Occurrence_Of (Pref, Loc),
1551 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1553 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
1555 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
1557 -- Res (Pos) := '.';
1560 Make_Assignment_Statement (Loc,
1561 Name => Make_Indexed_Component (Loc,
1562 Prefix => New_Occurrence_Of (Res, Loc),
1563 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1565 Make_Character_Literal (Loc,
1567 Char_Literal_Value =>
1568 UI_From_Int (Character'Pos ('.')))));
1571 Make_Assignment_Statement (Loc,
1572 Name => New_Occurrence_Of (Pos, Loc),
1575 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1576 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1578 -- Res (Pos .. Len) := Selector;
1581 Make_Assignment_Statement (Loc,
1582 Name => Make_Slice (Loc,
1583 Prefix => New_Occurrence_Of (Res, Loc),
1586 Low_Bound => New_Occurrence_Of (Pos, Loc),
1587 High_Bound => New_Occurrence_Of (Len, Loc))),
1588 Expression => New_Occurrence_Of (Sel, Loc)));
1590 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
1591 end Build_Task_Record_Image;
1593 ----------------------------------
1594 -- Component_May_Be_Bit_Aligned --
1595 ----------------------------------
1597 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
1601 -- If no component clause, then everything is fine, since the back end
1602 -- never bit-misaligns by default, even if there is a pragma Packed for
1605 if No (Comp) or else No (Component_Clause (Comp)) then
1609 UT := Underlying_Type (Etype (Comp));
1611 -- It is only array and record types that cause trouble
1613 if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then
1616 -- If we know that we have a small (64 bits or less) record or small
1617 -- bit-packed array, then everything is fine, since the back end can
1618 -- handle these cases correctly.
1620 elsif Esize (Comp) <= 64
1621 and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT))
1625 -- Otherwise if the component is not byte aligned, we know we have the
1626 -- nasty unaligned case.
1628 elsif Normalized_First_Bit (Comp) /= Uint_0
1629 or else Esize (Comp) mod System_Storage_Unit /= Uint_0
1633 -- If we are large and byte aligned, then OK at this level
1638 end Component_May_Be_Bit_Aligned;
1640 -----------------------------------
1641 -- Corresponding_Runtime_Package --
1642 -----------------------------------
1644 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
1645 Pkg_Id : RTU_Id := RTU_Null;
1648 pragma Assert (Is_Concurrent_Type (Typ));
1650 if Ekind (Typ) in Protected_Kind then
1651 if Has_Entries (Typ)
1653 -- A protected type without entries that covers an interface and
1654 -- overrides the abstract routines with protected procedures is
1655 -- considered equivalent to a protected type with entries in the
1656 -- context of dispatching select statements. It is sufficient to
1657 -- check for the presence of an interface list in the declaration
1658 -- node to recognize this case.
1660 or else Present (Interface_List (Parent (Typ)))
1662 -- Protected types with interrupt handlers (when not using a
1663 -- restricted profile) are also considered equivalent to
1664 -- protected types with entries. The types which are used
1665 -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection)
1666 -- are derived from Protection_Entries.
1668 or else (Has_Attach_Handler (Typ) and then not Restricted_Profile)
1669 or else Has_Interrupt_Handler (Typ)
1672 or else Restriction_Active (No_Entry_Queue) = False
1673 or else Restriction_Active (No_Select_Statements) = False
1674 or else Number_Entries (Typ) > 1
1675 or else (Has_Attach_Handler (Typ)
1676 and then not Restricted_Profile)
1678 Pkg_Id := System_Tasking_Protected_Objects_Entries;
1680 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
1684 Pkg_Id := System_Tasking_Protected_Objects;
1689 end Corresponding_Runtime_Package;
1691 -------------------------------
1692 -- Convert_To_Actual_Subtype --
1693 -------------------------------
1695 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
1699 Act_ST := Get_Actual_Subtype (Exp);
1701 if Act_ST = Etype (Exp) then
1704 Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
1705 Analyze_And_Resolve (Exp, Act_ST);
1707 end Convert_To_Actual_Subtype;
1709 -----------------------------------
1710 -- Current_Sem_Unit_Declarations --
1711 -----------------------------------
1713 function Current_Sem_Unit_Declarations return List_Id is
1714 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
1718 -- If the current unit is a package body, locate the visible
1719 -- declarations of the package spec.
1721 if Nkind (U) = N_Package_Body then
1722 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
1725 if Nkind (U) = N_Package_Declaration then
1726 U := Specification (U);
1727 Decls := Visible_Declarations (U);
1731 Set_Visible_Declarations (U, Decls);
1735 Decls := Declarations (U);
1739 Set_Declarations (U, Decls);
1744 end Current_Sem_Unit_Declarations;
1746 -----------------------
1747 -- Duplicate_Subexpr --
1748 -----------------------
1750 function Duplicate_Subexpr
1752 Name_Req : Boolean := False) return Node_Id
1755 Remove_Side_Effects (Exp, Name_Req);
1756 return New_Copy_Tree (Exp);
1757 end Duplicate_Subexpr;
1759 ---------------------------------
1760 -- Duplicate_Subexpr_No_Checks --
1761 ---------------------------------
1763 function Duplicate_Subexpr_No_Checks
1765 Name_Req : Boolean := False) return Node_Id
1769 Remove_Side_Effects (Exp, Name_Req);
1770 New_Exp := New_Copy_Tree (Exp);
1771 Remove_Checks (New_Exp);
1773 end Duplicate_Subexpr_No_Checks;
1775 -----------------------------------
1776 -- Duplicate_Subexpr_Move_Checks --
1777 -----------------------------------
1779 function Duplicate_Subexpr_Move_Checks
1781 Name_Req : Boolean := False) return Node_Id
1785 Remove_Side_Effects (Exp, Name_Req);
1786 New_Exp := New_Copy_Tree (Exp);
1787 Remove_Checks (Exp);
1789 end Duplicate_Subexpr_Move_Checks;
1791 --------------------
1792 -- Ensure_Defined --
1793 --------------------
1795 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
1799 -- An itype reference must only be created if this is a local itype, so
1800 -- that gigi can elaborate it on the proper objstack.
1802 if Is_Itype (Typ) and then Scope (Typ) = Current_Scope then
1803 IR := Make_Itype_Reference (Sloc (N));
1804 Set_Itype (IR, Typ);
1805 Insert_Action (N, IR);
1809 --------------------
1810 -- Entry_Names_OK --
1811 --------------------
1813 function Entry_Names_OK return Boolean is
1816 not Restricted_Profile
1817 and then not Global_Discard_Names
1818 and then not Restriction_Active (No_Implicit_Heap_Allocations)
1819 and then not Restriction_Active (No_Local_Allocators);
1826 procedure Evaluate_Name (Nam : Node_Id) is
1827 K : constant Node_Kind := Nkind (Nam);
1830 -- For an explicit dereference, we simply force the evaluation of the
1831 -- name expression. The dereference provides a value that is the address
1832 -- for the renamed object, and it is precisely this value that we want
1835 if K = N_Explicit_Dereference then
1836 Force_Evaluation (Prefix (Nam));
1838 -- For a selected component, we simply evaluate the prefix
1840 elsif K = N_Selected_Component then
1841 Evaluate_Name (Prefix (Nam));
1843 -- For an indexed component, or an attribute reference, we evaluate the
1844 -- prefix, which is itself a name, recursively, and then force the
1845 -- evaluation of all the subscripts (or attribute expressions).
1847 elsif Nkind_In (K, N_Indexed_Component, N_Attribute_Reference) then
1848 Evaluate_Name (Prefix (Nam));
1854 E := First (Expressions (Nam));
1855 while Present (E) loop
1856 Force_Evaluation (E);
1858 if Original_Node (E) /= E then
1859 Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E)));
1866 -- For a slice, we evaluate the prefix, as for the indexed component
1867 -- case and then, if there is a range present, either directly or as the
1868 -- constraint of a discrete subtype indication, we evaluate the two
1869 -- bounds of this range.
1871 elsif K = N_Slice then
1872 Evaluate_Name (Prefix (Nam));
1873 Evaluate_Slice_Bounds (Nam);
1875 -- For a type conversion, the expression of the conversion must be the
1876 -- name of an object, and we simply need to evaluate this name.
1878 elsif K = N_Type_Conversion then
1879 Evaluate_Name (Expression (Nam));
1881 -- For a function call, we evaluate the call
1883 elsif K = N_Function_Call then
1884 Force_Evaluation (Nam);
1886 -- The remaining cases are direct name, operator symbol and character
1887 -- literal. In all these cases, we do nothing, since we want to
1888 -- reevaluate each time the renamed object is used.
1895 ---------------------------
1896 -- Evaluate_Slice_Bounds --
1897 ---------------------------
1899 procedure Evaluate_Slice_Bounds (Slice : Node_Id) is
1900 DR : constant Node_Id := Discrete_Range (Slice);
1905 if Nkind (DR) = N_Range then
1906 Force_Evaluation (Low_Bound (DR));
1907 Force_Evaluation (High_Bound (DR));
1909 elsif Nkind (DR) = N_Subtype_Indication then
1910 Constr := Constraint (DR);
1912 if Nkind (Constr) = N_Range_Constraint then
1913 Rexpr := Range_Expression (Constr);
1915 Force_Evaluation (Low_Bound (Rexpr));
1916 Force_Evaluation (High_Bound (Rexpr));
1919 end Evaluate_Slice_Bounds;
1921 ---------------------
1922 -- Evolve_And_Then --
1923 ---------------------
1925 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
1931 Make_And_Then (Sloc (Cond1),
1933 Right_Opnd => Cond1);
1935 end Evolve_And_Then;
1937 --------------------
1938 -- Evolve_Or_Else --
1939 --------------------
1941 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
1947 Make_Or_Else (Sloc (Cond1),
1949 Right_Opnd => Cond1);
1953 -----------------------------------------
1954 -- Expand_Static_Predicates_In_Choices --
1955 -----------------------------------------
1957 procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
1958 pragma Assert (Nkind_In (N, N_Case_Statement_Alternative, N_Variant));
1960 Choices : constant List_Id := Discrete_Choices (N);
1968 Choice := First (Choices);
1969 while Present (Choice) loop
1970 Next_C := Next (Choice);
1972 -- Check for name of subtype with static predicate
1974 if Is_Entity_Name (Choice)
1975 and then Is_Type (Entity (Choice))
1976 and then Has_Predicates (Entity (Choice))
1978 -- Loop through entries in predicate list, converting to choices
1979 -- and inserting in the list before the current choice. Note that
1980 -- if the list is empty, corresponding to a False predicate, then
1981 -- no choices are inserted.
1983 P := First (Static_Predicate (Entity (Choice)));
1984 while Present (P) loop
1986 -- If low bound and high bounds are equal, copy simple choice
1988 if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then
1989 C := New_Copy (Low_Bound (P));
1991 -- Otherwise copy a range
1997 -- Change Sloc to referencing choice (rather than the Sloc of
1998 -- the predicate declaration element itself).
2000 Set_Sloc (C, Sloc (Choice));
2001 Insert_Before (Choice, C);
2005 -- Delete the predicated entry
2010 -- Move to next choice to check
2014 end Expand_Static_Predicates_In_Choices;
2016 ------------------------------
2017 -- Expand_Subtype_From_Expr --
2018 ------------------------------
2020 -- This function is applicable for both static and dynamic allocation of
2021 -- objects which are constrained by an initial expression. Basically it
2022 -- transforms an unconstrained subtype indication into a constrained one.
2024 -- The expression may also be transformed in certain cases in order to
2025 -- avoid multiple evaluation. In the static allocation case, the general
2030 -- is transformed into
2032 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
2034 -- Here are the main cases :
2036 -- <if Expr is a Slice>
2037 -- Val : T ([Index_Subtype (Expr)]) := Expr;
2039 -- <elsif Expr is a String Literal>
2040 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
2042 -- <elsif Expr is Constrained>
2043 -- subtype T is Type_Of_Expr
2046 -- <elsif Expr is an entity_name>
2047 -- Val : T (constraints taken from Expr) := Expr;
2050 -- type Axxx is access all T;
2051 -- Rval : Axxx := Expr'ref;
2052 -- Val : T (constraints taken from Rval) := Rval.all;
2054 -- ??? note: when the Expression is allocated in the secondary stack
2055 -- we could use it directly instead of copying it by declaring
2056 -- Val : T (...) renames Rval.all
2058 procedure Expand_Subtype_From_Expr
2060 Unc_Type : Entity_Id;
2061 Subtype_Indic : Node_Id;
2064 Loc : constant Source_Ptr := Sloc (N);
2065 Exp_Typ : constant Entity_Id := Etype (Exp);
2069 -- In general we cannot build the subtype if expansion is disabled,
2070 -- because internal entities may not have been defined. However, to
2071 -- avoid some cascaded errors, we try to continue when the expression is
2072 -- an array (or string), because it is safe to compute the bounds. It is
2073 -- in fact required to do so even in a generic context, because there
2074 -- may be constants that depend on the bounds of a string literal, both
2075 -- standard string types and more generally arrays of characters.
2077 -- In GNATprove mode, these extra subtypes are not needed
2079 if GNATprove_Mode then
2083 if not Expander_Active
2084 and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp)))
2089 if Nkind (Exp) = N_Slice then
2091 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
2094 Rewrite (Subtype_Indic,
2095 Make_Subtype_Indication (Loc,
2096 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
2098 Make_Index_Or_Discriminant_Constraint (Loc,
2099 Constraints => New_List
2100 (New_Occurrence_Of (Slice_Type, Loc)))));
2102 -- This subtype indication may be used later for constraint checks
2103 -- we better make sure that if a variable was used as a bound of
2104 -- of the original slice, its value is frozen.
2106 Evaluate_Slice_Bounds (Exp);
2109 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
2110 Rewrite (Subtype_Indic,
2111 Make_Subtype_Indication (Loc,
2112 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
2114 Make_Index_Or_Discriminant_Constraint (Loc,
2115 Constraints => New_List (
2116 Make_Literal_Range (Loc,
2117 Literal_Typ => Exp_Typ)))));
2119 -- If the type of the expression is an internally generated type it
2120 -- may not be necessary to create a new subtype. However there are two
2121 -- exceptions: references to the current instances, and aliased array
2122 -- object declarations for which the backend needs to create a template.
2124 elsif Is_Constrained (Exp_Typ)
2125 and then not Is_Class_Wide_Type (Unc_Type)
2127 (Nkind (N) /= N_Object_Declaration
2128 or else not Is_Entity_Name (Expression (N))
2129 or else not Comes_From_Source (Entity (Expression (N)))
2130 or else not Is_Array_Type (Exp_Typ)
2131 or else not Aliased_Present (N))
2133 if Is_Itype (Exp_Typ) then
2135 -- Within an initialization procedure, a selected component
2136 -- denotes a component of the enclosing record, and it appears as
2137 -- an actual in a call to its own initialization procedure. If
2138 -- this component depends on the outer discriminant, we must
2139 -- generate the proper actual subtype for it.
2141 if Nkind (Exp) = N_Selected_Component
2142 and then Within_Init_Proc
2145 Decl : constant Node_Id :=
2146 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
2148 if Present (Decl) then
2149 Insert_Action (N, Decl);
2150 T := Defining_Identifier (Decl);
2156 -- No need to generate a new subtype
2163 T := Make_Temporary (Loc, 'T');
2166 Make_Subtype_Declaration (Loc,
2167 Defining_Identifier => T,
2168 Subtype_Indication => New_Occurrence_Of (Exp_Typ, Loc)));
2170 -- This type is marked as an itype even though it has an explicit
2171 -- declaration since otherwise Is_Generic_Actual_Type can get
2172 -- set, resulting in the generation of spurious errors. (See
2173 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
2176 Set_Associated_Node_For_Itype (T, Exp);
2179 Rewrite (Subtype_Indic, New_Occurrence_Of (T, Loc));
2181 -- Nothing needs to be done for private types with unknown discriminants
2182 -- if the underlying type is not an unconstrained composite type or it
2183 -- is an unchecked union.
2185 elsif Is_Private_Type (Unc_Type)
2186 and then Has_Unknown_Discriminants (Unc_Type)
2187 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
2188 or else Is_Constrained (Underlying_Type (Unc_Type))
2189 or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
2193 -- Case of derived type with unknown discriminants where the parent type
2194 -- also has unknown discriminants.
2196 elsif Is_Record_Type (Unc_Type)
2197 and then not Is_Class_Wide_Type (Unc_Type)
2198 and then Has_Unknown_Discriminants (Unc_Type)
2199 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
2201 -- Nothing to be done if no underlying record view available
2203 if No (Underlying_Record_View (Unc_Type)) then
2206 -- Otherwise use the Underlying_Record_View to create the proper
2207 -- constrained subtype for an object of a derived type with unknown
2211 Remove_Side_Effects (Exp);
2212 Rewrite (Subtype_Indic,
2213 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
2216 -- Renamings of class-wide interface types require no equivalent
2217 -- constrained type declarations because we only need to reference
2218 -- the tag component associated with the interface. The same is
2219 -- presumably true for class-wide types in general, so this test
2220 -- is broadened to include all class-wide renamings, which also
2221 -- avoids cases of unbounded recursion in Remove_Side_Effects.
2222 -- (Is this really correct, or are there some cases of class-wide
2223 -- renamings that require action in this procedure???)
2226 and then Nkind (N) = N_Object_Renaming_Declaration
2227 and then Is_Class_Wide_Type (Unc_Type)
2231 -- In Ada 95 nothing to be done if the type of the expression is limited
2232 -- because in this case the expression cannot be copied, and its use can
2233 -- only be by reference.
2235 -- In Ada 2005 the context can be an object declaration whose expression
2236 -- is a function that returns in place. If the nominal subtype has
2237 -- unknown discriminants, the call still provides constraints on the
2238 -- object, and we have to create an actual subtype from it.
2240 -- If the type is class-wide, the expression is dynamically tagged and
2241 -- we do not create an actual subtype either. Ditto for an interface.
2242 -- For now this applies only if the type is immutably limited, and the
2243 -- function being called is build-in-place. This will have to be revised
2244 -- when build-in-place functions are generalized to other types.
2246 elsif Is_Limited_View (Exp_Typ)
2248 (Is_Class_Wide_Type (Exp_Typ)
2249 or else Is_Interface (Exp_Typ)
2250 or else not Has_Unknown_Discriminants (Exp_Typ)
2251 or else not Is_Composite_Type (Unc_Type))
2255 -- For limited objects initialized with build in place function calls,
2256 -- nothing to be done; otherwise we prematurely introduce an N_Reference
2257 -- node in the expression initializing the object, which breaks the
2258 -- circuitry that detects and adds the additional arguments to the
2261 elsif Is_Build_In_Place_Function_Call (Exp) then
2265 Remove_Side_Effects (Exp);
2266 Rewrite (Subtype_Indic,
2267 Make_Subtype_From_Expr (Exp, Unc_Type));
2269 end Expand_Subtype_From_Expr;
2271 ------------------------
2272 -- Find_Interface_ADT --
2273 ------------------------
2275 function Find_Interface_ADT
2277 Iface : Entity_Id) return Elmt_Id
2280 Typ : Entity_Id := T;
2283 pragma Assert (Is_Interface (Iface));
2285 -- Handle private types
2287 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
2288 Typ := Full_View (Typ);
2291 -- Handle access types
2293 if Is_Access_Type (Typ) then
2294 Typ := Designated_Type (Typ);
2297 -- Handle task and protected types implementing interfaces
2299 if Is_Concurrent_Type (Typ) then
2300 Typ := Corresponding_Record_Type (Typ);
2304 (not Is_Class_Wide_Type (Typ)
2305 and then Ekind (Typ) /= E_Incomplete_Type);
2307 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
2308 return First_Elmt (Access_Disp_Table (Typ));
2311 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
2313 and then Present (Related_Type (Node (ADT)))
2314 and then Related_Type (Node (ADT)) /= Iface
2315 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
2316 Use_Full_View => True)
2321 pragma Assert (Present (Related_Type (Node (ADT))));
2324 end Find_Interface_ADT;
2326 ------------------------
2327 -- Find_Interface_Tag --
2328 ------------------------
2330 function Find_Interface_Tag
2332 Iface : Entity_Id) return Entity_Id
2335 Found : Boolean := False;
2336 Typ : Entity_Id := T;
2338 procedure Find_Tag (Typ : Entity_Id);
2339 -- Internal subprogram used to recursively climb to the ancestors
2345 procedure Find_Tag (Typ : Entity_Id) is
2350 -- This routine does not handle the case in which the interface is an
2351 -- ancestor of Typ. That case is handled by the enclosing subprogram.
2353 pragma Assert (Typ /= Iface);
2355 -- Climb to the root type handling private types
2357 if Present (Full_View (Etype (Typ))) then
2358 if Full_View (Etype (Typ)) /= Typ then
2359 Find_Tag (Full_View (Etype (Typ)));
2362 elsif Etype (Typ) /= Typ then
2363 Find_Tag (Etype (Typ));
2366 -- Traverse the list of interfaces implemented by the type
2369 and then Present (Interfaces (Typ))
2370 and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
2372 -- Skip the tag associated with the primary table
2374 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
2375 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
2376 pragma Assert (Present (AI_Tag));
2378 AI_Elmt := First_Elmt (Interfaces (Typ));
2379 while Present (AI_Elmt) loop
2380 AI := Node (AI_Elmt);
2383 or else Is_Ancestor (Iface, AI, Use_Full_View => True)
2389 AI_Tag := Next_Tag_Component (AI_Tag);
2390 Next_Elmt (AI_Elmt);
2395 -- Start of processing for Find_Interface_Tag
2398 pragma Assert (Is_Interface (Iface));
2400 -- Handle access types
2402 if Is_Access_Type (Typ) then
2403 Typ := Designated_Type (Typ);
2406 -- Handle class-wide types
2408 if Is_Class_Wide_Type (Typ) then
2409 Typ := Root_Type (Typ);
2412 -- Handle private types
2414 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
2415 Typ := Full_View (Typ);
2418 -- Handle entities from the limited view
2420 if Ekind (Typ) = E_Incomplete_Type then
2421 pragma Assert (Present (Non_Limited_View (Typ)));
2422 Typ := Non_Limited_View (Typ);
2425 -- Handle task and protected types implementing interfaces
2427 if Is_Concurrent_Type (Typ) then
2428 Typ := Corresponding_Record_Type (Typ);
2431 -- If the interface is an ancestor of the type, then it shared the
2432 -- primary dispatch table.
2434 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
2435 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
2436 return First_Tag_Component (Typ);
2438 -- Otherwise we need to search for its associated tag component
2442 pragma Assert (Found);
2445 end Find_Interface_Tag;
2451 function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
2453 Typ : Entity_Id := T;
2457 if Is_Class_Wide_Type (Typ) then
2458 Typ := Root_Type (Typ);
2461 Typ := Underlying_Type (Typ);
2463 -- Loop through primitive operations
2465 Prim := First_Elmt (Primitive_Operations (Typ));
2466 while Present (Prim) loop
2469 -- We can retrieve primitive operations by name if it is an internal
2470 -- name. For equality we must check that both of its operands have
2471 -- the same type, to avoid confusion with user-defined equalities
2472 -- than may have a non-symmetric signature.
2474 exit when Chars (Op) = Name
2477 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
2481 -- Raise Program_Error if no primitive found
2484 raise Program_Error;
2495 function Find_Prim_Op
2497 Name : TSS_Name_Type) return Entity_Id
2499 Inher_Op : Entity_Id := Empty;
2500 Own_Op : Entity_Id := Empty;
2501 Prim_Elmt : Elmt_Id;
2502 Prim_Id : Entity_Id;
2503 Typ : Entity_Id := T;
2506 if Is_Class_Wide_Type (Typ) then
2507 Typ := Root_Type (Typ);
2510 Typ := Underlying_Type (Typ);
2512 -- This search is based on the assertion that the dispatching version
2513 -- of the TSS routine always precedes the real primitive.
2515 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
2516 while Present (Prim_Elmt) loop
2517 Prim_Id := Node (Prim_Elmt);
2519 if Is_TSS (Prim_Id, Name) then
2520 if Present (Alias (Prim_Id)) then
2521 Inher_Op := Prim_Id;
2527 Next_Elmt (Prim_Elmt);
2530 if Present (Own_Op) then
2532 elsif Present (Inher_Op) then
2535 raise Program_Error;
2539 ----------------------------
2540 -- Find_Protection_Object --
2541 ----------------------------
2543 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
2548 while Present (S) loop
2549 if Ekind_In (S, E_Entry, E_Entry_Family, E_Function, E_Procedure)
2550 and then Present (Protection_Object (S))
2552 return Protection_Object (S);
2558 -- If we do not find a Protection object in the scope chain, then
2559 -- something has gone wrong, most likely the object was never created.
2561 raise Program_Error;
2562 end Find_Protection_Object;
2564 --------------------------
2565 -- Find_Protection_Type --
2566 --------------------------
2568 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
2570 Typ : Entity_Id := Conc_Typ;
2573 if Is_Concurrent_Type (Typ) then
2574 Typ := Corresponding_Record_Type (Typ);
2577 -- Since restriction violations are not considered serious errors, the
2578 -- expander remains active, but may leave the corresponding record type
2579 -- malformed. In such cases, component _object is not available so do
2582 if not Analyzed (Typ) then
2586 Comp := First_Component (Typ);
2587 while Present (Comp) loop
2588 if Chars (Comp) = Name_uObject then
2589 return Base_Type (Etype (Comp));
2592 Next_Component (Comp);
2595 -- The corresponding record of a protected type should always have an
2598 raise Program_Error;
2599 end Find_Protection_Type;
2601 -----------------------
2602 -- Find_Hook_Context --
2603 -----------------------
2605 function Find_Hook_Context (N : Node_Id) return Node_Id is
2609 Wrapped_Node : Node_Id;
2610 -- Note: if we are in a transient scope, we want to reuse it as
2611 -- the context for actions insertion, if possible. But if N is itself
2612 -- part of the stored actions for the current transient scope,
2613 -- then we need to insert at the appropriate (inner) location in
2614 -- the not as an action on Node_To_Be_Wrapped.
2616 In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N);
2619 -- When the node is inside a case/if expression, the lifetime of any
2620 -- temporary controlled object is extended. Find a suitable insertion
2621 -- node by locating the topmost case or if expressions.
2623 if In_Cond_Expr then
2626 while Present (Par) loop
2627 if Nkind_In (Original_Node (Par), N_Case_Expression,
2632 -- Prevent the search from going too far
2634 elsif Is_Body_Or_Package_Declaration (Par) then
2638 Par := Parent (Par);
2641 -- The topmost case or if expression is now recovered, but it may
2642 -- still not be the correct place to add generated code. Climb to
2643 -- find a parent that is part of a declarative or statement list,
2644 -- and is not a list of actuals in a call.
2647 while Present (Par) loop
2648 if Is_List_Member (Par)
2649 and then not Nkind_In (Par, N_Component_Association,
2650 N_Discriminant_Association,
2651 N_Parameter_Association,
2652 N_Pragma_Argument_Association)
2653 and then not Nkind_In
2654 (Parent (Par), N_Function_Call,
2655 N_Procedure_Call_Statement,
2656 N_Entry_Call_Statement)
2661 -- Prevent the search from going too far
2663 elsif Is_Body_Or_Package_Declaration (Par) then
2667 Par := Parent (Par);
2674 while Present (Par) loop
2676 -- Keep climbing past various operators
2678 if Nkind (Parent (Par)) in N_Op
2679 or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else)
2681 Par := Parent (Par);
2689 -- The node may be located in a pragma in which case return the
2692 -- pragma Precondition (... and then Ctrl_Func_Call ...);
2694 -- Similar case occurs when the node is related to an object
2695 -- declaration or assignment:
2697 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
2699 -- Another case to consider is when the node is part of a return
2702 -- return ... and then Ctrl_Func_Call ...;
2704 -- Another case is when the node acts as a formal in a procedure
2707 -- Proc (... and then Ctrl_Func_Call ...);
2709 if Scope_Is_Transient then
2710 Wrapped_Node := Node_To_Be_Wrapped;
2712 Wrapped_Node := Empty;
2715 while Present (Par) loop
2716 if Par = Wrapped_Node
2717 or else Nkind_In (Par, N_Assignment_Statement,
2718 N_Object_Declaration,
2720 N_Procedure_Call_Statement,
2721 N_Simple_Return_Statement)
2725 -- Prevent the search from going too far
2727 elsif Is_Body_Or_Package_Declaration (Par) then
2731 Par := Parent (Par);
2734 -- Return the topmost short circuit operator
2738 end Find_Hook_Context;
2740 ----------------------
2741 -- Force_Evaluation --
2742 ----------------------
2744 procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
2746 Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
2747 end Force_Evaluation;
2749 ---------------------------------
2750 -- Fully_Qualified_Name_String --
2751 ---------------------------------
2753 function Fully_Qualified_Name_String
2755 Append_NUL : Boolean := True) return String_Id
2757 procedure Internal_Full_Qualified_Name (E : Entity_Id);
2758 -- Compute recursively the qualified name without NUL at the end, adding
2759 -- it to the currently started string being generated
2761 ----------------------------------
2762 -- Internal_Full_Qualified_Name --
2763 ----------------------------------
2765 procedure Internal_Full_Qualified_Name (E : Entity_Id) is
2769 -- Deal properly with child units
2771 if Nkind (E) = N_Defining_Program_Unit_Name then
2772 Ent := Defining_Identifier (E);
2777 -- Compute qualification recursively (only "Standard" has no scope)
2779 if Present (Scope (Scope (Ent))) then
2780 Internal_Full_Qualified_Name (Scope (Ent));
2781 Store_String_Char (Get_Char_Code ('.'));
2784 -- Every entity should have a name except some expanded blocks
2785 -- don't bother about those.
2787 if Chars (Ent) = No_Name then
2791 -- Generates the entity name in upper case
2793 Get_Decoded_Name_String (Chars (Ent));
2795 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2797 end Internal_Full_Qualified_Name;
2799 -- Start of processing for Full_Qualified_Name
2803 Internal_Full_Qualified_Name (E);
2806 Store_String_Char (Get_Char_Code (ASCII.NUL));
2810 end Fully_Qualified_Name_String;
2812 ------------------------
2813 -- Generate_Poll_Call --
2814 ------------------------
2816 procedure Generate_Poll_Call (N : Node_Id) is
2818 -- No poll call if polling not active
2820 if not Polling_Required then
2823 -- Otherwise generate require poll call
2826 Insert_Before_And_Analyze (N,
2827 Make_Procedure_Call_Statement (Sloc (N),
2828 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
2830 end Generate_Poll_Call;
2832 ---------------------------------
2833 -- Get_Current_Value_Condition --
2834 ---------------------------------
2836 -- Note: the implementation of this procedure is very closely tied to the
2837 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
2838 -- interpret Current_Value fields set by the Set procedure, so the two
2839 -- procedures need to be closely coordinated.
2841 procedure Get_Current_Value_Condition
2846 Loc : constant Source_Ptr := Sloc (Var);
2847 Ent : constant Entity_Id := Entity (Var);
2849 procedure Process_Current_Value_Condition
2852 -- N is an expression which holds either True (S = True) or False (S =
2853 -- False) in the condition. This procedure digs out the expression and
2854 -- if it refers to Ent, sets Op and Val appropriately.
2856 -------------------------------------
2857 -- Process_Current_Value_Condition --
2858 -------------------------------------
2860 procedure Process_Current_Value_Condition
2865 Prev_Cond : Node_Id;
2875 -- Deal with NOT operators, inverting sense
2877 while Nkind (Cond) = N_Op_Not loop
2878 Cond := Right_Opnd (Cond);
2882 -- Deal with conversions, qualifications, and expressions with
2885 while Nkind_In (Cond,
2887 N_Qualified_Expression,
2888 N_Expression_With_Actions)
2890 Cond := Expression (Cond);
2893 exit when Cond = Prev_Cond;
2896 -- Deal with AND THEN and AND cases
2898 if Nkind_In (Cond, N_And_Then, N_Op_And) then
2900 -- Don't ever try to invert a condition that is of the form of an
2901 -- AND or AND THEN (since we are not doing sufficiently general
2902 -- processing to allow this).
2904 if Sens = False then
2910 -- Recursively process AND and AND THEN branches
2912 Process_Current_Value_Condition (Left_Opnd (Cond), True);
2914 if Op /= N_Empty then
2918 Process_Current_Value_Condition (Right_Opnd (Cond), True);
2921 -- Case of relational operator
2923 elsif Nkind (Cond) in N_Op_Compare then
2926 -- Invert sense of test if inverted test
2928 if Sens = False then
2930 when N_Op_Eq => Op := N_Op_Ne;
2931 when N_Op_Ne => Op := N_Op_Eq;
2932 when N_Op_Lt => Op := N_Op_Ge;
2933 when N_Op_Gt => Op := N_Op_Le;
2934 when N_Op_Le => Op := N_Op_Gt;
2935 when N_Op_Ge => Op := N_Op_Lt;
2936 when others => raise Program_Error;
2940 -- Case of entity op value
2942 if Is_Entity_Name (Left_Opnd (Cond))
2943 and then Ent = Entity (Left_Opnd (Cond))
2944 and then Compile_Time_Known_Value (Right_Opnd (Cond))
2946 Val := Right_Opnd (Cond);
2948 -- Case of value op entity
2950 elsif Is_Entity_Name (Right_Opnd (Cond))
2951 and then Ent = Entity (Right_Opnd (Cond))
2952 and then Compile_Time_Known_Value (Left_Opnd (Cond))
2954 Val := Left_Opnd (Cond);
2956 -- We are effectively swapping operands
2959 when N_Op_Eq => null;
2960 when N_Op_Ne => null;
2961 when N_Op_Lt => Op := N_Op_Gt;
2962 when N_Op_Gt => Op := N_Op_Lt;
2963 when N_Op_Le => Op := N_Op_Ge;
2964 when N_Op_Ge => Op := N_Op_Le;
2965 when others => raise Program_Error;
2974 elsif Nkind_In (Cond,
2976 N_Qualified_Expression,
2977 N_Expression_With_Actions)
2979 Cond := Expression (Cond);
2981 -- Case of Boolean variable reference, return as though the
2982 -- reference had said var = True.
2985 if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then
2986 Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
2988 if Sens = False then
2995 end Process_Current_Value_Condition;
2997 -- Start of processing for Get_Current_Value_Condition
3003 -- Immediate return, nothing doing, if this is not an object
3005 if Ekind (Ent) not in Object_Kind then
3009 -- Otherwise examine current value
3012 CV : constant Node_Id := Current_Value (Ent);
3017 -- If statement. Condition is known true in THEN section, known False
3018 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
3020 if Nkind (CV) = N_If_Statement then
3022 -- Before start of IF statement
3024 if Loc < Sloc (CV) then
3027 -- After end of IF statement
3029 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
3033 -- At this stage we know that we are within the IF statement, but
3034 -- unfortunately, the tree does not record the SLOC of the ELSE so
3035 -- we cannot use a simple SLOC comparison to distinguish between
3036 -- the then/else statements, so we have to climb the tree.
3043 while Parent (N) /= CV loop
3046 -- If we fall off the top of the tree, then that's odd, but
3047 -- perhaps it could occur in some error situation, and the
3048 -- safest response is simply to assume that the outcome of
3049 -- the condition is unknown. No point in bombing during an
3050 -- attempt to optimize things.
3057 -- Now we have N pointing to a node whose parent is the IF
3058 -- statement in question, so now we can tell if we are within
3059 -- the THEN statements.
3061 if Is_List_Member (N)
3062 and then List_Containing (N) = Then_Statements (CV)
3066 -- If the variable reference does not come from source, we
3067 -- cannot reliably tell whether it appears in the else part.
3068 -- In particular, if it appears in generated code for a node
3069 -- that requires finalization, it may be attached to a list
3070 -- that has not been yet inserted into the code. For now,
3071 -- treat it as unknown.
3073 elsif not Comes_From_Source (N) then
3076 -- Otherwise we must be in ELSIF or ELSE part
3083 -- ELSIF part. Condition is known true within the referenced
3084 -- ELSIF, known False in any subsequent ELSIF or ELSE part,
3085 -- and unknown before the ELSE part or after the IF statement.
3087 elsif Nkind (CV) = N_Elsif_Part then
3089 -- if the Elsif_Part had condition_actions, the elsif has been
3090 -- rewritten as a nested if, and the original elsif_part is
3091 -- detached from the tree, so there is no way to obtain useful
3092 -- information on the current value of the variable.
3093 -- Can this be improved ???
3095 if No (Parent (CV)) then
3101 -- Before start of ELSIF part
3103 if Loc < Sloc (CV) then
3106 -- After end of IF statement
3108 elsif Loc >= Sloc (Stm) +
3109 Text_Ptr (UI_To_Int (End_Span (Stm)))
3114 -- Again we lack the SLOC of the ELSE, so we need to climb the
3115 -- tree to see if we are within the ELSIF part in question.
3122 while Parent (N) /= Stm loop
3125 -- If we fall off the top of the tree, then that's odd, but
3126 -- perhaps it could occur in some error situation, and the
3127 -- safest response is simply to assume that the outcome of
3128 -- the condition is unknown. No point in bombing during an
3129 -- attempt to optimize things.
3136 -- Now we have N pointing to a node whose parent is the IF
3137 -- statement in question, so see if is the ELSIF part we want.
3138 -- the THEN statements.
3143 -- Otherwise we must be in subsequent ELSIF or ELSE part
3150 -- Iteration scheme of while loop. The condition is known to be
3151 -- true within the body of the loop.
3153 elsif Nkind (CV) = N_Iteration_Scheme then
3155 Loop_Stmt : constant Node_Id := Parent (CV);
3158 -- Before start of body of loop
3160 if Loc < Sloc (Loop_Stmt) then
3163 -- After end of LOOP statement
3165 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
3168 -- We are within the body of the loop
3175 -- All other cases of Current_Value settings
3181 -- If we fall through here, then we have a reportable condition, Sens
3182 -- is True if the condition is true and False if it needs inverting.
3184 Process_Current_Value_Condition (Condition (CV), Sens);
3186 end Get_Current_Value_Condition;
3188 ---------------------
3189 -- Get_Stream_Size --
3190 ---------------------
3192 function Get_Stream_Size (E : Entity_Id) return Uint is
3194 -- If we have a Stream_Size clause for this type use it
3196 if Has_Stream_Size_Clause (E) then
3197 return Static_Integer (Expression (Stream_Size_Clause (E)));
3199 -- Otherwise the Stream_Size if the size of the type
3204 end Get_Stream_Size;
3206 ---------------------------
3207 -- Has_Access_Constraint --
3208 ---------------------------
3210 function Has_Access_Constraint (E : Entity_Id) return Boolean is
3212 T : constant Entity_Id := Etype (E);
3215 if Has_Per_Object_Constraint (E) and then Has_Discriminants (T) then
3216 Disc := First_Discriminant (T);
3217 while Present (Disc) loop
3218 if Is_Access_Type (Etype (Disc)) then
3222 Next_Discriminant (Disc);
3229 end Has_Access_Constraint;
3231 ----------------------------------
3232 -- Has_Following_Address_Clause --
3233 ----------------------------------
3235 -- Should this function check the private part in a package ???
3237 function Has_Following_Address_Clause (D : Node_Id) return Boolean is
3238 Id : constant Entity_Id := Defining_Identifier (D);
3243 while Present (Decl) loop
3244 if Nkind (Decl) = N_At_Clause
3245 and then Chars (Identifier (Decl)) = Chars (Id)
3249 elsif Nkind (Decl) = N_Attribute_Definition_Clause
3250 and then Chars (Decl) = Name_Address
3251 and then Chars (Name (Decl)) = Chars (Id)
3260 end Has_Following_Address_Clause;
3262 --------------------
3263 -- Homonym_Number --
3264 --------------------
3266 function Homonym_Number (Subp : Entity_Id) return Nat is
3272 Hom := Homonym (Subp);
3273 while Present (Hom) loop
3274 if Scope (Hom) = Scope (Subp) then
3278 Hom := Homonym (Hom);
3284 -----------------------------------
3285 -- In_Library_Level_Package_Body --
3286 -----------------------------------
3288 function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
3290 -- First determine whether the entity appears at the library level, then
3291 -- look at the containing unit.
3293 if Is_Library_Level_Entity (Id) then
3295 Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
3298 return Nkind (Unit (Container)) = N_Package_Body;
3303 end In_Library_Level_Package_Body;
3305 ------------------------------
3306 -- In_Unconditional_Context --
3307 ------------------------------
3309 function In_Unconditional_Context (Node : Node_Id) return Boolean is
3314 while Present (P) loop
3316 when N_Subprogram_Body =>
3319 when N_If_Statement =>
3322 when N_Loop_Statement =>
3325 when N_Case_Statement =>
3334 end In_Unconditional_Context;
3340 procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
3342 if Present (Ins_Action) then
3343 Insert_Actions (Assoc_Node, New_List (Ins_Action));
3347 -- Version with check(s) suppressed
3349 procedure Insert_Action
3350 (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
3353 Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
3356 -------------------------
3357 -- Insert_Action_After --
3358 -------------------------
3360 procedure Insert_Action_After
3361 (Assoc_Node : Node_Id;
3362 Ins_Action : Node_Id)
3365 Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
3366 end Insert_Action_After;
3368 --------------------
3369 -- Insert_Actions --
3370 --------------------
3372 procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
3376 Wrapped_Node : Node_Id := Empty;
3379 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
3383 -- Ignore insert of actions from inside default expression (or other
3384 -- similar "spec expression") in the special spec-expression analyze
3385 -- mode. Any insertions at this point have no relevance, since we are
3386 -- only doing the analyze to freeze the types of any static expressions.
3387 -- See section "Handling of Default Expressions" in the spec of package
3388 -- Sem for further details.
3390 if In_Spec_Expression then
3394 -- If the action derives from stuff inside a record, then the actions
3395 -- are attached to the current scope, to be inserted and analyzed on
3396 -- exit from the scope. The reason for this is that we may also be
3397 -- generating freeze actions at the same time, and they must eventually
3398 -- be elaborated in the correct order.
3400 if Is_Record_Type (Current_Scope)
3401 and then not Is_Frozen (Current_Scope)
3403 if No (Scope_Stack.Table
3404 (Scope_Stack.Last).Pending_Freeze_Actions)
3406 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
3411 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
3417 -- We now intend to climb up the tree to find the right point to
3418 -- insert the actions. We start at Assoc_Node, unless this node is a
3419 -- subexpression in which case we start with its parent. We do this for
3420 -- two reasons. First it speeds things up. Second, if Assoc_Node is
3421 -- itself one of the special nodes like N_And_Then, then we assume that
3422 -- an initial request to insert actions for such a node does not expect
3423 -- the actions to get deposited in the node for later handling when the
3424 -- node is expanded, since clearly the node is being dealt with by the
3425 -- caller. Note that in the subexpression case, N is always the child we
3428 -- N_Raise_xxx_Error is an annoying special case, it is a statement if
3429 -- it has type Standard_Void_Type, and a subexpression otherwise.
3430 -- otherwise. Procedure calls, and similarly procedure attribute
3431 -- references, are also statements.
3433 if Nkind (Assoc_Node) in N_Subexpr
3434 and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error
3435 or else Etype (Assoc_Node) /= Standard_Void_Type)
3436 and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement
3437 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
3439 not Is_Procedure_Attribute_Name
3440 (Attribute_Name (Assoc_Node)))
3443 P := Parent (Assoc_Node);
3445 -- Non-subexpression case. Note that N is initially Empty in this case
3446 -- (N is only guaranteed Non-Empty in the subexpr case).
3453 -- Capture root of the transient scope
3455 if Scope_Is_Transient then
3456 Wrapped_Node := Node_To_Be_Wrapped;
3460 pragma Assert (Present (P));
3462 -- Make sure that inserted actions stay in the transient scope
3464 if Present (Wrapped_Node) and then N = Wrapped_Node then
3465 Store_Before_Actions_In_Scope (Ins_Actions);
3471 -- Case of right operand of AND THEN or OR ELSE. Put the actions
3472 -- in the Actions field of the right operand. They will be moved
3473 -- out further when the AND THEN or OR ELSE operator is expanded.
3474 -- Nothing special needs to be done for the left operand since
3475 -- in that case the actions are executed unconditionally.
3477 when N_Short_Circuit =>
3478 if N = Right_Opnd (P) then
3480 -- We are now going to either append the actions to the
3481 -- actions field of the short-circuit operation. We will
3482 -- also analyze the actions now.
3484 -- This analysis is really too early, the proper thing would
3485 -- be to just park them there now, and only analyze them if
3486 -- we find we really need them, and to it at the proper
3487 -- final insertion point. However attempting to this proved
3488 -- tricky, so for now we just kill current values before and
3489 -- after the analyze call to make sure we avoid peculiar
3490 -- optimizations from this out of order insertion.
3492 Kill_Current_Values;
3494 -- If P has already been expanded, we can't park new actions
3495 -- on it, so we need to expand them immediately, introducing
3496 -- an Expression_With_Actions. N can't be an expression
3497 -- with actions, or else then the actions would have been
3498 -- inserted at an inner level.
3500 if Analyzed (P) then
3501 pragma Assert (Nkind (N) /= N_Expression_With_Actions);
3503 Make_Expression_With_Actions (Sloc (N),
3504 Actions => Ins_Actions,
3505 Expression => Relocate_Node (N)));
3506 Analyze_And_Resolve (N);
3508 elsif Present (Actions (P)) then
3509 Insert_List_After_And_Analyze
3510 (Last (Actions (P)), Ins_Actions);
3512 Set_Actions (P, Ins_Actions);
3513 Analyze_List (Actions (P));
3516 Kill_Current_Values;
3521 -- Then or Else dependent expression of an if expression. Add
3522 -- actions to Then_Actions or Else_Actions field as appropriate.
3523 -- The actions will be moved further out when the if is expanded.
3525 when N_If_Expression =>
3527 ThenX : constant Node_Id := Next (First (Expressions (P)));
3528 ElseX : constant Node_Id := Next (ThenX);
3531 -- If the enclosing expression is already analyzed, as
3532 -- is the case for nested elaboration checks, insert the
3533 -- conditional further out.
3535 if Analyzed (P) then
3538 -- Actions belong to the then expression, temporarily place
3539 -- them as Then_Actions of the if expression. They will be
3540 -- moved to the proper place later when the if expression
3543 elsif N = ThenX then
3544 if Present (Then_Actions (P)) then
3545 Insert_List_After_And_Analyze
3546 (Last (Then_Actions (P)), Ins_Actions);
3548 Set_Then_Actions (P, Ins_Actions);
3549 Analyze_List (Then_Actions (P));
3554 -- Actions belong to the else expression, temporarily place
3555 -- them as Else_Actions of the if expression. They will be
3556 -- moved to the proper place later when the if expression
3559 elsif N = ElseX then
3560 if Present (Else_Actions (P)) then
3561 Insert_List_After_And_Analyze
3562 (Last (Else_Actions (P)), Ins_Actions);
3564 Set_Else_Actions (P, Ins_Actions);
3565 Analyze_List (Else_Actions (P));
3570 -- Actions belong to the condition. In this case they are
3571 -- unconditionally executed, and so we can continue the
3572 -- search for the proper insert point.
3579 -- Alternative of case expression, we place the action in the
3580 -- Actions field of the case expression alternative, this will
3581 -- be handled when the case expression is expanded.
3583 when N_Case_Expression_Alternative =>
3584 if Present (Actions (P)) then
3585 Insert_List_After_And_Analyze
3586 (Last (Actions (P)), Ins_Actions);
3588 Set_Actions (P, Ins_Actions);
3589 Analyze_List (Actions (P));
3594 -- Case of appearing within an Expressions_With_Actions node. When
3595 -- the new actions come from the expression of the expression with
3596 -- actions, they must be added to the existing actions. The other
3597 -- alternative is when the new actions are related to one of the
3598 -- existing actions of the expression with actions, and should
3599 -- never reach here: if actions are inserted on a statement
3600 -- within the Actions of an expression with actions, or on some
3601 -- sub-expression of such a statement, then the outermost proper
3602 -- insertion point is right before the statement, and we should
3603 -- never climb up as far as the N_Expression_With_Actions itself.
3605 when N_Expression_With_Actions =>
3606 if N = Expression (P) then
3607 if Is_Empty_List (Actions (P)) then
3608 Append_List_To (Actions (P), Ins_Actions);
3609 Analyze_List (Actions (P));
3611 Insert_List_After_And_Analyze
3612 (Last (Actions (P)), Ins_Actions);
3618 raise Program_Error;
3621 -- Case of appearing in the condition of a while expression or
3622 -- elsif. We insert the actions into the Condition_Actions field.
3623 -- They will be moved further out when the while loop or elsif
3626 when N_Iteration_Scheme |
3629 if N = Condition (P) then
3630 if Present (Condition_Actions (P)) then
3631 Insert_List_After_And_Analyze
3632 (Last (Condition_Actions (P)), Ins_Actions);
3634 Set_Condition_Actions (P, Ins_Actions);
3636 -- Set the parent of the insert actions explicitly. This
3637 -- is not a syntactic field, but we need the parent field
3638 -- set, in particular so that freeze can understand that
3639 -- it is dealing with condition actions, and properly
3640 -- insert the freezing actions.
3642 Set_Parent (Ins_Actions, P);
3643 Analyze_List (Condition_Actions (P));
3649 -- Statements, declarations, pragmas, representation clauses
3654 N_Procedure_Call_Statement |
3655 N_Statement_Other_Than_Procedure_Call |
3661 -- Representation_Clause
3664 N_Attribute_Definition_Clause |
3665 N_Enumeration_Representation_Clause |
3666 N_Record_Representation_Clause |
3670 N_Abstract_Subprogram_Declaration |
3672 N_Exception_Declaration |
3673 N_Exception_Renaming_Declaration |
3674 N_Expression_Function |
3675 N_Formal_Abstract_Subprogram_Declaration |
3676 N_Formal_Concrete_Subprogram_Declaration |
3677 N_Formal_Object_Declaration |
3678 N_Formal_Type_Declaration |
3679 N_Full_Type_Declaration |
3680 N_Function_Instantiation |
3681 N_Generic_Function_Renaming_Declaration |
3682 N_Generic_Package_Declaration |
3683 N_Generic_Package_Renaming_Declaration |
3684 N_Generic_Procedure_Renaming_Declaration |
3685 N_Generic_Subprogram_Declaration |
3686 N_Implicit_Label_Declaration |
3687 N_Incomplete_Type_Declaration |
3688 N_Number_Declaration |
3689 N_Object_Declaration |
3690 N_Object_Renaming_Declaration |
3692 N_Package_Body_Stub |
3693 N_Package_Declaration |
3694 N_Package_Instantiation |
3695 N_Package_Renaming_Declaration |
3696 N_Private_Extension_Declaration |
3697 N_Private_Type_Declaration |
3698 N_Procedure_Instantiation |
3700 N_Protected_Body_Stub |
3701 N_Protected_Type_Declaration |
3702 N_Single_Task_Declaration |
3704 N_Subprogram_Body_Stub |
3705 N_Subprogram_Declaration |
3706 N_Subprogram_Renaming_Declaration |
3707 N_Subtype_Declaration |
3710 N_Task_Type_Declaration |
3712 -- Use clauses can appear in lists of declarations
3714 N_Use_Package_Clause |
3717 -- Freeze entity behaves like a declaration or statement
3720 N_Freeze_Generic_Entity
3722 -- Do not insert here if the item is not a list member (this
3723 -- happens for example with a triggering statement, and the
3724 -- proper approach is to insert before the entire select).
3726 if not Is_List_Member (P) then
3729 -- Do not insert if parent of P is an N_Component_Association
3730 -- node (i.e. we are in the context of an N_Aggregate or
3731 -- N_Extension_Aggregate node. In this case we want to insert
3732 -- before the entire aggregate.
3734 elsif Nkind (Parent (P)) = N_Component_Association then
3737 -- Do not insert if the parent of P is either an N_Variant node
3738 -- or an N_Record_Definition node, meaning in either case that
3739 -- P is a member of a component list, and that therefore the
3740 -- actions should be inserted outside the complete record
3743 elsif Nkind_In (Parent (P), N_Variant, N_Record_Definition) then
3746 -- Do not insert freeze nodes within the loop generated for
3747 -- an aggregate, because they may be elaborated too late for
3748 -- subsequent use in the back end: within a package spec the
3749 -- loop is part of the elaboration procedure and is only
3750 -- elaborated during the second pass.
3752 -- If the loop comes from source, or the entity is local to the
3753 -- loop itself it must remain within.
3755 elsif Nkind (Parent (P)) = N_Loop_Statement
3756 and then not Comes_From_Source (Parent (P))
3757 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
3759 Scope (Entity (First (Ins_Actions))) /= Current_Scope
3763 -- Otherwise we can go ahead and do the insertion
3765 elsif P = Wrapped_Node then
3766 Store_Before_Actions_In_Scope (Ins_Actions);
3770 Insert_List_Before_And_Analyze (P, Ins_Actions);
3774 -- A special case, N_Raise_xxx_Error can act either as a statement
3775 -- or a subexpression. We tell the difference by looking at the
3776 -- Etype. It is set to Standard_Void_Type in the statement case.
3779 N_Raise_xxx_Error =>
3780 if Etype (P) = Standard_Void_Type then
3781 if P = Wrapped_Node then
3782 Store_Before_Actions_In_Scope (Ins_Actions);
3784 Insert_List_Before_And_Analyze (P, Ins_Actions);
3789 -- In the subexpression case, keep climbing
3795 -- If a component association appears within a loop created for
3796 -- an array aggregate, attach the actions to the association so
3797 -- they can be subsequently inserted within the loop. For other
3798 -- component associations insert outside of the aggregate. For
3799 -- an association that will generate a loop, its Loop_Actions
3800 -- attribute is already initialized (see exp_aggr.adb).
3802 -- The list of loop_actions can in turn generate additional ones,
3803 -- that are inserted before the associated node. If the associated
3804 -- node is outside the aggregate, the new actions are collected
3805 -- at the end of the loop actions, to respect the order in which
3806 -- they are to be elaborated.
3809 N_Component_Association =>
3810 if Nkind (Parent (P)) = N_Aggregate
3811 and then Present (Loop_Actions (P))
3813 if Is_Empty_List (Loop_Actions (P)) then
3814 Set_Loop_Actions (P, Ins_Actions);
3815 Analyze_List (Ins_Actions);
3822 -- Check whether these actions were generated by a
3823 -- declaration that is part of the loop_ actions
3824 -- for the component_association.
3827 while Present (Decl) loop
3828 exit when Parent (Decl) = P
3829 and then Is_List_Member (Decl)
3831 List_Containing (Decl) = Loop_Actions (P);
3832 Decl := Parent (Decl);
3835 if Present (Decl) then
3836 Insert_List_Before_And_Analyze
3837 (Decl, Ins_Actions);
3839 Insert_List_After_And_Analyze
3840 (Last (Loop_Actions (P)), Ins_Actions);
3851 -- Another special case, an attribute denoting a procedure call
3854 N_Attribute_Reference =>
3855 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
3856 if P = Wrapped_Node then
3857 Store_Before_Actions_In_Scope (Ins_Actions);
3859 Insert_List_Before_And_Analyze (P, Ins_Actions);
3864 -- In the subexpression case, keep climbing
3870 -- A contract node should not belong to the tree
3873 raise Program_Error;
3875 -- For all other node types, keep climbing tree
3879 N_Accept_Alternative |
3880 N_Access_Definition |
3881 N_Access_Function_Definition |
3882 N_Access_Procedure_Definition |
3883 N_Access_To_Object_Definition |
3886 N_Aspect_Specification |
3888 N_Case_Statement_Alternative |
3889 N_Character_Literal |
3890 N_Compilation_Unit |
3891 N_Compilation_Unit_Aux |
3892 N_Component_Clause |
3893 N_Component_Declaration |
3894 N_Component_Definition |
3896 N_Constrained_Array_Definition |
3897 N_Decimal_Fixed_Point_Definition |
3898 N_Defining_Character_Literal |
3899 N_Defining_Identifier |
3900 N_Defining_Operator_Symbol |
3901 N_Defining_Program_Unit_Name |
3902 N_Delay_Alternative |
3903 N_Delta_Constraint |
3904 N_Derived_Type_Definition |
3906 N_Digits_Constraint |
3907 N_Discriminant_Association |
3908 N_Discriminant_Specification |
3910 N_Entry_Body_Formal_Part |
3911 N_Entry_Call_Alternative |
3912 N_Entry_Declaration |
3913 N_Entry_Index_Specification |
3914 N_Enumeration_Type_Definition |
3916 N_Exception_Handler |
3918 N_Explicit_Dereference |
3919 N_Extension_Aggregate |
3920 N_Floating_Point_Definition |
3921 N_Formal_Decimal_Fixed_Point_Definition |
3922 N_Formal_Derived_Type_Definition |
3923 N_Formal_Discrete_Type_Definition |
3924 N_Formal_Floating_Point_Definition |
3925 N_Formal_Modular_Type_Definition |
3926 N_Formal_Ordinary_Fixed_Point_Definition |
3927 N_Formal_Package_Declaration |
3928 N_Formal_Private_Type_Definition |
3929 N_Formal_Incomplete_Type_Definition |
3930 N_Formal_Signed_Integer_Type_Definition |
3932 N_Function_Specification |
3933 N_Generic_Association |
3934 N_Handled_Sequence_Of_Statements |
3937 N_Index_Or_Discriminant_Constraint |
3938 N_Indexed_Component |
3940 N_Iterator_Specification |
3943 N_Loop_Parameter_Specification |
3945 N_Modular_Type_Definition |
3971 N_Op_Shift_Right_Arithmetic |
3975 N_Ordinary_Fixed_Point_Definition |
3977 N_Package_Specification |
3978 N_Parameter_Association |
3979 N_Parameter_Specification |
3980 N_Pop_Constraint_Error_Label |
3981 N_Pop_Program_Error_Label |
3982 N_Pop_Storage_Error_Label |
3983 N_Pragma_Argument_Association |
3984 N_Procedure_Specification |
3985 N_Protected_Definition |
3986 N_Push_Constraint_Error_Label |
3987 N_Push_Program_Error_Label |
3988 N_Push_Storage_Error_Label |
3989 N_Qualified_Expression |
3990 N_Quantified_Expression |
3991 N_Raise_Expression |
3993 N_Range_Constraint |
3995 N_Real_Range_Specification |
3996 N_Record_Definition |
3998 N_SCIL_Dispatch_Table_Tag_Init |
3999 N_SCIL_Dispatching_Call |
4000 N_SCIL_Membership_Test |
4001 N_Selected_Component |
4002 N_Signed_Integer_Type_Definition |
4003 N_Single_Protected_Declaration |
4006 N_Subtype_Indication |
4009 N_Terminate_Alternative |
4010 N_Triggering_Alternative |
4012 N_Unchecked_Expression |
4013 N_Unchecked_Type_Conversion |
4014 N_Unconstrained_Array_Definition |
4019 N_Validate_Unchecked_Conversion |
4026 -- If we fall through above tests, keep climbing tree
4030 if Nkind (Parent (N)) = N_Subunit then
4032 -- This is the proper body corresponding to a stub. Insertion must
4033 -- be done at the point of the stub, which is in the declarative
4034 -- part of the parent unit.
4036 P := Corresponding_Stub (Parent (N));
4044 -- Version with check(s) suppressed
4046 procedure Insert_Actions
4047 (Assoc_Node : Node_Id;
4048 Ins_Actions : List_Id;
4049 Suppress : Check_Id)
4052 if Suppress = All_Checks then
4054 Sva : constant Suppress_Array := Scope_Suppress.Suppress;
4056 Scope_Suppress.Suppress := (others => True);
4057 Insert_Actions (Assoc_Node, Ins_Actions);
4058 Scope_Suppress.Suppress := Sva;
4063 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
4065 Scope_Suppress.Suppress (Suppress) := True;
4066 Insert_Actions (Assoc_Node, Ins_Actions);
4067 Scope_Suppress.Suppress (Suppress) := Svg;
4072 --------------------------
4073 -- Insert_Actions_After --
4074 --------------------------
4076 procedure Insert_Actions_After
4077 (Assoc_Node : Node_Id;
4078 Ins_Actions : List_Id)
4081 if Scope_Is_Transient and then Assoc_Node = Node_To_Be_Wrapped then
4082 Store_After_Actions_In_Scope (Ins_Actions);
4084 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
4086 end Insert_Actions_After;
4088 ------------------------
4089 -- Insert_Declaration --
4090 ------------------------
4092 procedure Insert_Declaration (N : Node_Id; Decl : Node_Id) is
4096 pragma Assert (Nkind (N) in N_Subexpr);
4098 -- Climb until we find a procedure or a package
4102 pragma Assert (Present (Parent (P)));
4105 if Is_List_Member (P) then
4106 exit when Nkind_In (Parent (P), N_Package_Specification,
4109 -- Special handling for handled sequence of statements, we must
4110 -- insert in the statements not the exception handlers!
4112 if Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements then
4113 P := First (Statements (Parent (P)));
4119 -- Now do the insertion
4121 Insert_Before (P, Decl);
4123 end Insert_Declaration;
4125 ---------------------------------
4126 -- Insert_Library_Level_Action --
4127 ---------------------------------
4129 procedure Insert_Library_Level_Action (N : Node_Id) is
4130 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
4133 Push_Scope (Cunit_Entity (Main_Unit));
4134 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
4136 if No (Actions (Aux)) then
4137 Set_Actions (Aux, New_List (N));
4139 Append (N, Actions (Aux));
4144 end Insert_Library_Level_Action;
4146 ----------------------------------
4147 -- Insert_Library_Level_Actions --
4148 ----------------------------------
4150 procedure Insert_Library_Level_Actions (L : List_Id) is
4151 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
4154 if Is_Non_Empty_List (L) then
4155 Push_Scope (Cunit_Entity (Main_Unit));
4156 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
4158 if No (Actions (Aux)) then
4159 Set_Actions (Aux, L);
4162 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
4167 end Insert_Library_Level_Actions;
4169 ----------------------
4170 -- Inside_Init_Proc --
4171 ----------------------
4173 function Inside_Init_Proc return Boolean is
4178 while Present (S) and then S /= Standard_Standard loop
4179 if Is_Init_Proc (S) then
4187 end Inside_Init_Proc;
4189 ----------------------------
4190 -- Is_All_Null_Statements --
4191 ----------------------------
4193 function Is_All_Null_Statements (L : List_Id) return Boolean is
4198 while Present (Stm) loop
4199 if Nkind (Stm) /= N_Null_Statement then
4207 end Is_All_Null_Statements;
4209 --------------------------------------------------
4210 -- Is_Displacement_Of_Object_Or_Function_Result --
4211 --------------------------------------------------
4213 function Is_Displacement_Of_Object_Or_Function_Result
4214 (Obj_Id : Entity_Id) return Boolean
4216 function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
4217 -- Determine if particular node denotes a controlled function call. The
4218 -- call may have been heavily expanded.
4220 function Is_Displace_Call (N : Node_Id) return Boolean;
4221 -- Determine whether a particular node is a call to Ada.Tags.Displace.
4222 -- The call might be nested within other actions such as conversions.
4224 function Is_Source_Object (N : Node_Id) return Boolean;
4225 -- Determine whether a particular node denotes a source object
4227 ---------------------------------
4228 -- Is_Controlled_Function_Call --
4229 ---------------------------------
4231 function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
4232 Expr : Node_Id := Original_Node (N);
4235 if Nkind (Expr) = N_Function_Call then
4236 Expr := Name (Expr);
4238 -- When a function call appears in Object.Operation format, the
4239 -- original representation has two possible forms depending on the
4240 -- availability of actual parameters:
4242 -- Obj.Func_Call N_Selected_Component
4243 -- Obj.Func_Call (Param) N_Indexed_Component
4246 if Nkind (Expr) = N_Indexed_Component then
4247 Expr := Prefix (Expr);
4250 if Nkind (Expr) = N_Selected_Component then
4251 Expr := Selector_Name (Expr);
4256 Nkind_In (Expr, N_Expanded_Name, N_Identifier)
4257 and then Ekind (Entity (Expr)) = E_Function
4258 and then Needs_Finalization (Etype (Entity (Expr)));
4259 end Is_Controlled_Function_Call;
4261 ----------------------
4262 -- Is_Displace_Call --
4263 ----------------------
4265 function Is_Displace_Call (N : Node_Id) return Boolean is
4266 Call : Node_Id := N;
4269 -- Strip various actions which may precede a call to Displace
4272 if Nkind (Call) = N_Explicit_Dereference then
4273 Call := Prefix (Call);
4275 elsif Nkind_In (Call, N_Type_Conversion,
4276 N_Unchecked_Type_Conversion)
4278 Call := Expression (Call);
4287 and then Nkind (Call) = N_Function_Call
4288 and then Is_RTE (Entity (Name (Call)), RE_Displace);
4289 end Is_Displace_Call;
4291 ----------------------
4292 -- Is_Source_Object --
4293 ----------------------
4295 function Is_Source_Object (N : Node_Id) return Boolean is
4299 and then Nkind (N) in N_Has_Entity
4300 and then Is_Object (Entity (N))
4301 and then Comes_From_Source (N);
4302 end Is_Source_Object;
4306 Decl : constant Node_Id := Parent (Obj_Id);
4307 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
4308 Orig_Decl : constant Node_Id := Original_Node (Decl);
4310 -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
4315 -- Obj : CW_Type := Function_Call (...);
4319 -- Tmp : ... := Function_Call (...)'reference;
4320 -- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp));
4322 -- where the return type of the function and the class-wide type require
4323 -- dispatch table pointer displacement.
4327 -- Obj : CW_Type := Src_Obj;
4331 -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
4333 -- where the type of the source object and the class-wide type require
4334 -- dispatch table pointer displacement.
4337 Nkind (Decl) = N_Object_Renaming_Declaration
4338 and then Nkind (Orig_Decl) = N_Object_Declaration
4339 and then Comes_From_Source (Orig_Decl)
4340 and then Is_Class_Wide_Type (Obj_Typ)
4341 and then Is_Displace_Call (Renamed_Object (Obj_Id))
4343 (Is_Controlled_Function_Call (Expression (Orig_Decl))
4344 or else Is_Source_Object (Expression (Orig_Decl)));
4345 end Is_Displacement_Of_Object_Or_Function_Result;
4347 ------------------------------
4348 -- Is_Finalizable_Transient --
4349 ------------------------------
4351 function Is_Finalizable_Transient
4353 Rel_Node : Node_Id) return Boolean
4355 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
4356 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
4357 Desig : Entity_Id := Obj_Typ;
4359 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
4360 -- Determine whether transient object Trans_Id is initialized either
4361 -- by a function call which returns an access type or simply renames
4364 function Initialized_By_Aliased_BIP_Func_Call
4365 (Trans_Id : Entity_Id) return Boolean;
4366 -- Determine whether transient object Trans_Id is initialized by a
4367 -- build-in-place function call where the BIPalloc parameter is of
4368 -- value 1 and BIPaccess is not null. This case creates an aliasing
4369 -- between the returned value and the value denoted by BIPaccess.
4372 (Trans_Id : Entity_Id;
4373 First_Stmt : Node_Id) return Boolean;
4374 -- Determine whether transient object Trans_Id has been renamed or
4375 -- aliased through 'reference in the statement list starting from
4378 function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
4379 -- Determine whether transient object Trans_Id is allocated on the heap
4381 function Is_Iterated_Container
4382 (Trans_Id : Entity_Id;
4383 First_Stmt : Node_Id) return Boolean;
4384 -- Determine whether transient object Trans_Id denotes a container which
4385 -- is in the process of being iterated in the statement list starting
4388 ---------------------------
4389 -- Initialized_By_Access --
4390 ---------------------------
4392 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
4393 Expr : constant Node_Id := Expression (Parent (Trans_Id));
4398 and then Nkind (Expr) /= N_Reference
4399 and then Is_Access_Type (Etype (Expr));
4400 end Initialized_By_Access;
4402 ------------------------------------------
4403 -- Initialized_By_Aliased_BIP_Func_Call --
4404 ------------------------------------------
4406 function Initialized_By_Aliased_BIP_Func_Call
4407 (Trans_Id : Entity_Id) return Boolean
4409 Call : Node_Id := Expression (Parent (Trans_Id));
4412 -- Build-in-place calls usually appear in 'reference format
4414 if Nkind (Call) = N_Reference then
4415 Call := Prefix (Call);
4418 if Is_Build_In_Place_Function_Call (Call) then
4420 Access_Nam : Name_Id := No_Name;
4421 Access_OK : Boolean := False;
4423 Alloc_Nam : Name_Id := No_Name;
4424 Alloc_OK : Boolean := False;
4426 Func_Id : Entity_Id;
4430 -- Examine all parameter associations of the function call
4432 Param := First (Parameter_Associations (Call));
4433 while Present (Param) loop
4434 if Nkind (Param) = N_Parameter_Association
4435 and then Nkind (Selector_Name (Param)) = N_Identifier
4437 Actual := Explicit_Actual_Parameter (Param);
4438 Formal := Selector_Name (Param);
4440 -- Construct the names of formals BIPaccess and BIPalloc
4441 -- using the function name retrieved from an arbitrary
4444 if Access_Nam = No_Name
4445 and then Alloc_Nam = No_Name
4446 and then Present (Entity (Formal))
4448 Func_Id := Scope (Entity (Formal));
4451 New_External_Name (Chars (Func_Id),
4452 BIP_Formal_Suffix (BIP_Object_Access));
4455 New_External_Name (Chars (Func_Id),
4456 BIP_Formal_Suffix (BIP_Alloc_Form));
4459 -- A match for BIPaccess => Temp has been found
4461 if Chars (Formal) = Access_Nam
4462 and then Nkind (Actual) /= N_Null
4467 -- A match for BIPalloc => 1 has been found
4469 if Chars (Formal) = Alloc_Nam
4470 and then Nkind (Actual) = N_Integer_Literal
4471 and then Intval (Actual) = Uint_1
4480 return Access_OK and Alloc_OK;
4485 end Initialized_By_Aliased_BIP_Func_Call;
4492 (Trans_Id : Entity_Id;
4493 First_Stmt : Node_Id) return Boolean
4495 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
4496 -- Given an object renaming declaration, retrieve the entity of the
4497 -- renamed name. Return Empty if the renamed name is anything other
4498 -- than a variable or a constant.
4500 -------------------------
4501 -- Find_Renamed_Object --
4502 -------------------------
4504 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
4505 Ren_Obj : Node_Id := Empty;
4507 function Find_Object (N : Node_Id) return Traverse_Result;
4508 -- Try to detect an object which is either a constant or a
4515 function Find_Object (N : Node_Id) return Traverse_Result is
4517 -- Stop the search once a constant or a variable has been
4520 if Nkind (N) = N_Identifier
4521 and then Present (Entity (N))
4522 and then Ekind_In (Entity (N), E_Constant, E_Variable)
4524 Ren_Obj := Entity (N);
4531 procedure Search is new Traverse_Proc (Find_Object);
4535 Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));
4537 -- Start of processing for Find_Renamed_Object
4540 -- Actions related to dispatching calls may appear as renamings of
4541 -- tags. Do not process this type of renaming because it does not
4542 -- use the actual value of the object.
4544 if not Is_RTE (Typ, RE_Tag_Ptr) then
4545 Search (Name (Ren_Decl));
4549 end Find_Renamed_Object;
4554 Ren_Obj : Entity_Id;
4557 -- Start of processing for Is_Aliased
4561 while Present (Stmt) loop
4562 if Nkind (Stmt) = N_Object_Declaration then
4563 Expr := Expression (Stmt);
4566 and then Nkind (Expr) = N_Reference
4567 and then Nkind (Prefix (Expr)) = N_Identifier
4568 and then Entity (Prefix (Expr)) = Trans_Id
4573 elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
4574 Ren_Obj := Find_Renamed_Object (Stmt);
4576 if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
4591 function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
4592 Expr : constant Node_Id := Expression (Parent (Trans_Id));
4595 Is_Access_Type (Etype (Trans_Id))
4596 and then Present (Expr)
4597 and then Nkind (Expr) = N_Allocator;
4600 ---------------------------
4601 -- Is_Iterated_Container --
4602 ---------------------------
4604 function Is_Iterated_Container
4605 (Trans_Id : Entity_Id;
4606 First_Stmt : Node_Id) return Boolean
4616 -- It is not possible to iterate over containers in non-Ada 2012 code
4618 if Ada_Version < Ada_2012 then
4622 Typ := Etype (Trans_Id);
4624 -- Handle access type created for secondary stack use
4626 if Is_Access_Type (Typ) then
4627 Typ := Designated_Type (Typ);
4630 -- Look for aspect Default_Iterator. It may be part of a type
4631 -- declaration for a container, or inherited from a base type
4634 Aspect := Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator);
4636 if Present (Aspect) then
4637 Iter := Entity (Aspect);
4639 -- Examine the statements following the container object and
4640 -- look for a call to the default iterate routine where the
4641 -- first parameter is the transient. Such a call appears as:
4643 -- It : Access_To_CW_Iterator :=
4644 -- Iterate (Tran_Id.all, ...)'reference;
4647 while Present (Stmt) loop
4649 -- Detect an object declaration which is initialized by a
4650 -- secondary stack function call.
4652 if Nkind (Stmt) = N_Object_Declaration
4653 and then Present (Expression (Stmt))
4654 and then Nkind (Expression (Stmt)) = N_Reference
4655 and then Nkind (Prefix (Expression (Stmt))) =
4658 Call := Prefix (Expression (Stmt));
4660 -- The call must invoke the default iterate routine of
4661 -- the container and the transient object must appear as
4662 -- the first actual parameter. Skip any calls whose names
4663 -- are not entities.
4665 if Is_Entity_Name (Name (Call))
4666 and then Entity (Name (Call)) = Iter
4667 and then Present (Parameter_Associations (Call))
4669 Param := First (Parameter_Associations (Call));
4671 if Nkind (Param) = N_Explicit_Dereference
4672 and then Entity (Prefix (Param)) = Trans_Id
4684 end Is_Iterated_Container;
4686 -- Start of processing for Is_Finalizable_Transient
4689 -- Handle access types
4691 if Is_Access_Type (Desig) then
4692 Desig := Available_View (Designated_Type (Desig));
4696 Ekind_In (Obj_Id, E_Constant, E_Variable)
4697 and then Needs_Finalization (Desig)
4698 and then Requires_Transient_Scope (Desig)
4699 and then Nkind (Rel_Node) /= N_Simple_Return_Statement
4701 -- Do not consider renamed or 'reference-d transient objects because
4702 -- the act of renaming extends the object's lifetime.
4704 and then not Is_Aliased (Obj_Id, Decl)
4706 -- Do not consider transient objects allocated on the heap since
4707 -- they are attached to a finalization master.
4709 and then not Is_Allocated (Obj_Id)
4711 -- If the transient object is a pointer, check that it is not
4712 -- initialized by a function which returns a pointer or acts as a
4713 -- renaming of another pointer.
4716 (not Is_Access_Type (Obj_Typ)
4717 or else not Initialized_By_Access (Obj_Id))
4719 -- Do not consider transient objects which act as indirect aliases
4720 -- of build-in-place function results.
4722 and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
4724 -- Do not consider conversions of tags to class-wide types
4726 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
4728 -- Do not consider containers in the context of iterator loops. Such
4729 -- transient objects must exist for as long as the loop is around,
4730 -- otherwise any operation carried out by the iterator will fail.
4732 and then not Is_Iterated_Container (Obj_Id, Decl);
4733 end Is_Finalizable_Transient;
4735 ---------------------------------
4736 -- Is_Fully_Repped_Tagged_Type --
4737 ---------------------------------
4739 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
4740 U : constant Entity_Id := Underlying_Type (T);
4744 if No (U) or else not Is_Tagged_Type (U) then
4746 elsif Has_Discriminants (U) then
4748 elsif not Has_Specified_Layout (U) then
4752 -- Here we have a tagged type, see if it has any unlayed out fields
4753 -- other than a possible tag and parent fields. If so, we return False.
4755 Comp := First_Component (U);
4756 while Present (Comp) loop
4757 if not Is_Tag (Comp)
4758 and then Chars (Comp) /= Name_uParent
4759 and then No (Component_Clause (Comp))
4763 Next_Component (Comp);
4767 -- All components are layed out
4770 end Is_Fully_Repped_Tagged_Type;
4772 ----------------------------------
4773 -- Is_Library_Level_Tagged_Type --
4774 ----------------------------------
4776 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
4778 return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ);
4779 end Is_Library_Level_Tagged_Type;
4781 --------------------------
4782 -- Is_Non_BIP_Func_Call --
4783 --------------------------
4785 function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
4787 -- The expected call is of the format
4789 -- Func_Call'reference
4792 Nkind (Expr) = N_Reference
4793 and then Nkind (Prefix (Expr)) = N_Function_Call
4794 and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
4795 end Is_Non_BIP_Func_Call;
4797 ------------------------------------
4798 -- Is_Object_Access_BIP_Func_Call --
4799 ------------------------------------
4801 function Is_Object_Access_BIP_Func_Call
4803 Obj_Id : Entity_Id) return Boolean
4805 Access_Nam : Name_Id := No_Name;
4812 -- Build-in-place calls usually appear in 'reference format. Note that
4813 -- the accessibility check machinery may add an extra 'reference due to
4814 -- side effect removal.
4817 while Nkind (Call) = N_Reference loop
4818 Call := Prefix (Call);
4821 if Nkind_In (Call, N_Qualified_Expression,
4822 N_Unchecked_Type_Conversion)
4824 Call := Expression (Call);
4827 if Is_Build_In_Place_Function_Call (Call) then
4829 -- Examine all parameter associations of the function call
4831 Param := First (Parameter_Associations (Call));
4832 while Present (Param) loop
4833 if Nkind (Param) = N_Parameter_Association
4834 and then Nkind (Selector_Name (Param)) = N_Identifier
4836 Formal := Selector_Name (Param);
4837 Actual := Explicit_Actual_Parameter (Param);
4839 -- Construct the name of formal BIPaccess. It is much easier to
4840 -- extract the name of the function using an arbitrary formal's
4841 -- scope rather than the Name field of Call.
4843 if Access_Nam = No_Name and then Present (Entity (Formal)) then
4846 (Chars (Scope (Entity (Formal))),
4847 BIP_Formal_Suffix (BIP_Object_Access));
4850 -- A match for BIPaccess => Obj_Id'Unrestricted_Access has been
4853 if Chars (Formal) = Access_Nam
4854 and then Nkind (Actual) = N_Attribute_Reference
4855 and then Attribute_Name (Actual) = Name_Unrestricted_Access
4856 and then Nkind (Prefix (Actual)) = N_Identifier
4857 and then Entity (Prefix (Actual)) = Obj_Id
4868 end Is_Object_Access_BIP_Func_Call;
4870 ----------------------------------
4871 -- Is_Possibly_Unaligned_Object --
4872 ----------------------------------
4874 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
4875 T : constant Entity_Id := Etype (N);
4878 -- If renamed object, apply test to underlying object
4880 if Is_Entity_Name (N)
4881 and then Is_Object (Entity (N))
4882 and then Present (Renamed_Object (Entity (N)))
4884 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
4887 -- Tagged and controlled types and aliased types are always aligned, as
4888 -- are concurrent types.
4891 or else Has_Controlled_Component (T)
4892 or else Is_Concurrent_Type (T)
4893 or else Is_Tagged_Type (T)
4894 or else Is_Controlled (T)
4899 -- If this is an element of a packed array, may be unaligned
4901 if Is_Ref_To_Bit_Packed_Array (N) then
4905 -- Case of indexed component reference: test whether prefix is unaligned
4907 if Nkind (N) = N_Indexed_Component then
4908 return Is_Possibly_Unaligned_Object (Prefix (N));
4910 -- Case of selected component reference
4912 elsif Nkind (N) = N_Selected_Component then
4914 P : constant Node_Id := Prefix (N);
4915 C : constant Entity_Id := Entity (Selector_Name (N));
4920 -- If component reference is for an array with non-static bounds,
4921 -- then it is always aligned: we can only process unaligned arrays
4922 -- with static bounds (more precisely compile time known bounds).
4924 if Is_Array_Type (T)
4925 and then not Compile_Time_Known_Bounds (T)
4930 -- If component is aliased, it is definitely properly aligned
4932 if Is_Aliased (C) then
4936 -- If component is for a type implemented as a scalar, and the
4937 -- record is packed, and the component is other than the first
4938 -- component of the record, then the component may be unaligned.
4940 if Is_Packed (Etype (P))
4941 and then Represented_As_Scalar (Etype (C))
4942 and then First_Entity (Scope (C)) /= C
4947 -- Compute maximum possible alignment for T
4949 -- If alignment is known, then that settles things
4951 if Known_Alignment (T) then
4952 M := UI_To_Int (Alignment (T));
4954 -- If alignment is not known, tentatively set max alignment
4957 M := Ttypes.Maximum_Alignment;
4959 -- We can reduce this if the Esize is known since the default
4960 -- alignment will never be more than the smallest power of 2
4961 -- that does not exceed this Esize value.
4963 if Known_Esize (T) then
4964 S := UI_To_Int (Esize (T));
4966 while (M / 2) >= S loop
4972 -- The following code is historical, it used to be present but it
4973 -- is too cautious, because the front-end does not know the proper
4974 -- default alignments for the target. Also, if the alignment is
4975 -- not known, the front end can't know in any case. If a copy is
4976 -- needed, the back-end will take care of it. This whole section
4977 -- including this comment can be removed later ???
4979 -- If the component reference is for a record that has a specified
4980 -- alignment, and we either know it is too small, or cannot tell,
4981 -- then the component may be unaligned.
4983 -- What is the following commented out code ???
4985 -- if Known_Alignment (Etype (P))
4986 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
4987 -- and then M > Alignment (Etype (P))
4992 -- Case of component clause present which may specify an
4993 -- unaligned position.
4995 if Present (Component_Clause (C)) then
4997 -- Otherwise we can do a test to make sure that the actual
4998 -- start position in the record, and the length, are both
4999 -- consistent with the required alignment. If not, we know
5000 -- that we are unaligned.
5003 Align_In_Bits : constant Nat := M * System_Storage_Unit;
5005 if Component_Bit_Offset (C) mod Align_In_Bits /= 0
5006 or else Esize (C) mod Align_In_Bits /= 0
5013 -- Otherwise, for a component reference, test prefix
5015 return Is_Possibly_Unaligned_Object (P);
5018 -- If not a component reference, must be aligned
5023 end Is_Possibly_Unaligned_Object;
5025 ---------------------------------
5026 -- Is_Possibly_Unaligned_Slice --
5027 ---------------------------------
5029 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
5031 -- Go to renamed object
5033 if Is_Entity_Name (N)
5034 and then Is_Object (Entity (N))
5035 and then Present (Renamed_Object (Entity (N)))
5037 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
5040 -- The reference must be a slice
5042 if Nkind (N) /= N_Slice then
5046 -- Always assume the worst for a nested record component with a
5047 -- component clause, which gigi/gcc does not appear to handle well.
5048 -- It is not clear why this special test is needed at all ???
5050 if Nkind (Prefix (N)) = N_Selected_Component
5051 and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
5053 Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
5058 -- We only need to worry if the target has strict alignment
5060 if not Target_Strict_Alignment then
5064 -- If it is a slice, then look at the array type being sliced
5067 Sarr : constant Node_Id := Prefix (N);
5068 -- Prefix of the slice, i.e. the array being sliced
5070 Styp : constant Entity_Id := Etype (Prefix (N));
5071 -- Type of the array being sliced
5077 -- The problems arise if the array object that is being sliced
5078 -- is a component of a record or array, and we cannot guarantee
5079 -- the alignment of the array within its containing object.
5081 -- To investigate this, we look at successive prefixes to see
5082 -- if we have a worrisome indexed or selected component.
5086 -- Case of array is part of an indexed component reference
5088 if Nkind (Pref) = N_Indexed_Component then
5089 Ptyp := Etype (Prefix (Pref));
5091 -- The only problematic case is when the array is packed, in
5092 -- which case we really know nothing about the alignment of
5093 -- individual components.
5095 if Is_Bit_Packed_Array (Ptyp) then
5099 -- Case of array is part of a selected component reference
5101 elsif Nkind (Pref) = N_Selected_Component then
5102 Ptyp := Etype (Prefix (Pref));
5104 -- We are definitely in trouble if the record in question
5105 -- has an alignment, and either we know this alignment is
5106 -- inconsistent with the alignment of the slice, or we don't
5107 -- know what the alignment of the slice should be.
5109 if Known_Alignment (Ptyp)
5110 and then (Unknown_Alignment (Styp)
5111 or else Alignment (Styp) > Alignment (Ptyp))
5116 -- We are in potential trouble if the record type is packed.
5117 -- We could special case when we know that the array is the
5118 -- first component, but that's not such a simple case ???
5120 if Is_Packed (Ptyp) then
5124 -- We are in trouble if there is a component clause, and
5125 -- either we do not know the alignment of the slice, or
5126 -- the alignment of the slice is inconsistent with the
5127 -- bit position specified by the component clause.
5130 Field : constant Entity_Id := Entity (Selector_Name (Pref));
5132 if Present (Component_Clause (Field))
5134 (Unknown_Alignment (Styp)
5136 (Component_Bit_Offset (Field) mod
5137 (System_Storage_Unit * Alignment (Styp))) /= 0)
5143 -- For cases other than selected or indexed components we know we
5144 -- are OK, since no issues arise over alignment.
5150 -- We processed an indexed component or selected component
5151 -- reference that looked safe, so keep checking prefixes.
5153 Pref := Prefix (Pref);
5156 end Is_Possibly_Unaligned_Slice;
5158 -------------------------------
5159 -- Is_Related_To_Func_Return --
5160 -------------------------------
5162 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
5163 Expr : constant Node_Id := Related_Expression (Id);
5167 and then Nkind (Expr) = N_Explicit_Dereference
5168 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
5169 end Is_Related_To_Func_Return;
5171 --------------------------------
5172 -- Is_Ref_To_Bit_Packed_Array --
5173 --------------------------------
5175 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
5180 if Is_Entity_Name (N)
5181 and then Is_Object (Entity (N))
5182 and then Present (Renamed_Object (Entity (N)))
5184 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
5187 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
5188 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
5191 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
5194 if Result and then Nkind (N) = N_Indexed_Component then
5195 Expr := First (Expressions (N));
5196 while Present (Expr) loop
5197 Force_Evaluation (Expr);
5207 end Is_Ref_To_Bit_Packed_Array;
5209 --------------------------------
5210 -- Is_Ref_To_Bit_Packed_Slice --
5211 --------------------------------
5213 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
5215 if Nkind (N) = N_Type_Conversion then
5216 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
5218 elsif Is_Entity_Name (N)
5219 and then Is_Object (Entity (N))
5220 and then Present (Renamed_Object (Entity (N)))
5222 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
5224 elsif Nkind (N) = N_Slice
5225 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
5229 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
5230 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
5235 end Is_Ref_To_Bit_Packed_Slice;
5237 -----------------------
5238 -- Is_Renamed_Object --
5239 -----------------------
5241 function Is_Renamed_Object (N : Node_Id) return Boolean is
5242 Pnod : constant Node_Id := Parent (N);
5243 Kind : constant Node_Kind := Nkind (Pnod);
5245 if Kind = N_Object_Renaming_Declaration then
5247 elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
5248 return Is_Renamed_Object (Pnod);
5252 end Is_Renamed_Object;
5254 --------------------------------------
5255 -- Is_Secondary_Stack_BIP_Func_Call --
5256 --------------------------------------
5258 function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
5259 Alloc_Nam : Name_Id := No_Name;
5261 Call : Node_Id := Expr;
5266 -- Build-in-place calls usually appear in 'reference format. Note that
5267 -- the accessibility check machinery may add an extra 'reference due to
5268 -- side effect removal.
5270 while Nkind (Call) = N_Reference loop
5271 Call := Prefix (Call);
5274 if Nkind_In (Call, N_Qualified_Expression,
5275 N_Unchecked_Type_Conversion)
5277 Call := Expression (Call);
5280 if Is_Build_In_Place_Function_Call (Call) then
5282 -- Examine all parameter associations of the function call
5284 Param := First (Parameter_Associations (Call));
5285 while Present (Param) loop
5286 if Nkind (Param) = N_Parameter_Association
5287 and then Nkind (Selector_Name (Param)) = N_Identifier
5289 Formal := Selector_Name (Param);
5290 Actual := Explicit_Actual_Parameter (Param);
5292 -- Construct the name of formal BIPalloc. It is much easier to
5293 -- extract the name of the function using an arbitrary formal's
5294 -- scope rather than the Name field of Call.
5296 if Alloc_Nam = No_Name and then Present (Entity (Formal)) then
5299 (Chars (Scope (Entity (Formal))),
5300 BIP_Formal_Suffix (BIP_Alloc_Form));
5303 -- A match for BIPalloc => 2 has been found
5305 if Chars (Formal) = Alloc_Nam
5306 and then Nkind (Actual) = N_Integer_Literal
5307 and then Intval (Actual) = Uint_2
5318 end Is_Secondary_Stack_BIP_Func_Call;
5320 -------------------------------------
5321 -- Is_Tag_To_Class_Wide_Conversion --
5322 -------------------------------------
5324 function Is_Tag_To_Class_Wide_Conversion
5325 (Obj_Id : Entity_Id) return Boolean
5327 Expr : constant Node_Id := Expression (Parent (Obj_Id));
5331 Is_Class_Wide_Type (Etype (Obj_Id))
5332 and then Present (Expr)
5333 and then Nkind (Expr) = N_Unchecked_Type_Conversion
5334 and then Etype (Expression (Expr)) = RTE (RE_Tag);
5335 end Is_Tag_To_Class_Wide_Conversion;
5337 ----------------------------
5338 -- Is_Untagged_Derivation --
5339 ----------------------------
5341 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
5343 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
5345 (Is_Private_Type (T) and then Present (Full_View (T))
5346 and then not Is_Tagged_Type (Full_View (T))
5347 and then Is_Derived_Type (Full_View (T))
5348 and then Etype (Full_View (T)) /= T);
5349 end Is_Untagged_Derivation;
5351 ---------------------------
5352 -- Is_Volatile_Reference --
5353 ---------------------------
5355 function Is_Volatile_Reference (N : Node_Id) return Boolean is
5357 -- Only source references are to be treated as volatile, internally
5358 -- generated stuff cannot have volatile external effects.
5360 if not Comes_From_Source (N) then
5363 -- Never true for reference to a type
5365 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
5368 -- True if object reference with volatile type
5370 elsif Is_Volatile_Object (N) then
5373 -- True if reference to volatile entity
5375 elsif Is_Entity_Name (N) then
5376 return Treat_As_Volatile (Entity (N));
5378 -- True for slice of volatile array
5380 elsif Nkind (N) = N_Slice then
5381 return Is_Volatile_Reference (Prefix (N));
5383 -- True if volatile component
5385 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
5386 if (Is_Entity_Name (Prefix (N))
5387 and then Has_Volatile_Components (Entity (Prefix (N))))
5388 or else (Present (Etype (Prefix (N)))
5389 and then Has_Volatile_Components (Etype (Prefix (N))))
5393 return Is_Volatile_Reference (Prefix (N));
5401 end Is_Volatile_Reference;
5403 --------------------------
5404 -- Is_VM_By_Copy_Actual --
5405 --------------------------
5407 function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean is
5409 return VM_Target /= No_VM
5410 and then (Nkind (N) = N_Slice
5412 (Nkind (N) = N_Identifier
5413 and then Present (Renamed_Object (Entity (N)))
5414 and then Nkind (Renamed_Object (Entity (N))) =
5416 end Is_VM_By_Copy_Actual;
5418 --------------------
5419 -- Kill_Dead_Code --
5420 --------------------
5422 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
5423 W : Boolean := Warn;
5424 -- Set False if warnings suppressed
5428 Remove_Warning_Messages (N);
5430 -- Generate warning if appropriate
5434 -- We suppress the warning if this code is under control of an
5435 -- if statement, whose condition is a simple identifier, and
5436 -- either we are in an instance, or warnings off is set for this
5437 -- identifier. The reason for killing it in the instance case is
5438 -- that it is common and reasonable for code to be deleted in
5439 -- instances for various reasons.
5441 if Nkind (Parent (N)) = N_If_Statement then
5443 C : constant Node_Id := Condition (Parent (N));
5445 if Nkind (C) = N_Identifier
5448 or else (Present (Entity (C))
5449 and then Has_Warnings_Off (Entity (C))))
5456 -- Generate warning if not suppressed
5460 ("?t?this code can never be executed and has been deleted!",
5465 -- Recurse into block statements and bodies to process declarations
5468 if Nkind (N) = N_Block_Statement
5469 or else Nkind (N) = N_Subprogram_Body
5470 or else Nkind (N) = N_Package_Body
5472 Kill_Dead_Code (Declarations (N), False);
5473 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
5475 if Nkind (N) = N_Subprogram_Body then
5476 Set_Is_Eliminated (Defining_Entity (N));
5479 elsif Nkind (N) = N_Package_Declaration then
5480 Kill_Dead_Code (Visible_Declarations (Specification (N)));
5481 Kill_Dead_Code (Private_Declarations (Specification (N)));
5483 -- ??? After this point, Delete_Tree has been called on all
5484 -- declarations in Specification (N), so references to entities
5485 -- therein look suspicious.
5488 E : Entity_Id := First_Entity (Defining_Entity (N));
5490 while Present (E) loop
5491 if Ekind (E) = E_Operator then
5492 Set_Is_Eliminated (E);
5499 -- Recurse into composite statement to kill individual statements in
5500 -- particular instantiations.
5502 elsif Nkind (N) = N_If_Statement then
5503 Kill_Dead_Code (Then_Statements (N));
5504 Kill_Dead_Code (Elsif_Parts (N));
5505 Kill_Dead_Code (Else_Statements (N));
5507 elsif Nkind (N) = N_Loop_Statement then
5508 Kill_Dead_Code (Statements (N));
5510 elsif Nkind (N) = N_Case_Statement then
5514 Alt := First (Alternatives (N));
5515 while Present (Alt) loop
5516 Kill_Dead_Code (Statements (Alt));
5521 elsif Nkind (N) = N_Case_Statement_Alternative then
5522 Kill_Dead_Code (Statements (N));
5524 -- Deal with dead instances caused by deleting instantiations
5526 elsif Nkind (N) in N_Generic_Instantiation then
5527 Remove_Dead_Instance (N);
5532 -- Case where argument is a list of nodes to be killed
5534 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
5539 if Is_Non_Empty_List (L) then
5541 while Present (N) loop
5542 Kill_Dead_Code (N, W);
5549 ------------------------
5550 -- Known_Non_Negative --
5551 ------------------------
5553 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
5555 if Is_OK_Static_Expression (Opnd) and then Expr_Value (Opnd) >= 0 then
5560 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
5563 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
5566 end Known_Non_Negative;
5568 --------------------
5569 -- Known_Non_Null --
5570 --------------------
5572 function Known_Non_Null (N : Node_Id) return Boolean is
5574 -- Checks for case where N is an entity reference
5576 if Is_Entity_Name (N) and then Present (Entity (N)) then
5578 E : constant Entity_Id := Entity (N);
5583 -- First check if we are in decisive conditional
5585 Get_Current_Value_Condition (N, Op, Val);
5587 if Known_Null (Val) then
5588 if Op = N_Op_Eq then
5590 elsif Op = N_Op_Ne then
5595 -- If OK to do replacement, test Is_Known_Non_Null flag
5597 if OK_To_Do_Constant_Replacement (E) then
5598 return Is_Known_Non_Null (E);
5600 -- Otherwise if not safe to do replacement, then say so
5607 -- True if access attribute
5609 elsif Nkind (N) = N_Attribute_Reference
5610 and then Nam_In (Attribute_Name (N), Name_Access,
5611 Name_Unchecked_Access,
5612 Name_Unrestricted_Access)
5616 -- True if allocator
5618 elsif Nkind (N) = N_Allocator then
5621 -- For a conversion, true if expression is known non-null
5623 elsif Nkind (N) = N_Type_Conversion then
5624 return Known_Non_Null (Expression (N));
5626 -- Above are all cases where the value could be determined to be
5627 -- non-null. In all other cases, we don't know, so return False.
5638 function Known_Null (N : Node_Id) return Boolean is
5640 -- Checks for case where N is an entity reference
5642 if Is_Entity_Name (N) and then Present (Entity (N)) then
5644 E : constant Entity_Id := Entity (N);
5649 -- Constant null value is for sure null
5651 if Ekind (E) = E_Constant
5652 and then Known_Null (Constant_Value (E))
5657 -- First check if we are in decisive conditional
5659 Get_Current_Value_Condition (N, Op, Val);
5661 if Known_Null (Val) then
5662 if Op = N_Op_Eq then
5664 elsif Op = N_Op_Ne then
5669 -- If OK to do replacement, test Is_Known_Null flag
5671 if OK_To_Do_Constant_Replacement (E) then
5672 return Is_Known_Null (E);
5674 -- Otherwise if not safe to do replacement, then say so
5681 -- True if explicit reference to null
5683 elsif Nkind (N) = N_Null then
5686 -- For a conversion, true if expression is known null
5688 elsif Nkind (N) = N_Type_Conversion then
5689 return Known_Null (Expression (N));
5691 -- Above are all cases where the value could be determined to be null.
5692 -- In all other cases, we don't know, so return False.
5699 -----------------------------
5700 -- Make_CW_Equivalent_Type --
5701 -----------------------------
5703 -- Create a record type used as an equivalent of any member of the class
5704 -- which takes its size from exp.
5706 -- Generate the following code:
5708 -- type Equiv_T is record
5709 -- _parent : T (List of discriminant constraints taken from Exp);
5710 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
5713 -- ??? Note that this type does not guarantee same alignment as all
5716 function Make_CW_Equivalent_Type
5718 E : Node_Id) return Entity_Id
5720 Loc : constant Source_Ptr := Sloc (E);
5721 Root_Typ : constant Entity_Id := Root_Type (T);
5722 List_Def : constant List_Id := Empty_List;
5723 Comp_List : constant List_Id := New_List;
5724 Equiv_Type : Entity_Id;
5725 Range_Type : Entity_Id;
5726 Str_Type : Entity_Id;
5727 Constr_Root : Entity_Id;
5731 -- If the root type is already constrained, there are no discriminants
5732 -- in the expression.
5734 if not Has_Discriminants (Root_Typ)
5735 or else Is_Constrained (Root_Typ)
5737 Constr_Root := Root_Typ;
5739 Constr_Root := Make_Temporary (Loc, 'R');
5741 -- subtype cstr__n is T (List of discr constraints taken from Exp)
5743 Append_To (List_Def,
5744 Make_Subtype_Declaration (Loc,
5745 Defining_Identifier => Constr_Root,
5746 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
5749 -- Generate the range subtype declaration
5751 Range_Type := Make_Temporary (Loc, 'G');
5753 if not Is_Interface (Root_Typ) then
5755 -- subtype rg__xx is
5756 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
5759 Make_Op_Subtract (Loc,
5761 Make_Attribute_Reference (Loc,
5763 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
5764 Attribute_Name => Name_Size),
5766 Make_Attribute_Reference (Loc,
5767 Prefix => New_Occurrence_Of (Constr_Root, Loc),
5768 Attribute_Name => Name_Object_Size));
5770 -- subtype rg__xx is
5771 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
5774 Make_Attribute_Reference (Loc,
5776 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
5777 Attribute_Name => Name_Size);
5780 Set_Paren_Count (Sizexpr, 1);
5782 Append_To (List_Def,
5783 Make_Subtype_Declaration (Loc,
5784 Defining_Identifier => Range_Type,
5785 Subtype_Indication =>
5786 Make_Subtype_Indication (Loc,
5787 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
5788 Constraint => Make_Range_Constraint (Loc,
5791 Low_Bound => Make_Integer_Literal (Loc, 1),
5793 Make_Op_Divide (Loc,
5794 Left_Opnd => Sizexpr,
5795 Right_Opnd => Make_Integer_Literal (Loc,
5796 Intval => System_Storage_Unit)))))));
5798 -- subtype str__nn is Storage_Array (rg__x);
5800 Str_Type := Make_Temporary (Loc, 'S');
5801 Append_To (List_Def,
5802 Make_Subtype_Declaration (Loc,
5803 Defining_Identifier => Str_Type,
5804 Subtype_Indication =>
5805 Make_Subtype_Indication (Loc,
5806 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
5808 Make_Index_Or_Discriminant_Constraint (Loc,
5810 New_List (New_Occurrence_Of (Range_Type, Loc))))));
5812 -- type Equiv_T is record
5813 -- [ _parent : Tnn; ]
5817 Equiv_Type := Make_Temporary (Loc, 'T');
5818 Set_Ekind (Equiv_Type, E_Record_Type);
5819 Set_Parent_Subtype (Equiv_Type, Constr_Root);
5821 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
5822 -- treatment for this type. In particular, even though _parent's type
5823 -- is a controlled type or contains controlled components, we do not
5824 -- want to set Has_Controlled_Component on it to avoid making it gain
5825 -- an unwanted _controller component.
5827 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
5829 if not Is_Interface (Root_Typ) then
5830 Append_To (Comp_List,
5831 Make_Component_Declaration (Loc,
5832 Defining_Identifier =>
5833 Make_Defining_Identifier (Loc, Name_uParent),
5834 Component_Definition =>
5835 Make_Component_Definition (Loc,
5836 Aliased_Present => False,
5837 Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc))));
5840 Append_To (Comp_List,
5841 Make_Component_Declaration (Loc,
5842 Defining_Identifier => Make_Temporary (Loc, 'C'),
5843 Component_Definition =>
5844 Make_Component_Definition (Loc,
5845 Aliased_Present => False,
5846 Subtype_Indication => New_Occurrence_Of (Str_Type, Loc))));
5848 Append_To (List_Def,
5849 Make_Full_Type_Declaration (Loc,
5850 Defining_Identifier => Equiv_Type,
5852 Make_Record_Definition (Loc,
5854 Make_Component_List (Loc,
5855 Component_Items => Comp_List,
5856 Variant_Part => Empty))));
5858 -- Suppress all checks during the analysis of the expanded code to avoid
5859 -- the generation of spurious warnings under ZFP run-time.
5861 Insert_Actions (E, List_Def, Suppress => All_Checks);
5863 end Make_CW_Equivalent_Type;
5865 -------------------------
5866 -- Make_Invariant_Call --
5867 -------------------------
5869 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
5870 Loc : constant Source_Ptr := Sloc (Expr);
5874 Typ := Etype (Expr);
5876 -- Subtypes may be subject to invariants coming from their respective
5877 -- base types. The subtype may be fully or partially private.
5879 if Ekind_In (Typ, E_Array_Subtype,
5882 E_Record_Subtype_With_Private)
5884 Typ := Base_Type (Typ);
5888 (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
5891 Make_Procedure_Call_Statement (Loc,
5893 New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
5894 Parameter_Associations => New_List (Relocate_Node (Expr)));
5895 end Make_Invariant_Call;
5897 ------------------------
5898 -- Make_Literal_Range --
5899 ------------------------
5901 function Make_Literal_Range
5903 Literal_Typ : Entity_Id) return Node_Id
5905 Lo : constant Node_Id :=
5906 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
5907 Index : constant Entity_Id := Etype (Lo);
5910 Length_Expr : constant Node_Id :=
5911 Make_Op_Subtract (Loc,
5913 Make_Integer_Literal (Loc,
5914 Intval => String_Literal_Length (Literal_Typ)),
5916 Make_Integer_Literal (Loc, 1));
5919 Set_Analyzed (Lo, False);
5921 if Is_Integer_Type (Index) then
5924 Left_Opnd => New_Copy_Tree (Lo),
5925 Right_Opnd => Length_Expr);
5928 Make_Attribute_Reference (Loc,
5929 Attribute_Name => Name_Val,
5930 Prefix => New_Occurrence_Of (Index, Loc),
5931 Expressions => New_List (
5934 Make_Attribute_Reference (Loc,
5935 Attribute_Name => Name_Pos,
5936 Prefix => New_Occurrence_Of (Index, Loc),
5937 Expressions => New_List (New_Copy_Tree (Lo))),
5938 Right_Opnd => Length_Expr)));
5945 end Make_Literal_Range;
5947 --------------------------
5948 -- Make_Non_Empty_Check --
5949 --------------------------
5951 function Make_Non_Empty_Check
5953 N : Node_Id) return Node_Id
5959 Make_Attribute_Reference (Loc,
5960 Attribute_Name => Name_Length,
5961 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
5963 Make_Integer_Literal (Loc, 0));
5964 end Make_Non_Empty_Check;
5966 -------------------------
5967 -- Make_Predicate_Call --
5968 -------------------------
5970 function Make_Predicate_Call
5973 Mem : Boolean := False) return Node_Id
5975 Loc : constant Source_Ptr := Sloc (Expr);
5978 pragma Assert (Present (Predicate_Function (Typ)));
5980 -- Call special membership version if requested and available
5984 PFM : constant Entity_Id := Predicate_Function_M (Typ);
5986 if Present (PFM) then
5988 Make_Function_Call (Loc,
5989 Name => New_Occurrence_Of (PFM, Loc),
5990 Parameter_Associations => New_List (Relocate_Node (Expr)));
5995 -- Case of calling normal predicate function
5998 Make_Function_Call (Loc,
6000 New_Occurrence_Of (Predicate_Function (Typ), Loc),
6001 Parameter_Associations => New_List (Relocate_Node (Expr)));
6002 end Make_Predicate_Call;
6004 --------------------------
6005 -- Make_Predicate_Check --
6006 --------------------------
6008 function Make_Predicate_Check
6010 Expr : Node_Id) return Node_Id
6012 Loc : constant Source_Ptr := Sloc (Expr);
6016 -- If predicate checks are suppressed, then return a null statement.
6017 -- For this call, we check only the scope setting. If the caller wants
6018 -- to check a specific entity's setting, they must do it manually.
6020 if Predicate_Checks_Suppressed (Empty) then
6021 return Make_Null_Statement (Loc);
6024 -- Do not generate a check within an internal subprogram (stream
6025 -- functions and the like, including including predicate functions).
6027 if Within_Internal_Subprogram then
6028 return Make_Null_Statement (Loc);
6031 -- Compute proper name to use, we need to get this right so that the
6032 -- right set of check policies apply to the Check pragma we are making.
6034 if Has_Dynamic_Predicate_Aspect (Typ) then
6035 Nam := Name_Dynamic_Predicate;
6036 elsif Has_Static_Predicate_Aspect (Typ) then
6037 Nam := Name_Static_Predicate;
6039 Nam := Name_Predicate;
6044 Pragma_Identifier => Make_Identifier (Loc, Name_Check),
6045 Pragma_Argument_Associations => New_List (
6046 Make_Pragma_Argument_Association (Loc,
6047 Expression => Make_Identifier (Loc, Nam)),
6048 Make_Pragma_Argument_Association (Loc,
6049 Expression => Make_Predicate_Call (Typ, Expr))));
6050 end Make_Predicate_Check;
6052 ----------------------------
6053 -- Make_Subtype_From_Expr --
6054 ----------------------------
6056 -- 1. If Expr is an unconstrained array expression, creates
6057 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
6059 -- 2. If Expr is a unconstrained discriminated type expression, creates
6060 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
6062 -- 3. If Expr is class-wide, creates an implicit class wide subtype
6064 function Make_Subtype_From_Expr
6066 Unc_Typ : Entity_Id) return Node_Id
6068 Loc : constant Source_Ptr := Sloc (E);
6069 List_Constr : constant List_Id := New_List;
6072 Full_Subtyp : Entity_Id;
6073 Priv_Subtyp : Entity_Id;
6078 if Is_Private_Type (Unc_Typ)
6079 and then Has_Unknown_Discriminants (Unc_Typ)
6081 -- Prepare the subtype completion, Go to base type to
6082 -- find underlying type, because the type may be a generic
6083 -- actual or an explicit subtype.
6085 Utyp := Underlying_Type (Base_Type (Unc_Typ));
6086 Full_Subtyp := Make_Temporary (Loc, 'C');
6088 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
6089 Set_Parent (Full_Exp, Parent (E));
6091 Priv_Subtyp := Make_Temporary (Loc, 'P');
6094 Make_Subtype_Declaration (Loc,
6095 Defining_Identifier => Full_Subtyp,
6096 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
6098 -- Define the dummy private subtype
6100 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
6101 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
6102 Set_Scope (Priv_Subtyp, Full_Subtyp);
6103 Set_Is_Constrained (Priv_Subtyp);
6104 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
6105 Set_Is_Itype (Priv_Subtyp);
6106 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
6108 if Is_Tagged_Type (Priv_Subtyp) then
6110 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
6111 Set_Direct_Primitive_Operations (Priv_Subtyp,
6112 Direct_Primitive_Operations (Unc_Typ));
6115 Set_Full_View (Priv_Subtyp, Full_Subtyp);
6117 return New_Occurrence_Of (Priv_Subtyp, Loc);
6119 elsif Is_Array_Type (Unc_Typ) then
6120 for J in 1 .. Number_Dimensions (Unc_Typ) loop
6121 Append_To (List_Constr,
6124 Make_Attribute_Reference (Loc,
6125 Prefix => Duplicate_Subexpr_No_Checks (E),
6126 Attribute_Name => Name_First,
6127 Expressions => New_List (
6128 Make_Integer_Literal (Loc, J))),
6131 Make_Attribute_Reference (Loc,
6132 Prefix => Duplicate_Subexpr_No_Checks (E),
6133 Attribute_Name => Name_Last,
6134 Expressions => New_List (
6135 Make_Integer_Literal (Loc, J)))));
6138 elsif Is_Class_Wide_Type (Unc_Typ) then
6140 CW_Subtype : Entity_Id;
6141 EQ_Typ : Entity_Id := Empty;
6144 -- A class-wide equivalent type is not needed when VM_Target
6145 -- because the VM back-ends handle the class-wide object
6146 -- initialization itself (and doesn't need or want the
6147 -- additional intermediate type to handle the assignment).
6149 if Expander_Active and then Tagged_Type_Expansion then
6151 -- If this is the class_wide type of a completion that is a
6152 -- record subtype, set the type of the class_wide type to be
6153 -- the full base type, for use in the expanded code for the
6154 -- equivalent type. Should this be done earlier when the
6155 -- completion is analyzed ???
6157 if Is_Private_Type (Etype (Unc_Typ))
6159 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
6161 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
6164 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
6167 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
6168 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
6169 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
6171 return New_Occurrence_Of (CW_Subtype, Loc);
6174 -- Indefinite record type with discriminants
6177 D := First_Discriminant (Unc_Typ);
6178 while Present (D) loop
6179 Append_To (List_Constr,
6180 Make_Selected_Component (Loc,
6181 Prefix => Duplicate_Subexpr_No_Checks (E),
6182 Selector_Name => New_Occurrence_Of (D, Loc)));
6184 Next_Discriminant (D);
6189 Make_Subtype_Indication (Loc,
6190 Subtype_Mark => New_Occurrence_Of (Unc_Typ, Loc),
6192 Make_Index_Or_Discriminant_Constraint (Loc,
6193 Constraints => List_Constr));
6194 end Make_Subtype_From_Expr;
6196 ----------------------------
6197 -- Matching_Standard_Type --
6198 ----------------------------
6200 function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is
6201 pragma Assert (Is_Scalar_Type (Typ));
6202 Siz : constant Uint := Esize (Typ);
6205 -- Floating-point cases
6207 if Is_Floating_Point_Type (Typ) then
6208 if Siz <= Esize (Standard_Short_Float) then
6209 return Standard_Short_Float;
6210 elsif Siz <= Esize (Standard_Float) then
6211 return Standard_Float;
6212 elsif Siz <= Esize (Standard_Long_Float) then
6213 return Standard_Long_Float;
6214 elsif Siz <= Esize (Standard_Long_Long_Float) then
6215 return Standard_Long_Long_Float;
6217 raise Program_Error;
6220 -- Integer cases (includes fixed-point types)
6222 -- Unsigned integer cases (includes normal enumeration types)
6224 elsif Is_Unsigned_Type (Typ) then
6225 if Siz <= Esize (Standard_Short_Short_Unsigned) then
6226 return Standard_Short_Short_Unsigned;
6227 elsif Siz <= Esize (Standard_Short_Unsigned) then
6228 return Standard_Short_Unsigned;
6229 elsif Siz <= Esize (Standard_Unsigned) then
6230 return Standard_Unsigned;
6231 elsif Siz <= Esize (Standard_Long_Unsigned) then
6232 return Standard_Long_Unsigned;
6233 elsif Siz <= Esize (Standard_Long_Long_Unsigned) then
6234 return Standard_Long_Long_Unsigned;
6236 raise Program_Error;
6239 -- Signed integer cases
6242 if Siz <= Esize (Standard_Short_Short_Integer) then
6243 return Standard_Short_Short_Integer;
6244 elsif Siz <= Esize (Standard_Short_Integer) then
6245 return Standard_Short_Integer;
6246 elsif Siz <= Esize (Standard_Integer) then
6247 return Standard_Integer;
6248 elsif Siz <= Esize (Standard_Long_Integer) then
6249 return Standard_Long_Integer;
6250 elsif Siz <= Esize (Standard_Long_Long_Integer) then
6251 return Standard_Long_Long_Integer;
6253 raise Program_Error;
6256 end Matching_Standard_Type;
6258 -----------------------------
6259 -- May_Generate_Large_Temp --
6260 -----------------------------
6262 -- At the current time, the only types that we return False for (i.e. where
6263 -- we decide we know they cannot generate large temps) are ones where we
6264 -- know the size is 256 bits or less at compile time, and we are still not
6265 -- doing a thorough job on arrays and records ???
6267 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
6269 if not Size_Known_At_Compile_Time (Typ) then
6272 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
6275 elsif Is_Array_Type (Typ) and then Present (Packed_Array_Type (Typ)) then
6276 return May_Generate_Large_Temp (Packed_Array_Type (Typ));
6278 -- We could do more here to find other small types ???
6283 end May_Generate_Large_Temp;
6285 ------------------------
6286 -- Needs_Finalization --
6287 ------------------------
6289 function Needs_Finalization (T : Entity_Id) return Boolean is
6290 function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
6291 -- If type is not frozen yet, check explicitly among its components,
6292 -- because the Has_Controlled_Component flag is not necessarily set.
6294 -----------------------------------
6295 -- Has_Some_Controlled_Component --
6296 -----------------------------------
6298 function Has_Some_Controlled_Component
6299 (Rec : Entity_Id) return Boolean
6304 if Has_Controlled_Component (Rec) then
6307 elsif not Is_Frozen (Rec) then
6308 if Is_Record_Type (Rec) then
6309 Comp := First_Entity (Rec);
6311 while Present (Comp) loop
6312 if not Is_Type (Comp)
6313 and then Needs_Finalization (Etype (Comp))
6323 elsif Is_Array_Type (Rec) then
6324 return Needs_Finalization (Component_Type (Rec));
6327 return Has_Controlled_Component (Rec);
6332 end Has_Some_Controlled_Component;
6334 -- Start of processing for Needs_Finalization
6337 -- Certain run-time configurations and targets do not provide support
6338 -- for controlled types.
6340 if Restriction_Active (No_Finalization) then
6343 -- C, C++, CIL and Java types are not considered controlled. It is
6344 -- assumed that the non-Ada side will handle their clean up.
6346 elsif Convention (T) = Convention_C
6347 or else Convention (T) = Convention_CIL
6348 or else Convention (T) = Convention_CPP
6349 or else Convention (T) = Convention_Java
6354 -- Class-wide types are treated as controlled because derivations
6355 -- from the root type can introduce controlled components.
6358 Is_Class_Wide_Type (T)
6359 or else Is_Controlled (T)
6360 or else Has_Controlled_Component (T)
6361 or else Has_Some_Controlled_Component (T)
6363 (Is_Concurrent_Type (T)
6364 and then Present (Corresponding_Record_Type (T))
6365 and then Needs_Finalization (Corresponding_Record_Type (T)));
6367 end Needs_Finalization;
6369 ----------------------------
6370 -- Needs_Constant_Address --
6371 ----------------------------
6373 function Needs_Constant_Address
6375 Typ : Entity_Id) return Boolean
6379 -- If we have no initialization of any kind, then we don't need to place
6380 -- any restrictions on the address clause, because the object will be
6381 -- elaborated after the address clause is evaluated. This happens if the
6382 -- declaration has no initial expression, or the type has no implicit
6383 -- initialization, or the object is imported.
6385 -- The same holds for all initialized scalar types and all access types.
6386 -- Packed bit arrays of size up to 64 are represented using a modular
6387 -- type with an initialization (to zero) and can be processed like other
6388 -- initialized scalar types.
6390 -- If the type is controlled, code to attach the object to a
6391 -- finalization chain is generated at the point of declaration, and
6392 -- therefore the elaboration of the object cannot be delayed: the
6393 -- address expression must be a constant.
6395 if No (Expression (Decl))
6396 and then not Needs_Finalization (Typ)
6398 (not Has_Non_Null_Base_Init_Proc (Typ)
6399 or else Is_Imported (Defining_Identifier (Decl)))
6403 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
6404 or else Is_Access_Type (Typ)
6406 (Is_Bit_Packed_Array (Typ)
6407 and then Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
6413 -- Otherwise, we require the address clause to be constant because
6414 -- the call to the initialization procedure (or the attach code) has
6415 -- to happen at the point of the declaration.
6417 -- Actually the IP call has been moved to the freeze actions anyway,
6418 -- so maybe we can relax this restriction???
6422 end Needs_Constant_Address;
6424 ----------------------------
6425 -- New_Class_Wide_Subtype --
6426 ----------------------------
6428 function New_Class_Wide_Subtype
6429 (CW_Typ : Entity_Id;
6430 N : Node_Id) return Entity_Id
6432 Res : constant Entity_Id := Create_Itype (E_Void, N);
6433 Res_Name : constant Name_Id := Chars (Res);
6434 Res_Scope : constant Entity_Id := Scope (Res);
6437 Copy_Node (CW_Typ, Res);
6438 Set_Comes_From_Source (Res, False);
6439 Set_Sloc (Res, Sloc (N));
6441 Set_Associated_Node_For_Itype (Res, N);
6442 Set_Is_Public (Res, False); -- By default, may be changed below.
6443 Set_Public_Status (Res);
6444 Set_Chars (Res, Res_Name);
6445 Set_Scope (Res, Res_Scope);
6446 Set_Ekind (Res, E_Class_Wide_Subtype);
6447 Set_Next_Entity (Res, Empty);
6448 Set_Etype (Res, Base_Type (CW_Typ));
6449 Set_Is_Frozen (Res, False);
6450 Set_Freeze_Node (Res, Empty);
6452 end New_Class_Wide_Subtype;
6454 --------------------------------
6455 -- Non_Limited_Designated_Type --
6456 ---------------------------------
6458 function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
6459 Desig : constant Entity_Id := Designated_Type (T);
6461 if Ekind (Desig) = E_Incomplete_Type
6462 and then Present (Non_Limited_View (Desig))
6464 return Non_Limited_View (Desig);
6468 end Non_Limited_Designated_Type;
6470 -----------------------------------
6471 -- OK_To_Do_Constant_Replacement --
6472 -----------------------------------
6474 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
6475 ES : constant Entity_Id := Scope (E);
6479 -- Do not replace statically allocated objects, because they may be
6480 -- modified outside the current scope.
6482 if Is_Statically_Allocated (E) then
6485 -- Do not replace aliased or volatile objects, since we don't know what
6486 -- else might change the value.
6488 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
6491 -- Debug flag -gnatdM disconnects this optimization
6493 elsif Debug_Flag_MM then
6496 -- Otherwise check scopes
6499 CS := Current_Scope;
6502 -- If we are in right scope, replacement is safe
6507 -- Packages do not affect the determination of safety
6509 elsif Ekind (CS) = E_Package then
6510 exit when CS = Standard_Standard;
6513 -- Blocks do not affect the determination of safety
6515 elsif Ekind (CS) = E_Block then
6518 -- Loops do not affect the determination of safety. Note that we
6519 -- kill all current values on entry to a loop, so we are just
6520 -- talking about processing within a loop here.
6522 elsif Ekind (CS) = E_Loop then
6525 -- Otherwise, the reference is dubious, and we cannot be sure that
6526 -- it is safe to do the replacement.
6535 end OK_To_Do_Constant_Replacement;
6537 ------------------------------------
6538 -- Possible_Bit_Aligned_Component --
6539 ------------------------------------
6541 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
6545 -- Case of indexed component
6547 when N_Indexed_Component =>
6549 P : constant Node_Id := Prefix (N);
6550 Ptyp : constant Entity_Id := Etype (P);
6553 -- If we know the component size and it is less than 64, then
6554 -- we are definitely OK. The back end always does assignment of
6555 -- misaligned small objects correctly.
6557 if Known_Static_Component_Size (Ptyp)
6558 and then Component_Size (Ptyp) <= 64
6562 -- Otherwise, we need to test the prefix, to see if we are
6563 -- indexing from a possibly unaligned component.
6566 return Possible_Bit_Aligned_Component (P);
6570 -- Case of selected component
6572 when N_Selected_Component =>
6574 P : constant Node_Id := Prefix (N);
6575 Comp : constant Entity_Id := Entity (Selector_Name (N));
6578 -- If there is no component clause, then we are in the clear
6579 -- since the back end will never misalign a large component
6580 -- unless it is forced to do so. In the clear means we need
6581 -- only the recursive test on the prefix.
6583 if Component_May_Be_Bit_Aligned (Comp) then
6586 return Possible_Bit_Aligned_Component (P);
6590 -- For a slice, test the prefix, if that is possibly misaligned,
6591 -- then for sure the slice is.
6594 return Possible_Bit_Aligned_Component (Prefix (N));
6596 -- For an unchecked conversion, check whether the expression may
6599 when N_Unchecked_Type_Conversion =>
6600 return Possible_Bit_Aligned_Component (Expression (N));
6602 -- If we have none of the above, it means that we have fallen off the
6603 -- top testing prefixes recursively, and we now have a stand alone
6604 -- object, where we don't have a problem.
6610 end Possible_Bit_Aligned_Component;
6612 -----------------------------------------------
6613 -- Process_Statements_For_Controlled_Objects --
6614 -----------------------------------------------
6616 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
6617 Loc : constant Source_Ptr := Sloc (N);
6619 function Are_Wrapped (L : List_Id) return Boolean;
6620 -- Determine whether list L contains only one statement which is a block
6622 function Wrap_Statements_In_Block
6624 Scop : Entity_Id := Current_Scope) return Node_Id;
6625 -- Given a list of statements L, wrap it in a block statement and return
6626 -- the generated node. Scop is either the current scope or the scope of
6627 -- the context (if applicable).
6633 function Are_Wrapped (L : List_Id) return Boolean is
6634 Stmt : constant Node_Id := First (L);
6638 and then No (Next (Stmt))
6639 and then Nkind (Stmt) = N_Block_Statement;
6642 ------------------------------
6643 -- Wrap_Statements_In_Block --
6644 ------------------------------
6646 function Wrap_Statements_In_Block
6648 Scop : Entity_Id := Current_Scope) return Node_Id
6650 Block_Id : Entity_Id;
6651 Block_Nod : Node_Id;
6652 Iter_Loop : Entity_Id;
6656 Make_Block_Statement (Loc,
6657 Declarations => No_List,
6658 Handled_Statement_Sequence =>
6659 Make_Handled_Sequence_Of_Statements (Loc,
6662 -- Create a label for the block in case the block needs to manage the
6663 -- secondary stack. A label allows for flag Uses_Sec_Stack to be set.
6665 Add_Block_Identifier (Block_Nod, Block_Id);
6667 -- When wrapping the statements of an iterator loop, check whether
6668 -- the loop requires secondary stack management and if so, propagate
6669 -- the flag to the block. This way the secondary stack is marked and
6670 -- released at each iteration of the loop.
6672 Iter_Loop := Find_Enclosing_Iterator_Loop (Scop);
6674 if Present (Iter_Loop) and then Uses_Sec_Stack (Iter_Loop) then
6675 Set_Uses_Sec_Stack (Block_Id);
6679 end Wrap_Statements_In_Block;
6685 -- Start of processing for Process_Statements_For_Controlled_Objects
6688 -- Whenever a non-handled statement list is wrapped in a block, the
6689 -- block must be explicitly analyzed to redecorate all entities in the
6690 -- list and ensure that a finalizer is properly built.
6695 N_Conditional_Entry_Call |
6696 N_Selective_Accept =>
6698 -- Check the "then statements" for elsif parts and if statements
6700 if Nkind_In (N, N_Elsif_Part, N_If_Statement)
6701 and then not Is_Empty_List (Then_Statements (N))
6702 and then not Are_Wrapped (Then_Statements (N))
6703 and then Requires_Cleanup_Actions
6704 (Then_Statements (N), False, False)
6706 Block := Wrap_Statements_In_Block (Then_Statements (N));
6707 Set_Then_Statements (N, New_List (Block));
6712 -- Check the "else statements" for conditional entry calls, if
6713 -- statements and selective accepts.
6715 if Nkind_In (N, N_Conditional_Entry_Call,
6718 and then not Is_Empty_List (Else_Statements (N))
6719 and then not Are_Wrapped (Else_Statements (N))
6720 and then Requires_Cleanup_Actions
6721 (Else_Statements (N), False, False)
6723 Block := Wrap_Statements_In_Block (Else_Statements (N));
6724 Set_Else_Statements (N, New_List (Block));
6729 when N_Abortable_Part |
6730 N_Accept_Alternative |
6731 N_Case_Statement_Alternative |
6732 N_Delay_Alternative |
6733 N_Entry_Call_Alternative |
6734 N_Exception_Handler |
6736 N_Triggering_Alternative =>
6738 if not Is_Empty_List (Statements (N))
6739 and then not Are_Wrapped (Statements (N))
6740 and then Requires_Cleanup_Actions (Statements (N), False, False)
6742 if Nkind (N) = N_Loop_Statement
6743 and then Present (Identifier (N))
6746 Wrap_Statements_In_Block
6747 (L => Statements (N),
6748 Scop => Entity (Identifier (N)));
6750 Block := Wrap_Statements_In_Block (Statements (N));
6753 Set_Statements (N, New_List (Block));
6760 end Process_Statements_For_Controlled_Objects;
6766 function Power_Of_Two (N : Node_Id) return Nat is
6767 Typ : constant Entity_Id := Etype (N);
6768 pragma Assert (Is_Integer_Type (Typ));
6769 Siz : constant Nat := UI_To_Int (Esize (Typ));
6773 if not Compile_Time_Known_Value (N) then
6777 Val := Expr_Value (N);
6778 for J in 1 .. Siz - 1 loop
6779 if Val = Uint_2 ** J then
6788 ----------------------
6789 -- Remove_Init_Call --
6790 ----------------------
6792 function Remove_Init_Call
6794 Rep_Clause : Node_Id) return Node_Id
6796 Par : constant Node_Id := Parent (Var);
6797 Typ : constant Entity_Id := Etype (Var);
6799 Init_Proc : Entity_Id;
6800 -- Initialization procedure for Typ
6802 function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
6803 -- Look for init call for Var starting at From and scanning the
6804 -- enclosing list until Rep_Clause or the end of the list is reached.
6806 ----------------------------
6807 -- Find_Init_Call_In_List --
6808 ----------------------------
6810 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
6811 Init_Call : Node_Id;
6815 while Present (Init_Call) and then Init_Call /= Rep_Clause loop
6816 if Nkind (Init_Call) = N_Procedure_Call_Statement
6817 and then Is_Entity_Name (Name (Init_Call))
6818 and then Entity (Name (Init_Call)) = Init_Proc
6827 end Find_Init_Call_In_List;
6829 Init_Call : Node_Id;
6831 -- Start of processing for Find_Init_Call
6834 if Present (Initialization_Statements (Var)) then
6835 Init_Call := Initialization_Statements (Var);
6836 Set_Initialization_Statements (Var, Empty);
6838 elsif not Has_Non_Null_Base_Init_Proc (Typ) then
6840 -- No init proc for the type, so obviously no call to be found
6845 -- We might be able to handle other cases below by just properly
6846 -- setting Initialization_Statements at the point where the init proc
6847 -- call is generated???
6849 Init_Proc := Base_Init_Proc (Typ);
6851 -- First scan the list containing the declaration of Var
6853 Init_Call := Find_Init_Call_In_List (From => Next (Par));
6855 -- If not found, also look on Var's freeze actions list, if any,
6856 -- since the init call may have been moved there (case of an address
6857 -- clause applying to Var).
6859 if No (Init_Call) and then Present (Freeze_Node (Var)) then
6861 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
6864 -- If the initialization call has actuals that use the secondary
6865 -- stack, the call may have been wrapped into a temporary block, in
6866 -- which case the block itself has to be removed.
6868 if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then
6870 Blk : constant Node_Id := Next (Par);
6873 (Find_Init_Call_In_List
6874 (First (Statements (Handled_Statement_Sequence (Blk)))))
6882 if Present (Init_Call) then
6886 end Remove_Init_Call;
6888 -------------------------
6889 -- Remove_Side_Effects --
6890 -------------------------
6892 procedure Remove_Side_Effects
6894 Name_Req : Boolean := False;
6895 Variable_Ref : Boolean := False)
6897 Loc : constant Source_Ptr := Sloc (Exp);
6898 Exp_Type : constant Entity_Id := Etype (Exp);
6899 Svg_Suppress : constant Suppress_Record := Scope_Suppress;
6903 Ptr_Typ_Decl : Node_Id;
6904 Ref_Type : Entity_Id;
6908 -- Handle cases in which there is nothing to do. In GNATprove mode,
6909 -- removal of side effects is useful for the light expansion of
6910 -- renamings. This removal should only occur when not inside a
6911 -- generic and not doing a pre-analysis.
6913 if not Expander_Active
6914 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
6919 -- Cannot generate temporaries if the invocation to remove side effects
6920 -- was issued too early and the type of the expression is not resolved
6921 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
6922 -- Remove_Side_Effects).
6924 if No (Exp_Type) or else Ekind (Exp_Type) = E_Access_Attribute_Type then
6927 -- No action needed for side-effect free expressions
6929 elsif Side_Effect_Free (Exp, Name_Req, Variable_Ref) then
6933 -- The remaining procesaing is done with all checks suppressed
6935 -- Note: from now on, don't use return statements, instead do a goto
6936 -- Leave, to ensure that we properly restore Scope_Suppress.Suppress.
6938 Scope_Suppress.Suppress := (others => True);
6940 -- If it is a scalar type and we need to capture the value, just make
6941 -- a copy. Likewise for a function call, an attribute reference, a
6942 -- conditional expression, an allocator, or an operator. And if we have
6943 -- a volatile reference and Name_Req is not set (see comments for
6944 -- Side_Effect_Free).
6946 if Is_Elementary_Type (Exp_Type)
6948 -- Note: this test is rather mysterious??? Why can't we just test ONLY
6949 -- Is_Elementary_Type and be done with it. If we try that approach, we
6950 -- get some failures (infinite recursions) from the Duplicate_Subexpr
6951 -- call at the end of Checks.Apply_Predicate_Check. To be
6954 and then (Variable_Ref
6955 or else Nkind_In (Exp, N_Attribute_Reference,
6960 or else Nkind (Exp) in N_Op
6961 or else (not Name_Req
6962 and then Is_Volatile_Reference (Exp)))
6964 Def_Id := Make_Temporary (Loc, 'R', Exp);
6965 Set_Etype (Def_Id, Exp_Type);
6966 Res := New_Occurrence_Of (Def_Id, Loc);
6968 -- If the expression is a packed reference, it must be reanalyzed and
6969 -- expanded, depending on context. This is the case for actuals where
6970 -- a constraint check may capture the actual before expansion of the
6971 -- call is complete.
6973 if Nkind (Exp) = N_Indexed_Component
6974 and then Is_Packed (Etype (Prefix (Exp)))
6976 Set_Analyzed (Exp, False);
6977 Set_Analyzed (Prefix (Exp), False);
6981 Make_Object_Declaration (Loc,
6982 Defining_Identifier => Def_Id,
6983 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
6984 Constant_Present => True,
6985 Expression => Relocate_Node (Exp));
6987 Set_Assignment_OK (E);
6988 Insert_Action (Exp, E);
6990 -- If the expression has the form v.all then we can just capture the
6991 -- pointer, and then do an explicit dereference on the result, but
6992 -- this is not right if this is a volatile reference.
6994 elsif Nkind (Exp) = N_Explicit_Dereference
6995 and then not Is_Volatile_Reference (Exp)
6997 Def_Id := Make_Temporary (Loc, 'R', Exp);
6999 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Def_Id, Loc));
7002 Make_Object_Declaration (Loc,
7003 Defining_Identifier => Def_Id,
7004 Object_Definition =>
7005 New_Occurrence_Of (Etype (Prefix (Exp)), Loc),
7006 Constant_Present => True,
7007 Expression => Relocate_Node (Prefix (Exp))));
7009 -- Similar processing for an unchecked conversion of an expression of
7010 -- the form v.all, where we want the same kind of treatment.
7012 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
7013 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
7015 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
7018 -- If this is a type conversion, leave the type conversion and remove
7019 -- the side effects in the expression. This is important in several
7020 -- circumstances: for change of representations, and also when this is a
7021 -- view conversion to a smaller object, where gigi can end up creating
7022 -- its own temporary of the wrong size.
7024 elsif Nkind (Exp) = N_Type_Conversion then
7025 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
7028 -- If this is an unchecked conversion that Gigi can't handle, make
7029 -- a copy or a use a renaming to capture the value.
7031 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
7032 and then not Safe_Unchecked_Type_Conversion (Exp)
7034 if CW_Or_Has_Controlled_Part (Exp_Type) then
7036 -- Use a renaming to capture the expression, rather than create
7037 -- a controlled temporary.
7039 Def_Id := Make_Temporary (Loc, 'R', Exp);
7040 Res := New_Occurrence_Of (Def_Id, Loc);
7043 Make_Object_Renaming_Declaration (Loc,
7044 Defining_Identifier => Def_Id,
7045 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
7046 Name => Relocate_Node (Exp)));
7049 Def_Id := Make_Temporary (Loc, 'R', Exp);
7050 Set_Etype (Def_Id, Exp_Type);
7051 Res := New_Occurrence_Of (Def_Id, Loc);
7054 Make_Object_Declaration (Loc,
7055 Defining_Identifier => Def_Id,
7056 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
7057 Constant_Present => not Is_Variable (Exp),
7058 Expression => Relocate_Node (Exp));
7060 Set_Assignment_OK (E);
7061 Insert_Action (Exp, E);
7064 -- For expressions that denote objects, we can use a renaming scheme.
7065 -- This is needed for correctness in the case of a volatile object of
7066 -- a non-volatile type because the Make_Reference call of the "default"
7067 -- approach would generate an illegal access value (an access value
7068 -- cannot designate such an object - see Analyze_Reference).
7070 elsif Is_Object_Reference (Exp)
7071 and then Nkind (Exp) /= N_Function_Call
7073 -- In Ada 2012 a qualified expression is an object, but for purposes
7074 -- of removing side effects it still need to be transformed into a
7075 -- separate declaration, particularly in the case of an aggregate.
7077 and then Nkind (Exp) /= N_Qualified_Expression
7079 -- We skip using this scheme if we have an object of a volatile
7080 -- type and we do not have Name_Req set true (see comments for
7081 -- Side_Effect_Free).
7083 and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
7085 Def_Id := Make_Temporary (Loc, 'R', Exp);
7087 if Nkind (Exp) = N_Selected_Component
7088 and then Nkind (Prefix (Exp)) = N_Function_Call
7089 and then Is_Array_Type (Exp_Type)
7091 -- Avoid generating a variable-sized temporary, by generating
7092 -- the renaming declaration just for the function call. The
7093 -- transformation could be refined to apply only when the array
7094 -- component is constrained by a discriminant???
7097 Make_Selected_Component (Loc,
7098 Prefix => New_Occurrence_Of (Def_Id, Loc),
7099 Selector_Name => Selector_Name (Exp));
7102 Make_Object_Renaming_Declaration (Loc,
7103 Defining_Identifier => Def_Id,
7105 New_Occurrence_Of (Base_Type (Etype (Prefix (Exp))), Loc),
7106 Name => Relocate_Node (Prefix (Exp))));
7109 Res := New_Occurrence_Of (Def_Id, Loc);
7112 Make_Object_Renaming_Declaration (Loc,
7113 Defining_Identifier => Def_Id,
7114 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
7115 Name => Relocate_Node (Exp)));
7118 -- If this is a packed reference, or a selected component with
7119 -- a non-standard representation, a reference to the temporary
7120 -- will be replaced by a copy of the original expression (see
7121 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
7122 -- elaborated by gigi, and is of course not to be replaced in-line
7123 -- by the expression it renames, which would defeat the purpose of
7124 -- removing the side-effect.
7126 if Nkind_In (Exp, N_Selected_Component, N_Indexed_Component)
7127 and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
7131 Set_Is_Renaming_Of_Object (Def_Id, False);
7134 -- Otherwise we generate a reference to the value
7137 -- An expression which is in SPARK mode is considered side effect
7138 -- free if the resulting value is captured by a variable or a
7142 and then Nkind (Parent (Exp)) = N_Object_Declaration
7147 -- Special processing for function calls that return a limited type.
7148 -- We need to build a declaration that will enable build-in-place
7149 -- expansion of the call. This is not done if the context is already
7150 -- an object declaration, to prevent infinite recursion.
7152 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
7153 -- to accommodate functions returning limited objects by reference.
7155 if Ada_Version >= Ada_2005
7156 and then Nkind (Exp) = N_Function_Call
7157 and then Is_Limited_View (Etype (Exp))
7158 and then Nkind (Parent (Exp)) /= N_Object_Declaration
7161 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
7166 Make_Object_Declaration (Loc,
7167 Defining_Identifier => Obj,
7168 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
7169 Expression => Relocate_Node (Exp));
7171 Insert_Action (Exp, Decl);
7172 Set_Etype (Obj, Exp_Type);
7173 Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
7178 Def_Id := Make_Temporary (Loc, 'R', Exp);
7180 -- The regular expansion of functions with side effects involves the
7181 -- generation of an access type to capture the return value found on
7182 -- the secondary stack. Since SPARK (and why) cannot process access
7183 -- types, use a different approach which ignores the secondary stack
7184 -- and "copies" the returned object.
7186 if GNATprove_Mode then
7187 Res := New_Occurrence_Of (Def_Id, Loc);
7188 Ref_Type := Exp_Type;
7190 -- Regular expansion utilizing an access type and 'reference
7194 Make_Explicit_Dereference (Loc,
7195 Prefix => New_Occurrence_Of (Def_Id, Loc));
7198 -- type Ann is access all <Exp_Type>;
7200 Ref_Type := Make_Temporary (Loc, 'A');
7203 Make_Full_Type_Declaration (Loc,
7204 Defining_Identifier => Ref_Type,
7206 Make_Access_To_Object_Definition (Loc,
7207 All_Present => True,
7208 Subtype_Indication =>
7209 New_Occurrence_Of (Exp_Type, Loc)));
7211 Insert_Action (Exp, Ptr_Typ_Decl);
7215 if Nkind (E) = N_Explicit_Dereference then
7216 New_Exp := Relocate_Node (Prefix (E));
7219 E := Relocate_Node (E);
7221 -- Do not generate a 'reference in SPARK mode since the access
7222 -- type is not created in the first place.
7224 if GNATprove_Mode then
7227 -- Otherwise generate reference, marking the value as non-null
7228 -- since we know it cannot be null and we don't want a check.
7231 New_Exp := Make_Reference (Loc, E);
7232 Set_Is_Known_Non_Null (Def_Id);
7236 if Is_Delayed_Aggregate (E) then
7238 -- The expansion of nested aggregates is delayed until the
7239 -- enclosing aggregate is expanded. As aggregates are often
7240 -- qualified, the predicate applies to qualified expressions as
7241 -- well, indicating that the enclosing aggregate has not been
7242 -- expanded yet. At this point the aggregate is part of a
7243 -- stand-alone declaration, and must be fully expanded.
7245 if Nkind (E) = N_Qualified_Expression then
7246 Set_Expansion_Delayed (Expression (E), False);
7247 Set_Analyzed (Expression (E), False);
7249 Set_Expansion_Delayed (E, False);
7252 Set_Analyzed (E, False);
7256 Make_Object_Declaration (Loc,
7257 Defining_Identifier => Def_Id,
7258 Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
7259 Constant_Present => True,
7260 Expression => New_Exp));
7263 -- Preserve the Assignment_OK flag in all copies, since at least one
7264 -- copy may be used in a context where this flag must be set (otherwise
7265 -- why would the flag be set in the first place).
7267 Set_Assignment_OK (Res, Assignment_OK (Exp));
7269 -- Finally rewrite the original expression and we are done
7272 Analyze_And_Resolve (Exp, Exp_Type);
7275 Scope_Suppress := Svg_Suppress;
7276 end Remove_Side_Effects;
7278 ---------------------------
7279 -- Represented_As_Scalar --
7280 ---------------------------
7282 function Represented_As_Scalar (T : Entity_Id) return Boolean is
7283 UT : constant Entity_Id := Underlying_Type (T);
7285 return Is_Scalar_Type (UT)
7286 or else (Is_Bit_Packed_Array (UT)
7287 and then Is_Scalar_Type (Packed_Array_Type (UT)));
7288 end Represented_As_Scalar;
7290 ------------------------------
7291 -- Requires_Cleanup_Actions --
7292 ------------------------------
7294 function Requires_Cleanup_Actions
7296 Lib_Level : Boolean) return Boolean
7298 At_Lib_Level : constant Boolean :=
7300 and then Nkind_In (N, N_Package_Body,
7301 N_Package_Specification);
7302 -- N is at the library level if the top-most context is a package and
7303 -- the path taken to reach N does not inlcude non-package constructs.
7307 when N_Accept_Statement |
7315 Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True)
7317 (Present (Handled_Statement_Sequence (N))
7319 Requires_Cleanup_Actions
7320 (Statements (Handled_Statement_Sequence (N)),
7321 At_Lib_Level, True));
7323 when N_Package_Specification =>
7325 Requires_Cleanup_Actions
7326 (Visible_Declarations (N), At_Lib_Level, True)
7328 Requires_Cleanup_Actions
7329 (Private_Declarations (N), At_Lib_Level, True);
7334 end Requires_Cleanup_Actions;
7336 ------------------------------
7337 -- Requires_Cleanup_Actions --
7338 ------------------------------
7340 function Requires_Cleanup_Actions
7342 Lib_Level : Boolean;
7343 Nested_Constructs : Boolean) return Boolean
7348 Obj_Typ : Entity_Id;
7349 Pack_Id : Entity_Id;
7354 or else Is_Empty_List (L)
7360 while Present (Decl) loop
7362 -- Library-level tagged types
7364 if Nkind (Decl) = N_Full_Type_Declaration then
7365 Typ := Defining_Identifier (Decl);
7367 if Is_Tagged_Type (Typ)
7368 and then Is_Library_Level_Entity (Typ)
7369 and then Convention (Typ) = Convention_Ada
7370 and then Present (Access_Disp_Table (Typ))
7371 and then RTE_Available (RE_Unregister_Tag)
7372 and then not No_Run_Time_Mode
7373 and then not Is_Abstract_Type (Typ)
7378 -- Regular object declarations
7380 elsif Nkind (Decl) = N_Object_Declaration then
7381 Obj_Id := Defining_Identifier (Decl);
7382 Obj_Typ := Base_Type (Etype (Obj_Id));
7383 Expr := Expression (Decl);
7385 -- Bypass any form of processing for objects which have their
7386 -- finalization disabled. This applies only to objects at the
7389 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
7392 -- Transient variables are treated separately in order to minimize
7393 -- the size of the generated code. See Exp_Ch7.Process_Transient_
7396 elsif Is_Processed_Transient (Obj_Id) then
7399 -- The object is of the form:
7400 -- Obj : Typ [:= Expr];
7402 -- Do not process the incomplete view of a deferred constant. Do
7403 -- not consider tag-to-class-wide conversions.
7405 elsif not Is_Imported (Obj_Id)
7406 and then Needs_Finalization (Obj_Typ)
7407 and then not (Ekind (Obj_Id) = E_Constant
7408 and then not Has_Completion (Obj_Id))
7409 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
7413 -- The object is of the form:
7414 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
7416 -- Obj : Access_Typ :=
7417 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
7419 elsif Is_Access_Type (Obj_Typ)
7420 and then Needs_Finalization
7421 (Available_View (Designated_Type (Obj_Typ)))
7422 and then Present (Expr)
7424 (Is_Secondary_Stack_BIP_Func_Call (Expr)
7426 (Is_Non_BIP_Func_Call (Expr)
7427 and then not Is_Related_To_Func_Return (Obj_Id)))
7431 -- Processing for "hook" objects generated for controlled
7432 -- transients declared inside an Expression_With_Actions.
7434 elsif Is_Access_Type (Obj_Typ)
7435 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
7436 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
7437 N_Object_Declaration
7438 and then Is_Finalizable_Transient
7439 (Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
7443 -- Processing for intermediate results of if expressions where
7444 -- one of the alternatives uses a controlled function call.
7446 elsif Is_Access_Type (Obj_Typ)
7447 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
7448 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
7449 N_Defining_Identifier
7450 and then Present (Expr)
7451 and then Nkind (Expr) = N_Null
7455 -- Simple protected objects which use type System.Tasking.
7456 -- Protected_Objects.Protection to manage their locks should be
7457 -- treated as controlled since they require manual cleanup.
7459 elsif Ekind (Obj_Id) = E_Variable
7461 (Is_Simple_Protected_Type (Obj_Typ)
7462 or else Has_Simple_Protected_Object (Obj_Typ))
7467 -- Specific cases of object renamings
7469 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
7470 Obj_Id := Defining_Identifier (Decl);
7471 Obj_Typ := Base_Type (Etype (Obj_Id));
7473 -- Bypass any form of processing for objects which have their
7474 -- finalization disabled. This applies only to objects at the
7477 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
7480 -- Return object of a build-in-place function. This case is
7481 -- recognized and marked by the expansion of an extended return
7482 -- statement (see Expand_N_Extended_Return_Statement).
7484 elsif Needs_Finalization (Obj_Typ)
7485 and then Is_Return_Object (Obj_Id)
7486 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
7490 -- Detect a case where a source object has been initialized by
7491 -- a controlled function call or another object which was later
7492 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
7494 -- Obj1 : CW_Type := Src_Obj;
7495 -- Obj2 : CW_Type := Function_Call (...);
7497 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
7498 -- Tmp : ... := Function_Call (...)'reference;
7499 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
7501 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
7505 -- Inspect the freeze node of an access-to-controlled type and look
7506 -- for a delayed finalization master. This case arises when the
7507 -- freeze actions are inserted at a later time than the expansion of
7508 -- the context. Since Build_Finalizer is never called on a single
7509 -- construct twice, the master will be ultimately left out and never
7510 -- finalized. This is also needed for freeze actions of designated
7511 -- types themselves, since in some cases the finalization master is
7512 -- associated with a designated type's freeze node rather than that
7513 -- of the access type (see handling for freeze actions in
7514 -- Build_Finalization_Master).
7516 elsif Nkind (Decl) = N_Freeze_Entity
7517 and then Present (Actions (Decl))
7519 Typ := Entity (Decl);
7521 if ((Is_Access_Type (Typ)
7522 and then not Is_Access_Subprogram_Type (Typ)
7523 and then Needs_Finalization
7524 (Available_View (Designated_Type (Typ))))
7527 and then Needs_Finalization (Typ)))
7528 and then Requires_Cleanup_Actions
7529 (Actions (Decl), Lib_Level, Nested_Constructs)
7534 -- Nested package declarations
7536 elsif Nested_Constructs
7537 and then Nkind (Decl) = N_Package_Declaration
7539 Pack_Id := Defining_Unit_Name (Specification (Decl));
7541 if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
7542 Pack_Id := Defining_Identifier (Pack_Id);
7545 if Ekind (Pack_Id) /= E_Generic_Package
7547 Requires_Cleanup_Actions (Specification (Decl), Lib_Level)
7552 -- Nested package bodies
7554 elsif Nested_Constructs and then Nkind (Decl) = N_Package_Body then
7555 Pack_Id := Corresponding_Spec (Decl);
7557 if Ekind (Pack_Id) /= E_Generic_Package
7558 and then Requires_Cleanup_Actions (Decl, Lib_Level)
7568 end Requires_Cleanup_Actions;
7570 ------------------------------------
7571 -- Safe_Unchecked_Type_Conversion --
7572 ------------------------------------
7574 -- Note: this function knows quite a bit about the exact requirements of
7575 -- Gigi with respect to unchecked type conversions, and its code must be
7576 -- coordinated with any changes in Gigi in this area.
7578 -- The above requirements should be documented in Sinfo ???
7580 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
7585 Pexp : constant Node_Id := Parent (Exp);
7588 -- If the expression is the RHS of an assignment or object declaration
7589 -- we are always OK because there will always be a target.
7591 -- Object renaming declarations, (generated for view conversions of
7592 -- actuals in inlined calls), like object declarations, provide an
7593 -- explicit type, and are safe as well.
7595 if (Nkind (Pexp) = N_Assignment_Statement
7596 and then Expression (Pexp) = Exp)
7597 or else Nkind_In (Pexp, N_Object_Declaration,
7598 N_Object_Renaming_Declaration)
7602 -- If the expression is the prefix of an N_Selected_Component we should
7603 -- also be OK because GCC knows to look inside the conversion except if
7604 -- the type is discriminated. We assume that we are OK anyway if the
7605 -- type is not set yet or if it is controlled since we can't afford to
7606 -- introduce a temporary in this case.
7608 elsif Nkind (Pexp) = N_Selected_Component
7609 and then Prefix (Pexp) = Exp
7611 if No (Etype (Pexp)) then
7615 not Has_Discriminants (Etype (Pexp))
7616 or else Is_Constrained (Etype (Pexp));
7620 -- Set the output type, this comes from Etype if it is set, otherwise we
7621 -- take it from the subtype mark, which we assume was already fully
7624 if Present (Etype (Exp)) then
7625 Otyp := Etype (Exp);
7627 Otyp := Entity (Subtype_Mark (Exp));
7630 -- The input type always comes from the expression, and we assume
7631 -- this is indeed always analyzed, so we can simply get the Etype.
7633 Ityp := Etype (Expression (Exp));
7635 -- Initialize alignments to unknown so far
7640 -- Replace a concurrent type by its corresponding record type and each
7641 -- type by its underlying type and do the tests on those. The original
7642 -- type may be a private type whose completion is a concurrent type, so
7643 -- find the underlying type first.
7645 if Present (Underlying_Type (Otyp)) then
7646 Otyp := Underlying_Type (Otyp);
7649 if Present (Underlying_Type (Ityp)) then
7650 Ityp := Underlying_Type (Ityp);
7653 if Is_Concurrent_Type (Otyp) then
7654 Otyp := Corresponding_Record_Type (Otyp);
7657 if Is_Concurrent_Type (Ityp) then
7658 Ityp := Corresponding_Record_Type (Ityp);
7661 -- If the base types are the same, we know there is no problem since
7662 -- this conversion will be a noop.
7664 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
7667 -- Same if this is an upwards conversion of an untagged type, and there
7668 -- are no constraints involved (could be more general???)
7670 elsif Etype (Ityp) = Otyp
7671 and then not Is_Tagged_Type (Ityp)
7672 and then not Has_Discriminants (Ityp)
7673 and then No (First_Rep_Item (Base_Type (Ityp)))
7677 -- If the expression has an access type (object or subprogram) we assume
7678 -- that the conversion is safe, because the size of the target is safe,
7679 -- even if it is a record (which might be treated as having unknown size
7682 elsif Is_Access_Type (Ityp) then
7685 -- If the size of output type is known at compile time, there is never
7686 -- a problem. Note that unconstrained records are considered to be of
7687 -- known size, but we can't consider them that way here, because we are
7688 -- talking about the actual size of the object.
7690 -- We also make sure that in addition to the size being known, we do not
7691 -- have a case which might generate an embarrassingly large temp in
7692 -- stack checking mode.
7694 elsif Size_Known_At_Compile_Time (Otyp)
7696 (not Stack_Checking_Enabled
7697 or else not May_Generate_Large_Temp (Otyp))
7698 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
7702 -- If either type is tagged, then we know the alignment is OK so
7703 -- Gigi will be able to use pointer punning.
7705 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
7708 -- If either type is a limited record type, we cannot do a copy, so say
7709 -- safe since there's nothing else we can do.
7711 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
7714 -- Conversions to and from packed array types are always ignored and
7717 elsif Is_Packed_Array_Type (Otyp)
7718 or else Is_Packed_Array_Type (Ityp)
7723 -- The only other cases known to be safe is if the input type's
7724 -- alignment is known to be at least the maximum alignment for the
7725 -- target or if both alignments are known and the output type's
7726 -- alignment is no stricter than the input's. We can use the component
7727 -- type alignement for an array if a type is an unpacked array type.
7729 if Present (Alignment_Clause (Otyp)) then
7730 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
7732 elsif Is_Array_Type (Otyp)
7733 and then Present (Alignment_Clause (Component_Type (Otyp)))
7735 Oalign := Expr_Value (Expression (Alignment_Clause
7736 (Component_Type (Otyp))));
7739 if Present (Alignment_Clause (Ityp)) then
7740 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
7742 elsif Is_Array_Type (Ityp)
7743 and then Present (Alignment_Clause (Component_Type (Ityp)))
7745 Ialign := Expr_Value (Expression (Alignment_Clause
7746 (Component_Type (Ityp))));
7749 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
7752 elsif Ialign /= No_Uint and then Oalign /= No_Uint
7753 and then Ialign <= Oalign
7757 -- Otherwise, Gigi cannot handle this and we must make a temporary
7762 end Safe_Unchecked_Type_Conversion;
7764 ---------------------------------
7765 -- Set_Current_Value_Condition --
7766 ---------------------------------
7768 -- Note: the implementation of this procedure is very closely tied to the
7769 -- implementation of Get_Current_Value_Condition. Here we set required
7770 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
7771 -- them, so they must have a consistent view.
7773 procedure Set_Current_Value_Condition (Cnode : Node_Id) is
7775 procedure Set_Entity_Current_Value (N : Node_Id);
7776 -- If N is an entity reference, where the entity is of an appropriate
7777 -- kind, then set the current value of this entity to Cnode, unless
7778 -- there is already a definite value set there.
7780 procedure Set_Expression_Current_Value (N : Node_Id);
7781 -- If N is of an appropriate form, sets an appropriate entry in current
7782 -- value fields of relevant entities. Multiple entities can be affected
7783 -- in the case of an AND or AND THEN.
7785 ------------------------------
7786 -- Set_Entity_Current_Value --
7787 ------------------------------
7789 procedure Set_Entity_Current_Value (N : Node_Id) is
7791 if Is_Entity_Name (N) then
7793 Ent : constant Entity_Id := Entity (N);
7796 -- Don't capture if not safe to do so
7798 if not Safe_To_Capture_Value (N, Ent, Cond => True) then
7802 -- Here we have a case where the Current_Value field may need
7803 -- to be set. We set it if it is not already set to a compile
7804 -- time expression value.
7806 -- Note that this represents a decision that one condition
7807 -- blots out another previous one. That's certainly right if
7808 -- they occur at the same level. If the second one is nested,
7809 -- then the decision is neither right nor wrong (it would be
7810 -- equally OK to leave the outer one in place, or take the new
7811 -- inner one. Really we should record both, but our data
7812 -- structures are not that elaborate.
7814 if Nkind (Current_Value (Ent)) not in N_Subexpr then
7815 Set_Current_Value (Ent, Cnode);
7819 end Set_Entity_Current_Value;
7821 ----------------------------------
7822 -- Set_Expression_Current_Value --
7823 ----------------------------------
7825 procedure Set_Expression_Current_Value (N : Node_Id) is
7831 -- Loop to deal with (ignore for now) any NOT operators present. The
7832 -- presence of NOT operators will be handled properly when we call
7833 -- Get_Current_Value_Condition.
7835 while Nkind (Cond) = N_Op_Not loop
7836 Cond := Right_Opnd (Cond);
7839 -- For an AND or AND THEN, recursively process operands
7841 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
7842 Set_Expression_Current_Value (Left_Opnd (Cond));
7843 Set_Expression_Current_Value (Right_Opnd (Cond));
7847 -- Check possible relational operator
7849 if Nkind (Cond) in N_Op_Compare then
7850 if Compile_Time_Known_Value (Right_Opnd (Cond)) then
7851 Set_Entity_Current_Value (Left_Opnd (Cond));
7852 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
7853 Set_Entity_Current_Value (Right_Opnd (Cond));
7856 elsif Nkind_In (Cond,
7858 N_Qualified_Expression,
7859 N_Expression_With_Actions)
7861 Set_Expression_Current_Value (Expression (Cond));
7863 -- Check possible boolean variable reference
7866 Set_Entity_Current_Value (Cond);
7868 end Set_Expression_Current_Value;
7870 -- Start of processing for Set_Current_Value_Condition
7873 Set_Expression_Current_Value (Condition (Cnode));
7874 end Set_Current_Value_Condition;
7876 --------------------------
7877 -- Set_Elaboration_Flag --
7878 --------------------------
7880 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
7881 Loc : constant Source_Ptr := Sloc (N);
7882 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
7886 if Present (Ent) then
7888 -- Nothing to do if at the compilation unit level, because in this
7889 -- case the flag is set by the binder generated elaboration routine.
7891 if Nkind (Parent (N)) = N_Compilation_Unit then
7894 -- Here we do need to generate an assignment statement
7897 Check_Restriction (No_Elaboration_Code, N);
7899 Make_Assignment_Statement (Loc,
7900 Name => New_Occurrence_Of (Ent, Loc),
7901 Expression => Make_Integer_Literal (Loc, Uint_1));
7903 if Nkind (Parent (N)) = N_Subunit then
7904 Insert_After (Corresponding_Stub (Parent (N)), Asn);
7906 Insert_After (N, Asn);
7911 -- Kill current value indication. This is necessary because the
7912 -- tests of this flag are inserted out of sequence and must not
7913 -- pick up bogus indications of the wrong constant value.
7915 Set_Current_Value (Ent, Empty);
7918 end Set_Elaboration_Flag;
7920 ----------------------------
7921 -- Set_Renamed_Subprogram --
7922 ----------------------------
7924 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
7926 -- If input node is an identifier, we can just reset it
7928 if Nkind (N) = N_Identifier then
7929 Set_Chars (N, Chars (E));
7932 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
7936 CS : constant Boolean := Comes_From_Source (N);
7938 Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
7940 Set_Comes_From_Source (N, CS);
7941 Set_Analyzed (N, True);
7944 end Set_Renamed_Subprogram;
7946 ----------------------
7947 -- Side_Effect_Free --
7948 ----------------------
7950 function Side_Effect_Free
7952 Name_Req : Boolean := False;
7953 Variable_Ref : Boolean := False) return Boolean
7955 Typ : constant Entity_Id := Etype (N);
7956 -- Result type of the expression
7958 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
7959 -- The argument N is a construct where the Prefix is dereferenced if it
7960 -- is an access type and the result is a variable. The call returns True
7961 -- if the construct is side effect free (not considering side effects in
7962 -- other than the prefix which are to be tested by the caller).
7964 function Within_In_Parameter (N : Node_Id) return Boolean;
7965 -- Determines if N is a subcomponent of a composite in-parameter. If so,
7966 -- N is not side-effect free when the actual is global and modifiable
7967 -- indirectly from within a subprogram, because it may be passed by
7968 -- reference. The front-end must be conservative here and assume that
7969 -- this may happen with any array or record type. On the other hand, we
7970 -- cannot create temporaries for all expressions for which this
7971 -- condition is true, for various reasons that might require clearing up
7972 -- ??? For example, discriminant references that appear out of place, or
7973 -- spurious type errors with class-wide expressions. As a result, we
7974 -- limit the transformation to loop bounds, which is so far the only
7975 -- case that requires it.
7977 -----------------------------
7978 -- Safe_Prefixed_Reference --
7979 -----------------------------
7981 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
7983 -- If prefix is not side effect free, definitely not safe
7985 if not Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref) then
7988 -- If the prefix is of an access type that is not access-to-constant,
7989 -- then this construct is a variable reference, which means it is to
7990 -- be considered to have side effects if Variable_Ref is set True.
7992 elsif Is_Access_Type (Etype (Prefix (N)))
7993 and then not Is_Access_Constant (Etype (Prefix (N)))
7994 and then Variable_Ref
7996 -- Exception is a prefix that is the result of a previous removal
7999 return Is_Entity_Name (Prefix (N))
8000 and then not Comes_From_Source (Prefix (N))
8001 and then Ekind (Entity (Prefix (N))) = E_Constant
8002 and then Is_Internal_Name (Chars (Entity (Prefix (N))));
8004 -- If the prefix is an explicit dereference then this construct is a
8005 -- variable reference, which means it is to be considered to have
8006 -- side effects if Variable_Ref is True.
8008 -- We do NOT exclude dereferences of access-to-constant types because
8009 -- we handle them as constant view of variables.
8011 elsif Nkind (Prefix (N)) = N_Explicit_Dereference
8012 and then Variable_Ref
8016 -- Note: The following test is the simplest way of solving a complex
8017 -- problem uncovered by the following test (Side effect on loop bound
8018 -- that is a subcomponent of a global variable:
8020 -- with Text_Io; use Text_Io;
8021 -- procedure Tloop is
8024 -- V : Natural := 4;
8025 -- S : String (1..5) := (others => 'a');
8032 -- with procedure Action;
8033 -- procedure Loop_G (Arg : X; Msg : String)
8035 -- procedure Loop_G (Arg : X; Msg : String) is
8037 -- Put_Line ("begin loop_g " & Msg & " will loop till: "
8038 -- & Natural'Image (Arg.V));
8039 -- for Index in 1 .. Arg.V loop
8041 -- (Natural'Image (Index) & " " & Arg.S (Index));
8042 -- if Index > 2 then
8046 -- Put_Line ("end loop_g " & Msg);
8049 -- procedure Loop1 is new Loop_G (Modi);
8050 -- procedure Modi is
8053 -- Loop1 (X1, "from modi");
8057 -- Loop1 (X1, "initial");
8060 -- The output of the above program should be:
8062 -- begin loop_g initial will loop till: 4
8066 -- begin loop_g from modi will loop till: 1
8068 -- end loop_g from modi
8070 -- begin loop_g from modi will loop till: 1
8072 -- end loop_g from modi
8073 -- end loop_g initial
8075 -- If a loop bound is a subcomponent of a global variable, a
8076 -- modification of that variable within the loop may incorrectly
8077 -- affect the execution of the loop.
8079 elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
8080 and then Within_In_Parameter (Prefix (N))
8081 and then Variable_Ref
8085 -- All other cases are side effect free
8090 end Safe_Prefixed_Reference;
8092 -------------------------
8093 -- Within_In_Parameter --
8094 -------------------------
8096 function Within_In_Parameter (N : Node_Id) return Boolean is
8098 if not Comes_From_Source (N) then
8101 elsif Is_Entity_Name (N) then
8102 return Ekind (Entity (N)) = E_In_Parameter;
8104 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
8105 return Within_In_Parameter (Prefix (N));
8110 end Within_In_Parameter;
8112 -- Start of processing for Side_Effect_Free
8115 -- If volatile reference, always consider it to have side effects
8117 if Is_Volatile_Reference (N) then
8121 -- Note on checks that could raise Constraint_Error. Strictly, if we
8122 -- take advantage of 11.6, these checks do not count as side effects.
8123 -- However, we would prefer to consider that they are side effects,
8124 -- since the backend CSE does not work very well on expressions which
8125 -- can raise Constraint_Error. On the other hand if we don't consider
8126 -- them to be side effect free, then we get some awkward expansions
8127 -- in -gnato mode, resulting in code insertions at a point where we
8128 -- do not have a clear model for performing the insertions.
8130 -- Special handling for entity names
8132 if Is_Entity_Name (N) then
8134 -- A type reference is always side effect free
8136 if Is_Type (Entity (N)) then
8139 -- Variables are considered to be a side effect if Variable_Ref
8140 -- is set or if we have a volatile reference and Name_Req is off.
8141 -- If Name_Req is True then we can't help returning a name which
8142 -- effectively allows multiple references in any case.
8144 elsif Is_Variable (N, Use_Original_Node => False) then
8145 return not Variable_Ref
8146 and then (not Is_Volatile_Reference (N) or else Name_Req);
8148 -- Any other entity (e.g. a subtype name) is definitely side
8155 -- A value known at compile time is always side effect free
8157 elsif Compile_Time_Known_Value (N) then
8160 -- A variable renaming is not side-effect free, because the renaming
8161 -- will function like a macro in the front-end in some cases, and an
8162 -- assignment can modify the component designated by N, so we need to
8163 -- create a temporary for it.
8165 -- The guard testing for Entity being present is needed at least in
8166 -- the case of rewritten predicate expressions, and may well also be
8167 -- appropriate elsewhere. Obviously we can't go testing the entity
8168 -- field if it does not exist, so it's reasonable to say that this is
8169 -- not the renaming case if it does not exist.
8171 elsif Is_Entity_Name (Original_Node (N))
8172 and then Present (Entity (Original_Node (N)))
8173 and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
8174 and then Ekind (Entity (Original_Node (N))) /= E_Constant
8177 RO : constant Node_Id :=
8178 Renamed_Object (Entity (Original_Node (N)));
8181 -- If the renamed object is an indexed component, or an
8182 -- explicit dereference, then the designated object could
8183 -- be modified by an assignment.
8185 if Nkind_In (RO, N_Indexed_Component,
8186 N_Explicit_Dereference)
8190 -- A selected component must have a safe prefix
8192 elsif Nkind (RO) = N_Selected_Component then
8193 return Safe_Prefixed_Reference (RO);
8195 -- In all other cases, designated object cannot be changed so
8196 -- we are side effect free.
8203 -- Remove_Side_Effects generates an object renaming declaration to
8204 -- capture the expression of a class-wide expression. In VM targets
8205 -- the frontend performs no expansion for dispatching calls to
8206 -- class- wide types since they are handled by the VM. Hence, we must
8207 -- locate here if this node corresponds to a previous invocation of
8208 -- Remove_Side_Effects to avoid a never ending loop in the frontend.
8210 elsif VM_Target /= No_VM
8211 and then not Comes_From_Source (N)
8212 and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
8213 and then Is_Class_Wide_Type (Typ)
8218 -- For other than entity names and compile time known values,
8219 -- check the node kind for special processing.
8223 -- An attribute reference is side effect free if its expressions
8224 -- are side effect free and its prefix is side effect free or
8225 -- is an entity reference.
8227 -- Is this right? what about x'first where x is a variable???
8229 when N_Attribute_Reference =>
8230 return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
8231 and then Attribute_Name (N) /= Name_Input
8232 and then (Is_Entity_Name (Prefix (N))
8233 or else Side_Effect_Free
8234 (Prefix (N), Name_Req, Variable_Ref));
8236 -- A binary operator is side effect free if and both operands are
8237 -- side effect free. For this purpose binary operators include
8238 -- membership tests and short circuit forms.
8240 when N_Binary_Op | N_Membership_Test | N_Short_Circuit =>
8241 return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
8243 Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
8245 -- An explicit dereference is side effect free only if it is
8246 -- a side effect free prefixed reference.
8248 when N_Explicit_Dereference =>
8249 return Safe_Prefixed_Reference (N);
8251 -- An expression with action is side effect free if its expression
8252 -- is side effect free and it has no actions.
8254 when N_Expression_With_Actions =>
8255 return Is_Empty_List (Actions (N))
8257 Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
8259 -- A call to _rep_to_pos is side effect free, since we generate
8260 -- this pure function call ourselves. Moreover it is critically
8261 -- important to make this exception, since otherwise we can have
8262 -- discriminants in array components which don't look side effect
8263 -- free in the case of an array whose index type is an enumeration
8264 -- type with an enumeration rep clause.
8266 -- All other function calls are not side effect free
8268 when N_Function_Call =>
8269 return Nkind (Name (N)) = N_Identifier
8270 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
8273 (First (Parameter_Associations (N)), Name_Req, Variable_Ref);
8275 -- An IF expression is side effect free if it's of a scalar type, and
8276 -- all its components are all side effect free (conditions and then
8277 -- actions and else actions). We restrict to scalar types, since it
8278 -- is annoying to deal with things like (if A then B else C)'First
8279 -- where the type involved is a string type.
8281 when N_If_Expression =>
8282 return Is_Scalar_Type (Typ)
8284 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref);
8286 -- An indexed component is side effect free if it is a side
8287 -- effect free prefixed reference and all the indexing
8288 -- expressions are side effect free.
8290 when N_Indexed_Component =>
8291 return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
8292 and then Safe_Prefixed_Reference (N);
8294 -- A type qualification is side effect free if the expression
8295 -- is side effect free.
8297 when N_Qualified_Expression =>
8298 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
8300 -- A selected component is side effect free only if it is a side
8301 -- effect free prefixed reference. If it designates a component
8302 -- with a rep. clause it must be treated has having a potential
8303 -- side effect, because it may be modified through a renaming, and
8304 -- a subsequent use of the renaming as a macro will yield the
8305 -- wrong value. This complex interaction between renaming and
8306 -- removing side effects is a reminder that the latter has become
8307 -- a headache to maintain, and that it should be removed in favor
8308 -- of the gcc mechanism to capture values ???
8310 when N_Selected_Component =>
8311 if Nkind (Parent (N)) = N_Explicit_Dereference
8312 and then Has_Non_Standard_Rep (Designated_Type (Typ))
8316 return Safe_Prefixed_Reference (N);
8319 -- A range is side effect free if the bounds are side effect free
8322 return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref)
8324 Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref);
8326 -- A slice is side effect free if it is a side effect free
8327 -- prefixed reference and the bounds are side effect free.
8330 return Side_Effect_Free
8331 (Discrete_Range (N), Name_Req, Variable_Ref)
8332 and then Safe_Prefixed_Reference (N);
8334 -- A type conversion is side effect free if the expression to be
8335 -- converted is side effect free.
8337 when N_Type_Conversion =>
8338 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
8340 -- A unary operator is side effect free if the operand
8341 -- is side effect free.
8344 return Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
8346 -- An unchecked type conversion is side effect free only if it
8347 -- is safe and its argument is side effect free.
8349 when N_Unchecked_Type_Conversion =>
8350 return Safe_Unchecked_Type_Conversion (N)
8352 Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
8354 -- An unchecked expression is side effect free if its expression
8355 -- is side effect free.
8357 when N_Unchecked_Expression =>
8358 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
8360 -- A literal is side effect free
8362 when N_Character_Literal |
8368 -- We consider that anything else has side effects. This is a bit
8369 -- crude, but we are pretty close for most common cases, and we
8370 -- are certainly correct (i.e. we never return True when the
8371 -- answer should be False).
8376 end Side_Effect_Free;
8378 -- A list is side effect free if all elements of the list are side
8381 function Side_Effect_Free
8383 Name_Req : Boolean := False;
8384 Variable_Ref : Boolean := False) return Boolean
8389 if L = No_List or else L = Error_List then
8394 while Present (N) loop
8395 if not Side_Effect_Free (N, Name_Req, Variable_Ref) then
8404 end Side_Effect_Free;
8406 ----------------------------------
8407 -- Silly_Boolean_Array_Not_Test --
8408 ----------------------------------
8410 -- This procedure implements an odd and silly test. We explicitly check
8411 -- for the case where the 'First of the component type is equal to the
8412 -- 'Last of this component type, and if this is the case, we make sure
8413 -- that constraint error is raised. The reason is that the NOT is bound
8414 -- to cause CE in this case, and we will not otherwise catch it.
8416 -- No such check is required for AND and OR, since for both these cases
8417 -- False op False = False, and True op True = True. For the XOR case,
8418 -- see Silly_Boolean_Array_Xor_Test.
8420 -- Believe it or not, this was reported as a bug. Note that nearly always,
8421 -- the test will evaluate statically to False, so the code will be
8422 -- statically removed, and no extra overhead caused.
8424 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
8425 Loc : constant Source_Ptr := Sloc (N);
8426 CT : constant Entity_Id := Component_Type (T);
8429 -- The check we install is
8431 -- constraint_error when
8432 -- component_type'first = component_type'last
8433 -- and then array_type'Length /= 0)
8435 -- We need the last guard because we don't want to raise CE for empty
8436 -- arrays since no out of range values result. (Empty arrays with a
8437 -- component type of True .. True -- very useful -- even the ACATS
8438 -- does not test that marginal case).
8441 Make_Raise_Constraint_Error (Loc,
8447 Make_Attribute_Reference (Loc,
8448 Prefix => New_Occurrence_Of (CT, Loc),
8449 Attribute_Name => Name_First),
8452 Make_Attribute_Reference (Loc,
8453 Prefix => New_Occurrence_Of (CT, Loc),
8454 Attribute_Name => Name_Last)),
8456 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
8457 Reason => CE_Range_Check_Failed));
8458 end Silly_Boolean_Array_Not_Test;
8460 ----------------------------------
8461 -- Silly_Boolean_Array_Xor_Test --
8462 ----------------------------------
8464 -- This procedure implements an odd and silly test. We explicitly check
8465 -- for the XOR case where the component type is True .. True, since this
8466 -- will raise constraint error. A special check is required since CE
8467 -- will not be generated otherwise (cf Expand_Packed_Not).
8469 -- No such check is required for AND and OR, since for both these cases
8470 -- False op False = False, and True op True = True, and no check is
8471 -- required for the case of False .. False, since False xor False = False.
8472 -- See also Silly_Boolean_Array_Not_Test
8474 procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is
8475 Loc : constant Source_Ptr := Sloc (N);
8476 CT : constant Entity_Id := Component_Type (T);
8479 -- The check we install is
8481 -- constraint_error when
8482 -- Boolean (component_type'First)
8483 -- and then Boolean (component_type'Last)
8484 -- and then array_type'Length /= 0)
8486 -- We need the last guard because we don't want to raise CE for empty
8487 -- arrays since no out of range values result (Empty arrays with a
8488 -- component type of True .. True -- very useful -- even the ACATS
8489 -- does not test that marginal case).
8492 Make_Raise_Constraint_Error (Loc,
8498 Convert_To (Standard_Boolean,
8499 Make_Attribute_Reference (Loc,
8500 Prefix => New_Occurrence_Of (CT, Loc),
8501 Attribute_Name => Name_First)),
8504 Convert_To (Standard_Boolean,
8505 Make_Attribute_Reference (Loc,
8506 Prefix => New_Occurrence_Of (CT, Loc),
8507 Attribute_Name => Name_Last))),
8509 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
8510 Reason => CE_Range_Check_Failed));
8511 end Silly_Boolean_Array_Xor_Test;
8513 --------------------------
8514 -- Target_Has_Fixed_Ops --
8515 --------------------------
8517 Integer_Sized_Small : Ureal;
8518 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
8519 -- called (we don't want to compute it more than once).
8521 Long_Integer_Sized_Small : Ureal;
8522 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
8523 -- is called (we don't want to compute it more than once)
8525 First_Time_For_THFO : Boolean := True;
8526 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
8528 function Target_Has_Fixed_Ops
8529 (Left_Typ : Entity_Id;
8530 Right_Typ : Entity_Id;
8531 Result_Typ : Entity_Id) return Boolean
8533 function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
8534 -- Return True if the given type is a fixed-point type with a small
8535 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
8536 -- an absolute value less than 1.0. This is currently limited to
8537 -- fixed-point types that map to Integer or Long_Integer.
8539 ------------------------
8540 -- Is_Fractional_Type --
8541 ------------------------
8543 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
8545 if Esize (Typ) = Standard_Integer_Size then
8546 return Small_Value (Typ) = Integer_Sized_Small;
8548 elsif Esize (Typ) = Standard_Long_Integer_Size then
8549 return Small_Value (Typ) = Long_Integer_Sized_Small;
8554 end Is_Fractional_Type;
8556 -- Start of processing for Target_Has_Fixed_Ops
8559 -- Return False if Fractional_Fixed_Ops_On_Target is false
8561 if not Fractional_Fixed_Ops_On_Target then
8565 -- Here the target has Fractional_Fixed_Ops, if first time, compute
8566 -- standard constants used by Is_Fractional_Type.
8568 if First_Time_For_THFO then
8569 First_Time_For_THFO := False;
8571 Integer_Sized_Small :=
8574 Den => UI_From_Int (Standard_Integer_Size - 1),
8577 Long_Integer_Sized_Small :=
8580 Den => UI_From_Int (Standard_Long_Integer_Size - 1),
8584 -- Return True if target supports fixed-by-fixed multiply/divide for
8585 -- fractional fixed-point types (see Is_Fractional_Type) and the operand
8586 -- and result types are equivalent fractional types.
8588 return Is_Fractional_Type (Base_Type (Left_Typ))
8589 and then Is_Fractional_Type (Base_Type (Right_Typ))
8590 and then Is_Fractional_Type (Base_Type (Result_Typ))
8591 and then Esize (Left_Typ) = Esize (Right_Typ)
8592 and then Esize (Left_Typ) = Esize (Result_Typ);
8593 end Target_Has_Fixed_Ops;
8595 ------------------------------------------
8596 -- Type_May_Have_Bit_Aligned_Components --
8597 ------------------------------------------
8599 function Type_May_Have_Bit_Aligned_Components
8600 (Typ : Entity_Id) return Boolean
8603 -- Array type, check component type
8605 if Is_Array_Type (Typ) then
8607 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
8609 -- Record type, check components
8611 elsif Is_Record_Type (Typ) then
8616 E := First_Component_Or_Discriminant (Typ);
8617 while Present (E) loop
8618 if Component_May_Be_Bit_Aligned (E)
8619 or else Type_May_Have_Bit_Aligned_Components (Etype (E))
8624 Next_Component_Or_Discriminant (E);
8630 -- Type other than array or record is always OK
8635 end Type_May_Have_Bit_Aligned_Components;
8637 ----------------------------------
8638 -- Within_Case_Or_If_Expression --
8639 ----------------------------------
8641 function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
8645 -- Locate an enclosing case or if expression. Note that these constructs
8646 -- can be expanded into Expression_With_Actions, hence the test of the
8650 while Present (Par) loop
8651 if Nkind_In (Original_Node (Par), N_Case_Expression,
8656 -- Prevent the search from going too far
8658 elsif Is_Body_Or_Package_Declaration (Par) then
8662 Par := Parent (Par);
8666 end Within_Case_Or_If_Expression;
8668 --------------------------------
8669 -- Within_Internal_Subprogram --
8670 --------------------------------
8672 function Within_Internal_Subprogram return Boolean is
8677 while Present (S) and then not Is_Subprogram (S) loop
8682 and then Get_TSS_Name (S) /= TSS_Null
8683 and then not Is_Predicate_Function (S);
8684 end Within_Internal_Subprogram;
8686 ----------------------------
8687 -- Wrap_Cleanup_Procedure --
8688 ----------------------------
8690 procedure Wrap_Cleanup_Procedure (N : Node_Id) is
8691 Loc : constant Source_Ptr := Sloc (N);
8692 Stseq : constant Node_Id := Handled_Statement_Sequence (N);
8693 Stmts : constant List_Id := Statements (Stseq);
8696 if Abort_Allowed then
8697 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
8698 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
8700 end Wrap_Cleanup_Procedure;