1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
29 with Atree; use Atree;
30 with Checks; use Checks;
31 with Einfo; use Einfo;
32 with Elists; use Elists;
33 with Errout; use Errout;
34 with Exp_Ch7; use Exp_Ch7;
35 with Exp_Ch11; use Exp_Ch11;
36 with Hostparm; use Hostparm;
37 with Inline; use Inline;
38 with Itypes; use Itypes;
40 with Namet; use Namet;
41 with Nlists; use Nlists;
42 with Nmake; use Nmake;
44 with Restrict; use Restrict;
46 with Sem_Ch8; use Sem_Ch8;
47 with Sem_Eval; use Sem_Eval;
48 with Sem_Res; use Sem_Res;
49 with Sem_Util; use Sem_Util;
50 with Sinfo; use Sinfo;
51 with Stand; use Stand;
52 with Stringt; use Stringt;
53 with Tbuild; use Tbuild;
54 with Ttypes; use Ttypes;
55 with Uintp; use Uintp;
56 with Validsw; use Validsw;
58 package body Exp_Util is
60 -----------------------
61 -- Local Subprograms --
62 -----------------------
64 function Build_Task_Array_Image
68 Dyn : Boolean := False)
70 -- Build function to generate the image string for a task that is an
71 -- array component, concatenating the images of each index. To avoid
72 -- storage leaks, the string is built with successive slice assignments.
73 -- The flag Dyn indicates whether this is called for the initialization
74 -- procedure of an array of tasks, or for the name of a dynamically
75 -- created task that is assigned to an indexed component.
77 function Build_Task_Image_Function
83 -- Common processing for Task_Array_Image and Task_Record_Image.
84 -- Build function body that computes image.
86 procedure Build_Task_Image_Prefix
93 Decls : in out List_Id;
94 Stats : in out List_Id);
95 -- Common processing for Task_Array_Image and Task_Record_Image.
96 -- Create local variables and assign prefix of name to result string.
98 function Build_Task_Record_Image
102 Dyn : Boolean := False)
104 -- Build function to generate the image string for a task that is a
105 -- record component. Concatenate name of variable with that of selector.
106 -- The flag Dyn indicates whether this is called for the initialization
107 -- procedure of record with task components, or for a dynamically
108 -- created task that is assigned to a selected component.
110 function Make_CW_Equivalent_Type
114 -- T is a class-wide type entity, E is the initial expression node that
115 -- constrains T in case such as: " X: T := E" or "new T'(E)"
116 -- This function returns the entity of the Equivalent type and inserts
117 -- on the fly the necessary declaration such as:
118 -- type anon is record
119 -- _parent : Root_Type (T); constrained with E discriminants (if any)
120 -- Extension : String (1 .. expr to match size of E);
123 -- This record is compatible with any object of the class of T thanks
124 -- to the first field and has the same size as E thanks to the second.
126 function Make_Literal_Range
128 Literal_Typ : Entity_Id;
129 Index_Typ : Entity_Id)
131 -- Produce a Range node whose bounds are:
132 -- Index_Typ'first .. Index_Typ'First + Length (Literal_Typ)
133 -- this is used for expanding declarations like X : String := "sdfgdfg";
135 function New_Class_Wide_Subtype
139 -- Create an implicit subtype of CW_Typ attached to node N.
141 ----------------------
142 -- Adjust_Condition --
143 ----------------------
145 procedure Adjust_Condition (N : Node_Id) is
152 Loc : constant Source_Ptr := Sloc (N);
153 T : constant Entity_Id := Etype (N);
157 -- For now, we simply ignore a call where the argument has no
158 -- type (probably case of unanalyzed condition), or has a type
159 -- that is not Boolean. This is because this is a pretty marginal
160 -- piece of functionality, and violations of these rules are
161 -- likely to be truly marginal (how much code uses Fortran Logical
162 -- as the barrier to a protected entry?) and we do not want to
163 -- blow up existing programs. We can change this to an assertion
164 -- after 3.12a is released ???
166 if No (T) or else not Is_Boolean_Type (T) then
170 -- Apply validity checking if needed
172 if Validity_Checks_On and Validity_Check_Tests then
176 -- Immediate return if standard boolean, the most common case,
177 -- where nothing needs to be done.
179 if Base_Type (T) = Standard_Boolean then
183 -- Case of zero/non-zero semantics or non-standard enumeration
184 -- representation. In each case, we rewrite the node as:
186 -- ityp!(N) /= False'Enum_Rep
188 -- where ityp is an integer type with large enough size to hold
189 -- any value of type T.
191 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
192 if Esize (T) <= Esize (Standard_Integer) then
193 Ti := Standard_Integer;
195 Ti := Standard_Long_Long_Integer;
200 Left_Opnd => Unchecked_Convert_To (Ti, N),
202 Make_Attribute_Reference (Loc,
203 Attribute_Name => Name_Enum_Rep,
205 New_Occurrence_Of (First_Literal (T), Loc))));
206 Analyze_And_Resolve (N, Standard_Boolean);
209 Rewrite (N, Convert_To (Standard_Boolean, N));
210 Analyze_And_Resolve (N, Standard_Boolean);
213 end Adjust_Condition;
215 ------------------------
216 -- Adjust_Result_Type --
217 ------------------------
219 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
221 -- Ignore call if current type is not Standard.Boolean
223 if Etype (N) /= Standard_Boolean then
227 -- If result is already of correct type, nothing to do. Note that
228 -- this will get the most common case where everything has a type
229 -- of Standard.Boolean.
231 if Base_Type (T) = Standard_Boolean then
236 KP : constant Node_Kind := Nkind (Parent (N));
239 -- If result is to be used as a Condition in the syntax, no need
240 -- to convert it back, since if it was changed to Standard.Boolean
241 -- using Adjust_Condition, that is just fine for this usage.
243 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
246 -- If result is an operand of another logical operation, no need
247 -- to reset its type, since Standard.Boolean is just fine, and
248 -- such operations always do Adjust_Condition on their operands.
250 elsif KP in N_Op_Boolean
251 or else KP = N_And_Then
252 or else KP = N_Or_Else
253 or else KP = N_Op_Not
257 -- Otherwise we perform a conversion from the current type,
258 -- which must be Standard.Boolean, to the desired type.
262 Rewrite (N, Convert_To (T, N));
263 Analyze_And_Resolve (N, T);
267 end Adjust_Result_Type;
269 --------------------------
270 -- Append_Freeze_Action --
271 --------------------------
273 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
274 Fnode : Node_Id := Freeze_Node (T);
277 Ensure_Freeze_Node (T);
278 Fnode := Freeze_Node (T);
280 if not Present (Actions (Fnode)) then
281 Set_Actions (Fnode, New_List);
284 Append (N, Actions (Fnode));
285 end Append_Freeze_Action;
287 ---------------------------
288 -- Append_Freeze_Actions --
289 ---------------------------
291 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
292 Fnode : constant Node_Id := Freeze_Node (T);
299 if No (Actions (Fnode)) then
300 Set_Actions (Fnode, L);
303 Append_List (L, Actions (Fnode));
307 end Append_Freeze_Actions;
309 ------------------------
310 -- Build_Runtime_Call --
311 ------------------------
313 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
316 Make_Procedure_Call_Statement (Loc,
317 Name => New_Reference_To (RTE (RE), Loc));
318 end Build_Runtime_Call;
320 -----------------------------
321 -- Build_Task_Array_Image --
322 -----------------------------
324 -- This function generates the body for a function that constructs the
325 -- image string for a task that is an array component. The function is
326 -- local to the init_proc for the array type, and is called for each one
327 -- of the components. The constructed image has the form of an indexed
328 -- component, whose prefix is the outer variable of the array type.
329 -- The n-dimensional array type has known indices Index, Index2...
330 -- Id_Ref is an indexed component form created by the enclosing init_proc.
331 -- Its successive indices are Val1, Val2,.. which are the loop variables
332 -- in the loops that call the individual task init_proc on each component.
334 -- The generated function has the following structure:
336 -- function F return Task_Image_Type is
337 -- Pref : string := Task_Id.all;
338 -- T1 : String := Index1'Image (Val1);
340 -- Tn : String := indexn'image (Valn);
341 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
342 -- -- Len includes commas and the end parentheses.
343 -- Res : String (1..Len);
344 -- Pos : Integer := Pref'Length;
347 -- Res (1 .. Pos) := Pref;
351 -- Res (Pos .. Pos + T1'Length - 1) := T1;
352 -- Pos := Pos + T1'Length;
356 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
359 -- return new String (Res);
362 -- Needless to say, multidimensional arrays of tasks are rare enough
363 -- that the bulkiness of this code is not really a concern.
365 function Build_Task_Array_Image
369 Dyn : Boolean := False)
372 Dims : constant Nat := Number_Dimensions (A_Type);
373 -- Number of dimensions for array of tasks.
375 Temps : array (1 .. Dims) of Entity_Id;
376 -- Array of temporaries to hold string for each index.
382 -- Total length of generated name
385 -- Running index for substring assignments
388 -- Name of enclosing variable, prefix of resulting name
391 -- string expression for Pref.
394 -- String to hold result
397 -- Value of successive indices
400 -- Expression to compute total size of string
403 -- Entity for name at one index position
405 Decls : List_Id := New_List;
406 Stats : List_Id := New_List;
409 Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
411 -- For a dynamic task, the name comes from the target variable.
412 -- For a static one it is a formal of the enclosing init_proc.
415 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
417 Make_String_Literal (Loc, Strval => String_From_Name_Buffer);
420 Make_Explicit_Dereference (Loc,
421 Prefix => Make_Identifier (Loc, Name_uTask_Id));
425 Make_Object_Declaration (Loc,
426 Defining_Identifier => Pref,
427 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
428 Expression => P_Nam));
430 Indx := First_Index (A_Type);
431 Val := First (Expressions (Id_Ref));
433 for J in 1 .. Dims loop
434 T := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
438 Make_Object_Declaration (Loc,
439 Defining_Identifier => T,
440 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
442 Make_Attribute_Reference (Loc,
443 Attribute_Name => Name_Image,
445 New_Occurrence_Of (Etype (Indx), Loc),
446 Expressions => New_List (
447 New_Copy_Tree (Val)))));
453 Sum := Make_Integer_Literal (Loc, Dims + 1);
459 Make_Attribute_Reference (Loc,
460 Attribute_Name => Name_Length,
462 New_Occurrence_Of (Pref, Loc),
463 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
465 for J in 1 .. Dims loop
470 Make_Attribute_Reference (Loc,
471 Attribute_Name => Name_Length,
473 New_Occurrence_Of (Temps (J), Loc),
474 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
477 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
479 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
482 Make_Assignment_Statement (Loc,
483 Name => Make_Indexed_Component (Loc,
484 Prefix => New_Occurrence_Of (Res, Loc),
485 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
487 Make_Character_Literal (Loc,
489 Char_Literal_Value =>
490 Char_Code (Character'Pos ('(')))));
493 Make_Assignment_Statement (Loc,
494 Name => New_Occurrence_Of (Pos, Loc),
497 Left_Opnd => New_Occurrence_Of (Pos, Loc),
498 Right_Opnd => Make_Integer_Literal (Loc, 1))));
500 for J in 1 .. Dims loop
503 Make_Assignment_Statement (Loc,
504 Name => Make_Slice (Loc,
505 Prefix => New_Occurrence_Of (Res, Loc),
508 Low_Bound => New_Occurrence_Of (Pos, Loc),
509 High_Bound => Make_Op_Subtract (Loc,
512 Left_Opnd => New_Occurrence_Of (Pos, Loc),
514 Make_Attribute_Reference (Loc,
515 Attribute_Name => Name_Length,
517 New_Occurrence_Of (Temps (J), Loc),
519 New_List (Make_Integer_Literal (Loc, 1)))),
520 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
522 Expression => New_Occurrence_Of (Temps (J), Loc)));
526 Make_Assignment_Statement (Loc,
527 Name => New_Occurrence_Of (Pos, Loc),
530 Left_Opnd => New_Occurrence_Of (Pos, Loc),
532 Make_Attribute_Reference (Loc,
533 Attribute_Name => Name_Length,
534 Prefix => New_Occurrence_Of (Temps (J), Loc),
536 New_List (Make_Integer_Literal (Loc, 1))))));
538 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
541 Make_Assignment_Statement (Loc,
542 Name => Make_Indexed_Component (Loc,
543 Prefix => New_Occurrence_Of (Res, Loc),
544 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
546 Make_Character_Literal (Loc,
548 Char_Literal_Value =>
549 Char_Code (Character'Pos (',')))));
552 Make_Assignment_Statement (Loc,
553 Name => New_Occurrence_Of (Pos, Loc),
556 Left_Opnd => New_Occurrence_Of (Pos, Loc),
557 Right_Opnd => Make_Integer_Literal (Loc, 1))));
561 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
564 Make_Assignment_Statement (Loc,
565 Name => Make_Indexed_Component (Loc,
566 Prefix => New_Occurrence_Of (Res, Loc),
567 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
569 Make_Character_Literal (Loc,
571 Char_Literal_Value =>
572 Char_Code (Character'Pos (')')))));
573 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
574 end Build_Task_Array_Image;
576 ----------------------------
577 -- Build_Task_Image_Decls --
578 ----------------------------
580 function Build_Task_Image_Decls
586 T_Id : Entity_Id := Empty;
588 Decls : List_Id := New_List;
589 Expr : Node_Id := Empty;
590 Fun : Node_Id := Empty;
591 Is_Dyn : constant Boolean :=
592 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
593 and then Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
596 -- If Discard_Names is in effect, generate a dummy declaration only.
598 if Global_Discard_Names then
600 Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
604 Make_Object_Declaration (Loc,
605 Defining_Identifier => T_Id,
607 New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc)));
610 if Nkind (Id_Ref) = N_Identifier
611 or else Nkind (Id_Ref) = N_Defining_Identifier
613 -- For a simple variable, the image of the task is the name
617 Make_Defining_Identifier (Loc,
618 New_External_Name (Chars (Id_Ref), 'I'));
620 Get_Name_String (Chars (Id_Ref));
625 Make_Qualified_Expression (Loc,
627 New_Occurrence_Of (Standard_String, Loc),
630 (Loc, Strval => String_From_Name_Buffer)));
632 elsif Nkind (Id_Ref) = N_Selected_Component then
634 Make_Defining_Identifier (Loc,
635 New_External_Name (Chars (Selector_Name (Id_Ref)), 'I'));
636 Fun := Build_Task_Record_Image (Loc, Id_Ref, A_Type, Is_Dyn);
638 elsif Nkind (Id_Ref) = N_Indexed_Component then
640 Make_Defining_Identifier (Loc,
641 New_External_Name (Chars (A_Type), 'I'));
643 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
647 if Present (Fun) then
651 Make_Function_Call (Loc,
652 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
655 Decl := Make_Object_Declaration (Loc,
656 Defining_Identifier => T_Id,
658 New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc),
661 Append (Decl, Decls);
663 end Build_Task_Image_Decls;
665 -------------------------------
666 -- Build_Task_Image_Function --
667 -------------------------------
669 function Build_Task_Image_Function
680 Make_Return_Statement (Loc,
684 Make_Qualified_Expression (Loc,
686 New_Occurrence_Of (Standard_String, Loc),
687 Expression => New_Occurrence_Of (Res, Loc)))));
689 Spec := Make_Function_Specification (Loc,
690 Defining_Unit_Name =>
691 Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
692 Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc));
694 return Make_Subprogram_Body (Loc,
695 Specification => Spec,
696 Declarations => Decls,
697 Handled_Statement_Sequence =>
698 Make_Handled_Sequence_Of_Statements (Loc,
699 Statements => Stats));
700 end Build_Task_Image_Function;
702 -----------------------------
703 -- Build_Task_Image_Prefix --
704 -----------------------------
706 procedure Build_Task_Image_Prefix
713 Decls : in out List_Id;
714 Stats : in out List_Id)
717 Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
720 Make_Object_Declaration (Loc,
721 Defining_Identifier => Len,
722 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
725 Res := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
728 Make_Object_Declaration (Loc,
729 Defining_Identifier => Res,
731 Make_Subtype_Indication (Loc,
732 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
734 Make_Index_Or_Discriminant_Constraint (Loc,
738 Low_Bound => Make_Integer_Literal (Loc, 1),
739 High_Bound => New_Occurrence_Of (Len, Loc)))))));
741 Pos := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
744 Make_Object_Declaration (Loc,
745 Defining_Identifier => Pos,
746 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
748 -- Pos := Prefix'Length;
751 Make_Assignment_Statement (Loc,
752 Name => New_Occurrence_Of (Pos, Loc),
754 Make_Attribute_Reference (Loc,
755 Attribute_Name => Name_Length,
756 Prefix => New_Occurrence_Of (Prefix, Loc),
758 New_List (Make_Integer_Literal (Loc, 1)))));
760 -- Res (1 .. Pos) := Prefix;
763 Make_Assignment_Statement (Loc,
764 Name => Make_Slice (Loc,
765 Prefix => New_Occurrence_Of (Res, Loc),
768 Low_Bound => Make_Integer_Literal (Loc, 1),
769 High_Bound => New_Occurrence_Of (Pos, Loc))),
771 Expression => New_Occurrence_Of (Prefix, Loc)));
774 Make_Assignment_Statement (Loc,
775 Name => New_Occurrence_Of (Pos, Loc),
778 Left_Opnd => New_Occurrence_Of (Pos, Loc),
779 Right_Opnd => Make_Integer_Literal (Loc, 1))));
780 end Build_Task_Image_Prefix;
782 -----------------------------
783 -- Build_Task_Record_Image --
784 -----------------------------
786 function Build_Task_Record_Image
790 Dyn : Boolean := False)
794 -- Total length of generated name
800 -- String to hold result
803 -- Name of enclosing variable, prefix of resulting name
806 -- string expression for Pref.
809 -- Expression to compute total size of string.
812 -- Entity for selector name
814 Decls : List_Id := New_List;
815 Stats : List_Id := New_List;
818 Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
820 -- For a dynamic task, the name comes from the target variable.
821 -- For a static one it is a formal of the enclosing init_proc.
824 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
826 Make_String_Literal (Loc, Strval => String_From_Name_Buffer);
829 Make_Explicit_Dereference (Loc,
830 Prefix => Make_Identifier (Loc, Name_uTask_Id));
834 Make_Object_Declaration (Loc,
835 Defining_Identifier => Pref,
836 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
837 Expression => P_Nam));
839 Sel := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
841 Get_Name_String (Chars (Selector_Name (Id_Ref)));
844 Make_Object_Declaration (Loc,
845 Defining_Identifier => Sel,
846 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
848 Make_String_Literal (Loc, Strval => String_From_Name_Buffer)));
850 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
856 Make_Attribute_Reference (Loc,
857 Attribute_Name => Name_Length,
859 New_Occurrence_Of (Pref, Loc),
860 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
862 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
864 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
869 Make_Assignment_Statement (Loc,
870 Name => Make_Indexed_Component (Loc,
871 Prefix => New_Occurrence_Of (Res, Loc),
872 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
874 Make_Character_Literal (Loc,
876 Char_Literal_Value =>
877 Char_Code (Character'Pos ('.')))));
880 Make_Assignment_Statement (Loc,
881 Name => New_Occurrence_Of (Pos, Loc),
884 Left_Opnd => New_Occurrence_Of (Pos, Loc),
885 Right_Opnd => Make_Integer_Literal (Loc, 1))));
887 -- Res (Pos .. Len) := Selector;
890 Make_Assignment_Statement (Loc,
891 Name => Make_Slice (Loc,
892 Prefix => New_Occurrence_Of (Res, Loc),
895 Low_Bound => New_Occurrence_Of (Pos, Loc),
896 High_Bound => New_Occurrence_Of (Len, Loc))),
897 Expression => New_Occurrence_Of (Sel, Loc)));
899 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
900 end Build_Task_Record_Image;
902 -------------------------------
903 -- Convert_To_Actual_Subtype --
904 -------------------------------
906 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
910 Act_ST := Get_Actual_Subtype (Exp);
912 if Act_ST = Etype (Exp) then
917 Convert_To (Act_ST, Relocate_Node (Exp)));
918 Analyze_And_Resolve (Exp, Act_ST);
920 end Convert_To_Actual_Subtype;
922 -----------------------------------
923 -- Current_Sem_Unit_Declarations --
924 -----------------------------------
926 function Current_Sem_Unit_Declarations return List_Id is
927 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
931 -- If the current unit is a package body, locate the visible
932 -- declarations of the package spec.
934 if Nkind (U) = N_Package_Body then
935 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
938 if Nkind (U) = N_Package_Declaration then
939 U := Specification (U);
940 Decls := Visible_Declarations (U);
944 Set_Visible_Declarations (U, Decls);
948 Decls := Declarations (U);
952 Set_Declarations (U, Decls);
957 end Current_Sem_Unit_Declarations;
959 -----------------------
960 -- Duplicate_Subexpr --
961 -----------------------
963 function Duplicate_Subexpr
965 Name_Req : Boolean := False)
969 Remove_Side_Effects (Exp, Name_Req);
970 return New_Copy_Tree (Exp);
971 end Duplicate_Subexpr;
977 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
982 if Is_Itype (Typ) then
983 IR := Make_Itype_Reference (Sloc (N));
986 if not In_Open_Scopes (Scope (Typ))
987 and then Is_Subprogram (Current_Scope)
988 and then Scope (Current_Scope) /= Standard_Standard
990 -- Insert node in front of subprogram, to avoid scope anomalies
996 and then Nkind (P) /= N_Subprogram_Body
1002 Insert_Action (P, IR);
1004 Insert_Action (N, IR);
1008 Insert_Action (N, IR);
1013 ---------------------
1014 -- Evolve_And_Then --
1015 ---------------------
1017 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
1023 Make_And_Then (Sloc (Cond1),
1025 Right_Opnd => Cond1);
1027 end Evolve_And_Then;
1029 --------------------
1030 -- Evolve_Or_Else --
1031 --------------------
1033 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
1039 Make_Or_Else (Sloc (Cond1),
1041 Right_Opnd => Cond1);
1045 ------------------------------
1046 -- Expand_Subtype_From_Expr --
1047 ------------------------------
1049 -- This function is applicable for both static and dynamic allocation of
1050 -- objects which are constrained by an initial expression. Basically it
1051 -- transforms an unconstrained subtype indication into a constrained one.
1052 -- The expression may also be transformed in certain cases in order to
1053 -- avoid multiple evaulation. In the static allocation case, the general
1058 -- is transformed into
1060 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1062 -- Here are the main cases :
1064 -- <if Expr is a Slice>
1065 -- Val : T ([Index_Subtype (Expr)]) := Expr;
1067 -- <elsif Expr is a String Literal>
1068 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1070 -- <elsif Expr is Constrained>
1071 -- subtype T is Type_Of_Expr
1074 -- <elsif Expr is an entity_name>
1075 -- Val : T (constraints taken from Expr) := Expr;
1078 -- type Axxx is access all T;
1079 -- Rval : Axxx := Expr'ref;
1080 -- Val : T (constraints taken from Rval) := Rval.all;
1082 -- ??? note: when the Expression is allocated in the secondary stack
1083 -- we could use it directly instead of copying it by declaring
1084 -- Val : T (...) renames Rval.all
1086 procedure Expand_Subtype_From_Expr
1088 Unc_Type : Entity_Id;
1089 Subtype_Indic : Node_Id;
1092 Loc : constant Source_Ptr := Sloc (N);
1093 Exp_Typ : constant Entity_Id := Etype (Exp);
1097 -- In general we cannot build the subtype if expansion is disabled,
1098 -- because internal entities may not have been defined. However, to
1099 -- avoid some cascaded errors, we try to continue when the expression
1100 -- is an array (or string), because it is safe to compute the bounds.
1101 -- It is in fact required to do so even in a generic context, because
1102 -- there may be constants that depend on bounds of string literal.
1104 if not Expander_Active
1105 and then (No (Etype (Exp))
1106 or else Base_Type (Etype (Exp)) /= Standard_String)
1111 if Nkind (Exp) = N_Slice then
1113 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
1116 Rewrite (Subtype_Indic,
1117 Make_Subtype_Indication (Loc,
1118 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1120 Make_Index_Or_Discriminant_Constraint (Loc,
1121 Constraints => New_List
1122 (New_Reference_To (Slice_Type, Loc)))));
1124 -- This subtype indication may be used later for contraint checks
1125 -- we better make sure that if a variable was used as a bound of
1126 -- of the original slice, its value is frozen.
1128 Force_Evaluation (Low_Bound (Scalar_Range (Slice_Type)));
1129 Force_Evaluation (High_Bound (Scalar_Range (Slice_Type)));
1132 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
1133 Rewrite (Subtype_Indic,
1134 Make_Subtype_Indication (Loc,
1135 Subtype_Mark => New_Reference_To (Unc_Type, Loc),
1137 Make_Index_Or_Discriminant_Constraint (Loc,
1138 Constraints => New_List (
1139 Make_Literal_Range (Loc,
1140 Literal_Typ => Exp_Typ,
1141 Index_Typ => Etype (First_Index (Unc_Type)))))));
1143 elsif Is_Constrained (Exp_Typ)
1144 and then not Is_Class_Wide_Type (Unc_Type)
1146 if Is_Itype (Exp_Typ) then
1148 -- No need to generate a new one.
1154 Make_Defining_Identifier (Loc,
1155 Chars => New_Internal_Name ('T'));
1158 Make_Subtype_Declaration (Loc,
1159 Defining_Identifier => T,
1160 Subtype_Indication => New_Reference_To (Exp_Typ, Loc)));
1162 -- This type is marked as an itype even though it has an
1163 -- explicit declaration because otherwise it can be marked
1164 -- with Is_Generic_Actual_Type and generate spurious errors.
1165 -- (see sem_ch8.Analyze_Package_Renaming and sem_type.covers)
1168 Set_Associated_Node_For_Itype (T, Exp);
1171 Rewrite (Subtype_Indic, New_Reference_To (T, Loc));
1173 -- nothing needs to be done for private types with unknown discriminants
1174 -- if the underlying type is not an unconstrained composite type.
1176 elsif Is_Private_Type (Unc_Type)
1177 and then Has_Unknown_Discriminants (Unc_Type)
1178 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
1179 or else Is_Constrained (Underlying_Type (Unc_Type)))
1184 Remove_Side_Effects (Exp);
1185 Rewrite (Subtype_Indic,
1186 Make_Subtype_From_Expr (Exp, Unc_Type));
1188 end Expand_Subtype_From_Expr;
1194 function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
1196 Typ : Entity_Id := T;
1199 if Is_Class_Wide_Type (Typ) then
1200 Typ := Root_Type (Typ);
1203 Typ := Underlying_Type (Typ);
1205 Prim := First_Elmt (Primitive_Operations (Typ));
1206 while Chars (Node (Prim)) /= Name loop
1208 pragma Assert (Present (Prim));
1214 ----------------------
1215 -- Force_Evaluation --
1216 ----------------------
1218 procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
1220 Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
1221 end Force_Evaluation;
1223 ------------------------
1224 -- Generate_Poll_Call --
1225 ------------------------
1227 procedure Generate_Poll_Call (N : Node_Id) is
1229 -- No poll call if polling not active
1231 if not Polling_Required then
1234 -- Otherwise generate require poll call
1237 Insert_Before_And_Analyze (N,
1238 Make_Procedure_Call_Statement (Sloc (N),
1239 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
1241 end Generate_Poll_Call;
1243 --------------------
1244 -- Homonym_Number --
1245 --------------------
1247 function Homonym_Number (Subp : Entity_Id) return Nat is
1253 Hom := Homonym (Subp);
1254 while Present (Hom) loop
1255 if Scope (Hom) = Scope (Subp) then
1259 Hom := Homonym (Hom);
1265 ------------------------------
1266 -- In_Unconditional_Context --
1267 ------------------------------
1269 function In_Unconditional_Context (Node : Node_Id) return Boolean is
1274 while Present (P) loop
1276 when N_Subprogram_Body =>
1279 when N_If_Statement =>
1282 when N_Loop_Statement =>
1285 when N_Case_Statement =>
1294 end In_Unconditional_Context;
1300 procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
1302 if Present (Ins_Action) then
1303 Insert_Actions (Assoc_Node, New_List (Ins_Action));
1307 -- Version with check(s) suppressed
1309 procedure Insert_Action
1310 (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
1313 Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
1316 --------------------
1317 -- Insert_Actions --
1318 --------------------
1320 procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
1324 Wrapped_Node : Node_Id := Empty;
1327 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
1331 -- Ignore insert of actions from inside default expression in the
1332 -- special preliminary analyze mode. Any insertions at this point
1333 -- have no relevance, since we are only doing the analyze to freeze
1334 -- the types of any static expressions. See section "Handling of
1335 -- Default Expressions" in the spec of package Sem for further details.
1337 if In_Default_Expression then
1341 -- If the action derives from stuff inside a record, then the actions
1342 -- are attached to the current scope, to be inserted and analyzed on
1343 -- exit from the scope. The reason for this is that we may also
1344 -- be generating freeze actions at the same time, and they must
1345 -- eventually be elaborated in the correct order.
1347 if Is_Record_Type (Current_Scope)
1348 and then not Is_Frozen (Current_Scope)
1350 if No (Scope_Stack.Table
1351 (Scope_Stack.Last).Pending_Freeze_Actions)
1353 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
1358 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
1364 -- We now intend to climb up the tree to find the right point to
1365 -- insert the actions. We start at Assoc_Node, unless this node is
1366 -- a subexpression in which case we start with its parent. We do this
1367 -- for two reasons. First it speeds things up. Second, if Assoc_Node
1368 -- is itself one of the special nodes like N_And_Then, then we assume
1369 -- that an initial request to insert actions for such a node does not
1370 -- expect the actions to get deposited in the node for later handling
1371 -- when the node is expanded, since clearly the node is being dealt
1372 -- with by the caller. Note that in the subexpression case, N is
1373 -- always the child we came from.
1375 -- N_Raise_xxx_Error is an annoying special case, it is a statement
1376 -- if it has type Standard_Void_Type, and a subexpression otherwise.
1377 -- otherwise. Procedure attribute references are also statements.
1379 if Nkind (Assoc_Node) in N_Subexpr
1380 and then (Nkind (Assoc_Node) in N_Raise_xxx_Error
1381 or else Etype (Assoc_Node) /= Standard_Void_Type)
1382 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
1384 not Is_Procedure_Attribute_Name
1385 (Attribute_Name (Assoc_Node)))
1387 P := Assoc_Node; -- ????? does not agree with above!
1388 N := Parent (Assoc_Node);
1390 -- Non-subexpression case. Note that N is initially Empty in this
1391 -- case (N is only guaranteed Non-Empty in the subexpr case).
1398 -- Capture root of the transient scope
1400 if Scope_Is_Transient then
1401 Wrapped_Node := Node_To_Be_Wrapped;
1405 pragma Assert (Present (P));
1409 -- Case of right operand of AND THEN or OR ELSE. Put the actions
1410 -- in the Actions field of the right operand. They will be moved
1411 -- out further when the AND THEN or OR ELSE operator is expanded.
1412 -- Nothing special needs to be done for the left operand since
1413 -- in that case the actions are executed unconditionally.
1415 when N_And_Then | N_Or_Else =>
1416 if N = Right_Opnd (P) then
1417 if Present (Actions (P)) then
1418 Insert_List_After_And_Analyze
1419 (Last (Actions (P)), Ins_Actions);
1421 Set_Actions (P, Ins_Actions);
1422 Analyze_List (Actions (P));
1428 -- Then or Else operand of conditional expression. Add actions to
1429 -- Then_Actions or Else_Actions field as appropriate. The actions
1430 -- will be moved further out when the conditional is expanded.
1432 when N_Conditional_Expression =>
1434 ThenX : constant Node_Id := Next (First (Expressions (P)));
1435 ElseX : constant Node_Id := Next (ThenX);
1438 -- Actions belong to the then expression, temporarily
1439 -- place them as Then_Actions of the conditional expr.
1440 -- They will be moved to the proper place later when
1441 -- the conditional expression is expanded.
1444 if Present (Then_Actions (P)) then
1445 Insert_List_After_And_Analyze
1446 (Last (Then_Actions (P)), Ins_Actions);
1448 Set_Then_Actions (P, Ins_Actions);
1449 Analyze_List (Then_Actions (P));
1454 -- Actions belong to the else expression, temporarily
1455 -- place them as Else_Actions of the conditional expr.
1456 -- They will be moved to the proper place later when
1457 -- the conditional expression is expanded.
1459 elsif N = ElseX then
1460 if Present (Else_Actions (P)) then
1461 Insert_List_After_And_Analyze
1462 (Last (Else_Actions (P)), Ins_Actions);
1464 Set_Else_Actions (P, Ins_Actions);
1465 Analyze_List (Else_Actions (P));
1470 -- Actions belong to the condition. In this case they are
1471 -- unconditionally executed, and so we can continue the
1472 -- search for the proper insert point.
1479 -- Case of appearing in the condition of a while expression or
1480 -- elsif. We insert the actions into the Condition_Actions field.
1481 -- They will be moved further out when the while loop or elsif
1484 when N_Iteration_Scheme |
1487 if N = Condition (P) then
1488 if Present (Condition_Actions (P)) then
1489 Insert_List_After_And_Analyze
1490 (Last (Condition_Actions (P)), Ins_Actions);
1492 Set_Condition_Actions (P, Ins_Actions);
1494 -- Set the parent of the insert actions explicitly.
1495 -- This is not a syntactic field, but we need the
1496 -- parent field set, in particular so that freeze
1497 -- can understand that it is dealing with condition
1498 -- actions, and properly insert the freezing actions.
1500 Set_Parent (Ins_Actions, P);
1501 Analyze_List (Condition_Actions (P));
1507 -- Statements, declarations, pragmas, representation clauses.
1512 N_Procedure_Call_Statement |
1513 N_Statement_Other_Than_Procedure_Call |
1519 -- Representation_Clause
1522 N_Attribute_Definition_Clause |
1523 N_Enumeration_Representation_Clause |
1524 N_Record_Representation_Clause |
1528 N_Abstract_Subprogram_Declaration |
1530 N_Exception_Declaration |
1531 N_Exception_Renaming_Declaration |
1532 N_Formal_Object_Declaration |
1533 N_Formal_Subprogram_Declaration |
1534 N_Formal_Type_Declaration |
1535 N_Full_Type_Declaration |
1536 N_Function_Instantiation |
1537 N_Generic_Function_Renaming_Declaration |
1538 N_Generic_Package_Declaration |
1539 N_Generic_Package_Renaming_Declaration |
1540 N_Generic_Procedure_Renaming_Declaration |
1541 N_Generic_Subprogram_Declaration |
1542 N_Implicit_Label_Declaration |
1543 N_Incomplete_Type_Declaration |
1544 N_Number_Declaration |
1545 N_Object_Declaration |
1546 N_Object_Renaming_Declaration |
1548 N_Package_Body_Stub |
1549 N_Package_Declaration |
1550 N_Package_Instantiation |
1551 N_Package_Renaming_Declaration |
1552 N_Private_Extension_Declaration |
1553 N_Private_Type_Declaration |
1554 N_Procedure_Instantiation |
1555 N_Protected_Body_Stub |
1556 N_Protected_Type_Declaration |
1557 N_Single_Task_Declaration |
1559 N_Subprogram_Body_Stub |
1560 N_Subprogram_Declaration |
1561 N_Subprogram_Renaming_Declaration |
1562 N_Subtype_Declaration |
1565 N_Task_Type_Declaration |
1567 -- Freeze entity behaves like a declaration or statement
1571 -- Do not insert here if the item is not a list member (this
1572 -- happens for example with a triggering statement, and the
1573 -- proper approach is to insert before the entire select).
1575 if not Is_List_Member (P) then
1578 -- Do not insert if parent of P is an N_Component_Association
1579 -- node (i.e. we are in the context of an N_Aggregate node.
1580 -- In this case we want to insert before the entire aggregate.
1582 elsif Nkind (Parent (P)) = N_Component_Association then
1585 -- Do not insert if the parent of P is either an N_Variant
1586 -- node or an N_Record_Definition node, meaning in either
1587 -- case that P is a member of a component list, and that
1588 -- therefore the actions should be inserted outside the
1589 -- complete record declaration.
1591 elsif Nkind (Parent (P)) = N_Variant
1592 or else Nkind (Parent (P)) = N_Record_Definition
1596 -- Do not insert freeze nodes within the loop generated for
1597 -- an aggregate, because they may be elaborated too late for
1598 -- subsequent use in the back end: within a package spec the
1599 -- loop is part of the elaboration procedure and is only
1600 -- elaborated during the second pass.
1601 -- If the loop comes from source, or the entity is local to
1602 -- the loop itself it must remain within.
1604 elsif Nkind (Parent (P)) = N_Loop_Statement
1605 and then not Comes_From_Source (Parent (P))
1606 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
1608 Scope (Entity (First (Ins_Actions))) /= Current_Scope
1612 -- Otherwise we can go ahead and do the insertion
1614 elsif P = Wrapped_Node then
1615 Store_Before_Actions_In_Scope (Ins_Actions);
1619 Insert_List_Before_And_Analyze (P, Ins_Actions);
1623 -- A special case, N_Raise_xxx_Error can act either as a
1624 -- statement or a subexpression. We tell the difference
1625 -- by looking at the Etype. It is set to Standard_Void_Type
1626 -- in the statement case.
1629 N_Raise_xxx_Error =>
1630 if Etype (P) = Standard_Void_Type then
1631 if P = Wrapped_Node then
1632 Store_Before_Actions_In_Scope (Ins_Actions);
1634 Insert_List_Before_And_Analyze (P, Ins_Actions);
1639 -- In the subexpression case, keep climbing
1645 -- If a component association appears within a loop created for
1646 -- an array aggregate, attach the actions to the association so
1647 -- they can be subsequently inserted within the loop. For other
1648 -- component associations insert outside of the aggregate.
1650 -- The list of loop_actions can in turn generate additional ones,
1651 -- that are inserted before the associated node. If the associated
1652 -- node is outside the aggregate, the new actions are collected
1653 -- at the end of the loop actions, to respect the order in which
1654 -- they are to be elaborated.
1657 N_Component_Association =>
1658 if Nkind (Parent (P)) = N_Aggregate
1659 and then Present (Aggregate_Bounds (Parent (P)))
1660 and then Nkind (First (Choices (P))) = N_Others_Choice
1661 and then Nkind (First (Ins_Actions)) /= N_Freeze_Entity
1663 if No (Loop_Actions (P)) then
1664 Set_Loop_Actions (P, Ins_Actions);
1665 Analyze_List (Ins_Actions);
1669 Decl : Node_Id := Assoc_Node;
1672 -- Check whether these actions were generated
1673 -- by a declaration that is part of the loop_
1674 -- actions for the component_association.
1676 while Present (Decl) loop
1677 exit when Parent (Decl) = P
1678 and then Is_List_Member (Decl)
1680 List_Containing (Decl) = Loop_Actions (P);
1681 Decl := Parent (Decl);
1684 if Present (Decl) then
1685 Insert_List_Before_And_Analyze
1686 (Decl, Ins_Actions);
1688 Insert_List_After_And_Analyze
1689 (Last (Loop_Actions (P)), Ins_Actions);
1700 -- Another special case, an attribute denoting a procedure call
1703 N_Attribute_Reference =>
1704 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
1705 if P = Wrapped_Node then
1706 Store_Before_Actions_In_Scope (Ins_Actions);
1708 Insert_List_Before_And_Analyze (P, Ins_Actions);
1713 -- In the subexpression case, keep climbing
1719 -- For all other node types, keep climbing tree
1723 N_Accept_Alternative |
1724 N_Access_Definition |
1725 N_Access_Function_Definition |
1726 N_Access_Procedure_Definition |
1727 N_Access_To_Object_Definition |
1730 N_Case_Statement_Alternative |
1731 N_Character_Literal |
1732 N_Compilation_Unit |
1733 N_Compilation_Unit_Aux |
1734 N_Component_Clause |
1735 N_Component_Declaration |
1737 N_Constrained_Array_Definition |
1738 N_Decimal_Fixed_Point_Definition |
1739 N_Defining_Character_Literal |
1740 N_Defining_Identifier |
1741 N_Defining_Operator_Symbol |
1742 N_Defining_Program_Unit_Name |
1743 N_Delay_Alternative |
1744 N_Delta_Constraint |
1745 N_Derived_Type_Definition |
1747 N_Digits_Constraint |
1748 N_Discriminant_Association |
1749 N_Discriminant_Specification |
1751 N_Entry_Body_Formal_Part |
1752 N_Entry_Call_Alternative |
1753 N_Entry_Declaration |
1754 N_Entry_Index_Specification |
1755 N_Enumeration_Type_Definition |
1757 N_Exception_Handler |
1759 N_Explicit_Dereference |
1760 N_Extension_Aggregate |
1761 N_Floating_Point_Definition |
1762 N_Formal_Decimal_Fixed_Point_Definition |
1763 N_Formal_Derived_Type_Definition |
1764 N_Formal_Discrete_Type_Definition |
1765 N_Formal_Floating_Point_Definition |
1766 N_Formal_Modular_Type_Definition |
1767 N_Formal_Ordinary_Fixed_Point_Definition |
1768 N_Formal_Package_Declaration |
1769 N_Formal_Private_Type_Definition |
1770 N_Formal_Signed_Integer_Type_Definition |
1772 N_Function_Specification |
1773 N_Generic_Association |
1774 N_Handled_Sequence_Of_Statements |
1777 N_Index_Or_Discriminant_Constraint |
1778 N_Indexed_Component |
1782 N_Loop_Parameter_Specification |
1784 N_Modular_Type_Definition |
1810 N_Op_Shift_Right_Arithmetic |
1814 N_Ordinary_Fixed_Point_Definition |
1816 N_Package_Specification |
1817 N_Parameter_Association |
1818 N_Parameter_Specification |
1819 N_Pragma_Argument_Association |
1820 N_Procedure_Specification |
1822 N_Protected_Definition |
1823 N_Qualified_Expression |
1825 N_Range_Constraint |
1827 N_Real_Range_Specification |
1828 N_Record_Definition |
1830 N_Selected_Component |
1831 N_Signed_Integer_Type_Definition |
1832 N_Single_Protected_Declaration |
1836 N_Subtype_Indication |
1839 N_Terminate_Alternative |
1840 N_Triggering_Alternative |
1842 N_Unchecked_Expression |
1843 N_Unchecked_Type_Conversion |
1844 N_Unconstrained_Array_Definition |
1847 N_Use_Package_Clause |
1851 N_Validate_Unchecked_Conversion |
1859 -- Make sure that inserted actions stay in the transient scope
1861 if P = Wrapped_Node then
1862 Store_Before_Actions_In_Scope (Ins_Actions);
1866 -- If we fall through above tests, keep climbing tree
1870 if Nkind (Parent (N)) = N_Subunit then
1872 -- This is the proper body corresponding to a stub. Insertion
1873 -- must be done at the point of the stub, which is in the decla-
1874 -- tive part of the parent unit.
1876 P := Corresponding_Stub (Parent (N));
1885 -- Version with check(s) suppressed
1887 procedure Insert_Actions
1888 (Assoc_Node : Node_Id; Ins_Actions : List_Id; Suppress : Check_Id)
1891 if Suppress = All_Checks then
1893 Svg : constant Suppress_Record := Scope_Suppress;
1896 Scope_Suppress := (others => True);
1897 Insert_Actions (Assoc_Node, Ins_Actions);
1898 Scope_Suppress := Svg;
1903 Svg : constant Boolean := Get_Scope_Suppress (Suppress);
1906 Set_Scope_Suppress (Suppress, True);
1907 Insert_Actions (Assoc_Node, Ins_Actions);
1908 Set_Scope_Suppress (Suppress, Svg);
1913 --------------------------
1914 -- Insert_Actions_After --
1915 --------------------------
1917 procedure Insert_Actions_After
1918 (Assoc_Node : Node_Id;
1919 Ins_Actions : List_Id)
1922 if Scope_Is_Transient
1923 and then Assoc_Node = Node_To_Be_Wrapped
1925 Store_After_Actions_In_Scope (Ins_Actions);
1927 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
1929 end Insert_Actions_After;
1931 ---------------------------------
1932 -- Insert_Library_Level_Action --
1933 ---------------------------------
1935 procedure Insert_Library_Level_Action (N : Node_Id) is
1936 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
1939 New_Scope (Cunit_Entity (Main_Unit));
1941 if No (Actions (Aux)) then
1942 Set_Actions (Aux, New_List (N));
1944 Append (N, Actions (Aux));
1949 end Insert_Library_Level_Action;
1951 ----------------------------------
1952 -- Insert_Library_Level_Actions --
1953 ----------------------------------
1955 procedure Insert_Library_Level_Actions (L : List_Id) is
1956 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
1959 if Is_Non_Empty_List (L) then
1960 New_Scope (Cunit_Entity (Main_Unit));
1962 if No (Actions (Aux)) then
1963 Set_Actions (Aux, L);
1966 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
1971 end Insert_Library_Level_Actions;
1973 ----------------------
1974 -- Inside_Init_Proc --
1975 ----------------------
1977 function Inside_Init_Proc return Boolean is
1982 while S /= Standard_Standard loop
1983 if Chars (S) = Name_uInit_Proc then
1991 end Inside_Init_Proc;
1993 --------------------------------
1994 -- Is_Ref_To_Bit_Packed_Array --
1995 --------------------------------
1997 function Is_Ref_To_Bit_Packed_Array (P : Node_Id) return Boolean is
2002 if Nkind (P) = N_Indexed_Component
2004 Nkind (P) = N_Selected_Component
2006 if Is_Bit_Packed_Array (Etype (Prefix (P))) then
2009 Result := Is_Ref_To_Bit_Packed_Array (Prefix (P));
2012 if Result and then Nkind (P) = N_Indexed_Component then
2013 Expr := First (Expressions (P));
2015 while Present (Expr) loop
2016 Force_Evaluation (Expr);
2026 end Is_Ref_To_Bit_Packed_Array;
2028 --------------------------------
2029 -- Is_Ref_To_Bit_Packed_Slce --
2030 --------------------------------
2032 function Is_Ref_To_Bit_Packed_Slice (P : Node_Id) return Boolean is
2034 if Nkind (P) = N_Slice
2035 and then Is_Bit_Packed_Array (Etype (Prefix (P)))
2039 elsif Nkind (P) = N_Indexed_Component
2041 Nkind (P) = N_Selected_Component
2043 return Is_Ref_To_Bit_Packed_Slice (Prefix (P));
2048 end Is_Ref_To_Bit_Packed_Slice;
2050 -----------------------
2051 -- Is_Renamed_Object --
2052 -----------------------
2054 function Is_Renamed_Object (N : Node_Id) return Boolean is
2055 Pnod : constant Node_Id := Parent (N);
2056 Kind : constant Node_Kind := Nkind (Pnod);
2059 if Kind = N_Object_Renaming_Declaration then
2062 elsif Kind = N_Indexed_Component
2063 or else Kind = N_Selected_Component
2065 return Is_Renamed_Object (Pnod);
2070 end Is_Renamed_Object;
2072 ----------------------------
2073 -- Is_Untagged_Derivation --
2074 ----------------------------
2076 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
2078 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
2080 (Is_Private_Type (T) and then Present (Full_View (T))
2081 and then not Is_Tagged_Type (Full_View (T))
2082 and then Is_Derived_Type (Full_View (T))
2083 and then Etype (Full_View (T)) /= T);
2085 end Is_Untagged_Derivation;
2087 --------------------
2088 -- Kill_Dead_Code --
2089 --------------------
2091 procedure Kill_Dead_Code (N : Node_Id) is
2094 Remove_Handler_Entries (N);
2095 Remove_Warning_Messages (N);
2097 -- Recurse into block statements to process declarations/statements
2099 if Nkind (N) = N_Block_Statement then
2100 Kill_Dead_Code (Declarations (N));
2101 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
2103 -- Recurse into composite statement to kill individual statements,
2104 -- in particular instantiations.
2106 elsif Nkind (N) = N_If_Statement then
2107 Kill_Dead_Code (Then_Statements (N));
2108 Kill_Dead_Code (Elsif_Parts (N));
2109 Kill_Dead_Code (Else_Statements (N));
2111 elsif Nkind (N) = N_Loop_Statement then
2112 Kill_Dead_Code (Statements (N));
2114 elsif Nkind (N) = N_Case_Statement then
2116 Alt : Node_Id := First (Alternatives (N));
2119 while Present (Alt) loop
2120 Kill_Dead_Code (Statements (Alt));
2125 -- Deal with dead instances caused by deleting instantiations
2127 elsif Nkind (N) in N_Generic_Instantiation then
2128 Remove_Dead_Instance (N);
2135 -- Case where argument is a list of nodes to be killed
2137 procedure Kill_Dead_Code (L : List_Id) is
2141 if Is_Non_Empty_List (L) then
2143 N := Remove_Head (L);
2150 ------------------------
2151 -- Known_Non_Negative --
2152 ------------------------
2154 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
2156 if Is_OK_Static_Expression (Opnd)
2157 and then Expr_Value (Opnd) >= 0
2163 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
2167 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
2170 end Known_Non_Negative;
2172 -----------------------------
2173 -- Make_CW_Equivalent_Type --
2174 -----------------------------
2176 -- Create a record type used as an equivalent of any member
2177 -- of the class which takes its size from exp.
2179 -- Generate the following code:
2181 -- type Equiv_T is record
2182 -- _parent : T (List of discriminant constaints taken from Exp);
2183 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'size) / Storage_Unit);
2186 function Make_CW_Equivalent_Type
2191 Loc : constant Source_Ptr := Sloc (E);
2192 Root_Typ : constant Entity_Id := Root_Type (T);
2193 Equiv_Type : Entity_Id;
2194 Range_Type : Entity_Id;
2195 Str_Type : Entity_Id;
2196 List_Def : List_Id := Empty_List;
2197 Constr_Root : Entity_Id;
2201 if not Has_Discriminants (Root_Typ) then
2202 Constr_Root := Root_Typ;
2205 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2207 -- subtype cstr__n is T (List of discr constraints taken from Exp)
2209 Append_To (List_Def,
2210 Make_Subtype_Declaration (Loc,
2211 Defining_Identifier => Constr_Root,
2212 Subtype_Indication =>
2213 Make_Subtype_From_Expr (E, Root_Typ)));
2216 -- subtype rg__xx is Storage_Offset range
2217 -- (Expr'size - typ'size) / Storage_Unit
2219 Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
2222 Make_Op_Subtract (Loc,
2224 Make_Attribute_Reference (Loc,
2225 Prefix => OK_Convert_To (T, Duplicate_Subexpr (E)),
2226 Attribute_Name => Name_Size),
2228 Make_Attribute_Reference (Loc,
2229 Prefix => New_Reference_To (Constr_Root, Loc),
2230 Attribute_Name => Name_Size));
2232 Set_Paren_Count (Sizexpr, 1);
2234 Append_To (List_Def,
2235 Make_Subtype_Declaration (Loc,
2236 Defining_Identifier => Range_Type,
2237 Subtype_Indication =>
2238 Make_Subtype_Indication (Loc,
2239 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Offset), Loc),
2240 Constraint => Make_Range_Constraint (Loc,
2243 Low_Bound => Make_Integer_Literal (Loc, 1),
2245 Make_Op_Divide (Loc,
2246 Left_Opnd => Sizexpr,
2247 Right_Opnd => Make_Integer_Literal (Loc,
2248 Intval => System_Storage_Unit)))))));
2250 -- subtype str__nn is Storage_Array (rg__x);
2252 Str_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
2253 Append_To (List_Def,
2254 Make_Subtype_Declaration (Loc,
2255 Defining_Identifier => Str_Type,
2256 Subtype_Indication =>
2257 Make_Subtype_Indication (Loc,
2258 Subtype_Mark => New_Reference_To (RTE (RE_Storage_Array), Loc),
2260 Make_Index_Or_Discriminant_Constraint (Loc,
2262 New_List (New_Reference_To (Range_Type, Loc))))));
2264 -- type Equiv_T is record
2269 Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
2271 -- Avoid the generation of an init procedure
2273 Set_Is_Frozen (Equiv_Type);
2275 Set_Ekind (Equiv_Type, E_Record_Type);
2276 Set_Parent_Subtype (Equiv_Type, Constr_Root);
2278 Append_To (List_Def,
2279 Make_Full_Type_Declaration (Loc,
2280 Defining_Identifier => Equiv_Type,
2283 Make_Record_Definition (Loc,
2284 Component_List => Make_Component_List (Loc,
2285 Component_Items => New_List (
2286 Make_Component_Declaration (Loc,
2287 Defining_Identifier =>
2288 Make_Defining_Identifier (Loc, Name_uParent),
2289 Subtype_Indication => New_Reference_To (Constr_Root, Loc)),
2291 Make_Component_Declaration (Loc,
2292 Defining_Identifier =>
2293 Make_Defining_Identifier (Loc,
2294 Chars => New_Internal_Name ('C')),
2295 Subtype_Indication => New_Reference_To (Str_Type, Loc))),
2296 Variant_Part => Empty))));
2298 Insert_Actions (E, List_Def);
2300 end Make_CW_Equivalent_Type;
2302 ------------------------
2303 -- Make_Literal_Range --
2304 ------------------------
2306 function Make_Literal_Range
2308 Literal_Typ : Entity_Id;
2309 Index_Typ : Entity_Id)
2316 Make_Attribute_Reference (Loc,
2317 Prefix => New_Occurrence_Of (Index_Typ, Loc),
2318 Attribute_Name => Name_First),
2321 Make_Op_Subtract (Loc,
2325 Make_Attribute_Reference (Loc,
2326 Prefix => New_Occurrence_Of (Index_Typ, Loc),
2327 Attribute_Name => Name_First),
2328 Right_Opnd => Make_Integer_Literal (Loc,
2329 String_Literal_Length (Literal_Typ))),
2330 Right_Opnd => Make_Integer_Literal (Loc, 1)));
2331 end Make_Literal_Range;
2333 ----------------------------
2334 -- Make_Subtype_From_Expr --
2335 ----------------------------
2337 -- 1. If Expr is an uncontrained array expression, creates
2338 -- Unc_Type(Expr'first(1)..Expr'Last(1),..., Expr'first(n)..Expr'last(n))
2340 -- 2. If Expr is a unconstrained discriminated type expression, creates
2341 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
2343 -- 3. If Expr is class-wide, creates an implicit class wide subtype
2345 function Make_Subtype_From_Expr
2347 Unc_Typ : Entity_Id)
2350 Loc : constant Source_Ptr := Sloc (E);
2351 List_Constr : List_Id := New_List;
2354 Full_Subtyp : Entity_Id;
2355 Priv_Subtyp : Entity_Id;
2360 if Is_Private_Type (Unc_Typ)
2361 and then Has_Unknown_Discriminants (Unc_Typ)
2363 -- Prepare the subtype completion
2365 Utyp := Underlying_Type (Unc_Typ);
2366 Full_Subtyp := Make_Defining_Identifier (Loc,
2367 New_Internal_Name ('C'));
2368 Full_Exp := Unchecked_Convert_To (Utyp, Duplicate_Subexpr (E));
2369 Set_Parent (Full_Exp, Parent (E));
2372 Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
2375 Make_Subtype_Declaration (Loc,
2376 Defining_Identifier => Full_Subtyp,
2377 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
2379 -- Define the dummy private subtype
2381 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
2382 Set_Etype (Priv_Subtyp, Unc_Typ);
2383 Set_Scope (Priv_Subtyp, Full_Subtyp);
2384 Set_Is_Constrained (Priv_Subtyp);
2385 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
2386 Set_Is_Itype (Priv_Subtyp);
2387 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
2389 if Is_Tagged_Type (Priv_Subtyp) then
2391 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
2392 Set_Primitive_Operations (Priv_Subtyp,
2393 Primitive_Operations (Unc_Typ));
2396 Set_Full_View (Priv_Subtyp, Full_Subtyp);
2398 return New_Reference_To (Priv_Subtyp, Loc);
2400 elsif Is_Array_Type (Unc_Typ) then
2401 for J in 1 .. Number_Dimensions (Unc_Typ) loop
2402 Append_To (List_Constr,
2405 Make_Attribute_Reference (Loc,
2406 Prefix => Duplicate_Subexpr (E),
2407 Attribute_Name => Name_First,
2408 Expressions => New_List (
2409 Make_Integer_Literal (Loc, J))),
2411 Make_Attribute_Reference (Loc,
2412 Prefix => Duplicate_Subexpr (E),
2413 Attribute_Name => Name_Last,
2414 Expressions => New_List (
2415 Make_Integer_Literal (Loc, J)))));
2418 elsif Is_Class_Wide_Type (Unc_Typ) then
2420 CW_Subtype : Entity_Id;
2421 EQ_Typ : Entity_Id := Empty;
2424 -- A class-wide equivalent type is not needed when Java_VM
2425 -- because the JVM back end handles the class-wide object
2426 -- intialization itself (and doesn't need or want the
2427 -- additional intermediate type to handle the assignment).
2429 if Expander_Active and then not Java_VM then
2430 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
2433 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
2434 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
2435 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
2437 return New_Occurrence_Of (CW_Subtype, Loc);
2441 D := First_Discriminant (Unc_Typ);
2442 while (Present (D)) loop
2444 Append_To (List_Constr,
2445 Make_Selected_Component (Loc,
2446 Prefix => Duplicate_Subexpr (E),
2447 Selector_Name => New_Reference_To (D, Loc)));
2449 Next_Discriminant (D);
2454 Make_Subtype_Indication (Loc,
2455 Subtype_Mark => New_Reference_To (Unc_Typ, Loc),
2457 Make_Index_Or_Discriminant_Constraint (Loc,
2458 Constraints => List_Constr));
2459 end Make_Subtype_From_Expr;
2461 -----------------------------
2462 -- May_Generate_Large_Temp --
2463 -----------------------------
2465 -- At the current time, the only types that we return False for (i.e.
2466 -- where we decide we know they cannot generate large temps) are ones
2467 -- where we know the size is 128 bits or less at compile time, and we
2468 -- are still not doing a thorough job on arrays and records ???
2470 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
2472 if not Stack_Checking_Enabled then
2475 elsif not Size_Known_At_Compile_Time (Typ) then
2478 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
2481 elsif Is_Array_Type (Typ)
2482 and then Present (Packed_Array_Type (Typ))
2484 return May_Generate_Large_Temp (Packed_Array_Type (Typ));
2486 -- We could do more here to find other small types ???
2491 end May_Generate_Large_Temp;
2493 ---------------------
2494 -- Must_Be_Aligned --
2495 ---------------------
2497 function Must_Be_Aligned (Obj : Node_Id) return Boolean is
2498 Typ : constant Entity_Id := Etype (Obj);
2500 function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean;
2501 -- If the component is in a record that contains previous packed
2502 -- components, consider it unaligned because the back-end might
2503 -- choose to pack the rest of the record. Lead to less efficient code,
2504 -- but safer vis-a-vis of back-end choices.
2506 function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean is
2507 Rec_Type : constant Entity_Id := Scope (Comp);
2508 Prev_Comp : Entity_Id;
2510 Prev_Comp := First_Entity (Rec_Type);
2511 while Present (Prev_Comp) loop
2512 if Is_Packed (Etype (Prev_Comp)) then
2515 elsif Prev_Comp = Comp then
2519 Next_Entity (Prev_Comp);
2523 end In_Partially_Packed_Record;
2525 -- If object is strictly aligned, we can quit now
2527 if Strict_Alignment (Typ) then
2530 -- Case of subscripted array reference
2532 elsif Nkind (Obj) = N_Indexed_Component then
2534 -- If we have a pointer to an array, then this is definitely
2535 -- aligned, because pointers always point to aligned versions.
2537 if Is_Access_Type (Etype (Prefix (Obj))) then
2540 -- Otherwise, go look at the prefix
2543 return Must_Be_Aligned (Prefix (Obj));
2546 -- Case of record field
2548 elsif Nkind (Obj) = N_Selected_Component then
2550 -- What is significant here is whether the record type is packed
2552 if Is_Record_Type (Etype (Prefix (Obj)))
2553 and then Is_Packed (Etype (Prefix (Obj)))
2557 -- Or the component has a component clause which might cause
2558 -- the component to become unaligned (we can't tell if the
2559 -- backend is doing alignment computations).
2561 elsif Present (Component_Clause (Entity (Selector_Name (Obj)))) then
2564 elsif In_Partially_Packed_Record (Entity (Selector_Name (Obj))) then
2567 -- In all other cases, go look at prefix
2570 return Must_Be_Aligned (Prefix (Obj));
2573 -- If not selected or indexed component, must be aligned
2578 end Must_Be_Aligned;
2580 ----------------------------
2581 -- New_Class_Wide_Subtype --
2582 ----------------------------
2584 function New_Class_Wide_Subtype
2585 (CW_Typ : Entity_Id;
2589 Res : Entity_Id := Create_Itype (E_Void, N);
2590 Res_Name : constant Name_Id := Chars (Res);
2591 Res_Scope : Entity_Id := Scope (Res);
2594 Copy_Node (CW_Typ, Res);
2595 Set_Sloc (Res, Sloc (N));
2597 Set_Associated_Node_For_Itype (Res, N);
2598 Set_Is_Public (Res, False); -- By default, may be changed below.
2599 Set_Public_Status (Res);
2600 Set_Chars (Res, Res_Name);
2601 Set_Scope (Res, Res_Scope);
2602 Set_Ekind (Res, E_Class_Wide_Subtype);
2603 Set_Next_Entity (Res, Empty);
2604 Set_Etype (Res, Base_Type (CW_Typ));
2605 Set_Freeze_Node (Res, Empty);
2607 end New_Class_Wide_Subtype;
2609 -------------------------
2610 -- Remove_Side_Effects --
2611 -------------------------
2613 procedure Remove_Side_Effects
2615 Name_Req : Boolean := False;
2616 Variable_Ref : Boolean := False)
2618 Loc : constant Source_Ptr := Sloc (Exp);
2619 Exp_Type : constant Entity_Id := Etype (Exp);
2620 Svg_Suppress : constant Suppress_Record := Scope_Suppress;
2622 Ref_Type : Entity_Id;
2624 Ptr_Typ_Decl : Node_Id;
2628 function Side_Effect_Free (N : Node_Id) return Boolean;
2629 -- Determines if the tree N represents an expession that is known
2630 -- not to have side effects, and for which no processing is required.
2632 function Side_Effect_Free (L : List_Id) return Boolean;
2633 -- Determines if all elements of the list L are side effect free
2635 function Mutable_Dereference (N : Node_Id) return Boolean;
2636 -- If a selected component involves an implicit dereference and
2637 -- the type of the prefix is not an_access_to_constant, the node
2638 -- must be evaluated because it may be affected by a subsequent
2641 -------------------------
2642 -- Mutable_Dereference --
2643 -------------------------
2645 function Mutable_Dereference (N : Node_Id) return Boolean is
2647 return Nkind (N) = N_Selected_Component
2648 and then Is_Access_Type (Etype (Prefix (N)))
2649 and then not Is_Access_Constant (Etype (Prefix (N)))
2650 and then Variable_Ref;
2651 end Mutable_Dereference;
2653 ----------------------
2654 -- Side_Effect_Free --
2655 ----------------------
2657 function Side_Effect_Free (N : Node_Id) return Boolean is
2658 K : constant Node_Kind := Nkind (N);
2661 -- Note on checks that could raise Constraint_Error. Strictly, if
2662 -- we take advantage of 11.6, these checks do not count as side
2663 -- effects. However, we would just as soon consider that they are
2664 -- side effects, since the backend CSE does not work very well on
2665 -- expressions which can raise Constraint_Error. On the other
2666 -- hand, if we do not consider them to be side effect free, then
2667 -- we get some awkward expansions in -gnato mode, resulting in
2668 -- code insertions at a point where we do not have a clear model
2669 -- for performing the insertions. See 4908-002/comment for details.
2671 -- An attribute reference is side effect free if its expressions
2672 -- are side effect free and its prefix is (could be a dereference
2673 -- or an indexed retrieval for example).
2675 if K = N_Attribute_Reference then
2676 return Side_Effect_Free (Expressions (N))
2677 and then (Is_Entity_Name (Prefix (N))
2678 or else Side_Effect_Free (Prefix (N)));
2680 -- An entity is side effect free unless it is a function call, or
2681 -- a reference to a volatile variable and Name_Req is False. If
2682 -- Name_Req is True then we can't help returning a name which
2683 -- effectively allows multiple references in any case.
2685 elsif Is_Entity_Name (N)
2686 and then Ekind (Entity (N)) /= E_Function
2687 and then (not Is_Volatile (Entity (N)) or else Name_Req)
2689 -- If the entity is a constant, it is definitely side effect
2690 -- free. Note that the test of Is_Variable (N) below might
2691 -- be expected to catch this case, but it does not, because
2692 -- this test goes to the original tree, and we may have
2693 -- already rewritten a variable node with a constant as
2694 -- a result of an earlier Force_Evaluation call.
2696 if Ekind (Entity (N)) = E_Constant then
2699 -- If the Variable_Ref flag is set, any variable reference is
2700 -- is considered a side-effect
2702 elsif Variable_Ref then
2703 return not Is_Variable (N);
2709 -- A value known at compile time is always side effect free
2711 elsif Compile_Time_Known_Value (N) then
2714 -- Literals are always side-effect free
2716 elsif (K = N_Integer_Literal
2717 or else K = N_Real_Literal
2718 or else K = N_Character_Literal
2719 or else K = N_String_Literal
2721 and then not Raises_Constraint_Error (N)
2725 -- A type conversion or qualification is side effect free if the
2726 -- expression to be converted is side effect free.
2728 elsif K = N_Type_Conversion or else K = N_Qualified_Expression then
2729 return Side_Effect_Free (Expression (N));
2731 -- An unchecked type conversion is never side effect free since we
2732 -- need to check whether it is safe.
2733 -- effect free if its argument is side effect free.
2735 elsif K = N_Unchecked_Type_Conversion then
2736 if Safe_Unchecked_Type_Conversion (N) then
2737 return Side_Effect_Free (Expression (N));
2742 -- A unary operator is side effect free if the operand
2743 -- is side effect free.
2745 elsif K in N_Unary_Op then
2746 return Side_Effect_Free (Right_Opnd (N));
2748 -- A binary operator is side effect free if and both operands
2749 -- are side effect free.
2751 elsif K in N_Binary_Op then
2752 return Side_Effect_Free (Left_Opnd (N))
2753 and then Side_Effect_Free (Right_Opnd (N));
2755 -- An explicit dereference or selected component is side effect
2756 -- free if its prefix is side effect free.
2758 elsif K = N_Explicit_Dereference
2759 or else K = N_Selected_Component
2761 return Side_Effect_Free (Prefix (N))
2762 and then not Mutable_Dereference (Prefix (N));
2764 -- An indexed component can be copied if the prefix is copyable
2765 -- and all the indexing expressions are copyable and there is
2766 -- no access check and no range checks.
2768 elsif K = N_Indexed_Component then
2769 return Side_Effect_Free (Prefix (N))
2770 and then Side_Effect_Free (Expressions (N));
2772 elsif K = N_Unchecked_Expression then
2773 return Side_Effect_Free (Expression (N));
2775 -- A call to _rep_to_pos is side effect free, since we generate
2776 -- this pure function call ourselves. Moreover it is critically
2777 -- important to make this exception, since otherwise we can
2778 -- have discriminants in array components which don't look
2779 -- side effect free in the case of an array whose index type
2780 -- is an enumeration type with an enumeration rep clause.
2782 elsif K = N_Function_Call
2783 and then Nkind (Name (N)) = N_Identifier
2784 and then Chars (Name (N)) = Name_uRep_To_Pos
2788 -- We consider that anything else has side effects. This is a bit
2789 -- crude, but we are pretty close for most common cases, and we
2790 -- are certainly correct (i.e. we never return True when the
2791 -- answer should be False).
2796 end Side_Effect_Free;
2798 function Side_Effect_Free (L : List_Id) return Boolean is
2802 if L = No_List or else L = Error_List then
2808 while Present (N) loop
2809 if not Side_Effect_Free (N) then
2818 end Side_Effect_Free;
2820 -- Start of processing for Remove_Side_Effects
2823 -- If we are side effect free already or expansion is disabled,
2824 -- there is nothing to do.
2826 if Side_Effect_Free (Exp) or else not Expander_Active then
2830 -- All the must not have any checks
2832 Scope_Suppress := (others => True);
2834 -- If the expression has the form v.all then we can just capture
2835 -- the pointer, and then do an explicit dereference on the result.
2837 if Nkind (Exp) = N_Explicit_Dereference then
2839 Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2841 Make_Explicit_Dereference (Loc, New_Reference_To (Def_Id, Loc));
2844 Make_Object_Declaration (Loc,
2845 Defining_Identifier => Def_Id,
2846 Object_Definition =>
2847 New_Reference_To (Etype (Prefix (Exp)), Loc),
2848 Constant_Present => True,
2849 Expression => Relocate_Node (Prefix (Exp))));
2851 -- If this is a type conversion, leave the type conversion and remove
2852 -- the side effects in the expression. This is important in several
2853 -- circumstances: for change of representations, and also when this
2854 -- is a view conversion to a smaller object, where gigi can end up
2855 -- its own temporary of the wrong size.
2856 -- ??? this transformation is inhibited for elementary types that are
2857 -- not involved in a change of representation because it causes
2858 -- regressions that are not fully understood yet.
2860 elsif Nkind (Exp) = N_Type_Conversion
2861 and then (not Is_Elementary_Type (Underlying_Type (Exp_Type))
2862 or else Nkind (Parent (Exp)) = N_Assignment_Statement)
2864 Remove_Side_Effects (Expression (Exp), Variable_Ref);
2865 Scope_Suppress := Svg_Suppress;
2868 -- For expressions that denote objects, we can use a renaming scheme.
2869 -- We skip using this if we have a volatile variable and we do not
2870 -- have Nam_Req set true (see comments above for Side_Effect_Free).
2871 -- We also skip this scheme for class-wide expressions in order to
2872 -- avoid recursive expension (see Expand_N_Object_Renaming_Declaration)
2873 -- If the object is a function call, we need to create a temporary and
2876 elsif Is_Object_Reference (Exp)
2877 and then Nkind (Exp) /= N_Function_Call
2878 and then not Variable_Ref
2880 or else not Is_Entity_Name (Exp)
2881 or else not Is_Volatile (Entity (Exp)))
2882 and then not Is_Class_Wide_Type (Exp_Type)
2884 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2886 if Nkind (Exp) = N_Selected_Component
2887 and then Nkind (Prefix (Exp)) = N_Function_Call
2888 and then Is_Array_Type (Etype (Exp))
2890 -- Avoid generating a variable-sized temporary, by generating
2891 -- the renaming declaration just for the function call. The
2892 -- transformation could be refined to apply only when the array
2893 -- component is constrained by a discriminant???
2896 Make_Selected_Component (Loc,
2897 Prefix => New_Occurrence_Of (Def_Id, Loc),
2898 Selector_Name => Selector_Name (Exp));
2901 Make_Object_Renaming_Declaration (Loc,
2902 Defining_Identifier => Def_Id,
2904 New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
2905 Name => Relocate_Node (Prefix (Exp))));
2907 Res := New_Reference_To (Def_Id, Loc);
2910 Make_Object_Renaming_Declaration (Loc,
2911 Defining_Identifier => Def_Id,
2912 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
2913 Name => Relocate_Node (Exp)));
2916 -- If it is a scalar type, just make a copy.
2918 elsif Is_Elementary_Type (Exp_Type) then
2919 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2920 Set_Etype (Def_Id, Exp_Type);
2921 Res := New_Reference_To (Def_Id, Loc);
2924 Make_Object_Declaration (Loc,
2925 Defining_Identifier => Def_Id,
2926 Object_Definition => New_Reference_To (Exp_Type, Loc),
2927 Constant_Present => True,
2928 Expression => Relocate_Node (Exp));
2930 Set_Assignment_OK (E);
2931 Insert_Action (Exp, E);
2933 -- If this is an unchecked conversion that Gigi can't handle, make
2934 -- a copy or a use a renaming to capture the value.
2936 elsif (Nkind (Exp) = N_Unchecked_Type_Conversion
2937 and then not Safe_Unchecked_Type_Conversion (Exp))
2939 if Controlled_Type (Etype (Exp)) then
2940 -- Use a renaming to capture the expression, rather than create
2941 -- a controlled temporary.
2943 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2944 Res := New_Reference_To (Def_Id, Loc);
2947 Make_Object_Renaming_Declaration (Loc,
2948 Defining_Identifier => Def_Id,
2949 Subtype_Mark => New_Reference_To (Exp_Type, Loc),
2950 Name => Relocate_Node (Exp)));
2953 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2954 Set_Etype (Def_Id, Exp_Type);
2955 Res := New_Reference_To (Def_Id, Loc);
2958 Make_Object_Declaration (Loc,
2959 Defining_Identifier => Def_Id,
2960 Object_Definition => New_Reference_To (Exp_Type, Loc),
2961 Constant_Present => True,
2962 Expression => Relocate_Node (Exp));
2964 Set_Assignment_OK (E);
2965 Insert_Action (Exp, E);
2968 -- Otherwise we generate a reference to the value
2971 Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
2974 Make_Full_Type_Declaration (Loc,
2975 Defining_Identifier => Ref_Type,
2977 Make_Access_To_Object_Definition (Loc,
2978 All_Present => True,
2979 Subtype_Indication =>
2980 New_Reference_To (Exp_Type, Loc)));
2983 Insert_Action (Exp, Ptr_Typ_Decl);
2985 Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
2986 Set_Etype (Def_Id, Exp_Type);
2989 Make_Explicit_Dereference (Loc,
2990 Prefix => New_Reference_To (Def_Id, Loc));
2992 if Nkind (E) = N_Explicit_Dereference then
2993 New_Exp := Relocate_Node (Prefix (E));
2995 E := Relocate_Node (E);
2996 New_Exp := Make_Reference (Loc, E);
2999 if Nkind (E) = N_Aggregate and then Expansion_Delayed (E) then
3000 Set_Expansion_Delayed (E, False);
3001 Set_Analyzed (E, False);
3005 Make_Object_Declaration (Loc,
3006 Defining_Identifier => Def_Id,
3007 Object_Definition => New_Reference_To (Ref_Type, Loc),
3008 Expression => New_Exp));
3011 -- Preserve the Assignment_OK flag in all copies, since at least
3012 -- one copy may be used in a context where this flag must be set
3013 -- (otherwise why would the flag be set in the first place).
3015 Set_Assignment_OK (Res, Assignment_OK (Exp));
3017 -- Finally rewrite the original expression and we are done
3020 Analyze_And_Resolve (Exp, Exp_Type);
3021 Scope_Suppress := Svg_Suppress;
3022 end Remove_Side_Effects;
3024 ------------------------------------
3025 -- Safe_Unchecked_Type_Conversion --
3026 ------------------------------------
3028 -- Note: this function knows quite a bit about the exact requirements
3029 -- of Gigi with respect to unchecked type conversions, and its code
3030 -- must be coordinated with any changes in Gigi in this area.
3032 -- The above requirements should be documented in Sinfo ???
3034 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
3039 Pexp : constant Node_Id := Parent (Exp);
3042 -- If the expression is the RHS of an assignment or object declaration
3043 -- we are always OK because there will always be a target.
3045 -- Object renaming declarations, (generated for view conversions of
3046 -- actuals in inlined calls), like object declarations, provide an
3047 -- explicit type, and are safe as well.
3049 if (Nkind (Pexp) = N_Assignment_Statement
3050 and then Expression (Pexp) = Exp)
3051 or else Nkind (Pexp) = N_Object_Declaration
3052 or else Nkind (Pexp) = N_Object_Renaming_Declaration
3056 -- If the expression is the prefix of an N_Selected_Component
3057 -- we should also be OK because GCC knows to look inside the
3058 -- conversion except if the type is discriminated. We assume
3059 -- that we are OK anyway if the type is not set yet or if it is
3060 -- controlled since we can't afford to introduce a temporary in
3063 elsif Nkind (Pexp) = N_Selected_Component
3064 and then Prefix (Pexp) = Exp
3066 if No (Etype (Pexp)) then
3070 not Has_Discriminants (Etype (Pexp))
3071 or else Is_Constrained (Etype (Pexp));
3075 -- Set the output type, this comes from Etype if it is set, otherwise
3076 -- we take it from the subtype mark, which we assume was already
3079 if Present (Etype (Exp)) then
3080 Otyp := Etype (Exp);
3082 Otyp := Entity (Subtype_Mark (Exp));
3085 -- The input type always comes from the expression, and we assume
3086 -- this is indeed always analyzed, so we can simply get the Etype.
3088 Ityp := Etype (Expression (Exp));
3090 -- Initialize alignments to unknown so far
3095 -- Replace a concurrent type by its corresponding record type
3096 -- and each type by its underlying type and do the tests on those.
3097 -- The original type may be a private type whose completion is a
3098 -- concurrent type, so find the underlying type first.
3100 if Present (Underlying_Type (Otyp)) then
3101 Otyp := Underlying_Type (Otyp);
3104 if Present (Underlying_Type (Ityp)) then
3105 Ityp := Underlying_Type (Ityp);
3108 if Is_Concurrent_Type (Otyp) then
3109 Otyp := Corresponding_Record_Type (Otyp);
3112 if Is_Concurrent_Type (Ityp) then
3113 Ityp := Corresponding_Record_Type (Ityp);
3116 -- If the base types are the same, we know there is no problem since
3117 -- this conversion will be a noop.
3119 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
3122 -- If the size of output type is known at compile time, there is
3123 -- never a problem. Note that unconstrained records are considered
3124 -- to be of known size, but we can't consider them that way here,
3125 -- because we are talking about the actual size of the object.
3127 -- We also make sure that in addition to the size being known, we do
3128 -- not have a case which might generate an embarrassingly large temp
3129 -- in stack checking mode.
3131 elsif Size_Known_At_Compile_Time (Otyp)
3132 and then not May_Generate_Large_Temp (Otyp)
3133 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
3137 -- If either type is tagged, then we know the alignment is OK so
3138 -- Gigi will be able to use pointer punning.
3140 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
3143 -- If either type is a limited record type, we cannot do a copy, so
3144 -- say safe since there's nothing else we can do.
3146 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
3149 -- Conversions to and from packed array types are always ignored and
3152 elsif Is_Packed_Array_Type (Otyp)
3153 or else Is_Packed_Array_Type (Ityp)
3158 -- The only other cases known to be safe is if the input type's
3159 -- alignment is known to be at least the maximum alignment for the
3160 -- target or if both alignments are known and the output type's
3161 -- alignment is no stricter than the input's. We can use the alignment
3162 -- of the component type of an array if a type is an unpacked
3165 if Present (Alignment_Clause (Otyp)) then
3166 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
3168 elsif Is_Array_Type (Otyp)
3169 and then Present (Alignment_Clause (Component_Type (Otyp)))
3171 Oalign := Expr_Value (Expression (Alignment_Clause
3172 (Component_Type (Otyp))));
3175 if Present (Alignment_Clause (Ityp)) then
3176 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
3178 elsif Is_Array_Type (Ityp)
3179 and then Present (Alignment_Clause (Component_Type (Ityp)))
3181 Ialign := Expr_Value (Expression (Alignment_Clause
3182 (Component_Type (Ityp))));
3185 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
3188 elsif Ialign /= No_Uint and then Oalign /= No_Uint
3189 and then Ialign <= Oalign
3193 -- Otherwise, Gigi cannot handle this and we must make a temporary.
3199 end Safe_Unchecked_Type_Conversion;
3201 --------------------------
3202 -- Set_Elaboration_Flag --
3203 --------------------------
3205 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
3206 Loc : constant Source_Ptr := Sloc (N);
3210 if Present (Elaboration_Entity (Spec_Id)) then
3212 -- Nothing to do if at the compilation unit level, because in this
3213 -- case the flag is set by the binder generated elaboration routine.
3215 if Nkind (Parent (N)) = N_Compilation_Unit then
3218 -- Here we do need to generate an assignment statement
3221 Check_Restriction (No_Elaboration_Code, N);
3223 Make_Assignment_Statement (Loc,
3224 Name => New_Occurrence_Of (Elaboration_Entity (Spec_Id), Loc),
3225 Expression => New_Occurrence_Of (Standard_True, Loc));
3227 if Nkind (Parent (N)) = N_Subunit then
3228 Insert_After (Corresponding_Stub (Parent (N)), Asn);
3230 Insert_After (N, Asn);
3236 end Set_Elaboration_Flag;
3238 ----------------------------
3239 -- Wrap_Cleanup_Procedure --
3240 ----------------------------
3242 procedure Wrap_Cleanup_Procedure (N : Node_Id) is
3243 Loc : constant Source_Ptr := Sloc (N);
3244 Stseq : constant Node_Id := Handled_Statement_Sequence (N);
3245 Stmts : constant List_Id := Statements (Stseq);
3248 if Abort_Allowed then
3249 Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
3250 Append_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Undefer));
3252 end Wrap_Cleanup_Procedure;