1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Einfo
; use Einfo
;
29 with Exp_Ch3
; use Exp_Ch3
;
30 with Exp_Ch6
; use Exp_Ch6
;
31 with Exp_Imgv
; use Exp_Imgv
;
32 with Exp_Tss
; use Exp_Tss
;
33 with Exp_Util
; use Exp_Util
;
34 with Freeze
; use Freeze
;
35 with Ghost
; use Ghost
;
36 with Namet
; use Namet
;
37 with Nlists
; use Nlists
;
38 with Nmake
; use Nmake
;
40 with Restrict
; use Restrict
;
41 with Rident
; use Rident
;
42 with Rtsfind
; use Rtsfind
;
44 with Sem_Aux
; use Sem_Aux
;
45 with Sem_Ch7
; use Sem_Ch7
;
46 with Sem_Ch8
; use Sem_Ch8
;
47 with Sem_Eval
; use Sem_Eval
;
48 with Sem_Util
; use Sem_Util
;
49 with Sinfo
; use Sinfo
;
50 with Snames
; use Snames
;
51 with Tbuild
; use Tbuild
;
52 with Uintp
; use Uintp
;
53 with Validsw
; use Validsw
;
55 package body Exp_Ch13
is
57 ------------------------------------------
58 -- Expand_N_Attribute_Definition_Clause --
59 ------------------------------------------
61 -- Expansion action depends on attribute involved
63 procedure Expand_N_Attribute_Definition_Clause
(N
: Node_Id
) is
64 Loc
: constant Source_Ptr
:= Sloc
(N
);
65 Exp
: constant Node_Id
:= Expression
(N
);
70 Ent
:= Entity
(Name
(N
));
73 Ent
:= Underlying_Type
(Ent
);
76 case Get_Attribute_Id
(Chars
(N
)) is
82 when Attribute_Address
=>
84 -- If there is an initialization which did not come from the
85 -- source program, then it is an artifact of our expansion, and we
86 -- suppress it. The case we are most concerned about here is the
87 -- initialization of a packed array to all false, which seems
88 -- inappropriate for variable to which an address clause is
89 -- applied. The expression may itself have been rewritten if the
90 -- type is packed array, so we need to examine whether the
91 -- original node is in the source. An exception though is the case
92 -- of an access variable which is default initialized to null, and
93 -- such initialization is retained.
95 -- Furthermore, if the initialization is the equivalent aggregate
96 -- of the type initialization procedure, it replaces an implicit
97 -- call to the init proc, and must be respected. Note that for
98 -- packed types we do not build equivalent aggregates.
100 -- Also, if Init_Or_Norm_Scalars applies, then we need to retain
101 -- any default initialization for objects of scalar types and
102 -- types with scalar components. Normally a composite type will
103 -- have an init_proc in the presence of Init_Or_Norm_Scalars,
104 -- so when that flag is set we have just have to do a test for
105 -- scalar and string types (the predefined string types such as
106 -- String and Wide_String don't have an init_proc).
109 Decl
: constant Node_Id
:= Declaration_Node
(Ent
);
110 Typ
: constant Entity_Id
:= Etype
(Ent
);
113 if Nkind
(Decl
) = N_Object_Declaration
114 and then Present
(Expression
(Decl
))
115 and then Nkind
(Expression
(Decl
)) /= N_Null
117 not Comes_From_Source
(Original_Node
(Expression
(Decl
)))
119 if Present
(Base_Init_Proc
(Typ
))
121 Present
(Static_Initialization
(Base_Init_Proc
(Typ
)))
125 elsif Init_Or_Norm_Scalars
127 (Is_Scalar_Type
(Typ
) or else Is_String_Type
(Typ
))
132 Set_Expression
(Decl
, Empty
);
135 -- An object declaration to which an address clause applies
136 -- has a delayed freeze, but the address expression itself
137 -- must be elaborated at the point it appears. If the object
138 -- is controlled, additional checks apply elsewhere.
140 elsif Nkind
(Decl
) = N_Object_Declaration
141 and then not Needs_Constant_Address
(Decl
, Typ
)
143 Remove_Side_Effects
(Exp
);
151 when Attribute_Alignment
=>
153 -- As required by Gigi, we guarantee that the operand is an
154 -- integer literal (this simplifies things in Gigi).
156 if Nkind
(Exp
) /= N_Integer_Literal
then
158 (Exp
, Make_Integer_Literal
(Loc
, Expr_Value
(Exp
)));
161 -- A complex case arises if the alignment clause applies to an
162 -- unconstrained object initialized with a function call. The
163 -- result of the call is placed on the secondary stack, and the
164 -- declaration is rewritten as a renaming of a dereference, which
165 -- fails expansion. We must introduce a temporary and assign its
166 -- value to the existing entity.
168 if Nkind
(Parent
(Ent
)) = N_Object_Renaming_Declaration
169 and then not Is_Entity_Name
(Renamed_Object
(Ent
))
172 Loc
: constant Source_Ptr
:= Sloc
(N
);
173 Decl
: constant Node_Id
:= Parent
(Ent
);
174 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
178 -- Replace entity with temporary and reanalyze
180 Set_Defining_Identifier
(Decl
, Temp
);
181 Set_Analyzed
(Decl
, False);
184 -- Introduce new declaration for entity but do not reanalyze
185 -- because entity is already in scope. Type and expression
186 -- are already resolved.
189 Make_Object_Declaration
(Loc
,
190 Defining_Identifier
=> Ent
,
192 New_Occurrence_Of
(Etype
(Ent
), Loc
),
193 Expression
=> New_Occurrence_Of
(Temp
, Loc
));
195 Set_Renamed_Object
(Ent
, Empty
);
196 Insert_After
(Decl
, New_Decl
);
205 when Attribute_Storage_Size
=>
207 -- If the type is a task type, then assign the value of the
208 -- storage size to the Size variable associated with the task.
209 -- Insert the assignment right after the declaration of the Size
214 -- task_typeZ := expression
216 if Ekind
(Ent
) = E_Task_Type
then
222 Make_Assignment_Statement
(Loc
,
224 New_Occurrence_Of
(Storage_Size_Variable
(Ent
), Loc
),
226 Convert_To
(RTE
(RE_Size_Type
), Expression
(N
)));
228 -- If the clause is not generated by an aspect, insert
229 -- the assignment here. Freezing rules ensure that this
230 -- is safe, or clause will have been rejected already.
232 if Is_List_Member
(N
) then
233 Insert_After
(N
, Assign
);
235 -- Otherwise, insert assignment after task declaration.
239 (Parent
(Storage_Size_Variable
(Entity
(N
))), Assign
);
245 -- For Storage_Size for an access type, create a variable to hold
246 -- the value of the specified size with name typeV and expand an
247 -- assignment statement to initialize this value.
249 elsif Is_Access_Type
(Ent
) then
251 -- We don't need the variable for a storage size of zero
253 if not No_Pool_Assigned
(Ent
) then
255 Make_Defining_Identifier
(Loc
,
256 Chars
=> New_External_Name
(Chars
(Ent
), 'V'));
258 -- Insert the declaration of the object
261 Make_Object_Declaration
(Loc
,
262 Defining_Identifier
=> V
,
264 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
266 Convert_To
(RTE
(RE_Storage_Offset
), Expression
(N
))));
268 Set_Storage_Size_Variable
(Ent
, Entity_Id
(V
));
272 -- Other attributes require no expansion
278 end Expand_N_Attribute_Definition_Clause
;
280 -----------------------------
281 -- Expand_N_Free_Statement --
282 -----------------------------
284 procedure Expand_N_Free_Statement
(N
: Node_Id
) is
285 Expr
: constant Node_Id
:= Expression
(N
);
289 -- Certain run-time configurations and targets do not provide support
290 -- for controlled types.
292 if Restriction_Active
(No_Finalization
) then
296 -- Use the base type to perform the check for finalization master
300 if Ekind
(Typ
) = E_Access_Subtype
then
304 -- Handle private access types
306 if Is_Private_Type
(Typ
)
307 and then Present
(Full_View
(Typ
))
309 Typ
:= Full_View
(Typ
);
312 -- Do not create a custom Deallocate when freeing an object with
313 -- suppressed finalization. In such cases the object is never attached
314 -- to a master, so it does not need to be detached. Use a regular free
315 -- statement instead.
317 if No
(Finalization_Master
(Typ
)) then
321 -- Use a temporary to store the result of a complex expression. Perform
322 -- the following transformation:
324 -- Free (Complex_Expression);
326 -- Temp : constant Type_Of_Expression := Complex_Expression;
329 if Nkind
(Expr
) /= N_Identifier
then
331 Expr_Typ
: constant Entity_Id
:= Etype
(Expr
);
332 Loc
: constant Source_Ptr
:= Sloc
(N
);
337 Temp_Id
:= Make_Temporary
(Loc
, 'T');
339 Make_Object_Declaration
(Loc
,
340 Defining_Identifier
=> Temp_Id
,
342 New_Occurrence_Of
(Expr_Typ
, Loc
),
344 Relocate_Node
(Expr
)));
346 New_Expr
:= New_Occurrence_Of
(Temp_Id
, Loc
);
347 Set_Etype
(New_Expr
, Expr_Typ
);
349 Set_Expression
(N
, New_Expr
);
353 -- Create a custom Deallocate for a controlled object. This routine
354 -- ensures that the hidden list header will be deallocated along with
355 -- the actual object.
357 Build_Allocate_Deallocate_Proc
(N
, Is_Allocate
=> False);
358 end Expand_N_Free_Statement
;
360 ----------------------------
361 -- Expand_N_Freeze_Entity --
362 ----------------------------
364 procedure Expand_N_Freeze_Entity
(N
: Node_Id
) is
365 E
: constant Entity_Id
:= Entity
(N
);
367 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
370 Delete
: Boolean := False;
372 In_Other_Scope
: Boolean;
373 In_Outer_Scope
: Boolean;
376 -- Ensure that all freezing activities are properly flagged as Ghost
378 Set_Ghost_Mode_From_Entity
(E
);
380 -- If there are delayed aspect specifications, we insert them just
381 -- before the freeze node. They are already analyzed so we don't need
382 -- to reanalyze them (they were analyzed before the type was frozen),
383 -- but we want them in the tree for the back end, and so that the
384 -- listing from sprint is clearer on where these occur logically.
386 if Has_Delayed_Aspects
(E
) then
392 -- Look for aspect specs for this entity
394 Ritem
:= First_Rep_Item
(E
);
395 while Present
(Ritem
) loop
396 if Nkind
(Ritem
) = N_Aspect_Specification
397 and then Entity
(Ritem
) = E
399 Aitem
:= Aspect_Rep_Item
(Ritem
);
401 -- Skip this for aspects (e.g. Current_Value) for which
402 -- there is no corresponding pragma or attribute.
406 -- Also skip if we have a null statement rather than a
407 -- delayed aspect (this happens when we are ignoring rep
408 -- items from use of the -gnatI switch).
410 and then Nkind
(Aitem
) /= N_Null_Statement
412 pragma Assert
(Is_Delayed_Aspect
(Aitem
));
413 Insert_Before
(N
, Aitem
);
417 Next_Rep_Item
(Ritem
);
422 -- Processing for objects
424 if Is_Object
(E
) then
425 if Present
(Address_Clause
(E
)) then
426 Apply_Address_Clause_Check
(E
, N
);
429 -- Analyze actions in freeze node, if any
431 if Present
(Actions
(N
)) then
435 Act
:= First
(Actions
(N
));
436 while Present
(Act
) loop
443 -- If initialization statements have been captured in a compound
444 -- statement, insert them back into the tree now.
446 Explode_Initialization_Compound_Statement
(E
);
447 Ghost_Mode
:= Save_Ghost_Mode
;
450 -- Only other items requiring any front end action are types and
453 elsif not Is_Type
(E
) and then not Is_Subprogram
(E
) then
454 Ghost_Mode
:= Save_Ghost_Mode
;
458 -- Here E is a type or a subprogram
460 E_Scope
:= Scope
(E
);
462 -- This is an error protection against previous errors
465 Check_Error_Detected
;
466 Ghost_Mode
:= Save_Ghost_Mode
;
470 -- The entity may be a subtype declared for a constrained record
471 -- component, in which case the relevant scope is the scope of
472 -- the record. This happens for class-wide subtypes created for
473 -- a constrained type extension with inherited discriminants.
476 and then Ekind
(E_Scope
) not in Concurrent_Kind
478 E_Scope
:= Scope
(E_Scope
);
481 -- Remember that we are processing a freezing entity and its freezing
482 -- nodes. This flag (non-zero = set) is used to avoid the need of
483 -- climbing through the tree while processing the freezing actions (ie.
484 -- to avoid generating spurious warnings or to avoid killing constant
485 -- indications while processing the code associated with freezing
486 -- actions). We use a counter to deal with nesting.
488 Inside_Freezing_Actions
:= Inside_Freezing_Actions
+ 1;
490 -- If we are freezing entities defined in protected types, they belong
491 -- in the enclosing scope, given that the original type has been
492 -- expanded away. The same is true for entities in task types, in
493 -- particular the parameter records of entries (Entities in bodies are
494 -- all frozen within the body). If we are in the task body, this is a
495 -- proper scope. If we are within a subprogram body, the proper scope
496 -- is the corresponding spec. This may happen for itypes generated in
497 -- the bodies of protected operations.
499 if Ekind
(E_Scope
) = E_Protected_Type
500 or else (Ekind
(E_Scope
) = E_Task_Type
501 and then not Has_Completion
(E_Scope
))
503 E_Scope
:= Scope
(E_Scope
);
505 elsif Ekind
(E_Scope
) = E_Subprogram_Body
then
506 E_Scope
:= Corresponding_Spec
(Unit_Declaration_Node
(E_Scope
));
509 -- If the scope of the entity is in open scopes, it is the current one
510 -- or an enclosing one, including a loop, a block, or a subprogram.
512 if In_Open_Scopes
(E_Scope
) then
513 In_Other_Scope
:= False;
514 In_Outer_Scope
:= E_Scope
/= Current_Scope
;
516 -- Otherwise it is a local package or a different compilation unit
519 In_Other_Scope
:= True;
520 In_Outer_Scope
:= False;
523 -- If the entity being frozen is defined in a scope that is not
524 -- currently on the scope stack, we must establish the proper
525 -- visibility before freezing the entity and related subprograms.
527 if In_Other_Scope
then
528 Push_Scope
(E_Scope
);
530 -- Finalizers are little odd in terms of freezing. The spec of the
531 -- procedure appears in the declarations while the body appears in
532 -- the statement part of a single construct. Since the finalizer must
533 -- be called by the At_End handler of the construct, the spec is
534 -- manually frozen right after its declaration. The only side effect
535 -- of this action appears in contexts where the construct is not in
536 -- its final resting place. These contexts are:
538 -- * Entry bodies - The declarations and statements are moved to
539 -- the procedure equivalen of the entry.
540 -- * Protected subprograms - The declarations and statements are
541 -- moved to the non-protected version of the subprogram.
542 -- * Task bodies - The declarations and statements are moved to the
543 -- task body procedure.
545 -- Visible declarations do not need to be installed in these three
546 -- cases since it does not make semantic sense to do so. All entities
547 -- referenced by a finalizer are visible and already resolved, plus
548 -- the enclosing scope may not have visible declarations at all.
550 if Ekind
(E
) = E_Procedure
551 and then Is_Finalizer
(E
)
554 or else (Is_Subprogram
(E_Scope
)
555 and then Is_Protected_Type
(Scope
(E_Scope
)))
556 or else Is_Task_Type
(E_Scope
))
560 Install_Visible_Declarations
(E_Scope
);
563 if Is_Package_Or_Generic_Package
(E_Scope
) or else
564 Is_Protected_Type
(E_Scope
) or else
565 Is_Task_Type
(E_Scope
)
567 Install_Private_Declarations
(E_Scope
);
570 -- If the entity is in an outer scope, then that scope needs to
571 -- temporarily become the current scope so that operations created
572 -- during type freezing will be declared in the right scope and
573 -- can properly override any corresponding inherited operations.
575 elsif In_Outer_Scope
then
576 Push_Scope
(E_Scope
);
579 -- If type, freeze the type
582 Delete
:= Freeze_Type
(N
);
584 -- And for enumeration type, build the enumeration tables
586 if Is_Enumeration_Type
(E
) then
587 Build_Enumeration_Image_Tables
(E
, N
);
590 -- If subprogram, freeze the subprogram
592 elsif Is_Subprogram
(E
) then
593 Exp_Ch6
.Freeze_Subprogram
(N
);
595 -- Ada 2005 (AI-251): Remove the freezing node associated with the
596 -- entities internally used by the frontend to register primitives
597 -- covering abstract interfaces. The call to Freeze_Subprogram has
598 -- already expanded the code that fills the corresponding entry in
599 -- its secondary dispatch table and therefore the code generator
600 -- has nothing else to do with this freezing node.
602 Delete
:= Present
(Interface_Alias
(E
));
605 -- Analyze actions generated by freezing. The init_proc contains source
606 -- expressions that may raise Constraint_Error, and the assignment
607 -- procedure for complex types needs checks on individual component
608 -- assignments, but all other freezing actions should be compiled with
611 if Present
(Actions
(N
)) then
612 Decl
:= First
(Actions
(N
));
613 while Present
(Decl
) loop
614 if Nkind
(Decl
) = N_Subprogram_Body
615 and then (Is_Init_Proc
(Defining_Entity
(Decl
))
617 Chars
(Defining_Entity
(Decl
)) = Name_uAssign
)
621 -- A subprogram body created for a renaming_as_body completes
622 -- a previous declaration, which may be in a different scope.
623 -- Establish the proper scope before analysis.
625 elsif Nkind
(Decl
) = N_Subprogram_Body
626 and then Present
(Corresponding_Spec
(Decl
))
627 and then Scope
(Corresponding_Spec
(Decl
)) /= Current_Scope
629 Push_Scope
(Scope
(Corresponding_Spec
(Decl
)));
630 Analyze
(Decl
, Suppress
=> All_Checks
);
633 -- We treat generated equality specially, if validity checks are
634 -- enabled, in order to detect components default-initialized
635 -- with invalid values.
637 elsif Nkind
(Decl
) = N_Subprogram_Body
638 and then Chars
(Defining_Entity
(Decl
)) = Name_Op_Eq
639 and then Validity_Checks_On
640 and then Initialize_Scalars
643 Save_Force
: constant Boolean := Force_Validity_Checks
;
645 Force_Validity_Checks
:= True;
647 Force_Validity_Checks
:= Save_Force
;
650 -- All other freezing actions
653 Analyze
(Decl
, Suppress
=> All_Checks
);
660 -- If we are to delete this N_Freeze_Entity, do so by rewriting so that
661 -- a loop on all nodes being inserted will work propertly.
664 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
667 -- Pop scope if we installed one for the analysis
669 if In_Other_Scope
then
670 if Ekind
(Current_Scope
) = E_Package
then
671 End_Package_Scope
(E_Scope
);
676 elsif In_Outer_Scope
then
680 -- Restore previous value of the nesting-level counter that records
681 -- whether we are inside a (possibly nested) call to this procedure.
683 Inside_Freezing_Actions
:= Inside_Freezing_Actions
- 1;
684 Ghost_Mode
:= Save_Ghost_Mode
;
685 end Expand_N_Freeze_Entity
;
687 -------------------------------------------
688 -- Expand_N_Record_Representation_Clause --
689 -------------------------------------------
691 -- The only expansion required is for the case of a mod clause present,
692 -- which is removed, and translated into an alignment representation
693 -- clause inserted immediately after the record rep clause with any
694 -- initial pragmas inserted at the start of the component clause list.
696 procedure Expand_N_Record_Representation_Clause
(N
: Node_Id
) is
697 Loc
: constant Source_Ptr
:= Sloc
(N
);
698 Rectype
: constant Entity_Id
:= Entity
(Identifier
(N
));
705 if Present
(Mod_Clause
(N
)) and then not Ignore_Rep_Clauses
then
706 Mod_Val
:= Expr_Value
(Expression
(Mod_Clause
(N
)));
707 Citems
:= Pragmas_Before
(Mod_Clause
(N
));
709 if Present
(Citems
) then
710 Append_List_To
(Citems
, Component_Clauses
(N
));
711 Set_Component_Clauses
(N
, Citems
);
715 Make_Attribute_Definition_Clause
(Loc
,
716 Name
=> New_Occurrence_Of
(Base_Type
(Rectype
), Loc
),
717 Chars
=> Name_Alignment
,
718 Expression
=> Make_Integer_Literal
(Loc
, Mod_Val
));
720 Set_From_At_Mod
(AtM_Nod
);
721 Insert_After
(N
, AtM_Nod
);
722 Set_Mod_Clause
(N
, Empty
);
725 -- If the record representation clause has no components, then
726 -- completely remove it. Note that we also have to remove
727 -- ourself from the Rep Item list.
729 if Is_Empty_List
(Component_Clauses
(N
)) then
730 if First_Rep_Item
(Rectype
) = N
then
731 Set_First_Rep_Item
(Rectype
, Next_Rep_Item
(N
));
733 Repitem
:= First_Rep_Item
(Rectype
);
734 while Present
(Next_Rep_Item
(Repitem
)) loop
735 if Next_Rep_Item
(Repitem
) = N
then
736 Set_Next_Rep_Item
(Repitem
, Next_Rep_Item
(N
));
740 Next_Rep_Item
(Repitem
);
745 Make_Null_Statement
(Loc
));
747 end Expand_N_Record_Representation_Clause
;