1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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 Atree; use Atree;
27 with Casing; use Casing;
28 with Checks; use Checks;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Elists; use Elists;
32 with Errout; use Errout;
33 with Exp_Aggr; use Exp_Aggr;
34 with Exp_Ch6; use Exp_Ch6;
35 with Exp_Ch7; use Exp_Ch7;
36 with Inline; use Inline;
37 with Itypes; use Itypes;
39 with Nlists; use Nlists;
40 with Nmake; use Nmake;
42 with Restrict; use Restrict;
43 with Rident; use Rident;
45 with Sem_Aux; use Sem_Aux;
46 with Sem_Ch8; use Sem_Ch8;
47 with Sem_Eval; use Sem_Eval;
48 with Sem_Prag; use Sem_Prag;
49 with Sem_Res; use Sem_Res;
50 with Sem_Type; use Sem_Type;
51 with Sem_Util; use Sem_Util;
52 with Snames; use Snames;
53 with Stand; use Stand;
54 with Stringt; use Stringt;
55 with Targparm; use Targparm;
56 with Tbuild; use Tbuild;
57 with Ttypes; use Ttypes;
58 with Urealp; use Urealp;
59 with Validsw; use Validsw;
61 package body Exp_Util is
63 -----------------------
64 -- Local Subprograms --
65 -----------------------
67 function Build_Task_Array_Image
71 Dyn : Boolean := False) return Node_Id;
72 -- Build function to generate the image string for a task that is an array
73 -- component, concatenating the images of each index. To avoid storage
74 -- leaks, the string is built with successive slice assignments. The flag
75 -- Dyn indicates whether this is called for the initialization procedure of
76 -- an array of tasks, or for the name of a dynamically created task that is
77 -- assigned to an indexed component.
79 function Build_Task_Image_Function
83 Res : Entity_Id) return Node_Id;
84 -- Common processing for Task_Array_Image and Task_Record_Image. Build
85 -- function body that computes image.
87 procedure Build_Task_Image_Prefix
96 -- Common processing for Task_Array_Image and Task_Record_Image. Create
97 -- local variables and assign prefix of name to result string.
99 function Build_Task_Record_Image
102 Dyn : Boolean := False) return Node_Id;
103 -- Build function to generate the image string for a task that is a record
104 -- component. Concatenate name of variable with that of selector. The flag
105 -- Dyn indicates whether this is called for the initialization procedure of
106 -- record with task components, or for a dynamically created task that is
107 -- assigned to a selected component.
109 function Make_CW_Equivalent_Type
111 E : Node_Id) return Entity_Id;
112 -- T is a class-wide type entity, E is the initial expression node that
113 -- constrains T in case such as: " X: T := E" or "new T'(E)". This function
114 -- returns the entity of the Equivalent type and inserts on the fly the
115 -- necessary declaration such as:
117 -- type anon is record
118 -- _parent : Root_Type (T); constrained with E discriminants (if any)
119 -- Extension : String (1 .. expr to match size of E);
122 -- This record is compatible with any object of the class of T thanks to
123 -- the first field and has the same size as E thanks to the second.
125 function Make_Literal_Range
127 Literal_Typ : Entity_Id) return Node_Id;
128 -- Produce a Range node whose bounds are:
129 -- Low_Bound (Literal_Type) ..
130 -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
131 -- this is used for expanding declarations like X : String := "sdfgdfg";
133 -- If the index type of the target array is not integer, we generate:
134 -- Low_Bound (Literal_Type) ..
136 -- (Literal_Type'Pos (Low_Bound (Literal_Type))
137 -- + (Length (Literal_Typ) -1))
139 function Make_Non_Empty_Check
141 N : Node_Id) return Node_Id;
142 -- Produce a boolean expression checking that the unidimensional array
143 -- node N is not empty.
145 function New_Class_Wide_Subtype
147 N : Node_Id) return Entity_Id;
148 -- Create an implicit subtype of CW_Typ attached to node N
150 function Requires_Cleanup_Actions
152 For_Package : Boolean;
153 Nested_Constructs : Boolean) return Boolean;
154 -- Given a list L, determine whether it contains one of the following:
156 -- 1) controlled objects
157 -- 2) library-level tagged types
159 -- Flag For_Package should be set when the list comes from a package spec
160 -- or body. Flag Nested_Constructs should be set when any nested packages
161 -- declared in L must be processed.
163 -------------------------------------
164 -- Activate_Atomic_Synchronization --
165 -------------------------------------
167 procedure Activate_Atomic_Synchronization (N : Node_Id) is
171 case Nkind (Parent (N)) is
173 -- Check for cases of appearing in the prefix of a construct where
174 -- we don't need atomic synchronization for this kind of usage.
177 -- Nothing to do if we are the prefix of an attribute, since we
178 -- do not want an atomic sync operation for things like 'Size.
180 N_Attribute_Reference |
182 -- The N_Reference node is like an attribute
186 -- Nothing to do for a reference to a component (or components)
187 -- of a composite object. Only reads and updates of the object
188 -- as a whole require atomic synchronization (RM C.6 (15)).
190 N_Indexed_Component |
191 N_Selected_Component |
194 -- For all the above cases, nothing to do if we are the prefix
196 if Prefix (Parent (N)) = N then
203 -- Go ahead and set the flag
205 Set_Atomic_Sync_Required (N);
207 -- Generate info message if requested
209 if Warn_On_Atomic_Synchronization then
214 when N_Selected_Component | N_Expanded_Name =>
215 Msg_Node := Selector_Name (N);
217 when N_Explicit_Dereference | N_Indexed_Component =>
221 pragma Assert (False);
225 if Present (Msg_Node) then
226 Error_Msg_N ("?info: atomic synchronization set for &", Msg_Node);
228 Error_Msg_N ("?info: atomic synchronization set", N);
231 end Activate_Atomic_Synchronization;
233 ----------------------
234 -- Adjust_Condition --
235 ----------------------
237 procedure Adjust_Condition (N : Node_Id) is
244 Loc : constant Source_Ptr := Sloc (N);
245 T : constant Entity_Id := Etype (N);
249 -- Defend against a call where the argument has no type, or has a
250 -- type that is not Boolean. This can occur because of prior errors.
252 if No (T) or else not Is_Boolean_Type (T) then
256 -- Apply validity checking if needed
258 if Validity_Checks_On and Validity_Check_Tests then
262 -- Immediate return if standard boolean, the most common case,
263 -- where nothing needs to be done.
265 if Base_Type (T) = Standard_Boolean then
269 -- Case of zero/non-zero semantics or non-standard enumeration
270 -- representation. In each case, we rewrite the node as:
272 -- ityp!(N) /= False'Enum_Rep
274 -- where ityp is an integer type with large enough size to hold any
277 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
278 if Esize (T) <= Esize (Standard_Integer) then
279 Ti := Standard_Integer;
281 Ti := Standard_Long_Long_Integer;
286 Left_Opnd => Unchecked_Convert_To (Ti, N),
288 Make_Attribute_Reference (Loc,
289 Attribute_Name => Name_Enum_Rep,
291 New_Occurrence_Of (First_Literal (T), Loc))));
292 Analyze_And_Resolve (N, Standard_Boolean);
295 Rewrite (N, Convert_To (Standard_Boolean, N));
296 Analyze_And_Resolve (N, Standard_Boolean);
299 end Adjust_Condition;
301 ------------------------
302 -- Adjust_Result_Type --
303 ------------------------
305 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
307 -- Ignore call if current type is not Standard.Boolean
309 if Etype (N) /= Standard_Boolean then
313 -- If result is already of correct type, nothing to do. Note that
314 -- this will get the most common case where everything has a type
315 -- of Standard.Boolean.
317 if Base_Type (T) = Standard_Boolean then
322 KP : constant Node_Kind := Nkind (Parent (N));
325 -- If result is to be used as a Condition in the syntax, no need
326 -- to convert it back, since if it was changed to Standard.Boolean
327 -- using Adjust_Condition, that is just fine for this usage.
329 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
332 -- If result is an operand of another logical operation, no need
333 -- to reset its type, since Standard.Boolean is just fine, and
334 -- such operations always do Adjust_Condition on their operands.
336 elsif KP in N_Op_Boolean
337 or else KP in N_Short_Circuit
338 or else KP = N_Op_Not
342 -- Otherwise we perform a conversion from the current type, which
343 -- must be Standard.Boolean, to the desired type.
347 Rewrite (N, Convert_To (T, N));
348 Analyze_And_Resolve (N, T);
352 end Adjust_Result_Type;
354 --------------------------
355 -- Append_Freeze_Action --
356 --------------------------
358 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
362 Ensure_Freeze_Node (T);
363 Fnode := Freeze_Node (T);
365 if No (Actions (Fnode)) then
366 Set_Actions (Fnode, New_List);
369 Append (N, Actions (Fnode));
370 end Append_Freeze_Action;
372 ---------------------------
373 -- Append_Freeze_Actions --
374 ---------------------------
376 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
377 Fnode : constant Node_Id := Freeze_Node (T);
384 if No (Actions (Fnode)) then
385 Set_Actions (Fnode, L);
387 Append_List (L, Actions (Fnode));
390 end Append_Freeze_Actions;
392 ------------------------------------
393 -- Build_Allocate_Deallocate_Proc --
394 ------------------------------------
396 procedure Build_Allocate_Deallocate_Proc
398 Is_Allocate : Boolean)
400 Desig_Typ : Entity_Id;
403 Proc_To_Call : Node_Id := Empty;
406 function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
407 -- Locate TSS primitive Finalize_Address in type Typ
409 function Find_Object (E : Node_Id) return Node_Id;
410 -- Given an arbitrary expression of an allocator, try to find an object
411 -- reference in it, otherwise return the original expression.
413 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
414 -- Determine whether subprogram Subp denotes a custom allocate or
417 ---------------------------
418 -- Find_Finalize_Address --
419 ---------------------------
421 function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id is
422 Utyp : Entity_Id := Typ;
425 -- Handle protected class-wide or task class-wide types
427 if Is_Class_Wide_Type (Utyp) then
428 if Is_Concurrent_Type (Root_Type (Utyp)) then
429 Utyp := Root_Type (Utyp);
431 elsif Is_Private_Type (Root_Type (Utyp))
432 and then Present (Full_View (Root_Type (Utyp)))
433 and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
435 Utyp := Full_View (Root_Type (Utyp));
439 -- Handle private types
441 if Is_Private_Type (Utyp)
442 and then Present (Full_View (Utyp))
444 Utyp := Full_View (Utyp);
447 -- Handle protected and task types
449 if Is_Concurrent_Type (Utyp)
450 and then Present (Corresponding_Record_Type (Utyp))
452 Utyp := Corresponding_Record_Type (Utyp);
455 Utyp := Underlying_Type (Base_Type (Utyp));
457 -- Deal with non-tagged derivation of private views. If the parent is
458 -- now known to be protected, the finalization routine is the one
459 -- defined on the corresponding record of the ancestor (corresponding
460 -- records do not automatically inherit operations, but maybe they
463 if Is_Untagged_Derivation (Typ) then
464 if Is_Protected_Type (Typ) then
465 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
467 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
469 if Is_Protected_Type (Utyp) then
470 Utyp := Corresponding_Record_Type (Utyp);
475 -- If the underlying_type is a subtype, we are dealing with the
476 -- completion of a private type. We need to access the base type and
477 -- generate a conversion to it.
479 if Utyp /= Base_Type (Utyp) then
480 pragma Assert (Is_Private_Type (Typ));
482 Utyp := Base_Type (Utyp);
485 return TSS (Utyp, TSS_Finalize_Address);
486 end Find_Finalize_Address;
492 function Find_Object (E : Node_Id) return Node_Id is
496 pragma Assert (Is_Allocate);
500 if Nkind_In (Expr, N_Qualified_Expression,
501 N_Unchecked_Type_Conversion)
503 Expr := Expression (Expr);
505 elsif Nkind (Expr) = N_Explicit_Dereference then
506 Expr := Prefix (Expr);
516 ---------------------------------
517 -- Is_Allocate_Deallocate_Proc --
518 ---------------------------------
520 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
522 -- Look for a subprogram body with only one statement which is a
523 -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
525 if Ekind (Subp) = E_Procedure
526 and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
529 HSS : constant Node_Id :=
530 Handled_Statement_Sequence (Parent (Parent (Subp)));
534 if Present (Statements (HSS))
535 and then Nkind (First (Statements (HSS))) =
536 N_Procedure_Call_Statement
538 Proc := Entity (Name (First (Statements (HSS))));
541 Is_RTE (Proc, RE_Allocate_Any_Controlled)
542 or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
548 end Is_Allocate_Deallocate_Proc;
550 -- Start of processing for Build_Allocate_Deallocate_Proc
553 -- Do not perform this expansion in Alfa mode because it is not
560 -- Obtain the attributes of the allocation / deallocation
562 if Nkind (N) = N_Free_Statement then
563 Expr := Expression (N);
564 Ptr_Typ := Base_Type (Etype (Expr));
565 Proc_To_Call := Procedure_To_Call (N);
568 if Nkind (N) = N_Object_Declaration then
569 Expr := Expression (N);
574 -- In certain cases an allocator with a qualified expression may
575 -- be relocated and used as the initialization expression of a
579 -- Obj : Ptr_Typ := new Desig_Typ'(...);
582 -- Tmp : Ptr_Typ := new Desig_Typ'(...);
583 -- Obj : Ptr_Typ := Tmp;
585 -- Since the allocator is always marked as analyzed to avoid infinite
586 -- expansion, it will never be processed by this routine given that
587 -- the designated type needs finalization actions. Detect this case
588 -- and complete the expansion of the allocator.
590 if Nkind (Expr) = N_Identifier
591 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
592 and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
594 Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
598 -- The allocator may have been rewritten into something else in which
599 -- case the expansion performed by this routine does not apply.
601 if Nkind (Expr) /= N_Allocator then
605 Ptr_Typ := Base_Type (Etype (Expr));
606 Proc_To_Call := Procedure_To_Call (Expr);
609 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
610 Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
612 -- Handle concurrent types
614 if Is_Concurrent_Type (Desig_Typ)
615 and then Present (Corresponding_Record_Type (Desig_Typ))
617 Desig_Typ := Corresponding_Record_Type (Desig_Typ);
620 -- Do not process allocations / deallocations without a pool
625 -- Do not process allocations on / deallocations from the secondary
628 elsif Is_RTE (Pool_Id, RE_SS_Pool) then
631 -- Do not replicate the machinery if the allocator / free has already
632 -- been expanded and has a custom Allocate / Deallocate.
634 elsif Present (Proc_To_Call)
635 and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
640 if Needs_Finalization (Desig_Typ) then
642 -- Certain run-time configurations and targets do not provide support
643 -- for controlled types.
645 if Restriction_Active (No_Finalization) then
648 -- Do nothing if the access type may never allocate / deallocate
651 elsif No_Pool_Assigned (Ptr_Typ) then
654 -- Access-to-controlled types are not supported on .NET/JVM since
655 -- these targets cannot support pools and address arithmetic.
657 elsif VM_Target /= No_VM then
661 -- The allocation / deallocation of a controlled object must be
662 -- chained on / detached from a finalization master.
664 pragma Assert (Present (Finalization_Master (Ptr_Typ)));
666 -- The only other kind of allocation / deallocation supported by this
667 -- routine is on / from a subpool.
669 elsif Nkind (Expr) = N_Allocator
670 and then No (Subpool_Handle_Name (Expr))
676 Loc : constant Source_Ptr := Sloc (N);
677 Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
678 Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
679 Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
680 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
683 Fin_Addr_Id : Entity_Id;
684 Fin_Mas_Act : Node_Id;
685 Fin_Mas_Id : Entity_Id;
686 Proc_To_Call : Entity_Id;
687 Subpool : Node_Id := Empty;
690 -- Step 1: Construct all the actuals for the call to library routine
691 -- Allocate_Any_Controlled / Deallocate_Any_Controlled.
695 Actuals := New_List (New_Reference_To (Pool_Id, Loc));
701 if Nkind (Expr) = N_Allocator then
702 Subpool := Subpool_Handle_Name (Expr);
705 if Present (Subpool) then
706 Append_To (Actuals, New_Reference_To (Entity (Subpool), Loc));
708 Append_To (Actuals, Make_Null (Loc));
711 -- c) Finalization master
713 if Needs_Finalization (Desig_Typ) then
714 Fin_Mas_Id := Finalization_Master (Ptr_Typ);
715 Fin_Mas_Act := New_Reference_To (Fin_Mas_Id, Loc);
717 -- Handle the case where the master is actually a pointer to a
718 -- master. This case arises in build-in-place functions.
720 if Is_Access_Type (Etype (Fin_Mas_Id)) then
721 Append_To (Actuals, Fin_Mas_Act);
724 Make_Attribute_Reference (Loc,
725 Prefix => Fin_Mas_Act,
726 Attribute_Name => Name_Unrestricted_Access));
729 Append_To (Actuals, Make_Null (Loc));
732 -- d) Finalize_Address
734 -- Primitive Finalize_Address is never generated in CodePeer mode
735 -- since it contains an Unchecked_Conversion.
737 if Needs_Finalization (Desig_Typ)
738 and then not CodePeer_Mode
740 Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
741 pragma Assert (Present (Fin_Addr_Id));
744 Make_Attribute_Reference (Loc,
745 Prefix => New_Reference_To (Fin_Addr_Id, Loc),
746 Attribute_Name => Name_Unrestricted_Access));
748 Append_To (Actuals, Make_Null (Loc));
756 Append_To (Actuals, New_Reference_To (Addr_Id, Loc));
757 Append_To (Actuals, New_Reference_To (Size_Id, Loc));
758 Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
762 -- Generate a run-time check to determine whether a class-wide object
763 -- is truly controlled.
765 if Needs_Finalization (Desig_Typ) then
766 if Is_Class_Wide_Type (Desig_Typ)
767 or else Is_Generic_Actual_Type (Desig_Typ)
770 Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
777 Temp := Find_Object (Expression (Expr));
782 -- Processing for generic actuals
784 if Is_Generic_Actual_Type (Desig_Typ) then
786 New_Reference_To (Boolean_Literals
787 (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
789 -- Processing for subtype indications
791 elsif Nkind (Temp) in N_Has_Entity
792 and then Is_Type (Entity (Temp))
795 New_Reference_To (Boolean_Literals
796 (Needs_Finalization (Entity (Temp))), Loc);
798 -- Generate a runtime check to test the controlled state of
799 -- an object for the purposes of allocation / deallocation.
802 -- The following case arises when allocating through an
803 -- interface class-wide type, generate:
807 if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
809 Make_Explicit_Dereference (Loc,
811 Relocate_Node (Temp));
818 Make_Attribute_Reference (Loc,
820 Relocate_Node (Temp),
821 Attribute_Name => Name_Tag);
825 -- Needs_Finalization (<Param>)
828 Make_Function_Call (Loc,
830 New_Reference_To (RTE (RE_Needs_Finalization), Loc),
831 Parameter_Associations => New_List (Param));
834 -- Create the temporary which represents the finalization
835 -- state of the expression. Generate:
837 -- F : constant Boolean := <Flag_Expr>;
840 Make_Object_Declaration (Loc,
841 Defining_Identifier => Flag_Id,
842 Constant_Present => True,
844 New_Reference_To (Standard_Boolean, Loc),
845 Expression => Flag_Expr));
847 -- The flag acts as the last actual
849 Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
852 -- The object is statically known to be controlled
855 Append_To (Actuals, New_Reference_To (Standard_True, Loc));
858 Append_To (Actuals, New_Reference_To (Standard_False, Loc));
865 New_Reference_To (Boolean_Literals (Present (Subpool)), Loc));
868 -- Step 2: Build a wrapper Allocate / Deallocate which internally
869 -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
871 -- Select the proper routine to call
874 Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
876 Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
879 -- Create a custom Allocate / Deallocate routine which has identical
880 -- profile to that of System.Storage_Pools.
883 Make_Subprogram_Body (Loc,
888 Make_Procedure_Specification (Loc,
889 Defining_Unit_Name => Proc_Id,
890 Parameter_Specifications => New_List (
892 -- P : Root_Storage_Pool
894 Make_Parameter_Specification (Loc,
895 Defining_Identifier =>
896 Make_Temporary (Loc, 'P'),
898 New_Reference_To (RTE (RE_Root_Storage_Pool), Loc)),
902 Make_Parameter_Specification (Loc,
903 Defining_Identifier => Addr_Id,
904 Out_Present => Is_Allocate,
906 New_Reference_To (RTE (RE_Address), Loc)),
910 Make_Parameter_Specification (Loc,
911 Defining_Identifier => Size_Id,
913 New_Reference_To (RTE (RE_Storage_Count), Loc)),
917 Make_Parameter_Specification (Loc,
918 Defining_Identifier => Alig_Id,
920 New_Reference_To (RTE (RE_Storage_Count), Loc)))),
922 Declarations => No_List,
924 Handled_Statement_Sequence =>
925 Make_Handled_Sequence_Of_Statements (Loc,
926 Statements => New_List (
927 Make_Procedure_Call_Statement (Loc,
929 New_Reference_To (Proc_To_Call, Loc),
930 Parameter_Associations => Actuals)))));
932 -- The newly generated Allocate / Deallocate becomes the default
933 -- procedure to call when the back end processes the allocation /
937 Set_Procedure_To_Call (Expr, Proc_Id);
939 Set_Procedure_To_Call (N, Proc_Id);
942 end Build_Allocate_Deallocate_Proc;
944 ------------------------
945 -- Build_Runtime_Call --
946 ------------------------
948 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
950 -- If entity is not available, we can skip making the call (this avoids
951 -- junk duplicated error messages in a number of cases).
953 if not RTE_Available (RE) then
954 return Make_Null_Statement (Loc);
957 Make_Procedure_Call_Statement (Loc,
958 Name => New_Reference_To (RTE (RE), Loc));
960 end Build_Runtime_Call;
962 ----------------------------
963 -- Build_Task_Array_Image --
964 ----------------------------
966 -- This function generates the body for a function that constructs the
967 -- image string for a task that is an array component. The function is
968 -- local to the init proc for the array type, and is called for each one
969 -- of the components. The constructed image has the form of an indexed
970 -- component, whose prefix is the outer variable of the array type.
971 -- The n-dimensional array type has known indexes Index, Index2...
973 -- Id_Ref is an indexed component form created by the enclosing init proc.
974 -- Its successive indexes are Val1, Val2, ... which are the loop variables
975 -- in the loops that call the individual task init proc on each component.
977 -- The generated function has the following structure:
979 -- function F return String is
980 -- Pref : string renames Task_Name;
981 -- T1 : String := Index1'Image (Val1);
983 -- Tn : String := indexn'image (Valn);
984 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
985 -- -- Len includes commas and the end parentheses.
986 -- Res : String (1..Len);
987 -- Pos : Integer := Pref'Length;
990 -- Res (1 .. Pos) := Pref;
994 -- Res (Pos .. Pos + T1'Length - 1) := T1;
995 -- Pos := Pos + T1'Length;
999 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
1000 -- Res (Len) := ')';
1005 -- Needless to say, multidimensional arrays of tasks are rare enough that
1006 -- the bulkiness of this code is not really a concern.
1008 function Build_Task_Array_Image
1012 Dyn : Boolean := False) return Node_Id
1014 Dims : constant Nat := Number_Dimensions (A_Type);
1015 -- Number of dimensions for array of tasks
1017 Temps : array (1 .. Dims) of Entity_Id;
1018 -- Array of temporaries to hold string for each index
1024 -- Total length of generated name
1027 -- Running index for substring assignments
1029 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
1030 -- Name of enclosing variable, prefix of resulting name
1033 -- String to hold result
1036 -- Value of successive indexes
1039 -- Expression to compute total size of string
1042 -- Entity for name at one index position
1044 Decls : constant List_Id := New_List;
1045 Stats : constant List_Id := New_List;
1048 -- For a dynamic task, the name comes from the target variable. For a
1049 -- static one it is a formal of the enclosing init proc.
1052 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
1054 Make_Object_Declaration (Loc,
1055 Defining_Identifier => Pref,
1056 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1058 Make_String_Literal (Loc,
1059 Strval => String_From_Name_Buffer)));
1063 Make_Object_Renaming_Declaration (Loc,
1064 Defining_Identifier => Pref,
1065 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1066 Name => Make_Identifier (Loc, Name_uTask_Name)));
1069 Indx := First_Index (A_Type);
1070 Val := First (Expressions (Id_Ref));
1072 for J in 1 .. Dims loop
1073 T := Make_Temporary (Loc, 'T');
1077 Make_Object_Declaration (Loc,
1078 Defining_Identifier => T,
1079 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1081 Make_Attribute_Reference (Loc,
1082 Attribute_Name => Name_Image,
1083 Prefix => New_Occurrence_Of (Etype (Indx), Loc),
1084 Expressions => New_List (New_Copy_Tree (Val)))));
1090 Sum := Make_Integer_Literal (Loc, Dims + 1);
1096 Make_Attribute_Reference (Loc,
1097 Attribute_Name => Name_Length,
1099 New_Occurrence_Of (Pref, Loc),
1100 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1102 for J in 1 .. Dims loop
1107 Make_Attribute_Reference (Loc,
1108 Attribute_Name => Name_Length,
1110 New_Occurrence_Of (Temps (J), Loc),
1111 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1114 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
1116 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
1119 Make_Assignment_Statement (Loc,
1120 Name => Make_Indexed_Component (Loc,
1121 Prefix => New_Occurrence_Of (Res, Loc),
1122 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1124 Make_Character_Literal (Loc,
1126 Char_Literal_Value =>
1127 UI_From_Int (Character'Pos ('(')))));
1130 Make_Assignment_Statement (Loc,
1131 Name => New_Occurrence_Of (Pos, Loc),
1134 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1135 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1137 for J in 1 .. Dims loop
1140 Make_Assignment_Statement (Loc,
1141 Name => Make_Slice (Loc,
1142 Prefix => New_Occurrence_Of (Res, Loc),
1145 Low_Bound => New_Occurrence_Of (Pos, Loc),
1146 High_Bound => Make_Op_Subtract (Loc,
1149 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1151 Make_Attribute_Reference (Loc,
1152 Attribute_Name => Name_Length,
1154 New_Occurrence_Of (Temps (J), Loc),
1156 New_List (Make_Integer_Literal (Loc, 1)))),
1157 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
1159 Expression => New_Occurrence_Of (Temps (J), Loc)));
1163 Make_Assignment_Statement (Loc,
1164 Name => New_Occurrence_Of (Pos, Loc),
1167 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1169 Make_Attribute_Reference (Loc,
1170 Attribute_Name => Name_Length,
1171 Prefix => New_Occurrence_Of (Temps (J), Loc),
1173 New_List (Make_Integer_Literal (Loc, 1))))));
1175 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
1178 Make_Assignment_Statement (Loc,
1179 Name => Make_Indexed_Component (Loc,
1180 Prefix => New_Occurrence_Of (Res, Loc),
1181 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1183 Make_Character_Literal (Loc,
1185 Char_Literal_Value =>
1186 UI_From_Int (Character'Pos (',')))));
1189 Make_Assignment_Statement (Loc,
1190 Name => New_Occurrence_Of (Pos, Loc),
1193 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1194 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1198 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
1201 Make_Assignment_Statement (Loc,
1202 Name => Make_Indexed_Component (Loc,
1203 Prefix => New_Occurrence_Of (Res, Loc),
1204 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
1206 Make_Character_Literal (Loc,
1208 Char_Literal_Value =>
1209 UI_From_Int (Character'Pos (')')))));
1210 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
1211 end Build_Task_Array_Image;
1213 ----------------------------
1214 -- Build_Task_Image_Decls --
1215 ----------------------------
1217 function Build_Task_Image_Decls
1221 In_Init_Proc : Boolean := False) return List_Id
1223 Decls : constant List_Id := New_List;
1224 T_Id : Entity_Id := Empty;
1226 Expr : Node_Id := Empty;
1227 Fun : Node_Id := Empty;
1228 Is_Dyn : constant Boolean :=
1229 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
1231 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
1234 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
1235 -- generate a dummy declaration only.
1237 if Restriction_Active (No_Implicit_Heap_Allocations)
1238 or else Global_Discard_Names
1240 T_Id := Make_Temporary (Loc, 'J');
1245 Make_Object_Declaration (Loc,
1246 Defining_Identifier => T_Id,
1247 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1249 Make_String_Literal (Loc,
1250 Strval => String_From_Name_Buffer)));
1253 if Nkind (Id_Ref) = N_Identifier
1254 or else Nkind (Id_Ref) = N_Defining_Identifier
1256 -- For a simple variable, the image of the task is built from
1257 -- the name of the variable. To avoid possible conflict with the
1258 -- anonymous type created for a single protected object, add a
1262 Make_Defining_Identifier (Loc,
1263 New_External_Name (Chars (Id_Ref), 'T', 1));
1265 Get_Name_String (Chars (Id_Ref));
1268 Make_String_Literal (Loc,
1269 Strval => String_From_Name_Buffer);
1271 elsif Nkind (Id_Ref) = N_Selected_Component then
1273 Make_Defining_Identifier (Loc,
1274 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
1275 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
1277 elsif Nkind (Id_Ref) = N_Indexed_Component then
1279 Make_Defining_Identifier (Loc,
1280 New_External_Name (Chars (A_Type), 'N'));
1282 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
1286 if Present (Fun) then
1287 Append (Fun, Decls);
1288 Expr := Make_Function_Call (Loc,
1289 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
1291 if not In_Init_Proc and then VM_Target = No_VM then
1292 Set_Uses_Sec_Stack (Defining_Entity (Fun));
1296 Decl := Make_Object_Declaration (Loc,
1297 Defining_Identifier => T_Id,
1298 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1299 Constant_Present => True,
1300 Expression => Expr);
1302 Append (Decl, Decls);
1304 end Build_Task_Image_Decls;
1306 -------------------------------
1307 -- Build_Task_Image_Function --
1308 -------------------------------
1310 function Build_Task_Image_Function
1314 Res : Entity_Id) return Node_Id
1320 Make_Simple_Return_Statement (Loc,
1321 Expression => New_Occurrence_Of (Res, Loc)));
1323 Spec := Make_Function_Specification (Loc,
1324 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
1325 Result_Definition => New_Occurrence_Of (Standard_String, Loc));
1327 -- Calls to 'Image use the secondary stack, which must be cleaned up
1328 -- after the task name is built.
1330 return Make_Subprogram_Body (Loc,
1331 Specification => Spec,
1332 Declarations => Decls,
1333 Handled_Statement_Sequence =>
1334 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
1335 end Build_Task_Image_Function;
1337 -----------------------------
1338 -- Build_Task_Image_Prefix --
1339 -----------------------------
1341 procedure Build_Task_Image_Prefix
1343 Len : out Entity_Id;
1344 Res : out Entity_Id;
1345 Pos : out Entity_Id;
1352 Len := Make_Temporary (Loc, 'L', Sum);
1355 Make_Object_Declaration (Loc,
1356 Defining_Identifier => Len,
1357 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
1358 Expression => Sum));
1360 Res := Make_Temporary (Loc, 'R');
1363 Make_Object_Declaration (Loc,
1364 Defining_Identifier => Res,
1365 Object_Definition =>
1366 Make_Subtype_Indication (Loc,
1367 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1369 Make_Index_Or_Discriminant_Constraint (Loc,
1373 Low_Bound => Make_Integer_Literal (Loc, 1),
1374 High_Bound => New_Occurrence_Of (Len, Loc)))))));
1376 Pos := Make_Temporary (Loc, 'P');
1379 Make_Object_Declaration (Loc,
1380 Defining_Identifier => Pos,
1381 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
1383 -- Pos := Prefix'Length;
1386 Make_Assignment_Statement (Loc,
1387 Name => New_Occurrence_Of (Pos, Loc),
1389 Make_Attribute_Reference (Loc,
1390 Attribute_Name => Name_Length,
1391 Prefix => New_Occurrence_Of (Prefix, Loc),
1392 Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
1394 -- Res (1 .. Pos) := Prefix;
1397 Make_Assignment_Statement (Loc,
1400 Prefix => New_Occurrence_Of (Res, Loc),
1403 Low_Bound => Make_Integer_Literal (Loc, 1),
1404 High_Bound => New_Occurrence_Of (Pos, Loc))),
1406 Expression => New_Occurrence_Of (Prefix, Loc)));
1409 Make_Assignment_Statement (Loc,
1410 Name => New_Occurrence_Of (Pos, Loc),
1413 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1414 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1415 end Build_Task_Image_Prefix;
1417 -----------------------------
1418 -- Build_Task_Record_Image --
1419 -----------------------------
1421 function Build_Task_Record_Image
1424 Dyn : Boolean := False) return Node_Id
1427 -- Total length of generated name
1430 -- Index into result
1433 -- String to hold result
1435 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
1436 -- Name of enclosing variable, prefix of resulting name
1439 -- Expression to compute total size of string
1442 -- Entity for selector name
1444 Decls : constant List_Id := New_List;
1445 Stats : constant List_Id := New_List;
1448 -- For a dynamic task, the name comes from the target variable. For a
1449 -- static one it is a formal of the enclosing init proc.
1452 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
1454 Make_Object_Declaration (Loc,
1455 Defining_Identifier => Pref,
1456 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1458 Make_String_Literal (Loc,
1459 Strval => String_From_Name_Buffer)));
1463 Make_Object_Renaming_Declaration (Loc,
1464 Defining_Identifier => Pref,
1465 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1466 Name => Make_Identifier (Loc, Name_uTask_Name)));
1469 Sel := Make_Temporary (Loc, 'S');
1471 Get_Name_String (Chars (Selector_Name (Id_Ref)));
1474 Make_Object_Declaration (Loc,
1475 Defining_Identifier => Sel,
1476 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1478 Make_String_Literal (Loc,
1479 Strval => String_From_Name_Buffer)));
1481 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
1487 Make_Attribute_Reference (Loc,
1488 Attribute_Name => Name_Length,
1490 New_Occurrence_Of (Pref, Loc),
1491 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1493 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
1495 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
1497 -- Res (Pos) := '.';
1500 Make_Assignment_Statement (Loc,
1501 Name => Make_Indexed_Component (Loc,
1502 Prefix => New_Occurrence_Of (Res, Loc),
1503 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1505 Make_Character_Literal (Loc,
1507 Char_Literal_Value =>
1508 UI_From_Int (Character'Pos ('.')))));
1511 Make_Assignment_Statement (Loc,
1512 Name => New_Occurrence_Of (Pos, Loc),
1515 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1516 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1518 -- Res (Pos .. Len) := Selector;
1521 Make_Assignment_Statement (Loc,
1522 Name => Make_Slice (Loc,
1523 Prefix => New_Occurrence_Of (Res, Loc),
1526 Low_Bound => New_Occurrence_Of (Pos, Loc),
1527 High_Bound => New_Occurrence_Of (Len, Loc))),
1528 Expression => New_Occurrence_Of (Sel, Loc)));
1530 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
1531 end Build_Task_Record_Image;
1533 ----------------------------------
1534 -- Component_May_Be_Bit_Aligned --
1535 ----------------------------------
1537 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
1541 -- If no component clause, then everything is fine, since the back end
1542 -- never bit-misaligns by default, even if there is a pragma Packed for
1545 if No (Comp) or else No (Component_Clause (Comp)) then
1549 UT := Underlying_Type (Etype (Comp));
1551 -- It is only array and record types that cause trouble
1553 if not Is_Record_Type (UT)
1554 and then not Is_Array_Type (UT)
1558 -- If we know that we have a small (64 bits or less) record or small
1559 -- bit-packed array, then everything is fine, since the back end can
1560 -- handle these cases correctly.
1562 elsif Esize (Comp) <= 64
1563 and then (Is_Record_Type (UT)
1564 or else Is_Bit_Packed_Array (UT))
1568 -- Otherwise if the component is not byte aligned, we know we have the
1569 -- nasty unaligned case.
1571 elsif Normalized_First_Bit (Comp) /= Uint_0
1572 or else Esize (Comp) mod System_Storage_Unit /= Uint_0
1576 -- If we are large and byte aligned, then OK at this level
1581 end Component_May_Be_Bit_Aligned;
1583 -----------------------------------
1584 -- Corresponding_Runtime_Package --
1585 -----------------------------------
1587 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
1588 Pkg_Id : RTU_Id := RTU_Null;
1591 pragma Assert (Is_Concurrent_Type (Typ));
1593 if Ekind (Typ) in Protected_Kind then
1594 if Has_Entries (Typ)
1596 -- A protected type without entries that covers an interface and
1597 -- overrides the abstract routines with protected procedures is
1598 -- considered equivalent to a protected type with entries in the
1599 -- context of dispatching select statements. It is sufficient to
1600 -- check for the presence of an interface list in the declaration
1601 -- node to recognize this case.
1603 or else Present (Interface_List (Parent (Typ)))
1605 (((Has_Attach_Handler (Typ) and then not Restricted_Profile)
1606 or else Has_Interrupt_Handler (Typ))
1607 and then not Restriction_Active (No_Dynamic_Attachment))
1610 or else Restriction_Active (No_Entry_Queue) = False
1611 or else Number_Entries (Typ) > 1
1612 or else (Has_Attach_Handler (Typ)
1613 and then not Restricted_Profile)
1615 Pkg_Id := System_Tasking_Protected_Objects_Entries;
1617 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
1621 Pkg_Id := System_Tasking_Protected_Objects;
1626 end Corresponding_Runtime_Package;
1628 -------------------------------
1629 -- Convert_To_Actual_Subtype --
1630 -------------------------------
1632 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
1636 Act_ST := Get_Actual_Subtype (Exp);
1638 if Act_ST = Etype (Exp) then
1641 Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
1642 Analyze_And_Resolve (Exp, Act_ST);
1644 end Convert_To_Actual_Subtype;
1646 -----------------------------------
1647 -- Current_Sem_Unit_Declarations --
1648 -----------------------------------
1650 function Current_Sem_Unit_Declarations return List_Id is
1651 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
1655 -- If the current unit is a package body, locate the visible
1656 -- declarations of the package spec.
1658 if Nkind (U) = N_Package_Body then
1659 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
1662 if Nkind (U) = N_Package_Declaration then
1663 U := Specification (U);
1664 Decls := Visible_Declarations (U);
1668 Set_Visible_Declarations (U, Decls);
1672 Decls := Declarations (U);
1676 Set_Declarations (U, Decls);
1681 end Current_Sem_Unit_Declarations;
1683 -----------------------
1684 -- Duplicate_Subexpr --
1685 -----------------------
1687 function Duplicate_Subexpr
1689 Name_Req : Boolean := False) return Node_Id
1692 Remove_Side_Effects (Exp, Name_Req);
1693 return New_Copy_Tree (Exp);
1694 end Duplicate_Subexpr;
1696 ---------------------------------
1697 -- Duplicate_Subexpr_No_Checks --
1698 ---------------------------------
1700 function Duplicate_Subexpr_No_Checks
1702 Name_Req : Boolean := False) return Node_Id
1707 Remove_Side_Effects (Exp, Name_Req);
1708 New_Exp := New_Copy_Tree (Exp);
1709 Remove_Checks (New_Exp);
1711 end Duplicate_Subexpr_No_Checks;
1713 -----------------------------------
1714 -- Duplicate_Subexpr_Move_Checks --
1715 -----------------------------------
1717 function Duplicate_Subexpr_Move_Checks
1719 Name_Req : Boolean := False) return Node_Id
1723 Remove_Side_Effects (Exp, Name_Req);
1724 New_Exp := New_Copy_Tree (Exp);
1725 Remove_Checks (Exp);
1727 end Duplicate_Subexpr_Move_Checks;
1729 --------------------
1730 -- Ensure_Defined --
1731 --------------------
1733 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
1737 -- An itype reference must only be created if this is a local itype, so
1738 -- that gigi can elaborate it on the proper objstack.
1741 and then Scope (Typ) = Current_Scope
1743 IR := Make_Itype_Reference (Sloc (N));
1744 Set_Itype (IR, Typ);
1745 Insert_Action (N, IR);
1749 --------------------
1750 -- Entry_Names_OK --
1751 --------------------
1753 function Entry_Names_OK return Boolean is
1756 not Restricted_Profile
1757 and then not Global_Discard_Names
1758 and then not Restriction_Active (No_Implicit_Heap_Allocations)
1759 and then not Restriction_Active (No_Local_Allocators);
1762 ---------------------
1763 -- Evolve_And_Then --
1764 ---------------------
1766 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
1772 Make_And_Then (Sloc (Cond1),
1774 Right_Opnd => Cond1);
1776 end Evolve_And_Then;
1778 --------------------
1779 -- Evolve_Or_Else --
1780 --------------------
1782 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
1788 Make_Or_Else (Sloc (Cond1),
1790 Right_Opnd => Cond1);
1794 ------------------------------
1795 -- Expand_Subtype_From_Expr --
1796 ------------------------------
1798 -- This function is applicable for both static and dynamic allocation of
1799 -- objects which are constrained by an initial expression. Basically it
1800 -- transforms an unconstrained subtype indication into a constrained one.
1802 -- The expression may also be transformed in certain cases in order to
1803 -- avoid multiple evaluation. In the static allocation case, the general
1808 -- is transformed into
1810 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1812 -- Here are the main cases :
1814 -- <if Expr is a Slice>
1815 -- Val : T ([Index_Subtype (Expr)]) := Expr;
1817 -- <elsif Expr is a String Literal>
1818 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1820 -- <elsif Expr is Constrained>
1821 -- subtype T is Type_Of_Expr
1824 -- <elsif Expr is an entity_name>
1825 -- Val : T (constraints taken from Expr) := Expr;
1828 -- type Axxx is access all T;
1829 -- Rval : Axxx := Expr'ref;
1830 -- Val : T (constraints taken from Rval) := Rval.all;
1832 -- ??? note: when the Expression is allocated in the secondary stack
1833 -- we could use it directly instead of copying it by declaring
1834 -- Val : T (...) renames Rval.all
1836 procedure Expand_Subtype_From_Expr
1838 Unc_Type : Entity_Id;
1839 Subtype_Indic : Node_Id;
1842 Loc : constant Source_Ptr := Sloc (N);
1843 Exp_Typ : constant Entity_Id := Etype (Exp);
1847 -- In general we cannot build the subtype if expansion is disabled,
1848 -- because internal entities may not have been defined. However, to
1849 -- avoid some cascaded errors, we try to continue when the expression is
1850 -- an array (or string), because it is safe to compute the bounds. It is
1851 -- in fact required to do so even in a generic context, because there
1852 -- may be constants that depend on the bounds of a string literal, both
1853 -- standard string types and more generally arrays of characters.
1855 if not Expander_Active
1856 and then (No (Etype (Exp))
1857 or else not Is_String_Type (Etype (Exp)))
1862 if Nkind (Exp) = N_Slice then
1864 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
1867 Rewrite (Subtype_Indic,
1868 Make_Subtype_Indication (Loc,
1869 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1871 Make_Index_Or_Discriminant_Constraint (Loc,
1872 Constraints => New_List
1873 (New_Reference_To (Slice_Type, Loc)))));
1875 -- This subtype indication may be used later for constraint checks
1876 -- we better make sure that if a variable was used as a bound of
1877 -- of the original slice, its value is frozen.
1879 Force_Evaluation (Low_Bound (Scalar_Range (Slice_Type)));
1880 Force_Evaluation (High_Bound (Scalar_Range (Slice_Type)));
1883 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
1884 Rewrite (Subtype_Indic,
1885 Make_Subtype_Indication (Loc,
1886 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1888 Make_Index_Or_Discriminant_Constraint (Loc,
1889 Constraints => New_List (
1890 Make_Literal_Range (Loc,
1891 Literal_Typ => Exp_Typ)))));
1893 elsif Is_Constrained (Exp_Typ)
1894 and then not Is_Class_Wide_Type (Unc_Type)
1896 if Is_Itype (Exp_Typ) then
1898 -- Within an initialization procedure, a selected component
1899 -- denotes a component of the enclosing record, and it appears as
1900 -- an actual in a call to its own initialization procedure. If
1901 -- this component depends on the outer discriminant, we must
1902 -- generate the proper actual subtype for it.
1904 if Nkind (Exp) = N_Selected_Component
1905 and then Within_Init_Proc
1908 Decl : constant Node_Id :=
1909 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
1911 if Present (Decl) then
1912 Insert_Action (N, Decl);
1913 T := Defining_Identifier (Decl);
1919 -- No need to generate a new one (new what???)
1926 T := Make_Temporary (Loc, 'T');
1929 Make_Subtype_Declaration (Loc,
1930 Defining_Identifier => T,
1931 Subtype_Indication => New_Reference_To (Exp_Typ, Loc)));
1933 -- This type is marked as an itype even though it has an explicit
1934 -- declaration since otherwise Is_Generic_Actual_Type can get
1935 -- set, resulting in the generation of spurious errors. (See
1936 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
1939 Set_Associated_Node_For_Itype (T, Exp);
1942 Rewrite (Subtype_Indic, New_Reference_To (T, Loc));
1944 -- Nothing needs to be done for private types with unknown discriminants
1945 -- if the underlying type is not an unconstrained composite type or it
1946 -- is an unchecked union.
1948 elsif Is_Private_Type (Unc_Type)
1949 and then Has_Unknown_Discriminants (Unc_Type)
1950 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
1951 or else Is_Constrained (Underlying_Type (Unc_Type))
1952 or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
1956 -- Case of derived type with unknown discriminants where the parent type
1957 -- also has unknown discriminants.
1959 elsif Is_Record_Type (Unc_Type)
1960 and then not Is_Class_Wide_Type (Unc_Type)
1961 and then Has_Unknown_Discriminants (Unc_Type)
1962 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
1964 -- Nothing to be done if no underlying record view available
1966 if No (Underlying_Record_View (Unc_Type)) then
1969 -- Otherwise use the Underlying_Record_View to create the proper
1970 -- constrained subtype for an object of a derived type with unknown
1974 Remove_Side_Effects (Exp);
1975 Rewrite (Subtype_Indic,
1976 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
1979 -- Renamings of class-wide interface types require no equivalent
1980 -- constrained type declarations because we only need to reference
1981 -- the tag component associated with the interface. The same is
1982 -- presumably true for class-wide types in general, so this test
1983 -- is broadened to include all class-wide renamings, which also
1984 -- avoids cases of unbounded recursion in Remove_Side_Effects.
1985 -- (Is this really correct, or are there some cases of class-wide
1986 -- renamings that require action in this procedure???)
1989 and then Nkind (N) = N_Object_Renaming_Declaration
1990 and then Is_Class_Wide_Type (Unc_Type)
1994 -- In Ada 95 nothing to be done if the type of the expression is limited
1995 -- because in this case the expression cannot be copied, and its use can
1996 -- only be by reference.
1998 -- In Ada 2005 the context can be an object declaration whose expression
1999 -- is a function that returns in place. If the nominal subtype has
2000 -- unknown discriminants, the call still provides constraints on the
2001 -- object, and we have to create an actual subtype from it.
2003 -- If the type is class-wide, the expression is dynamically tagged and
2004 -- we do not create an actual subtype either. Ditto for an interface.
2005 -- For now this applies only if the type is immutably limited, and the
2006 -- function being called is build-in-place. This will have to be revised
2007 -- when build-in-place functions are generalized to other types.
2009 elsif Is_Immutably_Limited_Type (Exp_Typ)
2011 (Is_Class_Wide_Type (Exp_Typ)
2012 or else Is_Interface (Exp_Typ)
2013 or else not Has_Unknown_Discriminants (Exp_Typ)
2014 or else not Is_Composite_Type (Unc_Type))
2018 -- For limited objects initialized with build in place function calls,
2019 -- nothing to be done; otherwise we prematurely introduce an N_Reference
2020 -- node in the expression initializing the object, which breaks the
2021 -- circuitry that detects and adds the additional arguments to the
2024 elsif Is_Build_In_Place_Function_Call (Exp) then
2028 Remove_Side_Effects (Exp);
2029 Rewrite (Subtype_Indic,
2030 Make_Subtype_From_Expr (Exp, Unc_Type));
2032 end Expand_Subtype_From_Expr;
2034 --------------------
2035 -- Find_Init_Call --
2036 --------------------
2038 function Find_Init_Call
2040 Rep_Clause : Node_Id) return Node_Id
2042 Typ : constant Entity_Id := Etype (Var);
2044 Init_Proc : Entity_Id;
2045 -- Initialization procedure for Typ
2047 function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
2048 -- Look for init call for Var starting at From and scanning the
2049 -- enclosing list until Rep_Clause or the end of the list is reached.
2051 ----------------------------
2052 -- Find_Init_Call_In_List --
2053 ----------------------------
2055 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
2056 Init_Call : Node_Id;
2060 while Present (Init_Call) and then Init_Call /= Rep_Clause loop
2061 if Nkind (Init_Call) = N_Procedure_Call_Statement
2062 and then Is_Entity_Name (Name (Init_Call))
2063 and then Entity (Name (Init_Call)) = Init_Proc
2072 end Find_Init_Call_In_List;
2074 Init_Call : Node_Id;
2076 -- Start of processing for Find_Init_Call
2079 if not Has_Non_Null_Base_Init_Proc (Typ) then
2080 -- No init proc for the type, so obviously no call to be found
2085 Init_Proc := Base_Init_Proc (Typ);
2087 -- First scan the list containing the declaration of Var
2089 Init_Call := Find_Init_Call_In_List (From => Next (Parent (Var)));
2091 -- If not found, also look on Var's freeze actions list, if any, since
2092 -- the init call may have been moved there (case of an address clause
2093 -- applying to Var).
2095 if No (Init_Call) and then Present (Freeze_Node (Var)) then
2097 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
2103 ------------------------
2104 -- Find_Interface_ADT --
2105 ------------------------
2107 function Find_Interface_ADT
2109 Iface : Entity_Id) return Elmt_Id
2112 Typ : Entity_Id := T;
2115 pragma Assert (Is_Interface (Iface));
2117 -- Handle private types
2119 if Has_Private_Declaration (Typ)
2120 and then Present (Full_View (Typ))
2122 Typ := Full_View (Typ);
2125 -- Handle access types
2127 if Is_Access_Type (Typ) then
2128 Typ := Designated_Type (Typ);
2131 -- Handle task and protected types implementing interfaces
2133 if Is_Concurrent_Type (Typ) then
2134 Typ := Corresponding_Record_Type (Typ);
2138 (not Is_Class_Wide_Type (Typ)
2139 and then Ekind (Typ) /= E_Incomplete_Type);
2141 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
2142 return First_Elmt (Access_Disp_Table (Typ));
2146 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
2148 and then Present (Related_Type (Node (ADT)))
2149 and then Related_Type (Node (ADT)) /= Iface
2150 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
2151 Use_Full_View => True)
2156 pragma Assert (Present (Related_Type (Node (ADT))));
2159 end Find_Interface_ADT;
2161 ------------------------
2162 -- Find_Interface_Tag --
2163 ------------------------
2165 function Find_Interface_Tag
2167 Iface : Entity_Id) return Entity_Id
2170 Found : Boolean := False;
2171 Typ : Entity_Id := T;
2173 procedure Find_Tag (Typ : Entity_Id);
2174 -- Internal subprogram used to recursively climb to the ancestors
2180 procedure Find_Tag (Typ : Entity_Id) is
2185 -- This routine does not handle the case in which the interface is an
2186 -- ancestor of Typ. That case is handled by the enclosing subprogram.
2188 pragma Assert (Typ /= Iface);
2190 -- Climb to the root type handling private types
2192 if Present (Full_View (Etype (Typ))) then
2193 if Full_View (Etype (Typ)) /= Typ then
2194 Find_Tag (Full_View (Etype (Typ)));
2197 elsif Etype (Typ) /= Typ then
2198 Find_Tag (Etype (Typ));
2201 -- Traverse the list of interfaces implemented by the type
2204 and then Present (Interfaces (Typ))
2205 and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
2207 -- Skip the tag associated with the primary table
2209 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
2210 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
2211 pragma Assert (Present (AI_Tag));
2213 AI_Elmt := First_Elmt (Interfaces (Typ));
2214 while Present (AI_Elmt) loop
2215 AI := Node (AI_Elmt);
2218 or else Is_Ancestor (Iface, AI, Use_Full_View => True)
2224 AI_Tag := Next_Tag_Component (AI_Tag);
2225 Next_Elmt (AI_Elmt);
2230 -- Start of processing for Find_Interface_Tag
2233 pragma Assert (Is_Interface (Iface));
2235 -- Handle access types
2237 if Is_Access_Type (Typ) then
2238 Typ := Designated_Type (Typ);
2241 -- Handle class-wide types
2243 if Is_Class_Wide_Type (Typ) then
2244 Typ := Root_Type (Typ);
2247 -- Handle private types
2249 if Has_Private_Declaration (Typ)
2250 and then Present (Full_View (Typ))
2252 Typ := Full_View (Typ);
2255 -- Handle entities from the limited view
2257 if Ekind (Typ) = E_Incomplete_Type then
2258 pragma Assert (Present (Non_Limited_View (Typ)));
2259 Typ := Non_Limited_View (Typ);
2262 -- Handle task and protected types implementing interfaces
2264 if Is_Concurrent_Type (Typ) then
2265 Typ := Corresponding_Record_Type (Typ);
2268 -- If the interface is an ancestor of the type, then it shared the
2269 -- primary dispatch table.
2271 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
2272 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
2273 return First_Tag_Component (Typ);
2275 -- Otherwise we need to search for its associated tag component
2279 pragma Assert (Found);
2282 end Find_Interface_Tag;
2288 function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
2290 Typ : Entity_Id := T;
2294 if Is_Class_Wide_Type (Typ) then
2295 Typ := Root_Type (Typ);
2298 Typ := Underlying_Type (Typ);
2300 -- Loop through primitive operations
2302 Prim := First_Elmt (Primitive_Operations (Typ));
2303 while Present (Prim) loop
2306 -- We can retrieve primitive operations by name if it is an internal
2307 -- name. For equality we must check that both of its operands have
2308 -- the same type, to avoid confusion with user-defined equalities
2309 -- than may have a non-symmetric signature.
2311 exit when Chars (Op) = Name
2314 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
2318 -- Raise Program_Error if no primitive found
2321 raise Program_Error;
2332 function Find_Prim_Op
2334 Name : TSS_Name_Type) return Entity_Id
2336 Inher_Op : Entity_Id := Empty;
2337 Own_Op : Entity_Id := Empty;
2338 Prim_Elmt : Elmt_Id;
2339 Prim_Id : Entity_Id;
2340 Typ : Entity_Id := T;
2343 if Is_Class_Wide_Type (Typ) then
2344 Typ := Root_Type (Typ);
2347 Typ := Underlying_Type (Typ);
2349 -- This search is based on the assertion that the dispatching version
2350 -- of the TSS routine always precedes the real primitive.
2352 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
2353 while Present (Prim_Elmt) loop
2354 Prim_Id := Node (Prim_Elmt);
2356 if Is_TSS (Prim_Id, Name) then
2357 if Present (Alias (Prim_Id)) then
2358 Inher_Op := Prim_Id;
2364 Next_Elmt (Prim_Elmt);
2367 if Present (Own_Op) then
2369 elsif Present (Inher_Op) then
2372 raise Program_Error;
2376 ----------------------------
2377 -- Find_Protection_Object --
2378 ----------------------------
2380 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
2385 while Present (S) loop
2386 if (Ekind (S) = E_Entry
2387 or else Ekind (S) = E_Entry_Family
2388 or else Ekind (S) = E_Function
2389 or else Ekind (S) = E_Procedure)
2390 and then Present (Protection_Object (S))
2392 return Protection_Object (S);
2398 -- If we do not find a Protection object in the scope chain, then
2399 -- something has gone wrong, most likely the object was never created.
2401 raise Program_Error;
2402 end Find_Protection_Object;
2404 --------------------------
2405 -- Find_Protection_Type --
2406 --------------------------
2408 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
2410 Typ : Entity_Id := Conc_Typ;
2413 if Is_Concurrent_Type (Typ) then
2414 Typ := Corresponding_Record_Type (Typ);
2417 -- Since restriction violations are not considered serious errors, the
2418 -- expander remains active, but may leave the corresponding record type
2419 -- malformed. In such cases, component _object is not available so do
2422 if not Analyzed (Typ) then
2426 Comp := First_Component (Typ);
2427 while Present (Comp) loop
2428 if Chars (Comp) = Name_uObject then
2429 return Base_Type (Etype (Comp));
2432 Next_Component (Comp);
2435 -- The corresponding record of a protected type should always have an
2438 raise Program_Error;
2439 end Find_Protection_Type;
2441 ----------------------
2442 -- Force_Evaluation --
2443 ----------------------
2445 procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
2447 Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
2448 end Force_Evaluation;
2450 ---------------------------------
2451 -- Fully_Qualified_Name_String --
2452 ---------------------------------
2454 function Fully_Qualified_Name_String (E : Entity_Id) return String_Id is
2455 procedure Internal_Full_Qualified_Name (E : Entity_Id);
2456 -- Compute recursively the qualified name without NUL at the end, adding
2457 -- it to the currently started string being generated
2459 ----------------------------------
2460 -- Internal_Full_Qualified_Name --
2461 ----------------------------------
2463 procedure Internal_Full_Qualified_Name (E : Entity_Id) is
2467 -- Deal properly with child units
2469 if Nkind (E) = N_Defining_Program_Unit_Name then
2470 Ent := Defining_Identifier (E);
2475 -- Compute qualification recursively (only "Standard" has no scope)
2477 if Present (Scope (Scope (Ent))) then
2478 Internal_Full_Qualified_Name (Scope (Ent));
2479 Store_String_Char (Get_Char_Code ('.'));
2482 -- Every entity should have a name except some expanded blocks
2483 -- don't bother about those.
2485 if Chars (Ent) = No_Name then
2489 -- Generates the entity name in upper case
2491 Get_Decoded_Name_String (Chars (Ent));
2493 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2495 end Internal_Full_Qualified_Name;
2497 -- Start of processing for Full_Qualified_Name
2501 Internal_Full_Qualified_Name (E);
2502 Store_String_Char (Get_Char_Code (ASCII.NUL));
2504 end Fully_Qualified_Name_String;
2506 ------------------------
2507 -- Generate_Poll_Call --
2508 ------------------------
2510 procedure Generate_Poll_Call (N : Node_Id) is
2512 -- No poll call if polling not active
2514 if not Polling_Required then
2517 -- Otherwise generate require poll call
2520 Insert_Before_And_Analyze (N,
2521 Make_Procedure_Call_Statement (Sloc (N),
2522 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
2524 end Generate_Poll_Call;
2526 ---------------------------------
2527 -- Get_Current_Value_Condition --
2528 ---------------------------------
2530 -- Note: the implementation of this procedure is very closely tied to the
2531 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
2532 -- interpret Current_Value fields set by the Set procedure, so the two
2533 -- procedures need to be closely coordinated.
2535 procedure Get_Current_Value_Condition
2540 Loc : constant Source_Ptr := Sloc (Var);
2541 Ent : constant Entity_Id := Entity (Var);
2543 procedure Process_Current_Value_Condition
2546 -- N is an expression which holds either True (S = True) or False (S =
2547 -- False) in the condition. This procedure digs out the expression and
2548 -- if it refers to Ent, sets Op and Val appropriately.
2550 -------------------------------------
2551 -- Process_Current_Value_Condition --
2552 -------------------------------------
2554 procedure Process_Current_Value_Condition
2565 -- Deal with NOT operators, inverting sense
2567 while Nkind (Cond) = N_Op_Not loop
2568 Cond := Right_Opnd (Cond);
2572 -- Deal with AND THEN and AND cases
2574 if Nkind (Cond) = N_And_Then
2575 or else Nkind (Cond) = N_Op_And
2577 -- Don't ever try to invert a condition that is of the form of an
2578 -- AND or AND THEN (since we are not doing sufficiently general
2579 -- processing to allow this).
2581 if Sens = False then
2587 -- Recursively process AND and AND THEN branches
2589 Process_Current_Value_Condition (Left_Opnd (Cond), True);
2591 if Op /= N_Empty then
2595 Process_Current_Value_Condition (Right_Opnd (Cond), True);
2598 -- Case of relational operator
2600 elsif Nkind (Cond) in N_Op_Compare then
2603 -- Invert sense of test if inverted test
2605 if Sens = False then
2607 when N_Op_Eq => Op := N_Op_Ne;
2608 when N_Op_Ne => Op := N_Op_Eq;
2609 when N_Op_Lt => Op := N_Op_Ge;
2610 when N_Op_Gt => Op := N_Op_Le;
2611 when N_Op_Le => Op := N_Op_Gt;
2612 when N_Op_Ge => Op := N_Op_Lt;
2613 when others => raise Program_Error;
2617 -- Case of entity op value
2619 if Is_Entity_Name (Left_Opnd (Cond))
2620 and then Ent = Entity (Left_Opnd (Cond))
2621 and then Compile_Time_Known_Value (Right_Opnd (Cond))
2623 Val := Right_Opnd (Cond);
2625 -- Case of value op entity
2627 elsif Is_Entity_Name (Right_Opnd (Cond))
2628 and then Ent = Entity (Right_Opnd (Cond))
2629 and then Compile_Time_Known_Value (Left_Opnd (Cond))
2631 Val := Left_Opnd (Cond);
2633 -- We are effectively swapping operands
2636 when N_Op_Eq => null;
2637 when N_Op_Ne => null;
2638 when N_Op_Lt => Op := N_Op_Gt;
2639 when N_Op_Gt => Op := N_Op_Lt;
2640 when N_Op_Le => Op := N_Op_Ge;
2641 when N_Op_Ge => Op := N_Op_Le;
2642 when others => raise Program_Error;
2651 -- Case of Boolean variable reference, return as though the
2652 -- reference had said var = True.
2655 if Is_Entity_Name (Cond)
2656 and then Ent = Entity (Cond)
2658 Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
2660 if Sens = False then
2667 end Process_Current_Value_Condition;
2669 -- Start of processing for Get_Current_Value_Condition
2675 -- Immediate return, nothing doing, if this is not an object
2677 if Ekind (Ent) not in Object_Kind then
2681 -- Otherwise examine current value
2684 CV : constant Node_Id := Current_Value (Ent);
2689 -- If statement. Condition is known true in THEN section, known False
2690 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
2692 if Nkind (CV) = N_If_Statement then
2694 -- Before start of IF statement
2696 if Loc < Sloc (CV) then
2699 -- After end of IF statement
2701 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
2705 -- At this stage we know that we are within the IF statement, but
2706 -- unfortunately, the tree does not record the SLOC of the ELSE so
2707 -- we cannot use a simple SLOC comparison to distinguish between
2708 -- the then/else statements, so we have to climb the tree.
2715 while Parent (N) /= CV loop
2718 -- If we fall off the top of the tree, then that's odd, but
2719 -- perhaps it could occur in some error situation, and the
2720 -- safest response is simply to assume that the outcome of
2721 -- the condition is unknown. No point in bombing during an
2722 -- attempt to optimize things.
2729 -- Now we have N pointing to a node whose parent is the IF
2730 -- statement in question, so now we can tell if we are within
2731 -- the THEN statements.
2733 if Is_List_Member (N)
2734 and then List_Containing (N) = Then_Statements (CV)
2738 -- If the variable reference does not come from source, we
2739 -- cannot reliably tell whether it appears in the else part.
2740 -- In particular, if it appears in generated code for a node
2741 -- that requires finalization, it may be attached to a list
2742 -- that has not been yet inserted into the code. For now,
2743 -- treat it as unknown.
2745 elsif not Comes_From_Source (N) then
2748 -- Otherwise we must be in ELSIF or ELSE part
2755 -- ELSIF part. Condition is known true within the referenced
2756 -- ELSIF, known False in any subsequent ELSIF or ELSE part,
2757 -- and unknown before the ELSE part or after the IF statement.
2759 elsif Nkind (CV) = N_Elsif_Part then
2761 -- if the Elsif_Part had condition_actions, the elsif has been
2762 -- rewritten as a nested if, and the original elsif_part is
2763 -- detached from the tree, so there is no way to obtain useful
2764 -- information on the current value of the variable.
2765 -- Can this be improved ???
2767 if No (Parent (CV)) then
2773 -- Before start of ELSIF part
2775 if Loc < Sloc (CV) then
2778 -- After end of IF statement
2780 elsif Loc >= Sloc (Stm) +
2781 Text_Ptr (UI_To_Int (End_Span (Stm)))
2786 -- Again we lack the SLOC of the ELSE, so we need to climb the
2787 -- tree to see if we are within the ELSIF part in question.
2794 while Parent (N) /= Stm loop
2797 -- If we fall off the top of the tree, then that's odd, but
2798 -- perhaps it could occur in some error situation, and the
2799 -- safest response is simply to assume that the outcome of
2800 -- the condition is unknown. No point in bombing during an
2801 -- attempt to optimize things.
2808 -- Now we have N pointing to a node whose parent is the IF
2809 -- statement in question, so see if is the ELSIF part we want.
2810 -- the THEN statements.
2815 -- Otherwise we must be in subsequent ELSIF or ELSE part
2822 -- Iteration scheme of while loop. The condition is known to be
2823 -- true within the body of the loop.
2825 elsif Nkind (CV) = N_Iteration_Scheme then
2827 Loop_Stmt : constant Node_Id := Parent (CV);
2830 -- Before start of body of loop
2832 if Loc < Sloc (Loop_Stmt) then
2835 -- After end of LOOP statement
2837 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
2840 -- We are within the body of the loop
2847 -- All other cases of Current_Value settings
2853 -- If we fall through here, then we have a reportable condition, Sens
2854 -- is True if the condition is true and False if it needs inverting.
2856 Process_Current_Value_Condition (Condition (CV), Sens);
2858 end Get_Current_Value_Condition;
2860 ---------------------
2861 -- Get_Stream_Size --
2862 ---------------------
2864 function Get_Stream_Size (E : Entity_Id) return Uint is
2866 -- If we have a Stream_Size clause for this type use it
2868 if Has_Stream_Size_Clause (E) then
2869 return Static_Integer (Expression (Stream_Size_Clause (E)));
2871 -- Otherwise the Stream_Size if the size of the type
2876 end Get_Stream_Size;
2878 ---------------------------
2879 -- Has_Access_Constraint --
2880 ---------------------------
2882 function Has_Access_Constraint (E : Entity_Id) return Boolean is
2884 T : constant Entity_Id := Etype (E);
2887 if Has_Per_Object_Constraint (E)
2888 and then Has_Discriminants (T)
2890 Disc := First_Discriminant (T);
2891 while Present (Disc) loop
2892 if Is_Access_Type (Etype (Disc)) then
2896 Next_Discriminant (Disc);
2903 end Has_Access_Constraint;
2905 ----------------------------------
2906 -- Has_Following_Address_Clause --
2907 ----------------------------------
2909 -- Should this function check the private part in a package ???
2911 function Has_Following_Address_Clause (D : Node_Id) return Boolean is
2912 Id : constant Entity_Id := Defining_Identifier (D);
2917 while Present (Decl) loop
2918 if Nkind (Decl) = N_At_Clause
2919 and then Chars (Identifier (Decl)) = Chars (Id)
2923 elsif Nkind (Decl) = N_Attribute_Definition_Clause
2924 and then Chars (Decl) = Name_Address
2925 and then Chars (Name (Decl)) = Chars (Id)
2934 end Has_Following_Address_Clause;
2936 --------------------
2937 -- Homonym_Number --
2938 --------------------
2940 function Homonym_Number (Subp : Entity_Id) return Nat is
2946 Hom := Homonym (Subp);
2947 while Present (Hom) loop
2948 if Scope (Hom) = Scope (Subp) then
2952 Hom := Homonym (Hom);
2958 -----------------------------------
2959 -- In_Library_Level_Package_Body --
2960 -----------------------------------
2962 function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
2964 -- First determine whether the entity appears at the library level, then
2965 -- look at the containing unit.
2967 if Is_Library_Level_Entity (Id) then
2969 Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
2972 return Nkind (Unit (Container)) = N_Package_Body;
2977 end In_Library_Level_Package_Body;
2979 ------------------------------
2980 -- In_Unconditional_Context --
2981 ------------------------------
2983 function In_Unconditional_Context (Node : Node_Id) return Boolean is
2988 while Present (P) loop
2990 when N_Subprogram_Body =>
2993 when N_If_Statement =>
2996 when N_Loop_Statement =>
2999 when N_Case_Statement =>
3008 end In_Unconditional_Context;
3014 procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
3016 if Present (Ins_Action) then
3017 Insert_Actions (Assoc_Node, New_List (Ins_Action));
3021 -- Version with check(s) suppressed
3023 procedure Insert_Action
3024 (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
3027 Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
3030 -------------------------
3031 -- Insert_Action_After --
3032 -------------------------
3034 procedure Insert_Action_After
3035 (Assoc_Node : Node_Id;
3036 Ins_Action : Node_Id)
3039 Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
3040 end Insert_Action_After;
3042 --------------------
3043 -- Insert_Actions --
3044 --------------------
3046 procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
3050 Wrapped_Node : Node_Id := Empty;
3053 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
3057 -- Ignore insert of actions from inside default expression (or other
3058 -- similar "spec expression") in the special spec-expression analyze
3059 -- mode. Any insertions at this point have no relevance, since we are
3060 -- only doing the analyze to freeze the types of any static expressions.
3061 -- See section "Handling of Default Expressions" in the spec of package
3062 -- Sem for further details.
3064 if In_Spec_Expression then
3068 -- If the action derives from stuff inside a record, then the actions
3069 -- are attached to the current scope, to be inserted and analyzed on
3070 -- exit from the scope. The reason for this is that we may also be
3071 -- generating freeze actions at the same time, and they must eventually
3072 -- be elaborated in the correct order.
3074 if Is_Record_Type (Current_Scope)
3075 and then not Is_Frozen (Current_Scope)
3077 if No (Scope_Stack.Table
3078 (Scope_Stack.Last).Pending_Freeze_Actions)
3080 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
3085 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
3091 -- We now intend to climb up the tree to find the right point to
3092 -- insert the actions. We start at Assoc_Node, unless this node is a
3093 -- subexpression in which case we start with its parent. We do this for
3094 -- two reasons. First it speeds things up. Second, if Assoc_Node is
3095 -- itself one of the special nodes like N_And_Then, then we assume that
3096 -- an initial request to insert actions for such a node does not expect
3097 -- the actions to get deposited in the node for later handling when the
3098 -- node is expanded, since clearly the node is being dealt with by the
3099 -- caller. Note that in the subexpression case, N is always the child we
3102 -- N_Raise_xxx_Error is an annoying special case, it is a statement if
3103 -- it has type Standard_Void_Type, and a subexpression otherwise.
3104 -- otherwise. Procedure attribute references are also statements.
3106 if Nkind (Assoc_Node) in N_Subexpr
3107 and then (Nkind (Assoc_Node) in N_Raise_xxx_Error
3108 or else Etype (Assoc_Node) /= Standard_Void_Type)
3109 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
3111 not Is_Procedure_Attribute_Name
3112 (Attribute_Name (Assoc_Node)))
3114 P := Assoc_Node; -- ??? does not agree with above!
3115 N := Parent (Assoc_Node);
3117 -- Non-subexpression case. Note that N is initially Empty in this case
3118 -- (N is only guaranteed Non-Empty in the subexpr case).
3125 -- Capture root of the transient scope
3127 if Scope_Is_Transient then
3128 Wrapped_Node := Node_To_Be_Wrapped;
3132 pragma Assert (Present (P));
3136 -- Case of right operand of AND THEN or OR ELSE. Put the actions
3137 -- in the Actions field of the right operand. They will be moved
3138 -- out further when the AND THEN or OR ELSE operator is expanded.
3139 -- Nothing special needs to be done for the left operand since
3140 -- in that case the actions are executed unconditionally.
3142 when N_Short_Circuit =>
3143 if N = Right_Opnd (P) then
3145 -- We are now going to either append the actions to the
3146 -- actions field of the short-circuit operation. We will
3147 -- also analyze the actions now.
3149 -- This analysis is really too early, the proper thing would
3150 -- be to just park them there now, and only analyze them if
3151 -- we find we really need them, and to it at the proper
3152 -- final insertion point. However attempting to this proved
3153 -- tricky, so for now we just kill current values before and
3154 -- after the analyze call to make sure we avoid peculiar
3155 -- optimizations from this out of order insertion.
3157 Kill_Current_Values;
3159 if Present (Actions (P)) then
3160 Insert_List_After_And_Analyze
3161 (Last (Actions (P)), Ins_Actions);
3163 Set_Actions (P, Ins_Actions);
3164 Analyze_List (Actions (P));
3167 Kill_Current_Values;
3172 -- Then or Else operand of conditional expression. Add actions to
3173 -- Then_Actions or Else_Actions field as appropriate. The actions
3174 -- will be moved further out when the conditional is expanded.
3176 when N_Conditional_Expression =>
3178 ThenX : constant Node_Id := Next (First (Expressions (P)));
3179 ElseX : constant Node_Id := Next (ThenX);
3182 -- If the enclosing expression is already analyzed, as
3183 -- is the case for nested elaboration checks, insert the
3184 -- conditional further out.
3186 if Analyzed (P) then
3189 -- Actions belong to the then expression, temporarily place
3190 -- them as Then_Actions of the conditional expr. They will
3191 -- be moved to the proper place later when the conditional
3192 -- expression is expanded.
3194 elsif N = ThenX then
3195 if Present (Then_Actions (P)) then
3196 Insert_List_After_And_Analyze
3197 (Last (Then_Actions (P)), Ins_Actions);
3199 Set_Then_Actions (P, Ins_Actions);
3200 Analyze_List (Then_Actions (P));
3205 -- Actions belong to the else expression, temporarily
3206 -- place them as Else_Actions of the conditional expr.
3207 -- They will be moved to the proper place later when
3208 -- the conditional expression is expanded.
3210 elsif N = ElseX then
3211 if Present (Else_Actions (P)) then
3212 Insert_List_After_And_Analyze
3213 (Last (Else_Actions (P)), Ins_Actions);
3215 Set_Else_Actions (P, Ins_Actions);
3216 Analyze_List (Else_Actions (P));
3221 -- Actions belong to the condition. In this case they are
3222 -- unconditionally executed, and so we can continue the
3223 -- search for the proper insert point.
3230 -- Alternative of case expression, we place the action in the
3231 -- Actions field of the case expression alternative, this will
3232 -- be handled when the case expression is expanded.
3234 when N_Case_Expression_Alternative =>
3235 if Present (Actions (P)) then
3236 Insert_List_After_And_Analyze
3237 (Last (Actions (P)), Ins_Actions);
3239 Set_Actions (P, Ins_Actions);
3240 Analyze_List (Actions (P));
3245 -- Case of appearing within an Expressions_With_Actions node. We
3246 -- prepend the actions to the list of actions already there, if
3247 -- the node has not been analyzed yet. Otherwise find insertion
3248 -- location further up the tree.
3250 when N_Expression_With_Actions =>
3251 if not Analyzed (P) then
3252 Prepend_List (Ins_Actions, Actions (P));
3256 -- Case of appearing in the condition of a while expression or
3257 -- elsif. We insert the actions into the Condition_Actions field.
3258 -- They will be moved further out when the while loop or elsif
3261 when N_Iteration_Scheme |
3264 if N = Condition (P) then
3265 if Present (Condition_Actions (P)) then
3266 Insert_List_After_And_Analyze
3267 (Last (Condition_Actions (P)), Ins_Actions);
3269 Set_Condition_Actions (P, Ins_Actions);
3271 -- Set the parent of the insert actions explicitly. This
3272 -- is not a syntactic field, but we need the parent field
3273 -- set, in particular so that freeze can understand that
3274 -- it is dealing with condition actions, and properly
3275 -- insert the freezing actions.
3277 Set_Parent (Ins_Actions, P);
3278 Analyze_List (Condition_Actions (P));
3284 -- Statements, declarations, pragmas, representation clauses
3289 N_Procedure_Call_Statement |
3290 N_Statement_Other_Than_Procedure_Call |
3296 -- Representation_Clause
3299 N_Attribute_Definition_Clause |
3300 N_Enumeration_Representation_Clause |
3301 N_Record_Representation_Clause |
3305 N_Abstract_Subprogram_Declaration |
3307 N_Exception_Declaration |
3308 N_Exception_Renaming_Declaration |
3309 N_Expression_Function |
3310 N_Formal_Abstract_Subprogram_Declaration |
3311 N_Formal_Concrete_Subprogram_Declaration |
3312 N_Formal_Object_Declaration |
3313 N_Formal_Type_Declaration |
3314 N_Full_Type_Declaration |
3315 N_Function_Instantiation |
3316 N_Generic_Function_Renaming_Declaration |
3317 N_Generic_Package_Declaration |
3318 N_Generic_Package_Renaming_Declaration |
3319 N_Generic_Procedure_Renaming_Declaration |
3320 N_Generic_Subprogram_Declaration |
3321 N_Implicit_Label_Declaration |
3322 N_Incomplete_Type_Declaration |
3323 N_Number_Declaration |
3324 N_Object_Declaration |
3325 N_Object_Renaming_Declaration |
3327 N_Package_Body_Stub |
3328 N_Package_Declaration |
3329 N_Package_Instantiation |
3330 N_Package_Renaming_Declaration |
3331 N_Private_Extension_Declaration |
3332 N_Private_Type_Declaration |
3333 N_Procedure_Instantiation |
3335 N_Protected_Body_Stub |
3336 N_Protected_Type_Declaration |
3337 N_Single_Task_Declaration |
3339 N_Subprogram_Body_Stub |
3340 N_Subprogram_Declaration |
3341 N_Subprogram_Renaming_Declaration |
3342 N_Subtype_Declaration |
3345 N_Task_Type_Declaration |
3347 -- Use clauses can appear in lists of declarations
3349 N_Use_Package_Clause |
3352 -- Freeze entity behaves like a declaration or statement
3356 -- Do not insert here if the item is not a list member (this
3357 -- happens for example with a triggering statement, and the
3358 -- proper approach is to insert before the entire select).
3360 if not Is_List_Member (P) then
3363 -- Do not insert if parent of P is an N_Component_Association
3364 -- node (i.e. we are in the context of an N_Aggregate or
3365 -- N_Extension_Aggregate node. In this case we want to insert
3366 -- before the entire aggregate.
3368 elsif Nkind (Parent (P)) = N_Component_Association then
3371 -- Do not insert if the parent of P is either an N_Variant node
3372 -- or an N_Record_Definition node, meaning in either case that
3373 -- P is a member of a component list, and that therefore the
3374 -- actions should be inserted outside the complete record
3377 elsif Nkind (Parent (P)) = N_Variant
3378 or else Nkind (Parent (P)) = N_Record_Definition
3382 -- Do not insert freeze nodes within the loop generated for
3383 -- an aggregate, because they may be elaborated too late for
3384 -- subsequent use in the back end: within a package spec the
3385 -- loop is part of the elaboration procedure and is only
3386 -- elaborated during the second pass.
3388 -- If the loop comes from source, or the entity is local to the
3389 -- loop itself it must remain within.
3391 elsif Nkind (Parent (P)) = N_Loop_Statement
3392 and then not Comes_From_Source (Parent (P))
3393 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
3395 Scope (Entity (First (Ins_Actions))) /= Current_Scope
3399 -- Otherwise we can go ahead and do the insertion
3401 elsif P = Wrapped_Node then
3402 Store_Before_Actions_In_Scope (Ins_Actions);
3406 Insert_List_Before_And_Analyze (P, Ins_Actions);
3410 -- A special case, N_Raise_xxx_Error can act either as a statement
3411 -- or a subexpression. We tell the difference by looking at the
3412 -- Etype. It is set to Standard_Void_Type in the statement case.
3415 N_Raise_xxx_Error =>
3416 if Etype (P) = Standard_Void_Type then
3417 if P = Wrapped_Node then
3418 Store_Before_Actions_In_Scope (Ins_Actions);
3420 Insert_List_Before_And_Analyze (P, Ins_Actions);
3425 -- In the subexpression case, keep climbing
3431 -- If a component association appears within a loop created for
3432 -- an array aggregate, attach the actions to the association so
3433 -- they can be subsequently inserted within the loop. For other
3434 -- component associations insert outside of the aggregate. For
3435 -- an association that will generate a loop, its Loop_Actions
3436 -- attribute is already initialized (see exp_aggr.adb).
3438 -- The list of loop_actions can in turn generate additional ones,
3439 -- that are inserted before the associated node. If the associated
3440 -- node is outside the aggregate, the new actions are collected
3441 -- at the end of the loop actions, to respect the order in which
3442 -- they are to be elaborated.
3445 N_Component_Association =>
3446 if Nkind (Parent (P)) = N_Aggregate
3447 and then Present (Loop_Actions (P))
3449 if Is_Empty_List (Loop_Actions (P)) then
3450 Set_Loop_Actions (P, Ins_Actions);
3451 Analyze_List (Ins_Actions);
3458 -- Check whether these actions were generated by a
3459 -- declaration that is part of the loop_ actions
3460 -- for the component_association.
3463 while Present (Decl) loop
3464 exit when Parent (Decl) = P
3465 and then Is_List_Member (Decl)
3467 List_Containing (Decl) = Loop_Actions (P);
3468 Decl := Parent (Decl);
3471 if Present (Decl) then
3472 Insert_List_Before_And_Analyze
3473 (Decl, Ins_Actions);
3475 Insert_List_After_And_Analyze
3476 (Last (Loop_Actions (P)), Ins_Actions);
3487 -- Another special case, an attribute denoting a procedure call
3490 N_Attribute_Reference =>
3491 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
3492 if P = Wrapped_Node then
3493 Store_Before_Actions_In_Scope (Ins_Actions);
3495 Insert_List_Before_And_Analyze (P, Ins_Actions);
3500 -- In the subexpression case, keep climbing
3506 -- A contract node should not belong to the tree
3509 raise Program_Error;
3511 -- For all other node types, keep climbing tree
3515 N_Accept_Alternative |
3516 N_Access_Definition |
3517 N_Access_Function_Definition |
3518 N_Access_Procedure_Definition |
3519 N_Access_To_Object_Definition |
3522 N_Aspect_Specification |
3524 N_Case_Statement_Alternative |
3525 N_Character_Literal |
3526 N_Compilation_Unit |
3527 N_Compilation_Unit_Aux |
3528 N_Component_Clause |
3529 N_Component_Declaration |
3530 N_Component_Definition |
3532 N_Constrained_Array_Definition |
3533 N_Decimal_Fixed_Point_Definition |
3534 N_Defining_Character_Literal |
3535 N_Defining_Identifier |
3536 N_Defining_Operator_Symbol |
3537 N_Defining_Program_Unit_Name |
3538 N_Delay_Alternative |
3539 N_Delta_Constraint |
3540 N_Derived_Type_Definition |
3542 N_Digits_Constraint |
3543 N_Discriminant_Association |
3544 N_Discriminant_Specification |
3546 N_Entry_Body_Formal_Part |
3547 N_Entry_Call_Alternative |
3548 N_Entry_Declaration |
3549 N_Entry_Index_Specification |
3550 N_Enumeration_Type_Definition |
3552 N_Exception_Handler |
3554 N_Explicit_Dereference |
3555 N_Extension_Aggregate |
3556 N_Floating_Point_Definition |
3557 N_Formal_Decimal_Fixed_Point_Definition |
3558 N_Formal_Derived_Type_Definition |
3559 N_Formal_Discrete_Type_Definition |
3560 N_Formal_Floating_Point_Definition |
3561 N_Formal_Modular_Type_Definition |
3562 N_Formal_Ordinary_Fixed_Point_Definition |
3563 N_Formal_Package_Declaration |
3564 N_Formal_Private_Type_Definition |
3565 N_Formal_Incomplete_Type_Definition |
3566 N_Formal_Signed_Integer_Type_Definition |
3568 N_Function_Specification |
3569 N_Generic_Association |
3570 N_Handled_Sequence_Of_Statements |
3573 N_Index_Or_Discriminant_Constraint |
3574 N_Indexed_Component |
3576 N_Iterator_Specification |
3579 N_Loop_Parameter_Specification |
3581 N_Modular_Type_Definition |
3607 N_Op_Shift_Right_Arithmetic |
3611 N_Ordinary_Fixed_Point_Definition |
3613 N_Package_Specification |
3614 N_Parameter_Association |
3615 N_Parameter_Specification |
3616 N_Pop_Constraint_Error_Label |
3617 N_Pop_Program_Error_Label |
3618 N_Pop_Storage_Error_Label |
3619 N_Pragma_Argument_Association |
3620 N_Procedure_Specification |
3621 N_Protected_Definition |
3622 N_Push_Constraint_Error_Label |
3623 N_Push_Program_Error_Label |
3624 N_Push_Storage_Error_Label |
3625 N_Qualified_Expression |
3626 N_Quantified_Expression |
3628 N_Range_Constraint |
3630 N_Real_Range_Specification |
3631 N_Record_Definition |
3633 N_SCIL_Dispatch_Table_Tag_Init |
3634 N_SCIL_Dispatching_Call |
3635 N_SCIL_Membership_Test |
3636 N_Selected_Component |
3637 N_Signed_Integer_Type_Definition |
3638 N_Single_Protected_Declaration |
3642 N_Subtype_Indication |
3645 N_Terminate_Alternative |
3646 N_Triggering_Alternative |
3648 N_Unchecked_Expression |
3649 N_Unchecked_Type_Conversion |
3650 N_Unconstrained_Array_Definition |
3655 N_Validate_Unchecked_Conversion |
3662 -- Make sure that inserted actions stay in the transient scope
3664 if P = Wrapped_Node then
3665 Store_Before_Actions_In_Scope (Ins_Actions);
3669 -- If we fall through above tests, keep climbing tree
3673 if Nkind (Parent (N)) = N_Subunit then
3675 -- This is the proper body corresponding to a stub. Insertion must
3676 -- be done at the point of the stub, which is in the declarative
3677 -- part of the parent unit.
3679 P := Corresponding_Stub (Parent (N));
3687 -- Version with check(s) suppressed
3689 procedure Insert_Actions
3690 (Assoc_Node : Node_Id;
3691 Ins_Actions : List_Id;
3692 Suppress : Check_Id)
3695 if Suppress = All_Checks then
3697 Svg : constant Suppress_Array := Scope_Suppress;
3699 Scope_Suppress := (others => True);
3700 Insert_Actions (Assoc_Node, Ins_Actions);
3701 Scope_Suppress := Svg;
3706 Svg : constant Boolean := Scope_Suppress (Suppress);
3708 Scope_Suppress (Suppress) := True;
3709 Insert_Actions (Assoc_Node, Ins_Actions);
3710 Scope_Suppress (Suppress) := Svg;
3715 --------------------------
3716 -- Insert_Actions_After --
3717 --------------------------
3719 procedure Insert_Actions_After
3720 (Assoc_Node : Node_Id;
3721 Ins_Actions : List_Id)
3724 if Scope_Is_Transient
3725 and then Assoc_Node = Node_To_Be_Wrapped
3727 Store_After_Actions_In_Scope (Ins_Actions);
3729 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
3731 end Insert_Actions_After;
3733 ---------------------------------
3734 -- Insert_Library_Level_Action --
3735 ---------------------------------
3737 procedure Insert_Library_Level_Action (N : Node_Id) is
3738 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
3741 Push_Scope (Cunit_Entity (Main_Unit));
3742 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
3744 if No (Actions (Aux)) then
3745 Set_Actions (Aux, New_List (N));
3747 Append (N, Actions (Aux));
3752 end Insert_Library_Level_Action;
3754 ----------------------------------
3755 -- Insert_Library_Level_Actions --
3756 ----------------------------------
3758 procedure Insert_Library_Level_Actions (L : List_Id) is
3759 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
3762 if Is_Non_Empty_List (L) then
3763 Push_Scope (Cunit_Entity (Main_Unit));
3764 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
3766 if No (Actions (Aux)) then
3767 Set_Actions (Aux, L);
3770 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
3775 end Insert_Library_Level_Actions;
3777 ----------------------
3778 -- Inside_Init_Proc --
3779 ----------------------
3781 function Inside_Init_Proc return Boolean is
3787 and then S /= Standard_Standard
3789 if Is_Init_Proc (S) then
3797 end Inside_Init_Proc;
3799 ----------------------------
3800 -- Is_All_Null_Statements --
3801 ----------------------------
3803 function Is_All_Null_Statements (L : List_Id) return Boolean is
3808 while Present (Stm) loop
3809 if Nkind (Stm) /= N_Null_Statement then
3817 end Is_All_Null_Statements;
3819 ------------------------------
3820 -- Is_Finalizable_Transient --
3821 ------------------------------
3823 function Is_Finalizable_Transient
3825 Rel_Node : Node_Id) return Boolean
3827 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
3828 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
3829 Desig : Entity_Id := Obj_Typ;
3831 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
3832 -- Determine whether transient object Trans_Id is initialized either
3833 -- by a function call which returns an access type or simply renames
3836 function Initialized_By_Aliased_BIP_Func_Call
3837 (Trans_Id : Entity_Id) return Boolean;
3838 -- Determine whether transient object Trans_Id is initialized by a
3839 -- build-in-place function call where the BIPalloc parameter is of
3840 -- value 1 and BIPaccess is not null. This case creates an aliasing
3841 -- between the returned value and the value denoted by BIPaccess.
3844 (Trans_Id : Entity_Id;
3845 First_Stmt : Node_Id) return Boolean;
3846 -- Determine whether transient object Trans_Id has been renamed or
3847 -- aliased through 'reference in the statement list starting from
3850 function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
3851 -- Determine whether transient object Trans_Id is allocated on the heap
3853 ---------------------------
3854 -- Initialized_By_Access --
3855 ---------------------------
3857 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
3858 Expr : constant Node_Id := Expression (Parent (Trans_Id));
3863 and then Nkind (Expr) /= N_Reference
3864 and then Is_Access_Type (Etype (Expr));
3865 end Initialized_By_Access;
3867 ------------------------------------------
3868 -- Initialized_By_Aliased_BIP_Func_Call --
3869 ------------------------------------------
3871 function Initialized_By_Aliased_BIP_Func_Call
3872 (Trans_Id : Entity_Id) return Boolean
3874 Call : Node_Id := Expression (Parent (Trans_Id));
3877 -- Build-in-place calls usually appear in 'reference format
3879 if Nkind (Call) = N_Reference then
3880 Call := Prefix (Call);
3883 if Is_Build_In_Place_Function_Call (Call) then
3885 Access_Nam : Name_Id := No_Name;
3886 Access_OK : Boolean := False;
3888 Alloc_Nam : Name_Id := No_Name;
3889 Alloc_OK : Boolean := False;
3891 Func_Id : Entity_Id;
3895 -- Examine all parameter associations of the function call
3897 Param := First (Parameter_Associations (Call));
3898 while Present (Param) loop
3899 if Nkind (Param) = N_Parameter_Association
3900 and then Nkind (Selector_Name (Param)) = N_Identifier
3902 Actual := Explicit_Actual_Parameter (Param);
3903 Formal := Selector_Name (Param);
3905 -- Construct the names of formals BIPaccess and BIPalloc
3906 -- using the function name retrieved from an arbitrary
3909 if Access_Nam = No_Name
3910 and then Alloc_Nam = No_Name
3911 and then Present (Entity (Formal))
3913 Func_Id := Scope (Entity (Formal));
3916 New_External_Name (Chars (Func_Id),
3917 BIP_Formal_Suffix (BIP_Object_Access));
3920 New_External_Name (Chars (Func_Id),
3921 BIP_Formal_Suffix (BIP_Alloc_Form));
3924 -- A match for BIPaccess => Temp has been found
3926 if Chars (Formal) = Access_Nam
3927 and then Nkind (Actual) /= N_Null
3932 -- A match for BIPalloc => 1 has been found
3934 if Chars (Formal) = Alloc_Nam
3935 and then Nkind (Actual) = N_Integer_Literal
3936 and then Intval (Actual) = Uint_1
3945 return Access_OK and then Alloc_OK;
3950 end Initialized_By_Aliased_BIP_Func_Call;
3957 (Trans_Id : Entity_Id;
3958 First_Stmt : Node_Id) return Boolean
3960 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
3961 -- Given an object renaming declaration, retrieve the entity of the
3962 -- renamed name. Return Empty if the renamed name is anything other
3963 -- than a variable or a constant.
3965 -------------------------
3966 -- Find_Renamed_Object --
3967 -------------------------
3969 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
3970 Ren_Obj : Node_Id := Empty;
3972 function Find_Object (N : Node_Id) return Traverse_Result;
3973 -- Try to detect an object which is either a constant or a
3980 function Find_Object (N : Node_Id) return Traverse_Result is
3982 -- Stop the search once a constant or a variable has been
3985 if Nkind (N) = N_Identifier
3986 and then Present (Entity (N))
3987 and then Ekind_In (Entity (N), E_Constant, E_Variable)
3989 Ren_Obj := Entity (N);
3996 procedure Search is new Traverse_Proc (Find_Object);
4000 Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));
4002 -- Start of processing for Find_Renamed_Object
4005 -- Actions related to dispatching calls may appear as renamings of
4006 -- tags. Do not process this type of renaming because it does not
4007 -- use the actual value of the object.
4009 if not Is_RTE (Typ, RE_Tag_Ptr) then
4010 Search (Name (Ren_Decl));
4014 end Find_Renamed_Object;
4019 Ren_Obj : Entity_Id;
4022 -- Start of processing for Is_Aliased
4026 while Present (Stmt) loop
4027 if Nkind (Stmt) = N_Object_Declaration then
4028 Expr := Expression (Stmt);
4031 and then Nkind (Expr) = N_Reference
4032 and then Nkind (Prefix (Expr)) = N_Identifier
4033 and then Entity (Prefix (Expr)) = Trans_Id
4038 elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
4039 Ren_Obj := Find_Renamed_Object (Stmt);
4041 if Present (Ren_Obj)
4042 and then Ren_Obj = Trans_Id
4058 function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
4059 Expr : constant Node_Id := Expression (Parent (Trans_Id));
4062 Is_Access_Type (Etype (Trans_Id))
4063 and then Present (Expr)
4064 and then Nkind (Expr) = N_Allocator;
4067 -- Start of processing for Is_Finalizable_Transient
4070 -- Handle access types
4072 if Is_Access_Type (Desig) then
4073 Desig := Available_View (Designated_Type (Desig));
4077 Ekind_In (Obj_Id, E_Constant, E_Variable)
4078 and then Needs_Finalization (Desig)
4079 and then Requires_Transient_Scope (Desig)
4080 and then Nkind (Rel_Node) /= N_Simple_Return_Statement
4082 -- Do not consider renamed or 'reference-d transient objects because
4083 -- the act of renaming extends the object's lifetime.
4085 and then not Is_Aliased (Obj_Id, Decl)
4087 -- Do not consider transient objects allocated on the heap since
4088 -- they are attached to a finalization master.
4090 and then not Is_Allocated (Obj_Id)
4092 -- If the transient object is a pointer, check that it is not
4093 -- initialized by a function which returns a pointer or acts as a
4094 -- renaming of another pointer.
4097 (not Is_Access_Type (Obj_Typ)
4098 or else not Initialized_By_Access (Obj_Id))
4100 -- Do not consider transient objects which act as indirect aliases
4101 -- of build-in-place function results.
4103 and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
4105 -- Do not consider conversions of tags to class-wide types
4107 and then not Is_Tag_To_CW_Conversion (Obj_Id);
4108 end Is_Finalizable_Transient;
4110 ---------------------------------
4111 -- Is_Fully_Repped_Tagged_Type --
4112 ---------------------------------
4114 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
4115 U : constant Entity_Id := Underlying_Type (T);
4119 if No (U) or else not Is_Tagged_Type (U) then
4121 elsif Has_Discriminants (U) then
4123 elsif not Has_Specified_Layout (U) then
4127 -- Here we have a tagged type, see if it has any unlayed out fields
4128 -- other than a possible tag and parent fields. If so, we return False.
4130 Comp := First_Component (U);
4131 while Present (Comp) loop
4132 if not Is_Tag (Comp)
4133 and then Chars (Comp) /= Name_uParent
4134 and then No (Component_Clause (Comp))
4138 Next_Component (Comp);
4142 -- All components are layed out
4145 end Is_Fully_Repped_Tagged_Type;
4147 ----------------------------------
4148 -- Is_Library_Level_Tagged_Type --
4149 ----------------------------------
4151 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
4153 return Is_Tagged_Type (Typ)
4154 and then Is_Library_Level_Entity (Typ);
4155 end Is_Library_Level_Tagged_Type;
4157 ----------------------------------
4158 -- Is_Null_Access_BIP_Func_Call --
4159 ----------------------------------
4161 function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean is
4162 Call : Node_Id := Expr;
4165 -- Build-in-place calls usually appear in 'reference format
4167 if Nkind (Call) = N_Reference then
4168 Call := Prefix (Call);
4171 if Nkind_In (Call, N_Qualified_Expression,
4172 N_Unchecked_Type_Conversion)
4174 Call := Expression (Call);
4177 if Is_Build_In_Place_Function_Call (Call) then
4179 Access_Nam : Name_Id := No_Name;
4185 -- Examine all parameter associations of the function call
4187 Param := First (Parameter_Associations (Call));
4188 while Present (Param) loop
4189 if Nkind (Param) = N_Parameter_Association
4190 and then Nkind (Selector_Name (Param)) = N_Identifier
4192 Formal := Selector_Name (Param);
4193 Actual := Explicit_Actual_Parameter (Param);
4195 -- Construct the name of formal BIPaccess. It is much easier
4196 -- to extract the name of the function using an arbitrary
4197 -- formal's scope rather than the Name field of Call.
4199 if Access_Nam = No_Name
4200 and then Present (Entity (Formal))
4204 (Chars (Scope (Entity (Formal))),
4205 BIP_Formal_Suffix (BIP_Object_Access));
4208 -- A match for BIPaccess => null has been found
4210 if Chars (Formal) = Access_Nam
4211 and then Nkind (Actual) = N_Null
4223 end Is_Null_Access_BIP_Func_Call;
4225 --------------------------
4226 -- Is_Non_BIP_Func_Call --
4227 --------------------------
4229 function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
4231 -- The expected call is of the format
4233 -- Func_Call'reference
4236 Nkind (Expr) = N_Reference
4237 and then Nkind (Prefix (Expr)) = N_Function_Call
4238 and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
4239 end Is_Non_BIP_Func_Call;
4241 ----------------------------------
4242 -- Is_Possibly_Unaligned_Object --
4243 ----------------------------------
4245 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
4246 T : constant Entity_Id := Etype (N);
4249 -- If renamed object, apply test to underlying object
4251 if Is_Entity_Name (N)
4252 and then Is_Object (Entity (N))
4253 and then Present (Renamed_Object (Entity (N)))
4255 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
4258 -- Tagged and controlled types and aliased types are always aligned, as
4259 -- are concurrent types.
4262 or else Has_Controlled_Component (T)
4263 or else Is_Concurrent_Type (T)
4264 or else Is_Tagged_Type (T)
4265 or else Is_Controlled (T)
4270 -- If this is an element of a packed array, may be unaligned
4272 if Is_Ref_To_Bit_Packed_Array (N) then
4276 -- Case of component reference
4278 if Nkind (N) = N_Selected_Component then
4280 P : constant Node_Id := Prefix (N);
4281 C : constant Entity_Id := Entity (Selector_Name (N));
4286 -- If component reference is for an array with non-static bounds,
4287 -- then it is always aligned: we can only process unaligned arrays
4288 -- with static bounds (more precisely compile time known bounds).
4290 if Is_Array_Type (T)
4291 and then not Compile_Time_Known_Bounds (T)
4296 -- If component is aliased, it is definitely properly aligned
4298 if Is_Aliased (C) then
4302 -- If component is for a type implemented as a scalar, and the
4303 -- record is packed, and the component is other than the first
4304 -- component of the record, then the component may be unaligned.
4306 if Is_Packed (Etype (P))
4307 and then Represented_As_Scalar (Etype (C))
4308 and then First_Entity (Scope (C)) /= C
4313 -- Compute maximum possible alignment for T
4315 -- If alignment is known, then that settles things
4317 if Known_Alignment (T) then
4318 M := UI_To_Int (Alignment (T));
4320 -- If alignment is not known, tentatively set max alignment
4323 M := Ttypes.Maximum_Alignment;
4325 -- We can reduce this if the Esize is known since the default
4326 -- alignment will never be more than the smallest power of 2
4327 -- that does not exceed this Esize value.
4329 if Known_Esize (T) then
4330 S := UI_To_Int (Esize (T));
4332 while (M / 2) >= S loop
4338 -- The following code is historical, it used to be present but it
4339 -- is too cautious, because the front-end does not know the proper
4340 -- default alignments for the target. Also, if the alignment is
4341 -- not known, the front end can't know in any case! If a copy is
4342 -- needed, the back-end will take care of it. This whole section
4343 -- including this comment can be removed later ???
4345 -- If the component reference is for a record that has a specified
4346 -- alignment, and we either know it is too small, or cannot tell,
4347 -- then the component may be unaligned.
4349 -- What is the following commented out code ???
4351 -- if Known_Alignment (Etype (P))
4352 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
4353 -- and then M > Alignment (Etype (P))
4358 -- Case of component clause present which may specify an
4359 -- unaligned position.
4361 if Present (Component_Clause (C)) then
4363 -- Otherwise we can do a test to make sure that the actual
4364 -- start position in the record, and the length, are both
4365 -- consistent with the required alignment. If not, we know
4366 -- that we are unaligned.
4369 Align_In_Bits : constant Nat := M * System_Storage_Unit;
4371 if Component_Bit_Offset (C) mod Align_In_Bits /= 0
4372 or else Esize (C) mod Align_In_Bits /= 0
4379 -- Otherwise, for a component reference, test prefix
4381 return Is_Possibly_Unaligned_Object (P);
4384 -- If not a component reference, must be aligned
4389 end Is_Possibly_Unaligned_Object;
4391 ---------------------------------
4392 -- Is_Possibly_Unaligned_Slice --
4393 ---------------------------------
4395 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
4397 -- Go to renamed object
4399 if Is_Entity_Name (N)
4400 and then Is_Object (Entity (N))
4401 and then Present (Renamed_Object (Entity (N)))
4403 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
4406 -- The reference must be a slice
4408 if Nkind (N) /= N_Slice then
4412 -- Always assume the worst for a nested record component with a
4413 -- component clause, which gigi/gcc does not appear to handle well.
4414 -- It is not clear why this special test is needed at all ???
4416 if Nkind (Prefix (N)) = N_Selected_Component
4417 and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
4419 Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
4424 -- We only need to worry if the target has strict alignment
4426 if not Target_Strict_Alignment then
4430 -- If it is a slice, then look at the array type being sliced
4433 Sarr : constant Node_Id := Prefix (N);
4434 -- Prefix of the slice, i.e. the array being sliced
4436 Styp : constant Entity_Id := Etype (Prefix (N));
4437 -- Type of the array being sliced
4443 -- The problems arise if the array object that is being sliced
4444 -- is a component of a record or array, and we cannot guarantee
4445 -- the alignment of the array within its containing object.
4447 -- To investigate this, we look at successive prefixes to see
4448 -- if we have a worrisome indexed or selected component.
4452 -- Case of array is part of an indexed component reference
4454 if Nkind (Pref) = N_Indexed_Component then
4455 Ptyp := Etype (Prefix (Pref));
4457 -- The only problematic case is when the array is packed, in
4458 -- which case we really know nothing about the alignment of
4459 -- individual components.
4461 if Is_Bit_Packed_Array (Ptyp) then
4465 -- Case of array is part of a selected component reference
4467 elsif Nkind (Pref) = N_Selected_Component then
4468 Ptyp := Etype (Prefix (Pref));
4470 -- We are definitely in trouble if the record in question
4471 -- has an alignment, and either we know this alignment is
4472 -- inconsistent with the alignment of the slice, or we don't
4473 -- know what the alignment of the slice should be.
4475 if Known_Alignment (Ptyp)
4476 and then (Unknown_Alignment (Styp)
4477 or else Alignment (Styp) > Alignment (Ptyp))
4482 -- We are in potential trouble if the record type is packed.
4483 -- We could special case when we know that the array is the
4484 -- first component, but that's not such a simple case ???
4486 if Is_Packed (Ptyp) then
4490 -- We are in trouble if there is a component clause, and
4491 -- either we do not know the alignment of the slice, or
4492 -- the alignment of the slice is inconsistent with the
4493 -- bit position specified by the component clause.
4496 Field : constant Entity_Id := Entity (Selector_Name (Pref));
4498 if Present (Component_Clause (Field))
4500 (Unknown_Alignment (Styp)
4502 (Component_Bit_Offset (Field) mod
4503 (System_Storage_Unit * Alignment (Styp))) /= 0)
4509 -- For cases other than selected or indexed components we know we
4510 -- are OK, since no issues arise over alignment.
4516 -- We processed an indexed component or selected component
4517 -- reference that looked safe, so keep checking prefixes.
4519 Pref := Prefix (Pref);
4522 end Is_Possibly_Unaligned_Slice;
4524 -------------------------------
4525 -- Is_Related_To_Func_Return --
4526 -------------------------------
4528 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
4529 Expr : constant Node_Id := Related_Expression (Id);
4533 and then Nkind (Expr) = N_Explicit_Dereference
4534 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
4535 end Is_Related_To_Func_Return;
4537 --------------------------------
4538 -- Is_Ref_To_Bit_Packed_Array --
4539 --------------------------------
4541 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
4546 if Is_Entity_Name (N)
4547 and then Is_Object (Entity (N))
4548 and then Present (Renamed_Object (Entity (N)))
4550 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
4553 if Nkind (N) = N_Indexed_Component
4555 Nkind (N) = N_Selected_Component
4557 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
4560 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
4563 if Result and then Nkind (N) = N_Indexed_Component then
4564 Expr := First (Expressions (N));
4565 while Present (Expr) loop
4566 Force_Evaluation (Expr);
4576 end Is_Ref_To_Bit_Packed_Array;
4578 --------------------------------
4579 -- Is_Ref_To_Bit_Packed_Slice --
4580 --------------------------------
4582 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
4584 if Nkind (N) = N_Type_Conversion then
4585 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
4587 elsif Is_Entity_Name (N)
4588 and then Is_Object (Entity (N))
4589 and then Present (Renamed_Object (Entity (N)))
4591 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
4593 elsif Nkind (N) = N_Slice
4594 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
4598 elsif Nkind (N) = N_Indexed_Component
4600 Nkind (N) = N_Selected_Component
4602 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
4607 end Is_Ref_To_Bit_Packed_Slice;
4609 -----------------------
4610 -- Is_Renamed_Object --
4611 -----------------------
4613 function Is_Renamed_Object (N : Node_Id) return Boolean is
4614 Pnod : constant Node_Id := Parent (N);
4615 Kind : constant Node_Kind := Nkind (Pnod);
4617 if Kind = N_Object_Renaming_Declaration then
4619 elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
4620 return Is_Renamed_Object (Pnod);
4624 end Is_Renamed_Object;
4626 -----------------------------
4627 -- Is_Tag_To_CW_Conversion --
4628 -----------------------------
4630 function Is_Tag_To_CW_Conversion (Obj_Id : Entity_Id) return Boolean is
4631 Expr : constant Node_Id := Expression (Parent (Obj_Id));
4635 Is_Class_Wide_Type (Etype (Obj_Id))
4636 and then Present (Expr)
4637 and then Nkind (Expr) = N_Unchecked_Type_Conversion
4638 and then Etype (Expression (Expr)) = RTE (RE_Tag);
4639 end Is_Tag_To_CW_Conversion;
4641 ----------------------------
4642 -- Is_Untagged_Derivation --
4643 ----------------------------
4645 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
4647 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
4649 (Is_Private_Type (T) and then Present (Full_View (T))
4650 and then not Is_Tagged_Type (Full_View (T))
4651 and then Is_Derived_Type (Full_View (T))
4652 and then Etype (Full_View (T)) /= T);
4653 end Is_Untagged_Derivation;
4655 ---------------------------
4656 -- Is_Volatile_Reference --
4657 ---------------------------
4659 function Is_Volatile_Reference (N : Node_Id) return Boolean is
4661 if Nkind (N) in N_Has_Etype
4662 and then Present (Etype (N))
4663 and then Treat_As_Volatile (Etype (N))
4667 elsif Is_Entity_Name (N) then
4668 return Treat_As_Volatile (Entity (N));
4670 elsif Nkind (N) = N_Slice then
4671 return Is_Volatile_Reference (Prefix (N));
4673 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
4674 if (Is_Entity_Name (Prefix (N))
4675 and then Has_Volatile_Components (Entity (Prefix (N))))
4676 or else (Present (Etype (Prefix (N)))
4677 and then Has_Volatile_Components (Etype (Prefix (N))))
4681 return Is_Volatile_Reference (Prefix (N));
4687 end Is_Volatile_Reference;
4689 --------------------------
4690 -- Is_VM_By_Copy_Actual --
4691 --------------------------
4693 function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean is
4695 return VM_Target /= No_VM
4696 and then (Nkind (N) = N_Slice
4698 (Nkind (N) = N_Identifier
4699 and then Present (Renamed_Object (Entity (N)))
4700 and then Nkind (Renamed_Object (Entity (N)))
4702 end Is_VM_By_Copy_Actual;
4704 --------------------
4705 -- Kill_Dead_Code --
4706 --------------------
4708 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
4709 W : Boolean := Warn;
4710 -- Set False if warnings suppressed
4714 Remove_Warning_Messages (N);
4716 -- Generate warning if appropriate
4720 -- We suppress the warning if this code is under control of an
4721 -- if statement, whose condition is a simple identifier, and
4722 -- either we are in an instance, or warnings off is set for this
4723 -- identifier. The reason for killing it in the instance case is
4724 -- that it is common and reasonable for code to be deleted in
4725 -- instances for various reasons.
4727 if Nkind (Parent (N)) = N_If_Statement then
4729 C : constant Node_Id := Condition (Parent (N));
4731 if Nkind (C) = N_Identifier
4734 or else (Present (Entity (C))
4735 and then Has_Warnings_Off (Entity (C))))
4742 -- Generate warning if not suppressed
4746 ("?this code can never be executed and has been deleted!", N);
4750 -- Recurse into block statements and bodies to process declarations
4753 if Nkind (N) = N_Block_Statement
4754 or else Nkind (N) = N_Subprogram_Body
4755 or else Nkind (N) = N_Package_Body
4757 Kill_Dead_Code (Declarations (N), False);
4758 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
4760 if Nkind (N) = N_Subprogram_Body then
4761 Set_Is_Eliminated (Defining_Entity (N));
4764 elsif Nkind (N) = N_Package_Declaration then
4765 Kill_Dead_Code (Visible_Declarations (Specification (N)));
4766 Kill_Dead_Code (Private_Declarations (Specification (N)));
4768 -- ??? After this point, Delete_Tree has been called on all
4769 -- declarations in Specification (N), so references to entities
4770 -- therein look suspicious.
4773 E : Entity_Id := First_Entity (Defining_Entity (N));
4775 while Present (E) loop
4776 if Ekind (E) = E_Operator then
4777 Set_Is_Eliminated (E);
4784 -- Recurse into composite statement to kill individual statements in
4785 -- particular instantiations.
4787 elsif Nkind (N) = N_If_Statement then
4788 Kill_Dead_Code (Then_Statements (N));
4789 Kill_Dead_Code (Elsif_Parts (N));
4790 Kill_Dead_Code (Else_Statements (N));
4792 elsif Nkind (N) = N_Loop_Statement then
4793 Kill_Dead_Code (Statements (N));
4795 elsif Nkind (N) = N_Case_Statement then
4799 Alt := First (Alternatives (N));
4800 while Present (Alt) loop
4801 Kill_Dead_Code (Statements (Alt));
4806 elsif Nkind (N) = N_Case_Statement_Alternative then
4807 Kill_Dead_Code (Statements (N));
4809 -- Deal with dead instances caused by deleting instantiations
4811 elsif Nkind (N) in N_Generic_Instantiation then
4812 Remove_Dead_Instance (N);
4817 -- Case where argument is a list of nodes to be killed
4819 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
4824 if Is_Non_Empty_List (L) then
4826 while Present (N) loop
4827 Kill_Dead_Code (N, W);
4834 ------------------------
4835 -- Known_Non_Negative --
4836 ------------------------
4838 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
4840 if Is_OK_Static_Expression (Opnd)
4841 and then Expr_Value (Opnd) >= 0
4847 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
4851 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
4854 end Known_Non_Negative;
4856 --------------------
4857 -- Known_Non_Null --
4858 --------------------
4860 function Known_Non_Null (N : Node_Id) return Boolean is
4862 -- Checks for case where N is an entity reference
4864 if Is_Entity_Name (N) and then Present (Entity (N)) then
4866 E : constant Entity_Id := Entity (N);
4871 -- First check if we are in decisive conditional
4873 Get_Current_Value_Condition (N, Op, Val);
4875 if Known_Null (Val) then
4876 if Op = N_Op_Eq then
4878 elsif Op = N_Op_Ne then
4883 -- If OK to do replacement, test Is_Known_Non_Null flag
4885 if OK_To_Do_Constant_Replacement (E) then
4886 return Is_Known_Non_Null (E);
4888 -- Otherwise if not safe to do replacement, then say so
4895 -- True if access attribute
4897 elsif Nkind (N) = N_Attribute_Reference
4898 and then (Attribute_Name (N) = Name_Access
4900 Attribute_Name (N) = Name_Unchecked_Access
4902 Attribute_Name (N) = Name_Unrestricted_Access)
4906 -- True if allocator
4908 elsif Nkind (N) = N_Allocator then
4911 -- For a conversion, true if expression is known non-null
4913 elsif Nkind (N) = N_Type_Conversion then
4914 return Known_Non_Null (Expression (N));
4916 -- Above are all cases where the value could be determined to be
4917 -- non-null. In all other cases, we don't know, so return False.
4928 function Known_Null (N : Node_Id) return Boolean is
4930 -- Checks for case where N is an entity reference
4932 if Is_Entity_Name (N) and then Present (Entity (N)) then
4934 E : constant Entity_Id := Entity (N);
4939 -- Constant null value is for sure null
4941 if Ekind (E) = E_Constant
4942 and then Known_Null (Constant_Value (E))
4947 -- First check if we are in decisive conditional
4949 Get_Current_Value_Condition (N, Op, Val);
4951 if Known_Null (Val) then
4952 if Op = N_Op_Eq then
4954 elsif Op = N_Op_Ne then
4959 -- If OK to do replacement, test Is_Known_Null flag
4961 if OK_To_Do_Constant_Replacement (E) then
4962 return Is_Known_Null (E);
4964 -- Otherwise if not safe to do replacement, then say so
4971 -- True if explicit reference to null
4973 elsif Nkind (N) = N_Null then
4976 -- For a conversion, true if expression is known null
4978 elsif Nkind (N) = N_Type_Conversion then
4979 return Known_Null (Expression (N));
4981 -- Above are all cases where the value could be determined to be null.
4982 -- In all other cases, we don't know, so return False.
4989 -----------------------------
4990 -- Make_CW_Equivalent_Type --
4991 -----------------------------
4993 -- Create a record type used as an equivalent of any member of the class
4994 -- which takes its size from exp.
4996 -- Generate the following code:
4998 -- type Equiv_T is record
4999 -- _parent : T (List of discriminant constraints taken from Exp);
5000 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
5003 -- ??? Note that this type does not guarantee same alignment as all
5006 function Make_CW_Equivalent_Type
5008 E : Node_Id) return Entity_Id
5010 Loc : constant Source_Ptr := Sloc (E);
5011 Root_Typ : constant Entity_Id := Root_Type (T);
5012 List_Def : constant List_Id := Empty_List;
5013 Comp_List : constant List_Id := New_List;
5014 Equiv_Type : Entity_Id;
5015 Range_Type : Entity_Id;
5016 Str_Type : Entity_Id;
5017 Constr_Root : Entity_Id;
5021 -- If the root type is already constrained, there are no discriminants
5022 -- in the expression.
5024 if not Has_Discriminants (Root_Typ)
5025 or else Is_Constrained (Root_Typ)
5027 Constr_Root := Root_Typ;
5029 Constr_Root := Make_Temporary (Loc, 'R');
5031 -- subtype cstr__n is T (List of discr constraints taken from Exp)
5033 Append_To (List_Def,
5034 Make_Subtype_Declaration (Loc,
5035 Defining_Identifier => Constr_Root,
5036 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
5039 -- Generate the range subtype declaration
5041 Range_Type := Make_Temporary (Loc, 'G');
5043 if not Is_Interface (Root_Typ) then
5045 -- subtype rg__xx is
5046 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
5049 Make_Op_Subtract (Loc,
5051 Make_Attribute_Reference (Loc,
5053 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
5054 Attribute_Name => Name_Size),
5056 Make_Attribute_Reference (Loc,
5057 Prefix => New_Reference_To (Constr_Root, Loc),
5058 Attribute_Name => Name_Object_Size));
5060 -- subtype rg__xx is
5061 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
5064 Make_Attribute_Reference (Loc,
5066 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
5067 Attribute_Name => Name_Size);
5070 Set_Paren_Count (Sizexpr, 1);
5072 Append_To (List_Def,
5073 Make_Subtype_Declaration (Loc,
5074 Defining_Identifier => Range_Type,
5075 Subtype_Indication =>
5076 Make_Subtype_Indication (Loc,
5077 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc),
5078 Constraint => Make_Range_Constraint (Loc,
5081 Low_Bound => Make_Integer_Literal (Loc, 1),
5083 Make_Op_Divide (Loc,
5084 Left_Opnd => Sizexpr,
5085 Right_Opnd => Make_Integer_Literal (Loc,
5086 Intval => System_Storage_Unit)))))));
5088 -- subtype str__nn is Storage_Array (rg__x);
5090 Str_Type := Make_Temporary (Loc, 'S');
5091 Append_To (List_Def,
5092 Make_Subtype_Declaration (Loc,
5093 Defining_Identifier => Str_Type,
5094 Subtype_Indication =>
5095 Make_Subtype_Indication (Loc,
5096 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
5098 Make_Index_Or_Discriminant_Constraint (Loc,
5100 New_List (New_Reference_To (Range_Type, Loc))))));
5102 -- type Equiv_T is record
5103 -- [ _parent : Tnn; ]
5107 Equiv_Type := Make_Temporary (Loc, 'T');
5108 Set_Ekind (Equiv_Type, E_Record_Type);
5109 Set_Parent_Subtype (Equiv_Type, Constr_Root);
5111 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
5112 -- treatment for this type. In particular, even though _parent's type
5113 -- is a controlled type or contains controlled components, we do not
5114 -- want to set Has_Controlled_Component on it to avoid making it gain
5115 -- an unwanted _controller component.
5117 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
5119 if not Is_Interface (Root_Typ) then
5120 Append_To (Comp_List,
5121 Make_Component_Declaration (Loc,
5122 Defining_Identifier =>
5123 Make_Defining_Identifier (Loc, Name_uParent),
5124 Component_Definition =>
5125 Make_Component_Definition (Loc,
5126 Aliased_Present => False,
5127 Subtype_Indication => New_Reference_To (Constr_Root, Loc))));
5130 Append_To (Comp_List,
5131 Make_Component_Declaration (Loc,
5132 Defining_Identifier => Make_Temporary (Loc, 'C'),
5133 Component_Definition =>
5134 Make_Component_Definition (Loc,
5135 Aliased_Present => False,
5136 Subtype_Indication => New_Reference_To (Str_Type, Loc))));
5138 Append_To (List_Def,
5139 Make_Full_Type_Declaration (Loc,
5140 Defining_Identifier => Equiv_Type,
5142 Make_Record_Definition (Loc,
5144 Make_Component_List (Loc,
5145 Component_Items => Comp_List,
5146 Variant_Part => Empty))));
5148 -- Suppress all checks during the analysis of the expanded code to avoid
5149 -- the generation of spurious warnings under ZFP run-time.
5151 Insert_Actions (E, List_Def, Suppress => All_Checks);
5153 end Make_CW_Equivalent_Type;
5155 -------------------------
5156 -- Make_Invariant_Call --
5157 -------------------------
5159 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
5160 Loc : constant Source_Ptr := Sloc (Expr);
5161 Typ : constant Entity_Id := Etype (Expr);
5165 (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
5167 if Check_Enabled (Name_Invariant)
5169 Check_Enabled (Name_Assertion)
5172 Make_Procedure_Call_Statement (Loc,
5174 New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
5175 Parameter_Associations => New_List (Relocate_Node (Expr)));
5179 Make_Null_Statement (Loc);
5181 end Make_Invariant_Call;
5183 ------------------------
5184 -- Make_Literal_Range --
5185 ------------------------
5187 function Make_Literal_Range
5189 Literal_Typ : Entity_Id) return Node_Id
5191 Lo : constant Node_Id :=
5192 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
5193 Index : constant Entity_Id := Etype (Lo);
5196 Length_Expr : constant Node_Id :=
5197 Make_Op_Subtract (Loc,
5199 Make_Integer_Literal (Loc,
5200 Intval => String_Literal_Length (Literal_Typ)),
5202 Make_Integer_Literal (Loc, 1));
5205 Set_Analyzed (Lo, False);
5207 if Is_Integer_Type (Index) then
5210 Left_Opnd => New_Copy_Tree (Lo),
5211 Right_Opnd => Length_Expr);
5214 Make_Attribute_Reference (Loc,
5215 Attribute_Name => Name_Val,
5216 Prefix => New_Occurrence_Of (Index, Loc),
5217 Expressions => New_List (
5220 Make_Attribute_Reference (Loc,
5221 Attribute_Name => Name_Pos,
5222 Prefix => New_Occurrence_Of (Index, Loc),
5223 Expressions => New_List (New_Copy_Tree (Lo))),
5224 Right_Opnd => Length_Expr)));
5231 end Make_Literal_Range;
5233 --------------------------
5234 -- Make_Non_Empty_Check --
5235 --------------------------
5237 function Make_Non_Empty_Check
5239 N : Node_Id) return Node_Id
5245 Make_Attribute_Reference (Loc,
5246 Attribute_Name => Name_Length,
5247 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
5249 Make_Integer_Literal (Loc, 0));
5250 end Make_Non_Empty_Check;
5252 -------------------------
5253 -- Make_Predicate_Call --
5254 -------------------------
5256 function Make_Predicate_Call
5258 Expr : Node_Id) return Node_Id
5260 Loc : constant Source_Ptr := Sloc (Expr);
5263 pragma Assert (Present (Predicate_Function (Typ)));
5266 Make_Function_Call (Loc,
5268 New_Occurrence_Of (Predicate_Function (Typ), Loc),
5269 Parameter_Associations => New_List (Relocate_Node (Expr)));
5270 end Make_Predicate_Call;
5272 --------------------------
5273 -- Make_Predicate_Check --
5274 --------------------------
5276 function Make_Predicate_Check
5278 Expr : Node_Id) return Node_Id
5280 Loc : constant Source_Ptr := Sloc (Expr);
5285 Pragma_Identifier => Make_Identifier (Loc, Name_Check),
5286 Pragma_Argument_Associations => New_List (
5287 Make_Pragma_Argument_Association (Loc,
5288 Expression => Make_Identifier (Loc, Name_Predicate)),
5289 Make_Pragma_Argument_Association (Loc,
5290 Expression => Make_Predicate_Call (Typ, Expr))));
5291 end Make_Predicate_Check;
5293 ----------------------------
5294 -- Make_Subtype_From_Expr --
5295 ----------------------------
5297 -- 1. If Expr is an unconstrained array expression, creates
5298 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
5300 -- 2. If Expr is a unconstrained discriminated type expression, creates
5301 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
5303 -- 3. If Expr is class-wide, creates an implicit class wide subtype
5305 function Make_Subtype_From_Expr
5307 Unc_Typ : Entity_Id) return Node_Id
5309 Loc : constant Source_Ptr := Sloc (E);
5310 List_Constr : constant List_Id := New_List;
5313 Full_Subtyp : Entity_Id;
5314 Priv_Subtyp : Entity_Id;
5319 if Is_Private_Type (Unc_Typ)
5320 and then Has_Unknown_Discriminants (Unc_Typ)
5322 -- Prepare the subtype completion, Go to base type to
5323 -- find underlying type, because the type may be a generic
5324 -- actual or an explicit subtype.
5326 Utyp := Underlying_Type (Base_Type (Unc_Typ));
5327 Full_Subtyp := Make_Temporary (Loc, 'C');
5329 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
5330 Set_Parent (Full_Exp, Parent (E));
5332 Priv_Subtyp := Make_Temporary (Loc, 'P');
5335 Make_Subtype_Declaration (Loc,
5336 Defining_Identifier => Full_Subtyp,
5337 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
5339 -- Define the dummy private subtype
5341 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
5342 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
5343 Set_Scope (Priv_Subtyp, Full_Subtyp);
5344 Set_Is_Constrained (Priv_Subtyp);
5345 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
5346 Set_Is_Itype (Priv_Subtyp);
5347 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
5349 if Is_Tagged_Type (Priv_Subtyp) then
5351 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
5352 Set_Direct_Primitive_Operations (Priv_Subtyp,
5353 Direct_Primitive_Operations (Unc_Typ));
5356 Set_Full_View (Priv_Subtyp, Full_Subtyp);
5358 return New_Reference_To (Priv_Subtyp, Loc);
5360 elsif Is_Array_Type (Unc_Typ) then
5361 for J in 1 .. Number_Dimensions (Unc_Typ) loop
5362 Append_To (List_Constr,
5365 Make_Attribute_Reference (Loc,
5366 Prefix => Duplicate_Subexpr_No_Checks (E),
5367 Attribute_Name => Name_First,
5368 Expressions => New_List (
5369 Make_Integer_Literal (Loc, J))),
5372 Make_Attribute_Reference (Loc,
5373 Prefix => Duplicate_Subexpr_No_Checks (E),
5374 Attribute_Name => Name_Last,
5375 Expressions => New_List (
5376 Make_Integer_Literal (Loc, J)))));
5379 elsif Is_Class_Wide_Type (Unc_Typ) then
5381 CW_Subtype : Entity_Id;
5382 EQ_Typ : Entity_Id := Empty;
5385 -- A class-wide equivalent type is not needed when VM_Target
5386 -- because the VM back-ends handle the class-wide object
5387 -- initialization itself (and doesn't need or want the
5388 -- additional intermediate type to handle the assignment).
5390 if Expander_Active and then Tagged_Type_Expansion then
5392 -- If this is the class_wide type of a completion that is a
5393 -- record subtype, set the type of the class_wide type to be
5394 -- the full base type, for use in the expanded code for the
5395 -- equivalent type. Should this be done earlier when the
5396 -- completion is analyzed ???
5398 if Is_Private_Type (Etype (Unc_Typ))
5400 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
5402 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
5405 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
5408 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
5409 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
5410 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
5412 return New_Occurrence_Of (CW_Subtype, Loc);
5415 -- Indefinite record type with discriminants
5418 D := First_Discriminant (Unc_Typ);
5419 while Present (D) loop
5420 Append_To (List_Constr,
5421 Make_Selected_Component (Loc,
5422 Prefix => Duplicate_Subexpr_No_Checks (E),
5423 Selector_Name => New_Reference_To (D, Loc)));
5425 Next_Discriminant (D);
5430 Make_Subtype_Indication (Loc,
5431 Subtype_Mark => New_Reference_To (Unc_Typ, Loc),
5433 Make_Index_Or_Discriminant_Constraint (Loc,
5434 Constraints => List_Constr));
5435 end Make_Subtype_From_Expr;
5437 -----------------------------
5438 -- May_Generate_Large_Temp --
5439 -----------------------------
5441 -- At the current time, the only types that we return False for (i.e. where
5442 -- we decide we know they cannot generate large temps) are ones where we
5443 -- know the size is 256 bits or less at compile time, and we are still not
5444 -- doing a thorough job on arrays and records ???
5446 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
5448 if not Size_Known_At_Compile_Time (Typ) then
5451 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
5454 elsif Is_Array_Type (Typ)
5455 and then Present (Packed_Array_Type (Typ))
5457 return May_Generate_Large_Temp (Packed_Array_Type (Typ));
5459 -- We could do more here to find other small types ???
5464 end May_Generate_Large_Temp;
5466 ------------------------
5467 -- Needs_Finalization --
5468 ------------------------
5470 function Needs_Finalization (T : Entity_Id) return Boolean is
5471 function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
5472 -- If type is not frozen yet, check explicitly among its components,
5473 -- because the Has_Controlled_Component flag is not necessarily set.
5475 -----------------------------------
5476 -- Has_Some_Controlled_Component --
5477 -----------------------------------
5479 function Has_Some_Controlled_Component
5480 (Rec : Entity_Id) return Boolean
5485 if Has_Controlled_Component (Rec) then
5488 elsif not Is_Frozen (Rec) then
5489 if Is_Record_Type (Rec) then
5490 Comp := First_Entity (Rec);
5492 while Present (Comp) loop
5493 if not Is_Type (Comp)
5494 and then Needs_Finalization (Etype (Comp))
5504 elsif Is_Array_Type (Rec) then
5505 return Needs_Finalization (Component_Type (Rec));
5508 return Has_Controlled_Component (Rec);
5513 end Has_Some_Controlled_Component;
5515 -- Start of processing for Needs_Finalization
5518 -- Certain run-time configurations and targets do not provide support
5519 -- for controlled types.
5521 if Restriction_Active (No_Finalization) then
5524 -- C, C++, CIL and Java types are not considered controlled. It is
5525 -- assumed that the non-Ada side will handle their clean up.
5527 elsif Convention (T) = Convention_C
5528 or else Convention (T) = Convention_CIL
5529 or else Convention (T) = Convention_CPP
5530 or else Convention (T) = Convention_Java
5535 -- Class-wide types are treated as controlled because derivations
5536 -- from the root type can introduce controlled components.
5539 Is_Class_Wide_Type (T)
5540 or else Is_Controlled (T)
5541 or else Has_Controlled_Component (T)
5542 or else Has_Some_Controlled_Component (T)
5544 (Is_Concurrent_Type (T)
5545 and then Present (Corresponding_Record_Type (T))
5546 and then Needs_Finalization (Corresponding_Record_Type (T)));
5548 end Needs_Finalization;
5550 ----------------------------
5551 -- Needs_Constant_Address --
5552 ----------------------------
5554 function Needs_Constant_Address
5556 Typ : Entity_Id) return Boolean
5560 -- If we have no initialization of any kind, then we don't need to place
5561 -- any restrictions on the address clause, because the object will be
5562 -- elaborated after the address clause is evaluated. This happens if the
5563 -- declaration has no initial expression, or the type has no implicit
5564 -- initialization, or the object is imported.
5566 -- The same holds for all initialized scalar types and all access types.
5567 -- Packed bit arrays of size up to 64 are represented using a modular
5568 -- type with an initialization (to zero) and can be processed like other
5569 -- initialized scalar types.
5571 -- If the type is controlled, code to attach the object to a
5572 -- finalization chain is generated at the point of declaration, and
5573 -- therefore the elaboration of the object cannot be delayed: the
5574 -- address expression must be a constant.
5576 if No (Expression (Decl))
5577 and then not Needs_Finalization (Typ)
5579 (not Has_Non_Null_Base_Init_Proc (Typ)
5580 or else Is_Imported (Defining_Identifier (Decl)))
5584 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
5585 or else Is_Access_Type (Typ)
5587 (Is_Bit_Packed_Array (Typ)
5588 and then Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
5594 -- Otherwise, we require the address clause to be constant because
5595 -- the call to the initialization procedure (or the attach code) has
5596 -- to happen at the point of the declaration.
5598 -- Actually the IP call has been moved to the freeze actions anyway,
5599 -- so maybe we can relax this restriction???
5603 end Needs_Constant_Address;
5605 ----------------------------
5606 -- New_Class_Wide_Subtype --
5607 ----------------------------
5609 function New_Class_Wide_Subtype
5610 (CW_Typ : Entity_Id;
5611 N : Node_Id) return Entity_Id
5613 Res : constant Entity_Id := Create_Itype (E_Void, N);
5614 Res_Name : constant Name_Id := Chars (Res);
5615 Res_Scope : constant Entity_Id := Scope (Res);
5618 Copy_Node (CW_Typ, Res);
5619 Set_Comes_From_Source (Res, False);
5620 Set_Sloc (Res, Sloc (N));
5622 Set_Associated_Node_For_Itype (Res, N);
5623 Set_Is_Public (Res, False); -- By default, may be changed below.
5624 Set_Public_Status (Res);
5625 Set_Chars (Res, Res_Name);
5626 Set_Scope (Res, Res_Scope);
5627 Set_Ekind (Res, E_Class_Wide_Subtype);
5628 Set_Next_Entity (Res, Empty);
5629 Set_Etype (Res, Base_Type (CW_Typ));
5630 Set_Is_Frozen (Res, False);
5631 Set_Freeze_Node (Res, Empty);
5633 end New_Class_Wide_Subtype;
5635 --------------------------------
5636 -- Non_Limited_Designated_Type --
5637 ---------------------------------
5639 function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
5640 Desig : constant Entity_Id := Designated_Type (T);
5642 if Ekind (Desig) = E_Incomplete_Type
5643 and then Present (Non_Limited_View (Desig))
5645 return Non_Limited_View (Desig);
5649 end Non_Limited_Designated_Type;
5651 -----------------------------------
5652 -- OK_To_Do_Constant_Replacement --
5653 -----------------------------------
5655 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
5656 ES : constant Entity_Id := Scope (E);
5660 -- Do not replace statically allocated objects, because they may be
5661 -- modified outside the current scope.
5663 if Is_Statically_Allocated (E) then
5666 -- Do not replace aliased or volatile objects, since we don't know what
5667 -- else might change the value.
5669 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
5672 -- Debug flag -gnatdM disconnects this optimization
5674 elsif Debug_Flag_MM then
5677 -- Otherwise check scopes
5680 CS := Current_Scope;
5683 -- If we are in right scope, replacement is safe
5688 -- Packages do not affect the determination of safety
5690 elsif Ekind (CS) = E_Package then
5691 exit when CS = Standard_Standard;
5694 -- Blocks do not affect the determination of safety
5696 elsif Ekind (CS) = E_Block then
5699 -- Loops do not affect the determination of safety. Note that we
5700 -- kill all current values on entry to a loop, so we are just
5701 -- talking about processing within a loop here.
5703 elsif Ekind (CS) = E_Loop then
5706 -- Otherwise, the reference is dubious, and we cannot be sure that
5707 -- it is safe to do the replacement.
5716 end OK_To_Do_Constant_Replacement;
5718 ------------------------------------
5719 -- Possible_Bit_Aligned_Component --
5720 ------------------------------------
5722 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
5726 -- Case of indexed component
5728 when N_Indexed_Component =>
5730 P : constant Node_Id := Prefix (N);
5731 Ptyp : constant Entity_Id := Etype (P);
5734 -- If we know the component size and it is less than 64, then
5735 -- we are definitely OK. The back end always does assignment of
5736 -- misaligned small objects correctly.
5738 if Known_Static_Component_Size (Ptyp)
5739 and then Component_Size (Ptyp) <= 64
5743 -- Otherwise, we need to test the prefix, to see if we are
5744 -- indexing from a possibly unaligned component.
5747 return Possible_Bit_Aligned_Component (P);
5751 -- Case of selected component
5753 when N_Selected_Component =>
5755 P : constant Node_Id := Prefix (N);
5756 Comp : constant Entity_Id := Entity (Selector_Name (N));
5759 -- If there is no component clause, then we are in the clear
5760 -- since the back end will never misalign a large component
5761 -- unless it is forced to do so. In the clear means we need
5762 -- only the recursive test on the prefix.
5764 if Component_May_Be_Bit_Aligned (Comp) then
5767 return Possible_Bit_Aligned_Component (P);
5771 -- For a slice, test the prefix, if that is possibly misaligned,
5772 -- then for sure the slice is!
5775 return Possible_Bit_Aligned_Component (Prefix (N));
5777 -- For an unchecked conversion, check whether the expression may
5780 when N_Unchecked_Type_Conversion =>
5781 return Possible_Bit_Aligned_Component (Expression (N));
5783 -- If we have none of the above, it means that we have fallen off the
5784 -- top testing prefixes recursively, and we now have a stand alone
5785 -- object, where we don't have a problem.
5791 end Possible_Bit_Aligned_Component;
5793 -----------------------------------------------
5794 -- Process_Statements_For_Controlled_Objects --
5795 -----------------------------------------------
5797 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
5798 Loc : constant Source_Ptr := Sloc (N);
5800 function Are_Wrapped (L : List_Id) return Boolean;
5801 -- Determine whether list L contains only one statement which is a block
5803 function Wrap_Statements_In_Block (L : List_Id) return Node_Id;
5804 -- Given a list of statements L, wrap it in a block statement and return
5805 -- the generated node.
5811 function Are_Wrapped (L : List_Id) return Boolean is
5812 Stmt : constant Node_Id := First (L);
5816 and then No (Next (Stmt))
5817 and then Nkind (Stmt) = N_Block_Statement;
5820 ------------------------------
5821 -- Wrap_Statements_In_Block --
5822 ------------------------------
5824 function Wrap_Statements_In_Block (L : List_Id) return Node_Id is
5827 Make_Block_Statement (Loc,
5828 Declarations => No_List,
5829 Handled_Statement_Sequence =>
5830 Make_Handled_Sequence_Of_Statements (Loc,
5832 end Wrap_Statements_In_Block;
5838 -- Start of processing for Process_Statements_For_Controlled_Objects
5841 -- Whenever a non-handled statement list is wrapped in a block, the
5842 -- block must be explicitly analyzed to redecorate all entities in the
5843 -- list and ensure that a finalizer is properly built.
5848 N_Conditional_Entry_Call |
5849 N_Selective_Accept =>
5851 -- Check the "then statements" for elsif parts and if statements
5853 if Nkind_In (N, N_Elsif_Part, N_If_Statement)
5854 and then not Is_Empty_List (Then_Statements (N))
5855 and then not Are_Wrapped (Then_Statements (N))
5856 and then Requires_Cleanup_Actions
5857 (Then_Statements (N), False, False)
5859 Block := Wrap_Statements_In_Block (Then_Statements (N));
5860 Set_Then_Statements (N, New_List (Block));
5865 -- Check the "else statements" for conditional entry calls, if
5866 -- statements and selective accepts.
5868 if Nkind_In (N, N_Conditional_Entry_Call,
5871 and then not Is_Empty_List (Else_Statements (N))
5872 and then not Are_Wrapped (Else_Statements (N))
5873 and then Requires_Cleanup_Actions
5874 (Else_Statements (N), False, False)
5876 Block := Wrap_Statements_In_Block (Else_Statements (N));
5877 Set_Else_Statements (N, New_List (Block));
5882 when N_Abortable_Part |
5883 N_Accept_Alternative |
5884 N_Case_Statement_Alternative |
5885 N_Delay_Alternative |
5886 N_Entry_Call_Alternative |
5887 N_Exception_Handler |
5889 N_Triggering_Alternative =>
5891 if not Is_Empty_List (Statements (N))
5892 and then not Are_Wrapped (Statements (N))
5893 and then Requires_Cleanup_Actions (Statements (N), False, False)
5895 Block := Wrap_Statements_In_Block (Statements (N));
5896 Set_Statements (N, New_List (Block));
5904 end Process_Statements_For_Controlled_Objects;
5906 -------------------------
5907 -- Remove_Side_Effects --
5908 -------------------------
5910 procedure Remove_Side_Effects
5912 Name_Req : Boolean := False;
5913 Variable_Ref : Boolean := False)
5915 Loc : constant Source_Ptr := Sloc (Exp);
5916 Exp_Type : constant Entity_Id := Etype (Exp);
5917 Svg_Suppress : constant Suppress_Array := Scope_Suppress;
5919 Ref_Type : Entity_Id;
5921 Ptr_Typ_Decl : Node_Id;
5925 function Side_Effect_Free (N : Node_Id) return Boolean;
5926 -- Determines if the tree N represents an expression that is known not
5927 -- to have side effects, and for which no processing is required.
5929 function Side_Effect_Free (L : List_Id) return Boolean;
5930 -- Determines if all elements of the list L are side effect free
5932 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
5933 -- The argument N is a construct where the Prefix is dereferenced if it
5934 -- is an access type and the result is a variable. The call returns True
5935 -- if the construct is side effect free (not considering side effects in
5936 -- other than the prefix which are to be tested by the caller).
5938 function Within_In_Parameter (N : Node_Id) return Boolean;
5939 -- Determines if N is a subcomponent of a composite in-parameter. If so,
5940 -- N is not side-effect free when the actual is global and modifiable
5941 -- indirectly from within a subprogram, because it may be passed by
5942 -- reference. The front-end must be conservative here and assume that
5943 -- this may happen with any array or record type. On the other hand, we
5944 -- cannot create temporaries for all expressions for which this
5945 -- condition is true, for various reasons that might require clearing up
5946 -- ??? For example, discriminant references that appear out of place, or
5947 -- spurious type errors with class-wide expressions. As a result, we
5948 -- limit the transformation to loop bounds, which is so far the only
5949 -- case that requires it.
5951 -----------------------------
5952 -- Safe_Prefixed_Reference --
5953 -----------------------------
5955 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
5957 -- If prefix is not side effect free, definitely not safe
5959 if not Side_Effect_Free (Prefix (N)) then
5962 -- If the prefix is of an access type that is not access-to-constant,
5963 -- then this construct is a variable reference, which means it is to
5964 -- be considered to have side effects if Variable_Ref is set True.
5966 elsif Is_Access_Type (Etype (Prefix (N)))
5967 and then not Is_Access_Constant (Etype (Prefix (N)))
5968 and then Variable_Ref
5970 -- Exception is a prefix that is the result of a previous removal
5973 return Is_Entity_Name (Prefix (N))
5974 and then not Comes_From_Source (Prefix (N))
5975 and then Ekind (Entity (Prefix (N))) = E_Constant
5976 and then Is_Internal_Name (Chars (Entity (Prefix (N))));
5978 -- If the prefix is an explicit dereference then this construct is a
5979 -- variable reference, which means it is to be considered to have
5980 -- side effects if Variable_Ref is True.
5982 -- We do NOT exclude dereferences of access-to-constant types because
5983 -- we handle them as constant view of variables.
5985 elsif Nkind (Prefix (N)) = N_Explicit_Dereference
5986 and then Variable_Ref
5990 -- Note: The following test is the simplest way of solving a complex
5991 -- problem uncovered by the following test (Side effect on loop bound
5992 -- that is a subcomponent of a global variable:
5994 -- with Text_Io; use Text_Io;
5995 -- procedure Tloop is
5998 -- V : Natural := 4;
5999 -- S : String (1..5) := (others => 'a');
6006 -- with procedure Action;
6007 -- procedure Loop_G (Arg : X; Msg : String)
6009 -- procedure Loop_G (Arg : X; Msg : String) is
6011 -- Put_Line ("begin loop_g " & Msg & " will loop till: "
6012 -- & Natural'Image (Arg.V));
6013 -- for Index in 1 .. Arg.V loop
6015 -- (Natural'Image (Index) & " " & Arg.S (Index));
6016 -- if Index > 2 then
6020 -- Put_Line ("end loop_g " & Msg);
6023 -- procedure Loop1 is new Loop_G (Modi);
6024 -- procedure Modi is
6027 -- Loop1 (X1, "from modi");
6031 -- Loop1 (X1, "initial");
6034 -- The output of the above program should be:
6036 -- begin loop_g initial will loop till: 4
6040 -- begin loop_g from modi will loop till: 1
6042 -- end loop_g from modi
6044 -- begin loop_g from modi will loop till: 1
6046 -- end loop_g from modi
6047 -- end loop_g initial
6049 -- If a loop bound is a subcomponent of a global variable, a
6050 -- modification of that variable within the loop may incorrectly
6051 -- affect the execution of the loop.
6053 elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
6054 and then Within_In_Parameter (Prefix (N))
6055 and then Variable_Ref
6059 -- All other cases are side effect free
6064 end Safe_Prefixed_Reference;
6066 ----------------------
6067 -- Side_Effect_Free --
6068 ----------------------
6070 function Side_Effect_Free (N : Node_Id) return Boolean is
6072 -- Note on checks that could raise Constraint_Error. Strictly, if we
6073 -- take advantage of 11.6, these checks do not count as side effects.
6074 -- However, we would prefer to consider that they are side effects,
6075 -- since the backend CSE does not work very well on expressions which
6076 -- can raise Constraint_Error. On the other hand if we don't consider
6077 -- them to be side effect free, then we get some awkward expansions
6078 -- in -gnato mode, resulting in code insertions at a point where we
6079 -- do not have a clear model for performing the insertions.
6081 -- Special handling for entity names
6083 if Is_Entity_Name (N) then
6085 -- Variables are considered to be a side effect if Variable_Ref
6086 -- is set or if we have a volatile reference and Name_Req is off.
6087 -- If Name_Req is True then we can't help returning a name which
6088 -- effectively allows multiple references in any case.
6090 if Is_Variable (N, Use_Original_Node => False) then
6091 return not Variable_Ref
6092 and then (not Is_Volatile_Reference (N) or else Name_Req);
6094 -- Any other entity (e.g. a subtype name) is definitely side
6101 -- A value known at compile time is always side effect free
6103 elsif Compile_Time_Known_Value (N) then
6106 -- A variable renaming is not side-effect free, because the renaming
6107 -- will function like a macro in the front-end in some cases, and an
6108 -- assignment can modify the component designated by N, so we need to
6109 -- create a temporary for it.
6111 -- The guard testing for Entity being present is needed at least in
6112 -- the case of rewritten predicate expressions, and may well also be
6113 -- appropriate elsewhere. Obviously we can't go testing the entity
6114 -- field if it does not exist, so it's reasonable to say that this is
6115 -- not the renaming case if it does not exist.
6117 elsif Is_Entity_Name (Original_Node (N))
6118 and then Present (Entity (Original_Node (N)))
6119 and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
6120 and then Ekind (Entity (Original_Node (N))) /= E_Constant
6124 -- Remove_Side_Effects generates an object renaming declaration to
6125 -- capture the expression of a class-wide expression. In VM targets
6126 -- the frontend performs no expansion for dispatching calls to
6127 -- class- wide types since they are handled by the VM. Hence, we must
6128 -- locate here if this node corresponds to a previous invocation of
6129 -- Remove_Side_Effects to avoid a never ending loop in the frontend.
6131 elsif VM_Target /= No_VM
6132 and then not Comes_From_Source (N)
6133 and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
6134 and then Is_Class_Wide_Type (Etype (N))
6139 -- For other than entity names and compile time known values,
6140 -- check the node kind for special processing.
6144 -- An attribute reference is side effect free if its expressions
6145 -- are side effect free and its prefix is side effect free or
6146 -- is an entity reference.
6148 -- Is this right? what about x'first where x is a variable???
6150 when N_Attribute_Reference =>
6151 return Side_Effect_Free (Expressions (N))
6152 and then Attribute_Name (N) /= Name_Input
6153 and then (Is_Entity_Name (Prefix (N))
6154 or else Side_Effect_Free (Prefix (N)));
6156 -- A binary operator is side effect free if and both operands are
6157 -- side effect free. For this purpose binary operators include
6158 -- membership tests and short circuit forms
6160 when N_Binary_Op | N_Membership_Test | N_Short_Circuit =>
6161 return Side_Effect_Free (Left_Opnd (N))
6163 Side_Effect_Free (Right_Opnd (N));
6165 -- An explicit dereference is side effect free only if it is
6166 -- a side effect free prefixed reference.
6168 when N_Explicit_Dereference =>
6169 return Safe_Prefixed_Reference (N);
6171 -- A call to _rep_to_pos is side effect free, since we generate
6172 -- this pure function call ourselves. Moreover it is critically
6173 -- important to make this exception, since otherwise we can have
6174 -- discriminants in array components which don't look side effect
6175 -- free in the case of an array whose index type is an enumeration
6176 -- type with an enumeration rep clause.
6178 -- All other function calls are not side effect free
6180 when N_Function_Call =>
6181 return Nkind (Name (N)) = N_Identifier
6182 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
6184 Side_Effect_Free (First (Parameter_Associations (N)));
6186 -- An indexed component is side effect free if it is a side
6187 -- effect free prefixed reference and all the indexing
6188 -- expressions are side effect free.
6190 when N_Indexed_Component =>
6191 return Side_Effect_Free (Expressions (N))
6192 and then Safe_Prefixed_Reference (N);
6194 -- A type qualification is side effect free if the expression
6195 -- is side effect free.
6197 when N_Qualified_Expression =>
6198 return Side_Effect_Free (Expression (N));
6200 -- A selected component is side effect free only if it is a side
6201 -- effect free prefixed reference. If it designates a component
6202 -- with a rep. clause it must be treated has having a potential
6203 -- side effect, because it may be modified through a renaming, and
6204 -- a subsequent use of the renaming as a macro will yield the
6205 -- wrong value. This complex interaction between renaming and
6206 -- removing side effects is a reminder that the latter has become
6207 -- a headache to maintain, and that it should be removed in favor
6208 -- of the gcc mechanism to capture values ???
6210 when N_Selected_Component =>
6211 if Nkind (Parent (N)) = N_Explicit_Dereference
6212 and then Has_Non_Standard_Rep (Designated_Type (Etype (N)))
6216 return Safe_Prefixed_Reference (N);
6219 -- A range is side effect free if the bounds are side effect free
6222 return Side_Effect_Free (Low_Bound (N))
6223 and then Side_Effect_Free (High_Bound (N));
6225 -- A slice is side effect free if it is a side effect free
6226 -- prefixed reference and the bounds are side effect free.
6229 return Side_Effect_Free (Discrete_Range (N))
6230 and then Safe_Prefixed_Reference (N);
6232 -- A type conversion is side effect free if the expression to be
6233 -- converted is side effect free.
6235 when N_Type_Conversion =>
6236 return Side_Effect_Free (Expression (N));
6238 -- A unary operator is side effect free if the operand
6239 -- is side effect free.
6242 return Side_Effect_Free (Right_Opnd (N));
6244 -- An unchecked type conversion is side effect free only if it
6245 -- is safe and its argument is side effect free.
6247 when N_Unchecked_Type_Conversion =>
6248 return Safe_Unchecked_Type_Conversion (N)
6249 and then Side_Effect_Free (Expression (N));
6251 -- An unchecked expression is side effect free if its expression
6252 -- is side effect free.
6254 when N_Unchecked_Expression =>
6255 return Side_Effect_Free (Expression (N));
6257 -- A literal is side effect free
6259 when N_Character_Literal |
6265 -- We consider that anything else has side effects. This is a bit
6266 -- crude, but we are pretty close for most common cases, and we
6267 -- are certainly correct (i.e. we never return True when the
6268 -- answer should be False).
6273 end Side_Effect_Free;
6275 -- A list is side effect free if all elements of the list are side
6278 function Side_Effect_Free (L : List_Id) return Boolean is
6282 if L = No_List or else L = Error_List then
6287 while Present (N) loop
6288 if not Side_Effect_Free (N) then
6297 end Side_Effect_Free;
6299 -------------------------
6300 -- Within_In_Parameter --
6301 -------------------------
6303 function Within_In_Parameter (N : Node_Id) return Boolean is
6305 if not Comes_From_Source (N) then
6308 elsif Is_Entity_Name (N) then
6309 return Ekind (Entity (N)) = E_In_Parameter;
6311 elsif Nkind (N) = N_Indexed_Component
6312 or else Nkind (N) = N_Selected_Component
6314 return Within_In_Parameter (Prefix (N));
6319 end Within_In_Parameter;
6321 -- Start of processing for Remove_Side_Effects
6324 -- Handle cases in which there is nothing to do
6326 if not Expander_Active then
6329 -- Cannot generate temporaries if the invocation to remove side effects
6330 -- was issued too early and the type of the expression is not resolved
6331 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
6332 -- Remove_Side_Effects).
6335 or else Ekind (Exp_Type) = E_Access_Attribute_Type
6339 -- No action needed for side-effect free expressions
6341 elsif Side_Effect_Free (Exp) then
6345 -- All this must not have any checks
6347 Scope_Suppress := (others => True);
6349 -- If it is a scalar type and we need to capture the value, just make
6350 -- a copy. Likewise for a function call, an attribute reference, an
6351 -- allocator, or an operator. And if we have a volatile reference and
6352 -- Name_Req is not set (see comments above for Side_Effect_Free).
6354 if Is_Elementary_Type (Exp_Type)
6355 and then (Variable_Ref
6356 or else Nkind (Exp) = N_Function_Call
6357 or else Nkind (Exp) = N_Attribute_Reference
6358 or else Nkind (Exp) = N_Allocator
6359 or else Nkind (Exp) in N_Op
6360 or else (not Name_Req and then Is_Volatile_Reference (Exp)))
6362 Def_Id := Make_Temporary (Loc, 'R', Exp);
6363 Set_Etype (Def_Id, Exp_Type);
6364 Res := New_Reference_To (Def_Id, Loc);
6366 -- If the expression is a packed reference, it must be reanalyzed and
6367 -- expanded, depending on context. This is the case for actuals where
6368 -- a constraint check may capture the actual before expansion of the
6369 -- call is complete.
6371 if Nkind (Exp) = N_Indexed_Component
6372 and then Is_Packed (Etype (Prefix (Exp)))
6374 Set_Analyzed (Exp, False);
6375 Set_Analyzed (Prefix (Exp), False);
6379 Make_Object_Declaration (Loc,
6380 Defining_Identifier => Def_Id,
6381 Object_Definition => New_Reference_To (Exp_Type, Loc),
6382 Constant_Present => True,
6383 Expression => Relocate_Node (Exp));
6385 Set_Assignment_OK (E);
6386 Insert_Action (Exp, E);
6388 -- If the expression has the form v.all then we can just capture the
6389 -- pointer, and then do an explicit dereference on the result.
6391 elsif Nkind (Exp) = N_Explicit_Dereference then
6392 Def_Id := Make_Temporary (Loc, 'R', Exp);
6394 Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc));
6397 Make_Object_Declaration (Loc,
6398 Defining_Identifier => Def_Id,
6399 Object_Definition =>
6400 New_Reference_To (Etype (Prefix (Exp)), Loc),
6401 Constant_Present => True,
6402 Expression => Relocate_Node (Prefix (Exp))));
6404 -- Similar processing for an unchecked conversion of an expression of
6405 -- the form v.all, where we want the same kind of treatment.
6407 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
6408 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
6410 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
6411 Scope_Suppress := Svg_Suppress;
6414 -- If this is a type conversion, leave the type conversion and remove
6415 -- the side effects in the expression. This is important in several
6416 -- circumstances: for change of representations, and also when this is a
6417 -- view conversion to a smaller object, where gigi can end up creating
6418 -- its own temporary of the wrong size.
6420 elsif Nkind (Exp) = N_Type_Conversion then
6421 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
6422 Scope_Suppress := Svg_Suppress;
6425 -- If this is an unchecked conversion that Gigi can't handle, make
6426 -- a copy or a use a renaming to capture the value.
6428 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
6429 and then not Safe_Unchecked_Type_Conversion (Exp)
6431 if CW_Or_Has_Controlled_Part (Exp_Type) then
6433 -- Use a renaming to capture the expression, rather than create
6434 -- a controlled temporary.
6436 Def_Id := Make_Temporary (Loc, 'R', Exp);
6437 Res := New_Reference_To (Def_Id, Loc);
6440 Make_Object_Renaming_Declaration (Loc,
6441 Defining_Identifier => Def_Id,
6442 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
6443 Name => Relocate_Node (Exp)));
6446 Def_Id := Make_Temporary (Loc, 'R', Exp);
6447 Set_Etype (Def_Id, Exp_Type);
6448 Res := New_Reference_To (Def_Id, Loc);
6451 Make_Object_Declaration (Loc,
6452 Defining_Identifier => Def_Id,
6453 Object_Definition => New_Reference_To (Exp_Type, Loc),
6454 Constant_Present => not Is_Variable (Exp),
6455 Expression => Relocate_Node (Exp));
6457 Set_Assignment_OK (E);
6458 Insert_Action (Exp, E);
6461 -- For expressions that denote objects, we can use a renaming scheme.
6462 -- This is needed for correctness in the case of a volatile object of a
6463 -- non-volatile type because the Make_Reference call of the "default"
6464 -- approach would generate an illegal access value (an access value
6465 -- cannot designate such an object - see Analyze_Reference). We skip
6466 -- using this scheme if we have an object of a volatile type and we do
6467 -- not have Name_Req set true (see comments above for Side_Effect_Free).
6469 elsif Is_Object_Reference (Exp)
6470 and then Nkind (Exp) /= N_Function_Call
6471 and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
6473 Def_Id := Make_Temporary (Loc, 'R', Exp);
6475 if Nkind (Exp) = N_Selected_Component
6476 and then Nkind (Prefix (Exp)) = N_Function_Call
6477 and then Is_Array_Type (Exp_Type)
6479 -- Avoid generating a variable-sized temporary, by generating
6480 -- the renaming declaration just for the function call. The
6481 -- transformation could be refined to apply only when the array
6482 -- component is constrained by a discriminant???
6485 Make_Selected_Component (Loc,
6486 Prefix => New_Occurrence_Of (Def_Id, Loc),
6487 Selector_Name => Selector_Name (Exp));
6490 Make_Object_Renaming_Declaration (Loc,
6491 Defining_Identifier => Def_Id,
6493 New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
6494 Name => Relocate_Node (Prefix (Exp))));
6497 Res := New_Reference_To (Def_Id, Loc);
6500 Make_Object_Renaming_Declaration (Loc,
6501 Defining_Identifier => Def_Id,
6502 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
6503 Name => Relocate_Node (Exp)));
6506 -- If this is a packed reference, or a selected component with
6507 -- a non-standard representation, a reference to the temporary
6508 -- will be replaced by a copy of the original expression (see
6509 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
6510 -- elaborated by gigi, and is of course not to be replaced in-line
6511 -- by the expression it renames, which would defeat the purpose of
6512 -- removing the side-effect.
6514 if (Nkind (Exp) = N_Selected_Component
6515 or else Nkind (Exp) = N_Indexed_Component)
6516 and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
6520 Set_Is_Renaming_Of_Object (Def_Id, False);
6523 -- Otherwise we generate a reference to the value
6526 -- Special processing for function calls that return a limited type.
6527 -- We need to build a declaration that will enable build-in-place
6528 -- expansion of the call. This is not done if the context is already
6529 -- an object declaration, to prevent infinite recursion.
6531 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
6532 -- to accommodate functions returning limited objects by reference.
6534 if Nkind (Exp) = N_Function_Call
6535 and then Is_Immutably_Limited_Type (Etype (Exp))
6536 and then Nkind (Parent (Exp)) /= N_Object_Declaration
6537 and then Ada_Version >= Ada_2005
6540 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
6545 Make_Object_Declaration (Loc,
6546 Defining_Identifier => Obj,
6547 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
6548 Expression => Relocate_Node (Exp));
6550 Insert_Action (Exp, Decl);
6551 Set_Etype (Obj, Exp_Type);
6552 Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
6557 Ref_Type := Make_Temporary (Loc, 'A');
6560 Make_Full_Type_Declaration (Loc,
6561 Defining_Identifier => Ref_Type,
6563 Make_Access_To_Object_Definition (Loc,
6564 All_Present => True,
6565 Subtype_Indication =>
6566 New_Reference_To (Exp_Type, Loc)));
6569 Insert_Action (Exp, Ptr_Typ_Decl);
6571 Def_Id := Make_Temporary (Loc, 'R', Exp);
6572 Set_Etype (Def_Id, Exp_Type);
6575 Make_Explicit_Dereference (Loc,
6576 Prefix => New_Reference_To (Def_Id, Loc));
6578 if Nkind (E) = N_Explicit_Dereference then
6579 New_Exp := Relocate_Node (Prefix (E));
6581 E := Relocate_Node (E);
6582 New_Exp := Make_Reference (Loc, E);
6585 if Is_Delayed_Aggregate (E) then
6587 -- The expansion of nested aggregates is delayed until the
6588 -- enclosing aggregate is expanded. As aggregates are often
6589 -- qualified, the predicate applies to qualified expressions as
6590 -- well, indicating that the enclosing aggregate has not been
6591 -- expanded yet. At this point the aggregate is part of a
6592 -- stand-alone declaration, and must be fully expanded.
6594 if Nkind (E) = N_Qualified_Expression then
6595 Set_Expansion_Delayed (Expression (E), False);
6596 Set_Analyzed (Expression (E), False);
6598 Set_Expansion_Delayed (E, False);
6601 Set_Analyzed (E, False);
6605 Make_Object_Declaration (Loc,
6606 Defining_Identifier => Def_Id,
6607 Object_Definition => New_Reference_To (Ref_Type, Loc),
6608 Constant_Present => True,
6609 Expression => New_Exp));
6612 -- Preserve the Assignment_OK flag in all copies, since at least one
6613 -- copy may be used in a context where this flag must be set (otherwise
6614 -- why would the flag be set in the first place).
6616 Set_Assignment_OK (Res, Assignment_OK (Exp));
6618 -- Finally rewrite the original expression and we are done
6621 Analyze_And_Resolve (Exp, Exp_Type);
6622 Scope_Suppress := Svg_Suppress;
6623 end Remove_Side_Effects;
6625 ---------------------------
6626 -- Represented_As_Scalar --
6627 ---------------------------
6629 function Represented_As_Scalar (T : Entity_Id) return Boolean is
6630 UT : constant Entity_Id := Underlying_Type (T);
6632 return Is_Scalar_Type (UT)
6633 or else (Is_Bit_Packed_Array (UT)
6634 and then Is_Scalar_Type (Packed_Array_Type (UT)));
6635 end Represented_As_Scalar;
6637 ------------------------------
6638 -- Requires_Cleanup_Actions --
6639 ------------------------------
6641 function Requires_Cleanup_Actions (N : Node_Id) return Boolean is
6642 For_Pkg : constant Boolean :=
6643 Nkind_In (N, N_Package_Body, N_Package_Specification);
6647 when N_Accept_Statement |
6655 Requires_Cleanup_Actions (Declarations (N), For_Pkg, True)
6657 (Present (Handled_Statement_Sequence (N))
6659 Requires_Cleanup_Actions (Statements
6660 (Handled_Statement_Sequence (N)), For_Pkg, True));
6662 when N_Package_Specification =>
6664 Requires_Cleanup_Actions
6665 (Visible_Declarations (N), For_Pkg, True)
6667 Requires_Cleanup_Actions
6668 (Private_Declarations (N), For_Pkg, True);
6673 end Requires_Cleanup_Actions;
6675 ------------------------------
6676 -- Requires_Cleanup_Actions --
6677 ------------------------------
6679 function Requires_Cleanup_Actions
6681 For_Package : Boolean;
6682 Nested_Constructs : Boolean) return Boolean
6687 Obj_Typ : Entity_Id;
6688 Pack_Id : Entity_Id;
6693 or else Is_Empty_List (L)
6699 while Present (Decl) loop
6701 -- Library-level tagged types
6703 if Nkind (Decl) = N_Full_Type_Declaration then
6704 Typ := Defining_Identifier (Decl);
6706 if Is_Tagged_Type (Typ)
6707 and then Is_Library_Level_Entity (Typ)
6708 and then Convention (Typ) = Convention_Ada
6709 and then Present (Access_Disp_Table (Typ))
6710 and then RTE_Available (RE_Unregister_Tag)
6711 and then not No_Run_Time_Mode
6712 and then not Is_Abstract_Type (Typ)
6717 -- Regular object declarations
6719 elsif Nkind (Decl) = N_Object_Declaration then
6720 Obj_Id := Defining_Identifier (Decl);
6721 Obj_Typ := Base_Type (Etype (Obj_Id));
6722 Expr := Expression (Decl);
6724 -- Bypass any form of processing for objects which have their
6725 -- finalization disabled. This applies only to objects at the
6729 and then Finalize_Storage_Only (Obj_Typ)
6733 -- Transient variables are treated separately in order to minimize
6734 -- the size of the generated code. See Exp_Ch7.Process_Transient_
6737 elsif Is_Processed_Transient (Obj_Id) then
6740 -- The object is of the form:
6741 -- Obj : Typ [:= Expr];
6743 -- Do not process the incomplete view of a deferred constant. Do
6744 -- not consider tag-to-class-wide conversions.
6746 elsif not Is_Imported (Obj_Id)
6747 and then Needs_Finalization (Obj_Typ)
6748 and then not (Ekind (Obj_Id) = E_Constant
6749 and then not Has_Completion (Obj_Id))
6750 and then not Is_Tag_To_CW_Conversion (Obj_Id)
6754 -- The object is of the form:
6755 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
6757 -- Obj : Access_Typ :=
6758 -- BIP_Function_Call
6759 -- (..., BIPaccess => null, ...)'reference;
6761 elsif Is_Access_Type (Obj_Typ)
6762 and then Needs_Finalization
6763 (Available_View (Designated_Type (Obj_Typ)))
6764 and then Present (Expr)
6766 (Is_Null_Access_BIP_Func_Call (Expr)
6768 (Is_Non_BIP_Func_Call (Expr)
6769 and then not Is_Related_To_Func_Return (Obj_Id)))
6773 -- Processing for "hook" objects generated for controlled
6774 -- transients declared inside an Expression_With_Actions.
6776 elsif Is_Access_Type (Obj_Typ)
6777 and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
6778 and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
6779 N_Object_Declaration
6780 and then Is_Finalizable_Transient
6781 (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
6785 -- Simple protected objects which use type System.Tasking.
6786 -- Protected_Objects.Protection to manage their locks should be
6787 -- treated as controlled since they require manual cleanup.
6789 elsif Ekind (Obj_Id) = E_Variable
6791 (Is_Simple_Protected_Type (Obj_Typ)
6792 or else Has_Simple_Protected_Object (Obj_Typ))
6797 -- Specific cases of object renamings
6799 elsif Nkind (Decl) = N_Object_Renaming_Declaration
6800 and then Nkind (Name (Decl)) = N_Explicit_Dereference
6801 and then Nkind (Prefix (Name (Decl))) = N_Identifier
6803 Obj_Id := Defining_Identifier (Decl);
6804 Obj_Typ := Base_Type (Etype (Obj_Id));
6806 -- Bypass any form of processing for objects which have their
6807 -- finalization disabled. This applies only to objects at the
6811 and then Finalize_Storage_Only (Obj_Typ)
6815 -- Return object of a build-in-place function. This case is
6816 -- recognized and marked by the expansion of an extended return
6817 -- statement (see Expand_N_Extended_Return_Statement).
6819 elsif Needs_Finalization (Obj_Typ)
6820 and then Is_Return_Object (Obj_Id)
6821 and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
6826 -- Inspect the freeze node of an access-to-controlled type and look
6827 -- for a delayed finalization master. This case arises when the
6828 -- freeze actions are inserted at a later time than the expansion of
6829 -- the context. Since Build_Finalizer is never called on a single
6830 -- construct twice, the master will be ultimately left out and never
6831 -- finalized. This is also needed for freeze actions of designated
6832 -- types themselves, since in some cases the finalization master is
6833 -- associated with a designated type's freeze node rather than that
6834 -- of the access type (see handling for freeze actions in
6835 -- Build_Finalization_Master).
6837 elsif Nkind (Decl) = N_Freeze_Entity
6838 and then Present (Actions (Decl))
6840 Typ := Entity (Decl);
6842 if ((Is_Access_Type (Typ)
6843 and then not Is_Access_Subprogram_Type (Typ)
6844 and then Needs_Finalization
6845 (Available_View (Designated_Type (Typ))))
6848 and then Needs_Finalization (Typ)))
6849 and then Requires_Cleanup_Actions
6850 (Actions (Decl), For_Package, Nested_Constructs)
6855 -- Nested package declarations
6857 elsif Nested_Constructs
6858 and then Nkind (Decl) = N_Package_Declaration
6860 Pack_Id := Defining_Unit_Name (Specification (Decl));
6862 if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
6863 Pack_Id := Defining_Identifier (Pack_Id);
6866 if Ekind (Pack_Id) /= E_Generic_Package
6867 and then Requires_Cleanup_Actions (Specification (Decl))
6872 -- Nested package bodies
6874 elsif Nested_Constructs
6875 and then Nkind (Decl) = N_Package_Body
6877 Pack_Id := Corresponding_Spec (Decl);
6879 if Ekind (Pack_Id) /= E_Generic_Package
6880 and then Requires_Cleanup_Actions (Decl)
6890 end Requires_Cleanup_Actions;
6892 ------------------------------------
6893 -- Safe_Unchecked_Type_Conversion --
6894 ------------------------------------
6896 -- Note: this function knows quite a bit about the exact requirements of
6897 -- Gigi with respect to unchecked type conversions, and its code must be
6898 -- coordinated with any changes in Gigi in this area.
6900 -- The above requirements should be documented in Sinfo ???
6902 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
6907 Pexp : constant Node_Id := Parent (Exp);
6910 -- If the expression is the RHS of an assignment or object declaration
6911 -- we are always OK because there will always be a target.
6913 -- Object renaming declarations, (generated for view conversions of
6914 -- actuals in inlined calls), like object declarations, provide an
6915 -- explicit type, and are safe as well.
6917 if (Nkind (Pexp) = N_Assignment_Statement
6918 and then Expression (Pexp) = Exp)
6919 or else Nkind (Pexp) = N_Object_Declaration
6920 or else Nkind (Pexp) = N_Object_Renaming_Declaration
6924 -- If the expression is the prefix of an N_Selected_Component we should
6925 -- also be OK because GCC knows to look inside the conversion except if
6926 -- the type is discriminated. We assume that we are OK anyway if the
6927 -- type is not set yet or if it is controlled since we can't afford to
6928 -- introduce a temporary in this case.
6930 elsif Nkind (Pexp) = N_Selected_Component
6931 and then Prefix (Pexp) = Exp
6933 if No (Etype (Pexp)) then
6937 not Has_Discriminants (Etype (Pexp))
6938 or else Is_Constrained (Etype (Pexp));
6942 -- Set the output type, this comes from Etype if it is set, otherwise we
6943 -- take it from the subtype mark, which we assume was already fully
6946 if Present (Etype (Exp)) then
6947 Otyp := Etype (Exp);
6949 Otyp := Entity (Subtype_Mark (Exp));
6952 -- The input type always comes from the expression, and we assume
6953 -- this is indeed always analyzed, so we can simply get the Etype.
6955 Ityp := Etype (Expression (Exp));
6957 -- Initialize alignments to unknown so far
6962 -- Replace a concurrent type by its corresponding record type and each
6963 -- type by its underlying type and do the tests on those. The original
6964 -- type may be a private type whose completion is a concurrent type, so
6965 -- find the underlying type first.
6967 if Present (Underlying_Type (Otyp)) then
6968 Otyp := Underlying_Type (Otyp);
6971 if Present (Underlying_Type (Ityp)) then
6972 Ityp := Underlying_Type (Ityp);
6975 if Is_Concurrent_Type (Otyp) then
6976 Otyp := Corresponding_Record_Type (Otyp);
6979 if Is_Concurrent_Type (Ityp) then
6980 Ityp := Corresponding_Record_Type (Ityp);
6983 -- If the base types are the same, we know there is no problem since
6984 -- this conversion will be a noop.
6986 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
6989 -- Same if this is an upwards conversion of an untagged type, and there
6990 -- are no constraints involved (could be more general???)
6992 elsif Etype (Ityp) = Otyp
6993 and then not Is_Tagged_Type (Ityp)
6994 and then not Has_Discriminants (Ityp)
6995 and then No (First_Rep_Item (Base_Type (Ityp)))
6999 -- If the expression has an access type (object or subprogram) we assume
7000 -- that the conversion is safe, because the size of the target is safe,
7001 -- even if it is a record (which might be treated as having unknown size
7004 elsif Is_Access_Type (Ityp) then
7007 -- If the size of output type is known at compile time, there is never
7008 -- a problem. Note that unconstrained records are considered to be of
7009 -- known size, but we can't consider them that way here, because we are
7010 -- talking about the actual size of the object.
7012 -- We also make sure that in addition to the size being known, we do not
7013 -- have a case which might generate an embarrassingly large temp in
7014 -- stack checking mode.
7016 elsif Size_Known_At_Compile_Time (Otyp)
7018 (not Stack_Checking_Enabled
7019 or else not May_Generate_Large_Temp (Otyp))
7020 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
7024 -- If either type is tagged, then we know the alignment is OK so
7025 -- Gigi will be able to use pointer punning.
7027 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
7030 -- If either type is a limited record type, we cannot do a copy, so say
7031 -- safe since there's nothing else we can do.
7033 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
7036 -- Conversions to and from packed array types are always ignored and
7039 elsif Is_Packed_Array_Type (Otyp)
7040 or else Is_Packed_Array_Type (Ityp)
7045 -- The only other cases known to be safe is if the input type's
7046 -- alignment is known to be at least the maximum alignment for the
7047 -- target or if both alignments are known and the output type's
7048 -- alignment is no stricter than the input's. We can use the component
7049 -- type alignement for an array if a type is an unpacked array type.
7051 if Present (Alignment_Clause (Otyp)) then
7052 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
7054 elsif Is_Array_Type (Otyp)
7055 and then Present (Alignment_Clause (Component_Type (Otyp)))
7057 Oalign := Expr_Value (Expression (Alignment_Clause
7058 (Component_Type (Otyp))));
7061 if Present (Alignment_Clause (Ityp)) then
7062 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
7064 elsif Is_Array_Type (Ityp)
7065 and then Present (Alignment_Clause (Component_Type (Ityp)))
7067 Ialign := Expr_Value (Expression (Alignment_Clause
7068 (Component_Type (Ityp))));
7071 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
7074 elsif Ialign /= No_Uint and then Oalign /= No_Uint
7075 and then Ialign <= Oalign
7079 -- Otherwise, Gigi cannot handle this and we must make a temporary
7084 end Safe_Unchecked_Type_Conversion;
7086 ---------------------------------
7087 -- Set_Current_Value_Condition --
7088 ---------------------------------
7090 -- Note: the implementation of this procedure is very closely tied to the
7091 -- implementation of Get_Current_Value_Condition. Here we set required
7092 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
7093 -- them, so they must have a consistent view.
7095 procedure Set_Current_Value_Condition (Cnode : Node_Id) is
7097 procedure Set_Entity_Current_Value (N : Node_Id);
7098 -- If N is an entity reference, where the entity is of an appropriate
7099 -- kind, then set the current value of this entity to Cnode, unless
7100 -- there is already a definite value set there.
7102 procedure Set_Expression_Current_Value (N : Node_Id);
7103 -- If N is of an appropriate form, sets an appropriate entry in current
7104 -- value fields of relevant entities. Multiple entities can be affected
7105 -- in the case of an AND or AND THEN.
7107 ------------------------------
7108 -- Set_Entity_Current_Value --
7109 ------------------------------
7111 procedure Set_Entity_Current_Value (N : Node_Id) is
7113 if Is_Entity_Name (N) then
7115 Ent : constant Entity_Id := Entity (N);
7118 -- Don't capture if not safe to do so
7120 if not Safe_To_Capture_Value (N, Ent, Cond => True) then
7124 -- Here we have a case where the Current_Value field may need
7125 -- to be set. We set it if it is not already set to a compile
7126 -- time expression value.
7128 -- Note that this represents a decision that one condition
7129 -- blots out another previous one. That's certainly right if
7130 -- they occur at the same level. If the second one is nested,
7131 -- then the decision is neither right nor wrong (it would be
7132 -- equally OK to leave the outer one in place, or take the new
7133 -- inner one. Really we should record both, but our data
7134 -- structures are not that elaborate.
7136 if Nkind (Current_Value (Ent)) not in N_Subexpr then
7137 Set_Current_Value (Ent, Cnode);
7141 end Set_Entity_Current_Value;
7143 ----------------------------------
7144 -- Set_Expression_Current_Value --
7145 ----------------------------------
7147 procedure Set_Expression_Current_Value (N : Node_Id) is
7153 -- Loop to deal with (ignore for now) any NOT operators present. The
7154 -- presence of NOT operators will be handled properly when we call
7155 -- Get_Current_Value_Condition.
7157 while Nkind (Cond) = N_Op_Not loop
7158 Cond := Right_Opnd (Cond);
7161 -- For an AND or AND THEN, recursively process operands
7163 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
7164 Set_Expression_Current_Value (Left_Opnd (Cond));
7165 Set_Expression_Current_Value (Right_Opnd (Cond));
7169 -- Check possible relational operator
7171 if Nkind (Cond) in N_Op_Compare then
7172 if Compile_Time_Known_Value (Right_Opnd (Cond)) then
7173 Set_Entity_Current_Value (Left_Opnd (Cond));
7174 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
7175 Set_Entity_Current_Value (Right_Opnd (Cond));
7178 -- Check possible boolean variable reference
7181 Set_Entity_Current_Value (Cond);
7183 end Set_Expression_Current_Value;
7185 -- Start of processing for Set_Current_Value_Condition
7188 Set_Expression_Current_Value (Condition (Cnode));
7189 end Set_Current_Value_Condition;
7191 --------------------------
7192 -- Set_Elaboration_Flag --
7193 --------------------------
7195 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
7196 Loc : constant Source_Ptr := Sloc (N);
7197 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
7201 if Present (Ent) then
7203 -- Nothing to do if at the compilation unit level, because in this
7204 -- case the flag is set by the binder generated elaboration routine.
7206 if Nkind (Parent (N)) = N_Compilation_Unit then
7209 -- Here we do need to generate an assignment statement
7212 Check_Restriction (No_Elaboration_Code, N);
7214 Make_Assignment_Statement (Loc,
7215 Name => New_Occurrence_Of (Ent, Loc),
7216 Expression => Make_Integer_Literal (Loc, Uint_1));
7218 if Nkind (Parent (N)) = N_Subunit then
7219 Insert_After (Corresponding_Stub (Parent (N)), Asn);
7221 Insert_After (N, Asn);
7226 -- Kill current value indication. This is necessary because the
7227 -- tests of this flag are inserted out of sequence and must not
7228 -- pick up bogus indications of the wrong constant value.
7230 Set_Current_Value (Ent, Empty);
7233 end Set_Elaboration_Flag;
7235 ----------------------------
7236 -- Set_Renamed_Subprogram --
7237 ----------------------------
7239 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
7241 -- If input node is an identifier, we can just reset it
7243 if Nkind (N) = N_Identifier then
7244 Set_Chars (N, Chars (E));
7247 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
7251 CS : constant Boolean := Comes_From_Source (N);
7253 Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
7255 Set_Comes_From_Source (N, CS);
7256 Set_Analyzed (N, True);
7259 end Set_Renamed_Subprogram;
7261 ----------------------------------
7262 -- Silly_Boolean_Array_Not_Test --
7263 ----------------------------------
7265 -- This procedure implements an odd and silly test. We explicitly check
7266 -- for the case where the 'First of the component type is equal to the
7267 -- 'Last of this component type, and if this is the case, we make sure
7268 -- that constraint error is raised. The reason is that the NOT is bound
7269 -- to cause CE in this case, and we will not otherwise catch it.
7271 -- No such check is required for AND and OR, since for both these cases
7272 -- False op False = False, and True op True = True. For the XOR case,
7273 -- see Silly_Boolean_Array_Xor_Test.
7275 -- Believe it or not, this was reported as a bug. Note that nearly always,
7276 -- the test will evaluate statically to False, so the code will be
7277 -- statically removed, and no extra overhead caused.
7279 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
7280 Loc : constant Source_Ptr := Sloc (N);
7281 CT : constant Entity_Id := Component_Type (T);
7284 -- The check we install is
7286 -- constraint_error when
7287 -- component_type'first = component_type'last
7288 -- and then array_type'Length /= 0)
7290 -- We need the last guard because we don't want to raise CE for empty
7291 -- arrays since no out of range values result. (Empty arrays with a
7292 -- component type of True .. True -- very useful -- even the ACATS
7293 -- does not test that marginal case!)
7296 Make_Raise_Constraint_Error (Loc,
7302 Make_Attribute_Reference (Loc,
7303 Prefix => New_Occurrence_Of (CT, Loc),
7304 Attribute_Name => Name_First),
7307 Make_Attribute_Reference (Loc,
7308 Prefix => New_Occurrence_Of (CT, Loc),
7309 Attribute_Name => Name_Last)),
7311 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
7312 Reason => CE_Range_Check_Failed));
7313 end Silly_Boolean_Array_Not_Test;
7315 ----------------------------------
7316 -- Silly_Boolean_Array_Xor_Test --
7317 ----------------------------------
7319 -- This procedure implements an odd and silly test. We explicitly check
7320 -- for the XOR case where the component type is True .. True, since this
7321 -- will raise constraint error. A special check is required since CE
7322 -- will not be generated otherwise (cf Expand_Packed_Not).
7324 -- No such check is required for AND and OR, since for both these cases
7325 -- False op False = False, and True op True = True, and no check is
7326 -- required for the case of False .. False, since False xor False = False.
7327 -- See also Silly_Boolean_Array_Not_Test
7329 procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is
7330 Loc : constant Source_Ptr := Sloc (N);
7331 CT : constant Entity_Id := Component_Type (T);
7334 -- The check we install is
7336 -- constraint_error when
7337 -- Boolean (component_type'First)
7338 -- and then Boolean (component_type'Last)
7339 -- and then array_type'Length /= 0)
7341 -- We need the last guard because we don't want to raise CE for empty
7342 -- arrays since no out of range values result (Empty arrays with a
7343 -- component type of True .. True -- very useful -- even the ACATS
7344 -- does not test that marginal case!).
7347 Make_Raise_Constraint_Error (Loc,
7353 Convert_To (Standard_Boolean,
7354 Make_Attribute_Reference (Loc,
7355 Prefix => New_Occurrence_Of (CT, Loc),
7356 Attribute_Name => Name_First)),
7359 Convert_To (Standard_Boolean,
7360 Make_Attribute_Reference (Loc,
7361 Prefix => New_Occurrence_Of (CT, Loc),
7362 Attribute_Name => Name_Last))),
7364 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
7365 Reason => CE_Range_Check_Failed));
7366 end Silly_Boolean_Array_Xor_Test;
7368 --------------------------
7369 -- Target_Has_Fixed_Ops --
7370 --------------------------
7372 Integer_Sized_Small : Ureal;
7373 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
7374 -- called (we don't want to compute it more than once!)
7376 Long_Integer_Sized_Small : Ureal;
7377 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
7378 -- is called (we don't want to compute it more than once)
7380 First_Time_For_THFO : Boolean := True;
7381 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
7383 function Target_Has_Fixed_Ops
7384 (Left_Typ : Entity_Id;
7385 Right_Typ : Entity_Id;
7386 Result_Typ : Entity_Id) return Boolean
7388 function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
7389 -- Return True if the given type is a fixed-point type with a small
7390 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
7391 -- an absolute value less than 1.0. This is currently limited to
7392 -- fixed-point types that map to Integer or Long_Integer.
7394 ------------------------
7395 -- Is_Fractional_Type --
7396 ------------------------
7398 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
7400 if Esize (Typ) = Standard_Integer_Size then
7401 return Small_Value (Typ) = Integer_Sized_Small;
7403 elsif Esize (Typ) = Standard_Long_Integer_Size then
7404 return Small_Value (Typ) = Long_Integer_Sized_Small;
7409 end Is_Fractional_Type;
7411 -- Start of processing for Target_Has_Fixed_Ops
7414 -- Return False if Fractional_Fixed_Ops_On_Target is false
7416 if not Fractional_Fixed_Ops_On_Target then
7420 -- Here the target has Fractional_Fixed_Ops, if first time, compute
7421 -- standard constants used by Is_Fractional_Type.
7423 if First_Time_For_THFO then
7424 First_Time_For_THFO := False;
7426 Integer_Sized_Small :=
7429 Den => UI_From_Int (Standard_Integer_Size - 1),
7432 Long_Integer_Sized_Small :=
7435 Den => UI_From_Int (Standard_Long_Integer_Size - 1),
7439 -- Return True if target supports fixed-by-fixed multiply/divide for
7440 -- fractional fixed-point types (see Is_Fractional_Type) and the operand
7441 -- and result types are equivalent fractional types.
7443 return Is_Fractional_Type (Base_Type (Left_Typ))
7444 and then Is_Fractional_Type (Base_Type (Right_Typ))
7445 and then Is_Fractional_Type (Base_Type (Result_Typ))
7446 and then Esize (Left_Typ) = Esize (Right_Typ)
7447 and then Esize (Left_Typ) = Esize (Result_Typ);
7448 end Target_Has_Fixed_Ops;
7450 ------------------------------------------
7451 -- Type_May_Have_Bit_Aligned_Components --
7452 ------------------------------------------
7454 function Type_May_Have_Bit_Aligned_Components
7455 (Typ : Entity_Id) return Boolean
7458 -- Array type, check component type
7460 if Is_Array_Type (Typ) then
7462 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
7464 -- Record type, check components
7466 elsif Is_Record_Type (Typ) then
7471 E := First_Component_Or_Discriminant (Typ);
7472 while Present (E) loop
7473 if Component_May_Be_Bit_Aligned (E)
7474 or else Type_May_Have_Bit_Aligned_Components (Etype (E))
7479 Next_Component_Or_Discriminant (E);
7485 -- Type other than array or record is always OK
7490 end Type_May_Have_Bit_Aligned_Components;
7492 ----------------------------
7493 -- Wrap_Cleanup_Procedure --
7494 ----------------------------
7496 procedure Wrap_Cleanup_Procedure (N : Node_Id) is
7497 Loc : constant Source_Ptr := Sloc (N);
7498 Stseq : constant Node_Id := Handled_Statement_Sequence (N);
7499 Stmts : constant List_Id := Statements (Stseq);
7502 if Abort_Allowed then
7503 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7504 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7506 end Wrap_Cleanup_Procedure;