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_Possibly_Unaligned_Object --
4799 ----------------------------------
4801 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
4802 T : constant Entity_Id := Etype (N);
4805 -- If renamed object, apply test to underlying object
4807 if Is_Entity_Name (N)
4808 and then Is_Object (Entity (N))
4809 and then Present (Renamed_Object (Entity (N)))
4811 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
4814 -- Tagged and controlled types and aliased types are always aligned, as
4815 -- are concurrent types.
4818 or else Has_Controlled_Component (T)
4819 or else Is_Concurrent_Type (T)
4820 or else Is_Tagged_Type (T)
4821 or else Is_Controlled (T)
4826 -- If this is an element of a packed array, may be unaligned
4828 if Is_Ref_To_Bit_Packed_Array (N) then
4832 -- Case of indexed component reference: test whether prefix is unaligned
4834 if Nkind (N) = N_Indexed_Component then
4835 return Is_Possibly_Unaligned_Object (Prefix (N));
4837 -- Case of selected component reference
4839 elsif Nkind (N) = N_Selected_Component then
4841 P : constant Node_Id := Prefix (N);
4842 C : constant Entity_Id := Entity (Selector_Name (N));
4847 -- If component reference is for an array with non-static bounds,
4848 -- then it is always aligned: we can only process unaligned arrays
4849 -- with static bounds (more precisely compile time known bounds).
4851 if Is_Array_Type (T)
4852 and then not Compile_Time_Known_Bounds (T)
4857 -- If component is aliased, it is definitely properly aligned
4859 if Is_Aliased (C) then
4863 -- If component is for a type implemented as a scalar, and the
4864 -- record is packed, and the component is other than the first
4865 -- component of the record, then the component may be unaligned.
4867 if Is_Packed (Etype (P))
4868 and then Represented_As_Scalar (Etype (C))
4869 and then First_Entity (Scope (C)) /= C
4874 -- Compute maximum possible alignment for T
4876 -- If alignment is known, then that settles things
4878 if Known_Alignment (T) then
4879 M := UI_To_Int (Alignment (T));
4881 -- If alignment is not known, tentatively set max alignment
4884 M := Ttypes.Maximum_Alignment;
4886 -- We can reduce this if the Esize is known since the default
4887 -- alignment will never be more than the smallest power of 2
4888 -- that does not exceed this Esize value.
4890 if Known_Esize (T) then
4891 S := UI_To_Int (Esize (T));
4893 while (M / 2) >= S loop
4899 -- The following code is historical, it used to be present but it
4900 -- is too cautious, because the front-end does not know the proper
4901 -- default alignments for the target. Also, if the alignment is
4902 -- not known, the front end can't know in any case. If a copy is
4903 -- needed, the back-end will take care of it. This whole section
4904 -- including this comment can be removed later ???
4906 -- If the component reference is for a record that has a specified
4907 -- alignment, and we either know it is too small, or cannot tell,
4908 -- then the component may be unaligned.
4910 -- What is the following commented out code ???
4912 -- if Known_Alignment (Etype (P))
4913 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
4914 -- and then M > Alignment (Etype (P))
4919 -- Case of component clause present which may specify an
4920 -- unaligned position.
4922 if Present (Component_Clause (C)) then
4924 -- Otherwise we can do a test to make sure that the actual
4925 -- start position in the record, and the length, are both
4926 -- consistent with the required alignment. If not, we know
4927 -- that we are unaligned.
4930 Align_In_Bits : constant Nat := M * System_Storage_Unit;
4932 if Component_Bit_Offset (C) mod Align_In_Bits /= 0
4933 or else Esize (C) mod Align_In_Bits /= 0
4940 -- Otherwise, for a component reference, test prefix
4942 return Is_Possibly_Unaligned_Object (P);
4945 -- If not a component reference, must be aligned
4950 end Is_Possibly_Unaligned_Object;
4952 ---------------------------------
4953 -- Is_Possibly_Unaligned_Slice --
4954 ---------------------------------
4956 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
4958 -- Go to renamed object
4960 if Is_Entity_Name (N)
4961 and then Is_Object (Entity (N))
4962 and then Present (Renamed_Object (Entity (N)))
4964 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
4967 -- The reference must be a slice
4969 if Nkind (N) /= N_Slice then
4973 -- Always assume the worst for a nested record component with a
4974 -- component clause, which gigi/gcc does not appear to handle well.
4975 -- It is not clear why this special test is needed at all ???
4977 if Nkind (Prefix (N)) = N_Selected_Component
4978 and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
4980 Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
4985 -- We only need to worry if the target has strict alignment
4987 if not Target_Strict_Alignment then
4991 -- If it is a slice, then look at the array type being sliced
4994 Sarr : constant Node_Id := Prefix (N);
4995 -- Prefix of the slice, i.e. the array being sliced
4997 Styp : constant Entity_Id := Etype (Prefix (N));
4998 -- Type of the array being sliced
5004 -- The problems arise if the array object that is being sliced
5005 -- is a component of a record or array, and we cannot guarantee
5006 -- the alignment of the array within its containing object.
5008 -- To investigate this, we look at successive prefixes to see
5009 -- if we have a worrisome indexed or selected component.
5013 -- Case of array is part of an indexed component reference
5015 if Nkind (Pref) = N_Indexed_Component then
5016 Ptyp := Etype (Prefix (Pref));
5018 -- The only problematic case is when the array is packed, in
5019 -- which case we really know nothing about the alignment of
5020 -- individual components.
5022 if Is_Bit_Packed_Array (Ptyp) then
5026 -- Case of array is part of a selected component reference
5028 elsif Nkind (Pref) = N_Selected_Component then
5029 Ptyp := Etype (Prefix (Pref));
5031 -- We are definitely in trouble if the record in question
5032 -- has an alignment, and either we know this alignment is
5033 -- inconsistent with the alignment of the slice, or we don't
5034 -- know what the alignment of the slice should be.
5036 if Known_Alignment (Ptyp)
5037 and then (Unknown_Alignment (Styp)
5038 or else Alignment (Styp) > Alignment (Ptyp))
5043 -- We are in potential trouble if the record type is packed.
5044 -- We could special case when we know that the array is the
5045 -- first component, but that's not such a simple case ???
5047 if Is_Packed (Ptyp) then
5051 -- We are in trouble if there is a component clause, and
5052 -- either we do not know the alignment of the slice, or
5053 -- the alignment of the slice is inconsistent with the
5054 -- bit position specified by the component clause.
5057 Field : constant Entity_Id := Entity (Selector_Name (Pref));
5059 if Present (Component_Clause (Field))
5061 (Unknown_Alignment (Styp)
5063 (Component_Bit_Offset (Field) mod
5064 (System_Storage_Unit * Alignment (Styp))) /= 0)
5070 -- For cases other than selected or indexed components we know we
5071 -- are OK, since no issues arise over alignment.
5077 -- We processed an indexed component or selected component
5078 -- reference that looked safe, so keep checking prefixes.
5080 Pref := Prefix (Pref);
5083 end Is_Possibly_Unaligned_Slice;
5085 -------------------------------
5086 -- Is_Related_To_Func_Return --
5087 -------------------------------
5089 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
5090 Expr : constant Node_Id := Related_Expression (Id);
5094 and then Nkind (Expr) = N_Explicit_Dereference
5095 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
5096 end Is_Related_To_Func_Return;
5098 --------------------------------
5099 -- Is_Ref_To_Bit_Packed_Array --
5100 --------------------------------
5102 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
5107 if Is_Entity_Name (N)
5108 and then Is_Object (Entity (N))
5109 and then Present (Renamed_Object (Entity (N)))
5111 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
5114 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
5115 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
5118 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
5121 if Result and then Nkind (N) = N_Indexed_Component then
5122 Expr := First (Expressions (N));
5123 while Present (Expr) loop
5124 Force_Evaluation (Expr);
5134 end Is_Ref_To_Bit_Packed_Array;
5136 --------------------------------
5137 -- Is_Ref_To_Bit_Packed_Slice --
5138 --------------------------------
5140 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
5142 if Nkind (N) = N_Type_Conversion then
5143 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
5145 elsif Is_Entity_Name (N)
5146 and then Is_Object (Entity (N))
5147 and then Present (Renamed_Object (Entity (N)))
5149 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
5151 elsif Nkind (N) = N_Slice
5152 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
5156 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
5157 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
5162 end Is_Ref_To_Bit_Packed_Slice;
5164 -----------------------
5165 -- Is_Renamed_Object --
5166 -----------------------
5168 function Is_Renamed_Object (N : Node_Id) return Boolean is
5169 Pnod : constant Node_Id := Parent (N);
5170 Kind : constant Node_Kind := Nkind (Pnod);
5172 if Kind = N_Object_Renaming_Declaration then
5174 elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
5175 return Is_Renamed_Object (Pnod);
5179 end Is_Renamed_Object;
5181 --------------------------------------
5182 -- Is_Secondary_Stack_BIP_Func_Call --
5183 --------------------------------------
5185 function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
5186 Call : Node_Id := Expr;
5189 -- Build-in-place calls usually appear in 'reference format. Note that
5190 -- the accessibility check machinery may add an extra 'reference due to
5191 -- side effect removal.
5193 while Nkind (Call) = N_Reference loop
5194 Call := Prefix (Call);
5197 if Nkind_In (Call, N_Qualified_Expression,
5198 N_Unchecked_Type_Conversion)
5200 Call := Expression (Call);
5203 if Is_Build_In_Place_Function_Call (Call) then
5205 Access_Nam : Name_Id := No_Name;
5211 -- Examine all parameter associations of the function call
5213 Param := First (Parameter_Associations (Call));
5214 while Present (Param) loop
5215 if Nkind (Param) = N_Parameter_Association
5216 and then Nkind (Selector_Name (Param)) = N_Identifier
5218 Formal := Selector_Name (Param);
5219 Actual := Explicit_Actual_Parameter (Param);
5221 -- Construct the name of formal BIPalloc. It is much easier
5222 -- to extract the name of the function using an arbitrary
5223 -- formal's scope rather than the Name field of Call.
5225 if Access_Nam = No_Name
5226 and then Present (Entity (Formal))
5230 (Chars (Scope (Entity (Formal))),
5231 BIP_Formal_Suffix (BIP_Alloc_Form));
5234 -- A match for BIPalloc => 2 has been found
5236 if Chars (Formal) = Access_Nam
5237 and then Nkind (Actual) = N_Integer_Literal
5238 and then Intval (Actual) = Uint_2
5250 end Is_Secondary_Stack_BIP_Func_Call;
5252 -------------------------------------
5253 -- Is_Tag_To_Class_Wide_Conversion --
5254 -------------------------------------
5256 function Is_Tag_To_Class_Wide_Conversion
5257 (Obj_Id : Entity_Id) return Boolean
5259 Expr : constant Node_Id := Expression (Parent (Obj_Id));
5263 Is_Class_Wide_Type (Etype (Obj_Id))
5264 and then Present (Expr)
5265 and then Nkind (Expr) = N_Unchecked_Type_Conversion
5266 and then Etype (Expression (Expr)) = RTE (RE_Tag);
5267 end Is_Tag_To_Class_Wide_Conversion;
5269 ----------------------------
5270 -- Is_Untagged_Derivation --
5271 ----------------------------
5273 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
5275 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
5277 (Is_Private_Type (T) and then Present (Full_View (T))
5278 and then not Is_Tagged_Type (Full_View (T))
5279 and then Is_Derived_Type (Full_View (T))
5280 and then Etype (Full_View (T)) /= T);
5281 end Is_Untagged_Derivation;
5283 ---------------------------
5284 -- Is_Volatile_Reference --
5285 ---------------------------
5287 function Is_Volatile_Reference (N : Node_Id) return Boolean is
5289 -- Only source references are to be treated as volatile, internally
5290 -- generated stuff cannot have volatile external effects.
5292 if not Comes_From_Source (N) then
5295 -- Never true for reference to a type
5297 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
5300 -- True if object reference with volatile type
5302 elsif Is_Volatile_Object (N) then
5305 -- True if reference to volatile entity
5307 elsif Is_Entity_Name (N) then
5308 return Treat_As_Volatile (Entity (N));
5310 -- True for slice of volatile array
5312 elsif Nkind (N) = N_Slice then
5313 return Is_Volatile_Reference (Prefix (N));
5315 -- True if volatile component
5317 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
5318 if (Is_Entity_Name (Prefix (N))
5319 and then Has_Volatile_Components (Entity (Prefix (N))))
5320 or else (Present (Etype (Prefix (N)))
5321 and then Has_Volatile_Components (Etype (Prefix (N))))
5325 return Is_Volatile_Reference (Prefix (N));
5333 end Is_Volatile_Reference;
5335 --------------------------
5336 -- Is_VM_By_Copy_Actual --
5337 --------------------------
5339 function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean is
5341 return VM_Target /= No_VM
5342 and then (Nkind (N) = N_Slice
5344 (Nkind (N) = N_Identifier
5345 and then Present (Renamed_Object (Entity (N)))
5346 and then Nkind (Renamed_Object (Entity (N))) =
5348 end Is_VM_By_Copy_Actual;
5350 --------------------
5351 -- Kill_Dead_Code --
5352 --------------------
5354 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
5355 W : Boolean := Warn;
5356 -- Set False if warnings suppressed
5360 Remove_Warning_Messages (N);
5362 -- Generate warning if appropriate
5366 -- We suppress the warning if this code is under control of an
5367 -- if statement, whose condition is a simple identifier, and
5368 -- either we are in an instance, or warnings off is set for this
5369 -- identifier. The reason for killing it in the instance case is
5370 -- that it is common and reasonable for code to be deleted in
5371 -- instances for various reasons.
5373 if Nkind (Parent (N)) = N_If_Statement then
5375 C : constant Node_Id := Condition (Parent (N));
5377 if Nkind (C) = N_Identifier
5380 or else (Present (Entity (C))
5381 and then Has_Warnings_Off (Entity (C))))
5388 -- Generate warning if not suppressed
5392 ("?t?this code can never be executed and has been deleted!",
5397 -- Recurse into block statements and bodies to process declarations
5400 if Nkind (N) = N_Block_Statement
5401 or else Nkind (N) = N_Subprogram_Body
5402 or else Nkind (N) = N_Package_Body
5404 Kill_Dead_Code (Declarations (N), False);
5405 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
5407 if Nkind (N) = N_Subprogram_Body then
5408 Set_Is_Eliminated (Defining_Entity (N));
5411 elsif Nkind (N) = N_Package_Declaration then
5412 Kill_Dead_Code (Visible_Declarations (Specification (N)));
5413 Kill_Dead_Code (Private_Declarations (Specification (N)));
5415 -- ??? After this point, Delete_Tree has been called on all
5416 -- declarations in Specification (N), so references to entities
5417 -- therein look suspicious.
5420 E : Entity_Id := First_Entity (Defining_Entity (N));
5422 while Present (E) loop
5423 if Ekind (E) = E_Operator then
5424 Set_Is_Eliminated (E);
5431 -- Recurse into composite statement to kill individual statements in
5432 -- particular instantiations.
5434 elsif Nkind (N) = N_If_Statement then
5435 Kill_Dead_Code (Then_Statements (N));
5436 Kill_Dead_Code (Elsif_Parts (N));
5437 Kill_Dead_Code (Else_Statements (N));
5439 elsif Nkind (N) = N_Loop_Statement then
5440 Kill_Dead_Code (Statements (N));
5442 elsif Nkind (N) = N_Case_Statement then
5446 Alt := First (Alternatives (N));
5447 while Present (Alt) loop
5448 Kill_Dead_Code (Statements (Alt));
5453 elsif Nkind (N) = N_Case_Statement_Alternative then
5454 Kill_Dead_Code (Statements (N));
5456 -- Deal with dead instances caused by deleting instantiations
5458 elsif Nkind (N) in N_Generic_Instantiation then
5459 Remove_Dead_Instance (N);
5464 -- Case where argument is a list of nodes to be killed
5466 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
5471 if Is_Non_Empty_List (L) then
5473 while Present (N) loop
5474 Kill_Dead_Code (N, W);
5481 ------------------------
5482 -- Known_Non_Negative --
5483 ------------------------
5485 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
5487 if Is_OK_Static_Expression (Opnd) and then Expr_Value (Opnd) >= 0 then
5492 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
5495 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
5498 end Known_Non_Negative;
5500 --------------------
5501 -- Known_Non_Null --
5502 --------------------
5504 function Known_Non_Null (N : Node_Id) return Boolean is
5506 -- Checks for case where N is an entity reference
5508 if Is_Entity_Name (N) and then Present (Entity (N)) then
5510 E : constant Entity_Id := Entity (N);
5515 -- First check if we are in decisive conditional
5517 Get_Current_Value_Condition (N, Op, Val);
5519 if Known_Null (Val) then
5520 if Op = N_Op_Eq then
5522 elsif Op = N_Op_Ne then
5527 -- If OK to do replacement, test Is_Known_Non_Null flag
5529 if OK_To_Do_Constant_Replacement (E) then
5530 return Is_Known_Non_Null (E);
5532 -- Otherwise if not safe to do replacement, then say so
5539 -- True if access attribute
5541 elsif Nkind (N) = N_Attribute_Reference
5542 and then Nam_In (Attribute_Name (N), Name_Access,
5543 Name_Unchecked_Access,
5544 Name_Unrestricted_Access)
5548 -- True if allocator
5550 elsif Nkind (N) = N_Allocator then
5553 -- For a conversion, true if expression is known non-null
5555 elsif Nkind (N) = N_Type_Conversion then
5556 return Known_Non_Null (Expression (N));
5558 -- Above are all cases where the value could be determined to be
5559 -- non-null. In all other cases, we don't know, so return False.
5570 function Known_Null (N : Node_Id) return Boolean is
5572 -- Checks for case where N is an entity reference
5574 if Is_Entity_Name (N) and then Present (Entity (N)) then
5576 E : constant Entity_Id := Entity (N);
5581 -- Constant null value is for sure null
5583 if Ekind (E) = E_Constant
5584 and then Known_Null (Constant_Value (E))
5589 -- First check if we are in decisive conditional
5591 Get_Current_Value_Condition (N, Op, Val);
5593 if Known_Null (Val) then
5594 if Op = N_Op_Eq then
5596 elsif Op = N_Op_Ne then
5601 -- If OK to do replacement, test Is_Known_Null flag
5603 if OK_To_Do_Constant_Replacement (E) then
5604 return Is_Known_Null (E);
5606 -- Otherwise if not safe to do replacement, then say so
5613 -- True if explicit reference to null
5615 elsif Nkind (N) = N_Null then
5618 -- For a conversion, true if expression is known null
5620 elsif Nkind (N) = N_Type_Conversion then
5621 return Known_Null (Expression (N));
5623 -- Above are all cases where the value could be determined to be null.
5624 -- In all other cases, we don't know, so return False.
5631 -----------------------------
5632 -- Make_CW_Equivalent_Type --
5633 -----------------------------
5635 -- Create a record type used as an equivalent of any member of the class
5636 -- which takes its size from exp.
5638 -- Generate the following code:
5640 -- type Equiv_T is record
5641 -- _parent : T (List of discriminant constraints taken from Exp);
5642 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
5645 -- ??? Note that this type does not guarantee same alignment as all
5648 function Make_CW_Equivalent_Type
5650 E : Node_Id) return Entity_Id
5652 Loc : constant Source_Ptr := Sloc (E);
5653 Root_Typ : constant Entity_Id := Root_Type (T);
5654 List_Def : constant List_Id := Empty_List;
5655 Comp_List : constant List_Id := New_List;
5656 Equiv_Type : Entity_Id;
5657 Range_Type : Entity_Id;
5658 Str_Type : Entity_Id;
5659 Constr_Root : Entity_Id;
5663 -- If the root type is already constrained, there are no discriminants
5664 -- in the expression.
5666 if not Has_Discriminants (Root_Typ)
5667 or else Is_Constrained (Root_Typ)
5669 Constr_Root := Root_Typ;
5671 Constr_Root := Make_Temporary (Loc, 'R');
5673 -- subtype cstr__n is T (List of discr constraints taken from Exp)
5675 Append_To (List_Def,
5676 Make_Subtype_Declaration (Loc,
5677 Defining_Identifier => Constr_Root,
5678 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
5681 -- Generate the range subtype declaration
5683 Range_Type := Make_Temporary (Loc, 'G');
5685 if not Is_Interface (Root_Typ) then
5687 -- subtype rg__xx is
5688 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
5691 Make_Op_Subtract (Loc,
5693 Make_Attribute_Reference (Loc,
5695 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
5696 Attribute_Name => Name_Size),
5698 Make_Attribute_Reference (Loc,
5699 Prefix => New_Occurrence_Of (Constr_Root, Loc),
5700 Attribute_Name => Name_Object_Size));
5702 -- subtype rg__xx is
5703 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
5706 Make_Attribute_Reference (Loc,
5708 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
5709 Attribute_Name => Name_Size);
5712 Set_Paren_Count (Sizexpr, 1);
5714 Append_To (List_Def,
5715 Make_Subtype_Declaration (Loc,
5716 Defining_Identifier => Range_Type,
5717 Subtype_Indication =>
5718 Make_Subtype_Indication (Loc,
5719 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
5720 Constraint => Make_Range_Constraint (Loc,
5723 Low_Bound => Make_Integer_Literal (Loc, 1),
5725 Make_Op_Divide (Loc,
5726 Left_Opnd => Sizexpr,
5727 Right_Opnd => Make_Integer_Literal (Loc,
5728 Intval => System_Storage_Unit)))))));
5730 -- subtype str__nn is Storage_Array (rg__x);
5732 Str_Type := Make_Temporary (Loc, 'S');
5733 Append_To (List_Def,
5734 Make_Subtype_Declaration (Loc,
5735 Defining_Identifier => Str_Type,
5736 Subtype_Indication =>
5737 Make_Subtype_Indication (Loc,
5738 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
5740 Make_Index_Or_Discriminant_Constraint (Loc,
5742 New_List (New_Occurrence_Of (Range_Type, Loc))))));
5744 -- type Equiv_T is record
5745 -- [ _parent : Tnn; ]
5749 Equiv_Type := Make_Temporary (Loc, 'T');
5750 Set_Ekind (Equiv_Type, E_Record_Type);
5751 Set_Parent_Subtype (Equiv_Type, Constr_Root);
5753 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
5754 -- treatment for this type. In particular, even though _parent's type
5755 -- is a controlled type or contains controlled components, we do not
5756 -- want to set Has_Controlled_Component on it to avoid making it gain
5757 -- an unwanted _controller component.
5759 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
5761 if not Is_Interface (Root_Typ) then
5762 Append_To (Comp_List,
5763 Make_Component_Declaration (Loc,
5764 Defining_Identifier =>
5765 Make_Defining_Identifier (Loc, Name_uParent),
5766 Component_Definition =>
5767 Make_Component_Definition (Loc,
5768 Aliased_Present => False,
5769 Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc))));
5772 Append_To (Comp_List,
5773 Make_Component_Declaration (Loc,
5774 Defining_Identifier => Make_Temporary (Loc, 'C'),
5775 Component_Definition =>
5776 Make_Component_Definition (Loc,
5777 Aliased_Present => False,
5778 Subtype_Indication => New_Occurrence_Of (Str_Type, Loc))));
5780 Append_To (List_Def,
5781 Make_Full_Type_Declaration (Loc,
5782 Defining_Identifier => Equiv_Type,
5784 Make_Record_Definition (Loc,
5786 Make_Component_List (Loc,
5787 Component_Items => Comp_List,
5788 Variant_Part => Empty))));
5790 -- Suppress all checks during the analysis of the expanded code to avoid
5791 -- the generation of spurious warnings under ZFP run-time.
5793 Insert_Actions (E, List_Def, Suppress => All_Checks);
5795 end Make_CW_Equivalent_Type;
5797 -------------------------
5798 -- Make_Invariant_Call --
5799 -------------------------
5801 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
5802 Loc : constant Source_Ptr := Sloc (Expr);
5806 Typ := Etype (Expr);
5808 -- Subtypes may be subject to invariants coming from their respective
5809 -- base types. The subtype may be fully or partially private.
5811 if Ekind_In (Typ, E_Array_Subtype,
5814 E_Record_Subtype_With_Private)
5816 Typ := Base_Type (Typ);
5820 (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
5823 Make_Procedure_Call_Statement (Loc,
5825 New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
5826 Parameter_Associations => New_List (Relocate_Node (Expr)));
5827 end Make_Invariant_Call;
5829 ------------------------
5830 -- Make_Literal_Range --
5831 ------------------------
5833 function Make_Literal_Range
5835 Literal_Typ : Entity_Id) return Node_Id
5837 Lo : constant Node_Id :=
5838 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
5839 Index : constant Entity_Id := Etype (Lo);
5842 Length_Expr : constant Node_Id :=
5843 Make_Op_Subtract (Loc,
5845 Make_Integer_Literal (Loc,
5846 Intval => String_Literal_Length (Literal_Typ)),
5848 Make_Integer_Literal (Loc, 1));
5851 Set_Analyzed (Lo, False);
5853 if Is_Integer_Type (Index) then
5856 Left_Opnd => New_Copy_Tree (Lo),
5857 Right_Opnd => Length_Expr);
5860 Make_Attribute_Reference (Loc,
5861 Attribute_Name => Name_Val,
5862 Prefix => New_Occurrence_Of (Index, Loc),
5863 Expressions => New_List (
5866 Make_Attribute_Reference (Loc,
5867 Attribute_Name => Name_Pos,
5868 Prefix => New_Occurrence_Of (Index, Loc),
5869 Expressions => New_List (New_Copy_Tree (Lo))),
5870 Right_Opnd => Length_Expr)));
5877 end Make_Literal_Range;
5879 --------------------------
5880 -- Make_Non_Empty_Check --
5881 --------------------------
5883 function Make_Non_Empty_Check
5885 N : Node_Id) return Node_Id
5891 Make_Attribute_Reference (Loc,
5892 Attribute_Name => Name_Length,
5893 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
5895 Make_Integer_Literal (Loc, 0));
5896 end Make_Non_Empty_Check;
5898 -------------------------
5899 -- Make_Predicate_Call --
5900 -------------------------
5902 function Make_Predicate_Call
5905 Mem : Boolean := False) return Node_Id
5907 Loc : constant Source_Ptr := Sloc (Expr);
5910 pragma Assert (Present (Predicate_Function (Typ)));
5912 -- Call special membership version if requested and available
5916 PFM : constant Entity_Id := Predicate_Function_M (Typ);
5918 if Present (PFM) then
5920 Make_Function_Call (Loc,
5921 Name => New_Occurrence_Of (PFM, Loc),
5922 Parameter_Associations => New_List (Relocate_Node (Expr)));
5927 -- Case of calling normal predicate function
5930 Make_Function_Call (Loc,
5932 New_Occurrence_Of (Predicate_Function (Typ), Loc),
5933 Parameter_Associations => New_List (Relocate_Node (Expr)));
5934 end Make_Predicate_Call;
5936 --------------------------
5937 -- Make_Predicate_Check --
5938 --------------------------
5940 function Make_Predicate_Check
5942 Expr : Node_Id) return Node_Id
5944 Loc : constant Source_Ptr := Sloc (Expr);
5948 -- If predicate checks are suppressed, then return a null statement.
5949 -- For this call, we check only the scope setting. If the caller wants
5950 -- to check a specific entity's setting, they must do it manually.
5952 if Predicate_Checks_Suppressed (Empty) then
5953 return Make_Null_Statement (Loc);
5956 -- Do not generate a check within an internal subprogram (stream
5957 -- functions and the like, including including predicate functions).
5959 if Within_Internal_Subprogram then
5960 return Make_Null_Statement (Loc);
5963 -- Compute proper name to use, we need to get this right so that the
5964 -- right set of check policies apply to the Check pragma we are making.
5966 if Has_Dynamic_Predicate_Aspect (Typ) then
5967 Nam := Name_Dynamic_Predicate;
5968 elsif Has_Static_Predicate_Aspect (Typ) then
5969 Nam := Name_Static_Predicate;
5971 Nam := Name_Predicate;
5976 Pragma_Identifier => Make_Identifier (Loc, Name_Check),
5977 Pragma_Argument_Associations => New_List (
5978 Make_Pragma_Argument_Association (Loc,
5979 Expression => Make_Identifier (Loc, Nam)),
5980 Make_Pragma_Argument_Association (Loc,
5981 Expression => Make_Predicate_Call (Typ, Expr))));
5982 end Make_Predicate_Check;
5984 ----------------------------
5985 -- Make_Subtype_From_Expr --
5986 ----------------------------
5988 -- 1. If Expr is an unconstrained array expression, creates
5989 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
5991 -- 2. If Expr is a unconstrained discriminated type expression, creates
5992 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
5994 -- 3. If Expr is class-wide, creates an implicit class wide subtype
5996 function Make_Subtype_From_Expr
5998 Unc_Typ : Entity_Id) return Node_Id
6000 Loc : constant Source_Ptr := Sloc (E);
6001 List_Constr : constant List_Id := New_List;
6004 Full_Subtyp : Entity_Id;
6005 Priv_Subtyp : Entity_Id;
6010 if Is_Private_Type (Unc_Typ)
6011 and then Has_Unknown_Discriminants (Unc_Typ)
6013 -- Prepare the subtype completion, Go to base type to
6014 -- find underlying type, because the type may be a generic
6015 -- actual or an explicit subtype.
6017 Utyp := Underlying_Type (Base_Type (Unc_Typ));
6018 Full_Subtyp := Make_Temporary (Loc, 'C');
6020 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
6021 Set_Parent (Full_Exp, Parent (E));
6023 Priv_Subtyp := Make_Temporary (Loc, 'P');
6026 Make_Subtype_Declaration (Loc,
6027 Defining_Identifier => Full_Subtyp,
6028 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
6030 -- Define the dummy private subtype
6032 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
6033 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
6034 Set_Scope (Priv_Subtyp, Full_Subtyp);
6035 Set_Is_Constrained (Priv_Subtyp);
6036 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
6037 Set_Is_Itype (Priv_Subtyp);
6038 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
6040 if Is_Tagged_Type (Priv_Subtyp) then
6042 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
6043 Set_Direct_Primitive_Operations (Priv_Subtyp,
6044 Direct_Primitive_Operations (Unc_Typ));
6047 Set_Full_View (Priv_Subtyp, Full_Subtyp);
6049 return New_Occurrence_Of (Priv_Subtyp, Loc);
6051 elsif Is_Array_Type (Unc_Typ) then
6052 for J in 1 .. Number_Dimensions (Unc_Typ) loop
6053 Append_To (List_Constr,
6056 Make_Attribute_Reference (Loc,
6057 Prefix => Duplicate_Subexpr_No_Checks (E),
6058 Attribute_Name => Name_First,
6059 Expressions => New_List (
6060 Make_Integer_Literal (Loc, J))),
6063 Make_Attribute_Reference (Loc,
6064 Prefix => Duplicate_Subexpr_No_Checks (E),
6065 Attribute_Name => Name_Last,
6066 Expressions => New_List (
6067 Make_Integer_Literal (Loc, J)))));
6070 elsif Is_Class_Wide_Type (Unc_Typ) then
6072 CW_Subtype : Entity_Id;
6073 EQ_Typ : Entity_Id := Empty;
6076 -- A class-wide equivalent type is not needed when VM_Target
6077 -- because the VM back-ends handle the class-wide object
6078 -- initialization itself (and doesn't need or want the
6079 -- additional intermediate type to handle the assignment).
6081 if Expander_Active and then Tagged_Type_Expansion then
6083 -- If this is the class_wide type of a completion that is a
6084 -- record subtype, set the type of the class_wide type to be
6085 -- the full base type, for use in the expanded code for the
6086 -- equivalent type. Should this be done earlier when the
6087 -- completion is analyzed ???
6089 if Is_Private_Type (Etype (Unc_Typ))
6091 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
6093 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
6096 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
6099 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
6100 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
6101 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
6103 return New_Occurrence_Of (CW_Subtype, Loc);
6106 -- Indefinite record type with discriminants
6109 D := First_Discriminant (Unc_Typ);
6110 while Present (D) loop
6111 Append_To (List_Constr,
6112 Make_Selected_Component (Loc,
6113 Prefix => Duplicate_Subexpr_No_Checks (E),
6114 Selector_Name => New_Occurrence_Of (D, Loc)));
6116 Next_Discriminant (D);
6121 Make_Subtype_Indication (Loc,
6122 Subtype_Mark => New_Occurrence_Of (Unc_Typ, Loc),
6124 Make_Index_Or_Discriminant_Constraint (Loc,
6125 Constraints => List_Constr));
6126 end Make_Subtype_From_Expr;
6128 ----------------------------
6129 -- Matching_Standard_Type --
6130 ----------------------------
6132 function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is
6133 pragma Assert (Is_Scalar_Type (Typ));
6134 Siz : constant Uint := Esize (Typ);
6137 -- Floating-point cases
6139 if Is_Floating_Point_Type (Typ) then
6140 if Siz <= Esize (Standard_Short_Float) then
6141 return Standard_Short_Float;
6142 elsif Siz <= Esize (Standard_Float) then
6143 return Standard_Float;
6144 elsif Siz <= Esize (Standard_Long_Float) then
6145 return Standard_Long_Float;
6146 elsif Siz <= Esize (Standard_Long_Long_Float) then
6147 return Standard_Long_Long_Float;
6149 raise Program_Error;
6152 -- Integer cases (includes fixed-point types)
6154 -- Unsigned integer cases (includes normal enumeration types)
6156 elsif Is_Unsigned_Type (Typ) then
6157 if Siz <= Esize (Standard_Short_Short_Unsigned) then
6158 return Standard_Short_Short_Unsigned;
6159 elsif Siz <= Esize (Standard_Short_Unsigned) then
6160 return Standard_Short_Unsigned;
6161 elsif Siz <= Esize (Standard_Unsigned) then
6162 return Standard_Unsigned;
6163 elsif Siz <= Esize (Standard_Long_Unsigned) then
6164 return Standard_Long_Unsigned;
6165 elsif Siz <= Esize (Standard_Long_Long_Unsigned) then
6166 return Standard_Long_Long_Unsigned;
6168 raise Program_Error;
6171 -- Signed integer cases
6174 if Siz <= Esize (Standard_Short_Short_Integer) then
6175 return Standard_Short_Short_Integer;
6176 elsif Siz <= Esize (Standard_Short_Integer) then
6177 return Standard_Short_Integer;
6178 elsif Siz <= Esize (Standard_Integer) then
6179 return Standard_Integer;
6180 elsif Siz <= Esize (Standard_Long_Integer) then
6181 return Standard_Long_Integer;
6182 elsif Siz <= Esize (Standard_Long_Long_Integer) then
6183 return Standard_Long_Long_Integer;
6185 raise Program_Error;
6188 end Matching_Standard_Type;
6190 -----------------------------
6191 -- May_Generate_Large_Temp --
6192 -----------------------------
6194 -- At the current time, the only types that we return False for (i.e. where
6195 -- we decide we know they cannot generate large temps) are ones where we
6196 -- know the size is 256 bits or less at compile time, and we are still not
6197 -- doing a thorough job on arrays and records ???
6199 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
6201 if not Size_Known_At_Compile_Time (Typ) then
6204 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
6207 elsif Is_Array_Type (Typ) and then Present (Packed_Array_Type (Typ)) then
6208 return May_Generate_Large_Temp (Packed_Array_Type (Typ));
6210 -- We could do more here to find other small types ???
6215 end May_Generate_Large_Temp;
6217 ------------------------
6218 -- Needs_Finalization --
6219 ------------------------
6221 function Needs_Finalization (T : Entity_Id) return Boolean is
6222 function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
6223 -- If type is not frozen yet, check explicitly among its components,
6224 -- because the Has_Controlled_Component flag is not necessarily set.
6226 -----------------------------------
6227 -- Has_Some_Controlled_Component --
6228 -----------------------------------
6230 function Has_Some_Controlled_Component
6231 (Rec : Entity_Id) return Boolean
6236 if Has_Controlled_Component (Rec) then
6239 elsif not Is_Frozen (Rec) then
6240 if Is_Record_Type (Rec) then
6241 Comp := First_Entity (Rec);
6243 while Present (Comp) loop
6244 if not Is_Type (Comp)
6245 and then Needs_Finalization (Etype (Comp))
6255 elsif Is_Array_Type (Rec) then
6256 return Needs_Finalization (Component_Type (Rec));
6259 return Has_Controlled_Component (Rec);
6264 end Has_Some_Controlled_Component;
6266 -- Start of processing for Needs_Finalization
6269 -- Certain run-time configurations and targets do not provide support
6270 -- for controlled types.
6272 if Restriction_Active (No_Finalization) then
6275 -- C, C++, CIL and Java types are not considered controlled. It is
6276 -- assumed that the non-Ada side will handle their clean up.
6278 elsif Convention (T) = Convention_C
6279 or else Convention (T) = Convention_CIL
6280 or else Convention (T) = Convention_CPP
6281 or else Convention (T) = Convention_Java
6286 -- Class-wide types are treated as controlled because derivations
6287 -- from the root type can introduce controlled components.
6290 Is_Class_Wide_Type (T)
6291 or else Is_Controlled (T)
6292 or else Has_Controlled_Component (T)
6293 or else Has_Some_Controlled_Component (T)
6295 (Is_Concurrent_Type (T)
6296 and then Present (Corresponding_Record_Type (T))
6297 and then Needs_Finalization (Corresponding_Record_Type (T)));
6299 end Needs_Finalization;
6301 ----------------------------
6302 -- Needs_Constant_Address --
6303 ----------------------------
6305 function Needs_Constant_Address
6307 Typ : Entity_Id) return Boolean
6311 -- If we have no initialization of any kind, then we don't need to place
6312 -- any restrictions on the address clause, because the object will be
6313 -- elaborated after the address clause is evaluated. This happens if the
6314 -- declaration has no initial expression, or the type has no implicit
6315 -- initialization, or the object is imported.
6317 -- The same holds for all initialized scalar types and all access types.
6318 -- Packed bit arrays of size up to 64 are represented using a modular
6319 -- type with an initialization (to zero) and can be processed like other
6320 -- initialized scalar types.
6322 -- If the type is controlled, code to attach the object to a
6323 -- finalization chain is generated at the point of declaration, and
6324 -- therefore the elaboration of the object cannot be delayed: the
6325 -- address expression must be a constant.
6327 if No (Expression (Decl))
6328 and then not Needs_Finalization (Typ)
6330 (not Has_Non_Null_Base_Init_Proc (Typ)
6331 or else Is_Imported (Defining_Identifier (Decl)))
6335 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
6336 or else Is_Access_Type (Typ)
6338 (Is_Bit_Packed_Array (Typ)
6339 and then Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
6345 -- Otherwise, we require the address clause to be constant because
6346 -- the call to the initialization procedure (or the attach code) has
6347 -- to happen at the point of the declaration.
6349 -- Actually the IP call has been moved to the freeze actions anyway,
6350 -- so maybe we can relax this restriction???
6354 end Needs_Constant_Address;
6356 ----------------------------
6357 -- New_Class_Wide_Subtype --
6358 ----------------------------
6360 function New_Class_Wide_Subtype
6361 (CW_Typ : Entity_Id;
6362 N : Node_Id) return Entity_Id
6364 Res : constant Entity_Id := Create_Itype (E_Void, N);
6365 Res_Name : constant Name_Id := Chars (Res);
6366 Res_Scope : constant Entity_Id := Scope (Res);
6369 Copy_Node (CW_Typ, Res);
6370 Set_Comes_From_Source (Res, False);
6371 Set_Sloc (Res, Sloc (N));
6373 Set_Associated_Node_For_Itype (Res, N);
6374 Set_Is_Public (Res, False); -- By default, may be changed below.
6375 Set_Public_Status (Res);
6376 Set_Chars (Res, Res_Name);
6377 Set_Scope (Res, Res_Scope);
6378 Set_Ekind (Res, E_Class_Wide_Subtype);
6379 Set_Next_Entity (Res, Empty);
6380 Set_Etype (Res, Base_Type (CW_Typ));
6381 Set_Is_Frozen (Res, False);
6382 Set_Freeze_Node (Res, Empty);
6384 end New_Class_Wide_Subtype;
6386 --------------------------------
6387 -- Non_Limited_Designated_Type --
6388 ---------------------------------
6390 function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
6391 Desig : constant Entity_Id := Designated_Type (T);
6393 if Ekind (Desig) = E_Incomplete_Type
6394 and then Present (Non_Limited_View (Desig))
6396 return Non_Limited_View (Desig);
6400 end Non_Limited_Designated_Type;
6402 -----------------------------------
6403 -- OK_To_Do_Constant_Replacement --
6404 -----------------------------------
6406 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
6407 ES : constant Entity_Id := Scope (E);
6411 -- Do not replace statically allocated objects, because they may be
6412 -- modified outside the current scope.
6414 if Is_Statically_Allocated (E) then
6417 -- Do not replace aliased or volatile objects, since we don't know what
6418 -- else might change the value.
6420 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
6423 -- Debug flag -gnatdM disconnects this optimization
6425 elsif Debug_Flag_MM then
6428 -- Otherwise check scopes
6431 CS := Current_Scope;
6434 -- If we are in right scope, replacement is safe
6439 -- Packages do not affect the determination of safety
6441 elsif Ekind (CS) = E_Package then
6442 exit when CS = Standard_Standard;
6445 -- Blocks do not affect the determination of safety
6447 elsif Ekind (CS) = E_Block then
6450 -- Loops do not affect the determination of safety. Note that we
6451 -- kill all current values on entry to a loop, so we are just
6452 -- talking about processing within a loop here.
6454 elsif Ekind (CS) = E_Loop then
6457 -- Otherwise, the reference is dubious, and we cannot be sure that
6458 -- it is safe to do the replacement.
6467 end OK_To_Do_Constant_Replacement;
6469 ------------------------------------
6470 -- Possible_Bit_Aligned_Component --
6471 ------------------------------------
6473 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
6477 -- Case of indexed component
6479 when N_Indexed_Component =>
6481 P : constant Node_Id := Prefix (N);
6482 Ptyp : constant Entity_Id := Etype (P);
6485 -- If we know the component size and it is less than 64, then
6486 -- we are definitely OK. The back end always does assignment of
6487 -- misaligned small objects correctly.
6489 if Known_Static_Component_Size (Ptyp)
6490 and then Component_Size (Ptyp) <= 64
6494 -- Otherwise, we need to test the prefix, to see if we are
6495 -- indexing from a possibly unaligned component.
6498 return Possible_Bit_Aligned_Component (P);
6502 -- Case of selected component
6504 when N_Selected_Component =>
6506 P : constant Node_Id := Prefix (N);
6507 Comp : constant Entity_Id := Entity (Selector_Name (N));
6510 -- If there is no component clause, then we are in the clear
6511 -- since the back end will never misalign a large component
6512 -- unless it is forced to do so. In the clear means we need
6513 -- only the recursive test on the prefix.
6515 if Component_May_Be_Bit_Aligned (Comp) then
6518 return Possible_Bit_Aligned_Component (P);
6522 -- For a slice, test the prefix, if that is possibly misaligned,
6523 -- then for sure the slice is.
6526 return Possible_Bit_Aligned_Component (Prefix (N));
6528 -- For an unchecked conversion, check whether the expression may
6531 when N_Unchecked_Type_Conversion =>
6532 return Possible_Bit_Aligned_Component (Expression (N));
6534 -- If we have none of the above, it means that we have fallen off the
6535 -- top testing prefixes recursively, and we now have a stand alone
6536 -- object, where we don't have a problem.
6542 end Possible_Bit_Aligned_Component;
6544 -----------------------------------------------
6545 -- Process_Statements_For_Controlled_Objects --
6546 -----------------------------------------------
6548 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
6549 Loc : constant Source_Ptr := Sloc (N);
6551 function Are_Wrapped (L : List_Id) return Boolean;
6552 -- Determine whether list L contains only one statement which is a block
6554 function Wrap_Statements_In_Block
6556 Scop : Entity_Id := Current_Scope) return Node_Id;
6557 -- Given a list of statements L, wrap it in a block statement and return
6558 -- the generated node. Scop is either the current scope or the scope of
6559 -- the context (if applicable).
6565 function Are_Wrapped (L : List_Id) return Boolean is
6566 Stmt : constant Node_Id := First (L);
6570 and then No (Next (Stmt))
6571 and then Nkind (Stmt) = N_Block_Statement;
6574 ------------------------------
6575 -- Wrap_Statements_In_Block --
6576 ------------------------------
6578 function Wrap_Statements_In_Block
6580 Scop : Entity_Id := Current_Scope) return Node_Id
6582 Block_Id : Entity_Id;
6583 Block_Nod : Node_Id;
6584 Iter_Loop : Entity_Id;
6588 Make_Block_Statement (Loc,
6589 Declarations => No_List,
6590 Handled_Statement_Sequence =>
6591 Make_Handled_Sequence_Of_Statements (Loc,
6594 -- Create a label for the block in case the block needs to manage the
6595 -- secondary stack. A label allows for flag Uses_Sec_Stack to be set.
6597 Add_Block_Identifier (Block_Nod, Block_Id);
6599 -- When wrapping the statements of an iterator loop, check whether
6600 -- the loop requires secondary stack management and if so, propagate
6601 -- the flag to the block. This way the secondary stack is marked and
6602 -- released at each iteration of the loop.
6604 Iter_Loop := Find_Enclosing_Iterator_Loop (Scop);
6606 if Present (Iter_Loop) and then Uses_Sec_Stack (Iter_Loop) then
6607 Set_Uses_Sec_Stack (Block_Id);
6611 end Wrap_Statements_In_Block;
6617 -- Start of processing for Process_Statements_For_Controlled_Objects
6620 -- Whenever a non-handled statement list is wrapped in a block, the
6621 -- block must be explicitly analyzed to redecorate all entities in the
6622 -- list and ensure that a finalizer is properly built.
6627 N_Conditional_Entry_Call |
6628 N_Selective_Accept =>
6630 -- Check the "then statements" for elsif parts and if statements
6632 if Nkind_In (N, N_Elsif_Part, N_If_Statement)
6633 and then not Is_Empty_List (Then_Statements (N))
6634 and then not Are_Wrapped (Then_Statements (N))
6635 and then Requires_Cleanup_Actions
6636 (Then_Statements (N), False, False)
6638 Block := Wrap_Statements_In_Block (Then_Statements (N));
6639 Set_Then_Statements (N, New_List (Block));
6644 -- Check the "else statements" for conditional entry calls, if
6645 -- statements and selective accepts.
6647 if Nkind_In (N, N_Conditional_Entry_Call,
6650 and then not Is_Empty_List (Else_Statements (N))
6651 and then not Are_Wrapped (Else_Statements (N))
6652 and then Requires_Cleanup_Actions
6653 (Else_Statements (N), False, False)
6655 Block := Wrap_Statements_In_Block (Else_Statements (N));
6656 Set_Else_Statements (N, New_List (Block));
6661 when N_Abortable_Part |
6662 N_Accept_Alternative |
6663 N_Case_Statement_Alternative |
6664 N_Delay_Alternative |
6665 N_Entry_Call_Alternative |
6666 N_Exception_Handler |
6668 N_Triggering_Alternative =>
6670 if not Is_Empty_List (Statements (N))
6671 and then not Are_Wrapped (Statements (N))
6672 and then Requires_Cleanup_Actions (Statements (N), False, False)
6674 if Nkind (N) = N_Loop_Statement
6675 and then Present (Identifier (N))
6678 Wrap_Statements_In_Block
6679 (L => Statements (N),
6680 Scop => Entity (Identifier (N)));
6682 Block := Wrap_Statements_In_Block (Statements (N));
6685 Set_Statements (N, New_List (Block));
6692 end Process_Statements_For_Controlled_Objects;
6698 function Power_Of_Two (N : Node_Id) return Nat is
6699 Typ : constant Entity_Id := Etype (N);
6700 pragma Assert (Is_Integer_Type (Typ));
6701 Siz : constant Nat := UI_To_Int (Esize (Typ));
6705 if not Compile_Time_Known_Value (N) then
6709 Val := Expr_Value (N);
6710 for J in 1 .. Siz - 1 loop
6711 if Val = Uint_2 ** J then
6720 ----------------------
6721 -- Remove_Init_Call --
6722 ----------------------
6724 function Remove_Init_Call
6726 Rep_Clause : Node_Id) return Node_Id
6728 Par : constant Node_Id := Parent (Var);
6729 Typ : constant Entity_Id := Etype (Var);
6731 Init_Proc : Entity_Id;
6732 -- Initialization procedure for Typ
6734 function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
6735 -- Look for init call for Var starting at From and scanning the
6736 -- enclosing list until Rep_Clause or the end of the list is reached.
6738 ----------------------------
6739 -- Find_Init_Call_In_List --
6740 ----------------------------
6742 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
6743 Init_Call : Node_Id;
6747 while Present (Init_Call) and then Init_Call /= Rep_Clause loop
6748 if Nkind (Init_Call) = N_Procedure_Call_Statement
6749 and then Is_Entity_Name (Name (Init_Call))
6750 and then Entity (Name (Init_Call)) = Init_Proc
6759 end Find_Init_Call_In_List;
6761 Init_Call : Node_Id;
6763 -- Start of processing for Find_Init_Call
6766 if Present (Initialization_Statements (Var)) then
6767 Init_Call := Initialization_Statements (Var);
6768 Set_Initialization_Statements (Var, Empty);
6770 elsif not Has_Non_Null_Base_Init_Proc (Typ) then
6772 -- No init proc for the type, so obviously no call to be found
6777 -- We might be able to handle other cases below by just properly
6778 -- setting Initialization_Statements at the point where the init proc
6779 -- call is generated???
6781 Init_Proc := Base_Init_Proc (Typ);
6783 -- First scan the list containing the declaration of Var
6785 Init_Call := Find_Init_Call_In_List (From => Next (Par));
6787 -- If not found, also look on Var's freeze actions list, if any,
6788 -- since the init call may have been moved there (case of an address
6789 -- clause applying to Var).
6791 if No (Init_Call) and then Present (Freeze_Node (Var)) then
6793 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
6796 -- If the initialization call has actuals that use the secondary
6797 -- stack, the call may have been wrapped into a temporary block, in
6798 -- which case the block itself has to be removed.
6800 if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then
6802 Blk : constant Node_Id := Next (Par);
6805 (Find_Init_Call_In_List
6806 (First (Statements (Handled_Statement_Sequence (Blk)))))
6814 if Present (Init_Call) then
6818 end Remove_Init_Call;
6820 -------------------------
6821 -- Remove_Side_Effects --
6822 -------------------------
6824 procedure Remove_Side_Effects
6826 Name_Req : Boolean := False;
6827 Variable_Ref : Boolean := False)
6829 Loc : constant Source_Ptr := Sloc (Exp);
6830 Exp_Type : constant Entity_Id := Etype (Exp);
6831 Svg_Suppress : constant Suppress_Record := Scope_Suppress;
6835 Ptr_Typ_Decl : Node_Id;
6836 Ref_Type : Entity_Id;
6840 -- Handle cases in which there is nothing to do. In GNATprove mode,
6841 -- removal of side effects is useful for the light expansion of
6842 -- renamings. This removal should only occur when not inside a
6843 -- generic and not doing a pre-analysis.
6845 if not Expander_Active
6846 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
6851 -- Cannot generate temporaries if the invocation to remove side effects
6852 -- was issued too early and the type of the expression is not resolved
6853 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
6854 -- Remove_Side_Effects).
6856 if No (Exp_Type) or else Ekind (Exp_Type) = E_Access_Attribute_Type then
6859 -- No action needed for side-effect free expressions
6861 elsif Side_Effect_Free (Exp, Name_Req, Variable_Ref) then
6865 -- The remaining procesaing is done with all checks suppressed
6867 -- Note: from now on, don't use return statements, instead do a goto
6868 -- Leave, to ensure that we properly restore Scope_Suppress.Suppress.
6870 Scope_Suppress.Suppress := (others => True);
6872 -- If it is a scalar type and we need to capture the value, just make
6873 -- a copy. Likewise for a function call, an attribute reference, a
6874 -- conditional expression, an allocator, or an operator. And if we have
6875 -- a volatile reference and Name_Req is not set (see comments for
6876 -- Side_Effect_Free).
6878 if Is_Elementary_Type (Exp_Type)
6880 -- Note: this test is rather mysterious??? Why can't we just test ONLY
6881 -- Is_Elementary_Type and be done with it. If we try that approach, we
6882 -- get some failures (infinite recursions) from the Duplicate_Subexpr
6883 -- call at the end of Checks.Apply_Predicate_Check. To be
6886 and then (Variable_Ref
6887 or else Nkind_In (Exp, N_Attribute_Reference,
6892 or else Nkind (Exp) in N_Op
6893 or else (not Name_Req
6894 and then Is_Volatile_Reference (Exp)))
6896 Def_Id := Make_Temporary (Loc, 'R', Exp);
6897 Set_Etype (Def_Id, Exp_Type);
6898 Res := New_Occurrence_Of (Def_Id, Loc);
6900 -- If the expression is a packed reference, it must be reanalyzed and
6901 -- expanded, depending on context. This is the case for actuals where
6902 -- a constraint check may capture the actual before expansion of the
6903 -- call is complete.
6905 if Nkind (Exp) = N_Indexed_Component
6906 and then Is_Packed (Etype (Prefix (Exp)))
6908 Set_Analyzed (Exp, False);
6909 Set_Analyzed (Prefix (Exp), False);
6913 Make_Object_Declaration (Loc,
6914 Defining_Identifier => Def_Id,
6915 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
6916 Constant_Present => True,
6917 Expression => Relocate_Node (Exp));
6919 Set_Assignment_OK (E);
6920 Insert_Action (Exp, E);
6922 -- If the expression has the form v.all then we can just capture the
6923 -- pointer, and then do an explicit dereference on the result, but
6924 -- this is not right if this is a volatile reference.
6926 elsif Nkind (Exp) = N_Explicit_Dereference
6927 and then not Is_Volatile_Reference (Exp)
6929 Def_Id := Make_Temporary (Loc, 'R', Exp);
6931 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Def_Id, Loc));
6934 Make_Object_Declaration (Loc,
6935 Defining_Identifier => Def_Id,
6936 Object_Definition =>
6937 New_Occurrence_Of (Etype (Prefix (Exp)), Loc),
6938 Constant_Present => True,
6939 Expression => Relocate_Node (Prefix (Exp))));
6941 -- Similar processing for an unchecked conversion of an expression of
6942 -- the form v.all, where we want the same kind of treatment.
6944 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
6945 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
6947 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
6950 -- If this is a type conversion, leave the type conversion and remove
6951 -- the side effects in the expression. This is important in several
6952 -- circumstances: for change of representations, and also when this is a
6953 -- view conversion to a smaller object, where gigi can end up creating
6954 -- its own temporary of the wrong size.
6956 elsif Nkind (Exp) = N_Type_Conversion then
6957 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
6960 -- If this is an unchecked conversion that Gigi can't handle, make
6961 -- a copy or a use a renaming to capture the value.
6963 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
6964 and then not Safe_Unchecked_Type_Conversion (Exp)
6966 if CW_Or_Has_Controlled_Part (Exp_Type) then
6968 -- Use a renaming to capture the expression, rather than create
6969 -- a controlled temporary.
6971 Def_Id := Make_Temporary (Loc, 'R', Exp);
6972 Res := New_Occurrence_Of (Def_Id, Loc);
6975 Make_Object_Renaming_Declaration (Loc,
6976 Defining_Identifier => Def_Id,
6977 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
6978 Name => Relocate_Node (Exp)));
6981 Def_Id := Make_Temporary (Loc, 'R', Exp);
6982 Set_Etype (Def_Id, Exp_Type);
6983 Res := New_Occurrence_Of (Def_Id, Loc);
6986 Make_Object_Declaration (Loc,
6987 Defining_Identifier => Def_Id,
6988 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
6989 Constant_Present => not Is_Variable (Exp),
6990 Expression => Relocate_Node (Exp));
6992 Set_Assignment_OK (E);
6993 Insert_Action (Exp, E);
6996 -- For expressions that denote objects, we can use a renaming scheme.
6997 -- This is needed for correctness in the case of a volatile object of
6998 -- a non-volatile type because the Make_Reference call of the "default"
6999 -- approach would generate an illegal access value (an access value
7000 -- cannot designate such an object - see Analyze_Reference).
7002 elsif Is_Object_Reference (Exp)
7003 and then Nkind (Exp) /= N_Function_Call
7005 -- In Ada 2012 a qualified expression is an object, but for purposes
7006 -- of removing side effects it still need to be transformed into a
7007 -- separate declaration, particularly in the case of an aggregate.
7009 and then Nkind (Exp) /= N_Qualified_Expression
7011 -- We skip using this scheme if we have an object of a volatile
7012 -- type and we do not have Name_Req set true (see comments for
7013 -- Side_Effect_Free).
7015 and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
7017 Def_Id := Make_Temporary (Loc, 'R', Exp);
7019 if Nkind (Exp) = N_Selected_Component
7020 and then Nkind (Prefix (Exp)) = N_Function_Call
7021 and then Is_Array_Type (Exp_Type)
7023 -- Avoid generating a variable-sized temporary, by generating
7024 -- the renaming declaration just for the function call. The
7025 -- transformation could be refined to apply only when the array
7026 -- component is constrained by a discriminant???
7029 Make_Selected_Component (Loc,
7030 Prefix => New_Occurrence_Of (Def_Id, Loc),
7031 Selector_Name => Selector_Name (Exp));
7034 Make_Object_Renaming_Declaration (Loc,
7035 Defining_Identifier => Def_Id,
7037 New_Occurrence_Of (Base_Type (Etype (Prefix (Exp))), Loc),
7038 Name => Relocate_Node (Prefix (Exp))));
7041 Res := New_Occurrence_Of (Def_Id, Loc);
7044 Make_Object_Renaming_Declaration (Loc,
7045 Defining_Identifier => Def_Id,
7046 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
7047 Name => Relocate_Node (Exp)));
7050 -- If this is a packed reference, or a selected component with
7051 -- a non-standard representation, a reference to the temporary
7052 -- will be replaced by a copy of the original expression (see
7053 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
7054 -- elaborated by gigi, and is of course not to be replaced in-line
7055 -- by the expression it renames, which would defeat the purpose of
7056 -- removing the side-effect.
7058 if Nkind_In (Exp, N_Selected_Component, N_Indexed_Component)
7059 and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
7063 Set_Is_Renaming_Of_Object (Def_Id, False);
7066 -- Otherwise we generate a reference to the value
7069 -- An expression which is in SPARK mode is considered side effect
7070 -- free if the resulting value is captured by a variable or a
7074 and then Nkind (Parent (Exp)) = N_Object_Declaration
7079 -- Special processing for function calls that return a limited type.
7080 -- We need to build a declaration that will enable build-in-place
7081 -- expansion of the call. This is not done if the context is already
7082 -- an object declaration, to prevent infinite recursion.
7084 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
7085 -- to accommodate functions returning limited objects by reference.
7087 if Ada_Version >= Ada_2005
7088 and then Nkind (Exp) = N_Function_Call
7089 and then Is_Limited_View (Etype (Exp))
7090 and then Nkind (Parent (Exp)) /= N_Object_Declaration
7093 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
7098 Make_Object_Declaration (Loc,
7099 Defining_Identifier => Obj,
7100 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
7101 Expression => Relocate_Node (Exp));
7103 Insert_Action (Exp, Decl);
7104 Set_Etype (Obj, Exp_Type);
7105 Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
7110 Def_Id := Make_Temporary (Loc, 'R', Exp);
7112 -- The regular expansion of functions with side effects involves the
7113 -- generation of an access type to capture the return value found on
7114 -- the secondary stack. Since SPARK (and why) cannot process access
7115 -- types, use a different approach which ignores the secondary stack
7116 -- and "copies" the returned object.
7118 if GNATprove_Mode then
7119 Res := New_Occurrence_Of (Def_Id, Loc);
7120 Ref_Type := Exp_Type;
7122 -- Regular expansion utilizing an access type and 'reference
7126 Make_Explicit_Dereference (Loc,
7127 Prefix => New_Occurrence_Of (Def_Id, Loc));
7130 -- type Ann is access all <Exp_Type>;
7132 Ref_Type := Make_Temporary (Loc, 'A');
7135 Make_Full_Type_Declaration (Loc,
7136 Defining_Identifier => Ref_Type,
7138 Make_Access_To_Object_Definition (Loc,
7139 All_Present => True,
7140 Subtype_Indication =>
7141 New_Occurrence_Of (Exp_Type, Loc)));
7143 Insert_Action (Exp, Ptr_Typ_Decl);
7147 if Nkind (E) = N_Explicit_Dereference then
7148 New_Exp := Relocate_Node (Prefix (E));
7151 E := Relocate_Node (E);
7153 -- Do not generate a 'reference in SPARK mode since the access
7154 -- type is not created in the first place.
7156 if GNATprove_Mode then
7159 -- Otherwise generate reference, marking the value as non-null
7160 -- since we know it cannot be null and we don't want a check.
7163 New_Exp := Make_Reference (Loc, E);
7164 Set_Is_Known_Non_Null (Def_Id);
7168 if Is_Delayed_Aggregate (E) then
7170 -- The expansion of nested aggregates is delayed until the
7171 -- enclosing aggregate is expanded. As aggregates are often
7172 -- qualified, the predicate applies to qualified expressions as
7173 -- well, indicating that the enclosing aggregate has not been
7174 -- expanded yet. At this point the aggregate is part of a
7175 -- stand-alone declaration, and must be fully expanded.
7177 if Nkind (E) = N_Qualified_Expression then
7178 Set_Expansion_Delayed (Expression (E), False);
7179 Set_Analyzed (Expression (E), False);
7181 Set_Expansion_Delayed (E, False);
7184 Set_Analyzed (E, False);
7188 Make_Object_Declaration (Loc,
7189 Defining_Identifier => Def_Id,
7190 Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
7191 Constant_Present => True,
7192 Expression => New_Exp));
7195 -- Preserve the Assignment_OK flag in all copies, since at least one
7196 -- copy may be used in a context where this flag must be set (otherwise
7197 -- why would the flag be set in the first place).
7199 Set_Assignment_OK (Res, Assignment_OK (Exp));
7201 -- Finally rewrite the original expression and we are done
7204 Analyze_And_Resolve (Exp, Exp_Type);
7207 Scope_Suppress := Svg_Suppress;
7208 end Remove_Side_Effects;
7210 ---------------------------
7211 -- Represented_As_Scalar --
7212 ---------------------------
7214 function Represented_As_Scalar (T : Entity_Id) return Boolean is
7215 UT : constant Entity_Id := Underlying_Type (T);
7217 return Is_Scalar_Type (UT)
7218 or else (Is_Bit_Packed_Array (UT)
7219 and then Is_Scalar_Type (Packed_Array_Type (UT)));
7220 end Represented_As_Scalar;
7222 ------------------------------
7223 -- Requires_Cleanup_Actions --
7224 ------------------------------
7226 function Requires_Cleanup_Actions
7228 Lib_Level : Boolean) return Boolean
7230 At_Lib_Level : constant Boolean :=
7232 and then Nkind_In (N, N_Package_Body,
7233 N_Package_Specification);
7234 -- N is at the library level if the top-most context is a package and
7235 -- the path taken to reach N does not inlcude non-package constructs.
7239 when N_Accept_Statement |
7247 Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True)
7249 (Present (Handled_Statement_Sequence (N))
7251 Requires_Cleanup_Actions
7252 (Statements (Handled_Statement_Sequence (N)),
7253 At_Lib_Level, True));
7255 when N_Package_Specification =>
7257 Requires_Cleanup_Actions
7258 (Visible_Declarations (N), At_Lib_Level, True)
7260 Requires_Cleanup_Actions
7261 (Private_Declarations (N), At_Lib_Level, True);
7266 end Requires_Cleanup_Actions;
7268 ------------------------------
7269 -- Requires_Cleanup_Actions --
7270 ------------------------------
7272 function Requires_Cleanup_Actions
7274 Lib_Level : Boolean;
7275 Nested_Constructs : Boolean) return Boolean
7280 Obj_Typ : Entity_Id;
7281 Pack_Id : Entity_Id;
7286 or else Is_Empty_List (L)
7292 while Present (Decl) loop
7294 -- Library-level tagged types
7296 if Nkind (Decl) = N_Full_Type_Declaration then
7297 Typ := Defining_Identifier (Decl);
7299 if Is_Tagged_Type (Typ)
7300 and then Is_Library_Level_Entity (Typ)
7301 and then Convention (Typ) = Convention_Ada
7302 and then Present (Access_Disp_Table (Typ))
7303 and then RTE_Available (RE_Unregister_Tag)
7304 and then not No_Run_Time_Mode
7305 and then not Is_Abstract_Type (Typ)
7310 -- Regular object declarations
7312 elsif Nkind (Decl) = N_Object_Declaration then
7313 Obj_Id := Defining_Identifier (Decl);
7314 Obj_Typ := Base_Type (Etype (Obj_Id));
7315 Expr := Expression (Decl);
7317 -- Bypass any form of processing for objects which have their
7318 -- finalization disabled. This applies only to objects at the
7321 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
7324 -- Transient variables are treated separately in order to minimize
7325 -- the size of the generated code. See Exp_Ch7.Process_Transient_
7328 elsif Is_Processed_Transient (Obj_Id) then
7331 -- The object is of the form:
7332 -- Obj : Typ [:= Expr];
7334 -- Do not process the incomplete view of a deferred constant. Do
7335 -- not consider tag-to-class-wide conversions.
7337 elsif not Is_Imported (Obj_Id)
7338 and then Needs_Finalization (Obj_Typ)
7339 and then not (Ekind (Obj_Id) = E_Constant
7340 and then not Has_Completion (Obj_Id))
7341 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
7345 -- The object is of the form:
7346 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
7348 -- Obj : Access_Typ :=
7349 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
7351 elsif Is_Access_Type (Obj_Typ)
7352 and then Needs_Finalization
7353 (Available_View (Designated_Type (Obj_Typ)))
7354 and then Present (Expr)
7356 (Is_Secondary_Stack_BIP_Func_Call (Expr)
7358 (Is_Non_BIP_Func_Call (Expr)
7359 and then not Is_Related_To_Func_Return (Obj_Id)))
7363 -- Processing for "hook" objects generated for controlled
7364 -- transients declared inside an Expression_With_Actions.
7366 elsif Is_Access_Type (Obj_Typ)
7367 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
7368 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
7369 N_Object_Declaration
7370 and then Is_Finalizable_Transient
7371 (Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
7375 -- Processing for intermediate results of if expressions where
7376 -- one of the alternatives uses a controlled function call.
7378 elsif Is_Access_Type (Obj_Typ)
7379 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
7380 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
7381 N_Defining_Identifier
7382 and then Present (Expr)
7383 and then Nkind (Expr) = N_Null
7387 -- Simple protected objects which use type System.Tasking.
7388 -- Protected_Objects.Protection to manage their locks should be
7389 -- treated as controlled since they require manual cleanup.
7391 elsif Ekind (Obj_Id) = E_Variable
7393 (Is_Simple_Protected_Type (Obj_Typ)
7394 or else Has_Simple_Protected_Object (Obj_Typ))
7399 -- Specific cases of object renamings
7401 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
7402 Obj_Id := Defining_Identifier (Decl);
7403 Obj_Typ := Base_Type (Etype (Obj_Id));
7405 -- Bypass any form of processing for objects which have their
7406 -- finalization disabled. This applies only to objects at the
7409 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
7412 -- Return object of a build-in-place function. This case is
7413 -- recognized and marked by the expansion of an extended return
7414 -- statement (see Expand_N_Extended_Return_Statement).
7416 elsif Needs_Finalization (Obj_Typ)
7417 and then Is_Return_Object (Obj_Id)
7418 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
7422 -- Detect a case where a source object has been initialized by
7423 -- a controlled function call or another object which was later
7424 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
7426 -- Obj1 : CW_Type := Src_Obj;
7427 -- Obj2 : CW_Type := Function_Call (...);
7429 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
7430 -- Tmp : ... := Function_Call (...)'reference;
7431 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
7433 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
7437 -- Inspect the freeze node of an access-to-controlled type and look
7438 -- for a delayed finalization master. This case arises when the
7439 -- freeze actions are inserted at a later time than the expansion of
7440 -- the context. Since Build_Finalizer is never called on a single
7441 -- construct twice, the master will be ultimately left out and never
7442 -- finalized. This is also needed for freeze actions of designated
7443 -- types themselves, since in some cases the finalization master is
7444 -- associated with a designated type's freeze node rather than that
7445 -- of the access type (see handling for freeze actions in
7446 -- Build_Finalization_Master).
7448 elsif Nkind (Decl) = N_Freeze_Entity
7449 and then Present (Actions (Decl))
7451 Typ := Entity (Decl);
7453 if ((Is_Access_Type (Typ)
7454 and then not Is_Access_Subprogram_Type (Typ)
7455 and then Needs_Finalization
7456 (Available_View (Designated_Type (Typ))))
7459 and then Needs_Finalization (Typ)))
7460 and then Requires_Cleanup_Actions
7461 (Actions (Decl), Lib_Level, Nested_Constructs)
7466 -- Nested package declarations
7468 elsif Nested_Constructs
7469 and then Nkind (Decl) = N_Package_Declaration
7471 Pack_Id := Defining_Unit_Name (Specification (Decl));
7473 if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
7474 Pack_Id := Defining_Identifier (Pack_Id);
7477 if Ekind (Pack_Id) /= E_Generic_Package
7479 Requires_Cleanup_Actions (Specification (Decl), Lib_Level)
7484 -- Nested package bodies
7486 elsif Nested_Constructs and then Nkind (Decl) = N_Package_Body then
7487 Pack_Id := Corresponding_Spec (Decl);
7489 if Ekind (Pack_Id) /= E_Generic_Package
7490 and then Requires_Cleanup_Actions (Decl, Lib_Level)
7500 end Requires_Cleanup_Actions;
7502 ------------------------------------
7503 -- Safe_Unchecked_Type_Conversion --
7504 ------------------------------------
7506 -- Note: this function knows quite a bit about the exact requirements of
7507 -- Gigi with respect to unchecked type conversions, and its code must be
7508 -- coordinated with any changes in Gigi in this area.
7510 -- The above requirements should be documented in Sinfo ???
7512 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
7517 Pexp : constant Node_Id := Parent (Exp);
7520 -- If the expression is the RHS of an assignment or object declaration
7521 -- we are always OK because there will always be a target.
7523 -- Object renaming declarations, (generated for view conversions of
7524 -- actuals in inlined calls), like object declarations, provide an
7525 -- explicit type, and are safe as well.
7527 if (Nkind (Pexp) = N_Assignment_Statement
7528 and then Expression (Pexp) = Exp)
7529 or else Nkind_In (Pexp, N_Object_Declaration,
7530 N_Object_Renaming_Declaration)
7534 -- If the expression is the prefix of an N_Selected_Component we should
7535 -- also be OK because GCC knows to look inside the conversion except if
7536 -- the type is discriminated. We assume that we are OK anyway if the
7537 -- type is not set yet or if it is controlled since we can't afford to
7538 -- introduce a temporary in this case.
7540 elsif Nkind (Pexp) = N_Selected_Component
7541 and then Prefix (Pexp) = Exp
7543 if No (Etype (Pexp)) then
7547 not Has_Discriminants (Etype (Pexp))
7548 or else Is_Constrained (Etype (Pexp));
7552 -- Set the output type, this comes from Etype if it is set, otherwise we
7553 -- take it from the subtype mark, which we assume was already fully
7556 if Present (Etype (Exp)) then
7557 Otyp := Etype (Exp);
7559 Otyp := Entity (Subtype_Mark (Exp));
7562 -- The input type always comes from the expression, and we assume
7563 -- this is indeed always analyzed, so we can simply get the Etype.
7565 Ityp := Etype (Expression (Exp));
7567 -- Initialize alignments to unknown so far
7572 -- Replace a concurrent type by its corresponding record type and each
7573 -- type by its underlying type and do the tests on those. The original
7574 -- type may be a private type whose completion is a concurrent type, so
7575 -- find the underlying type first.
7577 if Present (Underlying_Type (Otyp)) then
7578 Otyp := Underlying_Type (Otyp);
7581 if Present (Underlying_Type (Ityp)) then
7582 Ityp := Underlying_Type (Ityp);
7585 if Is_Concurrent_Type (Otyp) then
7586 Otyp := Corresponding_Record_Type (Otyp);
7589 if Is_Concurrent_Type (Ityp) then
7590 Ityp := Corresponding_Record_Type (Ityp);
7593 -- If the base types are the same, we know there is no problem since
7594 -- this conversion will be a noop.
7596 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
7599 -- Same if this is an upwards conversion of an untagged type, and there
7600 -- are no constraints involved (could be more general???)
7602 elsif Etype (Ityp) = Otyp
7603 and then not Is_Tagged_Type (Ityp)
7604 and then not Has_Discriminants (Ityp)
7605 and then No (First_Rep_Item (Base_Type (Ityp)))
7609 -- If the expression has an access type (object or subprogram) we assume
7610 -- that the conversion is safe, because the size of the target is safe,
7611 -- even if it is a record (which might be treated as having unknown size
7614 elsif Is_Access_Type (Ityp) then
7617 -- If the size of output type is known at compile time, there is never
7618 -- a problem. Note that unconstrained records are considered to be of
7619 -- known size, but we can't consider them that way here, because we are
7620 -- talking about the actual size of the object.
7622 -- We also make sure that in addition to the size being known, we do not
7623 -- have a case which might generate an embarrassingly large temp in
7624 -- stack checking mode.
7626 elsif Size_Known_At_Compile_Time (Otyp)
7628 (not Stack_Checking_Enabled
7629 or else not May_Generate_Large_Temp (Otyp))
7630 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
7634 -- If either type is tagged, then we know the alignment is OK so
7635 -- Gigi will be able to use pointer punning.
7637 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
7640 -- If either type is a limited record type, we cannot do a copy, so say
7641 -- safe since there's nothing else we can do.
7643 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
7646 -- Conversions to and from packed array types are always ignored and
7649 elsif Is_Packed_Array_Type (Otyp)
7650 or else Is_Packed_Array_Type (Ityp)
7655 -- The only other cases known to be safe is if the input type's
7656 -- alignment is known to be at least the maximum alignment for the
7657 -- target or if both alignments are known and the output type's
7658 -- alignment is no stricter than the input's. We can use the component
7659 -- type alignement for an array if a type is an unpacked array type.
7661 if Present (Alignment_Clause (Otyp)) then
7662 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
7664 elsif Is_Array_Type (Otyp)
7665 and then Present (Alignment_Clause (Component_Type (Otyp)))
7667 Oalign := Expr_Value (Expression (Alignment_Clause
7668 (Component_Type (Otyp))));
7671 if Present (Alignment_Clause (Ityp)) then
7672 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
7674 elsif Is_Array_Type (Ityp)
7675 and then Present (Alignment_Clause (Component_Type (Ityp)))
7677 Ialign := Expr_Value (Expression (Alignment_Clause
7678 (Component_Type (Ityp))));
7681 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
7684 elsif Ialign /= No_Uint and then Oalign /= No_Uint
7685 and then Ialign <= Oalign
7689 -- Otherwise, Gigi cannot handle this and we must make a temporary
7694 end Safe_Unchecked_Type_Conversion;
7696 ---------------------------------
7697 -- Set_Current_Value_Condition --
7698 ---------------------------------
7700 -- Note: the implementation of this procedure is very closely tied to the
7701 -- implementation of Get_Current_Value_Condition. Here we set required
7702 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
7703 -- them, so they must have a consistent view.
7705 procedure Set_Current_Value_Condition (Cnode : Node_Id) is
7707 procedure Set_Entity_Current_Value (N : Node_Id);
7708 -- If N is an entity reference, where the entity is of an appropriate
7709 -- kind, then set the current value of this entity to Cnode, unless
7710 -- there is already a definite value set there.
7712 procedure Set_Expression_Current_Value (N : Node_Id);
7713 -- If N is of an appropriate form, sets an appropriate entry in current
7714 -- value fields of relevant entities. Multiple entities can be affected
7715 -- in the case of an AND or AND THEN.
7717 ------------------------------
7718 -- Set_Entity_Current_Value --
7719 ------------------------------
7721 procedure Set_Entity_Current_Value (N : Node_Id) is
7723 if Is_Entity_Name (N) then
7725 Ent : constant Entity_Id := Entity (N);
7728 -- Don't capture if not safe to do so
7730 if not Safe_To_Capture_Value (N, Ent, Cond => True) then
7734 -- Here we have a case where the Current_Value field may need
7735 -- to be set. We set it if it is not already set to a compile
7736 -- time expression value.
7738 -- Note that this represents a decision that one condition
7739 -- blots out another previous one. That's certainly right if
7740 -- they occur at the same level. If the second one is nested,
7741 -- then the decision is neither right nor wrong (it would be
7742 -- equally OK to leave the outer one in place, or take the new
7743 -- inner one. Really we should record both, but our data
7744 -- structures are not that elaborate.
7746 if Nkind (Current_Value (Ent)) not in N_Subexpr then
7747 Set_Current_Value (Ent, Cnode);
7751 end Set_Entity_Current_Value;
7753 ----------------------------------
7754 -- Set_Expression_Current_Value --
7755 ----------------------------------
7757 procedure Set_Expression_Current_Value (N : Node_Id) is
7763 -- Loop to deal with (ignore for now) any NOT operators present. The
7764 -- presence of NOT operators will be handled properly when we call
7765 -- Get_Current_Value_Condition.
7767 while Nkind (Cond) = N_Op_Not loop
7768 Cond := Right_Opnd (Cond);
7771 -- For an AND or AND THEN, recursively process operands
7773 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
7774 Set_Expression_Current_Value (Left_Opnd (Cond));
7775 Set_Expression_Current_Value (Right_Opnd (Cond));
7779 -- Check possible relational operator
7781 if Nkind (Cond) in N_Op_Compare then
7782 if Compile_Time_Known_Value (Right_Opnd (Cond)) then
7783 Set_Entity_Current_Value (Left_Opnd (Cond));
7784 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
7785 Set_Entity_Current_Value (Right_Opnd (Cond));
7788 elsif Nkind_In (Cond,
7790 N_Qualified_Expression,
7791 N_Expression_With_Actions)
7793 Set_Expression_Current_Value (Expression (Cond));
7795 -- Check possible boolean variable reference
7798 Set_Entity_Current_Value (Cond);
7800 end Set_Expression_Current_Value;
7802 -- Start of processing for Set_Current_Value_Condition
7805 Set_Expression_Current_Value (Condition (Cnode));
7806 end Set_Current_Value_Condition;
7808 --------------------------
7809 -- Set_Elaboration_Flag --
7810 --------------------------
7812 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
7813 Loc : constant Source_Ptr := Sloc (N);
7814 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
7818 if Present (Ent) then
7820 -- Nothing to do if at the compilation unit level, because in this
7821 -- case the flag is set by the binder generated elaboration routine.
7823 if Nkind (Parent (N)) = N_Compilation_Unit then
7826 -- Here we do need to generate an assignment statement
7829 Check_Restriction (No_Elaboration_Code, N);
7831 Make_Assignment_Statement (Loc,
7832 Name => New_Occurrence_Of (Ent, Loc),
7833 Expression => Make_Integer_Literal (Loc, Uint_1));
7835 if Nkind (Parent (N)) = N_Subunit then
7836 Insert_After (Corresponding_Stub (Parent (N)), Asn);
7838 Insert_After (N, Asn);
7843 -- Kill current value indication. This is necessary because the
7844 -- tests of this flag are inserted out of sequence and must not
7845 -- pick up bogus indications of the wrong constant value.
7847 Set_Current_Value (Ent, Empty);
7850 end Set_Elaboration_Flag;
7852 ----------------------------
7853 -- Set_Renamed_Subprogram --
7854 ----------------------------
7856 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
7858 -- If input node is an identifier, we can just reset it
7860 if Nkind (N) = N_Identifier then
7861 Set_Chars (N, Chars (E));
7864 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
7868 CS : constant Boolean := Comes_From_Source (N);
7870 Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
7872 Set_Comes_From_Source (N, CS);
7873 Set_Analyzed (N, True);
7876 end Set_Renamed_Subprogram;
7878 ----------------------
7879 -- Side_Effect_Free --
7880 ----------------------
7882 function Side_Effect_Free
7884 Name_Req : Boolean := False;
7885 Variable_Ref : Boolean := False) return Boolean
7887 Typ : constant Entity_Id := Etype (N);
7888 -- Result type of the expression
7890 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
7891 -- The argument N is a construct where the Prefix is dereferenced if it
7892 -- is an access type and the result is a variable. The call returns True
7893 -- if the construct is side effect free (not considering side effects in
7894 -- other than the prefix which are to be tested by the caller).
7896 function Within_In_Parameter (N : Node_Id) return Boolean;
7897 -- Determines if N is a subcomponent of a composite in-parameter. If so,
7898 -- N is not side-effect free when the actual is global and modifiable
7899 -- indirectly from within a subprogram, because it may be passed by
7900 -- reference. The front-end must be conservative here and assume that
7901 -- this may happen with any array or record type. On the other hand, we
7902 -- cannot create temporaries for all expressions for which this
7903 -- condition is true, for various reasons that might require clearing up
7904 -- ??? For example, discriminant references that appear out of place, or
7905 -- spurious type errors with class-wide expressions. As a result, we
7906 -- limit the transformation to loop bounds, which is so far the only
7907 -- case that requires it.
7909 -----------------------------
7910 -- Safe_Prefixed_Reference --
7911 -----------------------------
7913 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
7915 -- If prefix is not side effect free, definitely not safe
7917 if not Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref) then
7920 -- If the prefix is of an access type that is not access-to-constant,
7921 -- then this construct is a variable reference, which means it is to
7922 -- be considered to have side effects if Variable_Ref is set True.
7924 elsif Is_Access_Type (Etype (Prefix (N)))
7925 and then not Is_Access_Constant (Etype (Prefix (N)))
7926 and then Variable_Ref
7928 -- Exception is a prefix that is the result of a previous removal
7931 return Is_Entity_Name (Prefix (N))
7932 and then not Comes_From_Source (Prefix (N))
7933 and then Ekind (Entity (Prefix (N))) = E_Constant
7934 and then Is_Internal_Name (Chars (Entity (Prefix (N))));
7936 -- If the prefix is an explicit dereference then this construct is a
7937 -- variable reference, which means it is to be considered to have
7938 -- side effects if Variable_Ref is True.
7940 -- We do NOT exclude dereferences of access-to-constant types because
7941 -- we handle them as constant view of variables.
7943 elsif Nkind (Prefix (N)) = N_Explicit_Dereference
7944 and then Variable_Ref
7948 -- Note: The following test is the simplest way of solving a complex
7949 -- problem uncovered by the following test (Side effect on loop bound
7950 -- that is a subcomponent of a global variable:
7952 -- with Text_Io; use Text_Io;
7953 -- procedure Tloop is
7956 -- V : Natural := 4;
7957 -- S : String (1..5) := (others => 'a');
7964 -- with procedure Action;
7965 -- procedure Loop_G (Arg : X; Msg : String)
7967 -- procedure Loop_G (Arg : X; Msg : String) is
7969 -- Put_Line ("begin loop_g " & Msg & " will loop till: "
7970 -- & Natural'Image (Arg.V));
7971 -- for Index in 1 .. Arg.V loop
7973 -- (Natural'Image (Index) & " " & Arg.S (Index));
7974 -- if Index > 2 then
7978 -- Put_Line ("end loop_g " & Msg);
7981 -- procedure Loop1 is new Loop_G (Modi);
7982 -- procedure Modi is
7985 -- Loop1 (X1, "from modi");
7989 -- Loop1 (X1, "initial");
7992 -- The output of the above program should be:
7994 -- begin loop_g initial will loop till: 4
7998 -- begin loop_g from modi will loop till: 1
8000 -- end loop_g from modi
8002 -- begin loop_g from modi will loop till: 1
8004 -- end loop_g from modi
8005 -- end loop_g initial
8007 -- If a loop bound is a subcomponent of a global variable, a
8008 -- modification of that variable within the loop may incorrectly
8009 -- affect the execution of the loop.
8011 elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
8012 and then Within_In_Parameter (Prefix (N))
8013 and then Variable_Ref
8017 -- All other cases are side effect free
8022 end Safe_Prefixed_Reference;
8024 -------------------------
8025 -- Within_In_Parameter --
8026 -------------------------
8028 function Within_In_Parameter (N : Node_Id) return Boolean is
8030 if not Comes_From_Source (N) then
8033 elsif Is_Entity_Name (N) then
8034 return Ekind (Entity (N)) = E_In_Parameter;
8036 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
8037 return Within_In_Parameter (Prefix (N));
8042 end Within_In_Parameter;
8044 -- Start of processing for Side_Effect_Free
8047 -- If volatile reference, always consider it to have side effects
8049 if Is_Volatile_Reference (N) then
8053 -- Note on checks that could raise Constraint_Error. Strictly, if we
8054 -- take advantage of 11.6, these checks do not count as side effects.
8055 -- However, we would prefer to consider that they are side effects,
8056 -- since the backend CSE does not work very well on expressions which
8057 -- can raise Constraint_Error. On the other hand if we don't consider
8058 -- them to be side effect free, then we get some awkward expansions
8059 -- in -gnato mode, resulting in code insertions at a point where we
8060 -- do not have a clear model for performing the insertions.
8062 -- Special handling for entity names
8064 if Is_Entity_Name (N) then
8066 -- A type reference is always side effect free
8068 if Is_Type (Entity (N)) then
8071 -- Variables are considered to be a side effect if Variable_Ref
8072 -- is set or if we have a volatile reference and Name_Req is off.
8073 -- If Name_Req is True then we can't help returning a name which
8074 -- effectively allows multiple references in any case.
8076 elsif Is_Variable (N, Use_Original_Node => False) then
8077 return not Variable_Ref
8078 and then (not Is_Volatile_Reference (N) or else Name_Req);
8080 -- Any other entity (e.g. a subtype name) is definitely side
8087 -- A value known at compile time is always side effect free
8089 elsif Compile_Time_Known_Value (N) then
8092 -- A variable renaming is not side-effect free, because the renaming
8093 -- will function like a macro in the front-end in some cases, and an
8094 -- assignment can modify the component designated by N, so we need to
8095 -- create a temporary for it.
8097 -- The guard testing for Entity being present is needed at least in
8098 -- the case of rewritten predicate expressions, and may well also be
8099 -- appropriate elsewhere. Obviously we can't go testing the entity
8100 -- field if it does not exist, so it's reasonable to say that this is
8101 -- not the renaming case if it does not exist.
8103 elsif Is_Entity_Name (Original_Node (N))
8104 and then Present (Entity (Original_Node (N)))
8105 and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
8106 and then Ekind (Entity (Original_Node (N))) /= E_Constant
8109 RO : constant Node_Id :=
8110 Renamed_Object (Entity (Original_Node (N)));
8113 -- If the renamed object is an indexed component, or an
8114 -- explicit dereference, then the designated object could
8115 -- be modified by an assignment.
8117 if Nkind_In (RO, N_Indexed_Component,
8118 N_Explicit_Dereference)
8122 -- A selected component must have a safe prefix
8124 elsif Nkind (RO) = N_Selected_Component then
8125 return Safe_Prefixed_Reference (RO);
8127 -- In all other cases, designated object cannot be changed so
8128 -- we are side effect free.
8135 -- Remove_Side_Effects generates an object renaming declaration to
8136 -- capture the expression of a class-wide expression. In VM targets
8137 -- the frontend performs no expansion for dispatching calls to
8138 -- class- wide types since they are handled by the VM. Hence, we must
8139 -- locate here if this node corresponds to a previous invocation of
8140 -- Remove_Side_Effects to avoid a never ending loop in the frontend.
8142 elsif VM_Target /= No_VM
8143 and then not Comes_From_Source (N)
8144 and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
8145 and then Is_Class_Wide_Type (Typ)
8150 -- For other than entity names and compile time known values,
8151 -- check the node kind for special processing.
8155 -- An attribute reference is side effect free if its expressions
8156 -- are side effect free and its prefix is side effect free or
8157 -- is an entity reference.
8159 -- Is this right? what about x'first where x is a variable???
8161 when N_Attribute_Reference =>
8162 return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
8163 and then Attribute_Name (N) /= Name_Input
8164 and then (Is_Entity_Name (Prefix (N))
8165 or else Side_Effect_Free
8166 (Prefix (N), Name_Req, Variable_Ref));
8168 -- A binary operator is side effect free if and both operands are
8169 -- side effect free. For this purpose binary operators include
8170 -- membership tests and short circuit forms.
8172 when N_Binary_Op | N_Membership_Test | N_Short_Circuit =>
8173 return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
8175 Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
8177 -- An explicit dereference is side effect free only if it is
8178 -- a side effect free prefixed reference.
8180 when N_Explicit_Dereference =>
8181 return Safe_Prefixed_Reference (N);
8183 -- An expression with action is side effect free if its expression
8184 -- is side effect free and it has no actions.
8186 when N_Expression_With_Actions =>
8187 return Is_Empty_List (Actions (N))
8189 Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
8191 -- A call to _rep_to_pos is side effect free, since we generate
8192 -- this pure function call ourselves. Moreover it is critically
8193 -- important to make this exception, since otherwise we can have
8194 -- discriminants in array components which don't look side effect
8195 -- free in the case of an array whose index type is an enumeration
8196 -- type with an enumeration rep clause.
8198 -- All other function calls are not side effect free
8200 when N_Function_Call =>
8201 return Nkind (Name (N)) = N_Identifier
8202 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
8205 (First (Parameter_Associations (N)), Name_Req, Variable_Ref);
8207 -- An IF expression is side effect free if it's of a scalar type, and
8208 -- all its components are all side effect free (conditions and then
8209 -- actions and else actions). We restrict to scalar types, since it
8210 -- is annoying to deal with things like (if A then B else C)'First
8211 -- where the type involved is a string type.
8213 when N_If_Expression =>
8214 return Is_Scalar_Type (Typ)
8216 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref);
8218 -- An indexed component is side effect free if it is a side
8219 -- effect free prefixed reference and all the indexing
8220 -- expressions are side effect free.
8222 when N_Indexed_Component =>
8223 return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
8224 and then Safe_Prefixed_Reference (N);
8226 -- A type qualification is side effect free if the expression
8227 -- is side effect free.
8229 when N_Qualified_Expression =>
8230 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
8232 -- A selected component is side effect free only if it is a side
8233 -- effect free prefixed reference. If it designates a component
8234 -- with a rep. clause it must be treated has having a potential
8235 -- side effect, because it may be modified through a renaming, and
8236 -- a subsequent use of the renaming as a macro will yield the
8237 -- wrong value. This complex interaction between renaming and
8238 -- removing side effects is a reminder that the latter has become
8239 -- a headache to maintain, and that it should be removed in favor
8240 -- of the gcc mechanism to capture values ???
8242 when N_Selected_Component =>
8243 if Nkind (Parent (N)) = N_Explicit_Dereference
8244 and then Has_Non_Standard_Rep (Designated_Type (Typ))
8248 return Safe_Prefixed_Reference (N);
8251 -- A range is side effect free if the bounds are side effect free
8254 return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref)
8256 Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref);
8258 -- A slice is side effect free if it is a side effect free
8259 -- prefixed reference and the bounds are side effect free.
8262 return Side_Effect_Free
8263 (Discrete_Range (N), Name_Req, Variable_Ref)
8264 and then Safe_Prefixed_Reference (N);
8266 -- A type conversion is side effect free if the expression to be
8267 -- converted is side effect free.
8269 when N_Type_Conversion =>
8270 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
8272 -- A unary operator is side effect free if the operand
8273 -- is side effect free.
8276 return Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
8278 -- An unchecked type conversion is side effect free only if it
8279 -- is safe and its argument is side effect free.
8281 when N_Unchecked_Type_Conversion =>
8282 return Safe_Unchecked_Type_Conversion (N)
8284 Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
8286 -- An unchecked expression is side effect free if its expression
8287 -- is side effect free.
8289 when N_Unchecked_Expression =>
8290 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
8292 -- A literal is side effect free
8294 when N_Character_Literal |
8300 -- We consider that anything else has side effects. This is a bit
8301 -- crude, but we are pretty close for most common cases, and we
8302 -- are certainly correct (i.e. we never return True when the
8303 -- answer should be False).
8308 end Side_Effect_Free;
8310 -- A list is side effect free if all elements of the list are side
8313 function Side_Effect_Free
8315 Name_Req : Boolean := False;
8316 Variable_Ref : Boolean := False) return Boolean
8321 if L = No_List or else L = Error_List then
8326 while Present (N) loop
8327 if not Side_Effect_Free (N, Name_Req, Variable_Ref) then
8336 end Side_Effect_Free;
8338 ----------------------------------
8339 -- Silly_Boolean_Array_Not_Test --
8340 ----------------------------------
8342 -- This procedure implements an odd and silly test. We explicitly check
8343 -- for the case where the 'First of the component type is equal to the
8344 -- 'Last of this component type, and if this is the case, we make sure
8345 -- that constraint error is raised. The reason is that the NOT is bound
8346 -- to cause CE in this case, and we will not otherwise catch it.
8348 -- No such check is required for AND and OR, since for both these cases
8349 -- False op False = False, and True op True = True. For the XOR case,
8350 -- see Silly_Boolean_Array_Xor_Test.
8352 -- Believe it or not, this was reported as a bug. Note that nearly always,
8353 -- the test will evaluate statically to False, so the code will be
8354 -- statically removed, and no extra overhead caused.
8356 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
8357 Loc : constant Source_Ptr := Sloc (N);
8358 CT : constant Entity_Id := Component_Type (T);
8361 -- The check we install is
8363 -- constraint_error when
8364 -- component_type'first = component_type'last
8365 -- and then array_type'Length /= 0)
8367 -- We need the last guard because we don't want to raise CE for empty
8368 -- arrays since no out of range values result. (Empty arrays with a
8369 -- component type of True .. True -- very useful -- even the ACATS
8370 -- does not test that marginal case).
8373 Make_Raise_Constraint_Error (Loc,
8379 Make_Attribute_Reference (Loc,
8380 Prefix => New_Occurrence_Of (CT, Loc),
8381 Attribute_Name => Name_First),
8384 Make_Attribute_Reference (Loc,
8385 Prefix => New_Occurrence_Of (CT, Loc),
8386 Attribute_Name => Name_Last)),
8388 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
8389 Reason => CE_Range_Check_Failed));
8390 end Silly_Boolean_Array_Not_Test;
8392 ----------------------------------
8393 -- Silly_Boolean_Array_Xor_Test --
8394 ----------------------------------
8396 -- This procedure implements an odd and silly test. We explicitly check
8397 -- for the XOR case where the component type is True .. True, since this
8398 -- will raise constraint error. A special check is required since CE
8399 -- will not be generated otherwise (cf Expand_Packed_Not).
8401 -- No such check is required for AND and OR, since for both these cases
8402 -- False op False = False, and True op True = True, and no check is
8403 -- required for the case of False .. False, since False xor False = False.
8404 -- See also Silly_Boolean_Array_Not_Test
8406 procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is
8407 Loc : constant Source_Ptr := Sloc (N);
8408 CT : constant Entity_Id := Component_Type (T);
8411 -- The check we install is
8413 -- constraint_error when
8414 -- Boolean (component_type'First)
8415 -- and then Boolean (component_type'Last)
8416 -- and then array_type'Length /= 0)
8418 -- We need the last guard because we don't want to raise CE for empty
8419 -- arrays since no out of range values result (Empty arrays with a
8420 -- component type of True .. True -- very useful -- even the ACATS
8421 -- does not test that marginal case).
8424 Make_Raise_Constraint_Error (Loc,
8430 Convert_To (Standard_Boolean,
8431 Make_Attribute_Reference (Loc,
8432 Prefix => New_Occurrence_Of (CT, Loc),
8433 Attribute_Name => Name_First)),
8436 Convert_To (Standard_Boolean,
8437 Make_Attribute_Reference (Loc,
8438 Prefix => New_Occurrence_Of (CT, Loc),
8439 Attribute_Name => Name_Last))),
8441 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
8442 Reason => CE_Range_Check_Failed));
8443 end Silly_Boolean_Array_Xor_Test;
8445 --------------------------
8446 -- Target_Has_Fixed_Ops --
8447 --------------------------
8449 Integer_Sized_Small : Ureal;
8450 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
8451 -- called (we don't want to compute it more than once).
8453 Long_Integer_Sized_Small : Ureal;
8454 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
8455 -- is called (we don't want to compute it more than once)
8457 First_Time_For_THFO : Boolean := True;
8458 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
8460 function Target_Has_Fixed_Ops
8461 (Left_Typ : Entity_Id;
8462 Right_Typ : Entity_Id;
8463 Result_Typ : Entity_Id) return Boolean
8465 function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
8466 -- Return True if the given type is a fixed-point type with a small
8467 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
8468 -- an absolute value less than 1.0. This is currently limited to
8469 -- fixed-point types that map to Integer or Long_Integer.
8471 ------------------------
8472 -- Is_Fractional_Type --
8473 ------------------------
8475 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
8477 if Esize (Typ) = Standard_Integer_Size then
8478 return Small_Value (Typ) = Integer_Sized_Small;
8480 elsif Esize (Typ) = Standard_Long_Integer_Size then
8481 return Small_Value (Typ) = Long_Integer_Sized_Small;
8486 end Is_Fractional_Type;
8488 -- Start of processing for Target_Has_Fixed_Ops
8491 -- Return False if Fractional_Fixed_Ops_On_Target is false
8493 if not Fractional_Fixed_Ops_On_Target then
8497 -- Here the target has Fractional_Fixed_Ops, if first time, compute
8498 -- standard constants used by Is_Fractional_Type.
8500 if First_Time_For_THFO then
8501 First_Time_For_THFO := False;
8503 Integer_Sized_Small :=
8506 Den => UI_From_Int (Standard_Integer_Size - 1),
8509 Long_Integer_Sized_Small :=
8512 Den => UI_From_Int (Standard_Long_Integer_Size - 1),
8516 -- Return True if target supports fixed-by-fixed multiply/divide for
8517 -- fractional fixed-point types (see Is_Fractional_Type) and the operand
8518 -- and result types are equivalent fractional types.
8520 return Is_Fractional_Type (Base_Type (Left_Typ))
8521 and then Is_Fractional_Type (Base_Type (Right_Typ))
8522 and then Is_Fractional_Type (Base_Type (Result_Typ))
8523 and then Esize (Left_Typ) = Esize (Right_Typ)
8524 and then Esize (Left_Typ) = Esize (Result_Typ);
8525 end Target_Has_Fixed_Ops;
8527 ------------------------------------------
8528 -- Type_May_Have_Bit_Aligned_Components --
8529 ------------------------------------------
8531 function Type_May_Have_Bit_Aligned_Components
8532 (Typ : Entity_Id) return Boolean
8535 -- Array type, check component type
8537 if Is_Array_Type (Typ) then
8539 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
8541 -- Record type, check components
8543 elsif Is_Record_Type (Typ) then
8548 E := First_Component_Or_Discriminant (Typ);
8549 while Present (E) loop
8550 if Component_May_Be_Bit_Aligned (E)
8551 or else Type_May_Have_Bit_Aligned_Components (Etype (E))
8556 Next_Component_Or_Discriminant (E);
8562 -- Type other than array or record is always OK
8567 end Type_May_Have_Bit_Aligned_Components;
8569 ----------------------------------
8570 -- Within_Case_Or_If_Expression --
8571 ----------------------------------
8573 function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
8577 -- Locate an enclosing case or if expression. Note that these constructs
8578 -- can be expanded into Expression_With_Actions, hence the test of the
8582 while Present (Par) loop
8583 if Nkind_In (Original_Node (Par), N_Case_Expression,
8588 -- Prevent the search from going too far
8590 elsif Is_Body_Or_Package_Declaration (Par) then
8594 Par := Parent (Par);
8598 end Within_Case_Or_If_Expression;
8600 --------------------------------
8601 -- Within_Internal_Subprogram --
8602 --------------------------------
8604 function Within_Internal_Subprogram return Boolean is
8609 while Present (S) and then not Is_Subprogram (S) loop
8614 and then Get_TSS_Name (S) /= TSS_Null
8615 and then not Is_Predicate_Function (S);
8616 end Within_Internal_Subprogram;
8618 ----------------------------
8619 -- Wrap_Cleanup_Procedure --
8620 ----------------------------
8622 procedure Wrap_Cleanup_Procedure (N : Node_Id) is
8623 Loc : constant Source_Ptr := Sloc (N);
8624 Stseq : constant Node_Id := Handled_Statement_Sequence (N);
8625 Stmts : constant List_Id := Statements (Stseq);
8628 if Abort_Allowed then
8629 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
8630 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
8632 end Wrap_Cleanup_Procedure;