1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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 back end
912 -- never bit-misaligns by default, even if there is a pragma Packed for
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 know we have the
937 -- 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 -- Corresponding_Runtime_Package --
953 -----------------------------------
955 function Corresponding_Runtime_Package
(Typ
: Entity_Id
) return RTU_Id
is
956 Pkg_Id
: RTU_Id
:= RTU_Null
;
959 pragma Assert
(Is_Concurrent_Type
(Typ
));
961 if Ekind
(Typ
) in Protected_Kind
then
963 or else Has_Interrupt_Handler
(Typ
)
964 or else (Has_Attach_Handler
(Typ
)
965 and then not Restricted_Profile
)
967 -- A protected type without entries that covers an interface and
968 -- overrides the abstract routines with protected procedures is
969 -- considered equivalent to a protected type with entries in the
970 -- context of dispatching select statements. It is sufficient to
971 -- check for the presence of an interface list in the declaration
972 -- node to recognize this case.
974 or else Present
(Interface_List
(Parent
(Typ
)))
977 or else Restriction_Active
(No_Entry_Queue
) = False
978 or else Number_Entries
(Typ
) > 1
979 or else (Has_Attach_Handler
(Typ
)
980 and then not Restricted_Profile
)
982 Pkg_Id
:= System_Tasking_Protected_Objects_Entries
;
984 Pkg_Id
:= System_Tasking_Protected_Objects_Single_Entry
;
988 Pkg_Id
:= System_Tasking_Protected_Objects
;
993 end Corresponding_Runtime_Package
;
995 -------------------------------
996 -- Convert_To_Actual_Subtype --
997 -------------------------------
999 procedure Convert_To_Actual_Subtype
(Exp
: Entity_Id
) is
1003 Act_ST
:= Get_Actual_Subtype
(Exp
);
1005 if Act_ST
= Etype
(Exp
) then
1010 Convert_To
(Act_ST
, Relocate_Node
(Exp
)));
1011 Analyze_And_Resolve
(Exp
, Act_ST
);
1013 end Convert_To_Actual_Subtype
;
1015 -----------------------------------
1016 -- Current_Sem_Unit_Declarations --
1017 -----------------------------------
1019 function Current_Sem_Unit_Declarations
return List_Id
is
1020 U
: Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
1024 -- If the current unit is a package body, locate the visible
1025 -- declarations of the package spec.
1027 if Nkind
(U
) = N_Package_Body
then
1028 U
:= Unit
(Library_Unit
(Cunit
(Current_Sem_Unit
)));
1031 if Nkind
(U
) = N_Package_Declaration
then
1032 U
:= Specification
(U
);
1033 Decls
:= Visible_Declarations
(U
);
1037 Set_Visible_Declarations
(U
, Decls
);
1041 Decls
:= Declarations
(U
);
1045 Set_Declarations
(U
, Decls
);
1050 end Current_Sem_Unit_Declarations
;
1052 -----------------------
1053 -- Duplicate_Subexpr --
1054 -----------------------
1056 function Duplicate_Subexpr
1058 Name_Req
: Boolean := False) return Node_Id
1061 Remove_Side_Effects
(Exp
, Name_Req
);
1062 return New_Copy_Tree
(Exp
);
1063 end Duplicate_Subexpr
;
1065 ---------------------------------
1066 -- Duplicate_Subexpr_No_Checks --
1067 ---------------------------------
1069 function Duplicate_Subexpr_No_Checks
1071 Name_Req
: Boolean := False) return Node_Id
1076 Remove_Side_Effects
(Exp
, Name_Req
);
1077 New_Exp
:= New_Copy_Tree
(Exp
);
1078 Remove_Checks
(New_Exp
);
1080 end Duplicate_Subexpr_No_Checks
;
1082 -----------------------------------
1083 -- Duplicate_Subexpr_Move_Checks --
1084 -----------------------------------
1086 function Duplicate_Subexpr_Move_Checks
1088 Name_Req
: Boolean := False) return Node_Id
1093 Remove_Side_Effects
(Exp
, Name_Req
);
1094 New_Exp
:= New_Copy_Tree
(Exp
);
1095 Remove_Checks
(Exp
);
1097 end Duplicate_Subexpr_Move_Checks
;
1099 --------------------
1100 -- Ensure_Defined --
1101 --------------------
1103 procedure Ensure_Defined
(Typ
: Entity_Id
; N
: Node_Id
) is
1107 -- An itype reference must only be created if this is a local
1108 -- itype, so that gigi can elaborate it on the proper objstack.
1111 and then Scope
(Typ
) = Current_Scope
1113 IR
:= Make_Itype_Reference
(Sloc
(N
));
1114 Set_Itype
(IR
, Typ
);
1115 Insert_Action
(N
, IR
);
1119 --------------------
1120 -- Entry_Names_OK --
1121 --------------------
1123 function Entry_Names_OK
return Boolean is
1126 not Restricted_Profile
1127 and then not Global_Discard_Names
1128 and then not Restriction_Active
(No_Implicit_Heap_Allocations
)
1129 and then not Restriction_Active
(No_Local_Allocators
);
1132 ---------------------
1133 -- Evolve_And_Then --
1134 ---------------------
1136 procedure Evolve_And_Then
(Cond
: in out Node_Id
; Cond1
: Node_Id
) is
1142 Make_And_Then
(Sloc
(Cond1
),
1144 Right_Opnd
=> Cond1
);
1146 end Evolve_And_Then
;
1148 --------------------
1149 -- Evolve_Or_Else --
1150 --------------------
1152 procedure Evolve_Or_Else
(Cond
: in out Node_Id
; Cond1
: Node_Id
) is
1158 Make_Or_Else
(Sloc
(Cond1
),
1160 Right_Opnd
=> Cond1
);
1164 ------------------------------
1165 -- Expand_Subtype_From_Expr --
1166 ------------------------------
1168 -- This function is applicable for both static and dynamic allocation of
1169 -- objects which are constrained by an initial expression. Basically it
1170 -- transforms an unconstrained subtype indication into a constrained one.
1171 -- The expression may also be transformed in certain cases in order to
1172 -- avoid multiple evaluation. In the static allocation case, the general
1177 -- is transformed into
1179 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1181 -- Here are the main cases :
1183 -- <if Expr is a Slice>
1184 -- Val : T ([Index_Subtype (Expr)]) := Expr;
1186 -- <elsif Expr is a String Literal>
1187 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1189 -- <elsif Expr is Constrained>
1190 -- subtype T is Type_Of_Expr
1193 -- <elsif Expr is an entity_name>
1194 -- Val : T (constraints taken from Expr) := Expr;
1197 -- type Axxx is access all T;
1198 -- Rval : Axxx := Expr'ref;
1199 -- Val : T (constraints taken from Rval) := Rval.all;
1201 -- ??? note: when the Expression is allocated in the secondary stack
1202 -- we could use it directly instead of copying it by declaring
1203 -- Val : T (...) renames Rval.all
1205 procedure Expand_Subtype_From_Expr
1207 Unc_Type
: Entity_Id
;
1208 Subtype_Indic
: Node_Id
;
1211 Loc
: constant Source_Ptr
:= Sloc
(N
);
1212 Exp_Typ
: constant Entity_Id
:= Etype
(Exp
);
1216 -- In general we cannot build the subtype if expansion is disabled,
1217 -- because internal entities may not have been defined. However, to
1218 -- avoid some cascaded errors, we try to continue when the expression
1219 -- is an array (or string), because it is safe to compute the bounds.
1220 -- It is in fact required to do so even in a generic context, because
1221 -- there may be constants that depend on bounds of string literal.
1223 if not Expander_Active
1224 and then (No
(Etype
(Exp
))
1225 or else Base_Type
(Etype
(Exp
)) /= Standard_String
)
1230 if Nkind
(Exp
) = N_Slice
then
1232 Slice_Type
: constant Entity_Id
:= Etype
(First_Index
(Exp_Typ
));
1235 Rewrite
(Subtype_Indic
,
1236 Make_Subtype_Indication
(Loc
,
1237 Subtype_Mark
=> New_Reference_To
(Unc_Type
, Loc
),
1239 Make_Index_Or_Discriminant_Constraint
(Loc
,
1240 Constraints
=> New_List
1241 (New_Reference_To
(Slice_Type
, Loc
)))));
1243 -- This subtype indication may be used later for constraint checks
1244 -- we better make sure that if a variable was used as a bound of
1245 -- of the original slice, its value is frozen.
1247 Force_Evaluation
(Low_Bound
(Scalar_Range
(Slice_Type
)));
1248 Force_Evaluation
(High_Bound
(Scalar_Range
(Slice_Type
)));
1251 elsif Ekind
(Exp_Typ
) = E_String_Literal_Subtype
then
1252 Rewrite
(Subtype_Indic
,
1253 Make_Subtype_Indication
(Loc
,
1254 Subtype_Mark
=> New_Reference_To
(Unc_Type
, Loc
),
1256 Make_Index_Or_Discriminant_Constraint
(Loc
,
1257 Constraints
=> New_List
(
1258 Make_Literal_Range
(Loc
,
1259 Literal_Typ
=> Exp_Typ
)))));
1261 elsif Is_Constrained
(Exp_Typ
)
1262 and then not Is_Class_Wide_Type
(Unc_Type
)
1264 if Is_Itype
(Exp_Typ
) then
1266 -- Within an initialization procedure, a selected component
1267 -- denotes a component of the enclosing record, and it appears
1268 -- as an actual in a call to its own initialization procedure.
1269 -- If this component depends on the outer discriminant, we must
1270 -- generate the proper actual subtype for it.
1272 if Nkind
(Exp
) = N_Selected_Component
1273 and then Within_Init_Proc
1276 Decl
: constant Node_Id
:=
1277 Build_Actual_Subtype_Of_Component
(Exp_Typ
, Exp
);
1279 if Present
(Decl
) then
1280 Insert_Action
(N
, Decl
);
1281 T
:= Defining_Identifier
(Decl
);
1287 -- No need to generate a new one (new what???)
1295 Make_Defining_Identifier
(Loc
,
1296 Chars
=> New_Internal_Name
('T'));
1299 Make_Subtype_Declaration
(Loc
,
1300 Defining_Identifier
=> T
,
1301 Subtype_Indication
=> New_Reference_To
(Exp_Typ
, Loc
)));
1303 -- This type is marked as an itype even though it has an
1304 -- explicit declaration because otherwise it can be marked
1305 -- with Is_Generic_Actual_Type and generate spurious errors.
1306 -- (see sem_ch8.Analyze_Package_Renaming and sem_type.covers)
1309 Set_Associated_Node_For_Itype
(T
, Exp
);
1312 Rewrite
(Subtype_Indic
, New_Reference_To
(T
, Loc
));
1314 -- nothing needs to be done for private types with unknown discriminants
1315 -- if the underlying type is not an unconstrained composite type.
1317 elsif Is_Private_Type
(Unc_Type
)
1318 and then Has_Unknown_Discriminants
(Unc_Type
)
1319 and then (not Is_Composite_Type
(Underlying_Type
(Unc_Type
))
1320 or else Is_Constrained
(Underlying_Type
(Unc_Type
)))
1324 -- Nothing to be done for derived types with unknown discriminants if
1325 -- the parent type also has unknown discriminants.
1327 elsif Is_Record_Type
(Unc_Type
)
1328 and then not Is_Class_Wide_Type
(Unc_Type
)
1329 and then Has_Unknown_Discriminants
(Unc_Type
)
1330 and then Has_Unknown_Discriminants
(Underlying_Type
(Unc_Type
))
1334 -- In Ada95, Nothing to be done if the type of the expression is
1335 -- limited, because in this case the expression cannot be copied,
1336 -- and its use can only be by reference.
1338 -- In Ada2005, the context can be an object declaration whose expression
1339 -- is a function that returns in place. If the nominal subtype has
1340 -- unknown discriminants, the call still provides constraints on the
1341 -- object, and we have to create an actual subtype from it.
1343 -- If the type is class-wide, the expression is dynamically tagged and
1344 -- we do not create an actual subtype either. Ditto for an interface.
1346 elsif Is_Limited_Type
(Exp_Typ
)
1348 (Is_Class_Wide_Type
(Exp_Typ
)
1349 or else Is_Interface
(Exp_Typ
)
1350 or else not Has_Unknown_Discriminants
(Exp_Typ
)
1351 or else not Is_Composite_Type
(Unc_Type
))
1355 -- For limited interfaces, nothing to be done
1357 -- This branch may be redundant once the limited interface issue is
1360 elsif Is_Interface
(Exp_Typ
)
1361 and then Is_Limited_Interface
(Exp_Typ
)
1365 -- For limited objects initialized with build in place function calls,
1366 -- nothing to be done; otherwise we prematurely introduce an N_Reference
1367 -- node in the expression initializing the object, which breaks the
1368 -- circuitry that detects and adds the additional arguments to the
1371 elsif Is_Build_In_Place_Function_Call
(Exp
) then
1375 Remove_Side_Effects
(Exp
);
1376 Rewrite
(Subtype_Indic
,
1377 Make_Subtype_From_Expr
(Exp
, Unc_Type
));
1379 end Expand_Subtype_From_Expr
;
1381 ------------------------
1382 -- Find_Interface_ADT --
1383 ------------------------
1385 function Find_Interface_ADT
1387 Iface
: Entity_Id
) return Elmt_Id
1390 Typ
: Entity_Id
:= T
;
1393 pragma Assert
(Is_Interface
(Iface
));
1395 -- Handle private types
1397 if Has_Private_Declaration
(Typ
)
1398 and then Present
(Full_View
(Typ
))
1400 Typ
:= Full_View
(Typ
);
1403 -- Handle access types
1405 if Is_Access_Type
(Typ
) then
1406 Typ
:= Directly_Designated_Type
(Typ
);
1409 -- Handle task and protected types implementing interfaces
1411 if Is_Concurrent_Type
(Typ
) then
1412 Typ
:= Corresponding_Record_Type
(Typ
);
1416 (not Is_Class_Wide_Type
(Typ
)
1417 and then Ekind
(Typ
) /= E_Incomplete_Type
);
1419 if Is_Ancestor
(Iface
, Typ
) then
1420 return First_Elmt
(Access_Disp_Table
(Typ
));
1424 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
1426 and then Present
(Related_Type
(Node
(ADT
)))
1427 and then Related_Type
(Node
(ADT
)) /= Iface
1428 and then not Is_Ancestor
(Iface
, Related_Type
(Node
(ADT
)))
1433 pragma Assert
(Present
(Related_Type
(Node
(ADT
))));
1436 end Find_Interface_ADT
;
1438 ------------------------
1439 -- Find_Interface_Tag --
1440 ------------------------
1442 function Find_Interface_Tag
1444 Iface
: Entity_Id
) return Entity_Id
1447 Found
: Boolean := False;
1448 Typ
: Entity_Id
:= T
;
1450 procedure Find_Tag
(Typ
: Entity_Id
);
1451 -- Internal subprogram used to recursively climb to the ancestors
1457 procedure Find_Tag
(Typ
: Entity_Id
) is
1462 -- Check if the interface is an immediate ancestor of the type and
1463 -- therefore shares the main tag.
1466 pragma Assert
(Etype
(First_Tag_Component
(Typ
)) = RTE
(RE_Tag
));
1467 AI_Tag
:= First_Tag_Component
(Typ
);
1472 -- Climb to the root type handling private types
1474 if Present
(Full_View
(Etype
(Typ
))) then
1475 if Full_View
(Etype
(Typ
)) /= Typ
then
1476 Find_Tag
(Full_View
(Etype
(Typ
)));
1479 elsif Etype
(Typ
) /= Typ
then
1480 Find_Tag
(Etype
(Typ
));
1483 -- Traverse the list of interfaces implemented by the type
1486 and then Present
(Interfaces
(Typ
))
1487 and then not (Is_Empty_Elmt_List
(Interfaces
(Typ
)))
1489 -- Skip the tag associated with the primary table
1491 pragma Assert
(Etype
(First_Tag_Component
(Typ
)) = RTE
(RE_Tag
));
1492 AI_Tag
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
1493 pragma Assert
(Present
(AI_Tag
));
1495 AI_Elmt
:= First_Elmt
(Interfaces
(Typ
));
1496 while Present
(AI_Elmt
) loop
1497 AI
:= Node
(AI_Elmt
);
1499 if AI
= Iface
or else Is_Ancestor
(Iface
, AI
) then
1504 AI_Tag
:= Next_Tag_Component
(AI_Tag
);
1505 Next_Elmt
(AI_Elmt
);
1510 -- Start of processing for Find_Interface_Tag
1513 pragma Assert
(Is_Interface
(Iface
));
1515 -- Handle private types
1517 if Has_Private_Declaration
(Typ
)
1518 and then Present
(Full_View
(Typ
))
1520 Typ
:= Full_View
(Typ
);
1523 -- Handle access types
1525 if Is_Access_Type
(Typ
) then
1526 Typ
:= Directly_Designated_Type
(Typ
);
1529 -- Handle task and protected types implementing interfaces
1531 if Is_Concurrent_Type
(Typ
) then
1532 Typ
:= Corresponding_Record_Type
(Typ
);
1535 if Is_Class_Wide_Type
(Typ
) then
1539 -- Handle entities from the limited view
1541 if Ekind
(Typ
) = E_Incomplete_Type
then
1542 pragma Assert
(Present
(Non_Limited_View
(Typ
)));
1543 Typ
:= Non_Limited_View
(Typ
);
1547 pragma Assert
(Found
);
1549 end Find_Interface_Tag
;
1555 function Find_Prim_Op
(T
: Entity_Id
; Name
: Name_Id
) return Entity_Id
is
1557 Typ
: Entity_Id
:= T
;
1561 if Is_Class_Wide_Type
(Typ
) then
1562 Typ
:= Root_Type
(Typ
);
1565 Typ
:= Underlying_Type
(Typ
);
1567 -- Loop through primitive operations
1569 Prim
:= First_Elmt
(Primitive_Operations
(Typ
));
1570 while Present
(Prim
) loop
1573 -- We can retrieve primitive operations by name if it is an internal
1574 -- name. For equality we must check that both of its operands have
1575 -- the same type, to avoid confusion with user-defined equalities
1576 -- than may have a non-symmetric signature.
1578 exit when Chars
(Op
) = Name
1581 or else Etype
(First_Entity
(Op
)) = Etype
(Last_Entity
(Op
)));
1585 -- Raise Program_Error if no primitive found
1588 raise Program_Error
;
1599 function Find_Prim_Op
1601 Name
: TSS_Name_Type
) return Entity_Id
1604 Typ
: Entity_Id
:= T
;
1607 if Is_Class_Wide_Type
(Typ
) then
1608 Typ
:= Root_Type
(Typ
);
1611 Typ
:= Underlying_Type
(Typ
);
1613 Prim
:= First_Elmt
(Primitive_Operations
(Typ
));
1614 while not Is_TSS
(Node
(Prim
), Name
) loop
1617 -- Raise program error if no primitive found
1620 raise Program_Error
;
1627 ----------------------------
1628 -- Find_Protection_Object --
1629 ----------------------------
1631 function Find_Protection_Object
(Scop
: Entity_Id
) return Entity_Id
is
1636 while Present
(S
) loop
1637 if (Ekind
(S
) = E_Entry
1638 or else Ekind
(S
) = E_Entry_Family
1639 or else Ekind
(S
) = E_Function
1640 or else Ekind
(S
) = E_Procedure
)
1641 and then Present
(Protection_Object
(S
))
1643 return Protection_Object
(S
);
1649 -- If we do not find a Protection object in the scope chain, then
1650 -- something has gone wrong, most likely the object was never created.
1652 raise Program_Error
;
1653 end Find_Protection_Object
;
1655 ----------------------
1656 -- Force_Evaluation --
1657 ----------------------
1659 procedure Force_Evaluation
(Exp
: Node_Id
; Name_Req
: Boolean := False) is
1661 Remove_Side_Effects
(Exp
, Name_Req
, Variable_Ref
=> True);
1662 end Force_Evaluation
;
1664 ------------------------
1665 -- Generate_Poll_Call --
1666 ------------------------
1668 procedure Generate_Poll_Call
(N
: Node_Id
) is
1670 -- No poll call if polling not active
1672 if not Polling_Required
then
1675 -- Otherwise generate require poll call
1678 Insert_Before_And_Analyze
(N
,
1679 Make_Procedure_Call_Statement
(Sloc
(N
),
1680 Name
=> New_Occurrence_Of
(RTE
(RE_Poll
), Sloc
(N
))));
1682 end Generate_Poll_Call
;
1684 ---------------------------------
1685 -- Get_Current_Value_Condition --
1686 ---------------------------------
1688 -- Note: the implementation of this procedure is very closely tied to the
1689 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
1690 -- interpret Current_Value fields set by the Set procedure, so the two
1691 -- procedures need to be closely coordinated.
1693 procedure Get_Current_Value_Condition
1698 Loc
: constant Source_Ptr
:= Sloc
(Var
);
1699 Ent
: constant Entity_Id
:= Entity
(Var
);
1701 procedure Process_Current_Value_Condition
1704 -- N is an expression which holds either True (S = True) or False (S =
1705 -- False) in the condition. This procedure digs out the expression and
1706 -- if it refers to Ent, sets Op and Val appropriately.
1708 -------------------------------------
1709 -- Process_Current_Value_Condition --
1710 -------------------------------------
1712 procedure Process_Current_Value_Condition
1723 -- Deal with NOT operators, inverting sense
1725 while Nkind
(Cond
) = N_Op_Not
loop
1726 Cond
:= Right_Opnd
(Cond
);
1730 -- Deal with AND THEN and AND cases
1732 if Nkind
(Cond
) = N_And_Then
1733 or else Nkind
(Cond
) = N_Op_And
1735 -- Don't ever try to invert a condition that is of the form
1736 -- of an AND or AND THEN (since we are not doing sufficiently
1737 -- general processing to allow this).
1739 if Sens
= False then
1745 -- Recursively process AND and AND THEN branches
1747 Process_Current_Value_Condition
(Left_Opnd
(Cond
), True);
1749 if Op
/= N_Empty
then
1753 Process_Current_Value_Condition
(Right_Opnd
(Cond
), True);
1756 -- Case of relational operator
1758 elsif Nkind
(Cond
) in N_Op_Compare
then
1761 -- Invert sense of test if inverted test
1763 if Sens
= False then
1765 when N_Op_Eq
=> Op
:= N_Op_Ne
;
1766 when N_Op_Ne
=> Op
:= N_Op_Eq
;
1767 when N_Op_Lt
=> Op
:= N_Op_Ge
;
1768 when N_Op_Gt
=> Op
:= N_Op_Le
;
1769 when N_Op_Le
=> Op
:= N_Op_Gt
;
1770 when N_Op_Ge
=> Op
:= N_Op_Lt
;
1771 when others => raise Program_Error
;
1775 -- Case of entity op value
1777 if Is_Entity_Name
(Left_Opnd
(Cond
))
1778 and then Ent
= Entity
(Left_Opnd
(Cond
))
1779 and then Compile_Time_Known_Value
(Right_Opnd
(Cond
))
1781 Val
:= Right_Opnd
(Cond
);
1783 -- Case of value op entity
1785 elsif Is_Entity_Name
(Right_Opnd
(Cond
))
1786 and then Ent
= Entity
(Right_Opnd
(Cond
))
1787 and then Compile_Time_Known_Value
(Left_Opnd
(Cond
))
1789 Val
:= Left_Opnd
(Cond
);
1791 -- We are effectively swapping operands
1794 when N_Op_Eq
=> null;
1795 when N_Op_Ne
=> null;
1796 when N_Op_Lt
=> Op
:= N_Op_Gt
;
1797 when N_Op_Gt
=> Op
:= N_Op_Lt
;
1798 when N_Op_Le
=> Op
:= N_Op_Ge
;
1799 when N_Op_Ge
=> Op
:= N_Op_Le
;
1800 when others => raise Program_Error
;
1809 -- Case of Boolean variable reference, return as though the
1810 -- reference had said var = True.
1813 if Is_Entity_Name
(Cond
)
1814 and then Ent
= Entity
(Cond
)
1816 Val
:= New_Occurrence_Of
(Standard_True
, Sloc
(Cond
));
1818 if Sens
= False then
1825 end Process_Current_Value_Condition
;
1827 -- Start of processing for Get_Current_Value_Condition
1833 -- Immediate return, nothing doing, if this is not an object
1835 if Ekind
(Ent
) not in Object_Kind
then
1839 -- Otherwise examine current value
1842 CV
: constant Node_Id
:= Current_Value
(Ent
);
1847 -- If statement. Condition is known true in THEN section, known False
1848 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
1850 if Nkind
(CV
) = N_If_Statement
then
1852 -- Before start of IF statement
1854 if Loc
< Sloc
(CV
) then
1857 -- After end of IF statement
1859 elsif Loc
>= Sloc
(CV
) + Text_Ptr
(UI_To_Int
(End_Span
(CV
))) then
1863 -- At this stage we know that we are within the IF statement, but
1864 -- unfortunately, the tree does not record the SLOC of the ELSE so
1865 -- we cannot use a simple SLOC comparison to distinguish between
1866 -- the then/else statements, so we have to climb the tree.
1873 while Parent
(N
) /= CV
loop
1876 -- If we fall off the top of the tree, then that's odd, but
1877 -- perhaps it could occur in some error situation, and the
1878 -- safest response is simply to assume that the outcome of
1879 -- the condition is unknown. No point in bombing during an
1880 -- attempt to optimize things.
1887 -- Now we have N pointing to a node whose parent is the IF
1888 -- statement in question, so now we can tell if we are within
1889 -- the THEN statements.
1891 if Is_List_Member
(N
)
1892 and then List_Containing
(N
) = Then_Statements
(CV
)
1896 -- If the variable reference does not come from source, we
1897 -- cannot reliably tell whether it appears in the else part.
1898 -- In particular, if it appears in generated code for a node
1899 -- that requires finalization, it may be attached to a list
1900 -- that has not been yet inserted into the code. For now,
1901 -- treat it as unknown.
1903 elsif not Comes_From_Source
(N
) then
1906 -- Otherwise we must be in ELSIF or ELSE part
1913 -- ELSIF part. Condition is known true within the referenced
1914 -- ELSIF, known False in any subsequent ELSIF or ELSE part, and
1915 -- unknown before the ELSE part or after the IF statement.
1917 elsif Nkind
(CV
) = N_Elsif_Part
then
1920 -- Before start of ELSIF part
1922 if Loc
< Sloc
(CV
) then
1925 -- After end of IF statement
1927 elsif Loc
>= Sloc
(Stm
) +
1928 Text_Ptr
(UI_To_Int
(End_Span
(Stm
)))
1933 -- Again we lack the SLOC of the ELSE, so we need to climb the
1934 -- tree to see if we are within the ELSIF part in question.
1941 while Parent
(N
) /= Stm
loop
1944 -- If we fall off the top of the tree, then that's odd, but
1945 -- perhaps it could occur in some error situation, and the
1946 -- safest response is simply to assume that the outcome of
1947 -- the condition is unknown. No point in bombing during an
1948 -- attempt to optimize things.
1955 -- Now we have N pointing to a node whose parent is the IF
1956 -- statement in question, so see if is the ELSIF part we want.
1957 -- the THEN statements.
1962 -- Otherwise we must be in subsequent ELSIF or ELSE part
1969 -- Iteration scheme of while loop. The condition is known to be
1970 -- true within the body of the loop.
1972 elsif Nkind
(CV
) = N_Iteration_Scheme
then
1974 Loop_Stmt
: constant Node_Id
:= Parent
(CV
);
1977 -- Before start of body of loop
1979 if Loc
< Sloc
(Loop_Stmt
) then
1982 -- After end of LOOP statement
1984 elsif Loc
>= Sloc
(End_Label
(Loop_Stmt
)) then
1987 -- We are within the body of the loop
1994 -- All other cases of Current_Value settings
2000 -- If we fall through here, then we have a reportable condition, Sens
2001 -- is True if the condition is true and False if it needs inverting.
2003 Process_Current_Value_Condition
(Condition
(CV
), Sens
);
2005 end Get_Current_Value_Condition
;
2007 ---------------------------------
2008 -- Has_Controlled_Coextensions --
2009 ---------------------------------
2011 function Has_Controlled_Coextensions
(Typ
: Entity_Id
) return Boolean is
2016 -- Only consider record types
2018 if Ekind
(Typ
) /= E_Record_Type
2019 and then Ekind
(Typ
) /= E_Record_Subtype
2024 if Has_Discriminants
(Typ
) then
2025 Discr
:= First_Discriminant
(Typ
);
2026 while Present
(Discr
) loop
2027 D_Typ
:= Etype
(Discr
);
2029 if Ekind
(D_Typ
) = E_Anonymous_Access_Type
2031 (Is_Controlled
(Directly_Designated_Type
(D_Typ
))
2033 Is_Concurrent_Type
(Directly_Designated_Type
(D_Typ
)))
2038 Next_Discriminant
(Discr
);
2043 end Has_Controlled_Coextensions
;
2045 --------------------
2046 -- Homonym_Number --
2047 --------------------
2049 function Homonym_Number
(Subp
: Entity_Id
) return Nat
is
2055 Hom
:= Homonym
(Subp
);
2056 while Present
(Hom
) loop
2057 if Scope
(Hom
) = Scope
(Subp
) then
2061 Hom
:= Homonym
(Hom
);
2067 ------------------------------
2068 -- In_Unconditional_Context --
2069 ------------------------------
2071 function In_Unconditional_Context
(Node
: Node_Id
) return Boolean is
2076 while Present
(P
) loop
2078 when N_Subprogram_Body
=>
2081 when N_If_Statement
=>
2084 when N_Loop_Statement
=>
2087 when N_Case_Statement
=>
2096 end In_Unconditional_Context
;
2102 procedure Insert_Action
(Assoc_Node
: Node_Id
; Ins_Action
: Node_Id
) is
2104 if Present
(Ins_Action
) then
2105 Insert_Actions
(Assoc_Node
, New_List
(Ins_Action
));
2109 -- Version with check(s) suppressed
2111 procedure Insert_Action
2112 (Assoc_Node
: Node_Id
; Ins_Action
: Node_Id
; Suppress
: Check_Id
)
2115 Insert_Actions
(Assoc_Node
, New_List
(Ins_Action
), Suppress
);
2118 --------------------
2119 -- Insert_Actions --
2120 --------------------
2122 procedure Insert_Actions
(Assoc_Node
: Node_Id
; Ins_Actions
: List_Id
) is
2126 Wrapped_Node
: Node_Id
:= Empty
;
2129 if No
(Ins_Actions
) or else Is_Empty_List
(Ins_Actions
) then
2133 -- Ignore insert of actions from inside default expression (or other
2134 -- similar "spec expression") in the special spec-expression analyze
2135 -- mode. Any insertions at this point have no relevance, since we are
2136 -- only doing the analyze to freeze the types of any static expressions.
2137 -- See section "Handling of Default Expressions" in the spec of package
2138 -- Sem for further details.
2140 if In_Spec_Expression
then
2144 -- If the action derives from stuff inside a record, then the actions
2145 -- are attached to the current scope, to be inserted and analyzed on
2146 -- exit from the scope. The reason for this is that we may also
2147 -- be generating freeze actions at the same time, and they must
2148 -- eventually be elaborated in the correct order.
2150 if Is_Record_Type
(Current_Scope
)
2151 and then not Is_Frozen
(Current_Scope
)
2153 if No
(Scope_Stack
.Table
2154 (Scope_Stack
.Last
).Pending_Freeze_Actions
)
2156 Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
:=
2161 Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
);
2167 -- We now intend to climb up the tree to find the right point to
2168 -- insert the actions. We start at Assoc_Node, unless this node is
2169 -- a subexpression in which case we start with its parent. We do this
2170 -- for two reasons. First it speeds things up. Second, if Assoc_Node
2171 -- is itself one of the special nodes like N_And_Then, then we assume
2172 -- that an initial request to insert actions for such a node does not
2173 -- expect the actions to get deposited in the node for later handling
2174 -- when the node is expanded, since clearly the node is being dealt
2175 -- with by the caller. Note that in the subexpression case, N is
2176 -- always the child we came from.
2178 -- N_Raise_xxx_Error is an annoying special case, it is a statement
2179 -- if it has type Standard_Void_Type, and a subexpression otherwise.
2180 -- otherwise. Procedure attribute references are also statements.
2182 if Nkind
(Assoc_Node
) in N_Subexpr
2183 and then (Nkind
(Assoc_Node
) in N_Raise_xxx_Error
2184 or else Etype
(Assoc_Node
) /= Standard_Void_Type
)
2185 and then (Nkind
(Assoc_Node
) /= N_Attribute_Reference
2187 not Is_Procedure_Attribute_Name
2188 (Attribute_Name
(Assoc_Node
)))
2190 P
:= Assoc_Node
; -- ??? does not agree with above!
2191 N
:= Parent
(Assoc_Node
);
2193 -- Non-subexpression case. Note that N is initially Empty in this
2194 -- case (N is only guaranteed Non-Empty in the subexpr case).
2201 -- Capture root of the transient scope
2203 if Scope_Is_Transient
then
2204 Wrapped_Node
:= Node_To_Be_Wrapped
;
2208 pragma Assert
(Present
(P
));
2212 -- Case of right operand of AND THEN or OR ELSE. Put the actions
2213 -- in the Actions field of the right operand. They will be moved
2214 -- out further when the AND THEN or OR ELSE operator is expanded.
2215 -- Nothing special needs to be done for the left operand since
2216 -- in that case the actions are executed unconditionally.
2218 when N_And_Then | N_Or_Else
=>
2219 if N
= Right_Opnd
(P
) then
2221 -- We are now going to either append the actions to the
2222 -- actions field of the short-circuit operation. We will
2223 -- also analyze the actions now.
2225 -- This analysis is really too early, the proper thing would
2226 -- be to just park them there now, and only analyze them if
2227 -- we find we really need them, and to it at the proper
2228 -- final insertion point. However attempting to this proved
2229 -- tricky, so for now we just kill current values before and
2230 -- after the analyze call to make sure we avoid peculiar
2231 -- optimizations from this out of order insertion.
2233 Kill_Current_Values
;
2235 if Present
(Actions
(P
)) then
2236 Insert_List_After_And_Analyze
2237 (Last
(Actions
(P
)), Ins_Actions
);
2239 Set_Actions
(P
, Ins_Actions
);
2240 Analyze_List
(Actions
(P
));
2243 Kill_Current_Values
;
2248 -- Then or Else operand of conditional expression. Add actions to
2249 -- Then_Actions or Else_Actions field as appropriate. The actions
2250 -- will be moved further out when the conditional is expanded.
2252 when N_Conditional_Expression
=>
2254 ThenX
: constant Node_Id
:= Next
(First
(Expressions
(P
)));
2255 ElseX
: constant Node_Id
:= Next
(ThenX
);
2258 -- Actions belong to the then expression, temporarily
2259 -- place them as Then_Actions of the conditional expr.
2260 -- They will be moved to the proper place later when
2261 -- the conditional expression is expanded.
2264 if Present
(Then_Actions
(P
)) then
2265 Insert_List_After_And_Analyze
2266 (Last
(Then_Actions
(P
)), Ins_Actions
);
2268 Set_Then_Actions
(P
, Ins_Actions
);
2269 Analyze_List
(Then_Actions
(P
));
2274 -- Actions belong to the else expression, temporarily
2275 -- place them as Else_Actions of the conditional expr.
2276 -- They will be moved to the proper place later when
2277 -- the conditional expression is expanded.
2279 elsif N
= ElseX
then
2280 if Present
(Else_Actions
(P
)) then
2281 Insert_List_After_And_Analyze
2282 (Last
(Else_Actions
(P
)), Ins_Actions
);
2284 Set_Else_Actions
(P
, Ins_Actions
);
2285 Analyze_List
(Else_Actions
(P
));
2290 -- Actions belong to the condition. In this case they are
2291 -- unconditionally executed, and so we can continue the
2292 -- search for the proper insert point.
2299 -- Case of appearing in the condition of a while expression or
2300 -- elsif. We insert the actions into the Condition_Actions field.
2301 -- They will be moved further out when the while loop or elsif
2304 when N_Iteration_Scheme |
2307 if N
= Condition
(P
) then
2308 if Present
(Condition_Actions
(P
)) then
2309 Insert_List_After_And_Analyze
2310 (Last
(Condition_Actions
(P
)), Ins_Actions
);
2312 Set_Condition_Actions
(P
, Ins_Actions
);
2314 -- Set the parent of the insert actions explicitly.
2315 -- This is not a syntactic field, but we need the
2316 -- parent field set, in particular so that freeze
2317 -- can understand that it is dealing with condition
2318 -- actions, and properly insert the freezing actions.
2320 Set_Parent
(Ins_Actions
, P
);
2321 Analyze_List
(Condition_Actions
(P
));
2327 -- Statements, declarations, pragmas, representation clauses
2332 N_Procedure_Call_Statement |
2333 N_Statement_Other_Than_Procedure_Call |
2339 -- Representation_Clause
2342 N_Attribute_Definition_Clause |
2343 N_Enumeration_Representation_Clause |
2344 N_Record_Representation_Clause |
2348 N_Abstract_Subprogram_Declaration |
2350 N_Exception_Declaration |
2351 N_Exception_Renaming_Declaration |
2352 N_Formal_Abstract_Subprogram_Declaration |
2353 N_Formal_Concrete_Subprogram_Declaration |
2354 N_Formal_Object_Declaration |
2355 N_Formal_Type_Declaration |
2356 N_Full_Type_Declaration |
2357 N_Function_Instantiation |
2358 N_Generic_Function_Renaming_Declaration |
2359 N_Generic_Package_Declaration |
2360 N_Generic_Package_Renaming_Declaration |
2361 N_Generic_Procedure_Renaming_Declaration |
2362 N_Generic_Subprogram_Declaration |
2363 N_Implicit_Label_Declaration |
2364 N_Incomplete_Type_Declaration |
2365 N_Number_Declaration |
2366 N_Object_Declaration |
2367 N_Object_Renaming_Declaration |
2369 N_Package_Body_Stub |
2370 N_Package_Declaration |
2371 N_Package_Instantiation |
2372 N_Package_Renaming_Declaration |
2373 N_Private_Extension_Declaration |
2374 N_Private_Type_Declaration |
2375 N_Procedure_Instantiation |
2377 N_Protected_Body_Stub |
2378 N_Protected_Type_Declaration |
2379 N_Single_Task_Declaration |
2381 N_Subprogram_Body_Stub |
2382 N_Subprogram_Declaration |
2383 N_Subprogram_Renaming_Declaration |
2384 N_Subtype_Declaration |
2387 N_Task_Type_Declaration |
2389 -- Freeze entity behaves like a declaration or statement
2393 -- Do not insert here if the item is not a list member (this
2394 -- happens for example with a triggering statement, and the
2395 -- proper approach is to insert before the entire select).
2397 if not Is_List_Member
(P
) then
2400 -- Do not insert if parent of P is an N_Component_Association
2401 -- node (i.e. we are in the context of an N_Aggregate or
2402 -- N_Extension_Aggregate node. In this case we want to insert
2403 -- before the entire aggregate.
2405 elsif Nkind
(Parent
(P
)) = N_Component_Association
then
2408 -- Do not insert if the parent of P is either an N_Variant
2409 -- node or an N_Record_Definition node, meaning in either
2410 -- case that P is a member of a component list, and that
2411 -- therefore the actions should be inserted outside the
2412 -- complete record declaration.
2414 elsif Nkind
(Parent
(P
)) = N_Variant
2415 or else Nkind
(Parent
(P
)) = N_Record_Definition
2419 -- Do not insert freeze nodes within the loop generated for
2420 -- an aggregate, because they may be elaborated too late for
2421 -- subsequent use in the back end: within a package spec the
2422 -- loop is part of the elaboration procedure and is only
2423 -- elaborated during the second pass.
2424 -- If the loop comes from source, or the entity is local to
2425 -- the loop itself it must remain within.
2427 elsif Nkind
(Parent
(P
)) = N_Loop_Statement
2428 and then not Comes_From_Source
(Parent
(P
))
2429 and then Nkind
(First
(Ins_Actions
)) = N_Freeze_Entity
2431 Scope
(Entity
(First
(Ins_Actions
))) /= Current_Scope
2435 -- Otherwise we can go ahead and do the insertion
2437 elsif P
= Wrapped_Node
then
2438 Store_Before_Actions_In_Scope
(Ins_Actions
);
2442 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
2446 -- A special case, N_Raise_xxx_Error can act either as a
2447 -- statement or a subexpression. We tell the difference
2448 -- by looking at the Etype. It is set to Standard_Void_Type
2449 -- in the statement case.
2452 N_Raise_xxx_Error
=>
2453 if Etype
(P
) = Standard_Void_Type
then
2454 if P
= Wrapped_Node
then
2455 Store_Before_Actions_In_Scope
(Ins_Actions
);
2457 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
2462 -- In the subexpression case, keep climbing
2468 -- If a component association appears within a loop created for
2469 -- an array aggregate, attach the actions to the association so
2470 -- they can be subsequently inserted within the loop. For other
2471 -- component associations insert outside of the aggregate. For
2472 -- an association that will generate a loop, its Loop_Actions
2473 -- attribute is already initialized (see exp_aggr.adb).
2475 -- The list of loop_actions can in turn generate additional ones,
2476 -- that are inserted before the associated node. If the associated
2477 -- node is outside the aggregate, the new actions are collected
2478 -- at the end of the loop actions, to respect the order in which
2479 -- they are to be elaborated.
2482 N_Component_Association
=>
2483 if Nkind
(Parent
(P
)) = N_Aggregate
2484 and then Present
(Loop_Actions
(P
))
2486 if Is_Empty_List
(Loop_Actions
(P
)) then
2487 Set_Loop_Actions
(P
, Ins_Actions
);
2488 Analyze_List
(Ins_Actions
);
2495 -- Check whether these actions were generated
2496 -- by a declaration that is part of the loop_
2497 -- actions for the component_association.
2500 while Present
(Decl
) loop
2501 exit when Parent
(Decl
) = P
2502 and then Is_List_Member
(Decl
)
2504 List_Containing
(Decl
) = Loop_Actions
(P
);
2505 Decl
:= Parent
(Decl
);
2508 if Present
(Decl
) then
2509 Insert_List_Before_And_Analyze
2510 (Decl
, Ins_Actions
);
2512 Insert_List_After_And_Analyze
2513 (Last
(Loop_Actions
(P
)), Ins_Actions
);
2524 -- Another special case, an attribute denoting a procedure call
2527 N_Attribute_Reference
=>
2528 if Is_Procedure_Attribute_Name
(Attribute_Name
(P
)) then
2529 if P
= Wrapped_Node
then
2530 Store_Before_Actions_In_Scope
(Ins_Actions
);
2532 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
2537 -- In the subexpression case, keep climbing
2543 -- For all other node types, keep climbing tree
2547 N_Accept_Alternative |
2548 N_Access_Definition |
2549 N_Access_Function_Definition |
2550 N_Access_Procedure_Definition |
2551 N_Access_To_Object_Definition |
2554 N_Case_Statement_Alternative |
2555 N_Character_Literal |
2556 N_Compilation_Unit |
2557 N_Compilation_Unit_Aux |
2558 N_Component_Clause |
2559 N_Component_Declaration |
2560 N_Component_Definition |
2562 N_Constrained_Array_Definition |
2563 N_Decimal_Fixed_Point_Definition |
2564 N_Defining_Character_Literal |
2565 N_Defining_Identifier |
2566 N_Defining_Operator_Symbol |
2567 N_Defining_Program_Unit_Name |
2568 N_Delay_Alternative |
2569 N_Delta_Constraint |
2570 N_Derived_Type_Definition |
2572 N_Digits_Constraint |
2573 N_Discriminant_Association |
2574 N_Discriminant_Specification |
2576 N_Entry_Body_Formal_Part |
2577 N_Entry_Call_Alternative |
2578 N_Entry_Declaration |
2579 N_Entry_Index_Specification |
2580 N_Enumeration_Type_Definition |
2582 N_Exception_Handler |
2584 N_Explicit_Dereference |
2585 N_Extension_Aggregate |
2586 N_Floating_Point_Definition |
2587 N_Formal_Decimal_Fixed_Point_Definition |
2588 N_Formal_Derived_Type_Definition |
2589 N_Formal_Discrete_Type_Definition |
2590 N_Formal_Floating_Point_Definition |
2591 N_Formal_Modular_Type_Definition |
2592 N_Formal_Ordinary_Fixed_Point_Definition |
2593 N_Formal_Package_Declaration |
2594 N_Formal_Private_Type_Definition |
2595 N_Formal_Signed_Integer_Type_Definition |
2597 N_Function_Specification |
2598 N_Generic_Association |
2599 N_Handled_Sequence_Of_Statements |
2602 N_Index_Or_Discriminant_Constraint |
2603 N_Indexed_Component |
2607 N_Loop_Parameter_Specification |
2609 N_Modular_Type_Definition |
2635 N_Op_Shift_Right_Arithmetic |
2639 N_Ordinary_Fixed_Point_Definition |
2641 N_Package_Specification |
2642 N_Parameter_Association |
2643 N_Parameter_Specification |
2644 N_Pop_Constraint_Error_Label |
2645 N_Pop_Program_Error_Label |
2646 N_Pop_Storage_Error_Label |
2647 N_Pragma_Argument_Association |
2648 N_Procedure_Specification |
2649 N_Protected_Definition |
2650 N_Push_Constraint_Error_Label |
2651 N_Push_Program_Error_Label |
2652 N_Push_Storage_Error_Label |
2653 N_Qualified_Expression |
2655 N_Range_Constraint |
2657 N_Real_Range_Specification |
2658 N_Record_Definition |
2660 N_Selected_Component |
2661 N_Signed_Integer_Type_Definition |
2662 N_Single_Protected_Declaration |
2666 N_Subtype_Indication |
2669 N_Terminate_Alternative |
2670 N_Triggering_Alternative |
2672 N_Unchecked_Expression |
2673 N_Unchecked_Type_Conversion |
2674 N_Unconstrained_Array_Definition |
2677 N_Use_Package_Clause |
2681 N_Validate_Unchecked_Conversion |
2688 -- Make sure that inserted actions stay in the transient scope
2690 if P
= Wrapped_Node
then
2691 Store_Before_Actions_In_Scope
(Ins_Actions
);
2695 -- If we fall through above tests, keep climbing tree
2699 if Nkind
(Parent
(N
)) = N_Subunit
then
2701 -- This is the proper body corresponding to a stub. Insertion
2702 -- must be done at the point of the stub, which is in the decla-
2703 -- rative part of the parent unit.
2705 P
:= Corresponding_Stub
(Parent
(N
));
2713 -- Version with check(s) suppressed
2715 procedure Insert_Actions
2716 (Assoc_Node
: Node_Id
;
2717 Ins_Actions
: List_Id
;
2718 Suppress
: Check_Id
)
2721 if Suppress
= All_Checks
then
2723 Svg
: constant Suppress_Array
:= Scope_Suppress
;
2725 Scope_Suppress
:= (others => True);
2726 Insert_Actions
(Assoc_Node
, Ins_Actions
);
2727 Scope_Suppress
:= Svg
;
2732 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
2734 Scope_Suppress
(Suppress
) := True;
2735 Insert_Actions
(Assoc_Node
, Ins_Actions
);
2736 Scope_Suppress
(Suppress
) := Svg
;
2741 --------------------------
2742 -- Insert_Actions_After --
2743 --------------------------
2745 procedure Insert_Actions_After
2746 (Assoc_Node
: Node_Id
;
2747 Ins_Actions
: List_Id
)
2750 if Scope_Is_Transient
2751 and then Assoc_Node
= Node_To_Be_Wrapped
2753 Store_After_Actions_In_Scope
(Ins_Actions
);
2755 Insert_List_After_And_Analyze
(Assoc_Node
, Ins_Actions
);
2757 end Insert_Actions_After
;
2759 ---------------------------------
2760 -- Insert_Library_Level_Action --
2761 ---------------------------------
2763 procedure Insert_Library_Level_Action
(N
: Node_Id
) is
2764 Aux
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Main_Unit
));
2767 Push_Scope
(Cunit_Entity
(Main_Unit
));
2768 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
2770 if No
(Actions
(Aux
)) then
2771 Set_Actions
(Aux
, New_List
(N
));
2773 Append
(N
, Actions
(Aux
));
2778 end Insert_Library_Level_Action
;
2780 ----------------------------------
2781 -- Insert_Library_Level_Actions --
2782 ----------------------------------
2784 procedure Insert_Library_Level_Actions
(L
: List_Id
) is
2785 Aux
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Main_Unit
));
2788 if Is_Non_Empty_List
(L
) then
2789 Push_Scope
(Cunit_Entity
(Main_Unit
));
2790 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
2792 if No
(Actions
(Aux
)) then
2793 Set_Actions
(Aux
, L
);
2796 Insert_List_After_And_Analyze
(Last
(Actions
(Aux
)), L
);
2801 end Insert_Library_Level_Actions
;
2803 ----------------------
2804 -- Inside_Init_Proc --
2805 ----------------------
2807 function Inside_Init_Proc
return Boolean is
2813 and then S
/= Standard_Standard
2815 if Is_Init_Proc
(S
) then
2823 end Inside_Init_Proc
;
2825 ----------------------------
2826 -- Is_All_Null_Statements --
2827 ----------------------------
2829 function Is_All_Null_Statements
(L
: List_Id
) return Boolean is
2834 while Present
(Stm
) loop
2835 if Nkind
(Stm
) /= N_Null_Statement
then
2843 end Is_All_Null_Statements
;
2845 ----------------------------------
2846 -- Is_Library_Level_Tagged_Type --
2847 ----------------------------------
2849 function Is_Library_Level_Tagged_Type
(Typ
: Entity_Id
) return Boolean is
2851 return Is_Tagged_Type
(Typ
)
2852 and then Is_Library_Level_Entity
(Typ
);
2853 end Is_Library_Level_Tagged_Type
;
2855 ----------------------------------
2856 -- Is_Possibly_Unaligned_Object --
2857 ----------------------------------
2859 function Is_Possibly_Unaligned_Object
(N
: Node_Id
) return Boolean is
2860 T
: constant Entity_Id
:= Etype
(N
);
2863 -- If renamed object, apply test to underlying object
2865 if Is_Entity_Name
(N
)
2866 and then Is_Object
(Entity
(N
))
2867 and then Present
(Renamed_Object
(Entity
(N
)))
2869 return Is_Possibly_Unaligned_Object
(Renamed_Object
(Entity
(N
)));
2872 -- Tagged and controlled types and aliased types are always aligned,
2873 -- as are concurrent types.
2876 or else Has_Controlled_Component
(T
)
2877 or else Is_Concurrent_Type
(T
)
2878 or else Is_Tagged_Type
(T
)
2879 or else Is_Controlled
(T
)
2884 -- If this is an element of a packed array, may be unaligned
2886 if Is_Ref_To_Bit_Packed_Array
(N
) then
2890 -- Case of component reference
2892 if Nkind
(N
) = N_Selected_Component
then
2894 P
: constant Node_Id
:= Prefix
(N
);
2895 C
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
2900 -- If component reference is for an array with non-static bounds,
2901 -- then it is always aligned: we can only process unaligned
2902 -- arrays with static bounds (more accurately bounds known at
2905 if Is_Array_Type
(T
)
2906 and then not Compile_Time_Known_Bounds
(T
)
2911 -- If component is aliased, it is definitely properly aligned
2913 if Is_Aliased
(C
) then
2917 -- If component is for a type implemented as a scalar, and the
2918 -- record is packed, and the component is other than the first
2919 -- component of the record, then the component may be unaligned.
2921 if Is_Packed
(Etype
(P
))
2922 and then Represented_As_Scalar
(Etype
(C
))
2923 and then First_Entity
(Scope
(C
)) /= C
2928 -- Compute maximum possible alignment for T
2930 -- If alignment is known, then that settles things
2932 if Known_Alignment
(T
) then
2933 M
:= UI_To_Int
(Alignment
(T
));
2935 -- If alignment is not known, tentatively set max alignment
2938 M
:= Ttypes
.Maximum_Alignment
;
2940 -- We can reduce this if the Esize is known since the default
2941 -- alignment will never be more than the smallest power of 2
2942 -- that does not exceed this Esize value.
2944 if Known_Esize
(T
) then
2945 S
:= UI_To_Int
(Esize
(T
));
2947 while (M
/ 2) >= S
loop
2953 -- If the component reference is for a record that has a specified
2954 -- alignment, and we either know it is too small, or cannot tell,
2955 -- then the component may be unaligned
2957 if Known_Alignment
(Etype
(P
))
2958 and then Alignment
(Etype
(P
)) < Ttypes
.Maximum_Alignment
2959 and then M
> Alignment
(Etype
(P
))
2964 -- Case of component clause present which may specify an
2965 -- unaligned position.
2967 if Present
(Component_Clause
(C
)) then
2969 -- Otherwise we can do a test to make sure that the actual
2970 -- start position in the record, and the length, are both
2971 -- consistent with the required alignment. If not, we know
2972 -- that we are unaligned.
2975 Align_In_Bits
: constant Nat
:= M
* System_Storage_Unit
;
2977 if Component_Bit_Offset
(C
) mod Align_In_Bits
/= 0
2978 or else Esize
(C
) mod Align_In_Bits
/= 0
2985 -- Otherwise, for a component reference, test prefix
2987 return Is_Possibly_Unaligned_Object
(P
);
2990 -- If not a component reference, must be aligned
2995 end Is_Possibly_Unaligned_Object
;
2997 ---------------------------------
2998 -- Is_Possibly_Unaligned_Slice --
2999 ---------------------------------
3001 function Is_Possibly_Unaligned_Slice
(N
: Node_Id
) return Boolean is
3003 -- Go to renamed object
3005 if Is_Entity_Name
(N
)
3006 and then Is_Object
(Entity
(N
))
3007 and then Present
(Renamed_Object
(Entity
(N
)))
3009 return Is_Possibly_Unaligned_Slice
(Renamed_Object
(Entity
(N
)));
3012 -- The reference must be a slice
3014 if Nkind
(N
) /= N_Slice
then
3018 -- Always assume the worst for a nested record component with a
3019 -- component clause, which gigi/gcc does not appear to handle well.
3020 -- It is not clear why this special test is needed at all ???
3022 if Nkind
(Prefix
(N
)) = N_Selected_Component
3023 and then Nkind
(Prefix
(Prefix
(N
))) = N_Selected_Component
3025 Present
(Component_Clause
(Entity
(Selector_Name
(Prefix
(N
)))))
3030 -- We only need to worry if the target has strict alignment
3032 if not Target_Strict_Alignment
then
3036 -- If it is a slice, then look at the array type being sliced
3039 Sarr
: constant Node_Id
:= Prefix
(N
);
3040 -- Prefix of the slice, i.e. the array being sliced
3042 Styp
: constant Entity_Id
:= Etype
(Prefix
(N
));
3043 -- Type of the array being sliced
3049 -- The problems arise if the array object that is being sliced
3050 -- is a component of a record or array, and we cannot guarantee
3051 -- the alignment of the array within its containing object.
3053 -- To investigate this, we look at successive prefixes to see
3054 -- if we have a worrisome indexed or selected component.
3058 -- Case of array is part of an indexed component reference
3060 if Nkind
(Pref
) = N_Indexed_Component
then
3061 Ptyp
:= Etype
(Prefix
(Pref
));
3063 -- The only problematic case is when the array is packed,
3064 -- in which case we really know nothing about the alignment
3065 -- of individual components.
3067 if Is_Bit_Packed_Array
(Ptyp
) then
3071 -- Case of array is part of a selected component reference
3073 elsif Nkind
(Pref
) = N_Selected_Component
then
3074 Ptyp
:= Etype
(Prefix
(Pref
));
3076 -- We are definitely in trouble if the record in question
3077 -- has an alignment, and either we know this alignment is
3078 -- inconsistent with the alignment of the slice, or we
3079 -- don't know what the alignment of the slice should be.
3081 if Known_Alignment
(Ptyp
)
3082 and then (Unknown_Alignment
(Styp
)
3083 or else Alignment
(Styp
) > Alignment
(Ptyp
))
3088 -- We are in potential trouble if the record type is packed.
3089 -- We could special case when we know that the array is the
3090 -- first component, but that's not such a simple case ???
3092 if Is_Packed
(Ptyp
) then
3096 -- We are in trouble if there is a component clause, and
3097 -- either we do not know the alignment of the slice, or
3098 -- the alignment of the slice is inconsistent with the
3099 -- bit position specified by the component clause.
3102 Field
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
3104 if Present
(Component_Clause
(Field
))
3106 (Unknown_Alignment
(Styp
)
3108 (Component_Bit_Offset
(Field
) mod
3109 (System_Storage_Unit
* Alignment
(Styp
))) /= 0)
3115 -- For cases other than selected or indexed components we
3116 -- know we are OK, since no issues arise over alignment.
3122 -- We processed an indexed component or selected component
3123 -- reference that looked safe, so keep checking prefixes.
3125 Pref
:= Prefix
(Pref
);
3128 end Is_Possibly_Unaligned_Slice
;
3130 --------------------------------
3131 -- Is_Ref_To_Bit_Packed_Array --
3132 --------------------------------
3134 function Is_Ref_To_Bit_Packed_Array
(N
: Node_Id
) return Boolean is
3139 if Is_Entity_Name
(N
)
3140 and then Is_Object
(Entity
(N
))
3141 and then Present
(Renamed_Object
(Entity
(N
)))
3143 return Is_Ref_To_Bit_Packed_Array
(Renamed_Object
(Entity
(N
)));
3146 if Nkind
(N
) = N_Indexed_Component
3148 Nkind
(N
) = N_Selected_Component
3150 if Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
3153 Result
:= Is_Ref_To_Bit_Packed_Array
(Prefix
(N
));
3156 if Result
and then Nkind
(N
) = N_Indexed_Component
then
3157 Expr
:= First
(Expressions
(N
));
3158 while Present
(Expr
) loop
3159 Force_Evaluation
(Expr
);
3169 end Is_Ref_To_Bit_Packed_Array
;
3171 --------------------------------
3172 -- Is_Ref_To_Bit_Packed_Slice --
3173 --------------------------------
3175 function Is_Ref_To_Bit_Packed_Slice
(N
: Node_Id
) return Boolean is
3177 if Nkind
(N
) = N_Type_Conversion
then
3178 return Is_Ref_To_Bit_Packed_Slice
(Expression
(N
));
3180 elsif Is_Entity_Name
(N
)
3181 and then Is_Object
(Entity
(N
))
3182 and then Present
(Renamed_Object
(Entity
(N
)))
3184 return Is_Ref_To_Bit_Packed_Slice
(Renamed_Object
(Entity
(N
)));
3186 elsif Nkind
(N
) = N_Slice
3187 and then Is_Bit_Packed_Array
(Etype
(Prefix
(N
)))
3191 elsif Nkind
(N
) = N_Indexed_Component
3193 Nkind
(N
) = N_Selected_Component
3195 return Is_Ref_To_Bit_Packed_Slice
(Prefix
(N
));
3200 end Is_Ref_To_Bit_Packed_Slice
;
3202 -----------------------
3203 -- Is_Renamed_Object --
3204 -----------------------
3206 function Is_Renamed_Object
(N
: Node_Id
) return Boolean is
3207 Pnod
: constant Node_Id
:= Parent
(N
);
3208 Kind
: constant Node_Kind
:= Nkind
(Pnod
);
3211 if Kind
= N_Object_Renaming_Declaration
then
3214 elsif Kind
= N_Indexed_Component
3215 or else Kind
= N_Selected_Component
3217 return Is_Renamed_Object
(Pnod
);
3222 end Is_Renamed_Object
;
3224 ----------------------------
3225 -- Is_Untagged_Derivation --
3226 ----------------------------
3228 function Is_Untagged_Derivation
(T
: Entity_Id
) return Boolean is
3230 return (not Is_Tagged_Type
(T
) and then Is_Derived_Type
(T
))
3232 (Is_Private_Type
(T
) and then Present
(Full_View
(T
))
3233 and then not Is_Tagged_Type
(Full_View
(T
))
3234 and then Is_Derived_Type
(Full_View
(T
))
3235 and then Etype
(Full_View
(T
)) /= T
);
3236 end Is_Untagged_Derivation
;
3238 ---------------------------
3239 -- Is_Volatile_Reference --
3240 ---------------------------
3242 function Is_Volatile_Reference
(N
: Node_Id
) return Boolean is
3244 if Nkind
(N
) in N_Has_Etype
3245 and then Present
(Etype
(N
))
3246 and then Treat_As_Volatile
(Etype
(N
))
3250 elsif Is_Entity_Name
(N
) then
3251 return Treat_As_Volatile
(Entity
(N
));
3253 elsif Nkind
(N
) = N_Slice
then
3254 return Is_Volatile_Reference
(Prefix
(N
));
3256 elsif Nkind_In
(N
, N_Indexed_Component
, N_Selected_Component
) then
3257 if (Is_Entity_Name
(Prefix
(N
))
3258 and then Has_Volatile_Components
(Entity
(Prefix
(N
))))
3259 or else (Present
(Etype
(Prefix
(N
)))
3260 and then Has_Volatile_Components
(Etype
(Prefix
(N
))))
3264 return Is_Volatile_Reference
(Prefix
(N
));
3270 end Is_Volatile_Reference
;
3272 --------------------
3273 -- Kill_Dead_Code --
3274 --------------------
3276 procedure Kill_Dead_Code
(N
: Node_Id
; Warn
: Boolean := False) is
3279 Remove_Warning_Messages
(N
);
3283 ("?this code can never be executed and has been deleted!", N
);
3286 -- Recurse into block statements and bodies to process declarations
3289 if Nkind
(N
) = N_Block_Statement
3290 or else Nkind
(N
) = N_Subprogram_Body
3291 or else Nkind
(N
) = N_Package_Body
3293 Kill_Dead_Code
(Declarations
(N
), False);
3294 Kill_Dead_Code
(Statements
(Handled_Statement_Sequence
(N
)));
3296 if Nkind
(N
) = N_Subprogram_Body
then
3297 Set_Is_Eliminated
(Defining_Entity
(N
));
3300 elsif Nkind
(N
) = N_Package_Declaration
then
3301 Kill_Dead_Code
(Visible_Declarations
(Specification
(N
)));
3302 Kill_Dead_Code
(Private_Declarations
(Specification
(N
)));
3304 -- ??? After this point, Delete_Tree has been called on all
3305 -- declarations in Specification (N), so references to
3306 -- entities therein look suspicious.
3309 E
: Entity_Id
:= First_Entity
(Defining_Entity
(N
));
3311 while Present
(E
) loop
3312 if Ekind
(E
) = E_Operator
then
3313 Set_Is_Eliminated
(E
);
3320 -- Recurse into composite statement to kill individual statements,
3321 -- in particular instantiations.
3323 elsif Nkind
(N
) = N_If_Statement
then
3324 Kill_Dead_Code
(Then_Statements
(N
));
3325 Kill_Dead_Code
(Elsif_Parts
(N
));
3326 Kill_Dead_Code
(Else_Statements
(N
));
3328 elsif Nkind
(N
) = N_Loop_Statement
then
3329 Kill_Dead_Code
(Statements
(N
));
3331 elsif Nkind
(N
) = N_Case_Statement
then
3335 Alt
:= First
(Alternatives
(N
));
3336 while Present
(Alt
) loop
3337 Kill_Dead_Code
(Statements
(Alt
));
3342 elsif Nkind
(N
) = N_Case_Statement_Alternative
then
3343 Kill_Dead_Code
(Statements
(N
));
3345 -- Deal with dead instances caused by deleting instantiations
3347 elsif Nkind
(N
) in N_Generic_Instantiation
then
3348 Remove_Dead_Instance
(N
);
3353 -- Case where argument is a list of nodes to be killed
3355 procedure Kill_Dead_Code
(L
: List_Id
; Warn
: Boolean := False) is
3360 if Is_Non_Empty_List
(L
) then
3362 while Present
(N
) loop
3363 Kill_Dead_Code
(N
, W
);
3370 ------------------------
3371 -- Known_Non_Negative --
3372 ------------------------
3374 function Known_Non_Negative
(Opnd
: Node_Id
) return Boolean is
3376 if Is_OK_Static_Expression
(Opnd
)
3377 and then Expr_Value
(Opnd
) >= 0
3383 Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Opnd
));
3387 Is_OK_Static_Expression
(Lo
) and then Expr_Value
(Lo
) >= 0;
3390 end Known_Non_Negative
;
3392 --------------------
3393 -- Known_Non_Null --
3394 --------------------
3396 function Known_Non_Null
(N
: Node_Id
) return Boolean is
3398 -- Checks for case where N is an entity reference
3400 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
3402 E
: constant Entity_Id
:= Entity
(N
);
3407 -- First check if we are in decisive conditional
3409 Get_Current_Value_Condition
(N
, Op
, Val
);
3411 if Known_Null
(Val
) then
3412 if Op
= N_Op_Eq
then
3414 elsif Op
= N_Op_Ne
then
3419 -- If OK to do replacement, test Is_Known_Non_Null flag
3421 if OK_To_Do_Constant_Replacement
(E
) then
3422 return Is_Known_Non_Null
(E
);
3424 -- Otherwise if not safe to do replacement, then say so
3431 -- True if access attribute
3433 elsif Nkind
(N
) = N_Attribute_Reference
3434 and then (Attribute_Name
(N
) = Name_Access
3436 Attribute_Name
(N
) = Name_Unchecked_Access
3438 Attribute_Name
(N
) = Name_Unrestricted_Access
)
3442 -- True if allocator
3444 elsif Nkind
(N
) = N_Allocator
then
3447 -- For a conversion, true if expression is known non-null
3449 elsif Nkind
(N
) = N_Type_Conversion
then
3450 return Known_Non_Null
(Expression
(N
));
3452 -- Above are all cases where the value could be determined to be
3453 -- non-null. In all other cases, we don't know, so return False.
3464 function Known_Null
(N
: Node_Id
) return Boolean is
3466 -- Checks for case where N is an entity reference
3468 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
3470 E
: constant Entity_Id
:= Entity
(N
);
3475 -- Constant null value is for sure null
3477 if Ekind
(E
) = E_Constant
3478 and then Known_Null
(Constant_Value
(E
))
3483 -- First check if we are in decisive conditional
3485 Get_Current_Value_Condition
(N
, Op
, Val
);
3487 if Known_Null
(Val
) then
3488 if Op
= N_Op_Eq
then
3490 elsif Op
= N_Op_Ne
then
3495 -- If OK to do replacement, test Is_Known_Null flag
3497 if OK_To_Do_Constant_Replacement
(E
) then
3498 return Is_Known_Null
(E
);
3500 -- Otherwise if not safe to do replacement, then say so
3507 -- True if explicit reference to null
3509 elsif Nkind
(N
) = N_Null
then
3512 -- For a conversion, true if expression is known null
3514 elsif Nkind
(N
) = N_Type_Conversion
then
3515 return Known_Null
(Expression
(N
));
3517 -- Above are all cases where the value could be determined to be null.
3518 -- In all other cases, we don't know, so return False.
3525 -----------------------------
3526 -- Make_CW_Equivalent_Type --
3527 -----------------------------
3529 -- Create a record type used as an equivalent of any member
3530 -- of the class which takes its size from exp.
3532 -- Generate the following code:
3534 -- type Equiv_T is record
3535 -- _parent : T (List of discriminant constraints taken from Exp);
3536 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
3539 -- ??? Note that this type does not guarantee same alignment as all
3542 function Make_CW_Equivalent_Type
3544 E
: Node_Id
) return Entity_Id
3546 Loc
: constant Source_Ptr
:= Sloc
(E
);
3547 Root_Typ
: constant Entity_Id
:= Root_Type
(T
);
3548 List_Def
: constant List_Id
:= Empty_List
;
3549 Comp_List
: constant List_Id
:= New_List
;
3550 Equiv_Type
: Entity_Id
;
3551 Range_Type
: Entity_Id
;
3552 Str_Type
: Entity_Id
;
3553 Constr_Root
: Entity_Id
;
3557 if not Has_Discriminants
(Root_Typ
) then
3558 Constr_Root
:= Root_Typ
;
3561 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
3563 -- subtype cstr__n is T (List of discr constraints taken from Exp)
3565 Append_To
(List_Def
,
3566 Make_Subtype_Declaration
(Loc
,
3567 Defining_Identifier
=> Constr_Root
,
3568 Subtype_Indication
=>
3569 Make_Subtype_From_Expr
(E
, Root_Typ
)));
3572 -- Generate the range subtype declaration
3574 Range_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('G'));
3576 if not Is_Interface
(Root_Typ
) then
3577 -- subtype rg__xx is
3578 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
3581 Make_Op_Subtract
(Loc
,
3583 Make_Attribute_Reference
(Loc
,
3585 OK_Convert_To
(T
, Duplicate_Subexpr_No_Checks
(E
)),
3586 Attribute_Name
=> Name_Size
),
3588 Make_Attribute_Reference
(Loc
,
3589 Prefix
=> New_Reference_To
(Constr_Root
, Loc
),
3590 Attribute_Name
=> Name_Object_Size
));
3592 -- subtype rg__xx is
3593 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
3596 Make_Attribute_Reference
(Loc
,
3598 OK_Convert_To
(T
, Duplicate_Subexpr_No_Checks
(E
)),
3599 Attribute_Name
=> Name_Size
);
3602 Set_Paren_Count
(Sizexpr
, 1);
3604 Append_To
(List_Def
,
3605 Make_Subtype_Declaration
(Loc
,
3606 Defining_Identifier
=> Range_Type
,
3607 Subtype_Indication
=>
3608 Make_Subtype_Indication
(Loc
,
3609 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
),
3610 Constraint
=> Make_Range_Constraint
(Loc
,
3613 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
3615 Make_Op_Divide
(Loc
,
3616 Left_Opnd
=> Sizexpr
,
3617 Right_Opnd
=> Make_Integer_Literal
(Loc
,
3618 Intval
=> System_Storage_Unit
)))))));
3620 -- subtype str__nn is Storage_Array (rg__x);
3622 Str_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
3623 Append_To
(List_Def
,
3624 Make_Subtype_Declaration
(Loc
,
3625 Defining_Identifier
=> Str_Type
,
3626 Subtype_Indication
=>
3627 Make_Subtype_Indication
(Loc
,
3628 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Storage_Array
), Loc
),
3630 Make_Index_Or_Discriminant_Constraint
(Loc
,
3632 New_List
(New_Reference_To
(Range_Type
, Loc
))))));
3634 -- type Equiv_T is record
3635 -- [ _parent : Tnn; ]
3639 Equiv_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
3641 -- When the target requires front-end layout, it's necessary to allow
3642 -- the equivalent type to be frozen so that layout can occur (when the
3643 -- associated class-wide subtype is frozen, the equivalent type will
3644 -- be frozen, see freeze.adb). For other targets, Gigi wants to have
3645 -- the equivalent type marked as frozen and deals with this type itself.
3646 -- In the Gigi case this will also avoid the generation of an init
3647 -- procedure for the type.
3649 if not Frontend_Layout_On_Target
then
3650 Set_Is_Frozen
(Equiv_Type
);
3653 Set_Ekind
(Equiv_Type
, E_Record_Type
);
3654 Set_Parent_Subtype
(Equiv_Type
, Constr_Root
);
3656 if not Is_Interface
(Root_Typ
) then
3657 Append_To
(Comp_List
,
3658 Make_Component_Declaration
(Loc
,
3659 Defining_Identifier
=>
3660 Make_Defining_Identifier
(Loc
, Name_uParent
),
3661 Component_Definition
=>
3662 Make_Component_Definition
(Loc
,
3663 Aliased_Present
=> False,
3664 Subtype_Indication
=> New_Reference_To
(Constr_Root
, Loc
))));
3667 Append_To
(Comp_List
,
3668 Make_Component_Declaration
(Loc
,
3669 Defining_Identifier
=>
3670 Make_Defining_Identifier
(Loc
,
3671 Chars
=> New_Internal_Name
('C')),
3672 Component_Definition
=>
3673 Make_Component_Definition
(Loc
,
3674 Aliased_Present
=> False,
3675 Subtype_Indication
=> New_Reference_To
(Str_Type
, Loc
))));
3677 Append_To
(List_Def
,
3678 Make_Full_Type_Declaration
(Loc
,
3679 Defining_Identifier
=> Equiv_Type
,
3681 Make_Record_Definition
(Loc
,
3683 Make_Component_List
(Loc
,
3684 Component_Items
=> Comp_List
,
3685 Variant_Part
=> Empty
))));
3687 -- Suppress all checks during the analysis of the expanded code
3688 -- to avoid the generation of spurious warnings under ZFP run-time.
3690 Insert_Actions
(E
, List_Def
, Suppress
=> All_Checks
);
3692 end Make_CW_Equivalent_Type
;
3694 ------------------------
3695 -- Make_Literal_Range --
3696 ------------------------
3698 function Make_Literal_Range
3700 Literal_Typ
: Entity_Id
) return Node_Id
3702 Lo
: constant Node_Id
:=
3703 New_Copy_Tree
(String_Literal_Low_Bound
(Literal_Typ
));
3704 Index
: constant Entity_Id
:= Etype
(Lo
);
3707 Length_Expr
: constant Node_Id
:=
3708 Make_Op_Subtract
(Loc
,
3710 Make_Integer_Literal
(Loc
,
3711 Intval
=> String_Literal_Length
(Literal_Typ
)),
3713 Make_Integer_Literal
(Loc
, 1));
3716 Set_Analyzed
(Lo
, False);
3718 if Is_Integer_Type
(Index
) then
3721 Left_Opnd
=> New_Copy_Tree
(Lo
),
3722 Right_Opnd
=> Length_Expr
);
3725 Make_Attribute_Reference
(Loc
,
3726 Attribute_Name
=> Name_Val
,
3727 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
3728 Expressions
=> New_List
(
3731 Make_Attribute_Reference
(Loc
,
3732 Attribute_Name
=> Name_Pos
,
3733 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
3734 Expressions
=> New_List
(New_Copy_Tree
(Lo
))),
3735 Right_Opnd
=> Length_Expr
)));
3742 end Make_Literal_Range
;
3744 ----------------------------
3745 -- Make_Subtype_From_Expr --
3746 ----------------------------
3748 -- 1. If Expr is an unconstrained array expression, creates
3749 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
3751 -- 2. If Expr is a unconstrained discriminated type expression, creates
3752 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
3754 -- 3. If Expr is class-wide, creates an implicit class wide subtype
3756 function Make_Subtype_From_Expr
3758 Unc_Typ
: Entity_Id
) return Node_Id
3760 Loc
: constant Source_Ptr
:= Sloc
(E
);
3761 List_Constr
: constant List_Id
:= New_List
;
3764 Full_Subtyp
: Entity_Id
;
3765 Priv_Subtyp
: Entity_Id
;
3770 if Is_Private_Type
(Unc_Typ
)
3771 and then Has_Unknown_Discriminants
(Unc_Typ
)
3773 -- Prepare the subtype completion, Go to base type to
3774 -- find underlying type, because the type may be a generic
3775 -- actual or an explicit subtype.
3777 Utyp
:= Underlying_Type
(Base_Type
(Unc_Typ
));
3778 Full_Subtyp
:= Make_Defining_Identifier
(Loc
,
3779 New_Internal_Name
('C'));
3781 Unchecked_Convert_To
3782 (Utyp
, Duplicate_Subexpr_No_Checks
(E
));
3783 Set_Parent
(Full_Exp
, Parent
(E
));
3786 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
3789 Make_Subtype_Declaration
(Loc
,
3790 Defining_Identifier
=> Full_Subtyp
,
3791 Subtype_Indication
=> Make_Subtype_From_Expr
(Full_Exp
, Utyp
)));
3793 -- Define the dummy private subtype
3795 Set_Ekind
(Priv_Subtyp
, Subtype_Kind
(Ekind
(Unc_Typ
)));
3796 Set_Etype
(Priv_Subtyp
, Base_Type
(Unc_Typ
));
3797 Set_Scope
(Priv_Subtyp
, Full_Subtyp
);
3798 Set_Is_Constrained
(Priv_Subtyp
);
3799 Set_Is_Tagged_Type
(Priv_Subtyp
, Is_Tagged_Type
(Unc_Typ
));
3800 Set_Is_Itype
(Priv_Subtyp
);
3801 Set_Associated_Node_For_Itype
(Priv_Subtyp
, E
);
3803 if Is_Tagged_Type
(Priv_Subtyp
) then
3805 (Base_Type
(Priv_Subtyp
), Class_Wide_Type
(Unc_Typ
));
3806 Set_Primitive_Operations
(Priv_Subtyp
,
3807 Primitive_Operations
(Unc_Typ
));
3810 Set_Full_View
(Priv_Subtyp
, Full_Subtyp
);
3812 return New_Reference_To
(Priv_Subtyp
, Loc
);
3814 elsif Is_Array_Type
(Unc_Typ
) then
3815 for J
in 1 .. Number_Dimensions
(Unc_Typ
) loop
3816 Append_To
(List_Constr
,
3819 Make_Attribute_Reference
(Loc
,
3820 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
3821 Attribute_Name
=> Name_First
,
3822 Expressions
=> New_List
(
3823 Make_Integer_Literal
(Loc
, J
))),
3826 Make_Attribute_Reference
(Loc
,
3827 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
3828 Attribute_Name
=> Name_Last
,
3829 Expressions
=> New_List
(
3830 Make_Integer_Literal
(Loc
, J
)))));
3833 elsif Is_Class_Wide_Type
(Unc_Typ
) then
3835 CW_Subtype
: Entity_Id
;
3836 EQ_Typ
: Entity_Id
:= Empty
;
3839 -- A class-wide equivalent type is not needed when VM_Target
3840 -- because the VM back-ends handle the class-wide object
3841 -- initialization itself (and doesn't need or want the
3842 -- additional intermediate type to handle the assignment).
3844 if Expander_Active
and then VM_Target
= No_VM
then
3845 EQ_Typ
:= Make_CW_Equivalent_Type
(Unc_Typ
, E
);
3848 CW_Subtype
:= New_Class_Wide_Subtype
(Unc_Typ
, E
);
3849 Set_Equivalent_Type
(CW_Subtype
, EQ_Typ
);
3851 if Present
(EQ_Typ
) then
3852 Set_Is_Class_Wide_Equivalent_Type
(EQ_Typ
);
3855 Set_Cloned_Subtype
(CW_Subtype
, Base_Type
(Unc_Typ
));
3857 return New_Occurrence_Of
(CW_Subtype
, Loc
);
3860 -- Indefinite record type with discriminants
3863 D
:= First_Discriminant
(Unc_Typ
);
3864 while Present
(D
) loop
3865 Append_To
(List_Constr
,
3866 Make_Selected_Component
(Loc
,
3867 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
3868 Selector_Name
=> New_Reference_To
(D
, Loc
)));
3870 Next_Discriminant
(D
);
3875 Make_Subtype_Indication
(Loc
,
3876 Subtype_Mark
=> New_Reference_To
(Unc_Typ
, Loc
),
3878 Make_Index_Or_Discriminant_Constraint
(Loc
,
3879 Constraints
=> List_Constr
));
3880 end Make_Subtype_From_Expr
;
3882 -----------------------------
3883 -- May_Generate_Large_Temp --
3884 -----------------------------
3886 -- At the current time, the only types that we return False for (i.e.
3887 -- where we decide we know they cannot generate large temps) are ones
3888 -- where we know the size is 256 bits or less at compile time, and we
3889 -- are still not doing a thorough job on arrays and records ???
3891 function May_Generate_Large_Temp
(Typ
: Entity_Id
) return Boolean is
3893 if not Size_Known_At_Compile_Time
(Typ
) then
3896 elsif Esize
(Typ
) /= 0 and then Esize
(Typ
) <= 256 then
3899 elsif Is_Array_Type
(Typ
)
3900 and then Present
(Packed_Array_Type
(Typ
))
3902 return May_Generate_Large_Temp
(Packed_Array_Type
(Typ
));
3904 -- We could do more here to find other small types ???
3909 end May_Generate_Large_Temp
;
3911 ----------------------------
3912 -- New_Class_Wide_Subtype --
3913 ----------------------------
3915 function New_Class_Wide_Subtype
3916 (CW_Typ
: Entity_Id
;
3917 N
: Node_Id
) return Entity_Id
3919 Res
: constant Entity_Id
:= Create_Itype
(E_Void
, N
);
3920 Res_Name
: constant Name_Id
:= Chars
(Res
);
3921 Res_Scope
: constant Entity_Id
:= Scope
(Res
);
3924 Copy_Node
(CW_Typ
, Res
);
3925 Set_Comes_From_Source
(Res
, False);
3926 Set_Sloc
(Res
, Sloc
(N
));
3928 Set_Associated_Node_For_Itype
(Res
, N
);
3929 Set_Is_Public
(Res
, False); -- By default, may be changed below.
3930 Set_Public_Status
(Res
);
3931 Set_Chars
(Res
, Res_Name
);
3932 Set_Scope
(Res
, Res_Scope
);
3933 Set_Ekind
(Res
, E_Class_Wide_Subtype
);
3934 Set_Next_Entity
(Res
, Empty
);
3935 Set_Etype
(Res
, Base_Type
(CW_Typ
));
3937 -- For targets where front-end layout is required, reset the Is_Frozen
3938 -- status of the subtype to False (it can be implicitly set to true
3939 -- from the copy of the class-wide type). For other targets, Gigi
3940 -- doesn't want the class-wide subtype to go through the freezing
3941 -- process (though it's unclear why that causes problems and it would
3942 -- be nice to allow freezing to occur normally for all targets ???).
3944 if Frontend_Layout_On_Target
then
3945 Set_Is_Frozen
(Res
, False);
3948 Set_Freeze_Node
(Res
, Empty
);
3950 end New_Class_Wide_Subtype
;
3952 --------------------------------
3953 -- Non_Limited_Designated_Type --
3954 ---------------------------------
3956 function Non_Limited_Designated_Type
(T
: Entity_Id
) return Entity_Id
is
3957 Desig
: constant Entity_Id
:= Designated_Type
(T
);
3959 if Ekind
(Desig
) = E_Incomplete_Type
3960 and then Present
(Non_Limited_View
(Desig
))
3962 return Non_Limited_View
(Desig
);
3966 end Non_Limited_Designated_Type
;
3968 -----------------------------------
3969 -- OK_To_Do_Constant_Replacement --
3970 -----------------------------------
3972 function OK_To_Do_Constant_Replacement
(E
: Entity_Id
) return Boolean is
3973 ES
: constant Entity_Id
:= Scope
(E
);
3977 -- Do not replace statically allocated objects, because they may be
3978 -- modified outside the current scope.
3980 if Is_Statically_Allocated
(E
) then
3983 -- Do not replace aliased or volatile objects, since we don't know what
3984 -- else might change the value.
3986 elsif Is_Aliased
(E
) or else Treat_As_Volatile
(E
) then
3989 -- Debug flag -gnatdM disconnects this optimization
3991 elsif Debug_Flag_MM
then
3994 -- Otherwise check scopes
3997 CS
:= Current_Scope
;
4000 -- If we are in right scope, replacement is safe
4005 -- Packages do not affect the determination of safety
4007 elsif Ekind
(CS
) = E_Package
then
4008 exit when CS
= Standard_Standard
;
4011 -- Blocks do not affect the determination of safety
4013 elsif Ekind
(CS
) = E_Block
then
4016 -- Loops do not affect the determination of safety. Note that we
4017 -- kill all current values on entry to a loop, so we are just
4018 -- talking about processing within a loop here.
4020 elsif Ekind
(CS
) = E_Loop
then
4023 -- Otherwise, the reference is dubious, and we cannot be sure that
4024 -- it is safe to do the replacement.
4033 end OK_To_Do_Constant_Replacement
;
4035 ------------------------------------
4036 -- Possible_Bit_Aligned_Component --
4037 ------------------------------------
4039 function Possible_Bit_Aligned_Component
(N
: Node_Id
) return Boolean is
4043 -- Case of indexed component
4045 when N_Indexed_Component
=>
4047 P
: constant Node_Id
:= Prefix
(N
);
4048 Ptyp
: constant Entity_Id
:= Etype
(P
);
4051 -- If we know the component size and it is less than 64, then
4052 -- we are definitely OK. The back end always does assignment of
4053 -- misaligned small objects correctly.
4055 if Known_Static_Component_Size
(Ptyp
)
4056 and then Component_Size
(Ptyp
) <= 64
4060 -- Otherwise, we need to test the prefix, to see if we are
4061 -- indexing from a possibly unaligned component.
4064 return Possible_Bit_Aligned_Component
(P
);
4068 -- Case of selected component
4070 when N_Selected_Component
=>
4072 P
: constant Node_Id
:= Prefix
(N
);
4073 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
4076 -- If there is no component clause, then we are in the clear
4077 -- since the back end will never misalign a large component
4078 -- unless it is forced to do so. In the clear means we need
4079 -- only the recursive test on the prefix.
4081 if Component_May_Be_Bit_Aligned
(Comp
) then
4084 return Possible_Bit_Aligned_Component
(P
);
4088 -- For a slice, test the prefix, if that is possibly misaligned,
4089 -- then for sure the slice is!
4092 return Possible_Bit_Aligned_Component
(Prefix
(N
));
4094 -- If we have none of the above, it means that we have fallen off the
4095 -- top testing prefixes recursively, and we now have a stand alone
4096 -- object, where we don't have a problem.
4102 end Possible_Bit_Aligned_Component
;
4104 -------------------------
4105 -- Remove_Side_Effects --
4106 -------------------------
4108 procedure Remove_Side_Effects
4110 Name_Req
: Boolean := False;
4111 Variable_Ref
: Boolean := False)
4113 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
4114 Exp_Type
: constant Entity_Id
:= Etype
(Exp
);
4115 Svg_Suppress
: constant Suppress_Array
:= Scope_Suppress
;
4117 Ref_Type
: Entity_Id
;
4119 Ptr_Typ_Decl
: Node_Id
;
4123 function Side_Effect_Free
(N
: Node_Id
) return Boolean;
4124 -- Determines if the tree N represents an expression that is known not
4125 -- to have side effects, and for which no processing is required.
4127 function Side_Effect_Free
(L
: List_Id
) return Boolean;
4128 -- Determines if all elements of the list L are side effect free
4130 function Safe_Prefixed_Reference
(N
: Node_Id
) return Boolean;
4131 -- The argument N is a construct where the Prefix is dereferenced if it
4132 -- is an access type and the result is a variable. The call returns True
4133 -- if the construct is side effect free (not considering side effects in
4134 -- other than the prefix which are to be tested by the caller).
4136 function Within_In_Parameter
(N
: Node_Id
) return Boolean;
4137 -- Determines if N is a subcomponent of a composite in-parameter. If so,
4138 -- N is not side-effect free when the actual is global and modifiable
4139 -- indirectly from within a subprogram, because it may be passed by
4140 -- reference. The front-end must be conservative here and assume that
4141 -- this may happen with any array or record type. On the other hand, we
4142 -- cannot create temporaries for all expressions for which this
4143 -- condition is true, for various reasons that might require clearing up
4144 -- ??? For example, discriminant references that appear out of place, or
4145 -- spurious type errors with class-wide expressions. As a result, we
4146 -- limit the transformation to loop bounds, which is so far the only
4147 -- case that requires it.
4149 -----------------------------
4150 -- Safe_Prefixed_Reference --
4151 -----------------------------
4153 function Safe_Prefixed_Reference
(N
: Node_Id
) return Boolean is
4155 -- If prefix is not side effect free, definitely not safe
4157 if not Side_Effect_Free
(Prefix
(N
)) then
4160 -- If the prefix is of an access type that is not access-to-constant,
4161 -- then this construct is a variable reference, which means it is to
4162 -- be considered to have side effects if Variable_Ref is set True
4163 -- Exception is an access to an entity that is a constant or an
4164 -- in-parameter which does not come from source, and is the result
4165 -- of a previous removal of side-effects.
4167 elsif Is_Access_Type
(Etype
(Prefix
(N
)))
4168 and then not Is_Access_Constant
(Etype
(Prefix
(N
)))
4169 and then Variable_Ref
4171 if not Is_Entity_Name
(Prefix
(N
)) then
4174 return Ekind
(Entity
(Prefix
(N
))) = E_Constant
4175 or else Ekind
(Entity
(Prefix
(N
))) = E_In_Parameter
;
4178 -- The following test is the simplest way of solving a complex
4179 -- problem uncovered by BB08-010: Side effect on loop bound that
4180 -- is a subcomponent of a global variable:
4181 -- If a loop bound is a subcomponent of a global variable, a
4182 -- modification of that variable within the loop may incorrectly
4183 -- affect the execution of the loop.
4186 (Nkind
(Parent
(Parent
(N
))) /= N_Loop_Parameter_Specification
4187 or else not Within_In_Parameter
(Prefix
(N
)))
4191 -- All other cases are side effect free
4196 end Safe_Prefixed_Reference
;
4198 ----------------------
4199 -- Side_Effect_Free --
4200 ----------------------
4202 function Side_Effect_Free
(N
: Node_Id
) return Boolean is
4204 -- Note on checks that could raise Constraint_Error. Strictly, if
4205 -- we take advantage of 11.6, these checks do not count as side
4206 -- effects. However, we would just as soon consider that they are
4207 -- side effects, since the backend CSE does not work very well on
4208 -- expressions which can raise Constraint_Error. On the other
4209 -- hand, if we do not consider them to be side effect free, then
4210 -- we get some awkward expansions in -gnato mode, resulting in
4211 -- code insertions at a point where we do not have a clear model
4212 -- for performing the insertions.
4214 -- Special handling for entity names
4216 if Is_Entity_Name
(N
) then
4218 -- If the entity is a constant, it is definitely side effect
4219 -- free. Note that the test of Is_Variable (N) below might
4220 -- be expected to catch this case, but it does not, because
4221 -- this test goes to the original tree, and we may have
4222 -- already rewritten a variable node with a constant as
4223 -- a result of an earlier Force_Evaluation call.
4225 if Ekind
(Entity
(N
)) = E_Constant
4226 or else Ekind
(Entity
(N
)) = E_In_Parameter
4230 -- Functions are not side effect free
4232 elsif Ekind
(Entity
(N
)) = E_Function
then
4235 -- Variables are considered to be a side effect if Variable_Ref
4236 -- is set or if we have a volatile reference and Name_Req is off.
4237 -- If Name_Req is True then we can't help returning a name which
4238 -- effectively allows multiple references in any case.
4240 elsif Is_Variable
(N
) then
4241 return not Variable_Ref
4242 and then (not Is_Volatile_Reference
(N
) or else Name_Req
);
4244 -- Any other entity (e.g. a subtype name) is definitely side
4251 -- A value known at compile time is always side effect free
4253 elsif Compile_Time_Known_Value
(N
) then
4256 -- A variable renaming is not side-effect free, because the
4257 -- renaming will function like a macro in the front-end in
4258 -- some cases, and an assignment can modify the component
4259 -- designated by N, so we need to create a temporary for it.
4261 elsif Is_Entity_Name
(Original_Node
(N
))
4262 and then Is_Renaming_Of_Object
(Entity
(Original_Node
(N
)))
4263 and then Ekind
(Entity
(Original_Node
(N
))) /= E_Constant
4268 -- For other than entity names and compile time known values,
4269 -- check the node kind for special processing.
4273 -- An attribute reference is side effect free if its expressions
4274 -- are side effect free and its prefix is side effect free or
4275 -- is an entity reference.
4277 -- Is this right? what about x'first where x is a variable???
4279 when N_Attribute_Reference
=>
4280 return Side_Effect_Free
(Expressions
(N
))
4281 and then Attribute_Name
(N
) /= Name_Input
4282 and then (Is_Entity_Name
(Prefix
(N
))
4283 or else Side_Effect_Free
(Prefix
(N
)));
4285 -- A binary operator is side effect free if and both operands
4286 -- are side effect free. For this purpose binary operators
4287 -- include membership tests and short circuit forms
4293 return Side_Effect_Free
(Left_Opnd
(N
))
4294 and then Side_Effect_Free
(Right_Opnd
(N
));
4296 -- An explicit dereference is side effect free only if it is
4297 -- a side effect free prefixed reference.
4299 when N_Explicit_Dereference
=>
4300 return Safe_Prefixed_Reference
(N
);
4302 -- A call to _rep_to_pos is side effect free, since we generate
4303 -- this pure function call ourselves. Moreover it is critically
4304 -- important to make this exception, since otherwise we can
4305 -- have discriminants in array components which don't look
4306 -- side effect free in the case of an array whose index type
4307 -- is an enumeration type with an enumeration rep clause.
4309 -- All other function calls are not side effect free
4311 when N_Function_Call
=>
4312 return Nkind
(Name
(N
)) = N_Identifier
4313 and then Is_TSS
(Name
(N
), TSS_Rep_To_Pos
)
4315 Side_Effect_Free
(First
(Parameter_Associations
(N
)));
4317 -- An indexed component is side effect free if it is a side
4318 -- effect free prefixed reference and all the indexing
4319 -- expressions are side effect free.
4321 when N_Indexed_Component
=>
4322 return Side_Effect_Free
(Expressions
(N
))
4323 and then Safe_Prefixed_Reference
(N
);
4325 -- A type qualification is side effect free if the expression
4326 -- is side effect free.
4328 when N_Qualified_Expression
=>
4329 return Side_Effect_Free
(Expression
(N
));
4331 -- A selected component is side effect free only if it is a
4332 -- side effect free prefixed reference. If it designates a
4333 -- component with a rep. clause it must be treated has having
4334 -- a potential side effect, because it may be modified through
4335 -- a renaming, and a subsequent use of the renaming as a macro
4336 -- will yield the wrong value. This complex interaction between
4337 -- renaming and removing side effects is a reminder that the
4338 -- latter has become a headache to maintain, and that it should
4339 -- be removed in favor of the gcc mechanism to capture values ???
4341 when N_Selected_Component
=>
4342 if Nkind
(Parent
(N
)) = N_Explicit_Dereference
4343 and then Has_Non_Standard_Rep
(Designated_Type
(Etype
(N
)))
4347 return Safe_Prefixed_Reference
(N
);
4350 -- A range is side effect free if the bounds are side effect free
4353 return Side_Effect_Free
(Low_Bound
(N
))
4354 and then Side_Effect_Free
(High_Bound
(N
));
4356 -- A slice is side effect free if it is a side effect free
4357 -- prefixed reference and the bounds are side effect free.
4360 return Side_Effect_Free
(Discrete_Range
(N
))
4361 and then Safe_Prefixed_Reference
(N
);
4363 -- A type conversion is side effect free if the expression to be
4364 -- converted is side effect free.
4366 when N_Type_Conversion
=>
4367 return Side_Effect_Free
(Expression
(N
));
4369 -- A unary operator is side effect free if the operand
4370 -- is side effect free.
4373 return Side_Effect_Free
(Right_Opnd
(N
));
4375 -- An unchecked type conversion is side effect free only if it
4376 -- is safe and its argument is side effect free.
4378 when N_Unchecked_Type_Conversion
=>
4379 return Safe_Unchecked_Type_Conversion
(N
)
4380 and then Side_Effect_Free
(Expression
(N
));
4382 -- An unchecked expression is side effect free if its expression
4383 -- is side effect free.
4385 when N_Unchecked_Expression
=>
4386 return Side_Effect_Free
(Expression
(N
));
4388 -- A literal is side effect free
4390 when N_Character_Literal |
4396 -- We consider that anything else has side effects. This is a bit
4397 -- crude, but we are pretty close for most common cases, and we
4398 -- are certainly correct (i.e. we never return True when the
4399 -- answer should be False).
4404 end Side_Effect_Free
;
4406 -- A list is side effect free if all elements of the list are
4407 -- side effect free.
4409 function Side_Effect_Free
(L
: List_Id
) return Boolean is
4413 if L
= No_List
or else L
= Error_List
then
4418 while Present
(N
) loop
4419 if not Side_Effect_Free
(N
) then
4428 end Side_Effect_Free
;
4430 -------------------------
4431 -- Within_In_Parameter --
4432 -------------------------
4434 function Within_In_Parameter
(N
: Node_Id
) return Boolean is
4436 if not Comes_From_Source
(N
) then
4439 elsif Is_Entity_Name
(N
) then
4440 return Ekind
(Entity
(N
)) = E_In_Parameter
;
4442 elsif Nkind
(N
) = N_Indexed_Component
4443 or else Nkind
(N
) = N_Selected_Component
4445 return Within_In_Parameter
(Prefix
(N
));
4450 end Within_In_Parameter
;
4452 -- Start of processing for Remove_Side_Effects
4455 -- If we are side effect free already or expansion is disabled,
4456 -- there is nothing to do.
4458 if Side_Effect_Free
(Exp
) or else not Expander_Active
then
4462 -- All this must not have any checks
4464 Scope_Suppress
:= (others => True);
4466 -- If it is a scalar type and we need to capture the value, just make
4467 -- a copy. Likewise for a function call, an attribute reference or an
4468 -- operator. And if we have a volatile reference and Name_Req is not
4469 -- set (see comments above for Side_Effect_Free).
4471 if Is_Elementary_Type
(Exp_Type
)
4472 and then (Variable_Ref
4473 or else Nkind
(Exp
) = N_Function_Call
4474 or else Nkind
(Exp
) = N_Attribute_Reference
4475 or else Nkind
(Exp
) in N_Op
4476 or else (not Name_Req
and then Is_Volatile_Reference
(Exp
)))
4478 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4479 Set_Etype
(Def_Id
, Exp_Type
);
4480 Res
:= New_Reference_To
(Def_Id
, Loc
);
4483 Make_Object_Declaration
(Loc
,
4484 Defining_Identifier
=> Def_Id
,
4485 Object_Definition
=> New_Reference_To
(Exp_Type
, Loc
),
4486 Constant_Present
=> True,
4487 Expression
=> Relocate_Node
(Exp
));
4489 Set_Assignment_OK
(E
);
4490 Insert_Action
(Exp
, E
);
4492 -- If the expression has the form v.all then we can just capture
4493 -- the pointer, and then do an explicit dereference on the result.
4495 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
4497 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4499 Make_Explicit_Dereference
(Loc
, New_Reference_To
(Def_Id
, Loc
));
4502 Make_Object_Declaration
(Loc
,
4503 Defining_Identifier
=> Def_Id
,
4504 Object_Definition
=>
4505 New_Reference_To
(Etype
(Prefix
(Exp
)), Loc
),
4506 Constant_Present
=> True,
4507 Expression
=> Relocate_Node
(Prefix
(Exp
))));
4509 -- Similar processing for an unchecked conversion of an expression
4510 -- of the form v.all, where we want the same kind of treatment.
4512 elsif Nkind
(Exp
) = N_Unchecked_Type_Conversion
4513 and then Nkind
(Expression
(Exp
)) = N_Explicit_Dereference
4515 Remove_Side_Effects
(Expression
(Exp
), Name_Req
, Variable_Ref
);
4516 Scope_Suppress
:= Svg_Suppress
;
4519 -- If this is a type conversion, leave the type conversion and remove
4520 -- the side effects in the expression. This is important in several
4521 -- circumstances: for change of representations, and also when this is
4522 -- a view conversion to a smaller object, where gigi can end up creating
4523 -- its own temporary of the wrong size.
4525 elsif Nkind
(Exp
) = N_Type_Conversion
then
4526 Remove_Side_Effects
(Expression
(Exp
), Name_Req
, Variable_Ref
);
4527 Scope_Suppress
:= Svg_Suppress
;
4530 -- If this is an unchecked conversion that Gigi can't handle, make
4531 -- a copy or a use a renaming to capture the value.
4533 elsif Nkind
(Exp
) = N_Unchecked_Type_Conversion
4534 and then not Safe_Unchecked_Type_Conversion
(Exp
)
4536 if CW_Or_Has_Controlled_Part
(Exp_Type
) then
4538 -- Use a renaming to capture the expression, rather than create
4539 -- a controlled temporary.
4541 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4542 Res
:= New_Reference_To
(Def_Id
, Loc
);
4545 Make_Object_Renaming_Declaration
(Loc
,
4546 Defining_Identifier
=> Def_Id
,
4547 Subtype_Mark
=> New_Reference_To
(Exp_Type
, Loc
),
4548 Name
=> Relocate_Node
(Exp
)));
4551 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4552 Set_Etype
(Def_Id
, Exp_Type
);
4553 Res
:= New_Reference_To
(Def_Id
, Loc
);
4556 Make_Object_Declaration
(Loc
,
4557 Defining_Identifier
=> Def_Id
,
4558 Object_Definition
=> New_Reference_To
(Exp_Type
, Loc
),
4559 Constant_Present
=> not Is_Variable
(Exp
),
4560 Expression
=> Relocate_Node
(Exp
));
4562 Set_Assignment_OK
(E
);
4563 Insert_Action
(Exp
, E
);
4566 -- For expressions that denote objects, we can use a renaming scheme.
4567 -- We skip using this if we have a volatile reference and we do not
4568 -- have Name_Req set true (see comments above for Side_Effect_Free).
4570 elsif Is_Object_Reference
(Exp
)
4571 and then Nkind
(Exp
) /= N_Function_Call
4572 and then (Name_Req
or else not Is_Volatile_Reference
(Exp
))
4574 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4576 if Nkind
(Exp
) = N_Selected_Component
4577 and then Nkind
(Prefix
(Exp
)) = N_Function_Call
4578 and then Is_Array_Type
(Exp_Type
)
4580 -- Avoid generating a variable-sized temporary, by generating
4581 -- the renaming declaration just for the function call. The
4582 -- transformation could be refined to apply only when the array
4583 -- component is constrained by a discriminant???
4586 Make_Selected_Component
(Loc
,
4587 Prefix
=> New_Occurrence_Of
(Def_Id
, Loc
),
4588 Selector_Name
=> Selector_Name
(Exp
));
4591 Make_Object_Renaming_Declaration
(Loc
,
4592 Defining_Identifier
=> Def_Id
,
4594 New_Reference_To
(Base_Type
(Etype
(Prefix
(Exp
))), Loc
),
4595 Name
=> Relocate_Node
(Prefix
(Exp
))));
4598 Res
:= New_Reference_To
(Def_Id
, Loc
);
4601 Make_Object_Renaming_Declaration
(Loc
,
4602 Defining_Identifier
=> Def_Id
,
4603 Subtype_Mark
=> New_Reference_To
(Exp_Type
, Loc
),
4604 Name
=> Relocate_Node
(Exp
)));
4608 -- If this is a packed reference, or a selected component with a
4609 -- non-standard representation, a reference to the temporary will
4610 -- be replaced by a copy of the original expression (see
4611 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
4612 -- elaborated by gigi, and is of course not to be replaced in-line
4613 -- by the expression it renames, which would defeat the purpose of
4614 -- removing the side-effect.
4616 if (Nkind
(Exp
) = N_Selected_Component
4617 or else Nkind
(Exp
) = N_Indexed_Component
)
4618 and then Has_Non_Standard_Rep
(Etype
(Prefix
(Exp
)))
4622 Set_Is_Renaming_Of_Object
(Def_Id
, False);
4625 -- Otherwise we generate a reference to the value
4628 -- Special processing for function calls that return a task. We need
4629 -- to build a declaration that will enable build-in-place expansion
4632 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
4633 -- to accommodate functions returning limited objects by reference.
4635 if Nkind
(Exp
) = N_Function_Call
4636 and then Is_Task_Type
(Etype
(Exp
))
4637 and then Ada_Version
>= Ada_05
4640 Obj
: constant Entity_Id
:=
4641 Make_Defining_Identifier
(Loc
,
4642 Chars
=> New_Internal_Name
('F'));
4647 Make_Object_Declaration
(Loc
,
4648 Defining_Identifier
=> Obj
,
4649 Object_Definition
=> New_Occurrence_Of
(Exp_Type
, Loc
),
4650 Expression
=> Relocate_Node
(Exp
));
4651 Insert_Action
(Exp
, Decl
);
4652 Set_Etype
(Obj
, Exp_Type
);
4653 Rewrite
(Exp
, New_Occurrence_Of
(Obj
, Loc
));
4658 Ref_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
4661 Make_Full_Type_Declaration
(Loc
,
4662 Defining_Identifier
=> Ref_Type
,
4664 Make_Access_To_Object_Definition
(Loc
,
4665 All_Present
=> True,
4666 Subtype_Indication
=>
4667 New_Reference_To
(Exp_Type
, Loc
)));
4670 Insert_Action
(Exp
, Ptr_Typ_Decl
);
4672 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4673 Set_Etype
(Def_Id
, Exp_Type
);
4676 Make_Explicit_Dereference
(Loc
,
4677 Prefix
=> New_Reference_To
(Def_Id
, Loc
));
4679 if Nkind
(E
) = N_Explicit_Dereference
then
4680 New_Exp
:= Relocate_Node
(Prefix
(E
));
4682 E
:= Relocate_Node
(E
);
4683 New_Exp
:= Make_Reference
(Loc
, E
);
4686 if Is_Delayed_Aggregate
(E
) then
4688 -- The expansion of nested aggregates is delayed until the
4689 -- enclosing aggregate is expanded. As aggregates are often
4690 -- qualified, the predicate applies to qualified expressions
4691 -- as well, indicating that the enclosing aggregate has not
4692 -- been expanded yet. At this point the aggregate is part of
4693 -- a stand-alone declaration, and must be fully expanded.
4695 if Nkind
(E
) = N_Qualified_Expression
then
4696 Set_Expansion_Delayed
(Expression
(E
), False);
4697 Set_Analyzed
(Expression
(E
), False);
4699 Set_Expansion_Delayed
(E
, False);
4702 Set_Analyzed
(E
, False);
4706 Make_Object_Declaration
(Loc
,
4707 Defining_Identifier
=> Def_Id
,
4708 Object_Definition
=> New_Reference_To
(Ref_Type
, Loc
),
4709 Expression
=> New_Exp
));
4712 -- Preserve the Assignment_OK flag in all copies, since at least
4713 -- one copy may be used in a context where this flag must be set
4714 -- (otherwise why would the flag be set in the first place).
4716 Set_Assignment_OK
(Res
, Assignment_OK
(Exp
));
4718 -- Finally rewrite the original expression and we are done
4721 Analyze_And_Resolve
(Exp
, Exp_Type
);
4722 Scope_Suppress
:= Svg_Suppress
;
4723 end Remove_Side_Effects
;
4725 ---------------------------
4726 -- Represented_As_Scalar --
4727 ---------------------------
4729 function Represented_As_Scalar
(T
: Entity_Id
) return Boolean is
4730 UT
: constant Entity_Id
:= Underlying_Type
(T
);
4732 return Is_Scalar_Type
(UT
)
4733 or else (Is_Bit_Packed_Array
(UT
)
4734 and then Is_Scalar_Type
(Packed_Array_Type
(UT
)));
4735 end Represented_As_Scalar
;
4737 ------------------------------------
4738 -- Safe_Unchecked_Type_Conversion --
4739 ------------------------------------
4741 -- Note: this function knows quite a bit about the exact requirements
4742 -- of Gigi with respect to unchecked type conversions, and its code
4743 -- must be coordinated with any changes in Gigi in this area.
4745 -- The above requirements should be documented in Sinfo ???
4747 function Safe_Unchecked_Type_Conversion
(Exp
: Node_Id
) return Boolean is
4752 Pexp
: constant Node_Id
:= Parent
(Exp
);
4755 -- If the expression is the RHS of an assignment or object declaration
4756 -- we are always OK because there will always be a target.
4758 -- Object renaming declarations, (generated for view conversions of
4759 -- actuals in inlined calls), like object declarations, provide an
4760 -- explicit type, and are safe as well.
4762 if (Nkind
(Pexp
) = N_Assignment_Statement
4763 and then Expression
(Pexp
) = Exp
)
4764 or else Nkind
(Pexp
) = N_Object_Declaration
4765 or else Nkind
(Pexp
) = N_Object_Renaming_Declaration
4769 -- If the expression is the prefix of an N_Selected_Component
4770 -- we should also be OK because GCC knows to look inside the
4771 -- conversion except if the type is discriminated. We assume
4772 -- that we are OK anyway if the type is not set yet or if it is
4773 -- controlled since we can't afford to introduce a temporary in
4776 elsif Nkind
(Pexp
) = N_Selected_Component
4777 and then Prefix
(Pexp
) = Exp
4779 if No
(Etype
(Pexp
)) then
4783 not Has_Discriminants
(Etype
(Pexp
))
4784 or else Is_Constrained
(Etype
(Pexp
));
4788 -- Set the output type, this comes from Etype if it is set, otherwise
4789 -- we take it from the subtype mark, which we assume was already
4792 if Present
(Etype
(Exp
)) then
4793 Otyp
:= Etype
(Exp
);
4795 Otyp
:= Entity
(Subtype_Mark
(Exp
));
4798 -- The input type always comes from the expression, and we assume
4799 -- this is indeed always analyzed, so we can simply get the Etype.
4801 Ityp
:= Etype
(Expression
(Exp
));
4803 -- Initialize alignments to unknown so far
4808 -- Replace a concurrent type by its corresponding record type
4809 -- and each type by its underlying type and do the tests on those.
4810 -- The original type may be a private type whose completion is a
4811 -- concurrent type, so find the underlying type first.
4813 if Present
(Underlying_Type
(Otyp
)) then
4814 Otyp
:= Underlying_Type
(Otyp
);
4817 if Present
(Underlying_Type
(Ityp
)) then
4818 Ityp
:= Underlying_Type
(Ityp
);
4821 if Is_Concurrent_Type
(Otyp
) then
4822 Otyp
:= Corresponding_Record_Type
(Otyp
);
4825 if Is_Concurrent_Type
(Ityp
) then
4826 Ityp
:= Corresponding_Record_Type
(Ityp
);
4829 -- If the base types are the same, we know there is no problem since
4830 -- this conversion will be a noop.
4832 if Implementation_Base_Type
(Otyp
) = Implementation_Base_Type
(Ityp
) then
4835 -- Same if this is an upwards conversion of an untagged type, and there
4836 -- are no constraints involved (could be more general???)
4838 elsif Etype
(Ityp
) = Otyp
4839 and then not Is_Tagged_Type
(Ityp
)
4840 and then not Has_Discriminants
(Ityp
)
4841 and then No
(First_Rep_Item
(Base_Type
(Ityp
)))
4845 -- If the size of output type is known at compile time, there is
4846 -- never a problem. Note that unconstrained records are considered
4847 -- to be of known size, but we can't consider them that way here,
4848 -- because we are talking about the actual size of the object.
4850 -- We also make sure that in addition to the size being known, we do
4851 -- not have a case which might generate an embarrassingly large temp
4852 -- in stack checking mode.
4854 elsif Size_Known_At_Compile_Time
(Otyp
)
4856 (not Stack_Checking_Enabled
4857 or else not May_Generate_Large_Temp
(Otyp
))
4858 and then not (Is_Record_Type
(Otyp
) and then not Is_Constrained
(Otyp
))
4862 -- If either type is tagged, then we know the alignment is OK so
4863 -- Gigi will be able to use pointer punning.
4865 elsif Is_Tagged_Type
(Otyp
) or else Is_Tagged_Type
(Ityp
) then
4868 -- If either type is a limited record type, we cannot do a copy, so
4869 -- say safe since there's nothing else we can do.
4871 elsif Is_Limited_Record
(Otyp
) or else Is_Limited_Record
(Ityp
) then
4874 -- Conversions to and from packed array types are always ignored and
4877 elsif Is_Packed_Array_Type
(Otyp
)
4878 or else Is_Packed_Array_Type
(Ityp
)
4883 -- The only other cases known to be safe is if the input type's
4884 -- alignment is known to be at least the maximum alignment for the
4885 -- target or if both alignments are known and the output type's
4886 -- alignment is no stricter than the input's. We can use the alignment
4887 -- of the component type of an array if a type is an unpacked
4890 if Present
(Alignment_Clause
(Otyp
)) then
4891 Oalign
:= Expr_Value
(Expression
(Alignment_Clause
(Otyp
)));
4893 elsif Is_Array_Type
(Otyp
)
4894 and then Present
(Alignment_Clause
(Component_Type
(Otyp
)))
4896 Oalign
:= Expr_Value
(Expression
(Alignment_Clause
4897 (Component_Type
(Otyp
))));
4900 if Present
(Alignment_Clause
(Ityp
)) then
4901 Ialign
:= Expr_Value
(Expression
(Alignment_Clause
(Ityp
)));
4903 elsif Is_Array_Type
(Ityp
)
4904 and then Present
(Alignment_Clause
(Component_Type
(Ityp
)))
4906 Ialign
:= Expr_Value
(Expression
(Alignment_Clause
4907 (Component_Type
(Ityp
))));
4910 if Ialign
/= No_Uint
and then Ialign
> Maximum_Alignment
then
4913 elsif Ialign
/= No_Uint
and then Oalign
/= No_Uint
4914 and then Ialign
<= Oalign
4918 -- Otherwise, Gigi cannot handle this and we must make a temporary
4923 end Safe_Unchecked_Type_Conversion
;
4925 ---------------------------------
4926 -- Set_Current_Value_Condition --
4927 ---------------------------------
4929 -- Note: the implementation of this procedure is very closely tied to the
4930 -- implementation of Get_Current_Value_Condition. Here we set required
4931 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
4932 -- them, so they must have a consistent view.
4934 procedure Set_Current_Value_Condition
(Cnode
: Node_Id
) is
4936 procedure Set_Entity_Current_Value
(N
: Node_Id
);
4937 -- If N is an entity reference, where the entity is of an appropriate
4938 -- kind, then set the current value of this entity to Cnode, unless
4939 -- there is already a definite value set there.
4941 procedure Set_Expression_Current_Value
(N
: Node_Id
);
4942 -- If N is of an appropriate form, sets an appropriate entry in current
4943 -- value fields of relevant entities. Multiple entities can be affected
4944 -- in the case of an AND or AND THEN.
4946 ------------------------------
4947 -- Set_Entity_Current_Value --
4948 ------------------------------
4950 procedure Set_Entity_Current_Value
(N
: Node_Id
) is
4952 if Is_Entity_Name
(N
) then
4954 Ent
: constant Entity_Id
:= Entity
(N
);
4957 -- Don't capture if not safe to do so
4959 if not Safe_To_Capture_Value
(N
, Ent
, Cond
=> True) then
4963 -- Here we have a case where the Current_Value field may
4964 -- need to be set. We set it if it is not already set to a
4965 -- compile time expression value.
4967 -- Note that this represents a decision that one condition
4968 -- blots out another previous one. That's certainly right
4969 -- if they occur at the same level. If the second one is
4970 -- nested, then the decision is neither right nor wrong (it
4971 -- would be equally OK to leave the outer one in place, or
4972 -- take the new inner one. Really we should record both, but
4973 -- our data structures are not that elaborate.
4975 if Nkind
(Current_Value
(Ent
)) not in N_Subexpr
then
4976 Set_Current_Value
(Ent
, Cnode
);
4980 end Set_Entity_Current_Value
;
4982 ----------------------------------
4983 -- Set_Expression_Current_Value --
4984 ----------------------------------
4986 procedure Set_Expression_Current_Value
(N
: Node_Id
) is
4992 -- Loop to deal with (ignore for now) any NOT operators present. The
4993 -- presence of NOT operators will be handled properly when we call
4994 -- Get_Current_Value_Condition.
4996 while Nkind
(Cond
) = N_Op_Not
loop
4997 Cond
:= Right_Opnd
(Cond
);
5000 -- For an AND or AND THEN, recursively process operands
5002 if Nkind
(Cond
) = N_Op_And
or else Nkind
(Cond
) = N_And_Then
then
5003 Set_Expression_Current_Value
(Left_Opnd
(Cond
));
5004 Set_Expression_Current_Value
(Right_Opnd
(Cond
));
5008 -- Check possible relational operator
5010 if Nkind
(Cond
) in N_Op_Compare
then
5011 if Compile_Time_Known_Value
(Right_Opnd
(Cond
)) then
5012 Set_Entity_Current_Value
(Left_Opnd
(Cond
));
5013 elsif Compile_Time_Known_Value
(Left_Opnd
(Cond
)) then
5014 Set_Entity_Current_Value
(Right_Opnd
(Cond
));
5017 -- Check possible boolean variable reference
5020 Set_Entity_Current_Value
(Cond
);
5022 end Set_Expression_Current_Value
;
5024 -- Start of processing for Set_Current_Value_Condition
5027 Set_Expression_Current_Value
(Condition
(Cnode
));
5028 end Set_Current_Value_Condition
;
5030 --------------------------
5031 -- Set_Elaboration_Flag --
5032 --------------------------
5034 procedure Set_Elaboration_Flag
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
5035 Loc
: constant Source_Ptr
:= Sloc
(N
);
5036 Ent
: constant Entity_Id
:= Elaboration_Entity
(Spec_Id
);
5040 if Present
(Ent
) then
5042 -- Nothing to do if at the compilation unit level, because in this
5043 -- case the flag is set by the binder generated elaboration routine.
5045 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5048 -- Here we do need to generate an assignment statement
5051 Check_Restriction
(No_Elaboration_Code
, N
);
5053 Make_Assignment_Statement
(Loc
,
5054 Name
=> New_Occurrence_Of
(Ent
, Loc
),
5055 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
));
5057 if Nkind
(Parent
(N
)) = N_Subunit
then
5058 Insert_After
(Corresponding_Stub
(Parent
(N
)), Asn
);
5060 Insert_After
(N
, Asn
);
5065 -- Kill current value indication. This is necessary because the
5066 -- tests of this flag are inserted out of sequence and must not
5067 -- pick up bogus indications of the wrong constant value.
5069 Set_Current_Value
(Ent
, Empty
);
5072 end Set_Elaboration_Flag
;
5074 ----------------------------
5075 -- Set_Renamed_Subprogram --
5076 ----------------------------
5078 procedure Set_Renamed_Subprogram
(N
: Node_Id
; E
: Entity_Id
) is
5080 -- If input node is an identifier, we can just reset it
5082 if Nkind
(N
) = N_Identifier
then
5083 Set_Chars
(N
, Chars
(E
));
5086 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
5090 CS
: constant Boolean := Comes_From_Source
(N
);
5092 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Chars
(E
)));
5094 Set_Comes_From_Source
(N
, CS
);
5095 Set_Analyzed
(N
, True);
5098 end Set_Renamed_Subprogram
;
5100 ----------------------------------
5101 -- Silly_Boolean_Array_Not_Test --
5102 ----------------------------------
5104 -- This procedure implements an odd and silly test. We explicitly check
5105 -- for the case where the 'First of the component type is equal to the
5106 -- 'Last of this component type, and if this is the case, we make sure
5107 -- that constraint error is raised. The reason is that the NOT is bound
5108 -- to cause CE in this case, and we will not otherwise catch it.
5110 -- Believe it or not, this was reported as a bug. Note that nearly
5111 -- always, the test will evaluate statically to False, so the code will
5112 -- be statically removed, and no extra overhead caused.
5114 procedure Silly_Boolean_Array_Not_Test
(N
: Node_Id
; T
: Entity_Id
) is
5115 Loc
: constant Source_Ptr
:= Sloc
(N
);
5116 CT
: constant Entity_Id
:= Component_Type
(T
);
5120 Make_Raise_Constraint_Error
(Loc
,
5124 Make_Attribute_Reference
(Loc
,
5125 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
5126 Attribute_Name
=> Name_First
),
5129 Make_Attribute_Reference
(Loc
,
5130 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
5131 Attribute_Name
=> Name_Last
)),
5132 Reason
=> CE_Range_Check_Failed
));
5133 end Silly_Boolean_Array_Not_Test
;
5135 ----------------------------------
5136 -- Silly_Boolean_Array_Xor_Test --
5137 ----------------------------------
5139 -- This procedure implements an odd and silly test. We explicitly check
5140 -- for the XOR case where the component type is True .. True, since this
5141 -- will raise constraint error. A special check is required since CE
5142 -- will not be required otherwise (cf Expand_Packed_Not).
5144 -- No such check is required for AND and OR, since for both these cases
5145 -- False op False = False, and True op True = True.
5147 procedure Silly_Boolean_Array_Xor_Test
(N
: Node_Id
; T
: Entity_Id
) is
5148 Loc
: constant Source_Ptr
:= Sloc
(N
);
5149 CT
: constant Entity_Id
:= Component_Type
(T
);
5150 BT
: constant Entity_Id
:= Base_Type
(CT
);
5154 Make_Raise_Constraint_Error
(Loc
,
5160 Make_Attribute_Reference
(Loc
,
5161 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
5162 Attribute_Name
=> Name_First
),
5166 New_Occurrence_Of
(Standard_True
, Loc
))),
5171 Make_Attribute_Reference
(Loc
,
5172 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
5173 Attribute_Name
=> Name_Last
),
5177 New_Occurrence_Of
(Standard_True
, Loc
)))),
5178 Reason
=> CE_Range_Check_Failed
));
5179 end Silly_Boolean_Array_Xor_Test
;
5181 --------------------------
5182 -- Target_Has_Fixed_Ops --
5183 --------------------------
5185 Integer_Sized_Small
: Ureal
;
5186 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this
5187 -- function is called (we don't want to compute it more than once!)
5189 Long_Integer_Sized_Small
: Ureal
;
5190 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
5191 -- function is called (we don't want to compute it more than once)
5193 First_Time_For_THFO
: Boolean := True;
5194 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
5196 function Target_Has_Fixed_Ops
5197 (Left_Typ
: Entity_Id
;
5198 Right_Typ
: Entity_Id
;
5199 Result_Typ
: Entity_Id
) return Boolean
5201 function Is_Fractional_Type
(Typ
: Entity_Id
) return Boolean;
5202 -- Return True if the given type is a fixed-point type with a small
5203 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
5204 -- an absolute value less than 1.0. This is currently limited
5205 -- to fixed-point types that map to Integer or Long_Integer.
5207 ------------------------
5208 -- Is_Fractional_Type --
5209 ------------------------
5211 function Is_Fractional_Type
(Typ
: Entity_Id
) return Boolean is
5213 if Esize
(Typ
) = Standard_Integer_Size
then
5214 return Small_Value
(Typ
) = Integer_Sized_Small
;
5216 elsif Esize
(Typ
) = Standard_Long_Integer_Size
then
5217 return Small_Value
(Typ
) = Long_Integer_Sized_Small
;
5222 end Is_Fractional_Type
;
5224 -- Start of processing for Target_Has_Fixed_Ops
5227 -- Return False if Fractional_Fixed_Ops_On_Target is false
5229 if not Fractional_Fixed_Ops_On_Target
then
5233 -- Here the target has Fractional_Fixed_Ops, if first time, compute
5234 -- standard constants used by Is_Fractional_Type.
5236 if First_Time_For_THFO
then
5237 First_Time_For_THFO
:= False;
5239 Integer_Sized_Small
:=
5242 Den
=> UI_From_Int
(Standard_Integer_Size
- 1),
5245 Long_Integer_Sized_Small
:=
5248 Den
=> UI_From_Int
(Standard_Long_Integer_Size
- 1),
5252 -- Return True if target supports fixed-by-fixed multiply/divide
5253 -- for fractional fixed-point types (see Is_Fractional_Type) and
5254 -- the operand and result types are equivalent fractional types.
5256 return Is_Fractional_Type
(Base_Type
(Left_Typ
))
5257 and then Is_Fractional_Type
(Base_Type
(Right_Typ
))
5258 and then Is_Fractional_Type
(Base_Type
(Result_Typ
))
5259 and then Esize
(Left_Typ
) = Esize
(Right_Typ
)
5260 and then Esize
(Left_Typ
) = Esize
(Result_Typ
);
5261 end Target_Has_Fixed_Ops
;
5263 ------------------------------------------
5264 -- Type_May_Have_Bit_Aligned_Components --
5265 ------------------------------------------
5267 function Type_May_Have_Bit_Aligned_Components
5268 (Typ
: Entity_Id
) return Boolean
5271 -- Array type, check component type
5273 if Is_Array_Type
(Typ
) then
5275 Type_May_Have_Bit_Aligned_Components
(Component_Type
(Typ
));
5277 -- Record type, check components
5279 elsif Is_Record_Type
(Typ
) then
5284 E
:= First_Component_Or_Discriminant
(Typ
);
5285 while Present
(E
) loop
5286 if Component_May_Be_Bit_Aligned
(E
)
5287 or else Type_May_Have_Bit_Aligned_Components
(Etype
(E
))
5292 Next_Component_Or_Discriminant
(E
);
5298 -- Type other than array or record is always OK
5303 end Type_May_Have_Bit_Aligned_Components
;
5305 ----------------------------
5306 -- Wrap_Cleanup_Procedure --
5307 ----------------------------
5309 procedure Wrap_Cleanup_Procedure
(N
: Node_Id
) is
5310 Loc
: constant Source_Ptr
:= Sloc
(N
);
5311 Stseq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
5312 Stmts
: constant List_Id
:= Statements
(Stseq
);
5315 if Abort_Allowed
then
5316 Prepend_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5317 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5319 end Wrap_Cleanup_Procedure
;