1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Exp_Aggr
; use Exp_Aggr
;
33 with Exp_Ch6
; use Exp_Ch6
;
34 with Exp_Ch7
; use Exp_Ch7
;
35 with Inline
; use Inline
;
36 with Itypes
; use Itypes
;
38 with Nlists
; use Nlists
;
39 with Nmake
; use Nmake
;
41 with Restrict
; use Restrict
;
42 with Rident
; use Rident
;
44 with Sem_Ch8
; use Sem_Ch8
;
45 with Sem_Eval
; use Sem_Eval
;
46 with Sem_Res
; use Sem_Res
;
47 with Sem_Type
; use Sem_Type
;
48 with Sem_Util
; use Sem_Util
;
49 with Snames
; use Snames
;
50 with Stand
; use Stand
;
51 with Stringt
; use Stringt
;
52 with Targparm
; use Targparm
;
53 with Tbuild
; use Tbuild
;
54 with Ttypes
; use Ttypes
;
55 with Uintp
; use Uintp
;
56 with Urealp
; use Urealp
;
57 with Validsw
; use Validsw
;
59 package body Exp_Util
is
61 -----------------------
62 -- Local Subprograms --
63 -----------------------
65 function Build_Task_Array_Image
69 Dyn
: Boolean := False) return Node_Id
;
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
81 Res
: Entity_Id
) return Node_Id
;
82 -- Common processing for Task_Array_Image and Task_Record_Image.
83 -- Build function body that computes image.
85 procedure Build_Task_Image_Prefix
94 -- Common processing for Task_Array_Image and Task_Record_Image.
95 -- Create local variables and assign prefix of name to result string.
97 function Build_Task_Record_Image
100 Dyn
: Boolean := False) return Node_Id
;
101 -- Build function to generate the image string for a task that is a
102 -- record component. Concatenate name of variable with that of selector.
103 -- The flag Dyn indicates whether this is called for the initialization
104 -- procedure of record with task components, or for a dynamically
105 -- created task that is assigned to a selected component.
107 function Make_CW_Equivalent_Type
109 E
: Node_Id
) return Entity_Id
;
110 -- T is a class-wide type entity, E is the initial expression node that
111 -- constrains T in case such as: " X: T := E" or "new T'(E)"
112 -- This function returns the entity of the Equivalent type and inserts
113 -- on the fly the necessary declaration such as:
115 -- type anon is record
116 -- _parent : Root_Type (T); constrained with E discriminants (if any)
117 -- Extension : String (1 .. expr to match size of E);
120 -- This record is compatible with any object of the class of T thanks
121 -- to the first field and has the same size as E thanks to the second.
123 function Make_Literal_Range
125 Literal_Typ
: Entity_Id
) return Node_Id
;
126 -- Produce a Range node whose bounds are:
127 -- Low_Bound (Literal_Type) ..
128 -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
129 -- this is used for expanding declarations like X : String := "sdfgdfg";
131 -- If the index type of the target array is not integer, we generate:
132 -- Low_Bound (Literal_Type) ..
134 -- (Literal_Type'Pos (Low_Bound (Literal_Type))
135 -- + (Length (Literal_Typ) -1))
137 function New_Class_Wide_Subtype
139 N
: Node_Id
) return Entity_Id
;
140 -- Create an implicit subtype of CW_Typ attached to node N
142 ----------------------
143 -- Adjust_Condition --
144 ----------------------
146 procedure Adjust_Condition
(N
: Node_Id
) is
153 Loc
: constant Source_Ptr
:= Sloc
(N
);
154 T
: constant Entity_Id
:= Etype
(N
);
158 -- For now, we simply ignore a call where the argument has no
159 -- type (probably case of unanalyzed condition), or has a type
160 -- that is not Boolean. This is because this is a pretty marginal
161 -- piece of functionality, and violations of these rules are
162 -- likely to be truly marginal (how much code uses Fortran Logical
163 -- as the barrier to a protected entry?) and we do not want to
164 -- blow up existing programs. We can change this to an assertion
165 -- after 3.12a is released ???
167 if No
(T
) or else not Is_Boolean_Type
(T
) then
171 -- Apply validity checking if needed
173 if Validity_Checks_On
and Validity_Check_Tests
then
177 -- Immediate return if standard boolean, the most common case,
178 -- where nothing needs to be done.
180 if Base_Type
(T
) = Standard_Boolean
then
184 -- Case of zero/non-zero semantics or non-standard enumeration
185 -- representation. In each case, we rewrite the node as:
187 -- ityp!(N) /= False'Enum_Rep
189 -- where ityp is an integer type with large enough size to hold
190 -- any value of type T.
192 if Nonzero_Is_True
(T
) or else Has_Non_Standard_Rep
(T
) then
193 if Esize
(T
) <= Esize
(Standard_Integer
) then
194 Ti
:= Standard_Integer
;
196 Ti
:= Standard_Long_Long_Integer
;
201 Left_Opnd
=> Unchecked_Convert_To
(Ti
, N
),
203 Make_Attribute_Reference
(Loc
,
204 Attribute_Name
=> Name_Enum_Rep
,
206 New_Occurrence_Of
(First_Literal
(T
), Loc
))));
207 Analyze_And_Resolve
(N
, Standard_Boolean
);
210 Rewrite
(N
, Convert_To
(Standard_Boolean
, N
));
211 Analyze_And_Resolve
(N
, Standard_Boolean
);
214 end Adjust_Condition
;
216 ------------------------
217 -- Adjust_Result_Type --
218 ------------------------
220 procedure Adjust_Result_Type
(N
: Node_Id
; T
: Entity_Id
) is
222 -- Ignore call if current type is not Standard.Boolean
224 if Etype
(N
) /= Standard_Boolean
then
228 -- If result is already of correct type, nothing to do. Note that
229 -- this will get the most common case where everything has a type
230 -- of Standard.Boolean.
232 if Base_Type
(T
) = Standard_Boolean
then
237 KP
: constant Node_Kind
:= Nkind
(Parent
(N
));
240 -- If result is to be used as a Condition in the syntax, no need
241 -- to convert it back, since if it was changed to Standard.Boolean
242 -- using Adjust_Condition, that is just fine for this usage.
244 if KP
in N_Raise_xxx_Error
or else KP
in N_Has_Condition
then
247 -- If result is an operand of another logical operation, no need
248 -- to reset its type, since Standard.Boolean is just fine, and
249 -- such operations always do Adjust_Condition on their operands.
251 elsif KP
in N_Op_Boolean
252 or else KP
= N_And_Then
253 or else KP
= N_Or_Else
254 or else KP
= N_Op_Not
258 -- Otherwise we perform a conversion from the current type,
259 -- which must be Standard.Boolean, to the desired type.
263 Rewrite
(N
, Convert_To
(T
, N
));
264 Analyze_And_Resolve
(N
, T
);
268 end Adjust_Result_Type
;
270 --------------------------
271 -- Append_Freeze_Action --
272 --------------------------
274 procedure Append_Freeze_Action
(T
: Entity_Id
; N
: Node_Id
) is
278 Ensure_Freeze_Node
(T
);
279 Fnode
:= Freeze_Node
(T
);
281 if No
(Actions
(Fnode
)) then
282 Set_Actions
(Fnode
, New_List
);
285 Append
(N
, Actions
(Fnode
));
286 end Append_Freeze_Action
;
288 ---------------------------
289 -- Append_Freeze_Actions --
290 ---------------------------
292 procedure Append_Freeze_Actions
(T
: Entity_Id
; L
: List_Id
) is
293 Fnode
: constant Node_Id
:= Freeze_Node
(T
);
300 if No
(Actions
(Fnode
)) then
301 Set_Actions
(Fnode
, L
);
304 Append_List
(L
, Actions
(Fnode
));
308 end Append_Freeze_Actions
;
310 ------------------------
311 -- Build_Runtime_Call --
312 ------------------------
314 function Build_Runtime_Call
(Loc
: Source_Ptr
; RE
: RE_Id
) return Node_Id
is
316 -- If entity is not available, we can skip making the call (this avoids
317 -- junk duplicated error messages in a number of cases).
319 if not RTE_Available
(RE
) then
320 return Make_Null_Statement
(Loc
);
323 Make_Procedure_Call_Statement
(Loc
,
324 Name
=> New_Reference_To
(RTE
(RE
), Loc
));
326 end Build_Runtime_Call
;
328 ----------------------------
329 -- Build_Task_Array_Image --
330 ----------------------------
332 -- This function generates the body for a function that constructs the
333 -- image string for a task that is an array component. The function is
334 -- local to the init proc for the array type, and is called for each one
335 -- of the components. The constructed image has the form of an indexed
336 -- component, whose prefix is the outer variable of the array type.
337 -- The n-dimensional array type has known indices Index, Index2...
338 -- Id_Ref is an indexed component form created by the enclosing init proc.
339 -- Its successive indices are Val1, Val2,.. which are the loop variables
340 -- in the loops that call the individual task init proc on each component.
342 -- The generated function has the following structure:
344 -- function F return String is
345 -- Pref : string renames Task_Name;
346 -- T1 : String := Index1'Image (Val1);
348 -- Tn : String := indexn'image (Valn);
349 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
350 -- -- Len includes commas and the end parentheses.
351 -- Res : String (1..Len);
352 -- Pos : Integer := Pref'Length;
355 -- Res (1 .. Pos) := Pref;
359 -- Res (Pos .. Pos + T1'Length - 1) := T1;
360 -- Pos := Pos + T1'Length;
364 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
370 -- Needless to say, multidimensional arrays of tasks are rare enough
371 -- that the bulkiness of this code is not really a concern.
373 function Build_Task_Array_Image
377 Dyn
: Boolean := False) return Node_Id
379 Dims
: constant Nat
:= Number_Dimensions
(A_Type
);
380 -- Number of dimensions for array of tasks
382 Temps
: array (1 .. Dims
) of Entity_Id
;
383 -- Array of temporaries to hold string for each index
389 -- Total length of generated name
392 -- Running index for substring assignments
395 -- Name of enclosing variable, prefix of resulting name
398 -- String to hold result
401 -- Value of successive indices
404 -- Expression to compute total size of string
407 -- Entity for name at one index position
409 Decls
: constant List_Id
:= New_List
;
410 Stats
: constant List_Id
:= New_List
;
413 Pref
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
415 -- For a dynamic task, the name comes from the target variable.
416 -- For a static one it is a formal of the enclosing init proc.
419 Get_Name_String
(Chars
(Entity
(Prefix
(Id_Ref
))));
421 Make_Object_Declaration
(Loc
,
422 Defining_Identifier
=> Pref
,
423 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
425 Make_String_Literal
(Loc
,
426 Strval
=> String_From_Name_Buffer
)));
430 Make_Object_Renaming_Declaration
(Loc
,
431 Defining_Identifier
=> Pref
,
432 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
433 Name
=> Make_Identifier
(Loc
, Name_uTask_Name
)));
436 Indx
:= First_Index
(A_Type
);
437 Val
:= First
(Expressions
(Id_Ref
));
439 for J
in 1 .. Dims
loop
440 T
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
444 Make_Object_Declaration
(Loc
,
445 Defining_Identifier
=> T
,
446 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
448 Make_Attribute_Reference
(Loc
,
449 Attribute_Name
=> Name_Image
,
451 New_Occurrence_Of
(Etype
(Indx
), Loc
),
452 Expressions
=> New_List
(
453 New_Copy_Tree
(Val
)))));
459 Sum
:= Make_Integer_Literal
(Loc
, Dims
+ 1);
465 Make_Attribute_Reference
(Loc
,
466 Attribute_Name
=> Name_Length
,
468 New_Occurrence_Of
(Pref
, Loc
),
469 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1))));
471 for J
in 1 .. Dims
loop
476 Make_Attribute_Reference
(Loc
,
477 Attribute_Name
=> Name_Length
,
479 New_Occurrence_Of
(Temps
(J
), Loc
),
480 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1))));
483 Build_Task_Image_Prefix
(Loc
, Len
, Res
, Pos
, Pref
, Sum
, Decls
, Stats
);
485 Set_Character_Literal_Name
(Char_Code
(Character'Pos ('(')));
488 Make_Assignment_Statement
(Loc
,
489 Name
=> Make_Indexed_Component
(Loc
,
490 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
491 Expressions
=> New_List
(New_Occurrence_Of
(Pos
, Loc
))),
493 Make_Character_Literal
(Loc
,
495 Char_Literal_Value
=>
496 UI_From_Int
(Character'Pos ('(')))));
499 Make_Assignment_Statement
(Loc
,
500 Name
=> New_Occurrence_Of
(Pos
, Loc
),
503 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
504 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
506 for J
in 1 .. Dims
loop
509 Make_Assignment_Statement
(Loc
,
510 Name
=> Make_Slice
(Loc
,
511 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
514 Low_Bound
=> New_Occurrence_Of
(Pos
, Loc
),
515 High_Bound
=> Make_Op_Subtract
(Loc
,
518 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
520 Make_Attribute_Reference
(Loc
,
521 Attribute_Name
=> Name_Length
,
523 New_Occurrence_Of
(Temps
(J
), Loc
),
525 New_List
(Make_Integer_Literal
(Loc
, 1)))),
526 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
528 Expression
=> New_Occurrence_Of
(Temps
(J
), Loc
)));
532 Make_Assignment_Statement
(Loc
,
533 Name
=> New_Occurrence_Of
(Pos
, Loc
),
536 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
538 Make_Attribute_Reference
(Loc
,
539 Attribute_Name
=> Name_Length
,
540 Prefix
=> New_Occurrence_Of
(Temps
(J
), Loc
),
542 New_List
(Make_Integer_Literal
(Loc
, 1))))));
544 Set_Character_Literal_Name
(Char_Code
(Character'Pos (',')));
547 Make_Assignment_Statement
(Loc
,
548 Name
=> Make_Indexed_Component
(Loc
,
549 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
550 Expressions
=> New_List
(New_Occurrence_Of
(Pos
, Loc
))),
552 Make_Character_Literal
(Loc
,
554 Char_Literal_Value
=>
555 UI_From_Int
(Character'Pos (',')))));
558 Make_Assignment_Statement
(Loc
,
559 Name
=> New_Occurrence_Of
(Pos
, Loc
),
562 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
563 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
567 Set_Character_Literal_Name
(Char_Code
(Character'Pos (')')));
570 Make_Assignment_Statement
(Loc
,
571 Name
=> Make_Indexed_Component
(Loc
,
572 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
573 Expressions
=> New_List
(New_Occurrence_Of
(Len
, Loc
))),
575 Make_Character_Literal
(Loc
,
577 Char_Literal_Value
=>
578 UI_From_Int
(Character'Pos (')')))));
579 return Build_Task_Image_Function
(Loc
, Decls
, Stats
, Res
);
580 end Build_Task_Array_Image
;
582 ----------------------------
583 -- Build_Task_Image_Decls --
584 ----------------------------
586 function Build_Task_Image_Decls
590 In_Init_Proc
: Boolean := False) return List_Id
592 Decls
: constant List_Id
:= New_List
;
593 T_Id
: Entity_Id
:= Empty
;
595 Expr
: Node_Id
:= Empty
;
596 Fun
: Node_Id
:= Empty
;
597 Is_Dyn
: constant Boolean :=
598 Nkind
(Parent
(Id_Ref
)) = N_Assignment_Statement
600 Nkind
(Expression
(Parent
(Id_Ref
))) = N_Allocator
;
603 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
604 -- generate a dummy declaration only.
606 if Restriction_Active
(No_Implicit_Heap_Allocations
)
607 or else Global_Discard_Names
609 T_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('J'));
614 Make_Object_Declaration
(Loc
,
615 Defining_Identifier
=> T_Id
,
616 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
618 Make_String_Literal
(Loc
,
619 Strval
=> String_From_Name_Buffer
)));
622 if Nkind
(Id_Ref
) = N_Identifier
623 or else Nkind
(Id_Ref
) = N_Defining_Identifier
625 -- For a simple variable, the image of the task is built from
626 -- the name of the variable. To avoid possible conflict with
627 -- the anonymous type created for a single protected object,
628 -- add a numeric suffix.
631 Make_Defining_Identifier
(Loc
,
632 New_External_Name
(Chars
(Id_Ref
), 'T', 1));
634 Get_Name_String
(Chars
(Id_Ref
));
637 Make_String_Literal
(Loc
,
638 Strval
=> String_From_Name_Buffer
);
640 elsif Nkind
(Id_Ref
) = N_Selected_Component
then
642 Make_Defining_Identifier
(Loc
,
643 New_External_Name
(Chars
(Selector_Name
(Id_Ref
)), 'T'));
644 Fun
:= Build_Task_Record_Image
(Loc
, Id_Ref
, Is_Dyn
);
646 elsif Nkind
(Id_Ref
) = N_Indexed_Component
then
648 Make_Defining_Identifier
(Loc
,
649 New_External_Name
(Chars
(A_Type
), 'N'));
651 Fun
:= Build_Task_Array_Image
(Loc
, Id_Ref
, A_Type
, Is_Dyn
);
655 if Present
(Fun
) then
657 Expr
:= Make_Function_Call
(Loc
,
658 Name
=> New_Occurrence_Of
(Defining_Entity
(Fun
), Loc
));
660 if not In_Init_Proc
and then VM_Target
= No_VM
then
661 Set_Uses_Sec_Stack
(Defining_Entity
(Fun
));
665 Decl
:= Make_Object_Declaration
(Loc
,
666 Defining_Identifier
=> T_Id
,
667 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
668 Constant_Present
=> True,
671 Append
(Decl
, Decls
);
673 end Build_Task_Image_Decls
;
675 -------------------------------
676 -- Build_Task_Image_Function --
677 -------------------------------
679 function Build_Task_Image_Function
683 Res
: Entity_Id
) return Node_Id
689 Make_Simple_Return_Statement
(Loc
,
690 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
692 Spec
:= Make_Function_Specification
(Loc
,
693 Defining_Unit_Name
=>
694 Make_Defining_Identifier
(Loc
, New_Internal_Name
('F')),
695 Result_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
));
697 -- Calls to 'Image use the secondary stack, which must be cleaned
698 -- up after the task name is built.
700 return Make_Subprogram_Body
(Loc
,
701 Specification
=> Spec
,
702 Declarations
=> Decls
,
703 Handled_Statement_Sequence
=>
704 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stats
));
705 end Build_Task_Image_Function
;
707 -----------------------------
708 -- Build_Task_Image_Prefix --
709 -----------------------------
711 procedure Build_Task_Image_Prefix
722 Len
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('L'));
725 Make_Object_Declaration
(Loc
,
726 Defining_Identifier
=> Len
,
727 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
730 Res
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
733 Make_Object_Declaration
(Loc
,
734 Defining_Identifier
=> Res
,
736 Make_Subtype_Indication
(Loc
,
737 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
739 Make_Index_Or_Discriminant_Constraint
(Loc
,
743 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
744 High_Bound
=> New_Occurrence_Of
(Len
, Loc
)))))));
746 Pos
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
749 Make_Object_Declaration
(Loc
,
750 Defining_Identifier
=> Pos
,
751 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
)));
753 -- Pos := Prefix'Length;
756 Make_Assignment_Statement
(Loc
,
757 Name
=> New_Occurrence_Of
(Pos
, Loc
),
759 Make_Attribute_Reference
(Loc
,
760 Attribute_Name
=> Name_Length
,
761 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
763 New_List
(Make_Integer_Literal
(Loc
, 1)))));
765 -- Res (1 .. Pos) := Prefix;
768 Make_Assignment_Statement
(Loc
,
769 Name
=> Make_Slice
(Loc
,
770 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
773 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
774 High_Bound
=> New_Occurrence_Of
(Pos
, Loc
))),
776 Expression
=> New_Occurrence_Of
(Prefix
, Loc
)));
779 Make_Assignment_Statement
(Loc
,
780 Name
=> New_Occurrence_Of
(Pos
, Loc
),
783 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
784 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
785 end Build_Task_Image_Prefix
;
787 -----------------------------
788 -- Build_Task_Record_Image --
789 -----------------------------
791 function Build_Task_Record_Image
794 Dyn
: Boolean := False) return Node_Id
797 -- Total length of generated name
803 -- String to hold result
806 -- Name of enclosing variable, prefix of resulting name
809 -- Expression to compute total size of string
812 -- Entity for selector name
814 Decls
: constant List_Id
:= New_List
;
815 Stats
: constant 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_Object_Declaration
(Loc
,
827 Defining_Identifier
=> Pref
,
828 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
830 Make_String_Literal
(Loc
,
831 Strval
=> String_From_Name_Buffer
)));
835 Make_Object_Renaming_Declaration
(Loc
,
836 Defining_Identifier
=> Pref
,
837 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
838 Name
=> Make_Identifier
(Loc
, Name_uTask_Name
)));
841 Sel
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
843 Get_Name_String
(Chars
(Selector_Name
(Id_Ref
)));
846 Make_Object_Declaration
(Loc
,
847 Defining_Identifier
=> Sel
,
848 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
850 Make_String_Literal
(Loc
,
851 Strval
=> String_From_Name_Buffer
)));
853 Sum
:= Make_Integer_Literal
(Loc
, Nat
(Name_Len
+ 1));
859 Make_Attribute_Reference
(Loc
,
860 Attribute_Name
=> Name_Length
,
862 New_Occurrence_Of
(Pref
, Loc
),
863 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1))));
865 Build_Task_Image_Prefix
(Loc
, Len
, Res
, Pos
, Pref
, Sum
, Decls
, Stats
);
867 Set_Character_Literal_Name
(Char_Code
(Character'Pos ('.')));
872 Make_Assignment_Statement
(Loc
,
873 Name
=> Make_Indexed_Component
(Loc
,
874 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
875 Expressions
=> New_List
(New_Occurrence_Of
(Pos
, Loc
))),
877 Make_Character_Literal
(Loc
,
879 Char_Literal_Value
=>
880 UI_From_Int
(Character'Pos ('.')))));
883 Make_Assignment_Statement
(Loc
,
884 Name
=> New_Occurrence_Of
(Pos
, Loc
),
887 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
888 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
890 -- Res (Pos .. Len) := Selector;
893 Make_Assignment_Statement
(Loc
,
894 Name
=> Make_Slice
(Loc
,
895 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
898 Low_Bound
=> New_Occurrence_Of
(Pos
, Loc
),
899 High_Bound
=> New_Occurrence_Of
(Len
, Loc
))),
900 Expression
=> New_Occurrence_Of
(Sel
, Loc
)));
902 return Build_Task_Image_Function
(Loc
, Decls
, Stats
, Res
);
903 end Build_Task_Record_Image
;
905 ----------------------------------
906 -- Component_May_Be_Bit_Aligned --
907 ----------------------------------
909 function Component_May_Be_Bit_Aligned
(Comp
: Entity_Id
) return Boolean is
911 -- If no component clause, then everything is fine, since the
912 -- back end never bit-misaligns by default, even if there is
913 -- a pragma Packed for the record.
915 if No
(Component_Clause
(Comp
)) then
919 -- It is only array and record types that cause trouble
921 if not Is_Record_Type
(Etype
(Comp
))
922 and then not Is_Array_Type
(Etype
(Comp
))
926 -- If we know that we have a small (64 bits or less) record
927 -- or bit-packed array, then everything is fine, since the
928 -- back end can handle these cases correctly.
930 elsif Esize
(Comp
) <= 64
931 and then (Is_Record_Type
(Etype
(Comp
))
932 or else Is_Bit_Packed_Array
(Etype
(Comp
)))
936 -- Otherwise if the component is not byte aligned, we
937 -- know we have the nasty unaligned case.
939 elsif Normalized_First_Bit
(Comp
) /= Uint_0
940 or else Esize
(Comp
) mod System_Storage_Unit
/= Uint_0
944 -- If we are large and byte aligned, then OK at this level
949 end Component_May_Be_Bit_Aligned
;
951 -------------------------------
952 -- Convert_To_Actual_Subtype --
953 -------------------------------
955 procedure Convert_To_Actual_Subtype
(Exp
: Entity_Id
) is
959 Act_ST
:= Get_Actual_Subtype
(Exp
);
961 if Act_ST
= Etype
(Exp
) then
966 Convert_To
(Act_ST
, Relocate_Node
(Exp
)));
967 Analyze_And_Resolve
(Exp
, Act_ST
);
969 end Convert_To_Actual_Subtype
;
971 -----------------------------------
972 -- Current_Sem_Unit_Declarations --
973 -----------------------------------
975 function Current_Sem_Unit_Declarations
return List_Id
is
976 U
: Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
980 -- If the current unit is a package body, locate the visible
981 -- declarations of the package spec.
983 if Nkind
(U
) = N_Package_Body
then
984 U
:= Unit
(Library_Unit
(Cunit
(Current_Sem_Unit
)));
987 if Nkind
(U
) = N_Package_Declaration
then
988 U
:= Specification
(U
);
989 Decls
:= Visible_Declarations
(U
);
993 Set_Visible_Declarations
(U
, Decls
);
997 Decls
:= Declarations
(U
);
1001 Set_Declarations
(U
, Decls
);
1006 end Current_Sem_Unit_Declarations
;
1008 -----------------------
1009 -- Duplicate_Subexpr --
1010 -----------------------
1012 function Duplicate_Subexpr
1014 Name_Req
: Boolean := False) return Node_Id
1017 Remove_Side_Effects
(Exp
, Name_Req
);
1018 return New_Copy_Tree
(Exp
);
1019 end Duplicate_Subexpr
;
1021 ---------------------------------
1022 -- Duplicate_Subexpr_No_Checks --
1023 ---------------------------------
1025 function Duplicate_Subexpr_No_Checks
1027 Name_Req
: Boolean := False) return Node_Id
1032 Remove_Side_Effects
(Exp
, Name_Req
);
1033 New_Exp
:= New_Copy_Tree
(Exp
);
1034 Remove_Checks
(New_Exp
);
1036 end Duplicate_Subexpr_No_Checks
;
1038 -----------------------------------
1039 -- Duplicate_Subexpr_Move_Checks --
1040 -----------------------------------
1042 function Duplicate_Subexpr_Move_Checks
1044 Name_Req
: Boolean := False) return Node_Id
1049 Remove_Side_Effects
(Exp
, Name_Req
);
1050 New_Exp
:= New_Copy_Tree
(Exp
);
1051 Remove_Checks
(Exp
);
1053 end Duplicate_Subexpr_Move_Checks
;
1055 --------------------
1056 -- Ensure_Defined --
1057 --------------------
1059 procedure Ensure_Defined
(Typ
: Entity_Id
; N
: Node_Id
) is
1063 -- An itype reference must only be created if this is a local
1064 -- itype, so that gigi can elaborate it on the proper objstack.
1067 and then Scope
(Typ
) = Current_Scope
1069 IR
:= Make_Itype_Reference
(Sloc
(N
));
1070 Set_Itype
(IR
, Typ
);
1071 Insert_Action
(N
, IR
);
1075 ---------------------
1076 -- Evolve_And_Then --
1077 ---------------------
1079 procedure Evolve_And_Then
(Cond
: in out Node_Id
; Cond1
: Node_Id
) is
1085 Make_And_Then
(Sloc
(Cond1
),
1087 Right_Opnd
=> Cond1
);
1089 end Evolve_And_Then
;
1091 --------------------
1092 -- Evolve_Or_Else --
1093 --------------------
1095 procedure Evolve_Or_Else
(Cond
: in out Node_Id
; Cond1
: Node_Id
) is
1101 Make_Or_Else
(Sloc
(Cond1
),
1103 Right_Opnd
=> Cond1
);
1107 ------------------------------
1108 -- Expand_Subtype_From_Expr --
1109 ------------------------------
1111 -- This function is applicable for both static and dynamic allocation of
1112 -- objects which are constrained by an initial expression. Basically it
1113 -- transforms an unconstrained subtype indication into a constrained one.
1114 -- The expression may also be transformed in certain cases in order to
1115 -- avoid multiple evaluation. In the static allocation case, the general
1120 -- is transformed into
1122 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1124 -- Here are the main cases :
1126 -- <if Expr is a Slice>
1127 -- Val : T ([Index_Subtype (Expr)]) := Expr;
1129 -- <elsif Expr is a String Literal>
1130 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1132 -- <elsif Expr is Constrained>
1133 -- subtype T is Type_Of_Expr
1136 -- <elsif Expr is an entity_name>
1137 -- Val : T (constraints taken from Expr) := Expr;
1140 -- type Axxx is access all T;
1141 -- Rval : Axxx := Expr'ref;
1142 -- Val : T (constraints taken from Rval) := Rval.all;
1144 -- ??? note: when the Expression is allocated in the secondary stack
1145 -- we could use it directly instead of copying it by declaring
1146 -- Val : T (...) renames Rval.all
1148 procedure Expand_Subtype_From_Expr
1150 Unc_Type
: Entity_Id
;
1151 Subtype_Indic
: Node_Id
;
1154 Loc
: constant Source_Ptr
:= Sloc
(N
);
1155 Exp_Typ
: constant Entity_Id
:= Etype
(Exp
);
1159 -- In general we cannot build the subtype if expansion is disabled,
1160 -- because internal entities may not have been defined. However, to
1161 -- avoid some cascaded errors, we try to continue when the expression
1162 -- is an array (or string), because it is safe to compute the bounds.
1163 -- It is in fact required to do so even in a generic context, because
1164 -- there may be constants that depend on bounds of string literal.
1166 if not Expander_Active
1167 and then (No
(Etype
(Exp
))
1168 or else Base_Type
(Etype
(Exp
)) /= Standard_String
)
1173 if Nkind
(Exp
) = N_Slice
then
1175 Slice_Type
: constant Entity_Id
:= Etype
(First_Index
(Exp_Typ
));
1178 Rewrite
(Subtype_Indic
,
1179 Make_Subtype_Indication
(Loc
,
1180 Subtype_Mark
=> New_Reference_To
(Unc_Type
, Loc
),
1182 Make_Index_Or_Discriminant_Constraint
(Loc
,
1183 Constraints
=> New_List
1184 (New_Reference_To
(Slice_Type
, Loc
)))));
1186 -- This subtype indication may be used later for contraint checks
1187 -- we better make sure that if a variable was used as a bound of
1188 -- of the original slice, its value is frozen.
1190 Force_Evaluation
(Low_Bound
(Scalar_Range
(Slice_Type
)));
1191 Force_Evaluation
(High_Bound
(Scalar_Range
(Slice_Type
)));
1194 elsif Ekind
(Exp_Typ
) = E_String_Literal_Subtype
then
1195 Rewrite
(Subtype_Indic
,
1196 Make_Subtype_Indication
(Loc
,
1197 Subtype_Mark
=> New_Reference_To
(Unc_Type
, Loc
),
1199 Make_Index_Or_Discriminant_Constraint
(Loc
,
1200 Constraints
=> New_List
(
1201 Make_Literal_Range
(Loc
,
1202 Literal_Typ
=> Exp_Typ
)))));
1204 elsif Is_Constrained
(Exp_Typ
)
1205 and then not Is_Class_Wide_Type
(Unc_Type
)
1207 if Is_Itype
(Exp_Typ
) then
1209 -- Within an initialization procedure, a selected component
1210 -- denotes a component of the enclosing record, and it appears
1211 -- as an actual in a call to its own initialization procedure.
1212 -- If this component depends on the outer discriminant, we must
1213 -- generate the proper actual subtype for it.
1215 if Nkind
(Exp
) = N_Selected_Component
1216 and then Within_Init_Proc
1219 Decl
: constant Node_Id
:=
1220 Build_Actual_Subtype_Of_Component
(Exp_Typ
, Exp
);
1222 if Present
(Decl
) then
1223 Insert_Action
(N
, Decl
);
1224 T
:= Defining_Identifier
(Decl
);
1230 -- No need to generate a new one (new what???)
1238 Make_Defining_Identifier
(Loc
,
1239 Chars
=> New_Internal_Name
('T'));
1242 Make_Subtype_Declaration
(Loc
,
1243 Defining_Identifier
=> T
,
1244 Subtype_Indication
=> New_Reference_To
(Exp_Typ
, Loc
)));
1246 -- This type is marked as an itype even though it has an
1247 -- explicit declaration because otherwise it can be marked
1248 -- with Is_Generic_Actual_Type and generate spurious errors.
1249 -- (see sem_ch8.Analyze_Package_Renaming and sem_type.covers)
1252 Set_Associated_Node_For_Itype
(T
, Exp
);
1255 Rewrite
(Subtype_Indic
, New_Reference_To
(T
, Loc
));
1257 -- nothing needs to be done for private types with unknown discriminants
1258 -- if the underlying type is not an unconstrained composite type.
1260 elsif Is_Private_Type
(Unc_Type
)
1261 and then Has_Unknown_Discriminants
(Unc_Type
)
1262 and then (not Is_Composite_Type
(Underlying_Type
(Unc_Type
))
1263 or else Is_Constrained
(Underlying_Type
(Unc_Type
)))
1267 -- Nothing to be done for derived types with unknown discriminants if
1268 -- the parent type also has unknown discriminants.
1270 elsif Is_Record_Type
(Unc_Type
)
1271 and then not Is_Class_Wide_Type
(Unc_Type
)
1272 and then Has_Unknown_Discriminants
(Unc_Type
)
1273 and then Has_Unknown_Discriminants
(Underlying_Type
(Unc_Type
))
1277 -- In Ada95, Nothing to be done if the type of the expression is
1278 -- limited, because in this case the expression cannot be copied,
1279 -- and its use can only be by reference.
1281 -- In Ada2005, the context can be an object declaration whose expression
1282 -- is a function that returns in place. If the nominal subtype has
1283 -- unknown discriminants, the call still provides constraints on the
1284 -- object, and we have to create an actual subtype from it.
1286 -- If the type is class-wide, the expression is dynamically tagged and
1287 -- we do not create an actual subtype either. Ditto for an interface.
1289 elsif Is_Limited_Type
(Exp_Typ
)
1291 (Is_Class_Wide_Type
(Exp_Typ
)
1292 or else Is_Interface
(Exp_Typ
)
1293 or else not Has_Unknown_Discriminants
(Exp_Typ
)
1294 or else not Is_Composite_Type
(Unc_Type
))
1298 -- For limited interfaces, nothing to be done
1300 -- This branch may be redundant once the limited interface issue is
1303 elsif Is_Interface
(Exp_Typ
)
1304 and then Is_Limited_Interface
(Exp_Typ
)
1308 -- For limited objects initialized with build in place function calls,
1309 -- nothing to be done; otherwise we prematurely introduce an N_Reference
1310 -- node in the expression initializing the object, which breaks the
1311 -- circuitry that detects and adds the additional arguments to the
1314 elsif Is_Build_In_Place_Function_Call
(Exp
) then
1318 Remove_Side_Effects
(Exp
);
1319 Rewrite
(Subtype_Indic
,
1320 Make_Subtype_From_Expr
(Exp
, Unc_Type
));
1322 end Expand_Subtype_From_Expr
;
1324 ------------------------
1325 -- Find_Interface_ADT --
1326 ------------------------
1328 function Find_Interface_ADT
1330 Iface
: Entity_Id
) return Entity_Id
1333 Found
: Boolean := False;
1334 Typ
: Entity_Id
:= T
;
1336 procedure Find_Secondary_Table
(Typ
: Entity_Id
);
1337 -- Internal subprogram used to recursively climb to the ancestors
1339 --------------------------
1340 -- Find_Secondary_Table --
1341 --------------------------
1343 procedure Find_Secondary_Table
(Typ
: Entity_Id
) is
1348 pragma Assert
(Typ
/= Iface
);
1350 -- Climb to the ancestor (if any) handling synchronized interface
1351 -- derivations and private types
1353 if Is_Concurrent_Record_Type
(Typ
) then
1355 Iface_List
: constant List_Id
:= Abstract_Interface_List
(Typ
);
1358 if Is_Non_Empty_List
(Iface_List
) then
1359 Find_Secondary_Table
(Etype
(First
(Iface_List
)));
1363 elsif Present
(Full_View
(Etype
(Typ
))) then
1364 if Full_View
(Etype
(Typ
)) /= Typ
then
1365 Find_Secondary_Table
(Full_View
(Etype
(Typ
)));
1368 elsif Etype
(Typ
) /= Typ
then
1369 Find_Secondary_Table
(Etype
(Typ
));
1372 -- Traverse the list of interfaces implemented by the type
1375 and then Present
(Abstract_Interfaces
(Typ
))
1376 and then not Is_Empty_Elmt_List
(Abstract_Interfaces
(Typ
))
1378 AI_Elmt
:= First_Elmt
(Abstract_Interfaces
(Typ
));
1379 while Present
(AI_Elmt
) loop
1380 AI
:= Node
(AI_Elmt
);
1382 if AI
= Iface
or else Is_Ancestor
(Iface
, AI
) then
1388 Next_Elmt
(AI_Elmt
);
1391 end Find_Secondary_Table
;
1393 -- Start of processing for Find_Interface_ADT
1396 pragma Assert
(Is_Interface
(Iface
));
1398 -- Handle private types
1400 if Has_Private_Declaration
(Typ
)
1401 and then Present
(Full_View
(Typ
))
1403 Typ
:= Full_View
(Typ
);
1406 -- Handle access types
1408 if Is_Access_Type
(Typ
) then
1409 Typ
:= Directly_Designated_Type
(Typ
);
1412 -- Handle task and protected types implementing interfaces
1414 if Is_Concurrent_Type
(Typ
) then
1415 Typ
:= Corresponding_Record_Type
(Typ
);
1419 (not Is_Class_Wide_Type
(Typ
)
1420 and then Ekind
(Typ
) /= E_Incomplete_Type
);
1422 ADT
:= Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
)));
1423 pragma Assert
(Present
(Node
(ADT
)));
1424 Find_Secondary_Table
(Typ
);
1425 pragma Assert
(Found
);
1427 end Find_Interface_ADT
;
1429 ------------------------
1430 -- Find_Interface_Tag --
1431 ------------------------
1433 function Find_Interface_Tag
1435 Iface
: Entity_Id
) return Entity_Id
1438 Found
: Boolean := False;
1439 Typ
: Entity_Id
:= T
;
1441 Is_Primary_Tag
: Boolean := False;
1443 Is_Sync_Typ
: Boolean := False;
1444 -- In case of non concurrent-record-types each parent-type has the
1445 -- tags associated with the interface types that are not implemented
1446 -- by the ancestors; concurrent-record-types have their whole list of
1447 -- interface tags (and this case requires some special management).
1449 procedure Find_Tag
(Typ
: Entity_Id
);
1450 -- Internal subprogram used to recursively climb to the ancestors
1456 procedure Find_Tag
(Typ
: Entity_Id
) is
1461 -- Check if the interface is an immediate ancestor of the type and
1462 -- therefore shares the main tag.
1466 Is_Primary_Tag
:= True;
1469 (Etype
(First_Tag_Component
(Typ
)) = RTE
(RE_Tag
));
1470 AI_Tag
:= First_Tag_Component
(Typ
);
1477 -- Handle synchronized interface derivations
1479 if Is_Concurrent_Record_Type
(Typ
) then
1481 Iface_List
: constant List_Id
:= Abstract_Interface_List
(Typ
);
1483 if Is_Non_Empty_List
(Iface_List
) then
1484 Find_Tag
(Etype
(First
(Iface_List
)));
1488 -- Climb to the root type handling private types
1490 elsif Present
(Full_View
(Etype
(Typ
))) then
1491 if Full_View
(Etype
(Typ
)) /= Typ
then
1492 Find_Tag
(Full_View
(Etype
(Typ
)));
1495 elsif Etype
(Typ
) /= Typ
then
1496 Find_Tag
(Etype
(Typ
));
1499 -- Traverse the list of interfaces implemented by the type
1502 and then Present
(Abstract_Interfaces
(Typ
))
1503 and then not (Is_Empty_Elmt_List
(Abstract_Interfaces
(Typ
)))
1505 -- Skip the tag associated with the primary table
1507 if not Is_Sync_Typ
then
1509 (Etype
(First_Tag_Component
(Typ
)) = RTE
(RE_Tag
));
1510 AI_Tag
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
1511 pragma Assert
(Present
(AI_Tag
));
1514 AI_Elmt
:= First_Elmt
(Abstract_Interfaces
(Typ
));
1515 while Present
(AI_Elmt
) loop
1516 AI
:= Node
(AI_Elmt
);
1518 if AI
= Iface
or else Is_Ancestor
(Iface
, AI
) then
1523 AI_Tag
:= Next_Tag_Component
(AI_Tag
);
1524 Next_Elmt
(AI_Elmt
);
1529 -- Start of processing for Find_Interface_Tag
1532 pragma Assert
(Is_Interface
(Iface
));
1534 -- Handle private types
1536 if Has_Private_Declaration
(Typ
)
1537 and then Present
(Full_View
(Typ
))
1539 Typ
:= Full_View
(Typ
);
1542 -- Handle access types
1544 if Is_Access_Type
(Typ
) then
1545 Typ
:= Directly_Designated_Type
(Typ
);
1548 -- Handle task and protected types implementing interfaces
1550 if Is_Concurrent_Type
(Typ
) then
1551 Typ
:= Corresponding_Record_Type
(Typ
);
1554 if Is_Class_Wide_Type
(Typ
) then
1558 -- Handle entities from the limited view
1560 if Ekind
(Typ
) = E_Incomplete_Type
then
1561 pragma Assert
(Present
(Non_Limited_View
(Typ
)));
1562 Typ
:= Non_Limited_View
(Typ
);
1565 if not Is_Concurrent_Record_Type
(Typ
) then
1567 pragma Assert
(Found
);
1570 -- Concurrent record types
1573 Is_Sync_Typ
:= True;
1574 AI_Tag
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
1576 pragma Assert
(Found
);
1578 if Is_Primary_Tag
then
1579 return First_Tag_Component
(Typ
);
1584 end Find_Interface_Tag
;
1586 --------------------
1587 -- Find_Interface --
1588 --------------------
1590 function Find_Interface
1592 Comp
: Entity_Id
) return Entity_Id
1595 Found
: Boolean := False;
1597 Typ
: Entity_Id
:= T
;
1599 Is_Sync_Typ
: Boolean := False;
1600 -- In case of non concurrent-record-types each parent-type has the
1601 -- tags associated with the interface types that are not implemented
1602 -- by the ancestors; concurrent-record-types have their whole list of
1603 -- interface tags (and this case requires some special management).
1605 procedure Find_Iface
(Typ
: Entity_Id
);
1606 -- Internal subprogram used to recursively climb to the ancestors
1612 procedure Find_Iface
(Typ
: Entity_Id
) is
1616 -- Climb to the root type
1618 -- Handle sychronized interface derivations
1620 if Is_Concurrent_Record_Type
(Typ
) then
1622 Iface_List
: constant List_Id
:= Abstract_Interface_List
(Typ
);
1624 if Is_Non_Empty_List
(Iface_List
) then
1625 Find_Iface
(Etype
(First
(Iface_List
)));
1629 -- Handle the common case
1631 elsif Etype
(Typ
) /= Typ
then
1632 pragma Assert
(not Present
(Full_View
(Etype
(Typ
))));
1633 Find_Iface
(Etype
(Typ
));
1636 -- Traverse the list of interfaces implemented by the type
1639 and then Present
(Abstract_Interfaces
(Typ
))
1640 and then not (Is_Empty_Elmt_List
(Abstract_Interfaces
(Typ
)))
1642 -- Skip the tag associated with the primary table
1644 if not Is_Sync_Typ
then
1646 (Etype
(First_Tag_Component
(Typ
)) = RTE
(RE_Tag
));
1647 AI_Tag
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
1648 pragma Assert
(Present
(AI_Tag
));
1651 AI_Elmt
:= First_Elmt
(Abstract_Interfaces
(Typ
));
1652 while Present
(AI_Elmt
) loop
1653 if AI_Tag
= Comp
then
1654 Iface
:= Node
(AI_Elmt
);
1659 AI_Tag
:= Next_Tag_Component
(AI_Tag
);
1660 Next_Elmt
(AI_Elmt
);
1665 -- Start of processing for Find_Interface
1668 -- Handle private types
1670 if Has_Private_Declaration
(Typ
)
1671 and then Present
(Full_View
(Typ
))
1673 Typ
:= Full_View
(Typ
);
1676 -- Handle access types
1678 if Is_Access_Type
(Typ
) then
1679 Typ
:= Directly_Designated_Type
(Typ
);
1682 -- Handle task and protected types implementing interfaces
1684 if Is_Concurrent_Type
(Typ
) then
1685 Typ
:= Corresponding_Record_Type
(Typ
);
1688 if Is_Class_Wide_Type
(Typ
) then
1692 -- Handle entities from the limited view
1694 if Ekind
(Typ
) = E_Incomplete_Type
then
1695 pragma Assert
(Present
(Non_Limited_View
(Typ
)));
1696 Typ
:= Non_Limited_View
(Typ
);
1699 if Is_Concurrent_Record_Type
(Typ
) then
1700 Is_Sync_Typ
:= True;
1701 AI_Tag
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
1705 pragma Assert
(Found
);
1713 function Find_Prim_Op
(T
: Entity_Id
; Name
: Name_Id
) return Entity_Id
is
1715 Typ
: Entity_Id
:= T
;
1719 if Is_Class_Wide_Type
(Typ
) then
1720 Typ
:= Root_Type
(Typ
);
1723 Typ
:= Underlying_Type
(Typ
);
1725 -- Loop through primitive operations
1727 Prim
:= First_Elmt
(Primitive_Operations
(Typ
));
1728 while Present
(Prim
) loop
1731 -- We can retrieve primitive operations by name if it is an internal
1732 -- name. For equality we must check that both of its operands have
1733 -- the same type, to avoid confusion with user-defined equalities
1734 -- than may have a non-symmetric signature.
1736 exit when Chars
(Op
) = Name
1739 or else Etype
(First_Entity
(Op
)) = Etype
(Last_Entity
(Op
)));
1742 pragma Assert
(Present
(Prim
));
1752 function Find_Prim_Op
1754 Name
: TSS_Name_Type
) return Entity_Id
1757 Typ
: Entity_Id
:= T
;
1760 if Is_Class_Wide_Type
(Typ
) then
1761 Typ
:= Root_Type
(Typ
);
1764 Typ
:= Underlying_Type
(Typ
);
1766 Prim
:= First_Elmt
(Primitive_Operations
(Typ
));
1767 while not Is_TSS
(Node
(Prim
), Name
) loop
1769 pragma Assert
(Present
(Prim
));
1775 ----------------------
1776 -- Force_Evaluation --
1777 ----------------------
1779 procedure Force_Evaluation
(Exp
: Node_Id
; Name_Req
: Boolean := False) is
1781 Remove_Side_Effects
(Exp
, Name_Req
, Variable_Ref
=> True);
1782 end Force_Evaluation
;
1784 ------------------------
1785 -- Generate_Poll_Call --
1786 ------------------------
1788 procedure Generate_Poll_Call
(N
: Node_Id
) is
1790 -- No poll call if polling not active
1792 if not Polling_Required
then
1795 -- Otherwise generate require poll call
1798 Insert_Before_And_Analyze
(N
,
1799 Make_Procedure_Call_Statement
(Sloc
(N
),
1800 Name
=> New_Occurrence_Of
(RTE
(RE_Poll
), Sloc
(N
))));
1802 end Generate_Poll_Call
;
1804 ---------------------------------
1805 -- Get_Current_Value_Condition --
1806 ---------------------------------
1808 -- Note: the implementation of this procedure is very closely tied to the
1809 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
1810 -- interpret Current_Value fields set by the Set procedure, so the two
1811 -- procedures need to be closely coordinated.
1813 procedure Get_Current_Value_Condition
1818 Loc
: constant Source_Ptr
:= Sloc
(Var
);
1819 Ent
: constant Entity_Id
:= Entity
(Var
);
1821 procedure Process_Current_Value_Condition
1824 -- N is an expression which holds either True (S = True) or False (S =
1825 -- False) in the condition. This procedure digs out the expression and
1826 -- if it refers to Ent, sets Op and Val appropriately.
1828 -------------------------------------
1829 -- Process_Current_Value_Condition --
1830 -------------------------------------
1832 procedure Process_Current_Value_Condition
1843 -- Deal with NOT operators, inverting sense
1845 while Nkind
(Cond
) = N_Op_Not
loop
1846 Cond
:= Right_Opnd
(Cond
);
1850 -- Deal with AND THEN and AND cases
1852 if Nkind
(Cond
) = N_And_Then
1853 or else Nkind
(Cond
) = N_Op_And
1855 -- Don't ever try to invert a condition that is of the form
1856 -- of an AND or AND THEN (since we are not doing sufficiently
1857 -- general processing to allow this).
1859 if Sens
= False then
1865 -- Recursively process AND and AND THEN branches
1867 Process_Current_Value_Condition
(Left_Opnd
(Cond
), True);
1869 if Op
/= N_Empty
then
1873 Process_Current_Value_Condition
(Right_Opnd
(Cond
), True);
1876 -- Case of relational operator
1878 elsif Nkind
(Cond
) in N_Op_Compare
then
1881 -- Invert sense of test if inverted test
1883 if Sens
= False then
1885 when N_Op_Eq
=> Op
:= N_Op_Ne
;
1886 when N_Op_Ne
=> Op
:= N_Op_Eq
;
1887 when N_Op_Lt
=> Op
:= N_Op_Ge
;
1888 when N_Op_Gt
=> Op
:= N_Op_Le
;
1889 when N_Op_Le
=> Op
:= N_Op_Gt
;
1890 when N_Op_Ge
=> Op
:= N_Op_Lt
;
1891 when others => raise Program_Error
;
1895 -- Case of entity op value
1897 if Is_Entity_Name
(Left_Opnd
(Cond
))
1898 and then Ent
= Entity
(Left_Opnd
(Cond
))
1899 and then Compile_Time_Known_Value
(Right_Opnd
(Cond
))
1901 Val
:= Right_Opnd
(Cond
);
1903 -- Case of value op entity
1905 elsif Is_Entity_Name
(Right_Opnd
(Cond
))
1906 and then Ent
= Entity
(Right_Opnd
(Cond
))
1907 and then Compile_Time_Known_Value
(Left_Opnd
(Cond
))
1909 Val
:= Left_Opnd
(Cond
);
1911 -- We are effectively swapping operands
1914 when N_Op_Eq
=> null;
1915 when N_Op_Ne
=> null;
1916 when N_Op_Lt
=> Op
:= N_Op_Gt
;
1917 when N_Op_Gt
=> Op
:= N_Op_Lt
;
1918 when N_Op_Le
=> Op
:= N_Op_Ge
;
1919 when N_Op_Ge
=> Op
:= N_Op_Le
;
1920 when others => raise Program_Error
;
1929 -- Case of Boolean variable reference, return as though the
1930 -- reference had said var = True.
1933 if Is_Entity_Name
(Cond
)
1934 and then Ent
= Entity
(Cond
)
1936 Val
:= New_Occurrence_Of
(Standard_True
, Sloc
(Cond
));
1938 if Sens
= False then
1945 end Process_Current_Value_Condition
;
1947 -- Start of processing for Get_Current_Value_Condition
1953 -- Immediate return, nothing doing, if this is not an object
1955 if Ekind
(Ent
) not in Object_Kind
then
1959 -- Otherwise examine current value
1962 CV
: constant Node_Id
:= Current_Value
(Ent
);
1967 -- If statement. Condition is known true in THEN section, known False
1968 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
1970 if Nkind
(CV
) = N_If_Statement
then
1972 -- Before start of IF statement
1974 if Loc
< Sloc
(CV
) then
1977 -- After end of IF statement
1979 elsif Loc
>= Sloc
(CV
) + Text_Ptr
(UI_To_Int
(End_Span
(CV
))) then
1983 -- At this stage we know that we are within the IF statement, but
1984 -- unfortunately, the tree does not record the SLOC of the ELSE so
1985 -- we cannot use a simple SLOC comparison to distinguish between
1986 -- the then/else statements, so we have to climb the tree.
1993 while Parent
(N
) /= CV
loop
1996 -- If we fall off the top of the tree, then that's odd, but
1997 -- perhaps it could occur in some error situation, and the
1998 -- safest response is simply to assume that the outcome of
1999 -- the condition is unknown. No point in bombing during an
2000 -- attempt to optimize things.
2007 -- Now we have N pointing to a node whose parent is the IF
2008 -- statement in question, so now we can tell if we are within
2009 -- the THEN statements.
2011 if Is_List_Member
(N
)
2012 and then List_Containing
(N
) = Then_Statements
(CV
)
2016 -- If the variable reference does not come from source, we
2017 -- cannot reliably tell whether it appears in the else part.
2018 -- In particular, if if appears in generated code for a node
2019 -- that requires finalization, it may be attached to a list
2020 -- that has not been yet inserted into the code. For now,
2021 -- treat it as unknown.
2023 elsif not Comes_From_Source
(N
) then
2026 -- Otherwise we must be in ELSIF or ELSE part
2033 -- ELSIF part. Condition is known true within the referenced
2034 -- ELSIF, known False in any subsequent ELSIF or ELSE part, and
2035 -- unknown before the ELSE part or after the IF statement.
2037 elsif Nkind
(CV
) = N_Elsif_Part
then
2040 -- Before start of ELSIF part
2042 if Loc
< Sloc
(CV
) then
2045 -- After end of IF statement
2047 elsif Loc
>= Sloc
(Stm
) +
2048 Text_Ptr
(UI_To_Int
(End_Span
(Stm
)))
2053 -- Again we lack the SLOC of the ELSE, so we need to climb the
2054 -- tree to see if we are within the ELSIF part in question.
2061 while Parent
(N
) /= Stm
loop
2064 -- If we fall off the top of the tree, then that's odd, but
2065 -- perhaps it could occur in some error situation, and the
2066 -- safest response is simply to assume that the outcome of
2067 -- the condition is unknown. No point in bombing during an
2068 -- attempt to optimize things.
2075 -- Now we have N pointing to a node whose parent is the IF
2076 -- statement in question, so see if is the ELSIF part we want.
2077 -- the THEN statements.
2082 -- Otherwise we must be in susbequent ELSIF or ELSE part
2089 -- Iteration scheme of while loop. The condition is known to be
2090 -- true within the body of the loop.
2092 elsif Nkind
(CV
) = N_Iteration_Scheme
then
2094 Loop_Stmt
: constant Node_Id
:= Parent
(CV
);
2097 -- Before start of body of loop
2099 if Loc
< Sloc
(Loop_Stmt
) then
2102 -- After end of LOOP statement
2104 elsif Loc
>= Sloc
(End_Label
(Loop_Stmt
)) then
2107 -- We are within the body of the loop
2114 -- All other cases of Current_Value settings
2120 -- If we fall through here, then we have a reportable condition, Sens
2121 -- is True if the condition is true and False if it needs inverting.
2123 Process_Current_Value_Condition
(Condition
(CV
), Sens
);
2125 end Get_Current_Value_Condition
;
2127 ---------------------------------
2128 -- Has_Controlled_Coextensions --
2129 ---------------------------------
2131 function Has_Controlled_Coextensions
(Typ
: Entity_Id
) return Boolean is
2136 -- Only consider record types
2138 if Ekind
(Typ
) /= E_Record_Type
2139 and then Ekind
(Typ
) /= E_Record_Subtype
2144 if Has_Discriminants
(Typ
) then
2145 Discr
:= First_Discriminant
(Typ
);
2146 while Present
(Discr
) loop
2147 D_Typ
:= Etype
(Discr
);
2149 if Ekind
(D_Typ
) = E_Anonymous_Access_Type
2151 (Is_Controlled
(Directly_Designated_Type
(D_Typ
))
2153 Is_Concurrent_Type
(Directly_Designated_Type
(D_Typ
)))
2158 Next_Discriminant
(Discr
);
2163 end Has_Controlled_Coextensions
;
2165 --------------------
2166 -- Homonym_Number --
2167 --------------------
2169 function Homonym_Number
(Subp
: Entity_Id
) return Nat
is
2175 Hom
:= Homonym
(Subp
);
2176 while Present
(Hom
) loop
2177 if Scope
(Hom
) = Scope
(Subp
) then
2181 Hom
:= Homonym
(Hom
);
2187 ------------------------------
2188 -- In_Unconditional_Context --
2189 ------------------------------
2191 function In_Unconditional_Context
(Node
: Node_Id
) return Boolean is
2196 while Present
(P
) loop
2198 when N_Subprogram_Body
=>
2201 when N_If_Statement
=>
2204 when N_Loop_Statement
=>
2207 when N_Case_Statement
=>
2216 end In_Unconditional_Context
;
2222 procedure Insert_Action
(Assoc_Node
: Node_Id
; Ins_Action
: Node_Id
) is
2224 if Present
(Ins_Action
) then
2225 Insert_Actions
(Assoc_Node
, New_List
(Ins_Action
));
2229 -- Version with check(s) suppressed
2231 procedure Insert_Action
2232 (Assoc_Node
: Node_Id
; Ins_Action
: Node_Id
; Suppress
: Check_Id
)
2235 Insert_Actions
(Assoc_Node
, New_List
(Ins_Action
), Suppress
);
2238 --------------------
2239 -- Insert_Actions --
2240 --------------------
2242 procedure Insert_Actions
(Assoc_Node
: Node_Id
; Ins_Actions
: List_Id
) is
2246 Wrapped_Node
: Node_Id
:= Empty
;
2249 if No
(Ins_Actions
) or else Is_Empty_List
(Ins_Actions
) then
2253 -- Ignore insert of actions from inside default expression in the
2254 -- special preliminary analyze mode. Any insertions at this point
2255 -- have no relevance, since we are only doing the analyze to freeze
2256 -- the types of any static expressions. See section "Handling of
2257 -- Default Expressions" in the spec of package Sem for further details.
2259 if In_Default_Expression
then
2263 -- If the action derives from stuff inside a record, then the actions
2264 -- are attached to the current scope, to be inserted and analyzed on
2265 -- exit from the scope. The reason for this is that we may also
2266 -- be generating freeze actions at the same time, and they must
2267 -- eventually be elaborated in the correct order.
2269 if Is_Record_Type
(Current_Scope
)
2270 and then not Is_Frozen
(Current_Scope
)
2272 if No
(Scope_Stack
.Table
2273 (Scope_Stack
.Last
).Pending_Freeze_Actions
)
2275 Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
:=
2280 Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
);
2286 -- We now intend to climb up the tree to find the right point to
2287 -- insert the actions. We start at Assoc_Node, unless this node is
2288 -- a subexpression in which case we start with its parent. We do this
2289 -- for two reasons. First it speeds things up. Second, if Assoc_Node
2290 -- is itself one of the special nodes like N_And_Then, then we assume
2291 -- that an initial request to insert actions for such a node does not
2292 -- expect the actions to get deposited in the node for later handling
2293 -- when the node is expanded, since clearly the node is being dealt
2294 -- with by the caller. Note that in the subexpression case, N is
2295 -- always the child we came from.
2297 -- N_Raise_xxx_Error is an annoying special case, it is a statement
2298 -- if it has type Standard_Void_Type, and a subexpression otherwise.
2299 -- otherwise. Procedure attribute references are also statements.
2301 if Nkind
(Assoc_Node
) in N_Subexpr
2302 and then (Nkind
(Assoc_Node
) in N_Raise_xxx_Error
2303 or else Etype
(Assoc_Node
) /= Standard_Void_Type
)
2304 and then (Nkind
(Assoc_Node
) /= N_Attribute_Reference
2306 not Is_Procedure_Attribute_Name
2307 (Attribute_Name
(Assoc_Node
)))
2309 P
:= Assoc_Node
; -- ??? does not agree with above!
2310 N
:= Parent
(Assoc_Node
);
2312 -- Non-subexpression case. Note that N is initially Empty in this
2313 -- case (N is only guaranteed Non-Empty in the subexpr case).
2320 -- Capture root of the transient scope
2322 if Scope_Is_Transient
then
2323 Wrapped_Node
:= Node_To_Be_Wrapped
;
2327 pragma Assert
(Present
(P
));
2331 -- Case of right operand of AND THEN or OR ELSE. Put the actions
2332 -- in the Actions field of the right operand. They will be moved
2333 -- out further when the AND THEN or OR ELSE operator is expanded.
2334 -- Nothing special needs to be done for the left operand since
2335 -- in that case the actions are executed unconditionally.
2337 when N_And_Then | N_Or_Else
=>
2338 if N
= Right_Opnd
(P
) then
2339 if Present
(Actions
(P
)) then
2340 Insert_List_After_And_Analyze
2341 (Last
(Actions
(P
)), Ins_Actions
);
2343 Set_Actions
(P
, Ins_Actions
);
2344 Analyze_List
(Actions
(P
));
2350 -- Then or Else operand of conditional expression. Add actions to
2351 -- Then_Actions or Else_Actions field as appropriate. The actions
2352 -- will be moved further out when the conditional is expanded.
2354 when N_Conditional_Expression
=>
2356 ThenX
: constant Node_Id
:= Next
(First
(Expressions
(P
)));
2357 ElseX
: constant Node_Id
:= Next
(ThenX
);
2360 -- Actions belong to the then expression, temporarily
2361 -- place them as Then_Actions of the conditional expr.
2362 -- They will be moved to the proper place later when
2363 -- the conditional expression is expanded.
2366 if Present
(Then_Actions
(P
)) then
2367 Insert_List_After_And_Analyze
2368 (Last
(Then_Actions
(P
)), Ins_Actions
);
2370 Set_Then_Actions
(P
, Ins_Actions
);
2371 Analyze_List
(Then_Actions
(P
));
2376 -- Actions belong to the else expression, temporarily
2377 -- place them as Else_Actions of the conditional expr.
2378 -- They will be moved to the proper place later when
2379 -- the conditional expression is expanded.
2381 elsif N
= ElseX
then
2382 if Present
(Else_Actions
(P
)) then
2383 Insert_List_After_And_Analyze
2384 (Last
(Else_Actions
(P
)), Ins_Actions
);
2386 Set_Else_Actions
(P
, Ins_Actions
);
2387 Analyze_List
(Else_Actions
(P
));
2392 -- Actions belong to the condition. In this case they are
2393 -- unconditionally executed, and so we can continue the
2394 -- search for the proper insert point.
2401 -- Case of appearing in the condition of a while expression or
2402 -- elsif. We insert the actions into the Condition_Actions field.
2403 -- They will be moved further out when the while loop or elsif
2406 when N_Iteration_Scheme |
2409 if N
= Condition
(P
) then
2410 if Present
(Condition_Actions
(P
)) then
2411 Insert_List_After_And_Analyze
2412 (Last
(Condition_Actions
(P
)), Ins_Actions
);
2414 Set_Condition_Actions
(P
, Ins_Actions
);
2416 -- Set the parent of the insert actions explicitly.
2417 -- This is not a syntactic field, but we need the
2418 -- parent field set, in particular so that freeze
2419 -- can understand that it is dealing with condition
2420 -- actions, and properly insert the freezing actions.
2422 Set_Parent
(Ins_Actions
, P
);
2423 Analyze_List
(Condition_Actions
(P
));
2429 -- Statements, declarations, pragmas, representation clauses
2434 N_Procedure_Call_Statement |
2435 N_Statement_Other_Than_Procedure_Call |
2441 -- Representation_Clause
2444 N_Attribute_Definition_Clause |
2445 N_Enumeration_Representation_Clause |
2446 N_Record_Representation_Clause |
2450 N_Abstract_Subprogram_Declaration |
2452 N_Exception_Declaration |
2453 N_Exception_Renaming_Declaration |
2454 N_Formal_Abstract_Subprogram_Declaration |
2455 N_Formal_Concrete_Subprogram_Declaration |
2456 N_Formal_Object_Declaration |
2457 N_Formal_Type_Declaration |
2458 N_Full_Type_Declaration |
2459 N_Function_Instantiation |
2460 N_Generic_Function_Renaming_Declaration |
2461 N_Generic_Package_Declaration |
2462 N_Generic_Package_Renaming_Declaration |
2463 N_Generic_Procedure_Renaming_Declaration |
2464 N_Generic_Subprogram_Declaration |
2465 N_Implicit_Label_Declaration |
2466 N_Incomplete_Type_Declaration |
2467 N_Number_Declaration |
2468 N_Object_Declaration |
2469 N_Object_Renaming_Declaration |
2471 N_Package_Body_Stub |
2472 N_Package_Declaration |
2473 N_Package_Instantiation |
2474 N_Package_Renaming_Declaration |
2475 N_Private_Extension_Declaration |
2476 N_Private_Type_Declaration |
2477 N_Procedure_Instantiation |
2479 N_Protected_Body_Stub |
2480 N_Protected_Type_Declaration |
2481 N_Single_Task_Declaration |
2483 N_Subprogram_Body_Stub |
2484 N_Subprogram_Declaration |
2485 N_Subprogram_Renaming_Declaration |
2486 N_Subtype_Declaration |
2489 N_Task_Type_Declaration |
2491 -- Freeze entity behaves like a declaration or statement
2495 -- Do not insert here if the item is not a list member (this
2496 -- happens for example with a triggering statement, and the
2497 -- proper approach is to insert before the entire select).
2499 if not Is_List_Member
(P
) then
2502 -- Do not insert if parent of P is an N_Component_Association
2503 -- node (i.e. we are in the context of an N_Aggregate or
2504 -- N_Extension_Aggregate node. In this case we want to insert
2505 -- before the entire aggregate.
2507 elsif Nkind
(Parent
(P
)) = N_Component_Association
then
2510 -- Do not insert if the parent of P is either an N_Variant
2511 -- node or an N_Record_Definition node, meaning in either
2512 -- case that P is a member of a component list, and that
2513 -- therefore the actions should be inserted outside the
2514 -- complete record declaration.
2516 elsif Nkind
(Parent
(P
)) = N_Variant
2517 or else Nkind
(Parent
(P
)) = N_Record_Definition
2521 -- Do not insert freeze nodes within the loop generated for
2522 -- an aggregate, because they may be elaborated too late for
2523 -- subsequent use in the back end: within a package spec the
2524 -- loop is part of the elaboration procedure and is only
2525 -- elaborated during the second pass.
2526 -- If the loop comes from source, or the entity is local to
2527 -- the loop itself it must remain within.
2529 elsif Nkind
(Parent
(P
)) = N_Loop_Statement
2530 and then not Comes_From_Source
(Parent
(P
))
2531 and then Nkind
(First
(Ins_Actions
)) = N_Freeze_Entity
2533 Scope
(Entity
(First
(Ins_Actions
))) /= Current_Scope
2537 -- Otherwise we can go ahead and do the insertion
2539 elsif P
= Wrapped_Node
then
2540 Store_Before_Actions_In_Scope
(Ins_Actions
);
2544 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
2548 -- A special case, N_Raise_xxx_Error can act either as a
2549 -- statement or a subexpression. We tell the difference
2550 -- by looking at the Etype. It is set to Standard_Void_Type
2551 -- in the statement case.
2554 N_Raise_xxx_Error
=>
2555 if Etype
(P
) = Standard_Void_Type
then
2556 if P
= Wrapped_Node
then
2557 Store_Before_Actions_In_Scope
(Ins_Actions
);
2559 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
2564 -- In the subexpression case, keep climbing
2570 -- If a component association appears within a loop created for
2571 -- an array aggregate, attach the actions to the association so
2572 -- they can be subsequently inserted within the loop. For other
2573 -- component associations insert outside of the aggregate. For
2574 -- an association that will generate a loop, its Loop_Actions
2575 -- attribute is already initialized (see exp_aggr.adb).
2577 -- The list of loop_actions can in turn generate additional ones,
2578 -- that are inserted before the associated node. If the associated
2579 -- node is outside the aggregate, the new actions are collected
2580 -- at the end of the loop actions, to respect the order in which
2581 -- they are to be elaborated.
2584 N_Component_Association
=>
2585 if Nkind
(Parent
(P
)) = N_Aggregate
2586 and then Present
(Loop_Actions
(P
))
2588 if Is_Empty_List
(Loop_Actions
(P
)) then
2589 Set_Loop_Actions
(P
, Ins_Actions
);
2590 Analyze_List
(Ins_Actions
);
2597 -- Check whether these actions were generated
2598 -- by a declaration that is part of the loop_
2599 -- actions for the component_association.
2602 while Present
(Decl
) loop
2603 exit when Parent
(Decl
) = P
2604 and then Is_List_Member
(Decl
)
2606 List_Containing
(Decl
) = Loop_Actions
(P
);
2607 Decl
:= Parent
(Decl
);
2610 if Present
(Decl
) then
2611 Insert_List_Before_And_Analyze
2612 (Decl
, Ins_Actions
);
2614 Insert_List_After_And_Analyze
2615 (Last
(Loop_Actions
(P
)), Ins_Actions
);
2626 -- Another special case, an attribute denoting a procedure call
2629 N_Attribute_Reference
=>
2630 if Is_Procedure_Attribute_Name
(Attribute_Name
(P
)) then
2631 if P
= Wrapped_Node
then
2632 Store_Before_Actions_In_Scope
(Ins_Actions
);
2634 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
2639 -- In the subexpression case, keep climbing
2645 -- For all other node types, keep climbing tree
2649 N_Accept_Alternative |
2650 N_Access_Definition |
2651 N_Access_Function_Definition |
2652 N_Access_Procedure_Definition |
2653 N_Access_To_Object_Definition |
2656 N_Case_Statement_Alternative |
2657 N_Character_Literal |
2658 N_Compilation_Unit |
2659 N_Compilation_Unit_Aux |
2660 N_Component_Clause |
2661 N_Component_Declaration |
2662 N_Component_Definition |
2664 N_Constrained_Array_Definition |
2665 N_Decimal_Fixed_Point_Definition |
2666 N_Defining_Character_Literal |
2667 N_Defining_Identifier |
2668 N_Defining_Operator_Symbol |
2669 N_Defining_Program_Unit_Name |
2670 N_Delay_Alternative |
2671 N_Delta_Constraint |
2672 N_Derived_Type_Definition |
2674 N_Digits_Constraint |
2675 N_Discriminant_Association |
2676 N_Discriminant_Specification |
2678 N_Entry_Body_Formal_Part |
2679 N_Entry_Call_Alternative |
2680 N_Entry_Declaration |
2681 N_Entry_Index_Specification |
2682 N_Enumeration_Type_Definition |
2684 N_Exception_Handler |
2686 N_Explicit_Dereference |
2687 N_Extension_Aggregate |
2688 N_Floating_Point_Definition |
2689 N_Formal_Decimal_Fixed_Point_Definition |
2690 N_Formal_Derived_Type_Definition |
2691 N_Formal_Discrete_Type_Definition |
2692 N_Formal_Floating_Point_Definition |
2693 N_Formal_Modular_Type_Definition |
2694 N_Formal_Ordinary_Fixed_Point_Definition |
2695 N_Formal_Package_Declaration |
2696 N_Formal_Private_Type_Definition |
2697 N_Formal_Signed_Integer_Type_Definition |
2699 N_Function_Specification |
2700 N_Generic_Association |
2701 N_Handled_Sequence_Of_Statements |
2704 N_Index_Or_Discriminant_Constraint |
2705 N_Indexed_Component |
2709 N_Loop_Parameter_Specification |
2711 N_Modular_Type_Definition |
2737 N_Op_Shift_Right_Arithmetic |
2741 N_Ordinary_Fixed_Point_Definition |
2743 N_Package_Specification |
2744 N_Parameter_Association |
2745 N_Parameter_Specification |
2746 N_Pop_Constraint_Error_Label |
2747 N_Pop_Program_Error_Label |
2748 N_Pop_Storage_Error_Label |
2749 N_Pragma_Argument_Association |
2750 N_Procedure_Specification |
2751 N_Protected_Definition |
2752 N_Push_Constraint_Error_Label |
2753 N_Push_Program_Error_Label |
2754 N_Push_Storage_Error_Label |
2755 N_Qualified_Expression |
2757 N_Range_Constraint |
2759 N_Real_Range_Specification |
2760 N_Record_Definition |
2762 N_Selected_Component |
2763 N_Signed_Integer_Type_Definition |
2764 N_Single_Protected_Declaration |
2768 N_Subtype_Indication |
2771 N_Terminate_Alternative |
2772 N_Triggering_Alternative |
2774 N_Unchecked_Expression |
2775 N_Unchecked_Type_Conversion |
2776 N_Unconstrained_Array_Definition |
2779 N_Use_Package_Clause |
2783 N_Validate_Unchecked_Conversion |
2790 -- Make sure that inserted actions stay in the transient scope
2792 if P
= Wrapped_Node
then
2793 Store_Before_Actions_In_Scope
(Ins_Actions
);
2797 -- If we fall through above tests, keep climbing tree
2801 if Nkind
(Parent
(N
)) = N_Subunit
then
2803 -- This is the proper body corresponding to a stub. Insertion
2804 -- must be done at the point of the stub, which is in the decla-
2805 -- tive part of the parent unit.
2807 P
:= Corresponding_Stub
(Parent
(N
));
2815 -- Version with check(s) suppressed
2817 procedure Insert_Actions
2818 (Assoc_Node
: Node_Id
;
2819 Ins_Actions
: List_Id
;
2820 Suppress
: Check_Id
)
2823 if Suppress
= All_Checks
then
2825 Svg
: constant Suppress_Array
:= Scope_Suppress
;
2827 Scope_Suppress
:= (others => True);
2828 Insert_Actions
(Assoc_Node
, Ins_Actions
);
2829 Scope_Suppress
:= Svg
;
2834 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
2836 Scope_Suppress
(Suppress
) := True;
2837 Insert_Actions
(Assoc_Node
, Ins_Actions
);
2838 Scope_Suppress
(Suppress
) := Svg
;
2843 --------------------------
2844 -- Insert_Actions_After --
2845 --------------------------
2847 procedure Insert_Actions_After
2848 (Assoc_Node
: Node_Id
;
2849 Ins_Actions
: List_Id
)
2852 if Scope_Is_Transient
2853 and then Assoc_Node
= Node_To_Be_Wrapped
2855 Store_After_Actions_In_Scope
(Ins_Actions
);
2857 Insert_List_After_And_Analyze
(Assoc_Node
, Ins_Actions
);
2859 end Insert_Actions_After
;
2861 ---------------------------------
2862 -- Insert_Library_Level_Action --
2863 ---------------------------------
2865 procedure Insert_Library_Level_Action
(N
: Node_Id
) is
2866 Aux
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Main_Unit
));
2869 Push_Scope
(Cunit_Entity
(Main_Unit
));
2870 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
2872 if No
(Actions
(Aux
)) then
2873 Set_Actions
(Aux
, New_List
(N
));
2875 Append
(N
, Actions
(Aux
));
2880 end Insert_Library_Level_Action
;
2882 ----------------------------------
2883 -- Insert_Library_Level_Actions --
2884 ----------------------------------
2886 procedure Insert_Library_Level_Actions
(L
: List_Id
) is
2887 Aux
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Main_Unit
));
2890 if Is_Non_Empty_List
(L
) then
2891 Push_Scope
(Cunit_Entity
(Main_Unit
));
2892 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
2894 if No
(Actions
(Aux
)) then
2895 Set_Actions
(Aux
, L
);
2898 Insert_List_After_And_Analyze
(Last
(Actions
(Aux
)), L
);
2903 end Insert_Library_Level_Actions
;
2905 ----------------------
2906 -- Inside_Init_Proc --
2907 ----------------------
2909 function Inside_Init_Proc
return Boolean is
2915 and then S
/= Standard_Standard
2917 if Is_Init_Proc
(S
) then
2925 end Inside_Init_Proc
;
2927 ----------------------------
2928 -- Is_All_Null_Statements --
2929 ----------------------------
2931 function Is_All_Null_Statements
(L
: List_Id
) return Boolean is
2936 while Present
(Stm
) loop
2937 if Nkind
(Stm
) /= N_Null_Statement
then
2945 end Is_All_Null_Statements
;
2947 ----------------------------------
2948 -- Is_Library_Level_Tagged_Type --
2949 ----------------------------------
2951 function Is_Library_Level_Tagged_Type
(Typ
: Entity_Id
) return Boolean is
2953 return Is_Tagged_Type
(Typ
)
2954 and then Is_Library_Level_Entity
(Typ
);
2955 end Is_Library_Level_Tagged_Type
;
2957 -----------------------------------------
2958 -- Is_Predefined_Dispatching_Operation --
2959 -----------------------------------------
2961 function Is_Predefined_Dispatching_Operation
(E
: Entity_Id
) return Boolean
2963 TSS_Name
: TSS_Name_Type
;
2966 if not Is_Dispatching_Operation
(E
) then
2970 Get_Name_String
(Chars
(E
));
2972 if Name_Len
> TSS_Name_Type
'Last then
2973 TSS_Name
:= TSS_Name_Type
(Name_Buffer
(Name_Len
- TSS_Name
'Length + 1
2975 if Chars
(E
) = Name_uSize
2976 or else Chars
(E
) = Name_uAlignment
2977 or else TSS_Name
= TSS_Stream_Read
2978 or else TSS_Name
= TSS_Stream_Write
2979 or else TSS_Name
= TSS_Stream_Input
2980 or else TSS_Name
= TSS_Stream_Output
2982 (Chars
(E
) = Name_Op_Eq
2983 and then Etype
(First_Entity
(E
)) = Etype
(Last_Entity
(E
)))
2984 or else Chars
(E
) = Name_uAssign
2985 or else TSS_Name
= TSS_Deep_Adjust
2986 or else TSS_Name
= TSS_Deep_Finalize
2987 or else (Ada_Version
>= Ada_05
2988 and then (Chars
(E
) = Name_uDisp_Asynchronous_Select
2989 or else Chars
(E
) = Name_uDisp_Conditional_Select
2990 or else Chars
(E
) = Name_uDisp_Get_Prim_Op_Kind
2991 or else Chars
(E
) = Name_uDisp_Get_Task_Id
2992 or else Chars
(E
) = Name_uDisp_Timed_Select
))
2999 end Is_Predefined_Dispatching_Operation
;
3001 ----------------------------------
3002 -- Is_Possibly_Unaligned_Object --
3003 ----------------------------------
3005 function Is_Possibly_Unaligned_Object
(N
: Node_Id
) return Boolean is
3006 T
: constant Entity_Id
:= Etype
(N
);
3009 -- If renamed object, apply test to underlying object
3011 if Is_Entity_Name
(N
)
3012 and then Is_Object
(Entity
(N
))
3013 and then Present
(Renamed_Object
(Entity
(N
)))
3015 return Is_Possibly_Unaligned_Object
(Renamed_Object
(Entity
(N
)));
3018 -- Tagged and controlled types and aliased types are always aligned,
3019 -- as are concurrent types.
3022 or else Has_Controlled_Component
(T
)
3023 or else Is_Concurrent_Type
(T
)
3024 or else Is_Tagged_Type
(T
)
3025 or else Is_Controlled
(T
)
3030 -- If this is an element of a packed array, may be unaligned
3032 if Is_Ref_To_Bit_Packed_Array
(N
) then
3036 -- Case of component reference
3038 if Nkind
(N
) = N_Selected_Component
then
3040 P
: constant Node_Id
:= Prefix
(N
);
3041 C
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
3046 -- If component reference is for an array with non-static bounds,
3047 -- then it is always aligned: we can only process unaligned
3048 -- arrays with static bounds (more accurately bounds known at
3051 if Is_Array_Type
(T
)
3052 and then not Compile_Time_Known_Bounds
(T
)
3057 -- If component is aliased, it is definitely properly aligned
3059 if Is_Aliased
(C
) then
3063 -- If component is for a type implemented as a scalar, and the
3064 -- record is packed, and the component is other than the first
3065 -- component of the record, then the component may be unaligned.
3067 if Is_Packed
(Etype
(P
))
3068 and then Represented_As_Scalar
(Etype
(C
))
3069 and then First_Entity
(Scope
(C
)) /= C
3074 -- Compute maximum possible alignment for T
3076 -- If alignment is known, then that settles things
3078 if Known_Alignment
(T
) then
3079 M
:= UI_To_Int
(Alignment
(T
));
3081 -- If alignment is not known, tentatively set max alignment
3084 M
:= Ttypes
.Maximum_Alignment
;
3086 -- We can reduce this if the Esize is known since the default
3087 -- alignment will never be more than the smallest power of 2
3088 -- that does not exceed this Esize value.
3090 if Known_Esize
(T
) then
3091 S
:= UI_To_Int
(Esize
(T
));
3093 while (M
/ 2) >= S
loop
3099 -- If the component reference is for a record that has a specified
3100 -- alignment, and we either know it is too small, or cannot tell,
3101 -- then the component may be unaligned
3103 if Known_Alignment
(Etype
(P
))
3104 and then Alignment
(Etype
(P
)) < Ttypes
.Maximum_Alignment
3105 and then M
> Alignment
(Etype
(P
))
3110 -- Case of component clause present which may specify an
3111 -- unaligned position.
3113 if Present
(Component_Clause
(C
)) then
3115 -- Otherwise we can do a test to make sure that the actual
3116 -- start position in the record, and the length, are both
3117 -- consistent with the required alignment. If not, we know
3118 -- that we are unaligned.
3121 Align_In_Bits
: constant Nat
:= M
* System_Storage_Unit
;
3123 if Component_Bit_Offset
(C
) mod Align_In_Bits
/= 0
3124 or else Esize
(C
) mod Align_In_Bits
/= 0
3131 -- Otherwise, for a component reference, test prefix
3133 return Is_Possibly_Unaligned_Object
(P
);
3136 -- If not a component reference, must be aligned
3141 end Is_Possibly_Unaligned_Object
;
3143 ---------------------------------
3144 -- Is_Possibly_Unaligned_Slice --
3145 ---------------------------------
3147 function Is_Possibly_Unaligned_Slice
(N
: Node_Id
) return Boolean is
3149 -- Go to renamed object
3151 if Is_Entity_Name
(N
)
3152 and then Is_Object
(Entity
(N
))
3153 and then Present
(Renamed_Object
(Entity
(N
)))
3155 return Is_Possibly_Unaligned_Slice
(Renamed_Object
(Entity
(N
)));
3158 -- The reference must be a slice
3160 if Nkind
(N
) /= N_Slice
then
3164 -- Always assume the worst for a nested record component with a
3165 -- component clause, which gigi/gcc does not appear to handle well.
3166 -- It is not clear why this special test is needed at all ???
3168 if Nkind
(Prefix
(N
)) = N_Selected_Component
3169 and then Nkind
(Prefix
(Prefix
(N
))) = N_Selected_Component
3171 Present
(Component_Clause
(Entity
(Selector_Name
(Prefix
(N
)))))
3176 -- We only need to worry if the target has strict alignment
3178 if not Target_Strict_Alignment
then
3182 -- If it is a slice, then look at the array type being sliced
3185 Sarr
: constant Node_Id
:= Prefix
(N
);
3186 -- Prefix of the slice, i.e. the array being sliced
3188 Styp
: constant Entity_Id
:= Etype
(Prefix
(N
));
3189 -- Type of the array being sliced
3195 -- The problems arise if the array object that is being sliced
3196 -- is a component of a record or array, and we cannot guarantee
3197 -- the alignment of the array within its containing object.
3199 -- To investigate this, we look at successive prefixes to see
3200 -- if we have a worrisome indexed or selected component.
3204 -- Case of array is part of an indexed component reference
3206 if Nkind
(Pref
) = N_Indexed_Component
then
3207 Ptyp
:= Etype
(Prefix
(Pref
));
3209 -- The only problematic case is when the array is packed,
3210 -- in which case we really know nothing about the alignment
3211 -- of individual components.
3213 if Is_Bit_Packed_Array
(Ptyp
) then
3217 -- Case of array is part of a selected component reference
3219 elsif Nkind
(Pref
) = N_Selected_Component
then
3220 Ptyp
:= Etype
(Prefix
(Pref
));
3222 -- We are definitely in trouble if the record in question
3223 -- has an alignment, and either we know this alignment is
3224 -- inconsistent with the alignment of the slice, or we
3225 -- don't know what the alignment of the slice should be.
3227 if Known_Alignment
(Ptyp
)
3228 and then (Unknown_Alignment
(Styp
)
3229 or else Alignment
(Styp
) > Alignment
(Ptyp
))
3234 -- We are in potential trouble if the record type is packed.
3235 -- We could special case when we know that the array is the
3236 -- first component, but that's not such a simple case ???
3238 if Is_Packed
(Ptyp
) then
3242 -- We are in trouble if there is a component clause, and
3243 -- either we do not know the alignment of the slice, or
3244 -- the alignment of the slice is inconsistent with the
3245 -- bit position specified by the component clause.
3248 Field
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
3250 if Present
(Component_Clause
(Field
))
3252 (Unknown_Alignment
(Styp
)
3254 (Component_Bit_Offset
(Field
) mod
3255 (System_Storage_Unit
* Alignment
(Styp
))) /= 0)
3261 -- For cases other than selected or indexed components we
3262 -- know we are OK, since no issues arise over alignment.
3268 -- We processed an indexed component or selected component
3269 -- reference that looked safe, so keep checking prefixes.
3271 Pref
:= Prefix
(Pref
);
3274 end Is_Possibly_Unaligned_Slice
;
3276 --------------------------------
3277 -- Is_Ref_To_Bit_Packed_Array --
3278 --------------------------------
3280 function Is_Ref_To_Bit_Packed_Array
(N
: Node_Id
) return Boolean is
3285 if Is_Entity_Name
(N
)
3286 and then Is_Object
(Entity
(N
))
3287 and then Present
(Renamed_Object
(Entity
(N
)))
3289 return Is_Ref_To_Bit_Packed_Array
(Renamed_Object
(Entity
(N
)));
3292 if Nkind
(N
) = N_Indexed_Component
3294 Nkind
(N
) = N_Selected_Component
3296 if Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
3299 Result
:= Is_Ref_To_Bit_Packed_Array
(Prefix
(N
));
3302 if Result
and then Nkind
(N
) = N_Indexed_Component
then
3303 Expr
:= First
(Expressions
(N
));
3304 while Present
(Expr
) loop
3305 Force_Evaluation
(Expr
);
3315 end Is_Ref_To_Bit_Packed_Array
;
3317 --------------------------------
3318 -- Is_Ref_To_Bit_Packed_Slice --
3319 --------------------------------
3321 function Is_Ref_To_Bit_Packed_Slice
(N
: Node_Id
) return Boolean is
3323 if Nkind
(N
) = N_Type_Conversion
then
3324 return Is_Ref_To_Bit_Packed_Slice
(Expression
(N
));
3326 elsif Is_Entity_Name
(N
)
3327 and then Is_Object
(Entity
(N
))
3328 and then Present
(Renamed_Object
(Entity
(N
)))
3330 return Is_Ref_To_Bit_Packed_Slice
(Renamed_Object
(Entity
(N
)));
3332 elsif Nkind
(N
) = N_Slice
3333 and then Is_Bit_Packed_Array
(Etype
(Prefix
(N
)))
3337 elsif Nkind
(N
) = N_Indexed_Component
3339 Nkind
(N
) = N_Selected_Component
3341 return Is_Ref_To_Bit_Packed_Slice
(Prefix
(N
));
3346 end Is_Ref_To_Bit_Packed_Slice
;
3348 -----------------------
3349 -- Is_Renamed_Object --
3350 -----------------------
3352 function Is_Renamed_Object
(N
: Node_Id
) return Boolean is
3353 Pnod
: constant Node_Id
:= Parent
(N
);
3354 Kind
: constant Node_Kind
:= Nkind
(Pnod
);
3357 if Kind
= N_Object_Renaming_Declaration
then
3360 elsif Kind
= N_Indexed_Component
3361 or else Kind
= N_Selected_Component
3363 return Is_Renamed_Object
(Pnod
);
3368 end Is_Renamed_Object
;
3370 ----------------------------
3371 -- Is_Untagged_Derivation --
3372 ----------------------------
3374 function Is_Untagged_Derivation
(T
: Entity_Id
) return Boolean is
3376 return (not Is_Tagged_Type
(T
) and then Is_Derived_Type
(T
))
3378 (Is_Private_Type
(T
) and then Present
(Full_View
(T
))
3379 and then not Is_Tagged_Type
(Full_View
(T
))
3380 and then Is_Derived_Type
(Full_View
(T
))
3381 and then Etype
(Full_View
(T
)) /= T
);
3382 end Is_Untagged_Derivation
;
3384 --------------------
3385 -- Kill_Dead_Code --
3386 --------------------
3388 procedure Kill_Dead_Code
(N
: Node_Id
; Warn
: Boolean := False) is
3391 Remove_Warning_Messages
(N
);
3395 ("?this code can never be executed and has been deleted!", N
);
3398 -- Recurse into block statements and bodies to process declarations
3401 if Nkind
(N
) = N_Block_Statement
3402 or else Nkind
(N
) = N_Subprogram_Body
3403 or else Nkind
(N
) = N_Package_Body
3406 (Declarations
(N
), False);
3408 (Statements
(Handled_Statement_Sequence
(N
)));
3410 if Nkind
(N
) = N_Subprogram_Body
then
3411 Set_Is_Eliminated
(Defining_Entity
(N
));
3414 elsif Nkind
(N
) = N_Package_Declaration
then
3415 Kill_Dead_Code
(Visible_Declarations
(Specification
(N
)));
3416 Kill_Dead_Code
(Private_Declarations
(Specification
(N
)));
3419 E
: Entity_Id
:= First_Entity
(Defining_Entity
(N
));
3421 while Present
(E
) loop
3422 if Ekind
(E
) = E_Operator
then
3423 Set_Is_Eliminated
(E
);
3430 -- Recurse into composite statement to kill individual statements,
3431 -- in particular instantiations.
3433 elsif Nkind
(N
) = N_If_Statement
then
3434 Kill_Dead_Code
(Then_Statements
(N
));
3435 Kill_Dead_Code
(Elsif_Parts
(N
));
3436 Kill_Dead_Code
(Else_Statements
(N
));
3438 elsif Nkind
(N
) = N_Loop_Statement
then
3439 Kill_Dead_Code
(Statements
(N
));
3441 elsif Nkind
(N
) = N_Case_Statement
then
3445 Alt
:= First
(Alternatives
(N
));
3446 while Present
(Alt
) loop
3447 Kill_Dead_Code
(Statements
(Alt
));
3452 elsif Nkind
(N
) = N_Case_Statement_Alternative
then
3453 Kill_Dead_Code
(Statements
(N
));
3455 -- Deal with dead instances caused by deleting instantiations
3457 elsif Nkind
(N
) in N_Generic_Instantiation
then
3458 Remove_Dead_Instance
(N
);
3465 -- Case where argument is a list of nodes to be killed
3467 procedure Kill_Dead_Code
(L
: List_Id
; Warn
: Boolean := False) is
3472 if Is_Non_Empty_List
(L
) then
3474 N
:= Remove_Head
(L
);
3476 Kill_Dead_Code
(N
, W
);
3482 ------------------------
3483 -- Known_Non_Negative --
3484 ------------------------
3486 function Known_Non_Negative
(Opnd
: Node_Id
) return Boolean is
3488 if Is_OK_Static_Expression
(Opnd
)
3489 and then Expr_Value
(Opnd
) >= 0
3495 Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Opnd
));
3499 Is_OK_Static_Expression
(Lo
) and then Expr_Value
(Lo
) >= 0;
3502 end Known_Non_Negative
;
3504 --------------------
3505 -- Known_Non_Null --
3506 --------------------
3508 function Known_Non_Null
(N
: Node_Id
) return Boolean is
3510 -- Checks for case where N is an entity reference
3512 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
3514 E
: constant Entity_Id
:= Entity
(N
);
3519 -- First check if we are in decisive conditional
3521 Get_Current_Value_Condition
(N
, Op
, Val
);
3523 if Known_Null
(Val
) then
3524 if Op
= N_Op_Eq
then
3526 elsif Op
= N_Op_Ne
then
3531 -- If OK to do replacement, test Is_Known_Non_Null flag
3533 if OK_To_Do_Constant_Replacement
(E
) then
3534 return Is_Known_Non_Null
(E
);
3536 -- Otherwise if not safe to do replacement, then say so
3543 -- True if access attribute
3545 elsif Nkind
(N
) = N_Attribute_Reference
3546 and then (Attribute_Name
(N
) = Name_Access
3548 Attribute_Name
(N
) = Name_Unchecked_Access
3550 Attribute_Name
(N
) = Name_Unrestricted_Access
)
3554 -- True if allocator
3556 elsif Nkind
(N
) = N_Allocator
then
3559 -- For a conversion, true if expression is known non-null
3561 elsif Nkind
(N
) = N_Type_Conversion
then
3562 return Known_Non_Null
(Expression
(N
));
3564 -- Above are all cases where the value could be determined to be
3565 -- non-null. In all other cases, we don't know, so return False.
3576 function Known_Null
(N
: Node_Id
) return Boolean is
3578 -- Checks for case where N is an entity reference
3580 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
3582 E
: constant Entity_Id
:= Entity
(N
);
3587 -- Constant null value is for sure null
3589 if Ekind
(E
) = E_Constant
3590 and then Known_Null
(Constant_Value
(E
))
3595 -- First check if we are in decisive conditional
3597 Get_Current_Value_Condition
(N
, Op
, Val
);
3599 if Known_Null
(Val
) then
3600 if Op
= N_Op_Eq
then
3602 elsif Op
= N_Op_Ne
then
3607 -- If OK to do replacement, test Is_Known_Null flag
3609 if OK_To_Do_Constant_Replacement
(E
) then
3610 return Is_Known_Null
(E
);
3612 -- Otherwise if not safe to do replacement, then say so
3619 -- True if explicit reference to null
3621 elsif Nkind
(N
) = N_Null
then
3624 -- For a conversion, true if expression is known null
3626 elsif Nkind
(N
) = N_Type_Conversion
then
3627 return Known_Null
(Expression
(N
));
3629 -- Above are all cases where the value could be determined to be null.
3630 -- In all other cases, we don't know, so return False.
3637 -----------------------------
3638 -- Make_CW_Equivalent_Type --
3639 -----------------------------
3641 -- Create a record type used as an equivalent of any member
3642 -- of the class which takes its size from exp.
3644 -- Generate the following code:
3646 -- type Equiv_T is record
3647 -- _parent : T (List of discriminant constaints taken from Exp);
3648 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
3651 -- ??? Note that this type does not guarantee same alignment as all
3654 function Make_CW_Equivalent_Type
3656 E
: Node_Id
) return Entity_Id
3658 Loc
: constant Source_Ptr
:= Sloc
(E
);
3659 Root_Typ
: constant Entity_Id
:= Root_Type
(T
);
3660 List_Def
: constant List_Id
:= Empty_List
;
3661 Comp_List
: constant List_Id
:= New_List
;
3662 Equiv_Type
: Entity_Id
;
3663 Range_Type
: Entity_Id
;
3664 Str_Type
: Entity_Id
;
3665 Constr_Root
: Entity_Id
;
3669 if not Has_Discriminants
(Root_Typ
) then
3670 Constr_Root
:= Root_Typ
;
3673 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
3675 -- subtype cstr__n is T (List of discr constraints taken from Exp)
3677 Append_To
(List_Def
,
3678 Make_Subtype_Declaration
(Loc
,
3679 Defining_Identifier
=> Constr_Root
,
3680 Subtype_Indication
=>
3681 Make_Subtype_From_Expr
(E
, Root_Typ
)));
3684 -- Generate the range subtype declaration
3686 Range_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('G'));
3688 if not Is_Interface
(Root_Typ
) then
3689 -- subtype rg__xx is
3690 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
3693 Make_Op_Subtract
(Loc
,
3695 Make_Attribute_Reference
(Loc
,
3697 OK_Convert_To
(T
, Duplicate_Subexpr_No_Checks
(E
)),
3698 Attribute_Name
=> Name_Size
),
3700 Make_Attribute_Reference
(Loc
,
3701 Prefix
=> New_Reference_To
(Constr_Root
, Loc
),
3702 Attribute_Name
=> Name_Object_Size
));
3704 -- subtype rg__xx is
3705 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
3708 Make_Attribute_Reference
(Loc
,
3710 OK_Convert_To
(T
, Duplicate_Subexpr_No_Checks
(E
)),
3711 Attribute_Name
=> Name_Size
);
3714 Set_Paren_Count
(Sizexpr
, 1);
3716 Append_To
(List_Def
,
3717 Make_Subtype_Declaration
(Loc
,
3718 Defining_Identifier
=> Range_Type
,
3719 Subtype_Indication
=>
3720 Make_Subtype_Indication
(Loc
,
3721 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
),
3722 Constraint
=> Make_Range_Constraint
(Loc
,
3725 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
3727 Make_Op_Divide
(Loc
,
3728 Left_Opnd
=> Sizexpr
,
3729 Right_Opnd
=> Make_Integer_Literal
(Loc
,
3730 Intval
=> System_Storage_Unit
)))))));
3732 -- subtype str__nn is Storage_Array (rg__x);
3734 Str_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
3735 Append_To
(List_Def
,
3736 Make_Subtype_Declaration
(Loc
,
3737 Defining_Identifier
=> Str_Type
,
3738 Subtype_Indication
=>
3739 Make_Subtype_Indication
(Loc
,
3740 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Storage_Array
), Loc
),
3742 Make_Index_Or_Discriminant_Constraint
(Loc
,
3744 New_List
(New_Reference_To
(Range_Type
, Loc
))))));
3746 -- type Equiv_T is record
3747 -- [ _parent : Tnn; ]
3751 Equiv_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
3753 -- When the target requires front-end layout, it's necessary to allow
3754 -- the equivalent type to be frozen so that layout can occur (when the
3755 -- associated class-wide subtype is frozen, the equivalent type will
3756 -- be frozen, see freeze.adb). For other targets, Gigi wants to have
3757 -- the equivalent type marked as frozen and deals with this type itself.
3758 -- In the Gigi case this will also avoid the generation of an init
3759 -- procedure for the type.
3761 if not Frontend_Layout_On_Target
then
3762 Set_Is_Frozen
(Equiv_Type
);
3765 Set_Ekind
(Equiv_Type
, E_Record_Type
);
3766 Set_Parent_Subtype
(Equiv_Type
, Constr_Root
);
3768 if not Is_Interface
(Root_Typ
) then
3769 Append_To
(Comp_List
,
3770 Make_Component_Declaration
(Loc
,
3771 Defining_Identifier
=>
3772 Make_Defining_Identifier
(Loc
, Name_uParent
),
3773 Component_Definition
=>
3774 Make_Component_Definition
(Loc
,
3775 Aliased_Present
=> False,
3776 Subtype_Indication
=> New_Reference_To
(Constr_Root
, Loc
))));
3779 Append_To
(Comp_List
,
3780 Make_Component_Declaration
(Loc
,
3781 Defining_Identifier
=>
3782 Make_Defining_Identifier
(Loc
,
3783 Chars
=> New_Internal_Name
('C')),
3784 Component_Definition
=>
3785 Make_Component_Definition
(Loc
,
3786 Aliased_Present
=> False,
3787 Subtype_Indication
=> New_Reference_To
(Str_Type
, Loc
))));
3789 Append_To
(List_Def
,
3790 Make_Full_Type_Declaration
(Loc
,
3791 Defining_Identifier
=> Equiv_Type
,
3793 Make_Record_Definition
(Loc
,
3795 Make_Component_List
(Loc
,
3796 Component_Items
=> Comp_List
,
3797 Variant_Part
=> Empty
))));
3799 -- Suppress all checks during the analysis of the expanded code
3800 -- to avoid the generation of spurious warnings under ZFP run-time.
3802 Insert_Actions
(E
, List_Def
, Suppress
=> All_Checks
);
3804 end Make_CW_Equivalent_Type
;
3806 ------------------------
3807 -- Make_Literal_Range --
3808 ------------------------
3810 function Make_Literal_Range
3812 Literal_Typ
: Entity_Id
) return Node_Id
3814 Lo
: constant Node_Id
:=
3815 New_Copy_Tree
(String_Literal_Low_Bound
(Literal_Typ
));
3816 Index
: constant Entity_Id
:= Etype
(Lo
);
3819 Length_Expr
: constant Node_Id
:=
3820 Make_Op_Subtract
(Loc
,
3822 Make_Integer_Literal
(Loc
,
3823 Intval
=> String_Literal_Length
(Literal_Typ
)),
3825 Make_Integer_Literal
(Loc
, 1));
3828 Set_Analyzed
(Lo
, False);
3830 if Is_Integer_Type
(Index
) then
3833 Left_Opnd
=> New_Copy_Tree
(Lo
),
3834 Right_Opnd
=> Length_Expr
);
3837 Make_Attribute_Reference
(Loc
,
3838 Attribute_Name
=> Name_Val
,
3839 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
3840 Expressions
=> New_List
(
3843 Make_Attribute_Reference
(Loc
,
3844 Attribute_Name
=> Name_Pos
,
3845 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
3846 Expressions
=> New_List
(New_Copy_Tree
(Lo
))),
3847 Right_Opnd
=> Length_Expr
)));
3854 end Make_Literal_Range
;
3856 ----------------------------
3857 -- Make_Subtype_From_Expr --
3858 ----------------------------
3860 -- 1. If Expr is an uncontrained array expression, creates
3861 -- Unc_Type(Expr'first(1)..Expr'Last(1),..., Expr'first(n)..Expr'last(n))
3863 -- 2. If Expr is a unconstrained discriminated type expression, creates
3864 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
3866 -- 3. If Expr is class-wide, creates an implicit class wide subtype
3868 function Make_Subtype_From_Expr
3870 Unc_Typ
: Entity_Id
) return Node_Id
3872 Loc
: constant Source_Ptr
:= Sloc
(E
);
3873 List_Constr
: constant List_Id
:= New_List
;
3876 Full_Subtyp
: Entity_Id
;
3877 Priv_Subtyp
: Entity_Id
;
3882 if Is_Private_Type
(Unc_Typ
)
3883 and then Has_Unknown_Discriminants
(Unc_Typ
)
3885 -- Prepare the subtype completion, Go to base type to
3886 -- find underlying type, because the type may be a generic
3887 -- actual or an explicit subtype.
3889 Utyp
:= Underlying_Type
(Base_Type
(Unc_Typ
));
3890 Full_Subtyp
:= Make_Defining_Identifier
(Loc
,
3891 New_Internal_Name
('C'));
3893 Unchecked_Convert_To
3894 (Utyp
, Duplicate_Subexpr_No_Checks
(E
));
3895 Set_Parent
(Full_Exp
, Parent
(E
));
3898 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
3901 Make_Subtype_Declaration
(Loc
,
3902 Defining_Identifier
=> Full_Subtyp
,
3903 Subtype_Indication
=> Make_Subtype_From_Expr
(Full_Exp
, Utyp
)));
3905 -- Define the dummy private subtype
3907 Set_Ekind
(Priv_Subtyp
, Subtype_Kind
(Ekind
(Unc_Typ
)));
3908 Set_Etype
(Priv_Subtyp
, Base_Type
(Unc_Typ
));
3909 Set_Scope
(Priv_Subtyp
, Full_Subtyp
);
3910 Set_Is_Constrained
(Priv_Subtyp
);
3911 Set_Is_Tagged_Type
(Priv_Subtyp
, Is_Tagged_Type
(Unc_Typ
));
3912 Set_Is_Itype
(Priv_Subtyp
);
3913 Set_Associated_Node_For_Itype
(Priv_Subtyp
, E
);
3915 if Is_Tagged_Type
(Priv_Subtyp
) then
3917 (Base_Type
(Priv_Subtyp
), Class_Wide_Type
(Unc_Typ
));
3918 Set_Primitive_Operations
(Priv_Subtyp
,
3919 Primitive_Operations
(Unc_Typ
));
3922 Set_Full_View
(Priv_Subtyp
, Full_Subtyp
);
3924 return New_Reference_To
(Priv_Subtyp
, Loc
);
3926 elsif Is_Array_Type
(Unc_Typ
) then
3927 for J
in 1 .. Number_Dimensions
(Unc_Typ
) loop
3928 Append_To
(List_Constr
,
3931 Make_Attribute_Reference
(Loc
,
3932 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
3933 Attribute_Name
=> Name_First
,
3934 Expressions
=> New_List
(
3935 Make_Integer_Literal
(Loc
, J
))),
3938 Make_Attribute_Reference
(Loc
,
3939 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
3940 Attribute_Name
=> Name_Last
,
3941 Expressions
=> New_List
(
3942 Make_Integer_Literal
(Loc
, J
)))));
3945 elsif Is_Class_Wide_Type
(Unc_Typ
) then
3947 CW_Subtype
: Entity_Id
;
3948 EQ_Typ
: Entity_Id
:= Empty
;
3951 -- A class-wide equivalent type is not needed when VM_Target
3952 -- because the VM back-ends handle the class-wide object
3953 -- initialization itself (and doesn't need or want the
3954 -- additional intermediate type to handle the assignment).
3956 if Expander_Active
and then VM_Target
= No_VM
then
3957 EQ_Typ
:= Make_CW_Equivalent_Type
(Unc_Typ
, E
);
3960 CW_Subtype
:= New_Class_Wide_Subtype
(Unc_Typ
, E
);
3961 Set_Equivalent_Type
(CW_Subtype
, EQ_Typ
);
3963 if Present
(EQ_Typ
) then
3964 Set_Is_Class_Wide_Equivalent_Type
(EQ_Typ
);
3967 Set_Cloned_Subtype
(CW_Subtype
, Base_Type
(Unc_Typ
));
3969 return New_Occurrence_Of
(CW_Subtype
, Loc
);
3972 -- Indefinite record type with discriminants
3975 D
:= First_Discriminant
(Unc_Typ
);
3976 while Present
(D
) loop
3977 Append_To
(List_Constr
,
3978 Make_Selected_Component
(Loc
,
3979 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
3980 Selector_Name
=> New_Reference_To
(D
, Loc
)));
3982 Next_Discriminant
(D
);
3987 Make_Subtype_Indication
(Loc
,
3988 Subtype_Mark
=> New_Reference_To
(Unc_Typ
, Loc
),
3990 Make_Index_Or_Discriminant_Constraint
(Loc
,
3991 Constraints
=> List_Constr
));
3992 end Make_Subtype_From_Expr
;
3994 -----------------------------
3995 -- May_Generate_Large_Temp --
3996 -----------------------------
3998 -- At the current time, the only types that we return False for (i.e.
3999 -- where we decide we know they cannot generate large temps) are ones
4000 -- where we know the size is 256 bits or less at compile time, and we
4001 -- are still not doing a thorough job on arrays and records ???
4003 function May_Generate_Large_Temp
(Typ
: Entity_Id
) return Boolean is
4005 if not Size_Known_At_Compile_Time
(Typ
) then
4008 elsif Esize
(Typ
) /= 0 and then Esize
(Typ
) <= 256 then
4011 elsif Is_Array_Type
(Typ
)
4012 and then Present
(Packed_Array_Type
(Typ
))
4014 return May_Generate_Large_Temp
(Packed_Array_Type
(Typ
));
4016 -- We could do more here to find other small types ???
4021 end May_Generate_Large_Temp
;
4023 ----------------------------
4024 -- New_Class_Wide_Subtype --
4025 ----------------------------
4027 function New_Class_Wide_Subtype
4028 (CW_Typ
: Entity_Id
;
4029 N
: Node_Id
) return Entity_Id
4031 Res
: constant Entity_Id
:= Create_Itype
(E_Void
, N
);
4032 Res_Name
: constant Name_Id
:= Chars
(Res
);
4033 Res_Scope
: constant Entity_Id
:= Scope
(Res
);
4036 Copy_Node
(CW_Typ
, Res
);
4037 Set_Comes_From_Source
(Res
, False);
4038 Set_Sloc
(Res
, Sloc
(N
));
4040 Set_Associated_Node_For_Itype
(Res
, N
);
4041 Set_Is_Public
(Res
, False); -- By default, may be changed below.
4042 Set_Public_Status
(Res
);
4043 Set_Chars
(Res
, Res_Name
);
4044 Set_Scope
(Res
, Res_Scope
);
4045 Set_Ekind
(Res
, E_Class_Wide_Subtype
);
4046 Set_Next_Entity
(Res
, Empty
);
4047 Set_Etype
(Res
, Base_Type
(CW_Typ
));
4049 -- For targets where front-end layout is required, reset the Is_Frozen
4050 -- status of the subtype to False (it can be implicitly set to true
4051 -- from the copy of the class-wide type). For other targets, Gigi
4052 -- doesn't want the class-wide subtype to go through the freezing
4053 -- process (though it's unclear why that causes problems and it would
4054 -- be nice to allow freezing to occur normally for all targets ???).
4056 if Frontend_Layout_On_Target
then
4057 Set_Is_Frozen
(Res
, False);
4060 Set_Freeze_Node
(Res
, Empty
);
4062 end New_Class_Wide_Subtype
;
4064 --------------------------------
4065 -- Non_Limited_Designated_Type --
4066 ---------------------------------
4068 function Non_Limited_Designated_Type
(T
: Entity_Id
) return Entity_Id
is
4069 Desig
: constant Entity_Id
:= Designated_Type
(T
);
4071 if Ekind
(Desig
) = E_Incomplete_Type
4072 and then Present
(Non_Limited_View
(Desig
))
4074 return Non_Limited_View
(Desig
);
4078 end Non_Limited_Designated_Type
;
4080 -----------------------------------
4081 -- OK_To_Do_Constant_Replacement --
4082 -----------------------------------
4084 function OK_To_Do_Constant_Replacement
(E
: Entity_Id
) return Boolean is
4085 ES
: constant Entity_Id
:= Scope
(E
);
4089 -- Do not replace statically allocated objects, because they may be
4090 -- modified outside the current scope.
4092 if Is_Statically_Allocated
(E
) then
4095 -- Do not replace aliased or volatile objects, since we don't know what
4096 -- else might change the value.
4098 elsif Is_Aliased
(E
) or else Treat_As_Volatile
(E
) then
4101 -- Debug flag -gnatdM disconnects this optimization
4103 elsif Debug_Flag_MM
then
4106 -- Otherwise check scopes
4109 CS
:= Current_Scope
;
4112 -- If we are in right scope, replacement is safe
4117 -- Packages do not affect the determination of safety
4119 elsif Ekind
(CS
) = E_Package
then
4120 exit when CS
= Standard_Standard
;
4123 -- Blocks do not affect the determination of safety
4125 elsif Ekind
(CS
) = E_Block
then
4128 -- Loops do not affect the determination of safety. Note that we
4129 -- kill all current values on entry to a loop, so we are just
4130 -- talking about processing within a loop here.
4132 elsif Ekind
(CS
) = E_Loop
then
4135 -- Otherwise, the reference is dubious, and we cannot be sure that
4136 -- it is safe to do the replacement.
4145 end OK_To_Do_Constant_Replacement
;
4147 ------------------------------------
4148 -- Possible_Bit_Aligned_Component --
4149 ------------------------------------
4151 function Possible_Bit_Aligned_Component
(N
: Node_Id
) return Boolean is
4155 -- Case of indexed component
4157 when N_Indexed_Component
=>
4159 P
: constant Node_Id
:= Prefix
(N
);
4160 Ptyp
: constant Entity_Id
:= Etype
(P
);
4163 -- If we know the component size and it is less than 64, then
4164 -- we are definitely OK. The back end always does assignment
4165 -- of misaligned small objects correctly.
4167 if Known_Static_Component_Size
(Ptyp
)
4168 and then Component_Size
(Ptyp
) <= 64
4172 -- Otherwise, we need to test the prefix, to see if we are
4173 -- indexing from a possibly unaligned component.
4176 return Possible_Bit_Aligned_Component
(P
);
4180 -- Case of selected component
4182 when N_Selected_Component
=>
4184 P
: constant Node_Id
:= Prefix
(N
);
4185 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
4188 -- If there is no component clause, then we are in the clear
4189 -- since the back end will never misalign a large component
4190 -- unless it is forced to do so. In the clear means we need
4191 -- only the recursive test on the prefix.
4193 if Component_May_Be_Bit_Aligned
(Comp
) then
4196 return Possible_Bit_Aligned_Component
(P
);
4200 -- If we have neither a record nor array component, it means that we
4201 -- have fallen off the top testing prefixes recursively, and we now
4202 -- have a stand alone object, where we don't have a problem.
4208 end Possible_Bit_Aligned_Component
;
4210 -------------------------
4211 -- Remove_Side_Effects --
4212 -------------------------
4214 procedure Remove_Side_Effects
4216 Name_Req
: Boolean := False;
4217 Variable_Ref
: Boolean := False)
4219 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
4220 Exp_Type
: constant Entity_Id
:= Etype
(Exp
);
4221 Svg_Suppress
: constant Suppress_Array
:= Scope_Suppress
;
4223 Ref_Type
: Entity_Id
;
4225 Ptr_Typ_Decl
: Node_Id
;
4229 function Side_Effect_Free
(N
: Node_Id
) return Boolean;
4230 -- Determines if the tree N represents an expression that is known not
4231 -- to have side effects, and for which no processing is required.
4233 function Side_Effect_Free
(L
: List_Id
) return Boolean;
4234 -- Determines if all elements of the list L are side effect free
4236 function Safe_Prefixed_Reference
(N
: Node_Id
) return Boolean;
4237 -- The argument N is a construct where the Prefix is dereferenced if it
4238 -- is an access type and the result is a variable. The call returns True
4239 -- if the construct is side effect free (not considering side effects in
4240 -- other than the prefix which are to be tested by the caller).
4242 function Within_In_Parameter
(N
: Node_Id
) return Boolean;
4243 -- Determines if N is a subcomponent of a composite in-parameter. If so,
4244 -- N is not side-effect free when the actual is global and modifiable
4245 -- indirectly from within a subprogram, because it may be passed by
4246 -- reference. The front-end must be conservative here and assume that
4247 -- this may happen with any array or record type. On the other hand, we
4248 -- cannot create temporaries for all expressions for which this
4249 -- condition is true, for various reasons that might require clearing up
4250 -- ??? For example, descriminant references that appear out of place, or
4251 -- spurious type errors with class-wide expressions. As a result, we
4252 -- limit the transformation to loop bounds, which is so far the only
4253 -- case that requires it.
4255 -----------------------------
4256 -- Safe_Prefixed_Reference --
4257 -----------------------------
4259 function Safe_Prefixed_Reference
(N
: Node_Id
) return Boolean is
4261 -- If prefix is not side effect free, definitely not safe
4263 if not Side_Effect_Free
(Prefix
(N
)) then
4266 -- If the prefix is of an access type that is not access-to-constant,
4267 -- then this construct is a variable reference, which means it is to
4268 -- be considered to have side effects if Variable_Ref is set True
4269 -- Exception is an access to an entity that is a constant or an
4270 -- in-parameter which does not come from source, and is the result
4271 -- of a previous removal of side-effects.
4273 elsif Is_Access_Type
(Etype
(Prefix
(N
)))
4274 and then not Is_Access_Constant
(Etype
(Prefix
(N
)))
4275 and then Variable_Ref
4277 if not Is_Entity_Name
(Prefix
(N
)) then
4280 return Ekind
(Entity
(Prefix
(N
))) = E_Constant
4281 or else Ekind
(Entity
(Prefix
(N
))) = E_In_Parameter
;
4284 -- The following test is the simplest way of solving a complex
4285 -- problem uncovered by BB08-010: Side effect on loop bound that
4286 -- is a subcomponent of a global variable:
4287 -- If a loop bound is a subcomponent of a global variable, a
4288 -- modification of that variable within the loop may incorrectly
4289 -- affect the execution of the loop.
4292 (Nkind
(Parent
(Parent
(N
))) /= N_Loop_Parameter_Specification
4293 or else not Within_In_Parameter
(Prefix
(N
)))
4297 -- All other cases are side effect free
4302 end Safe_Prefixed_Reference
;
4304 ----------------------
4305 -- Side_Effect_Free --
4306 ----------------------
4308 function Side_Effect_Free
(N
: Node_Id
) return Boolean is
4310 -- Note on checks that could raise Constraint_Error. Strictly, if
4311 -- we take advantage of 11.6, these checks do not count as side
4312 -- effects. However, we would just as soon consider that they are
4313 -- side effects, since the backend CSE does not work very well on
4314 -- expressions which can raise Constraint_Error. On the other
4315 -- hand, if we do not consider them to be side effect free, then
4316 -- we get some awkward expansions in -gnato mode, resulting in
4317 -- code insertions at a point where we do not have a clear model
4318 -- for performing the insertions. See 4908-002/comment for details.
4320 -- Special handling for entity names
4322 if Is_Entity_Name
(N
) then
4324 -- If the entity is a constant, it is definitely side effect
4325 -- free. Note that the test of Is_Variable (N) below might
4326 -- be expected to catch this case, but it does not, because
4327 -- this test goes to the original tree, and we may have
4328 -- already rewritten a variable node with a constant as
4329 -- a result of an earlier Force_Evaluation call.
4331 if Ekind
(Entity
(N
)) = E_Constant
4332 or else Ekind
(Entity
(N
)) = E_In_Parameter
4336 -- Functions are not side effect free
4338 elsif Ekind
(Entity
(N
)) = E_Function
then
4341 -- Variables are considered to be a side effect if Variable_Ref
4342 -- is set or if we have a volatile variable and Name_Req is off.
4343 -- If Name_Req is True then we can't help returning a name which
4344 -- effectively allows multiple references in any case.
4346 elsif Is_Variable
(N
) then
4347 return not Variable_Ref
4348 and then (not Treat_As_Volatile
(Entity
(N
))
4351 -- Any other entity (e.g. a subtype name) is definitely side
4358 -- A value known at compile time is always side effect free
4360 elsif Compile_Time_Known_Value
(N
) then
4363 -- A variable renaming is not side-effet free, because the
4364 -- renaming will function like a macro in the front-end in
4365 -- some cases, and an assignment can modify the the component
4366 -- designated by N, so we need to create a temporary for it.
4368 elsif Is_Entity_Name
(Original_Node
(N
))
4369 and then Is_Renaming_Of_Object
(Entity
(Original_Node
(N
)))
4370 and then Ekind
(Entity
(Original_Node
(N
))) /= E_Constant
4375 -- For other than entity names and compile time known values,
4376 -- check the node kind for special processing.
4380 -- An attribute reference is side effect free if its expressions
4381 -- are side effect free and its prefix is side effect free or
4382 -- is an entity reference.
4384 -- Is this right? what about x'first where x is a variable???
4386 when N_Attribute_Reference
=>
4387 return Side_Effect_Free
(Expressions
(N
))
4388 and then Attribute_Name
(N
) /= Name_Input
4389 and then (Is_Entity_Name
(Prefix
(N
))
4390 or else Side_Effect_Free
(Prefix
(N
)));
4392 -- A binary operator is side effect free if and both operands
4393 -- are side effect free. For this purpose binary operators
4394 -- include membership tests and short circuit forms
4400 return Side_Effect_Free
(Left_Opnd
(N
))
4401 and then Side_Effect_Free
(Right_Opnd
(N
));
4403 -- An explicit dereference is side effect free only if it is
4404 -- a side effect free prefixed reference.
4406 when N_Explicit_Dereference
=>
4407 return Safe_Prefixed_Reference
(N
);
4409 -- A call to _rep_to_pos is side effect free, since we generate
4410 -- this pure function call ourselves. Moreover it is critically
4411 -- important to make this exception, since otherwise we can
4412 -- have discriminants in array components which don't look
4413 -- side effect free in the case of an array whose index type
4414 -- is an enumeration type with an enumeration rep clause.
4416 -- All other function calls are not side effect free
4418 when N_Function_Call
=>
4419 return Nkind
(Name
(N
)) = N_Identifier
4420 and then Is_TSS
(Name
(N
), TSS_Rep_To_Pos
)
4422 Side_Effect_Free
(First
(Parameter_Associations
(N
)));
4424 -- An indexed component is side effect free if it is a side
4425 -- effect free prefixed reference and all the indexing
4426 -- expressions are side effect free.
4428 when N_Indexed_Component
=>
4429 return Side_Effect_Free
(Expressions
(N
))
4430 and then Safe_Prefixed_Reference
(N
);
4432 -- A type qualification is side effect free if the expression
4433 -- is side effect free.
4435 when N_Qualified_Expression
=>
4436 return Side_Effect_Free
(Expression
(N
));
4438 -- A selected component is side effect free only if it is a
4439 -- side effect free prefixed reference. If it designates a
4440 -- component with a rep. clause it must be treated has having
4441 -- a potential side effect, because it may be modified through
4442 -- a renaming, and a subsequent use of the renaming as a macro
4443 -- will yield the wrong value. This complex interaction between
4444 -- renaming and removing side effects is a reminder that the
4445 -- latter has become a headache to maintain, and that it should
4446 -- be removed in favor of the gcc mechanism to capture values ???
4448 when N_Selected_Component
=>
4449 if Nkind
(Parent
(N
)) = N_Explicit_Dereference
4450 and then Has_Non_Standard_Rep
(Designated_Type
(Etype
(N
)))
4454 return Safe_Prefixed_Reference
(N
);
4457 -- A range is side effect free if the bounds are side effect free
4460 return Side_Effect_Free
(Low_Bound
(N
))
4461 and then Side_Effect_Free
(High_Bound
(N
));
4463 -- A slice is side effect free if it is a side effect free
4464 -- prefixed reference and the bounds are side effect free.
4467 return Side_Effect_Free
(Discrete_Range
(N
))
4468 and then Safe_Prefixed_Reference
(N
);
4470 -- A type conversion is side effect free if the expression to be
4471 -- converted is side effect free.
4473 when N_Type_Conversion
=>
4474 return Side_Effect_Free
(Expression
(N
));
4476 -- A unary operator is side effect free if the operand
4477 -- is side effect free.
4480 return Side_Effect_Free
(Right_Opnd
(N
));
4482 -- An unchecked type conversion is side effect free only if it
4483 -- is safe and its argument is side effect free.
4485 when N_Unchecked_Type_Conversion
=>
4486 return Safe_Unchecked_Type_Conversion
(N
)
4487 and then Side_Effect_Free
(Expression
(N
));
4489 -- An unchecked expression is side effect free if its expression
4490 -- is side effect free.
4492 when N_Unchecked_Expression
=>
4493 return Side_Effect_Free
(Expression
(N
));
4495 -- A literal is side effect free
4497 when N_Character_Literal |
4503 -- We consider that anything else has side effects. This is a bit
4504 -- crude, but we are pretty close for most common cases, and we
4505 -- are certainly correct (i.e. we never return True when the
4506 -- answer should be False).
4511 end Side_Effect_Free
;
4513 -- A list is side effect free if all elements of the list are
4514 -- side effect free.
4516 function Side_Effect_Free
(L
: List_Id
) return Boolean is
4520 if L
= No_List
or else L
= Error_List
then
4525 while Present
(N
) loop
4526 if not Side_Effect_Free
(N
) then
4535 end Side_Effect_Free
;
4537 -------------------------
4538 -- Within_In_Parameter --
4539 -------------------------
4541 function Within_In_Parameter
(N
: Node_Id
) return Boolean is
4543 if not Comes_From_Source
(N
) then
4546 elsif Is_Entity_Name
(N
) then
4547 return Ekind
(Entity
(N
)) = E_In_Parameter
;
4549 elsif Nkind
(N
) = N_Indexed_Component
4550 or else Nkind
(N
) = N_Selected_Component
4552 return Within_In_Parameter
(Prefix
(N
));
4557 end Within_In_Parameter
;
4559 -- Start of processing for Remove_Side_Effects
4562 -- If we are side effect free already or expansion is disabled,
4563 -- there is nothing to do.
4565 if Side_Effect_Free
(Exp
) or else not Expander_Active
then
4569 -- All this must not have any checks
4571 Scope_Suppress
:= (others => True);
4573 -- If it is a scalar type and we need to capture the value, just make
4574 -- a copy. Likewise for a function or operator call. And if we have a
4575 -- volatile variable and Nam_Req is not set (see comments above for
4576 -- Side_Effect_Free).
4578 if Is_Elementary_Type
(Exp_Type
)
4579 and then (Variable_Ref
4580 or else Nkind
(Exp
) = N_Function_Call
4581 or else Nkind
(Exp
) in N_Op
4582 or else (not Name_Req
4583 and then Is_Entity_Name
(Exp
)
4584 and then Treat_As_Volatile
(Entity
(Exp
))))
4586 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4587 Set_Etype
(Def_Id
, Exp_Type
);
4588 Res
:= New_Reference_To
(Def_Id
, Loc
);
4591 Make_Object_Declaration
(Loc
,
4592 Defining_Identifier
=> Def_Id
,
4593 Object_Definition
=> New_Reference_To
(Exp_Type
, Loc
),
4594 Constant_Present
=> True,
4595 Expression
=> Relocate_Node
(Exp
));
4597 Set_Assignment_OK
(E
);
4598 Insert_Action
(Exp
, E
);
4600 -- If the expression has the form v.all then we can just capture
4601 -- the pointer, and then do an explicit dereference on the result.
4603 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
4605 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4607 Make_Explicit_Dereference
(Loc
, New_Reference_To
(Def_Id
, Loc
));
4610 Make_Object_Declaration
(Loc
,
4611 Defining_Identifier
=> Def_Id
,
4612 Object_Definition
=>
4613 New_Reference_To
(Etype
(Prefix
(Exp
)), Loc
),
4614 Constant_Present
=> True,
4615 Expression
=> Relocate_Node
(Prefix
(Exp
))));
4617 -- Similar processing for an unchecked conversion of an expression
4618 -- of the form v.all, where we want the same kind of treatment.
4620 elsif Nkind
(Exp
) = N_Unchecked_Type_Conversion
4621 and then Nkind
(Expression
(Exp
)) = N_Explicit_Dereference
4623 Remove_Side_Effects
(Expression
(Exp
), Name_Req
, Variable_Ref
);
4624 Scope_Suppress
:= Svg_Suppress
;
4627 -- If this is a type conversion, leave the type conversion and remove
4628 -- the side effects in the expression. This is important in several
4629 -- circumstances: for change of representations, and also when this
4630 -- is a view conversion to a smaller object, where gigi can end up
4631 -- creating its own temporary of the wrong size.
4633 elsif Nkind
(Exp
) = N_Type_Conversion
then
4634 Remove_Side_Effects
(Expression
(Exp
), Name_Req
, Variable_Ref
);
4635 Scope_Suppress
:= Svg_Suppress
;
4638 -- If this is an unchecked conversion that Gigi can't handle, make
4639 -- a copy or a use a renaming to capture the value.
4641 elsif Nkind
(Exp
) = N_Unchecked_Type_Conversion
4642 and then not Safe_Unchecked_Type_Conversion
(Exp
)
4644 if CW_Or_Controlled_Type
(Exp_Type
) then
4646 -- Use a renaming to capture the expression, rather than create
4647 -- a controlled temporary.
4649 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4650 Res
:= New_Reference_To
(Def_Id
, Loc
);
4653 Make_Object_Renaming_Declaration
(Loc
,
4654 Defining_Identifier
=> Def_Id
,
4655 Subtype_Mark
=> New_Reference_To
(Exp_Type
, Loc
),
4656 Name
=> Relocate_Node
(Exp
)));
4659 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4660 Set_Etype
(Def_Id
, Exp_Type
);
4661 Res
:= New_Reference_To
(Def_Id
, Loc
);
4664 Make_Object_Declaration
(Loc
,
4665 Defining_Identifier
=> Def_Id
,
4666 Object_Definition
=> New_Reference_To
(Exp_Type
, Loc
),
4667 Constant_Present
=> not Is_Variable
(Exp
),
4668 Expression
=> Relocate_Node
(Exp
));
4670 Set_Assignment_OK
(E
);
4671 Insert_Action
(Exp
, E
);
4674 -- For expressions that denote objects, we can use a renaming scheme.
4675 -- We skip using this if we have a volatile variable and we do not
4676 -- have Nam_Req set true (see comments above for Side_Effect_Free).
4678 elsif Is_Object_Reference
(Exp
)
4679 and then Nkind
(Exp
) /= N_Function_Call
4681 or else not Is_Entity_Name
(Exp
)
4682 or else not Treat_As_Volatile
(Entity
(Exp
)))
4684 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4686 if Nkind
(Exp
) = N_Selected_Component
4687 and then Nkind
(Prefix
(Exp
)) = N_Function_Call
4688 and then Is_Array_Type
(Exp_Type
)
4690 -- Avoid generating a variable-sized temporary, by generating
4691 -- the renaming declaration just for the function call. The
4692 -- transformation could be refined to apply only when the array
4693 -- component is constrained by a discriminant???
4696 Make_Selected_Component
(Loc
,
4697 Prefix
=> New_Occurrence_Of
(Def_Id
, Loc
),
4698 Selector_Name
=> Selector_Name
(Exp
));
4701 Make_Object_Renaming_Declaration
(Loc
,
4702 Defining_Identifier
=> Def_Id
,
4704 New_Reference_To
(Base_Type
(Etype
(Prefix
(Exp
))), Loc
),
4705 Name
=> Relocate_Node
(Prefix
(Exp
))));
4708 Res
:= New_Reference_To
(Def_Id
, Loc
);
4711 Make_Object_Renaming_Declaration
(Loc
,
4712 Defining_Identifier
=> Def_Id
,
4713 Subtype_Mark
=> New_Reference_To
(Exp_Type
, Loc
),
4714 Name
=> Relocate_Node
(Exp
)));
4718 -- If this is a packed reference, or a selected component with a
4719 -- non-standard representation, a reference to the temporary will
4720 -- be replaced by a copy of the original expression (see
4721 -- exp_ch2.Expand_Renaming). Otherwise the temporary must be
4722 -- elaborated by gigi, and is of course not to be replaced in-line
4723 -- by the expression it renames, which would defeat the purpose of
4724 -- removing the side-effect.
4726 if (Nkind
(Exp
) = N_Selected_Component
4727 or else Nkind
(Exp
) = N_Indexed_Component
)
4728 and then Has_Non_Standard_Rep
(Etype
(Prefix
(Exp
)))
4732 Set_Is_Renaming_Of_Object
(Def_Id
, False);
4735 -- Otherwise we generate a reference to the value
4738 Ref_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
4741 Make_Full_Type_Declaration
(Loc
,
4742 Defining_Identifier
=> Ref_Type
,
4744 Make_Access_To_Object_Definition
(Loc
,
4745 All_Present
=> True,
4746 Subtype_Indication
=>
4747 New_Reference_To
(Exp_Type
, Loc
)));
4750 Insert_Action
(Exp
, Ptr_Typ_Decl
);
4752 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4753 Set_Etype
(Def_Id
, Exp_Type
);
4756 Make_Explicit_Dereference
(Loc
,
4757 Prefix
=> New_Reference_To
(Def_Id
, Loc
));
4759 if Nkind
(E
) = N_Explicit_Dereference
then
4760 New_Exp
:= Relocate_Node
(Prefix
(E
));
4762 E
:= Relocate_Node
(E
);
4763 New_Exp
:= Make_Reference
(Loc
, E
);
4766 if Is_Delayed_Aggregate
(E
) then
4768 -- The expansion of nested aggregates is delayed until the
4769 -- enclosing aggregate is expanded. As aggregates are often
4770 -- qualified, the predicate applies to qualified expressions
4771 -- as well, indicating that the enclosing aggregate has not
4772 -- been expanded yet. At this point the aggregate is part of
4773 -- a stand-alone declaration, and must be fully expanded.
4775 if Nkind
(E
) = N_Qualified_Expression
then
4776 Set_Expansion_Delayed
(Expression
(E
), False);
4777 Set_Analyzed
(Expression
(E
), False);
4779 Set_Expansion_Delayed
(E
, False);
4782 Set_Analyzed
(E
, False);
4786 Make_Object_Declaration
(Loc
,
4787 Defining_Identifier
=> Def_Id
,
4788 Object_Definition
=> New_Reference_To
(Ref_Type
, Loc
),
4789 Expression
=> New_Exp
));
4792 -- Preserve the Assignment_OK flag in all copies, since at least
4793 -- one copy may be used in a context where this flag must be set
4794 -- (otherwise why would the flag be set in the first place).
4796 Set_Assignment_OK
(Res
, Assignment_OK
(Exp
));
4798 -- Finally rewrite the original expression and we are done
4801 Analyze_And_Resolve
(Exp
, Exp_Type
);
4802 Scope_Suppress
:= Svg_Suppress
;
4803 end Remove_Side_Effects
;
4805 ---------------------------
4806 -- Represented_As_Scalar --
4807 ---------------------------
4809 function Represented_As_Scalar
(T
: Entity_Id
) return Boolean is
4810 UT
: constant Entity_Id
:= Underlying_Type
(T
);
4812 return Is_Scalar_Type
(UT
)
4813 or else (Is_Bit_Packed_Array
(UT
)
4814 and then Is_Scalar_Type
(Packed_Array_Type
(UT
)));
4815 end Represented_As_Scalar
;
4817 ------------------------------------
4818 -- Safe_Unchecked_Type_Conversion --
4819 ------------------------------------
4821 -- Note: this function knows quite a bit about the exact requirements
4822 -- of Gigi with respect to unchecked type conversions, and its code
4823 -- must be coordinated with any changes in Gigi in this area.
4825 -- The above requirements should be documented in Sinfo ???
4827 function Safe_Unchecked_Type_Conversion
(Exp
: Node_Id
) return Boolean is
4832 Pexp
: constant Node_Id
:= Parent
(Exp
);
4835 -- If the expression is the RHS of an assignment or object declaration
4836 -- we are always OK because there will always be a target.
4838 -- Object renaming declarations, (generated for view conversions of
4839 -- actuals in inlined calls), like object declarations, provide an
4840 -- explicit type, and are safe as well.
4842 if (Nkind
(Pexp
) = N_Assignment_Statement
4843 and then Expression
(Pexp
) = Exp
)
4844 or else Nkind
(Pexp
) = N_Object_Declaration
4845 or else Nkind
(Pexp
) = N_Object_Renaming_Declaration
4849 -- If the expression is the prefix of an N_Selected_Component
4850 -- we should also be OK because GCC knows to look inside the
4851 -- conversion except if the type is discriminated. We assume
4852 -- that we are OK anyway if the type is not set yet or if it is
4853 -- controlled since we can't afford to introduce a temporary in
4856 elsif Nkind
(Pexp
) = N_Selected_Component
4857 and then Prefix
(Pexp
) = Exp
4859 if No
(Etype
(Pexp
)) then
4863 not Has_Discriminants
(Etype
(Pexp
))
4864 or else Is_Constrained
(Etype
(Pexp
));
4868 -- Set the output type, this comes from Etype if it is set, otherwise
4869 -- we take it from the subtype mark, which we assume was already
4872 if Present
(Etype
(Exp
)) then
4873 Otyp
:= Etype
(Exp
);
4875 Otyp
:= Entity
(Subtype_Mark
(Exp
));
4878 -- The input type always comes from the expression, and we assume
4879 -- this is indeed always analyzed, so we can simply get the Etype.
4881 Ityp
:= Etype
(Expression
(Exp
));
4883 -- Initialize alignments to unknown so far
4888 -- Replace a concurrent type by its corresponding record type
4889 -- and each type by its underlying type and do the tests on those.
4890 -- The original type may be a private type whose completion is a
4891 -- concurrent type, so find the underlying type first.
4893 if Present
(Underlying_Type
(Otyp
)) then
4894 Otyp
:= Underlying_Type
(Otyp
);
4897 if Present
(Underlying_Type
(Ityp
)) then
4898 Ityp
:= Underlying_Type
(Ityp
);
4901 if Is_Concurrent_Type
(Otyp
) then
4902 Otyp
:= Corresponding_Record_Type
(Otyp
);
4905 if Is_Concurrent_Type
(Ityp
) then
4906 Ityp
:= Corresponding_Record_Type
(Ityp
);
4909 -- If the base types are the same, we know there is no problem since
4910 -- this conversion will be a noop.
4912 if Implementation_Base_Type
(Otyp
) = Implementation_Base_Type
(Ityp
) then
4915 -- Same if this is an upwards conversion of an untagged type, and there
4916 -- are no constraints involved (could be more general???)
4918 elsif Etype
(Ityp
) = Otyp
4919 and then not Is_Tagged_Type
(Ityp
)
4920 and then not Has_Discriminants
(Ityp
)
4921 and then No
(First_Rep_Item
(Base_Type
(Ityp
)))
4925 -- If the size of output type is known at compile time, there is
4926 -- never a problem. Note that unconstrained records are considered
4927 -- to be of known size, but we can't consider them that way here,
4928 -- because we are talking about the actual size of the object.
4930 -- We also make sure that in addition to the size being known, we do
4931 -- not have a case which might generate an embarrassingly large temp
4932 -- in stack checking mode.
4934 elsif Size_Known_At_Compile_Time
(Otyp
)
4936 (not Stack_Checking_Enabled
4937 or else not May_Generate_Large_Temp
(Otyp
))
4938 and then not (Is_Record_Type
(Otyp
) and then not Is_Constrained
(Otyp
))
4942 -- If either type is tagged, then we know the alignment is OK so
4943 -- Gigi will be able to use pointer punning.
4945 elsif Is_Tagged_Type
(Otyp
) or else Is_Tagged_Type
(Ityp
) then
4948 -- If either type is a limited record type, we cannot do a copy, so
4949 -- say safe since there's nothing else we can do.
4951 elsif Is_Limited_Record
(Otyp
) or else Is_Limited_Record
(Ityp
) then
4954 -- Conversions to and from packed array types are always ignored and
4957 elsif Is_Packed_Array_Type
(Otyp
)
4958 or else Is_Packed_Array_Type
(Ityp
)
4963 -- The only other cases known to be safe is if the input type's
4964 -- alignment is known to be at least the maximum alignment for the
4965 -- target or if both alignments are known and the output type's
4966 -- alignment is no stricter than the input's. We can use the alignment
4967 -- of the component type of an array if a type is an unpacked
4970 if Present
(Alignment_Clause
(Otyp
)) then
4971 Oalign
:= Expr_Value
(Expression
(Alignment_Clause
(Otyp
)));
4973 elsif Is_Array_Type
(Otyp
)
4974 and then Present
(Alignment_Clause
(Component_Type
(Otyp
)))
4976 Oalign
:= Expr_Value
(Expression
(Alignment_Clause
4977 (Component_Type
(Otyp
))));
4980 if Present
(Alignment_Clause
(Ityp
)) then
4981 Ialign
:= Expr_Value
(Expression
(Alignment_Clause
(Ityp
)));
4983 elsif Is_Array_Type
(Ityp
)
4984 and then Present
(Alignment_Clause
(Component_Type
(Ityp
)))
4986 Ialign
:= Expr_Value
(Expression
(Alignment_Clause
4987 (Component_Type
(Ityp
))));
4990 if Ialign
/= No_Uint
and then Ialign
> Maximum_Alignment
then
4993 elsif Ialign
/= No_Uint
and then Oalign
/= No_Uint
4994 and then Ialign
<= Oalign
4998 -- Otherwise, Gigi cannot handle this and we must make a temporary
5003 end Safe_Unchecked_Type_Conversion
;
5005 ---------------------------------
5006 -- Set_Current_Value_Condition --
5007 ---------------------------------
5009 -- Note: the implementation of this procedure is very closely tied to the
5010 -- implementation of Get_Current_Value_Condition. Here we set required
5011 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
5012 -- them, so they must have a consistent view.
5014 procedure Set_Current_Value_Condition
(Cnode
: Node_Id
) is
5016 procedure Set_Entity_Current_Value
(N
: Node_Id
);
5017 -- If N is an entity reference, where the entity is of an appropriate
5018 -- kind, then set the current value of this entity to Cnode, unless
5019 -- there is already a definite value set there.
5021 procedure Set_Expression_Current_Value
(N
: Node_Id
);
5022 -- If N is of an appropriate form, sets an appropriate entry in current
5023 -- value fields of relevant entities. Multiple entities can be affected
5024 -- in the case of an AND or AND THEN.
5026 ------------------------------
5027 -- Set_Entity_Current_Value --
5028 ------------------------------
5030 procedure Set_Entity_Current_Value
(N
: Node_Id
) is
5032 if Is_Entity_Name
(N
) then
5034 Ent
: constant Entity_Id
:= Entity
(N
);
5037 -- Don't capture if not safe to do so
5039 if not Safe_To_Capture_Value
(N
, Ent
, Cond
=> True) then
5043 -- Here we have a case where the Current_Value field may
5044 -- need to be set. We set it if it is not already set to a
5045 -- compile time expression value.
5047 -- Note that this represents a decision that one condition
5048 -- blots out another previous one. That's certainly right
5049 -- if they occur at the same level. If the second one is
5050 -- nested, then the decision is neither right nor wrong (it
5051 -- would be equally OK to leave the outer one in place, or
5052 -- take the new inner one. Really we should record both, but
5053 -- our data structures are not that elaborate.
5055 if Nkind
(Current_Value
(Ent
)) not in N_Subexpr
then
5056 Set_Current_Value
(Ent
, Cnode
);
5060 end Set_Entity_Current_Value
;
5062 ----------------------------------
5063 -- Set_Expression_Current_Value --
5064 ----------------------------------
5066 procedure Set_Expression_Current_Value
(N
: Node_Id
) is
5072 -- Loop to deal with (ignore for now) any NOT operators present. The
5073 -- presence of NOT operators will be handled properly when we call
5074 -- Get_Current_Value_Condition.
5076 while Nkind
(Cond
) = N_Op_Not
loop
5077 Cond
:= Right_Opnd
(Cond
);
5080 -- For an AND or AND THEN, recursively process operands
5082 if Nkind
(Cond
) = N_Op_And
or else Nkind
(Cond
) = N_And_Then
then
5083 Set_Expression_Current_Value
(Left_Opnd
(Cond
));
5084 Set_Expression_Current_Value
(Right_Opnd
(Cond
));
5088 -- Check possible relational operator
5090 if Nkind
(Cond
) in N_Op_Compare
then
5091 if Compile_Time_Known_Value
(Right_Opnd
(Cond
)) then
5092 Set_Entity_Current_Value
(Left_Opnd
(Cond
));
5093 elsif Compile_Time_Known_Value
(Left_Opnd
(Cond
)) then
5094 Set_Entity_Current_Value
(Right_Opnd
(Cond
));
5097 -- Check possible boolean variable reference
5100 Set_Entity_Current_Value
(Cond
);
5102 end Set_Expression_Current_Value
;
5104 -- Start of processing for Set_Current_Value_Condition
5107 Set_Expression_Current_Value
(Condition
(Cnode
));
5108 end Set_Current_Value_Condition
;
5110 --------------------------
5111 -- Set_Elaboration_Flag --
5112 --------------------------
5114 procedure Set_Elaboration_Flag
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
5115 Loc
: constant Source_Ptr
:= Sloc
(N
);
5116 Ent
: constant Entity_Id
:= Elaboration_Entity
(Spec_Id
);
5120 if Present
(Ent
) then
5122 -- Nothing to do if at the compilation unit level, because in this
5123 -- case the flag is set by the binder generated elaboration routine.
5125 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5128 -- Here we do need to generate an assignment statement
5131 Check_Restriction
(No_Elaboration_Code
, N
);
5133 Make_Assignment_Statement
(Loc
,
5134 Name
=> New_Occurrence_Of
(Ent
, Loc
),
5135 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
));
5137 if Nkind
(Parent
(N
)) = N_Subunit
then
5138 Insert_After
(Corresponding_Stub
(Parent
(N
)), Asn
);
5140 Insert_After
(N
, Asn
);
5145 -- Kill current value indication. This is necessary because
5146 -- the tests of this flag are inserted out of sequence and must
5147 -- not pick up bogus indications of the wrong constant value.
5149 Set_Current_Value
(Ent
, Empty
);
5152 end Set_Elaboration_Flag
;
5154 ----------------------------
5155 -- Set_Renamed_Subprogram --
5156 ----------------------------
5158 procedure Set_Renamed_Subprogram
(N
: Node_Id
; E
: Entity_Id
) is
5160 -- If input node is an identifier, we can just reset it
5162 if Nkind
(N
) = N_Identifier
then
5163 Set_Chars
(N
, Chars
(E
));
5166 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
5170 CS
: constant Boolean := Comes_From_Source
(N
);
5172 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Chars
(E
)));
5174 Set_Comes_From_Source
(N
, CS
);
5175 Set_Analyzed
(N
, True);
5178 end Set_Renamed_Subprogram
;
5180 --------------------------
5181 -- Target_Has_Fixed_Ops --
5182 --------------------------
5184 Integer_Sized_Small
: Ureal
;
5185 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this
5186 -- function is called (we don't want to compute it more than once!)
5188 Long_Integer_Sized_Small
: Ureal
;
5189 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
5190 -- functoin is called (we don't want to compute it more than once)
5192 First_Time_For_THFO
: Boolean := True;
5193 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
5195 function Target_Has_Fixed_Ops
5196 (Left_Typ
: Entity_Id
;
5197 Right_Typ
: Entity_Id
;
5198 Result_Typ
: Entity_Id
) return Boolean
5200 function Is_Fractional_Type
(Typ
: Entity_Id
) return Boolean;
5201 -- Return True if the given type is a fixed-point type with a small
5202 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
5203 -- an absolute value less than 1.0. This is currently limited
5204 -- to fixed-point types that map to Integer or Long_Integer.
5206 ------------------------
5207 -- Is_Fractional_Type --
5208 ------------------------
5210 function Is_Fractional_Type
(Typ
: Entity_Id
) return Boolean is
5212 if Esize
(Typ
) = Standard_Integer_Size
then
5213 return Small_Value
(Typ
) = Integer_Sized_Small
;
5215 elsif Esize
(Typ
) = Standard_Long_Integer_Size
then
5216 return Small_Value
(Typ
) = Long_Integer_Sized_Small
;
5221 end Is_Fractional_Type
;
5223 -- Start of processing for Target_Has_Fixed_Ops
5226 -- Return False if Fractional_Fixed_Ops_On_Target is false
5228 if not Fractional_Fixed_Ops_On_Target
then
5232 -- Here the target has Fractional_Fixed_Ops, if first time, compute
5233 -- standard constants used by Is_Fractional_Type.
5235 if First_Time_For_THFO
then
5236 First_Time_For_THFO
:= False;
5238 Integer_Sized_Small
:=
5241 Den
=> UI_From_Int
(Standard_Integer_Size
- 1),
5244 Long_Integer_Sized_Small
:=
5247 Den
=> UI_From_Int
(Standard_Long_Integer_Size
- 1),
5251 -- Return True if target supports fixed-by-fixed multiply/divide
5252 -- for fractional fixed-point types (see Is_Fractional_Type) and
5253 -- the operand and result types are equivalent fractional types.
5255 return Is_Fractional_Type
(Base_Type
(Left_Typ
))
5256 and then Is_Fractional_Type
(Base_Type
(Right_Typ
))
5257 and then Is_Fractional_Type
(Base_Type
(Result_Typ
))
5258 and then Esize
(Left_Typ
) = Esize
(Right_Typ
)
5259 and then Esize
(Left_Typ
) = Esize
(Result_Typ
);
5260 end Target_Has_Fixed_Ops
;
5262 ------------------------------------------
5263 -- Type_May_Have_Bit_Aligned_Components --
5264 ------------------------------------------
5266 function Type_May_Have_Bit_Aligned_Components
5267 (Typ
: Entity_Id
) return Boolean
5270 -- Array type, check component type
5272 if Is_Array_Type
(Typ
) then
5274 Type_May_Have_Bit_Aligned_Components
(Component_Type
(Typ
));
5276 -- Record type, check components
5278 elsif Is_Record_Type
(Typ
) then
5283 E
:= First_Component_Or_Discriminant
(Typ
);
5284 while Present
(E
) loop
5285 if Component_May_Be_Bit_Aligned
(E
)
5286 or else Type_May_Have_Bit_Aligned_Components
(Etype
(E
))
5291 Next_Component_Or_Discriminant
(E
);
5297 -- Type other than array or record is always OK
5302 end Type_May_Have_Bit_Aligned_Components
;
5304 ----------------------------
5305 -- Wrap_Cleanup_Procedure --
5306 ----------------------------
5308 procedure Wrap_Cleanup_Procedure
(N
: Node_Id
) is
5309 Loc
: constant Source_Ptr
:= Sloc
(N
);
5310 Stseq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
5311 Stmts
: constant List_Id
:= Statements
(Stseq
);
5314 if Abort_Allowed
then
5315 Prepend_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5316 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5318 end Wrap_Cleanup_Procedure
;