1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, 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 Namet
; use Namet
;
36 with Nlists
; use Nlists
;
37 with Nmake
; use Nmake
;
39 with Restrict
; use Restrict
;
40 with Rident
; use Rident
;
41 with Rtsfind
; use Rtsfind
;
43 with Sem_Aux
; use Sem_Aux
;
44 with Sem_Ch7
; use Sem_Ch7
;
45 with Sem_Ch8
; use Sem_Ch8
;
46 with Sem_Eval
; use Sem_Eval
;
47 with Sem_Util
; use Sem_Util
;
48 with Sinfo
; use Sinfo
;
49 with Snames
; use Snames
;
50 with Targparm
; use Targparm
;
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
295 -- Do not create a specialized Deallocate since .NET/JVM compilers do
296 -- not support pools and address arithmetic.
298 elsif VM_Target
/= No_VM
then
302 -- Use the base type to perform the check for finalization master
306 if Ekind
(Typ
) = E_Access_Subtype
then
310 -- Handle private access types
312 if Is_Private_Type
(Typ
)
313 and then Present
(Full_View
(Typ
))
315 Typ
:= Full_View
(Typ
);
318 -- Do not create a custom Deallocate when freeing an object with
319 -- suppressed finalization. In such cases the object is never attached
320 -- to a master, so it does not need to be detached. Use a regular free
321 -- statement instead.
323 if No
(Finalization_Master
(Typ
)) then
327 -- Use a temporary to store the result of a complex expression. Perform
328 -- the following transformation:
330 -- Free (Complex_Expression);
332 -- Temp : constant Type_Of_Expression := Complex_Expression;
335 if Nkind
(Expr
) /= N_Identifier
then
337 Expr_Typ
: constant Entity_Id
:= Etype
(Expr
);
338 Loc
: constant Source_Ptr
:= Sloc
(N
);
343 Temp_Id
:= Make_Temporary
(Loc
, 'T');
345 Make_Object_Declaration
(Loc
,
346 Defining_Identifier
=> Temp_Id
,
348 New_Occurrence_Of
(Expr_Typ
, Loc
),
350 Relocate_Node
(Expr
)));
352 New_Expr
:= New_Occurrence_Of
(Temp_Id
, Loc
);
353 Set_Etype
(New_Expr
, Expr_Typ
);
355 Set_Expression
(N
, New_Expr
);
359 -- Create a custom Deallocate for a controlled object. This routine
360 -- ensures that the hidden list header will be deallocated along with
361 -- the actual object.
363 Build_Allocate_Deallocate_Proc
(N
, Is_Allocate
=> False);
364 end Expand_N_Free_Statement
;
366 ----------------------------
367 -- Expand_N_Freeze_Entity --
368 ----------------------------
370 procedure Expand_N_Freeze_Entity
(N
: Node_Id
) is
371 E
: constant Entity_Id
:= Entity
(N
);
373 In_Other_Scope
: Boolean;
374 In_Outer_Scope
: Boolean;
376 Delete
: Boolean := False;
379 -- If there are delayed aspect specifications, we insert them just
380 -- before the freeze node. They are already analyzed so we don't need
381 -- to reanalyze them (they were analyzed before the type was frozen),
382 -- but we want them in the tree for the back end, and so that the
383 -- listing from sprint is clearer on where these occur logically.
385 if Has_Delayed_Aspects
(E
) then
391 -- Look for aspect specs for this entity
393 Ritem
:= First_Rep_Item
(E
);
394 while Present
(Ritem
) loop
395 if Nkind
(Ritem
) = N_Aspect_Specification
396 and then Entity
(Ritem
) = E
398 Aitem
:= Aspect_Rep_Item
(Ritem
);
400 -- Skip this for aspects (e.g. Current_Value) for which
401 -- there is no corresponding pragma or attribute.
403 if Present
(Aitem
) then
404 pragma Assert
(Is_Delayed_Aspect
(Aitem
));
405 Insert_Before
(N
, Aitem
);
409 Next_Rep_Item
(Ritem
);
414 -- Processing for objects
416 if Is_Object
(E
) then
417 if Present
(Address_Clause
(E
)) then
418 Apply_Address_Clause_Check
(E
, N
);
421 -- Analyze actions in freeze node, if any
423 if Present
(Actions
(N
)) then
427 Act
:= First
(Actions
(N
));
428 while Present
(Act
) loop
435 -- If initialization statements have been captured in a compound
436 -- statement, insert them back into the tree now.
438 Explode_Initialization_Compound_Statement
(E
);
442 -- Only other items requiring any front end action are types and
445 elsif not Is_Type
(E
) and then not Is_Subprogram
(E
) then
449 -- Here E is a type or a subprogram
451 E_Scope
:= Scope
(E
);
453 -- This is an error protection against previous errors
456 Check_Error_Detected
;
460 -- The entity may be a subtype declared for a constrained record
461 -- component, in which case the relevant scope is the scope of
462 -- the record. This happens for class-wide subtypes created for
463 -- a constrained type extension with inherited discriminants.
466 and then Ekind
(E_Scope
) not in Concurrent_Kind
468 E_Scope
:= Scope
(E_Scope
);
471 -- Remember that we are processing a freezing entity and its freezing
472 -- nodes. This flag (non-zero = set) is used to avoid the need of
473 -- climbing through the tree while processing the freezing actions (ie.
474 -- to avoid generating spurious warnings or to avoid killing constant
475 -- indications while processing the code associated with freezing
476 -- actions). We use a counter to deal with nesting.
478 Inside_Freezing_Actions
:= Inside_Freezing_Actions
+ 1;
480 -- If we are freezing entities defined in protected types, they belong
481 -- in the enclosing scope, given that the original type has been
482 -- expanded away. The same is true for entities in task types, in
483 -- particular the parameter records of entries (Entities in bodies are
484 -- all frozen within the body). If we are in the task body, this is a
485 -- proper scope. If we are within a subprogram body, the proper scope
486 -- is the corresponding spec. This may happen for itypes generated in
487 -- the bodies of protected operations.
489 if Ekind
(E_Scope
) = E_Protected_Type
490 or else (Ekind
(E_Scope
) = E_Task_Type
491 and then not Has_Completion
(E_Scope
))
493 E_Scope
:= Scope
(E_Scope
);
495 elsif Ekind
(E_Scope
) = E_Subprogram_Body
then
496 E_Scope
:= Corresponding_Spec
(Unit_Declaration_Node
(E_Scope
));
499 -- If the scope of the entity is in open scopes, it is the current one
500 -- or an enclosing one, including a loop, a block, or a subprogram.
502 if In_Open_Scopes
(E_Scope
) then
503 In_Other_Scope
:= False;
504 In_Outer_Scope
:= E_Scope
/= Current_Scope
;
506 -- Otherwise it is a local package or a different compilation unit
509 In_Other_Scope
:= True;
510 In_Outer_Scope
:= False;
513 -- If the entity being frozen is defined in a scope that is not
514 -- currently on the scope stack, we must establish the proper
515 -- visibility before freezing the entity and related subprograms.
517 if In_Other_Scope
then
518 Push_Scope
(E_Scope
);
520 -- Finalizers are little odd in terms of freezing. The spec of the
521 -- procedure appears in the declarations while the body appears in
522 -- the statement part of a single construct. Since the finalizer must
523 -- be called by the At_End handler of the construct, the spec is
524 -- manually frozen right after its declaration. The only side effect
525 -- of this action appears in contexts where the construct is not in
526 -- its final resting place. These contexts are:
528 -- * Entry bodies - The declarations and statements are moved to
529 -- the procedure equivalen of the entry.
530 -- * Protected subprograms - The declarations and statements are
531 -- moved to the non-protected version of the subprogram.
532 -- * Task bodies - The declarations and statements are moved to the
533 -- task body procedure.
535 -- Visible declarations do not need to be installed in these three
536 -- cases since it does not make semantic sense to do so. All entities
537 -- referenced by a finalizer are visible and already resolved, plus
538 -- the enclosing scope may not have visible declarations at all.
540 if Ekind
(E
) = E_Procedure
541 and then Is_Finalizer
(E
)
544 or else (Is_Subprogram
(E_Scope
)
545 and then Is_Protected_Type
(Scope
(E_Scope
)))
546 or else Is_Task_Type
(E_Scope
))
550 Install_Visible_Declarations
(E_Scope
);
553 if Is_Package_Or_Generic_Package
(E_Scope
) or else
554 Is_Protected_Type
(E_Scope
) or else
555 Is_Task_Type
(E_Scope
)
557 Install_Private_Declarations
(E_Scope
);
560 -- If the entity is in an outer scope, then that scope needs to
561 -- temporarily become the current scope so that operations created
562 -- during type freezing will be declared in the right scope and
563 -- can properly override any corresponding inherited operations.
565 elsif In_Outer_Scope
then
566 Push_Scope
(E_Scope
);
569 -- If type, freeze the type
572 Delete
:= Freeze_Type
(N
);
574 -- And for enumeration type, build the enumeration tables
576 if Is_Enumeration_Type
(E
) then
577 Build_Enumeration_Image_Tables
(E
, N
);
580 -- If subprogram, freeze the subprogram
582 elsif Is_Subprogram
(E
) then
583 Exp_Ch6
.Freeze_Subprogram
(N
);
585 -- Ada 2005 (AI-251): Remove the freezing node associated with the
586 -- entities internally used by the frontend to register primitives
587 -- covering abstract interfaces. The call to Freeze_Subprogram has
588 -- already expanded the code that fills the corresponding entry in
589 -- its secondary dispatch table and therefore the code generator
590 -- has nothing else to do with this freezing node.
592 Delete
:= Present
(Interface_Alias
(E
));
595 -- Analyze actions generated by freezing. The init_proc contains source
596 -- expressions that may raise Constraint_Error, and the assignment
597 -- procedure for complex types needs checks on individual component
598 -- assignments, but all other freezing actions should be compiled with
601 if Present
(Actions
(N
)) then
602 Decl
:= First
(Actions
(N
));
603 while Present
(Decl
) loop
604 if Nkind
(Decl
) = N_Subprogram_Body
605 and then (Is_Init_Proc
(Defining_Entity
(Decl
))
607 Chars
(Defining_Entity
(Decl
)) = Name_uAssign
)
611 -- A subprogram body created for a renaming_as_body completes
612 -- a previous declaration, which may be in a different scope.
613 -- Establish the proper scope before analysis.
615 elsif Nkind
(Decl
) = N_Subprogram_Body
616 and then Present
(Corresponding_Spec
(Decl
))
617 and then Scope
(Corresponding_Spec
(Decl
)) /= Current_Scope
619 Push_Scope
(Scope
(Corresponding_Spec
(Decl
)));
620 Analyze
(Decl
, Suppress
=> All_Checks
);
623 -- We treat generated equality specially, if validity checks are
624 -- enabled, in order to detect components default-initialized
625 -- with invalid values.
627 elsif Nkind
(Decl
) = N_Subprogram_Body
628 and then Chars
(Defining_Entity
(Decl
)) = Name_Op_Eq
629 and then Validity_Checks_On
630 and then Initialize_Scalars
633 Save_Force
: constant Boolean := Force_Validity_Checks
;
635 Force_Validity_Checks
:= True;
637 Force_Validity_Checks
:= Save_Force
;
640 -- All other freezing actions
643 Analyze
(Decl
, Suppress
=> All_Checks
);
650 -- If we are to delete this N_Freeze_Entity, do so by rewriting so that
651 -- a loop on all nodes being inserted will work propertly.
654 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
657 -- Pop scope if we installed one for the analysis
659 if In_Other_Scope
then
660 if Ekind
(Current_Scope
) = E_Package
then
661 End_Package_Scope
(E_Scope
);
666 elsif In_Outer_Scope
then
670 -- Restore previous value of the nesting-level counter that records
671 -- whether we are inside a (possibly nested) call to this procedure.
673 Inside_Freezing_Actions
:= Inside_Freezing_Actions
- 1;
674 end Expand_N_Freeze_Entity
;
676 -------------------------------------------
677 -- Expand_N_Record_Representation_Clause --
678 -------------------------------------------
680 -- The only expansion required is for the case of a mod clause present,
681 -- which is removed, and translated into an alignment representation
682 -- clause inserted immediately after the record rep clause with any
683 -- initial pragmas inserted at the start of the component clause list.
685 procedure Expand_N_Record_Representation_Clause
(N
: Node_Id
) is
686 Loc
: constant Source_Ptr
:= Sloc
(N
);
687 Rectype
: constant Entity_Id
:= Entity
(Identifier
(N
));
694 if Present
(Mod_Clause
(N
)) and then not Ignore_Rep_Clauses
then
695 Mod_Val
:= Expr_Value
(Expression
(Mod_Clause
(N
)));
696 Citems
:= Pragmas_Before
(Mod_Clause
(N
));
698 if Present
(Citems
) then
699 Append_List_To
(Citems
, Component_Clauses
(N
));
700 Set_Component_Clauses
(N
, Citems
);
704 Make_Attribute_Definition_Clause
(Loc
,
705 Name
=> New_Occurrence_Of
(Base_Type
(Rectype
), Loc
),
706 Chars
=> Name_Alignment
,
707 Expression
=> Make_Integer_Literal
(Loc
, Mod_Val
));
709 Set_From_At_Mod
(AtM_Nod
);
710 Insert_After
(N
, AtM_Nod
);
711 Set_Mod_Clause
(N
, Empty
);
714 -- If the record representation clause has no components, then
715 -- completely remove it. Note that we also have to remove
716 -- ourself from the Rep Item list.
718 if Is_Empty_List
(Component_Clauses
(N
)) then
719 if First_Rep_Item
(Rectype
) = N
then
720 Set_First_Rep_Item
(Rectype
, Next_Rep_Item
(N
));
722 Repitem
:= First_Rep_Item
(Rectype
);
723 while Present
(Next_Rep_Item
(Repitem
)) loop
724 if Next_Rep_Item
(Repitem
) = N
then
725 Set_Next_Rep_Item
(Repitem
, Next_Rep_Item
(N
));
729 Next_Rep_Item
(Repitem
);
734 Make_Null_Statement
(Loc
));
736 end Expand_N_Record_Representation_Clause
;