1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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 Casing
; use Casing
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Elists
; use Elists
;
32 with Errout
; use Errout
;
33 with Exp_Aggr
; use Exp_Aggr
;
34 with Exp_Ch6
; use Exp_Ch6
;
35 with Exp_Ch7
; use Exp_Ch7
;
36 with Inline
; use Inline
;
37 with Itypes
; use Itypes
;
39 with Nlists
; use Nlists
;
40 with Nmake
; use Nmake
;
42 with Restrict
; use Restrict
;
43 with Rident
; use Rident
;
45 with Sem_Aux
; use Sem_Aux
;
46 with Sem_Ch8
; use Sem_Ch8
;
47 with Sem_Eval
; use Sem_Eval
;
48 with Sem_Prag
; use Sem_Prag
;
49 with Sem_Res
; use Sem_Res
;
50 with Sem_Type
; use Sem_Type
;
51 with Sem_Util
; use Sem_Util
;
52 with Snames
; use Snames
;
53 with Stand
; use Stand
;
54 with Stringt
; use Stringt
;
55 with Targparm
; use Targparm
;
56 with Tbuild
; use Tbuild
;
57 with Ttypes
; use Ttypes
;
58 with Uintp
; use Uintp
;
59 with Urealp
; use Urealp
;
60 with Validsw
; use Validsw
;
62 package body Exp_Util
is
64 -----------------------
65 -- Local Subprograms --
66 -----------------------
68 function Build_Task_Array_Image
72 Dyn
: Boolean := False) return Node_Id
;
73 -- Build function to generate the image string for a task that is an
74 -- array component, concatenating the images of each index. To avoid
75 -- storage leaks, the string is built with successive slice assignments.
76 -- The flag Dyn indicates whether this is called for the initialization
77 -- procedure of an array of tasks, or for the name of a dynamically
78 -- created task that is assigned to an indexed component.
80 function Build_Task_Image_Function
84 Res
: Entity_Id
) return Node_Id
;
85 -- Common processing for Task_Array_Image and Task_Record_Image.
86 -- Build function body that computes image.
88 procedure Build_Task_Image_Prefix
97 -- Common processing for Task_Array_Image and Task_Record_Image.
98 -- Create local variables and assign prefix of name to result string.
100 function Build_Task_Record_Image
103 Dyn
: Boolean := False) return Node_Id
;
104 -- Build function to generate the image string for a task that is a
105 -- record component. Concatenate name of variable with that of selector.
106 -- The flag Dyn indicates whether this is called for the initialization
107 -- procedure of record with task components, or for a dynamically
108 -- created task that is assigned to a selected component.
110 function Make_CW_Equivalent_Type
112 E
: Node_Id
) return Entity_Id
;
113 -- T is a class-wide type entity, E is the initial expression node that
114 -- constrains T in case such as: " X: T := E" or "new T'(E)"
115 -- This function returns the entity of the Equivalent type and inserts
116 -- on the fly the necessary declaration such as:
118 -- type anon is record
119 -- _parent : Root_Type (T); constrained with E discriminants (if any)
120 -- Extension : String (1 .. expr to match size of E);
123 -- This record is compatible with any object of the class of T thanks
124 -- to the first field and has the same size as E thanks to the second.
126 function Make_Literal_Range
128 Literal_Typ
: Entity_Id
) return Node_Id
;
129 -- Produce a Range node whose bounds are:
130 -- Low_Bound (Literal_Type) ..
131 -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
132 -- this is used for expanding declarations like X : String := "sdfgdfg";
134 -- If the index type of the target array is not integer, we generate:
135 -- Low_Bound (Literal_Type) ..
137 -- (Literal_Type'Pos (Low_Bound (Literal_Type))
138 -- + (Length (Literal_Typ) -1))
140 function Make_Non_Empty_Check
142 N
: Node_Id
) return Node_Id
;
143 -- Produce a boolean expression checking that the unidimensional array
144 -- node N is not empty.
146 function New_Class_Wide_Subtype
148 N
: Node_Id
) return Entity_Id
;
149 -- Create an implicit subtype of CW_Typ attached to node N
151 ----------------------
152 -- Adjust_Condition --
153 ----------------------
155 procedure Adjust_Condition
(N
: Node_Id
) is
162 Loc
: constant Source_Ptr
:= Sloc
(N
);
163 T
: constant Entity_Id
:= Etype
(N
);
167 -- For now, we simply ignore a call where the argument has no
168 -- type (probably case of unanalyzed condition), or has a type
169 -- that is not Boolean. This is because this is a pretty marginal
170 -- piece of functionality, and violations of these rules are
171 -- likely to be truly marginal (how much code uses Fortran Logical
172 -- as the barrier to a protected entry?) and we do not want to
173 -- blow up existing programs. We can change this to an assertion
174 -- after 3.12a is released ???
176 if No
(T
) or else not Is_Boolean_Type
(T
) then
180 -- Apply validity checking if needed
182 if Validity_Checks_On
and Validity_Check_Tests
then
186 -- Immediate return if standard boolean, the most common case,
187 -- where nothing needs to be done.
189 if Base_Type
(T
) = Standard_Boolean
then
193 -- Case of zero/non-zero semantics or non-standard enumeration
194 -- representation. In each case, we rewrite the node as:
196 -- ityp!(N) /= False'Enum_Rep
198 -- where ityp is an integer type with large enough size to hold
199 -- any value of type T.
201 if Nonzero_Is_True
(T
) or else Has_Non_Standard_Rep
(T
) then
202 if Esize
(T
) <= Esize
(Standard_Integer
) then
203 Ti
:= Standard_Integer
;
205 Ti
:= Standard_Long_Long_Integer
;
210 Left_Opnd
=> Unchecked_Convert_To
(Ti
, N
),
212 Make_Attribute_Reference
(Loc
,
213 Attribute_Name
=> Name_Enum_Rep
,
215 New_Occurrence_Of
(First_Literal
(T
), Loc
))));
216 Analyze_And_Resolve
(N
, Standard_Boolean
);
219 Rewrite
(N
, Convert_To
(Standard_Boolean
, N
));
220 Analyze_And_Resolve
(N
, Standard_Boolean
);
223 end Adjust_Condition
;
225 ------------------------
226 -- Adjust_Result_Type --
227 ------------------------
229 procedure Adjust_Result_Type
(N
: Node_Id
; T
: Entity_Id
) is
231 -- Ignore call if current type is not Standard.Boolean
233 if Etype
(N
) /= Standard_Boolean
then
237 -- If result is already of correct type, nothing to do. Note that
238 -- this will get the most common case where everything has a type
239 -- of Standard.Boolean.
241 if Base_Type
(T
) = Standard_Boolean
then
246 KP
: constant Node_Kind
:= Nkind
(Parent
(N
));
249 -- If result is to be used as a Condition in the syntax, no need
250 -- to convert it back, since if it was changed to Standard.Boolean
251 -- using Adjust_Condition, that is just fine for this usage.
253 if KP
in N_Raise_xxx_Error
or else KP
in N_Has_Condition
then
256 -- If result is an operand of another logical operation, no need
257 -- to reset its type, since Standard.Boolean is just fine, and
258 -- such operations always do Adjust_Condition on their operands.
260 elsif KP
in N_Op_Boolean
261 or else KP
in N_Short_Circuit
262 or else KP
= N_Op_Not
266 -- Otherwise we perform a conversion from the current type,
267 -- which must be Standard.Boolean, to the desired type.
271 Rewrite
(N
, Convert_To
(T
, N
));
272 Analyze_And_Resolve
(N
, T
);
276 end Adjust_Result_Type
;
278 --------------------------
279 -- Append_Freeze_Action --
280 --------------------------
282 procedure Append_Freeze_Action
(T
: Entity_Id
; N
: Node_Id
) is
286 Ensure_Freeze_Node
(T
);
287 Fnode
:= Freeze_Node
(T
);
289 if No
(Actions
(Fnode
)) then
290 Set_Actions
(Fnode
, New_List
);
293 Append
(N
, Actions
(Fnode
));
294 end Append_Freeze_Action
;
296 ---------------------------
297 -- Append_Freeze_Actions --
298 ---------------------------
300 procedure Append_Freeze_Actions
(T
: Entity_Id
; L
: List_Id
) is
301 Fnode
: constant Node_Id
:= Freeze_Node
(T
);
308 if No
(Actions
(Fnode
)) then
309 Set_Actions
(Fnode
, L
);
311 Append_List
(L
, Actions
(Fnode
));
314 end Append_Freeze_Actions
;
316 ------------------------
317 -- Build_Runtime_Call --
318 ------------------------
320 function Build_Runtime_Call
(Loc
: Source_Ptr
; RE
: RE_Id
) return Node_Id
is
322 -- If entity is not available, we can skip making the call (this avoids
323 -- junk duplicated error messages in a number of cases).
325 if not RTE_Available
(RE
) then
326 return Make_Null_Statement
(Loc
);
329 Make_Procedure_Call_Statement
(Loc
,
330 Name
=> New_Reference_To
(RTE
(RE
), Loc
));
332 end Build_Runtime_Call
;
334 ----------------------------
335 -- Build_Task_Array_Image --
336 ----------------------------
338 -- This function generates the body for a function that constructs the
339 -- image string for a task that is an array component. The function is
340 -- local to the init proc for the array type, and is called for each one
341 -- of the components. The constructed image has the form of an indexed
342 -- component, whose prefix is the outer variable of the array type.
343 -- The n-dimensional array type has known indices Index, Index2...
344 -- Id_Ref is an indexed component form created by the enclosing init proc.
345 -- Its successive indices are Val1, Val2, ... which are the loop variables
346 -- in the loops that call the individual task init proc on each component.
348 -- The generated function has the following structure:
350 -- function F return String is
351 -- Pref : string renames Task_Name;
352 -- T1 : String := Index1'Image (Val1);
354 -- Tn : String := indexn'image (Valn);
355 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
356 -- -- Len includes commas and the end parentheses.
357 -- Res : String (1..Len);
358 -- Pos : Integer := Pref'Length;
361 -- Res (1 .. Pos) := Pref;
365 -- Res (Pos .. Pos + T1'Length - 1) := T1;
366 -- Pos := Pos + T1'Length;
370 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
376 -- Needless to say, multidimensional arrays of tasks are rare enough
377 -- that the bulkiness of this code is not really a concern.
379 function Build_Task_Array_Image
383 Dyn
: Boolean := False) return Node_Id
385 Dims
: constant Nat
:= Number_Dimensions
(A_Type
);
386 -- Number of dimensions for array of tasks
388 Temps
: array (1 .. Dims
) of Entity_Id
;
389 -- Array of temporaries to hold string for each index
395 -- Total length of generated name
398 -- Running index for substring assignments
400 Pref
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
401 -- Name of enclosing variable, prefix of resulting name
404 -- String to hold result
407 -- Value of successive indices
410 -- Expression to compute total size of string
413 -- Entity for name at one index position
415 Decls
: constant List_Id
:= New_List
;
416 Stats
: constant List_Id
:= New_List
;
419 -- For a dynamic task, the name comes from the target variable.
420 -- For a static one it is a formal of the enclosing init proc.
423 Get_Name_String
(Chars
(Entity
(Prefix
(Id_Ref
))));
425 Make_Object_Declaration
(Loc
,
426 Defining_Identifier
=> Pref
,
427 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
429 Make_String_Literal
(Loc
,
430 Strval
=> String_From_Name_Buffer
)));
434 Make_Object_Renaming_Declaration
(Loc
,
435 Defining_Identifier
=> Pref
,
436 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
437 Name
=> Make_Identifier
(Loc
, Name_uTask_Name
)));
440 Indx
:= First_Index
(A_Type
);
441 Val
:= First
(Expressions
(Id_Ref
));
443 for J
in 1 .. Dims
loop
444 T
:= Make_Temporary
(Loc
, 'T');
448 Make_Object_Declaration
(Loc
,
449 Defining_Identifier
=> T
,
450 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
452 Make_Attribute_Reference
(Loc
,
453 Attribute_Name
=> Name_Image
,
454 Prefix
=> New_Occurrence_Of
(Etype
(Indx
), Loc
),
455 Expressions
=> New_List
(New_Copy_Tree
(Val
)))));
461 Sum
:= Make_Integer_Literal
(Loc
, Dims
+ 1);
467 Make_Attribute_Reference
(Loc
,
468 Attribute_Name
=> Name_Length
,
470 New_Occurrence_Of
(Pref
, Loc
),
471 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1))));
473 for J
in 1 .. Dims
loop
478 Make_Attribute_Reference
(Loc
,
479 Attribute_Name
=> Name_Length
,
481 New_Occurrence_Of
(Temps
(J
), Loc
),
482 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1))));
485 Build_Task_Image_Prefix
(Loc
, Len
, Res
, Pos
, Pref
, Sum
, Decls
, Stats
);
487 Set_Character_Literal_Name
(Char_Code
(Character'Pos ('(')));
490 Make_Assignment_Statement
(Loc
,
491 Name
=> Make_Indexed_Component
(Loc
,
492 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
493 Expressions
=> New_List
(New_Occurrence_Of
(Pos
, Loc
))),
495 Make_Character_Literal
(Loc
,
497 Char_Literal_Value
=>
498 UI_From_Int
(Character'Pos ('(')))));
501 Make_Assignment_Statement
(Loc
,
502 Name
=> New_Occurrence_Of
(Pos
, Loc
),
505 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
506 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
508 for J
in 1 .. Dims
loop
511 Make_Assignment_Statement
(Loc
,
512 Name
=> Make_Slice
(Loc
,
513 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
516 Low_Bound
=> New_Occurrence_Of
(Pos
, Loc
),
517 High_Bound
=> Make_Op_Subtract
(Loc
,
520 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
522 Make_Attribute_Reference
(Loc
,
523 Attribute_Name
=> Name_Length
,
525 New_Occurrence_Of
(Temps
(J
), Loc
),
527 New_List
(Make_Integer_Literal
(Loc
, 1)))),
528 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))),
530 Expression
=> New_Occurrence_Of
(Temps
(J
), Loc
)));
534 Make_Assignment_Statement
(Loc
,
535 Name
=> New_Occurrence_Of
(Pos
, Loc
),
538 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
540 Make_Attribute_Reference
(Loc
,
541 Attribute_Name
=> Name_Length
,
542 Prefix
=> New_Occurrence_Of
(Temps
(J
), Loc
),
544 New_List
(Make_Integer_Literal
(Loc
, 1))))));
546 Set_Character_Literal_Name
(Char_Code
(Character'Pos (',')));
549 Make_Assignment_Statement
(Loc
,
550 Name
=> Make_Indexed_Component
(Loc
,
551 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
552 Expressions
=> New_List
(New_Occurrence_Of
(Pos
, Loc
))),
554 Make_Character_Literal
(Loc
,
556 Char_Literal_Value
=>
557 UI_From_Int
(Character'Pos (',')))));
560 Make_Assignment_Statement
(Loc
,
561 Name
=> New_Occurrence_Of
(Pos
, Loc
),
564 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
565 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
569 Set_Character_Literal_Name
(Char_Code
(Character'Pos (')')));
572 Make_Assignment_Statement
(Loc
,
573 Name
=> Make_Indexed_Component
(Loc
,
574 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
575 Expressions
=> New_List
(New_Occurrence_Of
(Len
, Loc
))),
577 Make_Character_Literal
(Loc
,
579 Char_Literal_Value
=>
580 UI_From_Int
(Character'Pos (')')))));
581 return Build_Task_Image_Function
(Loc
, Decls
, Stats
, Res
);
582 end Build_Task_Array_Image
;
584 ----------------------------
585 -- Build_Task_Image_Decls --
586 ----------------------------
588 function Build_Task_Image_Decls
592 In_Init_Proc
: Boolean := False) return List_Id
594 Decls
: constant List_Id
:= New_List
;
595 T_Id
: Entity_Id
:= Empty
;
597 Expr
: Node_Id
:= Empty
;
598 Fun
: Node_Id
:= Empty
;
599 Is_Dyn
: constant Boolean :=
600 Nkind
(Parent
(Id_Ref
)) = N_Assignment_Statement
602 Nkind
(Expression
(Parent
(Id_Ref
))) = N_Allocator
;
605 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
606 -- generate a dummy declaration only.
608 if Restriction_Active
(No_Implicit_Heap_Allocations
)
609 or else Global_Discard_Names
611 T_Id
:= Make_Temporary
(Loc
, 'J');
616 Make_Object_Declaration
(Loc
,
617 Defining_Identifier
=> T_Id
,
618 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
620 Make_String_Literal
(Loc
,
621 Strval
=> String_From_Name_Buffer
)));
624 if Nkind
(Id_Ref
) = N_Identifier
625 or else Nkind
(Id_Ref
) = N_Defining_Identifier
627 -- For a simple variable, the image of the task is built from
628 -- the name of the variable. To avoid possible conflict with
629 -- the anonymous type created for a single protected object,
630 -- add a numeric suffix.
633 Make_Defining_Identifier
(Loc
,
634 New_External_Name
(Chars
(Id_Ref
), 'T', 1));
636 Get_Name_String
(Chars
(Id_Ref
));
639 Make_String_Literal
(Loc
,
640 Strval
=> String_From_Name_Buffer
);
642 elsif Nkind
(Id_Ref
) = N_Selected_Component
then
644 Make_Defining_Identifier
(Loc
,
645 New_External_Name
(Chars
(Selector_Name
(Id_Ref
)), 'T'));
646 Fun
:= Build_Task_Record_Image
(Loc
, Id_Ref
, Is_Dyn
);
648 elsif Nkind
(Id_Ref
) = N_Indexed_Component
then
650 Make_Defining_Identifier
(Loc
,
651 New_External_Name
(Chars
(A_Type
), 'N'));
653 Fun
:= Build_Task_Array_Image
(Loc
, Id_Ref
, A_Type
, Is_Dyn
);
657 if Present
(Fun
) then
659 Expr
:= Make_Function_Call
(Loc
,
660 Name
=> New_Occurrence_Of
(Defining_Entity
(Fun
), Loc
));
662 if not In_Init_Proc
and then VM_Target
= No_VM
then
663 Set_Uses_Sec_Stack
(Defining_Entity
(Fun
));
667 Decl
:= Make_Object_Declaration
(Loc
,
668 Defining_Identifier
=> T_Id
,
669 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
670 Constant_Present
=> True,
673 Append
(Decl
, Decls
);
675 end Build_Task_Image_Decls
;
677 -------------------------------
678 -- Build_Task_Image_Function --
679 -------------------------------
681 function Build_Task_Image_Function
685 Res
: Entity_Id
) return Node_Id
691 Make_Simple_Return_Statement
(Loc
,
692 Expression
=> New_Occurrence_Of
(Res
, Loc
)));
694 Spec
:= Make_Function_Specification
(Loc
,
695 Defining_Unit_Name
=> Make_Temporary
(Loc
, 'F'),
696 Result_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
));
698 -- Calls to 'Image use the secondary stack, which must be cleaned
699 -- up after the task name is built.
701 return Make_Subprogram_Body
(Loc
,
702 Specification
=> Spec
,
703 Declarations
=> Decls
,
704 Handled_Statement_Sequence
=>
705 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stats
));
706 end Build_Task_Image_Function
;
708 -----------------------------
709 -- Build_Task_Image_Prefix --
710 -----------------------------
712 procedure Build_Task_Image_Prefix
723 Len
:= Make_Temporary
(Loc
, 'L', Sum
);
726 Make_Object_Declaration
(Loc
,
727 Defining_Identifier
=> Len
,
728 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
731 Res
:= Make_Temporary
(Loc
, 'R');
734 Make_Object_Declaration
(Loc
,
735 Defining_Identifier
=> Res
,
737 Make_Subtype_Indication
(Loc
,
738 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
740 Make_Index_Or_Discriminant_Constraint
(Loc
,
744 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
745 High_Bound
=> New_Occurrence_Of
(Len
, Loc
)))))));
747 Pos
:= Make_Temporary
(Loc
, 'P');
750 Make_Object_Declaration
(Loc
,
751 Defining_Identifier
=> Pos
,
752 Object_Definition
=> New_Occurrence_Of
(Standard_Integer
, Loc
)));
754 -- Pos := Prefix'Length;
757 Make_Assignment_Statement
(Loc
,
758 Name
=> New_Occurrence_Of
(Pos
, Loc
),
760 Make_Attribute_Reference
(Loc
,
761 Attribute_Name
=> Name_Length
,
762 Prefix
=> New_Occurrence_Of
(Prefix
, Loc
),
763 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1)))));
765 -- Res (1 .. Pos) := Prefix;
768 Make_Assignment_Statement
(Loc
,
771 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
774 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
775 High_Bound
=> New_Occurrence_Of
(Pos
, Loc
))),
777 Expression
=> New_Occurrence_Of
(Prefix
, Loc
)));
780 Make_Assignment_Statement
(Loc
,
781 Name
=> New_Occurrence_Of
(Pos
, Loc
),
784 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
785 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
786 end Build_Task_Image_Prefix
;
788 -----------------------------
789 -- Build_Task_Record_Image --
790 -----------------------------
792 function Build_Task_Record_Image
795 Dyn
: Boolean := False) return Node_Id
798 -- Total length of generated name
804 -- String to hold result
806 Pref
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
807 -- Name of enclosing variable, prefix of resulting name
810 -- Expression to compute total size of string
813 -- Entity for selector name
815 Decls
: constant List_Id
:= New_List
;
816 Stats
: constant List_Id
:= New_List
;
819 -- For a dynamic task, the name comes from the target variable. For a
820 -- static one it is a formal of the enclosing init proc.
823 Get_Name_String
(Chars
(Entity
(Prefix
(Id_Ref
))));
825 Make_Object_Declaration
(Loc
,
826 Defining_Identifier
=> Pref
,
827 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
829 Make_String_Literal
(Loc
,
830 Strval
=> String_From_Name_Buffer
)));
834 Make_Object_Renaming_Declaration
(Loc
,
835 Defining_Identifier
=> Pref
,
836 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
837 Name
=> Make_Identifier
(Loc
, Name_uTask_Name
)));
840 Sel
:= Make_Temporary
(Loc
, 'S');
842 Get_Name_String
(Chars
(Selector_Name
(Id_Ref
)));
845 Make_Object_Declaration
(Loc
,
846 Defining_Identifier
=> Sel
,
847 Object_Definition
=> New_Occurrence_Of
(Standard_String
, Loc
),
849 Make_String_Literal
(Loc
,
850 Strval
=> String_From_Name_Buffer
)));
852 Sum
:= Make_Integer_Literal
(Loc
, Nat
(Name_Len
+ 1));
858 Make_Attribute_Reference
(Loc
,
859 Attribute_Name
=> Name_Length
,
861 New_Occurrence_Of
(Pref
, Loc
),
862 Expressions
=> New_List
(Make_Integer_Literal
(Loc
, 1))));
864 Build_Task_Image_Prefix
(Loc
, Len
, Res
, Pos
, Pref
, Sum
, Decls
, Stats
);
866 Set_Character_Literal_Name
(Char_Code
(Character'Pos ('.')));
871 Make_Assignment_Statement
(Loc
,
872 Name
=> Make_Indexed_Component
(Loc
,
873 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
874 Expressions
=> New_List
(New_Occurrence_Of
(Pos
, Loc
))),
876 Make_Character_Literal
(Loc
,
878 Char_Literal_Value
=>
879 UI_From_Int
(Character'Pos ('.')))));
882 Make_Assignment_Statement
(Loc
,
883 Name
=> New_Occurrence_Of
(Pos
, Loc
),
886 Left_Opnd
=> New_Occurrence_Of
(Pos
, Loc
),
887 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))));
889 -- Res (Pos .. Len) := Selector;
892 Make_Assignment_Statement
(Loc
,
893 Name
=> Make_Slice
(Loc
,
894 Prefix
=> New_Occurrence_Of
(Res
, Loc
),
897 Low_Bound
=> New_Occurrence_Of
(Pos
, Loc
),
898 High_Bound
=> New_Occurrence_Of
(Len
, Loc
))),
899 Expression
=> New_Occurrence_Of
(Sel
, Loc
)));
901 return Build_Task_Image_Function
(Loc
, Decls
, Stats
, Res
);
902 end Build_Task_Record_Image
;
904 ----------------------------------
905 -- Component_May_Be_Bit_Aligned --
906 ----------------------------------
908 function Component_May_Be_Bit_Aligned
(Comp
: Entity_Id
) return Boolean is
912 -- If no component clause, then everything is fine, since the back end
913 -- never bit-misaligns by default, even if there is a pragma Packed for
916 if No
(Comp
) or else No
(Component_Clause
(Comp
)) then
920 UT
:= Underlying_Type
(Etype
(Comp
));
922 -- It is only array and record types that cause trouble
924 if not Is_Record_Type
(UT
)
925 and then not Is_Array_Type
(UT
)
929 -- If we know that we have a small (64 bits or less) record or small
930 -- bit-packed array, then everything is fine, since the back end can
931 -- handle these cases correctly.
933 elsif Esize
(Comp
) <= 64
934 and then (Is_Record_Type
(UT
)
935 or else Is_Bit_Packed_Array
(UT
))
939 -- Otherwise if the component is not byte aligned, we know we have the
940 -- nasty unaligned case.
942 elsif Normalized_First_Bit
(Comp
) /= Uint_0
943 or else Esize
(Comp
) mod System_Storage_Unit
/= Uint_0
947 -- If we are large and byte aligned, then OK at this level
952 end Component_May_Be_Bit_Aligned
;
954 -----------------------------------
955 -- Corresponding_Runtime_Package --
956 -----------------------------------
958 function Corresponding_Runtime_Package
(Typ
: Entity_Id
) return RTU_Id
is
959 Pkg_Id
: RTU_Id
:= RTU_Null
;
962 pragma Assert
(Is_Concurrent_Type
(Typ
));
964 if Ekind
(Typ
) in Protected_Kind
then
966 or else Has_Interrupt_Handler
(Typ
)
967 or else (Has_Attach_Handler
(Typ
)
968 and then not Restricted_Profile
)
970 -- A protected type without entries that covers an interface and
971 -- overrides the abstract routines with protected procedures is
972 -- considered equivalent to a protected type with entries in the
973 -- context of dispatching select statements. It is sufficient to
974 -- check for the presence of an interface list in the declaration
975 -- node to recognize this case.
977 or else Present
(Interface_List
(Parent
(Typ
)))
980 or else Restriction_Active
(No_Entry_Queue
) = False
981 or else Number_Entries
(Typ
) > 1
982 or else (Has_Attach_Handler
(Typ
)
983 and then not Restricted_Profile
)
985 Pkg_Id
:= System_Tasking_Protected_Objects_Entries
;
987 Pkg_Id
:= System_Tasking_Protected_Objects_Single_Entry
;
991 Pkg_Id
:= System_Tasking_Protected_Objects
;
996 end Corresponding_Runtime_Package
;
998 -------------------------------
999 -- Convert_To_Actual_Subtype --
1000 -------------------------------
1002 procedure Convert_To_Actual_Subtype
(Exp
: Entity_Id
) is
1006 Act_ST
:= Get_Actual_Subtype
(Exp
);
1008 if Act_ST
= Etype
(Exp
) then
1013 Convert_To
(Act_ST
, Relocate_Node
(Exp
)));
1014 Analyze_And_Resolve
(Exp
, Act_ST
);
1016 end Convert_To_Actual_Subtype
;
1018 -----------------------------------
1019 -- Current_Sem_Unit_Declarations --
1020 -----------------------------------
1022 function Current_Sem_Unit_Declarations
return List_Id
is
1023 U
: Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
1027 -- If the current unit is a package body, locate the visible
1028 -- declarations of the package spec.
1030 if Nkind
(U
) = N_Package_Body
then
1031 U
:= Unit
(Library_Unit
(Cunit
(Current_Sem_Unit
)));
1034 if Nkind
(U
) = N_Package_Declaration
then
1035 U
:= Specification
(U
);
1036 Decls
:= Visible_Declarations
(U
);
1040 Set_Visible_Declarations
(U
, Decls
);
1044 Decls
:= Declarations
(U
);
1048 Set_Declarations
(U
, Decls
);
1053 end Current_Sem_Unit_Declarations
;
1055 -----------------------
1056 -- Duplicate_Subexpr --
1057 -----------------------
1059 function Duplicate_Subexpr
1061 Name_Req
: Boolean := False) return Node_Id
1064 Remove_Side_Effects
(Exp
, Name_Req
);
1065 return New_Copy_Tree
(Exp
);
1066 end Duplicate_Subexpr
;
1068 ---------------------------------
1069 -- Duplicate_Subexpr_No_Checks --
1070 ---------------------------------
1072 function Duplicate_Subexpr_No_Checks
1074 Name_Req
: Boolean := False) return Node_Id
1079 Remove_Side_Effects
(Exp
, Name_Req
);
1080 New_Exp
:= New_Copy_Tree
(Exp
);
1081 Remove_Checks
(New_Exp
);
1083 end Duplicate_Subexpr_No_Checks
;
1085 -----------------------------------
1086 -- Duplicate_Subexpr_Move_Checks --
1087 -----------------------------------
1089 function Duplicate_Subexpr_Move_Checks
1091 Name_Req
: Boolean := False) return Node_Id
1096 Remove_Side_Effects
(Exp
, Name_Req
);
1097 New_Exp
:= New_Copy_Tree
(Exp
);
1098 Remove_Checks
(Exp
);
1100 end Duplicate_Subexpr_Move_Checks
;
1102 --------------------
1103 -- Ensure_Defined --
1104 --------------------
1106 procedure Ensure_Defined
(Typ
: Entity_Id
; N
: Node_Id
) is
1110 -- An itype reference must only be created if this is a local itype, so
1111 -- that gigi can elaborate it on the proper objstack.
1114 and then Scope
(Typ
) = Current_Scope
1116 IR
:= Make_Itype_Reference
(Sloc
(N
));
1117 Set_Itype
(IR
, Typ
);
1118 Insert_Action
(N
, IR
);
1122 --------------------
1123 -- Entry_Names_OK --
1124 --------------------
1126 function Entry_Names_OK
return Boolean is
1129 not Restricted_Profile
1130 and then not Global_Discard_Names
1131 and then not Restriction_Active
(No_Implicit_Heap_Allocations
)
1132 and then not Restriction_Active
(No_Local_Allocators
);
1135 ---------------------
1136 -- Evolve_And_Then --
1137 ---------------------
1139 procedure Evolve_And_Then
(Cond
: in out Node_Id
; Cond1
: Node_Id
) is
1145 Make_And_Then
(Sloc
(Cond1
),
1147 Right_Opnd
=> Cond1
);
1149 end Evolve_And_Then
;
1151 --------------------
1152 -- Evolve_Or_Else --
1153 --------------------
1155 procedure Evolve_Or_Else
(Cond
: in out Node_Id
; Cond1
: Node_Id
) is
1161 Make_Or_Else
(Sloc
(Cond1
),
1163 Right_Opnd
=> Cond1
);
1167 ------------------------------
1168 -- Expand_Subtype_From_Expr --
1169 ------------------------------
1171 -- This function is applicable for both static and dynamic allocation of
1172 -- objects which are constrained by an initial expression. Basically it
1173 -- transforms an unconstrained subtype indication into a constrained one.
1174 -- The expression may also be transformed in certain cases in order to
1175 -- avoid multiple evaluation. In the static allocation case, the general
1180 -- is transformed into
1182 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
1184 -- Here are the main cases :
1186 -- <if Expr is a Slice>
1187 -- Val : T ([Index_Subtype (Expr)]) := Expr;
1189 -- <elsif Expr is a String Literal>
1190 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
1192 -- <elsif Expr is Constrained>
1193 -- subtype T is Type_Of_Expr
1196 -- <elsif Expr is an entity_name>
1197 -- Val : T (constraints taken from Expr) := Expr;
1200 -- type Axxx is access all T;
1201 -- Rval : Axxx := Expr'ref;
1202 -- Val : T (constraints taken from Rval) := Rval.all;
1204 -- ??? note: when the Expression is allocated in the secondary stack
1205 -- we could use it directly instead of copying it by declaring
1206 -- Val : T (...) renames Rval.all
1208 procedure Expand_Subtype_From_Expr
1210 Unc_Type
: Entity_Id
;
1211 Subtype_Indic
: Node_Id
;
1214 Loc
: constant Source_Ptr
:= Sloc
(N
);
1215 Exp_Typ
: constant Entity_Id
:= Etype
(Exp
);
1219 -- In general we cannot build the subtype if expansion is disabled,
1220 -- because internal entities may not have been defined. However, to
1221 -- avoid some cascaded errors, we try to continue when the expression is
1222 -- an array (or string), because it is safe to compute the bounds. It is
1223 -- in fact required to do so even in a generic context, because there
1224 -- may be constants that depend on the bounds of a string literal, both
1225 -- standard string types and more generally arrays of characters.
1227 if not Expander_Active
1228 and then (No
(Etype
(Exp
))
1229 or else not Is_String_Type
(Etype
(Exp
)))
1234 if Nkind
(Exp
) = N_Slice
then
1236 Slice_Type
: constant Entity_Id
:= Etype
(First_Index
(Exp_Typ
));
1239 Rewrite
(Subtype_Indic
,
1240 Make_Subtype_Indication
(Loc
,
1241 Subtype_Mark
=> New_Reference_To
(Unc_Type
, Loc
),
1243 Make_Index_Or_Discriminant_Constraint
(Loc
,
1244 Constraints
=> New_List
1245 (New_Reference_To
(Slice_Type
, Loc
)))));
1247 -- This subtype indication may be used later for constraint checks
1248 -- we better make sure that if a variable was used as a bound of
1249 -- of the original slice, its value is frozen.
1251 Force_Evaluation
(Low_Bound
(Scalar_Range
(Slice_Type
)));
1252 Force_Evaluation
(High_Bound
(Scalar_Range
(Slice_Type
)));
1255 elsif Ekind
(Exp_Typ
) = E_String_Literal_Subtype
then
1256 Rewrite
(Subtype_Indic
,
1257 Make_Subtype_Indication
(Loc
,
1258 Subtype_Mark
=> New_Reference_To
(Unc_Type
, Loc
),
1260 Make_Index_Or_Discriminant_Constraint
(Loc
,
1261 Constraints
=> New_List
(
1262 Make_Literal_Range
(Loc
,
1263 Literal_Typ
=> Exp_Typ
)))));
1265 elsif Is_Constrained
(Exp_Typ
)
1266 and then not Is_Class_Wide_Type
(Unc_Type
)
1268 if Is_Itype
(Exp_Typ
) then
1270 -- Within an initialization procedure, a selected component
1271 -- denotes a component of the enclosing record, and it appears
1272 -- as an actual in a call to its own initialization procedure.
1273 -- If this component depends on the outer discriminant, we must
1274 -- generate the proper actual subtype for it.
1276 if Nkind
(Exp
) = N_Selected_Component
1277 and then Within_Init_Proc
1280 Decl
: constant Node_Id
:=
1281 Build_Actual_Subtype_Of_Component
(Exp_Typ
, Exp
);
1283 if Present
(Decl
) then
1284 Insert_Action
(N
, Decl
);
1285 T
:= Defining_Identifier
(Decl
);
1291 -- No need to generate a new one (new what???)
1298 T
:= Make_Temporary
(Loc
, 'T');
1301 Make_Subtype_Declaration
(Loc
,
1302 Defining_Identifier
=> T
,
1303 Subtype_Indication
=> New_Reference_To
(Exp_Typ
, Loc
)));
1305 -- This type is marked as an itype even though it has an
1306 -- explicit declaration because otherwise it can be marked
1307 -- with Is_Generic_Actual_Type and generate spurious errors.
1308 -- (see sem_ch8.Analyze_Package_Renaming and sem_type.covers)
1311 Set_Associated_Node_For_Itype
(T
, Exp
);
1314 Rewrite
(Subtype_Indic
, New_Reference_To
(T
, Loc
));
1316 -- Nothing needs to be done for private types with unknown discriminants
1317 -- if the underlying type is not an unconstrained composite type or it
1318 -- is an unchecked union.
1320 elsif Is_Private_Type
(Unc_Type
)
1321 and then Has_Unknown_Discriminants
(Unc_Type
)
1322 and then (not Is_Composite_Type
(Underlying_Type
(Unc_Type
))
1323 or else Is_Constrained
(Underlying_Type
(Unc_Type
))
1324 or else Is_Unchecked_Union
(Underlying_Type
(Unc_Type
)))
1328 -- Case of derived type with unknown discriminants where the parent type
1329 -- also has unknown discriminants.
1331 elsif Is_Record_Type
(Unc_Type
)
1332 and then not Is_Class_Wide_Type
(Unc_Type
)
1333 and then Has_Unknown_Discriminants
(Unc_Type
)
1334 and then Has_Unknown_Discriminants
(Underlying_Type
(Unc_Type
))
1336 -- Nothing to be done if no underlying record view available
1338 if No
(Underlying_Record_View
(Unc_Type
)) then
1341 -- Otherwise use the Underlying_Record_View to create the proper
1342 -- constrained subtype for an object of a derived type with unknown
1346 Remove_Side_Effects
(Exp
);
1347 Rewrite
(Subtype_Indic
,
1348 Make_Subtype_From_Expr
(Exp
, Underlying_Record_View
(Unc_Type
)));
1351 -- Renamings of class-wide interface types require no equivalent
1352 -- constrained type declarations because we only need to reference
1353 -- the tag component associated with the interface.
1356 and then Nkind
(N
) = N_Object_Renaming_Declaration
1357 and then Is_Interface
(Unc_Type
)
1359 pragma Assert
(Is_Class_Wide_Type
(Unc_Type
));
1362 -- In Ada95 nothing to be done if the type of the expression is limited,
1363 -- because in this case the expression cannot be copied, and its use can
1364 -- only be by reference.
1366 -- In Ada2005, the context can be an object declaration whose expression
1367 -- is a function that returns in place. If the nominal subtype has
1368 -- unknown discriminants, the call still provides constraints on the
1369 -- object, and we have to create an actual subtype from it.
1371 -- If the type is class-wide, the expression is dynamically tagged and
1372 -- we do not create an actual subtype either. Ditto for an interface.
1374 elsif Is_Limited_Type
(Exp_Typ
)
1376 (Is_Class_Wide_Type
(Exp_Typ
)
1377 or else Is_Interface
(Exp_Typ
)
1378 or else not Has_Unknown_Discriminants
(Exp_Typ
)
1379 or else not Is_Composite_Type
(Unc_Type
))
1383 -- For limited objects initialized with build in place function calls,
1384 -- nothing to be done; otherwise we prematurely introduce an N_Reference
1385 -- node in the expression initializing the object, which breaks the
1386 -- circuitry that detects and adds the additional arguments to the
1389 elsif Is_Build_In_Place_Function_Call
(Exp
) then
1393 Remove_Side_Effects
(Exp
);
1394 Rewrite
(Subtype_Indic
,
1395 Make_Subtype_From_Expr
(Exp
, Unc_Type
));
1397 end Expand_Subtype_From_Expr
;
1399 --------------------
1400 -- Find_Init_Call --
1401 --------------------
1403 function Find_Init_Call
1405 Rep_Clause
: Node_Id
) return Node_Id
1407 Typ
: constant Entity_Id
:= Etype
(Var
);
1409 Init_Proc
: Entity_Id
;
1410 -- Initialization procedure for Typ
1412 function Find_Init_Call_In_List
(From
: Node_Id
) return Node_Id
;
1413 -- Look for init call for Var starting at From and scanning the
1414 -- enclosing list until Rep_Clause or the end of the list is reached.
1416 ----------------------------
1417 -- Find_Init_Call_In_List --
1418 ----------------------------
1420 function Find_Init_Call_In_List
(From
: Node_Id
) return Node_Id
is
1421 Init_Call
: Node_Id
;
1425 while Present
(Init_Call
) and then Init_Call
/= Rep_Clause
loop
1426 if Nkind
(Init_Call
) = N_Procedure_Call_Statement
1427 and then Is_Entity_Name
(Name
(Init_Call
))
1428 and then Entity
(Name
(Init_Call
)) = Init_Proc
1436 end Find_Init_Call_In_List
;
1438 Init_Call
: Node_Id
;
1440 -- Start of processing for Find_Init_Call
1443 if not Has_Non_Null_Base_Init_Proc
(Typ
) then
1444 -- No init proc for the type, so obviously no call to be found
1449 Init_Proc
:= Base_Init_Proc
(Typ
);
1451 -- First scan the list containing the declaration of Var
1453 Init_Call
:= Find_Init_Call_In_List
(From
=> Next
(Parent
(Var
)));
1455 -- If not found, also look on Var's freeze actions list, if any, since
1456 -- the init call may have been moved there (case of an address clause
1457 -- applying to Var).
1459 if No
(Init_Call
) and then Present
(Freeze_Node
(Var
)) then
1460 Init_Call
:= Find_Init_Call_In_List
1461 (First
(Actions
(Freeze_Node
(Var
))));
1467 ------------------------
1468 -- Find_Interface_ADT --
1469 ------------------------
1471 function Find_Interface_ADT
1473 Iface
: Entity_Id
) return Elmt_Id
1476 Typ
: Entity_Id
:= T
;
1479 pragma Assert
(Is_Interface
(Iface
));
1481 -- Handle private types
1483 if Has_Private_Declaration
(Typ
)
1484 and then Present
(Full_View
(Typ
))
1486 Typ
:= Full_View
(Typ
);
1489 -- Handle access types
1491 if Is_Access_Type
(Typ
) then
1492 Typ
:= Designated_Type
(Typ
);
1495 -- Handle task and protected types implementing interfaces
1497 if Is_Concurrent_Type
(Typ
) then
1498 Typ
:= Corresponding_Record_Type
(Typ
);
1502 (not Is_Class_Wide_Type
(Typ
)
1503 and then Ekind
(Typ
) /= E_Incomplete_Type
);
1505 if Is_Ancestor
(Iface
, Typ
) then
1506 return First_Elmt
(Access_Disp_Table
(Typ
));
1510 Next_Elmt
(Next_Elmt
(First_Elmt
(Access_Disp_Table
(Typ
))));
1512 and then Present
(Related_Type
(Node
(ADT
)))
1513 and then Related_Type
(Node
(ADT
)) /= Iface
1514 and then not Is_Ancestor
(Iface
, Related_Type
(Node
(ADT
)))
1519 pragma Assert
(Present
(Related_Type
(Node
(ADT
))));
1522 end Find_Interface_ADT
;
1524 ------------------------
1525 -- Find_Interface_Tag --
1526 ------------------------
1528 function Find_Interface_Tag
1530 Iface
: Entity_Id
) return Entity_Id
1533 Found
: Boolean := False;
1534 Typ
: Entity_Id
:= T
;
1536 procedure Find_Tag
(Typ
: Entity_Id
);
1537 -- Internal subprogram used to recursively climb to the ancestors
1543 procedure Find_Tag
(Typ
: Entity_Id
) is
1548 -- This routine does not handle the case in which the interface is an
1549 -- ancestor of Typ. That case is handled by the enclosing subprogram.
1551 pragma Assert
(Typ
/= Iface
);
1553 -- Climb to the root type handling private types
1555 if Present
(Full_View
(Etype
(Typ
))) then
1556 if Full_View
(Etype
(Typ
)) /= Typ
then
1557 Find_Tag
(Full_View
(Etype
(Typ
)));
1560 elsif Etype
(Typ
) /= Typ
then
1561 Find_Tag
(Etype
(Typ
));
1564 -- Traverse the list of interfaces implemented by the type
1567 and then Present
(Interfaces
(Typ
))
1568 and then not (Is_Empty_Elmt_List
(Interfaces
(Typ
)))
1570 -- Skip the tag associated with the primary table
1572 pragma Assert
(Etype
(First_Tag_Component
(Typ
)) = RTE
(RE_Tag
));
1573 AI_Tag
:= Next_Tag_Component
(First_Tag_Component
(Typ
));
1574 pragma Assert
(Present
(AI_Tag
));
1576 AI_Elmt
:= First_Elmt
(Interfaces
(Typ
));
1577 while Present
(AI_Elmt
) loop
1578 AI
:= Node
(AI_Elmt
);
1580 if AI
= Iface
or else Is_Ancestor
(Iface
, AI
) then
1585 AI_Tag
:= Next_Tag_Component
(AI_Tag
);
1586 Next_Elmt
(AI_Elmt
);
1591 -- Start of processing for Find_Interface_Tag
1594 pragma Assert
(Is_Interface
(Iface
));
1596 -- Handle access types
1598 if Is_Access_Type
(Typ
) then
1599 Typ
:= Designated_Type
(Typ
);
1602 -- Handle class-wide types
1604 if Is_Class_Wide_Type
(Typ
) then
1605 Typ
:= Root_Type
(Typ
);
1608 -- Handle private types
1610 if Has_Private_Declaration
(Typ
)
1611 and then Present
(Full_View
(Typ
))
1613 Typ
:= Full_View
(Typ
);
1616 -- Handle entities from the limited view
1618 if Ekind
(Typ
) = E_Incomplete_Type
then
1619 pragma Assert
(Present
(Non_Limited_View
(Typ
)));
1620 Typ
:= Non_Limited_View
(Typ
);
1623 -- Handle task and protected types implementing interfaces
1625 if Is_Concurrent_Type
(Typ
) then
1626 Typ
:= Corresponding_Record_Type
(Typ
);
1629 -- If the interface is an ancestor of the type, then it shared the
1630 -- primary dispatch table.
1632 if Is_Ancestor
(Iface
, Typ
) then
1633 pragma Assert
(Etype
(First_Tag_Component
(Typ
)) = RTE
(RE_Tag
));
1634 return First_Tag_Component
(Typ
);
1636 -- Otherwise we need to search for its associated tag component
1640 pragma Assert
(Found
);
1643 end Find_Interface_Tag
;
1649 function Find_Prim_Op
(T
: Entity_Id
; Name
: Name_Id
) return Entity_Id
is
1651 Typ
: Entity_Id
:= T
;
1655 if Is_Class_Wide_Type
(Typ
) then
1656 Typ
:= Root_Type
(Typ
);
1659 Typ
:= Underlying_Type
(Typ
);
1661 -- Loop through primitive operations
1663 Prim
:= First_Elmt
(Primitive_Operations
(Typ
));
1664 while Present
(Prim
) loop
1667 -- We can retrieve primitive operations by name if it is an internal
1668 -- name. For equality we must check that both of its operands have
1669 -- the same type, to avoid confusion with user-defined equalities
1670 -- than may have a non-symmetric signature.
1672 exit when Chars
(Op
) = Name
1675 or else Etype
(First_Formal
(Op
)) = Etype
(Last_Formal
(Op
)));
1679 -- Raise Program_Error if no primitive found
1682 raise Program_Error
;
1693 function Find_Prim_Op
1695 Name
: TSS_Name_Type
) return Entity_Id
1698 Typ
: Entity_Id
:= T
;
1701 if Is_Class_Wide_Type
(Typ
) then
1702 Typ
:= Root_Type
(Typ
);
1705 Typ
:= Underlying_Type
(Typ
);
1707 Prim
:= First_Elmt
(Primitive_Operations
(Typ
));
1708 while not Is_TSS
(Node
(Prim
), Name
) loop
1711 -- Raise program error if no primitive found
1714 raise Program_Error
;
1721 ----------------------------
1722 -- Find_Protection_Object --
1723 ----------------------------
1725 function Find_Protection_Object
(Scop
: Entity_Id
) return Entity_Id
is
1730 while Present
(S
) loop
1731 if (Ekind
(S
) = E_Entry
1732 or else Ekind
(S
) = E_Entry_Family
1733 or else Ekind
(S
) = E_Function
1734 or else Ekind
(S
) = E_Procedure
)
1735 and then Present
(Protection_Object
(S
))
1737 return Protection_Object
(S
);
1743 -- If we do not find a Protection object in the scope chain, then
1744 -- something has gone wrong, most likely the object was never created.
1746 raise Program_Error
;
1747 end Find_Protection_Object
;
1749 ----------------------
1750 -- Force_Evaluation --
1751 ----------------------
1753 procedure Force_Evaluation
(Exp
: Node_Id
; Name_Req
: Boolean := False) is
1755 Remove_Side_Effects
(Exp
, Name_Req
, Variable_Ref
=> True);
1756 end Force_Evaluation
;
1758 ---------------------------------
1759 -- Fully_Qualified_Name_String --
1760 ---------------------------------
1762 function Fully_Qualified_Name_String
(E
: Entity_Id
) return String_Id
is
1763 procedure Internal_Full_Qualified_Name
(E
: Entity_Id
);
1764 -- Compute recursively the qualified name without NUL at the end, adding
1765 -- it to the currently started string being generated
1767 ----------------------------------
1768 -- Internal_Full_Qualified_Name --
1769 ----------------------------------
1771 procedure Internal_Full_Qualified_Name
(E
: Entity_Id
) is
1775 -- Deal properly with child units
1777 if Nkind
(E
) = N_Defining_Program_Unit_Name
then
1778 Ent
:= Defining_Identifier
(E
);
1783 -- Compute qualification recursively (only "Standard" has no scope)
1785 if Present
(Scope
(Scope
(Ent
))) then
1786 Internal_Full_Qualified_Name
(Scope
(Ent
));
1787 Store_String_Char
(Get_Char_Code
('.'));
1790 -- Every entity should have a name except some expanded blocks
1791 -- don't bother about those.
1793 if Chars
(Ent
) = No_Name
then
1797 -- Generates the entity name in upper case
1799 Get_Decoded_Name_String
(Chars
(Ent
));
1801 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
1803 end Internal_Full_Qualified_Name
;
1805 -- Start of processing for Full_Qualified_Name
1809 Internal_Full_Qualified_Name
(E
);
1810 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
1812 end Fully_Qualified_Name_String
;
1814 ------------------------
1815 -- Generate_Poll_Call --
1816 ------------------------
1818 procedure Generate_Poll_Call
(N
: Node_Id
) is
1820 -- No poll call if polling not active
1822 if not Polling_Required
then
1825 -- Otherwise generate require poll call
1828 Insert_Before_And_Analyze
(N
,
1829 Make_Procedure_Call_Statement
(Sloc
(N
),
1830 Name
=> New_Occurrence_Of
(RTE
(RE_Poll
), Sloc
(N
))));
1832 end Generate_Poll_Call
;
1834 ---------------------------------
1835 -- Get_Current_Value_Condition --
1836 ---------------------------------
1838 -- Note: the implementation of this procedure is very closely tied to the
1839 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
1840 -- interpret Current_Value fields set by the Set procedure, so the two
1841 -- procedures need to be closely coordinated.
1843 procedure Get_Current_Value_Condition
1848 Loc
: constant Source_Ptr
:= Sloc
(Var
);
1849 Ent
: constant Entity_Id
:= Entity
(Var
);
1851 procedure Process_Current_Value_Condition
1854 -- N is an expression which holds either True (S = True) or False (S =
1855 -- False) in the condition. This procedure digs out the expression and
1856 -- if it refers to Ent, sets Op and Val appropriately.
1858 -------------------------------------
1859 -- Process_Current_Value_Condition --
1860 -------------------------------------
1862 procedure Process_Current_Value_Condition
1873 -- Deal with NOT operators, inverting sense
1875 while Nkind
(Cond
) = N_Op_Not
loop
1876 Cond
:= Right_Opnd
(Cond
);
1880 -- Deal with AND THEN and AND cases
1882 if Nkind
(Cond
) = N_And_Then
1883 or else Nkind
(Cond
) = N_Op_And
1885 -- Don't ever try to invert a condition that is of the form of an
1886 -- AND or AND THEN (since we are not doing sufficiently general
1887 -- processing to allow this).
1889 if Sens
= False then
1895 -- Recursively process AND and AND THEN branches
1897 Process_Current_Value_Condition
(Left_Opnd
(Cond
), True);
1899 if Op
/= N_Empty
then
1903 Process_Current_Value_Condition
(Right_Opnd
(Cond
), True);
1906 -- Case of relational operator
1908 elsif Nkind
(Cond
) in N_Op_Compare
then
1911 -- Invert sense of test if inverted test
1913 if Sens
= False then
1915 when N_Op_Eq
=> Op
:= N_Op_Ne
;
1916 when N_Op_Ne
=> Op
:= N_Op_Eq
;
1917 when N_Op_Lt
=> Op
:= N_Op_Ge
;
1918 when N_Op_Gt
=> Op
:= N_Op_Le
;
1919 when N_Op_Le
=> Op
:= N_Op_Gt
;
1920 when N_Op_Ge
=> Op
:= N_Op_Lt
;
1921 when others => raise Program_Error
;
1925 -- Case of entity op value
1927 if Is_Entity_Name
(Left_Opnd
(Cond
))
1928 and then Ent
= Entity
(Left_Opnd
(Cond
))
1929 and then Compile_Time_Known_Value
(Right_Opnd
(Cond
))
1931 Val
:= Right_Opnd
(Cond
);
1933 -- Case of value op entity
1935 elsif Is_Entity_Name
(Right_Opnd
(Cond
))
1936 and then Ent
= Entity
(Right_Opnd
(Cond
))
1937 and then Compile_Time_Known_Value
(Left_Opnd
(Cond
))
1939 Val
:= Left_Opnd
(Cond
);
1941 -- We are effectively swapping operands
1944 when N_Op_Eq
=> null;
1945 when N_Op_Ne
=> null;
1946 when N_Op_Lt
=> Op
:= N_Op_Gt
;
1947 when N_Op_Gt
=> Op
:= N_Op_Lt
;
1948 when N_Op_Le
=> Op
:= N_Op_Ge
;
1949 when N_Op_Ge
=> Op
:= N_Op_Le
;
1950 when others => raise Program_Error
;
1959 -- Case of Boolean variable reference, return as though the
1960 -- reference had said var = True.
1963 if Is_Entity_Name
(Cond
)
1964 and then Ent
= Entity
(Cond
)
1966 Val
:= New_Occurrence_Of
(Standard_True
, Sloc
(Cond
));
1968 if Sens
= False then
1975 end Process_Current_Value_Condition
;
1977 -- Start of processing for Get_Current_Value_Condition
1983 -- Immediate return, nothing doing, if this is not an object
1985 if Ekind
(Ent
) not in Object_Kind
then
1989 -- Otherwise examine current value
1992 CV
: constant Node_Id
:= Current_Value
(Ent
);
1997 -- If statement. Condition is known true in THEN section, known False
1998 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
2000 if Nkind
(CV
) = N_If_Statement
then
2002 -- Before start of IF statement
2004 if Loc
< Sloc
(CV
) then
2007 -- After end of IF statement
2009 elsif Loc
>= Sloc
(CV
) + Text_Ptr
(UI_To_Int
(End_Span
(CV
))) then
2013 -- At this stage we know that we are within the IF statement, but
2014 -- unfortunately, the tree does not record the SLOC of the ELSE so
2015 -- we cannot use a simple SLOC comparison to distinguish between
2016 -- the then/else statements, so we have to climb the tree.
2023 while Parent
(N
) /= CV
loop
2026 -- If we fall off the top of the tree, then that's odd, but
2027 -- perhaps it could occur in some error situation, and the
2028 -- safest response is simply to assume that the outcome of
2029 -- the condition is unknown. No point in bombing during an
2030 -- attempt to optimize things.
2037 -- Now we have N pointing to a node whose parent is the IF
2038 -- statement in question, so now we can tell if we are within
2039 -- the THEN statements.
2041 if Is_List_Member
(N
)
2042 and then List_Containing
(N
) = Then_Statements
(CV
)
2046 -- If the variable reference does not come from source, we
2047 -- cannot reliably tell whether it appears in the else part.
2048 -- In particular, if it appears in generated code for a node
2049 -- that requires finalization, it may be attached to a list
2050 -- that has not been yet inserted into the code. For now,
2051 -- treat it as unknown.
2053 elsif not Comes_From_Source
(N
) then
2056 -- Otherwise we must be in ELSIF or ELSE part
2063 -- ELSIF part. Condition is known true within the referenced
2064 -- ELSIF, known False in any subsequent ELSIF or ELSE part,
2065 -- and unknown before the ELSE part or after the IF statement.
2067 elsif Nkind
(CV
) = N_Elsif_Part
then
2069 -- if the Elsif_Part had condition_actions, the elsif has been
2070 -- rewritten as a nested if, and the original elsif_part is
2071 -- detached from the tree, so there is no way to obtain useful
2072 -- information on the current value of the variable.
2073 -- Can this be improved ???
2075 if No
(Parent
(CV
)) then
2081 -- Before start of ELSIF part
2083 if Loc
< Sloc
(CV
) then
2086 -- After end of IF statement
2088 elsif Loc
>= Sloc
(Stm
) +
2089 Text_Ptr
(UI_To_Int
(End_Span
(Stm
)))
2094 -- Again we lack the SLOC of the ELSE, so we need to climb the
2095 -- tree to see if we are within the ELSIF part in question.
2102 while Parent
(N
) /= Stm
loop
2105 -- If we fall off the top of the tree, then that's odd, but
2106 -- perhaps it could occur in some error situation, and the
2107 -- safest response is simply to assume that the outcome of
2108 -- the condition is unknown. No point in bombing during an
2109 -- attempt to optimize things.
2116 -- Now we have N pointing to a node whose parent is the IF
2117 -- statement in question, so see if is the ELSIF part we want.
2118 -- the THEN statements.
2123 -- Otherwise we must be in subsequent ELSIF or ELSE part
2130 -- Iteration scheme of while loop. The condition is known to be
2131 -- true within the body of the loop.
2133 elsif Nkind
(CV
) = N_Iteration_Scheme
then
2135 Loop_Stmt
: constant Node_Id
:= Parent
(CV
);
2138 -- Before start of body of loop
2140 if Loc
< Sloc
(Loop_Stmt
) then
2143 -- After end of LOOP statement
2145 elsif Loc
>= Sloc
(End_Label
(Loop_Stmt
)) then
2148 -- We are within the body of the loop
2155 -- All other cases of Current_Value settings
2161 -- If we fall through here, then we have a reportable condition, Sens
2162 -- is True if the condition is true and False if it needs inverting.
2164 Process_Current_Value_Condition
(Condition
(CV
), Sens
);
2166 end Get_Current_Value_Condition
;
2168 ---------------------------------
2169 -- Has_Controlled_Coextensions --
2170 ---------------------------------
2172 function Has_Controlled_Coextensions
(Typ
: Entity_Id
) return Boolean is
2177 -- Only consider record types
2179 if not Ekind_In
(Typ
, E_Record_Type
, E_Record_Subtype
) then
2183 if Has_Discriminants
(Typ
) then
2184 Discr
:= First_Discriminant
(Typ
);
2185 while Present
(Discr
) loop
2186 D_Typ
:= Etype
(Discr
);
2188 if Ekind
(D_Typ
) = E_Anonymous_Access_Type
2190 (Is_Controlled
(Designated_Type
(D_Typ
))
2192 Is_Concurrent_Type
(Designated_Type
(D_Typ
)))
2197 Next_Discriminant
(Discr
);
2202 end Has_Controlled_Coextensions
;
2204 ------------------------
2205 -- Has_Address_Clause --
2206 ------------------------
2208 -- Should this function check the private part in a package ???
2210 function Has_Following_Address_Clause
(D
: Node_Id
) return Boolean is
2211 Id
: constant Entity_Id
:= Defining_Identifier
(D
);
2216 while Present
(Decl
) loop
2217 if Nkind
(Decl
) = N_At_Clause
2218 and then Chars
(Identifier
(Decl
)) = Chars
(Id
)
2222 elsif Nkind
(Decl
) = N_Attribute_Definition_Clause
2223 and then Chars
(Decl
) = Name_Address
2224 and then Chars
(Name
(Decl
)) = Chars
(Id
)
2233 end Has_Following_Address_Clause
;
2235 --------------------
2236 -- Homonym_Number --
2237 --------------------
2239 function Homonym_Number
(Subp
: Entity_Id
) return Nat
is
2245 Hom
:= Homonym
(Subp
);
2246 while Present
(Hom
) loop
2247 if Scope
(Hom
) = Scope
(Subp
) then
2251 Hom
:= Homonym
(Hom
);
2257 ------------------------------
2258 -- In_Unconditional_Context --
2259 ------------------------------
2261 function In_Unconditional_Context
(Node
: Node_Id
) return Boolean is
2266 while Present
(P
) loop
2268 when N_Subprogram_Body
=>
2271 when N_If_Statement
=>
2274 when N_Loop_Statement
=>
2277 when N_Case_Statement
=>
2286 end In_Unconditional_Context
;
2292 procedure Insert_Action
(Assoc_Node
: Node_Id
; Ins_Action
: Node_Id
) is
2294 if Present
(Ins_Action
) then
2295 Insert_Actions
(Assoc_Node
, New_List
(Ins_Action
));
2299 -- Version with check(s) suppressed
2301 procedure Insert_Action
2302 (Assoc_Node
: Node_Id
; Ins_Action
: Node_Id
; Suppress
: Check_Id
)
2305 Insert_Actions
(Assoc_Node
, New_List
(Ins_Action
), Suppress
);
2308 --------------------
2309 -- Insert_Actions --
2310 --------------------
2312 procedure Insert_Actions
(Assoc_Node
: Node_Id
; Ins_Actions
: List_Id
) is
2316 Wrapped_Node
: Node_Id
:= Empty
;
2319 if No
(Ins_Actions
) or else Is_Empty_List
(Ins_Actions
) then
2323 -- Ignore insert of actions from inside default expression (or other
2324 -- similar "spec expression") in the special spec-expression analyze
2325 -- mode. Any insertions at this point have no relevance, since we are
2326 -- only doing the analyze to freeze the types of any static expressions.
2327 -- See section "Handling of Default Expressions" in the spec of package
2328 -- Sem for further details.
2330 if In_Spec_Expression
then
2334 -- If the action derives from stuff inside a record, then the actions
2335 -- are attached to the current scope, to be inserted and analyzed on
2336 -- exit from the scope. The reason for this is that we may also
2337 -- be generating freeze actions at the same time, and they must
2338 -- eventually be elaborated in the correct order.
2340 if Is_Record_Type
(Current_Scope
)
2341 and then not Is_Frozen
(Current_Scope
)
2343 if No
(Scope_Stack
.Table
2344 (Scope_Stack
.Last
).Pending_Freeze_Actions
)
2346 Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
:=
2351 Scope_Stack
.Table
(Scope_Stack
.Last
).Pending_Freeze_Actions
);
2357 -- We now intend to climb up the tree to find the right point to
2358 -- insert the actions. We start at Assoc_Node, unless this node is
2359 -- a subexpression in which case we start with its parent. We do this
2360 -- for two reasons. First it speeds things up. Second, if Assoc_Node
2361 -- is itself one of the special nodes like N_And_Then, then we assume
2362 -- that an initial request to insert actions for such a node does not
2363 -- expect the actions to get deposited in the node for later handling
2364 -- when the node is expanded, since clearly the node is being dealt
2365 -- with by the caller. Note that in the subexpression case, N is
2366 -- always the child we came from.
2368 -- N_Raise_xxx_Error is an annoying special case, it is a statement
2369 -- if it has type Standard_Void_Type, and a subexpression otherwise.
2370 -- otherwise. Procedure attribute references are also statements.
2372 if Nkind
(Assoc_Node
) in N_Subexpr
2373 and then (Nkind
(Assoc_Node
) in N_Raise_xxx_Error
2374 or else Etype
(Assoc_Node
) /= Standard_Void_Type
)
2375 and then (Nkind
(Assoc_Node
) /= N_Attribute_Reference
2377 not Is_Procedure_Attribute_Name
2378 (Attribute_Name
(Assoc_Node
)))
2380 P
:= Assoc_Node
; -- ??? does not agree with above!
2381 N
:= Parent
(Assoc_Node
);
2383 -- Non-subexpression case. Note that N is initially Empty in this
2384 -- case (N is only guaranteed Non-Empty in the subexpr case).
2391 -- Capture root of the transient scope
2393 if Scope_Is_Transient
then
2394 Wrapped_Node
:= Node_To_Be_Wrapped
;
2398 pragma Assert
(Present
(P
));
2402 -- Case of right operand of AND THEN or OR ELSE. Put the actions
2403 -- in the Actions field of the right operand. They will be moved
2404 -- out further when the AND THEN or OR ELSE operator is expanded.
2405 -- Nothing special needs to be done for the left operand since
2406 -- in that case the actions are executed unconditionally.
2408 when N_Short_Circuit
=>
2409 if N
= Right_Opnd
(P
) then
2411 -- We are now going to either append the actions to the
2412 -- actions field of the short-circuit operation. We will
2413 -- also analyze the actions now.
2415 -- This analysis is really too early, the proper thing would
2416 -- be to just park them there now, and only analyze them if
2417 -- we find we really need them, and to it at the proper
2418 -- final insertion point. However attempting to this proved
2419 -- tricky, so for now we just kill current values before and
2420 -- after the analyze call to make sure we avoid peculiar
2421 -- optimizations from this out of order insertion.
2423 Kill_Current_Values
;
2425 if Present
(Actions
(P
)) then
2426 Insert_List_After_And_Analyze
2427 (Last
(Actions
(P
)), Ins_Actions
);
2429 Set_Actions
(P
, Ins_Actions
);
2430 Analyze_List
(Actions
(P
));
2433 Kill_Current_Values
;
2438 -- Then or Else operand of conditional expression. Add actions to
2439 -- Then_Actions or Else_Actions field as appropriate. The actions
2440 -- will be moved further out when the conditional is expanded.
2442 when N_Conditional_Expression
=>
2444 ThenX
: constant Node_Id
:= Next
(First
(Expressions
(P
)));
2445 ElseX
: constant Node_Id
:= Next
(ThenX
);
2448 -- If the enclosing expression is already analyzed, as
2449 -- is the case for nested elaboration checks, insert the
2450 -- conditional further out.
2452 if Analyzed
(P
) then
2455 -- Actions belong to the then expression, temporarily place
2456 -- them as Then_Actions of the conditional expr. They will
2457 -- be moved to the proper place later when the conditional
2458 -- expression is expanded.
2460 elsif N
= ThenX
then
2461 if Present
(Then_Actions
(P
)) then
2462 Insert_List_After_And_Analyze
2463 (Last
(Then_Actions
(P
)), Ins_Actions
);
2465 Set_Then_Actions
(P
, Ins_Actions
);
2466 Analyze_List
(Then_Actions
(P
));
2471 -- Actions belong to the else expression, temporarily
2472 -- place them as Else_Actions of the conditional expr.
2473 -- They will be moved to the proper place later when
2474 -- the conditional expression is expanded.
2476 elsif N
= ElseX
then
2477 if Present
(Else_Actions
(P
)) then
2478 Insert_List_After_And_Analyze
2479 (Last
(Else_Actions
(P
)), Ins_Actions
);
2481 Set_Else_Actions
(P
, Ins_Actions
);
2482 Analyze_List
(Else_Actions
(P
));
2487 -- Actions belong to the condition. In this case they are
2488 -- unconditionally executed, and so we can continue the
2489 -- search for the proper insert point.
2496 -- Alternative of case expression, we place the action in the
2497 -- Actions field of the case expression alternative, this will
2498 -- be handled when the case expression is expanded.
2500 when N_Case_Expression_Alternative
=>
2501 if Present
(Actions
(P
)) then
2502 Insert_List_After_And_Analyze
2503 (Last
(Actions
(P
)), Ins_Actions
);
2505 Set_Actions
(P
, Ins_Actions
);
2506 Analyze_List
(Then_Actions
(P
));
2511 -- Case of appearing within an Expressions_With_Actions node. We
2512 -- prepend the actions to the list of actions already there, if
2513 -- the node has not been analyzed yet. Otherwise find insertion
2514 -- location further up the tree.
2516 when N_Expression_With_Actions
=>
2517 if not Analyzed
(P
) then
2518 Prepend_List
(Ins_Actions
, Actions
(P
));
2522 -- Case of appearing in the condition of a while expression or
2523 -- elsif. We insert the actions into the Condition_Actions field.
2524 -- They will be moved further out when the while loop or elsif
2527 when N_Iteration_Scheme |
2530 if N
= Condition
(P
) then
2531 if Present
(Condition_Actions
(P
)) then
2532 Insert_List_After_And_Analyze
2533 (Last
(Condition_Actions
(P
)), Ins_Actions
);
2535 Set_Condition_Actions
(P
, Ins_Actions
);
2537 -- Set the parent of the insert actions explicitly. This
2538 -- is not a syntactic field, but we need the parent field
2539 -- set, in particular so that freeze can understand that
2540 -- it is dealing with condition actions, and properly
2541 -- insert the freezing actions.
2543 Set_Parent
(Ins_Actions
, P
);
2544 Analyze_List
(Condition_Actions
(P
));
2550 -- Statements, declarations, pragmas, representation clauses
2555 N_Procedure_Call_Statement |
2556 N_Statement_Other_Than_Procedure_Call |
2562 -- Representation_Clause
2565 N_Attribute_Definition_Clause |
2566 N_Enumeration_Representation_Clause |
2567 N_Record_Representation_Clause |
2571 N_Abstract_Subprogram_Declaration |
2573 N_Exception_Declaration |
2574 N_Exception_Renaming_Declaration |
2575 N_Formal_Abstract_Subprogram_Declaration |
2576 N_Formal_Concrete_Subprogram_Declaration |
2577 N_Formal_Object_Declaration |
2578 N_Formal_Type_Declaration |
2579 N_Full_Type_Declaration |
2580 N_Function_Instantiation |
2581 N_Generic_Function_Renaming_Declaration |
2582 N_Generic_Package_Declaration |
2583 N_Generic_Package_Renaming_Declaration |
2584 N_Generic_Procedure_Renaming_Declaration |
2585 N_Generic_Subprogram_Declaration |
2586 N_Implicit_Label_Declaration |
2587 N_Incomplete_Type_Declaration |
2588 N_Number_Declaration |
2589 N_Object_Declaration |
2590 N_Object_Renaming_Declaration |
2592 N_Package_Body_Stub |
2593 N_Package_Declaration |
2594 N_Package_Instantiation |
2595 N_Package_Renaming_Declaration |
2596 N_Parameterized_Expression |
2597 N_Private_Extension_Declaration |
2598 N_Private_Type_Declaration |
2599 N_Procedure_Instantiation |
2601 N_Protected_Body_Stub |
2602 N_Protected_Type_Declaration |
2603 N_Single_Task_Declaration |
2605 N_Subprogram_Body_Stub |
2606 N_Subprogram_Declaration |
2607 N_Subprogram_Renaming_Declaration |
2608 N_Subtype_Declaration |
2611 N_Task_Type_Declaration |
2613 -- Freeze entity behaves like a declaration or statement
2617 -- Do not insert here if the item is not a list member (this
2618 -- happens for example with a triggering statement, and the
2619 -- proper approach is to insert before the entire select).
2621 if not Is_List_Member
(P
) then
2624 -- Do not insert if parent of P is an N_Component_Association
2625 -- node (i.e. we are in the context of an N_Aggregate or
2626 -- N_Extension_Aggregate node. In this case we want to insert
2627 -- before the entire aggregate.
2629 elsif Nkind
(Parent
(P
)) = N_Component_Association
then
2632 -- Do not insert if the parent of P is either an N_Variant
2633 -- node or an N_Record_Definition node, meaning in either
2634 -- case that P is a member of a component list, and that
2635 -- therefore the actions should be inserted outside the
2636 -- complete record declaration.
2638 elsif Nkind
(Parent
(P
)) = N_Variant
2639 or else Nkind
(Parent
(P
)) = N_Record_Definition
2643 -- Do not insert freeze nodes within the loop generated for
2644 -- an aggregate, because they may be elaborated too late for
2645 -- subsequent use in the back end: within a package spec the
2646 -- loop is part of the elaboration procedure and is only
2647 -- elaborated during the second pass.
2649 -- If the loop comes from source, or the entity is local to
2650 -- the loop itself it must remain within.
2652 elsif Nkind
(Parent
(P
)) = N_Loop_Statement
2653 and then not Comes_From_Source
(Parent
(P
))
2654 and then Nkind
(First
(Ins_Actions
)) = N_Freeze_Entity
2656 Scope
(Entity
(First
(Ins_Actions
))) /= Current_Scope
2660 -- Otherwise we can go ahead and do the insertion
2662 elsif P
= Wrapped_Node
then
2663 Store_Before_Actions_In_Scope
(Ins_Actions
);
2667 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
2671 -- A special case, N_Raise_xxx_Error can act either as a statement
2672 -- or a subexpression. We tell the difference by looking at the
2673 -- Etype. It is set to Standard_Void_Type in the statement case.
2676 N_Raise_xxx_Error
=>
2677 if Etype
(P
) = Standard_Void_Type
then
2678 if P
= Wrapped_Node
then
2679 Store_Before_Actions_In_Scope
(Ins_Actions
);
2681 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
2686 -- In the subexpression case, keep climbing
2692 -- If a component association appears within a loop created for
2693 -- an array aggregate, attach the actions to the association so
2694 -- they can be subsequently inserted within the loop. For other
2695 -- component associations insert outside of the aggregate. For
2696 -- an association that will generate a loop, its Loop_Actions
2697 -- attribute is already initialized (see exp_aggr.adb).
2699 -- The list of loop_actions can in turn generate additional ones,
2700 -- that are inserted before the associated node. If the associated
2701 -- node is outside the aggregate, the new actions are collected
2702 -- at the end of the loop actions, to respect the order in which
2703 -- they are to be elaborated.
2706 N_Component_Association
=>
2707 if Nkind
(Parent
(P
)) = N_Aggregate
2708 and then Present
(Loop_Actions
(P
))
2710 if Is_Empty_List
(Loop_Actions
(P
)) then
2711 Set_Loop_Actions
(P
, Ins_Actions
);
2712 Analyze_List
(Ins_Actions
);
2719 -- Check whether these actions were generated by a
2720 -- declaration that is part of the loop_ actions
2721 -- for the component_association.
2724 while Present
(Decl
) loop
2725 exit when Parent
(Decl
) = P
2726 and then Is_List_Member
(Decl
)
2728 List_Containing
(Decl
) = Loop_Actions
(P
);
2729 Decl
:= Parent
(Decl
);
2732 if Present
(Decl
) then
2733 Insert_List_Before_And_Analyze
2734 (Decl
, Ins_Actions
);
2736 Insert_List_After_And_Analyze
2737 (Last
(Loop_Actions
(P
)), Ins_Actions
);
2748 -- Another special case, an attribute denoting a procedure call
2751 N_Attribute_Reference
=>
2752 if Is_Procedure_Attribute_Name
(Attribute_Name
(P
)) then
2753 if P
= Wrapped_Node
then
2754 Store_Before_Actions_In_Scope
(Ins_Actions
);
2756 Insert_List_Before_And_Analyze
(P
, Ins_Actions
);
2761 -- In the subexpression case, keep climbing
2767 -- For all other node types, keep climbing tree
2771 N_Accept_Alternative |
2772 N_Access_Definition |
2773 N_Access_Function_Definition |
2774 N_Access_Procedure_Definition |
2775 N_Access_To_Object_Definition |
2778 N_Aspect_Specification |
2780 N_Case_Statement_Alternative |
2781 N_Character_Literal |
2782 N_Compilation_Unit |
2783 N_Compilation_Unit_Aux |
2784 N_Component_Clause |
2785 N_Component_Declaration |
2786 N_Component_Definition |
2788 N_Constrained_Array_Definition |
2789 N_Decimal_Fixed_Point_Definition |
2790 N_Defining_Character_Literal |
2791 N_Defining_Identifier |
2792 N_Defining_Operator_Symbol |
2793 N_Defining_Program_Unit_Name |
2794 N_Delay_Alternative |
2795 N_Delta_Constraint |
2796 N_Derived_Type_Definition |
2798 N_Digits_Constraint |
2799 N_Discriminant_Association |
2800 N_Discriminant_Specification |
2802 N_Entry_Body_Formal_Part |
2803 N_Entry_Call_Alternative |
2804 N_Entry_Declaration |
2805 N_Entry_Index_Specification |
2806 N_Enumeration_Type_Definition |
2808 N_Exception_Handler |
2810 N_Explicit_Dereference |
2811 N_Extension_Aggregate |
2812 N_Floating_Point_Definition |
2813 N_Formal_Decimal_Fixed_Point_Definition |
2814 N_Formal_Derived_Type_Definition |
2815 N_Formal_Discrete_Type_Definition |
2816 N_Formal_Floating_Point_Definition |
2817 N_Formal_Modular_Type_Definition |
2818 N_Formal_Ordinary_Fixed_Point_Definition |
2819 N_Formal_Package_Declaration |
2820 N_Formal_Private_Type_Definition |
2821 N_Formal_Signed_Integer_Type_Definition |
2823 N_Function_Specification |
2824 N_Generic_Association |
2825 N_Handled_Sequence_Of_Statements |
2828 N_Index_Or_Discriminant_Constraint |
2829 N_Indexed_Component |
2833 N_Loop_Parameter_Specification |
2835 N_Modular_Type_Definition |
2861 N_Op_Shift_Right_Arithmetic |
2865 N_Ordinary_Fixed_Point_Definition |
2867 N_Package_Specification |
2868 N_Parameter_Association |
2869 N_Parameter_Specification |
2870 N_Pop_Constraint_Error_Label |
2871 N_Pop_Program_Error_Label |
2872 N_Pop_Storage_Error_Label |
2873 N_Pragma_Argument_Association |
2874 N_Procedure_Specification |
2875 N_Protected_Definition |
2876 N_Push_Constraint_Error_Label |
2877 N_Push_Program_Error_Label |
2878 N_Push_Storage_Error_Label |
2879 N_Qualified_Expression |
2880 N_Quantified_Expression |
2882 N_Range_Constraint |
2884 N_Real_Range_Specification |
2885 N_Record_Definition |
2887 N_SCIL_Dispatch_Table_Tag_Init |
2888 N_SCIL_Dispatching_Call |
2889 N_SCIL_Membership_Test |
2890 N_Selected_Component |
2891 N_Signed_Integer_Type_Definition |
2892 N_Single_Protected_Declaration |
2896 N_Subtype_Indication |
2899 N_Terminate_Alternative |
2900 N_Triggering_Alternative |
2902 N_Unchecked_Expression |
2903 N_Unchecked_Type_Conversion |
2904 N_Unconstrained_Array_Definition |
2907 N_Use_Package_Clause |
2911 N_Validate_Unchecked_Conversion |
2918 -- Make sure that inserted actions stay in the transient scope
2920 if P
= Wrapped_Node
then
2921 Store_Before_Actions_In_Scope
(Ins_Actions
);
2925 -- If we fall through above tests, keep climbing tree
2929 if Nkind
(Parent
(N
)) = N_Subunit
then
2931 -- This is the proper body corresponding to a stub. Insertion must
2932 -- be done at the point of the stub, which is in the declarative
2933 -- part of the parent unit.
2935 P
:= Corresponding_Stub
(Parent
(N
));
2943 -- Version with check(s) suppressed
2945 procedure Insert_Actions
2946 (Assoc_Node
: Node_Id
;
2947 Ins_Actions
: List_Id
;
2948 Suppress
: Check_Id
)
2951 if Suppress
= All_Checks
then
2953 Svg
: constant Suppress_Array
:= Scope_Suppress
;
2955 Scope_Suppress
:= (others => True);
2956 Insert_Actions
(Assoc_Node
, Ins_Actions
);
2957 Scope_Suppress
:= Svg
;
2962 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
2964 Scope_Suppress
(Suppress
) := True;
2965 Insert_Actions
(Assoc_Node
, Ins_Actions
);
2966 Scope_Suppress
(Suppress
) := Svg
;
2971 --------------------------
2972 -- Insert_Actions_After --
2973 --------------------------
2975 procedure Insert_Actions_After
2976 (Assoc_Node
: Node_Id
;
2977 Ins_Actions
: List_Id
)
2980 if Scope_Is_Transient
2981 and then Assoc_Node
= Node_To_Be_Wrapped
2983 Store_After_Actions_In_Scope
(Ins_Actions
);
2985 Insert_List_After_And_Analyze
(Assoc_Node
, Ins_Actions
);
2987 end Insert_Actions_After
;
2989 ---------------------------------
2990 -- Insert_Library_Level_Action --
2991 ---------------------------------
2993 procedure Insert_Library_Level_Action
(N
: Node_Id
) is
2994 Aux
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Main_Unit
));
2997 Push_Scope
(Cunit_Entity
(Main_Unit
));
2998 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
3000 if No
(Actions
(Aux
)) then
3001 Set_Actions
(Aux
, New_List
(N
));
3003 Append
(N
, Actions
(Aux
));
3008 end Insert_Library_Level_Action
;
3010 ----------------------------------
3011 -- Insert_Library_Level_Actions --
3012 ----------------------------------
3014 procedure Insert_Library_Level_Actions
(L
: List_Id
) is
3015 Aux
: constant Node_Id
:= Aux_Decls_Node
(Cunit
(Main_Unit
));
3018 if Is_Non_Empty_List
(L
) then
3019 Push_Scope
(Cunit_Entity
(Main_Unit
));
3020 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
3022 if No
(Actions
(Aux
)) then
3023 Set_Actions
(Aux
, L
);
3026 Insert_List_After_And_Analyze
(Last
(Actions
(Aux
)), L
);
3031 end Insert_Library_Level_Actions
;
3033 ----------------------
3034 -- Inside_Init_Proc --
3035 ----------------------
3037 function Inside_Init_Proc
return Boolean is
3043 and then S
/= Standard_Standard
3045 if Is_Init_Proc
(S
) then
3053 end Inside_Init_Proc
;
3055 ----------------------------
3056 -- Is_All_Null_Statements --
3057 ----------------------------
3059 function Is_All_Null_Statements
(L
: List_Id
) return Boolean is
3064 while Present
(Stm
) loop
3065 if Nkind
(Stm
) /= N_Null_Statement
then
3073 end Is_All_Null_Statements
;
3075 ---------------------------------
3076 -- Is_Fully_Repped_Tagged_Type --
3077 ---------------------------------
3079 function Is_Fully_Repped_Tagged_Type
(T
: Entity_Id
) return Boolean is
3080 U
: constant Entity_Id
:= Underlying_Type
(T
);
3084 if No
(U
) or else not Is_Tagged_Type
(U
) then
3086 elsif Has_Discriminants
(U
) then
3088 elsif not Has_Specified_Layout
(U
) then
3092 -- Here we have a tagged type, see if it has any unlayed out fields
3093 -- other than a possible tag and parent fields. If so, we return False.
3095 Comp
:= First_Component
(U
);
3096 while Present
(Comp
) loop
3097 if not Is_Tag
(Comp
)
3098 and then Chars
(Comp
) /= Name_uParent
3099 and then No
(Component_Clause
(Comp
))
3103 Next_Component
(Comp
);
3107 -- All components are layed out
3110 end Is_Fully_Repped_Tagged_Type
;
3112 ----------------------------------
3113 -- Is_Library_Level_Tagged_Type --
3114 ----------------------------------
3116 function Is_Library_Level_Tagged_Type
(Typ
: Entity_Id
) return Boolean is
3118 return Is_Tagged_Type
(Typ
)
3119 and then Is_Library_Level_Entity
(Typ
);
3120 end Is_Library_Level_Tagged_Type
;
3122 ----------------------------------
3123 -- Is_Possibly_Unaligned_Object --
3124 ----------------------------------
3126 function Is_Possibly_Unaligned_Object
(N
: Node_Id
) return Boolean is
3127 T
: constant Entity_Id
:= Etype
(N
);
3130 -- If renamed object, apply test to underlying object
3132 if Is_Entity_Name
(N
)
3133 and then Is_Object
(Entity
(N
))
3134 and then Present
(Renamed_Object
(Entity
(N
)))
3136 return Is_Possibly_Unaligned_Object
(Renamed_Object
(Entity
(N
)));
3139 -- Tagged and controlled types and aliased types are always aligned,
3140 -- as are concurrent types.
3143 or else Has_Controlled_Component
(T
)
3144 or else Is_Concurrent_Type
(T
)
3145 or else Is_Tagged_Type
(T
)
3146 or else Is_Controlled
(T
)
3151 -- If this is an element of a packed array, may be unaligned
3153 if Is_Ref_To_Bit_Packed_Array
(N
) then
3157 -- Case of component reference
3159 if Nkind
(N
) = N_Selected_Component
then
3161 P
: constant Node_Id
:= Prefix
(N
);
3162 C
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
3167 -- If component reference is for an array with non-static bounds,
3168 -- then it is always aligned: we can only process unaligned
3169 -- arrays with static bounds (more accurately bounds known at
3172 if Is_Array_Type
(T
)
3173 and then not Compile_Time_Known_Bounds
(T
)
3178 -- If component is aliased, it is definitely properly aligned
3180 if Is_Aliased
(C
) then
3184 -- If component is for a type implemented as a scalar, and the
3185 -- record is packed, and the component is other than the first
3186 -- component of the record, then the component may be unaligned.
3188 if Is_Packed
(Etype
(P
))
3189 and then Represented_As_Scalar
(Etype
(C
))
3190 and then First_Entity
(Scope
(C
)) /= C
3195 -- Compute maximum possible alignment for T
3197 -- If alignment is known, then that settles things
3199 if Known_Alignment
(T
) then
3200 M
:= UI_To_Int
(Alignment
(T
));
3202 -- If alignment is not known, tentatively set max alignment
3205 M
:= Ttypes
.Maximum_Alignment
;
3207 -- We can reduce this if the Esize is known since the default
3208 -- alignment will never be more than the smallest power of 2
3209 -- that does not exceed this Esize value.
3211 if Known_Esize
(T
) then
3212 S
:= UI_To_Int
(Esize
(T
));
3214 while (M
/ 2) >= S
loop
3220 -- The following code is historical, it used to be present but it
3221 -- is too cautious, because the front-end does not know the proper
3222 -- default alignments for the target. Also, if the alignment is
3223 -- not known, the front end can't know in any case! If a copy is
3224 -- needed, the back-end will take care of it. This whole section
3225 -- including this comment can be removed later ???
3227 -- If the component reference is for a record that has a specified
3228 -- alignment, and we either know it is too small, or cannot tell,
3229 -- then the component may be unaligned.
3231 -- if Known_Alignment (Etype (P))
3232 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
3233 -- and then M > Alignment (Etype (P))
3238 -- Case of component clause present which may specify an
3239 -- unaligned position.
3241 if Present
(Component_Clause
(C
)) then
3243 -- Otherwise we can do a test to make sure that the actual
3244 -- start position in the record, and the length, are both
3245 -- consistent with the required alignment. If not, we know
3246 -- that we are unaligned.
3249 Align_In_Bits
: constant Nat
:= M
* System_Storage_Unit
;
3251 if Component_Bit_Offset
(C
) mod Align_In_Bits
/= 0
3252 or else Esize
(C
) mod Align_In_Bits
/= 0
3259 -- Otherwise, for a component reference, test prefix
3261 return Is_Possibly_Unaligned_Object
(P
);
3264 -- If not a component reference, must be aligned
3269 end Is_Possibly_Unaligned_Object
;
3271 ---------------------------------
3272 -- Is_Possibly_Unaligned_Slice --
3273 ---------------------------------
3275 function Is_Possibly_Unaligned_Slice
(N
: Node_Id
) return Boolean is
3277 -- Go to renamed object
3279 if Is_Entity_Name
(N
)
3280 and then Is_Object
(Entity
(N
))
3281 and then Present
(Renamed_Object
(Entity
(N
)))
3283 return Is_Possibly_Unaligned_Slice
(Renamed_Object
(Entity
(N
)));
3286 -- The reference must be a slice
3288 if Nkind
(N
) /= N_Slice
then
3292 -- Always assume the worst for a nested record component with a
3293 -- component clause, which gigi/gcc does not appear to handle well.
3294 -- It is not clear why this special test is needed at all ???
3296 if Nkind
(Prefix
(N
)) = N_Selected_Component
3297 and then Nkind
(Prefix
(Prefix
(N
))) = N_Selected_Component
3299 Present
(Component_Clause
(Entity
(Selector_Name
(Prefix
(N
)))))
3304 -- We only need to worry if the target has strict alignment
3306 if not Target_Strict_Alignment
then
3310 -- If it is a slice, then look at the array type being sliced
3313 Sarr
: constant Node_Id
:= Prefix
(N
);
3314 -- Prefix of the slice, i.e. the array being sliced
3316 Styp
: constant Entity_Id
:= Etype
(Prefix
(N
));
3317 -- Type of the array being sliced
3323 -- The problems arise if the array object that is being sliced
3324 -- is a component of a record or array, and we cannot guarantee
3325 -- the alignment of the array within its containing object.
3327 -- To investigate this, we look at successive prefixes to see
3328 -- if we have a worrisome indexed or selected component.
3332 -- Case of array is part of an indexed component reference
3334 if Nkind
(Pref
) = N_Indexed_Component
then
3335 Ptyp
:= Etype
(Prefix
(Pref
));
3337 -- The only problematic case is when the array is packed,
3338 -- in which case we really know nothing about the alignment
3339 -- of individual components.
3341 if Is_Bit_Packed_Array
(Ptyp
) then
3345 -- Case of array is part of a selected component reference
3347 elsif Nkind
(Pref
) = N_Selected_Component
then
3348 Ptyp
:= Etype
(Prefix
(Pref
));
3350 -- We are definitely in trouble if the record in question
3351 -- has an alignment, and either we know this alignment is
3352 -- inconsistent with the alignment of the slice, or we
3353 -- don't know what the alignment of the slice should be.
3355 if Known_Alignment
(Ptyp
)
3356 and then (Unknown_Alignment
(Styp
)
3357 or else Alignment
(Styp
) > Alignment
(Ptyp
))
3362 -- We are in potential trouble if the record type is packed.
3363 -- We could special case when we know that the array is the
3364 -- first component, but that's not such a simple case ???
3366 if Is_Packed
(Ptyp
) then
3370 -- We are in trouble if there is a component clause, and
3371 -- either we do not know the alignment of the slice, or
3372 -- the alignment of the slice is inconsistent with the
3373 -- bit position specified by the component clause.
3376 Field
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
3378 if Present
(Component_Clause
(Field
))
3380 (Unknown_Alignment
(Styp
)
3382 (Component_Bit_Offset
(Field
) mod
3383 (System_Storage_Unit
* Alignment
(Styp
))) /= 0)
3389 -- For cases other than selected or indexed components we
3390 -- know we are OK, since no issues arise over alignment.
3396 -- We processed an indexed component or selected component
3397 -- reference that looked safe, so keep checking prefixes.
3399 Pref
:= Prefix
(Pref
);
3402 end Is_Possibly_Unaligned_Slice
;
3404 --------------------------------
3405 -- Is_Ref_To_Bit_Packed_Array --
3406 --------------------------------
3408 function Is_Ref_To_Bit_Packed_Array
(N
: Node_Id
) return Boolean is
3413 if Is_Entity_Name
(N
)
3414 and then Is_Object
(Entity
(N
))
3415 and then Present
(Renamed_Object
(Entity
(N
)))
3417 return Is_Ref_To_Bit_Packed_Array
(Renamed_Object
(Entity
(N
)));
3420 if Nkind
(N
) = N_Indexed_Component
3422 Nkind
(N
) = N_Selected_Component
3424 if Is_Bit_Packed_Array
(Etype
(Prefix
(N
))) then
3427 Result
:= Is_Ref_To_Bit_Packed_Array
(Prefix
(N
));
3430 if Result
and then Nkind
(N
) = N_Indexed_Component
then
3431 Expr
:= First
(Expressions
(N
));
3432 while Present
(Expr
) loop
3433 Force_Evaluation
(Expr
);
3443 end Is_Ref_To_Bit_Packed_Array
;
3445 --------------------------------
3446 -- Is_Ref_To_Bit_Packed_Slice --
3447 --------------------------------
3449 function Is_Ref_To_Bit_Packed_Slice
(N
: Node_Id
) return Boolean is
3451 if Nkind
(N
) = N_Type_Conversion
then
3452 return Is_Ref_To_Bit_Packed_Slice
(Expression
(N
));
3454 elsif Is_Entity_Name
(N
)
3455 and then Is_Object
(Entity
(N
))
3456 and then Present
(Renamed_Object
(Entity
(N
)))
3458 return Is_Ref_To_Bit_Packed_Slice
(Renamed_Object
(Entity
(N
)));
3460 elsif Nkind
(N
) = N_Slice
3461 and then Is_Bit_Packed_Array
(Etype
(Prefix
(N
)))
3465 elsif Nkind
(N
) = N_Indexed_Component
3467 Nkind
(N
) = N_Selected_Component
3469 return Is_Ref_To_Bit_Packed_Slice
(Prefix
(N
));
3474 end Is_Ref_To_Bit_Packed_Slice
;
3476 -----------------------
3477 -- Is_Renamed_Object --
3478 -----------------------
3480 function Is_Renamed_Object
(N
: Node_Id
) return Boolean is
3481 Pnod
: constant Node_Id
:= Parent
(N
);
3482 Kind
: constant Node_Kind
:= Nkind
(Pnod
);
3484 if Kind
= N_Object_Renaming_Declaration
then
3486 elsif Nkind_In
(Kind
, N_Indexed_Component
, N_Selected_Component
) then
3487 return Is_Renamed_Object
(Pnod
);
3491 end Is_Renamed_Object
;
3493 ----------------------------
3494 -- Is_Untagged_Derivation --
3495 ----------------------------
3497 function Is_Untagged_Derivation
(T
: Entity_Id
) return Boolean is
3499 return (not Is_Tagged_Type
(T
) and then Is_Derived_Type
(T
))
3501 (Is_Private_Type
(T
) and then Present
(Full_View
(T
))
3502 and then not Is_Tagged_Type
(Full_View
(T
))
3503 and then Is_Derived_Type
(Full_View
(T
))
3504 and then Etype
(Full_View
(T
)) /= T
);
3505 end Is_Untagged_Derivation
;
3507 ---------------------------
3508 -- Is_Volatile_Reference --
3509 ---------------------------
3511 function Is_Volatile_Reference
(N
: Node_Id
) return Boolean is
3513 if Nkind
(N
) in N_Has_Etype
3514 and then Present
(Etype
(N
))
3515 and then Treat_As_Volatile
(Etype
(N
))
3519 elsif Is_Entity_Name
(N
) then
3520 return Treat_As_Volatile
(Entity
(N
));
3522 elsif Nkind
(N
) = N_Slice
then
3523 return Is_Volatile_Reference
(Prefix
(N
));
3525 elsif Nkind_In
(N
, N_Indexed_Component
, N_Selected_Component
) then
3526 if (Is_Entity_Name
(Prefix
(N
))
3527 and then Has_Volatile_Components
(Entity
(Prefix
(N
))))
3528 or else (Present
(Etype
(Prefix
(N
)))
3529 and then Has_Volatile_Components
(Etype
(Prefix
(N
))))
3533 return Is_Volatile_Reference
(Prefix
(N
));
3539 end Is_Volatile_Reference
;
3541 --------------------
3542 -- Kill_Dead_Code --
3543 --------------------
3545 procedure Kill_Dead_Code
(N
: Node_Id
; Warn
: Boolean := False) is
3546 W
: Boolean := Warn
;
3547 -- Set False if warnings suppressed
3551 Remove_Warning_Messages
(N
);
3553 -- Generate warning if appropriate
3557 -- We suppress the warning if this code is under control of an
3558 -- if statement, whose condition is a simple identifier, and
3559 -- either we are in an instance, or warnings off is set for this
3560 -- identifier. The reason for killing it in the instance case is
3561 -- that it is common and reasonable for code to be deleted in
3562 -- instances for various reasons.
3564 if Nkind
(Parent
(N
)) = N_If_Statement
then
3566 C
: constant Node_Id
:= Condition
(Parent
(N
));
3568 if Nkind
(C
) = N_Identifier
3571 or else (Present
(Entity
(C
))
3572 and then Has_Warnings_Off
(Entity
(C
))))
3579 -- Generate warning if not suppressed
3583 ("?this code can never be executed and has been deleted!", N
);
3587 -- Recurse into block statements and bodies to process declarations
3590 if Nkind
(N
) = N_Block_Statement
3591 or else Nkind
(N
) = N_Subprogram_Body
3592 or else Nkind
(N
) = N_Package_Body
3594 Kill_Dead_Code
(Declarations
(N
), False);
3595 Kill_Dead_Code
(Statements
(Handled_Statement_Sequence
(N
)));
3597 if Nkind
(N
) = N_Subprogram_Body
then
3598 Set_Is_Eliminated
(Defining_Entity
(N
));
3601 elsif Nkind
(N
) = N_Package_Declaration
then
3602 Kill_Dead_Code
(Visible_Declarations
(Specification
(N
)));
3603 Kill_Dead_Code
(Private_Declarations
(Specification
(N
)));
3605 -- ??? After this point, Delete_Tree has been called on all
3606 -- declarations in Specification (N), so references to
3607 -- entities therein look suspicious.
3610 E
: Entity_Id
:= First_Entity
(Defining_Entity
(N
));
3612 while Present
(E
) loop
3613 if Ekind
(E
) = E_Operator
then
3614 Set_Is_Eliminated
(E
);
3621 -- Recurse into composite statement to kill individual statements,
3622 -- in particular instantiations.
3624 elsif Nkind
(N
) = N_If_Statement
then
3625 Kill_Dead_Code
(Then_Statements
(N
));
3626 Kill_Dead_Code
(Elsif_Parts
(N
));
3627 Kill_Dead_Code
(Else_Statements
(N
));
3629 elsif Nkind
(N
) = N_Loop_Statement
then
3630 Kill_Dead_Code
(Statements
(N
));
3632 elsif Nkind
(N
) = N_Case_Statement
then
3636 Alt
:= First
(Alternatives
(N
));
3637 while Present
(Alt
) loop
3638 Kill_Dead_Code
(Statements
(Alt
));
3643 elsif Nkind
(N
) = N_Case_Statement_Alternative
then
3644 Kill_Dead_Code
(Statements
(N
));
3646 -- Deal with dead instances caused by deleting instantiations
3648 elsif Nkind
(N
) in N_Generic_Instantiation
then
3649 Remove_Dead_Instance
(N
);
3654 -- Case where argument is a list of nodes to be killed
3656 procedure Kill_Dead_Code
(L
: List_Id
; Warn
: Boolean := False) is
3661 if Is_Non_Empty_List
(L
) then
3663 while Present
(N
) loop
3664 Kill_Dead_Code
(N
, W
);
3671 ------------------------
3672 -- Known_Non_Negative --
3673 ------------------------
3675 function Known_Non_Negative
(Opnd
: Node_Id
) return Boolean is
3677 if Is_OK_Static_Expression
(Opnd
)
3678 and then Expr_Value
(Opnd
) >= 0
3684 Lo
: constant Node_Id
:= Type_Low_Bound
(Etype
(Opnd
));
3688 Is_OK_Static_Expression
(Lo
) and then Expr_Value
(Lo
) >= 0;
3691 end Known_Non_Negative
;
3693 --------------------
3694 -- Known_Non_Null --
3695 --------------------
3697 function Known_Non_Null
(N
: Node_Id
) return Boolean is
3699 -- Checks for case where N is an entity reference
3701 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
3703 E
: constant Entity_Id
:= Entity
(N
);
3708 -- First check if we are in decisive conditional
3710 Get_Current_Value_Condition
(N
, Op
, Val
);
3712 if Known_Null
(Val
) then
3713 if Op
= N_Op_Eq
then
3715 elsif Op
= N_Op_Ne
then
3720 -- If OK to do replacement, test Is_Known_Non_Null flag
3722 if OK_To_Do_Constant_Replacement
(E
) then
3723 return Is_Known_Non_Null
(E
);
3725 -- Otherwise if not safe to do replacement, then say so
3732 -- True if access attribute
3734 elsif Nkind
(N
) = N_Attribute_Reference
3735 and then (Attribute_Name
(N
) = Name_Access
3737 Attribute_Name
(N
) = Name_Unchecked_Access
3739 Attribute_Name
(N
) = Name_Unrestricted_Access
)
3743 -- True if allocator
3745 elsif Nkind
(N
) = N_Allocator
then
3748 -- For a conversion, true if expression is known non-null
3750 elsif Nkind
(N
) = N_Type_Conversion
then
3751 return Known_Non_Null
(Expression
(N
));
3753 -- Above are all cases where the value could be determined to be
3754 -- non-null. In all other cases, we don't know, so return False.
3765 function Known_Null
(N
: Node_Id
) return Boolean is
3767 -- Checks for case where N is an entity reference
3769 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
3771 E
: constant Entity_Id
:= Entity
(N
);
3776 -- Constant null value is for sure null
3778 if Ekind
(E
) = E_Constant
3779 and then Known_Null
(Constant_Value
(E
))
3784 -- First check if we are in decisive conditional
3786 Get_Current_Value_Condition
(N
, Op
, Val
);
3788 if Known_Null
(Val
) then
3789 if Op
= N_Op_Eq
then
3791 elsif Op
= N_Op_Ne
then
3796 -- If OK to do replacement, test Is_Known_Null flag
3798 if OK_To_Do_Constant_Replacement
(E
) then
3799 return Is_Known_Null
(E
);
3801 -- Otherwise if not safe to do replacement, then say so
3808 -- True if explicit reference to null
3810 elsif Nkind
(N
) = N_Null
then
3813 -- For a conversion, true if expression is known null
3815 elsif Nkind
(N
) = N_Type_Conversion
then
3816 return Known_Null
(Expression
(N
));
3818 -- Above are all cases where the value could be determined to be null.
3819 -- In all other cases, we don't know, so return False.
3826 -----------------------------
3827 -- Make_CW_Equivalent_Type --
3828 -----------------------------
3830 -- Create a record type used as an equivalent of any member of the class
3831 -- which takes its size from exp.
3833 -- Generate the following code:
3835 -- type Equiv_T is record
3836 -- _parent : T (List of discriminant constraints taken from Exp);
3837 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
3840 -- ??? Note that this type does not guarantee same alignment as all
3843 function Make_CW_Equivalent_Type
3845 E
: Node_Id
) return Entity_Id
3847 Loc
: constant Source_Ptr
:= Sloc
(E
);
3848 Root_Typ
: constant Entity_Id
:= Root_Type
(T
);
3849 List_Def
: constant List_Id
:= Empty_List
;
3850 Comp_List
: constant List_Id
:= New_List
;
3851 Equiv_Type
: Entity_Id
;
3852 Range_Type
: Entity_Id
;
3853 Str_Type
: Entity_Id
;
3854 Constr_Root
: Entity_Id
;
3858 -- If the root type is already constrained, there are no discriminants
3859 -- in the expression.
3861 if not Has_Discriminants
(Root_Typ
)
3862 or else Is_Constrained
(Root_Typ
)
3864 Constr_Root
:= Root_Typ
;
3866 Constr_Root
:= Make_Temporary
(Loc
, 'R');
3868 -- subtype cstr__n is T (List of discr constraints taken from Exp)
3870 Append_To
(List_Def
,
3871 Make_Subtype_Declaration
(Loc
,
3872 Defining_Identifier
=> Constr_Root
,
3873 Subtype_Indication
=> Make_Subtype_From_Expr
(E
, Root_Typ
)));
3876 -- Generate the range subtype declaration
3878 Range_Type
:= Make_Temporary
(Loc
, 'G');
3880 if not Is_Interface
(Root_Typ
) then
3882 -- subtype rg__xx is
3883 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
3886 Make_Op_Subtract
(Loc
,
3888 Make_Attribute_Reference
(Loc
,
3890 OK_Convert_To
(T
, Duplicate_Subexpr_No_Checks
(E
)),
3891 Attribute_Name
=> Name_Size
),
3893 Make_Attribute_Reference
(Loc
,
3894 Prefix
=> New_Reference_To
(Constr_Root
, Loc
),
3895 Attribute_Name
=> Name_Object_Size
));
3897 -- subtype rg__xx is
3898 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
3901 Make_Attribute_Reference
(Loc
,
3903 OK_Convert_To
(T
, Duplicate_Subexpr_No_Checks
(E
)),
3904 Attribute_Name
=> Name_Size
);
3907 Set_Paren_Count
(Sizexpr
, 1);
3909 Append_To
(List_Def
,
3910 Make_Subtype_Declaration
(Loc
,
3911 Defining_Identifier
=> Range_Type
,
3912 Subtype_Indication
=>
3913 Make_Subtype_Indication
(Loc
,
3914 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
),
3915 Constraint
=> Make_Range_Constraint
(Loc
,
3918 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
3920 Make_Op_Divide
(Loc
,
3921 Left_Opnd
=> Sizexpr
,
3922 Right_Opnd
=> Make_Integer_Literal
(Loc
,
3923 Intval
=> System_Storage_Unit
)))))));
3925 -- subtype str__nn is Storage_Array (rg__x);
3927 Str_Type
:= Make_Temporary
(Loc
, 'S');
3928 Append_To
(List_Def
,
3929 Make_Subtype_Declaration
(Loc
,
3930 Defining_Identifier
=> Str_Type
,
3931 Subtype_Indication
=>
3932 Make_Subtype_Indication
(Loc
,
3933 Subtype_Mark
=> New_Reference_To
(RTE
(RE_Storage_Array
), Loc
),
3935 Make_Index_Or_Discriminant_Constraint
(Loc
,
3937 New_List
(New_Reference_To
(Range_Type
, Loc
))))));
3939 -- type Equiv_T is record
3940 -- [ _parent : Tnn; ]
3944 Equiv_Type
:= Make_Temporary
(Loc
, 'T');
3945 Set_Ekind
(Equiv_Type
, E_Record_Type
);
3946 Set_Parent_Subtype
(Equiv_Type
, Constr_Root
);
3948 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
3949 -- treatment for this type. In particular, even though _parent's type
3950 -- is a controlled type or contains controlled components, we do not
3951 -- want to set Has_Controlled_Component on it to avoid making it gain
3952 -- an unwanted _controller component.
3954 Set_Is_Class_Wide_Equivalent_Type
(Equiv_Type
);
3956 if not Is_Interface
(Root_Typ
) then
3957 Append_To
(Comp_List
,
3958 Make_Component_Declaration
(Loc
,
3959 Defining_Identifier
=>
3960 Make_Defining_Identifier
(Loc
, Name_uParent
),
3961 Component_Definition
=>
3962 Make_Component_Definition
(Loc
,
3963 Aliased_Present
=> False,
3964 Subtype_Indication
=> New_Reference_To
(Constr_Root
, Loc
))));
3967 Append_To
(Comp_List
,
3968 Make_Component_Declaration
(Loc
,
3969 Defining_Identifier
=> Make_Temporary
(Loc
, 'C'),
3970 Component_Definition
=>
3971 Make_Component_Definition
(Loc
,
3972 Aliased_Present
=> False,
3973 Subtype_Indication
=> New_Reference_To
(Str_Type
, Loc
))));
3975 Append_To
(List_Def
,
3976 Make_Full_Type_Declaration
(Loc
,
3977 Defining_Identifier
=> Equiv_Type
,
3979 Make_Record_Definition
(Loc
,
3981 Make_Component_List
(Loc
,
3982 Component_Items
=> Comp_List
,
3983 Variant_Part
=> Empty
))));
3985 -- Suppress all checks during the analysis of the expanded code
3986 -- to avoid the generation of spurious warnings under ZFP run-time.
3988 Insert_Actions
(E
, List_Def
, Suppress
=> All_Checks
);
3990 end Make_CW_Equivalent_Type
;
3992 -------------------------
3993 -- Make_Invariant_Call --
3994 -------------------------
3996 function Make_Invariant_Call
(Expr
: Node_Id
) return Node_Id
is
3997 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
3998 Typ
: constant Entity_Id
:= Etype
(Expr
);
4001 if Check_Enabled
(Name_Invariant
)
4003 Check_Enabled
(Name_Assertion
)
4006 Make_Procedure_Call_Statement
(Loc
,
4008 New_Occurrence_Of
(Invariant_Procedure
(Typ
), Loc
),
4009 Parameter_Associations
=> New_List
(Relocate_Node
(Expr
)));
4013 Make_Null_Statement
(Loc
);
4015 end Make_Invariant_Call
;
4017 ------------------------
4018 -- Make_Literal_Range --
4019 ------------------------
4021 function Make_Literal_Range
4023 Literal_Typ
: Entity_Id
) return Node_Id
4025 Lo
: constant Node_Id
:=
4026 New_Copy_Tree
(String_Literal_Low_Bound
(Literal_Typ
));
4027 Index
: constant Entity_Id
:= Etype
(Lo
);
4030 Length_Expr
: constant Node_Id
:=
4031 Make_Op_Subtract
(Loc
,
4033 Make_Integer_Literal
(Loc
,
4034 Intval
=> String_Literal_Length
(Literal_Typ
)),
4036 Make_Integer_Literal
(Loc
, 1));
4039 Set_Analyzed
(Lo
, False);
4041 if Is_Integer_Type
(Index
) then
4044 Left_Opnd
=> New_Copy_Tree
(Lo
),
4045 Right_Opnd
=> Length_Expr
);
4048 Make_Attribute_Reference
(Loc
,
4049 Attribute_Name
=> Name_Val
,
4050 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
4051 Expressions
=> New_List
(
4054 Make_Attribute_Reference
(Loc
,
4055 Attribute_Name
=> Name_Pos
,
4056 Prefix
=> New_Occurrence_Of
(Index
, Loc
),
4057 Expressions
=> New_List
(New_Copy_Tree
(Lo
))),
4058 Right_Opnd
=> Length_Expr
)));
4065 end Make_Literal_Range
;
4067 --------------------------
4068 -- Make_Non_Empty_Check --
4069 --------------------------
4071 function Make_Non_Empty_Check
4073 N
: Node_Id
) return Node_Id
4079 Make_Attribute_Reference
(Loc
,
4080 Attribute_Name
=> Name_Length
,
4081 Prefix
=> Duplicate_Subexpr_No_Checks
(N
, Name_Req
=> True)),
4083 Make_Integer_Literal
(Loc
, 0));
4084 end Make_Non_Empty_Check
;
4086 ----------------------------
4087 -- Make_Subtype_From_Expr --
4088 ----------------------------
4090 -- 1. If Expr is an unconstrained array expression, creates
4091 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
4093 -- 2. If Expr is a unconstrained discriminated type expression, creates
4094 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
4096 -- 3. If Expr is class-wide, creates an implicit class wide subtype
4098 function Make_Subtype_From_Expr
4100 Unc_Typ
: Entity_Id
) return Node_Id
4102 Loc
: constant Source_Ptr
:= Sloc
(E
);
4103 List_Constr
: constant List_Id
:= New_List
;
4106 Full_Subtyp
: Entity_Id
;
4107 Priv_Subtyp
: Entity_Id
;
4112 if Is_Private_Type
(Unc_Typ
)
4113 and then Has_Unknown_Discriminants
(Unc_Typ
)
4115 -- Prepare the subtype completion, Go to base type to
4116 -- find underlying type, because the type may be a generic
4117 -- actual or an explicit subtype.
4119 Utyp
:= Underlying_Type
(Base_Type
(Unc_Typ
));
4120 Full_Subtyp
:= Make_Temporary
(Loc
, 'C');
4122 Unchecked_Convert_To
(Utyp
, Duplicate_Subexpr_No_Checks
(E
));
4123 Set_Parent
(Full_Exp
, Parent
(E
));
4125 Priv_Subtyp
:= Make_Temporary
(Loc
, 'P');
4128 Make_Subtype_Declaration
(Loc
,
4129 Defining_Identifier
=> Full_Subtyp
,
4130 Subtype_Indication
=> Make_Subtype_From_Expr
(Full_Exp
, Utyp
)));
4132 -- Define the dummy private subtype
4134 Set_Ekind
(Priv_Subtyp
, Subtype_Kind
(Ekind
(Unc_Typ
)));
4135 Set_Etype
(Priv_Subtyp
, Base_Type
(Unc_Typ
));
4136 Set_Scope
(Priv_Subtyp
, Full_Subtyp
);
4137 Set_Is_Constrained
(Priv_Subtyp
);
4138 Set_Is_Tagged_Type
(Priv_Subtyp
, Is_Tagged_Type
(Unc_Typ
));
4139 Set_Is_Itype
(Priv_Subtyp
);
4140 Set_Associated_Node_For_Itype
(Priv_Subtyp
, E
);
4142 if Is_Tagged_Type
(Priv_Subtyp
) then
4144 (Base_Type
(Priv_Subtyp
), Class_Wide_Type
(Unc_Typ
));
4145 Set_Direct_Primitive_Operations
(Priv_Subtyp
,
4146 Direct_Primitive_Operations
(Unc_Typ
));
4149 Set_Full_View
(Priv_Subtyp
, Full_Subtyp
);
4151 return New_Reference_To
(Priv_Subtyp
, Loc
);
4153 elsif Is_Array_Type
(Unc_Typ
) then
4154 for J
in 1 .. Number_Dimensions
(Unc_Typ
) loop
4155 Append_To
(List_Constr
,
4158 Make_Attribute_Reference
(Loc
,
4159 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
4160 Attribute_Name
=> Name_First
,
4161 Expressions
=> New_List
(
4162 Make_Integer_Literal
(Loc
, J
))),
4165 Make_Attribute_Reference
(Loc
,
4166 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
4167 Attribute_Name
=> Name_Last
,
4168 Expressions
=> New_List
(
4169 Make_Integer_Literal
(Loc
, J
)))));
4172 elsif Is_Class_Wide_Type
(Unc_Typ
) then
4174 CW_Subtype
: Entity_Id
;
4175 EQ_Typ
: Entity_Id
:= Empty
;
4178 -- A class-wide equivalent type is not needed when VM_Target
4179 -- because the VM back-ends handle the class-wide object
4180 -- initialization itself (and doesn't need or want the
4181 -- additional intermediate type to handle the assignment).
4183 if Expander_Active
and then Tagged_Type_Expansion
then
4185 -- If this is the class_wide type of a completion that is
4186 -- a record subtype, set the type of the class_wide type
4187 -- to be the full base type, for use in the expanded code
4188 -- for the equivalent type. Should this be done earlier when
4189 -- the completion is analyzed ???
4191 if Is_Private_Type
(Etype
(Unc_Typ
))
4193 Ekind
(Full_View
(Etype
(Unc_Typ
))) = E_Record_Subtype
4195 Set_Etype
(Unc_Typ
, Base_Type
(Full_View
(Etype
(Unc_Typ
))));
4198 EQ_Typ
:= Make_CW_Equivalent_Type
(Unc_Typ
, E
);
4201 CW_Subtype
:= New_Class_Wide_Subtype
(Unc_Typ
, E
);
4202 Set_Equivalent_Type
(CW_Subtype
, EQ_Typ
);
4203 Set_Cloned_Subtype
(CW_Subtype
, Base_Type
(Unc_Typ
));
4205 return New_Occurrence_Of
(CW_Subtype
, Loc
);
4208 -- Indefinite record type with discriminants
4211 D
:= First_Discriminant
(Unc_Typ
);
4212 while Present
(D
) loop
4213 Append_To
(List_Constr
,
4214 Make_Selected_Component
(Loc
,
4215 Prefix
=> Duplicate_Subexpr_No_Checks
(E
),
4216 Selector_Name
=> New_Reference_To
(D
, Loc
)));
4218 Next_Discriminant
(D
);
4223 Make_Subtype_Indication
(Loc
,
4224 Subtype_Mark
=> New_Reference_To
(Unc_Typ
, Loc
),
4226 Make_Index_Or_Discriminant_Constraint
(Loc
,
4227 Constraints
=> List_Constr
));
4228 end Make_Subtype_From_Expr
;
4230 -----------------------------
4231 -- May_Generate_Large_Temp --
4232 -----------------------------
4234 -- At the current time, the only types that we return False for (i.e.
4235 -- where we decide we know they cannot generate large temps) are ones
4236 -- where we know the size is 256 bits or less at compile time, and we
4237 -- are still not doing a thorough job on arrays and records ???
4239 function May_Generate_Large_Temp
(Typ
: Entity_Id
) return Boolean is
4241 if not Size_Known_At_Compile_Time
(Typ
) then
4244 elsif Esize
(Typ
) /= 0 and then Esize
(Typ
) <= 256 then
4247 elsif Is_Array_Type
(Typ
)
4248 and then Present
(Packed_Array_Type
(Typ
))
4250 return May_Generate_Large_Temp
(Packed_Array_Type
(Typ
));
4252 -- We could do more here to find other small types ???
4257 end May_Generate_Large_Temp
;
4259 ----------------------------
4260 -- Needs_Constant_Address --
4261 ----------------------------
4263 function Needs_Constant_Address
4265 Typ
: Entity_Id
) return Boolean
4269 -- If we have no initialization of any kind, then we don't need to
4270 -- place any restrictions on the address clause, because the object
4271 -- will be elaborated after the address clause is evaluated. This
4272 -- happens if the declaration has no initial expression, or the type
4273 -- has no implicit initialization, or the object is imported.
4275 -- The same holds for all initialized scalar types and all access
4276 -- types. Packed bit arrays of size up to 64 are represented using a
4277 -- modular type with an initialization (to zero) and can be processed
4278 -- like other initialized scalar types.
4280 -- If the type is controlled, code to attach the object to a
4281 -- finalization chain is generated at the point of declaration,
4282 -- and therefore the elaboration of the object cannot be delayed:
4283 -- the address expression must be a constant.
4285 if No
(Expression
(Decl
))
4286 and then not Needs_Finalization
(Typ
)
4288 (not Has_Non_Null_Base_Init_Proc
(Typ
)
4289 or else Is_Imported
(Defining_Identifier
(Decl
)))
4293 elsif (Present
(Expression
(Decl
)) and then Is_Scalar_Type
(Typ
))
4294 or else Is_Access_Type
(Typ
)
4296 (Is_Bit_Packed_Array
(Typ
)
4297 and then Is_Modular_Integer_Type
(Packed_Array_Type
(Typ
)))
4303 -- Otherwise, we require the address clause to be constant because
4304 -- the call to the initialization procedure (or the attach code) has
4305 -- to happen at the point of the declaration.
4307 -- Actually the IP call has been moved to the freeze actions
4308 -- anyway, so maybe we can relax this restriction???
4312 end Needs_Constant_Address
;
4314 ----------------------------
4315 -- New_Class_Wide_Subtype --
4316 ----------------------------
4318 function New_Class_Wide_Subtype
4319 (CW_Typ
: Entity_Id
;
4320 N
: Node_Id
) return Entity_Id
4322 Res
: constant Entity_Id
:= Create_Itype
(E_Void
, N
);
4323 Res_Name
: constant Name_Id
:= Chars
(Res
);
4324 Res_Scope
: constant Entity_Id
:= Scope
(Res
);
4327 Copy_Node
(CW_Typ
, Res
);
4328 Set_Comes_From_Source
(Res
, False);
4329 Set_Sloc
(Res
, Sloc
(N
));
4331 Set_Associated_Node_For_Itype
(Res
, N
);
4332 Set_Is_Public
(Res
, False); -- By default, may be changed below.
4333 Set_Public_Status
(Res
);
4334 Set_Chars
(Res
, Res_Name
);
4335 Set_Scope
(Res
, Res_Scope
);
4336 Set_Ekind
(Res
, E_Class_Wide_Subtype
);
4337 Set_Next_Entity
(Res
, Empty
);
4338 Set_Etype
(Res
, Base_Type
(CW_Typ
));
4339 Set_Is_Frozen
(Res
, False);
4340 Set_Freeze_Node
(Res
, Empty
);
4342 end New_Class_Wide_Subtype
;
4344 --------------------------------
4345 -- Non_Limited_Designated_Type --
4346 ---------------------------------
4348 function Non_Limited_Designated_Type
(T
: Entity_Id
) return Entity_Id
is
4349 Desig
: constant Entity_Id
:= Designated_Type
(T
);
4351 if Ekind
(Desig
) = E_Incomplete_Type
4352 and then Present
(Non_Limited_View
(Desig
))
4354 return Non_Limited_View
(Desig
);
4358 end Non_Limited_Designated_Type
;
4360 -----------------------------------
4361 -- OK_To_Do_Constant_Replacement --
4362 -----------------------------------
4364 function OK_To_Do_Constant_Replacement
(E
: Entity_Id
) return Boolean is
4365 ES
: constant Entity_Id
:= Scope
(E
);
4369 -- Do not replace statically allocated objects, because they may be
4370 -- modified outside the current scope.
4372 if Is_Statically_Allocated
(E
) then
4375 -- Do not replace aliased or volatile objects, since we don't know what
4376 -- else might change the value.
4378 elsif Is_Aliased
(E
) or else Treat_As_Volatile
(E
) then
4381 -- Debug flag -gnatdM disconnects this optimization
4383 elsif Debug_Flag_MM
then
4386 -- Otherwise check scopes
4389 CS
:= Current_Scope
;
4392 -- If we are in right scope, replacement is safe
4397 -- Packages do not affect the determination of safety
4399 elsif Ekind
(CS
) = E_Package
then
4400 exit when CS
= Standard_Standard
;
4403 -- Blocks do not affect the determination of safety
4405 elsif Ekind
(CS
) = E_Block
then
4408 -- Loops do not affect the determination of safety. Note that we
4409 -- kill all current values on entry to a loop, so we are just
4410 -- talking about processing within a loop here.
4412 elsif Ekind
(CS
) = E_Loop
then
4415 -- Otherwise, the reference is dubious, and we cannot be sure that
4416 -- it is safe to do the replacement.
4425 end OK_To_Do_Constant_Replacement
;
4427 ------------------------------------
4428 -- Possible_Bit_Aligned_Component --
4429 ------------------------------------
4431 function Possible_Bit_Aligned_Component
(N
: Node_Id
) return Boolean is
4435 -- Case of indexed component
4437 when N_Indexed_Component
=>
4439 P
: constant Node_Id
:= Prefix
(N
);
4440 Ptyp
: constant Entity_Id
:= Etype
(P
);
4443 -- If we know the component size and it is less than 64, then
4444 -- we are definitely OK. The back end always does assignment of
4445 -- misaligned small objects correctly.
4447 if Known_Static_Component_Size
(Ptyp
)
4448 and then Component_Size
(Ptyp
) <= 64
4452 -- Otherwise, we need to test the prefix, to see if we are
4453 -- indexing from a possibly unaligned component.
4456 return Possible_Bit_Aligned_Component
(P
);
4460 -- Case of selected component
4462 when N_Selected_Component
=>
4464 P
: constant Node_Id
:= Prefix
(N
);
4465 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
4468 -- If there is no component clause, then we are in the clear
4469 -- since the back end will never misalign a large component
4470 -- unless it is forced to do so. In the clear means we need
4471 -- only the recursive test on the prefix.
4473 if Component_May_Be_Bit_Aligned
(Comp
) then
4476 return Possible_Bit_Aligned_Component
(P
);
4480 -- For a slice, test the prefix, if that is possibly misaligned,
4481 -- then for sure the slice is!
4484 return Possible_Bit_Aligned_Component
(Prefix
(N
));
4486 -- If we have none of the above, it means that we have fallen off the
4487 -- top testing prefixes recursively, and we now have a stand alone
4488 -- object, where we don't have a problem.
4494 end Possible_Bit_Aligned_Component
;
4496 -------------------------
4497 -- Remove_Side_Effects --
4498 -------------------------
4500 procedure Remove_Side_Effects
4502 Name_Req
: Boolean := False;
4503 Variable_Ref
: Boolean := False)
4505 Loc
: constant Source_Ptr
:= Sloc
(Exp
);
4506 Exp_Type
: constant Entity_Id
:= Etype
(Exp
);
4507 Svg_Suppress
: constant Suppress_Array
:= Scope_Suppress
;
4509 Ref_Type
: Entity_Id
;
4511 Ptr_Typ_Decl
: Node_Id
;
4515 function Side_Effect_Free
(N
: Node_Id
) return Boolean;
4516 -- Determines if the tree N represents an expression that is known not
4517 -- to have side effects, and for which no processing is required.
4519 function Side_Effect_Free
(L
: List_Id
) return Boolean;
4520 -- Determines if all elements of the list L are side effect free
4522 function Safe_Prefixed_Reference
(N
: Node_Id
) return Boolean;
4523 -- The argument N is a construct where the Prefix is dereferenced if it
4524 -- is an access type and the result is a variable. The call returns True
4525 -- if the construct is side effect free (not considering side effects in
4526 -- other than the prefix which are to be tested by the caller).
4528 function Within_In_Parameter
(N
: Node_Id
) return Boolean;
4529 -- Determines if N is a subcomponent of a composite in-parameter. If so,
4530 -- N is not side-effect free when the actual is global and modifiable
4531 -- indirectly from within a subprogram, because it may be passed by
4532 -- reference. The front-end must be conservative here and assume that
4533 -- this may happen with any array or record type. On the other hand, we
4534 -- cannot create temporaries for all expressions for which this
4535 -- condition is true, for various reasons that might require clearing up
4536 -- ??? For example, discriminant references that appear out of place, or
4537 -- spurious type errors with class-wide expressions. As a result, we
4538 -- limit the transformation to loop bounds, which is so far the only
4539 -- case that requires it.
4541 -----------------------------
4542 -- Safe_Prefixed_Reference --
4543 -----------------------------
4545 function Safe_Prefixed_Reference
(N
: Node_Id
) return Boolean is
4547 -- If prefix is not side effect free, definitely not safe
4549 if not Side_Effect_Free
(Prefix
(N
)) then
4552 -- If the prefix is of an access type that is not access-to-constant,
4553 -- then this construct is a variable reference, which means it is to
4554 -- be considered to have side effects if Variable_Ref is set True
4555 -- Exception is an access to an entity that is a constant or an
4556 -- in-parameter which does not come from source, and is the result
4557 -- of a previous removal of side-effects.
4559 elsif Is_Access_Type
(Etype
(Prefix
(N
)))
4560 and then not Is_Access_Constant
(Etype
(Prefix
(N
)))
4561 and then Variable_Ref
4563 if not Is_Entity_Name
(Prefix
(N
)) then
4566 return Ekind
(Entity
(Prefix
(N
))) = E_Constant
4567 or else Ekind
(Entity
(Prefix
(N
))) = E_In_Parameter
;
4570 -- If the prefix is an explicit dereference then this construct is a
4571 -- variable reference, which means it is to be considered to have
4572 -- side effects if Variable_Ref is True.
4574 -- We do NOT exclude dereferences of access-to-constant types because
4575 -- we handle them as constant view of variables.
4577 -- Exception is an access to an entity that is a constant or an
4580 elsif Nkind
(Prefix
(N
)) = N_Explicit_Dereference
4581 and then Variable_Ref
4584 DDT
: constant Entity_Id
:=
4585 Designated_Type
(Etype
(Prefix
(Prefix
(N
))));
4587 return Ekind_In
(DDT
, E_Constant
, E_In_Parameter
);
4590 -- The following test is the simplest way of solving a complex
4591 -- problem uncovered by BB08-010: Side effect on loop bound that
4592 -- is a subcomponent of a global variable:
4593 -- If a loop bound is a subcomponent of a global variable, a
4594 -- modification of that variable within the loop may incorrectly
4595 -- affect the execution of the loop.
4598 (Nkind
(Parent
(Parent
(N
))) /= N_Loop_Parameter_Specification
4599 or else not Within_In_Parameter
(Prefix
(N
)))
4603 -- All other cases are side effect free
4608 end Safe_Prefixed_Reference
;
4610 ----------------------
4611 -- Side_Effect_Free --
4612 ----------------------
4614 function Side_Effect_Free
(N
: Node_Id
) return Boolean is
4616 -- Note on checks that could raise Constraint_Error. Strictly, if we
4617 -- take advantage of 11.6, these checks do not count as side effects.
4618 -- However, we would prefer to consider that they are side effects,
4619 -- since the backend CSE does not work very well on expressions which
4620 -- can raise Constraint_Error. On the other hand if we don't consider
4621 -- them to be side effect free, then we get some awkward expansions
4622 -- in -gnato mode, resulting in code insertions at a point where we
4623 -- do not have a clear model for performing the insertions.
4625 -- Special handling for entity names
4627 if Is_Entity_Name
(N
) then
4629 -- If the entity is a constant, it is definitely side effect
4630 -- free. Note that the test of Is_Variable (N) below might
4631 -- be expected to catch this case, but it does not, because
4632 -- this test goes to the original tree, and we may have
4633 -- already rewritten a variable node with a constant as
4634 -- a result of an earlier Force_Evaluation call.
4636 if Ekind_In
(Entity
(N
), E_Constant
, E_In_Parameter
) then
4639 -- Functions are not side effect free
4641 elsif Ekind
(Entity
(N
)) = E_Function
then
4644 -- Variables are considered to be a side effect if Variable_Ref
4645 -- is set or if we have a volatile reference and Name_Req is off.
4646 -- If Name_Req is True then we can't help returning a name which
4647 -- effectively allows multiple references in any case.
4649 elsif Is_Variable
(N
) then
4650 return not Variable_Ref
4651 and then (not Is_Volatile_Reference
(N
) or else Name_Req
);
4653 -- Any other entity (e.g. a subtype name) is definitely side
4660 -- A value known at compile time is always side effect free
4662 elsif Compile_Time_Known_Value
(N
) then
4665 -- A variable renaming is not side-effect free, because the
4666 -- renaming will function like a macro in the front-end in
4667 -- some cases, and an assignment can modify the component
4668 -- designated by N, so we need to create a temporary for it.
4670 elsif Is_Entity_Name
(Original_Node
(N
))
4671 and then Is_Renaming_Of_Object
(Entity
(Original_Node
(N
)))
4672 and then Ekind
(Entity
(Original_Node
(N
))) /= E_Constant
4676 -- Remove_Side_Effects generates an object renaming declaration to
4677 -- capture the expression of a class-wide expression. In VM targets
4678 -- the frontend performs no expansion for dispatching calls to
4679 -- class-wide types since they are handled by the VM. Hence, we must
4680 -- locate here if this node corresponds to a previous invocation of
4681 -- Remove_Side_Effects to avoid a never ending loop in the frontend.
4683 elsif VM_Target
/= No_VM
4684 and then not Comes_From_Source
(N
)
4685 and then Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
4686 and then Is_Class_Wide_Type
(Etype
(N
))
4691 -- For other than entity names and compile time known values,
4692 -- check the node kind for special processing.
4696 -- An attribute reference is side effect free if its expressions
4697 -- are side effect free and its prefix is side effect free or
4698 -- is an entity reference.
4700 -- Is this right? what about x'first where x is a variable???
4702 when N_Attribute_Reference
=>
4703 return Side_Effect_Free
(Expressions
(N
))
4704 and then Attribute_Name
(N
) /= Name_Input
4705 and then (Is_Entity_Name
(Prefix
(N
))
4706 or else Side_Effect_Free
(Prefix
(N
)));
4708 -- A binary operator is side effect free if and both operands
4709 -- are side effect free. For this purpose binary operators
4710 -- include membership tests and short circuit forms
4712 when N_Binary_Op | N_Membership_Test | N_Short_Circuit
=>
4713 return Side_Effect_Free
(Left_Opnd
(N
))
4715 Side_Effect_Free
(Right_Opnd
(N
));
4717 -- An explicit dereference is side effect free only if it is
4718 -- a side effect free prefixed reference.
4720 when N_Explicit_Dereference
=>
4721 return Safe_Prefixed_Reference
(N
);
4723 -- A call to _rep_to_pos is side effect free, since we generate
4724 -- this pure function call ourselves. Moreover it is critically
4725 -- important to make this exception, since otherwise we can
4726 -- have discriminants in array components which don't look
4727 -- side effect free in the case of an array whose index type
4728 -- is an enumeration type with an enumeration rep clause.
4730 -- All other function calls are not side effect free
4732 when N_Function_Call
=>
4733 return Nkind
(Name
(N
)) = N_Identifier
4734 and then Is_TSS
(Name
(N
), TSS_Rep_To_Pos
)
4736 Side_Effect_Free
(First
(Parameter_Associations
(N
)));
4738 -- An indexed component is side effect free if it is a side
4739 -- effect free prefixed reference and all the indexing
4740 -- expressions are side effect free.
4742 when N_Indexed_Component
=>
4743 return Side_Effect_Free
(Expressions
(N
))
4744 and then Safe_Prefixed_Reference
(N
);
4746 -- A type qualification is side effect free if the expression
4747 -- is side effect free.
4749 when N_Qualified_Expression
=>
4750 return Side_Effect_Free
(Expression
(N
));
4752 -- A selected component is side effect free only if it is a
4753 -- side effect free prefixed reference. If it designates a
4754 -- component with a rep. clause it must be treated has having
4755 -- a potential side effect, because it may be modified through
4756 -- a renaming, and a subsequent use of the renaming as a macro
4757 -- will yield the wrong value. This complex interaction between
4758 -- renaming and removing side effects is a reminder that the
4759 -- latter has become a headache to maintain, and that it should
4760 -- be removed in favor of the gcc mechanism to capture values ???
4762 when N_Selected_Component
=>
4763 if Nkind
(Parent
(N
)) = N_Explicit_Dereference
4764 and then Has_Non_Standard_Rep
(Designated_Type
(Etype
(N
)))
4768 return Safe_Prefixed_Reference
(N
);
4771 -- A range is side effect free if the bounds are side effect free
4774 return Side_Effect_Free
(Low_Bound
(N
))
4775 and then Side_Effect_Free
(High_Bound
(N
));
4777 -- A slice is side effect free if it is a side effect free
4778 -- prefixed reference and the bounds are side effect free.
4781 return Side_Effect_Free
(Discrete_Range
(N
))
4782 and then Safe_Prefixed_Reference
(N
);
4784 -- A type conversion is side effect free if the expression to be
4785 -- converted is side effect free.
4787 when N_Type_Conversion
=>
4788 return Side_Effect_Free
(Expression
(N
));
4790 -- A unary operator is side effect free if the operand
4791 -- is side effect free.
4794 return Side_Effect_Free
(Right_Opnd
(N
));
4796 -- An unchecked type conversion is side effect free only if it
4797 -- is safe and its argument is side effect free.
4799 when N_Unchecked_Type_Conversion
=>
4800 return Safe_Unchecked_Type_Conversion
(N
)
4801 and then Side_Effect_Free
(Expression
(N
));
4803 -- An unchecked expression is side effect free if its expression
4804 -- is side effect free.
4806 when N_Unchecked_Expression
=>
4807 return Side_Effect_Free
(Expression
(N
));
4809 -- A literal is side effect free
4811 when N_Character_Literal |
4817 -- We consider that anything else has side effects. This is a bit
4818 -- crude, but we are pretty close for most common cases, and we
4819 -- are certainly correct (i.e. we never return True when the
4820 -- answer should be False).
4825 end Side_Effect_Free
;
4827 -- A list is side effect free if all elements of the list are
4828 -- side effect free.
4830 function Side_Effect_Free
(L
: List_Id
) return Boolean is
4834 if L
= No_List
or else L
= Error_List
then
4839 while Present
(N
) loop
4840 if not Side_Effect_Free
(N
) then
4849 end Side_Effect_Free
;
4851 -------------------------
4852 -- Within_In_Parameter --
4853 -------------------------
4855 function Within_In_Parameter
(N
: Node_Id
) return Boolean is
4857 if not Comes_From_Source
(N
) then
4860 elsif Is_Entity_Name
(N
) then
4861 return Ekind
(Entity
(N
)) = E_In_Parameter
;
4863 elsif Nkind
(N
) = N_Indexed_Component
4864 or else Nkind
(N
) = N_Selected_Component
4866 return Within_In_Parameter
(Prefix
(N
));
4871 end Within_In_Parameter
;
4873 -- Start of processing for Remove_Side_Effects
4876 -- If we are side effect free already or expansion is disabled,
4877 -- there is nothing to do.
4879 if Side_Effect_Free
(Exp
) or else not Expander_Active
then
4883 -- All this must not have any checks
4885 Scope_Suppress
:= (others => True);
4887 -- If it is a scalar type and we need to capture the value, just make
4888 -- a copy. Likewise for a function call, an attribute reference, an
4889 -- allocator, or an operator. And if we have a volatile reference and
4890 -- Name_Req is not set (see comments above for Side_Effect_Free).
4892 if Is_Elementary_Type
(Exp_Type
)
4893 and then (Variable_Ref
4894 or else Nkind
(Exp
) = N_Function_Call
4895 or else Nkind
(Exp
) = N_Attribute_Reference
4896 or else Nkind
(Exp
) = N_Allocator
4897 or else Nkind
(Exp
) in N_Op
4898 or else (not Name_Req
and then Is_Volatile_Reference
(Exp
)))
4900 Def_Id
:= Make_Temporary
(Loc
, 'R', Exp
);
4901 Set_Etype
(Def_Id
, Exp_Type
);
4902 Res
:= New_Reference_To
(Def_Id
, Loc
);
4904 -- If the expression is a packed reference, it must be reanalyzed
4905 -- and expanded, depending on context. This is the case for actuals
4906 -- where a constraint check may capture the actual before expansion
4907 -- of the call is complete.
4909 if Nkind
(Exp
) = N_Indexed_Component
4910 and then Is_Packed
(Etype
(Prefix
(Exp
)))
4912 Set_Analyzed
(Exp
, False);
4913 Set_Analyzed
(Prefix
(Exp
), False);
4917 Make_Object_Declaration
(Loc
,
4918 Defining_Identifier
=> Def_Id
,
4919 Object_Definition
=> New_Reference_To
(Exp_Type
, Loc
),
4920 Constant_Present
=> True,
4921 Expression
=> Relocate_Node
(Exp
));
4923 Set_Assignment_OK
(E
);
4924 Insert_Action
(Exp
, E
);
4926 -- If the expression has the form v.all then we can just capture
4927 -- the pointer, and then do an explicit dereference on the result.
4929 elsif Nkind
(Exp
) = N_Explicit_Dereference
then
4930 Def_Id
:= Make_Temporary
(Loc
, 'R', Exp
);
4932 Make_Explicit_Dereference
(Loc
, New_Reference_To
(Def_Id
, Loc
));
4935 Make_Object_Declaration
(Loc
,
4936 Defining_Identifier
=> Def_Id
,
4937 Object_Definition
=>
4938 New_Reference_To
(Etype
(Prefix
(Exp
)), Loc
),
4939 Constant_Present
=> True,
4940 Expression
=> Relocate_Node
(Prefix
(Exp
))));
4942 -- Similar processing for an unchecked conversion of an expression
4943 -- of the form v.all, where we want the same kind of treatment.
4945 elsif Nkind
(Exp
) = N_Unchecked_Type_Conversion
4946 and then Nkind
(Expression
(Exp
)) = N_Explicit_Dereference
4948 Remove_Side_Effects
(Expression
(Exp
), Name_Req
, Variable_Ref
);
4949 Scope_Suppress
:= Svg_Suppress
;
4952 -- If this is a type conversion, leave the type conversion and remove
4953 -- the side effects in the expression. This is important in several
4954 -- circumstances: for change of representations, and also when this is
4955 -- a view conversion to a smaller object, where gigi can end up creating
4956 -- its own temporary of the wrong size.
4958 elsif Nkind
(Exp
) = N_Type_Conversion
then
4959 Remove_Side_Effects
(Expression
(Exp
), Name_Req
, Variable_Ref
);
4960 Scope_Suppress
:= Svg_Suppress
;
4963 -- If this is an unchecked conversion that Gigi can't handle, make
4964 -- a copy or a use a renaming to capture the value.
4966 elsif Nkind
(Exp
) = N_Unchecked_Type_Conversion
4967 and then not Safe_Unchecked_Type_Conversion
(Exp
)
4969 if CW_Or_Has_Controlled_Part
(Exp_Type
) then
4971 -- Use a renaming to capture the expression, rather than create
4972 -- a controlled temporary.
4974 Def_Id
:= Make_Temporary
(Loc
, 'R', Exp
);
4975 Res
:= New_Reference_To
(Def_Id
, Loc
);
4978 Make_Object_Renaming_Declaration
(Loc
,
4979 Defining_Identifier
=> Def_Id
,
4980 Subtype_Mark
=> New_Reference_To
(Exp_Type
, Loc
),
4981 Name
=> Relocate_Node
(Exp
)));
4984 Def_Id
:= Make_Temporary
(Loc
, 'R', Exp
);
4985 Set_Etype
(Def_Id
, Exp_Type
);
4986 Res
:= New_Reference_To
(Def_Id
, Loc
);
4989 Make_Object_Declaration
(Loc
,
4990 Defining_Identifier
=> Def_Id
,
4991 Object_Definition
=> New_Reference_To
(Exp_Type
, Loc
),
4992 Constant_Present
=> not Is_Variable
(Exp
),
4993 Expression
=> Relocate_Node
(Exp
));
4995 Set_Assignment_OK
(E
);
4996 Insert_Action
(Exp
, E
);
4999 -- For expressions that denote objects, we can use a renaming scheme.
5000 -- This is needed for correctness in the case of a volatile object
5001 -- of a non-volatile type because the Make_Reference call of the
5002 -- "default" approach would generate an illegal access value (an access
5003 -- value cannot designate such an object - see Analyze_Reference).
5004 -- We skip using this scheme if we have an object of a volatile type
5005 -- and we do not have Name_Req set true (see comments above for
5006 -- Side_Effect_Free).
5008 elsif Is_Object_Reference
(Exp
)
5009 and then Nkind
(Exp
) /= N_Function_Call
5010 and then (Name_Req
or else not Treat_As_Volatile
(Exp_Type
))
5012 Def_Id
:= Make_Temporary
(Loc
, 'R', Exp
);
5014 if Nkind
(Exp
) = N_Selected_Component
5015 and then Nkind
(Prefix
(Exp
)) = N_Function_Call
5016 and then Is_Array_Type
(Exp_Type
)
5018 -- Avoid generating a variable-sized temporary, by generating
5019 -- the renaming declaration just for the function call. The
5020 -- transformation could be refined to apply only when the array
5021 -- component is constrained by a discriminant???
5024 Make_Selected_Component
(Loc
,
5025 Prefix
=> New_Occurrence_Of
(Def_Id
, Loc
),
5026 Selector_Name
=> Selector_Name
(Exp
));
5029 Make_Object_Renaming_Declaration
(Loc
,
5030 Defining_Identifier
=> Def_Id
,
5032 New_Reference_To
(Base_Type
(Etype
(Prefix
(Exp
))), Loc
),
5033 Name
=> Relocate_Node
(Prefix
(Exp
))));
5036 Res
:= New_Reference_To
(Def_Id
, Loc
);
5039 Make_Object_Renaming_Declaration
(Loc
,
5040 Defining_Identifier
=> Def_Id
,
5041 Subtype_Mark
=> New_Reference_To
(Exp_Type
, Loc
),
5042 Name
=> Relocate_Node
(Exp
)));
5045 -- If this is a packed reference, or a selected component with a
5046 -- non-standard representation, a reference to the temporary will
5047 -- be replaced by a copy of the original expression (see
5048 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
5049 -- elaborated by gigi, and is of course not to be replaced in-line
5050 -- by the expression it renames, which would defeat the purpose of
5051 -- removing the side-effect.
5053 if (Nkind
(Exp
) = N_Selected_Component
5054 or else Nkind
(Exp
) = N_Indexed_Component
)
5055 and then Has_Non_Standard_Rep
(Etype
(Prefix
(Exp
)))
5059 Set_Is_Renaming_Of_Object
(Def_Id
, False);
5062 -- Otherwise we generate a reference to the value
5065 -- Special processing for function calls that return a limited type.
5066 -- We need to build a declaration that will enable build-in-place
5067 -- expansion of the call. This is not done if the context is already
5068 -- an object declaration, to prevent infinite recursion.
5070 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
5071 -- to accommodate functions returning limited objects by reference.
5073 if Nkind
(Exp
) = N_Function_Call
5074 and then Is_Immutably_Limited_Type
(Etype
(Exp
))
5075 and then Nkind
(Parent
(Exp
)) /= N_Object_Declaration
5076 and then Ada_Version
>= Ada_2005
5079 Obj
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F', Exp
);
5084 Make_Object_Declaration
(Loc
,
5085 Defining_Identifier
=> Obj
,
5086 Object_Definition
=> New_Occurrence_Of
(Exp_Type
, Loc
),
5087 Expression
=> Relocate_Node
(Exp
));
5089 Insert_Action
(Exp
, Decl
);
5090 Set_Etype
(Obj
, Exp_Type
);
5091 Rewrite
(Exp
, New_Occurrence_Of
(Obj
, Loc
));
5096 Ref_Type
:= Make_Temporary
(Loc
, 'A');
5099 Make_Full_Type_Declaration
(Loc
,
5100 Defining_Identifier
=> Ref_Type
,
5102 Make_Access_To_Object_Definition
(Loc
,
5103 All_Present
=> True,
5104 Subtype_Indication
=>
5105 New_Reference_To
(Exp_Type
, Loc
)));
5108 Insert_Action
(Exp
, Ptr_Typ_Decl
);
5110 Def_Id
:= Make_Temporary
(Loc
, 'R', Exp
);
5111 Set_Etype
(Def_Id
, Exp_Type
);
5114 Make_Explicit_Dereference
(Loc
,
5115 Prefix
=> New_Reference_To
(Def_Id
, Loc
));
5117 if Nkind
(E
) = N_Explicit_Dereference
then
5118 New_Exp
:= Relocate_Node
(Prefix
(E
));
5120 E
:= Relocate_Node
(E
);
5121 New_Exp
:= Make_Reference
(Loc
, E
);
5124 if Is_Delayed_Aggregate
(E
) then
5126 -- The expansion of nested aggregates is delayed until the
5127 -- enclosing aggregate is expanded. As aggregates are often
5128 -- qualified, the predicate applies to qualified expressions
5129 -- as well, indicating that the enclosing aggregate has not
5130 -- been expanded yet. At this point the aggregate is part of
5131 -- a stand-alone declaration, and must be fully expanded.
5133 if Nkind
(E
) = N_Qualified_Expression
then
5134 Set_Expansion_Delayed
(Expression
(E
), False);
5135 Set_Analyzed
(Expression
(E
), False);
5137 Set_Expansion_Delayed
(E
, False);
5140 Set_Analyzed
(E
, False);
5144 Make_Object_Declaration
(Loc
,
5145 Defining_Identifier
=> Def_Id
,
5146 Object_Definition
=> New_Reference_To
(Ref_Type
, Loc
),
5147 Constant_Present
=> True,
5148 Expression
=> New_Exp
));
5151 -- Preserve the Assignment_OK flag in all copies, since at least
5152 -- one copy may be used in a context where this flag must be set
5153 -- (otherwise why would the flag be set in the first place).
5155 Set_Assignment_OK
(Res
, Assignment_OK
(Exp
));
5157 -- Finally rewrite the original expression and we are done
5160 Analyze_And_Resolve
(Exp
, Exp_Type
);
5161 Scope_Suppress
:= Svg_Suppress
;
5162 end Remove_Side_Effects
;
5164 ---------------------------
5165 -- Represented_As_Scalar --
5166 ---------------------------
5168 function Represented_As_Scalar
(T
: Entity_Id
) return Boolean is
5169 UT
: constant Entity_Id
:= Underlying_Type
(T
);
5171 return Is_Scalar_Type
(UT
)
5172 or else (Is_Bit_Packed_Array
(UT
)
5173 and then Is_Scalar_Type
(Packed_Array_Type
(UT
)));
5174 end Represented_As_Scalar
;
5176 ------------------------------------
5177 -- Safe_Unchecked_Type_Conversion --
5178 ------------------------------------
5180 -- Note: this function knows quite a bit about the exact requirements
5181 -- of Gigi with respect to unchecked type conversions, and its code
5182 -- must be coordinated with any changes in Gigi in this area.
5184 -- The above requirements should be documented in Sinfo ???
5186 function Safe_Unchecked_Type_Conversion
(Exp
: Node_Id
) return Boolean is
5191 Pexp
: constant Node_Id
:= Parent
(Exp
);
5194 -- If the expression is the RHS of an assignment or object declaration
5195 -- we are always OK because there will always be a target.
5197 -- Object renaming declarations, (generated for view conversions of
5198 -- actuals in inlined calls), like object declarations, provide an
5199 -- explicit type, and are safe as well.
5201 if (Nkind
(Pexp
) = N_Assignment_Statement
5202 and then Expression
(Pexp
) = Exp
)
5203 or else Nkind
(Pexp
) = N_Object_Declaration
5204 or else Nkind
(Pexp
) = N_Object_Renaming_Declaration
5208 -- If the expression is the prefix of an N_Selected_Component
5209 -- we should also be OK because GCC knows to look inside the
5210 -- conversion except if the type is discriminated. We assume
5211 -- that we are OK anyway if the type is not set yet or if it is
5212 -- controlled since we can't afford to introduce a temporary in
5215 elsif Nkind
(Pexp
) = N_Selected_Component
5216 and then Prefix
(Pexp
) = Exp
5218 if No
(Etype
(Pexp
)) then
5222 not Has_Discriminants
(Etype
(Pexp
))
5223 or else Is_Constrained
(Etype
(Pexp
));
5227 -- Set the output type, this comes from Etype if it is set, otherwise
5228 -- we take it from the subtype mark, which we assume was already
5231 if Present
(Etype
(Exp
)) then
5232 Otyp
:= Etype
(Exp
);
5234 Otyp
:= Entity
(Subtype_Mark
(Exp
));
5237 -- The input type always comes from the expression, and we assume
5238 -- this is indeed always analyzed, so we can simply get the Etype.
5240 Ityp
:= Etype
(Expression
(Exp
));
5242 -- Initialize alignments to unknown so far
5247 -- Replace a concurrent type by its corresponding record type
5248 -- and each type by its underlying type and do the tests on those.
5249 -- The original type may be a private type whose completion is a
5250 -- concurrent type, so find the underlying type first.
5252 if Present
(Underlying_Type
(Otyp
)) then
5253 Otyp
:= Underlying_Type
(Otyp
);
5256 if Present
(Underlying_Type
(Ityp
)) then
5257 Ityp
:= Underlying_Type
(Ityp
);
5260 if Is_Concurrent_Type
(Otyp
) then
5261 Otyp
:= Corresponding_Record_Type
(Otyp
);
5264 if Is_Concurrent_Type
(Ityp
) then
5265 Ityp
:= Corresponding_Record_Type
(Ityp
);
5268 -- If the base types are the same, we know there is no problem since
5269 -- this conversion will be a noop.
5271 if Implementation_Base_Type
(Otyp
) = Implementation_Base_Type
(Ityp
) then
5274 -- Same if this is an upwards conversion of an untagged type, and there
5275 -- are no constraints involved (could be more general???)
5277 elsif Etype
(Ityp
) = Otyp
5278 and then not Is_Tagged_Type
(Ityp
)
5279 and then not Has_Discriminants
(Ityp
)
5280 and then No
(First_Rep_Item
(Base_Type
(Ityp
)))
5284 -- If the expression has an access type (object or subprogram) we
5285 -- assume that the conversion is safe, because the size of the target
5286 -- is safe, even if it is a record (which might be treated as having
5287 -- unknown size at this point).
5289 elsif Is_Access_Type
(Ityp
) then
5292 -- If the size of output type is known at compile time, there is
5293 -- never a problem. Note that unconstrained records are considered
5294 -- to be of known size, but we can't consider them that way here,
5295 -- because we are talking about the actual size of the object.
5297 -- We also make sure that in addition to the size being known, we do
5298 -- not have a case which might generate an embarrassingly large temp
5299 -- in stack checking mode.
5301 elsif Size_Known_At_Compile_Time
(Otyp
)
5303 (not Stack_Checking_Enabled
5304 or else not May_Generate_Large_Temp
(Otyp
))
5305 and then not (Is_Record_Type
(Otyp
) and then not Is_Constrained
(Otyp
))
5309 -- If either type is tagged, then we know the alignment is OK so
5310 -- Gigi will be able to use pointer punning.
5312 elsif Is_Tagged_Type
(Otyp
) or else Is_Tagged_Type
(Ityp
) then
5315 -- If either type is a limited record type, we cannot do a copy, so
5316 -- say safe since there's nothing else we can do.
5318 elsif Is_Limited_Record
(Otyp
) or else Is_Limited_Record
(Ityp
) then
5321 -- Conversions to and from packed array types are always ignored and
5324 elsif Is_Packed_Array_Type
(Otyp
)
5325 or else Is_Packed_Array_Type
(Ityp
)
5330 -- The only other cases known to be safe is if the input type's
5331 -- alignment is known to be at least the maximum alignment for the
5332 -- target or if both alignments are known and the output type's
5333 -- alignment is no stricter than the input's. We can use the alignment
5334 -- of the component type of an array if a type is an unpacked
5337 if Present
(Alignment_Clause
(Otyp
)) then
5338 Oalign
:= Expr_Value
(Expression
(Alignment_Clause
(Otyp
)));
5340 elsif Is_Array_Type
(Otyp
)
5341 and then Present
(Alignment_Clause
(Component_Type
(Otyp
)))
5343 Oalign
:= Expr_Value
(Expression
(Alignment_Clause
5344 (Component_Type
(Otyp
))));
5347 if Present
(Alignment_Clause
(Ityp
)) then
5348 Ialign
:= Expr_Value
(Expression
(Alignment_Clause
(Ityp
)));
5350 elsif Is_Array_Type
(Ityp
)
5351 and then Present
(Alignment_Clause
(Component_Type
(Ityp
)))
5353 Ialign
:= Expr_Value
(Expression
(Alignment_Clause
5354 (Component_Type
(Ityp
))));
5357 if Ialign
/= No_Uint
and then Ialign
> Maximum_Alignment
then
5360 elsif Ialign
/= No_Uint
and then Oalign
/= No_Uint
5361 and then Ialign
<= Oalign
5365 -- Otherwise, Gigi cannot handle this and we must make a temporary
5370 end Safe_Unchecked_Type_Conversion
;
5372 ---------------------------------
5373 -- Set_Current_Value_Condition --
5374 ---------------------------------
5376 -- Note: the implementation of this procedure is very closely tied to the
5377 -- implementation of Get_Current_Value_Condition. Here we set required
5378 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
5379 -- them, so they must have a consistent view.
5381 procedure Set_Current_Value_Condition
(Cnode
: Node_Id
) is
5383 procedure Set_Entity_Current_Value
(N
: Node_Id
);
5384 -- If N is an entity reference, where the entity is of an appropriate
5385 -- kind, then set the current value of this entity to Cnode, unless
5386 -- there is already a definite value set there.
5388 procedure Set_Expression_Current_Value
(N
: Node_Id
);
5389 -- If N is of an appropriate form, sets an appropriate entry in current
5390 -- value fields of relevant entities. Multiple entities can be affected
5391 -- in the case of an AND or AND THEN.
5393 ------------------------------
5394 -- Set_Entity_Current_Value --
5395 ------------------------------
5397 procedure Set_Entity_Current_Value
(N
: Node_Id
) is
5399 if Is_Entity_Name
(N
) then
5401 Ent
: constant Entity_Id
:= Entity
(N
);
5404 -- Don't capture if not safe to do so
5406 if not Safe_To_Capture_Value
(N
, Ent
, Cond
=> True) then
5410 -- Here we have a case where the Current_Value field may
5411 -- need to be set. We set it if it is not already set to a
5412 -- compile time expression value.
5414 -- Note that this represents a decision that one condition
5415 -- blots out another previous one. That's certainly right
5416 -- if they occur at the same level. If the second one is
5417 -- nested, then the decision is neither right nor wrong (it
5418 -- would be equally OK to leave the outer one in place, or
5419 -- take the new inner one. Really we should record both, but
5420 -- our data structures are not that elaborate.
5422 if Nkind
(Current_Value
(Ent
)) not in N_Subexpr
then
5423 Set_Current_Value
(Ent
, Cnode
);
5427 end Set_Entity_Current_Value
;
5429 ----------------------------------
5430 -- Set_Expression_Current_Value --
5431 ----------------------------------
5433 procedure Set_Expression_Current_Value
(N
: Node_Id
) is
5439 -- Loop to deal with (ignore for now) any NOT operators present. The
5440 -- presence of NOT operators will be handled properly when we call
5441 -- Get_Current_Value_Condition.
5443 while Nkind
(Cond
) = N_Op_Not
loop
5444 Cond
:= Right_Opnd
(Cond
);
5447 -- For an AND or AND THEN, recursively process operands
5449 if Nkind
(Cond
) = N_Op_And
or else Nkind
(Cond
) = N_And_Then
then
5450 Set_Expression_Current_Value
(Left_Opnd
(Cond
));
5451 Set_Expression_Current_Value
(Right_Opnd
(Cond
));
5455 -- Check possible relational operator
5457 if Nkind
(Cond
) in N_Op_Compare
then
5458 if Compile_Time_Known_Value
(Right_Opnd
(Cond
)) then
5459 Set_Entity_Current_Value
(Left_Opnd
(Cond
));
5460 elsif Compile_Time_Known_Value
(Left_Opnd
(Cond
)) then
5461 Set_Entity_Current_Value
(Right_Opnd
(Cond
));
5464 -- Check possible boolean variable reference
5467 Set_Entity_Current_Value
(Cond
);
5469 end Set_Expression_Current_Value
;
5471 -- Start of processing for Set_Current_Value_Condition
5474 Set_Expression_Current_Value
(Condition
(Cnode
));
5475 end Set_Current_Value_Condition
;
5477 --------------------------
5478 -- Set_Elaboration_Flag --
5479 --------------------------
5481 procedure Set_Elaboration_Flag
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
5482 Loc
: constant Source_Ptr
:= Sloc
(N
);
5483 Ent
: constant Entity_Id
:= Elaboration_Entity
(Spec_Id
);
5487 if Present
(Ent
) then
5489 -- Nothing to do if at the compilation unit level, because in this
5490 -- case the flag is set by the binder generated elaboration routine.
5492 if Nkind
(Parent
(N
)) = N_Compilation_Unit
then
5495 -- Here we do need to generate an assignment statement
5498 Check_Restriction
(No_Elaboration_Code
, N
);
5500 Make_Assignment_Statement
(Loc
,
5501 Name
=> New_Occurrence_Of
(Ent
, Loc
),
5502 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
));
5504 if Nkind
(Parent
(N
)) = N_Subunit
then
5505 Insert_After
(Corresponding_Stub
(Parent
(N
)), Asn
);
5507 Insert_After
(N
, Asn
);
5512 -- Kill current value indication. This is necessary because the
5513 -- tests of this flag are inserted out of sequence and must not
5514 -- pick up bogus indications of the wrong constant value.
5516 Set_Current_Value
(Ent
, Empty
);
5519 end Set_Elaboration_Flag
;
5521 ----------------------------
5522 -- Set_Renamed_Subprogram --
5523 ----------------------------
5525 procedure Set_Renamed_Subprogram
(N
: Node_Id
; E
: Entity_Id
) is
5527 -- If input node is an identifier, we can just reset it
5529 if Nkind
(N
) = N_Identifier
then
5530 Set_Chars
(N
, Chars
(E
));
5533 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
5537 CS
: constant Boolean := Comes_From_Source
(N
);
5539 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Chars
(E
)));
5541 Set_Comes_From_Source
(N
, CS
);
5542 Set_Analyzed
(N
, True);
5545 end Set_Renamed_Subprogram
;
5547 ----------------------------------
5548 -- Silly_Boolean_Array_Not_Test --
5549 ----------------------------------
5551 -- This procedure implements an odd and silly test. We explicitly check
5552 -- for the case where the 'First of the component type is equal to the
5553 -- 'Last of this component type, and if this is the case, we make sure
5554 -- that constraint error is raised. The reason is that the NOT is bound
5555 -- to cause CE in this case, and we will not otherwise catch it.
5557 -- No such check is required for AND and OR, since for both these cases
5558 -- False op False = False, and True op True = True. For the XOR case,
5559 -- see Silly_Boolean_Array_Xor_Test.
5561 -- Believe it or not, this was reported as a bug. Note that nearly
5562 -- always, the test will evaluate statically to False, so the code will
5563 -- be statically removed, and no extra overhead caused.
5565 procedure Silly_Boolean_Array_Not_Test
(N
: Node_Id
; T
: Entity_Id
) is
5566 Loc
: constant Source_Ptr
:= Sloc
(N
);
5567 CT
: constant Entity_Id
:= Component_Type
(T
);
5570 -- The check we install is
5572 -- constraint_error when
5573 -- component_type'first = component_type'last
5574 -- and then array_type'Length /= 0)
5576 -- We need the last guard because we don't want to raise CE for empty
5577 -- arrays since no out of range values result. (Empty arrays with a
5578 -- component type of True .. True -- very useful -- even the ACATS
5579 -- does not test that marginal case!)
5582 Make_Raise_Constraint_Error
(Loc
,
5588 Make_Attribute_Reference
(Loc
,
5589 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
5590 Attribute_Name
=> Name_First
),
5593 Make_Attribute_Reference
(Loc
,
5594 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
5595 Attribute_Name
=> Name_Last
)),
5597 Right_Opnd
=> Make_Non_Empty_Check
(Loc
, Right_Opnd
(N
))),
5598 Reason
=> CE_Range_Check_Failed
));
5599 end Silly_Boolean_Array_Not_Test
;
5601 ----------------------------------
5602 -- Silly_Boolean_Array_Xor_Test --
5603 ----------------------------------
5605 -- This procedure implements an odd and silly test. We explicitly check
5606 -- for the XOR case where the component type is True .. True, since this
5607 -- will raise constraint error. A special check is required since CE
5608 -- will not be generated otherwise (cf Expand_Packed_Not).
5610 -- No such check is required for AND and OR, since for both these cases
5611 -- False op False = False, and True op True = True, and no check is
5612 -- required for the case of False .. False, since False xor False = False.
5613 -- See also Silly_Boolean_Array_Not_Test
5615 procedure Silly_Boolean_Array_Xor_Test
(N
: Node_Id
; T
: Entity_Id
) is
5616 Loc
: constant Source_Ptr
:= Sloc
(N
);
5617 CT
: constant Entity_Id
:= Component_Type
(T
);
5620 -- The check we install is
5622 -- constraint_error when
5623 -- Boolean (component_type'First)
5624 -- and then Boolean (component_type'Last)
5625 -- and then array_type'Length /= 0)
5627 -- We need the last guard because we don't want to raise CE for empty
5628 -- arrays since no out of range values result (Empty arrays with a
5629 -- component type of True .. True -- very useful -- even the ACATS
5630 -- does not test that marginal case!).
5633 Make_Raise_Constraint_Error
(Loc
,
5639 Convert_To
(Standard_Boolean
,
5640 Make_Attribute_Reference
(Loc
,
5641 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
5642 Attribute_Name
=> Name_First
)),
5645 Convert_To
(Standard_Boolean
,
5646 Make_Attribute_Reference
(Loc
,
5647 Prefix
=> New_Occurrence_Of
(CT
, Loc
),
5648 Attribute_Name
=> Name_Last
))),
5650 Right_Opnd
=> Make_Non_Empty_Check
(Loc
, Right_Opnd
(N
))),
5651 Reason
=> CE_Range_Check_Failed
));
5652 end Silly_Boolean_Array_Xor_Test
;
5654 --------------------------
5655 -- Target_Has_Fixed_Ops --
5656 --------------------------
5658 Integer_Sized_Small
: Ureal
;
5659 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this
5660 -- function is called (we don't want to compute it more than once!)
5662 Long_Integer_Sized_Small
: Ureal
;
5663 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
5664 -- function is called (we don't want to compute it more than once)
5666 First_Time_For_THFO
: Boolean := True;
5667 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
5669 function Target_Has_Fixed_Ops
5670 (Left_Typ
: Entity_Id
;
5671 Right_Typ
: Entity_Id
;
5672 Result_Typ
: Entity_Id
) return Boolean
5674 function Is_Fractional_Type
(Typ
: Entity_Id
) return Boolean;
5675 -- Return True if the given type is a fixed-point type with a small
5676 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
5677 -- an absolute value less than 1.0. This is currently limited
5678 -- to fixed-point types that map to Integer or Long_Integer.
5680 ------------------------
5681 -- Is_Fractional_Type --
5682 ------------------------
5684 function Is_Fractional_Type
(Typ
: Entity_Id
) return Boolean is
5686 if Esize
(Typ
) = Standard_Integer_Size
then
5687 return Small_Value
(Typ
) = Integer_Sized_Small
;
5689 elsif Esize
(Typ
) = Standard_Long_Integer_Size
then
5690 return Small_Value
(Typ
) = Long_Integer_Sized_Small
;
5695 end Is_Fractional_Type
;
5697 -- Start of processing for Target_Has_Fixed_Ops
5700 -- Return False if Fractional_Fixed_Ops_On_Target is false
5702 if not Fractional_Fixed_Ops_On_Target
then
5706 -- Here the target has Fractional_Fixed_Ops, if first time, compute
5707 -- standard constants used by Is_Fractional_Type.
5709 if First_Time_For_THFO
then
5710 First_Time_For_THFO
:= False;
5712 Integer_Sized_Small
:=
5715 Den
=> UI_From_Int
(Standard_Integer_Size
- 1),
5718 Long_Integer_Sized_Small
:=
5721 Den
=> UI_From_Int
(Standard_Long_Integer_Size
- 1),
5725 -- Return True if target supports fixed-by-fixed multiply/divide
5726 -- for fractional fixed-point types (see Is_Fractional_Type) and
5727 -- the operand and result types are equivalent fractional types.
5729 return Is_Fractional_Type
(Base_Type
(Left_Typ
))
5730 and then Is_Fractional_Type
(Base_Type
(Right_Typ
))
5731 and then Is_Fractional_Type
(Base_Type
(Result_Typ
))
5732 and then Esize
(Left_Typ
) = Esize
(Right_Typ
)
5733 and then Esize
(Left_Typ
) = Esize
(Result_Typ
);
5734 end Target_Has_Fixed_Ops
;
5736 ------------------------------------------
5737 -- Type_May_Have_Bit_Aligned_Components --
5738 ------------------------------------------
5740 function Type_May_Have_Bit_Aligned_Components
5741 (Typ
: Entity_Id
) return Boolean
5744 -- Array type, check component type
5746 if Is_Array_Type
(Typ
) then
5748 Type_May_Have_Bit_Aligned_Components
(Component_Type
(Typ
));
5750 -- Record type, check components
5752 elsif Is_Record_Type
(Typ
) then
5757 E
:= First_Component_Or_Discriminant
(Typ
);
5758 while Present
(E
) loop
5759 if Component_May_Be_Bit_Aligned
(E
)
5760 or else Type_May_Have_Bit_Aligned_Components
(Etype
(E
))
5765 Next_Component_Or_Discriminant
(E
);
5771 -- Type other than array or record is always OK
5776 end Type_May_Have_Bit_Aligned_Components
;
5778 ----------------------------
5779 -- Wrap_Cleanup_Procedure --
5780 ----------------------------
5782 procedure Wrap_Cleanup_Procedure
(N
: Node_Id
) is
5783 Loc
: constant Source_Ptr
:= Sloc
(N
);
5784 Stseq
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
5785 Stmts
: constant List_Id
:= Statements
(Stseq
);
5788 if Abort_Allowed
then
5789 Prepend_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Defer
));
5790 Append_To
(Stmts
, Build_Runtime_Call
(Loc
, RE_Abort_Undefer
));
5792 end Wrap_Cleanup_Procedure
;