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
)));
1584 pragma Assert
(Present
(Prim
));
1594 function Find_Prim_Op
1596 Name
: TSS_Name_Type
) return Entity_Id
1599 Typ
: Entity_Id
:= T
;
1602 if Is_Class_Wide_Type
(Typ
) then
1603 Typ
:= Root_Type
(Typ
);
1606 Typ
:= Underlying_Type
(Typ
);
1608 Prim
:= First_Elmt
(Primitive_Operations
(Typ
));
1609 while not Is_TSS
(Node
(Prim
), Name
) loop
1611 pragma Assert
(Present
(Prim
));
1617 ----------------------------
1618 -- Find_Protection_Object --
1619 ----------------------------
1621 function Find_Protection_Object
(Scop
: Entity_Id
) return Entity_Id
is
1626 while Present
(S
) loop
1627 if (Ekind
(S
) = E_Entry
1628 or else Ekind
(S
) = E_Entry_Family
1629 or else Ekind
(S
) = E_Function
1630 or else Ekind
(S
) = E_Procedure
)
1631 and then Present
(Protection_Object
(S
))
1633 return Protection_Object
(S
);
1639 -- If we do not find a Protection object in the scope chain, then
1640 -- something has gone wrong, most likely the object was never created.
1642 raise Program_Error
;
1643 end Find_Protection_Object
;
1645 ----------------------
1646 -- Force_Evaluation --
1647 ----------------------
1649 procedure Force_Evaluation
(Exp
: Node_Id
; Name_Req
: Boolean := False) is
1651 Remove_Side_Effects
(Exp
, Name_Req
, Variable_Ref
=> True);
1652 end Force_Evaluation
;
1654 ------------------------
1655 -- Generate_Poll_Call --
1656 ------------------------
1658 procedure Generate_Poll_Call
(N
: Node_Id
) is
1660 -- No poll call if polling not active
1662 if not Polling_Required
then
1665 -- Otherwise generate require poll call
1668 Insert_Before_And_Analyze
(N
,
1669 Make_Procedure_Call_Statement
(Sloc
(N
),
1670 Name
=> New_Occurrence_Of
(RTE
(RE_Poll
), Sloc
(N
))));
1672 end Generate_Poll_Call
;
1674 ---------------------------------
1675 -- Get_Current_Value_Condition --
1676 ---------------------------------
1678 -- Note: the implementation of this procedure is very closely tied to the
1679 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
1680 -- interpret Current_Value fields set by the Set procedure, so the two
1681 -- procedures need to be closely coordinated.
1683 procedure Get_Current_Value_Condition
1688 Loc
: constant Source_Ptr
:= Sloc
(Var
);
1689 Ent
: constant Entity_Id
:= Entity
(Var
);
1691 procedure Process_Current_Value_Condition
1694 -- N is an expression which holds either True (S = True) or False (S =
1695 -- False) in the condition. This procedure digs out the expression and
1696 -- if it refers to Ent, sets Op and Val appropriately.
1698 -------------------------------------
1699 -- Process_Current_Value_Condition --
1700 -------------------------------------
1702 procedure Process_Current_Value_Condition
1713 -- Deal with NOT operators, inverting sense
1715 while Nkind
(Cond
) = N_Op_Not
loop
1716 Cond
:= Right_Opnd
(Cond
);
1720 -- Deal with AND THEN and AND cases
1722 if Nkind
(Cond
) = N_And_Then
1723 or else Nkind
(Cond
) = N_Op_And
1725 -- Don't ever try to invert a condition that is of the form
1726 -- of an AND or AND THEN (since we are not doing sufficiently
1727 -- general processing to allow this).
1729 if Sens
= False then
1735 -- Recursively process AND and AND THEN branches
1737 Process_Current_Value_Condition
(Left_Opnd
(Cond
), True);
1739 if Op
/= N_Empty
then
1743 Process_Current_Value_Condition
(Right_Opnd
(Cond
), True);
1746 -- Case of relational operator
1748 elsif Nkind
(Cond
) in N_Op_Compare
then
1751 -- Invert sense of test if inverted test
1753 if Sens
= False then
1755 when N_Op_Eq
=> Op
:= N_Op_Ne
;
1756 when N_Op_Ne
=> Op
:= N_Op_Eq
;
1757 when N_Op_Lt
=> Op
:= N_Op_Ge
;
1758 when N_Op_Gt
=> Op
:= N_Op_Le
;
1759 when N_Op_Le
=> Op
:= N_Op_Gt
;
1760 when N_Op_Ge
=> Op
:= N_Op_Lt
;
1761 when others => raise Program_Error
;
1765 -- Case of entity op value
1767 if Is_Entity_Name
(Left_Opnd
(Cond
))
1768 and then Ent
= Entity
(Left_Opnd
(Cond
))
1769 and then Compile_Time_Known_Value
(Right_Opnd
(Cond
))
1771 Val
:= Right_Opnd
(Cond
);
1773 -- Case of value op entity
1775 elsif Is_Entity_Name
(Right_Opnd
(Cond
))
1776 and then Ent
= Entity
(Right_Opnd
(Cond
))
1777 and then Compile_Time_Known_Value
(Left_Opnd
(Cond
))
1779 Val
:= Left_Opnd
(Cond
);
1781 -- We are effectively swapping operands
1784 when N_Op_Eq
=> null;
1785 when N_Op_Ne
=> null;
1786 when N_Op_Lt
=> Op
:= N_Op_Gt
;
1787 when N_Op_Gt
=> Op
:= N_Op_Lt
;
1788 when N_Op_Le
=> Op
:= N_Op_Ge
;
1789 when N_Op_Ge
=> Op
:= N_Op_Le
;
1790 when others => raise Program_Error
;
1799 -- Case of Boolean variable reference, return as though the
1800 -- reference had said var = True.
1803 if Is_Entity_Name
(Cond
)
1804 and then Ent
= Entity
(Cond
)
1806 Val
:= New_Occurrence_Of
(Standard_True
, Sloc
(Cond
));
1808 if Sens
= False then
1815 end Process_Current_Value_Condition
;
1817 -- Start of processing for Get_Current_Value_Condition
1823 -- Immediate return, nothing doing, if this is not an object
1825 if Ekind
(Ent
) not in Object_Kind
then
1829 -- Otherwise examine current value
1832 CV
: constant Node_Id
:= Current_Value
(Ent
);
1837 -- If statement. Condition is known true in THEN section, known False
1838 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
1840 if Nkind
(CV
) = N_If_Statement
then
1842 -- Before start of IF statement
1844 if Loc
< Sloc
(CV
) then
1847 -- After end of IF statement
1849 elsif Loc
>= Sloc
(CV
) + Text_Ptr
(UI_To_Int
(End_Span
(CV
))) then
1853 -- At this stage we know that we are within the IF statement, but
1854 -- unfortunately, the tree does not record the SLOC of the ELSE so
1855 -- we cannot use a simple SLOC comparison to distinguish between
1856 -- the then/else statements, so we have to climb the tree.
1863 while Parent
(N
) /= CV
loop
1866 -- If we fall off the top of the tree, then that's odd, but
1867 -- perhaps it could occur in some error situation, and the
1868 -- safest response is simply to assume that the outcome of
1869 -- the condition is unknown. No point in bombing during an
1870 -- attempt to optimize things.
1877 -- Now we have N pointing to a node whose parent is the IF
1878 -- statement in question, so now we can tell if we are within
1879 -- the THEN statements.
1881 if Is_List_Member
(N
)
1882 and then List_Containing
(N
) = Then_Statements
(CV
)
1886 -- If the variable reference does not come from source, we
1887 -- cannot reliably tell whether it appears in the else part.
1888 -- In particular, if if appears in generated code for a node
1889 -- that requires finalization, it may be attached to a list
1890 -- that has not been yet inserted into the code. For now,
1891 -- treat it as unknown.
1893 elsif not Comes_From_Source
(N
) then
1896 -- Otherwise we must be in ELSIF or ELSE part
1903 -- ELSIF part. Condition is known true within the referenced
1904 -- ELSIF, known False in any subsequent ELSIF or ELSE part, and
1905 -- unknown before the ELSE part or after the IF statement.
1907 elsif Nkind
(CV
) = N_Elsif_Part
then
1910 -- Before start of ELSIF part
1912 if Loc
< Sloc
(CV
) then
1915 -- After end of IF statement
1917 elsif Loc
>= Sloc
(Stm
) +
1918 Text_Ptr
(UI_To_Int
(End_Span
(Stm
)))
1923 -- Again we lack the SLOC of the ELSE, so we need to climb the
1924 -- tree to see if we are within the ELSIF part in question.
1931 while Parent
(N
) /= Stm
loop
1934 -- If we fall off the top of the tree, then that's odd, but
1935 -- perhaps it could occur in some error situation, and the
1936 -- safest response is simply to assume that the outcome of
1937 -- the condition is unknown. No point in bombing during an
1938 -- attempt to optimize things.
1945 -- Now we have N pointing to a node whose parent is the IF
1946 -- statement in question, so see if is the ELSIF part we want.
1947 -- the THEN statements.
1952 -- Otherwise we must be in subsequent ELSIF or ELSE part
1959 -- Iteration scheme of while loop. The condition is known to be
1960 -- true within the body of the loop.
1962 elsif Nkind
(CV
) = N_Iteration_Scheme
then
1964 Loop_Stmt
: constant Node_Id
:= Parent
(CV
);
1967 -- Before start of body of loop
1969 if Loc
< Sloc
(Loop_Stmt
) then
1972 -- After end of LOOP statement
1974 elsif Loc
>= Sloc
(End_Label
(Loop_Stmt
)) then
1977 -- We are within the body of the loop
1984 -- All other cases of Current_Value settings
1990 -- If we fall through here, then we have a reportable condition, Sens
1991 -- is True if the condition is true and False if it needs inverting.
1993 Process_Current_Value_Condition
(Condition
(CV
), Sens
);
1995 end Get_Current_Value_Condition
;
1997 ---------------------------------
1998 -- Has_Controlled_Coextensions --
1999 ---------------------------------
2001 function Has_Controlled_Coextensions
(Typ
: Entity_Id
) return Boolean is
2006 -- Only consider record types
2008 if Ekind
(Typ
) /= E_Record_Type
2009 and then Ekind
(Typ
) /= E_Record_Subtype
2014 if Has_Discriminants
(Typ
) then
2015 Discr
:= First_Discriminant
(Typ
);
2016 while Present
(Discr
) loop
2017 D_Typ
:= Etype
(Discr
);
2019 if Ekind
(D_Typ
) = E_Anonymous_Access_Type
2021 (Is_Controlled
(Directly_Designated_Type
(D_Typ
))
2023 Is_Concurrent_Type
(Directly_Designated_Type
(D_Typ
)))
2028 Next_Discriminant
(Discr
);
2033 end Has_Controlled_Coextensions
;
2035 --------------------
2036 -- Homonym_Number --
2037 --------------------
2039 function Homonym_Number
(Subp
: Entity_Id
) return Nat
is
2045 Hom
:= Homonym
(Subp
);
2046 while Present
(Hom
) loop
2047 if Scope
(Hom
) = Scope
(Subp
) then
2051 Hom
:= Homonym
(Hom
);
2057 ------------------------------
2058 -- In_Unconditional_Context --
2059 ------------------------------
2061 function In_Unconditional_Context
(Node
: Node_Id
) return Boolean is
2066 while Present
(P
) loop
2068 when N_Subprogram_Body
=>
2071 when N_If_Statement
=>
2074 when N_Loop_Statement
=>
2077 when N_Case_Statement
=>
2086 end In_Unconditional_Context
;
2092 procedure Insert_Action
(Assoc_Node
: Node_Id
; Ins_Action
: Node_Id
) is
2094 if Present
(Ins_Action
) then
2095 Insert_Actions
(Assoc_Node
, New_List
(Ins_Action
));
2099 -- Version with check(s) suppressed
2101 procedure Insert_Action
2102 (Assoc_Node
: Node_Id
; Ins_Action
: Node_Id
; Suppress
: Check_Id
)
2105 Insert_Actions
(Assoc_Node
, New_List
(Ins_Action
), Suppress
);
2108 --------------------
2109 -- Insert_Actions --
2110 --------------------
2112 procedure Insert_Actions
(Assoc_Node
: Node_Id
; Ins_Actions
: List_Id
) is
2116 Wrapped_Node
: Node_Id
:= Empty
;
2119 if No
(Ins_Actions
) or else Is_Empty_List
(Ins_Actions
) then
2123 -- Ignore insert of actions from inside default expression (or other
2124 -- similar "spec expression") in the special spec-expression analyze
2125 -- mode. Any insertions at this point have no relevance, since we are
2126 -- only doing the analyze to freeze the types of any static expressions.
2127 -- See section "Handling of Default Expressions" in the spec of package
2128 -- Sem for further details.
2130 if In_Spec_Expression
then
2134 -- If the action derives from stuff inside a record, then the actions
2135 -- are attached to the current scope, to be inserted and analyzed on
2136 -- exit from the scope. The reason for this is that we may also
2137 -- be generating freeze actions at the same time, and they must
2138 -- eventually be elaborated in the correct order.
2140 if Is_Record_Type
(Current_Scope
)
2141 and then not Is_Frozen
(Current_Scope
)
2143 if No
(Scope_Stack
.Table
2144 (Scope_Stack
.Last
).Pending_Freeze_Actions
)
2146 Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
:=
2151 Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
);
2157 -- We now intend to climb up the tree to find the right point to
2158 -- insert the actions. We start at Assoc_Node, unless this node is
2159 -- a subexpression in which case we start with its parent. We do this
2160 -- for two reasons. First it speeds things up. Second, if Assoc_Node
2161 -- is itself one of the special nodes like N_And_Then, then we assume
2162 -- that an initial request to insert actions for such a node does not
2163 -- expect the actions to get deposited in the node for later handling
2164 -- when the node is expanded, since clearly the node is being dealt
2165 -- with by the caller. Note that in the subexpression case, N is
2166 -- always the child we came from.
2168 -- N_Raise_xxx_Error is an annoying special case, it is a statement
2169 -- if it has type Standard_Void_Type, and a subexpression otherwise.
2170 -- otherwise. Procedure attribute references are also statements.
2172 if Nkind
(Assoc_Node
) in N_Subexpr
2173 and then (Nkind
(Assoc_Node
) in N_Raise_xxx_Error
2174 or else Etype
(Assoc_Node
) /= Standard_Void_Type
)
2175 and then (Nkind
(Assoc_Node
) /= N_Attribute_Reference
2177 not Is_Procedure_Attribute_Name
2178 (Attribute_Name
(Assoc_Node
)))
2180 P
:= Assoc_Node
; -- ??? does not agree with above!
2181 N
:= Parent
(Assoc_Node
);
2183 -- Non-subexpression case. Note that N is initially Empty in this
2184 -- case (N is only guaranteed Non-Empty in the subexpr case).
2191 -- Capture root of the transient scope
2193 if Scope_Is_Transient
then
2194 Wrapped_Node
:= Node_To_Be_Wrapped
;
2198 pragma Assert
(Present
(P
));
2202 -- Case of right operand of AND THEN or OR ELSE. Put the actions
2203 -- in the Actions field of the right operand. They will be moved
2204 -- out further when the AND THEN or OR ELSE operator is expanded.
2205 -- Nothing special needs to be done for the left operand since
2206 -- in that case the actions are executed unconditionally.
2208 when N_And_Then | N_Or_Else
=>
2209 if N
= Right_Opnd
(P
) then
2211 -- We are now going to either append the actions to the
2212 -- actions field of the short-circuit operation. We will
2213 -- also analyze the actions now.
2215 -- This analysis is really too early, the proper thing would
2216 -- be to just park them there now, and only analyze them if
2217 -- we find we really need them, and to it at the proper
2218 -- final insertion point. However attempting to this proved
2219 -- tricky, so for now we just kill current values before and
2220 -- after the analyze call to make sure we avoid peculiar
2221 -- optimizations from this out of order insertion.
2223 Kill_Current_Values
;
2225 if Present
(Actions
(P
)) then
2226 Insert_List_After_And_Analyze
2227 (Last
(Actions
(P
)), Ins_Actions
);
2229 Set_Actions
(P
, Ins_Actions
);
2230 Analyze_List
(Actions
(P
));
2233 Kill_Current_Values
;
2238 -- Then or Else operand of conditional expression. Add actions to
2239 -- Then_Actions or Else_Actions field as appropriate. The actions
2240 -- will be moved further out when the conditional is expanded.
2242 when N_Conditional_Expression
=>
2244 ThenX
: constant Node_Id
:= Next
(First
(Expressions
(P
)));
2245 ElseX
: constant Node_Id
:= Next
(ThenX
);
2248 -- Actions belong to the then expression, temporarily
2249 -- place them as Then_Actions of the conditional expr.
2250 -- They will be moved to the proper place later when
2251 -- the conditional expression is expanded.
2254 if Present
(Then_Actions
(P
)) then
2255 Insert_List_After_And_Analyze
2256 (Last
(Then_Actions
(P
)), Ins_Actions
);
2258 Set_Then_Actions
(P
, Ins_Actions
);
2259 Analyze_List
(Then_Actions
(P
));
2264 -- Actions belong to the else expression, temporarily
2265 -- place them as Else_Actions of the conditional expr.
2266 -- They will be moved to the proper place later when
2267 -- the conditional expression is expanded.
2269 elsif N
= ElseX
then
2270 if Present
(Else_Actions
(P
)) then
2271 Insert_List_After_And_Analyze
2272 (Last
(Else_Actions
(P
)), Ins_Actions
);
2274 Set_Else_Actions
(P
, Ins_Actions
);
2275 Analyze_List
(Else_Actions
(P
));
2280 -- Actions belong to the condition. In this case they are
2281 -- unconditionally executed, and so we can continue the
2282 -- search for the proper insert point.
2289 -- Case of appearing in the condition of a while expression or
2290 -- elsif. We insert the actions into the Condition_Actions field.
2291 -- They will be moved further out when the while loop or elsif
2294 when N_Iteration_Scheme |
2297 if N
= Condition
(P
) then
2298 if Present
(Condition_Actions
(P
)) then
2299 Insert_List_After_And_Analyze
2300 (Last
(Condition_Actions
(P
)), Ins_Actions
);
2302 Set_Condition_Actions
(P
, Ins_Actions
);
2304 -- Set the parent of the insert actions explicitly.
2305 -- This is not a syntactic field, but we need the
2306 -- parent field set, in particular so that freeze
2307 -- can understand that it is dealing with condition
2308 -- actions, and properly insert the freezing actions.
2310 Set_Parent
(Ins_Actions
, P
);
2311 Analyze_List
(Condition_Actions
(P
));
2317 -- Statements, declarations, pragmas, representation clauses
2322 N_Procedure_Call_Statement |
2323 N_Statement_Other_Than_Procedure_Call |
2329 -- Representation_Clause
2332 N_Attribute_Definition_Clause |
2333 N_Enumeration_Representation_Clause |
2334 N_Record_Representation_Clause |
2338 N_Abstract_Subprogram_Declaration |
2340 N_Exception_Declaration |
2341 N_Exception_Renaming_Declaration |
2342 N_Formal_Abstract_Subprogram_Declaration |
2343 N_Formal_Concrete_Subprogram_Declaration |
2344 N_Formal_Object_Declaration |
2345 N_Formal_Type_Declaration |
2346 N_Full_Type_Declaration |
2347 N_Function_Instantiation |
2348 N_Generic_Function_Renaming_Declaration |
2349 N_Generic_Package_Declaration |
2350 N_Generic_Package_Renaming_Declaration |
2351 N_Generic_Procedure_Renaming_Declaration |
2352 N_Generic_Subprogram_Declaration |
2353 N_Implicit_Label_Declaration |
2354 N_Incomplete_Type_Declaration |
2355 N_Number_Declaration |
2356 N_Object_Declaration |
2357 N_Object_Renaming_Declaration |
2359 N_Package_Body_Stub |
2360 N_Package_Declaration |
2361 N_Package_Instantiation |
2362 N_Package_Renaming_Declaration |
2363 N_Private_Extension_Declaration |
2364 N_Private_Type_Declaration |
2365 N_Procedure_Instantiation |
2367 N_Protected_Body_Stub |
2368 N_Protected_Type_Declaration |
2369 N_Single_Task_Declaration |
2371 N_Subprogram_Body_Stub |
2372 N_Subprogram_Declaration |
2373 N_Subprogram_Renaming_Declaration |
2374 N_Subtype_Declaration |
2377 N_Task_Type_Declaration |
2379 -- Freeze entity behaves like a declaration or statement
2383 -- Do not insert here if the item is not a list member (this
2384 -- happens for example with a triggering statement, and the
2385 -- proper approach is to insert before the entire select).
2387 if not Is_List_Member
(P
) then
2390 -- Do not insert if parent of P is an N_Component_Association
2391 -- node (i.e. we are in the context of an N_Aggregate or
2392 -- N_Extension_Aggregate node. In this case we want to insert
2393 -- before the entire aggregate.
2395 elsif Nkind
(Parent
(P
)) = N_Component_Association
then
2398 -- Do not insert if the parent of P is either an N_Variant
2399 -- node or an N_Record_Definition node, meaning in either
2400 -- case that P is a member of a component list, and that
2401 -- therefore the actions should be inserted outside the
2402 -- complete record declaration.
2404 elsif Nkind
(Parent
(P
)) = N_Variant
2405 or else Nkind
(Parent
(P
)) = N_Record_Definition
2409 -- Do not insert freeze nodes within the loop generated for
2410 -- an aggregate, because they may be elaborated too late for
2411 -- subsequent use in the back end: within a package spec the
2412 -- loop is part of the elaboration procedure and is only
2413 -- elaborated during the second pass.
2414 -- If the loop comes from source, or the entity is local to
2415 -- the loop itself it must remain within.
2417 elsif Nkind
(Parent
(P
)) = N_Loop_Statement
2418 and then not Comes_From_Source
(Parent
(P
))
2419 and then Nkind
(First
(Ins_Actions
)) = N_Freeze_Entity
2421 Scope
(Entity
(First
(Ins_Actions
))) /= Current_Scope
2425 -- Otherwise we can go ahead and do the insertion
2427 elsif P
= Wrapped_Node
then
2428 Store_Before_Actions_In_Scope
(Ins_Actions
);
2432 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
2436 -- A special case, N_Raise_xxx_Error can act either as a
2437 -- statement or a subexpression. We tell the difference
2438 -- by looking at the Etype. It is set to Standard_Void_Type
2439 -- in the statement case.
2442 N_Raise_xxx_Error
=>
2443 if Etype
(P
) = Standard_Void_Type
then
2444 if P
= Wrapped_Node
then
2445 Store_Before_Actions_In_Scope
(Ins_Actions
);
2447 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
2452 -- In the subexpression case, keep climbing
2458 -- If a component association appears within a loop created for
2459 -- an array aggregate, attach the actions to the association so
2460 -- they can be subsequently inserted within the loop. For other
2461 -- component associations insert outside of the aggregate. For
2462 -- an association that will generate a loop, its Loop_Actions
2463 -- attribute is already initialized (see exp_aggr.adb).
2465 -- The list of loop_actions can in turn generate additional ones,
2466 -- that are inserted before the associated node. If the associated
2467 -- node is outside the aggregate, the new actions are collected
2468 -- at the end of the loop actions, to respect the order in which
2469 -- they are to be elaborated.
2472 N_Component_Association
=>
2473 if Nkind
(Parent
(P
)) = N_Aggregate
2474 and then Present
(Loop_Actions
(P
))
2476 if Is_Empty_List
(Loop_Actions
(P
)) then
2477 Set_Loop_Actions
(P
, Ins_Actions
);
2478 Analyze_List
(Ins_Actions
);
2485 -- Check whether these actions were generated
2486 -- by a declaration that is part of the loop_
2487 -- actions for the component_association.
2490 while Present
(Decl
) loop
2491 exit when Parent
(Decl
) = P
2492 and then Is_List_Member
(Decl
)
2494 List_Containing
(Decl
) = Loop_Actions
(P
);
2495 Decl
:= Parent
(Decl
);
2498 if Present
(Decl
) then
2499 Insert_List_Before_And_Analyze
2500 (Decl
, Ins_Actions
);
2502 Insert_List_After_And_Analyze
2503 (Last
(Loop_Actions
(P
)), Ins_Actions
);
2514 -- Another special case, an attribute denoting a procedure call
2517 N_Attribute_Reference
=>
2518 if Is_Procedure_Attribute_Name
(Attribute_Name
(P
)) then
2519 if P
= Wrapped_Node
then
2520 Store_Before_Actions_In_Scope
(Ins_Actions
);
2522 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
2527 -- In the subexpression case, keep climbing
2533 -- For all other node types, keep climbing tree
2537 N_Accept_Alternative |
2538 N_Access_Definition |
2539 N_Access_Function_Definition |
2540 N_Access_Procedure_Definition |
2541 N_Access_To_Object_Definition |
2544 N_Case_Statement_Alternative |
2545 N_Character_Literal |
2546 N_Compilation_Unit |
2547 N_Compilation_Unit_Aux |
2548 N_Component_Clause |
2549 N_Component_Declaration |
2550 N_Component_Definition |
2552 N_Constrained_Array_Definition |
2553 N_Decimal_Fixed_Point_Definition |
2554 N_Defining_Character_Literal |
2555 N_Defining_Identifier |
2556 N_Defining_Operator_Symbol |
2557 N_Defining_Program_Unit_Name |
2558 N_Delay_Alternative |
2559 N_Delta_Constraint |
2560 N_Derived_Type_Definition |
2562 N_Digits_Constraint |
2563 N_Discriminant_Association |
2564 N_Discriminant_Specification |
2566 N_Entry_Body_Formal_Part |
2567 N_Entry_Call_Alternative |
2568 N_Entry_Declaration |
2569 N_Entry_Index_Specification |
2570 N_Enumeration_Type_Definition |
2572 N_Exception_Handler |
2574 N_Explicit_Dereference |
2575 N_Extension_Aggregate |
2576 N_Floating_Point_Definition |
2577 N_Formal_Decimal_Fixed_Point_Definition |
2578 N_Formal_Derived_Type_Definition |
2579 N_Formal_Discrete_Type_Definition |
2580 N_Formal_Floating_Point_Definition |
2581 N_Formal_Modular_Type_Definition |
2582 N_Formal_Ordinary_Fixed_Point_Definition |
2583 N_Formal_Package_Declaration |
2584 N_Formal_Private_Type_Definition |
2585 N_Formal_Signed_Integer_Type_Definition |
2587 N_Function_Specification |
2588 N_Generic_Association |
2589 N_Handled_Sequence_Of_Statements |
2592 N_Index_Or_Discriminant_Constraint |
2593 N_Indexed_Component |
2597 N_Loop_Parameter_Specification |
2599 N_Modular_Type_Definition |
2625 N_Op_Shift_Right_Arithmetic |
2629 N_Ordinary_Fixed_Point_Definition |
2631 N_Package_Specification |
2632 N_Parameter_Association |
2633 N_Parameter_Specification |
2634 N_Pop_Constraint_Error_Label |
2635 N_Pop_Program_Error_Label |
2636 N_Pop_Storage_Error_Label |
2637 N_Pragma_Argument_Association |
2638 N_Procedure_Specification |
2639 N_Protected_Definition |
2640 N_Push_Constraint_Error_Label |
2641 N_Push_Program_Error_Label |
2642 N_Push_Storage_Error_Label |
2643 N_Qualified_Expression |
2645 N_Range_Constraint |
2647 N_Real_Range_Specification |
2648 N_Record_Definition |
2650 N_Selected_Component |
2651 N_Signed_Integer_Type_Definition |
2652 N_Single_Protected_Declaration |
2656 N_Subtype_Indication |
2659 N_Terminate_Alternative |
2660 N_Triggering_Alternative |
2662 N_Unchecked_Expression |
2663 N_Unchecked_Type_Conversion |
2664 N_Unconstrained_Array_Definition |
2667 N_Use_Package_Clause |
2671 N_Validate_Unchecked_Conversion |
2678 -- Make sure that inserted actions stay in the transient scope
2680 if P
= Wrapped_Node
then
2681 Store_Before_Actions_In_Scope
(Ins_Actions
);
2685 -- If we fall through above tests, keep climbing tree
2689 if Nkind
(Parent
(N
)) = N_Subunit
then
2691 -- This is the proper body corresponding to a stub. Insertion
2692 -- must be done at the point of the stub, which is in the decla-
2693 -- rative part of the parent unit.
2695 P
:= Corresponding_Stub
(Parent
(N
));
2703 -- Version with check(s) suppressed
2705 procedure Insert_Actions
2706 (Assoc_Node
: Node_Id
;
2707 Ins_Actions
: List_Id
;
2708 Suppress
: Check_Id
)
2711 if Suppress
= All_Checks
then
2713 Svg
: constant Suppress_Array
:= Scope_Suppress
;
2715 Scope_Suppress
:= (others => True);
2716 Insert_Actions
(Assoc_Node
, Ins_Actions
);
2717 Scope_Suppress
:= Svg
;
2722 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
2724 Scope_Suppress
(Suppress
) := True;
2725 Insert_Actions
(Assoc_Node
, Ins_Actions
);
2726 Scope_Suppress
(Suppress
) := Svg
;
2731 --------------------------
2732 -- Insert_Actions_After --
2733 --------------------------
2735 procedure Insert_Actions_After
2736 (Assoc_Node
: Node_Id
;
2737 Ins_Actions
: List_Id
)
2740 if Scope_Is_Transient
2741 and then Assoc_Node
= Node_To_Be_Wrapped
2743 Store_After_Actions_In_Scope
(Ins_Actions
);
2745 Insert_List_After_And_Analyze
(Assoc_Node
, Ins_Actions
);
2747 end Insert_Actions_After
;
2749 ---------------------------------
2750 -- Insert_Library_Level_Action --
2751 ---------------------------------
2753 procedure Insert_Library_Level_Action
(N
: Node_Id
) is
2754 Aux
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Main_Unit
));
2757 Push_Scope
(Cunit_Entity
(Main_Unit
));
2758 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
2760 if No
(Actions
(Aux
)) then
2761 Set_Actions
(Aux
, New_List
(N
));
2763 Append
(N
, Actions
(Aux
));
2768 end Insert_Library_Level_Action
;
2770 ----------------------------------
2771 -- Insert_Library_Level_Actions --
2772 ----------------------------------
2774 procedure Insert_Library_Level_Actions
(L
: List_Id
) is
2775 Aux
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Main_Unit
));
2778 if Is_Non_Empty_List
(L
) then
2779 Push_Scope
(Cunit_Entity
(Main_Unit
));
2780 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
2782 if No
(Actions
(Aux
)) then
2783 Set_Actions
(Aux
, L
);
2786 Insert_List_After_And_Analyze
(Last
(Actions
(Aux
)), L
);
2791 end Insert_Library_Level_Actions
;
2793 ----------------------
2794 -- Inside_Init_Proc --
2795 ----------------------
2797 function Inside_Init_Proc
return Boolean is
2803 and then S
/= Standard_Standard
2805 if Is_Init_Proc
(S
) then
2813 end Inside_Init_Proc
;
2815 ----------------------------
2816 -- Is_All_Null_Statements --
2817 ----------------------------
2819 function Is_All_Null_Statements
(L
: List_Id
) return Boolean is
2824 while Present
(Stm
) loop
2825 if Nkind
(Stm
) /= N_Null_Statement
then
2833 end Is_All_Null_Statements
;
2835 ----------------------------------
2836 -- Is_Library_Level_Tagged_Type --
2837 ----------------------------------
2839 function Is_Library_Level_Tagged_Type
(Typ
: Entity_Id
) return Boolean is
2841 return Is_Tagged_Type
(Typ
)
2842 and then Is_Library_Level_Entity
(Typ
);
2843 end Is_Library_Level_Tagged_Type
;
2845 ----------------------------------
2846 -- Is_Possibly_Unaligned_Object --
2847 ----------------------------------
2849 function Is_Possibly_Unaligned_Object
(N
: Node_Id
) return Boolean is
2850 T
: constant Entity_Id
:= Etype
(N
);
2853 -- If renamed object, apply test to underlying object
2855 if Is_Entity_Name
(N
)
2856 and then Is_Object
(Entity
(N
))
2857 and then Present
(Renamed_Object
(Entity
(N
)))
2859 return Is_Possibly_Unaligned_Object
(Renamed_Object
(Entity
(N
)));
2862 -- Tagged and controlled types and aliased types are always aligned,
2863 -- as are concurrent types.
2866 or else Has_Controlled_Component
(T
)
2867 or else Is_Concurrent_Type
(T
)
2868 or else Is_Tagged_Type
(T
)
2869 or else Is_Controlled
(T
)
2874 -- If this is an element of a packed array, may be unaligned
2876 if Is_Ref_To_Bit_Packed_Array
(N
) then
2880 -- Case of component reference
2882 if Nkind
(N
) = N_Selected_Component
then
2884 P
: constant Node_Id
:= Prefix
(N
);
2885 C
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
2890 -- If component reference is for an array with non-static bounds,
2891 -- then it is always aligned: we can only process unaligned
2892 -- arrays with static bounds (more accurately bounds known at
2895 if Is_Array_Type
(T
)
2896 and then not Compile_Time_Known_Bounds
(T
)
2901 -- If component is aliased, it is definitely properly aligned
2903 if Is_Aliased
(C
) then
2907 -- If component is for a type implemented as a scalar, and the
2908 -- record is packed, and the component is other than the first
2909 -- component of the record, then the component may be unaligned.
2911 if Is_Packed
(Etype
(P
))
2912 and then Represented_As_Scalar
(Etype
(C
))
2913 and then First_Entity
(Scope
(C
)) /= C
2918 -- Compute maximum possible alignment for T
2920 -- If alignment is known, then that settles things
2922 if Known_Alignment
(T
) then
2923 M
:= UI_To_Int
(Alignment
(T
));
2925 -- If alignment is not known, tentatively set max alignment
2928 M
:= Ttypes
.Maximum_Alignment
;
2930 -- We can reduce this if the Esize is known since the default
2931 -- alignment will never be more than the smallest power of 2
2932 -- that does not exceed this Esize value.
2934 if Known_Esize
(T
) then
2935 S
:= UI_To_Int
(Esize
(T
));
2937 while (M
/ 2) >= S
loop
2943 -- If the component reference is for a record that has a specified
2944 -- alignment, and we either know it is too small, or cannot tell,
2945 -- then the component may be unaligned
2947 if Known_Alignment
(Etype
(P
))
2948 and then Alignment
(Etype
(P
)) < Ttypes
.Maximum_Alignment
2949 and then M
> Alignment
(Etype
(P
))
2954 -- Case of component clause present which may specify an
2955 -- unaligned position.
2957 if Present
(Component_Clause
(C
)) then
2959 -- Otherwise we can do a test to make sure that the actual
2960 -- start position in the record, and the length, are both
2961 -- consistent with the required alignment. If not, we know
2962 -- that we are unaligned.
2965 Align_In_Bits
: constant Nat
:= M
* System_Storage_Unit
;
2967 if Component_Bit_Offset
(C
) mod Align_In_Bits
/= 0
2968 or else Esize
(C
) mod Align_In_Bits
/= 0
2975 -- Otherwise, for a component reference, test prefix
2977 return Is_Possibly_Unaligned_Object
(P
);
2980 -- If not a component reference, must be aligned
2985 end Is_Possibly_Unaligned_Object
;
2987 ---------------------------------
2988 -- Is_Possibly_Unaligned_Slice --
2989 ---------------------------------
2991 function Is_Possibly_Unaligned_Slice
(N
: Node_Id
) return Boolean is
2993 -- Go to renamed object
2995 if Is_Entity_Name
(N
)
2996 and then Is_Object
(Entity
(N
))
2997 and then Present
(Renamed_Object
(Entity
(N
)))
2999 return Is_Possibly_Unaligned_Slice
(Renamed_Object
(Entity
(N
)));
3002 -- The reference must be a slice
3004 if Nkind
(N
) /= N_Slice
then
3008 -- Always assume the worst for a nested record component with a
3009 -- component clause, which gigi/gcc does not appear to handle well.
3010 -- It is not clear why this special test is needed at all ???
3012 if Nkind
(Prefix
(N
)) = N_Selected_Component
3013 and then Nkind
(Prefix
(Prefix
(N
))) = N_Selected_Component
3015 Present
(Component_Clause
(Entity
(Selector_Name
(Prefix
(N
)))))
3020 -- We only need to worry if the target has strict alignment
3022 if not Target_Strict_Alignment
then
3026 -- If it is a slice, then look at the array type being sliced
3029 Sarr
: constant Node_Id
:= Prefix
(N
);
3030 -- Prefix of the slice, i.e. the array being sliced
3032 Styp
: constant Entity_Id
:= Etype
(Prefix
(N
));
3033 -- Type of the array being sliced
3039 -- The problems arise if the array object that is being sliced
3040 -- is a component of a record or array, and we cannot guarantee
3041 -- the alignment of the array within its containing object.
3043 -- To investigate this, we look at successive prefixes to see
3044 -- if we have a worrisome indexed or selected component.
3048 -- Case of array is part of an indexed component reference
3050 if Nkind
(Pref
) = N_Indexed_Component
then
3051 Ptyp
:= Etype
(Prefix
(Pref
));
3053 -- The only problematic case is when the array is packed,
3054 -- in which case we really know nothing about the alignment
3055 -- of individual components.
3057 if Is_Bit_Packed_Array
(Ptyp
) then
3061 -- Case of array is part of a selected component reference
3063 elsif Nkind
(Pref
) = N_Selected_Component
then
3064 Ptyp
:= Etype
(Prefix
(Pref
));
3066 -- We are definitely in trouble if the record in question
3067 -- has an alignment, and either we know this alignment is
3068 -- inconsistent with the alignment of the slice, or we
3069 -- don't know what the alignment of the slice should be.
3071 if Known_Alignment
(Ptyp
)
3072 and then (Unknown_Alignment
(Styp
)
3073 or else Alignment
(Styp
) > Alignment
(Ptyp
))
3078 -- We are in potential trouble if the record type is packed.
3079 -- We could special case when we know that the array is the
3080 -- first component, but that's not such a simple case ???
3082 if Is_Packed
(Ptyp
) then
3086 -- We are in trouble if there is a component clause, and
3087 -- either we do not know the alignment of the slice, or
3088 -- the alignment of the slice is inconsistent with the
3089 -- bit position specified by the component clause.
3092 Field
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
3094 if Present
(Component_Clause
(Field
))
3096 (Unknown_Alignment
(Styp
)
3098 (Component_Bit_Offset
(Field
) mod
3099 (System_Storage_Unit
* Alignment
(Styp
))) /= 0)
3105 -- For cases other than selected or indexed components we
3106 -- know we are OK, since no issues arise over alignment.
3112 -- We processed an indexed component or selected component
3113 -- reference that looked safe, so keep checking prefixes.
3115 Pref
:= Prefix
(Pref
);
3118 end Is_Possibly_Unaligned_Slice
;
3120 --------------------------------
3121 -- Is_Ref_To_Bit_Packed_Array --
3122 --------------------------------
3124 function Is_Ref_To_Bit_Packed_Array
(N
: Node_Id
) return Boolean is
3129 if Is_Entity_Name
(N
)
3130 and then Is_Object
(Entity
(N
))
3131 and then Present
(Renamed_Object
(Entity
(N
)))
3133 return Is_Ref_To_Bit_Packed_Array
(Renamed_Object
(Entity
(N
)));
3136 if Nkind
(N
) = N_Indexed_Component
3138 Nkind
(N
) = N_Selected_Component
3140 if Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
3143 Result
:= Is_Ref_To_Bit_Packed_Array
(Prefix
(N
));
3146 if Result
and then Nkind
(N
) = N_Indexed_Component
then
3147 Expr
:= First
(Expressions
(N
));
3148 while Present
(Expr
) loop
3149 Force_Evaluation
(Expr
);
3159 end Is_Ref_To_Bit_Packed_Array
;
3161 --------------------------------
3162 -- Is_Ref_To_Bit_Packed_Slice --
3163 --------------------------------
3165 function Is_Ref_To_Bit_Packed_Slice
(N
: Node_Id
) return Boolean is
3167 if Nkind
(N
) = N_Type_Conversion
then
3168 return Is_Ref_To_Bit_Packed_Slice
(Expression
(N
));
3170 elsif Is_Entity_Name
(N
)
3171 and then Is_Object
(Entity
(N
))
3172 and then Present
(Renamed_Object
(Entity
(N
)))
3174 return Is_Ref_To_Bit_Packed_Slice
(Renamed_Object
(Entity
(N
)));
3176 elsif Nkind
(N
) = N_Slice
3177 and then Is_Bit_Packed_Array
(Etype
(Prefix
(N
)))
3181 elsif Nkind
(N
) = N_Indexed_Component
3183 Nkind
(N
) = N_Selected_Component
3185 return Is_Ref_To_Bit_Packed_Slice
(Prefix
(N
));
3190 end Is_Ref_To_Bit_Packed_Slice
;
3192 -----------------------
3193 -- Is_Renamed_Object --
3194 -----------------------
3196 function Is_Renamed_Object
(N
: Node_Id
) return Boolean is
3197 Pnod
: constant Node_Id
:= Parent
(N
);
3198 Kind
: constant Node_Kind
:= Nkind
(Pnod
);
3201 if Kind
= N_Object_Renaming_Declaration
then
3204 elsif Kind
= N_Indexed_Component
3205 or else Kind
= N_Selected_Component
3207 return Is_Renamed_Object
(Pnod
);
3212 end Is_Renamed_Object
;
3214 ----------------------------
3215 -- Is_Untagged_Derivation --
3216 ----------------------------
3218 function Is_Untagged_Derivation
(T
: Entity_Id
) return Boolean is
3220 return (not Is_Tagged_Type
(T
) and then Is_Derived_Type
(T
))
3222 (Is_Private_Type
(T
) and then Present
(Full_View
(T
))
3223 and then not Is_Tagged_Type
(Full_View
(T
))
3224 and then Is_Derived_Type
(Full_View
(T
))
3225 and then Etype
(Full_View
(T
)) /= T
);
3226 end Is_Untagged_Derivation
;
3228 ---------------------------
3229 -- Is_Volatile_Reference --
3230 ---------------------------
3232 function Is_Volatile_Reference
(N
: Node_Id
) return Boolean is
3234 if Nkind
(N
) in N_Has_Etype
3235 and then Present
(Etype
(N
))
3236 and then Treat_As_Volatile
(Etype
(N
))
3240 elsif Is_Entity_Name
(N
) then
3241 return Treat_As_Volatile
(Entity
(N
));
3243 elsif Nkind
(N
) = N_Slice
then
3244 return Is_Volatile_Reference
(Prefix
(N
));
3246 elsif Nkind_In
(N
, N_Indexed_Component
, N_Selected_Component
) then
3247 if (Is_Entity_Name
(Prefix
(N
))
3248 and then Has_Volatile_Components
(Entity
(Prefix
(N
))))
3249 or else (Present
(Etype
(Prefix
(N
)))
3250 and then Has_Volatile_Components
(Etype
(Prefix
(N
))))
3254 return Is_Volatile_Reference
(Prefix
(N
));
3260 end Is_Volatile_Reference
;
3262 --------------------
3263 -- Kill_Dead_Code --
3264 --------------------
3266 procedure Kill_Dead_Code
(N
: Node_Id
; Warn
: Boolean := False) is
3269 Remove_Warning_Messages
(N
);
3273 ("?this code can never be executed and has been deleted!", N
);
3276 -- Recurse into block statements and bodies to process declarations
3279 if Nkind
(N
) = N_Block_Statement
3280 or else Nkind
(N
) = N_Subprogram_Body
3281 or else Nkind
(N
) = N_Package_Body
3283 Kill_Dead_Code
(Declarations
(N
), False);
3284 Kill_Dead_Code
(Statements
(Handled_Statement_Sequence
(N
)));
3286 if Nkind
(N
) = N_Subprogram_Body
then
3287 Set_Is_Eliminated
(Defining_Entity
(N
));
3290 elsif Nkind
(N
) = N_Package_Declaration
then
3291 Kill_Dead_Code
(Visible_Declarations
(Specification
(N
)));
3292 Kill_Dead_Code
(Private_Declarations
(Specification
(N
)));
3294 -- ??? After this point, Delete_Tree has been called on all
3295 -- declarations in Specification (N), so references to
3296 -- entities therein look suspicious.
3299 E
: Entity_Id
:= First_Entity
(Defining_Entity
(N
));
3301 while Present
(E
) loop
3302 if Ekind
(E
) = E_Operator
then
3303 Set_Is_Eliminated
(E
);
3310 -- Recurse into composite statement to kill individual statements,
3311 -- in particular instantiations.
3313 elsif Nkind
(N
) = N_If_Statement
then
3314 Kill_Dead_Code
(Then_Statements
(N
));
3315 Kill_Dead_Code
(Elsif_Parts
(N
));
3316 Kill_Dead_Code
(Else_Statements
(N
));
3318 elsif Nkind
(N
) = N_Loop_Statement
then
3319 Kill_Dead_Code
(Statements
(N
));
3321 elsif Nkind
(N
) = N_Case_Statement
then
3325 Alt
:= First
(Alternatives
(N
));
3326 while Present
(Alt
) loop
3327 Kill_Dead_Code
(Statements
(Alt
));
3332 elsif Nkind
(N
) = N_Case_Statement_Alternative
then
3333 Kill_Dead_Code
(Statements
(N
));
3335 -- Deal with dead instances caused by deleting instantiations
3337 elsif Nkind
(N
) in N_Generic_Instantiation
then
3338 Remove_Dead_Instance
(N
);
3343 -- Case where argument is a list of nodes to be killed
3345 procedure Kill_Dead_Code
(L
: List_Id
; Warn
: Boolean := False) is
3350 if Is_Non_Empty_List
(L
) then
3352 while Present
(N
) loop
3353 Kill_Dead_Code
(N
, W
);
3360 ------------------------
3361 -- Known_Non_Negative --
3362 ------------------------
3364 function Known_Non_Negative
(Opnd
: Node_Id
) return Boolean is
3366 if Is_OK_Static_Expression
(Opnd
)
3367 and then Expr_Value
(Opnd
) >= 0
3373 Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Opnd
));
3377 Is_OK_Static_Expression
(Lo
) and then Expr_Value
(Lo
) >= 0;
3380 end Known_Non_Negative
;
3382 --------------------
3383 -- Known_Non_Null --
3384 --------------------
3386 function Known_Non_Null
(N
: Node_Id
) return Boolean is
3388 -- Checks for case where N is an entity reference
3390 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
3392 E
: constant Entity_Id
:= Entity
(N
);
3397 -- First check if we are in decisive conditional
3399 Get_Current_Value_Condition
(N
, Op
, Val
);
3401 if Known_Null
(Val
) then
3402 if Op
= N_Op_Eq
then
3404 elsif Op
= N_Op_Ne
then
3409 -- If OK to do replacement, test Is_Known_Non_Null flag
3411 if OK_To_Do_Constant_Replacement
(E
) then
3412 return Is_Known_Non_Null
(E
);
3414 -- Otherwise if not safe to do replacement, then say so
3421 -- True if access attribute
3423 elsif Nkind
(N
) = N_Attribute_Reference
3424 and then (Attribute_Name
(N
) = Name_Access
3426 Attribute_Name
(N
) = Name_Unchecked_Access
3428 Attribute_Name
(N
) = Name_Unrestricted_Access
)
3432 -- True if allocator
3434 elsif Nkind
(N
) = N_Allocator
then
3437 -- For a conversion, true if expression is known non-null
3439 elsif Nkind
(N
) = N_Type_Conversion
then
3440 return Known_Non_Null
(Expression
(N
));
3442 -- Above are all cases where the value could be determined to be
3443 -- non-null. In all other cases, we don't know, so return False.
3454 function Known_Null
(N
: Node_Id
) return Boolean is
3456 -- Checks for case where N is an entity reference
3458 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
3460 E
: constant Entity_Id
:= Entity
(N
);
3465 -- Constant null value is for sure null
3467 if Ekind
(E
) = E_Constant
3468 and then Known_Null
(Constant_Value
(E
))
3473 -- First check if we are in decisive conditional
3475 Get_Current_Value_Condition
(N
, Op
, Val
);
3477 if Known_Null
(Val
) then
3478 if Op
= N_Op_Eq
then
3480 elsif Op
= N_Op_Ne
then
3485 -- If OK to do replacement, test Is_Known_Null flag
3487 if OK_To_Do_Constant_Replacement
(E
) then
3488 return Is_Known_Null
(E
);
3490 -- Otherwise if not safe to do replacement, then say so
3497 -- True if explicit reference to null
3499 elsif Nkind
(N
) = N_Null
then
3502 -- For a conversion, true if expression is known null
3504 elsif Nkind
(N
) = N_Type_Conversion
then
3505 return Known_Null
(Expression
(N
));
3507 -- Above are all cases where the value could be determined to be null.
3508 -- In all other cases, we don't know, so return False.
3515 -----------------------------
3516 -- Make_CW_Equivalent_Type --
3517 -----------------------------
3519 -- Create a record type used as an equivalent of any member
3520 -- of the class which takes its size from exp.
3522 -- Generate the following code:
3524 -- type Equiv_T is record
3525 -- _parent : T (List of discriminant constraints taken from Exp);
3526 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
3529 -- ??? Note that this type does not guarantee same alignment as all
3532 function Make_CW_Equivalent_Type
3534 E
: Node_Id
) return Entity_Id
3536 Loc
: constant Source_Ptr
:= Sloc
(E
);
3537 Root_Typ
: constant Entity_Id
:= Root_Type
(T
);
3538 List_Def
: constant List_Id
:= Empty_List
;
3539 Comp_List
: constant List_Id
:= New_List
;
3540 Equiv_Type
: Entity_Id
;
3541 Range_Type
: Entity_Id
;
3542 Str_Type
: Entity_Id
;
3543 Constr_Root
: Entity_Id
;
3547 if not Has_Discriminants
(Root_Typ
) then
3548 Constr_Root
:= Root_Typ
;
3551 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
3553 -- subtype cstr__n is T (List of discr constraints taken from Exp)
3555 Append_To
(List_Def
,
3556 Make_Subtype_Declaration
(Loc
,
3557 Defining_Identifier
=> Constr_Root
,
3558 Subtype_Indication
=>
3559 Make_Subtype_From_Expr
(E
, Root_Typ
)));
3562 -- Generate the range subtype declaration
3564 Range_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('G'));
3566 if not Is_Interface
(Root_Typ
) then
3567 -- subtype rg__xx is
3568 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
3571 Make_Op_Subtract
(Loc
,
3573 Make_Attribute_Reference
(Loc
,
3575 OK_Convert_To
(T
, Duplicate_Subexpr_No_Checks
(E
)),
3576 Attribute_Name
=> Name_Size
),
3578 Make_Attribute_Reference
(Loc
,
3579 Prefix
=> New_Reference_To
(Constr_Root
, Loc
),
3580 Attribute_Name
=> Name_Object_Size
));
3582 -- subtype rg__xx is
3583 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
3586 Make_Attribute_Reference
(Loc
,
3588 OK_Convert_To
(T
, Duplicate_Subexpr_No_Checks
(E
)),
3589 Attribute_Name
=> Name_Size
);
3592 Set_Paren_Count
(Sizexpr
, 1);
3594 Append_To
(List_Def
,
3595 Make_Subtype_Declaration
(Loc
,
3596 Defining_Identifier
=> Range_Type
,
3597 Subtype_Indication
=>
3598 Make_Subtype_Indication
(Loc
,
3599 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
),
3600 Constraint
=> Make_Range_Constraint
(Loc
,
3603 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
3605 Make_Op_Divide
(Loc
,
3606 Left_Opnd
=> Sizexpr
,
3607 Right_Opnd
=> Make_Integer_Literal
(Loc
,
3608 Intval
=> System_Storage_Unit
)))))));
3610 -- subtype str__nn is Storage_Array (rg__x);
3612 Str_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('S'));
3613 Append_To
(List_Def
,
3614 Make_Subtype_Declaration
(Loc
,
3615 Defining_Identifier
=> Str_Type
,
3616 Subtype_Indication
=>
3617 Make_Subtype_Indication
(Loc
,
3618 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Storage_Array
), Loc
),
3620 Make_Index_Or_Discriminant_Constraint
(Loc
,
3622 New_List
(New_Reference_To
(Range_Type
, Loc
))))));
3624 -- type Equiv_T is record
3625 -- [ _parent : Tnn; ]
3629 Equiv_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('T'));
3631 -- When the target requires front-end layout, it's necessary to allow
3632 -- the equivalent type to be frozen so that layout can occur (when the
3633 -- associated class-wide subtype is frozen, the equivalent type will
3634 -- be frozen, see freeze.adb). For other targets, Gigi wants to have
3635 -- the equivalent type marked as frozen and deals with this type itself.
3636 -- In the Gigi case this will also avoid the generation of an init
3637 -- procedure for the type.
3639 if not Frontend_Layout_On_Target
then
3640 Set_Is_Frozen
(Equiv_Type
);
3643 Set_Ekind
(Equiv_Type
, E_Record_Type
);
3644 Set_Parent_Subtype
(Equiv_Type
, Constr_Root
);
3646 if not Is_Interface
(Root_Typ
) then
3647 Append_To
(Comp_List
,
3648 Make_Component_Declaration
(Loc
,
3649 Defining_Identifier
=>
3650 Make_Defining_Identifier
(Loc
, Name_uParent
),
3651 Component_Definition
=>
3652 Make_Component_Definition
(Loc
,
3653 Aliased_Present
=> False,
3654 Subtype_Indication
=> New_Reference_To
(Constr_Root
, Loc
))));
3657 Append_To
(Comp_List
,
3658 Make_Component_Declaration
(Loc
,
3659 Defining_Identifier
=>
3660 Make_Defining_Identifier
(Loc
,
3661 Chars
=> New_Internal_Name
('C')),
3662 Component_Definition
=>
3663 Make_Component_Definition
(Loc
,
3664 Aliased_Present
=> False,
3665 Subtype_Indication
=> New_Reference_To
(Str_Type
, Loc
))));
3667 Append_To
(List_Def
,
3668 Make_Full_Type_Declaration
(Loc
,
3669 Defining_Identifier
=> Equiv_Type
,
3671 Make_Record_Definition
(Loc
,
3673 Make_Component_List
(Loc
,
3674 Component_Items
=> Comp_List
,
3675 Variant_Part
=> Empty
))));
3677 -- Suppress all checks during the analysis of the expanded code
3678 -- to avoid the generation of spurious warnings under ZFP run-time.
3680 Insert_Actions
(E
, List_Def
, Suppress
=> All_Checks
);
3682 end Make_CW_Equivalent_Type
;
3684 ------------------------
3685 -- Make_Literal_Range --
3686 ------------------------
3688 function Make_Literal_Range
3690 Literal_Typ
: Entity_Id
) return Node_Id
3692 Lo
: constant Node_Id
:=
3693 New_Copy_Tree
(String_Literal_Low_Bound
(Literal_Typ
));
3694 Index
: constant Entity_Id
:= Etype
(Lo
);
3697 Length_Expr
: constant Node_Id
:=
3698 Make_Op_Subtract
(Loc
,
3700 Make_Integer_Literal
(Loc
,
3701 Intval
=> String_Literal_Length
(Literal_Typ
)),
3703 Make_Integer_Literal
(Loc
, 1));
3706 Set_Analyzed
(Lo
, False);
3708 if Is_Integer_Type
(Index
) then
3711 Left_Opnd
=> New_Copy_Tree
(Lo
),
3712 Right_Opnd
=> Length_Expr
);
3715 Make_Attribute_Reference
(Loc
,
3716 Attribute_Name
=> Name_Val
,
3717 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
3718 Expressions
=> New_List
(
3721 Make_Attribute_Reference
(Loc
,
3722 Attribute_Name
=> Name_Pos
,
3723 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
3724 Expressions
=> New_List
(New_Copy_Tree
(Lo
))),
3725 Right_Opnd
=> Length_Expr
)));
3732 end Make_Literal_Range
;
3734 ----------------------------
3735 -- Make_Subtype_From_Expr --
3736 ----------------------------
3738 -- 1. If Expr is an unconstrained array expression, creates
3739 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
3741 -- 2. If Expr is a unconstrained discriminated type expression, creates
3742 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
3744 -- 3. If Expr is class-wide, creates an implicit class wide subtype
3746 function Make_Subtype_From_Expr
3748 Unc_Typ
: Entity_Id
) return Node_Id
3750 Loc
: constant Source_Ptr
:= Sloc
(E
);
3751 List_Constr
: constant List_Id
:= New_List
;
3754 Full_Subtyp
: Entity_Id
;
3755 Priv_Subtyp
: Entity_Id
;
3760 if Is_Private_Type
(Unc_Typ
)
3761 and then Has_Unknown_Discriminants
(Unc_Typ
)
3763 -- Prepare the subtype completion, Go to base type to
3764 -- find underlying type, because the type may be a generic
3765 -- actual or an explicit subtype.
3767 Utyp
:= Underlying_Type
(Base_Type
(Unc_Typ
));
3768 Full_Subtyp
:= Make_Defining_Identifier
(Loc
,
3769 New_Internal_Name
('C'));
3771 Unchecked_Convert_To
3772 (Utyp
, Duplicate_Subexpr_No_Checks
(E
));
3773 Set_Parent
(Full_Exp
, Parent
(E
));
3776 Make_Defining_Identifier
(Loc
, New_Internal_Name
('P'));
3779 Make_Subtype_Declaration
(Loc
,
3780 Defining_Identifier
=> Full_Subtyp
,
3781 Subtype_Indication
=> Make_Subtype_From_Expr
(Full_Exp
, Utyp
)));
3783 -- Define the dummy private subtype
3785 Set_Ekind
(Priv_Subtyp
, Subtype_Kind
(Ekind
(Unc_Typ
)));
3786 Set_Etype
(Priv_Subtyp
, Base_Type
(Unc_Typ
));
3787 Set_Scope
(Priv_Subtyp
, Full_Subtyp
);
3788 Set_Is_Constrained
(Priv_Subtyp
);
3789 Set_Is_Tagged_Type
(Priv_Subtyp
, Is_Tagged_Type
(Unc_Typ
));
3790 Set_Is_Itype
(Priv_Subtyp
);
3791 Set_Associated_Node_For_Itype
(Priv_Subtyp
, E
);
3793 if Is_Tagged_Type
(Priv_Subtyp
) then
3795 (Base_Type
(Priv_Subtyp
), Class_Wide_Type
(Unc_Typ
));
3796 Set_Primitive_Operations
(Priv_Subtyp
,
3797 Primitive_Operations
(Unc_Typ
));
3800 Set_Full_View
(Priv_Subtyp
, Full_Subtyp
);
3802 return New_Reference_To
(Priv_Subtyp
, Loc
);
3804 elsif Is_Array_Type
(Unc_Typ
) then
3805 for J
in 1 .. Number_Dimensions
(Unc_Typ
) loop
3806 Append_To
(List_Constr
,
3809 Make_Attribute_Reference
(Loc
,
3810 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
3811 Attribute_Name
=> Name_First
,
3812 Expressions
=> New_List
(
3813 Make_Integer_Literal
(Loc
, J
))),
3816 Make_Attribute_Reference
(Loc
,
3817 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
3818 Attribute_Name
=> Name_Last
,
3819 Expressions
=> New_List
(
3820 Make_Integer_Literal
(Loc
, J
)))));
3823 elsif Is_Class_Wide_Type
(Unc_Typ
) then
3825 CW_Subtype
: Entity_Id
;
3826 EQ_Typ
: Entity_Id
:= Empty
;
3829 -- A class-wide equivalent type is not needed when VM_Target
3830 -- because the VM back-ends handle the class-wide object
3831 -- initialization itself (and doesn't need or want the
3832 -- additional intermediate type to handle the assignment).
3834 if Expander_Active
and then VM_Target
= No_VM
then
3835 EQ_Typ
:= Make_CW_Equivalent_Type
(Unc_Typ
, E
);
3838 CW_Subtype
:= New_Class_Wide_Subtype
(Unc_Typ
, E
);
3839 Set_Equivalent_Type
(CW_Subtype
, EQ_Typ
);
3841 if Present
(EQ_Typ
) then
3842 Set_Is_Class_Wide_Equivalent_Type
(EQ_Typ
);
3845 Set_Cloned_Subtype
(CW_Subtype
, Base_Type
(Unc_Typ
));
3847 return New_Occurrence_Of
(CW_Subtype
, Loc
);
3850 -- Indefinite record type with discriminants
3853 D
:= First_Discriminant
(Unc_Typ
);
3854 while Present
(D
) loop
3855 Append_To
(List_Constr
,
3856 Make_Selected_Component
(Loc
,
3857 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
3858 Selector_Name
=> New_Reference_To
(D
, Loc
)));
3860 Next_Discriminant
(D
);
3865 Make_Subtype_Indication
(Loc
,
3866 Subtype_Mark
=> New_Reference_To
(Unc_Typ
, Loc
),
3868 Make_Index_Or_Discriminant_Constraint
(Loc
,
3869 Constraints
=> List_Constr
));
3870 end Make_Subtype_From_Expr
;
3872 -----------------------------
3873 -- May_Generate_Large_Temp --
3874 -----------------------------
3876 -- At the current time, the only types that we return False for (i.e.
3877 -- where we decide we know they cannot generate large temps) are ones
3878 -- where we know the size is 256 bits or less at compile time, and we
3879 -- are still not doing a thorough job on arrays and records ???
3881 function May_Generate_Large_Temp
(Typ
: Entity_Id
) return Boolean is
3883 if not Size_Known_At_Compile_Time
(Typ
) then
3886 elsif Esize
(Typ
) /= 0 and then Esize
(Typ
) <= 256 then
3889 elsif Is_Array_Type
(Typ
)
3890 and then Present
(Packed_Array_Type
(Typ
))
3892 return May_Generate_Large_Temp
(Packed_Array_Type
(Typ
));
3894 -- We could do more here to find other small types ???
3899 end May_Generate_Large_Temp
;
3901 ----------------------------
3902 -- New_Class_Wide_Subtype --
3903 ----------------------------
3905 function New_Class_Wide_Subtype
3906 (CW_Typ
: Entity_Id
;
3907 N
: Node_Id
) return Entity_Id
3909 Res
: constant Entity_Id
:= Create_Itype
(E_Void
, N
);
3910 Res_Name
: constant Name_Id
:= Chars
(Res
);
3911 Res_Scope
: constant Entity_Id
:= Scope
(Res
);
3914 Copy_Node
(CW_Typ
, Res
);
3915 Set_Comes_From_Source
(Res
, False);
3916 Set_Sloc
(Res
, Sloc
(N
));
3918 Set_Associated_Node_For_Itype
(Res
, N
);
3919 Set_Is_Public
(Res
, False); -- By default, may be changed below.
3920 Set_Public_Status
(Res
);
3921 Set_Chars
(Res
, Res_Name
);
3922 Set_Scope
(Res
, Res_Scope
);
3923 Set_Ekind
(Res
, E_Class_Wide_Subtype
);
3924 Set_Next_Entity
(Res
, Empty
);
3925 Set_Etype
(Res
, Base_Type
(CW_Typ
));
3927 -- For targets where front-end layout is required, reset the Is_Frozen
3928 -- status of the subtype to False (it can be implicitly set to true
3929 -- from the copy of the class-wide type). For other targets, Gigi
3930 -- doesn't want the class-wide subtype to go through the freezing
3931 -- process (though it's unclear why that causes problems and it would
3932 -- be nice to allow freezing to occur normally for all targets ???).
3934 if Frontend_Layout_On_Target
then
3935 Set_Is_Frozen
(Res
, False);
3938 Set_Freeze_Node
(Res
, Empty
);
3940 end New_Class_Wide_Subtype
;
3942 --------------------------------
3943 -- Non_Limited_Designated_Type --
3944 ---------------------------------
3946 function Non_Limited_Designated_Type
(T
: Entity_Id
) return Entity_Id
is
3947 Desig
: constant Entity_Id
:= Designated_Type
(T
);
3949 if Ekind
(Desig
) = E_Incomplete_Type
3950 and then Present
(Non_Limited_View
(Desig
))
3952 return Non_Limited_View
(Desig
);
3956 end Non_Limited_Designated_Type
;
3958 -----------------------------------
3959 -- OK_To_Do_Constant_Replacement --
3960 -----------------------------------
3962 function OK_To_Do_Constant_Replacement
(E
: Entity_Id
) return Boolean is
3963 ES
: constant Entity_Id
:= Scope
(E
);
3967 -- Do not replace statically allocated objects, because they may be
3968 -- modified outside the current scope.
3970 if Is_Statically_Allocated
(E
) then
3973 -- Do not replace aliased or volatile objects, since we don't know what
3974 -- else might change the value.
3976 elsif Is_Aliased
(E
) or else Treat_As_Volatile
(E
) then
3979 -- Debug flag -gnatdM disconnects this optimization
3981 elsif Debug_Flag_MM
then
3984 -- Otherwise check scopes
3987 CS
:= Current_Scope
;
3990 -- If we are in right scope, replacement is safe
3995 -- Packages do not affect the determination of safety
3997 elsif Ekind
(CS
) = E_Package
then
3998 exit when CS
= Standard_Standard
;
4001 -- Blocks do not affect the determination of safety
4003 elsif Ekind
(CS
) = E_Block
then
4006 -- Loops do not affect the determination of safety. Note that we
4007 -- kill all current values on entry to a loop, so we are just
4008 -- talking about processing within a loop here.
4010 elsif Ekind
(CS
) = E_Loop
then
4013 -- Otherwise, the reference is dubious, and we cannot be sure that
4014 -- it is safe to do the replacement.
4023 end OK_To_Do_Constant_Replacement
;
4025 ------------------------------------
4026 -- Possible_Bit_Aligned_Component --
4027 ------------------------------------
4029 function Possible_Bit_Aligned_Component
(N
: Node_Id
) return Boolean is
4033 -- Case of indexed component
4035 when N_Indexed_Component
=>
4037 P
: constant Node_Id
:= Prefix
(N
);
4038 Ptyp
: constant Entity_Id
:= Etype
(P
);
4041 -- If we know the component size and it is less than 64, then
4042 -- we are definitely OK. The back end always does assignment of
4043 -- misaligned small objects correctly.
4045 if Known_Static_Component_Size
(Ptyp
)
4046 and then Component_Size
(Ptyp
) <= 64
4050 -- Otherwise, we need to test the prefix, to see if we are
4051 -- indexing from a possibly unaligned component.
4054 return Possible_Bit_Aligned_Component
(P
);
4058 -- Case of selected component
4060 when N_Selected_Component
=>
4062 P
: constant Node_Id
:= Prefix
(N
);
4063 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
4066 -- If there is no component clause, then we are in the clear
4067 -- since the back end will never misalign a large component
4068 -- unless it is forced to do so. In the clear means we need
4069 -- only the recursive test on the prefix.
4071 if Component_May_Be_Bit_Aligned
(Comp
) then
4074 return Possible_Bit_Aligned_Component
(P
);
4078 -- For a slice, test the prefix, if that is possibly misaligned,
4079 -- then for sure the slice is!
4082 return Possible_Bit_Aligned_Component
(Prefix
(N
));
4084 -- If we have none of the above, it means that we have fallen off the
4085 -- top testing prefixes recursively, and we now have a stand alone
4086 -- object, where we don't have a problem.
4092 end Possible_Bit_Aligned_Component
;
4094 -------------------------
4095 -- Remove_Side_Effects --
4096 -------------------------
4098 procedure Remove_Side_Effects
4100 Name_Req
: Boolean := False;
4101 Variable_Ref
: Boolean := False)
4103 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
4104 Exp_Type
: constant Entity_Id
:= Etype
(Exp
);
4105 Svg_Suppress
: constant Suppress_Array
:= Scope_Suppress
;
4107 Ref_Type
: Entity_Id
;
4109 Ptr_Typ_Decl
: Node_Id
;
4113 function Side_Effect_Free
(N
: Node_Id
) return Boolean;
4114 -- Determines if the tree N represents an expression that is known not
4115 -- to have side effects, and for which no processing is required.
4117 function Side_Effect_Free
(L
: List_Id
) return Boolean;
4118 -- Determines if all elements of the list L are side effect free
4120 function Safe_Prefixed_Reference
(N
: Node_Id
) return Boolean;
4121 -- The argument N is a construct where the Prefix is dereferenced if it
4122 -- is an access type and the result is a variable. The call returns True
4123 -- if the construct is side effect free (not considering side effects in
4124 -- other than the prefix which are to be tested by the caller).
4126 function Within_In_Parameter
(N
: Node_Id
) return Boolean;
4127 -- Determines if N is a subcomponent of a composite in-parameter. If so,
4128 -- N is not side-effect free when the actual is global and modifiable
4129 -- indirectly from within a subprogram, because it may be passed by
4130 -- reference. The front-end must be conservative here and assume that
4131 -- this may happen with any array or record type. On the other hand, we
4132 -- cannot create temporaries for all expressions for which this
4133 -- condition is true, for various reasons that might require clearing up
4134 -- ??? For example, discriminant references that appear out of place, or
4135 -- spurious type errors with class-wide expressions. As a result, we
4136 -- limit the transformation to loop bounds, which is so far the only
4137 -- case that requires it.
4139 -----------------------------
4140 -- Safe_Prefixed_Reference --
4141 -----------------------------
4143 function Safe_Prefixed_Reference
(N
: Node_Id
) return Boolean is
4145 -- If prefix is not side effect free, definitely not safe
4147 if not Side_Effect_Free
(Prefix
(N
)) then
4150 -- If the prefix is of an access type that is not access-to-constant,
4151 -- then this construct is a variable reference, which means it is to
4152 -- be considered to have side effects if Variable_Ref is set True
4153 -- Exception is an access to an entity that is a constant or an
4154 -- in-parameter which does not come from source, and is the result
4155 -- of a previous removal of side-effects.
4157 elsif Is_Access_Type
(Etype
(Prefix
(N
)))
4158 and then not Is_Access_Constant
(Etype
(Prefix
(N
)))
4159 and then Variable_Ref
4161 if not Is_Entity_Name
(Prefix
(N
)) then
4164 return Ekind
(Entity
(Prefix
(N
))) = E_Constant
4165 or else Ekind
(Entity
(Prefix
(N
))) = E_In_Parameter
;
4168 -- The following test is the simplest way of solving a complex
4169 -- problem uncovered by BB08-010: Side effect on loop bound that
4170 -- is a subcomponent of a global variable:
4171 -- If a loop bound is a subcomponent of a global variable, a
4172 -- modification of that variable within the loop may incorrectly
4173 -- affect the execution of the loop.
4176 (Nkind
(Parent
(Parent
(N
))) /= N_Loop_Parameter_Specification
4177 or else not Within_In_Parameter
(Prefix
(N
)))
4181 -- All other cases are side effect free
4186 end Safe_Prefixed_Reference
;
4188 ----------------------
4189 -- Side_Effect_Free --
4190 ----------------------
4192 function Side_Effect_Free
(N
: Node_Id
) return Boolean is
4194 -- Note on checks that could raise Constraint_Error. Strictly, if
4195 -- we take advantage of 11.6, these checks do not count as side
4196 -- effects. However, we would just as soon consider that they are
4197 -- side effects, since the backend CSE does not work very well on
4198 -- expressions which can raise Constraint_Error. On the other
4199 -- hand, if we do not consider them to be side effect free, then
4200 -- we get some awkward expansions in -gnato mode, resulting in
4201 -- code insertions at a point where we do not have a clear model
4202 -- for performing the insertions.
4204 -- Special handling for entity names
4206 if Is_Entity_Name
(N
) then
4208 -- If the entity is a constant, it is definitely side effect
4209 -- free. Note that the test of Is_Variable (N) below might
4210 -- be expected to catch this case, but it does not, because
4211 -- this test goes to the original tree, and we may have
4212 -- already rewritten a variable node with a constant as
4213 -- a result of an earlier Force_Evaluation call.
4215 if Ekind
(Entity
(N
)) = E_Constant
4216 or else Ekind
(Entity
(N
)) = E_In_Parameter
4220 -- Functions are not side effect free
4222 elsif Ekind
(Entity
(N
)) = E_Function
then
4225 -- Variables are considered to be a side effect if Variable_Ref
4226 -- is set or if we have a volatile reference and Name_Req is off.
4227 -- If Name_Req is True then we can't help returning a name which
4228 -- effectively allows multiple references in any case.
4230 elsif Is_Variable
(N
) then
4231 return not Variable_Ref
4232 and then (not Is_Volatile_Reference
(N
) or else Name_Req
);
4234 -- Any other entity (e.g. a subtype name) is definitely side
4241 -- A value known at compile time is always side effect free
4243 elsif Compile_Time_Known_Value
(N
) then
4246 -- A variable renaming is not side-effect free, because the
4247 -- renaming will function like a macro in the front-end in
4248 -- some cases, and an assignment can modify the component
4249 -- designated by N, so we need to create a temporary for it.
4251 elsif Is_Entity_Name
(Original_Node
(N
))
4252 and then Is_Renaming_Of_Object
(Entity
(Original_Node
(N
)))
4253 and then Ekind
(Entity
(Original_Node
(N
))) /= E_Constant
4258 -- For other than entity names and compile time known values,
4259 -- check the node kind for special processing.
4263 -- An attribute reference is side effect free if its expressions
4264 -- are side effect free and its prefix is side effect free or
4265 -- is an entity reference.
4267 -- Is this right? what about x'first where x is a variable???
4269 when N_Attribute_Reference
=>
4270 return Side_Effect_Free
(Expressions
(N
))
4271 and then Attribute_Name
(N
) /= Name_Input
4272 and then (Is_Entity_Name
(Prefix
(N
))
4273 or else Side_Effect_Free
(Prefix
(N
)));
4275 -- A binary operator is side effect free if and both operands
4276 -- are side effect free. For this purpose binary operators
4277 -- include membership tests and short circuit forms
4283 return Side_Effect_Free
(Left_Opnd
(N
))
4284 and then Side_Effect_Free
(Right_Opnd
(N
));
4286 -- An explicit dereference is side effect free only if it is
4287 -- a side effect free prefixed reference.
4289 when N_Explicit_Dereference
=>
4290 return Safe_Prefixed_Reference
(N
);
4292 -- A call to _rep_to_pos is side effect free, since we generate
4293 -- this pure function call ourselves. Moreover it is critically
4294 -- important to make this exception, since otherwise we can
4295 -- have discriminants in array components which don't look
4296 -- side effect free in the case of an array whose index type
4297 -- is an enumeration type with an enumeration rep clause.
4299 -- All other function calls are not side effect free
4301 when N_Function_Call
=>
4302 return Nkind
(Name
(N
)) = N_Identifier
4303 and then Is_TSS
(Name
(N
), TSS_Rep_To_Pos
)
4305 Side_Effect_Free
(First
(Parameter_Associations
(N
)));
4307 -- An indexed component is side effect free if it is a side
4308 -- effect free prefixed reference and all the indexing
4309 -- expressions are side effect free.
4311 when N_Indexed_Component
=>
4312 return Side_Effect_Free
(Expressions
(N
))
4313 and then Safe_Prefixed_Reference
(N
);
4315 -- A type qualification is side effect free if the expression
4316 -- is side effect free.
4318 when N_Qualified_Expression
=>
4319 return Side_Effect_Free
(Expression
(N
));
4321 -- A selected component is side effect free only if it is a
4322 -- side effect free prefixed reference. If it designates a
4323 -- component with a rep. clause it must be treated has having
4324 -- a potential side effect, because it may be modified through
4325 -- a renaming, and a subsequent use of the renaming as a macro
4326 -- will yield the wrong value. This complex interaction between
4327 -- renaming and removing side effects is a reminder that the
4328 -- latter has become a headache to maintain, and that it should
4329 -- be removed in favor of the gcc mechanism to capture values ???
4331 when N_Selected_Component
=>
4332 if Nkind
(Parent
(N
)) = N_Explicit_Dereference
4333 and then Has_Non_Standard_Rep
(Designated_Type
(Etype
(N
)))
4337 return Safe_Prefixed_Reference
(N
);
4340 -- A range is side effect free if the bounds are side effect free
4343 return Side_Effect_Free
(Low_Bound
(N
))
4344 and then Side_Effect_Free
(High_Bound
(N
));
4346 -- A slice is side effect free if it is a side effect free
4347 -- prefixed reference and the bounds are side effect free.
4350 return Side_Effect_Free
(Discrete_Range
(N
))
4351 and then Safe_Prefixed_Reference
(N
);
4353 -- A type conversion is side effect free if the expression to be
4354 -- converted is side effect free.
4356 when N_Type_Conversion
=>
4357 return Side_Effect_Free
(Expression
(N
));
4359 -- A unary operator is side effect free if the operand
4360 -- is side effect free.
4363 return Side_Effect_Free
(Right_Opnd
(N
));
4365 -- An unchecked type conversion is side effect free only if it
4366 -- is safe and its argument is side effect free.
4368 when N_Unchecked_Type_Conversion
=>
4369 return Safe_Unchecked_Type_Conversion
(N
)
4370 and then Side_Effect_Free
(Expression
(N
));
4372 -- An unchecked expression is side effect free if its expression
4373 -- is side effect free.
4375 when N_Unchecked_Expression
=>
4376 return Side_Effect_Free
(Expression
(N
));
4378 -- A literal is side effect free
4380 when N_Character_Literal |
4386 -- We consider that anything else has side effects. This is a bit
4387 -- crude, but we are pretty close for most common cases, and we
4388 -- are certainly correct (i.e. we never return True when the
4389 -- answer should be False).
4394 end Side_Effect_Free
;
4396 -- A list is side effect free if all elements of the list are
4397 -- side effect free.
4399 function Side_Effect_Free
(L
: List_Id
) return Boolean is
4403 if L
= No_List
or else L
= Error_List
then
4408 while Present
(N
) loop
4409 if not Side_Effect_Free
(N
) then
4418 end Side_Effect_Free
;
4420 -------------------------
4421 -- Within_In_Parameter --
4422 -------------------------
4424 function Within_In_Parameter
(N
: Node_Id
) return Boolean is
4426 if not Comes_From_Source
(N
) then
4429 elsif Is_Entity_Name
(N
) then
4430 return Ekind
(Entity
(N
)) = E_In_Parameter
;
4432 elsif Nkind
(N
) = N_Indexed_Component
4433 or else Nkind
(N
) = N_Selected_Component
4435 return Within_In_Parameter
(Prefix
(N
));
4440 end Within_In_Parameter
;
4442 -- Start of processing for Remove_Side_Effects
4445 -- If we are side effect free already or expansion is disabled,
4446 -- there is nothing to do.
4448 if Side_Effect_Free
(Exp
) or else not Expander_Active
then
4452 -- All this must not have any checks
4454 Scope_Suppress
:= (others => True);
4456 -- If it is a scalar type and we need to capture the value, just make
4457 -- a copy. Likewise for a function call, an attribute reference or an
4458 -- operator. And if we have a volatile reference and Name_Req is not
4459 -- set (see comments above for Side_Effect_Free).
4461 if Is_Elementary_Type
(Exp_Type
)
4462 and then (Variable_Ref
4463 or else Nkind
(Exp
) = N_Function_Call
4464 or else Nkind
(Exp
) = N_Attribute_Reference
4465 or else Nkind
(Exp
) in N_Op
4466 or else (not Name_Req
and then Is_Volatile_Reference
(Exp
)))
4468 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4469 Set_Etype
(Def_Id
, Exp_Type
);
4470 Res
:= New_Reference_To
(Def_Id
, Loc
);
4473 Make_Object_Declaration
(Loc
,
4474 Defining_Identifier
=> Def_Id
,
4475 Object_Definition
=> New_Reference_To
(Exp_Type
, Loc
),
4476 Constant_Present
=> True,
4477 Expression
=> Relocate_Node
(Exp
));
4479 Set_Assignment_OK
(E
);
4480 Insert_Action
(Exp
, E
);
4482 -- If the expression has the form v.all then we can just capture
4483 -- the pointer, and then do an explicit dereference on the result.
4485 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
4487 Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4489 Make_Explicit_Dereference
(Loc
, New_Reference_To
(Def_Id
, Loc
));
4492 Make_Object_Declaration
(Loc
,
4493 Defining_Identifier
=> Def_Id
,
4494 Object_Definition
=>
4495 New_Reference_To
(Etype
(Prefix
(Exp
)), Loc
),
4496 Constant_Present
=> True,
4497 Expression
=> Relocate_Node
(Prefix
(Exp
))));
4499 -- Similar processing for an unchecked conversion of an expression
4500 -- of the form v.all, where we want the same kind of treatment.
4502 elsif Nkind
(Exp
) = N_Unchecked_Type_Conversion
4503 and then Nkind
(Expression
(Exp
)) = N_Explicit_Dereference
4505 Remove_Side_Effects
(Expression
(Exp
), Name_Req
, Variable_Ref
);
4506 Scope_Suppress
:= Svg_Suppress
;
4509 -- If this is a type conversion, leave the type conversion and remove
4510 -- the side effects in the expression. This is important in several
4511 -- circumstances: for change of representations, and also when this is
4512 -- a view conversion to a smaller object, where gigi can end up creating
4513 -- its own temporary of the wrong size.
4515 elsif Nkind
(Exp
) = N_Type_Conversion
then
4516 Remove_Side_Effects
(Expression
(Exp
), Name_Req
, Variable_Ref
);
4517 Scope_Suppress
:= Svg_Suppress
;
4520 -- If this is an unchecked conversion that Gigi can't handle, make
4521 -- a copy or a use a renaming to capture the value.
4523 elsif Nkind
(Exp
) = N_Unchecked_Type_Conversion
4524 and then not Safe_Unchecked_Type_Conversion
(Exp
)
4526 if CW_Or_Controlled_Type
(Exp_Type
) then
4528 -- Use a renaming to capture the expression, rather than create
4529 -- a controlled temporary.
4531 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4532 Res
:= New_Reference_To
(Def_Id
, Loc
);
4535 Make_Object_Renaming_Declaration
(Loc
,
4536 Defining_Identifier
=> Def_Id
,
4537 Subtype_Mark
=> New_Reference_To
(Exp_Type
, Loc
),
4538 Name
=> Relocate_Node
(Exp
)));
4541 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4542 Set_Etype
(Def_Id
, Exp_Type
);
4543 Res
:= New_Reference_To
(Def_Id
, Loc
);
4546 Make_Object_Declaration
(Loc
,
4547 Defining_Identifier
=> Def_Id
,
4548 Object_Definition
=> New_Reference_To
(Exp_Type
, Loc
),
4549 Constant_Present
=> not Is_Variable
(Exp
),
4550 Expression
=> Relocate_Node
(Exp
));
4552 Set_Assignment_OK
(E
);
4553 Insert_Action
(Exp
, E
);
4556 -- For expressions that denote objects, we can use a renaming scheme.
4557 -- We skip using this if we have a volatile reference and we do not
4558 -- have Name_Req set true (see comments above for Side_Effect_Free).
4560 elsif Is_Object_Reference
(Exp
)
4561 and then Nkind
(Exp
) /= N_Function_Call
4562 and then (Name_Req
or else not Is_Volatile_Reference
(Exp
))
4564 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4566 if Nkind
(Exp
) = N_Selected_Component
4567 and then Nkind
(Prefix
(Exp
)) = N_Function_Call
4568 and then Is_Array_Type
(Exp_Type
)
4570 -- Avoid generating a variable-sized temporary, by generating
4571 -- the renaming declaration just for the function call. The
4572 -- transformation could be refined to apply only when the array
4573 -- component is constrained by a discriminant???
4576 Make_Selected_Component
(Loc
,
4577 Prefix
=> New_Occurrence_Of
(Def_Id
, Loc
),
4578 Selector_Name
=> Selector_Name
(Exp
));
4581 Make_Object_Renaming_Declaration
(Loc
,
4582 Defining_Identifier
=> Def_Id
,
4584 New_Reference_To
(Base_Type
(Etype
(Prefix
(Exp
))), Loc
),
4585 Name
=> Relocate_Node
(Prefix
(Exp
))));
4588 Res
:= New_Reference_To
(Def_Id
, Loc
);
4591 Make_Object_Renaming_Declaration
(Loc
,
4592 Defining_Identifier
=> Def_Id
,
4593 Subtype_Mark
=> New_Reference_To
(Exp_Type
, Loc
),
4594 Name
=> Relocate_Node
(Exp
)));
4598 -- If this is a packed reference, or a selected component with a
4599 -- non-standard representation, a reference to the temporary will
4600 -- be replaced by a copy of the original expression (see
4601 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
4602 -- elaborated by gigi, and is of course not to be replaced in-line
4603 -- by the expression it renames, which would defeat the purpose of
4604 -- removing the side-effect.
4606 if (Nkind
(Exp
) = N_Selected_Component
4607 or else Nkind
(Exp
) = N_Indexed_Component
)
4608 and then Has_Non_Standard_Rep
(Etype
(Prefix
(Exp
)))
4612 Set_Is_Renaming_Of_Object
(Def_Id
, False);
4615 -- Otherwise we generate a reference to the value
4618 -- Special processing for function calls that return a task. We need
4619 -- to build a declaration that will enable build-in-place expansion
4622 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
4623 -- to accommodate functions returning limited objects by reference.
4625 if Nkind
(Exp
) = N_Function_Call
4626 and then Is_Task_Type
(Etype
(Exp
))
4627 and then Ada_Version
>= Ada_05
4630 Obj
: constant Entity_Id
:=
4631 Make_Defining_Identifier
(Loc
,
4632 Chars
=> New_Internal_Name
('F'));
4637 Make_Object_Declaration
(Loc
,
4638 Defining_Identifier
=> Obj
,
4639 Object_Definition
=> New_Occurrence_Of
(Exp_Type
, Loc
),
4640 Expression
=> Relocate_Node
(Exp
));
4641 Insert_Action
(Exp
, Decl
);
4642 Set_Etype
(Obj
, Exp_Type
);
4643 Rewrite
(Exp
, New_Occurrence_Of
(Obj
, Loc
));
4648 Ref_Type
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('A'));
4651 Make_Full_Type_Declaration
(Loc
,
4652 Defining_Identifier
=> Ref_Type
,
4654 Make_Access_To_Object_Definition
(Loc
,
4655 All_Present
=> True,
4656 Subtype_Indication
=>
4657 New_Reference_To
(Exp_Type
, Loc
)));
4660 Insert_Action
(Exp
, Ptr_Typ_Decl
);
4662 Def_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('R'));
4663 Set_Etype
(Def_Id
, Exp_Type
);
4666 Make_Explicit_Dereference
(Loc
,
4667 Prefix
=> New_Reference_To
(Def_Id
, Loc
));
4669 if Nkind
(E
) = N_Explicit_Dereference
then
4670 New_Exp
:= Relocate_Node
(Prefix
(E
));
4672 E
:= Relocate_Node
(E
);
4673 New_Exp
:= Make_Reference
(Loc
, E
);
4676 if Is_Delayed_Aggregate
(E
) then
4678 -- The expansion of nested aggregates is delayed until the
4679 -- enclosing aggregate is expanded. As aggregates are often
4680 -- qualified, the predicate applies to qualified expressions
4681 -- as well, indicating that the enclosing aggregate has not
4682 -- been expanded yet. At this point the aggregate is part of
4683 -- a stand-alone declaration, and must be fully expanded.
4685 if Nkind
(E
) = N_Qualified_Expression
then
4686 Set_Expansion_Delayed
(Expression
(E
), False);
4687 Set_Analyzed
(Expression
(E
), False);
4689 Set_Expansion_Delayed
(E
, False);
4692 Set_Analyzed
(E
, False);
4696 Make_Object_Declaration
(Loc
,
4697 Defining_Identifier
=> Def_Id
,
4698 Object_Definition
=> New_Reference_To
(Ref_Type
, Loc
),
4699 Expression
=> New_Exp
));
4702 -- Preserve the Assignment_OK flag in all copies, since at least
4703 -- one copy may be used in a context where this flag must be set
4704 -- (otherwise why would the flag be set in the first place).
4706 Set_Assignment_OK
(Res
, Assignment_OK
(Exp
));
4708 -- Finally rewrite the original expression and we are done
4711 Analyze_And_Resolve
(Exp
, Exp_Type
);
4712 Scope_Suppress
:= Svg_Suppress
;
4713 end Remove_Side_Effects
;
4715 ---------------------------
4716 -- Represented_As_Scalar --
4717 ---------------------------
4719 function Represented_As_Scalar
(T
: Entity_Id
) return Boolean is
4720 UT
: constant Entity_Id
:= Underlying_Type
(T
);
4722 return Is_Scalar_Type
(UT
)
4723 or else (Is_Bit_Packed_Array
(UT
)
4724 and then Is_Scalar_Type
(Packed_Array_Type
(UT
)));
4725 end Represented_As_Scalar
;
4727 ------------------------------------
4728 -- Safe_Unchecked_Type_Conversion --
4729 ------------------------------------
4731 -- Note: this function knows quite a bit about the exact requirements
4732 -- of Gigi with respect to unchecked type conversions, and its code
4733 -- must be coordinated with any changes in Gigi in this area.
4735 -- The above requirements should be documented in Sinfo ???
4737 function Safe_Unchecked_Type_Conversion
(Exp
: Node_Id
) return Boolean is
4742 Pexp
: constant Node_Id
:= Parent
(Exp
);
4745 -- If the expression is the RHS of an assignment or object declaration
4746 -- we are always OK because there will always be a target.
4748 -- Object renaming declarations, (generated for view conversions of
4749 -- actuals in inlined calls), like object declarations, provide an
4750 -- explicit type, and are safe as well.
4752 if (Nkind
(Pexp
) = N_Assignment_Statement
4753 and then Expression
(Pexp
) = Exp
)
4754 or else Nkind
(Pexp
) = N_Object_Declaration
4755 or else Nkind
(Pexp
) = N_Object_Renaming_Declaration
4759 -- If the expression is the prefix of an N_Selected_Component
4760 -- we should also be OK because GCC knows to look inside the
4761 -- conversion except if the type is discriminated. We assume
4762 -- that we are OK anyway if the type is not set yet or if it is
4763 -- controlled since we can't afford to introduce a temporary in
4766 elsif Nkind
(Pexp
) = N_Selected_Component
4767 and then Prefix
(Pexp
) = Exp
4769 if No
(Etype
(Pexp
)) then
4773 not Has_Discriminants
(Etype
(Pexp
))
4774 or else Is_Constrained
(Etype
(Pexp
));
4778 -- Set the output type, this comes from Etype if it is set, otherwise
4779 -- we take it from the subtype mark, which we assume was already
4782 if Present
(Etype
(Exp
)) then
4783 Otyp
:= Etype
(Exp
);
4785 Otyp
:= Entity
(Subtype_Mark
(Exp
));
4788 -- The input type always comes from the expression, and we assume
4789 -- this is indeed always analyzed, so we can simply get the Etype.
4791 Ityp
:= Etype
(Expression
(Exp
));
4793 -- Initialize alignments to unknown so far
4798 -- Replace a concurrent type by its corresponding record type
4799 -- and each type by its underlying type and do the tests on those.
4800 -- The original type may be a private type whose completion is a
4801 -- concurrent type, so find the underlying type first.
4803 if Present
(Underlying_Type
(Otyp
)) then
4804 Otyp
:= Underlying_Type
(Otyp
);
4807 if Present
(Underlying_Type
(Ityp
)) then
4808 Ityp
:= Underlying_Type
(Ityp
);
4811 if Is_Concurrent_Type
(Otyp
) then
4812 Otyp
:= Corresponding_Record_Type
(Otyp
);
4815 if Is_Concurrent_Type
(Ityp
) then
4816 Ityp
:= Corresponding_Record_Type
(Ityp
);
4819 -- If the base types are the same, we know there is no problem since
4820 -- this conversion will be a noop.
4822 if Implementation_Base_Type
(Otyp
) = Implementation_Base_Type
(Ityp
) then
4825 -- Same if this is an upwards conversion of an untagged type, and there
4826 -- are no constraints involved (could be more general???)
4828 elsif Etype
(Ityp
) = Otyp
4829 and then not Is_Tagged_Type
(Ityp
)
4830 and then not Has_Discriminants
(Ityp
)
4831 and then No
(First_Rep_Item
(Base_Type
(Ityp
)))
4835 -- If the size of output type is known at compile time, there is
4836 -- never a problem. Note that unconstrained records are considered
4837 -- to be of known size, but we can't consider them that way here,
4838 -- because we are talking about the actual size of the object.
4840 -- We also make sure that in addition to the size being known, we do
4841 -- not have a case which might generate an embarrassingly large temp
4842 -- in stack checking mode.
4844 elsif Size_Known_At_Compile_Time
(Otyp
)
4846 (not Stack_Checking_Enabled
4847 or else not May_Generate_Large_Temp
(Otyp
))
4848 and then not (Is_Record_Type
(Otyp
) and then not Is_Constrained
(Otyp
))
4852 -- If either type is tagged, then we know the alignment is OK so
4853 -- Gigi will be able to use pointer punning.
4855 elsif Is_Tagged_Type
(Otyp
) or else Is_Tagged_Type
(Ityp
) then
4858 -- If either type is a limited record type, we cannot do a copy, so
4859 -- say safe since there's nothing else we can do.
4861 elsif Is_Limited_Record
(Otyp
) or else Is_Limited_Record
(Ityp
) then
4864 -- Conversions to and from packed array types are always ignored and
4867 elsif Is_Packed_Array_Type
(Otyp
)
4868 or else Is_Packed_Array_Type
(Ityp
)
4873 -- The only other cases known to be safe is if the input type's
4874 -- alignment is known to be at least the maximum alignment for the
4875 -- target or if both alignments are known and the output type's
4876 -- alignment is no stricter than the input's. We can use the alignment
4877 -- of the component type of an array if a type is an unpacked
4880 if Present
(Alignment_Clause
(Otyp
)) then
4881 Oalign
:= Expr_Value
(Expression
(Alignment_Clause
(Otyp
)));
4883 elsif Is_Array_Type
(Otyp
)
4884 and then Present
(Alignment_Clause
(Component_Type
(Otyp
)))
4886 Oalign
:= Expr_Value
(Expression
(Alignment_Clause
4887 (Component_Type
(Otyp
))));
4890 if Present
(Alignment_Clause
(Ityp
)) then
4891 Ialign
:= Expr_Value
(Expression
(Alignment_Clause
(Ityp
)));
4893 elsif Is_Array_Type
(Ityp
)
4894 and then Present
(Alignment_Clause
(Component_Type
(Ityp
)))
4896 Ialign
:= Expr_Value
(Expression
(Alignment_Clause
4897 (Component_Type
(Ityp
))));
4900 if Ialign
/= No_Uint
and then Ialign
> Maximum_Alignment
then
4903 elsif Ialign
/= No_Uint
and then Oalign
/= No_Uint
4904 and then Ialign
<= Oalign
4908 -- Otherwise, Gigi cannot handle this and we must make a temporary
4913 end Safe_Unchecked_Type_Conversion
;
4915 ---------------------------------
4916 -- Set_Current_Value_Condition --
4917 ---------------------------------
4919 -- Note: the implementation of this procedure is very closely tied to the
4920 -- implementation of Get_Current_Value_Condition. Here we set required
4921 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
4922 -- them, so they must have a consistent view.
4924 procedure Set_Current_Value_Condition
(Cnode
: Node_Id
) is
4926 procedure Set_Entity_Current_Value
(N
: Node_Id
);
4927 -- If N is an entity reference, where the entity is of an appropriate
4928 -- kind, then set the current value of this entity to Cnode, unless
4929 -- there is already a definite value set there.
4931 procedure Set_Expression_Current_Value
(N
: Node_Id
);
4932 -- If N is of an appropriate form, sets an appropriate entry in current
4933 -- value fields of relevant entities. Multiple entities can be affected
4934 -- in the case of an AND or AND THEN.
4936 ------------------------------
4937 -- Set_Entity_Current_Value --
4938 ------------------------------
4940 procedure Set_Entity_Current_Value
(N
: Node_Id
) is
4942 if Is_Entity_Name
(N
) then
4944 Ent
: constant Entity_Id
:= Entity
(N
);
4947 -- Don't capture if not safe to do so
4949 if not Safe_To_Capture_Value
(N
, Ent
, Cond
=> True) then
4953 -- Here we have a case where the Current_Value field may
4954 -- need to be set. We set it if it is not already set to a
4955 -- compile time expression value.
4957 -- Note that this represents a decision that one condition
4958 -- blots out another previous one. That's certainly right
4959 -- if they occur at the same level. If the second one is
4960 -- nested, then the decision is neither right nor wrong (it
4961 -- would be equally OK to leave the outer one in place, or
4962 -- take the new inner one. Really we should record both, but
4963 -- our data structures are not that elaborate.
4965 if Nkind
(Current_Value
(Ent
)) not in N_Subexpr
then
4966 Set_Current_Value
(Ent
, Cnode
);
4970 end Set_Entity_Current_Value
;
4972 ----------------------------------
4973 -- Set_Expression_Current_Value --
4974 ----------------------------------
4976 procedure Set_Expression_Current_Value
(N
: Node_Id
) is
4982 -- Loop to deal with (ignore for now) any NOT operators present. The
4983 -- presence of NOT operators will be handled properly when we call
4984 -- Get_Current_Value_Condition.
4986 while Nkind
(Cond
) = N_Op_Not
loop
4987 Cond
:= Right_Opnd
(Cond
);
4990 -- For an AND or AND THEN, recursively process operands
4992 if Nkind
(Cond
) = N_Op_And
or else Nkind
(Cond
) = N_And_Then
then
4993 Set_Expression_Current_Value
(Left_Opnd
(Cond
));
4994 Set_Expression_Current_Value
(Right_Opnd
(Cond
));
4998 -- Check possible relational operator
5000 if Nkind
(Cond
) in N_Op_Compare
then
5001 if Compile_Time_Known_Value
(Right_Opnd
(Cond
)) then
5002 Set_Entity_Current_Value
(Left_Opnd
(Cond
));
5003 elsif Compile_Time_Known_Value
(Left_Opnd
(Cond
)) then
5004 Set_Entity_Current_Value
(Right_Opnd
(Cond
));
5007 -- Check possible boolean variable reference
5010 Set_Entity_Current_Value
(Cond
);
5012 end Set_Expression_Current_Value
;
5014 -- Start of processing for Set_Current_Value_Condition
5017 Set_Expression_Current_Value
(Condition
(Cnode
));
5018 end Set_Current_Value_Condition
;
5020 --------------------------
5021 -- Set_Elaboration_Flag --
5022 --------------------------
5024 procedure Set_Elaboration_Flag
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
5025 Loc
: constant Source_Ptr
:= Sloc
(N
);
5026 Ent
: constant Entity_Id
:= Elaboration_Entity
(Spec_Id
);
5030 if Present
(Ent
) then
5032 -- Nothing to do if at the compilation unit level, because in this
5033 -- case the flag is set by the binder generated elaboration routine.
5035 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5038 -- Here we do need to generate an assignment statement
5041 Check_Restriction
(No_Elaboration_Code
, N
);
5043 Make_Assignment_Statement
(Loc
,
5044 Name
=> New_Occurrence_Of
(Ent
, Loc
),
5045 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
));
5047 if Nkind
(Parent
(N
)) = N_Subunit
then
5048 Insert_After
(Corresponding_Stub
(Parent
(N
)), Asn
);
5050 Insert_After
(N
, Asn
);
5055 -- Kill current value indication. This is necessary because the
5056 -- tests of this flag are inserted out of sequence and must not
5057 -- pick up bogus indications of the wrong constant value.
5059 Set_Current_Value
(Ent
, Empty
);
5062 end Set_Elaboration_Flag
;
5064 ----------------------------
5065 -- Set_Renamed_Subprogram --
5066 ----------------------------
5068 procedure Set_Renamed_Subprogram
(N
: Node_Id
; E
: Entity_Id
) is
5070 -- If input node is an identifier, we can just reset it
5072 if Nkind
(N
) = N_Identifier
then
5073 Set_Chars
(N
, Chars
(E
));
5076 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
5080 CS
: constant Boolean := Comes_From_Source
(N
);
5082 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Chars
(E
)));
5084 Set_Comes_From_Source
(N
, CS
);
5085 Set_Analyzed
(N
, True);
5088 end Set_Renamed_Subprogram
;
5090 ----------------------------------
5091 -- Silly_Boolean_Array_Not_Test --
5092 ----------------------------------
5094 -- This procedure implements an odd and silly test. We explicitly check
5095 -- for the case where the 'First of the component type is equal to the
5096 -- 'Last of this component type, and if this is the case, we make sure
5097 -- that constraint error is raised. The reason is that the NOT is bound
5098 -- to cause CE in this case, and we will not otherwise catch it.
5100 -- Believe it or not, this was reported as a bug. Note that nearly
5101 -- always, the test will evaluate statically to False, so the code will
5102 -- be statically removed, and no extra overhead caused.
5104 procedure Silly_Boolean_Array_Not_Test
(N
: Node_Id
; T
: Entity_Id
) is
5105 Loc
: constant Source_Ptr
:= Sloc
(N
);
5106 CT
: constant Entity_Id
:= Component_Type
(T
);
5110 Make_Raise_Constraint_Error
(Loc
,
5114 Make_Attribute_Reference
(Loc
,
5115 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
5116 Attribute_Name
=> Name_First
),
5119 Make_Attribute_Reference
(Loc
,
5120 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
5121 Attribute_Name
=> Name_Last
)),
5122 Reason
=> CE_Range_Check_Failed
));
5123 end Silly_Boolean_Array_Not_Test
;
5125 ----------------------------------
5126 -- Silly_Boolean_Array_Xor_Test --
5127 ----------------------------------
5129 -- This procedure implements an odd and silly test. We explicitly check
5130 -- for the XOR case where the component type is True .. True, since this
5131 -- will raise constraint error. A special check is required since CE
5132 -- will not be required otherwise (cf Expand_Packed_Not).
5134 -- No such check is required for AND and OR, since for both these cases
5135 -- False op False = False, and True op True = True.
5137 procedure Silly_Boolean_Array_Xor_Test
(N
: Node_Id
; T
: Entity_Id
) is
5138 Loc
: constant Source_Ptr
:= Sloc
(N
);
5139 CT
: constant Entity_Id
:= Component_Type
(T
);
5140 BT
: constant Entity_Id
:= Base_Type
(CT
);
5144 Make_Raise_Constraint_Error
(Loc
,
5150 Make_Attribute_Reference
(Loc
,
5151 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
5152 Attribute_Name
=> Name_First
),
5156 New_Occurrence_Of
(Standard_True
, Loc
))),
5161 Make_Attribute_Reference
(Loc
,
5162 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
5163 Attribute_Name
=> Name_Last
),
5167 New_Occurrence_Of
(Standard_True
, Loc
)))),
5168 Reason
=> CE_Range_Check_Failed
));
5169 end Silly_Boolean_Array_Xor_Test
;
5171 --------------------------
5172 -- Target_Has_Fixed_Ops --
5173 --------------------------
5175 Integer_Sized_Small
: Ureal
;
5176 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this
5177 -- function is called (we don't want to compute it more than once!)
5179 Long_Integer_Sized_Small
: Ureal
;
5180 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
5181 -- function is called (we don't want to compute it more than once)
5183 First_Time_For_THFO
: Boolean := True;
5184 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
5186 function Target_Has_Fixed_Ops
5187 (Left_Typ
: Entity_Id
;
5188 Right_Typ
: Entity_Id
;
5189 Result_Typ
: Entity_Id
) return Boolean
5191 function Is_Fractional_Type
(Typ
: Entity_Id
) return Boolean;
5192 -- Return True if the given type is a fixed-point type with a small
5193 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
5194 -- an absolute value less than 1.0. This is currently limited
5195 -- to fixed-point types that map to Integer or Long_Integer.
5197 ------------------------
5198 -- Is_Fractional_Type --
5199 ------------------------
5201 function Is_Fractional_Type
(Typ
: Entity_Id
) return Boolean is
5203 if Esize
(Typ
) = Standard_Integer_Size
then
5204 return Small_Value
(Typ
) = Integer_Sized_Small
;
5206 elsif Esize
(Typ
) = Standard_Long_Integer_Size
then
5207 return Small_Value
(Typ
) = Long_Integer_Sized_Small
;
5212 end Is_Fractional_Type
;
5214 -- Start of processing for Target_Has_Fixed_Ops
5217 -- Return False if Fractional_Fixed_Ops_On_Target is false
5219 if not Fractional_Fixed_Ops_On_Target
then
5223 -- Here the target has Fractional_Fixed_Ops, if first time, compute
5224 -- standard constants used by Is_Fractional_Type.
5226 if First_Time_For_THFO
then
5227 First_Time_For_THFO
:= False;
5229 Integer_Sized_Small
:=
5232 Den
=> UI_From_Int
(Standard_Integer_Size
- 1),
5235 Long_Integer_Sized_Small
:=
5238 Den
=> UI_From_Int
(Standard_Long_Integer_Size
- 1),
5242 -- Return True if target supports fixed-by-fixed multiply/divide
5243 -- for fractional fixed-point types (see Is_Fractional_Type) and
5244 -- the operand and result types are equivalent fractional types.
5246 return Is_Fractional_Type
(Base_Type
(Left_Typ
))
5247 and then Is_Fractional_Type
(Base_Type
(Right_Typ
))
5248 and then Is_Fractional_Type
(Base_Type
(Result_Typ
))
5249 and then Esize
(Left_Typ
) = Esize
(Right_Typ
)
5250 and then Esize
(Left_Typ
) = Esize
(Result_Typ
);
5251 end Target_Has_Fixed_Ops
;
5253 ------------------------------------------
5254 -- Type_May_Have_Bit_Aligned_Components --
5255 ------------------------------------------
5257 function Type_May_Have_Bit_Aligned_Components
5258 (Typ
: Entity_Id
) return Boolean
5261 -- Array type, check component type
5263 if Is_Array_Type
(Typ
) then
5265 Type_May_Have_Bit_Aligned_Components
(Component_Type
(Typ
));
5267 -- Record type, check components
5269 elsif Is_Record_Type
(Typ
) then
5274 E
:= First_Component_Or_Discriminant
(Typ
);
5275 while Present
(E
) loop
5276 if Component_May_Be_Bit_Aligned
(E
)
5277 or else Type_May_Have_Bit_Aligned_Components
(Etype
(E
))
5282 Next_Component_Or_Discriminant
(E
);
5288 -- Type other than array or record is always OK
5293 end Type_May_Have_Bit_Aligned_Components
;
5295 ----------------------------
5296 -- Wrap_Cleanup_Procedure --
5297 ----------------------------
5299 procedure Wrap_Cleanup_Procedure
(N
: Node_Id
) is
5300 Loc
: constant Source_Ptr
:= Sloc
(N
);
5301 Stseq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
5302 Stmts
: constant List_Id
:= Statements
(Stseq
);
5305 if Abort_Allowed
then
5306 Prepend_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5307 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5309 end Wrap_Cleanup_Procedure
;