1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Exp_Ch7
; use Exp_Ch7
;
33 with Exp_Ch11
; use Exp_Ch11
;
34 with Hostparm
; use Hostparm
;
35 with Inline
; use Inline
;
36 with Itypes
; use Itypes
;
38 with Namet
; use Namet
;
39 with Nlists
; use Nlists
;
40 with Nmake
; use Nmake
;
42 with Restrict
; use Restrict
;
44 with Sem_Ch8
; use Sem_Ch8
;
45 with Sem_Eval
; use Sem_Eval
;
46 with Sem_Res
; use Sem_Res
;
47 with Sem_Util
; use Sem_Util
;
48 with Sinfo
; use Sinfo
;
49 with Stand
; use Stand
;
50 with Stringt
; use Stringt
;
51 with Targparm
; use Targparm
;
52 with Tbuild
; use Tbuild
;
53 with Ttypes
; use Ttypes
;
54 with Uintp
; use Uintp
;
55 with Urealp
; use Urealp
;
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
101 Dyn
: Boolean := False)
103 -- Build function to generate the image string for a task that is a
104 -- record component. Concatenate name of variable with that of selector.
105 -- The flag Dyn indicates whether this is called for the initialization
106 -- procedure of record with task components, or for a dynamically
107 -- created task that is assigned to a selected component.
109 function Make_CW_Equivalent_Type
113 -- T is a class-wide type entity, E is the initial expression node that
114 -- constrains T in case such as: " X: T := E" or "new T'(E)"
115 -- This function returns the entity of the Equivalent type and inserts
116 -- on the fly the necessary declaration such as:
117 -- type anon is record
118 -- _parent : Root_Type (T); constrained with E discriminants (if any)
119 -- Extension : String (1 .. expr to match size of E);
122 -- This record is compatible with any object of the class of T thanks
123 -- to the first field and has the same size as E thanks to the second.
125 function Make_Literal_Range
127 Literal_Typ
: Entity_Id
)
129 -- Produce a Range node whose bounds are:
130 -- Low_Bound (Literal_Type) ..
131 -- Low_Bound (Literal_Type) + Length (Literal_Typ) - 1
132 -- this is used for expanding declarations like X : String := "sdfgdfg";
134 function New_Class_Wide_Subtype
138 -- Create an implicit subtype of CW_Typ attached to node N.
140 ----------------------
141 -- Adjust_Condition --
142 ----------------------
144 procedure Adjust_Condition
(N
: Node_Id
) is
151 Loc
: constant Source_Ptr
:= Sloc
(N
);
152 T
: constant Entity_Id
:= Etype
(N
);
156 -- For now, we simply ignore a call where the argument has no
157 -- type (probably case of unanalyzed condition), or has a type
158 -- that is not Boolean. This is because this is a pretty marginal
159 -- piece of functionality, and violations of these rules are
160 -- likely to be truly marginal (how much code uses Fortran Logical
161 -- as the barrier to a protected entry?) and we do not want to
162 -- blow up existing programs. We can change this to an assertion
163 -- after 3.12a is released ???
165 if No
(T
) or else not Is_Boolean_Type
(T
) then
169 -- Apply validity checking if needed
171 if Validity_Checks_On
and Validity_Check_Tests
then
175 -- Immediate return if standard boolean, the most common case,
176 -- where nothing needs to be done.
178 if Base_Type
(T
) = Standard_Boolean
then
182 -- Case of zero/non-zero semantics or non-standard enumeration
183 -- representation. In each case, we rewrite the node as:
185 -- ityp!(N) /= False'Enum_Rep
187 -- where ityp is an integer type with large enough size to hold
188 -- any value of type T.
190 if Nonzero_Is_True
(T
) or else Has_Non_Standard_Rep
(T
) then
191 if Esize
(T
) <= Esize
(Standard_Integer
) then
192 Ti
:= Standard_Integer
;
194 Ti
:= Standard_Long_Long_Integer
;
199 Left_Opnd
=> Unchecked_Convert_To
(Ti
, N
),
201 Make_Attribute_Reference
(Loc
,
202 Attribute_Name
=> Name_Enum_Rep
,
204 New_Occurrence_Of
(First_Literal
(T
), Loc
))));
205 Analyze_And_Resolve
(N
, Standard_Boolean
);
208 Rewrite
(N
, Convert_To
(Standard_Boolean
, N
));
209 Analyze_And_Resolve
(N
, Standard_Boolean
);
212 end Adjust_Condition
;
214 ------------------------
215 -- Adjust_Result_Type --
216 ------------------------
218 procedure Adjust_Result_Type
(N
: Node_Id
; T
: Entity_Id
) is
220 -- Ignore call if current type is not Standard.Boolean
222 if Etype
(N
) /= Standard_Boolean
then
226 -- If result is already of correct type, nothing to do. Note that
227 -- this will get the most common case where everything has a type
228 -- of Standard.Boolean.
230 if Base_Type
(T
) = Standard_Boolean
then
235 KP
: constant Node_Kind
:= Nkind
(Parent
(N
));
238 -- If result is to be used as a Condition in the syntax, no need
239 -- to convert it back, since if it was changed to Standard.Boolean
240 -- using Adjust_Condition, that is just fine for this usage.
242 if KP
in N_Raise_xxx_Error
or else KP
in N_Has_Condition
then
245 -- If result is an operand of another logical operation, no need
246 -- to reset its type, since Standard.Boolean is just fine, and
247 -- such operations always do Adjust_Condition on their operands.
249 elsif KP
in N_Op_Boolean
250 or else KP
= N_And_Then
251 or else KP
= N_Or_Else
252 or else KP
= N_Op_Not
256 -- Otherwise we perform a conversion from the current type,
257 -- which must be Standard.Boolean, to the desired type.
261 Rewrite
(N
, Convert_To
(T
, N
));
262 Analyze_And_Resolve
(N
, T
);
266 end Adjust_Result_Type
;
268 --------------------------
269 -- Append_Freeze_Action --
270 --------------------------
272 procedure Append_Freeze_Action
(T
: Entity_Id
; N
: Node_Id
) is
273 Fnode
: Node_Id
:= Freeze_Node
(T
);
276 Ensure_Freeze_Node
(T
);
277 Fnode
:= Freeze_Node
(T
);
279 if not Present
(Actions
(Fnode
)) then
280 Set_Actions
(Fnode
, New_List
);
283 Append
(N
, Actions
(Fnode
));
284 end Append_Freeze_Action
;
286 ---------------------------
287 -- Append_Freeze_Actions --
288 ---------------------------
290 procedure Append_Freeze_Actions
(T
: Entity_Id
; L
: List_Id
) is
291 Fnode
: constant Node_Id
:= Freeze_Node
(T
);
298 if No
(Actions
(Fnode
)) then
299 Set_Actions
(Fnode
, L
);
302 Append_List
(L
, Actions
(Fnode
));
306 end Append_Freeze_Actions
;
308 ------------------------
309 -- Build_Runtime_Call --
310 ------------------------
312 function Build_Runtime_Call
(Loc
: Source_Ptr
; RE
: RE_Id
) return Node_Id
is
315 Make_Procedure_Call_Statement
(Loc
,
316 Name
=> New_Reference_To
(RTE
(RE
), Loc
));
317 end Build_Runtime_Call
;
319 -----------------------------
320 -- Build_Task_Array_Image --
321 -----------------------------
323 -- This function generates the body for a function that constructs the
324 -- image string for a task that is an array component. The function is
325 -- local to the init_proc for the array type, and is called for each one
326 -- of the components. The constructed image has the form of an indexed
327 -- component, whose prefix is the outer variable of the array type.
328 -- The n-dimensional array type has known indices Index, Index2...
329 -- Id_Ref is an indexed component form created by the enclosing init_proc.
330 -- Its successive indices are Val1, Val2,.. which are the loop variables
331 -- in the loops that call the individual task init_proc on each component.
333 -- The generated function has the following structure:
335 -- function F return Task_Image_Type is
336 -- Pref : string := Task_Id.all;
337 -- T1 : String := Index1'Image (Val1);
339 -- Tn : String := indexn'image (Valn);
340 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
341 -- -- Len includes commas and the end parentheses.
342 -- Res : String (1..Len);
343 -- Pos : Integer := Pref'Length;
346 -- Res (1 .. Pos) := Pref;
350 -- Res (Pos .. Pos + T1'Length - 1) := T1;
351 -- Pos := Pos + T1'Length;
355 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
358 -- return new String (Res);
361 -- Needless to say, multidimensional arrays of tasks are rare enough
362 -- that the bulkiness of this code is not really a concern.
364 function Build_Task_Array_Image
368 Dyn
: Boolean := False)
371 Dims
: constant Nat
:= Number_Dimensions
(A_Type
);
372 -- Number of dimensions for array of tasks.
374 Temps
: array (1 .. Dims
) of Entity_Id
;
375 -- Array of temporaries to hold string for each index.
381 -- Total length of generated name
384 -- Running index for substring assignments
387 -- Name of enclosing variable, prefix of resulting name
390 -- string expression for Pref.
393 -- String to hold result
396 -- Value of successive indices
399 -- Expression to compute total size of string
402 -- Entity for name at one index position
404 Decls
: List_Id
:= New_List
;
405 Stats
: List_Id
:= New_List
;
408 Pref
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
410 -- For a dynamic task, the name comes from the target variable.
411 -- For a static one it is a formal of the enclosing init_proc.
414 Get_Name_String
(Chars
(Entity
(Prefix
(Id_Ref
))));
416 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
);
419 Make_Explicit_Dereference
(Loc
,
420 Prefix
=> Make_Identifier
(Loc
, Name_uTask_Id
));
424 Make_Object_Declaration
(Loc
,
425 Defining_Identifier
=> Pref
,
426 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
427 Expression
=> P_Nam
));
429 Indx
:= First_Index
(A_Type
);
430 Val
:= First
(Expressions
(Id_Ref
));
432 for J
in 1 .. Dims
loop
433 T
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
437 Make_Object_Declaration
(Loc
,
438 Defining_Identifier
=> T
,
439 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
441 Make_Attribute_Reference
(Loc
,
442 Attribute_Name
=> Name_Image
,
444 New_Occurrence_Of
(Etype
(Indx
), Loc
),
445 Expressions
=> New_List
(
446 New_Copy_Tree
(Val
)))));
452 Sum
:= Make_Integer_Literal
(Loc
, Dims
+ 1);
458 Make_Attribute_Reference
(Loc
,
459 Attribute_Name
=> Name_Length
,
461 New_Occurrence_Of
(Pref
, Loc
),
462 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1))));
464 for J
in 1 .. Dims
loop
469 Make_Attribute_Reference
(Loc
,
470 Attribute_Name
=> Name_Length
,
472 New_Occurrence_Of
(Temps
(J
), Loc
),
473 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1))));
476 Build_Task_Image_Prefix
(Loc
, Len
, Res
, Pos
, Pref
, Sum
, Decls
, Stats
);
478 Set_Character_Literal_Name
(Char_Code
(Character'Pos ('(')));
481 Make_Assignment_Statement
(Loc
,
482 Name
=> Make_Indexed_Component
(Loc
,
483 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
484 Expressions
=> New_List
(New_Occurrence_Of
(Pos
, Loc
))),
486 Make_Character_Literal
(Loc
,
488 Char_Literal_Value
=>
489 Char_Code
(Character'Pos ('(')))));
492 Make_Assignment_Statement
(Loc
,
493 Name
=> New_Occurrence_Of
(Pos
, Loc
),
496 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
497 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
499 for J
in 1 .. Dims
loop
502 Make_Assignment_Statement
(Loc
,
503 Name
=> Make_Slice
(Loc
,
504 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
507 Low_Bound
=> New_Occurrence_Of
(Pos
, Loc
),
508 High_Bound
=> Make_Op_Subtract
(Loc
,
511 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
513 Make_Attribute_Reference
(Loc
,
514 Attribute_Name
=> Name_Length
,
516 New_Occurrence_Of
(Temps
(J
), Loc
),
518 New_List
(Make_Integer_Literal
(Loc
, 1)))),
519 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
521 Expression
=> New_Occurrence_Of
(Temps
(J
), Loc
)));
525 Make_Assignment_Statement
(Loc
,
526 Name
=> New_Occurrence_Of
(Pos
, Loc
),
529 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
531 Make_Attribute_Reference
(Loc
,
532 Attribute_Name
=> Name_Length
,
533 Prefix
=> New_Occurrence_Of
(Temps
(J
), Loc
),
535 New_List
(Make_Integer_Literal
(Loc
, 1))))));
537 Set_Character_Literal_Name
(Char_Code
(Character'Pos (',')));
540 Make_Assignment_Statement
(Loc
,
541 Name
=> Make_Indexed_Component
(Loc
,
542 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
543 Expressions
=> New_List
(New_Occurrence_Of
(Pos
, Loc
))),
545 Make_Character_Literal
(Loc
,
547 Char_Literal_Value
=>
548 Char_Code
(Character'Pos (',')))));
551 Make_Assignment_Statement
(Loc
,
552 Name
=> New_Occurrence_Of
(Pos
, Loc
),
555 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
556 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
560 Set_Character_Literal_Name
(Char_Code
(Character'Pos (')')));
563 Make_Assignment_Statement
(Loc
,
564 Name
=> Make_Indexed_Component
(Loc
,
565 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
566 Expressions
=> New_List
(New_Occurrence_Of
(Len
, Loc
))),
568 Make_Character_Literal
(Loc
,
570 Char_Literal_Value
=>
571 Char_Code
(Character'Pos (')')))));
572 return Build_Task_Image_Function
(Loc
, Decls
, Stats
, Res
);
573 end Build_Task_Array_Image
;
575 ----------------------------
576 -- Build_Task_Image_Decls --
577 ----------------------------
579 function Build_Task_Image_Decls
585 T_Id
: Entity_Id
:= Empty
;
587 Decls
: List_Id
:= New_List
;
588 Expr
: Node_Id
:= Empty
;
589 Fun
: Node_Id
:= Empty
;
590 Is_Dyn
: constant Boolean :=
591 Nkind
(Parent
(Id_Ref
)) = N_Assignment_Statement
592 and then Nkind
(Expression
(Parent
(Id_Ref
))) = N_Allocator
;
595 -- If Discard_Names is in effect, generate a dummy declaration only.
597 if Global_Discard_Names
then
599 Make_Defining_Identifier
(Loc
, New_Internal_Name
('I'));
603 Make_Object_Declaration
(Loc
,
604 Defining_Identifier
=> T_Id
,
606 New_Occurrence_Of
(RTE
(RE_Task_Image_Type
), Loc
)));
609 if Nkind
(Id_Ref
) = N_Identifier
610 or else Nkind
(Id_Ref
) = N_Defining_Identifier
612 -- For a simple variable, the image of the task is the name
616 Make_Defining_Identifier
(Loc
,
617 New_External_Name
(Chars
(Id_Ref
), 'I'));
619 Get_Name_String
(Chars
(Id_Ref
));
624 Make_Qualified_Expression
(Loc
,
626 New_Occurrence_Of
(Standard_String
, Loc
),
629 (Loc
, Strval
=> String_From_Name_Buffer
)));
631 elsif Nkind
(Id_Ref
) = N_Selected_Component
then
633 Make_Defining_Identifier
(Loc
,
634 New_External_Name
(Chars
(Selector_Name
(Id_Ref
)), 'I'));
635 Fun
:= Build_Task_Record_Image
(Loc
, Id_Ref
, Is_Dyn
);
637 elsif Nkind
(Id_Ref
) = N_Indexed_Component
then
639 Make_Defining_Identifier
(Loc
,
640 New_External_Name
(Chars
(A_Type
), 'I'));
642 Fun
:= Build_Task_Array_Image
(Loc
, Id_Ref
, A_Type
, Is_Dyn
);
646 if Present
(Fun
) then
650 Make_Function_Call
(Loc
,
651 Name
=> New_Occurrence_Of
(Defining_Entity
(Fun
), Loc
));
654 Decl
:= Make_Object_Declaration
(Loc
,
655 Defining_Identifier
=> T_Id
,
657 New_Occurrence_Of
(RTE
(RE_Task_Image_Type
), Loc
),
660 Append
(Decl
, Decls
);
662 end Build_Task_Image_Decls
;
664 -------------------------------
665 -- Build_Task_Image_Function --
666 -------------------------------
668 function Build_Task_Image_Function
679 Make_Return_Statement
(Loc
,
683 Make_Qualified_Expression
(Loc
,
685 New_Occurrence_Of
(Standard_String
, Loc
),
686 Expression
=> New_Occurrence_Of
(Res
, Loc
)))));
688 Spec
:= Make_Function_Specification
(Loc
,
689 Defining_Unit_Name
=>
690 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
691 Subtype_Mark
=> New_Occurrence_Of
(RTE
(RE_Task_Image_Type
), Loc
));
693 return Make_Subprogram_Body
(Loc
,
694 Specification
=> Spec
,
695 Declarations
=> Decls
,
696 Handled_Statement_Sequence
=>
697 Make_Handled_Sequence_Of_Statements
(Loc
,
698 Statements
=> Stats
));
699 end Build_Task_Image_Function
;
701 -----------------------------
702 -- Build_Task_Image_Prefix --
703 -----------------------------
705 procedure Build_Task_Image_Prefix
712 Decls
: in out List_Id
;
713 Stats
: in out List_Id
)
716 Len
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('L'));
719 Make_Object_Declaration
(Loc
,
720 Defining_Identifier
=> Len
,
721 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
724 Res
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
727 Make_Object_Declaration
(Loc
,
728 Defining_Identifier
=> Res
,
730 Make_Subtype_Indication
(Loc
,
731 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
733 Make_Index_Or_Discriminant_Constraint
(Loc
,
737 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
738 High_Bound
=> New_Occurrence_Of
(Len
, Loc
)))))));
740 Pos
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
743 Make_Object_Declaration
(Loc
,
744 Defining_Identifier
=> Pos
,
745 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
)));
747 -- Pos := Prefix'Length;
750 Make_Assignment_Statement
(Loc
,
751 Name
=> New_Occurrence_Of
(Pos
, Loc
),
753 Make_Attribute_Reference
(Loc
,
754 Attribute_Name
=> Name_Length
,
755 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
757 New_List
(Make_Integer_Literal
(Loc
, 1)))));
759 -- Res (1 .. Pos) := Prefix;
762 Make_Assignment_Statement
(Loc
,
763 Name
=> Make_Slice
(Loc
,
764 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
767 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
768 High_Bound
=> New_Occurrence_Of
(Pos
, Loc
))),
770 Expression
=> New_Occurrence_Of
(Prefix
, Loc
)));
773 Make_Assignment_Statement
(Loc
,
774 Name
=> New_Occurrence_Of
(Pos
, Loc
),
777 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
778 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
779 end Build_Task_Image_Prefix
;
781 -----------------------------
782 -- Build_Task_Record_Image --
783 -----------------------------
785 function Build_Task_Record_Image
788 Dyn
: Boolean := False)
792 -- Total length of generated name
798 -- String to hold result
801 -- Name of enclosing variable, prefix of resulting name
804 -- string expression for Pref.
807 -- Expression to compute total size of string.
810 -- Entity for selector name
812 Decls
: List_Id
:= New_List
;
813 Stats
: List_Id
:= New_List
;
816 Pref
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
818 -- For a dynamic task, the name comes from the target variable.
819 -- For a static one it is a formal of the enclosing init_proc.
822 Get_Name_String
(Chars
(Entity
(Prefix
(Id_Ref
))));
824 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
);
827 Make_Explicit_Dereference
(Loc
,
828 Prefix
=> Make_Identifier
(Loc
, Name_uTask_Id
));
832 Make_Object_Declaration
(Loc
,
833 Defining_Identifier
=> Pref
,
834 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
835 Expression
=> P_Nam
));
837 Sel
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
839 Get_Name_String
(Chars
(Selector_Name
(Id_Ref
)));
842 Make_Object_Declaration
(Loc
,
843 Defining_Identifier
=> Sel
,
844 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
846 Make_String_Literal
(Loc
, Strval
=> String_From_Name_Buffer
)));
848 Sum
:= Make_Integer_Literal
(Loc
, Nat
(Name_Len
+ 1));
854 Make_Attribute_Reference
(Loc
,
855 Attribute_Name
=> Name_Length
,
857 New_Occurrence_Of
(Pref
, Loc
),
858 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1))));
860 Build_Task_Image_Prefix
(Loc
, Len
, Res
, Pos
, Pref
, Sum
, Decls
, Stats
);
862 Set_Character_Literal_Name
(Char_Code
(Character'Pos ('.')));
867 Make_Assignment_Statement
(Loc
,
868 Name
=> Make_Indexed_Component
(Loc
,
869 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
870 Expressions
=> New_List
(New_Occurrence_Of
(Pos
, Loc
))),
872 Make_Character_Literal
(Loc
,
874 Char_Literal_Value
=>
875 Char_Code
(Character'Pos ('.')))));
878 Make_Assignment_Statement
(Loc
,
879 Name
=> New_Occurrence_Of
(Pos
, Loc
),
882 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
883 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
885 -- Res (Pos .. Len) := Selector;
888 Make_Assignment_Statement
(Loc
,
889 Name
=> Make_Slice
(Loc
,
890 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
893 Low_Bound
=> New_Occurrence_Of
(Pos
, Loc
),
894 High_Bound
=> New_Occurrence_Of
(Len
, Loc
))),
895 Expression
=> New_Occurrence_Of
(Sel
, Loc
)));
897 return Build_Task_Image_Function
(Loc
, Decls
, Stats
, Res
);
898 end Build_Task_Record_Image
;
900 -------------------------------
901 -- Convert_To_Actual_Subtype --
902 -------------------------------
904 procedure Convert_To_Actual_Subtype
(Exp
: Entity_Id
) is
908 Act_ST
:= Get_Actual_Subtype
(Exp
);
910 if Act_ST
= Etype
(Exp
) then
915 Convert_To
(Act_ST
, Relocate_Node
(Exp
)));
916 Analyze_And_Resolve
(Exp
, Act_ST
);
918 end Convert_To_Actual_Subtype
;
920 -----------------------------------
921 -- Current_Sem_Unit_Declarations --
922 -----------------------------------
924 function Current_Sem_Unit_Declarations
return List_Id
is
925 U
: Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
929 -- If the current unit is a package body, locate the visible
930 -- declarations of the package spec.
932 if Nkind
(U
) = N_Package_Body
then
933 U
:= Unit
(Library_Unit
(Cunit
(Current_Sem_Unit
)));
936 if Nkind
(U
) = N_Package_Declaration
then
937 U
:= Specification
(U
);
938 Decls
:= Visible_Declarations
(U
);
942 Set_Visible_Declarations
(U
, Decls
);
946 Decls
:= Declarations
(U
);
950 Set_Declarations
(U
, Decls
);
955 end Current_Sem_Unit_Declarations
;
957 -----------------------
958 -- Duplicate_Subexpr --
959 -----------------------
961 function Duplicate_Subexpr
963 Name_Req
: Boolean := False)
967 Remove_Side_Effects
(Exp
, Name_Req
);
968 return New_Copy_Tree
(Exp
);
969 end Duplicate_Subexpr
;
971 ---------------------------------
972 -- Duplicate_Subexpr_No_Checks --
973 ---------------------------------
975 function Duplicate_Subexpr_No_Checks
977 Name_Req
: Boolean := False)
983 Remove_Side_Effects
(Exp
, Name_Req
);
984 New_Exp
:= New_Copy_Tree
(Exp
);
985 Remove_Checks
(New_Exp
);
987 end Duplicate_Subexpr_No_Checks
;
989 -----------------------------------
990 -- Duplicate_Subexpr_Move_Checks --
991 -----------------------------------
993 function Duplicate_Subexpr_Move_Checks
995 Name_Req
: Boolean := False)
1001 Remove_Side_Effects
(Exp
, Name_Req
);
1002 New_Exp
:= New_Copy_Tree
(Exp
);
1003 Remove_Checks
(Exp
);
1005 end Duplicate_Subexpr_Move_Checks
;
1007 --------------------
1008 -- Ensure_Defined --
1009 --------------------
1011 procedure Ensure_Defined
(Typ
: Entity_Id
; N
: Node_Id
) is
1016 if Is_Itype
(Typ
) then
1017 IR
:= Make_Itype_Reference
(Sloc
(N
));
1018 Set_Itype
(IR
, Typ
);
1020 if not In_Open_Scopes
(Scope
(Typ
))
1021 and then Is_Subprogram
(Current_Scope
)
1022 and then Scope
(Current_Scope
) /= Standard_Standard
1024 -- Insert node in front of subprogram, to avoid scope anomalies
1030 and then Nkind
(P
) /= N_Subprogram_Body
1036 Insert_Action
(P
, IR
);
1038 Insert_Action
(N
, IR
);
1042 Insert_Action
(N
, IR
);
1047 ---------------------
1048 -- Evolve_And_Then --
1049 ---------------------
1051 procedure Evolve_And_Then
(Cond
: in out Node_Id
; Cond1
: Node_Id
) is
1057 Make_And_Then
(Sloc
(Cond1
),
1059 Right_Opnd
=> Cond1
);
1061 end Evolve_And_Then
;
1063 --------------------
1064 -- Evolve_Or_Else --
1065 --------------------
1067 procedure Evolve_Or_Else
(Cond
: in out Node_Id
; Cond1
: Node_Id
) is
1073 Make_Or_Else
(Sloc
(Cond1
),
1075 Right_Opnd
=> Cond1
);
1079 ------------------------------
1080 -- Expand_Subtype_From_Expr --
1081 ------------------------------
1083 -- This function is applicable for both static and dynamic allocation of
1084 -- objects which are constrained by an initial expression. Basically it
1085 -- transforms an unconstrained subtype indication into a constrained one.
1086 -- The expression may also be transformed in certain cases in order to
1087 -- avoid multiple evaulation. In the static allocation case, the general
1092 -- is transformed into
1094 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1096 -- Here are the main cases :
1098 -- <if Expr is a Slice>
1099 -- Val : T ([Index_Subtype (Expr)]) := Expr;
1101 -- <elsif Expr is a String Literal>
1102 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1104 -- <elsif Expr is Constrained>
1105 -- subtype T is Type_Of_Expr
1108 -- <elsif Expr is an entity_name>
1109 -- Val : T (constraints taken from Expr) := Expr;
1112 -- type Axxx is access all T;
1113 -- Rval : Axxx := Expr'ref;
1114 -- Val : T (constraints taken from Rval) := Rval.all;
1116 -- ??? note: when the Expression is allocated in the secondary stack
1117 -- we could use it directly instead of copying it by declaring
1118 -- Val : T (...) renames Rval.all
1120 procedure Expand_Subtype_From_Expr
1122 Unc_Type
: Entity_Id
;
1123 Subtype_Indic
: Node_Id
;
1126 Loc
: constant Source_Ptr
:= Sloc
(N
);
1127 Exp_Typ
: constant Entity_Id
:= Etype
(Exp
);
1131 -- In general we cannot build the subtype if expansion is disabled,
1132 -- because internal entities may not have been defined. However, to
1133 -- avoid some cascaded errors, we try to continue when the expression
1134 -- is an array (or string), because it is safe to compute the bounds.
1135 -- It is in fact required to do so even in a generic context, because
1136 -- there may be constants that depend on bounds of string literal.
1138 if not Expander_Active
1139 and then (No
(Etype
(Exp
))
1140 or else Base_Type
(Etype
(Exp
)) /= Standard_String
)
1145 if Nkind
(Exp
) = N_Slice
then
1147 Slice_Type
: constant Entity_Id
:= Etype
(First_Index
(Exp_Typ
));
1150 Rewrite
(Subtype_Indic
,
1151 Make_Subtype_Indication
(Loc
,
1152 Subtype_Mark
=> New_Reference_To
(Unc_Type
, Loc
),
1154 Make_Index_Or_Discriminant_Constraint
(Loc
,
1155 Constraints
=> New_List
1156 (New_Reference_To
(Slice_Type
, Loc
)))));
1158 -- This subtype indication may be used later for contraint checks
1159 -- we better make sure that if a variable was used as a bound of
1160 -- of the original slice, its value is frozen.
1162 Force_Evaluation
(Low_Bound
(Scalar_Range
(Slice_Type
)));
1163 Force_Evaluation
(High_Bound
(Scalar_Range
(Slice_Type
)));
1166 elsif Ekind
(Exp_Typ
) = E_String_Literal_Subtype
then
1167 Rewrite
(Subtype_Indic
,
1168 Make_Subtype_Indication
(Loc
,
1169 Subtype_Mark
=> New_Reference_To
(Unc_Type
, Loc
),
1171 Make_Index_Or_Discriminant_Constraint
(Loc
,
1172 Constraints
=> New_List
(
1173 Make_Literal_Range
(Loc
,
1174 Literal_Typ
=> Exp_Typ
)))));
1176 elsif Is_Constrained
(Exp_Typ
)
1177 and then not Is_Class_Wide_Type
(Unc_Type
)
1179 if Is_Itype
(Exp_Typ
) then
1181 -- No need to generate a new one.
1187 Make_Defining_Identifier
(Loc
,
1188 Chars
=> New_Internal_Name
('T'));
1191 Make_Subtype_Declaration
(Loc
,
1192 Defining_Identifier
=> T
,
1193 Subtype_Indication
=> New_Reference_To
(Exp_Typ
, Loc
)));
1195 -- This type is marked as an itype even though it has an
1196 -- explicit declaration because otherwise it can be marked
1197 -- with Is_Generic_Actual_Type and generate spurious errors.
1198 -- (see sem_ch8.Analyze_Package_Renaming and sem_type.covers)
1201 Set_Associated_Node_For_Itype
(T
, Exp
);
1204 Rewrite
(Subtype_Indic
, New_Reference_To
(T
, Loc
));
1206 -- nothing needs to be done for private types with unknown discriminants
1207 -- if the underlying type is not an unconstrained composite type.
1209 elsif Is_Private_Type
(Unc_Type
)
1210 and then Has_Unknown_Discriminants
(Unc_Type
)
1211 and then (not Is_Composite_Type
(Underlying_Type
(Unc_Type
))
1212 or else Is_Constrained
(Underlying_Type
(Unc_Type
)))
1217 Remove_Side_Effects
(Exp
);
1218 Rewrite
(Subtype_Indic
,
1219 Make_Subtype_From_Expr
(Exp
, Unc_Type
));
1221 end Expand_Subtype_From_Expr
;
1227 function Find_Prim_Op
(T
: Entity_Id
; Name
: Name_Id
) return Entity_Id
is
1229 Typ
: Entity_Id
:= T
;
1232 if Is_Class_Wide_Type
(Typ
) then
1233 Typ
:= Root_Type
(Typ
);
1236 Typ
:= Underlying_Type
(Typ
);
1238 Prim
:= First_Elmt
(Primitive_Operations
(Typ
));
1239 while Chars
(Node
(Prim
)) /= Name
loop
1241 pragma Assert
(Present
(Prim
));
1247 ----------------------
1248 -- Force_Evaluation --
1249 ----------------------
1251 procedure Force_Evaluation
(Exp
: Node_Id
; Name_Req
: Boolean := False) is
1253 Remove_Side_Effects
(Exp
, Name_Req
, Variable_Ref
=> True);
1254 end Force_Evaluation
;
1256 ------------------------
1257 -- Generate_Poll_Call --
1258 ------------------------
1260 procedure Generate_Poll_Call
(N
: Node_Id
) is
1262 -- No poll call if polling not active
1264 if not Polling_Required
then
1267 -- Otherwise generate require poll call
1270 Insert_Before_And_Analyze
(N
,
1271 Make_Procedure_Call_Statement
(Sloc
(N
),
1272 Name
=> New_Occurrence_Of
(RTE
(RE_Poll
), Sloc
(N
))));
1274 end Generate_Poll_Call
;
1276 --------------------
1277 -- Homonym_Number --
1278 --------------------
1280 function Homonym_Number
(Subp
: Entity_Id
) return Nat
is
1286 Hom
:= Homonym
(Subp
);
1287 while Present
(Hom
) loop
1288 if Scope
(Hom
) = Scope
(Subp
) then
1292 Hom
:= Homonym
(Hom
);
1298 ------------------------------
1299 -- In_Unconditional_Context --
1300 ------------------------------
1302 function In_Unconditional_Context
(Node
: Node_Id
) return Boolean is
1307 while Present
(P
) loop
1309 when N_Subprogram_Body
=>
1312 when N_If_Statement
=>
1315 when N_Loop_Statement
=>
1318 when N_Case_Statement
=>
1327 end In_Unconditional_Context
;
1333 procedure Insert_Action
(Assoc_Node
: Node_Id
; Ins_Action
: Node_Id
) is
1335 if Present
(Ins_Action
) then
1336 Insert_Actions
(Assoc_Node
, New_List
(Ins_Action
));
1340 -- Version with check(s) suppressed
1342 procedure Insert_Action
1343 (Assoc_Node
: Node_Id
; Ins_Action
: Node_Id
; Suppress
: Check_Id
)
1346 Insert_Actions
(Assoc_Node
, New_List
(Ins_Action
), Suppress
);
1349 --------------------
1350 -- Insert_Actions --
1351 --------------------
1353 procedure Insert_Actions
(Assoc_Node
: Node_Id
; Ins_Actions
: List_Id
) is
1357 Wrapped_Node
: Node_Id
:= Empty
;
1360 if No
(Ins_Actions
) or else Is_Empty_List
(Ins_Actions
) then
1364 -- Ignore insert of actions from inside default expression in the
1365 -- special preliminary analyze mode. Any insertions at this point
1366 -- have no relevance, since we are only doing the analyze to freeze
1367 -- the types of any static expressions. See section "Handling of
1368 -- Default Expressions" in the spec of package Sem for further details.
1370 if In_Default_Expression
then
1374 -- If the action derives from stuff inside a record, then the actions
1375 -- are attached to the current scope, to be inserted and analyzed on
1376 -- exit from the scope. The reason for this is that we may also
1377 -- be generating freeze actions at the same time, and they must
1378 -- eventually be elaborated in the correct order.
1380 if Is_Record_Type
(Current_Scope
)
1381 and then not Is_Frozen
(Current_Scope
)
1383 if No
(Scope_Stack
.Table
1384 (Scope_Stack
.Last
).Pending_Freeze_Actions
)
1386 Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
:=
1391 Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
);
1397 -- We now intend to climb up the tree to find the right point to
1398 -- insert the actions. We start at Assoc_Node, unless this node is
1399 -- a subexpression in which case we start with its parent. We do this
1400 -- for two reasons. First it speeds things up. Second, if Assoc_Node
1401 -- is itself one of the special nodes like N_And_Then, then we assume
1402 -- that an initial request to insert actions for such a node does not
1403 -- expect the actions to get deposited in the node for later handling
1404 -- when the node is expanded, since clearly the node is being dealt
1405 -- with by the caller. Note that in the subexpression case, N is
1406 -- always the child we came from.
1408 -- N_Raise_xxx_Error is an annoying special case, it is a statement
1409 -- if it has type Standard_Void_Type, and a subexpression otherwise.
1410 -- otherwise. Procedure attribute references are also statements.
1412 if Nkind
(Assoc_Node
) in N_Subexpr
1413 and then (Nkind
(Assoc_Node
) in N_Raise_xxx_Error
1414 or else Etype
(Assoc_Node
) /= Standard_Void_Type
)
1415 and then (Nkind
(Assoc_Node
) /= N_Attribute_Reference
1417 not Is_Procedure_Attribute_Name
1418 (Attribute_Name
(Assoc_Node
)))
1420 P
:= Assoc_Node
; -- ????? does not agree with above!
1421 N
:= Parent
(Assoc_Node
);
1423 -- Non-subexpression case. Note that N is initially Empty in this
1424 -- case (N is only guaranteed Non-Empty in the subexpr case).
1431 -- Capture root of the transient scope
1433 if Scope_Is_Transient
then
1434 Wrapped_Node
:= Node_To_Be_Wrapped
;
1438 pragma Assert
(Present
(P
));
1442 -- Case of right operand of AND THEN or OR ELSE. Put the actions
1443 -- in the Actions field of the right operand. They will be moved
1444 -- out further when the AND THEN or OR ELSE operator is expanded.
1445 -- Nothing special needs to be done for the left operand since
1446 -- in that case the actions are executed unconditionally.
1448 when N_And_Then | N_Or_Else
=>
1449 if N
= Right_Opnd
(P
) then
1450 if Present
(Actions
(P
)) then
1451 Insert_List_After_And_Analyze
1452 (Last
(Actions
(P
)), Ins_Actions
);
1454 Set_Actions
(P
, Ins_Actions
);
1455 Analyze_List
(Actions
(P
));
1461 -- Then or Else operand of conditional expression. Add actions to
1462 -- Then_Actions or Else_Actions field as appropriate. The actions
1463 -- will be moved further out when the conditional is expanded.
1465 when N_Conditional_Expression
=>
1467 ThenX
: constant Node_Id
:= Next
(First
(Expressions
(P
)));
1468 ElseX
: constant Node_Id
:= Next
(ThenX
);
1471 -- Actions belong to the then expression, temporarily
1472 -- place them as Then_Actions of the conditional expr.
1473 -- They will be moved to the proper place later when
1474 -- the conditional expression is expanded.
1477 if Present
(Then_Actions
(P
)) then
1478 Insert_List_After_And_Analyze
1479 (Last
(Then_Actions
(P
)), Ins_Actions
);
1481 Set_Then_Actions
(P
, Ins_Actions
);
1482 Analyze_List
(Then_Actions
(P
));
1487 -- Actions belong to the else expression, temporarily
1488 -- place them as Else_Actions of the conditional expr.
1489 -- They will be moved to the proper place later when
1490 -- the conditional expression is expanded.
1492 elsif N
= ElseX
then
1493 if Present
(Else_Actions
(P
)) then
1494 Insert_List_After_And_Analyze
1495 (Last
(Else_Actions
(P
)), Ins_Actions
);
1497 Set_Else_Actions
(P
, Ins_Actions
);
1498 Analyze_List
(Else_Actions
(P
));
1503 -- Actions belong to the condition. In this case they are
1504 -- unconditionally executed, and so we can continue the
1505 -- search for the proper insert point.
1512 -- Case of appearing in the condition of a while expression or
1513 -- elsif. We insert the actions into the Condition_Actions field.
1514 -- They will be moved further out when the while loop or elsif
1517 when N_Iteration_Scheme |
1520 if N
= Condition
(P
) then
1521 if Present
(Condition_Actions
(P
)) then
1522 Insert_List_After_And_Analyze
1523 (Last
(Condition_Actions
(P
)), Ins_Actions
);
1525 Set_Condition_Actions
(P
, Ins_Actions
);
1527 -- Set the parent of the insert actions explicitly.
1528 -- This is not a syntactic field, but we need the
1529 -- parent field set, in particular so that freeze
1530 -- can understand that it is dealing with condition
1531 -- actions, and properly insert the freezing actions.
1533 Set_Parent
(Ins_Actions
, P
);
1534 Analyze_List
(Condition_Actions
(P
));
1540 -- Statements, declarations, pragmas, representation clauses.
1545 N_Procedure_Call_Statement |
1546 N_Statement_Other_Than_Procedure_Call |
1552 -- Representation_Clause
1555 N_Attribute_Definition_Clause |
1556 N_Enumeration_Representation_Clause |
1557 N_Record_Representation_Clause |
1561 N_Abstract_Subprogram_Declaration |
1563 N_Exception_Declaration |
1564 N_Exception_Renaming_Declaration |
1565 N_Formal_Object_Declaration |
1566 N_Formal_Subprogram_Declaration |
1567 N_Formal_Type_Declaration |
1568 N_Full_Type_Declaration |
1569 N_Function_Instantiation |
1570 N_Generic_Function_Renaming_Declaration |
1571 N_Generic_Package_Declaration |
1572 N_Generic_Package_Renaming_Declaration |
1573 N_Generic_Procedure_Renaming_Declaration |
1574 N_Generic_Subprogram_Declaration |
1575 N_Implicit_Label_Declaration |
1576 N_Incomplete_Type_Declaration |
1577 N_Number_Declaration |
1578 N_Object_Declaration |
1579 N_Object_Renaming_Declaration |
1581 N_Package_Body_Stub |
1582 N_Package_Declaration |
1583 N_Package_Instantiation |
1584 N_Package_Renaming_Declaration |
1585 N_Private_Extension_Declaration |
1586 N_Private_Type_Declaration |
1587 N_Procedure_Instantiation |
1588 N_Protected_Body_Stub |
1589 N_Protected_Type_Declaration |
1590 N_Single_Task_Declaration |
1592 N_Subprogram_Body_Stub |
1593 N_Subprogram_Declaration |
1594 N_Subprogram_Renaming_Declaration |
1595 N_Subtype_Declaration |
1598 N_Task_Type_Declaration |
1600 -- Freeze entity behaves like a declaration or statement
1604 -- Do not insert here if the item is not a list member (this
1605 -- happens for example with a triggering statement, and the
1606 -- proper approach is to insert before the entire select).
1608 if not Is_List_Member
(P
) then
1611 -- Do not insert if parent of P is an N_Component_Association
1612 -- node (i.e. we are in the context of an N_Aggregate node.
1613 -- In this case we want to insert before the entire aggregate.
1615 elsif Nkind
(Parent
(P
)) = N_Component_Association
then
1618 -- Do not insert if the parent of P is either an N_Variant
1619 -- node or an N_Record_Definition node, meaning in either
1620 -- case that P is a member of a component list, and that
1621 -- therefore the actions should be inserted outside the
1622 -- complete record declaration.
1624 elsif Nkind
(Parent
(P
)) = N_Variant
1625 or else Nkind
(Parent
(P
)) = N_Record_Definition
1629 -- Do not insert freeze nodes within the loop generated for
1630 -- an aggregate, because they may be elaborated too late for
1631 -- subsequent use in the back end: within a package spec the
1632 -- loop is part of the elaboration procedure and is only
1633 -- elaborated during the second pass.
1634 -- If the loop comes from source, or the entity is local to
1635 -- the loop itself it must remain within.
1637 elsif Nkind
(Parent
(P
)) = N_Loop_Statement
1638 and then not Comes_From_Source
(Parent
(P
))
1639 and then Nkind
(First
(Ins_Actions
)) = N_Freeze_Entity
1641 Scope
(Entity
(First
(Ins_Actions
))) /= Current_Scope
1645 -- Otherwise we can go ahead and do the insertion
1647 elsif P
= Wrapped_Node
then
1648 Store_Before_Actions_In_Scope
(Ins_Actions
);
1652 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
1656 -- A special case, N_Raise_xxx_Error can act either as a
1657 -- statement or a subexpression. We tell the difference
1658 -- by looking at the Etype. It is set to Standard_Void_Type
1659 -- in the statement case.
1662 N_Raise_xxx_Error
=>
1663 if Etype
(P
) = Standard_Void_Type
then
1664 if P
= Wrapped_Node
then
1665 Store_Before_Actions_In_Scope
(Ins_Actions
);
1667 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
1672 -- In the subexpression case, keep climbing
1678 -- If a component association appears within a loop created for
1679 -- an array aggregate, attach the actions to the association so
1680 -- they can be subsequently inserted within the loop. For other
1681 -- component associations insert outside of the aggregate.
1683 -- The list of loop_actions can in turn generate additional ones,
1684 -- that are inserted before the associated node. If the associated
1685 -- node is outside the aggregate, the new actions are collected
1686 -- at the end of the loop actions, to respect the order in which
1687 -- they are to be elaborated.
1690 N_Component_Association
=>
1691 if Nkind
(Parent
(P
)) = N_Aggregate
1692 and then Present
(Aggregate_Bounds
(Parent
(P
)))
1693 and then Nkind
(First
(Choices
(P
))) = N_Others_Choice
1695 if No
(Loop_Actions
(P
)) then
1696 Set_Loop_Actions
(P
, Ins_Actions
);
1697 Analyze_List
(Ins_Actions
);
1701 Decl
: Node_Id
:= Assoc_Node
;
1704 -- Check whether these actions were generated
1705 -- by a declaration that is part of the loop_
1706 -- actions for the component_association.
1708 while Present
(Decl
) loop
1709 exit when Parent
(Decl
) = P
1710 and then Is_List_Member
(Decl
)
1712 List_Containing
(Decl
) = Loop_Actions
(P
);
1713 Decl
:= Parent
(Decl
);
1716 if Present
(Decl
) then
1717 Insert_List_Before_And_Analyze
1718 (Decl
, Ins_Actions
);
1720 Insert_List_After_And_Analyze
1721 (Last
(Loop_Actions
(P
)), Ins_Actions
);
1732 -- Another special case, an attribute denoting a procedure call
1735 N_Attribute_Reference
=>
1736 if Is_Procedure_Attribute_Name
(Attribute_Name
(P
)) then
1737 if P
= Wrapped_Node
then
1738 Store_Before_Actions_In_Scope
(Ins_Actions
);
1740 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
1745 -- In the subexpression case, keep climbing
1751 -- For all other node types, keep climbing tree
1755 N_Accept_Alternative |
1756 N_Access_Definition |
1757 N_Access_Function_Definition |
1758 N_Access_Procedure_Definition |
1759 N_Access_To_Object_Definition |
1762 N_Case_Statement_Alternative |
1763 N_Character_Literal |
1764 N_Compilation_Unit |
1765 N_Compilation_Unit_Aux |
1766 N_Component_Clause |
1767 N_Component_Declaration |
1769 N_Constrained_Array_Definition |
1770 N_Decimal_Fixed_Point_Definition |
1771 N_Defining_Character_Literal |
1772 N_Defining_Identifier |
1773 N_Defining_Operator_Symbol |
1774 N_Defining_Program_Unit_Name |
1775 N_Delay_Alternative |
1776 N_Delta_Constraint |
1777 N_Derived_Type_Definition |
1779 N_Digits_Constraint |
1780 N_Discriminant_Association |
1781 N_Discriminant_Specification |
1783 N_Entry_Body_Formal_Part |
1784 N_Entry_Call_Alternative |
1785 N_Entry_Declaration |
1786 N_Entry_Index_Specification |
1787 N_Enumeration_Type_Definition |
1789 N_Exception_Handler |
1791 N_Explicit_Dereference |
1792 N_Extension_Aggregate |
1793 N_Floating_Point_Definition |
1794 N_Formal_Decimal_Fixed_Point_Definition |
1795 N_Formal_Derived_Type_Definition |
1796 N_Formal_Discrete_Type_Definition |
1797 N_Formal_Floating_Point_Definition |
1798 N_Formal_Modular_Type_Definition |
1799 N_Formal_Ordinary_Fixed_Point_Definition |
1800 N_Formal_Package_Declaration |
1801 N_Formal_Private_Type_Definition |
1802 N_Formal_Signed_Integer_Type_Definition |
1804 N_Function_Specification |
1805 N_Generic_Association |
1806 N_Handled_Sequence_Of_Statements |
1809 N_Index_Or_Discriminant_Constraint |
1810 N_Indexed_Component |
1814 N_Loop_Parameter_Specification |
1816 N_Modular_Type_Definition |
1842 N_Op_Shift_Right_Arithmetic |
1846 N_Ordinary_Fixed_Point_Definition |
1848 N_Package_Specification |
1849 N_Parameter_Association |
1850 N_Parameter_Specification |
1851 N_Pragma_Argument_Association |
1852 N_Procedure_Specification |
1854 N_Protected_Definition |
1855 N_Qualified_Expression |
1857 N_Range_Constraint |
1859 N_Real_Range_Specification |
1860 N_Record_Definition |
1862 N_Selected_Component |
1863 N_Signed_Integer_Type_Definition |
1864 N_Single_Protected_Declaration |
1868 N_Subtype_Indication |
1871 N_Terminate_Alternative |
1872 N_Triggering_Alternative |
1874 N_Unchecked_Expression |
1875 N_Unchecked_Type_Conversion |
1876 N_Unconstrained_Array_Definition |
1879 N_Use_Package_Clause |
1883 N_Validate_Unchecked_Conversion |
1891 -- Make sure that inserted actions stay in the transient scope
1893 if P
= Wrapped_Node
then
1894 Store_Before_Actions_In_Scope
(Ins_Actions
);
1898 -- If we fall through above tests, keep climbing tree
1902 if Nkind
(Parent
(N
)) = N_Subunit
then
1904 -- This is the proper body corresponding to a stub. Insertion
1905 -- must be done at the point of the stub, which is in the decla-
1906 -- tive part of the parent unit.
1908 P
:= Corresponding_Stub
(Parent
(N
));
1917 -- Version with check(s) suppressed
1919 procedure Insert_Actions
1920 (Assoc_Node
: Node_Id
; Ins_Actions
: List_Id
; Suppress
: Check_Id
)
1923 if Suppress
= All_Checks
then
1925 Svg
: constant Suppress_Record
:= Scope_Suppress
;
1928 Scope_Suppress
:= (others => True);
1929 Insert_Actions
(Assoc_Node
, Ins_Actions
);
1930 Scope_Suppress
:= Svg
;
1935 Svg
: constant Boolean := Get_Scope_Suppress
(Suppress
);
1938 Set_Scope_Suppress
(Suppress
, True);
1939 Insert_Actions
(Assoc_Node
, Ins_Actions
);
1940 Set_Scope_Suppress
(Suppress
, Svg
);
1945 --------------------------
1946 -- Insert_Actions_After --
1947 --------------------------
1949 procedure Insert_Actions_After
1950 (Assoc_Node
: Node_Id
;
1951 Ins_Actions
: List_Id
)
1954 if Scope_Is_Transient
1955 and then Assoc_Node
= Node_To_Be_Wrapped
1957 Store_After_Actions_In_Scope
(Ins_Actions
);
1959 Insert_List_After_And_Analyze
(Assoc_Node
, Ins_Actions
);
1961 end Insert_Actions_After
;
1963 ---------------------------------
1964 -- Insert_Library_Level_Action --
1965 ---------------------------------
1967 procedure Insert_Library_Level_Action
(N
: Node_Id
) is
1968 Aux
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Main_Unit
));
1971 New_Scope
(Cunit_Entity
(Main_Unit
));
1973 if No
(Actions
(Aux
)) then
1974 Set_Actions
(Aux
, New_List
(N
));
1976 Append
(N
, Actions
(Aux
));
1981 end Insert_Library_Level_Action
;
1983 ----------------------------------
1984 -- Insert_Library_Level_Actions --
1985 ----------------------------------
1987 procedure Insert_Library_Level_Actions
(L
: List_Id
) is
1988 Aux
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Main_Unit
));
1991 if Is_Non_Empty_List
(L
) then
1992 New_Scope
(Cunit_Entity
(Main_Unit
));
1994 if No
(Actions
(Aux
)) then
1995 Set_Actions
(Aux
, L
);
1998 Insert_List_After_And_Analyze
(Last
(Actions
(Aux
)), L
);
2003 end Insert_Library_Level_Actions
;
2005 ----------------------
2006 -- Inside_Init_Proc --
2007 ----------------------
2009 function Inside_Init_Proc
return Boolean is
2014 while S
/= Standard_Standard
loop
2015 if Chars
(S
) = Name_uInit_Proc
then
2023 end Inside_Init_Proc
;
2025 --------------------------------
2026 -- Is_Ref_To_Bit_Packed_Array --
2027 --------------------------------
2029 function Is_Ref_To_Bit_Packed_Array
(P
: Node_Id
) return Boolean is
2034 if Nkind
(P
) = N_Indexed_Component
2036 Nkind
(P
) = N_Selected_Component
2038 if Is_Bit_Packed_Array
(Etype
(Prefix
(P
))) then
2041 Result
:= Is_Ref_To_Bit_Packed_Array
(Prefix
(P
));
2044 if Result
and then Nkind
(P
) = N_Indexed_Component
then
2045 Expr
:= First
(Expressions
(P
));
2047 while Present
(Expr
) loop
2048 Force_Evaluation
(Expr
);
2058 end Is_Ref_To_Bit_Packed_Array
;
2060 --------------------------------
2061 -- Is_Ref_To_Bit_Packed_Slce --
2062 --------------------------------
2064 function Is_Ref_To_Bit_Packed_Slice
(P
: Node_Id
) return Boolean is
2066 if Nkind
(P
) = N_Slice
2067 and then Is_Bit_Packed_Array
(Etype
(Prefix
(P
)))
2071 elsif Nkind
(P
) = N_Indexed_Component
2073 Nkind
(P
) = N_Selected_Component
2075 return Is_Ref_To_Bit_Packed_Slice
(Prefix
(P
));
2080 end Is_Ref_To_Bit_Packed_Slice
;
2082 -----------------------
2083 -- Is_Renamed_Object --
2084 -----------------------
2086 function Is_Renamed_Object
(N
: Node_Id
) return Boolean is
2087 Pnod
: constant Node_Id
:= Parent
(N
);
2088 Kind
: constant Node_Kind
:= Nkind
(Pnod
);
2091 if Kind
= N_Object_Renaming_Declaration
then
2094 elsif Kind
= N_Indexed_Component
2095 or else Kind
= N_Selected_Component
2097 return Is_Renamed_Object
(Pnod
);
2102 end Is_Renamed_Object
;
2104 ----------------------------
2105 -- Is_Untagged_Derivation --
2106 ----------------------------
2108 function Is_Untagged_Derivation
(T
: Entity_Id
) return Boolean is
2110 return (not Is_Tagged_Type
(T
) and then Is_Derived_Type
(T
))
2112 (Is_Private_Type
(T
) and then Present
(Full_View
(T
))
2113 and then not Is_Tagged_Type
(Full_View
(T
))
2114 and then Is_Derived_Type
(Full_View
(T
))
2115 and then Etype
(Full_View
(T
)) /= T
);
2117 end Is_Untagged_Derivation
;
2119 --------------------
2120 -- Kill_Dead_Code --
2121 --------------------
2123 procedure Kill_Dead_Code
(N
: Node_Id
) is
2126 Remove_Handler_Entries
(N
);
2127 Remove_Warning_Messages
(N
);
2129 -- Recurse into block statements and bodies to process declarations
2132 if Nkind
(N
) = N_Block_Statement
2133 or else Nkind
(N
) = N_Subprogram_Body
2134 or else Nkind
(N
) = N_Package_Body
2136 Kill_Dead_Code
(Declarations
(N
));
2137 Kill_Dead_Code
(Statements
(Handled_Statement_Sequence
(N
)));
2139 if Nkind
(N
) = N_Subprogram_Body
then
2140 Set_Is_Eliminated
(Defining_Entity
(N
));
2143 -- Recurse into composite statement to kill individual statements,
2144 -- in particular instantiations.
2146 elsif Nkind
(N
) = N_If_Statement
then
2147 Kill_Dead_Code
(Then_Statements
(N
));
2148 Kill_Dead_Code
(Elsif_Parts
(N
));
2149 Kill_Dead_Code
(Else_Statements
(N
));
2151 elsif Nkind
(N
) = N_Loop_Statement
then
2152 Kill_Dead_Code
(Statements
(N
));
2154 elsif Nkind
(N
) = N_Case_Statement
then
2156 Alt
: Node_Id
:= First
(Alternatives
(N
));
2159 while Present
(Alt
) loop
2160 Kill_Dead_Code
(Statements
(Alt
));
2165 -- Deal with dead instances caused by deleting instantiations
2167 elsif Nkind
(N
) in N_Generic_Instantiation
then
2168 Remove_Dead_Instance
(N
);
2175 -- Case where argument is a list of nodes to be killed
2177 procedure Kill_Dead_Code
(L
: List_Id
) is
2181 if Is_Non_Empty_List
(L
) then
2183 N
:= Remove_Head
(L
);
2190 ------------------------
2191 -- Known_Non_Negative --
2192 ------------------------
2194 function Known_Non_Negative
(Opnd
: Node_Id
) return Boolean is
2196 if Is_OK_Static_Expression
(Opnd
)
2197 and then Expr_Value
(Opnd
) >= 0
2203 Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Opnd
));
2207 Is_OK_Static_Expression
(Lo
) and then Expr_Value
(Lo
) >= 0;
2210 end Known_Non_Negative
;
2212 --------------------------
2213 -- Target_Has_Fixed_Ops --
2214 --------------------------
2216 Integer_Sized_Small
: Ureal
;
2217 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this
2218 -- function is called (we don't want to compute it more than once!)
2220 Long_Integer_Sized_Small
: Ureal
;
2221 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
2222 -- functoin is called (we don't want to compute it more than once)
2224 First_Time_For_THFO
: Boolean := True;
2225 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
2227 function Target_Has_Fixed_Ops
2228 (Left_Typ
: Entity_Id
;
2229 Right_Typ
: Entity_Id
;
2230 Result_Typ
: Entity_Id
)
2233 function Is_Fractional_Type
(Typ
: Entity_Id
) return Boolean;
2234 -- Return True if the given type is a fixed-point type with a small
2235 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
2236 -- an absolute value less than 1.0. This is currently limited
2237 -- to fixed-point types that map to Integer or Long_Integer.
2239 ------------------------
2240 -- Is_Fractional_Type --
2241 ------------------------
2243 function Is_Fractional_Type
(Typ
: Entity_Id
) return Boolean is
2245 if Esize
(Typ
) = Standard_Integer_Size
then
2246 return Small_Value
(Typ
) = Integer_Sized_Small
;
2248 elsif Esize
(Typ
) = Standard_Long_Integer_Size
then
2249 return Small_Value
(Typ
) = Long_Integer_Sized_Small
;
2254 end Is_Fractional_Type
;
2256 -- Start of processing for Target_Has_Fixed_Ops
2259 -- Return False if Fractional_Fixed_Ops_On_Target is false
2261 if not Fractional_Fixed_Ops_On_Target
then
2265 -- Here the target has Fractional_Fixed_Ops, if first time, compute
2266 -- standard constants used by Is_Fractional_Type.
2268 if First_Time_For_THFO
then
2269 First_Time_For_THFO
:= False;
2271 Integer_Sized_Small
:=
2274 Den
=> UI_From_Int
(Standard_Integer_Size
- 1),
2277 Long_Integer_Sized_Small
:=
2280 Den
=> UI_From_Int
(Standard_Long_Integer_Size
- 1),
2284 -- Return True if target supports fixed-by-fixed multiply/divide
2285 -- for fractional fixed-point types (see Is_Fractional_Type) and
2286 -- the operand and result types are equivalent fractional types.
2288 return Is_Fractional_Type
(Base_Type
(Left_Typ
))
2289 and then Is_Fractional_Type
(Base_Type
(Right_Typ
))
2290 and then Is_Fractional_Type
(Base_Type
(Result_Typ
))
2291 and then Esize
(Left_Typ
) = Esize
(Right_Typ
)
2292 and then Esize
(Left_Typ
) = Esize
(Result_Typ
);
2293 end Target_Has_Fixed_Ops
;
2295 -----------------------------
2296 -- Make_CW_Equivalent_Type --
2297 -----------------------------
2299 -- Create a record type used as an equivalent of any member
2300 -- of the class which takes its size from exp.
2302 -- Generate the following code:
2304 -- type Equiv_T is record
2305 -- _parent : T (List of discriminant constaints taken from Exp);
2306 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'size) / Storage_Unit);
2309 function Make_CW_Equivalent_Type
2314 Loc
: constant Source_Ptr
:= Sloc
(E
);
2315 Root_Typ
: constant Entity_Id
:= Root_Type
(T
);
2316 Equiv_Type
: Entity_Id
;
2317 Range_Type
: Entity_Id
;
2318 Str_Type
: Entity_Id
;
2319 List_Def
: List_Id
:= Empty_List
;
2320 Constr_Root
: Entity_Id
;
2324 if not Has_Discriminants
(Root_Typ
) then
2325 Constr_Root
:= Root_Typ
;
2328 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
2330 -- subtype cstr__n is T (List of discr constraints taken from Exp)
2332 Append_To
(List_Def
,
2333 Make_Subtype_Declaration
(Loc
,
2334 Defining_Identifier
=> Constr_Root
,
2335 Subtype_Indication
=>
2336 Make_Subtype_From_Expr
(E
, Root_Typ
)));
2339 -- subtype rg__xx is Storage_Offset range
2340 -- (Expr'size - typ'size) / Storage_Unit
2342 Range_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('G'));
2345 Make_Op_Subtract
(Loc
,
2347 Make_Attribute_Reference
(Loc
,
2349 OK_Convert_To
(T
, Duplicate_Subexpr_No_Checks
(E
)),
2350 Attribute_Name
=> Name_Size
),
2352 Make_Attribute_Reference
(Loc
,
2353 Prefix
=> New_Reference_To
(Constr_Root
, Loc
),
2354 Attribute_Name
=> Name_Size
));
2356 Set_Paren_Count
(Sizexpr
, 1);
2358 Append_To
(List_Def
,
2359 Make_Subtype_Declaration
(Loc
,
2360 Defining_Identifier
=> Range_Type
,
2361 Subtype_Indication
=>
2362 Make_Subtype_Indication
(Loc
,
2363 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
),
2364 Constraint
=> Make_Range_Constraint
(Loc
,
2367 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
2369 Make_Op_Divide
(Loc
,
2370 Left_Opnd
=> Sizexpr
,
2371 Right_Opnd
=> Make_Integer_Literal
(Loc
,
2372 Intval
=> System_Storage_Unit
)))))));
2374 -- subtype str__nn is Storage_Array (rg__x);
2376 Str_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
2377 Append_To
(List_Def
,
2378 Make_Subtype_Declaration
(Loc
,
2379 Defining_Identifier
=> Str_Type
,
2380 Subtype_Indication
=>
2381 Make_Subtype_Indication
(Loc
,
2382 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Storage_Array
), Loc
),
2384 Make_Index_Or_Discriminant_Constraint
(Loc
,
2386 New_List
(New_Reference_To
(Range_Type
, Loc
))))));
2388 -- type Equiv_T is record
2393 Equiv_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
2395 -- Avoid the generation of an init procedure
2397 Set_Is_Frozen
(Equiv_Type
);
2399 Set_Ekind
(Equiv_Type
, E_Record_Type
);
2400 Set_Parent_Subtype
(Equiv_Type
, Constr_Root
);
2402 Append_To
(List_Def
,
2403 Make_Full_Type_Declaration
(Loc
,
2404 Defining_Identifier
=> Equiv_Type
,
2407 Make_Record_Definition
(Loc
,
2408 Component_List
=> Make_Component_List
(Loc
,
2409 Component_Items
=> New_List
(
2410 Make_Component_Declaration
(Loc
,
2411 Defining_Identifier
=>
2412 Make_Defining_Identifier
(Loc
, Name_uParent
),
2413 Subtype_Indication
=> New_Reference_To
(Constr_Root
, Loc
)),
2415 Make_Component_Declaration
(Loc
,
2416 Defining_Identifier
=>
2417 Make_Defining_Identifier
(Loc
,
2418 Chars
=> New_Internal_Name
('C')),
2419 Subtype_Indication
=> New_Reference_To
(Str_Type
, Loc
))),
2420 Variant_Part
=> Empty
))));
2422 Insert_Actions
(E
, List_Def
);
2424 end Make_CW_Equivalent_Type
;
2426 ------------------------
2427 -- Make_Literal_Range --
2428 ------------------------
2430 function Make_Literal_Range
2432 Literal_Typ
: Entity_Id
)
2436 New_Copy_Tree
(String_Literal_Low_Bound
(Literal_Typ
));
2439 Set_Analyzed
(Lo
, False);
2446 Make_Op_Subtract
(Loc
,
2449 Left_Opnd
=> New_Copy_Tree
(Lo
),
2451 Make_Integer_Literal
(Loc
,
2452 String_Literal_Length
(Literal_Typ
))),
2453 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
2454 end Make_Literal_Range
;
2456 ----------------------------
2457 -- Make_Subtype_From_Expr --
2458 ----------------------------
2460 -- 1. If Expr is an uncontrained array expression, creates
2461 -- Unc_Type(Expr'first(1)..Expr'Last(1),..., Expr'first(n)..Expr'last(n))
2463 -- 2. If Expr is a unconstrained discriminated type expression, creates
2464 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
2466 -- 3. If Expr is class-wide, creates an implicit class wide subtype
2468 function Make_Subtype_From_Expr
2470 Unc_Typ
: Entity_Id
)
2473 Loc
: constant Source_Ptr
:= Sloc
(E
);
2474 List_Constr
: List_Id
:= New_List
;
2477 Full_Subtyp
: Entity_Id
;
2478 Priv_Subtyp
: Entity_Id
;
2483 if Is_Private_Type
(Unc_Typ
)
2484 and then Has_Unknown_Discriminants
(Unc_Typ
)
2486 -- Prepare the subtype completion
2488 Utyp
:= Underlying_Type
(Unc_Typ
);
2489 Full_Subtyp
:= Make_Defining_Identifier
(Loc
,
2490 New_Internal_Name
('C'));
2492 Unchecked_Convert_To
2493 (Utyp
, Duplicate_Subexpr_No_Checks
(E
));
2494 Set_Parent
(Full_Exp
, Parent
(E
));
2497 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
2500 Make_Subtype_Declaration
(Loc
,
2501 Defining_Identifier
=> Full_Subtyp
,
2502 Subtype_Indication
=> Make_Subtype_From_Expr
(Full_Exp
, Utyp
)));
2504 -- Define the dummy private subtype
2506 Set_Ekind
(Priv_Subtyp
, Subtype_Kind
(Ekind
(Unc_Typ
)));
2507 Set_Etype
(Priv_Subtyp
, Unc_Typ
);
2508 Set_Scope
(Priv_Subtyp
, Full_Subtyp
);
2509 Set_Is_Constrained
(Priv_Subtyp
);
2510 Set_Is_Tagged_Type
(Priv_Subtyp
, Is_Tagged_Type
(Unc_Typ
));
2511 Set_Is_Itype
(Priv_Subtyp
);
2512 Set_Associated_Node_For_Itype
(Priv_Subtyp
, E
);
2514 if Is_Tagged_Type
(Priv_Subtyp
) then
2516 (Base_Type
(Priv_Subtyp
), Class_Wide_Type
(Unc_Typ
));
2517 Set_Primitive_Operations
(Priv_Subtyp
,
2518 Primitive_Operations
(Unc_Typ
));
2521 Set_Full_View
(Priv_Subtyp
, Full_Subtyp
);
2523 return New_Reference_To
(Priv_Subtyp
, Loc
);
2525 elsif Is_Array_Type
(Unc_Typ
) then
2526 for J
in 1 .. Number_Dimensions
(Unc_Typ
) loop
2527 Append_To
(List_Constr
,
2530 Make_Attribute_Reference
(Loc
,
2531 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
2532 Attribute_Name
=> Name_First
,
2533 Expressions
=> New_List
(
2534 Make_Integer_Literal
(Loc
, J
))),
2537 Make_Attribute_Reference
(Loc
,
2538 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
2539 Attribute_Name
=> Name_Last
,
2540 Expressions
=> New_List
(
2541 Make_Integer_Literal
(Loc
, J
)))));
2544 elsif Is_Class_Wide_Type
(Unc_Typ
) then
2546 CW_Subtype
: Entity_Id
;
2547 EQ_Typ
: Entity_Id
:= Empty
;
2550 -- A class-wide equivalent type is not needed when Java_VM
2551 -- because the JVM back end handles the class-wide object
2552 -- initialization itself (and doesn't need or want the
2553 -- additional intermediate type to handle the assignment).
2555 if Expander_Active
and then not Java_VM
then
2556 EQ_Typ
:= Make_CW_Equivalent_Type
(Unc_Typ
, E
);
2559 CW_Subtype
:= New_Class_Wide_Subtype
(Unc_Typ
, E
);
2560 Set_Equivalent_Type
(CW_Subtype
, EQ_Typ
);
2561 Set_Cloned_Subtype
(CW_Subtype
, Base_Type
(Unc_Typ
));
2563 return New_Occurrence_Of
(CW_Subtype
, Loc
);
2567 D
:= First_Discriminant
(Unc_Typ
);
2568 while (Present
(D
)) loop
2570 Append_To
(List_Constr
,
2571 Make_Selected_Component
(Loc
,
2572 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
2573 Selector_Name
=> New_Reference_To
(D
, Loc
)));
2575 Next_Discriminant
(D
);
2580 Make_Subtype_Indication
(Loc
,
2581 Subtype_Mark
=> New_Reference_To
(Unc_Typ
, Loc
),
2583 Make_Index_Or_Discriminant_Constraint
(Loc
,
2584 Constraints
=> List_Constr
));
2585 end Make_Subtype_From_Expr
;
2587 -----------------------------
2588 -- May_Generate_Large_Temp --
2589 -----------------------------
2591 -- At the current time, the only types that we return False for (i.e.
2592 -- where we decide we know they cannot generate large temps) are ones
2593 -- where we know the size is 128 bits or less at compile time, and we
2594 -- are still not doing a thorough job on arrays and records ???
2596 function May_Generate_Large_Temp
(Typ
: Entity_Id
) return Boolean is
2598 if not Stack_Checking_Enabled
then
2601 elsif not Size_Known_At_Compile_Time
(Typ
) then
2604 elsif Esize
(Typ
) /= 0 and then Esize
(Typ
) <= 256 then
2607 elsif Is_Array_Type
(Typ
)
2608 and then Present
(Packed_Array_Type
(Typ
))
2610 return May_Generate_Large_Temp
(Packed_Array_Type
(Typ
));
2612 -- We could do more here to find other small types ???
2617 end May_Generate_Large_Temp
;
2619 ----------------------------
2620 -- New_Class_Wide_Subtype --
2621 ----------------------------
2623 function New_Class_Wide_Subtype
2624 (CW_Typ
: Entity_Id
;
2628 Res
: Entity_Id
:= Create_Itype
(E_Void
, N
);
2629 Res_Name
: constant Name_Id
:= Chars
(Res
);
2630 Res_Scope
: Entity_Id
:= Scope
(Res
);
2633 Copy_Node
(CW_Typ
, Res
);
2634 Set_Sloc
(Res
, Sloc
(N
));
2636 Set_Associated_Node_For_Itype
(Res
, N
);
2637 Set_Is_Public
(Res
, False); -- By default, may be changed below.
2638 Set_Public_Status
(Res
);
2639 Set_Chars
(Res
, Res_Name
);
2640 Set_Scope
(Res
, Res_Scope
);
2641 Set_Ekind
(Res
, E_Class_Wide_Subtype
);
2642 Set_Next_Entity
(Res
, Empty
);
2643 Set_Etype
(Res
, Base_Type
(CW_Typ
));
2644 Set_Freeze_Node
(Res
, Empty
);
2646 end New_Class_Wide_Subtype
;
2648 -------------------------
2649 -- Remove_Side_Effects --
2650 -------------------------
2652 procedure Remove_Side_Effects
2654 Name_Req
: Boolean := False;
2655 Variable_Ref
: Boolean := False)
2657 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
2658 Exp_Type
: constant Entity_Id
:= Etype
(Exp
);
2659 Svg_Suppress
: constant Suppress_Record
:= Scope_Suppress
;
2661 Ref_Type
: Entity_Id
;
2663 Ptr_Typ_Decl
: Node_Id
;
2667 function Side_Effect_Free
(N
: Node_Id
) return Boolean;
2668 -- Determines if the tree N represents an expession that is known
2669 -- not to have side effects, and for which no processing is required.
2671 function Side_Effect_Free
(L
: List_Id
) return Boolean;
2672 -- Determines if all elements of the list L are side effect free
2674 function Mutable_Dereference
(N
: Node_Id
) return Boolean;
2675 -- If a selected component involves an implicit dereference and
2676 -- the type of the prefix is not an_access_to_constant, the node
2677 -- must be evaluated because it may be affected by a subsequent
2680 -------------------------
2681 -- Mutable_Dereference --
2682 -------------------------
2684 function Mutable_Dereference
(N
: Node_Id
) return Boolean is
2686 return Nkind
(N
) = N_Selected_Component
2687 and then Is_Access_Type
(Etype
(Prefix
(N
)))
2688 and then not Is_Access_Constant
(Etype
(Prefix
(N
)))
2689 and then Variable_Ref
;
2690 end Mutable_Dereference
;
2692 ----------------------
2693 -- Side_Effect_Free --
2694 ----------------------
2696 function Side_Effect_Free
(N
: Node_Id
) return Boolean is
2697 K
: constant Node_Kind
:= Nkind
(N
);
2700 -- Note on checks that could raise Constraint_Error. Strictly, if
2701 -- we take advantage of 11.6, these checks do not count as side
2702 -- effects. However, we would just as soon consider that they are
2703 -- side effects, since the backend CSE does not work very well on
2704 -- expressions which can raise Constraint_Error. On the other
2705 -- hand, if we do not consider them to be side effect free, then
2706 -- we get some awkward expansions in -gnato mode, resulting in
2707 -- code insertions at a point where we do not have a clear model
2708 -- for performing the insertions. See 4908-002/comment for details.
2710 -- An attribute reference is side effect free if its expressions
2711 -- are side effect free and its prefix is (could be a dereference
2712 -- or an indexed retrieval for example).
2714 if K
= N_Attribute_Reference
then
2715 return Side_Effect_Free
(Expressions
(N
))
2716 and then (Is_Entity_Name
(Prefix
(N
))
2717 or else Side_Effect_Free
(Prefix
(N
)));
2719 -- An entity is side effect free unless it is a function call, or
2720 -- a reference to a volatile variable and Name_Req is False. If
2721 -- Name_Req is True then we can't help returning a name which
2722 -- effectively allows multiple references in any case.
2724 elsif Is_Entity_Name
(N
)
2725 and then Ekind
(Entity
(N
)) /= E_Function
2726 and then (not Is_Volatile
(Entity
(N
)) or else Name_Req
)
2728 -- If the entity is a constant, it is definitely side effect
2729 -- free. Note that the test of Is_Variable (N) below might
2730 -- be expected to catch this case, but it does not, because
2731 -- this test goes to the original tree, and we may have
2732 -- already rewritten a variable node with a constant as
2733 -- a result of an earlier Force_Evaluation call.
2735 if Ekind
(Entity
(N
)) = E_Constant
then
2738 -- If the Variable_Ref flag is set, any variable reference is
2739 -- is considered a side-effect
2741 elsif Variable_Ref
then
2742 return not Is_Variable
(N
);
2748 -- A value known at compile time is always side effect free
2750 elsif Compile_Time_Known_Value
(N
) then
2753 -- Literals are always side-effect free
2755 elsif (K
= N_Integer_Literal
2756 or else K
= N_Real_Literal
2757 or else K
= N_Character_Literal
2758 or else K
= N_String_Literal
2760 and then not Raises_Constraint_Error
(N
)
2764 -- A type conversion or qualification is side effect free if the
2765 -- expression to be converted is side effect free.
2767 elsif K
= N_Type_Conversion
or else K
= N_Qualified_Expression
then
2768 return Side_Effect_Free
(Expression
(N
));
2770 -- An unchecked type conversion is never side effect free since we
2771 -- need to check whether it is safe.
2772 -- effect free if its argument is side effect free.
2774 elsif K
= N_Unchecked_Type_Conversion
then
2775 if Safe_Unchecked_Type_Conversion
(N
) then
2776 return Side_Effect_Free
(Expression
(N
));
2781 -- A unary operator is side effect free if the operand
2782 -- is side effect free.
2784 elsif K
in N_Unary_Op
then
2785 return Side_Effect_Free
(Right_Opnd
(N
));
2787 -- A binary operator is side effect free if and both operands
2788 -- are side effect free.
2790 elsif K
in N_Binary_Op
then
2791 return Side_Effect_Free
(Left_Opnd
(N
))
2792 and then Side_Effect_Free
(Right_Opnd
(N
));
2794 -- An explicit dereference or selected component is side effect
2795 -- free if its prefix is side effect free.
2797 elsif K
= N_Explicit_Dereference
2798 or else K
= N_Selected_Component
2800 return Side_Effect_Free
(Prefix
(N
))
2801 and then not Mutable_Dereference
(Prefix
(N
));
2803 -- An indexed component can be copied if the prefix is copyable
2804 -- and all the indexing expressions are copyable and there is
2805 -- no access check and no range checks.
2807 elsif K
= N_Indexed_Component
then
2808 return Side_Effect_Free
(Prefix
(N
))
2809 and then Side_Effect_Free
(Expressions
(N
));
2811 elsif K
= N_Unchecked_Expression
then
2812 return Side_Effect_Free
(Expression
(N
));
2814 -- A call to _rep_to_pos is side effect free, since we generate
2815 -- this pure function call ourselves. Moreover it is critically
2816 -- important to make this exception, since otherwise we can
2817 -- have discriminants in array components which don't look
2818 -- side effect free in the case of an array whose index type
2819 -- is an enumeration type with an enumeration rep clause.
2821 elsif K
= N_Function_Call
2822 and then Nkind
(Name
(N
)) = N_Identifier
2823 and then Chars
(Name
(N
)) = Name_uRep_To_Pos
2827 -- We consider that anything else has side effects. This is a bit
2828 -- crude, but we are pretty close for most common cases, and we
2829 -- are certainly correct (i.e. we never return True when the
2830 -- answer should be False).
2835 end Side_Effect_Free
;
2837 function Side_Effect_Free
(L
: List_Id
) return Boolean is
2841 if L
= No_List
or else L
= Error_List
then
2847 while Present
(N
) loop
2848 if not Side_Effect_Free
(N
) then
2857 end Side_Effect_Free
;
2859 -- Start of processing for Remove_Side_Effects
2862 -- If we are side effect free already or expansion is disabled,
2863 -- there is nothing to do.
2865 if Side_Effect_Free
(Exp
) or else not Expander_Active
then
2869 -- All the must not have any checks
2871 Scope_Suppress
:= (others => True);
2873 -- If the expression has the form v.all then we can just capture
2874 -- the pointer, and then do an explicit dereference on the result.
2876 if Nkind
(Exp
) = N_Explicit_Dereference
then
2878 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
2880 Make_Explicit_Dereference
(Loc
, New_Reference_To
(Def_Id
, Loc
));
2883 Make_Object_Declaration
(Loc
,
2884 Defining_Identifier
=> Def_Id
,
2885 Object_Definition
=>
2886 New_Reference_To
(Etype
(Prefix
(Exp
)), Loc
),
2887 Constant_Present
=> True,
2888 Expression
=> Relocate_Node
(Prefix
(Exp
))));
2890 -- If this is a type conversion, leave the type conversion and remove
2891 -- the side effects in the expression. This is important in several
2892 -- circumstances: for change of representations, and also when this
2893 -- is a view conversion to a smaller object, where gigi can end up
2894 -- its own temporary of the wrong size.
2896 -- ??? this transformation is inhibited for elementary types that are
2897 -- not involved in a change of representation because it causes
2898 -- regressions that are not fully understood yet.
2900 elsif Nkind
(Exp
) = N_Type_Conversion
2901 and then (not Is_Elementary_Type
(Underlying_Type
(Exp_Type
))
2902 or else Nkind
(Parent
(Exp
)) = N_Assignment_Statement
)
2904 Remove_Side_Effects
(Expression
(Exp
), Variable_Ref
);
2905 Scope_Suppress
:= Svg_Suppress
;
2908 -- For expressions that denote objects, we can use a renaming scheme.
2909 -- We skip using this if we have a volatile variable and we do not
2910 -- have Nam_Req set true (see comments above for Side_Effect_Free).
2911 -- We also skip this scheme for class-wide expressions in order to
2912 -- avoid recursive expension (see Expand_N_Object_Renaming_Declaration)
2913 -- If the object is a function call, we need to create a temporary and
2916 elsif Is_Object_Reference
(Exp
)
2917 and then Nkind
(Exp
) /= N_Function_Call
2918 and then not Variable_Ref
2920 or else not Is_Entity_Name
(Exp
)
2921 or else not Is_Volatile
(Entity
(Exp
)))
2922 and then not Is_Class_Wide_Type
(Exp_Type
)
2924 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
2926 if Nkind
(Exp
) = N_Selected_Component
2927 and then Nkind
(Prefix
(Exp
)) = N_Function_Call
2928 and then Is_Array_Type
(Etype
(Exp
))
2930 -- Avoid generating a variable-sized temporary, by generating
2931 -- the renaming declaration just for the function call. The
2932 -- transformation could be refined to apply only when the array
2933 -- component is constrained by a discriminant???
2936 Make_Selected_Component
(Loc
,
2937 Prefix
=> New_Occurrence_Of
(Def_Id
, Loc
),
2938 Selector_Name
=> Selector_Name
(Exp
));
2941 Make_Object_Renaming_Declaration
(Loc
,
2942 Defining_Identifier
=> Def_Id
,
2944 New_Reference_To
(Base_Type
(Etype
(Prefix
(Exp
))), Loc
),
2945 Name
=> Relocate_Node
(Prefix
(Exp
))));
2947 Res
:= New_Reference_To
(Def_Id
, Loc
);
2950 Make_Object_Renaming_Declaration
(Loc
,
2951 Defining_Identifier
=> Def_Id
,
2952 Subtype_Mark
=> New_Reference_To
(Exp_Type
, Loc
),
2953 Name
=> Relocate_Node
(Exp
)));
2956 -- If it is a scalar type, just make a copy.
2958 elsif Is_Elementary_Type
(Exp_Type
) then
2959 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
2960 Set_Etype
(Def_Id
, Exp_Type
);
2961 Res
:= New_Reference_To
(Def_Id
, Loc
);
2964 Make_Object_Declaration
(Loc
,
2965 Defining_Identifier
=> Def_Id
,
2966 Object_Definition
=> New_Reference_To
(Exp_Type
, Loc
),
2967 Constant_Present
=> True,
2968 Expression
=> Relocate_Node
(Exp
));
2970 Set_Assignment_OK
(E
);
2971 Insert_Action
(Exp
, E
);
2973 -- If this is an unchecked conversion that Gigi can't handle, make
2974 -- a copy or a use a renaming to capture the value.
2976 elsif (Nkind
(Exp
) = N_Unchecked_Type_Conversion
2977 and then not Safe_Unchecked_Type_Conversion
(Exp
))
2979 if Controlled_Type
(Etype
(Exp
)) then
2980 -- Use a renaming to capture the expression, rather than create
2981 -- a controlled temporary.
2983 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
2984 Res
:= New_Reference_To
(Def_Id
, Loc
);
2987 Make_Object_Renaming_Declaration
(Loc
,
2988 Defining_Identifier
=> Def_Id
,
2989 Subtype_Mark
=> New_Reference_To
(Exp_Type
, Loc
),
2990 Name
=> Relocate_Node
(Exp
)));
2993 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
2994 Set_Etype
(Def_Id
, Exp_Type
);
2995 Res
:= New_Reference_To
(Def_Id
, Loc
);
2998 Make_Object_Declaration
(Loc
,
2999 Defining_Identifier
=> Def_Id
,
3000 Object_Definition
=> New_Reference_To
(Exp_Type
, Loc
),
3001 Constant_Present
=> True,
3002 Expression
=> Relocate_Node
(Exp
));
3004 Set_Assignment_OK
(E
);
3005 Insert_Action
(Exp
, E
);
3008 -- Otherwise we generate a reference to the value
3011 Ref_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
3014 Make_Full_Type_Declaration
(Loc
,
3015 Defining_Identifier
=> Ref_Type
,
3017 Make_Access_To_Object_Definition
(Loc
,
3018 All_Present
=> True,
3019 Subtype_Indication
=>
3020 New_Reference_To
(Exp_Type
, Loc
)));
3023 Insert_Action
(Exp
, Ptr_Typ_Decl
);
3025 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
3026 Set_Etype
(Def_Id
, Exp_Type
);
3029 Make_Explicit_Dereference
(Loc
,
3030 Prefix
=> New_Reference_To
(Def_Id
, Loc
));
3032 if Nkind
(E
) = N_Explicit_Dereference
then
3033 New_Exp
:= Relocate_Node
(Prefix
(E
));
3035 E
:= Relocate_Node
(E
);
3036 New_Exp
:= Make_Reference
(Loc
, E
);
3039 if Nkind
(E
) = N_Aggregate
and then Expansion_Delayed
(E
) then
3040 Set_Expansion_Delayed
(E
, False);
3041 Set_Analyzed
(E
, False);
3045 Make_Object_Declaration
(Loc
,
3046 Defining_Identifier
=> Def_Id
,
3047 Object_Definition
=> New_Reference_To
(Ref_Type
, Loc
),
3048 Expression
=> New_Exp
));
3051 -- Preserve the Assignment_OK flag in all copies, since at least
3052 -- one copy may be used in a context where this flag must be set
3053 -- (otherwise why would the flag be set in the first place).
3055 Set_Assignment_OK
(Res
, Assignment_OK
(Exp
));
3057 -- Finally rewrite the original expression and we are done
3060 Analyze_And_Resolve
(Exp
, Exp_Type
);
3061 Scope_Suppress
:= Svg_Suppress
;
3062 end Remove_Side_Effects
;
3064 ------------------------------------
3065 -- Safe_Unchecked_Type_Conversion --
3066 ------------------------------------
3068 -- Note: this function knows quite a bit about the exact requirements
3069 -- of Gigi with respect to unchecked type conversions, and its code
3070 -- must be coordinated with any changes in Gigi in this area.
3072 -- The above requirements should be documented in Sinfo ???
3074 function Safe_Unchecked_Type_Conversion
(Exp
: Node_Id
) return Boolean is
3079 Pexp
: constant Node_Id
:= Parent
(Exp
);
3082 -- If the expression is the RHS of an assignment or object declaration
3083 -- we are always OK because there will always be a target.
3085 -- Object renaming declarations, (generated for view conversions of
3086 -- actuals in inlined calls), like object declarations, provide an
3087 -- explicit type, and are safe as well.
3089 if (Nkind
(Pexp
) = N_Assignment_Statement
3090 and then Expression
(Pexp
) = Exp
)
3091 or else Nkind
(Pexp
) = N_Object_Declaration
3092 or else Nkind
(Pexp
) = N_Object_Renaming_Declaration
3096 -- If the expression is the prefix of an N_Selected_Component
3097 -- we should also be OK because GCC knows to look inside the
3098 -- conversion except if the type is discriminated. We assume
3099 -- that we are OK anyway if the type is not set yet or if it is
3100 -- controlled since we can't afford to introduce a temporary in
3103 elsif Nkind
(Pexp
) = N_Selected_Component
3104 and then Prefix
(Pexp
) = Exp
3106 if No
(Etype
(Pexp
)) then
3110 not Has_Discriminants
(Etype
(Pexp
))
3111 or else Is_Constrained
(Etype
(Pexp
));
3115 -- Set the output type, this comes from Etype if it is set, otherwise
3116 -- we take it from the subtype mark, which we assume was already
3119 if Present
(Etype
(Exp
)) then
3120 Otyp
:= Etype
(Exp
);
3122 Otyp
:= Entity
(Subtype_Mark
(Exp
));
3125 -- The input type always comes from the expression, and we assume
3126 -- this is indeed always analyzed, so we can simply get the Etype.
3128 Ityp
:= Etype
(Expression
(Exp
));
3130 -- Initialize alignments to unknown so far
3135 -- Replace a concurrent type by its corresponding record type
3136 -- and each type by its underlying type and do the tests on those.
3137 -- The original type may be a private type whose completion is a
3138 -- concurrent type, so find the underlying type first.
3140 if Present
(Underlying_Type
(Otyp
)) then
3141 Otyp
:= Underlying_Type
(Otyp
);
3144 if Present
(Underlying_Type
(Ityp
)) then
3145 Ityp
:= Underlying_Type
(Ityp
);
3148 if Is_Concurrent_Type
(Otyp
) then
3149 Otyp
:= Corresponding_Record_Type
(Otyp
);
3152 if Is_Concurrent_Type
(Ityp
) then
3153 Ityp
:= Corresponding_Record_Type
(Ityp
);
3156 -- If the base types are the same, we know there is no problem since
3157 -- this conversion will be a noop.
3159 if Implementation_Base_Type
(Otyp
) = Implementation_Base_Type
(Ityp
) then
3162 -- If the size of output type is known at compile time, there is
3163 -- never a problem. Note that unconstrained records are considered
3164 -- to be of known size, but we can't consider them that way here,
3165 -- because we are talking about the actual size of the object.
3167 -- We also make sure that in addition to the size being known, we do
3168 -- not have a case which might generate an embarrassingly large temp
3169 -- in stack checking mode.
3171 elsif Size_Known_At_Compile_Time
(Otyp
)
3172 and then not May_Generate_Large_Temp
(Otyp
)
3173 and then not (Is_Record_Type
(Otyp
) and then not Is_Constrained
(Otyp
))
3177 -- If either type is tagged, then we know the alignment is OK so
3178 -- Gigi will be able to use pointer punning.
3180 elsif Is_Tagged_Type
(Otyp
) or else Is_Tagged_Type
(Ityp
) then
3183 -- If either type is a limited record type, we cannot do a copy, so
3184 -- say safe since there's nothing else we can do.
3186 elsif Is_Limited_Record
(Otyp
) or else Is_Limited_Record
(Ityp
) then
3189 -- Conversions to and from packed array types are always ignored and
3192 elsif Is_Packed_Array_Type
(Otyp
)
3193 or else Is_Packed_Array_Type
(Ityp
)
3198 -- The only other cases known to be safe is if the input type's
3199 -- alignment is known to be at least the maximum alignment for the
3200 -- target or if both alignments are known and the output type's
3201 -- alignment is no stricter than the input's. We can use the alignment
3202 -- of the component type of an array if a type is an unpacked
3205 if Present
(Alignment_Clause
(Otyp
)) then
3206 Oalign
:= Expr_Value
(Expression
(Alignment_Clause
(Otyp
)));
3208 elsif Is_Array_Type
(Otyp
)
3209 and then Present
(Alignment_Clause
(Component_Type
(Otyp
)))
3211 Oalign
:= Expr_Value
(Expression
(Alignment_Clause
3212 (Component_Type
(Otyp
))));
3215 if Present
(Alignment_Clause
(Ityp
)) then
3216 Ialign
:= Expr_Value
(Expression
(Alignment_Clause
(Ityp
)));
3218 elsif Is_Array_Type
(Ityp
)
3219 and then Present
(Alignment_Clause
(Component_Type
(Ityp
)))
3221 Ialign
:= Expr_Value
(Expression
(Alignment_Clause
3222 (Component_Type
(Ityp
))));
3225 if Ialign
/= No_Uint
and then Ialign
> Maximum_Alignment
then
3228 elsif Ialign
/= No_Uint
and then Oalign
/= No_Uint
3229 and then Ialign
<= Oalign
3233 -- Otherwise, Gigi cannot handle this and we must make a temporary.
3239 end Safe_Unchecked_Type_Conversion
;
3241 --------------------------
3242 -- Set_Elaboration_Flag --
3243 --------------------------
3245 procedure Set_Elaboration_Flag
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
3246 Loc
: constant Source_Ptr
:= Sloc
(N
);
3250 if Present
(Elaboration_Entity
(Spec_Id
)) then
3252 -- Nothing to do if at the compilation unit level, because in this
3253 -- case the flag is set by the binder generated elaboration routine.
3255 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
3258 -- Here we do need to generate an assignment statement
3261 Check_Restriction
(No_Elaboration_Code
, N
);
3263 Make_Assignment_Statement
(Loc
,
3264 Name
=> New_Occurrence_Of
(Elaboration_Entity
(Spec_Id
), Loc
),
3265 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
));
3267 if Nkind
(Parent
(N
)) = N_Subunit
then
3268 Insert_After
(Corresponding_Stub
(Parent
(N
)), Asn
);
3270 Insert_After
(N
, Asn
);
3276 end Set_Elaboration_Flag
;
3278 ----------------------------
3279 -- Wrap_Cleanup_Procedure --
3280 ----------------------------
3282 procedure Wrap_Cleanup_Procedure
(N
: Node_Id
) is
3283 Loc
: constant Source_Ptr
:= Sloc
(N
);
3284 Stseq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
3285 Stmts
: constant List_Id
:= Statements
(Stseq
);
3288 if Abort_Allowed
then
3289 Prepend_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
3290 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
3292 end Wrap_Cleanup_Procedure
;