1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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_Prag; use Sem_Prag;
50 with Sem_Res; use Sem_Res;
51 with Sem_Type; use Sem_Type;
52 with Sem_Util; use Sem_Util;
53 with Snames; use Snames;
54 with Stand; use Stand;
55 with Stringt; use Stringt;
56 with Targparm; use Targparm;
57 with Tbuild; use Tbuild;
58 with Ttypes; use Ttypes;
59 with Urealp; use Urealp;
60 with Validsw; use Validsw;
62 package body Exp_Util is
64 -----------------------
65 -- Local Subprograms --
66 -----------------------
68 function Build_Task_Array_Image
72 Dyn : Boolean := False) return Node_Id;
73 -- Build function to generate the image string for a task that is an array
74 -- component, concatenating the images of each index. To avoid storage
75 -- leaks, the string is built with successive slice assignments. The flag
76 -- Dyn indicates whether this is called for the initialization procedure of
77 -- an array of tasks, or for the name of a dynamically created task that is
78 -- assigned to an indexed component.
80 function Build_Task_Image_Function
84 Res : Entity_Id) return Node_Id;
85 -- Common processing for Task_Array_Image and Task_Record_Image. Build
86 -- function body that computes image.
88 procedure Build_Task_Image_Prefix
97 -- Common processing for Task_Array_Image and Task_Record_Image. Create
98 -- local variables and assign prefix of name to result string.
100 function Build_Task_Record_Image
103 Dyn : Boolean := False) return Node_Id;
104 -- Build function to generate the image string for a task that is a record
105 -- component. Concatenate name of variable with that of selector. The flag
106 -- Dyn indicates whether this is called for the initialization procedure of
107 -- record with task components, or for a dynamically created task that is
108 -- assigned to a selected component.
110 function Make_CW_Equivalent_Type
112 E : Node_Id) return Entity_Id;
113 -- T is a class-wide type entity, E is the initial expression node that
114 -- constrains T in case such as: " X: T := E" or "new T'(E)". This function
115 -- returns the entity of the Equivalent type and inserts on the fly the
116 -- necessary declaration such as:
118 -- type anon is record
119 -- _parent : Root_Type (T); constrained with E discriminants (if any)
120 -- Extension : String (1 .. expr to match size of E);
123 -- This record is compatible with any object of the class of T thanks to
124 -- the first field and has the same size as E thanks to the second.
126 function Make_Literal_Range
128 Literal_Typ : Entity_Id) return Node_Id;
129 -- Produce a Range node whose bounds are:
130 -- Low_Bound (Literal_Type) ..
131 -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
132 -- this is used for expanding declarations like X : String := "sdfgdfg";
134 -- If the index type of the target array is not integer, we generate:
135 -- Low_Bound (Literal_Type) ..
137 -- (Literal_Type'Pos (Low_Bound (Literal_Type))
138 -- + (Length (Literal_Typ) -1))
140 function Make_Non_Empty_Check
142 N : Node_Id) return Node_Id;
143 -- Produce a boolean expression checking that the unidimensional array
144 -- node N is not empty.
146 function New_Class_Wide_Subtype
148 N : Node_Id) return Entity_Id;
149 -- Create an implicit subtype of CW_Typ attached to node N
151 function Requires_Cleanup_Actions
154 Nested_Constructs : Boolean) return Boolean;
155 -- Given a list L, determine whether it contains one of the following:
157 -- 1) controlled objects
158 -- 2) library-level tagged types
160 -- Lib_Level is True when the list comes from a construct at the library
161 -- level, and False otherwise. Nested_Constructs is True when any nested
162 -- packages declared in L must be processed, and False otherwise.
164 -------------------------------------
165 -- Activate_Atomic_Synchronization --
166 -------------------------------------
168 procedure Activate_Atomic_Synchronization (N : Node_Id) is
172 case Nkind (Parent (N)) is
174 -- Check for cases of appearing in the prefix of a construct where
175 -- we don't need atomic synchronization for this kind of usage.
178 -- Nothing to do if we are the prefix of an attribute, since we
179 -- do not want an atomic sync operation for things like 'Size.
181 N_Attribute_Reference |
183 -- The N_Reference node is like an attribute
187 -- Nothing to do for a reference to a component (or components)
188 -- of a composite object. Only reads and updates of the object
189 -- as a whole require atomic synchronization (RM C.6 (15)).
191 N_Indexed_Component |
192 N_Selected_Component |
195 -- For all the above cases, nothing to do if we are the prefix
197 if Prefix (Parent (N)) = N then
204 -- Go ahead and set the flag
206 Set_Atomic_Sync_Required (N);
208 -- Generate info message if requested
210 if Warn_On_Atomic_Synchronization then
215 when N_Selected_Component | N_Expanded_Name =>
216 Msg_Node := Selector_Name (N);
218 when N_Explicit_Dereference | N_Indexed_Component =>
222 pragma Assert (False);
226 if Present (Msg_Node) then
228 ("?n?info: atomic synchronization set for &", Msg_Node);
231 ("?n?info: atomic synchronization set", N);
234 end Activate_Atomic_Synchronization;
236 ----------------------
237 -- Adjust_Condition --
238 ----------------------
240 procedure Adjust_Condition (N : Node_Id) is
247 Loc : constant Source_Ptr := Sloc (N);
248 T : constant Entity_Id := Etype (N);
252 -- Defend against a call where the argument has no type, or has a
253 -- type that is not Boolean. This can occur because of prior errors.
255 if No (T) or else not Is_Boolean_Type (T) then
259 -- Apply validity checking if needed
261 if Validity_Checks_On and Validity_Check_Tests then
265 -- Immediate return if standard boolean, the most common case,
266 -- where nothing needs to be done.
268 if Base_Type (T) = Standard_Boolean then
272 -- Case of zero/non-zero semantics or non-standard enumeration
273 -- representation. In each case, we rewrite the node as:
275 -- ityp!(N) /= False'Enum_Rep
277 -- where ityp is an integer type with large enough size to hold any
280 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
281 if Esize (T) <= Esize (Standard_Integer) then
282 Ti := Standard_Integer;
284 Ti := Standard_Long_Long_Integer;
289 Left_Opnd => Unchecked_Convert_To (Ti, N),
291 Make_Attribute_Reference (Loc,
292 Attribute_Name => Name_Enum_Rep,
294 New_Occurrence_Of (First_Literal (T), Loc))));
295 Analyze_And_Resolve (N, Standard_Boolean);
298 Rewrite (N, Convert_To (Standard_Boolean, N));
299 Analyze_And_Resolve (N, Standard_Boolean);
302 end Adjust_Condition;
304 ------------------------
305 -- Adjust_Result_Type --
306 ------------------------
308 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
310 -- Ignore call if current type is not Standard.Boolean
312 if Etype (N) /= Standard_Boolean then
316 -- If result is already of correct type, nothing to do. Note that
317 -- this will get the most common case where everything has a type
318 -- of Standard.Boolean.
320 if Base_Type (T) = Standard_Boolean then
325 KP : constant Node_Kind := Nkind (Parent (N));
328 -- If result is to be used as a Condition in the syntax, no need
329 -- to convert it back, since if it was changed to Standard.Boolean
330 -- using Adjust_Condition, that is just fine for this usage.
332 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
335 -- If result is an operand of another logical operation, no need
336 -- to reset its type, since Standard.Boolean is just fine, and
337 -- such operations always do Adjust_Condition on their operands.
339 elsif KP in N_Op_Boolean
340 or else KP in N_Short_Circuit
341 or else KP = N_Op_Not
345 -- Otherwise we perform a conversion from the current type, which
346 -- must be Standard.Boolean, to the desired type.
350 Rewrite (N, Convert_To (T, N));
351 Analyze_And_Resolve (N, T);
355 end Adjust_Result_Type;
357 --------------------------
358 -- Append_Freeze_Action --
359 --------------------------
361 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
365 Ensure_Freeze_Node (T);
366 Fnode := Freeze_Node (T);
368 if No (Actions (Fnode)) then
369 Set_Actions (Fnode, New_List);
372 Append (N, Actions (Fnode));
373 end Append_Freeze_Action;
375 ---------------------------
376 -- Append_Freeze_Actions --
377 ---------------------------
379 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
380 Fnode : constant Node_Id := Freeze_Node (T);
387 if No (Actions (Fnode)) then
388 Set_Actions (Fnode, L);
390 Append_List (L, Actions (Fnode));
393 end Append_Freeze_Actions;
395 ------------------------------------
396 -- Build_Allocate_Deallocate_Proc --
397 ------------------------------------
399 procedure Build_Allocate_Deallocate_Proc
401 Is_Allocate : Boolean)
403 Desig_Typ : Entity_Id;
406 Proc_To_Call : Node_Id := Empty;
409 function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
410 -- Locate TSS primitive Finalize_Address in type Typ
412 function Find_Object (E : Node_Id) return Node_Id;
413 -- Given an arbitrary expression of an allocator, try to find an object
414 -- reference in it, otherwise return the original expression.
416 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
417 -- Determine whether subprogram Subp denotes a custom allocate or
420 ---------------------------
421 -- Find_Finalize_Address --
422 ---------------------------
424 function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id is
425 Utyp : Entity_Id := Typ;
428 -- Handle protected class-wide or task class-wide types
430 if Is_Class_Wide_Type (Utyp) then
431 if Is_Concurrent_Type (Root_Type (Utyp)) then
432 Utyp := Root_Type (Utyp);
434 elsif Is_Private_Type (Root_Type (Utyp))
435 and then Present (Full_View (Root_Type (Utyp)))
436 and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
438 Utyp := Full_View (Root_Type (Utyp));
442 -- Handle private types
444 if Is_Private_Type (Utyp)
445 and then Present (Full_View (Utyp))
447 Utyp := Full_View (Utyp);
450 -- Handle protected and task types
452 if Is_Concurrent_Type (Utyp)
453 and then Present (Corresponding_Record_Type (Utyp))
455 Utyp := Corresponding_Record_Type (Utyp);
458 Utyp := Underlying_Type (Base_Type (Utyp));
460 -- Deal with non-tagged derivation of private views. If the parent is
461 -- now known to be protected, the finalization routine is the one
462 -- defined on the corresponding record of the ancestor (corresponding
463 -- records do not automatically inherit operations, but maybe they
466 if Is_Untagged_Derivation (Typ) then
467 if Is_Protected_Type (Typ) then
468 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
470 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
472 if Is_Protected_Type (Utyp) then
473 Utyp := Corresponding_Record_Type (Utyp);
478 -- If the underlying_type is a subtype, we are dealing with the
479 -- completion of a private type. We need to access the base type and
480 -- generate a conversion to it.
482 if Utyp /= Base_Type (Utyp) then
483 pragma Assert (Is_Private_Type (Typ));
485 Utyp := Base_Type (Utyp);
488 -- When dealing with an internally built full view for a type with
489 -- unknown discriminants, use the original record type.
491 if Is_Underlying_Record_View (Utyp) then
492 Utyp := Etype (Utyp);
495 return TSS (Utyp, TSS_Finalize_Address);
496 end Find_Finalize_Address;
502 function Find_Object (E : Node_Id) return Node_Id is
506 pragma Assert (Is_Allocate);
510 if Nkind_In (Expr, N_Qualified_Expression,
511 N_Unchecked_Type_Conversion)
513 Expr := Expression (Expr);
515 elsif Nkind (Expr) = N_Explicit_Dereference then
516 Expr := Prefix (Expr);
526 ---------------------------------
527 -- Is_Allocate_Deallocate_Proc --
528 ---------------------------------
530 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
532 -- Look for a subprogram body with only one statement which is a
533 -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
535 if Ekind (Subp) = E_Procedure
536 and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
539 HSS : constant Node_Id :=
540 Handled_Statement_Sequence (Parent (Parent (Subp)));
544 if Present (Statements (HSS))
545 and then Nkind (First (Statements (HSS))) =
546 N_Procedure_Call_Statement
548 Proc := Entity (Name (First (Statements (HSS))));
551 Is_RTE (Proc, RE_Allocate_Any_Controlled)
552 or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
558 end Is_Allocate_Deallocate_Proc;
560 -- Start of processing for Build_Allocate_Deallocate_Proc
563 -- Do not perform this expansion in Alfa mode because it is not
570 -- Obtain the attributes of the allocation / deallocation
572 if Nkind (N) = N_Free_Statement then
573 Expr := Expression (N);
574 Ptr_Typ := Base_Type (Etype (Expr));
575 Proc_To_Call := Procedure_To_Call (N);
578 if Nkind (N) = N_Object_Declaration then
579 Expr := Expression (N);
584 -- In certain cases an allocator with a qualified expression may
585 -- be relocated and used as the initialization expression of a
589 -- Obj : Ptr_Typ := new Desig_Typ'(...);
592 -- Tmp : Ptr_Typ := new Desig_Typ'(...);
593 -- Obj : Ptr_Typ := Tmp;
595 -- Since the allocator is always marked as analyzed to avoid infinite
596 -- expansion, it will never be processed by this routine given that
597 -- the designated type needs finalization actions. Detect this case
598 -- and complete the expansion of the allocator.
600 if Nkind (Expr) = N_Identifier
601 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
602 and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
604 Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
608 -- The allocator may have been rewritten into something else in which
609 -- case the expansion performed by this routine does not apply.
611 if Nkind (Expr) /= N_Allocator then
615 Ptr_Typ := Base_Type (Etype (Expr));
616 Proc_To_Call := Procedure_To_Call (Expr);
619 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
620 Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
622 -- Handle concurrent types
624 if Is_Concurrent_Type (Desig_Typ)
625 and then Present (Corresponding_Record_Type (Desig_Typ))
627 Desig_Typ := Corresponding_Record_Type (Desig_Typ);
630 -- Do not process allocations / deallocations without a pool
635 -- Do not process allocations on / deallocations from the secondary
638 elsif Is_RTE (Pool_Id, RE_SS_Pool) then
641 -- Do not replicate the machinery if the allocator / free has already
642 -- been expanded and has a custom Allocate / Deallocate.
644 elsif Present (Proc_To_Call)
645 and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
650 if Needs_Finalization (Desig_Typ) then
652 -- Certain run-time configurations and targets do not provide support
653 -- for controlled types.
655 if Restriction_Active (No_Finalization) then
658 -- Do nothing if the access type may never allocate / deallocate
661 elsif No_Pool_Assigned (Ptr_Typ) then
664 -- Access-to-controlled types are not supported on .NET/JVM since
665 -- these targets cannot support pools and address arithmetic.
667 elsif VM_Target /= No_VM then
671 -- The allocation / deallocation of a controlled object must be
672 -- chained on / detached from a finalization master.
674 pragma Assert (Present (Finalization_Master (Ptr_Typ)));
676 -- The only other kind of allocation / deallocation supported by this
677 -- routine is on / from a subpool.
679 elsif Nkind (Expr) = N_Allocator
680 and then No (Subpool_Handle_Name (Expr))
686 Loc : constant Source_Ptr := Sloc (N);
687 Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
688 Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
689 Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
690 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
693 Fin_Addr_Id : Entity_Id;
694 Fin_Mas_Act : Node_Id;
695 Fin_Mas_Id : Entity_Id;
696 Proc_To_Call : Entity_Id;
697 Subpool : Node_Id := Empty;
700 -- Step 1: Construct all the actuals for the call to library routine
701 -- Allocate_Any_Controlled / Deallocate_Any_Controlled.
705 Actuals := New_List (New_Reference_To (Pool_Id, Loc));
711 if Nkind (Expr) = N_Allocator then
712 Subpool := Subpool_Handle_Name (Expr);
715 -- If a subpool is present it can be an arbitrary name, so make
716 -- the actual by copying the tree.
718 if Present (Subpool) then
719 Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
721 Append_To (Actuals, Make_Null (Loc));
724 -- c) Finalization master
726 if Needs_Finalization (Desig_Typ) then
727 Fin_Mas_Id := Finalization_Master (Ptr_Typ);
728 Fin_Mas_Act := New_Reference_To (Fin_Mas_Id, Loc);
730 -- Handle the case where the master is actually a pointer to a
731 -- master. This case arises in build-in-place functions.
733 if Is_Access_Type (Etype (Fin_Mas_Id)) then
734 Append_To (Actuals, Fin_Mas_Act);
737 Make_Attribute_Reference (Loc,
738 Prefix => Fin_Mas_Act,
739 Attribute_Name => Name_Unrestricted_Access));
742 Append_To (Actuals, Make_Null (Loc));
745 -- d) Finalize_Address
747 -- Primitive Finalize_Address is never generated in CodePeer mode
748 -- since it contains an Unchecked_Conversion.
750 if Needs_Finalization (Desig_Typ)
751 and then not CodePeer_Mode
753 Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
754 pragma Assert (Present (Fin_Addr_Id));
757 Make_Attribute_Reference (Loc,
758 Prefix => New_Reference_To (Fin_Addr_Id, Loc),
759 Attribute_Name => Name_Unrestricted_Access));
761 Append_To (Actuals, Make_Null (Loc));
769 Append_To (Actuals, New_Reference_To (Addr_Id, Loc));
770 Append_To (Actuals, New_Reference_To (Size_Id, Loc));
772 if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then
773 Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
775 -- For deallocation of class wide types we obtain the value of
776 -- alignment from the Type Specific Record of the deallocated object.
777 -- This is needed because the frontend expansion of class-wide types
778 -- into equivalent types confuses the backend.
784 -- ... because 'Alignment applied to class-wide types is expanded
785 -- into the code that reads the value of alignment from the TSD
786 -- (see Expand_N_Attribute_Reference)
789 Unchecked_Convert_To (RTE (RE_Storage_Offset),
790 Make_Attribute_Reference (Loc,
792 Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
793 Attribute_Name => Name_Alignment)));
798 -- Generate a run-time check to determine whether a class-wide object
799 -- is truly controlled.
801 if Needs_Finalization (Desig_Typ) then
802 if Is_Class_Wide_Type (Desig_Typ)
803 or else Is_Generic_Actual_Type (Desig_Typ)
806 Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
813 Temp := Find_Object (Expression (Expr));
818 -- Processing for generic actuals
820 if Is_Generic_Actual_Type (Desig_Typ) then
822 New_Reference_To (Boolean_Literals
823 (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
825 -- Processing for subtype indications
827 elsif Nkind (Temp) in N_Has_Entity
828 and then Is_Type (Entity (Temp))
831 New_Reference_To (Boolean_Literals
832 (Needs_Finalization (Entity (Temp))), Loc);
834 -- Generate a runtime check to test the controlled state of
835 -- an object for the purposes of allocation / deallocation.
838 -- The following case arises when allocating through an
839 -- interface class-wide type, generate:
843 if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
845 Make_Explicit_Dereference (Loc,
847 Relocate_Node (Temp));
854 Make_Attribute_Reference (Loc,
856 Relocate_Node (Temp),
857 Attribute_Name => Name_Tag);
861 -- Needs_Finalization (<Param>)
864 Make_Function_Call (Loc,
866 New_Reference_To (RTE (RE_Needs_Finalization), Loc),
867 Parameter_Associations => New_List (Param));
870 -- Create the temporary which represents the finalization
871 -- state of the expression. Generate:
873 -- F : constant Boolean := <Flag_Expr>;
876 Make_Object_Declaration (Loc,
877 Defining_Identifier => Flag_Id,
878 Constant_Present => True,
880 New_Reference_To (Standard_Boolean, Loc),
881 Expression => Flag_Expr));
883 -- The flag acts as the last actual
885 Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
888 -- The object is statically known to be controlled
891 Append_To (Actuals, New_Reference_To (Standard_True, Loc));
895 Append_To (Actuals, New_Reference_To (Standard_False, Loc));
902 New_Reference_To (Boolean_Literals (Present (Subpool)), Loc));
905 -- Step 2: Build a wrapper Allocate / Deallocate which internally
906 -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
908 -- Select the proper routine to call
911 Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
913 Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
916 -- Create a custom Allocate / Deallocate routine which has identical
917 -- profile to that of System.Storage_Pools.
920 Make_Subprogram_Body (Loc,
925 Make_Procedure_Specification (Loc,
926 Defining_Unit_Name => Proc_Id,
927 Parameter_Specifications => New_List (
929 -- P : Root_Storage_Pool
931 Make_Parameter_Specification (Loc,
932 Defining_Identifier => Make_Temporary (Loc, 'P'),
934 New_Reference_To (RTE (RE_Root_Storage_Pool), Loc)),
938 Make_Parameter_Specification (Loc,
939 Defining_Identifier => Addr_Id,
940 Out_Present => Is_Allocate,
942 New_Reference_To (RTE (RE_Address), Loc)),
946 Make_Parameter_Specification (Loc,
947 Defining_Identifier => Size_Id,
949 New_Reference_To (RTE (RE_Storage_Count), Loc)),
953 Make_Parameter_Specification (Loc,
954 Defining_Identifier => Alig_Id,
956 New_Reference_To (RTE (RE_Storage_Count), Loc)))),
958 Declarations => No_List,
960 Handled_Statement_Sequence =>
961 Make_Handled_Sequence_Of_Statements (Loc,
962 Statements => New_List (
963 Make_Procedure_Call_Statement (Loc,
964 Name => New_Reference_To (Proc_To_Call, Loc),
965 Parameter_Associations => Actuals)))));
967 -- The newly generated Allocate / Deallocate becomes the default
968 -- procedure to call when the back end processes the allocation /
972 Set_Procedure_To_Call (Expr, Proc_Id);
974 Set_Procedure_To_Call (N, Proc_Id);
977 end Build_Allocate_Deallocate_Proc;
979 ------------------------
980 -- Build_Runtime_Call --
981 ------------------------
983 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
985 -- If entity is not available, we can skip making the call (this avoids
986 -- junk duplicated error messages in a number of cases).
988 if not RTE_Available (RE) then
989 return Make_Null_Statement (Loc);
992 Make_Procedure_Call_Statement (Loc,
993 Name => New_Reference_To (RTE (RE), Loc));
995 end Build_Runtime_Call;
997 ----------------------------
998 -- Build_Task_Array_Image --
999 ----------------------------
1001 -- This function generates the body for a function that constructs the
1002 -- image string for a task that is an array component. The function is
1003 -- local to the init proc for the array type, and is called for each one
1004 -- of the components. The constructed image has the form of an indexed
1005 -- component, whose prefix is the outer variable of the array type.
1006 -- The n-dimensional array type has known indexes Index, Index2...
1008 -- Id_Ref is an indexed component form created by the enclosing init proc.
1009 -- Its successive indexes are Val1, Val2, ... which are the loop variables
1010 -- in the loops that call the individual task init proc on each component.
1012 -- The generated function has the following structure:
1014 -- function F return String is
1015 -- Pref : string renames Task_Name;
1016 -- T1 : String := Index1'Image (Val1);
1018 -- Tn : String := indexn'image (Valn);
1019 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
1020 -- -- Len includes commas and the end parentheses.
1021 -- Res : String (1..Len);
1022 -- Pos : Integer := Pref'Length;
1025 -- Res (1 .. Pos) := Pref;
1027 -- Res (Pos) := '(';
1029 -- Res (Pos .. Pos + T1'Length - 1) := T1;
1030 -- Pos := Pos + T1'Length;
1031 -- Res (Pos) := '.';
1034 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
1035 -- Res (Len) := ')';
1040 -- Needless to say, multidimensional arrays of tasks are rare enough that
1041 -- the bulkiness of this code is not really a concern.
1043 function Build_Task_Array_Image
1047 Dyn : Boolean := False) return Node_Id
1049 Dims : constant Nat := Number_Dimensions (A_Type);
1050 -- Number of dimensions for array of tasks
1052 Temps : array (1 .. Dims) of Entity_Id;
1053 -- Array of temporaries to hold string for each index
1059 -- Total length of generated name
1062 -- Running index for substring assignments
1064 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
1065 -- Name of enclosing variable, prefix of resulting name
1068 -- String to hold result
1071 -- Value of successive indexes
1074 -- Expression to compute total size of string
1077 -- Entity for name at one index position
1079 Decls : constant List_Id := New_List;
1080 Stats : constant List_Id := New_List;
1083 -- For a dynamic task, the name comes from the target variable. For a
1084 -- static one it is a formal of the enclosing init proc.
1087 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
1089 Make_Object_Declaration (Loc,
1090 Defining_Identifier => Pref,
1091 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1093 Make_String_Literal (Loc,
1094 Strval => String_From_Name_Buffer)));
1098 Make_Object_Renaming_Declaration (Loc,
1099 Defining_Identifier => Pref,
1100 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1101 Name => Make_Identifier (Loc, Name_uTask_Name)));
1104 Indx := First_Index (A_Type);
1105 Val := First (Expressions (Id_Ref));
1107 for J in 1 .. Dims loop
1108 T := Make_Temporary (Loc, 'T');
1112 Make_Object_Declaration (Loc,
1113 Defining_Identifier => T,
1114 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1116 Make_Attribute_Reference (Loc,
1117 Attribute_Name => Name_Image,
1118 Prefix => New_Occurrence_Of (Etype (Indx), Loc),
1119 Expressions => New_List (New_Copy_Tree (Val)))));
1125 Sum := Make_Integer_Literal (Loc, Dims + 1);
1131 Make_Attribute_Reference (Loc,
1132 Attribute_Name => Name_Length,
1133 Prefix => New_Occurrence_Of (Pref, Loc),
1134 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1136 for J in 1 .. Dims loop
1141 Make_Attribute_Reference (Loc,
1142 Attribute_Name => Name_Length,
1144 New_Occurrence_Of (Temps (J), Loc),
1145 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1148 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
1150 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
1153 Make_Assignment_Statement (Loc,
1155 Make_Indexed_Component (Loc,
1156 Prefix => New_Occurrence_Of (Res, Loc),
1157 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1159 Make_Character_Literal (Loc,
1161 Char_Literal_Value => UI_From_Int (Character'Pos ('(')))));
1164 Make_Assignment_Statement (Loc,
1165 Name => New_Occurrence_Of (Pos, Loc),
1168 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1169 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1171 for J in 1 .. Dims loop
1174 Make_Assignment_Statement (Loc,
1177 Prefix => New_Occurrence_Of (Res, Loc),
1180 Low_Bound => New_Occurrence_Of (Pos, Loc),
1182 Make_Op_Subtract (Loc,
1185 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1187 Make_Attribute_Reference (Loc,
1188 Attribute_Name => Name_Length,
1190 New_Occurrence_Of (Temps (J), Loc),
1192 New_List (Make_Integer_Literal (Loc, 1)))),
1193 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
1195 Expression => New_Occurrence_Of (Temps (J), Loc)));
1199 Make_Assignment_Statement (Loc,
1200 Name => New_Occurrence_Of (Pos, Loc),
1203 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1205 Make_Attribute_Reference (Loc,
1206 Attribute_Name => Name_Length,
1207 Prefix => New_Occurrence_Of (Temps (J), Loc),
1209 New_List (Make_Integer_Literal (Loc, 1))))));
1211 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
1214 Make_Assignment_Statement (Loc,
1215 Name => Make_Indexed_Component (Loc,
1216 Prefix => New_Occurrence_Of (Res, Loc),
1217 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1219 Make_Character_Literal (Loc,
1221 Char_Literal_Value => UI_From_Int (Character'Pos (',')))));
1224 Make_Assignment_Statement (Loc,
1225 Name => New_Occurrence_Of (Pos, Loc),
1228 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1229 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1233 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
1236 Make_Assignment_Statement (Loc,
1238 Make_Indexed_Component (Loc,
1239 Prefix => New_Occurrence_Of (Res, Loc),
1240 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
1242 Make_Character_Literal (Loc,
1244 Char_Literal_Value => UI_From_Int (Character'Pos (')')))));
1245 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
1246 end Build_Task_Array_Image;
1248 ----------------------------
1249 -- Build_Task_Image_Decls --
1250 ----------------------------
1252 function Build_Task_Image_Decls
1256 In_Init_Proc : Boolean := False) return List_Id
1258 Decls : constant List_Id := New_List;
1259 T_Id : Entity_Id := Empty;
1261 Expr : Node_Id := Empty;
1262 Fun : Node_Id := Empty;
1263 Is_Dyn : constant Boolean :=
1264 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
1266 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
1269 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
1270 -- generate a dummy declaration only.
1272 if Restriction_Active (No_Implicit_Heap_Allocations)
1273 or else Global_Discard_Names
1275 T_Id := Make_Temporary (Loc, 'J');
1280 Make_Object_Declaration (Loc,
1281 Defining_Identifier => T_Id,
1282 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1284 Make_String_Literal (Loc,
1285 Strval => String_From_Name_Buffer)));
1288 if Nkind (Id_Ref) = N_Identifier
1289 or else Nkind (Id_Ref) = N_Defining_Identifier
1291 -- For a simple variable, the image of the task is built from
1292 -- the name of the variable. To avoid possible conflict with the
1293 -- anonymous type created for a single protected object, add a
1297 Make_Defining_Identifier (Loc,
1298 New_External_Name (Chars (Id_Ref), 'T', 1));
1300 Get_Name_String (Chars (Id_Ref));
1303 Make_String_Literal (Loc,
1304 Strval => String_From_Name_Buffer);
1306 elsif Nkind (Id_Ref) = N_Selected_Component then
1308 Make_Defining_Identifier (Loc,
1309 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
1310 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
1312 elsif Nkind (Id_Ref) = N_Indexed_Component then
1314 Make_Defining_Identifier (Loc,
1315 New_External_Name (Chars (A_Type), 'N'));
1317 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
1321 if Present (Fun) then
1322 Append (Fun, Decls);
1323 Expr := Make_Function_Call (Loc,
1324 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
1326 if not In_Init_Proc and then VM_Target = No_VM then
1327 Set_Uses_Sec_Stack (Defining_Entity (Fun));
1331 Decl := Make_Object_Declaration (Loc,
1332 Defining_Identifier => T_Id,
1333 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1334 Constant_Present => True,
1335 Expression => Expr);
1337 Append (Decl, Decls);
1339 end Build_Task_Image_Decls;
1341 -------------------------------
1342 -- Build_Task_Image_Function --
1343 -------------------------------
1345 function Build_Task_Image_Function
1349 Res : Entity_Id) return Node_Id
1355 Make_Simple_Return_Statement (Loc,
1356 Expression => New_Occurrence_Of (Res, Loc)));
1358 Spec := Make_Function_Specification (Loc,
1359 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
1360 Result_Definition => New_Occurrence_Of (Standard_String, Loc));
1362 -- Calls to 'Image use the secondary stack, which must be cleaned up
1363 -- after the task name is built.
1365 return Make_Subprogram_Body (Loc,
1366 Specification => Spec,
1367 Declarations => Decls,
1368 Handled_Statement_Sequence =>
1369 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
1370 end Build_Task_Image_Function;
1372 -----------------------------
1373 -- Build_Task_Image_Prefix --
1374 -----------------------------
1376 procedure Build_Task_Image_Prefix
1378 Len : out Entity_Id;
1379 Res : out Entity_Id;
1380 Pos : out Entity_Id;
1387 Len := Make_Temporary (Loc, 'L', Sum);
1390 Make_Object_Declaration (Loc,
1391 Defining_Identifier => Len,
1392 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
1393 Expression => Sum));
1395 Res := Make_Temporary (Loc, 'R');
1398 Make_Object_Declaration (Loc,
1399 Defining_Identifier => Res,
1400 Object_Definition =>
1401 Make_Subtype_Indication (Loc,
1402 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1404 Make_Index_Or_Discriminant_Constraint (Loc,
1408 Low_Bound => Make_Integer_Literal (Loc, 1),
1409 High_Bound => New_Occurrence_Of (Len, Loc)))))));
1411 Pos := Make_Temporary (Loc, 'P');
1414 Make_Object_Declaration (Loc,
1415 Defining_Identifier => Pos,
1416 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
1418 -- Pos := Prefix'Length;
1421 Make_Assignment_Statement (Loc,
1422 Name => New_Occurrence_Of (Pos, Loc),
1424 Make_Attribute_Reference (Loc,
1425 Attribute_Name => Name_Length,
1426 Prefix => New_Occurrence_Of (Prefix, Loc),
1427 Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
1429 -- Res (1 .. Pos) := Prefix;
1432 Make_Assignment_Statement (Loc,
1435 Prefix => New_Occurrence_Of (Res, Loc),
1438 Low_Bound => Make_Integer_Literal (Loc, 1),
1439 High_Bound => New_Occurrence_Of (Pos, Loc))),
1441 Expression => New_Occurrence_Of (Prefix, Loc)));
1444 Make_Assignment_Statement (Loc,
1445 Name => New_Occurrence_Of (Pos, Loc),
1448 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1449 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1450 end Build_Task_Image_Prefix;
1452 -----------------------------
1453 -- Build_Task_Record_Image --
1454 -----------------------------
1456 function Build_Task_Record_Image
1459 Dyn : Boolean := False) return Node_Id
1462 -- Total length of generated name
1465 -- Index into result
1468 -- String to hold result
1470 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
1471 -- Name of enclosing variable, prefix of resulting name
1474 -- Expression to compute total size of string
1477 -- Entity for selector name
1479 Decls : constant List_Id := New_List;
1480 Stats : constant List_Id := New_List;
1483 -- For a dynamic task, the name comes from the target variable. For a
1484 -- static one it is a formal of the enclosing init proc.
1487 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
1489 Make_Object_Declaration (Loc,
1490 Defining_Identifier => Pref,
1491 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1493 Make_String_Literal (Loc,
1494 Strval => String_From_Name_Buffer)));
1498 Make_Object_Renaming_Declaration (Loc,
1499 Defining_Identifier => Pref,
1500 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1501 Name => Make_Identifier (Loc, Name_uTask_Name)));
1504 Sel := Make_Temporary (Loc, 'S');
1506 Get_Name_String (Chars (Selector_Name (Id_Ref)));
1509 Make_Object_Declaration (Loc,
1510 Defining_Identifier => Sel,
1511 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1513 Make_String_Literal (Loc,
1514 Strval => String_From_Name_Buffer)));
1516 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
1522 Make_Attribute_Reference (Loc,
1523 Attribute_Name => Name_Length,
1525 New_Occurrence_Of (Pref, Loc),
1526 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1528 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
1530 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
1532 -- Res (Pos) := '.';
1535 Make_Assignment_Statement (Loc,
1536 Name => Make_Indexed_Component (Loc,
1537 Prefix => New_Occurrence_Of (Res, Loc),
1538 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1540 Make_Character_Literal (Loc,
1542 Char_Literal_Value =>
1543 UI_From_Int (Character'Pos ('.')))));
1546 Make_Assignment_Statement (Loc,
1547 Name => New_Occurrence_Of (Pos, Loc),
1550 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1551 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1553 -- Res (Pos .. Len) := Selector;
1556 Make_Assignment_Statement (Loc,
1557 Name => Make_Slice (Loc,
1558 Prefix => New_Occurrence_Of (Res, Loc),
1561 Low_Bound => New_Occurrence_Of (Pos, Loc),
1562 High_Bound => New_Occurrence_Of (Len, Loc))),
1563 Expression => New_Occurrence_Of (Sel, Loc)));
1565 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
1566 end Build_Task_Record_Image;
1568 ----------------------------------
1569 -- Component_May_Be_Bit_Aligned --
1570 ----------------------------------
1572 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
1576 -- If no component clause, then everything is fine, since the back end
1577 -- never bit-misaligns by default, even if there is a pragma Packed for
1580 if No (Comp) or else No (Component_Clause (Comp)) then
1584 UT := Underlying_Type (Etype (Comp));
1586 -- It is only array and record types that cause trouble
1588 if not Is_Record_Type (UT)
1589 and then not Is_Array_Type (UT)
1593 -- If we know that we have a small (64 bits or less) record or small
1594 -- bit-packed array, then everything is fine, since the back end can
1595 -- handle these cases correctly.
1597 elsif Esize (Comp) <= 64
1598 and then (Is_Record_Type (UT)
1599 or else Is_Bit_Packed_Array (UT))
1603 -- Otherwise if the component is not byte aligned, we know we have the
1604 -- nasty unaligned case.
1606 elsif Normalized_First_Bit (Comp) /= Uint_0
1607 or else Esize (Comp) mod System_Storage_Unit /= Uint_0
1611 -- If we are large and byte aligned, then OK at this level
1616 end Component_May_Be_Bit_Aligned;
1618 -----------------------------------
1619 -- Corresponding_Runtime_Package --
1620 -----------------------------------
1622 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
1623 Pkg_Id : RTU_Id := RTU_Null;
1626 pragma Assert (Is_Concurrent_Type (Typ));
1628 if Ekind (Typ) in Protected_Kind then
1629 if Has_Entries (Typ)
1631 -- A protected type without entries that covers an interface and
1632 -- overrides the abstract routines with protected procedures is
1633 -- considered equivalent to a protected type with entries in the
1634 -- context of dispatching select statements. It is sufficient to
1635 -- check for the presence of an interface list in the declaration
1636 -- node to recognize this case.
1638 or else Present (Interface_List (Parent (Typ)))
1640 (((Has_Attach_Handler (Typ) and then not Restricted_Profile)
1641 or else Has_Interrupt_Handler (Typ))
1642 and then not Restriction_Active (No_Dynamic_Attachment))
1645 or else Restriction_Active (No_Entry_Queue) = False
1646 or else Number_Entries (Typ) > 1
1647 or else (Has_Attach_Handler (Typ)
1648 and then not Restricted_Profile)
1650 Pkg_Id := System_Tasking_Protected_Objects_Entries;
1652 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
1656 Pkg_Id := System_Tasking_Protected_Objects;
1661 end Corresponding_Runtime_Package;
1663 -------------------------------
1664 -- Convert_To_Actual_Subtype --
1665 -------------------------------
1667 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
1671 Act_ST := Get_Actual_Subtype (Exp);
1673 if Act_ST = Etype (Exp) then
1676 Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
1677 Analyze_And_Resolve (Exp, Act_ST);
1679 end Convert_To_Actual_Subtype;
1681 -----------------------------------
1682 -- Current_Sem_Unit_Declarations --
1683 -----------------------------------
1685 function Current_Sem_Unit_Declarations return List_Id is
1686 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
1690 -- If the current unit is a package body, locate the visible
1691 -- declarations of the package spec.
1693 if Nkind (U) = N_Package_Body then
1694 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
1697 if Nkind (U) = N_Package_Declaration then
1698 U := Specification (U);
1699 Decls := Visible_Declarations (U);
1703 Set_Visible_Declarations (U, Decls);
1707 Decls := Declarations (U);
1711 Set_Declarations (U, Decls);
1716 end Current_Sem_Unit_Declarations;
1718 -----------------------
1719 -- Duplicate_Subexpr --
1720 -----------------------
1722 function Duplicate_Subexpr
1724 Name_Req : Boolean := False) return Node_Id
1727 Remove_Side_Effects (Exp, Name_Req);
1728 return New_Copy_Tree (Exp);
1729 end Duplicate_Subexpr;
1731 ---------------------------------
1732 -- Duplicate_Subexpr_No_Checks --
1733 ---------------------------------
1735 function Duplicate_Subexpr_No_Checks
1737 Name_Req : Boolean := False) return Node_Id
1742 Remove_Side_Effects (Exp, Name_Req);
1743 New_Exp := New_Copy_Tree (Exp);
1744 Remove_Checks (New_Exp);
1746 end Duplicate_Subexpr_No_Checks;
1748 -----------------------------------
1749 -- Duplicate_Subexpr_Move_Checks --
1750 -----------------------------------
1752 function Duplicate_Subexpr_Move_Checks
1754 Name_Req : Boolean := False) return Node_Id
1758 Remove_Side_Effects (Exp, Name_Req);
1759 New_Exp := New_Copy_Tree (Exp);
1760 Remove_Checks (Exp);
1762 end Duplicate_Subexpr_Move_Checks;
1764 --------------------
1765 -- Ensure_Defined --
1766 --------------------
1768 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
1772 -- An itype reference must only be created if this is a local itype, so
1773 -- that gigi can elaborate it on the proper objstack.
1776 and then Scope (Typ) = Current_Scope
1778 IR := Make_Itype_Reference (Sloc (N));
1779 Set_Itype (IR, Typ);
1780 Insert_Action (N, IR);
1784 --------------------
1785 -- Entry_Names_OK --
1786 --------------------
1788 function Entry_Names_OK return Boolean is
1791 not Restricted_Profile
1792 and then not Global_Discard_Names
1793 and then not Restriction_Active (No_Implicit_Heap_Allocations)
1794 and then not Restriction_Active (No_Local_Allocators);
1801 procedure Evaluate_Name (Nam : Node_Id) is
1802 K : constant Node_Kind := Nkind (Nam);
1805 -- For an explicit dereference, we simply force the evaluation of the
1806 -- name expression. The dereference provides a value that is the address
1807 -- for the renamed object, and it is precisely this value that we want
1810 if K = N_Explicit_Dereference then
1811 Force_Evaluation (Prefix (Nam));
1813 -- For a selected component, we simply evaluate the prefix
1815 elsif K = N_Selected_Component then
1816 Evaluate_Name (Prefix (Nam));
1818 -- For an indexed component, or an attribute reference, we evaluate the
1819 -- prefix, which is itself a name, recursively, and then force the
1820 -- evaluation of all the subscripts (or attribute expressions).
1822 elsif Nkind_In (K, N_Indexed_Component, N_Attribute_Reference) then
1823 Evaluate_Name (Prefix (Nam));
1829 E := First (Expressions (Nam));
1830 while Present (E) loop
1831 Force_Evaluation (E);
1833 if Original_Node (E) /= E then
1834 Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E)));
1841 -- For a slice, we evaluate the prefix, as for the indexed component
1842 -- case and then, if there is a range present, either directly or as the
1843 -- constraint of a discrete subtype indication, we evaluate the two
1844 -- bounds of this range.
1846 elsif K = N_Slice then
1847 Evaluate_Name (Prefix (Nam));
1850 DR : constant Node_Id := Discrete_Range (Nam);
1855 if Nkind (DR) = N_Range then
1856 Force_Evaluation (Low_Bound (DR));
1857 Force_Evaluation (High_Bound (DR));
1859 elsif Nkind (DR) = N_Subtype_Indication then
1860 Constr := Constraint (DR);
1862 if Nkind (Constr) = N_Range_Constraint then
1863 Rexpr := Range_Expression (Constr);
1865 Force_Evaluation (Low_Bound (Rexpr));
1866 Force_Evaluation (High_Bound (Rexpr));
1871 -- For a type conversion, the expression of the conversion must be the
1872 -- name of an object, and we simply need to evaluate this name.
1874 elsif K = N_Type_Conversion then
1875 Evaluate_Name (Expression (Nam));
1877 -- For a function call, we evaluate the call
1879 elsif K = N_Function_Call then
1880 Force_Evaluation (Nam);
1882 -- The remaining cases are direct name, operator symbol and character
1883 -- literal. In all these cases, we do nothing, since we want to
1884 -- reevaluate each time the renamed object is used.
1891 ---------------------
1892 -- Evolve_And_Then --
1893 ---------------------
1895 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
1901 Make_And_Then (Sloc (Cond1),
1903 Right_Opnd => Cond1);
1905 end Evolve_And_Then;
1907 --------------------
1908 -- Evolve_Or_Else --
1909 --------------------
1911 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
1917 Make_Or_Else (Sloc (Cond1),
1919 Right_Opnd => Cond1);
1923 ------------------------------
1924 -- Expand_Subtype_From_Expr --
1925 ------------------------------
1927 -- This function is applicable for both static and dynamic allocation of
1928 -- objects which are constrained by an initial expression. Basically it
1929 -- transforms an unconstrained subtype indication into a constrained one.
1931 -- The expression may also be transformed in certain cases in order to
1932 -- avoid multiple evaluation. In the static allocation case, the general
1937 -- is transformed into
1939 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1941 -- Here are the main cases :
1943 -- <if Expr is a Slice>
1944 -- Val : T ([Index_Subtype (Expr)]) := Expr;
1946 -- <elsif Expr is a String Literal>
1947 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1949 -- <elsif Expr is Constrained>
1950 -- subtype T is Type_Of_Expr
1953 -- <elsif Expr is an entity_name>
1954 -- Val : T (constraints taken from Expr) := Expr;
1957 -- type Axxx is access all T;
1958 -- Rval : Axxx := Expr'ref;
1959 -- Val : T (constraints taken from Rval) := Rval.all;
1961 -- ??? note: when the Expression is allocated in the secondary stack
1962 -- we could use it directly instead of copying it by declaring
1963 -- Val : T (...) renames Rval.all
1965 procedure Expand_Subtype_From_Expr
1967 Unc_Type : Entity_Id;
1968 Subtype_Indic : Node_Id;
1971 Loc : constant Source_Ptr := Sloc (N);
1972 Exp_Typ : constant Entity_Id := Etype (Exp);
1976 -- In general we cannot build the subtype if expansion is disabled,
1977 -- because internal entities may not have been defined. However, to
1978 -- avoid some cascaded errors, we try to continue when the expression is
1979 -- an array (or string), because it is safe to compute the bounds. It is
1980 -- in fact required to do so even in a generic context, because there
1981 -- may be constants that depend on the bounds of a string literal, both
1982 -- standard string types and more generally arrays of characters.
1984 if not Expander_Active
1985 and then (No (Etype (Exp))
1986 or else not Is_String_Type (Etype (Exp)))
1991 if Nkind (Exp) = N_Slice then
1993 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
1996 Rewrite (Subtype_Indic,
1997 Make_Subtype_Indication (Loc,
1998 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
2000 Make_Index_Or_Discriminant_Constraint (Loc,
2001 Constraints => New_List
2002 (New_Reference_To (Slice_Type, Loc)))));
2004 -- This subtype indication may be used later for constraint checks
2005 -- we better make sure that if a variable was used as a bound of
2006 -- of the original slice, its value is frozen.
2008 Force_Evaluation (Low_Bound (Scalar_Range (Slice_Type)));
2009 Force_Evaluation (High_Bound (Scalar_Range (Slice_Type)));
2012 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
2013 Rewrite (Subtype_Indic,
2014 Make_Subtype_Indication (Loc,
2015 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
2017 Make_Index_Or_Discriminant_Constraint (Loc,
2018 Constraints => New_List (
2019 Make_Literal_Range (Loc,
2020 Literal_Typ => Exp_Typ)))));
2022 elsif Is_Constrained (Exp_Typ)
2023 and then not Is_Class_Wide_Type (Unc_Type)
2025 if Is_Itype (Exp_Typ) then
2027 -- Within an initialization procedure, a selected component
2028 -- denotes a component of the enclosing record, and it appears as
2029 -- an actual in a call to its own initialization procedure. If
2030 -- this component depends on the outer discriminant, we must
2031 -- generate the proper actual subtype for it.
2033 if Nkind (Exp) = N_Selected_Component
2034 and then Within_Init_Proc
2037 Decl : constant Node_Id :=
2038 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
2040 if Present (Decl) then
2041 Insert_Action (N, Decl);
2042 T := Defining_Identifier (Decl);
2048 -- No need to generate a new one (new what???)
2055 T := Make_Temporary (Loc, 'T');
2058 Make_Subtype_Declaration (Loc,
2059 Defining_Identifier => T,
2060 Subtype_Indication => New_Reference_To (Exp_Typ, Loc)));
2062 -- This type is marked as an itype even though it has an explicit
2063 -- declaration since otherwise Is_Generic_Actual_Type can get
2064 -- set, resulting in the generation of spurious errors. (See
2065 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
2068 Set_Associated_Node_For_Itype (T, Exp);
2071 Rewrite (Subtype_Indic, New_Reference_To (T, Loc));
2073 -- Nothing needs to be done for private types with unknown discriminants
2074 -- if the underlying type is not an unconstrained composite type or it
2075 -- is an unchecked union.
2077 elsif Is_Private_Type (Unc_Type)
2078 and then Has_Unknown_Discriminants (Unc_Type)
2079 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
2080 or else Is_Constrained (Underlying_Type (Unc_Type))
2081 or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
2085 -- Case of derived type with unknown discriminants where the parent type
2086 -- also has unknown discriminants.
2088 elsif Is_Record_Type (Unc_Type)
2089 and then not Is_Class_Wide_Type (Unc_Type)
2090 and then Has_Unknown_Discriminants (Unc_Type)
2091 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
2093 -- Nothing to be done if no underlying record view available
2095 if No (Underlying_Record_View (Unc_Type)) then
2098 -- Otherwise use the Underlying_Record_View to create the proper
2099 -- constrained subtype for an object of a derived type with unknown
2103 Remove_Side_Effects (Exp);
2104 Rewrite (Subtype_Indic,
2105 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
2108 -- Renamings of class-wide interface types require no equivalent
2109 -- constrained type declarations because we only need to reference
2110 -- the tag component associated with the interface. The same is
2111 -- presumably true for class-wide types in general, so this test
2112 -- is broadened to include all class-wide renamings, which also
2113 -- avoids cases of unbounded recursion in Remove_Side_Effects.
2114 -- (Is this really correct, or are there some cases of class-wide
2115 -- renamings that require action in this procedure???)
2118 and then Nkind (N) = N_Object_Renaming_Declaration
2119 and then Is_Class_Wide_Type (Unc_Type)
2123 -- In Ada 95 nothing to be done if the type of the expression is limited
2124 -- because in this case the expression cannot be copied, and its use can
2125 -- only be by reference.
2127 -- In Ada 2005 the context can be an object declaration whose expression
2128 -- is a function that returns in place. If the nominal subtype has
2129 -- unknown discriminants, the call still provides constraints on the
2130 -- object, and we have to create an actual subtype from it.
2132 -- If the type is class-wide, the expression is dynamically tagged and
2133 -- we do not create an actual subtype either. Ditto for an interface.
2134 -- For now this applies only if the type is immutably limited, and the
2135 -- function being called is build-in-place. This will have to be revised
2136 -- when build-in-place functions are generalized to other types.
2138 elsif Is_Immutably_Limited_Type (Exp_Typ)
2140 (Is_Class_Wide_Type (Exp_Typ)
2141 or else Is_Interface (Exp_Typ)
2142 or else not Has_Unknown_Discriminants (Exp_Typ)
2143 or else not Is_Composite_Type (Unc_Type))
2147 -- For limited objects initialized with build in place function calls,
2148 -- nothing to be done; otherwise we prematurely introduce an N_Reference
2149 -- node in the expression initializing the object, which breaks the
2150 -- circuitry that detects and adds the additional arguments to the
2153 elsif Is_Build_In_Place_Function_Call (Exp) then
2157 Remove_Side_Effects (Exp);
2158 Rewrite (Subtype_Indic,
2159 Make_Subtype_From_Expr (Exp, Unc_Type));
2161 end Expand_Subtype_From_Expr;
2163 --------------------
2164 -- Find_Init_Call --
2165 --------------------
2167 function Find_Init_Call
2169 Rep_Clause : Node_Id) return Node_Id
2171 Par : constant Node_Id := Parent (Var);
2172 Typ : constant Entity_Id := Etype (Var);
2174 Init_Proc : Entity_Id;
2175 -- Initialization procedure for Typ
2177 function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
2178 -- Look for init call for Var starting at From and scanning the
2179 -- enclosing list until Rep_Clause or the end of the list is reached.
2181 ----------------------------
2182 -- Find_Init_Call_In_List --
2183 ----------------------------
2185 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
2186 Init_Call : Node_Id;
2190 while Present (Init_Call) and then Init_Call /= Rep_Clause loop
2191 if Nkind (Init_Call) = N_Procedure_Call_Statement
2192 and then Is_Entity_Name (Name (Init_Call))
2193 and then Entity (Name (Init_Call)) = Init_Proc
2202 end Find_Init_Call_In_List;
2204 Init_Call : Node_Id;
2206 -- Start of processing for Find_Init_Call
2209 if not Has_Non_Null_Base_Init_Proc (Typ) then
2211 -- No init proc for the type, so obviously no call to be found
2216 Init_Proc := Base_Init_Proc (Typ);
2218 -- First scan the list containing the declaration of Var
2220 Init_Call := Find_Init_Call_In_List (From => Next (Par));
2222 -- If not found, also look on Var's freeze actions list, if any, since
2223 -- the init call may have been moved there (case of an address clause
2224 -- applying to Var).
2226 if No (Init_Call) and then Present (Freeze_Node (Var)) then
2228 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
2231 -- If the initialization call has actuals that use the secondary stack,
2232 -- the call may have been wrapped into a temporary block, in which case
2233 -- the block itself has to be removed.
2235 if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then
2237 Blk : constant Node_Id := Next (Par);
2240 (Find_Init_Call_In_List
2241 (First (Statements (Handled_Statement_Sequence (Blk)))))
2251 ------------------------
2252 -- Find_Interface_ADT --
2253 ------------------------
2255 function Find_Interface_ADT
2257 Iface : Entity_Id) return Elmt_Id
2260 Typ : Entity_Id := T;
2263 pragma Assert (Is_Interface (Iface));
2265 -- Handle private types
2267 if Has_Private_Declaration (Typ)
2268 and then Present (Full_View (Typ))
2270 Typ := Full_View (Typ);
2273 -- Handle access types
2275 if Is_Access_Type (Typ) then
2276 Typ := Designated_Type (Typ);
2279 -- Handle task and protected types implementing interfaces
2281 if Is_Concurrent_Type (Typ) then
2282 Typ := Corresponding_Record_Type (Typ);
2286 (not Is_Class_Wide_Type (Typ)
2287 and then Ekind (Typ) /= E_Incomplete_Type);
2289 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
2290 return First_Elmt (Access_Disp_Table (Typ));
2294 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
2296 and then Present (Related_Type (Node (ADT)))
2297 and then Related_Type (Node (ADT)) /= Iface
2298 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
2299 Use_Full_View => True)
2304 pragma Assert (Present (Related_Type (Node (ADT))));
2307 end Find_Interface_ADT;
2309 ------------------------
2310 -- Find_Interface_Tag --
2311 ------------------------
2313 function Find_Interface_Tag
2315 Iface : Entity_Id) return Entity_Id
2318 Found : Boolean := False;
2319 Typ : Entity_Id := T;
2321 procedure Find_Tag (Typ : Entity_Id);
2322 -- Internal subprogram used to recursively climb to the ancestors
2328 procedure Find_Tag (Typ : Entity_Id) is
2333 -- This routine does not handle the case in which the interface is an
2334 -- ancestor of Typ. That case is handled by the enclosing subprogram.
2336 pragma Assert (Typ /= Iface);
2338 -- Climb to the root type handling private types
2340 if Present (Full_View (Etype (Typ))) then
2341 if Full_View (Etype (Typ)) /= Typ then
2342 Find_Tag (Full_View (Etype (Typ)));
2345 elsif Etype (Typ) /= Typ then
2346 Find_Tag (Etype (Typ));
2349 -- Traverse the list of interfaces implemented by the type
2352 and then Present (Interfaces (Typ))
2353 and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
2355 -- Skip the tag associated with the primary table
2357 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
2358 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
2359 pragma Assert (Present (AI_Tag));
2361 AI_Elmt := First_Elmt (Interfaces (Typ));
2362 while Present (AI_Elmt) loop
2363 AI := Node (AI_Elmt);
2366 or else Is_Ancestor (Iface, AI, Use_Full_View => True)
2372 AI_Tag := Next_Tag_Component (AI_Tag);
2373 Next_Elmt (AI_Elmt);
2378 -- Start of processing for Find_Interface_Tag
2381 pragma Assert (Is_Interface (Iface));
2383 -- Handle access types
2385 if Is_Access_Type (Typ) then
2386 Typ := Designated_Type (Typ);
2389 -- Handle class-wide types
2391 if Is_Class_Wide_Type (Typ) then
2392 Typ := Root_Type (Typ);
2395 -- Handle private types
2397 if Has_Private_Declaration (Typ)
2398 and then Present (Full_View (Typ))
2400 Typ := Full_View (Typ);
2403 -- Handle entities from the limited view
2405 if Ekind (Typ) = E_Incomplete_Type then
2406 pragma Assert (Present (Non_Limited_View (Typ)));
2407 Typ := Non_Limited_View (Typ);
2410 -- Handle task and protected types implementing interfaces
2412 if Is_Concurrent_Type (Typ) then
2413 Typ := Corresponding_Record_Type (Typ);
2416 -- If the interface is an ancestor of the type, then it shared the
2417 -- primary dispatch table.
2419 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
2420 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
2421 return First_Tag_Component (Typ);
2423 -- Otherwise we need to search for its associated tag component
2427 pragma Assert (Found);
2430 end Find_Interface_Tag;
2436 function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
2438 Typ : Entity_Id := T;
2442 if Is_Class_Wide_Type (Typ) then
2443 Typ := Root_Type (Typ);
2446 Typ := Underlying_Type (Typ);
2448 -- Loop through primitive operations
2450 Prim := First_Elmt (Primitive_Operations (Typ));
2451 while Present (Prim) loop
2454 -- We can retrieve primitive operations by name if it is an internal
2455 -- name. For equality we must check that both of its operands have
2456 -- the same type, to avoid confusion with user-defined equalities
2457 -- than may have a non-symmetric signature.
2459 exit when Chars (Op) = Name
2462 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
2466 -- Raise Program_Error if no primitive found
2469 raise Program_Error;
2480 function Find_Prim_Op
2482 Name : TSS_Name_Type) return Entity_Id
2484 Inher_Op : Entity_Id := Empty;
2485 Own_Op : Entity_Id := Empty;
2486 Prim_Elmt : Elmt_Id;
2487 Prim_Id : Entity_Id;
2488 Typ : Entity_Id := T;
2491 if Is_Class_Wide_Type (Typ) then
2492 Typ := Root_Type (Typ);
2495 Typ := Underlying_Type (Typ);
2497 -- This search is based on the assertion that the dispatching version
2498 -- of the TSS routine always precedes the real primitive.
2500 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
2501 while Present (Prim_Elmt) loop
2502 Prim_Id := Node (Prim_Elmt);
2504 if Is_TSS (Prim_Id, Name) then
2505 if Present (Alias (Prim_Id)) then
2506 Inher_Op := Prim_Id;
2512 Next_Elmt (Prim_Elmt);
2515 if Present (Own_Op) then
2517 elsif Present (Inher_Op) then
2520 raise Program_Error;
2524 ----------------------------
2525 -- Find_Protection_Object --
2526 ----------------------------
2528 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
2533 while Present (S) loop
2534 if (Ekind (S) = E_Entry
2535 or else Ekind (S) = E_Entry_Family
2536 or else Ekind (S) = E_Function
2537 or else Ekind (S) = E_Procedure)
2538 and then Present (Protection_Object (S))
2540 return Protection_Object (S);
2546 -- If we do not find a Protection object in the scope chain, then
2547 -- something has gone wrong, most likely the object was never created.
2549 raise Program_Error;
2550 end Find_Protection_Object;
2552 --------------------------
2553 -- Find_Protection_Type --
2554 --------------------------
2556 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
2558 Typ : Entity_Id := Conc_Typ;
2561 if Is_Concurrent_Type (Typ) then
2562 Typ := Corresponding_Record_Type (Typ);
2565 -- Since restriction violations are not considered serious errors, the
2566 -- expander remains active, but may leave the corresponding record type
2567 -- malformed. In such cases, component _object is not available so do
2570 if not Analyzed (Typ) then
2574 Comp := First_Component (Typ);
2575 while Present (Comp) loop
2576 if Chars (Comp) = Name_uObject then
2577 return Base_Type (Etype (Comp));
2580 Next_Component (Comp);
2583 -- The corresponding record of a protected type should always have an
2586 raise Program_Error;
2587 end Find_Protection_Type;
2589 ----------------------
2590 -- Force_Evaluation --
2591 ----------------------
2593 procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
2595 Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
2596 end Force_Evaluation;
2598 ---------------------------------
2599 -- Fully_Qualified_Name_String --
2600 ---------------------------------
2602 function Fully_Qualified_Name_String (E : Entity_Id) return String_Id is
2603 procedure Internal_Full_Qualified_Name (E : Entity_Id);
2604 -- Compute recursively the qualified name without NUL at the end, adding
2605 -- it to the currently started string being generated
2607 ----------------------------------
2608 -- Internal_Full_Qualified_Name --
2609 ----------------------------------
2611 procedure Internal_Full_Qualified_Name (E : Entity_Id) is
2615 -- Deal properly with child units
2617 if Nkind (E) = N_Defining_Program_Unit_Name then
2618 Ent := Defining_Identifier (E);
2623 -- Compute qualification recursively (only "Standard" has no scope)
2625 if Present (Scope (Scope (Ent))) then
2626 Internal_Full_Qualified_Name (Scope (Ent));
2627 Store_String_Char (Get_Char_Code ('.'));
2630 -- Every entity should have a name except some expanded blocks
2631 -- don't bother about those.
2633 if Chars (Ent) = No_Name then
2637 -- Generates the entity name in upper case
2639 Get_Decoded_Name_String (Chars (Ent));
2641 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2643 end Internal_Full_Qualified_Name;
2645 -- Start of processing for Full_Qualified_Name
2649 Internal_Full_Qualified_Name (E);
2650 Store_String_Char (Get_Char_Code (ASCII.NUL));
2652 end Fully_Qualified_Name_String;
2654 ------------------------
2655 -- Generate_Poll_Call --
2656 ------------------------
2658 procedure Generate_Poll_Call (N : Node_Id) is
2660 -- No poll call if polling not active
2662 if not Polling_Required then
2665 -- Otherwise generate require poll call
2668 Insert_Before_And_Analyze (N,
2669 Make_Procedure_Call_Statement (Sloc (N),
2670 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
2672 end Generate_Poll_Call;
2674 ---------------------------------
2675 -- Get_Current_Value_Condition --
2676 ---------------------------------
2678 -- Note: the implementation of this procedure is very closely tied to the
2679 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
2680 -- interpret Current_Value fields set by the Set procedure, so the two
2681 -- procedures need to be closely coordinated.
2683 procedure Get_Current_Value_Condition
2688 Loc : constant Source_Ptr := Sloc (Var);
2689 Ent : constant Entity_Id := Entity (Var);
2691 procedure Process_Current_Value_Condition
2694 -- N is an expression which holds either True (S = True) or False (S =
2695 -- False) in the condition. This procedure digs out the expression and
2696 -- if it refers to Ent, sets Op and Val appropriately.
2698 -------------------------------------
2699 -- Process_Current_Value_Condition --
2700 -------------------------------------
2702 procedure Process_Current_Value_Condition
2713 -- Deal with NOT operators, inverting sense
2715 while Nkind (Cond) = N_Op_Not loop
2716 Cond := Right_Opnd (Cond);
2720 -- Deal with AND THEN and AND cases
2722 if Nkind (Cond) = N_And_Then
2723 or else Nkind (Cond) = N_Op_And
2725 -- Don't ever try to invert a condition that is of the form of an
2726 -- AND or AND THEN (since we are not doing sufficiently general
2727 -- processing to allow this).
2729 if Sens = False then
2735 -- Recursively process AND and AND THEN branches
2737 Process_Current_Value_Condition (Left_Opnd (Cond), True);
2739 if Op /= N_Empty then
2743 Process_Current_Value_Condition (Right_Opnd (Cond), True);
2746 -- Case of relational operator
2748 elsif Nkind (Cond) in N_Op_Compare then
2751 -- Invert sense of test if inverted test
2753 if Sens = False then
2755 when N_Op_Eq => Op := N_Op_Ne;
2756 when N_Op_Ne => Op := N_Op_Eq;
2757 when N_Op_Lt => Op := N_Op_Ge;
2758 when N_Op_Gt => Op := N_Op_Le;
2759 when N_Op_Le => Op := N_Op_Gt;
2760 when N_Op_Ge => Op := N_Op_Lt;
2761 when others => raise Program_Error;
2765 -- Case of entity op value
2767 if Is_Entity_Name (Left_Opnd (Cond))
2768 and then Ent = Entity (Left_Opnd (Cond))
2769 and then Compile_Time_Known_Value (Right_Opnd (Cond))
2771 Val := Right_Opnd (Cond);
2773 -- Case of value op entity
2775 elsif Is_Entity_Name (Right_Opnd (Cond))
2776 and then Ent = Entity (Right_Opnd (Cond))
2777 and then Compile_Time_Known_Value (Left_Opnd (Cond))
2779 Val := Left_Opnd (Cond);
2781 -- We are effectively swapping operands
2784 when N_Op_Eq => null;
2785 when N_Op_Ne => null;
2786 when N_Op_Lt => Op := N_Op_Gt;
2787 when N_Op_Gt => Op := N_Op_Lt;
2788 when N_Op_Le => Op := N_Op_Ge;
2789 when N_Op_Ge => Op := N_Op_Le;
2790 when others => raise Program_Error;
2799 -- Case of Boolean variable reference, return as though the
2800 -- reference had said var = True.
2803 if Is_Entity_Name (Cond)
2804 and then Ent = Entity (Cond)
2806 Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
2808 if Sens = False then
2815 end Process_Current_Value_Condition;
2817 -- Start of processing for Get_Current_Value_Condition
2823 -- Immediate return, nothing doing, if this is not an object
2825 if Ekind (Ent) not in Object_Kind then
2829 -- Otherwise examine current value
2832 CV : constant Node_Id := Current_Value (Ent);
2837 -- If statement. Condition is known true in THEN section, known False
2838 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
2840 if Nkind (CV) = N_If_Statement then
2842 -- Before start of IF statement
2844 if Loc < Sloc (CV) then
2847 -- After end of IF statement
2849 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
2853 -- At this stage we know that we are within the IF statement, but
2854 -- unfortunately, the tree does not record the SLOC of the ELSE so
2855 -- we cannot use a simple SLOC comparison to distinguish between
2856 -- the then/else statements, so we have to climb the tree.
2863 while Parent (N) /= CV loop
2866 -- If we fall off the top of the tree, then that's odd, but
2867 -- perhaps it could occur in some error situation, and the
2868 -- safest response is simply to assume that the outcome of
2869 -- the condition is unknown. No point in bombing during an
2870 -- attempt to optimize things.
2877 -- Now we have N pointing to a node whose parent is the IF
2878 -- statement in question, so now we can tell if we are within
2879 -- the THEN statements.
2881 if Is_List_Member (N)
2882 and then List_Containing (N) = Then_Statements (CV)
2886 -- If the variable reference does not come from source, we
2887 -- cannot reliably tell whether it appears in the else part.
2888 -- In particular, if it appears in generated code for a node
2889 -- that requires finalization, it may be attached to a list
2890 -- that has not been yet inserted into the code. For now,
2891 -- treat it as unknown.
2893 elsif not Comes_From_Source (N) then
2896 -- Otherwise we must be in ELSIF or ELSE part
2903 -- ELSIF part. Condition is known true within the referenced
2904 -- ELSIF, known False in any subsequent ELSIF or ELSE part,
2905 -- and unknown before the ELSE part or after the IF statement.
2907 elsif Nkind (CV) = N_Elsif_Part then
2909 -- if the Elsif_Part had condition_actions, the elsif has been
2910 -- rewritten as a nested if, and the original elsif_part is
2911 -- detached from the tree, so there is no way to obtain useful
2912 -- information on the current value of the variable.
2913 -- Can this be improved ???
2915 if No (Parent (CV)) then
2921 -- Before start of ELSIF part
2923 if Loc < Sloc (CV) then
2926 -- After end of IF statement
2928 elsif Loc >= Sloc (Stm) +
2929 Text_Ptr (UI_To_Int (End_Span (Stm)))
2934 -- Again we lack the SLOC of the ELSE, so we need to climb the
2935 -- tree to see if we are within the ELSIF part in question.
2942 while Parent (N) /= Stm loop
2945 -- If we fall off the top of the tree, then that's odd, but
2946 -- perhaps it could occur in some error situation, and the
2947 -- safest response is simply to assume that the outcome of
2948 -- the condition is unknown. No point in bombing during an
2949 -- attempt to optimize things.
2956 -- Now we have N pointing to a node whose parent is the IF
2957 -- statement in question, so see if is the ELSIF part we want.
2958 -- the THEN statements.
2963 -- Otherwise we must be in subsequent ELSIF or ELSE part
2970 -- Iteration scheme of while loop. The condition is known to be
2971 -- true within the body of the loop.
2973 elsif Nkind (CV) = N_Iteration_Scheme then
2975 Loop_Stmt : constant Node_Id := Parent (CV);
2978 -- Before start of body of loop
2980 if Loc < Sloc (Loop_Stmt) then
2983 -- After end of LOOP statement
2985 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
2988 -- We are within the body of the loop
2995 -- All other cases of Current_Value settings
3001 -- If we fall through here, then we have a reportable condition, Sens
3002 -- is True if the condition is true and False if it needs inverting.
3004 Process_Current_Value_Condition (Condition (CV), Sens);
3006 end Get_Current_Value_Condition;
3008 ---------------------
3009 -- Get_Stream_Size --
3010 ---------------------
3012 function Get_Stream_Size (E : Entity_Id) return Uint is
3014 -- If we have a Stream_Size clause for this type use it
3016 if Has_Stream_Size_Clause (E) then
3017 return Static_Integer (Expression (Stream_Size_Clause (E)));
3019 -- Otherwise the Stream_Size if the size of the type
3024 end Get_Stream_Size;
3026 ---------------------------
3027 -- Has_Access_Constraint --
3028 ---------------------------
3030 function Has_Access_Constraint (E : Entity_Id) return Boolean is
3032 T : constant Entity_Id := Etype (E);
3035 if Has_Per_Object_Constraint (E)
3036 and then Has_Discriminants (T)
3038 Disc := First_Discriminant (T);
3039 while Present (Disc) loop
3040 if Is_Access_Type (Etype (Disc)) then
3044 Next_Discriminant (Disc);
3051 end Has_Access_Constraint;
3053 ----------------------------------
3054 -- Has_Following_Address_Clause --
3055 ----------------------------------
3057 -- Should this function check the private part in a package ???
3059 function Has_Following_Address_Clause (D : Node_Id) return Boolean is
3060 Id : constant Entity_Id := Defining_Identifier (D);
3065 while Present (Decl) loop
3066 if Nkind (Decl) = N_At_Clause
3067 and then Chars (Identifier (Decl)) = Chars (Id)
3071 elsif Nkind (Decl) = N_Attribute_Definition_Clause
3072 and then Chars (Decl) = Name_Address
3073 and then Chars (Name (Decl)) = Chars (Id)
3082 end Has_Following_Address_Clause;
3084 --------------------
3085 -- Homonym_Number --
3086 --------------------
3088 function Homonym_Number (Subp : Entity_Id) return Nat is
3094 Hom := Homonym (Subp);
3095 while Present (Hom) loop
3096 if Scope (Hom) = Scope (Subp) then
3100 Hom := Homonym (Hom);
3106 -----------------------------------
3107 -- In_Library_Level_Package_Body --
3108 -----------------------------------
3110 function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
3112 -- First determine whether the entity appears at the library level, then
3113 -- look at the containing unit.
3115 if Is_Library_Level_Entity (Id) then
3117 Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
3120 return Nkind (Unit (Container)) = N_Package_Body;
3125 end In_Library_Level_Package_Body;
3127 ------------------------------
3128 -- In_Unconditional_Context --
3129 ------------------------------
3131 function In_Unconditional_Context (Node : Node_Id) return Boolean is
3136 while Present (P) loop
3138 when N_Subprogram_Body =>
3141 when N_If_Statement =>
3144 when N_Loop_Statement =>
3147 when N_Case_Statement =>
3156 end In_Unconditional_Context;
3162 procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
3164 if Present (Ins_Action) then
3165 Insert_Actions (Assoc_Node, New_List (Ins_Action));
3169 -- Version with check(s) suppressed
3171 procedure Insert_Action
3172 (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
3175 Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
3178 -------------------------
3179 -- Insert_Action_After --
3180 -------------------------
3182 procedure Insert_Action_After
3183 (Assoc_Node : Node_Id;
3184 Ins_Action : Node_Id)
3187 Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
3188 end Insert_Action_After;
3190 --------------------
3191 -- Insert_Actions --
3192 --------------------
3194 procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
3198 Wrapped_Node : Node_Id := Empty;
3201 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
3205 -- Ignore insert of actions from inside default expression (or other
3206 -- similar "spec expression") in the special spec-expression analyze
3207 -- mode. Any insertions at this point have no relevance, since we are
3208 -- only doing the analyze to freeze the types of any static expressions.
3209 -- See section "Handling of Default Expressions" in the spec of package
3210 -- Sem for further details.
3212 if In_Spec_Expression then
3216 -- If the action derives from stuff inside a record, then the actions
3217 -- are attached to the current scope, to be inserted and analyzed on
3218 -- exit from the scope. The reason for this is that we may also be
3219 -- generating freeze actions at the same time, and they must eventually
3220 -- be elaborated in the correct order.
3222 if Is_Record_Type (Current_Scope)
3223 and then not Is_Frozen (Current_Scope)
3225 if No (Scope_Stack.Table
3226 (Scope_Stack.Last).Pending_Freeze_Actions)
3228 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
3233 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
3239 -- We now intend to climb up the tree to find the right point to
3240 -- insert the actions. We start at Assoc_Node, unless this node is a
3241 -- subexpression in which case we start with its parent. We do this for
3242 -- two reasons. First it speeds things up. Second, if Assoc_Node is
3243 -- itself one of the special nodes like N_And_Then, then we assume that
3244 -- an initial request to insert actions for such a node does not expect
3245 -- the actions to get deposited in the node for later handling when the
3246 -- node is expanded, since clearly the node is being dealt with by the
3247 -- caller. Note that in the subexpression case, N is always the child we
3250 -- N_Raise_xxx_Error is an annoying special case, it is a statement if
3251 -- it has type Standard_Void_Type, and a subexpression otherwise.
3252 -- otherwise. Procedure attribute references are also statements.
3254 if Nkind (Assoc_Node) in N_Subexpr
3255 and then (Nkind (Assoc_Node) in N_Raise_xxx_Error
3256 or else Etype (Assoc_Node) /= Standard_Void_Type)
3257 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
3259 not Is_Procedure_Attribute_Name
3260 (Attribute_Name (Assoc_Node)))
3262 P := Assoc_Node; -- ??? does not agree with above!
3263 N := Parent (Assoc_Node);
3265 -- Non-subexpression case. Note that N is initially Empty in this case
3266 -- (N is only guaranteed Non-Empty in the subexpr case).
3273 -- Capture root of the transient scope
3275 if Scope_Is_Transient then
3276 Wrapped_Node := Node_To_Be_Wrapped;
3280 pragma Assert (Present (P));
3284 -- Case of right operand of AND THEN or OR ELSE. Put the actions
3285 -- in the Actions field of the right operand. They will be moved
3286 -- out further when the AND THEN or OR ELSE operator is expanded.
3287 -- Nothing special needs to be done for the left operand since
3288 -- in that case the actions are executed unconditionally.
3290 when N_Short_Circuit =>
3291 if N = Right_Opnd (P) then
3293 -- We are now going to either append the actions to the
3294 -- actions field of the short-circuit operation. We will
3295 -- also analyze the actions now.
3297 -- This analysis is really too early, the proper thing would
3298 -- be to just park them there now, and only analyze them if
3299 -- we find we really need them, and to it at the proper
3300 -- final insertion point. However attempting to this proved
3301 -- tricky, so for now we just kill current values before and
3302 -- after the analyze call to make sure we avoid peculiar
3303 -- optimizations from this out of order insertion.
3305 Kill_Current_Values;
3307 if Present (Actions (P)) then
3308 Insert_List_After_And_Analyze
3309 (Last (Actions (P)), Ins_Actions);
3311 Set_Actions (P, Ins_Actions);
3312 Analyze_List (Actions (P));
3315 Kill_Current_Values;
3320 -- Then or Else dependent expression of an if expression. Add
3321 -- actions to Then_Actions or Else_Actions field as appropriate.
3322 -- The actions will be moved further out when the if is expanded.
3324 when N_If_Expression =>
3326 ThenX : constant Node_Id := Next (First (Expressions (P)));
3327 ElseX : constant Node_Id := Next (ThenX);
3330 -- If the enclosing expression is already analyzed, as
3331 -- is the case for nested elaboration checks, insert the
3332 -- conditional further out.
3334 if Analyzed (P) then
3337 -- Actions belong to the then expression, temporarily place
3338 -- them as Then_Actions of the if expression. They will be
3339 -- moved to the proper place later when the if expression
3342 elsif N = ThenX then
3343 if Present (Then_Actions (P)) then
3344 Insert_List_After_And_Analyze
3345 (Last (Then_Actions (P)), Ins_Actions);
3347 Set_Then_Actions (P, Ins_Actions);
3348 Analyze_List (Then_Actions (P));
3353 -- Actions belong to the else expression, temporarily place
3354 -- them as Else_Actions of the if expression. They will be
3355 -- moved to the proper place later when the if expression
3358 elsif N = ElseX then
3359 if Present (Else_Actions (P)) then
3360 Insert_List_After_And_Analyze
3361 (Last (Else_Actions (P)), Ins_Actions);
3363 Set_Else_Actions (P, Ins_Actions);
3364 Analyze_List (Else_Actions (P));
3369 -- Actions belong to the condition. In this case they are
3370 -- unconditionally executed, and so we can continue the
3371 -- search for the proper insert point.
3378 -- Alternative of case expression, we place the action in the
3379 -- Actions field of the case expression alternative, this will
3380 -- be handled when the case expression is expanded.
3382 when N_Case_Expression_Alternative =>
3383 if Present (Actions (P)) then
3384 Insert_List_After_And_Analyze
3385 (Last (Actions (P)), Ins_Actions);
3387 Set_Actions (P, Ins_Actions);
3388 Analyze_List (Actions (P));
3393 -- Case of appearing within an Expressions_With_Actions node. We
3394 -- prepend the actions to the list of actions already there, if
3395 -- the node has not been analyzed yet. Otherwise find insertion
3396 -- location further up the tree.
3398 when N_Expression_With_Actions =>
3399 if not Analyzed (P) then
3400 Prepend_List (Ins_Actions, Actions (P));
3404 -- Case of appearing in the condition of a while expression or
3405 -- elsif. We insert the actions into the Condition_Actions field.
3406 -- They will be moved further out when the while loop or elsif
3409 when N_Iteration_Scheme |
3412 if N = Condition (P) then
3413 if Present (Condition_Actions (P)) then
3414 Insert_List_After_And_Analyze
3415 (Last (Condition_Actions (P)), Ins_Actions);
3417 Set_Condition_Actions (P, Ins_Actions);
3419 -- Set the parent of the insert actions explicitly. This
3420 -- is not a syntactic field, but we need the parent field
3421 -- set, in particular so that freeze can understand that
3422 -- it is dealing with condition actions, and properly
3423 -- insert the freezing actions.
3425 Set_Parent (Ins_Actions, P);
3426 Analyze_List (Condition_Actions (P));
3432 -- Statements, declarations, pragmas, representation clauses
3437 N_Procedure_Call_Statement |
3438 N_Statement_Other_Than_Procedure_Call |
3444 -- Representation_Clause
3447 N_Attribute_Definition_Clause |
3448 N_Enumeration_Representation_Clause |
3449 N_Record_Representation_Clause |
3453 N_Abstract_Subprogram_Declaration |
3455 N_Exception_Declaration |
3456 N_Exception_Renaming_Declaration |
3457 N_Expression_Function |
3458 N_Formal_Abstract_Subprogram_Declaration |
3459 N_Formal_Concrete_Subprogram_Declaration |
3460 N_Formal_Object_Declaration |
3461 N_Formal_Type_Declaration |
3462 N_Full_Type_Declaration |
3463 N_Function_Instantiation |
3464 N_Generic_Function_Renaming_Declaration |
3465 N_Generic_Package_Declaration |
3466 N_Generic_Package_Renaming_Declaration |
3467 N_Generic_Procedure_Renaming_Declaration |
3468 N_Generic_Subprogram_Declaration |
3469 N_Implicit_Label_Declaration |
3470 N_Incomplete_Type_Declaration |
3471 N_Number_Declaration |
3472 N_Object_Declaration |
3473 N_Object_Renaming_Declaration |
3475 N_Package_Body_Stub |
3476 N_Package_Declaration |
3477 N_Package_Instantiation |
3478 N_Package_Renaming_Declaration |
3479 N_Private_Extension_Declaration |
3480 N_Private_Type_Declaration |
3481 N_Procedure_Instantiation |
3483 N_Protected_Body_Stub |
3484 N_Protected_Type_Declaration |
3485 N_Single_Task_Declaration |
3487 N_Subprogram_Body_Stub |
3488 N_Subprogram_Declaration |
3489 N_Subprogram_Renaming_Declaration |
3490 N_Subtype_Declaration |
3493 N_Task_Type_Declaration |
3495 -- Use clauses can appear in lists of declarations
3497 N_Use_Package_Clause |
3500 -- Freeze entity behaves like a declaration or statement
3504 -- Do not insert here if the item is not a list member (this
3505 -- happens for example with a triggering statement, and the
3506 -- proper approach is to insert before the entire select).
3508 if not Is_List_Member (P) then
3511 -- Do not insert if parent of P is an N_Component_Association
3512 -- node (i.e. we are in the context of an N_Aggregate or
3513 -- N_Extension_Aggregate node. In this case we want to insert
3514 -- before the entire aggregate.
3516 elsif Nkind (Parent (P)) = N_Component_Association then
3519 -- Do not insert if the parent of P is either an N_Variant node
3520 -- or an N_Record_Definition node, meaning in either case that
3521 -- P is a member of a component list, and that therefore the
3522 -- actions should be inserted outside the complete record
3525 elsif Nkind (Parent (P)) = N_Variant
3526 or else Nkind (Parent (P)) = N_Record_Definition
3530 -- Do not insert freeze nodes within the loop generated for
3531 -- an aggregate, because they may be elaborated too late for
3532 -- subsequent use in the back end: within a package spec the
3533 -- loop is part of the elaboration procedure and is only
3534 -- elaborated during the second pass.
3536 -- If the loop comes from source, or the entity is local to the
3537 -- loop itself it must remain within.
3539 elsif Nkind (Parent (P)) = N_Loop_Statement
3540 and then not Comes_From_Source (Parent (P))
3541 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
3543 Scope (Entity (First (Ins_Actions))) /= Current_Scope
3547 -- Otherwise we can go ahead and do the insertion
3549 elsif P = Wrapped_Node then
3550 Store_Before_Actions_In_Scope (Ins_Actions);
3554 Insert_List_Before_And_Analyze (P, Ins_Actions);
3558 -- A special case, N_Raise_xxx_Error can act either as a statement
3559 -- or a subexpression. We tell the difference by looking at the
3560 -- Etype. It is set to Standard_Void_Type in the statement case.
3563 N_Raise_xxx_Error =>
3564 if Etype (P) = Standard_Void_Type then
3565 if P = Wrapped_Node then
3566 Store_Before_Actions_In_Scope (Ins_Actions);
3568 Insert_List_Before_And_Analyze (P, Ins_Actions);
3573 -- In the subexpression case, keep climbing
3579 -- If a component association appears within a loop created for
3580 -- an array aggregate, attach the actions to the association so
3581 -- they can be subsequently inserted within the loop. For other
3582 -- component associations insert outside of the aggregate. For
3583 -- an association that will generate a loop, its Loop_Actions
3584 -- attribute is already initialized (see exp_aggr.adb).
3586 -- The list of loop_actions can in turn generate additional ones,
3587 -- that are inserted before the associated node. If the associated
3588 -- node is outside the aggregate, the new actions are collected
3589 -- at the end of the loop actions, to respect the order in which
3590 -- they are to be elaborated.
3593 N_Component_Association =>
3594 if Nkind (Parent (P)) = N_Aggregate
3595 and then Present (Loop_Actions (P))
3597 if Is_Empty_List (Loop_Actions (P)) then
3598 Set_Loop_Actions (P, Ins_Actions);
3599 Analyze_List (Ins_Actions);
3606 -- Check whether these actions were generated by a
3607 -- declaration that is part of the loop_ actions
3608 -- for the component_association.
3611 while Present (Decl) loop
3612 exit when Parent (Decl) = P
3613 and then Is_List_Member (Decl)
3615 List_Containing (Decl) = Loop_Actions (P);
3616 Decl := Parent (Decl);
3619 if Present (Decl) then
3620 Insert_List_Before_And_Analyze
3621 (Decl, Ins_Actions);
3623 Insert_List_After_And_Analyze
3624 (Last (Loop_Actions (P)), Ins_Actions);
3635 -- Another special case, an attribute denoting a procedure call
3638 N_Attribute_Reference =>
3639 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
3640 if P = Wrapped_Node then
3641 Store_Before_Actions_In_Scope (Ins_Actions);
3643 Insert_List_Before_And_Analyze (P, Ins_Actions);
3648 -- In the subexpression case, keep climbing
3654 -- A contract node should not belong to the tree
3657 raise Program_Error;
3659 -- For all other node types, keep climbing tree
3663 N_Accept_Alternative |
3664 N_Access_Definition |
3665 N_Access_Function_Definition |
3666 N_Access_Procedure_Definition |
3667 N_Access_To_Object_Definition |
3670 N_Aspect_Specification |
3672 N_Case_Statement_Alternative |
3673 N_Character_Literal |
3674 N_Compilation_Unit |
3675 N_Compilation_Unit_Aux |
3676 N_Component_Clause |
3677 N_Component_Declaration |
3678 N_Component_Definition |
3680 N_Constrained_Array_Definition |
3681 N_Decimal_Fixed_Point_Definition |
3682 N_Defining_Character_Literal |
3683 N_Defining_Identifier |
3684 N_Defining_Operator_Symbol |
3685 N_Defining_Program_Unit_Name |
3686 N_Delay_Alternative |
3687 N_Delta_Constraint |
3688 N_Derived_Type_Definition |
3690 N_Digits_Constraint |
3691 N_Discriminant_Association |
3692 N_Discriminant_Specification |
3694 N_Entry_Body_Formal_Part |
3695 N_Entry_Call_Alternative |
3696 N_Entry_Declaration |
3697 N_Entry_Index_Specification |
3698 N_Enumeration_Type_Definition |
3700 N_Exception_Handler |
3702 N_Explicit_Dereference |
3703 N_Extension_Aggregate |
3704 N_Floating_Point_Definition |
3705 N_Formal_Decimal_Fixed_Point_Definition |
3706 N_Formal_Derived_Type_Definition |
3707 N_Formal_Discrete_Type_Definition |
3708 N_Formal_Floating_Point_Definition |
3709 N_Formal_Modular_Type_Definition |
3710 N_Formal_Ordinary_Fixed_Point_Definition |
3711 N_Formal_Package_Declaration |
3712 N_Formal_Private_Type_Definition |
3713 N_Formal_Incomplete_Type_Definition |
3714 N_Formal_Signed_Integer_Type_Definition |
3716 N_Function_Specification |
3717 N_Generic_Association |
3718 N_Handled_Sequence_Of_Statements |
3721 N_Index_Or_Discriminant_Constraint |
3722 N_Indexed_Component |
3724 N_Iterator_Specification |
3727 N_Loop_Parameter_Specification |
3729 N_Modular_Type_Definition |
3755 N_Op_Shift_Right_Arithmetic |
3759 N_Ordinary_Fixed_Point_Definition |
3761 N_Package_Specification |
3762 N_Parameter_Association |
3763 N_Parameter_Specification |
3764 N_Pop_Constraint_Error_Label |
3765 N_Pop_Program_Error_Label |
3766 N_Pop_Storage_Error_Label |
3767 N_Pragma_Argument_Association |
3768 N_Procedure_Specification |
3769 N_Protected_Definition |
3770 N_Push_Constraint_Error_Label |
3771 N_Push_Program_Error_Label |
3772 N_Push_Storage_Error_Label |
3773 N_Qualified_Expression |
3774 N_Quantified_Expression |
3776 N_Range_Constraint |
3778 N_Real_Range_Specification |
3779 N_Record_Definition |
3781 N_SCIL_Dispatch_Table_Tag_Init |
3782 N_SCIL_Dispatching_Call |
3783 N_SCIL_Membership_Test |
3784 N_Selected_Component |
3785 N_Signed_Integer_Type_Definition |
3786 N_Single_Protected_Declaration |
3790 N_Subtype_Indication |
3793 N_Terminate_Alternative |
3794 N_Triggering_Alternative |
3796 N_Unchecked_Expression |
3797 N_Unchecked_Type_Conversion |
3798 N_Unconstrained_Array_Definition |
3803 N_Validate_Unchecked_Conversion |
3810 -- Make sure that inserted actions stay in the transient scope
3812 if P = Wrapped_Node then
3813 Store_Before_Actions_In_Scope (Ins_Actions);
3817 -- If we fall through above tests, keep climbing tree
3821 if Nkind (Parent (N)) = N_Subunit then
3823 -- This is the proper body corresponding to a stub. Insertion must
3824 -- be done at the point of the stub, which is in the declarative
3825 -- part of the parent unit.
3827 P := Corresponding_Stub (Parent (N));
3835 -- Version with check(s) suppressed
3837 procedure Insert_Actions
3838 (Assoc_Node : Node_Id;
3839 Ins_Actions : List_Id;
3840 Suppress : Check_Id)
3843 if Suppress = All_Checks then
3845 Sva : constant Suppress_Array := Scope_Suppress.Suppress;
3847 Scope_Suppress.Suppress := (others => True);
3848 Insert_Actions (Assoc_Node, Ins_Actions);
3849 Scope_Suppress.Suppress := Sva;
3854 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
3856 Scope_Suppress.Suppress (Suppress) := True;
3857 Insert_Actions (Assoc_Node, Ins_Actions);
3858 Scope_Suppress.Suppress (Suppress) := Svg;
3863 --------------------------
3864 -- Insert_Actions_After --
3865 --------------------------
3867 procedure Insert_Actions_After
3868 (Assoc_Node : Node_Id;
3869 Ins_Actions : List_Id)
3872 if Scope_Is_Transient
3873 and then Assoc_Node = Node_To_Be_Wrapped
3875 Store_After_Actions_In_Scope (Ins_Actions);
3877 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
3879 end Insert_Actions_After;
3881 ---------------------------------
3882 -- Insert_Library_Level_Action --
3883 ---------------------------------
3885 procedure Insert_Library_Level_Action (N : Node_Id) is
3886 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
3889 Push_Scope (Cunit_Entity (Main_Unit));
3890 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
3892 if No (Actions (Aux)) then
3893 Set_Actions (Aux, New_List (N));
3895 Append (N, Actions (Aux));
3900 end Insert_Library_Level_Action;
3902 ----------------------------------
3903 -- Insert_Library_Level_Actions --
3904 ----------------------------------
3906 procedure Insert_Library_Level_Actions (L : List_Id) is
3907 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
3910 if Is_Non_Empty_List (L) then
3911 Push_Scope (Cunit_Entity (Main_Unit));
3912 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
3914 if No (Actions (Aux)) then
3915 Set_Actions (Aux, L);
3918 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
3923 end Insert_Library_Level_Actions;
3925 ----------------------
3926 -- Inside_Init_Proc --
3927 ----------------------
3929 function Inside_Init_Proc return Boolean is
3935 and then S /= Standard_Standard
3937 if Is_Init_Proc (S) then
3945 end Inside_Init_Proc;
3947 ----------------------------
3948 -- Is_All_Null_Statements --
3949 ----------------------------
3951 function Is_All_Null_Statements (L : List_Id) return Boolean is
3956 while Present (Stm) loop
3957 if Nkind (Stm) /= N_Null_Statement then
3965 end Is_All_Null_Statements;
3967 --------------------------------------------------
3968 -- Is_Displacement_Of_Object_Or_Function_Result --
3969 --------------------------------------------------
3971 function Is_Displacement_Of_Object_Or_Function_Result
3972 (Obj_Id : Entity_Id) return Boolean
3974 function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
3975 -- Determine if particular node denotes a controlled function call
3977 function Is_Displace_Call (N : Node_Id) return Boolean;
3978 -- Determine whether a particular node is a call to Ada.Tags.Displace.
3979 -- The call might be nested within other actions such as conversions.
3981 function Is_Source_Object (N : Node_Id) return Boolean;
3982 -- Determine whether a particular node denotes a source object
3984 ---------------------------------
3985 -- Is_Controlled_Function_Call --
3986 ---------------------------------
3988 function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
3989 Expr : Node_Id := Original_Node (N);
3992 if Nkind (Expr) = N_Function_Call then
3993 Expr := Name (Expr);
3996 -- The function call may appear in object.operation format
3998 if Nkind (Expr) = N_Selected_Component then
3999 Expr := Selector_Name (Expr);
4003 Nkind_In (Expr, N_Expanded_Name, N_Identifier)
4004 and then Ekind (Entity (Expr)) = E_Function
4005 and then Needs_Finalization (Etype (Entity (Expr)));
4006 end Is_Controlled_Function_Call;
4008 ----------------------
4009 -- Is_Displace_Call --
4010 ----------------------
4012 function Is_Displace_Call (N : Node_Id) return Boolean is
4013 Call : Node_Id := N;
4016 -- Strip various actions which may precede a call to Displace
4019 if Nkind (Call) = N_Explicit_Dereference then
4020 Call := Prefix (Call);
4022 elsif Nkind_In (Call, N_Type_Conversion,
4023 N_Unchecked_Type_Conversion)
4025 Call := Expression (Call);
4034 and then Nkind (Call) = N_Function_Call
4035 and then Is_RTE (Entity (Name (Call)), RE_Displace);
4036 end Is_Displace_Call;
4038 ----------------------
4039 -- Is_Source_Object --
4040 ----------------------
4042 function Is_Source_Object (N : Node_Id) return Boolean is
4046 and then Nkind (N) in N_Has_Entity
4047 and then Is_Object (Entity (N))
4048 and then Comes_From_Source (N);
4049 end Is_Source_Object;
4053 Decl : constant Node_Id := Parent (Obj_Id);
4054 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
4055 Orig_Decl : constant Node_Id := Original_Node (Decl);
4057 -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
4062 -- Obj : CW_Type := Function_Call (...);
4066 -- Tmp : ... := Function_Call (...)'reference;
4067 -- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp));
4069 -- where the return type of the function and the class-wide type require
4070 -- dispatch table pointer displacement.
4074 -- Obj : CW_Type := Src_Obj;
4078 -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
4080 -- where the type of the source object and the class-wide type require
4081 -- dispatch table pointer displacement.
4084 Nkind (Decl) = N_Object_Renaming_Declaration
4085 and then Nkind (Orig_Decl) = N_Object_Declaration
4086 and then Comes_From_Source (Orig_Decl)
4087 and then Is_Class_Wide_Type (Obj_Typ)
4088 and then Is_Displace_Call (Renamed_Object (Obj_Id))
4090 (Is_Controlled_Function_Call (Expression (Orig_Decl))
4091 or else Is_Source_Object (Expression (Orig_Decl)));
4092 end Is_Displacement_Of_Object_Or_Function_Result;
4094 ------------------------------
4095 -- Is_Finalizable_Transient --
4096 ------------------------------
4098 function Is_Finalizable_Transient
4100 Rel_Node : Node_Id) return Boolean
4102 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
4103 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
4104 Desig : Entity_Id := Obj_Typ;
4106 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
4107 -- Determine whether transient object Trans_Id is initialized either
4108 -- by a function call which returns an access type or simply renames
4111 function Initialized_By_Aliased_BIP_Func_Call
4112 (Trans_Id : Entity_Id) return Boolean;
4113 -- Determine whether transient object Trans_Id is initialized by a
4114 -- build-in-place function call where the BIPalloc parameter is of
4115 -- value 1 and BIPaccess is not null. This case creates an aliasing
4116 -- between the returned value and the value denoted by BIPaccess.
4119 (Trans_Id : Entity_Id;
4120 First_Stmt : Node_Id) return Boolean;
4121 -- Determine whether transient object Trans_Id has been renamed or
4122 -- aliased through 'reference in the statement list starting from
4125 function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
4126 -- Determine whether transient object Trans_Id is allocated on the heap
4128 function Is_Iterated_Container
4129 (Trans_Id : Entity_Id;
4130 First_Stmt : Node_Id) return Boolean;
4131 -- Determine whether transient object Trans_Id denotes a container which
4132 -- is in the process of being iterated in the statement list starting
4135 ---------------------------
4136 -- Initialized_By_Access --
4137 ---------------------------
4139 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
4140 Expr : constant Node_Id := Expression (Parent (Trans_Id));
4145 and then Nkind (Expr) /= N_Reference
4146 and then Is_Access_Type (Etype (Expr));
4147 end Initialized_By_Access;
4149 ------------------------------------------
4150 -- Initialized_By_Aliased_BIP_Func_Call --
4151 ------------------------------------------
4153 function Initialized_By_Aliased_BIP_Func_Call
4154 (Trans_Id : Entity_Id) return Boolean
4156 Call : Node_Id := Expression (Parent (Trans_Id));
4159 -- Build-in-place calls usually appear in 'reference format
4161 if Nkind (Call) = N_Reference then
4162 Call := Prefix (Call);
4165 if Is_Build_In_Place_Function_Call (Call) then
4167 Access_Nam : Name_Id := No_Name;
4168 Access_OK : Boolean := False;
4170 Alloc_Nam : Name_Id := No_Name;
4171 Alloc_OK : Boolean := False;
4173 Func_Id : Entity_Id;
4177 -- Examine all parameter associations of the function call
4179 Param := First (Parameter_Associations (Call));
4180 while Present (Param) loop
4181 if Nkind (Param) = N_Parameter_Association
4182 and then Nkind (Selector_Name (Param)) = N_Identifier
4184 Actual := Explicit_Actual_Parameter (Param);
4185 Formal := Selector_Name (Param);
4187 -- Construct the names of formals BIPaccess and BIPalloc
4188 -- using the function name retrieved from an arbitrary
4191 if Access_Nam = No_Name
4192 and then Alloc_Nam = No_Name
4193 and then Present (Entity (Formal))
4195 Func_Id := Scope (Entity (Formal));
4198 New_External_Name (Chars (Func_Id),
4199 BIP_Formal_Suffix (BIP_Object_Access));
4202 New_External_Name (Chars (Func_Id),
4203 BIP_Formal_Suffix (BIP_Alloc_Form));
4206 -- A match for BIPaccess => Temp has been found
4208 if Chars (Formal) = Access_Nam
4209 and then Nkind (Actual) /= N_Null
4214 -- A match for BIPalloc => 1 has been found
4216 if Chars (Formal) = Alloc_Nam
4217 and then Nkind (Actual) = N_Integer_Literal
4218 and then Intval (Actual) = Uint_1
4227 return Access_OK and then Alloc_OK;
4232 end Initialized_By_Aliased_BIP_Func_Call;
4239 (Trans_Id : Entity_Id;
4240 First_Stmt : Node_Id) return Boolean
4242 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
4243 -- Given an object renaming declaration, retrieve the entity of the
4244 -- renamed name. Return Empty if the renamed name is anything other
4245 -- than a variable or a constant.
4247 -------------------------
4248 -- Find_Renamed_Object --
4249 -------------------------
4251 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
4252 Ren_Obj : Node_Id := Empty;
4254 function Find_Object (N : Node_Id) return Traverse_Result;
4255 -- Try to detect an object which is either a constant or a
4262 function Find_Object (N : Node_Id) return Traverse_Result is
4264 -- Stop the search once a constant or a variable has been
4267 if Nkind (N) = N_Identifier
4268 and then Present (Entity (N))
4269 and then Ekind_In (Entity (N), E_Constant, E_Variable)
4271 Ren_Obj := Entity (N);
4278 procedure Search is new Traverse_Proc (Find_Object);
4282 Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));
4284 -- Start of processing for Find_Renamed_Object
4287 -- Actions related to dispatching calls may appear as renamings of
4288 -- tags. Do not process this type of renaming because it does not
4289 -- use the actual value of the object.
4291 if not Is_RTE (Typ, RE_Tag_Ptr) then
4292 Search (Name (Ren_Decl));
4296 end Find_Renamed_Object;
4301 Ren_Obj : Entity_Id;
4304 -- Start of processing for Is_Aliased
4308 while Present (Stmt) loop
4309 if Nkind (Stmt) = N_Object_Declaration then
4310 Expr := Expression (Stmt);
4313 and then Nkind (Expr) = N_Reference
4314 and then Nkind (Prefix (Expr)) = N_Identifier
4315 and then Entity (Prefix (Expr)) = Trans_Id
4320 elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
4321 Ren_Obj := Find_Renamed_Object (Stmt);
4323 if Present (Ren_Obj)
4324 and then Ren_Obj = Trans_Id
4340 function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
4341 Expr : constant Node_Id := Expression (Parent (Trans_Id));
4344 Is_Access_Type (Etype (Trans_Id))
4345 and then Present (Expr)
4346 and then Nkind (Expr) = N_Allocator;
4349 ---------------------------
4350 -- Is_Iterated_Container --
4351 ---------------------------
4353 function Is_Iterated_Container
4354 (Trans_Id : Entity_Id;
4355 First_Stmt : Node_Id) return Boolean
4365 -- It is not possible to iterate over containers in non-Ada 2012 code
4367 if Ada_Version < Ada_2012 then
4371 Typ := Etype (Trans_Id);
4373 -- Handle access type created for secondary stack use
4375 if Is_Access_Type (Typ) then
4376 Typ := Designated_Type (Typ);
4379 -- Look for aspect Default_Iterator
4381 if Has_Aspects (Parent (Typ)) then
4382 Aspect := Find_Aspect (Typ, Aspect_Default_Iterator);
4384 if Present (Aspect) then
4385 Iter := Entity (Aspect);
4387 -- Examine the statements following the container object and
4388 -- look for a call to the default iterate routine where the
4389 -- first parameter is the transient. Such a call appears as:
4391 -- It : Access_To_CW_Iterator :=
4392 -- Iterate (Tran_Id.all, ...)'reference;
4395 while Present (Stmt) loop
4397 -- Detect an object declaration which is initialized by a
4398 -- secondary stack function call.
4400 if Nkind (Stmt) = N_Object_Declaration
4401 and then Present (Expression (Stmt))
4402 and then Nkind (Expression (Stmt)) = N_Reference
4403 and then Nkind (Prefix (Expression (Stmt))) =
4406 Call := Prefix (Expression (Stmt));
4408 -- The call must invoke the default iterate routine of
4409 -- the container and the transient object must appear as
4410 -- the first actual parameter. Skip any calls whose names
4411 -- are not entities.
4413 if Is_Entity_Name (Name (Call))
4414 and then Entity (Name (Call)) = Iter
4415 and then Present (Parameter_Associations (Call))
4417 Param := First (Parameter_Associations (Call));
4419 if Nkind (Param) = N_Explicit_Dereference
4420 and then Entity (Prefix (Param)) = Trans_Id
4433 end Is_Iterated_Container;
4435 -- Start of processing for Is_Finalizable_Transient
4438 -- Handle access types
4440 if Is_Access_Type (Desig) then
4441 Desig := Available_View (Designated_Type (Desig));
4445 Ekind_In (Obj_Id, E_Constant, E_Variable)
4446 and then Needs_Finalization (Desig)
4447 and then Requires_Transient_Scope (Desig)
4448 and then Nkind (Rel_Node) /= N_Simple_Return_Statement
4450 -- Do not consider renamed or 'reference-d transient objects because
4451 -- the act of renaming extends the object's lifetime.
4453 and then not Is_Aliased (Obj_Id, Decl)
4455 -- Do not consider transient objects allocated on the heap since
4456 -- they are attached to a finalization master.
4458 and then not Is_Allocated (Obj_Id)
4460 -- If the transient object is a pointer, check that it is not
4461 -- initialized by a function which returns a pointer or acts as a
4462 -- renaming of another pointer.
4465 (not Is_Access_Type (Obj_Typ)
4466 or else not Initialized_By_Access (Obj_Id))
4468 -- Do not consider transient objects which act as indirect aliases
4469 -- of build-in-place function results.
4471 and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
4473 -- Do not consider conversions of tags to class-wide types
4475 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
4477 -- Do not consider containers in the context of iterator loops. Such
4478 -- transient objects must exist for as long as the loop is around,
4479 -- otherwise any operation carried out by the iterator will fail.
4481 and then not Is_Iterated_Container (Obj_Id, Decl);
4482 end Is_Finalizable_Transient;
4484 ---------------------------------
4485 -- Is_Fully_Repped_Tagged_Type --
4486 ---------------------------------
4488 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
4489 U : constant Entity_Id := Underlying_Type (T);
4493 if No (U) or else not Is_Tagged_Type (U) then
4495 elsif Has_Discriminants (U) then
4497 elsif not Has_Specified_Layout (U) then
4501 -- Here we have a tagged type, see if it has any unlayed out fields
4502 -- other than a possible tag and parent fields. If so, we return False.
4504 Comp := First_Component (U);
4505 while Present (Comp) loop
4506 if not Is_Tag (Comp)
4507 and then Chars (Comp) /= Name_uParent
4508 and then No (Component_Clause (Comp))
4512 Next_Component (Comp);
4516 -- All components are layed out
4519 end Is_Fully_Repped_Tagged_Type;
4521 ----------------------------------
4522 -- Is_Library_Level_Tagged_Type --
4523 ----------------------------------
4525 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
4527 return Is_Tagged_Type (Typ)
4528 and then Is_Library_Level_Entity (Typ);
4529 end Is_Library_Level_Tagged_Type;
4531 --------------------------
4532 -- Is_Non_BIP_Func_Call --
4533 --------------------------
4535 function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
4537 -- The expected call is of the format
4539 -- Func_Call'reference
4542 Nkind (Expr) = N_Reference
4543 and then Nkind (Prefix (Expr)) = N_Function_Call
4544 and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
4545 end Is_Non_BIP_Func_Call;
4547 ----------------------------------
4548 -- Is_Possibly_Unaligned_Object --
4549 ----------------------------------
4551 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
4552 T : constant Entity_Id := Etype (N);
4555 -- If renamed object, apply test to underlying object
4557 if Is_Entity_Name (N)
4558 and then Is_Object (Entity (N))
4559 and then Present (Renamed_Object (Entity (N)))
4561 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
4564 -- Tagged and controlled types and aliased types are always aligned, as
4565 -- are concurrent types.
4568 or else Has_Controlled_Component (T)
4569 or else Is_Concurrent_Type (T)
4570 or else Is_Tagged_Type (T)
4571 or else Is_Controlled (T)
4576 -- If this is an element of a packed array, may be unaligned
4578 if Is_Ref_To_Bit_Packed_Array (N) then
4582 -- Case of indexed component reference: test whether prefix is unaligned
4584 if Nkind (N) = N_Indexed_Component then
4585 return Is_Possibly_Unaligned_Object (Prefix (N));
4587 -- Case of selected component reference
4589 elsif Nkind (N) = N_Selected_Component then
4591 P : constant Node_Id := Prefix (N);
4592 C : constant Entity_Id := Entity (Selector_Name (N));
4597 -- If component reference is for an array with non-static bounds,
4598 -- then it is always aligned: we can only process unaligned arrays
4599 -- with static bounds (more precisely compile time known bounds).
4601 if Is_Array_Type (T)
4602 and then not Compile_Time_Known_Bounds (T)
4607 -- If component is aliased, it is definitely properly aligned
4609 if Is_Aliased (C) then
4613 -- If component is for a type implemented as a scalar, and the
4614 -- record is packed, and the component is other than the first
4615 -- component of the record, then the component may be unaligned.
4617 if Is_Packed (Etype (P))
4618 and then Represented_As_Scalar (Etype (C))
4619 and then First_Entity (Scope (C)) /= C
4624 -- Compute maximum possible alignment for T
4626 -- If alignment is known, then that settles things
4628 if Known_Alignment (T) then
4629 M := UI_To_Int (Alignment (T));
4631 -- If alignment is not known, tentatively set max alignment
4634 M := Ttypes.Maximum_Alignment;
4636 -- We can reduce this if the Esize is known since the default
4637 -- alignment will never be more than the smallest power of 2
4638 -- that does not exceed this Esize value.
4640 if Known_Esize (T) then
4641 S := UI_To_Int (Esize (T));
4643 while (M / 2) >= S loop
4649 -- The following code is historical, it used to be present but it
4650 -- is too cautious, because the front-end does not know the proper
4651 -- default alignments for the target. Also, if the alignment is
4652 -- not known, the front end can't know in any case! If a copy is
4653 -- needed, the back-end will take care of it. This whole section
4654 -- including this comment can be removed later ???
4656 -- If the component reference is for a record that has a specified
4657 -- alignment, and we either know it is too small, or cannot tell,
4658 -- then the component may be unaligned.
4660 -- What is the following commented out code ???
4662 -- if Known_Alignment (Etype (P))
4663 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
4664 -- and then M > Alignment (Etype (P))
4669 -- Case of component clause present which may specify an
4670 -- unaligned position.
4672 if Present (Component_Clause (C)) then
4674 -- Otherwise we can do a test to make sure that the actual
4675 -- start position in the record, and the length, are both
4676 -- consistent with the required alignment. If not, we know
4677 -- that we are unaligned.
4680 Align_In_Bits : constant Nat := M * System_Storage_Unit;
4682 if Component_Bit_Offset (C) mod Align_In_Bits /= 0
4683 or else Esize (C) mod Align_In_Bits /= 0
4690 -- Otherwise, for a component reference, test prefix
4692 return Is_Possibly_Unaligned_Object (P);
4695 -- If not a component reference, must be aligned
4700 end Is_Possibly_Unaligned_Object;
4702 ---------------------------------
4703 -- Is_Possibly_Unaligned_Slice --
4704 ---------------------------------
4706 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
4708 -- Go to renamed object
4710 if Is_Entity_Name (N)
4711 and then Is_Object (Entity (N))
4712 and then Present (Renamed_Object (Entity (N)))
4714 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
4717 -- The reference must be a slice
4719 if Nkind (N) /= N_Slice then
4723 -- Always assume the worst for a nested record component with a
4724 -- component clause, which gigi/gcc does not appear to handle well.
4725 -- It is not clear why this special test is needed at all ???
4727 if Nkind (Prefix (N)) = N_Selected_Component
4728 and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
4730 Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
4735 -- We only need to worry if the target has strict alignment
4737 if not Target_Strict_Alignment then
4741 -- If it is a slice, then look at the array type being sliced
4744 Sarr : constant Node_Id := Prefix (N);
4745 -- Prefix of the slice, i.e. the array being sliced
4747 Styp : constant Entity_Id := Etype (Prefix (N));
4748 -- Type of the array being sliced
4754 -- The problems arise if the array object that is being sliced
4755 -- is a component of a record or array, and we cannot guarantee
4756 -- the alignment of the array within its containing object.
4758 -- To investigate this, we look at successive prefixes to see
4759 -- if we have a worrisome indexed or selected component.
4763 -- Case of array is part of an indexed component reference
4765 if Nkind (Pref) = N_Indexed_Component then
4766 Ptyp := Etype (Prefix (Pref));
4768 -- The only problematic case is when the array is packed, in
4769 -- which case we really know nothing about the alignment of
4770 -- individual components.
4772 if Is_Bit_Packed_Array (Ptyp) then
4776 -- Case of array is part of a selected component reference
4778 elsif Nkind (Pref) = N_Selected_Component then
4779 Ptyp := Etype (Prefix (Pref));
4781 -- We are definitely in trouble if the record in question
4782 -- has an alignment, and either we know this alignment is
4783 -- inconsistent with the alignment of the slice, or we don't
4784 -- know what the alignment of the slice should be.
4786 if Known_Alignment (Ptyp)
4787 and then (Unknown_Alignment (Styp)
4788 or else Alignment (Styp) > Alignment (Ptyp))
4793 -- We are in potential trouble if the record type is packed.
4794 -- We could special case when we know that the array is the
4795 -- first component, but that's not such a simple case ???
4797 if Is_Packed (Ptyp) then
4801 -- We are in trouble if there is a component clause, and
4802 -- either we do not know the alignment of the slice, or
4803 -- the alignment of the slice is inconsistent with the
4804 -- bit position specified by the component clause.
4807 Field : constant Entity_Id := Entity (Selector_Name (Pref));
4809 if Present (Component_Clause (Field))
4811 (Unknown_Alignment (Styp)
4813 (Component_Bit_Offset (Field) mod
4814 (System_Storage_Unit * Alignment (Styp))) /= 0)
4820 -- For cases other than selected or indexed components we know we
4821 -- are OK, since no issues arise over alignment.
4827 -- We processed an indexed component or selected component
4828 -- reference that looked safe, so keep checking prefixes.
4830 Pref := Prefix (Pref);
4833 end Is_Possibly_Unaligned_Slice;
4835 -------------------------------
4836 -- Is_Related_To_Func_Return --
4837 -------------------------------
4839 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
4840 Expr : constant Node_Id := Related_Expression (Id);
4844 and then Nkind (Expr) = N_Explicit_Dereference
4845 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
4846 end Is_Related_To_Func_Return;
4848 --------------------------------
4849 -- Is_Ref_To_Bit_Packed_Array --
4850 --------------------------------
4852 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
4857 if Is_Entity_Name (N)
4858 and then Is_Object (Entity (N))
4859 and then Present (Renamed_Object (Entity (N)))
4861 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
4864 if Nkind (N) = N_Indexed_Component
4866 Nkind (N) = N_Selected_Component
4868 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
4871 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
4874 if Result and then Nkind (N) = N_Indexed_Component then
4875 Expr := First (Expressions (N));
4876 while Present (Expr) loop
4877 Force_Evaluation (Expr);
4887 end Is_Ref_To_Bit_Packed_Array;
4889 --------------------------------
4890 -- Is_Ref_To_Bit_Packed_Slice --
4891 --------------------------------
4893 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
4895 if Nkind (N) = N_Type_Conversion then
4896 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
4898 elsif Is_Entity_Name (N)
4899 and then Is_Object (Entity (N))
4900 and then Present (Renamed_Object (Entity (N)))
4902 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
4904 elsif Nkind (N) = N_Slice
4905 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
4909 elsif Nkind (N) = N_Indexed_Component
4911 Nkind (N) = N_Selected_Component
4913 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
4918 end Is_Ref_To_Bit_Packed_Slice;
4920 -----------------------
4921 -- Is_Renamed_Object --
4922 -----------------------
4924 function Is_Renamed_Object (N : Node_Id) return Boolean is
4925 Pnod : constant Node_Id := Parent (N);
4926 Kind : constant Node_Kind := Nkind (Pnod);
4928 if Kind = N_Object_Renaming_Declaration then
4930 elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
4931 return Is_Renamed_Object (Pnod);
4935 end Is_Renamed_Object;
4937 --------------------------------------
4938 -- Is_Secondary_Stack_BIP_Func_Call --
4939 --------------------------------------
4941 function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
4942 Call : Node_Id := Expr;
4945 -- Build-in-place calls usually appear in 'reference format. Note that
4946 -- the accessibility check machinery may add an extra 'reference due to
4947 -- side effect removal.
4949 while Nkind (Call) = N_Reference loop
4950 Call := Prefix (Call);
4953 if Nkind_In (Call, N_Qualified_Expression,
4954 N_Unchecked_Type_Conversion)
4956 Call := Expression (Call);
4959 if Is_Build_In_Place_Function_Call (Call) then
4961 Access_Nam : Name_Id := No_Name;
4967 -- Examine all parameter associations of the function call
4969 Param := First (Parameter_Associations (Call));
4970 while Present (Param) loop
4971 if Nkind (Param) = N_Parameter_Association
4972 and then Nkind (Selector_Name (Param)) = N_Identifier
4974 Formal := Selector_Name (Param);
4975 Actual := Explicit_Actual_Parameter (Param);
4977 -- Construct the name of formal BIPalloc. It is much easier
4978 -- to extract the name of the function using an arbitrary
4979 -- formal's scope rather than the Name field of Call.
4981 if Access_Nam = No_Name
4982 and then Present (Entity (Formal))
4986 (Chars (Scope (Entity (Formal))),
4987 BIP_Formal_Suffix (BIP_Alloc_Form));
4990 -- A match for BIPalloc => 2 has been found
4992 if Chars (Formal) = Access_Nam
4993 and then Nkind (Actual) = N_Integer_Literal
4994 and then Intval (Actual) = Uint_2
5006 end Is_Secondary_Stack_BIP_Func_Call;
5008 -------------------------------------
5009 -- Is_Tag_To_Class_Wide_Conversion --
5010 -------------------------------------
5012 function Is_Tag_To_Class_Wide_Conversion
5013 (Obj_Id : Entity_Id) return Boolean
5015 Expr : constant Node_Id := Expression (Parent (Obj_Id));
5019 Is_Class_Wide_Type (Etype (Obj_Id))
5020 and then Present (Expr)
5021 and then Nkind (Expr) = N_Unchecked_Type_Conversion
5022 and then Etype (Expression (Expr)) = RTE (RE_Tag);
5023 end Is_Tag_To_Class_Wide_Conversion;
5025 ----------------------------
5026 -- Is_Untagged_Derivation --
5027 ----------------------------
5029 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
5031 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
5033 (Is_Private_Type (T) and then Present (Full_View (T))
5034 and then not Is_Tagged_Type (Full_View (T))
5035 and then Is_Derived_Type (Full_View (T))
5036 and then Etype (Full_View (T)) /= T);
5037 end Is_Untagged_Derivation;
5039 ---------------------------
5040 -- Is_Volatile_Reference --
5041 ---------------------------
5043 function Is_Volatile_Reference (N : Node_Id) return Boolean is
5045 if Nkind (N) in N_Has_Etype
5046 and then Present (Etype (N))
5047 and then Treat_As_Volatile (Etype (N))
5051 elsif Is_Entity_Name (N) then
5052 return Treat_As_Volatile (Entity (N));
5054 elsif Nkind (N) = N_Slice then
5055 return Is_Volatile_Reference (Prefix (N));
5057 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
5058 if (Is_Entity_Name (Prefix (N))
5059 and then Has_Volatile_Components (Entity (Prefix (N))))
5060 or else (Present (Etype (Prefix (N)))
5061 and then Has_Volatile_Components (Etype (Prefix (N))))
5065 return Is_Volatile_Reference (Prefix (N));
5071 end Is_Volatile_Reference;
5073 --------------------------
5074 -- Is_VM_By_Copy_Actual --
5075 --------------------------
5077 function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean is
5079 return VM_Target /= No_VM
5080 and then (Nkind (N) = N_Slice
5082 (Nkind (N) = N_Identifier
5083 and then Present (Renamed_Object (Entity (N)))
5084 and then Nkind (Renamed_Object (Entity (N)))
5086 end Is_VM_By_Copy_Actual;
5088 --------------------
5089 -- Kill_Dead_Code --
5090 --------------------
5092 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
5093 W : Boolean := Warn;
5094 -- Set False if warnings suppressed
5098 Remove_Warning_Messages (N);
5100 -- Generate warning if appropriate
5104 -- We suppress the warning if this code is under control of an
5105 -- if statement, whose condition is a simple identifier, and
5106 -- either we are in an instance, or warnings off is set for this
5107 -- identifier. The reason for killing it in the instance case is
5108 -- that it is common and reasonable for code to be deleted in
5109 -- instances for various reasons.
5111 if Nkind (Parent (N)) = N_If_Statement then
5113 C : constant Node_Id := Condition (Parent (N));
5115 if Nkind (C) = N_Identifier
5118 or else (Present (Entity (C))
5119 and then Has_Warnings_Off (Entity (C))))
5126 -- Generate warning if not suppressed
5130 ("??this code can never be executed and has been deleted!",
5135 -- Recurse into block statements and bodies to process declarations
5138 if Nkind (N) = N_Block_Statement
5139 or else Nkind (N) = N_Subprogram_Body
5140 or else Nkind (N) = N_Package_Body
5142 Kill_Dead_Code (Declarations (N), False);
5143 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
5145 if Nkind (N) = N_Subprogram_Body then
5146 Set_Is_Eliminated (Defining_Entity (N));
5149 elsif Nkind (N) = N_Package_Declaration then
5150 Kill_Dead_Code (Visible_Declarations (Specification (N)));
5151 Kill_Dead_Code (Private_Declarations (Specification (N)));
5153 -- ??? After this point, Delete_Tree has been called on all
5154 -- declarations in Specification (N), so references to entities
5155 -- therein look suspicious.
5158 E : Entity_Id := First_Entity (Defining_Entity (N));
5160 while Present (E) loop
5161 if Ekind (E) = E_Operator then
5162 Set_Is_Eliminated (E);
5169 -- Recurse into composite statement to kill individual statements in
5170 -- particular instantiations.
5172 elsif Nkind (N) = N_If_Statement then
5173 Kill_Dead_Code (Then_Statements (N));
5174 Kill_Dead_Code (Elsif_Parts (N));
5175 Kill_Dead_Code (Else_Statements (N));
5177 elsif Nkind (N) = N_Loop_Statement then
5178 Kill_Dead_Code (Statements (N));
5180 elsif Nkind (N) = N_Case_Statement then
5184 Alt := First (Alternatives (N));
5185 while Present (Alt) loop
5186 Kill_Dead_Code (Statements (Alt));
5191 elsif Nkind (N) = N_Case_Statement_Alternative then
5192 Kill_Dead_Code (Statements (N));
5194 -- Deal with dead instances caused by deleting instantiations
5196 elsif Nkind (N) in N_Generic_Instantiation then
5197 Remove_Dead_Instance (N);
5202 -- Case where argument is a list of nodes to be killed
5204 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
5209 if Is_Non_Empty_List (L) then
5211 while Present (N) loop
5212 Kill_Dead_Code (N, W);
5219 ------------------------
5220 -- Known_Non_Negative --
5221 ------------------------
5223 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
5225 if Is_OK_Static_Expression (Opnd)
5226 and then Expr_Value (Opnd) >= 0
5232 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
5236 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
5239 end Known_Non_Negative;
5241 --------------------
5242 -- Known_Non_Null --
5243 --------------------
5245 function Known_Non_Null (N : Node_Id) return Boolean is
5247 -- Checks for case where N is an entity reference
5249 if Is_Entity_Name (N) and then Present (Entity (N)) then
5251 E : constant Entity_Id := Entity (N);
5256 -- First check if we are in decisive conditional
5258 Get_Current_Value_Condition (N, Op, Val);
5260 if Known_Null (Val) then
5261 if Op = N_Op_Eq then
5263 elsif Op = N_Op_Ne then
5268 -- If OK to do replacement, test Is_Known_Non_Null flag
5270 if OK_To_Do_Constant_Replacement (E) then
5271 return Is_Known_Non_Null (E);
5273 -- Otherwise if not safe to do replacement, then say so
5280 -- True if access attribute
5282 elsif Nkind (N) = N_Attribute_Reference
5283 and then (Attribute_Name (N) = Name_Access
5285 Attribute_Name (N) = Name_Unchecked_Access
5287 Attribute_Name (N) = Name_Unrestricted_Access)
5291 -- True if allocator
5293 elsif Nkind (N) = N_Allocator then
5296 -- For a conversion, true if expression is known non-null
5298 elsif Nkind (N) = N_Type_Conversion then
5299 return Known_Non_Null (Expression (N));
5301 -- Above are all cases where the value could be determined to be
5302 -- non-null. In all other cases, we don't know, so return False.
5313 function Known_Null (N : Node_Id) return Boolean is
5315 -- Checks for case where N is an entity reference
5317 if Is_Entity_Name (N) and then Present (Entity (N)) then
5319 E : constant Entity_Id := Entity (N);
5324 -- Constant null value is for sure null
5326 if Ekind (E) = E_Constant
5327 and then Known_Null (Constant_Value (E))
5332 -- First check if we are in decisive conditional
5334 Get_Current_Value_Condition (N, Op, Val);
5336 if Known_Null (Val) then
5337 if Op = N_Op_Eq then
5339 elsif Op = N_Op_Ne then
5344 -- If OK to do replacement, test Is_Known_Null flag
5346 if OK_To_Do_Constant_Replacement (E) then
5347 return Is_Known_Null (E);
5349 -- Otherwise if not safe to do replacement, then say so
5356 -- True if explicit reference to null
5358 elsif Nkind (N) = N_Null then
5361 -- For a conversion, true if expression is known null
5363 elsif Nkind (N) = N_Type_Conversion then
5364 return Known_Null (Expression (N));
5366 -- Above are all cases where the value could be determined to be null.
5367 -- In all other cases, we don't know, so return False.
5374 -----------------------------
5375 -- Make_CW_Equivalent_Type --
5376 -----------------------------
5378 -- Create a record type used as an equivalent of any member of the class
5379 -- which takes its size from exp.
5381 -- Generate the following code:
5383 -- type Equiv_T is record
5384 -- _parent : T (List of discriminant constraints taken from Exp);
5385 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
5388 -- ??? Note that this type does not guarantee same alignment as all
5391 function Make_CW_Equivalent_Type
5393 E : Node_Id) return Entity_Id
5395 Loc : constant Source_Ptr := Sloc (E);
5396 Root_Typ : constant Entity_Id := Root_Type (T);
5397 List_Def : constant List_Id := Empty_List;
5398 Comp_List : constant List_Id := New_List;
5399 Equiv_Type : Entity_Id;
5400 Range_Type : Entity_Id;
5401 Str_Type : Entity_Id;
5402 Constr_Root : Entity_Id;
5406 -- If the root type is already constrained, there are no discriminants
5407 -- in the expression.
5409 if not Has_Discriminants (Root_Typ)
5410 or else Is_Constrained (Root_Typ)
5412 Constr_Root := Root_Typ;
5414 Constr_Root := Make_Temporary (Loc, 'R');
5416 -- subtype cstr__n is T (List of discr constraints taken from Exp)
5418 Append_To (List_Def,
5419 Make_Subtype_Declaration (Loc,
5420 Defining_Identifier => Constr_Root,
5421 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
5424 -- Generate the range subtype declaration
5426 Range_Type := Make_Temporary (Loc, 'G');
5428 if not Is_Interface (Root_Typ) then
5430 -- subtype rg__xx is
5431 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
5434 Make_Op_Subtract (Loc,
5436 Make_Attribute_Reference (Loc,
5438 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
5439 Attribute_Name => Name_Size),
5441 Make_Attribute_Reference (Loc,
5442 Prefix => New_Reference_To (Constr_Root, Loc),
5443 Attribute_Name => Name_Object_Size));
5445 -- subtype rg__xx is
5446 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
5449 Make_Attribute_Reference (Loc,
5451 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
5452 Attribute_Name => Name_Size);
5455 Set_Paren_Count (Sizexpr, 1);
5457 Append_To (List_Def,
5458 Make_Subtype_Declaration (Loc,
5459 Defining_Identifier => Range_Type,
5460 Subtype_Indication =>
5461 Make_Subtype_Indication (Loc,
5462 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc),
5463 Constraint => Make_Range_Constraint (Loc,
5466 Low_Bound => Make_Integer_Literal (Loc, 1),
5468 Make_Op_Divide (Loc,
5469 Left_Opnd => Sizexpr,
5470 Right_Opnd => Make_Integer_Literal (Loc,
5471 Intval => System_Storage_Unit)))))));
5473 -- subtype str__nn is Storage_Array (rg__x);
5475 Str_Type := Make_Temporary (Loc, 'S');
5476 Append_To (List_Def,
5477 Make_Subtype_Declaration (Loc,
5478 Defining_Identifier => Str_Type,
5479 Subtype_Indication =>
5480 Make_Subtype_Indication (Loc,
5481 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
5483 Make_Index_Or_Discriminant_Constraint (Loc,
5485 New_List (New_Reference_To (Range_Type, Loc))))));
5487 -- type Equiv_T is record
5488 -- [ _parent : Tnn; ]
5492 Equiv_Type := Make_Temporary (Loc, 'T');
5493 Set_Ekind (Equiv_Type, E_Record_Type);
5494 Set_Parent_Subtype (Equiv_Type, Constr_Root);
5496 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
5497 -- treatment for this type. In particular, even though _parent's type
5498 -- is a controlled type or contains controlled components, we do not
5499 -- want to set Has_Controlled_Component on it to avoid making it gain
5500 -- an unwanted _controller component.
5502 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
5504 if not Is_Interface (Root_Typ) then
5505 Append_To (Comp_List,
5506 Make_Component_Declaration (Loc,
5507 Defining_Identifier =>
5508 Make_Defining_Identifier (Loc, Name_uParent),
5509 Component_Definition =>
5510 Make_Component_Definition (Loc,
5511 Aliased_Present => False,
5512 Subtype_Indication => New_Reference_To (Constr_Root, Loc))));
5515 Append_To (Comp_List,
5516 Make_Component_Declaration (Loc,
5517 Defining_Identifier => Make_Temporary (Loc, 'C'),
5518 Component_Definition =>
5519 Make_Component_Definition (Loc,
5520 Aliased_Present => False,
5521 Subtype_Indication => New_Reference_To (Str_Type, Loc))));
5523 Append_To (List_Def,
5524 Make_Full_Type_Declaration (Loc,
5525 Defining_Identifier => Equiv_Type,
5527 Make_Record_Definition (Loc,
5529 Make_Component_List (Loc,
5530 Component_Items => Comp_List,
5531 Variant_Part => Empty))));
5533 -- Suppress all checks during the analysis of the expanded code to avoid
5534 -- the generation of spurious warnings under ZFP run-time.
5536 Insert_Actions (E, List_Def, Suppress => All_Checks);
5538 end Make_CW_Equivalent_Type;
5540 -------------------------
5541 -- Make_Invariant_Call --
5542 -------------------------
5544 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
5545 Loc : constant Source_Ptr := Sloc (Expr);
5546 Typ : constant Entity_Id := Etype (Expr);
5550 (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
5552 if Check_Enabled (Name_Invariant)
5554 Check_Enabled (Name_Assertion)
5557 Make_Procedure_Call_Statement (Loc,
5559 New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
5560 Parameter_Associations => New_List (Relocate_Node (Expr)));
5564 Make_Null_Statement (Loc);
5566 end Make_Invariant_Call;
5568 ------------------------
5569 -- Make_Literal_Range --
5570 ------------------------
5572 function Make_Literal_Range
5574 Literal_Typ : Entity_Id) return Node_Id
5576 Lo : constant Node_Id :=
5577 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
5578 Index : constant Entity_Id := Etype (Lo);
5581 Length_Expr : constant Node_Id :=
5582 Make_Op_Subtract (Loc,
5584 Make_Integer_Literal (Loc,
5585 Intval => String_Literal_Length (Literal_Typ)),
5587 Make_Integer_Literal (Loc, 1));
5590 Set_Analyzed (Lo, False);
5592 if Is_Integer_Type (Index) then
5595 Left_Opnd => New_Copy_Tree (Lo),
5596 Right_Opnd => Length_Expr);
5599 Make_Attribute_Reference (Loc,
5600 Attribute_Name => Name_Val,
5601 Prefix => New_Occurrence_Of (Index, Loc),
5602 Expressions => New_List (
5605 Make_Attribute_Reference (Loc,
5606 Attribute_Name => Name_Pos,
5607 Prefix => New_Occurrence_Of (Index, Loc),
5608 Expressions => New_List (New_Copy_Tree (Lo))),
5609 Right_Opnd => Length_Expr)));
5616 end Make_Literal_Range;
5618 --------------------------
5619 -- Make_Non_Empty_Check --
5620 --------------------------
5622 function Make_Non_Empty_Check
5624 N : Node_Id) return Node_Id
5630 Make_Attribute_Reference (Loc,
5631 Attribute_Name => Name_Length,
5632 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
5634 Make_Integer_Literal (Loc, 0));
5635 end Make_Non_Empty_Check;
5637 -------------------------
5638 -- Make_Predicate_Call --
5639 -------------------------
5641 function Make_Predicate_Call
5643 Expr : Node_Id) return Node_Id
5645 Loc : constant Source_Ptr := Sloc (Expr);
5648 pragma Assert (Present (Predicate_Function (Typ)));
5651 Make_Function_Call (Loc,
5653 New_Occurrence_Of (Predicate_Function (Typ), Loc),
5654 Parameter_Associations => New_List (Relocate_Node (Expr)));
5655 end Make_Predicate_Call;
5657 --------------------------
5658 -- Make_Predicate_Check --
5659 --------------------------
5661 function Make_Predicate_Check
5663 Expr : Node_Id) return Node_Id
5665 Loc : constant Source_Ptr := Sloc (Expr);
5670 Pragma_Identifier => Make_Identifier (Loc, Name_Check),
5671 Pragma_Argument_Associations => New_List (
5672 Make_Pragma_Argument_Association (Loc,
5673 Expression => Make_Identifier (Loc, Name_Predicate)),
5674 Make_Pragma_Argument_Association (Loc,
5675 Expression => Make_Predicate_Call (Typ, Expr))));
5676 end Make_Predicate_Check;
5678 ----------------------------
5679 -- Make_Subtype_From_Expr --
5680 ----------------------------
5682 -- 1. If Expr is an unconstrained array expression, creates
5683 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
5685 -- 2. If Expr is a unconstrained discriminated type expression, creates
5686 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
5688 -- 3. If Expr is class-wide, creates an implicit class wide subtype
5690 function Make_Subtype_From_Expr
5692 Unc_Typ : Entity_Id) return Node_Id
5694 Loc : constant Source_Ptr := Sloc (E);
5695 List_Constr : constant List_Id := New_List;
5698 Full_Subtyp : Entity_Id;
5699 Priv_Subtyp : Entity_Id;
5704 if Is_Private_Type (Unc_Typ)
5705 and then Has_Unknown_Discriminants (Unc_Typ)
5707 -- Prepare the subtype completion, Go to base type to
5708 -- find underlying type, because the type may be a generic
5709 -- actual or an explicit subtype.
5711 Utyp := Underlying_Type (Base_Type (Unc_Typ));
5712 Full_Subtyp := Make_Temporary (Loc, 'C');
5714 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
5715 Set_Parent (Full_Exp, Parent (E));
5717 Priv_Subtyp := Make_Temporary (Loc, 'P');
5720 Make_Subtype_Declaration (Loc,
5721 Defining_Identifier => Full_Subtyp,
5722 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
5724 -- Define the dummy private subtype
5726 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
5727 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
5728 Set_Scope (Priv_Subtyp, Full_Subtyp);
5729 Set_Is_Constrained (Priv_Subtyp);
5730 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
5731 Set_Is_Itype (Priv_Subtyp);
5732 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
5734 if Is_Tagged_Type (Priv_Subtyp) then
5736 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
5737 Set_Direct_Primitive_Operations (Priv_Subtyp,
5738 Direct_Primitive_Operations (Unc_Typ));
5741 Set_Full_View (Priv_Subtyp, Full_Subtyp);
5743 return New_Reference_To (Priv_Subtyp, Loc);
5745 elsif Is_Array_Type (Unc_Typ) then
5746 for J in 1 .. Number_Dimensions (Unc_Typ) loop
5747 Append_To (List_Constr,
5750 Make_Attribute_Reference (Loc,
5751 Prefix => Duplicate_Subexpr_No_Checks (E),
5752 Attribute_Name => Name_First,
5753 Expressions => New_List (
5754 Make_Integer_Literal (Loc, J))),
5757 Make_Attribute_Reference (Loc,
5758 Prefix => Duplicate_Subexpr_No_Checks (E),
5759 Attribute_Name => Name_Last,
5760 Expressions => New_List (
5761 Make_Integer_Literal (Loc, J)))));
5764 elsif Is_Class_Wide_Type (Unc_Typ) then
5766 CW_Subtype : Entity_Id;
5767 EQ_Typ : Entity_Id := Empty;
5770 -- A class-wide equivalent type is not needed when VM_Target
5771 -- because the VM back-ends handle the class-wide object
5772 -- initialization itself (and doesn't need or want the
5773 -- additional intermediate type to handle the assignment).
5775 if Expander_Active and then Tagged_Type_Expansion then
5777 -- If this is the class_wide type of a completion that is a
5778 -- record subtype, set the type of the class_wide type to be
5779 -- the full base type, for use in the expanded code for the
5780 -- equivalent type. Should this be done earlier when the
5781 -- completion is analyzed ???
5783 if Is_Private_Type (Etype (Unc_Typ))
5785 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
5787 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
5790 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
5793 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
5794 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
5795 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
5797 return New_Occurrence_Of (CW_Subtype, Loc);
5800 -- Indefinite record type with discriminants
5803 D := First_Discriminant (Unc_Typ);
5804 while Present (D) loop
5805 Append_To (List_Constr,
5806 Make_Selected_Component (Loc,
5807 Prefix => Duplicate_Subexpr_No_Checks (E),
5808 Selector_Name => New_Reference_To (D, Loc)));
5810 Next_Discriminant (D);
5815 Make_Subtype_Indication (Loc,
5816 Subtype_Mark => New_Reference_To (Unc_Typ, Loc),
5818 Make_Index_Or_Discriminant_Constraint (Loc,
5819 Constraints => List_Constr));
5820 end Make_Subtype_From_Expr;
5822 -----------------------------
5823 -- May_Generate_Large_Temp --
5824 -----------------------------
5826 -- At the current time, the only types that we return False for (i.e. where
5827 -- we decide we know they cannot generate large temps) are ones where we
5828 -- know the size is 256 bits or less at compile time, and we are still not
5829 -- doing a thorough job on arrays and records ???
5831 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
5833 if not Size_Known_At_Compile_Time (Typ) then
5836 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
5839 elsif Is_Array_Type (Typ)
5840 and then Present (Packed_Array_Type (Typ))
5842 return May_Generate_Large_Temp (Packed_Array_Type (Typ));
5844 -- We could do more here to find other small types ???
5849 end May_Generate_Large_Temp;
5851 ------------------------
5852 -- Needs_Finalization --
5853 ------------------------
5855 function Needs_Finalization (T : Entity_Id) return Boolean is
5856 function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
5857 -- If type is not frozen yet, check explicitly among its components,
5858 -- because the Has_Controlled_Component flag is not necessarily set.
5860 -----------------------------------
5861 -- Has_Some_Controlled_Component --
5862 -----------------------------------
5864 function Has_Some_Controlled_Component
5865 (Rec : Entity_Id) return Boolean
5870 if Has_Controlled_Component (Rec) then
5873 elsif not Is_Frozen (Rec) then
5874 if Is_Record_Type (Rec) then
5875 Comp := First_Entity (Rec);
5877 while Present (Comp) loop
5878 if not Is_Type (Comp)
5879 and then Needs_Finalization (Etype (Comp))
5889 elsif Is_Array_Type (Rec) then
5890 return Needs_Finalization (Component_Type (Rec));
5893 return Has_Controlled_Component (Rec);
5898 end Has_Some_Controlled_Component;
5900 -- Start of processing for Needs_Finalization
5903 -- Certain run-time configurations and targets do not provide support
5904 -- for controlled types.
5906 if Restriction_Active (No_Finalization) then
5909 -- C, C++, CIL and Java types are not considered controlled. It is
5910 -- assumed that the non-Ada side will handle their clean up.
5912 elsif Convention (T) = Convention_C
5913 or else Convention (T) = Convention_CIL
5914 or else Convention (T) = Convention_CPP
5915 or else Convention (T) = Convention_Java
5920 -- Class-wide types are treated as controlled because derivations
5921 -- from the root type can introduce controlled components.
5924 Is_Class_Wide_Type (T)
5925 or else Is_Controlled (T)
5926 or else Has_Controlled_Component (T)
5927 or else Has_Some_Controlled_Component (T)
5929 (Is_Concurrent_Type (T)
5930 and then Present (Corresponding_Record_Type (T))
5931 and then Needs_Finalization (Corresponding_Record_Type (T)));
5933 end Needs_Finalization;
5935 ----------------------------
5936 -- Needs_Constant_Address --
5937 ----------------------------
5939 function Needs_Constant_Address
5941 Typ : Entity_Id) return Boolean
5945 -- If we have no initialization of any kind, then we don't need to place
5946 -- any restrictions on the address clause, because the object will be
5947 -- elaborated after the address clause is evaluated. This happens if the
5948 -- declaration has no initial expression, or the type has no implicit
5949 -- initialization, or the object is imported.
5951 -- The same holds for all initialized scalar types and all access types.
5952 -- Packed bit arrays of size up to 64 are represented using a modular
5953 -- type with an initialization (to zero) and can be processed like other
5954 -- initialized scalar types.
5956 -- If the type is controlled, code to attach the object to a
5957 -- finalization chain is generated at the point of declaration, and
5958 -- therefore the elaboration of the object cannot be delayed: the
5959 -- address expression must be a constant.
5961 if No (Expression (Decl))
5962 and then not Needs_Finalization (Typ)
5964 (not Has_Non_Null_Base_Init_Proc (Typ)
5965 or else Is_Imported (Defining_Identifier (Decl)))
5969 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
5970 or else Is_Access_Type (Typ)
5972 (Is_Bit_Packed_Array (Typ)
5973 and then Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
5979 -- Otherwise, we require the address clause to be constant because
5980 -- the call to the initialization procedure (or the attach code) has
5981 -- to happen at the point of the declaration.
5983 -- Actually the IP call has been moved to the freeze actions anyway,
5984 -- so maybe we can relax this restriction???
5988 end Needs_Constant_Address;
5990 ----------------------------
5991 -- New_Class_Wide_Subtype --
5992 ----------------------------
5994 function New_Class_Wide_Subtype
5995 (CW_Typ : Entity_Id;
5996 N : Node_Id) return Entity_Id
5998 Res : constant Entity_Id := Create_Itype (E_Void, N);
5999 Res_Name : constant Name_Id := Chars (Res);
6000 Res_Scope : constant Entity_Id := Scope (Res);
6003 Copy_Node (CW_Typ, Res);
6004 Set_Comes_From_Source (Res, False);
6005 Set_Sloc (Res, Sloc (N));
6007 Set_Associated_Node_For_Itype (Res, N);
6008 Set_Is_Public (Res, False); -- By default, may be changed below.
6009 Set_Public_Status (Res);
6010 Set_Chars (Res, Res_Name);
6011 Set_Scope (Res, Res_Scope);
6012 Set_Ekind (Res, E_Class_Wide_Subtype);
6013 Set_Next_Entity (Res, Empty);
6014 Set_Etype (Res, Base_Type (CW_Typ));
6015 Set_Is_Frozen (Res, False);
6016 Set_Freeze_Node (Res, Empty);
6018 end New_Class_Wide_Subtype;
6020 --------------------------------
6021 -- Non_Limited_Designated_Type --
6022 ---------------------------------
6024 function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
6025 Desig : constant Entity_Id := Designated_Type (T);
6027 if Ekind (Desig) = E_Incomplete_Type
6028 and then Present (Non_Limited_View (Desig))
6030 return Non_Limited_View (Desig);
6034 end Non_Limited_Designated_Type;
6036 -----------------------------------
6037 -- OK_To_Do_Constant_Replacement --
6038 -----------------------------------
6040 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
6041 ES : constant Entity_Id := Scope (E);
6045 -- Do not replace statically allocated objects, because they may be
6046 -- modified outside the current scope.
6048 if Is_Statically_Allocated (E) then
6051 -- Do not replace aliased or volatile objects, since we don't know what
6052 -- else might change the value.
6054 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
6057 -- Debug flag -gnatdM disconnects this optimization
6059 elsif Debug_Flag_MM then
6062 -- Otherwise check scopes
6065 CS := Current_Scope;
6068 -- If we are in right scope, replacement is safe
6073 -- Packages do not affect the determination of safety
6075 elsif Ekind (CS) = E_Package then
6076 exit when CS = Standard_Standard;
6079 -- Blocks do not affect the determination of safety
6081 elsif Ekind (CS) = E_Block then
6084 -- Loops do not affect the determination of safety. Note that we
6085 -- kill all current values on entry to a loop, so we are just
6086 -- talking about processing within a loop here.
6088 elsif Ekind (CS) = E_Loop then
6091 -- Otherwise, the reference is dubious, and we cannot be sure that
6092 -- it is safe to do the replacement.
6101 end OK_To_Do_Constant_Replacement;
6103 ------------------------------------
6104 -- Possible_Bit_Aligned_Component --
6105 ------------------------------------
6107 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
6111 -- Case of indexed component
6113 when N_Indexed_Component =>
6115 P : constant Node_Id := Prefix (N);
6116 Ptyp : constant Entity_Id := Etype (P);
6119 -- If we know the component size and it is less than 64, then
6120 -- we are definitely OK. The back end always does assignment of
6121 -- misaligned small objects correctly.
6123 if Known_Static_Component_Size (Ptyp)
6124 and then Component_Size (Ptyp) <= 64
6128 -- Otherwise, we need to test the prefix, to see if we are
6129 -- indexing from a possibly unaligned component.
6132 return Possible_Bit_Aligned_Component (P);
6136 -- Case of selected component
6138 when N_Selected_Component =>
6140 P : constant Node_Id := Prefix (N);
6141 Comp : constant Entity_Id := Entity (Selector_Name (N));
6144 -- If there is no component clause, then we are in the clear
6145 -- since the back end will never misalign a large component
6146 -- unless it is forced to do so. In the clear means we need
6147 -- only the recursive test on the prefix.
6149 if Component_May_Be_Bit_Aligned (Comp) then
6152 return Possible_Bit_Aligned_Component (P);
6156 -- For a slice, test the prefix, if that is possibly misaligned,
6157 -- then for sure the slice is!
6160 return Possible_Bit_Aligned_Component (Prefix (N));
6162 -- For an unchecked conversion, check whether the expression may
6165 when N_Unchecked_Type_Conversion =>
6166 return Possible_Bit_Aligned_Component (Expression (N));
6168 -- If we have none of the above, it means that we have fallen off the
6169 -- top testing prefixes recursively, and we now have a stand alone
6170 -- object, where we don't have a problem.
6176 end Possible_Bit_Aligned_Component;
6178 -----------------------------------------------
6179 -- Process_Statements_For_Controlled_Objects --
6180 -----------------------------------------------
6182 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
6183 Loc : constant Source_Ptr := Sloc (N);
6185 function Are_Wrapped (L : List_Id) return Boolean;
6186 -- Determine whether list L contains only one statement which is a block
6188 function Wrap_Statements_In_Block (L : List_Id) return Node_Id;
6189 -- Given a list of statements L, wrap it in a block statement and return
6190 -- the generated node.
6196 function Are_Wrapped (L : List_Id) return Boolean is
6197 Stmt : constant Node_Id := First (L);
6201 and then No (Next (Stmt))
6202 and then Nkind (Stmt) = N_Block_Statement;
6205 ------------------------------
6206 -- Wrap_Statements_In_Block --
6207 ------------------------------
6209 function Wrap_Statements_In_Block (L : List_Id) return Node_Id is
6212 Make_Block_Statement (Loc,
6213 Declarations => No_List,
6214 Handled_Statement_Sequence =>
6215 Make_Handled_Sequence_Of_Statements (Loc,
6217 end Wrap_Statements_In_Block;
6223 -- Start of processing for Process_Statements_For_Controlled_Objects
6226 -- Whenever a non-handled statement list is wrapped in a block, the
6227 -- block must be explicitly analyzed to redecorate all entities in the
6228 -- list and ensure that a finalizer is properly built.
6233 N_Conditional_Entry_Call |
6234 N_Selective_Accept =>
6236 -- Check the "then statements" for elsif parts and if statements
6238 if Nkind_In (N, N_Elsif_Part, N_If_Statement)
6239 and then not Is_Empty_List (Then_Statements (N))
6240 and then not Are_Wrapped (Then_Statements (N))
6241 and then Requires_Cleanup_Actions
6242 (Then_Statements (N), False, False)
6244 Block := Wrap_Statements_In_Block (Then_Statements (N));
6245 Set_Then_Statements (N, New_List (Block));
6250 -- Check the "else statements" for conditional entry calls, if
6251 -- statements and selective accepts.
6253 if Nkind_In (N, N_Conditional_Entry_Call,
6256 and then not Is_Empty_List (Else_Statements (N))
6257 and then not Are_Wrapped (Else_Statements (N))
6258 and then Requires_Cleanup_Actions
6259 (Else_Statements (N), False, False)
6261 Block := Wrap_Statements_In_Block (Else_Statements (N));
6262 Set_Else_Statements (N, New_List (Block));
6267 when N_Abortable_Part |
6268 N_Accept_Alternative |
6269 N_Case_Statement_Alternative |
6270 N_Delay_Alternative |
6271 N_Entry_Call_Alternative |
6272 N_Exception_Handler |
6274 N_Triggering_Alternative =>
6276 if not Is_Empty_List (Statements (N))
6277 and then not Are_Wrapped (Statements (N))
6278 and then Requires_Cleanup_Actions (Statements (N), False, False)
6280 Block := Wrap_Statements_In_Block (Statements (N));
6281 Set_Statements (N, New_List (Block));
6289 end Process_Statements_For_Controlled_Objects;
6291 -------------------------
6292 -- Remove_Side_Effects --
6293 -------------------------
6295 procedure Remove_Side_Effects
6297 Name_Req : Boolean := False;
6298 Variable_Ref : Boolean := False)
6300 Loc : constant Source_Ptr := Sloc (Exp);
6301 Exp_Type : constant Entity_Id := Etype (Exp);
6302 Svg_Suppress : constant Suppress_Record := Scope_Suppress;
6306 Ptr_Typ_Decl : Node_Id;
6307 Ref_Type : Entity_Id;
6310 function Side_Effect_Free (N : Node_Id) return Boolean;
6311 -- Determines if the tree N represents an expression that is known not
6312 -- to have side effects, and for which no processing is required.
6314 function Side_Effect_Free (L : List_Id) return Boolean;
6315 -- Determines if all elements of the list L are side effect free
6317 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
6318 -- The argument N is a construct where the Prefix is dereferenced if it
6319 -- is an access type and the result is a variable. The call returns True
6320 -- if the construct is side effect free (not considering side effects in
6321 -- other than the prefix which are to be tested by the caller).
6323 function Within_In_Parameter (N : Node_Id) return Boolean;
6324 -- Determines if N is a subcomponent of a composite in-parameter. If so,
6325 -- N is not side-effect free when the actual is global and modifiable
6326 -- indirectly from within a subprogram, because it may be passed by
6327 -- reference. The front-end must be conservative here and assume that
6328 -- this may happen with any array or record type. On the other hand, we
6329 -- cannot create temporaries for all expressions for which this
6330 -- condition is true, for various reasons that might require clearing up
6331 -- ??? For example, discriminant references that appear out of place, or
6332 -- spurious type errors with class-wide expressions. As a result, we
6333 -- limit the transformation to loop bounds, which is so far the only
6334 -- case that requires it.
6336 -----------------------------
6337 -- Safe_Prefixed_Reference --
6338 -----------------------------
6340 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
6342 -- If prefix is not side effect free, definitely not safe
6344 if not Side_Effect_Free (Prefix (N)) then
6347 -- If the prefix is of an access type that is not access-to-constant,
6348 -- then this construct is a variable reference, which means it is to
6349 -- be considered to have side effects if Variable_Ref is set True.
6351 elsif Is_Access_Type (Etype (Prefix (N)))
6352 and then not Is_Access_Constant (Etype (Prefix (N)))
6353 and then Variable_Ref
6355 -- Exception is a prefix that is the result of a previous removal
6358 return Is_Entity_Name (Prefix (N))
6359 and then not Comes_From_Source (Prefix (N))
6360 and then Ekind (Entity (Prefix (N))) = E_Constant
6361 and then Is_Internal_Name (Chars (Entity (Prefix (N))));
6363 -- If the prefix is an explicit dereference then this construct is a
6364 -- variable reference, which means it is to be considered to have
6365 -- side effects if Variable_Ref is True.
6367 -- We do NOT exclude dereferences of access-to-constant types because
6368 -- we handle them as constant view of variables.
6370 elsif Nkind (Prefix (N)) = N_Explicit_Dereference
6371 and then Variable_Ref
6375 -- Note: The following test is the simplest way of solving a complex
6376 -- problem uncovered by the following test (Side effect on loop bound
6377 -- that is a subcomponent of a global variable:
6379 -- with Text_Io; use Text_Io;
6380 -- procedure Tloop is
6383 -- V : Natural := 4;
6384 -- S : String (1..5) := (others => 'a');
6391 -- with procedure Action;
6392 -- procedure Loop_G (Arg : X; Msg : String)
6394 -- procedure Loop_G (Arg : X; Msg : String) is
6396 -- Put_Line ("begin loop_g " & Msg & " will loop till: "
6397 -- & Natural'Image (Arg.V));
6398 -- for Index in 1 .. Arg.V loop
6400 -- (Natural'Image (Index) & " " & Arg.S (Index));
6401 -- if Index > 2 then
6405 -- Put_Line ("end loop_g " & Msg);
6408 -- procedure Loop1 is new Loop_G (Modi);
6409 -- procedure Modi is
6412 -- Loop1 (X1, "from modi");
6416 -- Loop1 (X1, "initial");
6419 -- The output of the above program should be:
6421 -- begin loop_g initial will loop till: 4
6425 -- begin loop_g from modi will loop till: 1
6427 -- end loop_g from modi
6429 -- begin loop_g from modi will loop till: 1
6431 -- end loop_g from modi
6432 -- end loop_g initial
6434 -- If a loop bound is a subcomponent of a global variable, a
6435 -- modification of that variable within the loop may incorrectly
6436 -- affect the execution of the loop.
6438 elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
6439 and then Within_In_Parameter (Prefix (N))
6440 and then Variable_Ref
6444 -- All other cases are side effect free
6449 end Safe_Prefixed_Reference;
6451 ----------------------
6452 -- Side_Effect_Free --
6453 ----------------------
6455 function Side_Effect_Free (N : Node_Id) return Boolean is
6457 -- Note on checks that could raise Constraint_Error. Strictly, if we
6458 -- take advantage of 11.6, these checks do not count as side effects.
6459 -- However, we would prefer to consider that they are side effects,
6460 -- since the backend CSE does not work very well on expressions which
6461 -- can raise Constraint_Error. On the other hand if we don't consider
6462 -- them to be side effect free, then we get some awkward expansions
6463 -- in -gnato mode, resulting in code insertions at a point where we
6464 -- do not have a clear model for performing the insertions.
6466 -- Special handling for entity names
6468 if Is_Entity_Name (N) then
6470 -- Variables are considered to be a side effect if Variable_Ref
6471 -- is set or if we have a volatile reference and Name_Req is off.
6472 -- If Name_Req is True then we can't help returning a name which
6473 -- effectively allows multiple references in any case.
6475 if Is_Variable (N, Use_Original_Node => False) then
6476 return not Variable_Ref
6477 and then (not Is_Volatile_Reference (N) or else Name_Req);
6479 -- Any other entity (e.g. a subtype name) is definitely side
6486 -- A value known at compile time is always side effect free
6488 elsif Compile_Time_Known_Value (N) then
6491 -- A variable renaming is not side-effect free, because the renaming
6492 -- will function like a macro in the front-end in some cases, and an
6493 -- assignment can modify the component designated by N, so we need to
6494 -- create a temporary for it.
6496 -- The guard testing for Entity being present is needed at least in
6497 -- the case of rewritten predicate expressions, and may well also be
6498 -- appropriate elsewhere. Obviously we can't go testing the entity
6499 -- field if it does not exist, so it's reasonable to say that this is
6500 -- not the renaming case if it does not exist.
6502 elsif Is_Entity_Name (Original_Node (N))
6503 and then Present (Entity (Original_Node (N)))
6504 and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
6505 and then Ekind (Entity (Original_Node (N))) /= E_Constant
6509 -- Remove_Side_Effects generates an object renaming declaration to
6510 -- capture the expression of a class-wide expression. In VM targets
6511 -- the frontend performs no expansion for dispatching calls to
6512 -- class- wide types since they are handled by the VM. Hence, we must
6513 -- locate here if this node corresponds to a previous invocation of
6514 -- Remove_Side_Effects to avoid a never ending loop in the frontend.
6516 elsif VM_Target /= No_VM
6517 and then not Comes_From_Source (N)
6518 and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
6519 and then Is_Class_Wide_Type (Etype (N))
6524 -- For other than entity names and compile time known values,
6525 -- check the node kind for special processing.
6529 -- An attribute reference is side effect free if its expressions
6530 -- are side effect free and its prefix is side effect free or
6531 -- is an entity reference.
6533 -- Is this right? what about x'first where x is a variable???
6535 when N_Attribute_Reference =>
6536 return Side_Effect_Free (Expressions (N))
6537 and then Attribute_Name (N) /= Name_Input
6538 and then (Is_Entity_Name (Prefix (N))
6539 or else Side_Effect_Free (Prefix (N)));
6541 -- A binary operator is side effect free if and both operands are
6542 -- side effect free. For this purpose binary operators include
6543 -- membership tests and short circuit forms.
6545 when N_Binary_Op | N_Membership_Test | N_Short_Circuit =>
6546 return Side_Effect_Free (Left_Opnd (N))
6548 Side_Effect_Free (Right_Opnd (N));
6550 -- An explicit dereference is side effect free only if it is
6551 -- a side effect free prefixed reference.
6553 when N_Explicit_Dereference =>
6554 return Safe_Prefixed_Reference (N);
6556 -- A call to _rep_to_pos is side effect free, since we generate
6557 -- this pure function call ourselves. Moreover it is critically
6558 -- important to make this exception, since otherwise we can have
6559 -- discriminants in array components which don't look side effect
6560 -- free in the case of an array whose index type is an enumeration
6561 -- type with an enumeration rep clause.
6563 -- All other function calls are not side effect free
6565 when N_Function_Call =>
6566 return Nkind (Name (N)) = N_Identifier
6567 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
6569 Side_Effect_Free (First (Parameter_Associations (N)));
6571 -- An indexed component is side effect free if it is a side
6572 -- effect free prefixed reference and all the indexing
6573 -- expressions are side effect free.
6575 when N_Indexed_Component =>
6576 return Side_Effect_Free (Expressions (N))
6577 and then Safe_Prefixed_Reference (N);
6579 -- A type qualification is side effect free if the expression
6580 -- is side effect free.
6582 when N_Qualified_Expression =>
6583 return Side_Effect_Free (Expression (N));
6585 -- A selected component is side effect free only if it is a side
6586 -- effect free prefixed reference. If it designates a component
6587 -- with a rep. clause it must be treated has having a potential
6588 -- side effect, because it may be modified through a renaming, and
6589 -- a subsequent use of the renaming as a macro will yield the
6590 -- wrong value. This complex interaction between renaming and
6591 -- removing side effects is a reminder that the latter has become
6592 -- a headache to maintain, and that it should be removed in favor
6593 -- of the gcc mechanism to capture values ???
6595 when N_Selected_Component =>
6596 if Nkind (Parent (N)) = N_Explicit_Dereference
6597 and then Has_Non_Standard_Rep (Designated_Type (Etype (N)))
6601 return Safe_Prefixed_Reference (N);
6604 -- A range is side effect free if the bounds are side effect free
6607 return Side_Effect_Free (Low_Bound (N))
6608 and then Side_Effect_Free (High_Bound (N));
6610 -- A slice is side effect free if it is a side effect free
6611 -- prefixed reference and the bounds are side effect free.
6614 return Side_Effect_Free (Discrete_Range (N))
6615 and then Safe_Prefixed_Reference (N);
6617 -- A type conversion is side effect free if the expression to be
6618 -- converted is side effect free.
6620 when N_Type_Conversion =>
6621 return Side_Effect_Free (Expression (N));
6623 -- A unary operator is side effect free if the operand
6624 -- is side effect free.
6627 return Side_Effect_Free (Right_Opnd (N));
6629 -- An unchecked type conversion is side effect free only if it
6630 -- is safe and its argument is side effect free.
6632 when N_Unchecked_Type_Conversion =>
6633 return Safe_Unchecked_Type_Conversion (N)
6634 and then Side_Effect_Free (Expression (N));
6636 -- An unchecked expression is side effect free if its expression
6637 -- is side effect free.
6639 when N_Unchecked_Expression =>
6640 return Side_Effect_Free (Expression (N));
6642 -- A literal is side effect free
6644 when N_Character_Literal |
6650 -- We consider that anything else has side effects. This is a bit
6651 -- crude, but we are pretty close for most common cases, and we
6652 -- are certainly correct (i.e. we never return True when the
6653 -- answer should be False).
6658 end Side_Effect_Free;
6660 -- A list is side effect free if all elements of the list are side
6663 function Side_Effect_Free (L : List_Id) return Boolean is
6667 if L = No_List or else L = Error_List then
6672 while Present (N) loop
6673 if not Side_Effect_Free (N) then
6682 end Side_Effect_Free;
6684 -------------------------
6685 -- Within_In_Parameter --
6686 -------------------------
6688 function Within_In_Parameter (N : Node_Id) return Boolean is
6690 if not Comes_From_Source (N) then
6693 elsif Is_Entity_Name (N) then
6694 return Ekind (Entity (N)) = E_In_Parameter;
6696 elsif Nkind (N) = N_Indexed_Component
6697 or else Nkind (N) = N_Selected_Component
6699 return Within_In_Parameter (Prefix (N));
6704 end Within_In_Parameter;
6706 -- Start of processing for Remove_Side_Effects
6709 -- Handle cases in which there is nothing to do
6711 if not Expander_Active then
6715 -- Cannot generate temporaries if the invocation to remove side effects
6716 -- was issued too early and the type of the expression is not resolved
6717 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
6718 -- Remove_Side_Effects).
6721 or else Ekind (Exp_Type) = E_Access_Attribute_Type
6725 -- No action needed for side-effect free expressions
6727 elsif Side_Effect_Free (Exp) then
6731 -- All this must not have any checks
6733 Scope_Suppress.Suppress := (others => True);
6735 -- If it is a scalar type and we need to capture the value, just make
6736 -- a copy. Likewise for a function call, an attribute reference, an
6737 -- allocator, or an operator. And if we have a volatile reference and
6738 -- Name_Req is not set (see comments above for Side_Effect_Free).
6740 if Is_Elementary_Type (Exp_Type)
6741 and then (Variable_Ref
6742 or else Nkind (Exp) = N_Function_Call
6743 or else Nkind (Exp) = N_Attribute_Reference
6744 or else Nkind (Exp) = N_Allocator
6745 or else Nkind (Exp) in N_Op
6746 or else (not Name_Req and then Is_Volatile_Reference (Exp)))
6748 Def_Id := Make_Temporary (Loc, 'R', Exp);
6749 Set_Etype (Def_Id, Exp_Type);
6750 Res := New_Reference_To (Def_Id, Loc);
6752 -- If the expression is a packed reference, it must be reanalyzed and
6753 -- expanded, depending on context. This is the case for actuals where
6754 -- a constraint check may capture the actual before expansion of the
6755 -- call is complete.
6757 if Nkind (Exp) = N_Indexed_Component
6758 and then Is_Packed (Etype (Prefix (Exp)))
6760 Set_Analyzed (Exp, False);
6761 Set_Analyzed (Prefix (Exp), False);
6765 Make_Object_Declaration (Loc,
6766 Defining_Identifier => Def_Id,
6767 Object_Definition => New_Reference_To (Exp_Type, Loc),
6768 Constant_Present => True,
6769 Expression => Relocate_Node (Exp));
6771 Set_Assignment_OK (E);
6772 Insert_Action (Exp, E);
6774 -- If the expression has the form v.all then we can just capture the
6775 -- pointer, and then do an explicit dereference on the result.
6777 elsif Nkind (Exp) = N_Explicit_Dereference then
6778 Def_Id := Make_Temporary (Loc, 'R', Exp);
6780 Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc));
6783 Make_Object_Declaration (Loc,
6784 Defining_Identifier => Def_Id,
6785 Object_Definition =>
6786 New_Reference_To (Etype (Prefix (Exp)), Loc),
6787 Constant_Present => True,
6788 Expression => Relocate_Node (Prefix (Exp))));
6790 -- Similar processing for an unchecked conversion of an expression of
6791 -- the form v.all, where we want the same kind of treatment.
6793 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
6794 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
6796 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
6797 Scope_Suppress := Svg_Suppress;
6800 -- If this is a type conversion, leave the type conversion and remove
6801 -- the side effects in the expression. This is important in several
6802 -- circumstances: for change of representations, and also when this is a
6803 -- view conversion to a smaller object, where gigi can end up creating
6804 -- its own temporary of the wrong size.
6806 elsif Nkind (Exp) = N_Type_Conversion then
6807 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
6808 Scope_Suppress := Svg_Suppress;
6811 -- If this is an unchecked conversion that Gigi can't handle, make
6812 -- a copy or a use a renaming to capture the value.
6814 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
6815 and then not Safe_Unchecked_Type_Conversion (Exp)
6817 if CW_Or_Has_Controlled_Part (Exp_Type) then
6819 -- Use a renaming to capture the expression, rather than create
6820 -- a controlled temporary.
6822 Def_Id := Make_Temporary (Loc, 'R', Exp);
6823 Res := New_Reference_To (Def_Id, Loc);
6826 Make_Object_Renaming_Declaration (Loc,
6827 Defining_Identifier => Def_Id,
6828 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
6829 Name => Relocate_Node (Exp)));
6832 Def_Id := Make_Temporary (Loc, 'R', Exp);
6833 Set_Etype (Def_Id, Exp_Type);
6834 Res := New_Reference_To (Def_Id, Loc);
6837 Make_Object_Declaration (Loc,
6838 Defining_Identifier => Def_Id,
6839 Object_Definition => New_Reference_To (Exp_Type, Loc),
6840 Constant_Present => not Is_Variable (Exp),
6841 Expression => Relocate_Node (Exp));
6843 Set_Assignment_OK (E);
6844 Insert_Action (Exp, E);
6847 -- For expressions that denote objects, we can use a renaming scheme.
6848 -- This is needed for correctness in the case of a volatile object of
6849 -- a non-volatile type because the Make_Reference call of the "default"
6850 -- approach would generate an illegal access value (an access value
6851 -- cannot designate such an object - see Analyze_Reference). We skip
6852 -- using this scheme if we have an object of a volatile type and we do
6853 -- not have Name_Req set true (see comments above for Side_Effect_Free).
6855 -- In Ada 2012 a qualified expression is an object, but for purposes of
6856 -- removing side effects it still need to be transformed into a separate
6857 -- declaration, particularly if the expression is an aggregate.
6859 elsif Is_Object_Reference (Exp)
6860 and then Nkind (Exp) /= N_Function_Call
6861 and then Nkind (Exp) /= N_Qualified_Expression
6862 and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
6864 Def_Id := Make_Temporary (Loc, 'R', Exp);
6866 if Nkind (Exp) = N_Selected_Component
6867 and then Nkind (Prefix (Exp)) = N_Function_Call
6868 and then Is_Array_Type (Exp_Type)
6870 -- Avoid generating a variable-sized temporary, by generating
6871 -- the renaming declaration just for the function call. The
6872 -- transformation could be refined to apply only when the array
6873 -- component is constrained by a discriminant???
6876 Make_Selected_Component (Loc,
6877 Prefix => New_Occurrence_Of (Def_Id, Loc),
6878 Selector_Name => Selector_Name (Exp));
6881 Make_Object_Renaming_Declaration (Loc,
6882 Defining_Identifier => Def_Id,
6884 New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
6885 Name => Relocate_Node (Prefix (Exp))));
6888 Res := New_Reference_To (Def_Id, Loc);
6891 Make_Object_Renaming_Declaration (Loc,
6892 Defining_Identifier => Def_Id,
6893 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
6894 Name => Relocate_Node (Exp)));
6897 -- If this is a packed reference, or a selected component with
6898 -- a non-standard representation, a reference to the temporary
6899 -- will be replaced by a copy of the original expression (see
6900 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
6901 -- elaborated by gigi, and is of course not to be replaced in-line
6902 -- by the expression it renames, which would defeat the purpose of
6903 -- removing the side-effect.
6905 if (Nkind (Exp) = N_Selected_Component
6906 or else Nkind (Exp) = N_Indexed_Component)
6907 and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
6911 Set_Is_Renaming_Of_Object (Def_Id, False);
6914 -- Otherwise we generate a reference to the value
6917 -- An expression which is in Alfa mode is considered side effect free
6918 -- if the resulting value is captured by a variable or a constant.
6921 and then Nkind (Parent (Exp)) = N_Object_Declaration
6926 -- Special processing for function calls that return a limited type.
6927 -- We need to build a declaration that will enable build-in-place
6928 -- expansion of the call. This is not done if the context is already
6929 -- an object declaration, to prevent infinite recursion.
6931 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
6932 -- to accommodate functions returning limited objects by reference.
6934 if Ada_Version >= Ada_2005
6935 and then Nkind (Exp) = N_Function_Call
6936 and then Is_Immutably_Limited_Type (Etype (Exp))
6937 and then Nkind (Parent (Exp)) /= N_Object_Declaration
6940 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
6945 Make_Object_Declaration (Loc,
6946 Defining_Identifier => Obj,
6947 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
6948 Expression => Relocate_Node (Exp));
6950 Insert_Action (Exp, Decl);
6951 Set_Etype (Obj, Exp_Type);
6952 Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
6957 Def_Id := Make_Temporary (Loc, 'R', Exp);
6958 Set_Etype (Def_Id, Exp_Type);
6960 -- The regular expansion of functions with side effects involves the
6961 -- generation of an access type to capture the return value found on
6962 -- the secondary stack. Since Alfa (and why) cannot process access
6963 -- types, use a different approach which ignores the secondary stack
6964 -- and "copies" the returned object.
6967 Res := New_Reference_To (Def_Id, Loc);
6968 Ref_Type := Exp_Type;
6970 -- Regular expansion utilizing an access type and 'reference
6974 Make_Explicit_Dereference (Loc,
6975 Prefix => New_Reference_To (Def_Id, Loc));
6978 -- type Ann is access all <Exp_Type>;
6980 Ref_Type := Make_Temporary (Loc, 'A');
6983 Make_Full_Type_Declaration (Loc,
6984 Defining_Identifier => Ref_Type,
6986 Make_Access_To_Object_Definition (Loc,
6987 All_Present => True,
6988 Subtype_Indication =>
6989 New_Reference_To (Exp_Type, Loc)));
6991 Insert_Action (Exp, Ptr_Typ_Decl);
6995 if Nkind (E) = N_Explicit_Dereference then
6996 New_Exp := Relocate_Node (Prefix (E));
6998 E := Relocate_Node (E);
7000 -- Do not generate a 'reference in Alfa mode since the access type
7001 -- is not created in the first place.
7006 -- Otherwise generate reference, marking the value as non-null
7007 -- since we know it cannot be null and we don't want a check.
7010 New_Exp := Make_Reference (Loc, E);
7011 Set_Is_Known_Non_Null (Def_Id);
7015 if Is_Delayed_Aggregate (E) then
7017 -- The expansion of nested aggregates is delayed until the
7018 -- enclosing aggregate is expanded. As aggregates are often
7019 -- qualified, the predicate applies to qualified expressions as
7020 -- well, indicating that the enclosing aggregate has not been
7021 -- expanded yet. At this point the aggregate is part of a
7022 -- stand-alone declaration, and must be fully expanded.
7024 if Nkind (E) = N_Qualified_Expression then
7025 Set_Expansion_Delayed (Expression (E), False);
7026 Set_Analyzed (Expression (E), False);
7028 Set_Expansion_Delayed (E, False);
7031 Set_Analyzed (E, False);
7035 Make_Object_Declaration (Loc,
7036 Defining_Identifier => Def_Id,
7037 Object_Definition => New_Reference_To (Ref_Type, Loc),
7038 Constant_Present => True,
7039 Expression => New_Exp));
7042 -- Preserve the Assignment_OK flag in all copies, since at least one
7043 -- copy may be used in a context where this flag must be set (otherwise
7044 -- why would the flag be set in the first place).
7046 Set_Assignment_OK (Res, Assignment_OK (Exp));
7048 -- Finally rewrite the original expression and we are done
7051 Analyze_And_Resolve (Exp, Exp_Type);
7052 Scope_Suppress := Svg_Suppress;
7053 end Remove_Side_Effects;
7055 ---------------------------
7056 -- Represented_As_Scalar --
7057 ---------------------------
7059 function Represented_As_Scalar (T : Entity_Id) return Boolean is
7060 UT : constant Entity_Id := Underlying_Type (T);
7062 return Is_Scalar_Type (UT)
7063 or else (Is_Bit_Packed_Array (UT)
7064 and then Is_Scalar_Type (Packed_Array_Type (UT)));
7065 end Represented_As_Scalar;
7067 ------------------------------
7068 -- Requires_Cleanup_Actions --
7069 ------------------------------
7071 function Requires_Cleanup_Actions
7073 Lib_Level : Boolean) return Boolean
7075 At_Lib_Level : constant Boolean :=
7077 and then Nkind_In (N, N_Package_Body,
7078 N_Package_Specification);
7079 -- N is at the library level if the top-most context is a package and
7080 -- the path taken to reach N does not inlcude non-package constructs.
7084 when N_Accept_Statement |
7092 Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True)
7094 (Present (Handled_Statement_Sequence (N))
7096 Requires_Cleanup_Actions
7097 (Statements (Handled_Statement_Sequence (N)),
7098 At_Lib_Level, True));
7100 when N_Package_Specification =>
7102 Requires_Cleanup_Actions
7103 (Visible_Declarations (N), At_Lib_Level, True)
7105 Requires_Cleanup_Actions
7106 (Private_Declarations (N), At_Lib_Level, True);
7111 end Requires_Cleanup_Actions;
7113 ------------------------------
7114 -- Requires_Cleanup_Actions --
7115 ------------------------------
7117 function Requires_Cleanup_Actions
7119 Lib_Level : Boolean;
7120 Nested_Constructs : Boolean) return Boolean
7125 Obj_Typ : Entity_Id;
7126 Pack_Id : Entity_Id;
7131 or else Is_Empty_List (L)
7137 while Present (Decl) loop
7139 -- Library-level tagged types
7141 if Nkind (Decl) = N_Full_Type_Declaration then
7142 Typ := Defining_Identifier (Decl);
7144 if Is_Tagged_Type (Typ)
7145 and then Is_Library_Level_Entity (Typ)
7146 and then Convention (Typ) = Convention_Ada
7147 and then Present (Access_Disp_Table (Typ))
7148 and then RTE_Available (RE_Unregister_Tag)
7149 and then not No_Run_Time_Mode
7150 and then not Is_Abstract_Type (Typ)
7155 -- Regular object declarations
7157 elsif Nkind (Decl) = N_Object_Declaration then
7158 Obj_Id := Defining_Identifier (Decl);
7159 Obj_Typ := Base_Type (Etype (Obj_Id));
7160 Expr := Expression (Decl);
7162 -- Bypass any form of processing for objects which have their
7163 -- finalization disabled. This applies only to objects at the
7166 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
7169 -- Transient variables are treated separately in order to minimize
7170 -- the size of the generated code. See Exp_Ch7.Process_Transient_
7173 elsif Is_Processed_Transient (Obj_Id) then
7176 -- The object is of the form:
7177 -- Obj : Typ [:= Expr];
7179 -- Do not process the incomplete view of a deferred constant. Do
7180 -- not consider tag-to-class-wide conversions.
7182 elsif not Is_Imported (Obj_Id)
7183 and then Needs_Finalization (Obj_Typ)
7184 and then not (Ekind (Obj_Id) = E_Constant
7185 and then not Has_Completion (Obj_Id))
7186 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
7190 -- The object is of the form:
7191 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
7193 -- Obj : Access_Typ :=
7194 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
7196 elsif Is_Access_Type (Obj_Typ)
7197 and then Needs_Finalization
7198 (Available_View (Designated_Type (Obj_Typ)))
7199 and then Present (Expr)
7201 (Is_Secondary_Stack_BIP_Func_Call (Expr)
7203 (Is_Non_BIP_Func_Call (Expr)
7204 and then not Is_Related_To_Func_Return (Obj_Id)))
7208 -- Processing for "hook" objects generated for controlled
7209 -- transients declared inside an Expression_With_Actions.
7211 elsif Is_Access_Type (Obj_Typ)
7212 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
7213 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
7214 N_Object_Declaration
7215 and then Is_Finalizable_Transient
7216 (Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
7220 -- Processing for intermediate results of if expressions where
7221 -- one of the alternatives uses a controlled function call.
7223 elsif Is_Access_Type (Obj_Typ)
7224 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
7225 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
7226 N_Defining_Identifier
7227 and then Present (Expr)
7228 and then Nkind (Expr) = N_Null
7232 -- Simple protected objects which use type System.Tasking.
7233 -- Protected_Objects.Protection to manage their locks should be
7234 -- treated as controlled since they require manual cleanup.
7236 elsif Ekind (Obj_Id) = E_Variable
7238 (Is_Simple_Protected_Type (Obj_Typ)
7239 or else Has_Simple_Protected_Object (Obj_Typ))
7244 -- Specific cases of object renamings
7246 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
7247 Obj_Id := Defining_Identifier (Decl);
7248 Obj_Typ := Base_Type (Etype (Obj_Id));
7250 -- Bypass any form of processing for objects which have their
7251 -- finalization disabled. This applies only to objects at the
7254 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
7257 -- Return object of a build-in-place function. This case is
7258 -- recognized and marked by the expansion of an extended return
7259 -- statement (see Expand_N_Extended_Return_Statement).
7261 elsif Needs_Finalization (Obj_Typ)
7262 and then Is_Return_Object (Obj_Id)
7263 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
7267 -- Detect a case where a source object has been initialized by
7268 -- a controlled function call or another object which was later
7269 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
7271 -- Obj1 : CW_Type := Src_Obj;
7272 -- Obj2 : CW_Type := Function_Call (...);
7274 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
7275 -- Tmp : ... := Function_Call (...)'reference;
7276 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
7278 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
7282 -- Inspect the freeze node of an access-to-controlled type and look
7283 -- for a delayed finalization master. This case arises when the
7284 -- freeze actions are inserted at a later time than the expansion of
7285 -- the context. Since Build_Finalizer is never called on a single
7286 -- construct twice, the master will be ultimately left out and never
7287 -- finalized. This is also needed for freeze actions of designated
7288 -- types themselves, since in some cases the finalization master is
7289 -- associated with a designated type's freeze node rather than that
7290 -- of the access type (see handling for freeze actions in
7291 -- Build_Finalization_Master).
7293 elsif Nkind (Decl) = N_Freeze_Entity
7294 and then Present (Actions (Decl))
7296 Typ := Entity (Decl);
7298 if ((Is_Access_Type (Typ)
7299 and then not Is_Access_Subprogram_Type (Typ)
7300 and then Needs_Finalization
7301 (Available_View (Designated_Type (Typ))))
7304 and then Needs_Finalization (Typ)))
7305 and then Requires_Cleanup_Actions
7306 (Actions (Decl), Lib_Level, Nested_Constructs)
7311 -- Nested package declarations
7313 elsif Nested_Constructs
7314 and then Nkind (Decl) = N_Package_Declaration
7316 Pack_Id := Defining_Unit_Name (Specification (Decl));
7318 if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
7319 Pack_Id := Defining_Identifier (Pack_Id);
7322 if Ekind (Pack_Id) /= E_Generic_Package
7323 and then Requires_Cleanup_Actions
7324 (Specification (Decl), Lib_Level)
7329 -- Nested package bodies
7331 elsif Nested_Constructs
7332 and then Nkind (Decl) = N_Package_Body
7334 Pack_Id := Corresponding_Spec (Decl);
7336 if Ekind (Pack_Id) /= E_Generic_Package
7337 and then Requires_Cleanup_Actions (Decl, Lib_Level)
7347 end Requires_Cleanup_Actions;
7349 ------------------------------------
7350 -- Safe_Unchecked_Type_Conversion --
7351 ------------------------------------
7353 -- Note: this function knows quite a bit about the exact requirements of
7354 -- Gigi with respect to unchecked type conversions, and its code must be
7355 -- coordinated with any changes in Gigi in this area.
7357 -- The above requirements should be documented in Sinfo ???
7359 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
7364 Pexp : constant Node_Id := Parent (Exp);
7367 -- If the expression is the RHS of an assignment or object declaration
7368 -- we are always OK because there will always be a target.
7370 -- Object renaming declarations, (generated for view conversions of
7371 -- actuals in inlined calls), like object declarations, provide an
7372 -- explicit type, and are safe as well.
7374 if (Nkind (Pexp) = N_Assignment_Statement
7375 and then Expression (Pexp) = Exp)
7376 or else Nkind (Pexp) = N_Object_Declaration
7377 or else Nkind (Pexp) = N_Object_Renaming_Declaration
7381 -- If the expression is the prefix of an N_Selected_Component we should
7382 -- also be OK because GCC knows to look inside the conversion except if
7383 -- the type is discriminated. We assume that we are OK anyway if the
7384 -- type is not set yet or if it is controlled since we can't afford to
7385 -- introduce a temporary in this case.
7387 elsif Nkind (Pexp) = N_Selected_Component
7388 and then Prefix (Pexp) = Exp
7390 if No (Etype (Pexp)) then
7394 not Has_Discriminants (Etype (Pexp))
7395 or else Is_Constrained (Etype (Pexp));
7399 -- Set the output type, this comes from Etype if it is set, otherwise we
7400 -- take it from the subtype mark, which we assume was already fully
7403 if Present (Etype (Exp)) then
7404 Otyp := Etype (Exp);
7406 Otyp := Entity (Subtype_Mark (Exp));
7409 -- The input type always comes from the expression, and we assume
7410 -- this is indeed always analyzed, so we can simply get the Etype.
7412 Ityp := Etype (Expression (Exp));
7414 -- Initialize alignments to unknown so far
7419 -- Replace a concurrent type by its corresponding record type and each
7420 -- type by its underlying type and do the tests on those. The original
7421 -- type may be a private type whose completion is a concurrent type, so
7422 -- find the underlying type first.
7424 if Present (Underlying_Type (Otyp)) then
7425 Otyp := Underlying_Type (Otyp);
7428 if Present (Underlying_Type (Ityp)) then
7429 Ityp := Underlying_Type (Ityp);
7432 if Is_Concurrent_Type (Otyp) then
7433 Otyp := Corresponding_Record_Type (Otyp);
7436 if Is_Concurrent_Type (Ityp) then
7437 Ityp := Corresponding_Record_Type (Ityp);
7440 -- If the base types are the same, we know there is no problem since
7441 -- this conversion will be a noop.
7443 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
7446 -- Same if this is an upwards conversion of an untagged type, and there
7447 -- are no constraints involved (could be more general???)
7449 elsif Etype (Ityp) = Otyp
7450 and then not Is_Tagged_Type (Ityp)
7451 and then not Has_Discriminants (Ityp)
7452 and then No (First_Rep_Item (Base_Type (Ityp)))
7456 -- If the expression has an access type (object or subprogram) we assume
7457 -- that the conversion is safe, because the size of the target is safe,
7458 -- even if it is a record (which might be treated as having unknown size
7461 elsif Is_Access_Type (Ityp) then
7464 -- If the size of output type is known at compile time, there is never
7465 -- a problem. Note that unconstrained records are considered to be of
7466 -- known size, but we can't consider them that way here, because we are
7467 -- talking about the actual size of the object.
7469 -- We also make sure that in addition to the size being known, we do not
7470 -- have a case which might generate an embarrassingly large temp in
7471 -- stack checking mode.
7473 elsif Size_Known_At_Compile_Time (Otyp)
7475 (not Stack_Checking_Enabled
7476 or else not May_Generate_Large_Temp (Otyp))
7477 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
7481 -- If either type is tagged, then we know the alignment is OK so
7482 -- Gigi will be able to use pointer punning.
7484 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
7487 -- If either type is a limited record type, we cannot do a copy, so say
7488 -- safe since there's nothing else we can do.
7490 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
7493 -- Conversions to and from packed array types are always ignored and
7496 elsif Is_Packed_Array_Type (Otyp)
7497 or else Is_Packed_Array_Type (Ityp)
7502 -- The only other cases known to be safe is if the input type's
7503 -- alignment is known to be at least the maximum alignment for the
7504 -- target or if both alignments are known and the output type's
7505 -- alignment is no stricter than the input's. We can use the component
7506 -- type alignement for an array if a type is an unpacked array type.
7508 if Present (Alignment_Clause (Otyp)) then
7509 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
7511 elsif Is_Array_Type (Otyp)
7512 and then Present (Alignment_Clause (Component_Type (Otyp)))
7514 Oalign := Expr_Value (Expression (Alignment_Clause
7515 (Component_Type (Otyp))));
7518 if Present (Alignment_Clause (Ityp)) then
7519 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
7521 elsif Is_Array_Type (Ityp)
7522 and then Present (Alignment_Clause (Component_Type (Ityp)))
7524 Ialign := Expr_Value (Expression (Alignment_Clause
7525 (Component_Type (Ityp))));
7528 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
7531 elsif Ialign /= No_Uint and then Oalign /= No_Uint
7532 and then Ialign <= Oalign
7536 -- Otherwise, Gigi cannot handle this and we must make a temporary
7541 end Safe_Unchecked_Type_Conversion;
7543 ---------------------------------
7544 -- Set_Current_Value_Condition --
7545 ---------------------------------
7547 -- Note: the implementation of this procedure is very closely tied to the
7548 -- implementation of Get_Current_Value_Condition. Here we set required
7549 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
7550 -- them, so they must have a consistent view.
7552 procedure Set_Current_Value_Condition (Cnode : Node_Id) is
7554 procedure Set_Entity_Current_Value (N : Node_Id);
7555 -- If N is an entity reference, where the entity is of an appropriate
7556 -- kind, then set the current value of this entity to Cnode, unless
7557 -- there is already a definite value set there.
7559 procedure Set_Expression_Current_Value (N : Node_Id);
7560 -- If N is of an appropriate form, sets an appropriate entry in current
7561 -- value fields of relevant entities. Multiple entities can be affected
7562 -- in the case of an AND or AND THEN.
7564 ------------------------------
7565 -- Set_Entity_Current_Value --
7566 ------------------------------
7568 procedure Set_Entity_Current_Value (N : Node_Id) is
7570 if Is_Entity_Name (N) then
7572 Ent : constant Entity_Id := Entity (N);
7575 -- Don't capture if not safe to do so
7577 if not Safe_To_Capture_Value (N, Ent, Cond => True) then
7581 -- Here we have a case where the Current_Value field may need
7582 -- to be set. We set it if it is not already set to a compile
7583 -- time expression value.
7585 -- Note that this represents a decision that one condition
7586 -- blots out another previous one. That's certainly right if
7587 -- they occur at the same level. If the second one is nested,
7588 -- then the decision is neither right nor wrong (it would be
7589 -- equally OK to leave the outer one in place, or take the new
7590 -- inner one. Really we should record both, but our data
7591 -- structures are not that elaborate.
7593 if Nkind (Current_Value (Ent)) not in N_Subexpr then
7594 Set_Current_Value (Ent, Cnode);
7598 end Set_Entity_Current_Value;
7600 ----------------------------------
7601 -- Set_Expression_Current_Value --
7602 ----------------------------------
7604 procedure Set_Expression_Current_Value (N : Node_Id) is
7610 -- Loop to deal with (ignore for now) any NOT operators present. The
7611 -- presence of NOT operators will be handled properly when we call
7612 -- Get_Current_Value_Condition.
7614 while Nkind (Cond) = N_Op_Not loop
7615 Cond := Right_Opnd (Cond);
7618 -- For an AND or AND THEN, recursively process operands
7620 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
7621 Set_Expression_Current_Value (Left_Opnd (Cond));
7622 Set_Expression_Current_Value (Right_Opnd (Cond));
7626 -- Check possible relational operator
7628 if Nkind (Cond) in N_Op_Compare then
7629 if Compile_Time_Known_Value (Right_Opnd (Cond)) then
7630 Set_Entity_Current_Value (Left_Opnd (Cond));
7631 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
7632 Set_Entity_Current_Value (Right_Opnd (Cond));
7635 -- Check possible boolean variable reference
7638 Set_Entity_Current_Value (Cond);
7640 end Set_Expression_Current_Value;
7642 -- Start of processing for Set_Current_Value_Condition
7645 Set_Expression_Current_Value (Condition (Cnode));
7646 end Set_Current_Value_Condition;
7648 --------------------------
7649 -- Set_Elaboration_Flag --
7650 --------------------------
7652 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
7653 Loc : constant Source_Ptr := Sloc (N);
7654 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
7658 if Present (Ent) then
7660 -- Nothing to do if at the compilation unit level, because in this
7661 -- case the flag is set by the binder generated elaboration routine.
7663 if Nkind (Parent (N)) = N_Compilation_Unit then
7666 -- Here we do need to generate an assignment statement
7669 Check_Restriction (No_Elaboration_Code, N);
7671 Make_Assignment_Statement (Loc,
7672 Name => New_Occurrence_Of (Ent, Loc),
7673 Expression => Make_Integer_Literal (Loc, Uint_1));
7675 if Nkind (Parent (N)) = N_Subunit then
7676 Insert_After (Corresponding_Stub (Parent (N)), Asn);
7678 Insert_After (N, Asn);
7683 -- Kill current value indication. This is necessary because the
7684 -- tests of this flag are inserted out of sequence and must not
7685 -- pick up bogus indications of the wrong constant value.
7687 Set_Current_Value (Ent, Empty);
7690 end Set_Elaboration_Flag;
7692 ----------------------------
7693 -- Set_Renamed_Subprogram --
7694 ----------------------------
7696 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
7698 -- If input node is an identifier, we can just reset it
7700 if Nkind (N) = N_Identifier then
7701 Set_Chars (N, Chars (E));
7704 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
7708 CS : constant Boolean := Comes_From_Source (N);
7710 Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
7712 Set_Comes_From_Source (N, CS);
7713 Set_Analyzed (N, True);
7716 end Set_Renamed_Subprogram;
7718 ----------------------------------
7719 -- Silly_Boolean_Array_Not_Test --
7720 ----------------------------------
7722 -- This procedure implements an odd and silly test. We explicitly check
7723 -- for the case where the 'First of the component type is equal to the
7724 -- 'Last of this component type, and if this is the case, we make sure
7725 -- that constraint error is raised. The reason is that the NOT is bound
7726 -- to cause CE in this case, and we will not otherwise catch it.
7728 -- No such check is required for AND and OR, since for both these cases
7729 -- False op False = False, and True op True = True. For the XOR case,
7730 -- see Silly_Boolean_Array_Xor_Test.
7732 -- Believe it or not, this was reported as a bug. Note that nearly always,
7733 -- the test will evaluate statically to False, so the code will be
7734 -- statically removed, and no extra overhead caused.
7736 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
7737 Loc : constant Source_Ptr := Sloc (N);
7738 CT : constant Entity_Id := Component_Type (T);
7741 -- The check we install is
7743 -- constraint_error when
7744 -- component_type'first = component_type'last
7745 -- and then array_type'Length /= 0)
7747 -- We need the last guard because we don't want to raise CE for empty
7748 -- arrays since no out of range values result. (Empty arrays with a
7749 -- component type of True .. True -- very useful -- even the ACATS
7750 -- does not test that marginal case!)
7753 Make_Raise_Constraint_Error (Loc,
7759 Make_Attribute_Reference (Loc,
7760 Prefix => New_Occurrence_Of (CT, Loc),
7761 Attribute_Name => Name_First),
7764 Make_Attribute_Reference (Loc,
7765 Prefix => New_Occurrence_Of (CT, Loc),
7766 Attribute_Name => Name_Last)),
7768 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
7769 Reason => CE_Range_Check_Failed));
7770 end Silly_Boolean_Array_Not_Test;
7772 ----------------------------------
7773 -- Silly_Boolean_Array_Xor_Test --
7774 ----------------------------------
7776 -- This procedure implements an odd and silly test. We explicitly check
7777 -- for the XOR case where the component type is True .. True, since this
7778 -- will raise constraint error. A special check is required since CE
7779 -- will not be generated otherwise (cf Expand_Packed_Not).
7781 -- No such check is required for AND and OR, since for both these cases
7782 -- False op False = False, and True op True = True, and no check is
7783 -- required for the case of False .. False, since False xor False = False.
7784 -- See also Silly_Boolean_Array_Not_Test
7786 procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is
7787 Loc : constant Source_Ptr := Sloc (N);
7788 CT : constant Entity_Id := Component_Type (T);
7791 -- The check we install is
7793 -- constraint_error when
7794 -- Boolean (component_type'First)
7795 -- and then Boolean (component_type'Last)
7796 -- and then array_type'Length /= 0)
7798 -- We need the last guard because we don't want to raise CE for empty
7799 -- arrays since no out of range values result (Empty arrays with a
7800 -- component type of True .. True -- very useful -- even the ACATS
7801 -- does not test that marginal case!).
7804 Make_Raise_Constraint_Error (Loc,
7810 Convert_To (Standard_Boolean,
7811 Make_Attribute_Reference (Loc,
7812 Prefix => New_Occurrence_Of (CT, Loc),
7813 Attribute_Name => Name_First)),
7816 Convert_To (Standard_Boolean,
7817 Make_Attribute_Reference (Loc,
7818 Prefix => New_Occurrence_Of (CT, Loc),
7819 Attribute_Name => Name_Last))),
7821 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
7822 Reason => CE_Range_Check_Failed));
7823 end Silly_Boolean_Array_Xor_Test;
7825 --------------------------
7826 -- Target_Has_Fixed_Ops --
7827 --------------------------
7829 Integer_Sized_Small : Ureal;
7830 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
7831 -- called (we don't want to compute it more than once!)
7833 Long_Integer_Sized_Small : Ureal;
7834 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
7835 -- is called (we don't want to compute it more than once)
7837 First_Time_For_THFO : Boolean := True;
7838 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
7840 function Target_Has_Fixed_Ops
7841 (Left_Typ : Entity_Id;
7842 Right_Typ : Entity_Id;
7843 Result_Typ : Entity_Id) return Boolean
7845 function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
7846 -- Return True if the given type is a fixed-point type with a small
7847 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
7848 -- an absolute value less than 1.0. This is currently limited to
7849 -- fixed-point types that map to Integer or Long_Integer.
7851 ------------------------
7852 -- Is_Fractional_Type --
7853 ------------------------
7855 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
7857 if Esize (Typ) = Standard_Integer_Size then
7858 return Small_Value (Typ) = Integer_Sized_Small;
7860 elsif Esize (Typ) = Standard_Long_Integer_Size then
7861 return Small_Value (Typ) = Long_Integer_Sized_Small;
7866 end Is_Fractional_Type;
7868 -- Start of processing for Target_Has_Fixed_Ops
7871 -- Return False if Fractional_Fixed_Ops_On_Target is false
7873 if not Fractional_Fixed_Ops_On_Target then
7877 -- Here the target has Fractional_Fixed_Ops, if first time, compute
7878 -- standard constants used by Is_Fractional_Type.
7880 if First_Time_For_THFO then
7881 First_Time_For_THFO := False;
7883 Integer_Sized_Small :=
7886 Den => UI_From_Int (Standard_Integer_Size - 1),
7889 Long_Integer_Sized_Small :=
7892 Den => UI_From_Int (Standard_Long_Integer_Size - 1),
7896 -- Return True if target supports fixed-by-fixed multiply/divide for
7897 -- fractional fixed-point types (see Is_Fractional_Type) and the operand
7898 -- and result types are equivalent fractional types.
7900 return Is_Fractional_Type (Base_Type (Left_Typ))
7901 and then Is_Fractional_Type (Base_Type (Right_Typ))
7902 and then Is_Fractional_Type (Base_Type (Result_Typ))
7903 and then Esize (Left_Typ) = Esize (Right_Typ)
7904 and then Esize (Left_Typ) = Esize (Result_Typ);
7905 end Target_Has_Fixed_Ops;
7907 ------------------------------------------
7908 -- Type_May_Have_Bit_Aligned_Components --
7909 ------------------------------------------
7911 function Type_May_Have_Bit_Aligned_Components
7912 (Typ : Entity_Id) return Boolean
7915 -- Array type, check component type
7917 if Is_Array_Type (Typ) then
7919 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
7921 -- Record type, check components
7923 elsif Is_Record_Type (Typ) then
7928 E := First_Component_Or_Discriminant (Typ);
7929 while Present (E) loop
7930 if Component_May_Be_Bit_Aligned (E)
7931 or else Type_May_Have_Bit_Aligned_Components (Etype (E))
7936 Next_Component_Or_Discriminant (E);
7942 -- Type other than array or record is always OK
7947 end Type_May_Have_Bit_Aligned_Components;
7949 ----------------------------
7950 -- Wrap_Cleanup_Procedure --
7951 ----------------------------
7953 procedure Wrap_Cleanup_Procedure (N : Node_Id) is
7954 Loc : constant Source_Ptr := Sloc (N);
7955 Stseq : constant Node_Id := Handled_Statement_Sequence (N);
7956 Stmts : constant List_Id := Statements (Stseq);
7959 if Abort_Allowed then
7960 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7961 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7963 end Wrap_Cleanup_Procedure;