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 -- Adjust_Condition --
165 ----------------------
167 procedure Adjust_Condition (N : Node_Id) is
174 Loc : constant Source_Ptr := Sloc (N);
175 T : constant Entity_Id := Etype (N);
179 -- Defend against a call where the argument has no type, or has a
180 -- type that is not Boolean. This can occur because of prior errors.
182 if No (T) or else not Is_Boolean_Type (T) then
186 -- Apply validity checking if needed
188 if Validity_Checks_On and Validity_Check_Tests then
192 -- Immediate return if standard boolean, the most common case,
193 -- where nothing needs to be done.
195 if Base_Type (T) = Standard_Boolean then
199 -- Case of zero/non-zero semantics or non-standard enumeration
200 -- representation. In each case, we rewrite the node as:
202 -- ityp!(N) /= False'Enum_Rep
204 -- where ityp is an integer type with large enough size to hold any
207 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
208 if Esize (T) <= Esize (Standard_Integer) then
209 Ti := Standard_Integer;
211 Ti := Standard_Long_Long_Integer;
216 Left_Opnd => Unchecked_Convert_To (Ti, N),
218 Make_Attribute_Reference (Loc,
219 Attribute_Name => Name_Enum_Rep,
221 New_Occurrence_Of (First_Literal (T), Loc))));
222 Analyze_And_Resolve (N, Standard_Boolean);
225 Rewrite (N, Convert_To (Standard_Boolean, N));
226 Analyze_And_Resolve (N, Standard_Boolean);
229 end Adjust_Condition;
231 ------------------------
232 -- Adjust_Result_Type --
233 ------------------------
235 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
237 -- Ignore call if current type is not Standard.Boolean
239 if Etype (N) /= Standard_Boolean then
243 -- If result is already of correct type, nothing to do. Note that
244 -- this will get the most common case where everything has a type
245 -- of Standard.Boolean.
247 if Base_Type (T) = Standard_Boolean then
252 KP : constant Node_Kind := Nkind (Parent (N));
255 -- If result is to be used as a Condition in the syntax, no need
256 -- to convert it back, since if it was changed to Standard.Boolean
257 -- using Adjust_Condition, that is just fine for this usage.
259 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
262 -- If result is an operand of another logical operation, no need
263 -- to reset its type, since Standard.Boolean is just fine, and
264 -- such operations always do Adjust_Condition on their operands.
266 elsif KP in N_Op_Boolean
267 or else KP in N_Short_Circuit
268 or else KP = N_Op_Not
272 -- Otherwise we perform a conversion from the current type, which
273 -- must be Standard.Boolean, to the desired type.
277 Rewrite (N, Convert_To (T, N));
278 Analyze_And_Resolve (N, T);
282 end Adjust_Result_Type;
284 --------------------------
285 -- Append_Freeze_Action --
286 --------------------------
288 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
292 Ensure_Freeze_Node (T);
293 Fnode := Freeze_Node (T);
295 if No (Actions (Fnode)) then
296 Set_Actions (Fnode, New_List);
299 Append (N, Actions (Fnode));
300 end Append_Freeze_Action;
302 ---------------------------
303 -- Append_Freeze_Actions --
304 ---------------------------
306 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
307 Fnode : constant Node_Id := Freeze_Node (T);
314 if No (Actions (Fnode)) then
315 Set_Actions (Fnode, L);
317 Append_List (L, Actions (Fnode));
320 end Append_Freeze_Actions;
322 ------------------------------------
323 -- Build_Allocate_Deallocate_Proc --
324 ------------------------------------
326 procedure Build_Allocate_Deallocate_Proc
328 Is_Allocate : Boolean)
330 Desig_Typ : Entity_Id;
333 Proc_To_Call : Node_Id := Empty;
336 function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id;
337 -- Locate TSS primitive Finalize_Address in type Typ
339 function Find_Object (E : Node_Id) return Node_Id;
340 -- Given an arbitrary expression of an allocator, try to find an object
341 -- reference in it, otherwise return the original expression.
343 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
344 -- Determine whether subprogram Subp denotes a custom allocate or
347 ---------------------------
348 -- Find_Finalize_Address --
349 ---------------------------
351 function Find_Finalize_Address (Typ : Entity_Id) return Entity_Id is
352 Utyp : Entity_Id := Typ;
355 -- Handle protected class-wide or task class-wide types
357 if Is_Class_Wide_Type (Utyp) then
358 if Is_Concurrent_Type (Root_Type (Utyp)) then
359 Utyp := Root_Type (Utyp);
361 elsif Is_Private_Type (Root_Type (Utyp))
362 and then Present (Full_View (Root_Type (Utyp)))
363 and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
365 Utyp := Full_View (Root_Type (Utyp));
369 -- Handle private types
371 if Is_Private_Type (Utyp)
372 and then Present (Full_View (Utyp))
374 Utyp := Full_View (Utyp);
377 -- Handle protected and task types
379 if Is_Concurrent_Type (Utyp)
380 and then Present (Corresponding_Record_Type (Utyp))
382 Utyp := Corresponding_Record_Type (Utyp);
385 Utyp := Underlying_Type (Base_Type (Utyp));
387 -- Deal with non-tagged derivation of private views. If the parent is
388 -- now known to be protected, the finalization routine is the one
389 -- defined on the corresponding record of the ancestor (corresponding
390 -- records do not automatically inherit operations, but maybe they
393 if Is_Untagged_Derivation (Typ) then
394 if Is_Protected_Type (Typ) then
395 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
397 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
399 if Is_Protected_Type (Utyp) then
400 Utyp := Corresponding_Record_Type (Utyp);
405 -- If the underlying_type is a subtype, we are dealing with the
406 -- completion of a private type. We need to access the base type and
407 -- generate a conversion to it.
409 if Utyp /= Base_Type (Utyp) then
410 pragma Assert (Is_Private_Type (Typ));
412 Utyp := Base_Type (Utyp);
415 return TSS (Utyp, TSS_Finalize_Address);
416 end Find_Finalize_Address;
422 function Find_Object (E : Node_Id) return Node_Id is
426 pragma Assert (Is_Allocate);
430 if Nkind_In (Expr, N_Qualified_Expression,
431 N_Unchecked_Type_Conversion)
433 Expr := Expression (Expr);
435 elsif Nkind (Expr) = N_Explicit_Dereference then
436 Expr := Prefix (Expr);
446 ---------------------------------
447 -- Is_Allocate_Deallocate_Proc --
448 ---------------------------------
450 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
452 -- Look for a subprogram body with only one statement which is a
453 -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
455 if Ekind (Subp) = E_Procedure
456 and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
459 HSS : constant Node_Id :=
460 Handled_Statement_Sequence (Parent (Parent (Subp)));
464 if Present (Statements (HSS))
465 and then Nkind (First (Statements (HSS))) =
466 N_Procedure_Call_Statement
468 Proc := Entity (Name (First (Statements (HSS))));
471 Is_RTE (Proc, RE_Allocate_Any_Controlled)
472 or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
478 end Is_Allocate_Deallocate_Proc;
480 -- Start of processing for Build_Allocate_Deallocate_Proc
483 -- Obtain the attributes of the allocation / deallocation
485 if Nkind (N) = N_Free_Statement then
486 Expr := Expression (N);
487 Ptr_Typ := Base_Type (Etype (Expr));
488 Proc_To_Call := Procedure_To_Call (N);
491 if Nkind (N) = N_Object_Declaration then
492 Expr := Expression (N);
497 -- In certain cases an allocator with a qualified expression may
498 -- be relocated and used as the initialization expression of a
502 -- Obj : Ptr_Typ := new Desig_Typ'(...);
505 -- Tmp : Ptr_Typ := new Desig_Typ'(...);
506 -- Obj : Ptr_Typ := Tmp;
508 -- Since the allocator is always marked as analyzed to avoid infinite
509 -- expansion, it will never be processed by this routine given that
510 -- the designated type needs finalization actions. Detect this case
511 -- and complete the expansion of the allocator.
513 if Nkind (Expr) = N_Identifier
514 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
515 and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
517 Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
521 -- The allocator may have been rewritten into something else in which
522 -- case the expansion performed by this routine does not apply.
524 if Nkind (Expr) /= N_Allocator then
528 Ptr_Typ := Base_Type (Etype (Expr));
529 Proc_To_Call := Procedure_To_Call (Expr);
532 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
533 Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
535 -- Handle concurrent types
537 if Is_Concurrent_Type (Desig_Typ)
538 and then Present (Corresponding_Record_Type (Desig_Typ))
540 Desig_Typ := Corresponding_Record_Type (Desig_Typ);
543 -- Do not process allocations / deallocations without a pool
548 -- Do not process allocations on / deallocations from the secondary
551 elsif Is_RTE (Pool_Id, RE_SS_Pool) then
554 -- Do not replicate the machinery if the allocator / free has already
555 -- been expanded and has a custom Allocate / Deallocate.
557 elsif Present (Proc_To_Call)
558 and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
563 if Needs_Finalization (Desig_Typ) then
565 -- Certain run-time configurations and targets do not provide support
566 -- for controlled types.
568 if Restriction_Active (No_Finalization) then
571 -- Do nothing if the access type may never allocate / deallocate
574 elsif No_Pool_Assigned (Ptr_Typ) then
577 -- Access-to-controlled types are not supported on .NET/JVM since
578 -- these targets cannot support pools and address arithmetic.
580 elsif VM_Target /= No_VM then
584 -- The allocation / deallocation of a controlled object must be
585 -- chained on / detached from a finalization master.
587 pragma Assert (Present (Finalization_Master (Ptr_Typ)));
589 -- The only other kind of allocation / deallocation supported by this
590 -- routine is on / from a subpool.
592 elsif Nkind (Expr) = N_Allocator
593 and then No (Subpool_Handle_Name (Expr))
599 Loc : constant Source_Ptr := Sloc (N);
600 Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
601 Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
602 Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
603 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
606 Fin_Addr_Id : Entity_Id;
607 Fin_Mas_Act : Node_Id;
608 Fin_Mas_Id : Entity_Id;
609 Proc_To_Call : Entity_Id;
610 Subpool : Node_Id := Empty;
613 -- Step 1: Construct all the actuals for the call to library routine
614 -- Allocate_Any_Controlled / Deallocate_Any_Controlled.
618 Actuals := New_List (New_Reference_To (Pool_Id, Loc));
624 if Nkind (Expr) = N_Allocator then
625 Subpool := Subpool_Handle_Name (Expr);
628 if Present (Subpool) then
629 Append_To (Actuals, New_Reference_To (Entity (Subpool), Loc));
631 Append_To (Actuals, Make_Null (Loc));
634 -- c) Finalization master
636 if Needs_Finalization (Desig_Typ) then
637 Fin_Mas_Id := Finalization_Master (Ptr_Typ);
638 Fin_Mas_Act := New_Reference_To (Fin_Mas_Id, Loc);
640 -- Handle the case where the master is actually a pointer to a
641 -- master. This case arises in build-in-place functions.
643 if Is_Access_Type (Etype (Fin_Mas_Id)) then
644 Append_To (Actuals, Fin_Mas_Act);
647 Make_Attribute_Reference (Loc,
648 Prefix => Fin_Mas_Act,
649 Attribute_Name => Name_Unrestricted_Access));
652 Append_To (Actuals, Make_Null (Loc));
655 -- d) Finalize_Address
657 -- Primitive Finalize_Address is never generated in CodePeer mode
658 -- since it contains an Unchecked_Conversion.
660 if Needs_Finalization (Desig_Typ)
661 and then not CodePeer_Mode
663 Fin_Addr_Id := Find_Finalize_Address (Desig_Typ);
664 pragma Assert (Present (Fin_Addr_Id));
667 Make_Attribute_Reference (Loc,
668 Prefix => New_Reference_To (Fin_Addr_Id, Loc),
669 Attribute_Name => Name_Unrestricted_Access));
671 Append_To (Actuals, Make_Null (Loc));
679 Append_To (Actuals, New_Reference_To (Addr_Id, Loc));
680 Append_To (Actuals, New_Reference_To (Size_Id, Loc));
681 Append_To (Actuals, New_Reference_To (Alig_Id, Loc));
685 -- Generate a run-time check to determine whether a class-wide object
686 -- is truly controlled.
688 if Needs_Finalization (Desig_Typ) then
689 if Is_Class_Wide_Type (Desig_Typ)
690 or else Is_Generic_Actual_Type (Desig_Typ)
693 Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
700 Temp := Find_Object (Expression (Expr));
705 -- Processing for generic actuals
707 if Is_Generic_Actual_Type (Desig_Typ) then
709 New_Reference_To (Boolean_Literals
710 (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
712 -- Processing for subtype indications
714 elsif Nkind (Temp) in N_Has_Entity
715 and then Is_Type (Entity (Temp))
718 New_Reference_To (Boolean_Literals
719 (Needs_Finalization (Entity (Temp))), Loc);
721 -- Generate a runtime check to test the controlled state of
722 -- an object for the purposes of allocation / deallocation.
725 -- The following case arises when allocating through an
726 -- interface class-wide type, generate:
730 if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
732 Make_Explicit_Dereference (Loc,
734 Relocate_Node (Temp));
741 Make_Attribute_Reference (Loc,
743 Relocate_Node (Temp),
744 Attribute_Name => Name_Tag);
748 -- Needs_Finalization (<Param>)
751 Make_Function_Call (Loc,
753 New_Reference_To (RTE (RE_Needs_Finalization), Loc),
754 Parameter_Associations => New_List (Param));
757 -- Create the temporary which represents the finalization
758 -- state of the expression. Generate:
760 -- F : constant Boolean := <Flag_Expr>;
763 Make_Object_Declaration (Loc,
764 Defining_Identifier => Flag_Id,
765 Constant_Present => True,
767 New_Reference_To (Standard_Boolean, Loc),
768 Expression => Flag_Expr));
770 -- The flag acts as the last actual
772 Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
775 -- The object is statically known to be controlled
778 Append_To (Actuals, New_Reference_To (Standard_True, Loc));
781 Append_To (Actuals, New_Reference_To (Standard_False, Loc));
788 New_Reference_To (Boolean_Literals (Present (Subpool)), Loc));
791 -- Step 2: Build a wrapper Allocate / Deallocate which internally
792 -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
794 -- Select the proper routine to call
797 Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
799 Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
802 -- Create a custom Allocate / Deallocate routine which has identical
803 -- profile to that of System.Storage_Pools.
806 Make_Subprogram_Body (Loc,
811 Make_Procedure_Specification (Loc,
812 Defining_Unit_Name => Proc_Id,
813 Parameter_Specifications => New_List (
815 -- P : Root_Storage_Pool
817 Make_Parameter_Specification (Loc,
818 Defining_Identifier =>
819 Make_Temporary (Loc, 'P'),
821 New_Reference_To (RTE (RE_Root_Storage_Pool), Loc)),
825 Make_Parameter_Specification (Loc,
826 Defining_Identifier => Addr_Id,
827 Out_Present => Is_Allocate,
829 New_Reference_To (RTE (RE_Address), Loc)),
833 Make_Parameter_Specification (Loc,
834 Defining_Identifier => Size_Id,
836 New_Reference_To (RTE (RE_Storage_Count), Loc)),
840 Make_Parameter_Specification (Loc,
841 Defining_Identifier => Alig_Id,
843 New_Reference_To (RTE (RE_Storage_Count), Loc)))),
845 Declarations => No_List,
847 Handled_Statement_Sequence =>
848 Make_Handled_Sequence_Of_Statements (Loc,
849 Statements => New_List (
850 Make_Procedure_Call_Statement (Loc,
852 New_Reference_To (Proc_To_Call, Loc),
853 Parameter_Associations => Actuals)))));
855 -- The newly generated Allocate / Deallocate becomes the default
856 -- procedure to call when the back end processes the allocation /
860 Set_Procedure_To_Call (Expr, Proc_Id);
862 Set_Procedure_To_Call (N, Proc_Id);
865 end Build_Allocate_Deallocate_Proc;
867 ------------------------
868 -- Build_Runtime_Call --
869 ------------------------
871 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
873 -- If entity is not available, we can skip making the call (this avoids
874 -- junk duplicated error messages in a number of cases).
876 if not RTE_Available (RE) then
877 return Make_Null_Statement (Loc);
880 Make_Procedure_Call_Statement (Loc,
881 Name => New_Reference_To (RTE (RE), Loc));
883 end Build_Runtime_Call;
885 ----------------------------
886 -- Build_Task_Array_Image --
887 ----------------------------
889 -- This function generates the body for a function that constructs the
890 -- image string for a task that is an array component. The function is
891 -- local to the init proc for the array type, and is called for each one
892 -- of the components. The constructed image has the form of an indexed
893 -- component, whose prefix is the outer variable of the array type.
894 -- The n-dimensional array type has known indexes Index, Index2...
896 -- Id_Ref is an indexed component form created by the enclosing init proc.
897 -- Its successive indexes are Val1, Val2, ... which are the loop variables
898 -- in the loops that call the individual task init proc on each component.
900 -- The generated function has the following structure:
902 -- function F return String is
903 -- Pref : string renames Task_Name;
904 -- T1 : String := Index1'Image (Val1);
906 -- Tn : String := indexn'image (Valn);
907 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
908 -- -- Len includes commas and the end parentheses.
909 -- Res : String (1..Len);
910 -- Pos : Integer := Pref'Length;
913 -- Res (1 .. Pos) := Pref;
917 -- Res (Pos .. Pos + T1'Length - 1) := T1;
918 -- Pos := Pos + T1'Length;
922 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
928 -- Needless to say, multidimensional arrays of tasks are rare enough that
929 -- the bulkiness of this code is not really a concern.
931 function Build_Task_Array_Image
935 Dyn : Boolean := False) return Node_Id
937 Dims : constant Nat := Number_Dimensions (A_Type);
938 -- Number of dimensions for array of tasks
940 Temps : array (1 .. Dims) of Entity_Id;
941 -- Array of temporaries to hold string for each index
947 -- Total length of generated name
950 -- Running index for substring assignments
952 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
953 -- Name of enclosing variable, prefix of resulting name
956 -- String to hold result
959 -- Value of successive indexes
962 -- Expression to compute total size of string
965 -- Entity for name at one index position
967 Decls : constant List_Id := New_List;
968 Stats : constant List_Id := New_List;
971 -- For a dynamic task, the name comes from the target variable. For a
972 -- static one it is a formal of the enclosing init proc.
975 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
977 Make_Object_Declaration (Loc,
978 Defining_Identifier => Pref,
979 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
981 Make_String_Literal (Loc,
982 Strval => String_From_Name_Buffer)));
986 Make_Object_Renaming_Declaration (Loc,
987 Defining_Identifier => Pref,
988 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
989 Name => Make_Identifier (Loc, Name_uTask_Name)));
992 Indx := First_Index (A_Type);
993 Val := First (Expressions (Id_Ref));
995 for J in 1 .. Dims loop
996 T := Make_Temporary (Loc, 'T');
1000 Make_Object_Declaration (Loc,
1001 Defining_Identifier => T,
1002 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1004 Make_Attribute_Reference (Loc,
1005 Attribute_Name => Name_Image,
1006 Prefix => New_Occurrence_Of (Etype (Indx), Loc),
1007 Expressions => New_List (New_Copy_Tree (Val)))));
1013 Sum := Make_Integer_Literal (Loc, Dims + 1);
1019 Make_Attribute_Reference (Loc,
1020 Attribute_Name => Name_Length,
1022 New_Occurrence_Of (Pref, Loc),
1023 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1025 for J in 1 .. Dims loop
1030 Make_Attribute_Reference (Loc,
1031 Attribute_Name => Name_Length,
1033 New_Occurrence_Of (Temps (J), Loc),
1034 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1037 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
1039 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
1042 Make_Assignment_Statement (Loc,
1043 Name => Make_Indexed_Component (Loc,
1044 Prefix => New_Occurrence_Of (Res, Loc),
1045 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1047 Make_Character_Literal (Loc,
1049 Char_Literal_Value =>
1050 UI_From_Int (Character'Pos ('(')))));
1053 Make_Assignment_Statement (Loc,
1054 Name => New_Occurrence_Of (Pos, Loc),
1057 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1058 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1060 for J in 1 .. Dims loop
1063 Make_Assignment_Statement (Loc,
1064 Name => Make_Slice (Loc,
1065 Prefix => New_Occurrence_Of (Res, Loc),
1068 Low_Bound => New_Occurrence_Of (Pos, Loc),
1069 High_Bound => Make_Op_Subtract (Loc,
1072 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1074 Make_Attribute_Reference (Loc,
1075 Attribute_Name => Name_Length,
1077 New_Occurrence_Of (Temps (J), Loc),
1079 New_List (Make_Integer_Literal (Loc, 1)))),
1080 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
1082 Expression => New_Occurrence_Of (Temps (J), Loc)));
1086 Make_Assignment_Statement (Loc,
1087 Name => New_Occurrence_Of (Pos, Loc),
1090 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1092 Make_Attribute_Reference (Loc,
1093 Attribute_Name => Name_Length,
1094 Prefix => New_Occurrence_Of (Temps (J), Loc),
1096 New_List (Make_Integer_Literal (Loc, 1))))));
1098 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
1101 Make_Assignment_Statement (Loc,
1102 Name => Make_Indexed_Component (Loc,
1103 Prefix => New_Occurrence_Of (Res, Loc),
1104 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1106 Make_Character_Literal (Loc,
1108 Char_Literal_Value =>
1109 UI_From_Int (Character'Pos (',')))));
1112 Make_Assignment_Statement (Loc,
1113 Name => New_Occurrence_Of (Pos, Loc),
1116 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1117 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1121 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
1124 Make_Assignment_Statement (Loc,
1125 Name => Make_Indexed_Component (Loc,
1126 Prefix => New_Occurrence_Of (Res, Loc),
1127 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
1129 Make_Character_Literal (Loc,
1131 Char_Literal_Value =>
1132 UI_From_Int (Character'Pos (')')))));
1133 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
1134 end Build_Task_Array_Image;
1136 ----------------------------
1137 -- Build_Task_Image_Decls --
1138 ----------------------------
1140 function Build_Task_Image_Decls
1144 In_Init_Proc : Boolean := False) return List_Id
1146 Decls : constant List_Id := New_List;
1147 T_Id : Entity_Id := Empty;
1149 Expr : Node_Id := Empty;
1150 Fun : Node_Id := Empty;
1151 Is_Dyn : constant Boolean :=
1152 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
1154 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
1157 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
1158 -- generate a dummy declaration only.
1160 if Restriction_Active (No_Implicit_Heap_Allocations)
1161 or else Global_Discard_Names
1163 T_Id := Make_Temporary (Loc, 'J');
1168 Make_Object_Declaration (Loc,
1169 Defining_Identifier => T_Id,
1170 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1172 Make_String_Literal (Loc,
1173 Strval => String_From_Name_Buffer)));
1176 if Nkind (Id_Ref) = N_Identifier
1177 or else Nkind (Id_Ref) = N_Defining_Identifier
1179 -- For a simple variable, the image of the task is built from
1180 -- the name of the variable. To avoid possible conflict with the
1181 -- anonymous type created for a single protected object, add a
1185 Make_Defining_Identifier (Loc,
1186 New_External_Name (Chars (Id_Ref), 'T', 1));
1188 Get_Name_String (Chars (Id_Ref));
1191 Make_String_Literal (Loc,
1192 Strval => String_From_Name_Buffer);
1194 elsif Nkind (Id_Ref) = N_Selected_Component then
1196 Make_Defining_Identifier (Loc,
1197 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
1198 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
1200 elsif Nkind (Id_Ref) = N_Indexed_Component then
1202 Make_Defining_Identifier (Loc,
1203 New_External_Name (Chars (A_Type), 'N'));
1205 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
1209 if Present (Fun) then
1210 Append (Fun, Decls);
1211 Expr := Make_Function_Call (Loc,
1212 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
1214 if not In_Init_Proc and then VM_Target = No_VM then
1215 Set_Uses_Sec_Stack (Defining_Entity (Fun));
1219 Decl := Make_Object_Declaration (Loc,
1220 Defining_Identifier => T_Id,
1221 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1222 Constant_Present => True,
1223 Expression => Expr);
1225 Append (Decl, Decls);
1227 end Build_Task_Image_Decls;
1229 -------------------------------
1230 -- Build_Task_Image_Function --
1231 -------------------------------
1233 function Build_Task_Image_Function
1237 Res : Entity_Id) return Node_Id
1243 Make_Simple_Return_Statement (Loc,
1244 Expression => New_Occurrence_Of (Res, Loc)));
1246 Spec := Make_Function_Specification (Loc,
1247 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
1248 Result_Definition => New_Occurrence_Of (Standard_String, Loc));
1250 -- Calls to 'Image use the secondary stack, which must be cleaned up
1251 -- after the task name is built.
1253 return Make_Subprogram_Body (Loc,
1254 Specification => Spec,
1255 Declarations => Decls,
1256 Handled_Statement_Sequence =>
1257 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
1258 end Build_Task_Image_Function;
1260 -----------------------------
1261 -- Build_Task_Image_Prefix --
1262 -----------------------------
1264 procedure Build_Task_Image_Prefix
1266 Len : out Entity_Id;
1267 Res : out Entity_Id;
1268 Pos : out Entity_Id;
1275 Len := Make_Temporary (Loc, 'L', Sum);
1278 Make_Object_Declaration (Loc,
1279 Defining_Identifier => Len,
1280 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
1281 Expression => Sum));
1283 Res := Make_Temporary (Loc, 'R');
1286 Make_Object_Declaration (Loc,
1287 Defining_Identifier => Res,
1288 Object_Definition =>
1289 Make_Subtype_Indication (Loc,
1290 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1292 Make_Index_Or_Discriminant_Constraint (Loc,
1296 Low_Bound => Make_Integer_Literal (Loc, 1),
1297 High_Bound => New_Occurrence_Of (Len, Loc)))))));
1299 Pos := Make_Temporary (Loc, 'P');
1302 Make_Object_Declaration (Loc,
1303 Defining_Identifier => Pos,
1304 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
1306 -- Pos := Prefix'Length;
1309 Make_Assignment_Statement (Loc,
1310 Name => New_Occurrence_Of (Pos, Loc),
1312 Make_Attribute_Reference (Loc,
1313 Attribute_Name => Name_Length,
1314 Prefix => New_Occurrence_Of (Prefix, Loc),
1315 Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
1317 -- Res (1 .. Pos) := Prefix;
1320 Make_Assignment_Statement (Loc,
1323 Prefix => New_Occurrence_Of (Res, Loc),
1326 Low_Bound => Make_Integer_Literal (Loc, 1),
1327 High_Bound => New_Occurrence_Of (Pos, Loc))),
1329 Expression => New_Occurrence_Of (Prefix, Loc)));
1332 Make_Assignment_Statement (Loc,
1333 Name => New_Occurrence_Of (Pos, Loc),
1336 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1337 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1338 end Build_Task_Image_Prefix;
1340 -----------------------------
1341 -- Build_Task_Record_Image --
1342 -----------------------------
1344 function Build_Task_Record_Image
1347 Dyn : Boolean := False) return Node_Id
1350 -- Total length of generated name
1353 -- Index into result
1356 -- String to hold result
1358 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
1359 -- Name of enclosing variable, prefix of resulting name
1362 -- Expression to compute total size of string
1365 -- Entity for selector name
1367 Decls : constant List_Id := New_List;
1368 Stats : constant List_Id := New_List;
1371 -- For a dynamic task, the name comes from the target variable. For a
1372 -- static one it is a formal of the enclosing init proc.
1375 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
1377 Make_Object_Declaration (Loc,
1378 Defining_Identifier => Pref,
1379 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1381 Make_String_Literal (Loc,
1382 Strval => String_From_Name_Buffer)));
1386 Make_Object_Renaming_Declaration (Loc,
1387 Defining_Identifier => Pref,
1388 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1389 Name => Make_Identifier (Loc, Name_uTask_Name)));
1392 Sel := Make_Temporary (Loc, 'S');
1394 Get_Name_String (Chars (Selector_Name (Id_Ref)));
1397 Make_Object_Declaration (Loc,
1398 Defining_Identifier => Sel,
1399 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1401 Make_String_Literal (Loc,
1402 Strval => String_From_Name_Buffer)));
1404 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
1410 Make_Attribute_Reference (Loc,
1411 Attribute_Name => Name_Length,
1413 New_Occurrence_Of (Pref, Loc),
1414 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1416 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
1418 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
1420 -- Res (Pos) := '.';
1423 Make_Assignment_Statement (Loc,
1424 Name => Make_Indexed_Component (Loc,
1425 Prefix => New_Occurrence_Of (Res, Loc),
1426 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1428 Make_Character_Literal (Loc,
1430 Char_Literal_Value =>
1431 UI_From_Int (Character'Pos ('.')))));
1434 Make_Assignment_Statement (Loc,
1435 Name => New_Occurrence_Of (Pos, Loc),
1438 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1439 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1441 -- Res (Pos .. Len) := Selector;
1444 Make_Assignment_Statement (Loc,
1445 Name => Make_Slice (Loc,
1446 Prefix => New_Occurrence_Of (Res, Loc),
1449 Low_Bound => New_Occurrence_Of (Pos, Loc),
1450 High_Bound => New_Occurrence_Of (Len, Loc))),
1451 Expression => New_Occurrence_Of (Sel, Loc)));
1453 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
1454 end Build_Task_Record_Image;
1456 ----------------------------------
1457 -- Component_May_Be_Bit_Aligned --
1458 ----------------------------------
1460 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
1464 -- If no component clause, then everything is fine, since the back end
1465 -- never bit-misaligns by default, even if there is a pragma Packed for
1468 if No (Comp) or else No (Component_Clause (Comp)) then
1472 UT := Underlying_Type (Etype (Comp));
1474 -- It is only array and record types that cause trouble
1476 if not Is_Record_Type (UT)
1477 and then not Is_Array_Type (UT)
1481 -- If we know that we have a small (64 bits or less) record or small
1482 -- bit-packed array, then everything is fine, since the back end can
1483 -- handle these cases correctly.
1485 elsif Esize (Comp) <= 64
1486 and then (Is_Record_Type (UT)
1487 or else Is_Bit_Packed_Array (UT))
1491 -- Otherwise if the component is not byte aligned, we know we have the
1492 -- nasty unaligned case.
1494 elsif Normalized_First_Bit (Comp) /= Uint_0
1495 or else Esize (Comp) mod System_Storage_Unit /= Uint_0
1499 -- If we are large and byte aligned, then OK at this level
1504 end Component_May_Be_Bit_Aligned;
1506 -----------------------------------
1507 -- Corresponding_Runtime_Package --
1508 -----------------------------------
1510 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
1511 Pkg_Id : RTU_Id := RTU_Null;
1514 pragma Assert (Is_Concurrent_Type (Typ));
1516 if Ekind (Typ) in Protected_Kind then
1517 if Has_Entries (Typ)
1518 or else Has_Interrupt_Handler (Typ)
1519 or else (Has_Attach_Handler (Typ)
1520 and then not Restricted_Profile)
1522 -- A protected type without entries that covers an interface and
1523 -- overrides the abstract routines with protected procedures is
1524 -- considered equivalent to a protected type with entries in the
1525 -- context of dispatching select statements. It is sufficient to
1526 -- check for the presence of an interface list in the declaration
1527 -- node to recognize this case.
1529 or else Present (Interface_List (Parent (Typ)))
1532 or else Restriction_Active (No_Entry_Queue) = False
1533 or else Number_Entries (Typ) > 1
1534 or else (Has_Attach_Handler (Typ)
1535 and then not Restricted_Profile)
1537 Pkg_Id := System_Tasking_Protected_Objects_Entries;
1539 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
1543 Pkg_Id := System_Tasking_Protected_Objects;
1548 end Corresponding_Runtime_Package;
1550 -------------------------------
1551 -- Convert_To_Actual_Subtype --
1552 -------------------------------
1554 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
1558 Act_ST := Get_Actual_Subtype (Exp);
1560 if Act_ST = Etype (Exp) then
1565 Convert_To (Act_ST, Relocate_Node (Exp)));
1566 Analyze_And_Resolve (Exp, Act_ST);
1568 end Convert_To_Actual_Subtype;
1570 -----------------------------------
1571 -- Current_Sem_Unit_Declarations --
1572 -----------------------------------
1574 function Current_Sem_Unit_Declarations return List_Id is
1575 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
1579 -- If the current unit is a package body, locate the visible
1580 -- declarations of the package spec.
1582 if Nkind (U) = N_Package_Body then
1583 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
1586 if Nkind (U) = N_Package_Declaration then
1587 U := Specification (U);
1588 Decls := Visible_Declarations (U);
1592 Set_Visible_Declarations (U, Decls);
1596 Decls := Declarations (U);
1600 Set_Declarations (U, Decls);
1605 end Current_Sem_Unit_Declarations;
1607 -----------------------
1608 -- Duplicate_Subexpr --
1609 -----------------------
1611 function Duplicate_Subexpr
1613 Name_Req : Boolean := False) return Node_Id
1616 Remove_Side_Effects (Exp, Name_Req);
1617 return New_Copy_Tree (Exp);
1618 end Duplicate_Subexpr;
1620 ---------------------------------
1621 -- Duplicate_Subexpr_No_Checks --
1622 ---------------------------------
1624 function Duplicate_Subexpr_No_Checks
1626 Name_Req : Boolean := False) return Node_Id
1631 Remove_Side_Effects (Exp, Name_Req);
1632 New_Exp := New_Copy_Tree (Exp);
1633 Remove_Checks (New_Exp);
1635 end Duplicate_Subexpr_No_Checks;
1637 -----------------------------------
1638 -- Duplicate_Subexpr_Move_Checks --
1639 -----------------------------------
1641 function Duplicate_Subexpr_Move_Checks
1643 Name_Req : Boolean := False) return Node_Id
1648 Remove_Side_Effects (Exp, Name_Req);
1649 New_Exp := New_Copy_Tree (Exp);
1650 Remove_Checks (Exp);
1652 end Duplicate_Subexpr_Move_Checks;
1654 --------------------
1655 -- Ensure_Defined --
1656 --------------------
1658 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
1662 -- An itype reference must only be created if this is a local itype, so
1663 -- that gigi can elaborate it on the proper objstack.
1666 and then Scope (Typ) = Current_Scope
1668 IR := Make_Itype_Reference (Sloc (N));
1669 Set_Itype (IR, Typ);
1670 Insert_Action (N, IR);
1674 --------------------
1675 -- Entry_Names_OK --
1676 --------------------
1678 function Entry_Names_OK return Boolean is
1681 not Restricted_Profile
1682 and then not Global_Discard_Names
1683 and then not Restriction_Active (No_Implicit_Heap_Allocations)
1684 and then not Restriction_Active (No_Local_Allocators);
1687 ---------------------
1688 -- Evolve_And_Then --
1689 ---------------------
1691 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
1697 Make_And_Then (Sloc (Cond1),
1699 Right_Opnd => Cond1);
1701 end Evolve_And_Then;
1703 --------------------
1704 -- Evolve_Or_Else --
1705 --------------------
1707 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
1713 Make_Or_Else (Sloc (Cond1),
1715 Right_Opnd => Cond1);
1719 ------------------------------
1720 -- Expand_Subtype_From_Expr --
1721 ------------------------------
1723 -- This function is applicable for both static and dynamic allocation of
1724 -- objects which are constrained by an initial expression. Basically it
1725 -- transforms an unconstrained subtype indication into a constrained one.
1727 -- The expression may also be transformed in certain cases in order to
1728 -- avoid multiple evaluation. In the static allocation case, the general
1733 -- is transformed into
1735 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1737 -- Here are the main cases :
1739 -- <if Expr is a Slice>
1740 -- Val : T ([Index_Subtype (Expr)]) := Expr;
1742 -- <elsif Expr is a String Literal>
1743 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1745 -- <elsif Expr is Constrained>
1746 -- subtype T is Type_Of_Expr
1749 -- <elsif Expr is an entity_name>
1750 -- Val : T (constraints taken from Expr) := Expr;
1753 -- type Axxx is access all T;
1754 -- Rval : Axxx := Expr'ref;
1755 -- Val : T (constraints taken from Rval) := Rval.all;
1757 -- ??? note: when the Expression is allocated in the secondary stack
1758 -- we could use it directly instead of copying it by declaring
1759 -- Val : T (...) renames Rval.all
1761 procedure Expand_Subtype_From_Expr
1763 Unc_Type : Entity_Id;
1764 Subtype_Indic : Node_Id;
1767 Loc : constant Source_Ptr := Sloc (N);
1768 Exp_Typ : constant Entity_Id := Etype (Exp);
1772 -- In general we cannot build the subtype if expansion is disabled,
1773 -- because internal entities may not have been defined. However, to
1774 -- avoid some cascaded errors, we try to continue when the expression is
1775 -- an array (or string), because it is safe to compute the bounds. It is
1776 -- in fact required to do so even in a generic context, because there
1777 -- may be constants that depend on the bounds of a string literal, both
1778 -- standard string types and more generally arrays of characters.
1780 if not Expander_Active
1781 and then (No (Etype (Exp))
1782 or else not Is_String_Type (Etype (Exp)))
1787 if Nkind (Exp) = N_Slice then
1789 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
1792 Rewrite (Subtype_Indic,
1793 Make_Subtype_Indication (Loc,
1794 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1796 Make_Index_Or_Discriminant_Constraint (Loc,
1797 Constraints => New_List
1798 (New_Reference_To (Slice_Type, Loc)))));
1800 -- This subtype indication may be used later for constraint checks
1801 -- we better make sure that if a variable was used as a bound of
1802 -- of the original slice, its value is frozen.
1804 Force_Evaluation (Low_Bound (Scalar_Range (Slice_Type)));
1805 Force_Evaluation (High_Bound (Scalar_Range (Slice_Type)));
1808 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
1809 Rewrite (Subtype_Indic,
1810 Make_Subtype_Indication (Loc,
1811 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1813 Make_Index_Or_Discriminant_Constraint (Loc,
1814 Constraints => New_List (
1815 Make_Literal_Range (Loc,
1816 Literal_Typ => Exp_Typ)))));
1818 elsif Is_Constrained (Exp_Typ)
1819 and then not Is_Class_Wide_Type (Unc_Type)
1821 if Is_Itype (Exp_Typ) then
1823 -- Within an initialization procedure, a selected component
1824 -- denotes a component of the enclosing record, and it appears as
1825 -- an actual in a call to its own initialization procedure. If
1826 -- this component depends on the outer discriminant, we must
1827 -- generate the proper actual subtype for it.
1829 if Nkind (Exp) = N_Selected_Component
1830 and then Within_Init_Proc
1833 Decl : constant Node_Id :=
1834 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
1836 if Present (Decl) then
1837 Insert_Action (N, Decl);
1838 T := Defining_Identifier (Decl);
1844 -- No need to generate a new one (new what???)
1851 T := Make_Temporary (Loc, 'T');
1854 Make_Subtype_Declaration (Loc,
1855 Defining_Identifier => T,
1856 Subtype_Indication => New_Reference_To (Exp_Typ, Loc)));
1858 -- This type is marked as an itype even though it has an explicit
1859 -- declaration since otherwise Is_Generic_Actual_Type can get
1860 -- set, resulting in the generation of spurious errors. (See
1861 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
1864 Set_Associated_Node_For_Itype (T, Exp);
1867 Rewrite (Subtype_Indic, New_Reference_To (T, Loc));
1869 -- Nothing needs to be done for private types with unknown discriminants
1870 -- if the underlying type is not an unconstrained composite type or it
1871 -- is an unchecked union.
1873 elsif Is_Private_Type (Unc_Type)
1874 and then Has_Unknown_Discriminants (Unc_Type)
1875 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
1876 or else Is_Constrained (Underlying_Type (Unc_Type))
1877 or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
1881 -- Case of derived type with unknown discriminants where the parent type
1882 -- also has unknown discriminants.
1884 elsif Is_Record_Type (Unc_Type)
1885 and then not Is_Class_Wide_Type (Unc_Type)
1886 and then Has_Unknown_Discriminants (Unc_Type)
1887 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
1889 -- Nothing to be done if no underlying record view available
1891 if No (Underlying_Record_View (Unc_Type)) then
1894 -- Otherwise use the Underlying_Record_View to create the proper
1895 -- constrained subtype for an object of a derived type with unknown
1899 Remove_Side_Effects (Exp);
1900 Rewrite (Subtype_Indic,
1901 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
1904 -- Renamings of class-wide interface types require no equivalent
1905 -- constrained type declarations because we only need to reference
1906 -- the tag component associated with the interface. The same is
1907 -- presumably true for class-wide types in general, so this test
1908 -- is broadened to include all class-wide renamings, which also
1909 -- avoids cases of unbounded recursion in Remove_Side_Effects.
1910 -- (Is this really correct, or are there some cases of class-wide
1911 -- renamings that require action in this procedure???)
1914 and then Nkind (N) = N_Object_Renaming_Declaration
1915 and then Is_Class_Wide_Type (Unc_Type)
1919 -- In Ada95 nothing to be done if the type of the expression is limited,
1920 -- because in this case the expression cannot be copied, and its use can
1921 -- only be by reference.
1923 -- In Ada2005, the context can be an object declaration whose expression
1924 -- is a function that returns in place. If the nominal subtype has
1925 -- unknown discriminants, the call still provides constraints on the
1926 -- object, and we have to create an actual subtype from it.
1928 -- If the type is class-wide, the expression is dynamically tagged and
1929 -- we do not create an actual subtype either. Ditto for an interface.
1930 -- For now this applies only if the type is immutably limited, and the
1931 -- function being called is build-in-place. This will have to be revised
1932 -- when build-in-place functions are generalized to other types.
1934 elsif Is_Immutably_Limited_Type (Exp_Typ)
1936 (Is_Class_Wide_Type (Exp_Typ)
1937 or else Is_Interface (Exp_Typ)
1938 or else not Has_Unknown_Discriminants (Exp_Typ)
1939 or else not Is_Composite_Type (Unc_Type))
1943 -- For limited objects initialized with build in place function calls,
1944 -- nothing to be done; otherwise we prematurely introduce an N_Reference
1945 -- node in the expression initializing the object, which breaks the
1946 -- circuitry that detects and adds the additional arguments to the
1949 elsif Is_Build_In_Place_Function_Call (Exp) then
1953 Remove_Side_Effects (Exp);
1954 Rewrite (Subtype_Indic,
1955 Make_Subtype_From_Expr (Exp, Unc_Type));
1957 end Expand_Subtype_From_Expr;
1959 --------------------
1960 -- Find_Init_Call --
1961 --------------------
1963 function Find_Init_Call
1965 Rep_Clause : Node_Id) return Node_Id
1967 Typ : constant Entity_Id := Etype (Var);
1969 Init_Proc : Entity_Id;
1970 -- Initialization procedure for Typ
1972 function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
1973 -- Look for init call for Var starting at From and scanning the
1974 -- enclosing list until Rep_Clause or the end of the list is reached.
1976 ----------------------------
1977 -- Find_Init_Call_In_List --
1978 ----------------------------
1980 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
1981 Init_Call : Node_Id;
1985 while Present (Init_Call) and then Init_Call /= Rep_Clause loop
1986 if Nkind (Init_Call) = N_Procedure_Call_Statement
1987 and then Is_Entity_Name (Name (Init_Call))
1988 and then Entity (Name (Init_Call)) = Init_Proc
1997 end Find_Init_Call_In_List;
1999 Init_Call : Node_Id;
2001 -- Start of processing for Find_Init_Call
2004 if not Has_Non_Null_Base_Init_Proc (Typ) then
2005 -- No init proc for the type, so obviously no call to be found
2010 Init_Proc := Base_Init_Proc (Typ);
2012 -- First scan the list containing the declaration of Var
2014 Init_Call := Find_Init_Call_In_List (From => Next (Parent (Var)));
2016 -- If not found, also look on Var's freeze actions list, if any, since
2017 -- the init call may have been moved there (case of an address clause
2018 -- applying to Var).
2020 if No (Init_Call) and then Present (Freeze_Node (Var)) then
2022 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
2028 ------------------------
2029 -- Find_Interface_ADT --
2030 ------------------------
2032 function Find_Interface_ADT
2034 Iface : Entity_Id) return Elmt_Id
2037 Typ : Entity_Id := T;
2040 pragma Assert (Is_Interface (Iface));
2042 -- Handle private types
2044 if Has_Private_Declaration (Typ)
2045 and then Present (Full_View (Typ))
2047 Typ := Full_View (Typ);
2050 -- Handle access types
2052 if Is_Access_Type (Typ) then
2053 Typ := Designated_Type (Typ);
2056 -- Handle task and protected types implementing interfaces
2058 if Is_Concurrent_Type (Typ) then
2059 Typ := Corresponding_Record_Type (Typ);
2063 (not Is_Class_Wide_Type (Typ)
2064 and then Ekind (Typ) /= E_Incomplete_Type);
2066 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
2067 return First_Elmt (Access_Disp_Table (Typ));
2071 Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
2073 and then Present (Related_Type (Node (ADT)))
2074 and then Related_Type (Node (ADT)) /= Iface
2075 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
2076 Use_Full_View => True)
2081 pragma Assert (Present (Related_Type (Node (ADT))));
2084 end Find_Interface_ADT;
2086 ------------------------
2087 -- Find_Interface_Tag --
2088 ------------------------
2090 function Find_Interface_Tag
2092 Iface : Entity_Id) return Entity_Id
2095 Found : Boolean := False;
2096 Typ : Entity_Id := T;
2098 procedure Find_Tag (Typ : Entity_Id);
2099 -- Internal subprogram used to recursively climb to the ancestors
2105 procedure Find_Tag (Typ : Entity_Id) is
2110 -- This routine does not handle the case in which the interface is an
2111 -- ancestor of Typ. That case is handled by the enclosing subprogram.
2113 pragma Assert (Typ /= Iface);
2115 -- Climb to the root type handling private types
2117 if Present (Full_View (Etype (Typ))) then
2118 if Full_View (Etype (Typ)) /= Typ then
2119 Find_Tag (Full_View (Etype (Typ)));
2122 elsif Etype (Typ) /= Typ then
2123 Find_Tag (Etype (Typ));
2126 -- Traverse the list of interfaces implemented by the type
2129 and then Present (Interfaces (Typ))
2130 and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
2132 -- Skip the tag associated with the primary table
2134 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
2135 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
2136 pragma Assert (Present (AI_Tag));
2138 AI_Elmt := First_Elmt (Interfaces (Typ));
2139 while Present (AI_Elmt) loop
2140 AI := Node (AI_Elmt);
2143 or else Is_Ancestor (Iface, AI, Use_Full_View => True)
2149 AI_Tag := Next_Tag_Component (AI_Tag);
2150 Next_Elmt (AI_Elmt);
2155 -- Start of processing for Find_Interface_Tag
2158 pragma Assert (Is_Interface (Iface));
2160 -- Handle access types
2162 if Is_Access_Type (Typ) then
2163 Typ := Designated_Type (Typ);
2166 -- Handle class-wide types
2168 if Is_Class_Wide_Type (Typ) then
2169 Typ := Root_Type (Typ);
2172 -- Handle private types
2174 if Has_Private_Declaration (Typ)
2175 and then Present (Full_View (Typ))
2177 Typ := Full_View (Typ);
2180 -- Handle entities from the limited view
2182 if Ekind (Typ) = E_Incomplete_Type then
2183 pragma Assert (Present (Non_Limited_View (Typ)));
2184 Typ := Non_Limited_View (Typ);
2187 -- Handle task and protected types implementing interfaces
2189 if Is_Concurrent_Type (Typ) then
2190 Typ := Corresponding_Record_Type (Typ);
2193 -- If the interface is an ancestor of the type, then it shared the
2194 -- primary dispatch table.
2196 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
2197 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
2198 return First_Tag_Component (Typ);
2200 -- Otherwise we need to search for its associated tag component
2204 pragma Assert (Found);
2207 end Find_Interface_Tag;
2213 function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
2215 Typ : Entity_Id := T;
2219 if Is_Class_Wide_Type (Typ) then
2220 Typ := Root_Type (Typ);
2223 Typ := Underlying_Type (Typ);
2225 -- Loop through primitive operations
2227 Prim := First_Elmt (Primitive_Operations (Typ));
2228 while Present (Prim) loop
2231 -- We can retrieve primitive operations by name if it is an internal
2232 -- name. For equality we must check that both of its operands have
2233 -- the same type, to avoid confusion with user-defined equalities
2234 -- than may have a non-symmetric signature.
2236 exit when Chars (Op) = Name
2239 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
2243 -- Raise Program_Error if no primitive found
2246 raise Program_Error;
2257 function Find_Prim_Op
2259 Name : TSS_Name_Type) return Entity_Id
2261 Inher_Op : Entity_Id := Empty;
2262 Own_Op : Entity_Id := Empty;
2263 Prim_Elmt : Elmt_Id;
2264 Prim_Id : Entity_Id;
2265 Typ : Entity_Id := T;
2268 if Is_Class_Wide_Type (Typ) then
2269 Typ := Root_Type (Typ);
2272 Typ := Underlying_Type (Typ);
2274 -- This search is based on the assertion that the dispatching version
2275 -- of the TSS routine always precedes the real primitive.
2277 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
2278 while Present (Prim_Elmt) loop
2279 Prim_Id := Node (Prim_Elmt);
2281 if Is_TSS (Prim_Id, Name) then
2282 if Present (Alias (Prim_Id)) then
2283 Inher_Op := Prim_Id;
2289 Next_Elmt (Prim_Elmt);
2292 if Present (Own_Op) then
2294 elsif Present (Inher_Op) then
2297 raise Program_Error;
2301 ----------------------------
2302 -- Find_Protection_Object --
2303 ----------------------------
2305 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
2310 while Present (S) loop
2311 if (Ekind (S) = E_Entry
2312 or else Ekind (S) = E_Entry_Family
2313 or else Ekind (S) = E_Function
2314 or else Ekind (S) = E_Procedure)
2315 and then Present (Protection_Object (S))
2317 return Protection_Object (S);
2323 -- If we do not find a Protection object in the scope chain, then
2324 -- something has gone wrong, most likely the object was never created.
2326 raise Program_Error;
2327 end Find_Protection_Object;
2329 --------------------------
2330 -- Find_Protection_Type --
2331 --------------------------
2333 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
2335 Typ : Entity_Id := Conc_Typ;
2338 if Is_Concurrent_Type (Typ) then
2339 Typ := Corresponding_Record_Type (Typ);
2342 -- Since restriction violations are not considered serious errors, the
2343 -- expander remains active, but may leave the corresponding record type
2344 -- malformed. In such cases, component _object is not available so do
2347 if not Analyzed (Typ) then
2351 Comp := First_Component (Typ);
2352 while Present (Comp) loop
2353 if Chars (Comp) = Name_uObject then
2354 return Base_Type (Etype (Comp));
2357 Next_Component (Comp);
2360 -- The corresponding record of a protected type should always have an
2363 raise Program_Error;
2364 end Find_Protection_Type;
2366 ----------------------
2367 -- Force_Evaluation --
2368 ----------------------
2370 procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
2372 Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
2373 end Force_Evaluation;
2375 ---------------------------------
2376 -- Fully_Qualified_Name_String --
2377 ---------------------------------
2379 function Fully_Qualified_Name_String (E : Entity_Id) return String_Id is
2380 procedure Internal_Full_Qualified_Name (E : Entity_Id);
2381 -- Compute recursively the qualified name without NUL at the end, adding
2382 -- it to the currently started string being generated
2384 ----------------------------------
2385 -- Internal_Full_Qualified_Name --
2386 ----------------------------------
2388 procedure Internal_Full_Qualified_Name (E : Entity_Id) is
2392 -- Deal properly with child units
2394 if Nkind (E) = N_Defining_Program_Unit_Name then
2395 Ent := Defining_Identifier (E);
2400 -- Compute qualification recursively (only "Standard" has no scope)
2402 if Present (Scope (Scope (Ent))) then
2403 Internal_Full_Qualified_Name (Scope (Ent));
2404 Store_String_Char (Get_Char_Code ('.'));
2407 -- Every entity should have a name except some expanded blocks
2408 -- don't bother about those.
2410 if Chars (Ent) = No_Name then
2414 -- Generates the entity name in upper case
2416 Get_Decoded_Name_String (Chars (Ent));
2418 Store_String_Chars (Name_Buffer (1 .. Name_Len));
2420 end Internal_Full_Qualified_Name;
2422 -- Start of processing for Full_Qualified_Name
2426 Internal_Full_Qualified_Name (E);
2427 Store_String_Char (Get_Char_Code (ASCII.NUL));
2429 end Fully_Qualified_Name_String;
2431 ------------------------
2432 -- Generate_Poll_Call --
2433 ------------------------
2435 procedure Generate_Poll_Call (N : Node_Id) is
2437 -- No poll call if polling not active
2439 if not Polling_Required then
2442 -- Otherwise generate require poll call
2445 Insert_Before_And_Analyze (N,
2446 Make_Procedure_Call_Statement (Sloc (N),
2447 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
2449 end Generate_Poll_Call;
2451 ---------------------------------
2452 -- Get_Current_Value_Condition --
2453 ---------------------------------
2455 -- Note: the implementation of this procedure is very closely tied to the
2456 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
2457 -- interpret Current_Value fields set by the Set procedure, so the two
2458 -- procedures need to be closely coordinated.
2460 procedure Get_Current_Value_Condition
2465 Loc : constant Source_Ptr := Sloc (Var);
2466 Ent : constant Entity_Id := Entity (Var);
2468 procedure Process_Current_Value_Condition
2471 -- N is an expression which holds either True (S = True) or False (S =
2472 -- False) in the condition. This procedure digs out the expression and
2473 -- if it refers to Ent, sets Op and Val appropriately.
2475 -------------------------------------
2476 -- Process_Current_Value_Condition --
2477 -------------------------------------
2479 procedure Process_Current_Value_Condition
2490 -- Deal with NOT operators, inverting sense
2492 while Nkind (Cond) = N_Op_Not loop
2493 Cond := Right_Opnd (Cond);
2497 -- Deal with AND THEN and AND cases
2499 if Nkind (Cond) = N_And_Then
2500 or else Nkind (Cond) = N_Op_And
2502 -- Don't ever try to invert a condition that is of the form of an
2503 -- AND or AND THEN (since we are not doing sufficiently general
2504 -- processing to allow this).
2506 if Sens = False then
2512 -- Recursively process AND and AND THEN branches
2514 Process_Current_Value_Condition (Left_Opnd (Cond), True);
2516 if Op /= N_Empty then
2520 Process_Current_Value_Condition (Right_Opnd (Cond), True);
2523 -- Case of relational operator
2525 elsif Nkind (Cond) in N_Op_Compare then
2528 -- Invert sense of test if inverted test
2530 if Sens = False then
2532 when N_Op_Eq => Op := N_Op_Ne;
2533 when N_Op_Ne => Op := N_Op_Eq;
2534 when N_Op_Lt => Op := N_Op_Ge;
2535 when N_Op_Gt => Op := N_Op_Le;
2536 when N_Op_Le => Op := N_Op_Gt;
2537 when N_Op_Ge => Op := N_Op_Lt;
2538 when others => raise Program_Error;
2542 -- Case of entity op value
2544 if Is_Entity_Name (Left_Opnd (Cond))
2545 and then Ent = Entity (Left_Opnd (Cond))
2546 and then Compile_Time_Known_Value (Right_Opnd (Cond))
2548 Val := Right_Opnd (Cond);
2550 -- Case of value op entity
2552 elsif Is_Entity_Name (Right_Opnd (Cond))
2553 and then Ent = Entity (Right_Opnd (Cond))
2554 and then Compile_Time_Known_Value (Left_Opnd (Cond))
2556 Val := Left_Opnd (Cond);
2558 -- We are effectively swapping operands
2561 when N_Op_Eq => null;
2562 when N_Op_Ne => null;
2563 when N_Op_Lt => Op := N_Op_Gt;
2564 when N_Op_Gt => Op := N_Op_Lt;
2565 when N_Op_Le => Op := N_Op_Ge;
2566 when N_Op_Ge => Op := N_Op_Le;
2567 when others => raise Program_Error;
2576 -- Case of Boolean variable reference, return as though the
2577 -- reference had said var = True.
2580 if Is_Entity_Name (Cond)
2581 and then Ent = Entity (Cond)
2583 Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
2585 if Sens = False then
2592 end Process_Current_Value_Condition;
2594 -- Start of processing for Get_Current_Value_Condition
2600 -- Immediate return, nothing doing, if this is not an object
2602 if Ekind (Ent) not in Object_Kind then
2606 -- Otherwise examine current value
2609 CV : constant Node_Id := Current_Value (Ent);
2614 -- If statement. Condition is known true in THEN section, known False
2615 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
2617 if Nkind (CV) = N_If_Statement then
2619 -- Before start of IF statement
2621 if Loc < Sloc (CV) then
2624 -- After end of IF statement
2626 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
2630 -- At this stage we know that we are within the IF statement, but
2631 -- unfortunately, the tree does not record the SLOC of the ELSE so
2632 -- we cannot use a simple SLOC comparison to distinguish between
2633 -- the then/else statements, so we have to climb the tree.
2640 while Parent (N) /= CV loop
2643 -- If we fall off the top of the tree, then that's odd, but
2644 -- perhaps it could occur in some error situation, and the
2645 -- safest response is simply to assume that the outcome of
2646 -- the condition is unknown. No point in bombing during an
2647 -- attempt to optimize things.
2654 -- Now we have N pointing to a node whose parent is the IF
2655 -- statement in question, so now we can tell if we are within
2656 -- the THEN statements.
2658 if Is_List_Member (N)
2659 and then List_Containing (N) = Then_Statements (CV)
2663 -- If the variable reference does not come from source, we
2664 -- cannot reliably tell whether it appears in the else part.
2665 -- In particular, if it appears in generated code for a node
2666 -- that requires finalization, it may be attached to a list
2667 -- that has not been yet inserted into the code. For now,
2668 -- treat it as unknown.
2670 elsif not Comes_From_Source (N) then
2673 -- Otherwise we must be in ELSIF or ELSE part
2680 -- ELSIF part. Condition is known true within the referenced
2681 -- ELSIF, known False in any subsequent ELSIF or ELSE part,
2682 -- and unknown before the ELSE part or after the IF statement.
2684 elsif Nkind (CV) = N_Elsif_Part then
2686 -- if the Elsif_Part had condition_actions, the elsif has been
2687 -- rewritten as a nested if, and the original elsif_part is
2688 -- detached from the tree, so there is no way to obtain useful
2689 -- information on the current value of the variable.
2690 -- Can this be improved ???
2692 if No (Parent (CV)) then
2698 -- Before start of ELSIF part
2700 if Loc < Sloc (CV) then
2703 -- After end of IF statement
2705 elsif Loc >= Sloc (Stm) +
2706 Text_Ptr (UI_To_Int (End_Span (Stm)))
2711 -- Again we lack the SLOC of the ELSE, so we need to climb the
2712 -- tree to see if we are within the ELSIF part in question.
2719 while Parent (N) /= Stm loop
2722 -- If we fall off the top of the tree, then that's odd, but
2723 -- perhaps it could occur in some error situation, and the
2724 -- safest response is simply to assume that the outcome of
2725 -- the condition is unknown. No point in bombing during an
2726 -- attempt to optimize things.
2733 -- Now we have N pointing to a node whose parent is the IF
2734 -- statement in question, so see if is the ELSIF part we want.
2735 -- the THEN statements.
2740 -- Otherwise we must be in subsequent ELSIF or ELSE part
2747 -- Iteration scheme of while loop. The condition is known to be
2748 -- true within the body of the loop.
2750 elsif Nkind (CV) = N_Iteration_Scheme then
2752 Loop_Stmt : constant Node_Id := Parent (CV);
2755 -- Before start of body of loop
2757 if Loc < Sloc (Loop_Stmt) then
2760 -- After end of LOOP statement
2762 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
2765 -- We are within the body of the loop
2772 -- All other cases of Current_Value settings
2778 -- If we fall through here, then we have a reportable condition, Sens
2779 -- is True if the condition is true and False if it needs inverting.
2781 Process_Current_Value_Condition (Condition (CV), Sens);
2783 end Get_Current_Value_Condition;
2785 ---------------------
2786 -- Get_Stream_Size --
2787 ---------------------
2789 function Get_Stream_Size (E : Entity_Id) return Uint is
2791 -- If we have a Stream_Size clause for this type use it
2793 if Has_Stream_Size_Clause (E) then
2794 return Static_Integer (Expression (Stream_Size_Clause (E)));
2796 -- Otherwise the Stream_Size if the size of the type
2801 end Get_Stream_Size;
2803 ---------------------------
2804 -- Has_Access_Constraint --
2805 ---------------------------
2807 function Has_Access_Constraint (E : Entity_Id) return Boolean is
2809 T : constant Entity_Id := Etype (E);
2812 if Has_Per_Object_Constraint (E)
2813 and then Has_Discriminants (T)
2815 Disc := First_Discriminant (T);
2816 while Present (Disc) loop
2817 if Is_Access_Type (Etype (Disc)) then
2821 Next_Discriminant (Disc);
2828 end Has_Access_Constraint;
2830 ----------------------------------
2831 -- Has_Following_Address_Clause --
2832 ----------------------------------
2834 -- Should this function check the private part in a package ???
2836 function Has_Following_Address_Clause (D : Node_Id) return Boolean is
2837 Id : constant Entity_Id := Defining_Identifier (D);
2842 while Present (Decl) loop
2843 if Nkind (Decl) = N_At_Clause
2844 and then Chars (Identifier (Decl)) = Chars (Id)
2848 elsif Nkind (Decl) = N_Attribute_Definition_Clause
2849 and then Chars (Decl) = Name_Address
2850 and then Chars (Name (Decl)) = Chars (Id)
2859 end Has_Following_Address_Clause;
2861 --------------------
2862 -- Homonym_Number --
2863 --------------------
2865 function Homonym_Number (Subp : Entity_Id) return Nat is
2871 Hom := Homonym (Subp);
2872 while Present (Hom) loop
2873 if Scope (Hom) = Scope (Subp) then
2877 Hom := Homonym (Hom);
2883 -----------------------------------
2884 -- In_Library_Level_Package_Body --
2885 -----------------------------------
2887 function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
2889 -- First determine whether the entity appears at the library level, then
2890 -- look at the containing unit.
2892 if Is_Library_Level_Entity (Id) then
2894 Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
2897 return Nkind (Unit (Container)) = N_Package_Body;
2902 end In_Library_Level_Package_Body;
2904 ------------------------------
2905 -- In_Unconditional_Context --
2906 ------------------------------
2908 function In_Unconditional_Context (Node : Node_Id) return Boolean is
2913 while Present (P) loop
2915 when N_Subprogram_Body =>
2918 when N_If_Statement =>
2921 when N_Loop_Statement =>
2924 when N_Case_Statement =>
2933 end In_Unconditional_Context;
2939 procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
2941 if Present (Ins_Action) then
2942 Insert_Actions (Assoc_Node, New_List (Ins_Action));
2946 -- Version with check(s) suppressed
2948 procedure Insert_Action
2949 (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
2952 Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
2955 -------------------------
2956 -- Insert_Action_After --
2957 -------------------------
2959 procedure Insert_Action_After
2960 (Assoc_Node : Node_Id;
2961 Ins_Action : Node_Id)
2964 Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
2965 end Insert_Action_After;
2967 --------------------
2968 -- Insert_Actions --
2969 --------------------
2971 procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
2975 Wrapped_Node : Node_Id := Empty;
2978 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
2982 -- Ignore insert of actions from inside default expression (or other
2983 -- similar "spec expression") in the special spec-expression analyze
2984 -- mode. Any insertions at this point have no relevance, since we are
2985 -- only doing the analyze to freeze the types of any static expressions.
2986 -- See section "Handling of Default Expressions" in the spec of package
2987 -- Sem for further details.
2989 if In_Spec_Expression then
2993 -- If the action derives from stuff inside a record, then the actions
2994 -- are attached to the current scope, to be inserted and analyzed on
2995 -- exit from the scope. The reason for this is that we may also be
2996 -- generating freeze actions at the same time, and they must eventually
2997 -- be elaborated in the correct order.
2999 if Is_Record_Type (Current_Scope)
3000 and then not Is_Frozen (Current_Scope)
3002 if No (Scope_Stack.Table
3003 (Scope_Stack.Last).Pending_Freeze_Actions)
3005 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
3010 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
3016 -- We now intend to climb up the tree to find the right point to
3017 -- insert the actions. We start at Assoc_Node, unless this node is a
3018 -- subexpression in which case we start with its parent. We do this for
3019 -- two reasons. First it speeds things up. Second, if Assoc_Node is
3020 -- itself one of the special nodes like N_And_Then, then we assume that
3021 -- an initial request to insert actions for such a node does not expect
3022 -- the actions to get deposited in the node for later handling when the
3023 -- node is expanded, since clearly the node is being dealt with by the
3024 -- caller. Note that in the subexpression case, N is always the child we
3027 -- N_Raise_xxx_Error is an annoying special case, it is a statement if
3028 -- it has type Standard_Void_Type, and a subexpression otherwise.
3029 -- otherwise. Procedure attribute references are also statements.
3031 if Nkind (Assoc_Node) in N_Subexpr
3032 and then (Nkind (Assoc_Node) in N_Raise_xxx_Error
3033 or else Etype (Assoc_Node) /= Standard_Void_Type)
3034 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
3036 not Is_Procedure_Attribute_Name
3037 (Attribute_Name (Assoc_Node)))
3039 P := Assoc_Node; -- ??? does not agree with above!
3040 N := Parent (Assoc_Node);
3042 -- Non-subexpression case. Note that N is initially Empty in this case
3043 -- (N is only guaranteed Non-Empty in the subexpr case).
3050 -- Capture root of the transient scope
3052 if Scope_Is_Transient then
3053 Wrapped_Node := Node_To_Be_Wrapped;
3057 pragma Assert (Present (P));
3061 -- Case of right operand of AND THEN or OR ELSE. Put the actions
3062 -- in the Actions field of the right operand. They will be moved
3063 -- out further when the AND THEN or OR ELSE operator is expanded.
3064 -- Nothing special needs to be done for the left operand since
3065 -- in that case the actions are executed unconditionally.
3067 when N_Short_Circuit =>
3068 if N = Right_Opnd (P) then
3070 -- We are now going to either append the actions to the
3071 -- actions field of the short-circuit operation. We will
3072 -- also analyze the actions now.
3074 -- This analysis is really too early, the proper thing would
3075 -- be to just park them there now, and only analyze them if
3076 -- we find we really need them, and to it at the proper
3077 -- final insertion point. However attempting to this proved
3078 -- tricky, so for now we just kill current values before and
3079 -- after the analyze call to make sure we avoid peculiar
3080 -- optimizations from this out of order insertion.
3082 Kill_Current_Values;
3084 if Present (Actions (P)) then
3085 Insert_List_After_And_Analyze
3086 (Last (Actions (P)), Ins_Actions);
3088 Set_Actions (P, Ins_Actions);
3089 Analyze_List (Actions (P));
3092 Kill_Current_Values;
3097 -- Then or Else operand of conditional expression. Add actions to
3098 -- Then_Actions or Else_Actions field as appropriate. The actions
3099 -- will be moved further out when the conditional is expanded.
3101 when N_Conditional_Expression =>
3103 ThenX : constant Node_Id := Next (First (Expressions (P)));
3104 ElseX : constant Node_Id := Next (ThenX);
3107 -- If the enclosing expression is already analyzed, as
3108 -- is the case for nested elaboration checks, insert the
3109 -- conditional further out.
3111 if Analyzed (P) then
3114 -- Actions belong to the then expression, temporarily place
3115 -- them as Then_Actions of the conditional expr. They will
3116 -- be moved to the proper place later when the conditional
3117 -- expression is expanded.
3119 elsif N = ThenX then
3120 if Present (Then_Actions (P)) then
3121 Insert_List_After_And_Analyze
3122 (Last (Then_Actions (P)), Ins_Actions);
3124 Set_Then_Actions (P, Ins_Actions);
3125 Analyze_List (Then_Actions (P));
3130 -- Actions belong to the else expression, temporarily
3131 -- place them as Else_Actions of the conditional expr.
3132 -- They will be moved to the proper place later when
3133 -- the conditional expression is expanded.
3135 elsif N = ElseX then
3136 if Present (Else_Actions (P)) then
3137 Insert_List_After_And_Analyze
3138 (Last (Else_Actions (P)), Ins_Actions);
3140 Set_Else_Actions (P, Ins_Actions);
3141 Analyze_List (Else_Actions (P));
3146 -- Actions belong to the condition. In this case they are
3147 -- unconditionally executed, and so we can continue the
3148 -- search for the proper insert point.
3155 -- Alternative of case expression, we place the action in the
3156 -- Actions field of the case expression alternative, this will
3157 -- be handled when the case expression is expanded.
3159 when N_Case_Expression_Alternative =>
3160 if Present (Actions (P)) then
3161 Insert_List_After_And_Analyze
3162 (Last (Actions (P)), Ins_Actions);
3164 Set_Actions (P, Ins_Actions);
3165 Analyze_List (Actions (P));
3170 -- Case of appearing within an Expressions_With_Actions node. We
3171 -- prepend the actions to the list of actions already there, if
3172 -- the node has not been analyzed yet. Otherwise find insertion
3173 -- location further up the tree.
3175 when N_Expression_With_Actions =>
3176 if not Analyzed (P) then
3177 Prepend_List (Ins_Actions, Actions (P));
3181 -- Case of appearing in the condition of a while expression or
3182 -- elsif. We insert the actions into the Condition_Actions field.
3183 -- They will be moved further out when the while loop or elsif
3186 when N_Iteration_Scheme |
3189 if N = Condition (P) then
3190 if Present (Condition_Actions (P)) then
3191 Insert_List_After_And_Analyze
3192 (Last (Condition_Actions (P)), Ins_Actions);
3194 Set_Condition_Actions (P, Ins_Actions);
3196 -- Set the parent of the insert actions explicitly. This
3197 -- is not a syntactic field, but we need the parent field
3198 -- set, in particular so that freeze can understand that
3199 -- it is dealing with condition actions, and properly
3200 -- insert the freezing actions.
3202 Set_Parent (Ins_Actions, P);
3203 Analyze_List (Condition_Actions (P));
3209 -- Statements, declarations, pragmas, representation clauses
3214 N_Procedure_Call_Statement |
3215 N_Statement_Other_Than_Procedure_Call |
3221 -- Representation_Clause
3224 N_Attribute_Definition_Clause |
3225 N_Enumeration_Representation_Clause |
3226 N_Record_Representation_Clause |
3230 N_Abstract_Subprogram_Declaration |
3232 N_Exception_Declaration |
3233 N_Exception_Renaming_Declaration |
3234 N_Expression_Function |
3235 N_Formal_Abstract_Subprogram_Declaration |
3236 N_Formal_Concrete_Subprogram_Declaration |
3237 N_Formal_Object_Declaration |
3238 N_Formal_Type_Declaration |
3239 N_Full_Type_Declaration |
3240 N_Function_Instantiation |
3241 N_Generic_Function_Renaming_Declaration |
3242 N_Generic_Package_Declaration |
3243 N_Generic_Package_Renaming_Declaration |
3244 N_Generic_Procedure_Renaming_Declaration |
3245 N_Generic_Subprogram_Declaration |
3246 N_Implicit_Label_Declaration |
3247 N_Incomplete_Type_Declaration |
3248 N_Number_Declaration |
3249 N_Object_Declaration |
3250 N_Object_Renaming_Declaration |
3252 N_Package_Body_Stub |
3253 N_Package_Declaration |
3254 N_Package_Instantiation |
3255 N_Package_Renaming_Declaration |
3256 N_Private_Extension_Declaration |
3257 N_Private_Type_Declaration |
3258 N_Procedure_Instantiation |
3260 N_Protected_Body_Stub |
3261 N_Protected_Type_Declaration |
3262 N_Single_Task_Declaration |
3264 N_Subprogram_Body_Stub |
3265 N_Subprogram_Declaration |
3266 N_Subprogram_Renaming_Declaration |
3267 N_Subtype_Declaration |
3270 N_Task_Type_Declaration |
3272 -- Use clauses can appear in lists of declarations
3274 N_Use_Package_Clause |
3277 -- Freeze entity behaves like a declaration or statement
3281 -- Do not insert here if the item is not a list member (this
3282 -- happens for example with a triggering statement, and the
3283 -- proper approach is to insert before the entire select).
3285 if not Is_List_Member (P) then
3288 -- Do not insert if parent of P is an N_Component_Association
3289 -- node (i.e. we are in the context of an N_Aggregate or
3290 -- N_Extension_Aggregate node. In this case we want to insert
3291 -- before the entire aggregate.
3293 elsif Nkind (Parent (P)) = N_Component_Association then
3296 -- Do not insert if the parent of P is either an N_Variant node
3297 -- or an N_Record_Definition node, meaning in either case that
3298 -- P is a member of a component list, and that therefore the
3299 -- actions should be inserted outside the complete record
3302 elsif Nkind (Parent (P)) = N_Variant
3303 or else Nkind (Parent (P)) = N_Record_Definition
3307 -- Do not insert freeze nodes within the loop generated for
3308 -- an aggregate, because they may be elaborated too late for
3309 -- subsequent use in the back end: within a package spec the
3310 -- loop is part of the elaboration procedure and is only
3311 -- elaborated during the second pass.
3313 -- If the loop comes from source, or the entity is local to the
3314 -- loop itself it must remain within.
3316 elsif Nkind (Parent (P)) = N_Loop_Statement
3317 and then not Comes_From_Source (Parent (P))
3318 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
3320 Scope (Entity (First (Ins_Actions))) /= Current_Scope
3324 -- Otherwise we can go ahead and do the insertion
3326 elsif P = Wrapped_Node then
3327 Store_Before_Actions_In_Scope (Ins_Actions);
3331 Insert_List_Before_And_Analyze (P, Ins_Actions);
3335 -- A special case, N_Raise_xxx_Error can act either as a statement
3336 -- or a subexpression. We tell the difference by looking at the
3337 -- Etype. It is set to Standard_Void_Type in the statement case.
3340 N_Raise_xxx_Error =>
3341 if Etype (P) = Standard_Void_Type then
3342 if P = Wrapped_Node then
3343 Store_Before_Actions_In_Scope (Ins_Actions);
3345 Insert_List_Before_And_Analyze (P, Ins_Actions);
3350 -- In the subexpression case, keep climbing
3356 -- If a component association appears within a loop created for
3357 -- an array aggregate, attach the actions to the association so
3358 -- they can be subsequently inserted within the loop. For other
3359 -- component associations insert outside of the aggregate. For
3360 -- an association that will generate a loop, its Loop_Actions
3361 -- attribute is already initialized (see exp_aggr.adb).
3363 -- The list of loop_actions can in turn generate additional ones,
3364 -- that are inserted before the associated node. If the associated
3365 -- node is outside the aggregate, the new actions are collected
3366 -- at the end of the loop actions, to respect the order in which
3367 -- they are to be elaborated.
3370 N_Component_Association =>
3371 if Nkind (Parent (P)) = N_Aggregate
3372 and then Present (Loop_Actions (P))
3374 if Is_Empty_List (Loop_Actions (P)) then
3375 Set_Loop_Actions (P, Ins_Actions);
3376 Analyze_List (Ins_Actions);
3383 -- Check whether these actions were generated by a
3384 -- declaration that is part of the loop_ actions
3385 -- for the component_association.
3388 while Present (Decl) loop
3389 exit when Parent (Decl) = P
3390 and then Is_List_Member (Decl)
3392 List_Containing (Decl) = Loop_Actions (P);
3393 Decl := Parent (Decl);
3396 if Present (Decl) then
3397 Insert_List_Before_And_Analyze
3398 (Decl, Ins_Actions);
3400 Insert_List_After_And_Analyze
3401 (Last (Loop_Actions (P)), Ins_Actions);
3412 -- Another special case, an attribute denoting a procedure call
3415 N_Attribute_Reference =>
3416 if Is_Procedure_Attribute_Name (Attribute_Name (P)) 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 -- A contract node should not belong to the tree
3434 raise Program_Error;
3436 -- For all other node types, keep climbing tree
3440 N_Accept_Alternative |
3441 N_Access_Definition |
3442 N_Access_Function_Definition |
3443 N_Access_Procedure_Definition |
3444 N_Access_To_Object_Definition |
3447 N_Aspect_Specification |
3449 N_Case_Statement_Alternative |
3450 N_Character_Literal |
3451 N_Compilation_Unit |
3452 N_Compilation_Unit_Aux |
3453 N_Component_Clause |
3454 N_Component_Declaration |
3455 N_Component_Definition |
3457 N_Constrained_Array_Definition |
3458 N_Decimal_Fixed_Point_Definition |
3459 N_Defining_Character_Literal |
3460 N_Defining_Identifier |
3461 N_Defining_Operator_Symbol |
3462 N_Defining_Program_Unit_Name |
3463 N_Delay_Alternative |
3464 N_Delta_Constraint |
3465 N_Derived_Type_Definition |
3467 N_Digits_Constraint |
3468 N_Discriminant_Association |
3469 N_Discriminant_Specification |
3471 N_Entry_Body_Formal_Part |
3472 N_Entry_Call_Alternative |
3473 N_Entry_Declaration |
3474 N_Entry_Index_Specification |
3475 N_Enumeration_Type_Definition |
3477 N_Exception_Handler |
3479 N_Explicit_Dereference |
3480 N_Extension_Aggregate |
3481 N_Floating_Point_Definition |
3482 N_Formal_Decimal_Fixed_Point_Definition |
3483 N_Formal_Derived_Type_Definition |
3484 N_Formal_Discrete_Type_Definition |
3485 N_Formal_Floating_Point_Definition |
3486 N_Formal_Modular_Type_Definition |
3487 N_Formal_Ordinary_Fixed_Point_Definition |
3488 N_Formal_Package_Declaration |
3489 N_Formal_Private_Type_Definition |
3490 N_Formal_Incomplete_Type_Definition |
3491 N_Formal_Signed_Integer_Type_Definition |
3493 N_Function_Specification |
3494 N_Generic_Association |
3495 N_Handled_Sequence_Of_Statements |
3498 N_Index_Or_Discriminant_Constraint |
3499 N_Indexed_Component |
3501 N_Iterator_Specification |
3504 N_Loop_Parameter_Specification |
3506 N_Modular_Type_Definition |
3532 N_Op_Shift_Right_Arithmetic |
3536 N_Ordinary_Fixed_Point_Definition |
3538 N_Package_Specification |
3539 N_Parameter_Association |
3540 N_Parameter_Specification |
3541 N_Pop_Constraint_Error_Label |
3542 N_Pop_Program_Error_Label |
3543 N_Pop_Storage_Error_Label |
3544 N_Pragma_Argument_Association |
3545 N_Procedure_Specification |
3546 N_Protected_Definition |
3547 N_Push_Constraint_Error_Label |
3548 N_Push_Program_Error_Label |
3549 N_Push_Storage_Error_Label |
3550 N_Qualified_Expression |
3551 N_Quantified_Expression |
3553 N_Range_Constraint |
3555 N_Real_Range_Specification |
3556 N_Record_Definition |
3558 N_SCIL_Dispatch_Table_Tag_Init |
3559 N_SCIL_Dispatching_Call |
3560 N_SCIL_Membership_Test |
3561 N_Selected_Component |
3562 N_Signed_Integer_Type_Definition |
3563 N_Single_Protected_Declaration |
3567 N_Subtype_Indication |
3570 N_Terminate_Alternative |
3571 N_Triggering_Alternative |
3573 N_Unchecked_Expression |
3574 N_Unchecked_Type_Conversion |
3575 N_Unconstrained_Array_Definition |
3580 N_Validate_Unchecked_Conversion |
3587 -- Make sure that inserted actions stay in the transient scope
3589 if P = Wrapped_Node then
3590 Store_Before_Actions_In_Scope (Ins_Actions);
3594 -- If we fall through above tests, keep climbing tree
3598 if Nkind (Parent (N)) = N_Subunit then
3600 -- This is the proper body corresponding to a stub. Insertion must
3601 -- be done at the point of the stub, which is in the declarative
3602 -- part of the parent unit.
3604 P := Corresponding_Stub (Parent (N));
3612 -- Version with check(s) suppressed
3614 procedure Insert_Actions
3615 (Assoc_Node : Node_Id;
3616 Ins_Actions : List_Id;
3617 Suppress : Check_Id)
3620 if Suppress = All_Checks then
3622 Svg : constant Suppress_Array := Scope_Suppress;
3624 Scope_Suppress := (others => True);
3625 Insert_Actions (Assoc_Node, Ins_Actions);
3626 Scope_Suppress := Svg;
3631 Svg : constant Boolean := Scope_Suppress (Suppress);
3633 Scope_Suppress (Suppress) := True;
3634 Insert_Actions (Assoc_Node, Ins_Actions);
3635 Scope_Suppress (Suppress) := Svg;
3640 --------------------------
3641 -- Insert_Actions_After --
3642 --------------------------
3644 procedure Insert_Actions_After
3645 (Assoc_Node : Node_Id;
3646 Ins_Actions : List_Id)
3649 if Scope_Is_Transient
3650 and then Assoc_Node = Node_To_Be_Wrapped
3652 Store_After_Actions_In_Scope (Ins_Actions);
3654 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
3656 end Insert_Actions_After;
3658 ---------------------------------
3659 -- Insert_Library_Level_Action --
3660 ---------------------------------
3662 procedure Insert_Library_Level_Action (N : Node_Id) is
3663 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
3666 Push_Scope (Cunit_Entity (Main_Unit));
3667 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
3669 if No (Actions (Aux)) then
3670 Set_Actions (Aux, New_List (N));
3672 Append (N, Actions (Aux));
3677 end Insert_Library_Level_Action;
3679 ----------------------------------
3680 -- Insert_Library_Level_Actions --
3681 ----------------------------------
3683 procedure Insert_Library_Level_Actions (L : List_Id) is
3684 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
3687 if Is_Non_Empty_List (L) then
3688 Push_Scope (Cunit_Entity (Main_Unit));
3689 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
3691 if No (Actions (Aux)) then
3692 Set_Actions (Aux, L);
3695 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
3700 end Insert_Library_Level_Actions;
3702 ----------------------
3703 -- Inside_Init_Proc --
3704 ----------------------
3706 function Inside_Init_Proc return Boolean is
3712 and then S /= Standard_Standard
3714 if Is_Init_Proc (S) then
3722 end Inside_Init_Proc;
3724 ----------------------------
3725 -- Is_All_Null_Statements --
3726 ----------------------------
3728 function Is_All_Null_Statements (L : List_Id) return Boolean is
3733 while Present (Stm) loop
3734 if Nkind (Stm) /= N_Null_Statement then
3742 end Is_All_Null_Statements;
3744 ------------------------------
3745 -- Is_Finalizable_Transient --
3746 ------------------------------
3748 function Is_Finalizable_Transient
3750 Rel_Node : Node_Id) return Boolean
3752 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
3753 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
3754 Desig : Entity_Id := Obj_Typ;
3756 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
3757 -- Determine whether transient object Trans_Id is initialized either
3758 -- by a function call which returns an access type or simply renames
3761 function Initialized_By_Aliased_BIP_Func_Call
3762 (Trans_Id : Entity_Id) return Boolean;
3763 -- Determine whether transient object Trans_Id is initialized by a
3764 -- build-in-place function call where the BIPalloc parameter is of
3765 -- value 1 and BIPaccess is not null. This case creates an aliasing
3766 -- between the returned value and the value denoted by BIPaccess.
3769 (Trans_Id : Entity_Id;
3770 First_Stmt : Node_Id) return Boolean;
3771 -- Determine whether transient object Trans_Id has been renamed or
3772 -- aliased through 'reference in the statement list starting from
3775 function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
3776 -- Determine whether transient object Trans_Id is allocated on the heap
3778 ---------------------------
3779 -- Initialized_By_Access --
3780 ---------------------------
3782 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
3783 Expr : constant Node_Id := Expression (Parent (Trans_Id));
3788 and then Nkind (Expr) /= N_Reference
3789 and then Is_Access_Type (Etype (Expr));
3790 end Initialized_By_Access;
3792 ------------------------------------------
3793 -- Initialized_By_Aliased_BIP_Func_Call --
3794 ------------------------------------------
3796 function Initialized_By_Aliased_BIP_Func_Call
3797 (Trans_Id : Entity_Id) return Boolean
3799 Call : Node_Id := Expression (Parent (Trans_Id));
3802 -- Build-in-place calls usually appear in 'reference format
3804 if Nkind (Call) = N_Reference then
3805 Call := Prefix (Call);
3808 if Is_Build_In_Place_Function_Call (Call) then
3810 Access_Nam : Name_Id := No_Name;
3811 Access_OK : Boolean := False;
3813 Alloc_Nam : Name_Id := No_Name;
3814 Alloc_OK : Boolean := False;
3816 Func_Id : Entity_Id;
3820 -- Examine all parameter associations of the function call
3822 Param := First (Parameter_Associations (Call));
3823 while Present (Param) loop
3824 if Nkind (Param) = N_Parameter_Association
3825 and then Nkind (Selector_Name (Param)) = N_Identifier
3827 Actual := Explicit_Actual_Parameter (Param);
3828 Formal := Selector_Name (Param);
3830 -- Construct the names of formals BIPaccess and BIPalloc
3831 -- using the function name retrieved from an arbitrary
3834 if Access_Nam = No_Name
3835 and then Alloc_Nam = No_Name
3836 and then Present (Entity (Formal))
3838 Func_Id := Scope (Entity (Formal));
3841 New_External_Name (Chars (Func_Id),
3842 BIP_Formal_Suffix (BIP_Object_Access));
3845 New_External_Name (Chars (Func_Id),
3846 BIP_Formal_Suffix (BIP_Alloc_Form));
3849 -- A match for BIPaccess => Temp has been found
3851 if Chars (Formal) = Access_Nam
3852 and then Nkind (Actual) /= N_Null
3857 -- A match for BIPalloc => 1 has been found
3859 if Chars (Formal) = Alloc_Nam
3860 and then Nkind (Actual) = N_Integer_Literal
3861 and then Intval (Actual) = Uint_1
3870 return Access_OK and then Alloc_OK;
3875 end Initialized_By_Aliased_BIP_Func_Call;
3882 (Trans_Id : Entity_Id;
3883 First_Stmt : Node_Id) return Boolean
3885 function Extract_Renamed_Object
3886 (Ren_Decl : Node_Id) return Entity_Id;
3887 -- Given an object renaming declaration, retrieve the entity of the
3888 -- renamed name. Return Empty if the renamed name is anything other
3889 -- than a variable or a constant.
3891 ----------------------------
3892 -- Extract_Renamed_Object --
3893 ----------------------------
3895 function Extract_Renamed_Object
3896 (Ren_Decl : Node_Id) return Entity_Id
3903 Ren_Obj := Renamed_Object (Defining_Identifier (Ren_Decl));
3908 if Nkind_In (Ren_Obj, N_Explicit_Dereference,
3909 N_Indexed_Component,
3910 N_Selected_Component)
3912 Ren_Obj := Prefix (Ren_Obj);
3915 elsif Nkind_In (Ren_Obj, N_Type_Conversion,
3916 N_Unchecked_Type_Conversion)
3918 Ren_Obj := Expression (Ren_Obj);
3923 if Nkind (Ren_Obj) in N_Has_Entity then
3924 return Entity (Ren_Obj);
3928 end Extract_Renamed_Object;
3933 Ren_Obj : Entity_Id;
3936 -- Start of processing for Is_Aliased
3940 while Present (Stmt) loop
3941 if Nkind (Stmt) = N_Object_Declaration then
3942 Expr := Expression (Stmt);
3945 and then Nkind (Expr) = N_Reference
3946 and then Nkind (Prefix (Expr)) = N_Identifier
3947 and then Entity (Prefix (Expr)) = Trans_Id
3952 elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
3953 Ren_Obj := Extract_Renamed_Object (Stmt);
3955 if Present (Ren_Obj)
3956 and then Ren_Obj = Trans_Id
3972 function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
3973 Expr : constant Node_Id := Expression (Parent (Trans_Id));
3977 Is_Access_Type (Etype (Trans_Id))
3978 and then Present (Expr)
3979 and then Nkind (Expr) = N_Allocator;
3982 -- Start of processing for Is_Finalizable_Transient
3985 -- Handle access types
3987 if Is_Access_Type (Desig) then
3988 Desig := Available_View (Designated_Type (Desig));
3992 Ekind_In (Obj_Id, E_Constant, E_Variable)
3993 and then Needs_Finalization (Desig)
3994 and then Requires_Transient_Scope (Desig)
3995 and then Nkind (Rel_Node) /= N_Simple_Return_Statement
3997 -- Do not consider renamed or 'reference-d transient objects because
3998 -- the act of renaming extends the object's lifetime.
4000 and then not Is_Aliased (Obj_Id, Decl)
4002 -- Do not consider transient objects allocated on the heap since they
4003 -- are attached to a finalization master.
4005 and then not Is_Allocated (Obj_Id)
4007 -- If the transient object is a pointer, check that it is not
4008 -- initialized by a function which returns a pointer or acts as a
4009 -- renaming of another pointer.
4012 (not Is_Access_Type (Obj_Typ)
4013 or else not Initialized_By_Access (Obj_Id))
4015 -- Do not consider transient objects which act as indirect aliases of
4016 -- build-in-place function results.
4018 and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
4020 -- Do not consider conversions of tags to class-wide types
4022 and then not Is_Tag_To_CW_Conversion (Obj_Id);
4023 end Is_Finalizable_Transient;
4025 ---------------------------------
4026 -- Is_Fully_Repped_Tagged_Type --
4027 ---------------------------------
4029 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
4030 U : constant Entity_Id := Underlying_Type (T);
4034 if No (U) or else not Is_Tagged_Type (U) then
4036 elsif Has_Discriminants (U) then
4038 elsif not Has_Specified_Layout (U) then
4042 -- Here we have a tagged type, see if it has any unlayed out fields
4043 -- other than a possible tag and parent fields. If so, we return False.
4045 Comp := First_Component (U);
4046 while Present (Comp) loop
4047 if not Is_Tag (Comp)
4048 and then Chars (Comp) /= Name_uParent
4049 and then No (Component_Clause (Comp))
4053 Next_Component (Comp);
4057 -- All components are layed out
4060 end Is_Fully_Repped_Tagged_Type;
4062 ----------------------------------
4063 -- Is_Library_Level_Tagged_Type --
4064 ----------------------------------
4066 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
4068 return Is_Tagged_Type (Typ)
4069 and then Is_Library_Level_Entity (Typ);
4070 end Is_Library_Level_Tagged_Type;
4072 ----------------------------------
4073 -- Is_Null_Access_BIP_Func_Call --
4074 ----------------------------------
4076 function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean is
4077 Call : Node_Id := Expr;
4080 -- Build-in-place calls usually appear in 'reference format
4082 if Nkind (Call) = N_Reference then
4083 Call := Prefix (Call);
4086 if Nkind_In (Call, N_Qualified_Expression,
4087 N_Unchecked_Type_Conversion)
4089 Call := Expression (Call);
4092 if Is_Build_In_Place_Function_Call (Call) then
4094 Access_Nam : Name_Id := No_Name;
4100 -- Examine all parameter associations of the function call
4102 Param := First (Parameter_Associations (Call));
4103 while Present (Param) loop
4104 if Nkind (Param) = N_Parameter_Association
4105 and then Nkind (Selector_Name (Param)) = N_Identifier
4107 Formal := Selector_Name (Param);
4108 Actual := Explicit_Actual_Parameter (Param);
4110 -- Construct the name of formal BIPaccess. It is much easier
4111 -- to extract the name of the function using an arbitrary
4112 -- formal's scope rather than the Name field of Call.
4114 if Access_Nam = No_Name
4115 and then Present (Entity (Formal))
4119 (Chars (Scope (Entity (Formal))),
4120 BIP_Formal_Suffix (BIP_Object_Access));
4123 -- A match for BIPaccess => null has been found
4125 if Chars (Formal) = Access_Nam
4126 and then Nkind (Actual) = N_Null
4138 end Is_Null_Access_BIP_Func_Call;
4140 --------------------------
4141 -- Is_Non_BIP_Func_Call --
4142 --------------------------
4144 function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
4146 -- The expected call is of the format
4148 -- Func_Call'reference
4151 Nkind (Expr) = N_Reference
4152 and then Nkind (Prefix (Expr)) = N_Function_Call
4153 and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
4154 end Is_Non_BIP_Func_Call;
4156 ----------------------------------
4157 -- Is_Possibly_Unaligned_Object --
4158 ----------------------------------
4160 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
4161 T : constant Entity_Id := Etype (N);
4164 -- If renamed object, apply test to underlying object
4166 if Is_Entity_Name (N)
4167 and then Is_Object (Entity (N))
4168 and then Present (Renamed_Object (Entity (N)))
4170 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
4173 -- Tagged and controlled types and aliased types are always aligned, as
4174 -- are concurrent types.
4177 or else Has_Controlled_Component (T)
4178 or else Is_Concurrent_Type (T)
4179 or else Is_Tagged_Type (T)
4180 or else Is_Controlled (T)
4185 -- If this is an element of a packed array, may be unaligned
4187 if Is_Ref_To_Bit_Packed_Array (N) then
4191 -- Case of component reference
4193 if Nkind (N) = N_Selected_Component then
4195 P : constant Node_Id := Prefix (N);
4196 C : constant Entity_Id := Entity (Selector_Name (N));
4201 -- If component reference is for an array with non-static bounds,
4202 -- then it is always aligned: we can only process unaligned arrays
4203 -- with static bounds (more accurately bounds known at compile
4206 if Is_Array_Type (T)
4207 and then not Compile_Time_Known_Bounds (T)
4212 -- If component is aliased, it is definitely properly aligned
4214 if Is_Aliased (C) then
4218 -- If component is for a type implemented as a scalar, and the
4219 -- record is packed, and the component is other than the first
4220 -- component of the record, then the component may be unaligned.
4222 if Is_Packed (Etype (P))
4223 and then Represented_As_Scalar (Etype (C))
4224 and then First_Entity (Scope (C)) /= C
4229 -- Compute maximum possible alignment for T
4231 -- If alignment is known, then that settles things
4233 if Known_Alignment (T) then
4234 M := UI_To_Int (Alignment (T));
4236 -- If alignment is not known, tentatively set max alignment
4239 M := Ttypes.Maximum_Alignment;
4241 -- We can reduce this if the Esize is known since the default
4242 -- alignment will never be more than the smallest power of 2
4243 -- that does not exceed this Esize value.
4245 if Known_Esize (T) then
4246 S := UI_To_Int (Esize (T));
4248 while (M / 2) >= S loop
4254 -- The following code is historical, it used to be present but it
4255 -- is too cautious, because the front-end does not know the proper
4256 -- default alignments for the target. Also, if the alignment is
4257 -- not known, the front end can't know in any case! If a copy is
4258 -- needed, the back-end will take care of it. This whole section
4259 -- including this comment can be removed later ???
4261 -- If the component reference is for a record that has a specified
4262 -- alignment, and we either know it is too small, or cannot tell,
4263 -- then the component may be unaligned.
4265 -- if Known_Alignment (Etype (P))
4266 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
4267 -- and then M > Alignment (Etype (P))
4272 -- Case of component clause present which may specify an
4273 -- unaligned position.
4275 if Present (Component_Clause (C)) then
4277 -- Otherwise we can do a test to make sure that the actual
4278 -- start position in the record, and the length, are both
4279 -- consistent with the required alignment. If not, we know
4280 -- that we are unaligned.
4283 Align_In_Bits : constant Nat := M * System_Storage_Unit;
4285 if Component_Bit_Offset (C) mod Align_In_Bits /= 0
4286 or else Esize (C) mod Align_In_Bits /= 0
4293 -- Otherwise, for a component reference, test prefix
4295 return Is_Possibly_Unaligned_Object (P);
4298 -- If not a component reference, must be aligned
4303 end Is_Possibly_Unaligned_Object;
4305 ---------------------------------
4306 -- Is_Possibly_Unaligned_Slice --
4307 ---------------------------------
4309 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
4311 -- Go to renamed object
4313 if Is_Entity_Name (N)
4314 and then Is_Object (Entity (N))
4315 and then Present (Renamed_Object (Entity (N)))
4317 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
4320 -- The reference must be a slice
4322 if Nkind (N) /= N_Slice then
4326 -- Always assume the worst for a nested record component with a
4327 -- component clause, which gigi/gcc does not appear to handle well.
4328 -- It is not clear why this special test is needed at all ???
4330 if Nkind (Prefix (N)) = N_Selected_Component
4331 and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
4333 Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
4338 -- We only need to worry if the target has strict alignment
4340 if not Target_Strict_Alignment then
4344 -- If it is a slice, then look at the array type being sliced
4347 Sarr : constant Node_Id := Prefix (N);
4348 -- Prefix of the slice, i.e. the array being sliced
4350 Styp : constant Entity_Id := Etype (Prefix (N));
4351 -- Type of the array being sliced
4357 -- The problems arise if the array object that is being sliced
4358 -- is a component of a record or array, and we cannot guarantee
4359 -- the alignment of the array within its containing object.
4361 -- To investigate this, we look at successive prefixes to see
4362 -- if we have a worrisome indexed or selected component.
4366 -- Case of array is part of an indexed component reference
4368 if Nkind (Pref) = N_Indexed_Component then
4369 Ptyp := Etype (Prefix (Pref));
4371 -- The only problematic case is when the array is packed, in
4372 -- which case we really know nothing about the alignment of
4373 -- individual components.
4375 if Is_Bit_Packed_Array (Ptyp) then
4379 -- Case of array is part of a selected component reference
4381 elsif Nkind (Pref) = N_Selected_Component then
4382 Ptyp := Etype (Prefix (Pref));
4384 -- We are definitely in trouble if the record in question
4385 -- has an alignment, and either we know this alignment is
4386 -- inconsistent with the alignment of the slice, or we don't
4387 -- know what the alignment of the slice should be.
4389 if Known_Alignment (Ptyp)
4390 and then (Unknown_Alignment (Styp)
4391 or else Alignment (Styp) > Alignment (Ptyp))
4396 -- We are in potential trouble if the record type is packed.
4397 -- We could special case when we know that the array is the
4398 -- first component, but that's not such a simple case ???
4400 if Is_Packed (Ptyp) then
4404 -- We are in trouble if there is a component clause, and
4405 -- either we do not know the alignment of the slice, or
4406 -- the alignment of the slice is inconsistent with the
4407 -- bit position specified by the component clause.
4410 Field : constant Entity_Id := Entity (Selector_Name (Pref));
4412 if Present (Component_Clause (Field))
4414 (Unknown_Alignment (Styp)
4416 (Component_Bit_Offset (Field) mod
4417 (System_Storage_Unit * Alignment (Styp))) /= 0)
4423 -- For cases other than selected or indexed components we know we
4424 -- are OK, since no issues arise over alignment.
4430 -- We processed an indexed component or selected component
4431 -- reference that looked safe, so keep checking prefixes.
4433 Pref := Prefix (Pref);
4436 end Is_Possibly_Unaligned_Slice;
4438 -------------------------------
4439 -- Is_Related_To_Func_Return --
4440 -------------------------------
4442 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
4443 Expr : constant Node_Id := Related_Expression (Id);
4447 and then Nkind (Expr) = N_Explicit_Dereference
4448 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
4449 end Is_Related_To_Func_Return;
4451 --------------------------------
4452 -- Is_Ref_To_Bit_Packed_Array --
4453 --------------------------------
4455 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
4460 if Is_Entity_Name (N)
4461 and then Is_Object (Entity (N))
4462 and then Present (Renamed_Object (Entity (N)))
4464 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
4467 if Nkind (N) = N_Indexed_Component
4469 Nkind (N) = N_Selected_Component
4471 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
4474 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
4477 if Result and then Nkind (N) = N_Indexed_Component then
4478 Expr := First (Expressions (N));
4479 while Present (Expr) loop
4480 Force_Evaluation (Expr);
4490 end Is_Ref_To_Bit_Packed_Array;
4492 --------------------------------
4493 -- Is_Ref_To_Bit_Packed_Slice --
4494 --------------------------------
4496 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
4498 if Nkind (N) = N_Type_Conversion then
4499 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
4501 elsif Is_Entity_Name (N)
4502 and then Is_Object (Entity (N))
4503 and then Present (Renamed_Object (Entity (N)))
4505 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
4507 elsif Nkind (N) = N_Slice
4508 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
4512 elsif Nkind (N) = N_Indexed_Component
4514 Nkind (N) = N_Selected_Component
4516 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
4521 end Is_Ref_To_Bit_Packed_Slice;
4523 -----------------------
4524 -- Is_Renamed_Object --
4525 -----------------------
4527 function Is_Renamed_Object (N : Node_Id) return Boolean is
4528 Pnod : constant Node_Id := Parent (N);
4529 Kind : constant Node_Kind := Nkind (Pnod);
4531 if Kind = N_Object_Renaming_Declaration then
4533 elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
4534 return Is_Renamed_Object (Pnod);
4538 end Is_Renamed_Object;
4540 -----------------------------
4541 -- Is_Tag_To_CW_Conversion --
4542 -----------------------------
4544 function Is_Tag_To_CW_Conversion (Obj_Id : Entity_Id) return Boolean is
4545 Expr : constant Node_Id := Expression (Parent (Obj_Id));
4549 Is_Class_Wide_Type (Etype (Obj_Id))
4550 and then Present (Expr)
4551 and then Nkind (Expr) = N_Unchecked_Type_Conversion
4552 and then Etype (Expression (Expr)) = RTE (RE_Tag);
4553 end Is_Tag_To_CW_Conversion;
4555 ----------------------------
4556 -- Is_Untagged_Derivation --
4557 ----------------------------
4559 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
4561 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
4563 (Is_Private_Type (T) and then Present (Full_View (T))
4564 and then not Is_Tagged_Type (Full_View (T))
4565 and then Is_Derived_Type (Full_View (T))
4566 and then Etype (Full_View (T)) /= T);
4567 end Is_Untagged_Derivation;
4569 ---------------------------
4570 -- Is_Volatile_Reference --
4571 ---------------------------
4573 function Is_Volatile_Reference (N : Node_Id) return Boolean is
4575 if Nkind (N) in N_Has_Etype
4576 and then Present (Etype (N))
4577 and then Treat_As_Volatile (Etype (N))
4581 elsif Is_Entity_Name (N) then
4582 return Treat_As_Volatile (Entity (N));
4584 elsif Nkind (N) = N_Slice then
4585 return Is_Volatile_Reference (Prefix (N));
4587 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
4588 if (Is_Entity_Name (Prefix (N))
4589 and then Has_Volatile_Components (Entity (Prefix (N))))
4590 or else (Present (Etype (Prefix (N)))
4591 and then Has_Volatile_Components (Etype (Prefix (N))))
4595 return Is_Volatile_Reference (Prefix (N));
4601 end Is_Volatile_Reference;
4603 --------------------------
4604 -- Is_VM_By_Copy_Actual --
4605 --------------------------
4607 function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean is
4609 return VM_Target /= No_VM
4610 and then (Nkind (N) = N_Slice
4612 (Nkind (N) = N_Identifier
4613 and then Present (Renamed_Object (Entity (N)))
4614 and then Nkind (Renamed_Object (Entity (N)))
4616 end Is_VM_By_Copy_Actual;
4618 --------------------
4619 -- Kill_Dead_Code --
4620 --------------------
4622 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
4623 W : Boolean := Warn;
4624 -- Set False if warnings suppressed
4628 Remove_Warning_Messages (N);
4630 -- Generate warning if appropriate
4634 -- We suppress the warning if this code is under control of an
4635 -- if statement, whose condition is a simple identifier, and
4636 -- either we are in an instance, or warnings off is set for this
4637 -- identifier. The reason for killing it in the instance case is
4638 -- that it is common and reasonable for code to be deleted in
4639 -- instances for various reasons.
4641 if Nkind (Parent (N)) = N_If_Statement then
4643 C : constant Node_Id := Condition (Parent (N));
4645 if Nkind (C) = N_Identifier
4648 or else (Present (Entity (C))
4649 and then Has_Warnings_Off (Entity (C))))
4656 -- Generate warning if not suppressed
4660 ("?this code can never be executed and has been deleted!", N);
4664 -- Recurse into block statements and bodies to process declarations
4667 if Nkind (N) = N_Block_Statement
4668 or else Nkind (N) = N_Subprogram_Body
4669 or else Nkind (N) = N_Package_Body
4671 Kill_Dead_Code (Declarations (N), False);
4672 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
4674 if Nkind (N) = N_Subprogram_Body then
4675 Set_Is_Eliminated (Defining_Entity (N));
4678 elsif Nkind (N) = N_Package_Declaration then
4679 Kill_Dead_Code (Visible_Declarations (Specification (N)));
4680 Kill_Dead_Code (Private_Declarations (Specification (N)));
4682 -- ??? After this point, Delete_Tree has been called on all
4683 -- declarations in Specification (N), so references to entities
4684 -- therein look suspicious.
4687 E : Entity_Id := First_Entity (Defining_Entity (N));
4689 while Present (E) loop
4690 if Ekind (E) = E_Operator then
4691 Set_Is_Eliminated (E);
4698 -- Recurse into composite statement to kill individual statements in
4699 -- particular instantiations.
4701 elsif Nkind (N) = N_If_Statement then
4702 Kill_Dead_Code (Then_Statements (N));
4703 Kill_Dead_Code (Elsif_Parts (N));
4704 Kill_Dead_Code (Else_Statements (N));
4706 elsif Nkind (N) = N_Loop_Statement then
4707 Kill_Dead_Code (Statements (N));
4709 elsif Nkind (N) = N_Case_Statement then
4713 Alt := First (Alternatives (N));
4714 while Present (Alt) loop
4715 Kill_Dead_Code (Statements (Alt));
4720 elsif Nkind (N) = N_Case_Statement_Alternative then
4721 Kill_Dead_Code (Statements (N));
4723 -- Deal with dead instances caused by deleting instantiations
4725 elsif Nkind (N) in N_Generic_Instantiation then
4726 Remove_Dead_Instance (N);
4731 -- Case where argument is a list of nodes to be killed
4733 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
4738 if Is_Non_Empty_List (L) then
4740 while Present (N) loop
4741 Kill_Dead_Code (N, W);
4748 ------------------------
4749 -- Known_Non_Negative --
4750 ------------------------
4752 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
4754 if Is_OK_Static_Expression (Opnd)
4755 and then Expr_Value (Opnd) >= 0
4761 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
4765 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
4768 end Known_Non_Negative;
4770 --------------------
4771 -- Known_Non_Null --
4772 --------------------
4774 function Known_Non_Null (N : Node_Id) return Boolean is
4776 -- Checks for case where N is an entity reference
4778 if Is_Entity_Name (N) and then Present (Entity (N)) then
4780 E : constant Entity_Id := Entity (N);
4785 -- First check if we are in decisive conditional
4787 Get_Current_Value_Condition (N, Op, Val);
4789 if Known_Null (Val) then
4790 if Op = N_Op_Eq then
4792 elsif Op = N_Op_Ne then
4797 -- If OK to do replacement, test Is_Known_Non_Null flag
4799 if OK_To_Do_Constant_Replacement (E) then
4800 return Is_Known_Non_Null (E);
4802 -- Otherwise if not safe to do replacement, then say so
4809 -- True if access attribute
4811 elsif Nkind (N) = N_Attribute_Reference
4812 and then (Attribute_Name (N) = Name_Access
4814 Attribute_Name (N) = Name_Unchecked_Access
4816 Attribute_Name (N) = Name_Unrestricted_Access)
4820 -- True if allocator
4822 elsif Nkind (N) = N_Allocator then
4825 -- For a conversion, true if expression is known non-null
4827 elsif Nkind (N) = N_Type_Conversion then
4828 return Known_Non_Null (Expression (N));
4830 -- Above are all cases where the value could be determined to be
4831 -- non-null. In all other cases, we don't know, so return False.
4842 function Known_Null (N : Node_Id) return Boolean is
4844 -- Checks for case where N is an entity reference
4846 if Is_Entity_Name (N) and then Present (Entity (N)) then
4848 E : constant Entity_Id := Entity (N);
4853 -- Constant null value is for sure null
4855 if Ekind (E) = E_Constant
4856 and then Known_Null (Constant_Value (E))
4861 -- First check if we are in decisive conditional
4863 Get_Current_Value_Condition (N, Op, Val);
4865 if Known_Null (Val) then
4866 if Op = N_Op_Eq then
4868 elsif Op = N_Op_Ne then
4873 -- If OK to do replacement, test Is_Known_Null flag
4875 if OK_To_Do_Constant_Replacement (E) then
4876 return Is_Known_Null (E);
4878 -- Otherwise if not safe to do replacement, then say so
4885 -- True if explicit reference to null
4887 elsif Nkind (N) = N_Null then
4890 -- For a conversion, true if expression is known null
4892 elsif Nkind (N) = N_Type_Conversion then
4893 return Known_Null (Expression (N));
4895 -- Above are all cases where the value could be determined to be null.
4896 -- In all other cases, we don't know, so return False.
4903 -----------------------------
4904 -- Make_CW_Equivalent_Type --
4905 -----------------------------
4907 -- Create a record type used as an equivalent of any member of the class
4908 -- which takes its size from exp.
4910 -- Generate the following code:
4912 -- type Equiv_T is record
4913 -- _parent : T (List of discriminant constraints taken from Exp);
4914 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
4917 -- ??? Note that this type does not guarantee same alignment as all
4920 function Make_CW_Equivalent_Type
4922 E : Node_Id) return Entity_Id
4924 Loc : constant Source_Ptr := Sloc (E);
4925 Root_Typ : constant Entity_Id := Root_Type (T);
4926 List_Def : constant List_Id := Empty_List;
4927 Comp_List : constant List_Id := New_List;
4928 Equiv_Type : Entity_Id;
4929 Range_Type : Entity_Id;
4930 Str_Type : Entity_Id;
4931 Constr_Root : Entity_Id;
4935 -- If the root type is already constrained, there are no discriminants
4936 -- in the expression.
4938 if not Has_Discriminants (Root_Typ)
4939 or else Is_Constrained (Root_Typ)
4941 Constr_Root := Root_Typ;
4943 Constr_Root := Make_Temporary (Loc, 'R');
4945 -- subtype cstr__n is T (List of discr constraints taken from Exp)
4947 Append_To (List_Def,
4948 Make_Subtype_Declaration (Loc,
4949 Defining_Identifier => Constr_Root,
4950 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
4953 -- Generate the range subtype declaration
4955 Range_Type := Make_Temporary (Loc, 'G');
4957 if not Is_Interface (Root_Typ) then
4959 -- subtype rg__xx is
4960 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
4963 Make_Op_Subtract (Loc,
4965 Make_Attribute_Reference (Loc,
4967 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
4968 Attribute_Name => Name_Size),
4970 Make_Attribute_Reference (Loc,
4971 Prefix => New_Reference_To (Constr_Root, Loc),
4972 Attribute_Name => Name_Object_Size));
4974 -- subtype rg__xx is
4975 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
4978 Make_Attribute_Reference (Loc,
4980 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
4981 Attribute_Name => Name_Size);
4984 Set_Paren_Count (Sizexpr, 1);
4986 Append_To (List_Def,
4987 Make_Subtype_Declaration (Loc,
4988 Defining_Identifier => Range_Type,
4989 Subtype_Indication =>
4990 Make_Subtype_Indication (Loc,
4991 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc),
4992 Constraint => Make_Range_Constraint (Loc,
4995 Low_Bound => Make_Integer_Literal (Loc, 1),
4997 Make_Op_Divide (Loc,
4998 Left_Opnd => Sizexpr,
4999 Right_Opnd => Make_Integer_Literal (Loc,
5000 Intval => System_Storage_Unit)))))));
5002 -- subtype str__nn is Storage_Array (rg__x);
5004 Str_Type := Make_Temporary (Loc, 'S');
5005 Append_To (List_Def,
5006 Make_Subtype_Declaration (Loc,
5007 Defining_Identifier => Str_Type,
5008 Subtype_Indication =>
5009 Make_Subtype_Indication (Loc,
5010 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
5012 Make_Index_Or_Discriminant_Constraint (Loc,
5014 New_List (New_Reference_To (Range_Type, Loc))))));
5016 -- type Equiv_T is record
5017 -- [ _parent : Tnn; ]
5021 Equiv_Type := Make_Temporary (Loc, 'T');
5022 Set_Ekind (Equiv_Type, E_Record_Type);
5023 Set_Parent_Subtype (Equiv_Type, Constr_Root);
5025 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
5026 -- treatment for this type. In particular, even though _parent's type
5027 -- is a controlled type or contains controlled components, we do not
5028 -- want to set Has_Controlled_Component on it to avoid making it gain
5029 -- an unwanted _controller component.
5031 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
5033 if not Is_Interface (Root_Typ) then
5034 Append_To (Comp_List,
5035 Make_Component_Declaration (Loc,
5036 Defining_Identifier =>
5037 Make_Defining_Identifier (Loc, Name_uParent),
5038 Component_Definition =>
5039 Make_Component_Definition (Loc,
5040 Aliased_Present => False,
5041 Subtype_Indication => New_Reference_To (Constr_Root, Loc))));
5044 Append_To (Comp_List,
5045 Make_Component_Declaration (Loc,
5046 Defining_Identifier => Make_Temporary (Loc, 'C'),
5047 Component_Definition =>
5048 Make_Component_Definition (Loc,
5049 Aliased_Present => False,
5050 Subtype_Indication => New_Reference_To (Str_Type, Loc))));
5052 Append_To (List_Def,
5053 Make_Full_Type_Declaration (Loc,
5054 Defining_Identifier => Equiv_Type,
5056 Make_Record_Definition (Loc,
5058 Make_Component_List (Loc,
5059 Component_Items => Comp_List,
5060 Variant_Part => Empty))));
5062 -- Suppress all checks during the analysis of the expanded code to avoid
5063 -- the generation of spurious warnings under ZFP run-time.
5065 Insert_Actions (E, List_Def, Suppress => All_Checks);
5067 end Make_CW_Equivalent_Type;
5069 -------------------------
5070 -- Make_Invariant_Call --
5071 -------------------------
5073 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
5074 Loc : constant Source_Ptr := Sloc (Expr);
5075 Typ : constant Entity_Id := Etype (Expr);
5079 (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
5081 if Check_Enabled (Name_Invariant)
5083 Check_Enabled (Name_Assertion)
5086 Make_Procedure_Call_Statement (Loc,
5088 New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
5089 Parameter_Associations => New_List (Relocate_Node (Expr)));
5093 Make_Null_Statement (Loc);
5095 end Make_Invariant_Call;
5097 ------------------------
5098 -- Make_Literal_Range --
5099 ------------------------
5101 function Make_Literal_Range
5103 Literal_Typ : Entity_Id) return Node_Id
5105 Lo : constant Node_Id :=
5106 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
5107 Index : constant Entity_Id := Etype (Lo);
5110 Length_Expr : constant Node_Id :=
5111 Make_Op_Subtract (Loc,
5113 Make_Integer_Literal (Loc,
5114 Intval => String_Literal_Length (Literal_Typ)),
5116 Make_Integer_Literal (Loc, 1));
5119 Set_Analyzed (Lo, False);
5121 if Is_Integer_Type (Index) then
5124 Left_Opnd => New_Copy_Tree (Lo),
5125 Right_Opnd => Length_Expr);
5128 Make_Attribute_Reference (Loc,
5129 Attribute_Name => Name_Val,
5130 Prefix => New_Occurrence_Of (Index, Loc),
5131 Expressions => New_List (
5134 Make_Attribute_Reference (Loc,
5135 Attribute_Name => Name_Pos,
5136 Prefix => New_Occurrence_Of (Index, Loc),
5137 Expressions => New_List (New_Copy_Tree (Lo))),
5138 Right_Opnd => Length_Expr)));
5145 end Make_Literal_Range;
5147 --------------------------
5148 -- Make_Non_Empty_Check --
5149 --------------------------
5151 function Make_Non_Empty_Check
5153 N : Node_Id) return Node_Id
5159 Make_Attribute_Reference (Loc,
5160 Attribute_Name => Name_Length,
5161 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
5163 Make_Integer_Literal (Loc, 0));
5164 end Make_Non_Empty_Check;
5166 -------------------------
5167 -- Make_Predicate_Call --
5168 -------------------------
5170 function Make_Predicate_Call
5172 Expr : Node_Id) return Node_Id
5174 Loc : constant Source_Ptr := Sloc (Expr);
5177 pragma Assert (Present (Predicate_Function (Typ)));
5180 Make_Function_Call (Loc,
5182 New_Occurrence_Of (Predicate_Function (Typ), Loc),
5183 Parameter_Associations => New_List (Relocate_Node (Expr)));
5184 end Make_Predicate_Call;
5186 --------------------------
5187 -- Make_Predicate_Check --
5188 --------------------------
5190 function Make_Predicate_Check
5192 Expr : Node_Id) return Node_Id
5194 Loc : constant Source_Ptr := Sloc (Expr);
5199 Pragma_Identifier => Make_Identifier (Loc, Name_Check),
5200 Pragma_Argument_Associations => New_List (
5201 Make_Pragma_Argument_Association (Loc,
5202 Expression => Make_Identifier (Loc, Name_Predicate)),
5203 Make_Pragma_Argument_Association (Loc,
5204 Expression => Make_Predicate_Call (Typ, Expr))));
5205 end Make_Predicate_Check;
5207 ----------------------------
5208 -- Make_Subtype_From_Expr --
5209 ----------------------------
5211 -- 1. If Expr is an unconstrained array expression, creates
5212 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
5214 -- 2. If Expr is a unconstrained discriminated type expression, creates
5215 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
5217 -- 3. If Expr is class-wide, creates an implicit class wide subtype
5219 function Make_Subtype_From_Expr
5221 Unc_Typ : Entity_Id) return Node_Id
5223 Loc : constant Source_Ptr := Sloc (E);
5224 List_Constr : constant List_Id := New_List;
5227 Full_Subtyp : Entity_Id;
5228 Priv_Subtyp : Entity_Id;
5233 if Is_Private_Type (Unc_Typ)
5234 and then Has_Unknown_Discriminants (Unc_Typ)
5236 -- Prepare the subtype completion, Go to base type to
5237 -- find underlying type, because the type may be a generic
5238 -- actual or an explicit subtype.
5240 Utyp := Underlying_Type (Base_Type (Unc_Typ));
5241 Full_Subtyp := Make_Temporary (Loc, 'C');
5243 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
5244 Set_Parent (Full_Exp, Parent (E));
5246 Priv_Subtyp := Make_Temporary (Loc, 'P');
5249 Make_Subtype_Declaration (Loc,
5250 Defining_Identifier => Full_Subtyp,
5251 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
5253 -- Define the dummy private subtype
5255 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
5256 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
5257 Set_Scope (Priv_Subtyp, Full_Subtyp);
5258 Set_Is_Constrained (Priv_Subtyp);
5259 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
5260 Set_Is_Itype (Priv_Subtyp);
5261 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
5263 if Is_Tagged_Type (Priv_Subtyp) then
5265 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
5266 Set_Direct_Primitive_Operations (Priv_Subtyp,
5267 Direct_Primitive_Operations (Unc_Typ));
5270 Set_Full_View (Priv_Subtyp, Full_Subtyp);
5272 return New_Reference_To (Priv_Subtyp, Loc);
5274 elsif Is_Array_Type (Unc_Typ) then
5275 for J in 1 .. Number_Dimensions (Unc_Typ) loop
5276 Append_To (List_Constr,
5279 Make_Attribute_Reference (Loc,
5280 Prefix => Duplicate_Subexpr_No_Checks (E),
5281 Attribute_Name => Name_First,
5282 Expressions => New_List (
5283 Make_Integer_Literal (Loc, J))),
5286 Make_Attribute_Reference (Loc,
5287 Prefix => Duplicate_Subexpr_No_Checks (E),
5288 Attribute_Name => Name_Last,
5289 Expressions => New_List (
5290 Make_Integer_Literal (Loc, J)))));
5293 elsif Is_Class_Wide_Type (Unc_Typ) then
5295 CW_Subtype : Entity_Id;
5296 EQ_Typ : Entity_Id := Empty;
5299 -- A class-wide equivalent type is not needed when VM_Target
5300 -- because the VM back-ends handle the class-wide object
5301 -- initialization itself (and doesn't need or want the
5302 -- additional intermediate type to handle the assignment).
5304 if Expander_Active and then Tagged_Type_Expansion then
5306 -- If this is the class_wide type of a completion that is a
5307 -- record subtype, set the type of the class_wide type to be
5308 -- the full base type, for use in the expanded code for the
5309 -- equivalent type. Should this be done earlier when the
5310 -- completion is analyzed ???
5312 if Is_Private_Type (Etype (Unc_Typ))
5314 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
5316 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
5319 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
5322 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
5323 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
5324 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
5326 return New_Occurrence_Of (CW_Subtype, Loc);
5329 -- Indefinite record type with discriminants
5332 D := First_Discriminant (Unc_Typ);
5333 while Present (D) loop
5334 Append_To (List_Constr,
5335 Make_Selected_Component (Loc,
5336 Prefix => Duplicate_Subexpr_No_Checks (E),
5337 Selector_Name => New_Reference_To (D, Loc)));
5339 Next_Discriminant (D);
5344 Make_Subtype_Indication (Loc,
5345 Subtype_Mark => New_Reference_To (Unc_Typ, Loc),
5347 Make_Index_Or_Discriminant_Constraint (Loc,
5348 Constraints => List_Constr));
5349 end Make_Subtype_From_Expr;
5351 -----------------------------
5352 -- May_Generate_Large_Temp --
5353 -----------------------------
5355 -- At the current time, the only types that we return False for (i.e. where
5356 -- we decide we know they cannot generate large temps) are ones where we
5357 -- know the size is 256 bits or less at compile time, and we are still not
5358 -- doing a thorough job on arrays and records ???
5360 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
5362 if not Size_Known_At_Compile_Time (Typ) then
5365 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
5368 elsif Is_Array_Type (Typ)
5369 and then Present (Packed_Array_Type (Typ))
5371 return May_Generate_Large_Temp (Packed_Array_Type (Typ));
5373 -- We could do more here to find other small types ???
5378 end May_Generate_Large_Temp;
5380 ------------------------
5381 -- Needs_Finalization --
5382 ------------------------
5384 function Needs_Finalization (T : Entity_Id) return Boolean is
5385 function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
5386 -- If type is not frozen yet, check explicitly among its components,
5387 -- because the Has_Controlled_Component flag is not necessarily set.
5389 -----------------------------------
5390 -- Has_Some_Controlled_Component --
5391 -----------------------------------
5393 function Has_Some_Controlled_Component
5394 (Rec : Entity_Id) return Boolean
5399 if Has_Controlled_Component (Rec) then
5402 elsif not Is_Frozen (Rec) then
5403 if Is_Record_Type (Rec) then
5404 Comp := First_Entity (Rec);
5406 while Present (Comp) loop
5407 if not Is_Type (Comp)
5408 and then Needs_Finalization (Etype (Comp))
5418 elsif Is_Array_Type (Rec) then
5419 return Needs_Finalization (Component_Type (Rec));
5422 return Has_Controlled_Component (Rec);
5427 end Has_Some_Controlled_Component;
5429 -- Start of processing for Needs_Finalization
5432 -- Certain run-time configurations and targets do not provide support
5433 -- for controlled types.
5435 if Restriction_Active (No_Finalization) then
5438 -- C, C++, CIL and Java types are not considered controlled. It is
5439 -- assumed that the non-Ada side will handle their clean up.
5441 elsif Convention (T) = Convention_C
5442 or else Convention (T) = Convention_CIL
5443 or else Convention (T) = Convention_CPP
5444 or else Convention (T) = Convention_Java
5449 -- Class-wide types are treated as controlled because derivations
5450 -- from the root type can introduce controlled components.
5453 Is_Class_Wide_Type (T)
5454 or else Is_Controlled (T)
5455 or else Has_Controlled_Component (T)
5456 or else Has_Some_Controlled_Component (T)
5458 (Is_Concurrent_Type (T)
5459 and then Present (Corresponding_Record_Type (T))
5460 and then Needs_Finalization (Corresponding_Record_Type (T)));
5462 end Needs_Finalization;
5464 ----------------------------
5465 -- Needs_Constant_Address --
5466 ----------------------------
5468 function Needs_Constant_Address
5470 Typ : Entity_Id) return Boolean
5474 -- If we have no initialization of any kind, then we don't need to place
5475 -- any restrictions on the address clause, because the object will be
5476 -- elaborated after the address clause is evaluated. This happens if the
5477 -- declaration has no initial expression, or the type has no implicit
5478 -- initialization, or the object is imported.
5480 -- The same holds for all initialized scalar types and all access types.
5481 -- Packed bit arrays of size up to 64 are represented using a modular
5482 -- type with an initialization (to zero) and can be processed like other
5483 -- initialized scalar types.
5485 -- If the type is controlled, code to attach the object to a
5486 -- finalization chain is generated at the point of declaration, and
5487 -- therefore the elaboration of the object cannot be delayed: the
5488 -- address expression must be a constant.
5490 if No (Expression (Decl))
5491 and then not Needs_Finalization (Typ)
5493 (not Has_Non_Null_Base_Init_Proc (Typ)
5494 or else Is_Imported (Defining_Identifier (Decl)))
5498 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
5499 or else Is_Access_Type (Typ)
5501 (Is_Bit_Packed_Array (Typ)
5502 and then Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
5508 -- Otherwise, we require the address clause to be constant because
5509 -- the call to the initialization procedure (or the attach code) has
5510 -- to happen at the point of the declaration.
5512 -- Actually the IP call has been moved to the freeze actions anyway,
5513 -- so maybe we can relax this restriction???
5517 end Needs_Constant_Address;
5519 ----------------------------
5520 -- New_Class_Wide_Subtype --
5521 ----------------------------
5523 function New_Class_Wide_Subtype
5524 (CW_Typ : Entity_Id;
5525 N : Node_Id) return Entity_Id
5527 Res : constant Entity_Id := Create_Itype (E_Void, N);
5528 Res_Name : constant Name_Id := Chars (Res);
5529 Res_Scope : constant Entity_Id := Scope (Res);
5532 Copy_Node (CW_Typ, Res);
5533 Set_Comes_From_Source (Res, False);
5534 Set_Sloc (Res, Sloc (N));
5536 Set_Associated_Node_For_Itype (Res, N);
5537 Set_Is_Public (Res, False); -- By default, may be changed below.
5538 Set_Public_Status (Res);
5539 Set_Chars (Res, Res_Name);
5540 Set_Scope (Res, Res_Scope);
5541 Set_Ekind (Res, E_Class_Wide_Subtype);
5542 Set_Next_Entity (Res, Empty);
5543 Set_Etype (Res, Base_Type (CW_Typ));
5544 Set_Is_Frozen (Res, False);
5545 Set_Freeze_Node (Res, Empty);
5547 end New_Class_Wide_Subtype;
5549 --------------------------------
5550 -- Non_Limited_Designated_Type --
5551 ---------------------------------
5553 function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
5554 Desig : constant Entity_Id := Designated_Type (T);
5556 if Ekind (Desig) = E_Incomplete_Type
5557 and then Present (Non_Limited_View (Desig))
5559 return Non_Limited_View (Desig);
5563 end Non_Limited_Designated_Type;
5565 -----------------------------------
5566 -- OK_To_Do_Constant_Replacement --
5567 -----------------------------------
5569 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
5570 ES : constant Entity_Id := Scope (E);
5574 -- Do not replace statically allocated objects, because they may be
5575 -- modified outside the current scope.
5577 if Is_Statically_Allocated (E) then
5580 -- Do not replace aliased or volatile objects, since we don't know what
5581 -- else might change the value.
5583 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
5586 -- Debug flag -gnatdM disconnects this optimization
5588 elsif Debug_Flag_MM then
5591 -- Otherwise check scopes
5594 CS := Current_Scope;
5597 -- If we are in right scope, replacement is safe
5602 -- Packages do not affect the determination of safety
5604 elsif Ekind (CS) = E_Package then
5605 exit when CS = Standard_Standard;
5608 -- Blocks do not affect the determination of safety
5610 elsif Ekind (CS) = E_Block then
5613 -- Loops do not affect the determination of safety. Note that we
5614 -- kill all current values on entry to a loop, so we are just
5615 -- talking about processing within a loop here.
5617 elsif Ekind (CS) = E_Loop then
5620 -- Otherwise, the reference is dubious, and we cannot be sure that
5621 -- it is safe to do the replacement.
5630 end OK_To_Do_Constant_Replacement;
5632 ------------------------------------
5633 -- Possible_Bit_Aligned_Component --
5634 ------------------------------------
5636 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
5640 -- Case of indexed component
5642 when N_Indexed_Component =>
5644 P : constant Node_Id := Prefix (N);
5645 Ptyp : constant Entity_Id := Etype (P);
5648 -- If we know the component size and it is less than 64, then
5649 -- we are definitely OK. The back end always does assignment of
5650 -- misaligned small objects correctly.
5652 if Known_Static_Component_Size (Ptyp)
5653 and then Component_Size (Ptyp) <= 64
5657 -- Otherwise, we need to test the prefix, to see if we are
5658 -- indexing from a possibly unaligned component.
5661 return Possible_Bit_Aligned_Component (P);
5665 -- Case of selected component
5667 when N_Selected_Component =>
5669 P : constant Node_Id := Prefix (N);
5670 Comp : constant Entity_Id := Entity (Selector_Name (N));
5673 -- If there is no component clause, then we are in the clear
5674 -- since the back end will never misalign a large component
5675 -- unless it is forced to do so. In the clear means we need
5676 -- only the recursive test on the prefix.
5678 if Component_May_Be_Bit_Aligned (Comp) then
5681 return Possible_Bit_Aligned_Component (P);
5685 -- For a slice, test the prefix, if that is possibly misaligned,
5686 -- then for sure the slice is!
5689 return Possible_Bit_Aligned_Component (Prefix (N));
5691 -- If we have none of the above, it means that we have fallen off the
5692 -- top testing prefixes recursively, and we now have a stand alone
5693 -- object, where we don't have a problem.
5699 end Possible_Bit_Aligned_Component;
5701 -----------------------------------------------
5702 -- Process_Statements_For_Controlled_Objects --
5703 -----------------------------------------------
5705 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
5706 Loc : constant Source_Ptr := Sloc (N);
5708 function Are_Wrapped (L : List_Id) return Boolean;
5709 -- Determine whether list L contains only one statement which is a block
5711 function Wrap_Statements_In_Block (L : List_Id) return Node_Id;
5712 -- Given a list of statements L, wrap it in a block statement and return
5713 -- the generated node.
5719 function Are_Wrapped (L : List_Id) return Boolean is
5720 Stmt : constant Node_Id := First (L);
5724 and then No (Next (Stmt))
5725 and then Nkind (Stmt) = N_Block_Statement;
5728 ------------------------------
5729 -- Wrap_Statements_In_Block --
5730 ------------------------------
5732 function Wrap_Statements_In_Block (L : List_Id) return Node_Id is
5735 Make_Block_Statement (Loc,
5736 Declarations => No_List,
5737 Handled_Statement_Sequence =>
5738 Make_Handled_Sequence_Of_Statements (Loc,
5740 end Wrap_Statements_In_Block;
5746 -- Start of processing for Process_Statements_For_Controlled_Objects
5749 -- Whenever a non-handled statement list is wrapped in a block, the
5750 -- block must be explicitly analyzed to redecorate all entities in the
5751 -- list and ensure that a finalizer is properly built.
5756 N_Conditional_Entry_Call |
5757 N_Selective_Accept =>
5759 -- Check the "then statements" for elsif parts and if statements
5761 if Nkind_In (N, N_Elsif_Part, N_If_Statement)
5762 and then not Is_Empty_List (Then_Statements (N))
5763 and then not Are_Wrapped (Then_Statements (N))
5764 and then Requires_Cleanup_Actions
5765 (Then_Statements (N), False, False)
5767 Block := Wrap_Statements_In_Block (Then_Statements (N));
5768 Set_Then_Statements (N, New_List (Block));
5773 -- Check the "else statements" for conditional entry calls, if
5774 -- statements and selective accepts.
5776 if Nkind_In (N, N_Conditional_Entry_Call,
5779 and then not Is_Empty_List (Else_Statements (N))
5780 and then not Are_Wrapped (Else_Statements (N))
5781 and then Requires_Cleanup_Actions
5782 (Else_Statements (N), False, False)
5784 Block := Wrap_Statements_In_Block (Else_Statements (N));
5785 Set_Else_Statements (N, New_List (Block));
5790 when N_Abortable_Part |
5791 N_Accept_Alternative |
5792 N_Case_Statement_Alternative |
5793 N_Delay_Alternative |
5794 N_Entry_Call_Alternative |
5795 N_Exception_Handler |
5797 N_Triggering_Alternative =>
5799 if not Is_Empty_List (Statements (N))
5800 and then not Are_Wrapped (Statements (N))
5801 and then Requires_Cleanup_Actions (Statements (N), False, False)
5803 Block := Wrap_Statements_In_Block (Statements (N));
5804 Set_Statements (N, New_List (Block));
5812 end Process_Statements_For_Controlled_Objects;
5814 -------------------------
5815 -- Remove_Side_Effects --
5816 -------------------------
5818 procedure Remove_Side_Effects
5820 Name_Req : Boolean := False;
5821 Variable_Ref : Boolean := False)
5823 Loc : constant Source_Ptr := Sloc (Exp);
5824 Exp_Type : constant Entity_Id := Etype (Exp);
5825 Svg_Suppress : constant Suppress_Array := Scope_Suppress;
5827 Ref_Type : Entity_Id;
5829 Ptr_Typ_Decl : Node_Id;
5833 function Side_Effect_Free (N : Node_Id) return Boolean;
5834 -- Determines if the tree N represents an expression that is known not
5835 -- to have side effects, and for which no processing is required.
5837 function Side_Effect_Free (L : List_Id) return Boolean;
5838 -- Determines if all elements of the list L are side effect free
5840 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
5841 -- The argument N is a construct where the Prefix is dereferenced if it
5842 -- is an access type and the result is a variable. The call returns True
5843 -- if the construct is side effect free (not considering side effects in
5844 -- other than the prefix which are to be tested by the caller).
5846 function Within_In_Parameter (N : Node_Id) return Boolean;
5847 -- Determines if N is a subcomponent of a composite in-parameter. If so,
5848 -- N is not side-effect free when the actual is global and modifiable
5849 -- indirectly from within a subprogram, because it may be passed by
5850 -- reference. The front-end must be conservative here and assume that
5851 -- this may happen with any array or record type. On the other hand, we
5852 -- cannot create temporaries for all expressions for which this
5853 -- condition is true, for various reasons that might require clearing up
5854 -- ??? For example, discriminant references that appear out of place, or
5855 -- spurious type errors with class-wide expressions. As a result, we
5856 -- limit the transformation to loop bounds, which is so far the only
5857 -- case that requires it.
5859 -----------------------------
5860 -- Safe_Prefixed_Reference --
5861 -----------------------------
5863 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
5865 -- If prefix is not side effect free, definitely not safe
5867 if not Side_Effect_Free (Prefix (N)) then
5870 -- If the prefix is of an access type that is not access-to-constant,
5871 -- then this construct is a variable reference, which means it is to
5872 -- be considered to have side effects if Variable_Ref is set True.
5874 elsif Is_Access_Type (Etype (Prefix (N)))
5875 and then not Is_Access_Constant (Etype (Prefix (N)))
5876 and then Variable_Ref
5878 -- Exception is a prefix that is the result of a previous removal
5881 return Is_Entity_Name (Prefix (N))
5882 and then not Comes_From_Source (Prefix (N))
5883 and then Ekind (Entity (Prefix (N))) = E_Constant
5884 and then Is_Internal_Name (Chars (Entity (Prefix (N))));
5886 -- If the prefix is an explicit dereference then this construct is a
5887 -- variable reference, which means it is to be considered to have
5888 -- side effects if Variable_Ref is True.
5890 -- We do NOT exclude dereferences of access-to-constant types because
5891 -- we handle them as constant view of variables.
5893 -- Exception is an access to an entity that is a constant or an
5896 elsif Nkind (Prefix (N)) = N_Explicit_Dereference
5897 and then Variable_Ref
5900 DDT : constant Entity_Id :=
5901 Designated_Type (Etype (Prefix (Prefix (N))));
5903 return Ekind_In (DDT, E_Constant, E_In_Parameter);
5906 -- The following test is the simplest way of solving a complex
5907 -- problem uncovered by BB08-010: Side effect on loop bound that
5908 -- is a subcomponent of a global variable:
5910 -- If a loop bound is a subcomponent of a global variable, a
5911 -- modification of that variable within the loop may incorrectly
5912 -- affect the execution of the loop.
5915 (Nkind (Parent (Parent (N))) /= N_Loop_Parameter_Specification
5916 or else not Within_In_Parameter (Prefix (N)))
5920 -- All other cases are side effect free
5925 end Safe_Prefixed_Reference;
5927 ----------------------
5928 -- Side_Effect_Free --
5929 ----------------------
5931 function Side_Effect_Free (N : Node_Id) return Boolean is
5933 -- Note on checks that could raise Constraint_Error. Strictly, if we
5934 -- take advantage of 11.6, these checks do not count as side effects.
5935 -- However, we would prefer to consider that they are side effects,
5936 -- since the backend CSE does not work very well on expressions which
5937 -- can raise Constraint_Error. On the other hand if we don't consider
5938 -- them to be side effect free, then we get some awkward expansions
5939 -- in -gnato mode, resulting in code insertions at a point where we
5940 -- do not have a clear model for performing the insertions.
5942 -- Special handling for entity names
5944 if Is_Entity_Name (N) then
5946 -- Variables are considered to be a side effect if Variable_Ref
5947 -- is set or if we have a volatile reference and Name_Req is off.
5948 -- If Name_Req is True then we can't help returning a name which
5949 -- effectively allows multiple references in any case.
5951 if Is_Variable (N, Use_Original_Node => False) then
5952 return not Variable_Ref
5953 and then (not Is_Volatile_Reference (N) or else Name_Req);
5955 -- Any other entity (e.g. a subtype name) is definitely side
5962 -- A value known at compile time is always side effect free
5964 elsif Compile_Time_Known_Value (N) then
5967 -- A variable renaming is not side-effect free, because the renaming
5968 -- will function like a macro in the front-end in some cases, and an
5969 -- assignment can modify the component designated by N, so we need to
5970 -- create a temporary for it.
5972 -- The guard testing for Entity being present is needed at least in
5973 -- the case of rewritten predicate expressions, and may well also be
5974 -- appropriate elsewhere. Obviously we can't go testing the entity
5975 -- field if it does not exist, so it's reasonable to say that this is
5976 -- not the renaming case if it does not exist.
5978 elsif Is_Entity_Name (Original_Node (N))
5979 and then Present (Entity (Original_Node (N)))
5980 and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
5981 and then Ekind (Entity (Original_Node (N))) /= E_Constant
5985 -- Remove_Side_Effects generates an object renaming declaration to
5986 -- capture the expression of a class-wide expression. In VM targets
5987 -- the frontend performs no expansion for dispatching calls to
5988 -- class- wide types since they are handled by the VM. Hence, we must
5989 -- locate here if this node corresponds to a previous invocation of
5990 -- Remove_Side_Effects to avoid a never ending loop in the frontend.
5992 elsif VM_Target /= No_VM
5993 and then not Comes_From_Source (N)
5994 and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
5995 and then Is_Class_Wide_Type (Etype (N))
6000 -- For other than entity names and compile time known values,
6001 -- check the node kind for special processing.
6005 -- An attribute reference is side effect free if its expressions
6006 -- are side effect free and its prefix is side effect free or
6007 -- is an entity reference.
6009 -- Is this right? what about x'first where x is a variable???
6011 when N_Attribute_Reference =>
6012 return Side_Effect_Free (Expressions (N))
6013 and then Attribute_Name (N) /= Name_Input
6014 and then (Is_Entity_Name (Prefix (N))
6015 or else Side_Effect_Free (Prefix (N)));
6017 -- A binary operator is side effect free if and both operands are
6018 -- side effect free. For this purpose binary operators include
6019 -- membership tests and short circuit forms
6021 when N_Binary_Op | N_Membership_Test | N_Short_Circuit =>
6022 return Side_Effect_Free (Left_Opnd (N))
6024 Side_Effect_Free (Right_Opnd (N));
6026 -- An explicit dereference is side effect free only if it is
6027 -- a side effect free prefixed reference.
6029 when N_Explicit_Dereference =>
6030 return Safe_Prefixed_Reference (N);
6032 -- A call to _rep_to_pos is side effect free, since we generate
6033 -- this pure function call ourselves. Moreover it is critically
6034 -- important to make this exception, since otherwise we can have
6035 -- discriminants in array components which don't look side effect
6036 -- free in the case of an array whose index type is an enumeration
6037 -- type with an enumeration rep clause.
6039 -- All other function calls are not side effect free
6041 when N_Function_Call =>
6042 return Nkind (Name (N)) = N_Identifier
6043 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
6045 Side_Effect_Free (First (Parameter_Associations (N)));
6047 -- An indexed component is side effect free if it is a side
6048 -- effect free prefixed reference and all the indexing
6049 -- expressions are side effect free.
6051 when N_Indexed_Component =>
6052 return Side_Effect_Free (Expressions (N))
6053 and then Safe_Prefixed_Reference (N);
6055 -- A type qualification is side effect free if the expression
6056 -- is side effect free.
6058 when N_Qualified_Expression =>
6059 return Side_Effect_Free (Expression (N));
6061 -- A selected component is side effect free only if it is a side
6062 -- effect free prefixed reference. If it designates a component
6063 -- with a rep. clause it must be treated has having a potential
6064 -- side effect, because it may be modified through a renaming, and
6065 -- a subsequent use of the renaming as a macro will yield the
6066 -- wrong value. This complex interaction between renaming and
6067 -- removing side effects is a reminder that the latter has become
6068 -- a headache to maintain, and that it should be removed in favor
6069 -- of the gcc mechanism to capture values ???
6071 when N_Selected_Component =>
6072 if Nkind (Parent (N)) = N_Explicit_Dereference
6073 and then Has_Non_Standard_Rep (Designated_Type (Etype (N)))
6077 return Safe_Prefixed_Reference (N);
6080 -- A range is side effect free if the bounds are side effect free
6083 return Side_Effect_Free (Low_Bound (N))
6084 and then Side_Effect_Free (High_Bound (N));
6086 -- A slice is side effect free if it is a side effect free
6087 -- prefixed reference and the bounds are side effect free.
6090 return Side_Effect_Free (Discrete_Range (N))
6091 and then Safe_Prefixed_Reference (N);
6093 -- A type conversion is side effect free if the expression to be
6094 -- converted is side effect free.
6096 when N_Type_Conversion =>
6097 return Side_Effect_Free (Expression (N));
6099 -- A unary operator is side effect free if the operand
6100 -- is side effect free.
6103 return Side_Effect_Free (Right_Opnd (N));
6105 -- An unchecked type conversion is side effect free only if it
6106 -- is safe and its argument is side effect free.
6108 when N_Unchecked_Type_Conversion =>
6109 return Safe_Unchecked_Type_Conversion (N)
6110 and then Side_Effect_Free (Expression (N));
6112 -- An unchecked expression is side effect free if its expression
6113 -- is side effect free.
6115 when N_Unchecked_Expression =>
6116 return Side_Effect_Free (Expression (N));
6118 -- A literal is side effect free
6120 when N_Character_Literal |
6126 -- We consider that anything else has side effects. This is a bit
6127 -- crude, but we are pretty close for most common cases, and we
6128 -- are certainly correct (i.e. we never return True when the
6129 -- answer should be False).
6134 end Side_Effect_Free;
6136 -- A list is side effect free if all elements of the list are side
6139 function Side_Effect_Free (L : List_Id) return Boolean is
6143 if L = No_List or else L = Error_List then
6148 while Present (N) loop
6149 if not Side_Effect_Free (N) then
6158 end Side_Effect_Free;
6160 -------------------------
6161 -- Within_In_Parameter --
6162 -------------------------
6164 function Within_In_Parameter (N : Node_Id) return Boolean is
6166 if not Comes_From_Source (N) then
6169 elsif Is_Entity_Name (N) then
6170 return Ekind (Entity (N)) = E_In_Parameter;
6172 elsif Nkind (N) = N_Indexed_Component
6173 or else Nkind (N) = N_Selected_Component
6175 return Within_In_Parameter (Prefix (N));
6180 end Within_In_Parameter;
6182 -- Start of processing for Remove_Side_Effects
6185 -- Handle cases in which there is nothing to do
6187 if not Expander_Active then
6190 -- Cannot generate temporaries if the invocation to remove side effects
6191 -- was issued too early and the type of the expression is not resolved
6192 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
6193 -- Remove_Side_Effects).
6196 or else Ekind (Exp_Type) = E_Access_Attribute_Type
6200 -- No action needed for side-effect free expressions
6202 elsif Side_Effect_Free (Exp) then
6206 -- All this must not have any checks
6208 Scope_Suppress := (others => True);
6210 -- If it is a scalar type and we need to capture the value, just make
6211 -- a copy. Likewise for a function call, an attribute reference, an
6212 -- allocator, or an operator. And if we have a volatile reference and
6213 -- Name_Req is not set (see comments above for Side_Effect_Free).
6215 if Is_Elementary_Type (Exp_Type)
6216 and then (Variable_Ref
6217 or else Nkind (Exp) = N_Function_Call
6218 or else Nkind (Exp) = N_Attribute_Reference
6219 or else Nkind (Exp) = N_Allocator
6220 or else Nkind (Exp) in N_Op
6221 or else (not Name_Req and then Is_Volatile_Reference (Exp)))
6223 Def_Id := Make_Temporary (Loc, 'R', Exp);
6224 Set_Etype (Def_Id, Exp_Type);
6225 Res := New_Reference_To (Def_Id, Loc);
6227 -- If the expression is a packed reference, it must be reanalyzed and
6228 -- expanded, depending on context. This is the case for actuals where
6229 -- a constraint check may capture the actual before expansion of the
6230 -- call is complete.
6232 if Nkind (Exp) = N_Indexed_Component
6233 and then Is_Packed (Etype (Prefix (Exp)))
6235 Set_Analyzed (Exp, False);
6236 Set_Analyzed (Prefix (Exp), False);
6240 Make_Object_Declaration (Loc,
6241 Defining_Identifier => Def_Id,
6242 Object_Definition => New_Reference_To (Exp_Type, Loc),
6243 Constant_Present => True,
6244 Expression => Relocate_Node (Exp));
6246 Set_Assignment_OK (E);
6247 Insert_Action (Exp, E);
6249 -- If the expression has the form v.all then we can just capture the
6250 -- pointer, and then do an explicit dereference on the result.
6252 elsif Nkind (Exp) = N_Explicit_Dereference then
6253 Def_Id := Make_Temporary (Loc, 'R', Exp);
6255 Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc));
6258 Make_Object_Declaration (Loc,
6259 Defining_Identifier => Def_Id,
6260 Object_Definition =>
6261 New_Reference_To (Etype (Prefix (Exp)), Loc),
6262 Constant_Present => True,
6263 Expression => Relocate_Node (Prefix (Exp))));
6265 -- Similar processing for an unchecked conversion of an expression of
6266 -- the form v.all, where we want the same kind of treatment.
6268 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
6269 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
6271 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
6272 Scope_Suppress := Svg_Suppress;
6275 -- If this is a type conversion, leave the type conversion and remove
6276 -- the side effects in the expression. This is important in several
6277 -- circumstances: for change of representations, and also when this is a
6278 -- view conversion to a smaller object, where gigi can end up creating
6279 -- its own temporary of the wrong size.
6281 elsif Nkind (Exp) = N_Type_Conversion then
6282 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
6283 Scope_Suppress := Svg_Suppress;
6286 -- If this is an unchecked conversion that Gigi can't handle, make
6287 -- a copy or a use a renaming to capture the value.
6289 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
6290 and then not Safe_Unchecked_Type_Conversion (Exp)
6292 if CW_Or_Has_Controlled_Part (Exp_Type) then
6294 -- Use a renaming to capture the expression, rather than create
6295 -- a controlled temporary.
6297 Def_Id := Make_Temporary (Loc, 'R', Exp);
6298 Res := New_Reference_To (Def_Id, Loc);
6301 Make_Object_Renaming_Declaration (Loc,
6302 Defining_Identifier => Def_Id,
6303 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
6304 Name => Relocate_Node (Exp)));
6307 Def_Id := Make_Temporary (Loc, 'R', Exp);
6308 Set_Etype (Def_Id, Exp_Type);
6309 Res := New_Reference_To (Def_Id, Loc);
6312 Make_Object_Declaration (Loc,
6313 Defining_Identifier => Def_Id,
6314 Object_Definition => New_Reference_To (Exp_Type, Loc),
6315 Constant_Present => not Is_Variable (Exp),
6316 Expression => Relocate_Node (Exp));
6318 Set_Assignment_OK (E);
6319 Insert_Action (Exp, E);
6322 -- For expressions that denote objects, we can use a renaming scheme.
6323 -- This is needed for correctness in the case of a volatile object of a
6324 -- non-volatile type because the Make_Reference call of the "default"
6325 -- approach would generate an illegal access value (an access value
6326 -- cannot designate such an object - see Analyze_Reference). We skip
6327 -- using this scheme if we have an object of a volatile type and we do
6328 -- not have Name_Req set true (see comments above for Side_Effect_Free).
6330 elsif Is_Object_Reference (Exp)
6331 and then Nkind (Exp) /= N_Function_Call
6332 and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
6334 Def_Id := Make_Temporary (Loc, 'R', Exp);
6336 if Nkind (Exp) = N_Selected_Component
6337 and then Nkind (Prefix (Exp)) = N_Function_Call
6338 and then Is_Array_Type (Exp_Type)
6340 -- Avoid generating a variable-sized temporary, by generating
6341 -- the renaming declaration just for the function call. The
6342 -- transformation could be refined to apply only when the array
6343 -- component is constrained by a discriminant???
6346 Make_Selected_Component (Loc,
6347 Prefix => New_Occurrence_Of (Def_Id, Loc),
6348 Selector_Name => Selector_Name (Exp));
6351 Make_Object_Renaming_Declaration (Loc,
6352 Defining_Identifier => Def_Id,
6354 New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
6355 Name => Relocate_Node (Prefix (Exp))));
6358 Res := New_Reference_To (Def_Id, Loc);
6361 Make_Object_Renaming_Declaration (Loc,
6362 Defining_Identifier => Def_Id,
6363 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
6364 Name => Relocate_Node (Exp)));
6367 -- If this is a packed reference, or a selected component with
6368 -- a non-standard representation, a reference to the temporary
6369 -- will be replaced by a copy of the original expression (see
6370 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
6371 -- elaborated by gigi, and is of course not to be replaced in-line
6372 -- by the expression it renames, which would defeat the purpose of
6373 -- removing the side-effect.
6375 if (Nkind (Exp) = N_Selected_Component
6376 or else Nkind (Exp) = N_Indexed_Component)
6377 and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
6381 Set_Is_Renaming_Of_Object (Def_Id, False);
6384 -- Otherwise we generate a reference to the value
6387 -- Special processing for function calls that return a limited type.
6388 -- We need to build a declaration that will enable build-in-place
6389 -- expansion of the call. This is not done if the context is already
6390 -- an object declaration, to prevent infinite recursion.
6392 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
6393 -- to accommodate functions returning limited objects by reference.
6395 if Nkind (Exp) = N_Function_Call
6396 and then Is_Immutably_Limited_Type (Etype (Exp))
6397 and then Nkind (Parent (Exp)) /= N_Object_Declaration
6398 and then Ada_Version >= Ada_2005
6401 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
6406 Make_Object_Declaration (Loc,
6407 Defining_Identifier => Obj,
6408 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
6409 Expression => Relocate_Node (Exp));
6411 Insert_Action (Exp, Decl);
6412 Set_Etype (Obj, Exp_Type);
6413 Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
6418 Ref_Type := Make_Temporary (Loc, 'A');
6421 Make_Full_Type_Declaration (Loc,
6422 Defining_Identifier => Ref_Type,
6424 Make_Access_To_Object_Definition (Loc,
6425 All_Present => True,
6426 Subtype_Indication =>
6427 New_Reference_To (Exp_Type, Loc)));
6430 Insert_Action (Exp, Ptr_Typ_Decl);
6432 Def_Id := Make_Temporary (Loc, 'R', Exp);
6433 Set_Etype (Def_Id, Exp_Type);
6436 Make_Explicit_Dereference (Loc,
6437 Prefix => New_Reference_To (Def_Id, Loc));
6439 if Nkind (E) = N_Explicit_Dereference then
6440 New_Exp := Relocate_Node (Prefix (E));
6442 E := Relocate_Node (E);
6443 New_Exp := Make_Reference (Loc, E);
6446 if Is_Delayed_Aggregate (E) then
6448 -- The expansion of nested aggregates is delayed until the
6449 -- enclosing aggregate is expanded. As aggregates are often
6450 -- qualified, the predicate applies to qualified expressions as
6451 -- well, indicating that the enclosing aggregate has not been
6452 -- expanded yet. At this point the aggregate is part of a
6453 -- stand-alone declaration, and must be fully expanded.
6455 if Nkind (E) = N_Qualified_Expression then
6456 Set_Expansion_Delayed (Expression (E), False);
6457 Set_Analyzed (Expression (E), False);
6459 Set_Expansion_Delayed (E, False);
6462 Set_Analyzed (E, False);
6466 Make_Object_Declaration (Loc,
6467 Defining_Identifier => Def_Id,
6468 Object_Definition => New_Reference_To (Ref_Type, Loc),
6469 Constant_Present => True,
6470 Expression => New_Exp));
6473 -- Preserve the Assignment_OK flag in all copies, since at least one
6474 -- copy may be used in a context where this flag must be set (otherwise
6475 -- why would the flag be set in the first place).
6477 Set_Assignment_OK (Res, Assignment_OK (Exp));
6479 -- Finally rewrite the original expression and we are done
6482 Analyze_And_Resolve (Exp, Exp_Type);
6483 Scope_Suppress := Svg_Suppress;
6484 end Remove_Side_Effects;
6486 ---------------------------
6487 -- Represented_As_Scalar --
6488 ---------------------------
6490 function Represented_As_Scalar (T : Entity_Id) return Boolean is
6491 UT : constant Entity_Id := Underlying_Type (T);
6493 return Is_Scalar_Type (UT)
6494 or else (Is_Bit_Packed_Array (UT)
6495 and then Is_Scalar_Type (Packed_Array_Type (UT)));
6496 end Represented_As_Scalar;
6498 ------------------------------
6499 -- Requires_Cleanup_Actions --
6500 ------------------------------
6502 function Requires_Cleanup_Actions (N : Node_Id) return Boolean is
6503 For_Pkg : constant Boolean :=
6504 Nkind_In (N, N_Package_Body, N_Package_Specification);
6508 when N_Accept_Statement |
6516 Requires_Cleanup_Actions (Declarations (N), For_Pkg, True)
6518 (Present (Handled_Statement_Sequence (N))
6520 Requires_Cleanup_Actions (Statements
6521 (Handled_Statement_Sequence (N)), For_Pkg, True));
6523 when N_Package_Specification =>
6525 Requires_Cleanup_Actions
6526 (Visible_Declarations (N), For_Pkg, True)
6528 Requires_Cleanup_Actions
6529 (Private_Declarations (N), For_Pkg, True);
6534 end Requires_Cleanup_Actions;
6536 ------------------------------
6537 -- Requires_Cleanup_Actions --
6538 ------------------------------
6540 function Requires_Cleanup_Actions
6542 For_Package : Boolean;
6543 Nested_Constructs : Boolean) return Boolean
6548 Obj_Typ : Entity_Id;
6549 Pack_Id : Entity_Id;
6554 or else Is_Empty_List (L)
6560 while Present (Decl) loop
6562 -- Library-level tagged types
6564 if Nkind (Decl) = N_Full_Type_Declaration then
6565 Typ := Defining_Identifier (Decl);
6567 if Is_Tagged_Type (Typ)
6568 and then Is_Library_Level_Entity (Typ)
6569 and then Convention (Typ) = Convention_Ada
6570 and then Present (Access_Disp_Table (Typ))
6571 and then RTE_Available (RE_Unregister_Tag)
6572 and then not No_Run_Time_Mode
6573 and then not Is_Abstract_Type (Typ)
6578 -- Regular object declarations
6580 elsif Nkind (Decl) = N_Object_Declaration then
6581 Obj_Id := Defining_Identifier (Decl);
6582 Obj_Typ := Base_Type (Etype (Obj_Id));
6583 Expr := Expression (Decl);
6585 -- Bypass any form of processing for objects which have their
6586 -- finalization disabled. This applies only to objects at the
6590 and then Finalize_Storage_Only (Obj_Typ)
6594 -- Transient variables are treated separately in order to minimize
6595 -- the size of the generated code. See Exp_Ch7.Process_Transient_
6598 elsif Is_Processed_Transient (Obj_Id) then
6601 -- The object is of the form:
6602 -- Obj : Typ [:= Expr];
6604 -- Do not process the incomplete view of a deferred constant. Do
6605 -- not consider tag-to-class-wide conversions.
6607 elsif not Is_Imported (Obj_Id)
6608 and then Needs_Finalization (Obj_Typ)
6609 and then not (Ekind (Obj_Id) = E_Constant
6610 and then not Has_Completion (Obj_Id))
6611 and then not Is_Tag_To_CW_Conversion (Obj_Id)
6615 -- The object is of the form:
6616 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
6618 -- Obj : Access_Typ :=
6619 -- BIP_Function_Call
6620 -- (..., BIPaccess => null, ...)'reference;
6622 elsif Is_Access_Type (Obj_Typ)
6623 and then Needs_Finalization
6624 (Available_View (Designated_Type (Obj_Typ)))
6625 and then Present (Expr)
6627 (Is_Null_Access_BIP_Func_Call (Expr)
6629 (Is_Non_BIP_Func_Call (Expr)
6630 and then not Is_Related_To_Func_Return (Obj_Id)))
6634 -- Processing for "hook" objects generated for controlled
6635 -- transients declared inside an Expression_With_Actions.
6637 elsif Is_Access_Type (Obj_Typ)
6638 and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
6639 and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
6640 N_Object_Declaration
6641 and then Is_Finalizable_Transient
6642 (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
6646 -- Simple protected objects which use type System.Tasking.
6647 -- Protected_Objects.Protection to manage their locks should be
6648 -- treated as controlled since they require manual cleanup.
6650 elsif Ekind (Obj_Id) = E_Variable
6652 (Is_Simple_Protected_Type (Obj_Typ)
6653 or else Has_Simple_Protected_Object (Obj_Typ))
6658 -- Specific cases of object renamings
6660 elsif Nkind (Decl) = N_Object_Renaming_Declaration
6661 and then Nkind (Name (Decl)) = N_Explicit_Dereference
6662 and then Nkind (Prefix (Name (Decl))) = N_Identifier
6664 Obj_Id := Defining_Identifier (Decl);
6665 Obj_Typ := Base_Type (Etype (Obj_Id));
6667 -- Bypass any form of processing for objects which have their
6668 -- finalization disabled. This applies only to objects at the
6672 and then Finalize_Storage_Only (Obj_Typ)
6676 -- Return object of a build-in-place function. This case is
6677 -- recognized and marked by the expansion of an extended return
6678 -- statement (see Expand_N_Extended_Return_Statement).
6680 elsif Needs_Finalization (Obj_Typ)
6681 and then Is_Return_Object (Obj_Id)
6682 and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
6687 -- Inspect the freeze node of an access-to-controlled type and look
6688 -- for a delayed finalization master. This case arises when the
6689 -- freeze actions are inserted at a later time than the expansion of
6690 -- the context. Since Build_Finalizer is never called on a single
6691 -- construct twice, the master will be ultimately left out and never
6692 -- finalized. This is also needed for freeze actions of designated
6693 -- types themselves, since in some cases the finalization master is
6694 -- associated with a designated type's freeze node rather than that
6695 -- of the access type (see handling for freeze actions in
6696 -- Build_Finalization_Master).
6698 elsif Nkind (Decl) = N_Freeze_Entity
6699 and then Present (Actions (Decl))
6701 Typ := Entity (Decl);
6703 if ((Is_Access_Type (Typ)
6704 and then not Is_Access_Subprogram_Type (Typ)
6705 and then Needs_Finalization
6706 (Available_View (Designated_Type (Typ))))
6709 and then Needs_Finalization (Typ)))
6710 and then Requires_Cleanup_Actions
6711 (Actions (Decl), For_Package, Nested_Constructs)
6716 -- Nested package declarations
6718 elsif Nested_Constructs
6719 and then Nkind (Decl) = N_Package_Declaration
6721 Pack_Id := Defining_Unit_Name (Specification (Decl));
6723 if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
6724 Pack_Id := Defining_Identifier (Pack_Id);
6727 if Ekind (Pack_Id) /= E_Generic_Package
6728 and then Requires_Cleanup_Actions (Specification (Decl))
6733 -- Nested package bodies
6735 elsif Nested_Constructs
6736 and then Nkind (Decl) = N_Package_Body
6738 Pack_Id := Corresponding_Spec (Decl);
6740 if Ekind (Pack_Id) /= E_Generic_Package
6741 and then Requires_Cleanup_Actions (Decl)
6751 end Requires_Cleanup_Actions;
6753 ------------------------------------
6754 -- Safe_Unchecked_Type_Conversion --
6755 ------------------------------------
6757 -- Note: this function knows quite a bit about the exact requirements of
6758 -- Gigi with respect to unchecked type conversions, and its code must be
6759 -- coordinated with any changes in Gigi in this area.
6761 -- The above requirements should be documented in Sinfo ???
6763 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
6768 Pexp : constant Node_Id := Parent (Exp);
6771 -- If the expression is the RHS of an assignment or object declaration
6772 -- we are always OK because there will always be a target.
6774 -- Object renaming declarations, (generated for view conversions of
6775 -- actuals in inlined calls), like object declarations, provide an
6776 -- explicit type, and are safe as well.
6778 if (Nkind (Pexp) = N_Assignment_Statement
6779 and then Expression (Pexp) = Exp)
6780 or else Nkind (Pexp) = N_Object_Declaration
6781 or else Nkind (Pexp) = N_Object_Renaming_Declaration
6785 -- If the expression is the prefix of an N_Selected_Component we should
6786 -- also be OK because GCC knows to look inside the conversion except if
6787 -- the type is discriminated. We assume that we are OK anyway if the
6788 -- type is not set yet or if it is controlled since we can't afford to
6789 -- introduce a temporary in this case.
6791 elsif Nkind (Pexp) = N_Selected_Component
6792 and then Prefix (Pexp) = Exp
6794 if No (Etype (Pexp)) then
6798 not Has_Discriminants (Etype (Pexp))
6799 or else Is_Constrained (Etype (Pexp));
6803 -- Set the output type, this comes from Etype if it is set, otherwise we
6804 -- take it from the subtype mark, which we assume was already fully
6807 if Present (Etype (Exp)) then
6808 Otyp := Etype (Exp);
6810 Otyp := Entity (Subtype_Mark (Exp));
6813 -- The input type always comes from the expression, and we assume
6814 -- this is indeed always analyzed, so we can simply get the Etype.
6816 Ityp := Etype (Expression (Exp));
6818 -- Initialize alignments to unknown so far
6823 -- Replace a concurrent type by its corresponding record type and each
6824 -- type by its underlying type and do the tests on those. The original
6825 -- type may be a private type whose completion is a concurrent type, so
6826 -- find the underlying type first.
6828 if Present (Underlying_Type (Otyp)) then
6829 Otyp := Underlying_Type (Otyp);
6832 if Present (Underlying_Type (Ityp)) then
6833 Ityp := Underlying_Type (Ityp);
6836 if Is_Concurrent_Type (Otyp) then
6837 Otyp := Corresponding_Record_Type (Otyp);
6840 if Is_Concurrent_Type (Ityp) then
6841 Ityp := Corresponding_Record_Type (Ityp);
6844 -- If the base types are the same, we know there is no problem since
6845 -- this conversion will be a noop.
6847 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
6850 -- Same if this is an upwards conversion of an untagged type, and there
6851 -- are no constraints involved (could be more general???)
6853 elsif Etype (Ityp) = Otyp
6854 and then not Is_Tagged_Type (Ityp)
6855 and then not Has_Discriminants (Ityp)
6856 and then No (First_Rep_Item (Base_Type (Ityp)))
6860 -- If the expression has an access type (object or subprogram) we assume
6861 -- that the conversion is safe, because the size of the target is safe,
6862 -- even if it is a record (which might be treated as having unknown size
6865 elsif Is_Access_Type (Ityp) then
6868 -- If the size of output type is known at compile time, there is never
6869 -- a problem. Note that unconstrained records are considered to be of
6870 -- known size, but we can't consider them that way here, because we are
6871 -- talking about the actual size of the object.
6873 -- We also make sure that in addition to the size being known, we do not
6874 -- have a case which might generate an embarrassingly large temp in
6875 -- stack checking mode.
6877 elsif Size_Known_At_Compile_Time (Otyp)
6879 (not Stack_Checking_Enabled
6880 or else not May_Generate_Large_Temp (Otyp))
6881 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
6885 -- If either type is tagged, then we know the alignment is OK so
6886 -- Gigi will be able to use pointer punning.
6888 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
6891 -- If either type is a limited record type, we cannot do a copy, so say
6892 -- safe since there's nothing else we can do.
6894 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
6897 -- Conversions to and from packed array types are always ignored and
6900 elsif Is_Packed_Array_Type (Otyp)
6901 or else Is_Packed_Array_Type (Ityp)
6906 -- The only other cases known to be safe is if the input type's
6907 -- alignment is known to be at least the maximum alignment for the
6908 -- target or if both alignments are known and the output type's
6909 -- alignment is no stricter than the input's. We can use the component
6910 -- type alignement for an array if a type is an unpacked array type.
6912 if Present (Alignment_Clause (Otyp)) then
6913 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
6915 elsif Is_Array_Type (Otyp)
6916 and then Present (Alignment_Clause (Component_Type (Otyp)))
6918 Oalign := Expr_Value (Expression (Alignment_Clause
6919 (Component_Type (Otyp))));
6922 if Present (Alignment_Clause (Ityp)) then
6923 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
6925 elsif Is_Array_Type (Ityp)
6926 and then Present (Alignment_Clause (Component_Type (Ityp)))
6928 Ialign := Expr_Value (Expression (Alignment_Clause
6929 (Component_Type (Ityp))));
6932 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
6935 elsif Ialign /= No_Uint and then Oalign /= No_Uint
6936 and then Ialign <= Oalign
6940 -- Otherwise, Gigi cannot handle this and we must make a temporary
6945 end Safe_Unchecked_Type_Conversion;
6947 ---------------------------------
6948 -- Set_Current_Value_Condition --
6949 ---------------------------------
6951 -- Note: the implementation of this procedure is very closely tied to the
6952 -- implementation of Get_Current_Value_Condition. Here we set required
6953 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
6954 -- them, so they must have a consistent view.
6956 procedure Set_Current_Value_Condition (Cnode : Node_Id) is
6958 procedure Set_Entity_Current_Value (N : Node_Id);
6959 -- If N is an entity reference, where the entity is of an appropriate
6960 -- kind, then set the current value of this entity to Cnode, unless
6961 -- there is already a definite value set there.
6963 procedure Set_Expression_Current_Value (N : Node_Id);
6964 -- If N is of an appropriate form, sets an appropriate entry in current
6965 -- value fields of relevant entities. Multiple entities can be affected
6966 -- in the case of an AND or AND THEN.
6968 ------------------------------
6969 -- Set_Entity_Current_Value --
6970 ------------------------------
6972 procedure Set_Entity_Current_Value (N : Node_Id) is
6974 if Is_Entity_Name (N) then
6976 Ent : constant Entity_Id := Entity (N);
6979 -- Don't capture if not safe to do so
6981 if not Safe_To_Capture_Value (N, Ent, Cond => True) then
6985 -- Here we have a case where the Current_Value field may need
6986 -- to be set. We set it if it is not already set to a compile
6987 -- time expression value.
6989 -- Note that this represents a decision that one condition
6990 -- blots out another previous one. That's certainly right if
6991 -- they occur at the same level. If the second one is nested,
6992 -- then the decision is neither right nor wrong (it would be
6993 -- equally OK to leave the outer one in place, or take the new
6994 -- inner one. Really we should record both, but our data
6995 -- structures are not that elaborate.
6997 if Nkind (Current_Value (Ent)) not in N_Subexpr then
6998 Set_Current_Value (Ent, Cnode);
7002 end Set_Entity_Current_Value;
7004 ----------------------------------
7005 -- Set_Expression_Current_Value --
7006 ----------------------------------
7008 procedure Set_Expression_Current_Value (N : Node_Id) is
7014 -- Loop to deal with (ignore for now) any NOT operators present. The
7015 -- presence of NOT operators will be handled properly when we call
7016 -- Get_Current_Value_Condition.
7018 while Nkind (Cond) = N_Op_Not loop
7019 Cond := Right_Opnd (Cond);
7022 -- For an AND or AND THEN, recursively process operands
7024 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
7025 Set_Expression_Current_Value (Left_Opnd (Cond));
7026 Set_Expression_Current_Value (Right_Opnd (Cond));
7030 -- Check possible relational operator
7032 if Nkind (Cond) in N_Op_Compare then
7033 if Compile_Time_Known_Value (Right_Opnd (Cond)) then
7034 Set_Entity_Current_Value (Left_Opnd (Cond));
7035 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
7036 Set_Entity_Current_Value (Right_Opnd (Cond));
7039 -- Check possible boolean variable reference
7042 Set_Entity_Current_Value (Cond);
7044 end Set_Expression_Current_Value;
7046 -- Start of processing for Set_Current_Value_Condition
7049 Set_Expression_Current_Value (Condition (Cnode));
7050 end Set_Current_Value_Condition;
7052 --------------------------
7053 -- Set_Elaboration_Flag --
7054 --------------------------
7056 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
7057 Loc : constant Source_Ptr := Sloc (N);
7058 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
7062 if Present (Ent) then
7064 -- Nothing to do if at the compilation unit level, because in this
7065 -- case the flag is set by the binder generated elaboration routine.
7067 if Nkind (Parent (N)) = N_Compilation_Unit then
7070 -- Here we do need to generate an assignment statement
7073 Check_Restriction (No_Elaboration_Code, N);
7075 Make_Assignment_Statement (Loc,
7076 Name => New_Occurrence_Of (Ent, Loc),
7077 Expression => Make_Integer_Literal (Loc, Uint_1));
7079 if Nkind (Parent (N)) = N_Subunit then
7080 Insert_After (Corresponding_Stub (Parent (N)), Asn);
7082 Insert_After (N, Asn);
7087 -- Kill current value indication. This is necessary because the
7088 -- tests of this flag are inserted out of sequence and must not
7089 -- pick up bogus indications of the wrong constant value.
7091 Set_Current_Value (Ent, Empty);
7094 end Set_Elaboration_Flag;
7096 ----------------------------
7097 -- Set_Renamed_Subprogram --
7098 ----------------------------
7100 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
7102 -- If input node is an identifier, we can just reset it
7104 if Nkind (N) = N_Identifier then
7105 Set_Chars (N, Chars (E));
7108 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
7112 CS : constant Boolean := Comes_From_Source (N);
7114 Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
7116 Set_Comes_From_Source (N, CS);
7117 Set_Analyzed (N, True);
7120 end Set_Renamed_Subprogram;
7122 ----------------------------------
7123 -- Silly_Boolean_Array_Not_Test --
7124 ----------------------------------
7126 -- This procedure implements an odd and silly test. We explicitly check
7127 -- for the case where the 'First of the component type is equal to the
7128 -- 'Last of this component type, and if this is the case, we make sure
7129 -- that constraint error is raised. The reason is that the NOT is bound
7130 -- to cause CE in this case, and we will not otherwise catch it.
7132 -- No such check is required for AND and OR, since for both these cases
7133 -- False op False = False, and True op True = True. For the XOR case,
7134 -- see Silly_Boolean_Array_Xor_Test.
7136 -- Believe it or not, this was reported as a bug. Note that nearly always,
7137 -- the test will evaluate statically to False, so the code will be
7138 -- statically removed, and no extra overhead caused.
7140 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
7141 Loc : constant Source_Ptr := Sloc (N);
7142 CT : constant Entity_Id := Component_Type (T);
7145 -- The check we install is
7147 -- constraint_error when
7148 -- component_type'first = component_type'last
7149 -- and then array_type'Length /= 0)
7151 -- We need the last guard because we don't want to raise CE for empty
7152 -- arrays since no out of range values result. (Empty arrays with a
7153 -- component type of True .. True -- very useful -- even the ACATS
7154 -- does not test that marginal case!)
7157 Make_Raise_Constraint_Error (Loc,
7163 Make_Attribute_Reference (Loc,
7164 Prefix => New_Occurrence_Of (CT, Loc),
7165 Attribute_Name => Name_First),
7168 Make_Attribute_Reference (Loc,
7169 Prefix => New_Occurrence_Of (CT, Loc),
7170 Attribute_Name => Name_Last)),
7172 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
7173 Reason => CE_Range_Check_Failed));
7174 end Silly_Boolean_Array_Not_Test;
7176 ----------------------------------
7177 -- Silly_Boolean_Array_Xor_Test --
7178 ----------------------------------
7180 -- This procedure implements an odd and silly test. We explicitly check
7181 -- for the XOR case where the component type is True .. True, since this
7182 -- will raise constraint error. A special check is required since CE
7183 -- will not be generated otherwise (cf Expand_Packed_Not).
7185 -- No such check is required for AND and OR, since for both these cases
7186 -- False op False = False, and True op True = True, and no check is
7187 -- required for the case of False .. False, since False xor False = False.
7188 -- See also Silly_Boolean_Array_Not_Test
7190 procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is
7191 Loc : constant Source_Ptr := Sloc (N);
7192 CT : constant Entity_Id := Component_Type (T);
7195 -- The check we install is
7197 -- constraint_error when
7198 -- Boolean (component_type'First)
7199 -- and then Boolean (component_type'Last)
7200 -- and then array_type'Length /= 0)
7202 -- We need the last guard because we don't want to raise CE for empty
7203 -- arrays since no out of range values result (Empty arrays with a
7204 -- component type of True .. True -- very useful -- even the ACATS
7205 -- does not test that marginal case!).
7208 Make_Raise_Constraint_Error (Loc,
7214 Convert_To (Standard_Boolean,
7215 Make_Attribute_Reference (Loc,
7216 Prefix => New_Occurrence_Of (CT, Loc),
7217 Attribute_Name => Name_First)),
7220 Convert_To (Standard_Boolean,
7221 Make_Attribute_Reference (Loc,
7222 Prefix => New_Occurrence_Of (CT, Loc),
7223 Attribute_Name => Name_Last))),
7225 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
7226 Reason => CE_Range_Check_Failed));
7227 end Silly_Boolean_Array_Xor_Test;
7229 --------------------------
7230 -- Target_Has_Fixed_Ops --
7231 --------------------------
7233 Integer_Sized_Small : Ureal;
7234 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
7235 -- called (we don't want to compute it more than once!)
7237 Long_Integer_Sized_Small : Ureal;
7238 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
7239 -- is called (we don't want to compute it more than once)
7241 First_Time_For_THFO : Boolean := True;
7242 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
7244 function Target_Has_Fixed_Ops
7245 (Left_Typ : Entity_Id;
7246 Right_Typ : Entity_Id;
7247 Result_Typ : Entity_Id) return Boolean
7249 function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
7250 -- Return True if the given type is a fixed-point type with a small
7251 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
7252 -- an absolute value less than 1.0. This is currently limited to
7253 -- fixed-point types that map to Integer or Long_Integer.
7255 ------------------------
7256 -- Is_Fractional_Type --
7257 ------------------------
7259 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
7261 if Esize (Typ) = Standard_Integer_Size then
7262 return Small_Value (Typ) = Integer_Sized_Small;
7264 elsif Esize (Typ) = Standard_Long_Integer_Size then
7265 return Small_Value (Typ) = Long_Integer_Sized_Small;
7270 end Is_Fractional_Type;
7272 -- Start of processing for Target_Has_Fixed_Ops
7275 -- Return False if Fractional_Fixed_Ops_On_Target is false
7277 if not Fractional_Fixed_Ops_On_Target then
7281 -- Here the target has Fractional_Fixed_Ops, if first time, compute
7282 -- standard constants used by Is_Fractional_Type.
7284 if First_Time_For_THFO then
7285 First_Time_For_THFO := False;
7287 Integer_Sized_Small :=
7290 Den => UI_From_Int (Standard_Integer_Size - 1),
7293 Long_Integer_Sized_Small :=
7296 Den => UI_From_Int (Standard_Long_Integer_Size - 1),
7300 -- Return True if target supports fixed-by-fixed multiply/divide for
7301 -- fractional fixed-point types (see Is_Fractional_Type) and the operand
7302 -- and result types are equivalent fractional types.
7304 return Is_Fractional_Type (Base_Type (Left_Typ))
7305 and then Is_Fractional_Type (Base_Type (Right_Typ))
7306 and then Is_Fractional_Type (Base_Type (Result_Typ))
7307 and then Esize (Left_Typ) = Esize (Right_Typ)
7308 and then Esize (Left_Typ) = Esize (Result_Typ);
7309 end Target_Has_Fixed_Ops;
7311 ------------------------------------------
7312 -- Type_May_Have_Bit_Aligned_Components --
7313 ------------------------------------------
7315 function Type_May_Have_Bit_Aligned_Components
7316 (Typ : Entity_Id) return Boolean
7319 -- Array type, check component type
7321 if Is_Array_Type (Typ) then
7323 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
7325 -- Record type, check components
7327 elsif Is_Record_Type (Typ) then
7332 E := First_Component_Or_Discriminant (Typ);
7333 while Present (E) loop
7334 if Component_May_Be_Bit_Aligned (E)
7335 or else Type_May_Have_Bit_Aligned_Components (Etype (E))
7340 Next_Component_Or_Discriminant (E);
7346 -- Type other than array or record is always OK
7351 end Type_May_Have_Bit_Aligned_Components;
7353 ----------------------------
7354 -- Wrap_Cleanup_Procedure --
7355 ----------------------------
7357 procedure Wrap_Cleanup_Procedure (N : Node_Id) is
7358 Loc : constant Source_Ptr := Sloc (N);
7359 Stseq : constant Node_Id := Handled_Statement_Sequence (N);
7360 Stmts : constant List_Id := Statements (Stseq);
7363 if Abort_Allowed then
7364 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
7365 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
7367 end Wrap_Cleanup_Procedure;