1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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 Namet
; use Namet
;
35 with Nlists
; use Nlists
;
36 with Nmake
; use Nmake
;
38 with Restrict
; use Restrict
;
39 with Rident
; use Rident
;
40 with Rtsfind
; use Rtsfind
;
42 with Sem_Aux
; use Sem_Aux
;
43 with Sem_Ch7
; use Sem_Ch7
;
44 with Sem_Ch8
; use Sem_Ch8
;
45 with Sem_Eval
; use Sem_Eval
;
46 with Sem_Util
; use Sem_Util
;
47 with Sinfo
; use Sinfo
;
48 with Snames
; use Snames
;
49 with Targparm
; use Targparm
;
50 with Tbuild
; use Tbuild
;
51 with Uintp
; use Uintp
;
52 with Validsw
; use Validsw
;
54 package body Exp_Ch13
is
56 ------------------------------------------
57 -- Expand_N_Attribute_Definition_Clause --
58 ------------------------------------------
60 -- Expansion action depends on attribute involved
62 procedure Expand_N_Attribute_Definition_Clause
(N
: Node_Id
) is
63 Loc
: constant Source_Ptr
:= Sloc
(N
);
64 Exp
: constant Node_Id
:= Expression
(N
);
69 Ent
:= Entity
(Name
(N
));
72 Ent
:= Underlying_Type
(Ent
);
75 case Get_Attribute_Id
(Chars
(N
)) is
81 when Attribute_Address
=>
83 -- If there is an initialization which did not come from the
84 -- source program, then it is an artifact of our expansion, and we
85 -- suppress it. The case we are most concerned about here is the
86 -- initialization of a packed array to all false, which seems
87 -- inappropriate for variable to which an address clause is
88 -- applied. The expression may itself have been rewritten if the
89 -- type is packed array, so we need to examine whether the
90 -- original node is in the source. An exception though is the case
91 -- of an access variable which is default initialized to null, and
92 -- such initialization is retained.
94 -- Furthermore, if the initialization is the equivalent aggregate
95 -- of the type initialization procedure, it replaces an implicit
96 -- call to the init proc, and must be respected. Note that for
97 -- packed types we do not build equivalent aggregates.
99 -- Also, if Init_Or_Norm_Scalars applies, then we need to retain
100 -- any default initialization for objects of scalar types and
101 -- types with scalar components. Normally a composite type will
102 -- have an init_proc in the presence of Init_Or_Norm_Scalars,
103 -- so when that flag is set we have just have to do a test for
104 -- scalar and string types (the predefined string types such as
105 -- String and Wide_String don't have an init_proc).
108 Decl
: constant Node_Id
:= Declaration_Node
(Ent
);
109 Typ
: constant Entity_Id
:= Etype
(Ent
);
112 if Nkind
(Decl
) = N_Object_Declaration
113 and then Present
(Expression
(Decl
))
114 and then Nkind
(Expression
(Decl
)) /= N_Null
116 not Comes_From_Source
(Original_Node
(Expression
(Decl
)))
118 if Present
(Base_Init_Proc
(Typ
))
120 Present
(Static_Initialization
(Base_Init_Proc
(Typ
)))
124 elsif Init_Or_Norm_Scalars
126 (Is_Scalar_Type
(Typ
) or else Is_String_Type
(Typ
))
131 Set_Expression
(Decl
, Empty
);
134 -- An object declaration to which an address clause applies
135 -- has a delayed freeze, but the address expression itself
136 -- must be elaborated at the point it appears. If the object
137 -- is controlled, additional checks apply elsewhere.
139 elsif Nkind
(Decl
) = N_Object_Declaration
140 and then not Needs_Constant_Address
(Decl
, Typ
)
142 Remove_Side_Effects
(Exp
);
150 when Attribute_Alignment
=>
152 -- As required by Gigi, we guarantee that the operand is an
153 -- integer literal (this simplifies things in Gigi).
155 if Nkind
(Exp
) /= N_Integer_Literal
then
157 (Exp
, Make_Integer_Literal
(Loc
, Expr_Value
(Exp
)));
160 -- A complex case arises if the alignment clause applies to an
161 -- unconstrained object initialized with a function call. The
162 -- result of the call is placed on the secondary stack, and the
163 -- declaration is rewritten as a renaming of a dereference, which
164 -- fails expansion. We must introduce a temporary and assign its
165 -- value to the existing entity.
167 if Nkind
(Parent
(Ent
)) = N_Object_Renaming_Declaration
168 and then not Is_Entity_Name
(Renamed_Object
(Ent
))
171 Loc
: constant Source_Ptr
:= Sloc
(N
);
172 Decl
: constant Node_Id
:= Parent
(Ent
);
173 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
177 -- Replace entity with temporary and reanalyze
179 Set_Defining_Identifier
(Decl
, Temp
);
180 Set_Analyzed
(Decl
, False);
183 -- Introduce new declaration for entity but do not reanalyze
184 -- because entity is already in scope. Type and expression
185 -- are already resolved.
188 Make_Object_Declaration
(Loc
,
189 Defining_Identifier
=> Ent
,
191 New_Occurrence_Of
(Etype
(Ent
), Loc
),
192 Expression
=> New_Occurrence_Of
(Temp
, Loc
));
194 Set_Renamed_Object
(Ent
, Empty
);
195 Insert_After
(Decl
, New_Decl
);
204 when Attribute_Storage_Size
=>
206 -- If the type is a task type, then assign the value of the
207 -- storage size to the Size variable associated with the task.
208 -- Insert the assignment right after the declaration of the Size
213 -- task_typeZ := expression
215 if Ekind
(Ent
) = E_Task_Type
then
221 Make_Assignment_Statement
(Loc
,
223 New_Occurrence_Of
(Storage_Size_Variable
(Ent
), Loc
),
225 Convert_To
(RTE
(RE_Size_Type
), Expression
(N
)));
227 -- If the clause is not generated by an aspect, insert
228 -- the assignment here. Freezing rules ensure that this
229 -- is safe, or clause will have been rejected already.
231 if Is_List_Member
(N
) then
232 Insert_After
(N
, Assign
);
234 -- Otherwise, insert assignment after task declaration.
238 (Parent
(Storage_Size_Variable
(Entity
(N
))), Assign
);
244 -- For Storage_Size for an access type, create a variable to hold
245 -- the value of the specified size with name typeV and expand an
246 -- assignment statement to initialize this value.
248 elsif Is_Access_Type
(Ent
) then
250 -- We don't need the variable for a storage size of zero
252 if not No_Pool_Assigned
(Ent
) then
254 Make_Defining_Identifier
(Loc
,
255 Chars
=> New_External_Name
(Chars
(Ent
), 'V'));
257 -- Insert the declaration of the object
260 Make_Object_Declaration
(Loc
,
261 Defining_Identifier
=> V
,
263 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
265 Convert_To
(RTE
(RE_Storage_Offset
), Expression
(N
))));
267 Set_Storage_Size_Variable
(Ent
, Entity_Id
(V
));
271 -- Other attributes require no expansion
277 end Expand_N_Attribute_Definition_Clause
;
279 -----------------------------
280 -- Expand_N_Free_Statement --
281 -----------------------------
283 procedure Expand_N_Free_Statement
(N
: Node_Id
) is
284 Expr
: constant Node_Id
:= Expression
(N
);
288 -- Certain run-time configurations and targets do not provide support
289 -- for controlled types.
291 if Restriction_Active
(No_Finalization
) then
294 -- Do not create a specialized Deallocate since .NET/JVM compilers do
295 -- not support pools and address arithmetic.
297 elsif VM_Target
/= No_VM
then
301 -- Use the base type to perform the check for finalization master
305 if Ekind
(Typ
) = E_Access_Subtype
then
309 -- Handle private access types
311 if Is_Private_Type
(Typ
)
312 and then Present
(Full_View
(Typ
))
314 Typ
:= Full_View
(Typ
);
317 -- Do not create a custom Deallocate when freeing an object with
318 -- suppressed finalization. In such cases the object is never attached
319 -- to a master, so it does not need to be detached. Use a regular free
320 -- statement instead.
322 if No
(Finalization_Master
(Typ
)) then
326 -- Use a temporary to store the result of a complex expression. Perform
327 -- the following transformation:
329 -- Free (Complex_Expression);
331 -- Temp : constant Type_Of_Expression := Complex_Expression;
334 if Nkind
(Expr
) /= N_Identifier
then
336 Expr_Typ
: constant Entity_Id
:= Etype
(Expr
);
337 Loc
: constant Source_Ptr
:= Sloc
(N
);
342 Temp_Id
:= Make_Temporary
(Loc
, 'T');
344 Make_Object_Declaration
(Loc
,
345 Defining_Identifier
=> Temp_Id
,
347 New_Occurrence_Of
(Expr_Typ
, Loc
),
349 Relocate_Node
(Expr
)));
351 New_Expr
:= New_Occurrence_Of
(Temp_Id
, Loc
);
352 Set_Etype
(New_Expr
, Expr_Typ
);
354 Set_Expression
(N
, New_Expr
);
358 -- Create a custom Deallocate for a controlled object. This routine
359 -- ensures that the hidden list header will be deallocated along with
360 -- the actual object.
362 Build_Allocate_Deallocate_Proc
(N
, Is_Allocate
=> False);
363 end Expand_N_Free_Statement
;
365 ----------------------------
366 -- Expand_N_Freeze_Entity --
367 ----------------------------
369 procedure Expand_N_Freeze_Entity
(N
: Node_Id
) is
370 E
: constant Entity_Id
:= Entity
(N
);
372 In_Other_Scope
: Boolean;
373 In_Outer_Scope
: Boolean;
375 Delete
: Boolean := False;
378 -- If there are delayed aspect specifications, we insert them just
379 -- before the freeze node. They are already analyzed so we don't need
380 -- to reanalyze them (they were analyzed before the type was frozen),
381 -- but we want them in the tree for the back end, and so that the
382 -- listing from sprint is clearer on where these occur logically.
384 if Has_Delayed_Aspects
(E
) then
390 -- Look for aspect specs for this entity
392 Ritem
:= First_Rep_Item
(E
);
393 while Present
(Ritem
) loop
394 if Nkind
(Ritem
) = N_Aspect_Specification
395 and then Entity
(Ritem
) = E
397 Aitem
:= Aspect_Rep_Item
(Ritem
);
399 -- Skip this for aspects (e.g. Current_Value) for which
400 -- there is no corresponding pragma or attribute.
402 if Present
(Aitem
) then
403 pragma Assert
(Is_Delayed_Aspect
(Aitem
));
404 Insert_Before
(N
, Aitem
);
408 Next_Rep_Item
(Ritem
);
413 -- Processing for objects with address clauses
415 if Is_Object
(E
) and then Present
(Address_Clause
(E
)) then
416 Apply_Address_Clause_Check
(E
, N
);
419 -- Only other items requiring any front end action are types and
422 elsif not Is_Type
(E
) and then not Is_Subprogram
(E
) then
426 -- Here E is a type or a subprogram
428 E_Scope
:= Scope
(E
);
430 -- This is an error protection against previous errors
433 Check_Error_Detected
;
437 -- Remember that we are processing a freezing entity and its freezing
438 -- nodes. This flag (non-zero = set) is used to avoid the need of
439 -- climbing through the tree while processing the freezing actions (ie.
440 -- to avoid generating spurious warnings or to avoid killing constant
441 -- indications while processing the code associated with freezing
442 -- actions). We use a counter to deal with nesting.
444 Inside_Freezing_Actions
:= Inside_Freezing_Actions
+ 1;
446 -- If we are freezing entities defined in protected types, they belong
447 -- in the enclosing scope, given that the original type has been
448 -- expanded away. The same is true for entities in task types, in
449 -- particular the parameter records of entries (Entities in bodies are
450 -- all frozen within the body). If we are in the task body, this is a
451 -- proper scope. If we are within a subprogram body, the proper scope
452 -- is the corresponding spec. This may happen for itypes generated in
453 -- the bodies of protected operations.
455 if Ekind
(E_Scope
) = E_Protected_Type
456 or else (Ekind
(E_Scope
) = E_Task_Type
457 and then not Has_Completion
(E_Scope
))
459 E_Scope
:= Scope
(E_Scope
);
461 elsif Ekind
(E_Scope
) = E_Subprogram_Body
then
462 E_Scope
:= Corresponding_Spec
(Unit_Declaration_Node
(E_Scope
));
465 -- If the scope of the entity is in open scopes, it is the current one
466 -- or an enclosing one, including a loop, a block, or a subprogram.
468 if In_Open_Scopes
(E_Scope
) then
469 In_Other_Scope
:= False;
470 In_Outer_Scope
:= E_Scope
/= Current_Scope
;
472 -- Otherwise it is a local package or a different compilation unit
475 In_Other_Scope
:= True;
476 In_Outer_Scope
:= False;
479 -- If the entity being frozen is defined in a scope that is not
480 -- currently on the scope stack, we must establish the proper
481 -- visibility before freezing the entity and related subprograms.
483 if In_Other_Scope
then
484 Push_Scope
(E_Scope
);
486 -- Finalizers are little odd in terms of freezing. The spec of the
487 -- procedure appears in the declarations while the body appears in
488 -- the statement part of a single construct. Since the finalizer must
489 -- be called by the At_End handler of the construct, the spec is
490 -- manually frozen right after its declaration. The only side effect
491 -- of this action appears in contexts where the construct is not in
492 -- its final resting place. These contexts are:
494 -- * Entry bodies - The declarations and statements are moved to
495 -- the procedure equivalen of the entry.
496 -- * Protected subprograms - The declarations and statements are
497 -- moved to the non-protected version of the subprogram.
498 -- * Task bodies - The declarations and statements are moved to the
499 -- task body procedure.
501 -- Visible declarations do not need to be installed in these three
502 -- cases since it does not make semantic sense to do so. All entities
503 -- referenced by a finalizer are visible and already resolved, plus
504 -- the enclosing scope may not have visible declarations at all.
506 if Ekind
(E
) = E_Procedure
507 and then Is_Finalizer
(E
)
510 or else (Is_Subprogram
(E_Scope
)
511 and then Is_Protected_Type
(Scope
(E_Scope
)))
512 or else Is_Task_Type
(E_Scope
))
516 Install_Visible_Declarations
(E_Scope
);
519 if Is_Package_Or_Generic_Package
(E_Scope
) or else
520 Is_Protected_Type
(E_Scope
) or else
521 Is_Task_Type
(E_Scope
)
523 Install_Private_Declarations
(E_Scope
);
526 -- If the entity is in an outer scope, then that scope needs to
527 -- temporarily become the current scope so that operations created
528 -- during type freezing will be declared in the right scope and
529 -- can properly override any corresponding inherited operations.
531 elsif In_Outer_Scope
then
532 Push_Scope
(E_Scope
);
535 -- If type, freeze the type
538 Delete
:= Freeze_Type
(N
);
540 -- And for enumeration type, build the enumeration tables
542 if Is_Enumeration_Type
(E
) then
543 Build_Enumeration_Image_Tables
(E
, N
);
546 -- If subprogram, freeze the subprogram
548 elsif Is_Subprogram
(E
) then
549 Freeze_Subprogram
(N
);
551 -- Ada 2005 (AI-251): Remove the freezing node associated with the
552 -- entities internally used by the frontend to register primitives
553 -- covering abstract interfaces. The call to Freeze_Subprogram has
554 -- already expanded the code that fills the corresponding entry in
555 -- its secondary dispatch table and therefore the code generator
556 -- has nothing else to do with this freezing node.
558 Delete
:= Present
(Interface_Alias
(E
));
561 -- Analyze actions generated by freezing. The init_proc contains source
562 -- expressions that may raise Constraint_Error, and the assignment
563 -- procedure for complex types needs checks on individual component
564 -- assignments, but all other freezing actions should be compiled with
567 if Present
(Actions
(N
)) then
568 Decl
:= First
(Actions
(N
));
569 while Present
(Decl
) loop
570 if Nkind
(Decl
) = N_Subprogram_Body
571 and then (Is_Init_Proc
(Defining_Entity
(Decl
))
573 Chars
(Defining_Entity
(Decl
)) = Name_uAssign
)
577 -- A subprogram body created for a renaming_as_body completes
578 -- a previous declaration, which may be in a different scope.
579 -- Establish the proper scope before analysis.
581 elsif Nkind
(Decl
) = N_Subprogram_Body
582 and then Present
(Corresponding_Spec
(Decl
))
583 and then Scope
(Corresponding_Spec
(Decl
)) /= Current_Scope
585 Push_Scope
(Scope
(Corresponding_Spec
(Decl
)));
586 Analyze
(Decl
, Suppress
=> All_Checks
);
589 -- We treat generated equality specially, if validity checks are
590 -- enabled, in order to detect components default-initialized
591 -- with invalid values.
593 elsif Nkind
(Decl
) = N_Subprogram_Body
594 and then Chars
(Defining_Entity
(Decl
)) = Name_Op_Eq
595 and then Validity_Checks_On
596 and then Initialize_Scalars
599 Save_Force
: constant Boolean := Force_Validity_Checks
;
601 Force_Validity_Checks
:= True;
603 Force_Validity_Checks
:= Save_Force
;
606 -- All other freezing actions
609 Analyze
(Decl
, Suppress
=> All_Checks
);
616 -- If we are to delete this N_Freeze_Entity, do so by rewriting so that
617 -- a loop on all nodes being inserted will work propertly.
620 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
623 -- Pop scope if we installed one for the analysis
625 if In_Other_Scope
then
626 if Ekind
(Current_Scope
) = E_Package
then
627 End_Package_Scope
(E_Scope
);
632 elsif In_Outer_Scope
then
636 -- Restore previous value of the nesting-level counter that records
637 -- whether we are inside a (possibly nested) call to this procedure.
639 Inside_Freezing_Actions
:= Inside_Freezing_Actions
- 1;
640 end Expand_N_Freeze_Entity
;
642 -------------------------------------------
643 -- Expand_N_Record_Representation_Clause --
644 -------------------------------------------
646 -- The only expansion required is for the case of a mod clause present,
647 -- which is removed, and translated into an alignment representation
648 -- clause inserted immediately after the record rep clause with any
649 -- initial pragmas inserted at the start of the component clause list.
651 procedure Expand_N_Record_Representation_Clause
(N
: Node_Id
) is
652 Loc
: constant Source_Ptr
:= Sloc
(N
);
653 Rectype
: constant Entity_Id
:= Entity
(Identifier
(N
));
660 if Present
(Mod_Clause
(N
)) and then not Ignore_Rep_Clauses
then
661 Mod_Val
:= Expr_Value
(Expression
(Mod_Clause
(N
)));
662 Citems
:= Pragmas_Before
(Mod_Clause
(N
));
664 if Present
(Citems
) then
665 Append_List_To
(Citems
, Component_Clauses
(N
));
666 Set_Component_Clauses
(N
, Citems
);
670 Make_Attribute_Definition_Clause
(Loc
,
671 Name
=> New_Occurrence_Of
(Base_Type
(Rectype
), Loc
),
672 Chars
=> Name_Alignment
,
673 Expression
=> Make_Integer_Literal
(Loc
, Mod_Val
));
675 Set_From_At_Mod
(AtM_Nod
);
676 Insert_After
(N
, AtM_Nod
);
677 Set_Mod_Clause
(N
, Empty
);
680 -- If the record representation clause has no components, then
681 -- completely remove it. Note that we also have to remove
682 -- ourself from the Rep Item list.
684 if Is_Empty_List
(Component_Clauses
(N
)) then
685 if First_Rep_Item
(Rectype
) = N
then
686 Set_First_Rep_Item
(Rectype
, Next_Rep_Item
(N
));
688 Repitem
:= First_Rep_Item
(Rectype
);
689 while Present
(Next_Rep_Item
(Repitem
)) loop
690 if Next_Rep_Item
(Repitem
) = N
then
691 Set_Next_Rep_Item
(Repitem
, Next_Rep_Item
(N
));
695 Next_Rep_Item
(Repitem
);
700 Make_Null_Statement
(Loc
));
702 end Expand_N_Record_Representation_Clause
;