1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Casing; use Casing;
29 with Checks; use Checks;
30 with Debug; use Debug;
31 with Einfo; use Einfo;
32 with Elists; use Elists;
33 with Errout; use Errout;
34 with Exp_Aggr; use Exp_Aggr;
35 with Exp_Ch6; use Exp_Ch6;
36 with Exp_Ch7; use Exp_Ch7;
37 with Ghost; use Ghost;
38 with Inline; use Inline;
39 with Itypes; use Itypes;
41 with Nlists; use Nlists;
42 with Nmake; use Nmake;
44 with Restrict; use Restrict;
45 with Rident; use Rident;
47 with Sem_Aux; use Sem_Aux;
48 with Sem_Ch8; use Sem_Ch8;
49 with Sem_Eval; use Sem_Eval;
50 with Sem_Res; use Sem_Res;
51 with Sem_Type; use Sem_Type;
52 with Sem_Util; use Sem_Util;
53 with Snames; use Snames;
54 with Stand; use Stand;
55 with Stringt; use Stringt;
56 with Targparm; use Targparm;
57 with Tbuild; use Tbuild;
58 with Ttypes; use Ttypes;
59 with Urealp; use Urealp;
60 with Validsw; use Validsw;
62 package body Exp_Util is
64 -----------------------
65 -- Local Subprograms --
66 -----------------------
68 function Build_Task_Array_Image
72 Dyn : Boolean := False) return Node_Id;
73 -- Build function to generate the image string for a task that is an array
74 -- component, concatenating the images of each index. To avoid storage
75 -- leaks, the string is built with successive slice assignments. The flag
76 -- Dyn indicates whether this is called for the initialization procedure of
77 -- an array of tasks, or for the name of a dynamically created task that is
78 -- assigned to an indexed component.
80 function Build_Task_Image_Function
84 Res : Entity_Id) return Node_Id;
85 -- Common processing for Task_Array_Image and Task_Record_Image. Build
86 -- function body that computes image.
88 procedure Build_Task_Image_Prefix
97 -- Common processing for Task_Array_Image and Task_Record_Image. Create
98 -- local variables and assign prefix of name to result string.
100 function Build_Task_Record_Image
103 Dyn : Boolean := False) return Node_Id;
104 -- Build function to generate the image string for a task that is a record
105 -- component. Concatenate name of variable with that of selector. The flag
106 -- Dyn indicates whether this is called for the initialization procedure of
107 -- record with task components, or for a dynamically created task that is
108 -- assigned to a selected component.
110 procedure Evaluate_Slice_Bounds (Slice : Node_Id);
111 -- Force evaluation of bounds of a slice, which may be given by a range
112 -- or by a subtype indication with or without a constraint.
114 function Make_CW_Equivalent_Type
116 E : Node_Id) return Entity_Id;
117 -- T is a class-wide type entity, E is the initial expression node that
118 -- constrains T in case such as: " X: T := E" or "new T'(E)". This function
119 -- returns the entity of the Equivalent type and inserts on the fly the
120 -- necessary declaration such as:
122 -- type anon is record
123 -- _parent : Root_Type (T); constrained with E discriminants (if any)
124 -- Extension : String (1 .. expr to match size of E);
127 -- This record is compatible with any object of the class of T thanks to
128 -- the first field and has the same size as E thanks to the second.
130 function Make_Literal_Range
132 Literal_Typ : Entity_Id) return Node_Id;
133 -- Produce a Range node whose bounds are:
134 -- Low_Bound (Literal_Type) ..
135 -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
136 -- this is used for expanding declarations like X : String := "sdfgdfg";
138 -- If the index type of the target array is not integer, we generate:
139 -- Low_Bound (Literal_Type) ..
141 -- (Literal_Type'Pos (Low_Bound (Literal_Type))
142 -- + (Length (Literal_Typ) -1))
144 function Make_Non_Empty_Check
146 N : Node_Id) return Node_Id;
147 -- Produce a boolean expression checking that the unidimensional array
148 -- node N is not empty.
150 function New_Class_Wide_Subtype
152 N : Node_Id) return Entity_Id;
153 -- Create an implicit subtype of CW_Typ attached to node N
155 function Requires_Cleanup_Actions
158 Nested_Constructs : Boolean) return Boolean;
159 -- Given a list L, determine whether it contains one of the following:
161 -- 1) controlled objects
162 -- 2) library-level tagged types
164 -- Lib_Level is True when the list comes from a construct at the library
165 -- level, and False otherwise. Nested_Constructs is True when any nested
166 -- packages declared in L must be processed, and False otherwise.
168 -------------------------------------
169 -- Activate_Atomic_Synchronization --
170 -------------------------------------
172 procedure Activate_Atomic_Synchronization (N : Node_Id) is
176 case Nkind (Parent (N)) is
178 -- Check for cases of appearing in the prefix of a construct where
179 -- we don't need atomic synchronization for this kind of usage.
182 -- Nothing to do if we are the prefix of an attribute, since we
183 -- do not want an atomic sync operation for things like 'Size.
185 N_Attribute_Reference |
187 -- The N_Reference node is like an attribute
191 -- Nothing to do for a reference to a component (or components)
192 -- of a composite object. Only reads and updates of the object
193 -- as a whole require atomic synchronization (RM C.6 (15)).
195 N_Indexed_Component |
196 N_Selected_Component |
199 -- For all the above cases, nothing to do if we are the prefix
201 if Prefix (Parent (N)) = N then
208 -- Nothing to do for the identifier in an object renaming declaration,
209 -- the renaming itself does not need atomic syncrhonization.
211 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
215 -- Go ahead and set the flag
217 Set_Atomic_Sync_Required (N);
219 -- Generate info message if requested
221 if Warn_On_Atomic_Synchronization then
226 when N_Selected_Component | N_Expanded_Name =>
227 Msg_Node := Selector_Name (N);
229 when N_Explicit_Dereference | N_Indexed_Component =>
233 pragma Assert (False);
237 if Present (Msg_Node) then
239 ("info: atomic synchronization set for &?N?", Msg_Node);
242 ("info: atomic synchronization set?N?", N);
245 end Activate_Atomic_Synchronization;
247 ----------------------
248 -- Adjust_Condition --
249 ----------------------
251 procedure Adjust_Condition (N : Node_Id) is
258 Loc : constant Source_Ptr := Sloc (N);
259 T : constant Entity_Id := Etype (N);
263 -- Defend against a call where the argument has no type, or has a
264 -- type that is not Boolean. This can occur because of prior errors.
266 if No (T) or else not Is_Boolean_Type (T) then
270 -- Apply validity checking if needed
272 if Validity_Checks_On and Validity_Check_Tests then
276 -- Immediate return if standard boolean, the most common case,
277 -- where nothing needs to be done.
279 if Base_Type (T) = Standard_Boolean then
283 -- Case of zero/non-zero semantics or non-standard enumeration
284 -- representation. In each case, we rewrite the node as:
286 -- ityp!(N) /= False'Enum_Rep
288 -- where ityp is an integer type with large enough size to hold any
291 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
292 if Esize (T) <= Esize (Standard_Integer) then
293 Ti := Standard_Integer;
295 Ti := Standard_Long_Long_Integer;
300 Left_Opnd => Unchecked_Convert_To (Ti, N),
302 Make_Attribute_Reference (Loc,
303 Attribute_Name => Name_Enum_Rep,
305 New_Occurrence_Of (First_Literal (T), Loc))));
306 Analyze_And_Resolve (N, Standard_Boolean);
309 Rewrite (N, Convert_To (Standard_Boolean, N));
310 Analyze_And_Resolve (N, Standard_Boolean);
313 end Adjust_Condition;
315 ------------------------
316 -- Adjust_Result_Type --
317 ------------------------
319 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
321 -- Ignore call if current type is not Standard.Boolean
323 if Etype (N) /= Standard_Boolean then
327 -- If result is already of correct type, nothing to do. Note that
328 -- this will get the most common case where everything has a type
329 -- of Standard.Boolean.
331 if Base_Type (T) = Standard_Boolean then
336 KP : constant Node_Kind := Nkind (Parent (N));
339 -- If result is to be used as a Condition in the syntax, no need
340 -- to convert it back, since if it was changed to Standard.Boolean
341 -- using Adjust_Condition, that is just fine for this usage.
343 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
346 -- If result is an operand of another logical operation, no need
347 -- to reset its type, since Standard.Boolean is just fine, and
348 -- such operations always do Adjust_Condition on their operands.
350 elsif KP in N_Op_Boolean
351 or else KP in N_Short_Circuit
352 or else KP = N_Op_Not
356 -- Otherwise we perform a conversion from the current type, which
357 -- must be Standard.Boolean, to the desired type.
361 Rewrite (N, Convert_To (T, N));
362 Analyze_And_Resolve (N, T);
366 end Adjust_Result_Type;
368 --------------------------
369 -- Append_Freeze_Action --
370 --------------------------
372 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
376 Ensure_Freeze_Node (T);
377 Fnode := Freeze_Node (T);
379 if No (Actions (Fnode)) then
380 Set_Actions (Fnode, New_List (N));
382 Append (N, Actions (Fnode));
385 end Append_Freeze_Action;
387 ---------------------------
388 -- Append_Freeze_Actions --
389 ---------------------------
391 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
399 Ensure_Freeze_Node (T);
400 Fnode := Freeze_Node (T);
402 if No (Actions (Fnode)) then
403 Set_Actions (Fnode, L);
405 Append_List (L, Actions (Fnode));
407 end Append_Freeze_Actions;
409 ------------------------------------
410 -- Build_Allocate_Deallocate_Proc --
411 ------------------------------------
413 procedure Build_Allocate_Deallocate_Proc
415 Is_Allocate : Boolean)
417 Desig_Typ : Entity_Id;
420 Proc_To_Call : Node_Id := Empty;
423 function Find_Object (E : Node_Id) return Node_Id;
424 -- Given an arbitrary expression of an allocator, try to find an object
425 -- reference in it, otherwise return the original expression.
427 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
428 -- Determine whether subprogram Subp denotes a custom allocate or
435 function Find_Object (E : Node_Id) return Node_Id is
439 pragma Assert (Is_Allocate);
443 if Nkind (Expr) = N_Explicit_Dereference then
444 Expr := Prefix (Expr);
446 elsif Nkind (Expr) = N_Qualified_Expression then
447 Expr := Expression (Expr);
449 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
451 -- When interface class-wide types are involved in allocation,
452 -- the expander introduces several levels of address arithmetic
453 -- to perform dispatch table displacement. In this scenario the
454 -- object appears as:
456 -- Tag_Ptr (Base_Address (<object>'Address))
458 -- Detect this case and utilize the whole expression as the
459 -- "object" since it now points to the proper dispatch table.
461 if Is_RTE (Etype (Expr), RE_Tag_Ptr) then
464 -- Continue to strip the object
467 Expr := Expression (Expr);
478 ---------------------------------
479 -- Is_Allocate_Deallocate_Proc --
480 ---------------------------------
482 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
484 -- Look for a subprogram body with only one statement which is a
485 -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
487 if Ekind (Subp) = E_Procedure
488 and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
491 HSS : constant Node_Id :=
492 Handled_Statement_Sequence (Parent (Parent (Subp)));
496 if Present (Statements (HSS))
497 and then Nkind (First (Statements (HSS))) =
498 N_Procedure_Call_Statement
500 Proc := Entity (Name (First (Statements (HSS))));
503 Is_RTE (Proc, RE_Allocate_Any_Controlled)
504 or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
510 end Is_Allocate_Deallocate_Proc;
512 -- Start of processing for Build_Allocate_Deallocate_Proc
515 -- Obtain the attributes of the allocation / deallocation
517 if Nkind (N) = N_Free_Statement then
518 Expr := Expression (N);
519 Ptr_Typ := Base_Type (Etype (Expr));
520 Proc_To_Call := Procedure_To_Call (N);
523 if Nkind (N) = N_Object_Declaration then
524 Expr := Expression (N);
529 -- In certain cases an allocator with a qualified expression may
530 -- be relocated and used as the initialization expression of a
534 -- Obj : Ptr_Typ := new Desig_Typ'(...);
537 -- Tmp : Ptr_Typ := new Desig_Typ'(...);
538 -- Obj : Ptr_Typ := Tmp;
540 -- Since the allocator is always marked as analyzed to avoid infinite
541 -- expansion, it will never be processed by this routine given that
542 -- the designated type needs finalization actions. Detect this case
543 -- and complete the expansion of the allocator.
545 if Nkind (Expr) = N_Identifier
546 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
547 and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
549 Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
553 -- The allocator may have been rewritten into something else in which
554 -- case the expansion performed by this routine does not apply.
556 if Nkind (Expr) /= N_Allocator then
560 Ptr_Typ := Base_Type (Etype (Expr));
561 Proc_To_Call := Procedure_To_Call (Expr);
564 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
565 Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
567 -- Handle concurrent types
569 if Is_Concurrent_Type (Desig_Typ)
570 and then Present (Corresponding_Record_Type (Desig_Typ))
572 Desig_Typ := Corresponding_Record_Type (Desig_Typ);
575 -- Do not process allocations / deallocations without a pool
580 -- Do not process allocations on / deallocations from the secondary
583 elsif Is_RTE (Pool_Id, RE_SS_Pool) then
586 -- Do not replicate the machinery if the allocator / free has already
587 -- been expanded and has a custom Allocate / Deallocate.
589 elsif Present (Proc_To_Call)
590 and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
595 if Needs_Finalization (Desig_Typ) then
597 -- Certain run-time configurations and targets do not provide support
598 -- for controlled types.
600 if Restriction_Active (No_Finalization) then
603 -- Do nothing if the access type may never allocate / deallocate
606 elsif No_Pool_Assigned (Ptr_Typ) then
610 -- The allocation / deallocation of a controlled object must be
611 -- chained on / detached from a finalization master.
613 pragma Assert (Present (Finalization_Master (Ptr_Typ)));
615 -- The only other kind of allocation / deallocation supported by this
616 -- routine is on / from a subpool.
618 elsif Nkind (Expr) = N_Allocator
619 and then No (Subpool_Handle_Name (Expr))
625 Loc : constant Source_Ptr := Sloc (N);
626 Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
627 Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
628 Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
629 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
632 Fin_Addr_Id : Entity_Id;
633 Fin_Mas_Act : Node_Id;
634 Fin_Mas_Id : Entity_Id;
635 Proc_To_Call : Entity_Id;
636 Subpool : Node_Id := Empty;
639 -- Step 1: Construct all the actuals for the call to library routine
640 -- Allocate_Any_Controlled / Deallocate_Any_Controlled.
644 Actuals := New_List (New_Occurrence_Of (Pool_Id, Loc));
650 if Nkind (Expr) = N_Allocator then
651 Subpool := Subpool_Handle_Name (Expr);
654 -- If a subpool is present it can be an arbitrary name, so make
655 -- the actual by copying the tree.
657 if Present (Subpool) then
658 Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
660 Append_To (Actuals, Make_Null (Loc));
663 -- c) Finalization master
665 if Needs_Finalization (Desig_Typ) then
666 Fin_Mas_Id := Finalization_Master (Ptr_Typ);
667 Fin_Mas_Act := New_Occurrence_Of (Fin_Mas_Id, Loc);
669 -- Handle the case where the master is actually a pointer to a
670 -- master. This case arises in build-in-place functions.
672 if Is_Access_Type (Etype (Fin_Mas_Id)) then
673 Append_To (Actuals, Fin_Mas_Act);
676 Make_Attribute_Reference (Loc,
677 Prefix => Fin_Mas_Act,
678 Attribute_Name => Name_Unrestricted_Access));
681 Append_To (Actuals, Make_Null (Loc));
684 -- d) Finalize_Address
686 -- Primitive Finalize_Address is never generated in CodePeer mode
687 -- since it contains an Unchecked_Conversion.
689 if Needs_Finalization (Desig_Typ) and then not CodePeer_Mode then
690 Fin_Addr_Id := Finalize_Address (Desig_Typ);
691 pragma Assert (Present (Fin_Addr_Id));
694 Make_Attribute_Reference (Loc,
695 Prefix => New_Occurrence_Of (Fin_Addr_Id, Loc),
696 Attribute_Name => Name_Unrestricted_Access));
698 Append_To (Actuals, Make_Null (Loc));
706 Append_To (Actuals, New_Occurrence_Of (Addr_Id, Loc));
707 Append_To (Actuals, New_Occurrence_Of (Size_Id, Loc));
709 if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then
710 Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc));
712 -- For deallocation of class-wide types we obtain the value of
713 -- alignment from the Type Specific Record of the deallocated object.
714 -- This is needed because the frontend expansion of class-wide types
715 -- into equivalent types confuses the backend.
721 -- ... because 'Alignment applied to class-wide types is expanded
722 -- into the code that reads the value of alignment from the TSD
723 -- (see Expand_N_Attribute_Reference)
726 Unchecked_Convert_To (RTE (RE_Storage_Offset),
727 Make_Attribute_Reference (Loc,
729 Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
730 Attribute_Name => Name_Alignment)));
735 if Needs_Finalization (Desig_Typ) then
737 Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
744 Temp := Find_Object (Expression (Expr));
749 -- Processing for allocations where the expression is a subtype
753 and then Is_Entity_Name (Temp)
754 and then Is_Type (Entity (Temp))
759 (Needs_Finalization (Entity (Temp))), Loc);
761 -- The allocation / deallocation of a class-wide object relies
762 -- on a runtime check to determine whether the object is truly
763 -- controlled or not. Depending on this check, the finalization
764 -- machinery will request or reclaim extra storage reserved for
767 elsif Is_Class_Wide_Type (Desig_Typ) then
769 -- Detect a special case where interface class-wide types
770 -- are involved as the object appears as:
772 -- Tag_Ptr (Base_Address (<object>'Address))
774 -- The expression already yields the proper tag, generate:
778 if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
780 Make_Explicit_Dereference (Loc,
781 Prefix => Relocate_Node (Temp));
783 -- In the default case, obtain the tag of the object about
784 -- to be allocated / deallocated. Generate:
790 Make_Attribute_Reference (Loc,
791 Prefix => Relocate_Node (Temp),
792 Attribute_Name => Name_Tag);
796 -- Needs_Finalization (<Param>)
799 Make_Function_Call (Loc,
801 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
802 Parameter_Associations => New_List (Param));
804 -- Processing for generic actuals
806 elsif Is_Generic_Actual_Type (Desig_Typ) then
808 New_Occurrence_Of (Boolean_Literals
809 (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
811 -- The object does not require any specialized checks, it is
812 -- known to be controlled.
815 Flag_Expr := New_Occurrence_Of (Standard_True, Loc);
818 -- Create the temporary which represents the finalization state
819 -- of the expression. Generate:
821 -- F : constant Boolean := <Flag_Expr>;
824 Make_Object_Declaration (Loc,
825 Defining_Identifier => Flag_Id,
826 Constant_Present => True,
828 New_Occurrence_Of (Standard_Boolean, Loc),
829 Expression => Flag_Expr));
831 Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc));
834 -- The object is not controlled
837 Append_To (Actuals, New_Occurrence_Of (Standard_False, Loc));
844 New_Occurrence_Of (Boolean_Literals (Present (Subpool)), Loc));
847 -- Step 2: Build a wrapper Allocate / Deallocate which internally
848 -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
850 -- Select the proper routine to call
853 Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
855 Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
858 -- Create a custom Allocate / Deallocate routine which has identical
859 -- profile to that of System.Storage_Pools.
862 Make_Subprogram_Body (Loc,
867 Make_Procedure_Specification (Loc,
868 Defining_Unit_Name => Proc_Id,
869 Parameter_Specifications => New_List (
871 -- P : Root_Storage_Pool
873 Make_Parameter_Specification (Loc,
874 Defining_Identifier => Make_Temporary (Loc, 'P'),
876 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)),
880 Make_Parameter_Specification (Loc,
881 Defining_Identifier => Addr_Id,
882 Out_Present => Is_Allocate,
884 New_Occurrence_Of (RTE (RE_Address), Loc)),
888 Make_Parameter_Specification (Loc,
889 Defining_Identifier => Size_Id,
891 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)),
895 Make_Parameter_Specification (Loc,
896 Defining_Identifier => Alig_Id,
898 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)))),
900 Declarations => No_List,
902 Handled_Statement_Sequence =>
903 Make_Handled_Sequence_Of_Statements (Loc,
904 Statements => New_List (
905 Make_Procedure_Call_Statement (Loc,
906 Name => New_Occurrence_Of (Proc_To_Call, Loc),
907 Parameter_Associations => Actuals)))));
909 -- The newly generated Allocate / Deallocate becomes the default
910 -- procedure to call when the back end processes the allocation /
914 Set_Procedure_To_Call (Expr, Proc_Id);
916 Set_Procedure_To_Call (N, Proc_Id);
919 end Build_Allocate_Deallocate_Proc;
921 ------------------------
922 -- Build_Runtime_Call --
923 ------------------------
925 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
927 -- If entity is not available, we can skip making the call (this avoids
928 -- junk duplicated error messages in a number of cases).
930 if not RTE_Available (RE) then
931 return Make_Null_Statement (Loc);
934 Make_Procedure_Call_Statement (Loc,
935 Name => New_Occurrence_Of (RTE (RE), Loc));
937 end Build_Runtime_Call;
939 ------------------------
940 -- Build_SS_Mark_Call --
941 ------------------------
943 function Build_SS_Mark_Call
945 Mark : Entity_Id) return Node_Id
949 -- Mark : constant Mark_Id := SS_Mark;
952 Make_Object_Declaration (Loc,
953 Defining_Identifier => Mark,
954 Constant_Present => True,
956 New_Occurrence_Of (RTE (RE_Mark_Id), Loc),
958 Make_Function_Call (Loc,
959 Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc)));
960 end Build_SS_Mark_Call;
962 ---------------------------
963 -- Build_SS_Release_Call --
964 ---------------------------
966 function Build_SS_Release_Call
968 Mark : Entity_Id) return Node_Id
972 -- SS_Release (Mark);
975 Make_Procedure_Call_Statement (Loc,
977 New_Occurrence_Of (RTE (RE_SS_Release), Loc),
978 Parameter_Associations => New_List (
979 New_Occurrence_Of (Mark, Loc)));
980 end Build_SS_Release_Call;
982 ----------------------------
983 -- Build_Task_Array_Image --
984 ----------------------------
986 -- This function generates the body for a function that constructs the
987 -- image string for a task that is an array component. The function is
988 -- local to the init proc for the array type, and is called for each one
989 -- of the components. The constructed image has the form of an indexed
990 -- component, whose prefix is the outer variable of the array type.
991 -- The n-dimensional array type has known indexes Index, Index2...
993 -- Id_Ref is an indexed component form created by the enclosing init proc.
994 -- Its successive indexes are Val1, Val2, ... which are the loop variables
995 -- in the loops that call the individual task init proc on each component.
997 -- The generated function has the following structure:
999 -- function F return String is
1000 -- Pref : string renames Task_Name;
1001 -- T1 : String := Index1'Image (Val1);
1003 -- Tn : String := indexn'image (Valn);
1004 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
1005 -- -- Len includes commas and the end parentheses.
1006 -- Res : String (1..Len);
1007 -- Pos : Integer := Pref'Length;
1010 -- Res (1 .. Pos) := Pref;
1012 -- Res (Pos) := '(';
1014 -- Res (Pos .. Pos + T1'Length - 1) := T1;
1015 -- Pos := Pos + T1'Length;
1016 -- Res (Pos) := '.';
1019 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
1020 -- Res (Len) := ')';
1025 -- Needless to say, multidimensional arrays of tasks are rare enough that
1026 -- the bulkiness of this code is not really a concern.
1028 function Build_Task_Array_Image
1032 Dyn : Boolean := False) return Node_Id
1034 Dims : constant Nat := Number_Dimensions (A_Type);
1035 -- Number of dimensions for array of tasks
1037 Temps : array (1 .. Dims) of Entity_Id;
1038 -- Array of temporaries to hold string for each index
1044 -- Total length of generated name
1047 -- Running index for substring assignments
1049 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
1050 -- Name of enclosing variable, prefix of resulting name
1053 -- String to hold result
1056 -- Value of successive indexes
1059 -- Expression to compute total size of string
1062 -- Entity for name at one index position
1064 Decls : constant List_Id := New_List;
1065 Stats : constant List_Id := New_List;
1068 -- For a dynamic task, the name comes from the target variable. For a
1069 -- static one it is a formal of the enclosing init proc.
1072 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
1074 Make_Object_Declaration (Loc,
1075 Defining_Identifier => Pref,
1076 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1078 Make_String_Literal (Loc,
1079 Strval => String_From_Name_Buffer)));
1083 Make_Object_Renaming_Declaration (Loc,
1084 Defining_Identifier => Pref,
1085 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1086 Name => Make_Identifier (Loc, Name_uTask_Name)));
1089 Indx := First_Index (A_Type);
1090 Val := First (Expressions (Id_Ref));
1092 for J in 1 .. Dims loop
1093 T := Make_Temporary (Loc, 'T');
1097 Make_Object_Declaration (Loc,
1098 Defining_Identifier => T,
1099 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1101 Make_Attribute_Reference (Loc,
1102 Attribute_Name => Name_Image,
1103 Prefix => New_Occurrence_Of (Etype (Indx), Loc),
1104 Expressions => New_List (New_Copy_Tree (Val)))));
1110 Sum := Make_Integer_Literal (Loc, Dims + 1);
1116 Make_Attribute_Reference (Loc,
1117 Attribute_Name => Name_Length,
1118 Prefix => New_Occurrence_Of (Pref, Loc),
1119 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1121 for J in 1 .. Dims loop
1126 Make_Attribute_Reference (Loc,
1127 Attribute_Name => Name_Length,
1129 New_Occurrence_Of (Temps (J), Loc),
1130 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1133 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
1135 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
1138 Make_Assignment_Statement (Loc,
1140 Make_Indexed_Component (Loc,
1141 Prefix => New_Occurrence_Of (Res, Loc),
1142 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1144 Make_Character_Literal (Loc,
1146 Char_Literal_Value => UI_From_Int (Character'Pos ('(')))));
1149 Make_Assignment_Statement (Loc,
1150 Name => New_Occurrence_Of (Pos, Loc),
1153 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1154 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1156 for J in 1 .. Dims loop
1159 Make_Assignment_Statement (Loc,
1162 Prefix => New_Occurrence_Of (Res, Loc),
1165 Low_Bound => New_Occurrence_Of (Pos, Loc),
1167 Make_Op_Subtract (Loc,
1170 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1172 Make_Attribute_Reference (Loc,
1173 Attribute_Name => Name_Length,
1175 New_Occurrence_Of (Temps (J), Loc),
1177 New_List (Make_Integer_Literal (Loc, 1)))),
1178 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
1180 Expression => New_Occurrence_Of (Temps (J), Loc)));
1184 Make_Assignment_Statement (Loc,
1185 Name => New_Occurrence_Of (Pos, Loc),
1188 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1190 Make_Attribute_Reference (Loc,
1191 Attribute_Name => Name_Length,
1192 Prefix => New_Occurrence_Of (Temps (J), Loc),
1194 New_List (Make_Integer_Literal (Loc, 1))))));
1196 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
1199 Make_Assignment_Statement (Loc,
1200 Name => Make_Indexed_Component (Loc,
1201 Prefix => New_Occurrence_Of (Res, Loc),
1202 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1204 Make_Character_Literal (Loc,
1206 Char_Literal_Value => UI_From_Int (Character'Pos (',')))));
1209 Make_Assignment_Statement (Loc,
1210 Name => New_Occurrence_Of (Pos, Loc),
1213 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1214 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1218 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
1221 Make_Assignment_Statement (Loc,
1223 Make_Indexed_Component (Loc,
1224 Prefix => New_Occurrence_Of (Res, Loc),
1225 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
1227 Make_Character_Literal (Loc,
1229 Char_Literal_Value => UI_From_Int (Character'Pos (')')))));
1230 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
1231 end Build_Task_Array_Image;
1233 ----------------------------
1234 -- Build_Task_Image_Decls --
1235 ----------------------------
1237 function Build_Task_Image_Decls
1241 In_Init_Proc : Boolean := False) return List_Id
1243 Decls : constant List_Id := New_List;
1244 T_Id : Entity_Id := Empty;
1246 Expr : Node_Id := Empty;
1247 Fun : Node_Id := Empty;
1248 Is_Dyn : constant Boolean :=
1249 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
1251 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
1254 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
1255 -- generate a dummy declaration only.
1257 if Restriction_Active (No_Implicit_Heap_Allocations)
1258 or else Global_Discard_Names
1260 T_Id := Make_Temporary (Loc, 'J');
1265 Make_Object_Declaration (Loc,
1266 Defining_Identifier => T_Id,
1267 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1269 Make_String_Literal (Loc,
1270 Strval => String_From_Name_Buffer)));
1273 if Nkind (Id_Ref) = N_Identifier
1274 or else Nkind (Id_Ref) = N_Defining_Identifier
1276 -- For a simple variable, the image of the task is built from
1277 -- the name of the variable. To avoid possible conflict with the
1278 -- anonymous type created for a single protected object, add a
1282 Make_Defining_Identifier (Loc,
1283 New_External_Name (Chars (Id_Ref), 'T', 1));
1285 Get_Name_String (Chars (Id_Ref));
1288 Make_String_Literal (Loc,
1289 Strval => String_From_Name_Buffer);
1291 elsif Nkind (Id_Ref) = N_Selected_Component then
1293 Make_Defining_Identifier (Loc,
1294 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
1295 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
1297 elsif Nkind (Id_Ref) = N_Indexed_Component then
1299 Make_Defining_Identifier (Loc,
1300 New_External_Name (Chars (A_Type), 'N'));
1302 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
1306 if Present (Fun) then
1307 Append (Fun, Decls);
1308 Expr := Make_Function_Call (Loc,
1309 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
1311 if not In_Init_Proc then
1312 Set_Uses_Sec_Stack (Defining_Entity (Fun));
1316 Decl := Make_Object_Declaration (Loc,
1317 Defining_Identifier => T_Id,
1318 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1319 Constant_Present => True,
1320 Expression => Expr);
1322 Append (Decl, Decls);
1324 end Build_Task_Image_Decls;
1326 -------------------------------
1327 -- Build_Task_Image_Function --
1328 -------------------------------
1330 function Build_Task_Image_Function
1334 Res : Entity_Id) return Node_Id
1340 Make_Simple_Return_Statement (Loc,
1341 Expression => New_Occurrence_Of (Res, Loc)));
1343 Spec := Make_Function_Specification (Loc,
1344 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
1345 Result_Definition => New_Occurrence_Of (Standard_String, Loc));
1347 -- Calls to 'Image use the secondary stack, which must be cleaned up
1348 -- after the task name is built.
1350 return Make_Subprogram_Body (Loc,
1351 Specification => Spec,
1352 Declarations => Decls,
1353 Handled_Statement_Sequence =>
1354 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
1355 end Build_Task_Image_Function;
1357 -----------------------------
1358 -- Build_Task_Image_Prefix --
1359 -----------------------------
1361 procedure Build_Task_Image_Prefix
1363 Len : out Entity_Id;
1364 Res : out Entity_Id;
1365 Pos : out Entity_Id;
1372 Len := Make_Temporary (Loc, 'L', Sum);
1375 Make_Object_Declaration (Loc,
1376 Defining_Identifier => Len,
1377 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
1378 Expression => Sum));
1380 Res := Make_Temporary (Loc, 'R');
1383 Make_Object_Declaration (Loc,
1384 Defining_Identifier => Res,
1385 Object_Definition =>
1386 Make_Subtype_Indication (Loc,
1387 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1389 Make_Index_Or_Discriminant_Constraint (Loc,
1393 Low_Bound => Make_Integer_Literal (Loc, 1),
1394 High_Bound => New_Occurrence_Of (Len, Loc)))))));
1396 -- Indicate that the result is an internal temporary, so it does not
1397 -- receive a bogus initialization when declaration is expanded. This
1398 -- is both efficient, and prevents anomalies in the handling of
1399 -- dynamic objects on the secondary stack.
1401 Set_Is_Internal (Res);
1402 Pos := Make_Temporary (Loc, 'P');
1405 Make_Object_Declaration (Loc,
1406 Defining_Identifier => Pos,
1407 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
1409 -- Pos := Prefix'Length;
1412 Make_Assignment_Statement (Loc,
1413 Name => New_Occurrence_Of (Pos, Loc),
1415 Make_Attribute_Reference (Loc,
1416 Attribute_Name => Name_Length,
1417 Prefix => New_Occurrence_Of (Prefix, Loc),
1418 Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
1420 -- Res (1 .. Pos) := Prefix;
1423 Make_Assignment_Statement (Loc,
1426 Prefix => New_Occurrence_Of (Res, Loc),
1429 Low_Bound => Make_Integer_Literal (Loc, 1),
1430 High_Bound => New_Occurrence_Of (Pos, Loc))),
1432 Expression => New_Occurrence_Of (Prefix, Loc)));
1435 Make_Assignment_Statement (Loc,
1436 Name => New_Occurrence_Of (Pos, Loc),
1439 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1440 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1441 end Build_Task_Image_Prefix;
1443 -----------------------------
1444 -- Build_Task_Record_Image --
1445 -----------------------------
1447 function Build_Task_Record_Image
1450 Dyn : Boolean := False) return Node_Id
1453 -- Total length of generated name
1456 -- Index into result
1459 -- String to hold result
1461 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
1462 -- Name of enclosing variable, prefix of resulting name
1465 -- Expression to compute total size of string
1468 -- Entity for selector name
1470 Decls : constant List_Id := New_List;
1471 Stats : constant List_Id := New_List;
1474 -- For a dynamic task, the name comes from the target variable. For a
1475 -- static one it is a formal of the enclosing init proc.
1478 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
1480 Make_Object_Declaration (Loc,
1481 Defining_Identifier => Pref,
1482 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1484 Make_String_Literal (Loc,
1485 Strval => String_From_Name_Buffer)));
1489 Make_Object_Renaming_Declaration (Loc,
1490 Defining_Identifier => Pref,
1491 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1492 Name => Make_Identifier (Loc, Name_uTask_Name)));
1495 Sel := Make_Temporary (Loc, 'S');
1497 Get_Name_String (Chars (Selector_Name (Id_Ref)));
1500 Make_Object_Declaration (Loc,
1501 Defining_Identifier => Sel,
1502 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
1504 Make_String_Literal (Loc,
1505 Strval => String_From_Name_Buffer)));
1507 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
1513 Make_Attribute_Reference (Loc,
1514 Attribute_Name => Name_Length,
1516 New_Occurrence_Of (Pref, Loc),
1517 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
1519 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
1521 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
1523 -- Res (Pos) := '.';
1526 Make_Assignment_Statement (Loc,
1527 Name => Make_Indexed_Component (Loc,
1528 Prefix => New_Occurrence_Of (Res, Loc),
1529 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
1531 Make_Character_Literal (Loc,
1533 Char_Literal_Value =>
1534 UI_From_Int (Character'Pos ('.')))));
1537 Make_Assignment_Statement (Loc,
1538 Name => New_Occurrence_Of (Pos, Loc),
1541 Left_Opnd => New_Occurrence_Of (Pos, Loc),
1542 Right_Opnd => Make_Integer_Literal (Loc, 1))));
1544 -- Res (Pos .. Len) := Selector;
1547 Make_Assignment_Statement (Loc,
1548 Name => Make_Slice (Loc,
1549 Prefix => New_Occurrence_Of (Res, Loc),
1552 Low_Bound => New_Occurrence_Of (Pos, Loc),
1553 High_Bound => New_Occurrence_Of (Len, Loc))),
1554 Expression => New_Occurrence_Of (Sel, Loc)));
1556 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
1557 end Build_Task_Record_Image;
1559 -----------------------------
1560 -- Check_Float_Op_Overflow --
1561 -----------------------------
1563 procedure Check_Float_Op_Overflow (N : Node_Id) is
1565 -- Return if no check needed
1567 if not Is_Floating_Point_Type (Etype (N))
1568 or else not (Do_Overflow_Check (N) and then Check_Float_Overflow)
1570 -- In CodePeer_Mode, rely on the overflow check flag being set instead
1571 -- and do not expand the code for float overflow checking.
1573 or else CodePeer_Mode
1578 -- Otherwise we replace the expression by
1580 -- do Tnn : constant ftype := expression;
1581 -- constraint_error when not Tnn'Valid;
1585 Loc : constant Source_Ptr := Sloc (N);
1586 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
1587 Typ : constant Entity_Id := Etype (N);
1590 -- Turn off the Do_Overflow_Check flag, since we are doing that work
1591 -- right here. We also set the node as analyzed to prevent infinite
1592 -- recursion from repeating the operation in the expansion.
1594 Set_Do_Overflow_Check (N, False);
1595 Set_Analyzed (N, True);
1597 -- Do the rewrite to include the check
1600 Make_Expression_With_Actions (Loc,
1601 Actions => New_List (
1602 Make_Object_Declaration (Loc,
1603 Defining_Identifier => Tnn,
1604 Object_Definition => New_Occurrence_Of (Typ, Loc),
1605 Constant_Present => True,
1606 Expression => Relocate_Node (N)),
1607 Make_Raise_Constraint_Error (Loc,
1611 Make_Attribute_Reference (Loc,
1612 Prefix => New_Occurrence_Of (Tnn, Loc),
1613 Attribute_Name => Name_Valid)),
1614 Reason => CE_Overflow_Check_Failed)),
1615 Expression => New_Occurrence_Of (Tnn, Loc)));
1617 Analyze_And_Resolve (N, Typ);
1619 end Check_Float_Op_Overflow;
1621 ----------------------------------
1622 -- Component_May_Be_Bit_Aligned --
1623 ----------------------------------
1625 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
1629 -- If no component clause, then everything is fine, since the back end
1630 -- never bit-misaligns by default, even if there is a pragma Packed for
1633 if No (Comp) or else No (Component_Clause (Comp)) then
1637 UT := Underlying_Type (Etype (Comp));
1639 -- It is only array and record types that cause trouble
1641 if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then
1644 -- If we know that we have a small (64 bits or less) record or small
1645 -- bit-packed array, then everything is fine, since the back end can
1646 -- handle these cases correctly.
1648 elsif Esize (Comp) <= 64
1649 and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT))
1653 -- Otherwise if the component is not byte aligned, we know we have the
1654 -- nasty unaligned case.
1656 elsif Normalized_First_Bit (Comp) /= Uint_0
1657 or else Esize (Comp) mod System_Storage_Unit /= Uint_0
1661 -- If we are large and byte aligned, then OK at this level
1666 end Component_May_Be_Bit_Aligned;
1668 ----------------------------------------
1669 -- Containing_Package_With_Ext_Axioms --
1670 ----------------------------------------
1672 function Containing_Package_With_Ext_Axioms
1673 (E : Entity_Id) return Entity_Id
1678 if Ekind (E) = E_Package then
1679 if Nkind (Parent (E)) = N_Defining_Program_Unit_Name then
1680 Decl := Parent (Parent (E));
1686 -- E is the package or generic package which is externally axiomatized
1688 if Ekind_In (E, E_Package, E_Generic_Package)
1689 and then Has_Annotate_Pragma_For_External_Axiomatization (E)
1694 -- If E's scope is axiomatized, E is axiomatized.
1697 First_Ax_Parent_Scope : Entity_Id := Empty;
1700 if Present (Scope (E)) then
1701 First_Ax_Parent_Scope :=
1702 Containing_Package_With_Ext_Axioms (Scope (E));
1705 if Present (First_Ax_Parent_Scope) then
1706 return First_Ax_Parent_Scope;
1709 -- otherwise, if E is a package instance, it is axiomatized if the
1710 -- corresponding generic package is axiomatized.
1712 if Ekind (E) = E_Package
1713 and then Present (Generic_Parent (Decl))
1716 Containing_Package_With_Ext_Axioms (Generic_Parent (Decl));
1721 end Containing_Package_With_Ext_Axioms;
1723 -------------------------------
1724 -- Convert_To_Actual_Subtype --
1725 -------------------------------
1727 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
1731 Act_ST := Get_Actual_Subtype (Exp);
1733 if Act_ST = Etype (Exp) then
1736 Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
1737 Analyze_And_Resolve (Exp, Act_ST);
1739 end Convert_To_Actual_Subtype;
1741 -----------------------------------
1742 -- Corresponding_Runtime_Package --
1743 -----------------------------------
1745 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
1746 Pkg_Id : RTU_Id := RTU_Null;
1749 pragma Assert (Is_Concurrent_Type (Typ));
1751 if Ekind (Typ) in Protected_Kind then
1752 if Has_Entries (Typ)
1754 -- A protected type without entries that covers an interface and
1755 -- overrides the abstract routines with protected procedures is
1756 -- considered equivalent to a protected type with entries in the
1757 -- context of dispatching select statements. It is sufficient to
1758 -- check for the presence of an interface list in the declaration
1759 -- node to recognize this case.
1761 or else Present (Interface_List (Parent (Typ)))
1763 -- Protected types with interrupt handlers (when not using a
1764 -- restricted profile) are also considered equivalent to
1765 -- protected types with entries. The types which are used
1766 -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection)
1767 -- are derived from Protection_Entries.
1769 or else (Has_Attach_Handler (Typ) and then not Restricted_Profile)
1770 or else Has_Interrupt_Handler (Typ)
1773 or else Restriction_Active (No_Entry_Queue) = False
1774 or else Restriction_Active (No_Select_Statements) = False
1775 or else Number_Entries (Typ) > 1
1776 or else (Has_Attach_Handler (Typ)
1777 and then not Restricted_Profile)
1779 Pkg_Id := System_Tasking_Protected_Objects_Entries;
1781 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
1785 Pkg_Id := System_Tasking_Protected_Objects;
1790 end Corresponding_Runtime_Package;
1792 -----------------------------------
1793 -- Current_Sem_Unit_Declarations --
1794 -----------------------------------
1796 function Current_Sem_Unit_Declarations return List_Id is
1797 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
1801 -- If the current unit is a package body, locate the visible
1802 -- declarations of the package spec.
1804 if Nkind (U) = N_Package_Body then
1805 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
1808 if Nkind (U) = N_Package_Declaration then
1809 U := Specification (U);
1810 Decls := Visible_Declarations (U);
1814 Set_Visible_Declarations (U, Decls);
1818 Decls := Declarations (U);
1822 Set_Declarations (U, Decls);
1827 end Current_Sem_Unit_Declarations;
1829 -----------------------
1830 -- Duplicate_Subexpr --
1831 -----------------------
1833 function Duplicate_Subexpr
1835 Name_Req : Boolean := False;
1836 Renaming_Req : Boolean := False) return Node_Id
1839 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
1840 return New_Copy_Tree (Exp);
1841 end Duplicate_Subexpr;
1843 ---------------------------------
1844 -- Duplicate_Subexpr_No_Checks --
1845 ---------------------------------
1847 function Duplicate_Subexpr_No_Checks
1849 Name_Req : Boolean := False;
1850 Renaming_Req : Boolean := False;
1851 Related_Id : Entity_Id := Empty;
1852 Is_Low_Bound : Boolean := False;
1853 Is_High_Bound : Boolean := False) return Node_Id
1860 Name_Req => Name_Req,
1861 Renaming_Req => Renaming_Req,
1862 Related_Id => Related_Id,
1863 Is_Low_Bound => Is_Low_Bound,
1864 Is_High_Bound => Is_High_Bound);
1866 New_Exp := New_Copy_Tree (Exp);
1867 Remove_Checks (New_Exp);
1869 end Duplicate_Subexpr_No_Checks;
1871 -----------------------------------
1872 -- Duplicate_Subexpr_Move_Checks --
1873 -----------------------------------
1875 function Duplicate_Subexpr_Move_Checks
1877 Name_Req : Boolean := False;
1878 Renaming_Req : Boolean := False) return Node_Id
1883 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
1884 New_Exp := New_Copy_Tree (Exp);
1885 Remove_Checks (Exp);
1887 end Duplicate_Subexpr_Move_Checks;
1889 --------------------
1890 -- Ensure_Defined --
1891 --------------------
1893 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
1897 -- An itype reference must only be created if this is a local itype, so
1898 -- that gigi can elaborate it on the proper objstack.
1900 if Is_Itype (Typ) and then Scope (Typ) = Current_Scope then
1901 IR := Make_Itype_Reference (Sloc (N));
1902 Set_Itype (IR, Typ);
1903 Insert_Action (N, IR);
1907 --------------------
1908 -- Entry_Names_OK --
1909 --------------------
1911 function Entry_Names_OK return Boolean is
1914 not Restricted_Profile
1915 and then not Global_Discard_Names
1916 and then not Restriction_Active (No_Implicit_Heap_Allocations)
1917 and then not Restriction_Active (No_Local_Allocators);
1924 procedure Evaluate_Name (Nam : Node_Id) is
1925 K : constant Node_Kind := Nkind (Nam);
1928 -- For an explicit dereference, we simply force the evaluation of the
1929 -- name expression. The dereference provides a value that is the address
1930 -- for the renamed object, and it is precisely this value that we want
1933 if K = N_Explicit_Dereference then
1934 Force_Evaluation (Prefix (Nam));
1936 -- For a selected component, we simply evaluate the prefix
1938 elsif K = N_Selected_Component then
1939 Evaluate_Name (Prefix (Nam));
1941 -- For an indexed component, or an attribute reference, we evaluate the
1942 -- prefix, which is itself a name, recursively, and then force the
1943 -- evaluation of all the subscripts (or attribute expressions).
1945 elsif Nkind_In (K, N_Indexed_Component, N_Attribute_Reference) then
1946 Evaluate_Name (Prefix (Nam));
1952 E := First (Expressions (Nam));
1953 while Present (E) loop
1954 Force_Evaluation (E);
1956 if Original_Node (E) /= E then
1957 Set_Do_Range_Check (E, Do_Range_Check (Original_Node (E)));
1964 -- For a slice, we evaluate the prefix, as for the indexed component
1965 -- case and then, if there is a range present, either directly or as the
1966 -- constraint of a discrete subtype indication, we evaluate the two
1967 -- bounds of this range.
1969 elsif K = N_Slice then
1970 Evaluate_Name (Prefix (Nam));
1971 Evaluate_Slice_Bounds (Nam);
1973 -- For a type conversion, the expression of the conversion must be the
1974 -- name of an object, and we simply need to evaluate this name.
1976 elsif K = N_Type_Conversion then
1977 Evaluate_Name (Expression (Nam));
1979 -- For a function call, we evaluate the call
1981 elsif K = N_Function_Call then
1982 Force_Evaluation (Nam);
1984 -- The remaining cases are direct name, operator symbol and character
1985 -- literal. In all these cases, we do nothing, since we want to
1986 -- reevaluate each time the renamed object is used.
1993 ---------------------------
1994 -- Evaluate_Slice_Bounds --
1995 ---------------------------
1997 procedure Evaluate_Slice_Bounds (Slice : Node_Id) is
1998 DR : constant Node_Id := Discrete_Range (Slice);
2003 if Nkind (DR) = N_Range then
2004 Force_Evaluation (Low_Bound (DR));
2005 Force_Evaluation (High_Bound (DR));
2007 elsif Nkind (DR) = N_Subtype_Indication then
2008 Constr := Constraint (DR);
2010 if Nkind (Constr) = N_Range_Constraint then
2011 Rexpr := Range_Expression (Constr);
2013 Force_Evaluation (Low_Bound (Rexpr));
2014 Force_Evaluation (High_Bound (Rexpr));
2017 end Evaluate_Slice_Bounds;
2019 ---------------------
2020 -- Evolve_And_Then --
2021 ---------------------
2023 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
2029 Make_And_Then (Sloc (Cond1),
2031 Right_Opnd => Cond1);
2033 end Evolve_And_Then;
2035 --------------------
2036 -- Evolve_Or_Else --
2037 --------------------
2039 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
2045 Make_Or_Else (Sloc (Cond1),
2047 Right_Opnd => Cond1);
2051 -----------------------------------------
2052 -- Expand_Static_Predicates_In_Choices --
2053 -----------------------------------------
2055 procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
2056 pragma Assert (Nkind_In (N, N_Case_Statement_Alternative, N_Variant));
2058 Choices : constant List_Id := Discrete_Choices (N);
2066 Choice := First (Choices);
2067 while Present (Choice) loop
2068 Next_C := Next (Choice);
2070 -- Check for name of subtype with static predicate
2072 if Is_Entity_Name (Choice)
2073 and then Is_Type (Entity (Choice))
2074 and then Has_Predicates (Entity (Choice))
2076 -- Loop through entries in predicate list, converting to choices
2077 -- and inserting in the list before the current choice. Note that
2078 -- if the list is empty, corresponding to a False predicate, then
2079 -- no choices are inserted.
2081 P := First (Static_Discrete_Predicate (Entity (Choice)));
2082 while Present (P) loop
2084 -- If low bound and high bounds are equal, copy simple choice
2086 if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then
2087 C := New_Copy (Low_Bound (P));
2089 -- Otherwise copy a range
2095 -- Change Sloc to referencing choice (rather than the Sloc of
2096 -- the predicate declaration element itself).
2098 Set_Sloc (C, Sloc (Choice));
2099 Insert_Before (Choice, C);
2103 -- Delete the predicated entry
2108 -- Move to next choice to check
2112 end Expand_Static_Predicates_In_Choices;
2114 ------------------------------
2115 -- Expand_Subtype_From_Expr --
2116 ------------------------------
2118 -- This function is applicable for both static and dynamic allocation of
2119 -- objects which are constrained by an initial expression. Basically it
2120 -- transforms an unconstrained subtype indication into a constrained one.
2122 -- The expression may also be transformed in certain cases in order to
2123 -- avoid multiple evaluation. In the static allocation case, the general
2128 -- is transformed into
2130 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
2132 -- Here are the main cases :
2134 -- <if Expr is a Slice>
2135 -- Val : T ([Index_Subtype (Expr)]) := Expr;
2137 -- <elsif Expr is a String Literal>
2138 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
2140 -- <elsif Expr is Constrained>
2141 -- subtype T is Type_Of_Expr
2144 -- <elsif Expr is an entity_name>
2145 -- Val : T (constraints taken from Expr) := Expr;
2148 -- type Axxx is access all T;
2149 -- Rval : Axxx := Expr'ref;
2150 -- Val : T (constraints taken from Rval) := Rval.all;
2152 -- ??? note: when the Expression is allocated in the secondary stack
2153 -- we could use it directly instead of copying it by declaring
2154 -- Val : T (...) renames Rval.all
2156 procedure Expand_Subtype_From_Expr
2158 Unc_Type : Entity_Id;
2159 Subtype_Indic : Node_Id;
2162 Loc : constant Source_Ptr := Sloc (N);
2163 Exp_Typ : constant Entity_Id := Etype (Exp);
2167 -- In general we cannot build the subtype if expansion is disabled,
2168 -- because internal entities may not have been defined. However, to
2169 -- avoid some cascaded errors, we try to continue when the expression is
2170 -- an array (or string), because it is safe to compute the bounds. It is
2171 -- in fact required to do so even in a generic context, because there
2172 -- may be constants that depend on the bounds of a string literal, both
2173 -- standard string types and more generally arrays of characters.
2175 -- In GNATprove mode, these extra subtypes are not needed
2177 if GNATprove_Mode then
2181 if not Expander_Active
2182 and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp)))
2187 if Nkind (Exp) = N_Slice then
2189 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
2192 Rewrite (Subtype_Indic,
2193 Make_Subtype_Indication (Loc,
2194 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
2196 Make_Index_Or_Discriminant_Constraint (Loc,
2197 Constraints => New_List
2198 (New_Occurrence_Of (Slice_Type, Loc)))));
2200 -- This subtype indication may be used later for constraint checks
2201 -- we better make sure that if a variable was used as a bound of
2202 -- of the original slice, its value is frozen.
2204 Evaluate_Slice_Bounds (Exp);
2207 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
2208 Rewrite (Subtype_Indic,
2209 Make_Subtype_Indication (Loc,
2210 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
2212 Make_Index_Or_Discriminant_Constraint (Loc,
2213 Constraints => New_List (
2214 Make_Literal_Range (Loc,
2215 Literal_Typ => Exp_Typ)))));
2217 -- If the type of the expression is an internally generated type it
2218 -- may not be necessary to create a new subtype. However there are two
2219 -- exceptions: references to the current instances, and aliased array
2220 -- object declarations for which the backend needs to create a template.
2222 elsif Is_Constrained (Exp_Typ)
2223 and then not Is_Class_Wide_Type (Unc_Type)
2225 (Nkind (N) /= N_Object_Declaration
2226 or else not Is_Entity_Name (Expression (N))
2227 or else not Comes_From_Source (Entity (Expression (N)))
2228 or else not Is_Array_Type (Exp_Typ)
2229 or else not Aliased_Present (N))
2231 if Is_Itype (Exp_Typ) then
2233 -- Within an initialization procedure, a selected component
2234 -- denotes a component of the enclosing record, and it appears as
2235 -- an actual in a call to its own initialization procedure. If
2236 -- this component depends on the outer discriminant, we must
2237 -- generate the proper actual subtype for it.
2239 if Nkind (Exp) = N_Selected_Component
2240 and then Within_Init_Proc
2243 Decl : constant Node_Id :=
2244 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
2246 if Present (Decl) then
2247 Insert_Action (N, Decl);
2248 T := Defining_Identifier (Decl);
2254 -- No need to generate a new subtype
2261 T := Make_Temporary (Loc, 'T');
2264 Make_Subtype_Declaration (Loc,
2265 Defining_Identifier => T,
2266 Subtype_Indication => New_Occurrence_Of (Exp_Typ, Loc)));
2268 -- This type is marked as an itype even though it has an explicit
2269 -- declaration since otherwise Is_Generic_Actual_Type can get
2270 -- set, resulting in the generation of spurious errors. (See
2271 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
2274 Set_Associated_Node_For_Itype (T, Exp);
2277 Rewrite (Subtype_Indic, New_Occurrence_Of (T, Loc));
2279 -- Nothing needs to be done for private types with unknown discriminants
2280 -- if the underlying type is not an unconstrained composite type or it
2281 -- is an unchecked union.
2283 elsif Is_Private_Type (Unc_Type)
2284 and then Has_Unknown_Discriminants (Unc_Type)
2285 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
2286 or else Is_Constrained (Underlying_Type (Unc_Type))
2287 or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
2291 -- Case of derived type with unknown discriminants where the parent type
2292 -- also has unknown discriminants.
2294 elsif Is_Record_Type (Unc_Type)
2295 and then not Is_Class_Wide_Type (Unc_Type)
2296 and then Has_Unknown_Discriminants (Unc_Type)
2297 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
2299 -- Nothing to be done if no underlying record view available
2301 if No (Underlying_Record_View (Unc_Type)) then
2304 -- Otherwise use the Underlying_Record_View to create the proper
2305 -- constrained subtype for an object of a derived type with unknown
2309 Remove_Side_Effects (Exp);
2310 Rewrite (Subtype_Indic,
2311 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
2314 -- Renamings of class-wide interface types require no equivalent
2315 -- constrained type declarations because we only need to reference
2316 -- the tag component associated with the interface. The same is
2317 -- presumably true for class-wide types in general, so this test
2318 -- is broadened to include all class-wide renamings, which also
2319 -- avoids cases of unbounded recursion in Remove_Side_Effects.
2320 -- (Is this really correct, or are there some cases of class-wide
2321 -- renamings that require action in this procedure???)
2324 and then Nkind (N) = N_Object_Renaming_Declaration
2325 and then Is_Class_Wide_Type (Unc_Type)
2329 -- In Ada 95 nothing to be done if the type of the expression is limited
2330 -- because in this case the expression cannot be copied, and its use can
2331 -- only be by reference.
2333 -- In Ada 2005 the context can be an object declaration whose expression
2334 -- is a function that returns in place. If the nominal subtype has
2335 -- unknown discriminants, the call still provides constraints on the
2336 -- object, and we have to create an actual subtype from it.
2338 -- If the type is class-wide, the expression is dynamically tagged and
2339 -- we do not create an actual subtype either. Ditto for an interface.
2340 -- For now this applies only if the type is immutably limited, and the
2341 -- function being called is build-in-place. This will have to be revised
2342 -- when build-in-place functions are generalized to other types.
2344 elsif Is_Limited_View (Exp_Typ)
2346 (Is_Class_Wide_Type (Exp_Typ)
2347 or else Is_Interface (Exp_Typ)
2348 or else not Has_Unknown_Discriminants (Exp_Typ)
2349 or else not Is_Composite_Type (Unc_Type))
2353 -- For limited objects initialized with build in place function calls,
2354 -- nothing to be done; otherwise we prematurely introduce an N_Reference
2355 -- node in the expression initializing the object, which breaks the
2356 -- circuitry that detects and adds the additional arguments to the
2359 elsif Is_Build_In_Place_Function_Call (Exp) then
2363 Remove_Side_Effects (Exp);
2364 Rewrite (Subtype_Indic,
2365 Make_Subtype_From_Expr (Exp, Unc_Type));
2367 end Expand_Subtype_From_Expr;
2369 ----------------------
2370 -- Finalize_Address --
2371 ----------------------
2373 function Finalize_Address (Typ : Entity_Id) return Entity_Id is
2374 Utyp : Entity_Id := Typ;
2377 -- Handle protected class-wide or task class-wide types
2379 if Is_Class_Wide_Type (Utyp) then
2380 if Is_Concurrent_Type (Root_Type (Utyp)) then
2381 Utyp := Root_Type (Utyp);
2383 elsif Is_Private_Type (Root_Type (Utyp))
2384 and then Present (Full_View (Root_Type (Utyp)))
2385 and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
2387 Utyp := Full_View (Root_Type (Utyp));
2391 -- Handle private types
2393 if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
2394 Utyp := Full_View (Utyp);
2397 -- Handle protected and task types
2399 if Is_Concurrent_Type (Utyp)
2400 and then Present (Corresponding_Record_Type (Utyp))
2402 Utyp := Corresponding_Record_Type (Utyp);
2405 Utyp := Underlying_Type (Base_Type (Utyp));
2407 -- Deal with untagged derivation of private views. If the parent is
2408 -- now known to be protected, the finalization routine is the one
2409 -- defined on the corresponding record of the ancestor (corresponding
2410 -- records do not automatically inherit operations, but maybe they
2413 if Is_Untagged_Derivation (Typ) then
2414 if Is_Protected_Type (Typ) then
2415 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
2418 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
2420 if Is_Protected_Type (Utyp) then
2421 Utyp := Corresponding_Record_Type (Utyp);
2426 -- If the underlying_type is a subtype, we are dealing with the
2427 -- completion of a private type. We need to access the base type and
2428 -- generate a conversion to it.
2430 if Utyp /= Base_Type (Utyp) then
2431 pragma Assert (Is_Private_Type (Typ));
2433 Utyp := Base_Type (Utyp);
2436 -- When dealing with an internally built full view for a type with
2437 -- unknown discriminants, use the original record type.
2439 if Is_Underlying_Record_View (Utyp) then
2440 Utyp := Etype (Utyp);
2443 return TSS (Utyp, TSS_Finalize_Address);
2444 end Finalize_Address;
2446 ------------------------
2447 -- Find_Interface_ADT --
2448 ------------------------
2450 function Find_Interface_ADT
2452 Iface : Entity_Id) return Elmt_Id
2455 Typ : Entity_Id := T;
2458 pragma Assert (Is_Interface (Iface));
2460 -- Handle private types
2462 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
2463 Typ := Full_View (Typ);
2466 -- Handle access types
2468 if Is_Access_Type (Typ) then
2469 Typ := Designated_Type (Typ);
2472 -- Handle task and protected types implementing interfaces
2474 if Is_Concurrent_Type (Typ) then
2475 Typ := Corresponding_Record_Type (Typ);
2479 (not Is_Class_Wide_Type (Typ)
2480 and then Ekind (Typ) /= E_Incomplete_Type);
2482 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
2483 return First_Elmt (Access_Disp_Table (Typ));
2486 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
2488 and then Present (Related_Type (Node (ADT)))
2489 and then Related_Type (Node (ADT)) /= Iface
2490 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
2491 Use_Full_View => True)
2496 pragma Assert (Present (Related_Type (Node (ADT))));
2499 end Find_Interface_ADT;
2501 ------------------------
2502 -- Find_Interface_Tag --
2503 ------------------------
2505 function Find_Interface_Tag
2507 Iface : Entity_Id) return Entity_Id
2510 Found : Boolean := False;
2511 Typ : Entity_Id := T;
2513 procedure Find_Tag (Typ : Entity_Id);
2514 -- Internal subprogram used to recursively climb to the ancestors
2520 procedure Find_Tag (Typ : Entity_Id) is
2525 -- This routine does not handle the case in which the interface is an
2526 -- ancestor of Typ. That case is handled by the enclosing subprogram.
2528 pragma Assert (Typ /= Iface);
2530 -- Climb to the root type handling private types
2532 if Present (Full_View (Etype (Typ))) then
2533 if Full_View (Etype (Typ)) /= Typ then
2534 Find_Tag (Full_View (Etype (Typ)));
2537 elsif Etype (Typ) /= Typ then
2538 Find_Tag (Etype (Typ));
2541 -- Traverse the list of interfaces implemented by the type
2544 and then Present (Interfaces (Typ))
2545 and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
2547 -- Skip the tag associated with the primary table
2549 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
2550 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
2551 pragma Assert (Present (AI_Tag));
2553 AI_Elmt := First_Elmt (Interfaces (Typ));
2554 while Present (AI_Elmt) loop
2555 AI := Node (AI_Elmt);
2558 or else Is_Ancestor (Iface, AI, Use_Full_View => True)
2564 AI_Tag := Next_Tag_Component (AI_Tag);
2565 Next_Elmt (AI_Elmt);
2570 -- Start of processing for Find_Interface_Tag
2573 pragma Assert (Is_Interface (Iface));
2575 -- Handle access types
2577 if Is_Access_Type (Typ) then
2578 Typ := Designated_Type (Typ);
2581 -- Handle class-wide types
2583 if Is_Class_Wide_Type (Typ) then
2584 Typ := Root_Type (Typ);
2587 -- Handle private types
2589 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
2590 Typ := Full_View (Typ);
2593 -- Handle entities from the limited view
2595 if Ekind (Typ) = E_Incomplete_Type then
2596 pragma Assert (Present (Non_Limited_View (Typ)));
2597 Typ := Non_Limited_View (Typ);
2600 -- Handle task and protected types implementing interfaces
2602 if Is_Concurrent_Type (Typ) then
2603 Typ := Corresponding_Record_Type (Typ);
2606 -- If the interface is an ancestor of the type, then it shared the
2607 -- primary dispatch table.
2609 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
2610 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
2611 return First_Tag_Component (Typ);
2613 -- Otherwise we need to search for its associated tag component
2617 pragma Assert (Found);
2620 end Find_Interface_Tag;
2622 ---------------------------
2623 -- Find_Optional_Prim_Op --
2624 ---------------------------
2626 function Find_Optional_Prim_Op
2627 (T : Entity_Id; Name : Name_Id) return Entity_Id
2630 Typ : Entity_Id := T;
2634 if Is_Class_Wide_Type (Typ) then
2635 Typ := Root_Type (Typ);
2638 Typ := Underlying_Type (Typ);
2640 -- Loop through primitive operations
2642 Prim := First_Elmt (Primitive_Operations (Typ));
2643 while Present (Prim) loop
2646 -- We can retrieve primitive operations by name if it is an internal
2647 -- name. For equality we must check that both of its operands have
2648 -- the same type, to avoid confusion with user-defined equalities
2649 -- than may have a non-symmetric signature.
2651 exit when Chars (Op) = Name
2654 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
2659 return Node (Prim); -- Empty if not found
2660 end Find_Optional_Prim_Op;
2662 ---------------------------
2663 -- Find_Optional_Prim_Op --
2664 ---------------------------
2666 function Find_Optional_Prim_Op
2668 Name : TSS_Name_Type) return Entity_Id
2670 Inher_Op : Entity_Id := Empty;
2671 Own_Op : Entity_Id := Empty;
2672 Prim_Elmt : Elmt_Id;
2673 Prim_Id : Entity_Id;
2674 Typ : Entity_Id := T;
2677 if Is_Class_Wide_Type (Typ) then
2678 Typ := Root_Type (Typ);
2681 Typ := Underlying_Type (Typ);
2683 -- This search is based on the assertion that the dispatching version
2684 -- of the TSS routine always precedes the real primitive.
2686 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
2687 while Present (Prim_Elmt) loop
2688 Prim_Id := Node (Prim_Elmt);
2690 if Is_TSS (Prim_Id, Name) then
2691 if Present (Alias (Prim_Id)) then
2692 Inher_Op := Prim_Id;
2698 Next_Elmt (Prim_Elmt);
2701 if Present (Own_Op) then
2703 elsif Present (Inher_Op) then
2708 end Find_Optional_Prim_Op;
2714 function Find_Prim_Op
2715 (T : Entity_Id; Name : Name_Id) return Entity_Id
2717 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
2720 raise Program_Error;
2730 function Find_Prim_Op
2732 Name : TSS_Name_Type) return Entity_Id
2734 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
2737 raise Program_Error;
2743 ----------------------------
2744 -- Find_Protection_Object --
2745 ----------------------------
2747 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
2752 while Present (S) loop
2753 if Ekind_In (S, E_Entry, E_Entry_Family, E_Function, E_Procedure)
2754 and then Present (Protection_Object (S))
2756 return Protection_Object (S);
2762 -- If we do not find a Protection object in the scope chain, then
2763 -- something has gone wrong, most likely the object was never created.
2765 raise Program_Error;
2766 end Find_Protection_Object;
2768 --------------------------
2769 -- Find_Protection_Type --
2770 --------------------------
2772 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
2774 Typ : Entity_Id := Conc_Typ;
2777 if Is_Concurrent_Type (Typ) then
2778 Typ := Corresponding_Record_Type (Typ);
2781 -- Since restriction violations are not considered serious errors, the
2782 -- expander remains active, but may leave the corresponding record type
2783 -- malformed. In such cases, component _object is not available so do
2786 if not Analyzed (Typ) then
2790 Comp := First_Component (Typ);
2791 while Present (Comp) loop
2792 if Chars (Comp) = Name_uObject then
2793 return Base_Type (Etype (Comp));
2796 Next_Component (Comp);
2799 -- The corresponding record of a protected type should always have an
2802 raise Program_Error;
2803 end Find_Protection_Type;
2805 -----------------------
2806 -- Find_Hook_Context --
2807 -----------------------
2809 function Find_Hook_Context (N : Node_Id) return Node_Id is
2813 Wrapped_Node : Node_Id;
2814 -- Note: if we are in a transient scope, we want to reuse it as
2815 -- the context for actions insertion, if possible. But if N is itself
2816 -- part of the stored actions for the current transient scope,
2817 -- then we need to insert at the appropriate (inner) location in
2818 -- the not as an action on Node_To_Be_Wrapped.
2820 In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N);
2823 -- When the node is inside a case/if expression, the lifetime of any
2824 -- temporary controlled object is extended. Find a suitable insertion
2825 -- node by locating the topmost case or if expressions.
2827 if In_Cond_Expr then
2830 while Present (Par) loop
2831 if Nkind_In (Original_Node (Par), N_Case_Expression,
2836 -- Prevent the search from going too far
2838 elsif Is_Body_Or_Package_Declaration (Par) then
2842 Par := Parent (Par);
2845 -- The topmost case or if expression is now recovered, but it may
2846 -- still not be the correct place to add generated code. Climb to
2847 -- find a parent that is part of a declarative or statement list,
2848 -- and is not a list of actuals in a call.
2851 while Present (Par) loop
2852 if Is_List_Member (Par)
2853 and then not Nkind_In (Par, N_Component_Association,
2854 N_Discriminant_Association,
2855 N_Parameter_Association,
2856 N_Pragma_Argument_Association)
2857 and then not Nkind_In
2858 (Parent (Par), N_Function_Call,
2859 N_Procedure_Call_Statement,
2860 N_Entry_Call_Statement)
2865 -- Prevent the search from going too far
2867 elsif Is_Body_Or_Package_Declaration (Par) then
2871 Par := Parent (Par);
2878 while Present (Par) loop
2880 -- Keep climbing past various operators
2882 if Nkind (Parent (Par)) in N_Op
2883 or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else)
2885 Par := Parent (Par);
2893 -- The node may be located in a pragma in which case return the
2896 -- pragma Precondition (... and then Ctrl_Func_Call ...);
2898 -- Similar case occurs when the node is related to an object
2899 -- declaration or assignment:
2901 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
2903 -- Another case to consider is when the node is part of a return
2906 -- return ... and then Ctrl_Func_Call ...;
2908 -- Another case is when the node acts as a formal in a procedure
2911 -- Proc (... and then Ctrl_Func_Call ...);
2913 if Scope_Is_Transient then
2914 Wrapped_Node := Node_To_Be_Wrapped;
2916 Wrapped_Node := Empty;
2919 while Present (Par) loop
2920 if Par = Wrapped_Node
2921 or else Nkind_In (Par, N_Assignment_Statement,
2922 N_Object_Declaration,
2924 N_Procedure_Call_Statement,
2925 N_Simple_Return_Statement)
2929 -- Prevent the search from going too far
2931 elsif Is_Body_Or_Package_Declaration (Par) then
2935 Par := Parent (Par);
2938 -- Return the topmost short circuit operator
2942 end Find_Hook_Context;
2944 ------------------------------
2945 -- Following_Address_Clause --
2946 ------------------------------
2948 function Following_Address_Clause (D : Node_Id) return Node_Id is
2949 Id : constant Entity_Id := Defining_Identifier (D);
2953 function Check_Decls (D : Node_Id) return Node_Id;
2954 -- This internal function differs from the main function in that it
2955 -- gets called to deal with a following package private part, and
2956 -- it checks declarations starting with D (the main function checks
2957 -- declarations following D). If D is Empty, then Empty is returned.
2963 function Check_Decls (D : Node_Id) return Node_Id is
2968 while Present (Decl) loop
2969 if Nkind (Decl) = N_At_Clause
2970 and then Chars (Identifier (Decl)) = Chars (Id)
2974 elsif Nkind (Decl) = N_Attribute_Definition_Clause
2975 and then Chars (Decl) = Name_Address
2976 and then Chars (Name (Decl)) = Chars (Id)
2984 -- Otherwise not found, return Empty
2989 -- Start of processing for Following_Address_Clause
2992 -- If parser detected no address clause for the identifier in question,
2993 -- then the answer is a quick NO, without the need for a search.
2995 if not Get_Name_Table_Boolean1 (Chars (Id)) then
2999 -- Otherwise search current declarative unit
3001 Result := Check_Decls (Next (D));
3003 if Present (Result) then
3007 -- Check for possible package private part following
3011 if Nkind (Par) = N_Package_Specification
3012 and then Visible_Declarations (Par) = List_Containing (D)
3013 and then Present (Private_Declarations (Par))
3015 -- Private part present, check declarations there
3017 return Check_Decls (First (Private_Declarations (Par)));
3020 -- No private part, clause not found, return Empty
3024 end Following_Address_Clause;
3026 ----------------------
3027 -- Force_Evaluation --
3028 ----------------------
3030 procedure Force_Evaluation
3032 Name_Req : Boolean := False;
3033 Related_Id : Entity_Id := Empty;
3034 Is_Low_Bound : Boolean := False;
3035 Is_High_Bound : Boolean := False)
3040 Name_Req => Name_Req,
3041 Variable_Ref => True,
3042 Renaming_Req => False,
3043 Related_Id => Related_Id,
3044 Is_Low_Bound => Is_Low_Bound,
3045 Is_High_Bound => Is_High_Bound);
3046 end Force_Evaluation;
3048 ---------------------------------
3049 -- Fully_Qualified_Name_String --
3050 ---------------------------------
3052 function Fully_Qualified_Name_String
3054 Append_NUL : Boolean := True) return String_Id
3056 procedure Internal_Full_Qualified_Name (E : Entity_Id);
3057 -- Compute recursively the qualified name without NUL at the end, adding
3058 -- it to the currently started string being generated
3060 ----------------------------------
3061 -- Internal_Full_Qualified_Name --
3062 ----------------------------------
3064 procedure Internal_Full_Qualified_Name (E : Entity_Id) is
3068 -- Deal properly with child units
3070 if Nkind (E) = N_Defining_Program_Unit_Name then
3071 Ent := Defining_Identifier (E);
3076 -- Compute qualification recursively (only "Standard" has no scope)
3078 if Present (Scope (Scope (Ent))) then
3079 Internal_Full_Qualified_Name (Scope (Ent));
3080 Store_String_Char (Get_Char_Code ('.'));
3083 -- Every entity should have a name except some expanded blocks
3084 -- don't bother about those.
3086 if Chars (Ent) = No_Name then
3090 -- Generates the entity name in upper case
3092 Get_Decoded_Name_String (Chars (Ent));
3094 Store_String_Chars (Name_Buffer (1 .. Name_Len));
3096 end Internal_Full_Qualified_Name;
3098 -- Start of processing for Full_Qualified_Name
3102 Internal_Full_Qualified_Name (E);
3105 Store_String_Char (Get_Char_Code (ASCII.NUL));
3109 end Fully_Qualified_Name_String;
3111 ------------------------
3112 -- Generate_Poll_Call --
3113 ------------------------
3115 procedure Generate_Poll_Call (N : Node_Id) is
3117 -- No poll call if polling not active
3119 if not Polling_Required then
3122 -- Otherwise generate require poll call
3125 Insert_Before_And_Analyze (N,
3126 Make_Procedure_Call_Statement (Sloc (N),
3127 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
3129 end Generate_Poll_Call;
3131 ---------------------------------
3132 -- Get_Current_Value_Condition --
3133 ---------------------------------
3135 -- Note: the implementation of this procedure is very closely tied to the
3136 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
3137 -- interpret Current_Value fields set by the Set procedure, so the two
3138 -- procedures need to be closely coordinated.
3140 procedure Get_Current_Value_Condition
3145 Loc : constant Source_Ptr := Sloc (Var);
3146 Ent : constant Entity_Id := Entity (Var);
3148 procedure Process_Current_Value_Condition
3151 -- N is an expression which holds either True (S = True) or False (S =
3152 -- False) in the condition. This procedure digs out the expression and
3153 -- if it refers to Ent, sets Op and Val appropriately.
3155 -------------------------------------
3156 -- Process_Current_Value_Condition --
3157 -------------------------------------
3159 procedure Process_Current_Value_Condition
3164 Prev_Cond : Node_Id;
3174 -- Deal with NOT operators, inverting sense
3176 while Nkind (Cond) = N_Op_Not loop
3177 Cond := Right_Opnd (Cond);
3181 -- Deal with conversions, qualifications, and expressions with
3184 while Nkind_In (Cond,
3186 N_Qualified_Expression,
3187 N_Expression_With_Actions)
3189 Cond := Expression (Cond);
3192 exit when Cond = Prev_Cond;
3195 -- Deal with AND THEN and AND cases
3197 if Nkind_In (Cond, N_And_Then, N_Op_And) then
3199 -- Don't ever try to invert a condition that is of the form of an
3200 -- AND or AND THEN (since we are not doing sufficiently general
3201 -- processing to allow this).
3203 if Sens = False then
3209 -- Recursively process AND and AND THEN branches
3211 Process_Current_Value_Condition (Left_Opnd (Cond), True);
3213 if Op /= N_Empty then
3217 Process_Current_Value_Condition (Right_Opnd (Cond), True);
3220 -- Case of relational operator
3222 elsif Nkind (Cond) in N_Op_Compare then
3225 -- Invert sense of test if inverted test
3227 if Sens = False then
3229 when N_Op_Eq => Op := N_Op_Ne;
3230 when N_Op_Ne => Op := N_Op_Eq;
3231 when N_Op_Lt => Op := N_Op_Ge;
3232 when N_Op_Gt => Op := N_Op_Le;
3233 when N_Op_Le => Op := N_Op_Gt;
3234 when N_Op_Ge => Op := N_Op_Lt;
3235 when others => raise Program_Error;
3239 -- Case of entity op value
3241 if Is_Entity_Name (Left_Opnd (Cond))
3242 and then Ent = Entity (Left_Opnd (Cond))
3243 and then Compile_Time_Known_Value (Right_Opnd (Cond))
3245 Val := Right_Opnd (Cond);
3247 -- Case of value op entity
3249 elsif Is_Entity_Name (Right_Opnd (Cond))
3250 and then Ent = Entity (Right_Opnd (Cond))
3251 and then Compile_Time_Known_Value (Left_Opnd (Cond))
3253 Val := Left_Opnd (Cond);
3255 -- We are effectively swapping operands
3258 when N_Op_Eq => null;
3259 when N_Op_Ne => null;
3260 when N_Op_Lt => Op := N_Op_Gt;
3261 when N_Op_Gt => Op := N_Op_Lt;
3262 when N_Op_Le => Op := N_Op_Ge;
3263 when N_Op_Ge => Op := N_Op_Le;
3264 when others => raise Program_Error;
3273 elsif Nkind_In (Cond,
3275 N_Qualified_Expression,
3276 N_Expression_With_Actions)
3278 Cond := Expression (Cond);
3280 -- Case of Boolean variable reference, return as though the
3281 -- reference had said var = True.
3284 if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then
3285 Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
3287 if Sens = False then
3294 end Process_Current_Value_Condition;
3296 -- Start of processing for Get_Current_Value_Condition
3302 -- Immediate return, nothing doing, if this is not an object
3304 if Ekind (Ent) not in Object_Kind then
3308 -- Otherwise examine current value
3311 CV : constant Node_Id := Current_Value (Ent);
3316 -- If statement. Condition is known true in THEN section, known False
3317 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
3319 if Nkind (CV) = N_If_Statement then
3321 -- Before start of IF statement
3323 if Loc < Sloc (CV) then
3326 -- After end of IF statement
3328 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
3332 -- At this stage we know that we are within the IF statement, but
3333 -- unfortunately, the tree does not record the SLOC of the ELSE so
3334 -- we cannot use a simple SLOC comparison to distinguish between
3335 -- the then/else statements, so we have to climb the tree.
3342 while Parent (N) /= CV loop
3345 -- If we fall off the top of the tree, then that's odd, but
3346 -- perhaps it could occur in some error situation, and the
3347 -- safest response is simply to assume that the outcome of
3348 -- the condition is unknown. No point in bombing during an
3349 -- attempt to optimize things.
3356 -- Now we have N pointing to a node whose parent is the IF
3357 -- statement in question, so now we can tell if we are within
3358 -- the THEN statements.
3360 if Is_List_Member (N)
3361 and then List_Containing (N) = Then_Statements (CV)
3365 -- If the variable reference does not come from source, we
3366 -- cannot reliably tell whether it appears in the else part.
3367 -- In particular, if it appears in generated code for a node
3368 -- that requires finalization, it may be attached to a list
3369 -- that has not been yet inserted into the code. For now,
3370 -- treat it as unknown.
3372 elsif not Comes_From_Source (N) then
3375 -- Otherwise we must be in ELSIF or ELSE part
3382 -- ELSIF part. Condition is known true within the referenced
3383 -- ELSIF, known False in any subsequent ELSIF or ELSE part,
3384 -- and unknown before the ELSE part or after the IF statement.
3386 elsif Nkind (CV) = N_Elsif_Part then
3388 -- if the Elsif_Part had condition_actions, the elsif has been
3389 -- rewritten as a nested if, and the original elsif_part is
3390 -- detached from the tree, so there is no way to obtain useful
3391 -- information on the current value of the variable.
3392 -- Can this be improved ???
3394 if No (Parent (CV)) then
3400 -- If the tree has been otherwise rewritten there is nothing
3401 -- else to be done either.
3403 if Nkind (Stm) /= N_If_Statement then
3407 -- Before start of ELSIF part
3409 if Loc < Sloc (CV) then
3412 -- After end of IF statement
3414 elsif Loc >= Sloc (Stm) +
3415 Text_Ptr (UI_To_Int (End_Span (Stm)))
3420 -- Again we lack the SLOC of the ELSE, so we need to climb the
3421 -- tree to see if we are within the ELSIF part in question.
3428 while Parent (N) /= Stm loop
3431 -- If we fall off the top of the tree, then that's odd, but
3432 -- perhaps it could occur in some error situation, and the
3433 -- safest response is simply to assume that the outcome of
3434 -- the condition is unknown. No point in bombing during an
3435 -- attempt to optimize things.
3442 -- Now we have N pointing to a node whose parent is the IF
3443 -- statement in question, so see if is the ELSIF part we want.
3444 -- the THEN statements.
3449 -- Otherwise we must be in subsequent ELSIF or ELSE part
3456 -- Iteration scheme of while loop. The condition is known to be
3457 -- true within the body of the loop.
3459 elsif Nkind (CV) = N_Iteration_Scheme then
3461 Loop_Stmt : constant Node_Id := Parent (CV);
3464 -- Before start of body of loop
3466 if Loc < Sloc (Loop_Stmt) then
3469 -- After end of LOOP statement
3471 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
3474 -- We are within the body of the loop
3481 -- All other cases of Current_Value settings
3487 -- If we fall through here, then we have a reportable condition, Sens
3488 -- is True if the condition is true and False if it needs inverting.
3490 Process_Current_Value_Condition (Condition (CV), Sens);
3492 end Get_Current_Value_Condition;
3494 ---------------------
3495 -- Get_Stream_Size --
3496 ---------------------
3498 function Get_Stream_Size (E : Entity_Id) return Uint is
3500 -- If we have a Stream_Size clause for this type use it
3502 if Has_Stream_Size_Clause (E) then
3503 return Static_Integer (Expression (Stream_Size_Clause (E)));
3505 -- Otherwise the Stream_Size if the size of the type
3510 end Get_Stream_Size;
3512 ---------------------------
3513 -- Has_Access_Constraint --
3514 ---------------------------
3516 function Has_Access_Constraint (E : Entity_Id) return Boolean is
3518 T : constant Entity_Id := Etype (E);
3521 if Has_Per_Object_Constraint (E) and then Has_Discriminants (T) then
3522 Disc := First_Discriminant (T);
3523 while Present (Disc) loop
3524 if Is_Access_Type (Etype (Disc)) then
3528 Next_Discriminant (Disc);
3535 end Has_Access_Constraint;
3537 -----------------------------------------------------
3538 -- Has_Annotate_Pragma_For_External_Axiomatization --
3539 -----------------------------------------------------
3541 function Has_Annotate_Pragma_For_External_Axiomatization
3542 (E : Entity_Id) return Boolean
3544 function Is_Annotate_Pragma_For_External_Axiomatization
3545 (N : Node_Id) return Boolean;
3546 -- Returns whether N is
3547 -- pragma Annotate (GNATprove, External_Axiomatization);
3549 ----------------------------------------------------
3550 -- Is_Annotate_Pragma_For_External_Axiomatization --
3551 ----------------------------------------------------
3553 -- The general form of pragma Annotate is
3555 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
3556 -- ARG ::= NAME | EXPRESSION
3558 -- The first two arguments are by convention intended to refer to an
3559 -- external tool and a tool-specific function. These arguments are
3562 -- The following is used to annotate a package specification which
3563 -- GNATprove should treat specially, because the axiomatization of
3564 -- this unit is given by the user instead of being automatically
3567 -- pragma Annotate (GNATprove, External_Axiomatization);
3569 function Is_Annotate_Pragma_For_External_Axiomatization
3570 (N : Node_Id) return Boolean
3572 Name_GNATprove : constant String :=
3574 Name_External_Axiomatization : constant String :=
3575 "external_axiomatization";
3579 if Nkind (N) = N_Pragma
3580 and then Get_Pragma_Id (Pragma_Name (N)) = Pragma_Annotate
3581 and then List_Length (Pragma_Argument_Associations (N)) = 2
3584 Arg1 : constant Node_Id :=
3585 First (Pragma_Argument_Associations (N));
3586 Arg2 : constant Node_Id := Next (Arg1);
3591 -- Fill in Name_Buffer with Name_GNATprove first, and then with
3592 -- Name_External_Axiomatization so that Name_Find returns the
3593 -- corresponding name. This takes care of all possible casings.
3596 Add_Str_To_Name_Buffer (Name_GNATprove);
3600 Add_Str_To_Name_Buffer (Name_External_Axiomatization);
3603 return Chars (Get_Pragma_Arg (Arg1)) = Nam1
3605 Chars (Get_Pragma_Arg (Arg2)) = Nam2;
3611 end Is_Annotate_Pragma_For_External_Axiomatization;
3616 Vis_Decls : List_Id;
3619 -- Start of processing for Has_Annotate_Pragma_For_External_Axiomatization
3622 if Nkind (Parent (E)) = N_Defining_Program_Unit_Name then
3623 Decl := Parent (Parent (E));
3628 Vis_Decls := Visible_Declarations (Decl);
3630 N := First (Vis_Decls);
3631 while Present (N) loop
3633 -- Skip declarations generated by the frontend. Skip all pragmas
3634 -- that are not the desired Annotate pragma. Stop the search on
3635 -- the first non-pragma source declaration.
3637 if Comes_From_Source (N) then
3638 if Nkind (N) = N_Pragma then
3639 if Is_Annotate_Pragma_For_External_Axiomatization (N) then
3651 end Has_Annotate_Pragma_For_External_Axiomatization;
3653 --------------------
3654 -- Homonym_Number --
3655 --------------------
3657 function Homonym_Number (Subp : Entity_Id) return Nat is
3663 Hom := Homonym (Subp);
3664 while Present (Hom) loop
3665 if Scope (Hom) = Scope (Subp) then
3669 Hom := Homonym (Hom);
3675 -----------------------------------
3676 -- In_Library_Level_Package_Body --
3677 -----------------------------------
3679 function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
3681 -- First determine whether the entity appears at the library level, then
3682 -- look at the containing unit.
3684 if Is_Library_Level_Entity (Id) then
3686 Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
3689 return Nkind (Unit (Container)) = N_Package_Body;
3694 end In_Library_Level_Package_Body;
3696 ------------------------------
3697 -- In_Unconditional_Context --
3698 ------------------------------
3700 function In_Unconditional_Context (Node : Node_Id) return Boolean is
3705 while Present (P) loop
3707 when N_Subprogram_Body =>
3710 when N_If_Statement =>
3713 when N_Loop_Statement =>
3716 when N_Case_Statement =>
3725 end In_Unconditional_Context;
3731 procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
3733 if Present (Ins_Action) then
3734 Insert_Actions (Assoc_Node, New_List (Ins_Action));
3738 -- Version with check(s) suppressed
3740 procedure Insert_Action
3741 (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
3744 Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
3747 -------------------------
3748 -- Insert_Action_After --
3749 -------------------------
3751 procedure Insert_Action_After
3752 (Assoc_Node : Node_Id;
3753 Ins_Action : Node_Id)
3756 Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
3757 end Insert_Action_After;
3759 --------------------
3760 -- Insert_Actions --
3761 --------------------
3763 procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
3767 Wrapped_Node : Node_Id := Empty;
3770 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
3774 -- Ignore insert of actions from inside default expression (or other
3775 -- similar "spec expression") in the special spec-expression analyze
3776 -- mode. Any insertions at this point have no relevance, since we are
3777 -- only doing the analyze to freeze the types of any static expressions.
3778 -- See section "Handling of Default Expressions" in the spec of package
3779 -- Sem for further details.
3781 if In_Spec_Expression then
3785 -- If the action derives from stuff inside a record, then the actions
3786 -- are attached to the current scope, to be inserted and analyzed on
3787 -- exit from the scope. The reason for this is that we may also be
3788 -- generating freeze actions at the same time, and they must eventually
3789 -- be elaborated in the correct order.
3791 if Is_Record_Type (Current_Scope)
3792 and then not Is_Frozen (Current_Scope)
3794 if No (Scope_Stack.Table
3795 (Scope_Stack.Last).Pending_Freeze_Actions)
3797 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
3802 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
3808 -- We now intend to climb up the tree to find the right point to
3809 -- insert the actions. We start at Assoc_Node, unless this node is a
3810 -- subexpression in which case we start with its parent. We do this for
3811 -- two reasons. First it speeds things up. Second, if Assoc_Node is
3812 -- itself one of the special nodes like N_And_Then, then we assume that
3813 -- an initial request to insert actions for such a node does not expect
3814 -- the actions to get deposited in the node for later handling when the
3815 -- node is expanded, since clearly the node is being dealt with by the
3816 -- caller. Note that in the subexpression case, N is always the child we
3819 -- N_Raise_xxx_Error is an annoying special case, it is a statement if
3820 -- it has type Standard_Void_Type, and a subexpression otherwise.
3821 -- otherwise. Procedure calls, and similarly procedure attribute
3822 -- references, are also statements.
3824 if Nkind (Assoc_Node) in N_Subexpr
3825 and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error
3826 or else Etype (Assoc_Node) /= Standard_Void_Type)
3827 and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement
3828 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
3829 or else not Is_Procedure_Attribute_Name
3830 (Attribute_Name (Assoc_Node)))
3833 P := Parent (Assoc_Node);
3835 -- Non-subexpression case. Note that N is initially Empty in this case
3836 -- (N is only guaranteed Non-Empty in the subexpr case).
3843 -- Capture root of the transient scope
3845 if Scope_Is_Transient then
3846 Wrapped_Node := Node_To_Be_Wrapped;
3850 pragma Assert (Present (P));
3852 -- Make sure that inserted actions stay in the transient scope
3854 if Present (Wrapped_Node) and then N = Wrapped_Node then
3855 Store_Before_Actions_In_Scope (Ins_Actions);
3861 -- Case of right operand of AND THEN or OR ELSE. Put the actions
3862 -- in the Actions field of the right operand. They will be moved
3863 -- out further when the AND THEN or OR ELSE operator is expanded.
3864 -- Nothing special needs to be done for the left operand since
3865 -- in that case the actions are executed unconditionally.
3867 when N_Short_Circuit =>
3868 if N = Right_Opnd (P) then
3870 -- We are now going to either append the actions to the
3871 -- actions field of the short-circuit operation. We will
3872 -- also analyze the actions now.
3874 -- This analysis is really too early, the proper thing would
3875 -- be to just park them there now, and only analyze them if
3876 -- we find we really need them, and to it at the proper
3877 -- final insertion point. However attempting to this proved
3878 -- tricky, so for now we just kill current values before and
3879 -- after the analyze call to make sure we avoid peculiar
3880 -- optimizations from this out of order insertion.
3882 Kill_Current_Values;
3884 -- If P has already been expanded, we can't park new actions
3885 -- on it, so we need to expand them immediately, introducing
3886 -- an Expression_With_Actions. N can't be an expression
3887 -- with actions, or else then the actions would have been
3888 -- inserted at an inner level.
3890 if Analyzed (P) then
3891 pragma Assert (Nkind (N) /= N_Expression_With_Actions);
3893 Make_Expression_With_Actions (Sloc (N),
3894 Actions => Ins_Actions,
3895 Expression => Relocate_Node (N)));
3896 Analyze_And_Resolve (N);
3898 elsif Present (Actions (P)) then
3899 Insert_List_After_And_Analyze
3900 (Last (Actions (P)), Ins_Actions);
3902 Set_Actions (P, Ins_Actions);
3903 Analyze_List (Actions (P));
3906 Kill_Current_Values;
3911 -- Then or Else dependent expression of an if expression. Add
3912 -- actions to Then_Actions or Else_Actions field as appropriate.
3913 -- The actions will be moved further out when the if is expanded.
3915 when N_If_Expression =>
3917 ThenX : constant Node_Id := Next (First (Expressions (P)));
3918 ElseX : constant Node_Id := Next (ThenX);
3921 -- If the enclosing expression is already analyzed, as
3922 -- is the case for nested elaboration checks, insert the
3923 -- conditional further out.
3925 if Analyzed (P) then
3928 -- Actions belong to the then expression, temporarily place
3929 -- them as Then_Actions of the if expression. They will be
3930 -- moved to the proper place later when the if expression
3933 elsif N = ThenX then
3934 if Present (Then_Actions (P)) then
3935 Insert_List_After_And_Analyze
3936 (Last (Then_Actions (P)), Ins_Actions);
3938 Set_Then_Actions (P, Ins_Actions);
3939 Analyze_List (Then_Actions (P));
3944 -- Actions belong to the else expression, temporarily place
3945 -- them as Else_Actions of the if expression. They will be
3946 -- moved to the proper place later when the if expression
3949 elsif N = ElseX then
3950 if Present (Else_Actions (P)) then
3951 Insert_List_After_And_Analyze
3952 (Last (Else_Actions (P)), Ins_Actions);
3954 Set_Else_Actions (P, Ins_Actions);
3955 Analyze_List (Else_Actions (P));
3960 -- Actions belong to the condition. In this case they are
3961 -- unconditionally executed, and so we can continue the
3962 -- search for the proper insert point.
3969 -- Alternative of case expression, we place the action in the
3970 -- Actions field of the case expression alternative, this will
3971 -- be handled when the case expression is expanded.
3973 when N_Case_Expression_Alternative =>
3974 if Present (Actions (P)) then
3975 Insert_List_After_And_Analyze
3976 (Last (Actions (P)), Ins_Actions);
3978 Set_Actions (P, Ins_Actions);
3979 Analyze_List (Actions (P));
3984 -- Case of appearing within an Expressions_With_Actions node. When
3985 -- the new actions come from the expression of the expression with
3986 -- actions, they must be added to the existing actions. The other
3987 -- alternative is when the new actions are related to one of the
3988 -- existing actions of the expression with actions, and should
3989 -- never reach here: if actions are inserted on a statement
3990 -- within the Actions of an expression with actions, or on some
3991 -- sub-expression of such a statement, then the outermost proper
3992 -- insertion point is right before the statement, and we should
3993 -- never climb up as far as the N_Expression_With_Actions itself.
3995 when N_Expression_With_Actions =>
3996 if N = Expression (P) then
3997 if Is_Empty_List (Actions (P)) then
3998 Append_List_To (Actions (P), Ins_Actions);
3999 Analyze_List (Actions (P));
4001 Insert_List_After_And_Analyze
4002 (Last (Actions (P)), Ins_Actions);
4008 raise Program_Error;
4011 -- Case of appearing in the condition of a while expression or
4012 -- elsif. We insert the actions into the Condition_Actions field.
4013 -- They will be moved further out when the while loop or elsif
4016 when N_Iteration_Scheme |
4019 if N = Condition (P) then
4020 if Present (Condition_Actions (P)) then
4021 Insert_List_After_And_Analyze
4022 (Last (Condition_Actions (P)), Ins_Actions);
4024 Set_Condition_Actions (P, Ins_Actions);
4026 -- Set the parent of the insert actions explicitly. This
4027 -- is not a syntactic field, but we need the parent field
4028 -- set, in particular so that freeze can understand that
4029 -- it is dealing with condition actions, and properly
4030 -- insert the freezing actions.
4032 Set_Parent (Ins_Actions, P);
4033 Analyze_List (Condition_Actions (P));
4039 -- Statements, declarations, pragmas, representation clauses
4044 N_Procedure_Call_Statement |
4045 N_Statement_Other_Than_Procedure_Call |
4051 -- Representation_Clause
4054 N_Attribute_Definition_Clause |
4055 N_Enumeration_Representation_Clause |
4056 N_Record_Representation_Clause |
4060 N_Abstract_Subprogram_Declaration |
4062 N_Exception_Declaration |
4063 N_Exception_Renaming_Declaration |
4064 N_Expression_Function |
4065 N_Formal_Abstract_Subprogram_Declaration |
4066 N_Formal_Concrete_Subprogram_Declaration |
4067 N_Formal_Object_Declaration |
4068 N_Formal_Type_Declaration |
4069 N_Full_Type_Declaration |
4070 N_Function_Instantiation |
4071 N_Generic_Function_Renaming_Declaration |
4072 N_Generic_Package_Declaration |
4073 N_Generic_Package_Renaming_Declaration |
4074 N_Generic_Procedure_Renaming_Declaration |
4075 N_Generic_Subprogram_Declaration |
4076 N_Implicit_Label_Declaration |
4077 N_Incomplete_Type_Declaration |
4078 N_Number_Declaration |
4079 N_Object_Declaration |
4080 N_Object_Renaming_Declaration |
4082 N_Package_Body_Stub |
4083 N_Package_Declaration |
4084 N_Package_Instantiation |
4085 N_Package_Renaming_Declaration |
4086 N_Private_Extension_Declaration |
4087 N_Private_Type_Declaration |
4088 N_Procedure_Instantiation |
4090 N_Protected_Body_Stub |
4091 N_Protected_Type_Declaration |
4092 N_Single_Task_Declaration |
4094 N_Subprogram_Body_Stub |
4095 N_Subprogram_Declaration |
4096 N_Subprogram_Renaming_Declaration |
4097 N_Subtype_Declaration |
4100 N_Task_Type_Declaration |
4102 -- Use clauses can appear in lists of declarations
4104 N_Use_Package_Clause |
4107 -- Freeze entity behaves like a declaration or statement
4110 N_Freeze_Generic_Entity
4112 -- Do not insert here if the item is not a list member (this
4113 -- happens for example with a triggering statement, and the
4114 -- proper approach is to insert before the entire select).
4116 if not Is_List_Member (P) then
4119 -- Do not insert if parent of P is an N_Component_Association
4120 -- node (i.e. we are in the context of an N_Aggregate or
4121 -- N_Extension_Aggregate node. In this case we want to insert
4122 -- before the entire aggregate.
4124 elsif Nkind (Parent (P)) = N_Component_Association then
4127 -- Do not insert if the parent of P is either an N_Variant node
4128 -- or an N_Record_Definition node, meaning in either case that
4129 -- P is a member of a component list, and that therefore the
4130 -- actions should be inserted outside the complete record
4133 elsif Nkind_In (Parent (P), N_Variant, N_Record_Definition) then
4136 -- Do not insert freeze nodes within the loop generated for
4137 -- an aggregate, because they may be elaborated too late for
4138 -- subsequent use in the back end: within a package spec the
4139 -- loop is part of the elaboration procedure and is only
4140 -- elaborated during the second pass.
4142 -- If the loop comes from source, or the entity is local to the
4143 -- loop itself it must remain within.
4145 elsif Nkind (Parent (P)) = N_Loop_Statement
4146 and then not Comes_From_Source (Parent (P))
4147 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
4149 Scope (Entity (First (Ins_Actions))) /= Current_Scope
4153 -- Otherwise we can go ahead and do the insertion
4155 elsif P = Wrapped_Node then
4156 Store_Before_Actions_In_Scope (Ins_Actions);
4160 Insert_List_Before_And_Analyze (P, Ins_Actions);
4164 -- A special case, N_Raise_xxx_Error can act either as a statement
4165 -- or a subexpression. We tell the difference by looking at the
4166 -- Etype. It is set to Standard_Void_Type in the statement case.
4169 N_Raise_xxx_Error =>
4170 if Etype (P) = Standard_Void_Type then
4171 if P = Wrapped_Node then
4172 Store_Before_Actions_In_Scope (Ins_Actions);
4174 Insert_List_Before_And_Analyze (P, Ins_Actions);
4179 -- In the subexpression case, keep climbing
4185 -- If a component association appears within a loop created for
4186 -- an array aggregate, attach the actions to the association so
4187 -- they can be subsequently inserted within the loop. For other
4188 -- component associations insert outside of the aggregate. For
4189 -- an association that will generate a loop, its Loop_Actions
4190 -- attribute is already initialized (see exp_aggr.adb).
4192 -- The list of loop_actions can in turn generate additional ones,
4193 -- that are inserted before the associated node. If the associated
4194 -- node is outside the aggregate, the new actions are collected
4195 -- at the end of the loop actions, to respect the order in which
4196 -- they are to be elaborated.
4199 N_Component_Association =>
4200 if Nkind (Parent (P)) = N_Aggregate
4201 and then Present (Loop_Actions (P))
4203 if Is_Empty_List (Loop_Actions (P)) then
4204 Set_Loop_Actions (P, Ins_Actions);
4205 Analyze_List (Ins_Actions);
4212 -- Check whether these actions were generated by a
4213 -- declaration that is part of the loop_ actions
4214 -- for the component_association.
4217 while Present (Decl) loop
4218 exit when Parent (Decl) = P
4219 and then Is_List_Member (Decl)
4221 List_Containing (Decl) = Loop_Actions (P);
4222 Decl := Parent (Decl);
4225 if Present (Decl) then
4226 Insert_List_Before_And_Analyze
4227 (Decl, Ins_Actions);
4229 Insert_List_After_And_Analyze
4230 (Last (Loop_Actions (P)), Ins_Actions);
4241 -- Another special case, an attribute denoting a procedure call
4244 N_Attribute_Reference =>
4245 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
4246 if P = Wrapped_Node then
4247 Store_Before_Actions_In_Scope (Ins_Actions);
4249 Insert_List_Before_And_Analyze (P, Ins_Actions);
4254 -- In the subexpression case, keep climbing
4260 -- A contract node should not belong to the tree
4263 raise Program_Error;
4265 -- For all other node types, keep climbing tree
4269 N_Accept_Alternative |
4270 N_Access_Definition |
4271 N_Access_Function_Definition |
4272 N_Access_Procedure_Definition |
4273 N_Access_To_Object_Definition |
4276 N_Aspect_Specification |
4278 N_Case_Statement_Alternative |
4279 N_Character_Literal |
4280 N_Compilation_Unit |
4281 N_Compilation_Unit_Aux |
4282 N_Component_Clause |
4283 N_Component_Declaration |
4284 N_Component_Definition |
4286 N_Constrained_Array_Definition |
4287 N_Decimal_Fixed_Point_Definition |
4288 N_Defining_Character_Literal |
4289 N_Defining_Identifier |
4290 N_Defining_Operator_Symbol |
4291 N_Defining_Program_Unit_Name |
4292 N_Delay_Alternative |
4293 N_Delta_Constraint |
4294 N_Derived_Type_Definition |
4296 N_Digits_Constraint |
4297 N_Discriminant_Association |
4298 N_Discriminant_Specification |
4300 N_Entry_Body_Formal_Part |
4301 N_Entry_Call_Alternative |
4302 N_Entry_Declaration |
4303 N_Entry_Index_Specification |
4304 N_Enumeration_Type_Definition |
4306 N_Exception_Handler |
4308 N_Explicit_Dereference |
4309 N_Extension_Aggregate |
4310 N_Floating_Point_Definition |
4311 N_Formal_Decimal_Fixed_Point_Definition |
4312 N_Formal_Derived_Type_Definition |
4313 N_Formal_Discrete_Type_Definition |
4314 N_Formal_Floating_Point_Definition |
4315 N_Formal_Modular_Type_Definition |
4316 N_Formal_Ordinary_Fixed_Point_Definition |
4317 N_Formal_Package_Declaration |
4318 N_Formal_Private_Type_Definition |
4319 N_Formal_Incomplete_Type_Definition |
4320 N_Formal_Signed_Integer_Type_Definition |
4322 N_Function_Specification |
4323 N_Generic_Association |
4324 N_Handled_Sequence_Of_Statements |
4327 N_Index_Or_Discriminant_Constraint |
4328 N_Indexed_Component |
4330 N_Iterator_Specification |
4333 N_Loop_Parameter_Specification |
4335 N_Modular_Type_Definition |
4361 N_Op_Shift_Right_Arithmetic |
4365 N_Ordinary_Fixed_Point_Definition |
4367 N_Package_Specification |
4368 N_Parameter_Association |
4369 N_Parameter_Specification |
4370 N_Pop_Constraint_Error_Label |
4371 N_Pop_Program_Error_Label |
4372 N_Pop_Storage_Error_Label |
4373 N_Pragma_Argument_Association |
4374 N_Procedure_Specification |
4375 N_Protected_Definition |
4376 N_Push_Constraint_Error_Label |
4377 N_Push_Program_Error_Label |
4378 N_Push_Storage_Error_Label |
4379 N_Qualified_Expression |
4380 N_Quantified_Expression |
4381 N_Raise_Expression |
4383 N_Range_Constraint |
4385 N_Real_Range_Specification |
4386 N_Record_Definition |
4388 N_SCIL_Dispatch_Table_Tag_Init |
4389 N_SCIL_Dispatching_Call |
4390 N_SCIL_Membership_Test |
4391 N_Selected_Component |
4392 N_Signed_Integer_Type_Definition |
4393 N_Single_Protected_Declaration |
4396 N_Subtype_Indication |
4399 N_Terminate_Alternative |
4400 N_Triggering_Alternative |
4402 N_Unchecked_Expression |
4403 N_Unchecked_Type_Conversion |
4404 N_Unconstrained_Array_Definition |
4409 N_Validate_Unchecked_Conversion |
4416 -- If we fall through above tests, keep climbing tree
4420 if Nkind (Parent (N)) = N_Subunit then
4422 -- This is the proper body corresponding to a stub. Insertion must
4423 -- be done at the point of the stub, which is in the declarative
4424 -- part of the parent unit.
4426 P := Corresponding_Stub (Parent (N));
4434 -- Version with check(s) suppressed
4436 procedure Insert_Actions
4437 (Assoc_Node : Node_Id;
4438 Ins_Actions : List_Id;
4439 Suppress : Check_Id)
4442 if Suppress = All_Checks then
4444 Sva : constant Suppress_Array := Scope_Suppress.Suppress;
4446 Scope_Suppress.Suppress := (others => True);
4447 Insert_Actions (Assoc_Node, Ins_Actions);
4448 Scope_Suppress.Suppress := Sva;
4453 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
4455 Scope_Suppress.Suppress (Suppress) := True;
4456 Insert_Actions (Assoc_Node, Ins_Actions);
4457 Scope_Suppress.Suppress (Suppress) := Svg;
4462 --------------------------
4463 -- Insert_Actions_After --
4464 --------------------------
4466 procedure Insert_Actions_After
4467 (Assoc_Node : Node_Id;
4468 Ins_Actions : List_Id)
4471 if Scope_Is_Transient and then Assoc_Node = Node_To_Be_Wrapped then
4472 Store_After_Actions_In_Scope (Ins_Actions);
4474 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
4476 end Insert_Actions_After;
4478 ------------------------
4479 -- Insert_Declaration --
4480 ------------------------
4482 procedure Insert_Declaration (N : Node_Id; Decl : Node_Id) is
4486 pragma Assert (Nkind (N) in N_Subexpr);
4488 -- Climb until we find a procedure or a package
4492 pragma Assert (Present (Parent (P)));
4495 if Is_List_Member (P) then
4496 exit when Nkind_In (Parent (P), N_Package_Specification,
4499 -- Special handling for handled sequence of statements, we must
4500 -- insert in the statements not the exception handlers!
4502 if Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements then
4503 P := First (Statements (Parent (P)));
4509 -- Now do the insertion
4511 Insert_Before (P, Decl);
4513 end Insert_Declaration;
4515 ---------------------------------
4516 -- Insert_Library_Level_Action --
4517 ---------------------------------
4519 procedure Insert_Library_Level_Action (N : Node_Id) is
4520 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
4523 Push_Scope (Cunit_Entity (Main_Unit));
4524 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
4526 if No (Actions (Aux)) then
4527 Set_Actions (Aux, New_List (N));
4529 Append (N, Actions (Aux));
4534 end Insert_Library_Level_Action;
4536 ----------------------------------
4537 -- Insert_Library_Level_Actions --
4538 ----------------------------------
4540 procedure Insert_Library_Level_Actions (L : List_Id) is
4541 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
4544 if Is_Non_Empty_List (L) then
4545 Push_Scope (Cunit_Entity (Main_Unit));
4546 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
4548 if No (Actions (Aux)) then
4549 Set_Actions (Aux, L);
4552 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
4557 end Insert_Library_Level_Actions;
4559 ----------------------
4560 -- Inside_Init_Proc --
4561 ----------------------
4563 function Inside_Init_Proc return Boolean is
4568 while Present (S) and then S /= Standard_Standard loop
4569 if Is_Init_Proc (S) then
4577 end Inside_Init_Proc;
4579 ----------------------------
4580 -- Is_All_Null_Statements --
4581 ----------------------------
4583 function Is_All_Null_Statements (L : List_Id) return Boolean is
4588 while Present (Stm) loop
4589 if Nkind (Stm) /= N_Null_Statement then
4597 end Is_All_Null_Statements;
4599 --------------------------------------------------
4600 -- Is_Displacement_Of_Object_Or_Function_Result --
4601 --------------------------------------------------
4603 function Is_Displacement_Of_Object_Or_Function_Result
4604 (Obj_Id : Entity_Id) return Boolean
4606 function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
4607 -- Determine if particular node denotes a controlled function call. The
4608 -- call may have been heavily expanded.
4610 function Is_Displace_Call (N : Node_Id) return Boolean;
4611 -- Determine whether a particular node is a call to Ada.Tags.Displace.
4612 -- The call might be nested within other actions such as conversions.
4614 function Is_Source_Object (N : Node_Id) return Boolean;
4615 -- Determine whether a particular node denotes a source object
4617 ---------------------------------
4618 -- Is_Controlled_Function_Call --
4619 ---------------------------------
4621 function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
4622 Expr : Node_Id := Original_Node (N);
4625 if Nkind (Expr) = N_Function_Call then
4626 Expr := Name (Expr);
4628 -- When a function call appears in Object.Operation format, the
4629 -- original representation has two possible forms depending on the
4630 -- availability of actual parameters:
4632 -- Obj.Func_Call N_Selected_Component
4633 -- Obj.Func_Call (Param) N_Indexed_Component
4636 if Nkind (Expr) = N_Indexed_Component then
4637 Expr := Prefix (Expr);
4640 if Nkind (Expr) = N_Selected_Component then
4641 Expr := Selector_Name (Expr);
4646 Nkind_In (Expr, N_Expanded_Name, N_Identifier)
4647 and then Ekind (Entity (Expr)) = E_Function
4648 and then Needs_Finalization (Etype (Entity (Expr)));
4649 end Is_Controlled_Function_Call;
4651 ----------------------
4652 -- Is_Displace_Call --
4653 ----------------------
4655 function Is_Displace_Call (N : Node_Id) return Boolean is
4656 Call : Node_Id := N;
4659 -- Strip various actions which may precede a call to Displace
4662 if Nkind (Call) = N_Explicit_Dereference then
4663 Call := Prefix (Call);
4665 elsif Nkind_In (Call, N_Type_Conversion,
4666 N_Unchecked_Type_Conversion)
4668 Call := Expression (Call);
4677 and then Nkind (Call) = N_Function_Call
4678 and then Is_RTE (Entity (Name (Call)), RE_Displace);
4679 end Is_Displace_Call;
4681 ----------------------
4682 -- Is_Source_Object --
4683 ----------------------
4685 function Is_Source_Object (N : Node_Id) return Boolean is
4689 and then Nkind (N) in N_Has_Entity
4690 and then Is_Object (Entity (N))
4691 and then Comes_From_Source (N);
4692 end Is_Source_Object;
4696 Decl : constant Node_Id := Parent (Obj_Id);
4697 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
4698 Orig_Decl : constant Node_Id := Original_Node (Decl);
4700 -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
4705 -- Obj : CW_Type := Function_Call (...);
4709 -- Tmp : ... := Function_Call (...)'reference;
4710 -- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp));
4712 -- where the return type of the function and the class-wide type require
4713 -- dispatch table pointer displacement.
4717 -- Obj : CW_Type := Src_Obj;
4721 -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
4723 -- where the type of the source object and the class-wide type require
4724 -- dispatch table pointer displacement.
4727 Nkind (Decl) = N_Object_Renaming_Declaration
4728 and then Nkind (Orig_Decl) = N_Object_Declaration
4729 and then Comes_From_Source (Orig_Decl)
4730 and then Is_Class_Wide_Type (Obj_Typ)
4731 and then Is_Displace_Call (Renamed_Object (Obj_Id))
4733 (Is_Controlled_Function_Call (Expression (Orig_Decl))
4734 or else Is_Source_Object (Expression (Orig_Decl)));
4735 end Is_Displacement_Of_Object_Or_Function_Result;
4737 ------------------------------
4738 -- Is_Finalizable_Transient --
4739 ------------------------------
4741 function Is_Finalizable_Transient
4743 Rel_Node : Node_Id) return Boolean
4745 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
4746 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
4748 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
4749 -- Determine whether transient object Trans_Id is initialized either
4750 -- by a function call which returns an access type or simply renames
4753 function Initialized_By_Aliased_BIP_Func_Call
4754 (Trans_Id : Entity_Id) return Boolean;
4755 -- Determine whether transient object Trans_Id is initialized by a
4756 -- build-in-place function call where the BIPalloc parameter is of
4757 -- value 1 and BIPaccess is not null. This case creates an aliasing
4758 -- between the returned value and the value denoted by BIPaccess.
4761 (Trans_Id : Entity_Id;
4762 First_Stmt : Node_Id) return Boolean;
4763 -- Determine whether transient object Trans_Id has been renamed or
4764 -- aliased through 'reference in the statement list starting from
4767 function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
4768 -- Determine whether transient object Trans_Id is allocated on the heap
4770 function Is_Iterated_Container
4771 (Trans_Id : Entity_Id;
4772 First_Stmt : Node_Id) return Boolean;
4773 -- Determine whether transient object Trans_Id denotes a container which
4774 -- is in the process of being iterated in the statement list starting
4777 ---------------------------
4778 -- Initialized_By_Access --
4779 ---------------------------
4781 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
4782 Expr : constant Node_Id := Expression (Parent (Trans_Id));
4787 and then Nkind (Expr) /= N_Reference
4788 and then Is_Access_Type (Etype (Expr));
4789 end Initialized_By_Access;
4791 ------------------------------------------
4792 -- Initialized_By_Aliased_BIP_Func_Call --
4793 ------------------------------------------
4795 function Initialized_By_Aliased_BIP_Func_Call
4796 (Trans_Id : Entity_Id) return Boolean
4798 Call : Node_Id := Expression (Parent (Trans_Id));
4801 -- Build-in-place calls usually appear in 'reference format
4803 if Nkind (Call) = N_Reference then
4804 Call := Prefix (Call);
4807 if Is_Build_In_Place_Function_Call (Call) then
4809 Access_Nam : Name_Id := No_Name;
4810 Access_OK : Boolean := False;
4812 Alloc_Nam : Name_Id := No_Name;
4813 Alloc_OK : Boolean := False;
4815 Func_Id : Entity_Id;
4819 -- Examine all parameter associations of the function call
4821 Param := First (Parameter_Associations (Call));
4822 while Present (Param) loop
4823 if Nkind (Param) = N_Parameter_Association
4824 and then Nkind (Selector_Name (Param)) = N_Identifier
4826 Actual := Explicit_Actual_Parameter (Param);
4827 Formal := Selector_Name (Param);
4829 -- Construct the names of formals BIPaccess and BIPalloc
4830 -- using the function name retrieved from an arbitrary
4833 if Access_Nam = No_Name
4834 and then Alloc_Nam = No_Name
4835 and then Present (Entity (Formal))
4837 Func_Id := Scope (Entity (Formal));
4840 New_External_Name (Chars (Func_Id),
4841 BIP_Formal_Suffix (BIP_Object_Access));
4844 New_External_Name (Chars (Func_Id),
4845 BIP_Formal_Suffix (BIP_Alloc_Form));
4848 -- A match for BIPaccess => Temp has been found
4850 if Chars (Formal) = Access_Nam
4851 and then Nkind (Actual) /= N_Null
4856 -- A match for BIPalloc => 1 has been found
4858 if Chars (Formal) = Alloc_Nam
4859 and then Nkind (Actual) = N_Integer_Literal
4860 and then Intval (Actual) = Uint_1
4869 return Access_OK and Alloc_OK;
4874 end Initialized_By_Aliased_BIP_Func_Call;
4881 (Trans_Id : Entity_Id;
4882 First_Stmt : Node_Id) return Boolean
4884 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
4885 -- Given an object renaming declaration, retrieve the entity of the
4886 -- renamed name. Return Empty if the renamed name is anything other
4887 -- than a variable or a constant.
4889 -------------------------
4890 -- Find_Renamed_Object --
4891 -------------------------
4893 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
4894 Ren_Obj : Node_Id := Empty;
4896 function Find_Object (N : Node_Id) return Traverse_Result;
4897 -- Try to detect an object which is either a constant or a
4904 function Find_Object (N : Node_Id) return Traverse_Result is
4906 -- Stop the search once a constant or a variable has been
4909 if Nkind (N) = N_Identifier
4910 and then Present (Entity (N))
4911 and then Ekind_In (Entity (N), E_Constant, E_Variable)
4913 Ren_Obj := Entity (N);
4920 procedure Search is new Traverse_Proc (Find_Object);
4924 Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));
4926 -- Start of processing for Find_Renamed_Object
4929 -- Actions related to dispatching calls may appear as renamings of
4930 -- tags. Do not process this type of renaming because it does not
4931 -- use the actual value of the object.
4933 if not Is_RTE (Typ, RE_Tag_Ptr) then
4934 Search (Name (Ren_Decl));
4938 end Find_Renamed_Object;
4943 Ren_Obj : Entity_Id;
4946 -- Start of processing for Is_Aliased
4949 -- A controlled transient object is not considered aliased when it
4950 -- appears inside an expression_with_actions node even when there are
4951 -- explicit aliases of it:
4954 -- Trans_Id : Ctrl_Typ ...; -- controlled transient object
4955 -- Alias : ... := Trans_Id; -- object is aliased
4956 -- Val : constant Boolean :=
4957 -- ... Alias ...; -- aliasing ends
4958 -- <finalize Trans_Id> -- object safe to finalize
4961 -- Expansion ensures that all aliases are encapsulated in the actions
4962 -- list and do not leak to the expression by forcing the evaluation
4963 -- of the expression.
4965 if Nkind (Rel_Node) = N_Expression_With_Actions then
4968 -- Otherwise examine the statements after the controlled transient
4969 -- object and look for various forms of aliasing.
4973 while Present (Stmt) loop
4974 if Nkind (Stmt) = N_Object_Declaration then
4975 Expr := Expression (Stmt);
4977 -- Aliasing of the form:
4978 -- Obj : ... := Trans_Id'reference;
4981 and then Nkind (Expr) = N_Reference
4982 and then Nkind (Prefix (Expr)) = N_Identifier
4983 and then Entity (Prefix (Expr)) = Trans_Id
4988 elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
4989 Ren_Obj := Find_Renamed_Object (Stmt);
4991 -- Aliasing of the form:
4992 -- Obj : ... renames ... Trans_Id ...;
4994 if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
5010 function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
5011 Expr : constant Node_Id := Expression (Parent (Trans_Id));
5014 Is_Access_Type (Etype (Trans_Id))
5015 and then Present (Expr)
5016 and then Nkind (Expr) = N_Allocator;
5019 ---------------------------
5020 -- Is_Iterated_Container --
5021 ---------------------------
5023 function Is_Iterated_Container
5024 (Trans_Id : Entity_Id;
5025 First_Stmt : Node_Id) return Boolean
5035 -- It is not possible to iterate over containers in non-Ada 2012 code
5037 if Ada_Version < Ada_2012 then
5041 Typ := Etype (Trans_Id);
5043 -- Handle access type created for secondary stack use
5045 if Is_Access_Type (Typ) then
5046 Typ := Designated_Type (Typ);
5049 -- Look for aspect Default_Iterator. It may be part of a type
5050 -- declaration for a container, or inherited from a base type
5053 Aspect := Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator);
5055 if Present (Aspect) then
5056 Iter := Entity (Aspect);
5058 -- Examine the statements following the container object and
5059 -- look for a call to the default iterate routine where the
5060 -- first parameter is the transient. Such a call appears as:
5062 -- It : Access_To_CW_Iterator :=
5063 -- Iterate (Tran_Id.all, ...)'reference;
5066 while Present (Stmt) loop
5068 -- Detect an object declaration which is initialized by a
5069 -- secondary stack function call.
5071 if Nkind (Stmt) = N_Object_Declaration
5072 and then Present (Expression (Stmt))
5073 and then Nkind (Expression (Stmt)) = N_Reference
5074 and then Nkind (Prefix (Expression (Stmt))) = N_Function_Call
5076 Call := Prefix (Expression (Stmt));
5078 -- The call must invoke the default iterate routine of
5079 -- the container and the transient object must appear as
5080 -- the first actual parameter. Skip any calls whose names
5081 -- are not entities.
5083 if Is_Entity_Name (Name (Call))
5084 and then Entity (Name (Call)) = Iter
5085 and then Present (Parameter_Associations (Call))
5087 Param := First (Parameter_Associations (Call));
5089 if Nkind (Param) = N_Explicit_Dereference
5090 and then Entity (Prefix (Param)) = Trans_Id
5102 end Is_Iterated_Container;
5106 Desig : Entity_Id := Obj_Typ;
5108 -- Start of processing for Is_Finalizable_Transient
5111 -- Handle access types
5113 if Is_Access_Type (Desig) then
5114 Desig := Available_View (Designated_Type (Desig));
5118 Ekind_In (Obj_Id, E_Constant, E_Variable)
5119 and then Needs_Finalization (Desig)
5120 and then Requires_Transient_Scope (Desig)
5121 and then Nkind (Rel_Node) /= N_Simple_Return_Statement
5123 -- Do not consider renamed or 'reference-d transient objects because
5124 -- the act of renaming extends the object's lifetime.
5126 and then not Is_Aliased (Obj_Id, Decl)
5128 -- Do not consider transient objects allocated on the heap since
5129 -- they are attached to a finalization master.
5131 and then not Is_Allocated (Obj_Id)
5133 -- If the transient object is a pointer, check that it is not
5134 -- initialized by a function that returns a pointer or acts as a
5135 -- renaming of another pointer.
5138 (not Is_Access_Type (Obj_Typ)
5139 or else not Initialized_By_Access (Obj_Id))
5141 -- Do not consider transient objects which act as indirect aliases
5142 -- of build-in-place function results.
5144 and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
5146 -- Do not consider conversions of tags to class-wide types
5148 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
5150 -- Do not consider iterators because those are treated as normal
5151 -- controlled objects and are processed by the usual finalization
5152 -- machinery. This avoids the double finalization of an iterator.
5154 and then not Is_Iterator (Desig)
5156 -- Do not consider containers in the context of iterator loops. Such
5157 -- transient objects must exist for as long as the loop is around,
5158 -- otherwise any operation carried out by the iterator will fail.
5160 and then not Is_Iterated_Container (Obj_Id, Decl);
5161 end Is_Finalizable_Transient;
5163 ---------------------------------
5164 -- Is_Fully_Repped_Tagged_Type --
5165 ---------------------------------
5167 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
5168 U : constant Entity_Id := Underlying_Type (T);
5172 if No (U) or else not Is_Tagged_Type (U) then
5174 elsif Has_Discriminants (U) then
5176 elsif not Has_Specified_Layout (U) then
5180 -- Here we have a tagged type, see if it has any unlayed out fields
5181 -- other than a possible tag and parent fields. If so, we return False.
5183 Comp := First_Component (U);
5184 while Present (Comp) loop
5185 if not Is_Tag (Comp)
5186 and then Chars (Comp) /= Name_uParent
5187 and then No (Component_Clause (Comp))
5191 Next_Component (Comp);
5195 -- All components are layed out
5198 end Is_Fully_Repped_Tagged_Type;
5200 ----------------------------------
5201 -- Is_Library_Level_Tagged_Type --
5202 ----------------------------------
5204 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
5206 return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ);
5207 end Is_Library_Level_Tagged_Type;
5209 --------------------------
5210 -- Is_Non_BIP_Func_Call --
5211 --------------------------
5213 function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
5215 -- The expected call is of the format
5217 -- Func_Call'reference
5220 Nkind (Expr) = N_Reference
5221 and then Nkind (Prefix (Expr)) = N_Function_Call
5222 and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
5223 end Is_Non_BIP_Func_Call;
5225 ------------------------------------
5226 -- Is_Object_Access_BIP_Func_Call --
5227 ------------------------------------
5229 function Is_Object_Access_BIP_Func_Call
5231 Obj_Id : Entity_Id) return Boolean
5233 Access_Nam : Name_Id := No_Name;
5240 -- Build-in-place calls usually appear in 'reference format. Note that
5241 -- the accessibility check machinery may add an extra 'reference due to
5242 -- side effect removal.
5245 while Nkind (Call) = N_Reference loop
5246 Call := Prefix (Call);
5249 if Nkind_In (Call, N_Qualified_Expression,
5250 N_Unchecked_Type_Conversion)
5252 Call := Expression (Call);
5255 if Is_Build_In_Place_Function_Call (Call) then
5257 -- Examine all parameter associations of the function call
5259 Param := First (Parameter_Associations (Call));
5260 while Present (Param) loop
5261 if Nkind (Param) = N_Parameter_Association
5262 and then Nkind (Selector_Name (Param)) = N_Identifier
5264 Formal := Selector_Name (Param);
5265 Actual := Explicit_Actual_Parameter (Param);
5267 -- Construct the name of formal BIPaccess. It is much easier to
5268 -- extract the name of the function using an arbitrary formal's
5269 -- scope rather than the Name field of Call.
5271 if Access_Nam = No_Name and then Present (Entity (Formal)) then
5274 (Chars (Scope (Entity (Formal))),
5275 BIP_Formal_Suffix (BIP_Object_Access));
5278 -- A match for BIPaccess => Obj_Id'Unrestricted_Access has been
5281 if Chars (Formal) = Access_Nam
5282 and then Nkind (Actual) = N_Attribute_Reference
5283 and then Attribute_Name (Actual) = Name_Unrestricted_Access
5284 and then Nkind (Prefix (Actual)) = N_Identifier
5285 and then Entity (Prefix (Actual)) = Obj_Id
5296 end Is_Object_Access_BIP_Func_Call;
5298 ----------------------------------
5299 -- Is_Possibly_Unaligned_Object --
5300 ----------------------------------
5302 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
5303 T : constant Entity_Id := Etype (N);
5306 -- If renamed object, apply test to underlying object
5308 if Is_Entity_Name (N)
5309 and then Is_Object (Entity (N))
5310 and then Present (Renamed_Object (Entity (N)))
5312 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
5315 -- Tagged and controlled types and aliased types are always aligned, as
5316 -- are concurrent types.
5319 or else Has_Controlled_Component (T)
5320 or else Is_Concurrent_Type (T)
5321 or else Is_Tagged_Type (T)
5322 or else Is_Controlled (T)
5327 -- If this is an element of a packed array, may be unaligned
5329 if Is_Ref_To_Bit_Packed_Array (N) then
5333 -- Case of indexed component reference: test whether prefix is unaligned
5335 if Nkind (N) = N_Indexed_Component then
5336 return Is_Possibly_Unaligned_Object (Prefix (N));
5338 -- Case of selected component reference
5340 elsif Nkind (N) = N_Selected_Component then
5342 P : constant Node_Id := Prefix (N);
5343 C : constant Entity_Id := Entity (Selector_Name (N));
5348 -- If component reference is for an array with non-static bounds,
5349 -- then it is always aligned: we can only process unaligned arrays
5350 -- with static bounds (more precisely compile time known bounds).
5352 if Is_Array_Type (T)
5353 and then not Compile_Time_Known_Bounds (T)
5358 -- If component is aliased, it is definitely properly aligned
5360 if Is_Aliased (C) then
5364 -- If component is for a type implemented as a scalar, and the
5365 -- record is packed, and the component is other than the first
5366 -- component of the record, then the component may be unaligned.
5368 if Is_Packed (Etype (P))
5369 and then Represented_As_Scalar (Etype (C))
5370 and then First_Entity (Scope (C)) /= C
5375 -- Compute maximum possible alignment for T
5377 -- If alignment is known, then that settles things
5379 if Known_Alignment (T) then
5380 M := UI_To_Int (Alignment (T));
5382 -- If alignment is not known, tentatively set max alignment
5385 M := Ttypes.Maximum_Alignment;
5387 -- We can reduce this if the Esize is known since the default
5388 -- alignment will never be more than the smallest power of 2
5389 -- that does not exceed this Esize value.
5391 if Known_Esize (T) then
5392 S := UI_To_Int (Esize (T));
5394 while (M / 2) >= S loop
5400 -- The following code is historical, it used to be present but it
5401 -- is too cautious, because the front-end does not know the proper
5402 -- default alignments for the target. Also, if the alignment is
5403 -- not known, the front end can't know in any case. If a copy is
5404 -- needed, the back-end will take care of it. This whole section
5405 -- including this comment can be removed later ???
5407 -- If the component reference is for a record that has a specified
5408 -- alignment, and we either know it is too small, or cannot tell,
5409 -- then the component may be unaligned.
5411 -- What is the following commented out code ???
5413 -- if Known_Alignment (Etype (P))
5414 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
5415 -- and then M > Alignment (Etype (P))
5420 -- Case of component clause present which may specify an
5421 -- unaligned position.
5423 if Present (Component_Clause (C)) then
5425 -- Otherwise we can do a test to make sure that the actual
5426 -- start position in the record, and the length, are both
5427 -- consistent with the required alignment. If not, we know
5428 -- that we are unaligned.
5431 Align_In_Bits : constant Nat := M * System_Storage_Unit;
5433 if Component_Bit_Offset (C) mod Align_In_Bits /= 0
5434 or else Esize (C) mod Align_In_Bits /= 0
5441 -- Otherwise, for a component reference, test prefix
5443 return Is_Possibly_Unaligned_Object (P);
5446 -- If not a component reference, must be aligned
5451 end Is_Possibly_Unaligned_Object;
5453 ---------------------------------
5454 -- Is_Possibly_Unaligned_Slice --
5455 ---------------------------------
5457 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
5459 -- Go to renamed object
5461 if Is_Entity_Name (N)
5462 and then Is_Object (Entity (N))
5463 and then Present (Renamed_Object (Entity (N)))
5465 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
5468 -- The reference must be a slice
5470 if Nkind (N) /= N_Slice then
5474 -- We only need to worry if the target has strict alignment
5476 if not Target_Strict_Alignment then
5480 -- If it is a slice, then look at the array type being sliced
5483 Sarr : constant Node_Id := Prefix (N);
5484 -- Prefix of the slice, i.e. the array being sliced
5486 Styp : constant Entity_Id := Etype (Prefix (N));
5487 -- Type of the array being sliced
5493 -- The problems arise if the array object that is being sliced
5494 -- is a component of a record or array, and we cannot guarantee
5495 -- the alignment of the array within its containing object.
5497 -- To investigate this, we look at successive prefixes to see
5498 -- if we have a worrisome indexed or selected component.
5502 -- Case of array is part of an indexed component reference
5504 if Nkind (Pref) = N_Indexed_Component then
5505 Ptyp := Etype (Prefix (Pref));
5507 -- The only problematic case is when the array is packed, in
5508 -- which case we really know nothing about the alignment of
5509 -- individual components.
5511 if Is_Bit_Packed_Array (Ptyp) then
5515 -- Case of array is part of a selected component reference
5517 elsif Nkind (Pref) = N_Selected_Component then
5518 Ptyp := Etype (Prefix (Pref));
5520 -- We are definitely in trouble if the record in question
5521 -- has an alignment, and either we know this alignment is
5522 -- inconsistent with the alignment of the slice, or we don't
5523 -- know what the alignment of the slice should be.
5525 if Known_Alignment (Ptyp)
5526 and then (Unknown_Alignment (Styp)
5527 or else Alignment (Styp) > Alignment (Ptyp))
5532 -- We are in potential trouble if the record type is packed.
5533 -- We could special case when we know that the array is the
5534 -- first component, but that's not such a simple case ???
5536 if Is_Packed (Ptyp) then
5540 -- We are in trouble if there is a component clause, and
5541 -- either we do not know the alignment of the slice, or
5542 -- the alignment of the slice is inconsistent with the
5543 -- bit position specified by the component clause.
5546 Field : constant Entity_Id := Entity (Selector_Name (Pref));
5548 if Present (Component_Clause (Field))
5550 (Unknown_Alignment (Styp)
5552 (Component_Bit_Offset (Field) mod
5553 (System_Storage_Unit * Alignment (Styp))) /= 0)
5559 -- For cases other than selected or indexed components we know we
5560 -- are OK, since no issues arise over alignment.
5566 -- We processed an indexed component or selected component
5567 -- reference that looked safe, so keep checking prefixes.
5569 Pref := Prefix (Pref);
5572 end Is_Possibly_Unaligned_Slice;
5574 -------------------------------
5575 -- Is_Related_To_Func_Return --
5576 -------------------------------
5578 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
5579 Expr : constant Node_Id := Related_Expression (Id);
5583 and then Nkind (Expr) = N_Explicit_Dereference
5584 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
5585 end Is_Related_To_Func_Return;
5587 --------------------------------
5588 -- Is_Ref_To_Bit_Packed_Array --
5589 --------------------------------
5591 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
5596 if Is_Entity_Name (N)
5597 and then Is_Object (Entity (N))
5598 and then Present (Renamed_Object (Entity (N)))
5600 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
5603 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
5604 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
5607 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
5610 if Result and then Nkind (N) = N_Indexed_Component then
5611 Expr := First (Expressions (N));
5612 while Present (Expr) loop
5613 Force_Evaluation (Expr);
5623 end Is_Ref_To_Bit_Packed_Array;
5625 --------------------------------
5626 -- Is_Ref_To_Bit_Packed_Slice --
5627 --------------------------------
5629 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
5631 if Nkind (N) = N_Type_Conversion then
5632 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
5634 elsif Is_Entity_Name (N)
5635 and then Is_Object (Entity (N))
5636 and then Present (Renamed_Object (Entity (N)))
5638 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
5640 elsif Nkind (N) = N_Slice
5641 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
5645 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
5646 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
5651 end Is_Ref_To_Bit_Packed_Slice;
5653 -----------------------
5654 -- Is_Renamed_Object --
5655 -----------------------
5657 function Is_Renamed_Object (N : Node_Id) return Boolean is
5658 Pnod : constant Node_Id := Parent (N);
5659 Kind : constant Node_Kind := Nkind (Pnod);
5661 if Kind = N_Object_Renaming_Declaration then
5663 elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
5664 return Is_Renamed_Object (Pnod);
5668 end Is_Renamed_Object;
5670 --------------------------------------
5671 -- Is_Secondary_Stack_BIP_Func_Call --
5672 --------------------------------------
5674 function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
5675 Alloc_Nam : Name_Id := No_Name;
5677 Call : Node_Id := Expr;
5682 -- Build-in-place calls usually appear in 'reference format. Note that
5683 -- the accessibility check machinery may add an extra 'reference due to
5684 -- side effect removal.
5686 while Nkind (Call) = N_Reference loop
5687 Call := Prefix (Call);
5690 if Nkind_In (Call, N_Qualified_Expression,
5691 N_Unchecked_Type_Conversion)
5693 Call := Expression (Call);
5696 if Is_Build_In_Place_Function_Call (Call) then
5698 -- Examine all parameter associations of the function call
5700 Param := First (Parameter_Associations (Call));
5701 while Present (Param) loop
5702 if Nkind (Param) = N_Parameter_Association
5703 and then Nkind (Selector_Name (Param)) = N_Identifier
5705 Formal := Selector_Name (Param);
5706 Actual := Explicit_Actual_Parameter (Param);
5708 -- Construct the name of formal BIPalloc. It is much easier to
5709 -- extract the name of the function using an arbitrary formal's
5710 -- scope rather than the Name field of Call.
5712 if Alloc_Nam = No_Name and then Present (Entity (Formal)) then
5715 (Chars (Scope (Entity (Formal))),
5716 BIP_Formal_Suffix (BIP_Alloc_Form));
5719 -- A match for BIPalloc => 2 has been found
5721 if Chars (Formal) = Alloc_Nam
5722 and then Nkind (Actual) = N_Integer_Literal
5723 and then Intval (Actual) = Uint_2
5734 end Is_Secondary_Stack_BIP_Func_Call;
5736 -------------------------------------
5737 -- Is_Tag_To_Class_Wide_Conversion --
5738 -------------------------------------
5740 function Is_Tag_To_Class_Wide_Conversion
5741 (Obj_Id : Entity_Id) return Boolean
5743 Expr : constant Node_Id := Expression (Parent (Obj_Id));
5747 Is_Class_Wide_Type (Etype (Obj_Id))
5748 and then Present (Expr)
5749 and then Nkind (Expr) = N_Unchecked_Type_Conversion
5750 and then Etype (Expression (Expr)) = RTE (RE_Tag);
5751 end Is_Tag_To_Class_Wide_Conversion;
5753 ----------------------------
5754 -- Is_Untagged_Derivation --
5755 ----------------------------
5757 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
5759 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
5761 (Is_Private_Type (T) and then Present (Full_View (T))
5762 and then not Is_Tagged_Type (Full_View (T))
5763 and then Is_Derived_Type (Full_View (T))
5764 and then Etype (Full_View (T)) /= T);
5765 end Is_Untagged_Derivation;
5767 ---------------------------
5768 -- Is_Volatile_Reference --
5769 ---------------------------
5771 function Is_Volatile_Reference (N : Node_Id) return Boolean is
5773 -- Only source references are to be treated as volatile, internally
5774 -- generated stuff cannot have volatile external effects.
5776 if not Comes_From_Source (N) then
5779 -- Never true for reference to a type
5781 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
5784 -- Never true for a compile time known constant
5786 elsif Compile_Time_Known_Value (N) then
5789 -- True if object reference with volatile type
5791 elsif Is_Volatile_Object (N) then
5794 -- True if reference to volatile entity
5796 elsif Is_Entity_Name (N) then
5797 return Treat_As_Volatile (Entity (N));
5799 -- True for slice of volatile array
5801 elsif Nkind (N) = N_Slice then
5802 return Is_Volatile_Reference (Prefix (N));
5804 -- True if volatile component
5806 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
5807 if (Is_Entity_Name (Prefix (N))
5808 and then Has_Volatile_Components (Entity (Prefix (N))))
5809 or else (Present (Etype (Prefix (N)))
5810 and then Has_Volatile_Components (Etype (Prefix (N))))
5814 return Is_Volatile_Reference (Prefix (N));
5822 end Is_Volatile_Reference;
5824 --------------------
5825 -- Kill_Dead_Code --
5826 --------------------
5828 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
5829 W : Boolean := Warn;
5830 -- Set False if warnings suppressed
5834 Remove_Warning_Messages (N);
5836 -- Generate warning if appropriate
5840 -- We suppress the warning if this code is under control of an
5841 -- if statement, whose condition is a simple identifier, and
5842 -- either we are in an instance, or warnings off is set for this
5843 -- identifier. The reason for killing it in the instance case is
5844 -- that it is common and reasonable for code to be deleted in
5845 -- instances for various reasons.
5847 -- Could we use Is_Statically_Unevaluated here???
5849 if Nkind (Parent (N)) = N_If_Statement then
5851 C : constant Node_Id := Condition (Parent (N));
5853 if Nkind (C) = N_Identifier
5856 or else (Present (Entity (C))
5857 and then Has_Warnings_Off (Entity (C))))
5864 -- Generate warning if not suppressed
5868 ("?t?this code can never be executed and has been deleted!",
5873 -- Recurse into block statements and bodies to process declarations
5876 if Nkind (N) = N_Block_Statement
5877 or else Nkind (N) = N_Subprogram_Body
5878 or else Nkind (N) = N_Package_Body
5880 Kill_Dead_Code (Declarations (N), False);
5881 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
5883 if Nkind (N) = N_Subprogram_Body then
5884 Set_Is_Eliminated (Defining_Entity (N));
5887 elsif Nkind (N) = N_Package_Declaration then
5888 Kill_Dead_Code (Visible_Declarations (Specification (N)));
5889 Kill_Dead_Code (Private_Declarations (Specification (N)));
5891 -- ??? After this point, Delete_Tree has been called on all
5892 -- declarations in Specification (N), so references to entities
5893 -- therein look suspicious.
5896 E : Entity_Id := First_Entity (Defining_Entity (N));
5899 while Present (E) loop
5900 if Ekind (E) = E_Operator then
5901 Set_Is_Eliminated (E);
5908 -- Recurse into composite statement to kill individual statements in
5909 -- particular instantiations.
5911 elsif Nkind (N) = N_If_Statement then
5912 Kill_Dead_Code (Then_Statements (N));
5913 Kill_Dead_Code (Elsif_Parts (N));
5914 Kill_Dead_Code (Else_Statements (N));
5916 elsif Nkind (N) = N_Loop_Statement then
5917 Kill_Dead_Code (Statements (N));
5919 elsif Nkind (N) = N_Case_Statement then
5923 Alt := First (Alternatives (N));
5924 while Present (Alt) loop
5925 Kill_Dead_Code (Statements (Alt));
5930 elsif Nkind (N) = N_Case_Statement_Alternative then
5931 Kill_Dead_Code (Statements (N));
5933 -- Deal with dead instances caused by deleting instantiations
5935 elsif Nkind (N) in N_Generic_Instantiation then
5936 Remove_Dead_Instance (N);
5941 -- Case where argument is a list of nodes to be killed
5943 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
5950 if Is_Non_Empty_List (L) then
5952 while Present (N) loop
5953 Kill_Dead_Code (N, W);
5960 ------------------------
5961 -- Known_Non_Negative --
5962 ------------------------
5964 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
5966 if Is_OK_Static_Expression (Opnd) and then Expr_Value (Opnd) >= 0 then
5971 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
5974 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
5977 end Known_Non_Negative;
5979 --------------------
5980 -- Known_Non_Null --
5981 --------------------
5983 function Known_Non_Null (N : Node_Id) return Boolean is
5985 -- Checks for case where N is an entity reference
5987 if Is_Entity_Name (N) and then Present (Entity (N)) then
5989 E : constant Entity_Id := Entity (N);
5994 -- First check if we are in decisive conditional
5996 Get_Current_Value_Condition (N, Op, Val);
5998 if Known_Null (Val) then
5999 if Op = N_Op_Eq then
6001 elsif Op = N_Op_Ne then
6006 -- If OK to do replacement, test Is_Known_Non_Null flag
6008 if OK_To_Do_Constant_Replacement (E) then
6009 return Is_Known_Non_Null (E);
6011 -- Otherwise if not safe to do replacement, then say so
6018 -- True if access attribute
6020 elsif Nkind (N) = N_Attribute_Reference
6021 and then Nam_In (Attribute_Name (N), Name_Access,
6022 Name_Unchecked_Access,
6023 Name_Unrestricted_Access)
6027 -- True if allocator
6029 elsif Nkind (N) = N_Allocator then
6032 -- For a conversion, true if expression is known non-null
6034 elsif Nkind (N) = N_Type_Conversion then
6035 return Known_Non_Null (Expression (N));
6037 -- Above are all cases where the value could be determined to be
6038 -- non-null. In all other cases, we don't know, so return False.
6049 function Known_Null (N : Node_Id) return Boolean is
6051 -- Checks for case where N is an entity reference
6053 if Is_Entity_Name (N) and then Present (Entity (N)) then
6055 E : constant Entity_Id := Entity (N);
6060 -- Constant null value is for sure null
6062 if Ekind (E) = E_Constant
6063 and then Known_Null (Constant_Value (E))
6068 -- First check if we are in decisive conditional
6070 Get_Current_Value_Condition (N, Op, Val);
6072 if Known_Null (Val) then
6073 if Op = N_Op_Eq then
6075 elsif Op = N_Op_Ne then
6080 -- If OK to do replacement, test Is_Known_Null flag
6082 if OK_To_Do_Constant_Replacement (E) then
6083 return Is_Known_Null (E);
6085 -- Otherwise if not safe to do replacement, then say so
6092 -- True if explicit reference to null
6094 elsif Nkind (N) = N_Null then
6097 -- For a conversion, true if expression is known null
6099 elsif Nkind (N) = N_Type_Conversion then
6100 return Known_Null (Expression (N));
6102 -- Above are all cases where the value could be determined to be null.
6103 -- In all other cases, we don't know, so return False.
6110 -----------------------------
6111 -- Make_CW_Equivalent_Type --
6112 -----------------------------
6114 -- Create a record type used as an equivalent of any member of the class
6115 -- which takes its size from exp.
6117 -- Generate the following code:
6119 -- type Equiv_T is record
6120 -- _parent : T (List of discriminant constraints taken from Exp);
6121 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
6124 -- ??? Note that this type does not guarantee same alignment as all
6127 function Make_CW_Equivalent_Type
6129 E : Node_Id) return Entity_Id
6131 Loc : constant Source_Ptr := Sloc (E);
6132 Root_Typ : constant Entity_Id := Root_Type (T);
6133 List_Def : constant List_Id := Empty_List;
6134 Comp_List : constant List_Id := New_List;
6135 Equiv_Type : Entity_Id;
6136 Range_Type : Entity_Id;
6137 Str_Type : Entity_Id;
6138 Constr_Root : Entity_Id;
6142 -- If the root type is already constrained, there are no discriminants
6143 -- in the expression.
6145 if not Has_Discriminants (Root_Typ)
6146 or else Is_Constrained (Root_Typ)
6148 Constr_Root := Root_Typ;
6150 -- At this point in the expansion, non-limited view of the type
6151 -- must be available, otherwise the error will be reported later.
6153 if From_Limited_With (Constr_Root)
6154 and then Present (Non_Limited_View (Constr_Root))
6156 Constr_Root := Non_Limited_View (Constr_Root);
6160 Constr_Root := Make_Temporary (Loc, 'R');
6162 -- subtype cstr__n is T (List of discr constraints taken from Exp)
6164 Append_To (List_Def,
6165 Make_Subtype_Declaration (Loc,
6166 Defining_Identifier => Constr_Root,
6167 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
6170 -- Generate the range subtype declaration
6172 Range_Type := Make_Temporary (Loc, 'G');
6174 if not Is_Interface (Root_Typ) then
6176 -- subtype rg__xx is
6177 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
6180 Make_Op_Subtract (Loc,
6182 Make_Attribute_Reference (Loc,
6184 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
6185 Attribute_Name => Name_Size),
6187 Make_Attribute_Reference (Loc,
6188 Prefix => New_Occurrence_Of (Constr_Root, Loc),
6189 Attribute_Name => Name_Object_Size));
6191 -- subtype rg__xx is
6192 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
6195 Make_Attribute_Reference (Loc,
6197 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
6198 Attribute_Name => Name_Size);
6201 Set_Paren_Count (Sizexpr, 1);
6203 Append_To (List_Def,
6204 Make_Subtype_Declaration (Loc,
6205 Defining_Identifier => Range_Type,
6206 Subtype_Indication =>
6207 Make_Subtype_Indication (Loc,
6208 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
6209 Constraint => Make_Range_Constraint (Loc,
6212 Low_Bound => Make_Integer_Literal (Loc, 1),
6214 Make_Op_Divide (Loc,
6215 Left_Opnd => Sizexpr,
6216 Right_Opnd => Make_Integer_Literal (Loc,
6217 Intval => System_Storage_Unit)))))));
6219 -- subtype str__nn is Storage_Array (rg__x);
6221 Str_Type := Make_Temporary (Loc, 'S');
6222 Append_To (List_Def,
6223 Make_Subtype_Declaration (Loc,
6224 Defining_Identifier => Str_Type,
6225 Subtype_Indication =>
6226 Make_Subtype_Indication (Loc,
6227 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
6229 Make_Index_Or_Discriminant_Constraint (Loc,
6231 New_List (New_Occurrence_Of (Range_Type, Loc))))));
6233 -- type Equiv_T is record
6234 -- [ _parent : Tnn; ]
6238 Equiv_Type := Make_Temporary (Loc, 'T');
6239 Set_Ekind (Equiv_Type, E_Record_Type);
6240 Set_Parent_Subtype (Equiv_Type, Constr_Root);
6242 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
6243 -- treatment for this type. In particular, even though _parent's type
6244 -- is a controlled type or contains controlled components, we do not
6245 -- want to set Has_Controlled_Component on it to avoid making it gain
6246 -- an unwanted _controller component.
6248 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
6250 -- A class-wide equivalent type does not require initialization
6252 Set_Suppress_Initialization (Equiv_Type);
6254 if not Is_Interface (Root_Typ) then
6255 Append_To (Comp_List,
6256 Make_Component_Declaration (Loc,
6257 Defining_Identifier =>
6258 Make_Defining_Identifier (Loc, Name_uParent),
6259 Component_Definition =>
6260 Make_Component_Definition (Loc,
6261 Aliased_Present => False,
6262 Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc))));
6265 Append_To (Comp_List,
6266 Make_Component_Declaration (Loc,
6267 Defining_Identifier => Make_Temporary (Loc, 'C'),
6268 Component_Definition =>
6269 Make_Component_Definition (Loc,
6270 Aliased_Present => False,
6271 Subtype_Indication => New_Occurrence_Of (Str_Type, Loc))));
6273 Append_To (List_Def,
6274 Make_Full_Type_Declaration (Loc,
6275 Defining_Identifier => Equiv_Type,
6277 Make_Record_Definition (Loc,
6279 Make_Component_List (Loc,
6280 Component_Items => Comp_List,
6281 Variant_Part => Empty))));
6283 -- Suppress all checks during the analysis of the expanded code to avoid
6284 -- the generation of spurious warnings under ZFP run-time.
6286 Insert_Actions (E, List_Def, Suppress => All_Checks);
6288 end Make_CW_Equivalent_Type;
6290 -------------------------
6291 -- Make_Invariant_Call --
6292 -------------------------
6294 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
6295 Loc : constant Source_Ptr := Sloc (Expr);
6299 Typ := Etype (Expr);
6301 -- Subtypes may be subject to invariants coming from their respective
6302 -- base types. The subtype may be fully or partially private.
6304 if Ekind_In (Typ, E_Array_Subtype,
6307 E_Record_Subtype_With_Private)
6309 Typ := Base_Type (Typ);
6313 (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
6316 Make_Procedure_Call_Statement (Loc,
6318 New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
6319 Parameter_Associations => New_List (Relocate_Node (Expr)));
6320 end Make_Invariant_Call;
6322 ------------------------
6323 -- Make_Literal_Range --
6324 ------------------------
6326 function Make_Literal_Range
6328 Literal_Typ : Entity_Id) return Node_Id
6330 Lo : constant Node_Id :=
6331 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
6332 Index : constant Entity_Id := Etype (Lo);
6335 Length_Expr : constant Node_Id :=
6336 Make_Op_Subtract (Loc,
6338 Make_Integer_Literal (Loc,
6339 Intval => String_Literal_Length (Literal_Typ)),
6341 Make_Integer_Literal (Loc, 1));
6344 Set_Analyzed (Lo, False);
6346 if Is_Integer_Type (Index) then
6349 Left_Opnd => New_Copy_Tree (Lo),
6350 Right_Opnd => Length_Expr);
6353 Make_Attribute_Reference (Loc,
6354 Attribute_Name => Name_Val,
6355 Prefix => New_Occurrence_Of (Index, Loc),
6356 Expressions => New_List (
6359 Make_Attribute_Reference (Loc,
6360 Attribute_Name => Name_Pos,
6361 Prefix => New_Occurrence_Of (Index, Loc),
6362 Expressions => New_List (New_Copy_Tree (Lo))),
6363 Right_Opnd => Length_Expr)));
6370 end Make_Literal_Range;
6372 --------------------------
6373 -- Make_Non_Empty_Check --
6374 --------------------------
6376 function Make_Non_Empty_Check
6378 N : Node_Id) return Node_Id
6384 Make_Attribute_Reference (Loc,
6385 Attribute_Name => Name_Length,
6386 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
6388 Make_Integer_Literal (Loc, 0));
6389 end Make_Non_Empty_Check;
6391 -------------------------
6392 -- Make_Predicate_Call --
6393 -------------------------
6395 function Make_Predicate_Call
6398 Mem : Boolean := False) return Node_Id
6400 Loc : constant Source_Ptr := Sloc (Expr);
6404 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
6407 pragma Assert (Present (Predicate_Function (Typ)));
6409 -- The related type may be subject to pragma Ghost. Set the mode now to
6410 -- ensure that the call is properly marked as Ghost.
6412 Set_Ghost_Mode_From_Entity (Typ);
6414 -- Call special membership version if requested and available
6417 PFM := Predicate_Function_M (Typ);
6419 if Present (PFM) then
6421 Make_Function_Call (Loc,
6422 Name => New_Occurrence_Of (PFM, Loc),
6423 Parameter_Associations => New_List (Relocate_Node (Expr)));
6425 Ghost_Mode := Save_Ghost_Mode;
6430 -- Case of calling normal predicate function
6433 Make_Function_Call (Loc,
6435 New_Occurrence_Of (Predicate_Function (Typ), Loc),
6436 Parameter_Associations => New_List (Relocate_Node (Expr)));
6438 Ghost_Mode := Save_Ghost_Mode;
6440 end Make_Predicate_Call;
6442 --------------------------
6443 -- Make_Predicate_Check --
6444 --------------------------
6446 function Make_Predicate_Check
6448 Expr : Node_Id) return Node_Id
6450 Loc : constant Source_Ptr := Sloc (Expr);
6454 -- If predicate checks are suppressed, then return a null statement.
6455 -- For this call, we check only the scope setting. If the caller wants
6456 -- to check a specific entity's setting, they must do it manually.
6458 if Predicate_Checks_Suppressed (Empty) then
6459 return Make_Null_Statement (Loc);
6462 -- Do not generate a check within an internal subprogram (stream
6463 -- functions and the like, including including predicate functions).
6465 if Within_Internal_Subprogram then
6466 return Make_Null_Statement (Loc);
6469 -- Compute proper name to use, we need to get this right so that the
6470 -- right set of check policies apply to the Check pragma we are making.
6472 if Has_Dynamic_Predicate_Aspect (Typ) then
6473 Nam := Name_Dynamic_Predicate;
6474 elsif Has_Static_Predicate_Aspect (Typ) then
6475 Nam := Name_Static_Predicate;
6477 Nam := Name_Predicate;
6482 Pragma_Identifier => Make_Identifier (Loc, Name_Check),
6483 Pragma_Argument_Associations => New_List (
6484 Make_Pragma_Argument_Association (Loc,
6485 Expression => Make_Identifier (Loc, Nam)),
6486 Make_Pragma_Argument_Association (Loc,
6487 Expression => Make_Predicate_Call (Typ, Expr))));
6488 end Make_Predicate_Check;
6490 ----------------------------
6491 -- Make_Subtype_From_Expr --
6492 ----------------------------
6494 -- 1. If Expr is an unconstrained array expression, creates
6495 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
6497 -- 2. If Expr is a unconstrained discriminated type expression, creates
6498 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
6500 -- 3. If Expr is class-wide, creates an implicit class-wide subtype
6502 function Make_Subtype_From_Expr
6504 Unc_Typ : Entity_Id) return Node_Id
6506 List_Constr : constant List_Id := New_List;
6507 Loc : constant Source_Ptr := Sloc (E);
6510 Full_Subtyp : Entity_Id;
6511 High_Bound : Entity_Id;
6512 Index_Typ : Entity_Id;
6513 Low_Bound : Entity_Id;
6514 Priv_Subtyp : Entity_Id;
6518 if Is_Private_Type (Unc_Typ)
6519 and then Has_Unknown_Discriminants (Unc_Typ)
6521 -- Prepare the subtype completion. Use the base type to find the
6522 -- underlying type because the type may be a generic actual or an
6523 -- explicit subtype.
6525 Utyp := Underlying_Type (Base_Type (Unc_Typ));
6526 Full_Subtyp := Make_Temporary (Loc, 'C');
6528 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
6529 Set_Parent (Full_Exp, Parent (E));
6531 Priv_Subtyp := Make_Temporary (Loc, 'P');
6534 Make_Subtype_Declaration (Loc,
6535 Defining_Identifier => Full_Subtyp,
6536 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
6538 -- Define the dummy private subtype
6540 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
6541 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
6542 Set_Scope (Priv_Subtyp, Full_Subtyp);
6543 Set_Is_Constrained (Priv_Subtyp);
6544 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
6545 Set_Is_Itype (Priv_Subtyp);
6546 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
6548 if Is_Tagged_Type (Priv_Subtyp) then
6550 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
6551 Set_Direct_Primitive_Operations (Priv_Subtyp,
6552 Direct_Primitive_Operations (Unc_Typ));
6555 Set_Full_View (Priv_Subtyp, Full_Subtyp);
6557 return New_Occurrence_Of (Priv_Subtyp, Loc);
6559 elsif Is_Array_Type (Unc_Typ) then
6560 Index_Typ := First_Index (Unc_Typ);
6561 for J in 1 .. Number_Dimensions (Unc_Typ) loop
6563 -- Capture the bounds of each index constraint in case the context
6564 -- is an object declaration of an unconstrained type initialized
6565 -- by a function call:
6567 -- Obj : Unconstr_Typ := Func_Call;
6569 -- This scenario requires secondary scope management and the index
6570 -- constraint cannot depend on the temporary used to capture the
6571 -- result of the function call.
6574 -- Temp : Unconstr_Typ_Ptr := Func_Call'reference;
6575 -- subtype S is Unconstr_Typ (Temp.all'First .. Temp.all'Last);
6576 -- Obj : S := Temp.all;
6577 -- SS_Release; -- Temp is gone at this point, bounds of S are
6581 -- Low_Bound : constant Base_Type (Index_Typ) := E'First (J);
6583 Low_Bound := Make_Temporary (Loc, 'B');
6585 Make_Object_Declaration (Loc,
6586 Defining_Identifier => Low_Bound,
6587 Object_Definition =>
6588 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
6589 Constant_Present => True,
6591 Make_Attribute_Reference (Loc,
6592 Prefix => Duplicate_Subexpr_No_Checks (E),
6593 Attribute_Name => Name_First,
6594 Expressions => New_List (
6595 Make_Integer_Literal (Loc, J)))));
6598 -- High_Bound : constant Base_Type (Index_Typ) := E'Last (J);
6600 High_Bound := Make_Temporary (Loc, 'B');
6602 Make_Object_Declaration (Loc,
6603 Defining_Identifier => High_Bound,
6604 Object_Definition =>
6605 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
6606 Constant_Present => True,
6608 Make_Attribute_Reference (Loc,
6609 Prefix => Duplicate_Subexpr_No_Checks (E),
6610 Attribute_Name => Name_Last,
6611 Expressions => New_List (
6612 Make_Integer_Literal (Loc, J)))));
6614 Append_To (List_Constr,
6616 Low_Bound => New_Occurrence_Of (Low_Bound, Loc),
6617 High_Bound => New_Occurrence_Of (High_Bound, Loc)));
6619 Index_Typ := Next_Index (Index_Typ);
6622 elsif Is_Class_Wide_Type (Unc_Typ) then
6624 CW_Subtype : Entity_Id;
6625 EQ_Typ : Entity_Id := Empty;
6628 -- A class-wide equivalent type is not needed on VM targets
6629 -- because the VM back-ends handle the class-wide object
6630 -- initialization itself (and doesn't need or want the
6631 -- additional intermediate type to handle the assignment).
6633 if Expander_Active and then Tagged_Type_Expansion then
6635 -- If this is the class-wide type of a completion that is a
6636 -- record subtype, set the type of the class-wide type to be
6637 -- the full base type, for use in the expanded code for the
6638 -- equivalent type. Should this be done earlier when the
6639 -- completion is analyzed ???
6641 if Is_Private_Type (Etype (Unc_Typ))
6643 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
6645 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
6648 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
6651 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
6652 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
6653 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
6655 return New_Occurrence_Of (CW_Subtype, Loc);
6658 -- Indefinite record type with discriminants
6661 D := First_Discriminant (Unc_Typ);
6662 while Present (D) loop
6663 Append_To (List_Constr,
6664 Make_Selected_Component (Loc,
6665 Prefix => Duplicate_Subexpr_No_Checks (E),
6666 Selector_Name => New_Occurrence_Of (D, Loc)));
6668 Next_Discriminant (D);
6673 Make_Subtype_Indication (Loc,
6674 Subtype_Mark => New_Occurrence_Of (Unc_Typ, Loc),
6676 Make_Index_Or_Discriminant_Constraint (Loc,
6677 Constraints => List_Constr));
6678 end Make_Subtype_From_Expr;
6680 ----------------------------
6681 -- Matching_Standard_Type --
6682 ----------------------------
6684 function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is
6685 pragma Assert (Is_Scalar_Type (Typ));
6686 Siz : constant Uint := Esize (Typ);
6689 -- Floating-point cases
6691 if Is_Floating_Point_Type (Typ) then
6692 if Siz <= Esize (Standard_Short_Float) then
6693 return Standard_Short_Float;
6694 elsif Siz <= Esize (Standard_Float) then
6695 return Standard_Float;
6696 elsif Siz <= Esize (Standard_Long_Float) then
6697 return Standard_Long_Float;
6698 elsif Siz <= Esize (Standard_Long_Long_Float) then
6699 return Standard_Long_Long_Float;
6701 raise Program_Error;
6704 -- Integer cases (includes fixed-point types)
6706 -- Unsigned integer cases (includes normal enumeration types)
6708 elsif Is_Unsigned_Type (Typ) then
6709 if Siz <= Esize (Standard_Short_Short_Unsigned) then
6710 return Standard_Short_Short_Unsigned;
6711 elsif Siz <= Esize (Standard_Short_Unsigned) then
6712 return Standard_Short_Unsigned;
6713 elsif Siz <= Esize (Standard_Unsigned) then
6714 return Standard_Unsigned;
6715 elsif Siz <= Esize (Standard_Long_Unsigned) then
6716 return Standard_Long_Unsigned;
6717 elsif Siz <= Esize (Standard_Long_Long_Unsigned) then
6718 return Standard_Long_Long_Unsigned;
6720 raise Program_Error;
6723 -- Signed integer cases
6726 if Siz <= Esize (Standard_Short_Short_Integer) then
6727 return Standard_Short_Short_Integer;
6728 elsif Siz <= Esize (Standard_Short_Integer) then
6729 return Standard_Short_Integer;
6730 elsif Siz <= Esize (Standard_Integer) then
6731 return Standard_Integer;
6732 elsif Siz <= Esize (Standard_Long_Integer) then
6733 return Standard_Long_Integer;
6734 elsif Siz <= Esize (Standard_Long_Long_Integer) then
6735 return Standard_Long_Long_Integer;
6737 raise Program_Error;
6740 end Matching_Standard_Type;
6742 -----------------------------
6743 -- May_Generate_Large_Temp --
6744 -----------------------------
6746 -- At the current time, the only types that we return False for (i.e. where
6747 -- we decide we know they cannot generate large temps) are ones where we
6748 -- know the size is 256 bits or less at compile time, and we are still not
6749 -- doing a thorough job on arrays and records ???
6751 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
6753 if not Size_Known_At_Compile_Time (Typ) then
6756 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
6759 elsif Is_Array_Type (Typ)
6760 and then Present (Packed_Array_Impl_Type (Typ))
6762 return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ));
6764 -- We could do more here to find other small types ???
6769 end May_Generate_Large_Temp;
6771 ------------------------
6772 -- Needs_Finalization --
6773 ------------------------
6775 function Needs_Finalization (T : Entity_Id) return Boolean is
6776 function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
6777 -- If type is not frozen yet, check explicitly among its components,
6778 -- because the Has_Controlled_Component flag is not necessarily set.
6780 -----------------------------------
6781 -- Has_Some_Controlled_Component --
6782 -----------------------------------
6784 function Has_Some_Controlled_Component
6785 (Rec : Entity_Id) return Boolean
6790 if Has_Controlled_Component (Rec) then
6793 elsif not Is_Frozen (Rec) then
6794 if Is_Record_Type (Rec) then
6795 Comp := First_Entity (Rec);
6797 while Present (Comp) loop
6798 if not Is_Type (Comp)
6799 and then Needs_Finalization (Etype (Comp))
6809 elsif Is_Array_Type (Rec) then
6810 return Needs_Finalization (Component_Type (Rec));
6813 return Has_Controlled_Component (Rec);
6818 end Has_Some_Controlled_Component;
6820 -- Start of processing for Needs_Finalization
6823 -- Certain run-time configurations and targets do not provide support
6824 -- for controlled types.
6826 if Restriction_Active (No_Finalization) then
6829 -- C++ types are not considered controlled. It is assumed that the
6830 -- non-Ada side will handle their clean up.
6832 elsif Convention (T) = Convention_CPP then
6835 -- Never needs finalization if Disable_Controlled set
6837 elsif Disable_Controlled (T) then
6841 -- Class-wide types are treated as controlled because derivations
6842 -- from the root type can introduce controlled components.
6844 return Is_Class_Wide_Type (T)
6845 or else Is_Controlled (T)
6846 or else Has_Controlled_Component (T)
6847 or else Has_Some_Controlled_Component (T)
6849 (Is_Concurrent_Type (T)
6850 and then Present (Corresponding_Record_Type (T))
6851 and then Needs_Finalization (Corresponding_Record_Type (T)));
6853 end Needs_Finalization;
6855 ----------------------------
6856 -- Needs_Constant_Address --
6857 ----------------------------
6859 function Needs_Constant_Address
6861 Typ : Entity_Id) return Boolean
6865 -- If we have no initialization of any kind, then we don't need to place
6866 -- any restrictions on the address clause, because the object will be
6867 -- elaborated after the address clause is evaluated. This happens if the
6868 -- declaration has no initial expression, or the type has no implicit
6869 -- initialization, or the object is imported.
6871 -- The same holds for all initialized scalar types and all access types.
6872 -- Packed bit arrays of size up to 64 are represented using a modular
6873 -- type with an initialization (to zero) and can be processed like other
6874 -- initialized scalar types.
6876 -- If the type is controlled, code to attach the object to a
6877 -- finalization chain is generated at the point of declaration, and
6878 -- therefore the elaboration of the object cannot be delayed: the
6879 -- address expression must be a constant.
6881 if No (Expression (Decl))
6882 and then not Needs_Finalization (Typ)
6884 (not Has_Non_Null_Base_Init_Proc (Typ)
6885 or else Is_Imported (Defining_Identifier (Decl)))
6889 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
6890 or else Is_Access_Type (Typ)
6892 (Is_Bit_Packed_Array (Typ)
6893 and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)))
6899 -- Otherwise, we require the address clause to be constant because
6900 -- the call to the initialization procedure (or the attach code) has
6901 -- to happen at the point of the declaration.
6903 -- Actually the IP call has been moved to the freeze actions anyway,
6904 -- so maybe we can relax this restriction???
6908 end Needs_Constant_Address;
6910 ----------------------------
6911 -- New_Class_Wide_Subtype --
6912 ----------------------------
6914 function New_Class_Wide_Subtype
6915 (CW_Typ : Entity_Id;
6916 N : Node_Id) return Entity_Id
6918 Res : constant Entity_Id := Create_Itype (E_Void, N);
6919 Res_Name : constant Name_Id := Chars (Res);
6920 Res_Scope : constant Entity_Id := Scope (Res);
6923 Copy_Node (CW_Typ, Res);
6924 Set_Comes_From_Source (Res, False);
6925 Set_Sloc (Res, Sloc (N));
6927 Set_Associated_Node_For_Itype (Res, N);
6928 Set_Is_Public (Res, False); -- By default, may be changed below.
6929 Set_Public_Status (Res);
6930 Set_Chars (Res, Res_Name);
6931 Set_Scope (Res, Res_Scope);
6932 Set_Ekind (Res, E_Class_Wide_Subtype);
6933 Set_Next_Entity (Res, Empty);
6934 Set_Etype (Res, Base_Type (CW_Typ));
6935 Set_Is_Frozen (Res, False);
6936 Set_Freeze_Node (Res, Empty);
6938 end New_Class_Wide_Subtype;
6940 --------------------------------
6941 -- Non_Limited_Designated_Type --
6942 ---------------------------------
6944 function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
6945 Desig : constant Entity_Id := Designated_Type (T);
6947 if Has_Non_Limited_View (Desig) then
6948 return Non_Limited_View (Desig);
6952 end Non_Limited_Designated_Type;
6954 -----------------------------------
6955 -- OK_To_Do_Constant_Replacement --
6956 -----------------------------------
6958 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
6959 ES : constant Entity_Id := Scope (E);
6963 -- Do not replace statically allocated objects, because they may be
6964 -- modified outside the current scope.
6966 if Is_Statically_Allocated (E) then
6969 -- Do not replace aliased or volatile objects, since we don't know what
6970 -- else might change the value.
6972 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
6975 -- Debug flag -gnatdM disconnects this optimization
6977 elsif Debug_Flag_MM then
6980 -- Otherwise check scopes
6983 CS := Current_Scope;
6986 -- If we are in right scope, replacement is safe
6991 -- Packages do not affect the determination of safety
6993 elsif Ekind (CS) = E_Package then
6994 exit when CS = Standard_Standard;
6997 -- Blocks do not affect the determination of safety
6999 elsif Ekind (CS) = E_Block then
7002 -- Loops do not affect the determination of safety. Note that we
7003 -- kill all current values on entry to a loop, so we are just
7004 -- talking about processing within a loop here.
7006 elsif Ekind (CS) = E_Loop then
7009 -- Otherwise, the reference is dubious, and we cannot be sure that
7010 -- it is safe to do the replacement.
7019 end OK_To_Do_Constant_Replacement;
7021 ------------------------------------
7022 -- Possible_Bit_Aligned_Component --
7023 ------------------------------------
7025 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
7027 -- Do not process an unanalyzed node because it is not yet decorated and
7028 -- most checks performed below will fail.
7030 if not Analyzed (N) then
7036 -- Case of indexed component
7038 when N_Indexed_Component =>
7040 P : constant Node_Id := Prefix (N);
7041 Ptyp : constant Entity_Id := Etype (P);
7044 -- If we know the component size and it is less than 64, then
7045 -- we are definitely OK. The back end always does assignment of
7046 -- misaligned small objects correctly.
7048 if Known_Static_Component_Size (Ptyp)
7049 and then Component_Size (Ptyp) <= 64
7053 -- Otherwise, we need to test the prefix, to see if we are
7054 -- indexing from a possibly unaligned component.
7057 return Possible_Bit_Aligned_Component (P);
7061 -- Case of selected component
7063 when N_Selected_Component =>
7065 P : constant Node_Id := Prefix (N);
7066 Comp : constant Entity_Id := Entity (Selector_Name (N));
7069 -- If there is no component clause, then we are in the clear
7070 -- since the back end will never misalign a large component
7071 -- unless it is forced to do so. In the clear means we need
7072 -- only the recursive test on the prefix.
7074 if Component_May_Be_Bit_Aligned (Comp) then
7077 return Possible_Bit_Aligned_Component (P);
7081 -- For a slice, test the prefix, if that is possibly misaligned,
7082 -- then for sure the slice is.
7085 return Possible_Bit_Aligned_Component (Prefix (N));
7087 -- For an unchecked conversion, check whether the expression may
7090 when N_Unchecked_Type_Conversion =>
7091 return Possible_Bit_Aligned_Component (Expression (N));
7093 -- If we have none of the above, it means that we have fallen off the
7094 -- top testing prefixes recursively, and we now have a stand alone
7095 -- object, where we don't have a problem, unless this is a renaming,
7096 -- in which case we need to look into the renamed object.
7099 if Is_Entity_Name (N)
7100 and then Present (Renamed_Object (Entity (N)))
7103 Possible_Bit_Aligned_Component (Renamed_Object (Entity (N)));
7109 end Possible_Bit_Aligned_Component;
7111 -----------------------------------------------
7112 -- Process_Statements_For_Controlled_Objects --
7113 -----------------------------------------------
7115 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
7116 Loc : constant Source_Ptr := Sloc (N);
7118 function Are_Wrapped (L : List_Id) return Boolean;
7119 -- Determine whether list L contains only one statement which is a block
7121 function Wrap_Statements_In_Block
7123 Scop : Entity_Id := Current_Scope) return Node_Id;
7124 -- Given a list of statements L, wrap it in a block statement and return
7125 -- the generated node. Scop is either the current scope or the scope of
7126 -- the context (if applicable).
7132 function Are_Wrapped (L : List_Id) return Boolean is
7133 Stmt : constant Node_Id := First (L);
7137 and then No (Next (Stmt))
7138 and then Nkind (Stmt) = N_Block_Statement;
7141 ------------------------------
7142 -- Wrap_Statements_In_Block --
7143 ------------------------------
7145 function Wrap_Statements_In_Block
7147 Scop : Entity_Id := Current_Scope) return Node_Id
7149 Block_Id : Entity_Id;
7150 Block_Nod : Node_Id;
7151 Iter_Loop : Entity_Id;
7155 Make_Block_Statement (Loc,
7156 Declarations => No_List,
7157 Handled_Statement_Sequence =>
7158 Make_Handled_Sequence_Of_Statements (Loc,
7161 -- Create a label for the block in case the block needs to manage the
7162 -- secondary stack. A label allows for flag Uses_Sec_Stack to be set.
7164 Add_Block_Identifier (Block_Nod, Block_Id);
7166 -- When wrapping the statements of an iterator loop, check whether
7167 -- the loop requires secondary stack management and if so, propagate
7168 -- the appropriate flags to the block. This ensures that the cursor
7169 -- is properly cleaned up at each iteration of the loop.
7171 Iter_Loop := Find_Enclosing_Iterator_Loop (Scop);
7173 if Present (Iter_Loop) then
7174 Set_Uses_Sec_Stack (Block_Id, Uses_Sec_Stack (Iter_Loop));
7176 -- Secondary stack reclamation is suppressed when the associated
7177 -- iterator loop contains a return statement which uses the stack.
7179 Set_Sec_Stack_Needed_For_Return
7180 (Block_Id, Sec_Stack_Needed_For_Return (Iter_Loop));
7184 end Wrap_Statements_In_Block;
7190 -- Start of processing for Process_Statements_For_Controlled_Objects
7193 -- Whenever a non-handled statement list is wrapped in a block, the
7194 -- block must be explicitly analyzed to redecorate all entities in the
7195 -- list and ensure that a finalizer is properly built.
7200 N_Conditional_Entry_Call |
7201 N_Selective_Accept =>
7203 -- Check the "then statements" for elsif parts and if statements
7205 if Nkind_In (N, N_Elsif_Part, N_If_Statement)
7206 and then not Is_Empty_List (Then_Statements (N))
7207 and then not Are_Wrapped (Then_Statements (N))
7208 and then Requires_Cleanup_Actions
7209 (Then_Statements (N), False, False)
7211 Block := Wrap_Statements_In_Block (Then_Statements (N));
7212 Set_Then_Statements (N, New_List (Block));
7217 -- Check the "else statements" for conditional entry calls, if
7218 -- statements and selective accepts.
7220 if Nkind_In (N, N_Conditional_Entry_Call,
7223 and then not Is_Empty_List (Else_Statements (N))
7224 and then not Are_Wrapped (Else_Statements (N))
7225 and then Requires_Cleanup_Actions
7226 (Else_Statements (N), False, False)
7228 Block := Wrap_Statements_In_Block (Else_Statements (N));
7229 Set_Else_Statements (N, New_List (Block));
7234 when N_Abortable_Part |
7235 N_Accept_Alternative |
7236 N_Case_Statement_Alternative |
7237 N_Delay_Alternative |
7238 N_Entry_Call_Alternative |
7239 N_Exception_Handler |
7241 N_Triggering_Alternative =>
7243 if not Is_Empty_List (Statements (N))
7244 and then not Are_Wrapped (Statements (N))
7245 and then Requires_Cleanup_Actions (Statements (N), False, False)
7247 if Nkind (N) = N_Loop_Statement
7248 and then Present (Identifier (N))
7251 Wrap_Statements_In_Block
7252 (L => Statements (N),
7253 Scop => Entity (Identifier (N)));
7255 Block := Wrap_Statements_In_Block (Statements (N));
7258 Set_Statements (N, New_List (Block));
7265 end Process_Statements_For_Controlled_Objects;
7271 function Power_Of_Two (N : Node_Id) return Nat is
7272 Typ : constant Entity_Id := Etype (N);
7273 pragma Assert (Is_Integer_Type (Typ));
7275 Siz : constant Nat := UI_To_Int (Esize (Typ));
7279 if not Compile_Time_Known_Value (N) then
7283 Val := Expr_Value (N);
7284 for J in 1 .. Siz - 1 loop
7285 if Val = Uint_2 ** J then
7294 ----------------------
7295 -- Remove_Init_Call --
7296 ----------------------
7298 function Remove_Init_Call
7300 Rep_Clause : Node_Id) return Node_Id
7302 Par : constant Node_Id := Parent (Var);
7303 Typ : constant Entity_Id := Etype (Var);
7305 Init_Proc : Entity_Id;
7306 -- Initialization procedure for Typ
7308 function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
7309 -- Look for init call for Var starting at From and scanning the
7310 -- enclosing list until Rep_Clause or the end of the list is reached.
7312 ----------------------------
7313 -- Find_Init_Call_In_List --
7314 ----------------------------
7316 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
7317 Init_Call : Node_Id;
7321 while Present (Init_Call) and then Init_Call /= Rep_Clause loop
7322 if Nkind (Init_Call) = N_Procedure_Call_Statement
7323 and then Is_Entity_Name (Name (Init_Call))
7324 and then Entity (Name (Init_Call)) = Init_Proc
7333 end Find_Init_Call_In_List;
7335 Init_Call : Node_Id;
7337 -- Start of processing for Find_Init_Call
7340 if Present (Initialization_Statements (Var)) then
7341 Init_Call := Initialization_Statements (Var);
7342 Set_Initialization_Statements (Var, Empty);
7344 elsif not Has_Non_Null_Base_Init_Proc (Typ) then
7346 -- No init proc for the type, so obviously no call to be found
7351 -- We might be able to handle other cases below by just properly
7352 -- setting Initialization_Statements at the point where the init proc
7353 -- call is generated???
7355 Init_Proc := Base_Init_Proc (Typ);
7357 -- First scan the list containing the declaration of Var
7359 Init_Call := Find_Init_Call_In_List (From => Next (Par));
7361 -- If not found, also look on Var's freeze actions list, if any,
7362 -- since the init call may have been moved there (case of an address
7363 -- clause applying to Var).
7365 if No (Init_Call) and then Present (Freeze_Node (Var)) then
7367 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
7370 -- If the initialization call has actuals that use the secondary
7371 -- stack, the call may have been wrapped into a temporary block, in
7372 -- which case the block itself has to be removed.
7374 if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then
7376 Blk : constant Node_Id := Next (Par);
7379 (Find_Init_Call_In_List
7380 (First (Statements (Handled_Statement_Sequence (Blk)))))
7388 if Present (Init_Call) then
7392 end Remove_Init_Call;
7394 -------------------------
7395 -- Remove_Side_Effects --
7396 -------------------------
7398 procedure Remove_Side_Effects
7400 Name_Req : Boolean := False;
7401 Renaming_Req : Boolean := False;
7402 Variable_Ref : Boolean := False;
7403 Related_Id : Entity_Id := Empty;
7404 Is_Low_Bound : Boolean := False;
7405 Is_High_Bound : Boolean := False)
7407 function Build_Temporary
7410 Related_Nod : Node_Id := Empty) return Entity_Id;
7411 -- Create an external symbol of the form xxx_FIRST/_LAST if Related_Nod
7412 -- is present (xxx is taken from the Chars field of Related_Nod),
7413 -- otherwise it generates an internal temporary.
7415 function Is_Name_Reference (N : Node_Id) return Boolean;
7416 -- Determine if the tree referenced by N represents a name. This is
7417 -- similar to Is_Object_Reference but returns true only if N can be
7418 -- renamed without the need for a temporary, the typical example of
7419 -- an object not in this category being a function call.
7421 ---------------------
7422 -- Build_Temporary --
7423 ---------------------
7425 function Build_Temporary
7428 Related_Nod : Node_Id := Empty) return Entity_Id
7433 -- The context requires an external symbol
7435 if Present (Related_Id) then
7436 if Is_Low_Bound then
7437 Temp_Nam := New_External_Name (Chars (Related_Id), "_FIRST");
7438 else pragma Assert (Is_High_Bound);
7439 Temp_Nam := New_External_Name (Chars (Related_Id), "_LAST");
7442 return Make_Defining_Identifier (Loc, Temp_Nam);
7444 -- Otherwise generate an internal temporary
7447 return Make_Temporary (Loc, Id, Related_Nod);
7449 end Build_Temporary;
7451 -----------------------
7452 -- Is_Name_Reference --
7453 -----------------------
7455 function Is_Name_Reference (N : Node_Id) return Boolean is
7457 if Is_Entity_Name (N) then
7458 return Present (Entity (N)) and then Is_Object (Entity (N));
7462 when N_Indexed_Component | N_Slice =>
7464 Is_Name_Reference (Prefix (N))
7465 or else Is_Access_Type (Etype (Prefix (N)));
7467 -- Attributes 'Input, 'Old and 'Result produce objects
7469 when N_Attribute_Reference =>
7472 (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
7474 when N_Selected_Component =>
7476 Is_Name_Reference (Selector_Name (N))
7478 (Is_Name_Reference (Prefix (N))
7479 or else Is_Access_Type (Etype (Prefix (N))));
7481 when N_Explicit_Dereference =>
7484 -- A view conversion of a tagged name is a name reference
7486 when N_Type_Conversion =>
7487 return Is_Tagged_Type (Etype (Subtype_Mark (N)))
7488 and then Is_Tagged_Type (Etype (Expression (N)))
7489 and then Is_Name_Reference (Expression (N));
7491 -- An unchecked type conversion is considered to be a name if
7492 -- the operand is a name (this construction arises only as a
7493 -- result of expansion activities).
7495 when N_Unchecked_Type_Conversion =>
7496 return Is_Name_Reference (Expression (N));
7501 end Is_Name_Reference;
7505 Loc : constant Source_Ptr := Sloc (Exp);
7506 Exp_Type : constant Entity_Id := Etype (Exp);
7507 Svg_Suppress : constant Suppress_Record := Scope_Suppress;
7511 Ptr_Typ_Decl : Node_Id;
7512 Ref_Type : Entity_Id;
7515 -- Start of processing for Remove_Side_Effects
7518 -- Handle cases in which there is nothing to do. In GNATprove mode,
7519 -- removal of side effects is useful for the light expansion of
7520 -- renamings. This removal should only occur when not inside a
7521 -- generic and not doing a pre-analysis.
7523 if not Expander_Active
7524 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
7529 -- Cannot generate temporaries if the invocation to remove side effects
7530 -- was issued too early and the type of the expression is not resolved
7531 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
7532 -- Remove_Side_Effects).
7534 if No (Exp_Type) or else Ekind (Exp_Type) = E_Access_Attribute_Type then
7537 -- No action needed for side-effect free expressions
7539 elsif Side_Effect_Free (Exp, Name_Req, Variable_Ref) then
7543 -- The remaining processing is done with all checks suppressed
7545 -- Note: from now on, don't use return statements, instead do a goto
7546 -- Leave, to ensure that we properly restore Scope_Suppress.Suppress.
7548 Scope_Suppress.Suppress := (others => True);
7550 -- If it is an elementary type and we need to capture the value, just
7551 -- make a constant. Likewise if this is not a name reference, except
7552 -- for a type conversion because we would enter an infinite recursion
7553 -- with Checks.Apply_Predicate_Check if the target type has predicates.
7554 -- And type conversions need a specific treatment anyway, see below.
7555 -- Also do it if we have a volatile reference and Name_Req is not set
7556 -- (see comments for Side_Effect_Free).
7558 if Is_Elementary_Type (Exp_Type)
7559 and then (Variable_Ref
7560 or else (not Is_Name_Reference (Exp)
7561 and then Nkind (Exp) /= N_Type_Conversion)
7562 or else (not Name_Req
7563 and then Is_Volatile_Reference (Exp)))
7565 Def_Id := Build_Temporary (Loc, 'R', Exp);
7566 Set_Etype (Def_Id, Exp_Type);
7567 Res := New_Occurrence_Of (Def_Id, Loc);
7569 -- If the expression is a packed reference, it must be reanalyzed and
7570 -- expanded, depending on context. This is the case for actuals where
7571 -- a constraint check may capture the actual before expansion of the
7572 -- call is complete.
7574 if Nkind (Exp) = N_Indexed_Component
7575 and then Is_Packed (Etype (Prefix (Exp)))
7577 Set_Analyzed (Exp, False);
7578 Set_Analyzed (Prefix (Exp), False);
7582 -- Rnn : Exp_Type renames Expr;
7584 if Renaming_Req then
7586 Make_Object_Renaming_Declaration (Loc,
7587 Defining_Identifier => Def_Id,
7588 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
7589 Name => Relocate_Node (Exp));
7592 -- Rnn : constant Exp_Type := Expr;
7596 Make_Object_Declaration (Loc,
7597 Defining_Identifier => Def_Id,
7598 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
7599 Constant_Present => True,
7600 Expression => Relocate_Node (Exp));
7602 Set_Assignment_OK (E);
7605 Insert_Action (Exp, E);
7607 -- If the expression has the form v.all then we can just capture the
7608 -- pointer, and then do an explicit dereference on the result, but
7609 -- this is not right if this is a volatile reference.
7611 elsif Nkind (Exp) = N_Explicit_Dereference
7612 and then not Is_Volatile_Reference (Exp)
7614 Def_Id := Build_Temporary (Loc, 'R', Exp);
7616 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Def_Id, Loc));
7619 Make_Object_Declaration (Loc,
7620 Defining_Identifier => Def_Id,
7621 Object_Definition =>
7622 New_Occurrence_Of (Etype (Prefix (Exp)), Loc),
7623 Constant_Present => True,
7624 Expression => Relocate_Node (Prefix (Exp))));
7626 -- Similar processing for an unchecked conversion of an expression of
7627 -- the form v.all, where we want the same kind of treatment.
7629 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
7630 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
7632 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
7635 -- If this is a type conversion, leave the type conversion and remove
7636 -- the side effects in the expression. This is important in several
7637 -- circumstances: for change of representations, and also when this is a
7638 -- view conversion to a smaller object, where gigi can end up creating
7639 -- its own temporary of the wrong size.
7641 elsif Nkind (Exp) = N_Type_Conversion then
7642 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
7645 -- If this is an unchecked conversion that Gigi can't handle, make
7646 -- a copy or a use a renaming to capture the value.
7648 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
7649 and then not Safe_Unchecked_Type_Conversion (Exp)
7651 if CW_Or_Has_Controlled_Part (Exp_Type) then
7653 -- Use a renaming to capture the expression, rather than create
7654 -- a controlled temporary.
7656 Def_Id := Build_Temporary (Loc, 'R', Exp);
7657 Res := New_Occurrence_Of (Def_Id, Loc);
7660 Make_Object_Renaming_Declaration (Loc,
7661 Defining_Identifier => Def_Id,
7662 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
7663 Name => Relocate_Node (Exp)));
7666 Def_Id := Build_Temporary (Loc, 'R', Exp);
7667 Set_Etype (Def_Id, Exp_Type);
7668 Res := New_Occurrence_Of (Def_Id, Loc);
7671 Make_Object_Declaration (Loc,
7672 Defining_Identifier => Def_Id,
7673 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
7674 Constant_Present => not Is_Variable (Exp),
7675 Expression => Relocate_Node (Exp));
7677 Set_Assignment_OK (E);
7678 Insert_Action (Exp, E);
7681 -- For expressions that denote names, we can use a renaming scheme.
7682 -- This is needed for correctness in the case of a volatile object of
7683 -- a non-volatile type because the Make_Reference call of the "default"
7684 -- approach would generate an illegal access value (an access value
7685 -- cannot designate such an object - see Analyze_Reference).
7687 elsif Is_Name_Reference (Exp)
7689 -- We skip using this scheme if we have an object of a volatile
7690 -- type and we do not have Name_Req set true (see comments for
7691 -- Side_Effect_Free).
7693 and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
7695 Def_Id := Build_Temporary (Loc, 'R', Exp);
7696 Res := New_Occurrence_Of (Def_Id, Loc);
7699 Make_Object_Renaming_Declaration (Loc,
7700 Defining_Identifier => Def_Id,
7701 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
7702 Name => Relocate_Node (Exp)));
7704 -- If this is a packed reference, or a selected component with
7705 -- a non-standard representation, a reference to the temporary
7706 -- will be replaced by a copy of the original expression (see
7707 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
7708 -- elaborated by gigi, and is of course not to be replaced in-line
7709 -- by the expression it renames, which would defeat the purpose of
7710 -- removing the side-effect.
7712 if Nkind_In (Exp, N_Selected_Component, N_Indexed_Component)
7713 and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
7717 Set_Is_Renaming_Of_Object (Def_Id, False);
7720 -- Avoid generating a variable-sized temporary, by generating the
7721 -- reference just for the function call. The transformation could be
7722 -- refined to apply only when the array component is constrained by a
7725 elsif Nkind (Exp) = N_Selected_Component
7726 and then Nkind (Prefix (Exp)) = N_Function_Call
7727 and then Is_Array_Type (Exp_Type)
7729 Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
7732 -- Otherwise we generate a reference to the expression
7735 -- An expression which is in SPARK mode is considered side effect
7736 -- free if the resulting value is captured by a variable or a
7740 and then Nkind (Parent (Exp)) = N_Object_Declaration
7745 -- Special processing for function calls that return a limited type.
7746 -- We need to build a declaration that will enable build-in-place
7747 -- expansion of the call. This is not done if the context is already
7748 -- an object declaration, to prevent infinite recursion.
7750 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
7751 -- to accommodate functions returning limited objects by reference.
7753 if Ada_Version >= Ada_2005
7754 and then Nkind (Exp) = N_Function_Call
7755 and then Is_Limited_View (Etype (Exp))
7756 and then Nkind (Parent (Exp)) /= N_Object_Declaration
7759 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
7764 Make_Object_Declaration (Loc,
7765 Defining_Identifier => Obj,
7766 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
7767 Expression => Relocate_Node (Exp));
7769 Insert_Action (Exp, Decl);
7770 Set_Etype (Obj, Exp_Type);
7771 Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
7776 Def_Id := Build_Temporary (Loc, 'R', Exp);
7778 -- The regular expansion of functions with side effects involves the
7779 -- generation of an access type to capture the return value found on
7780 -- the secondary stack. Since SPARK (and why) cannot process access
7781 -- types, use a different approach which ignores the secondary stack
7782 -- and "copies" the returned object.
7784 if GNATprove_Mode then
7785 Res := New_Occurrence_Of (Def_Id, Loc);
7786 Ref_Type := Exp_Type;
7788 -- Regular expansion utilizing an access type and 'reference
7792 Make_Explicit_Dereference (Loc,
7793 Prefix => New_Occurrence_Of (Def_Id, Loc));
7796 -- type Ann is access all <Exp_Type>;
7798 Ref_Type := Make_Temporary (Loc, 'A');
7801 Make_Full_Type_Declaration (Loc,
7802 Defining_Identifier => Ref_Type,
7804 Make_Access_To_Object_Definition (Loc,
7805 All_Present => True,
7806 Subtype_Indication =>
7807 New_Occurrence_Of (Exp_Type, Loc)));
7809 Insert_Action (Exp, Ptr_Typ_Decl);
7813 if Nkind (E) = N_Explicit_Dereference then
7814 New_Exp := Relocate_Node (Prefix (E));
7817 E := Relocate_Node (E);
7819 -- Do not generate a 'reference in SPARK mode since the access
7820 -- type is not created in the first place.
7822 if GNATprove_Mode then
7825 -- Otherwise generate reference, marking the value as non-null
7826 -- since we know it cannot be null and we don't want a check.
7829 New_Exp := Make_Reference (Loc, E);
7830 Set_Is_Known_Non_Null (Def_Id);
7834 if Is_Delayed_Aggregate (E) then
7836 -- The expansion of nested aggregates is delayed until the
7837 -- enclosing aggregate is expanded. As aggregates are often
7838 -- qualified, the predicate applies to qualified expressions as
7839 -- well, indicating that the enclosing aggregate has not been
7840 -- expanded yet. At this point the aggregate is part of a
7841 -- stand-alone declaration, and must be fully expanded.
7843 if Nkind (E) = N_Qualified_Expression then
7844 Set_Expansion_Delayed (Expression (E), False);
7845 Set_Analyzed (Expression (E), False);
7847 Set_Expansion_Delayed (E, False);
7850 Set_Analyzed (E, False);
7854 Make_Object_Declaration (Loc,
7855 Defining_Identifier => Def_Id,
7856 Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
7857 Constant_Present => True,
7858 Expression => New_Exp));
7861 -- Preserve the Assignment_OK flag in all copies, since at least one
7862 -- copy may be used in a context where this flag must be set (otherwise
7863 -- why would the flag be set in the first place).
7865 Set_Assignment_OK (Res, Assignment_OK (Exp));
7867 -- Finally rewrite the original expression and we are done
7870 Analyze_And_Resolve (Exp, Exp_Type);
7873 Scope_Suppress := Svg_Suppress;
7874 end Remove_Side_Effects;
7876 ---------------------------
7877 -- Represented_As_Scalar --
7878 ---------------------------
7880 function Represented_As_Scalar (T : Entity_Id) return Boolean is
7881 UT : constant Entity_Id := Underlying_Type (T);
7883 return Is_Scalar_Type (UT)
7884 or else (Is_Bit_Packed_Array (UT)
7885 and then Is_Scalar_Type (Packed_Array_Impl_Type (UT)));
7886 end Represented_As_Scalar;
7888 ------------------------------
7889 -- Requires_Cleanup_Actions --
7890 ------------------------------
7892 function Requires_Cleanup_Actions
7894 Lib_Level : Boolean) return Boolean
7896 At_Lib_Level : constant Boolean :=
7898 and then Nkind_In (N, N_Package_Body,
7899 N_Package_Specification);
7900 -- N is at the library level if the top-most context is a package and
7901 -- the path taken to reach N does not inlcude non-package constructs.
7905 when N_Accept_Statement |
7913 Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True)
7915 (Present (Handled_Statement_Sequence (N))
7917 Requires_Cleanup_Actions
7918 (Statements (Handled_Statement_Sequence (N)),
7919 At_Lib_Level, True));
7921 when N_Package_Specification =>
7923 Requires_Cleanup_Actions
7924 (Visible_Declarations (N), At_Lib_Level, True)
7926 Requires_Cleanup_Actions
7927 (Private_Declarations (N), At_Lib_Level, True);
7932 end Requires_Cleanup_Actions;
7934 ------------------------------
7935 -- Requires_Cleanup_Actions --
7936 ------------------------------
7938 function Requires_Cleanup_Actions
7940 Lib_Level : Boolean;
7941 Nested_Constructs : Boolean) return Boolean
7946 Obj_Typ : Entity_Id;
7947 Pack_Id : Entity_Id;
7952 or else Is_Empty_List (L)
7958 while Present (Decl) loop
7960 -- Library-level tagged types
7962 if Nkind (Decl) = N_Full_Type_Declaration then
7963 Typ := Defining_Identifier (Decl);
7965 -- Ignored Ghost types do not need any cleanup actions because
7966 -- they will not appear in the final tree.
7968 if Is_Ignored_Ghost_Entity (Typ) then
7971 elsif Is_Tagged_Type (Typ)
7972 and then Is_Library_Level_Entity (Typ)
7973 and then Convention (Typ) = Convention_Ada
7974 and then Present (Access_Disp_Table (Typ))
7975 and then RTE_Available (RE_Unregister_Tag)
7976 and then not Is_Abstract_Type (Typ)
7977 and then not No_Run_Time_Mode
7982 -- Regular object declarations
7984 elsif Nkind (Decl) = N_Object_Declaration then
7985 Obj_Id := Defining_Identifier (Decl);
7986 Obj_Typ := Base_Type (Etype (Obj_Id));
7987 Expr := Expression (Decl);
7989 -- Bypass any form of processing for objects which have their
7990 -- finalization disabled. This applies only to objects at the
7993 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
7996 -- Transient variables are treated separately in order to minimize
7997 -- the size of the generated code. See Exp_Ch7.Process_Transient_
8000 elsif Is_Processed_Transient (Obj_Id) then
8003 -- Ignored Ghost objects do not need any cleanup actions because
8004 -- they will not appear in the final tree.
8006 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
8009 -- The object is of the form:
8010 -- Obj : Typ [:= Expr];
8012 -- Do not process the incomplete view of a deferred constant. Do
8013 -- not consider tag-to-class-wide conversions.
8015 elsif not Is_Imported (Obj_Id)
8016 and then Needs_Finalization (Obj_Typ)
8017 and then not (Ekind (Obj_Id) = E_Constant
8018 and then not Has_Completion (Obj_Id))
8019 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
8023 -- The object is of the form:
8024 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
8026 -- Obj : Access_Typ :=
8027 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
8029 elsif Is_Access_Type (Obj_Typ)
8030 and then Needs_Finalization
8031 (Available_View (Designated_Type (Obj_Typ)))
8032 and then Present (Expr)
8034 (Is_Secondary_Stack_BIP_Func_Call (Expr)
8036 (Is_Non_BIP_Func_Call (Expr)
8037 and then not Is_Related_To_Func_Return (Obj_Id)))
8041 -- Processing for "hook" objects generated for controlled
8042 -- transients declared inside an Expression_With_Actions.
8044 elsif Is_Access_Type (Obj_Typ)
8045 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
8046 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
8047 N_Object_Declaration
8051 -- Processing for intermediate results of if expressions where
8052 -- one of the alternatives uses a controlled function call.
8054 elsif Is_Access_Type (Obj_Typ)
8055 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
8056 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
8057 N_Defining_Identifier
8058 and then Present (Expr)
8059 and then Nkind (Expr) = N_Null
8063 -- Simple protected objects which use type System.Tasking.
8064 -- Protected_Objects.Protection to manage their locks should be
8065 -- treated as controlled since they require manual cleanup.
8067 elsif Ekind (Obj_Id) = E_Variable
8068 and then (Is_Simple_Protected_Type (Obj_Typ)
8069 or else Has_Simple_Protected_Object (Obj_Typ))
8074 -- Specific cases of object renamings
8076 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
8077 Obj_Id := Defining_Identifier (Decl);
8078 Obj_Typ := Base_Type (Etype (Obj_Id));
8080 -- Bypass any form of processing for objects which have their
8081 -- finalization disabled. This applies only to objects at the
8084 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
8087 -- Ignored Ghost object renamings do not need any cleanup actions
8088 -- because they will not appear in the final tree.
8090 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
8093 -- Return object of a build-in-place function. This case is
8094 -- recognized and marked by the expansion of an extended return
8095 -- statement (see Expand_N_Extended_Return_Statement).
8097 elsif Needs_Finalization (Obj_Typ)
8098 and then Is_Return_Object (Obj_Id)
8099 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
8103 -- Detect a case where a source object has been initialized by
8104 -- a controlled function call or another object which was later
8105 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
8107 -- Obj1 : CW_Type := Src_Obj;
8108 -- Obj2 : CW_Type := Function_Call (...);
8110 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
8111 -- Tmp : ... := Function_Call (...)'reference;
8112 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
8114 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
8118 -- Inspect the freeze node of an access-to-controlled type and look
8119 -- for a delayed finalization master. This case arises when the
8120 -- freeze actions are inserted at a later time than the expansion of
8121 -- the context. Since Build_Finalizer is never called on a single
8122 -- construct twice, the master will be ultimately left out and never
8123 -- finalized. This is also needed for freeze actions of designated
8124 -- types themselves, since in some cases the finalization master is
8125 -- associated with a designated type's freeze node rather than that
8126 -- of the access type (see handling for freeze actions in
8127 -- Build_Finalization_Master).
8129 elsif Nkind (Decl) = N_Freeze_Entity
8130 and then Present (Actions (Decl))
8132 Typ := Entity (Decl);
8134 -- Freeze nodes for ignored Ghost types do not need cleanup
8135 -- actions because they will never appear in the final tree.
8137 if Is_Ignored_Ghost_Entity (Typ) then
8140 elsif ((Is_Access_Type (Typ)
8141 and then not Is_Access_Subprogram_Type (Typ)
8142 and then Needs_Finalization
8143 (Available_View (Designated_Type (Typ))))
8144 or else (Is_Type (Typ) and then Needs_Finalization (Typ)))
8145 and then Requires_Cleanup_Actions
8146 (Actions (Decl), Lib_Level, Nested_Constructs)
8151 -- Nested package declarations
8153 elsif Nested_Constructs
8154 and then Nkind (Decl) = N_Package_Declaration
8156 Pack_Id := Defining_Entity (Decl);
8158 -- Do not inspect an ignored Ghost package because all code found
8159 -- within will not appear in the final tree.
8161 if Is_Ignored_Ghost_Entity (Pack_Id) then
8164 elsif Ekind (Pack_Id) /= E_Generic_Package
8165 and then Requires_Cleanup_Actions
8166 (Specification (Decl), Lib_Level)
8171 -- Nested package bodies
8173 elsif Nested_Constructs and then Nkind (Decl) = N_Package_Body then
8175 -- Do not inspect an ignored Ghost package body because all code
8176 -- found within will not appear in the final tree.
8178 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
8181 elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
8182 and then Requires_Cleanup_Actions (Decl, Lib_Level)
8187 elsif Nkind (Decl) = N_Block_Statement
8190 -- Handle a rare case caused by a controlled transient variable
8191 -- created as part of a record init proc. The variable is wrapped
8192 -- in a block, but the block is not associated with a transient
8197 -- Handle the case where the original context has been wrapped in
8198 -- a block to avoid interference between exception handlers and
8199 -- At_End handlers. Treat the block as transparent and process its
8202 or else Is_Finalization_Wrapper (Decl))
8204 if Requires_Cleanup_Actions (Decl, Lib_Level) then
8213 end Requires_Cleanup_Actions;
8215 ------------------------------------
8216 -- Safe_Unchecked_Type_Conversion --
8217 ------------------------------------
8219 -- Note: this function knows quite a bit about the exact requirements of
8220 -- Gigi with respect to unchecked type conversions, and its code must be
8221 -- coordinated with any changes in Gigi in this area.
8223 -- The above requirements should be documented in Sinfo ???
8225 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
8230 Pexp : constant Node_Id := Parent (Exp);
8233 -- If the expression is the RHS of an assignment or object declaration
8234 -- we are always OK because there will always be a target.
8236 -- Object renaming declarations, (generated for view conversions of
8237 -- actuals in inlined calls), like object declarations, provide an
8238 -- explicit type, and are safe as well.
8240 if (Nkind (Pexp) = N_Assignment_Statement
8241 and then Expression (Pexp) = Exp)
8242 or else Nkind_In (Pexp, N_Object_Declaration,
8243 N_Object_Renaming_Declaration)
8247 -- If the expression is the prefix of an N_Selected_Component we should
8248 -- also be OK because GCC knows to look inside the conversion except if
8249 -- the type is discriminated. We assume that we are OK anyway if the
8250 -- type is not set yet or if it is controlled since we can't afford to
8251 -- introduce a temporary in this case.
8253 elsif Nkind (Pexp) = N_Selected_Component
8254 and then Prefix (Pexp) = Exp
8256 if No (Etype (Pexp)) then
8260 not Has_Discriminants (Etype (Pexp))
8261 or else Is_Constrained (Etype (Pexp));
8265 -- Set the output type, this comes from Etype if it is set, otherwise we
8266 -- take it from the subtype mark, which we assume was already fully
8269 if Present (Etype (Exp)) then
8270 Otyp := Etype (Exp);
8272 Otyp := Entity (Subtype_Mark (Exp));
8275 -- The input type always comes from the expression, and we assume this
8276 -- is indeed always analyzed, so we can simply get the Etype.
8278 Ityp := Etype (Expression (Exp));
8280 -- Initialize alignments to unknown so far
8285 -- Replace a concurrent type by its corresponding record type and each
8286 -- type by its underlying type and do the tests on those. The original
8287 -- type may be a private type whose completion is a concurrent type, so
8288 -- find the underlying type first.
8290 if Present (Underlying_Type (Otyp)) then
8291 Otyp := Underlying_Type (Otyp);
8294 if Present (Underlying_Type (Ityp)) then
8295 Ityp := Underlying_Type (Ityp);
8298 if Is_Concurrent_Type (Otyp) then
8299 Otyp := Corresponding_Record_Type (Otyp);
8302 if Is_Concurrent_Type (Ityp) then
8303 Ityp := Corresponding_Record_Type (Ityp);
8306 -- If the base types are the same, we know there is no problem since
8307 -- this conversion will be a noop.
8309 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
8312 -- Same if this is an upwards conversion of an untagged type, and there
8313 -- are no constraints involved (could be more general???)
8315 elsif Etype (Ityp) = Otyp
8316 and then not Is_Tagged_Type (Ityp)
8317 and then not Has_Discriminants (Ityp)
8318 and then No (First_Rep_Item (Base_Type (Ityp)))
8322 -- If the expression has an access type (object or subprogram) we assume
8323 -- that the conversion is safe, because the size of the target is safe,
8324 -- even if it is a record (which might be treated as having unknown size
8327 elsif Is_Access_Type (Ityp) then
8330 -- If the size of output type is known at compile time, there is never
8331 -- a problem. Note that unconstrained records are considered to be of
8332 -- known size, but we can't consider them that way here, because we are
8333 -- talking about the actual size of the object.
8335 -- We also make sure that in addition to the size being known, we do not
8336 -- have a case which might generate an embarrassingly large temp in
8337 -- stack checking mode.
8339 elsif Size_Known_At_Compile_Time (Otyp)
8341 (not Stack_Checking_Enabled
8342 or else not May_Generate_Large_Temp (Otyp))
8343 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
8347 -- If either type is tagged, then we know the alignment is OK so Gigi
8348 -- will be able to use pointer punning.
8350 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
8353 -- If either type is a limited record type, we cannot do a copy, so say
8354 -- safe since there's nothing else we can do.
8356 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
8359 -- Conversions to and from packed array types are always ignored and
8362 elsif Is_Packed_Array_Impl_Type (Otyp)
8363 or else Is_Packed_Array_Impl_Type (Ityp)
8368 -- The only other cases known to be safe is if the input type's
8369 -- alignment is known to be at least the maximum alignment for the
8370 -- target or if both alignments are known and the output type's
8371 -- alignment is no stricter than the input's. We can use the component
8372 -- type alignement for an array if a type is an unpacked array type.
8374 if Present (Alignment_Clause (Otyp)) then
8375 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
8377 elsif Is_Array_Type (Otyp)
8378 and then Present (Alignment_Clause (Component_Type (Otyp)))
8380 Oalign := Expr_Value (Expression (Alignment_Clause
8381 (Component_Type (Otyp))));
8384 if Present (Alignment_Clause (Ityp)) then
8385 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
8387 elsif Is_Array_Type (Ityp)
8388 and then Present (Alignment_Clause (Component_Type (Ityp)))
8390 Ialign := Expr_Value (Expression (Alignment_Clause
8391 (Component_Type (Ityp))));
8394 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
8397 elsif Ialign /= No_Uint
8398 and then Oalign /= No_Uint
8399 and then Ialign <= Oalign
8403 -- Otherwise, Gigi cannot handle this and we must make a temporary
8408 end Safe_Unchecked_Type_Conversion;
8410 ---------------------------------
8411 -- Set_Current_Value_Condition --
8412 ---------------------------------
8414 -- Note: the implementation of this procedure is very closely tied to the
8415 -- implementation of Get_Current_Value_Condition. Here we set required
8416 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
8417 -- them, so they must have a consistent view.
8419 procedure Set_Current_Value_Condition (Cnode : Node_Id) is
8421 procedure Set_Entity_Current_Value (N : Node_Id);
8422 -- If N is an entity reference, where the entity is of an appropriate
8423 -- kind, then set the current value of this entity to Cnode, unless
8424 -- there is already a definite value set there.
8426 procedure Set_Expression_Current_Value (N : Node_Id);
8427 -- If N is of an appropriate form, sets an appropriate entry in current
8428 -- value fields of relevant entities. Multiple entities can be affected
8429 -- in the case of an AND or AND THEN.
8431 ------------------------------
8432 -- Set_Entity_Current_Value --
8433 ------------------------------
8435 procedure Set_Entity_Current_Value (N : Node_Id) is
8437 if Is_Entity_Name (N) then
8439 Ent : constant Entity_Id := Entity (N);
8442 -- Don't capture if not safe to do so
8444 if not Safe_To_Capture_Value (N, Ent, Cond => True) then
8448 -- Here we have a case where the Current_Value field may need
8449 -- to be set. We set it if it is not already set to a compile
8450 -- time expression value.
8452 -- Note that this represents a decision that one condition
8453 -- blots out another previous one. That's certainly right if
8454 -- they occur at the same level. If the second one is nested,
8455 -- then the decision is neither right nor wrong (it would be
8456 -- equally OK to leave the outer one in place, or take the new
8457 -- inner one. Really we should record both, but our data
8458 -- structures are not that elaborate.
8460 if Nkind (Current_Value (Ent)) not in N_Subexpr then
8461 Set_Current_Value (Ent, Cnode);
8465 end Set_Entity_Current_Value;
8467 ----------------------------------
8468 -- Set_Expression_Current_Value --
8469 ----------------------------------
8471 procedure Set_Expression_Current_Value (N : Node_Id) is
8477 -- Loop to deal with (ignore for now) any NOT operators present. The
8478 -- presence of NOT operators will be handled properly when we call
8479 -- Get_Current_Value_Condition.
8481 while Nkind (Cond) = N_Op_Not loop
8482 Cond := Right_Opnd (Cond);
8485 -- For an AND or AND THEN, recursively process operands
8487 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
8488 Set_Expression_Current_Value (Left_Opnd (Cond));
8489 Set_Expression_Current_Value (Right_Opnd (Cond));
8493 -- Check possible relational operator
8495 if Nkind (Cond) in N_Op_Compare then
8496 if Compile_Time_Known_Value (Right_Opnd (Cond)) then
8497 Set_Entity_Current_Value (Left_Opnd (Cond));
8498 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
8499 Set_Entity_Current_Value (Right_Opnd (Cond));
8502 elsif Nkind_In (Cond,
8504 N_Qualified_Expression,
8505 N_Expression_With_Actions)
8507 Set_Expression_Current_Value (Expression (Cond));
8509 -- Check possible boolean variable reference
8512 Set_Entity_Current_Value (Cond);
8514 end Set_Expression_Current_Value;
8516 -- Start of processing for Set_Current_Value_Condition
8519 Set_Expression_Current_Value (Condition (Cnode));
8520 end Set_Current_Value_Condition;
8522 --------------------------
8523 -- Set_Elaboration_Flag --
8524 --------------------------
8526 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
8527 Loc : constant Source_Ptr := Sloc (N);
8528 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
8532 if Present (Ent) then
8534 -- Nothing to do if at the compilation unit level, because in this
8535 -- case the flag is set by the binder generated elaboration routine.
8537 if Nkind (Parent (N)) = N_Compilation_Unit then
8540 -- Here we do need to generate an assignment statement
8543 Check_Restriction (No_Elaboration_Code, N);
8545 Make_Assignment_Statement (Loc,
8546 Name => New_Occurrence_Of (Ent, Loc),
8547 Expression => Make_Integer_Literal (Loc, Uint_1));
8549 if Nkind (Parent (N)) = N_Subunit then
8550 Insert_After (Corresponding_Stub (Parent (N)), Asn);
8552 Insert_After (N, Asn);
8557 -- Kill current value indication. This is necessary because the
8558 -- tests of this flag are inserted out of sequence and must not
8559 -- pick up bogus indications of the wrong constant value.
8561 Set_Current_Value (Ent, Empty);
8563 -- If the subprogram is in the current declarative part and
8564 -- 'access has been applied to it, generate an elaboration
8565 -- check at the beginning of the declarations of the body.
8567 if Nkind (N) = N_Subprogram_Body
8568 and then Address_Taken (Spec_Id)
8570 Ekind_In (Scope (Spec_Id), E_Block, E_Procedure, E_Function)
8573 Loc : constant Source_Ptr := Sloc (N);
8574 Decls : constant List_Id := Declarations (N);
8578 -- No need to generate this check if first entry in the
8579 -- declaration list is a raise of Program_Error now.
8582 and then Nkind (First (Decls)) = N_Raise_Program_Error
8587 -- Otherwise generate the check
8590 Make_Raise_Program_Error (Loc,
8593 Left_Opnd => New_Occurrence_Of (Ent, Loc),
8594 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
8595 Reason => PE_Access_Before_Elaboration);
8598 Set_Declarations (N, New_List (Chk));
8600 Prepend (Chk, Decls);
8608 end Set_Elaboration_Flag;
8610 ----------------------------
8611 -- Set_Renamed_Subprogram --
8612 ----------------------------
8614 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
8616 -- If input node is an identifier, we can just reset it
8618 if Nkind (N) = N_Identifier then
8619 Set_Chars (N, Chars (E));
8622 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
8626 CS : constant Boolean := Comes_From_Source (N);
8628 Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
8630 Set_Comes_From_Source (N, CS);
8631 Set_Analyzed (N, True);
8634 end Set_Renamed_Subprogram;
8636 ----------------------
8637 -- Side_Effect_Free --
8638 ----------------------
8640 function Side_Effect_Free
8642 Name_Req : Boolean := False;
8643 Variable_Ref : Boolean := False) return Boolean
8645 Typ : constant Entity_Id := Etype (N);
8646 -- Result type of the expression
8648 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
8649 -- The argument N is a construct where the Prefix is dereferenced if it
8650 -- is an access type and the result is a variable. The call returns True
8651 -- if the construct is side effect free (not considering side effects in
8652 -- other than the prefix which are to be tested by the caller).
8654 function Within_In_Parameter (N : Node_Id) return Boolean;
8655 -- Determines if N is a subcomponent of a composite in-parameter. If so,
8656 -- N is not side-effect free when the actual is global and modifiable
8657 -- indirectly from within a subprogram, because it may be passed by
8658 -- reference. The front-end must be conservative here and assume that
8659 -- this may happen with any array or record type. On the other hand, we
8660 -- cannot create temporaries for all expressions for which this
8661 -- condition is true, for various reasons that might require clearing up
8662 -- ??? For example, discriminant references that appear out of place, or
8663 -- spurious type errors with class-wide expressions. As a result, we
8664 -- limit the transformation to loop bounds, which is so far the only
8665 -- case that requires it.
8667 -----------------------------
8668 -- Safe_Prefixed_Reference --
8669 -----------------------------
8671 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
8673 -- If prefix is not side effect free, definitely not safe
8675 if not Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref) then
8678 -- If the prefix is of an access type that is not access-to-constant,
8679 -- then this construct is a variable reference, which means it is to
8680 -- be considered to have side effects if Variable_Ref is set True.
8682 elsif Is_Access_Type (Etype (Prefix (N)))
8683 and then not Is_Access_Constant (Etype (Prefix (N)))
8684 and then Variable_Ref
8686 -- Exception is a prefix that is the result of a previous removal
8689 return Is_Entity_Name (Prefix (N))
8690 and then not Comes_From_Source (Prefix (N))
8691 and then Ekind (Entity (Prefix (N))) = E_Constant
8692 and then Is_Internal_Name (Chars (Entity (Prefix (N))));
8694 -- If the prefix is an explicit dereference then this construct is a
8695 -- variable reference, which means it is to be considered to have
8696 -- side effects if Variable_Ref is True.
8698 -- We do NOT exclude dereferences of access-to-constant types because
8699 -- we handle them as constant view of variables.
8701 elsif Nkind (Prefix (N)) = N_Explicit_Dereference
8702 and then Variable_Ref
8706 -- Note: The following test is the simplest way of solving a complex
8707 -- problem uncovered by the following test (Side effect on loop bound
8708 -- that is a subcomponent of a global variable:
8710 -- with Text_Io; use Text_Io;
8711 -- procedure Tloop is
8714 -- V : Natural := 4;
8715 -- S : String (1..5) := (others => 'a');
8722 -- with procedure Action;
8723 -- procedure Loop_G (Arg : X; Msg : String)
8725 -- procedure Loop_G (Arg : X; Msg : String) is
8727 -- Put_Line ("begin loop_g " & Msg & " will loop till: "
8728 -- & Natural'Image (Arg.V));
8729 -- for Index in 1 .. Arg.V loop
8731 -- (Natural'Image (Index) & " " & Arg.S (Index));
8732 -- if Index > 2 then
8736 -- Put_Line ("end loop_g " & Msg);
8739 -- procedure Loop1 is new Loop_G (Modi);
8740 -- procedure Modi is
8743 -- Loop1 (X1, "from modi");
8747 -- Loop1 (X1, "initial");
8750 -- The output of the above program should be:
8752 -- begin loop_g initial will loop till: 4
8756 -- begin loop_g from modi will loop till: 1
8758 -- end loop_g from modi
8760 -- begin loop_g from modi will loop till: 1
8762 -- end loop_g from modi
8763 -- end loop_g initial
8765 -- If a loop bound is a subcomponent of a global variable, a
8766 -- modification of that variable within the loop may incorrectly
8767 -- affect the execution of the loop.
8769 elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
8770 and then Within_In_Parameter (Prefix (N))
8771 and then Variable_Ref
8775 -- All other cases are side effect free
8780 end Safe_Prefixed_Reference;
8782 -------------------------
8783 -- Within_In_Parameter --
8784 -------------------------
8786 function Within_In_Parameter (N : Node_Id) return Boolean is
8788 if not Comes_From_Source (N) then
8791 elsif Is_Entity_Name (N) then
8792 return Ekind (Entity (N)) = E_In_Parameter;
8794 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
8795 return Within_In_Parameter (Prefix (N));
8800 end Within_In_Parameter;
8802 -- Start of processing for Side_Effect_Free
8805 -- If volatile reference, always consider it to have side effects
8807 if Is_Volatile_Reference (N) then
8811 -- Note on checks that could raise Constraint_Error. Strictly, if we
8812 -- take advantage of 11.6, these checks do not count as side effects.
8813 -- However, we would prefer to consider that they are side effects,
8814 -- since the backend CSE does not work very well on expressions which
8815 -- can raise Constraint_Error. On the other hand if we don't consider
8816 -- them to be side effect free, then we get some awkward expansions
8817 -- in -gnato mode, resulting in code insertions at a point where we
8818 -- do not have a clear model for performing the insertions.
8820 -- Special handling for entity names
8822 if Is_Entity_Name (N) then
8824 -- A type reference is always side effect free
8826 if Is_Type (Entity (N)) then
8829 -- Variables are considered to be a side effect if Variable_Ref
8830 -- is set or if we have a volatile reference and Name_Req is off.
8831 -- If Name_Req is True then we can't help returning a name which
8832 -- effectively allows multiple references in any case.
8834 elsif Is_Variable (N, Use_Original_Node => False) then
8835 return not Variable_Ref
8836 and then (not Is_Volatile_Reference (N) or else Name_Req);
8838 -- Any other entity (e.g. a subtype name) is definitely side
8845 -- A value known at compile time is always side effect free
8847 elsif Compile_Time_Known_Value (N) then
8850 -- A variable renaming is not side-effect free, because the renaming
8851 -- will function like a macro in the front-end in some cases, and an
8852 -- assignment can modify the component designated by N, so we need to
8853 -- create a temporary for it.
8855 -- The guard testing for Entity being present is needed at least in
8856 -- the case of rewritten predicate expressions, and may well also be
8857 -- appropriate elsewhere. Obviously we can't go testing the entity
8858 -- field if it does not exist, so it's reasonable to say that this is
8859 -- not the renaming case if it does not exist.
8861 elsif Is_Entity_Name (Original_Node (N))
8862 and then Present (Entity (Original_Node (N)))
8863 and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
8864 and then Ekind (Entity (Original_Node (N))) /= E_Constant
8867 RO : constant Node_Id :=
8868 Renamed_Object (Entity (Original_Node (N)));
8871 -- If the renamed object is an indexed component, or an
8872 -- explicit dereference, then the designated object could
8873 -- be modified by an assignment.
8875 if Nkind_In (RO, N_Indexed_Component,
8876 N_Explicit_Dereference)
8880 -- A selected component must have a safe prefix
8882 elsif Nkind (RO) = N_Selected_Component then
8883 return Safe_Prefixed_Reference (RO);
8885 -- In all other cases, designated object cannot be changed so
8886 -- we are side effect free.
8893 -- Remove_Side_Effects generates an object renaming declaration to
8894 -- capture the expression of a class-wide expression. In VM targets
8895 -- the frontend performs no expansion for dispatching calls to
8896 -- class- wide types since they are handled by the VM. Hence, we must
8897 -- locate here if this node corresponds to a previous invocation of
8898 -- Remove_Side_Effects to avoid a never ending loop in the frontend.
8900 elsif not Tagged_Type_Expansion
8901 and then not Comes_From_Source (N)
8902 and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
8903 and then Is_Class_Wide_Type (Typ)
8908 -- For other than entity names and compile time known values,
8909 -- check the node kind for special processing.
8913 -- An attribute reference is side effect free if its expressions
8914 -- are side effect free and its prefix is side effect free or
8915 -- is an entity reference.
8917 -- Is this right? what about x'first where x is a variable???
8919 when N_Attribute_Reference =>
8920 return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
8921 and then Attribute_Name (N) /= Name_Input
8922 and then (Is_Entity_Name (Prefix (N))
8923 or else Side_Effect_Free
8924 (Prefix (N), Name_Req, Variable_Ref));
8926 -- A binary operator is side effect free if and both operands are
8927 -- side effect free. For this purpose binary operators include
8928 -- membership tests and short circuit forms.
8930 when N_Binary_Op | N_Membership_Test | N_Short_Circuit =>
8931 return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
8933 Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
8935 -- An explicit dereference is side effect free only if it is
8936 -- a side effect free prefixed reference.
8938 when N_Explicit_Dereference =>
8939 return Safe_Prefixed_Reference (N);
8941 -- An expression with action is side effect free if its expression
8942 -- is side effect free and it has no actions.
8944 when N_Expression_With_Actions =>
8945 return Is_Empty_List (Actions (N))
8947 Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
8949 -- A call to _rep_to_pos is side effect free, since we generate
8950 -- this pure function call ourselves. Moreover it is critically
8951 -- important to make this exception, since otherwise we can have
8952 -- discriminants in array components which don't look side effect
8953 -- free in the case of an array whose index type is an enumeration
8954 -- type with an enumeration rep clause.
8956 -- All other function calls are not side effect free
8958 when N_Function_Call =>
8959 return Nkind (Name (N)) = N_Identifier
8960 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
8963 (First (Parameter_Associations (N)), Name_Req, Variable_Ref);
8965 -- An IF expression is side effect free if it's of a scalar type, and
8966 -- all its components are all side effect free (conditions and then
8967 -- actions and else actions). We restrict to scalar types, since it
8968 -- is annoying to deal with things like (if A then B else C)'First
8969 -- where the type involved is a string type.
8971 when N_If_Expression =>
8972 return Is_Scalar_Type (Typ)
8974 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref);
8976 -- An indexed component is side effect free if it is a side
8977 -- effect free prefixed reference and all the indexing
8978 -- expressions are side effect free.
8980 when N_Indexed_Component =>
8981 return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
8982 and then Safe_Prefixed_Reference (N);
8984 -- A type qualification is side effect free if the expression
8985 -- is side effect free.
8987 when N_Qualified_Expression =>
8988 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
8990 -- A selected component is side effect free only if it is a side
8991 -- effect free prefixed reference.
8993 when N_Selected_Component =>
8994 return Safe_Prefixed_Reference (N);
8996 -- A range is side effect free if the bounds are side effect free
8999 return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref)
9001 Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref);
9003 -- A slice is side effect free if it is a side effect free
9004 -- prefixed reference and the bounds are side effect free.
9007 return Side_Effect_Free
9008 (Discrete_Range (N), Name_Req, Variable_Ref)
9009 and then Safe_Prefixed_Reference (N);
9011 -- A type conversion is side effect free if the expression to be
9012 -- converted is side effect free.
9014 when N_Type_Conversion =>
9015 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
9017 -- A unary operator is side effect free if the operand
9018 -- is side effect free.
9021 return Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
9023 -- An unchecked type conversion is side effect free only if it
9024 -- is safe and its argument is side effect free.
9026 when N_Unchecked_Type_Conversion =>
9027 return Safe_Unchecked_Type_Conversion (N)
9029 Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
9031 -- An unchecked expression is side effect free if its expression
9032 -- is side effect free.
9034 when N_Unchecked_Expression =>
9035 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
9037 -- A literal is side effect free
9039 when N_Character_Literal |
9045 -- We consider that anything else has side effects. This is a bit
9046 -- crude, but we are pretty close for most common cases, and we
9047 -- are certainly correct (i.e. we never return True when the
9048 -- answer should be False).
9053 end Side_Effect_Free;
9055 -- A list is side effect free if all elements of the list are side
9058 function Side_Effect_Free
9060 Name_Req : Boolean := False;
9061 Variable_Ref : Boolean := False) return Boolean
9066 if L = No_List or else L = Error_List then
9071 while Present (N) loop
9072 if not Side_Effect_Free (N, Name_Req, Variable_Ref) then
9081 end Side_Effect_Free;
9083 ----------------------------------
9084 -- Silly_Boolean_Array_Not_Test --
9085 ----------------------------------
9087 -- This procedure implements an odd and silly test. We explicitly check
9088 -- for the case where the 'First of the component type is equal to the
9089 -- 'Last of this component type, and if this is the case, we make sure
9090 -- that constraint error is raised. The reason is that the NOT is bound
9091 -- to cause CE in this case, and we will not otherwise catch it.
9093 -- No such check is required for AND and OR, since for both these cases
9094 -- False op False = False, and True op True = True. For the XOR case,
9095 -- see Silly_Boolean_Array_Xor_Test.
9097 -- Believe it or not, this was reported as a bug. Note that nearly always,
9098 -- the test will evaluate statically to False, so the code will be
9099 -- statically removed, and no extra overhead caused.
9101 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
9102 Loc : constant Source_Ptr := Sloc (N);
9103 CT : constant Entity_Id := Component_Type (T);
9106 -- The check we install is
9108 -- constraint_error when
9109 -- component_type'first = component_type'last
9110 -- and then array_type'Length /= 0)
9112 -- We need the last guard because we don't want to raise CE for empty
9113 -- arrays since no out of range values result. (Empty arrays with a
9114 -- component type of True .. True -- very useful -- even the ACATS
9115 -- does not test that marginal case).
9118 Make_Raise_Constraint_Error (Loc,
9124 Make_Attribute_Reference (Loc,
9125 Prefix => New_Occurrence_Of (CT, Loc),
9126 Attribute_Name => Name_First),
9129 Make_Attribute_Reference (Loc,
9130 Prefix => New_Occurrence_Of (CT, Loc),
9131 Attribute_Name => Name_Last)),
9133 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
9134 Reason => CE_Range_Check_Failed));
9135 end Silly_Boolean_Array_Not_Test;
9137 ----------------------------------
9138 -- Silly_Boolean_Array_Xor_Test --
9139 ----------------------------------
9141 -- This procedure implements an odd and silly test. We explicitly check
9142 -- for the XOR case where the component type is True .. True, since this
9143 -- will raise constraint error. A special check is required since CE
9144 -- will not be generated otherwise (cf Expand_Packed_Not).
9146 -- No such check is required for AND and OR, since for both these cases
9147 -- False op False = False, and True op True = True, and no check is
9148 -- required for the case of False .. False, since False xor False = False.
9149 -- See also Silly_Boolean_Array_Not_Test
9151 procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is
9152 Loc : constant Source_Ptr := Sloc (N);
9153 CT : constant Entity_Id := Component_Type (T);
9156 -- The check we install is
9158 -- constraint_error when
9159 -- Boolean (component_type'First)
9160 -- and then Boolean (component_type'Last)
9161 -- and then array_type'Length /= 0)
9163 -- We need the last guard because we don't want to raise CE for empty
9164 -- arrays since no out of range values result (Empty arrays with a
9165 -- component type of True .. True -- very useful -- even the ACATS
9166 -- does not test that marginal case).
9169 Make_Raise_Constraint_Error (Loc,
9175 Convert_To (Standard_Boolean,
9176 Make_Attribute_Reference (Loc,
9177 Prefix => New_Occurrence_Of (CT, Loc),
9178 Attribute_Name => Name_First)),
9181 Convert_To (Standard_Boolean,
9182 Make_Attribute_Reference (Loc,
9183 Prefix => New_Occurrence_Of (CT, Loc),
9184 Attribute_Name => Name_Last))),
9186 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
9187 Reason => CE_Range_Check_Failed));
9188 end Silly_Boolean_Array_Xor_Test;
9190 --------------------------
9191 -- Target_Has_Fixed_Ops --
9192 --------------------------
9194 Integer_Sized_Small : Ureal;
9195 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
9196 -- called (we don't want to compute it more than once).
9198 Long_Integer_Sized_Small : Ureal;
9199 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
9200 -- is called (we don't want to compute it more than once)
9202 First_Time_For_THFO : Boolean := True;
9203 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
9205 function Target_Has_Fixed_Ops
9206 (Left_Typ : Entity_Id;
9207 Right_Typ : Entity_Id;
9208 Result_Typ : Entity_Id) return Boolean
9210 function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
9211 -- Return True if the given type is a fixed-point type with a small
9212 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
9213 -- an absolute value less than 1.0. This is currently limited to
9214 -- fixed-point types that map to Integer or Long_Integer.
9216 ------------------------
9217 -- Is_Fractional_Type --
9218 ------------------------
9220 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
9222 if Esize (Typ) = Standard_Integer_Size then
9223 return Small_Value (Typ) = Integer_Sized_Small;
9225 elsif Esize (Typ) = Standard_Long_Integer_Size then
9226 return Small_Value (Typ) = Long_Integer_Sized_Small;
9231 end Is_Fractional_Type;
9233 -- Start of processing for Target_Has_Fixed_Ops
9236 -- Return False if Fractional_Fixed_Ops_On_Target is false
9238 if not Fractional_Fixed_Ops_On_Target then
9242 -- Here the target has Fractional_Fixed_Ops, if first time, compute
9243 -- standard constants used by Is_Fractional_Type.
9245 if First_Time_For_THFO then
9246 First_Time_For_THFO := False;
9248 Integer_Sized_Small :=
9251 Den => UI_From_Int (Standard_Integer_Size - 1),
9254 Long_Integer_Sized_Small :=
9257 Den => UI_From_Int (Standard_Long_Integer_Size - 1),
9261 -- Return True if target supports fixed-by-fixed multiply/divide for
9262 -- fractional fixed-point types (see Is_Fractional_Type) and the operand
9263 -- and result types are equivalent fractional types.
9265 return Is_Fractional_Type (Base_Type (Left_Typ))
9266 and then Is_Fractional_Type (Base_Type (Right_Typ))
9267 and then Is_Fractional_Type (Base_Type (Result_Typ))
9268 and then Esize (Left_Typ) = Esize (Right_Typ)
9269 and then Esize (Left_Typ) = Esize (Result_Typ);
9270 end Target_Has_Fixed_Ops;
9272 ------------------------------------------
9273 -- Type_May_Have_Bit_Aligned_Components --
9274 ------------------------------------------
9276 function Type_May_Have_Bit_Aligned_Components
9277 (Typ : Entity_Id) return Boolean
9280 -- Array type, check component type
9282 if Is_Array_Type (Typ) then
9284 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
9286 -- Record type, check components
9288 elsif Is_Record_Type (Typ) then
9293 E := First_Component_Or_Discriminant (Typ);
9294 while Present (E) loop
9295 if Component_May_Be_Bit_Aligned (E)
9296 or else Type_May_Have_Bit_Aligned_Components (Etype (E))
9301 Next_Component_Or_Discriminant (E);
9307 -- Type other than array or record is always OK
9312 end Type_May_Have_Bit_Aligned_Components;
9314 ----------------------------------
9315 -- Within_Case_Or_If_Expression --
9316 ----------------------------------
9318 function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
9322 -- Locate an enclosing case or if expression. Note that these constructs
9323 -- can be expanded into Expression_With_Actions, hence the test of the
9327 while Present (Par) loop
9328 if Nkind_In (Original_Node (Par), N_Case_Expression,
9333 -- Prevent the search from going too far
9335 elsif Is_Body_Or_Package_Declaration (Par) then
9339 Par := Parent (Par);
9343 end Within_Case_Or_If_Expression;
9345 --------------------------------
9346 -- Within_Internal_Subprogram --
9347 --------------------------------
9349 function Within_Internal_Subprogram return Boolean is
9354 while Present (S) and then not Is_Subprogram (S) loop
9359 and then Get_TSS_Name (S) /= TSS_Null
9360 and then not Is_Predicate_Function (S);
9361 end Within_Internal_Subprogram;
9363 ----------------------------
9364 -- Wrap_Cleanup_Procedure --
9365 ----------------------------
9367 procedure Wrap_Cleanup_Procedure (N : Node_Id) is
9368 Loc : constant Source_Ptr := Sloc (N);
9369 Stseq : constant Node_Id := Handled_Statement_Sequence (N);
9370 Stmts : constant List_Id := Statements (Stseq);
9372 if Abort_Allowed then
9373 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
9374 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
9376 end Wrap_Cleanup_Procedure;