1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, 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
;
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 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
125 and then (Is_Scalar_Type
(Typ
)
126 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.
138 -- If the attribute comes from an aspect specification it
139 -- is being elaborated at the freeze point and side effects
140 -- need not be removed (and shouldn't, if the expression
141 -- depends on other entities that have delayed freeze).
142 -- This is another consequence of the delayed analysis of
143 -- aspects, and a real semantic difference.
145 elsif Nkind
(Decl
) = N_Object_Declaration
146 and then not Needs_Constant_Address
(Decl
, Typ
)
147 and then not From_Aspect_Specification
(N
)
149 Remove_Side_Effects
(Exp
);
157 when Attribute_Alignment
=>
159 -- As required by Gigi, we guarantee that the operand is an
160 -- integer literal (this simplifies things in Gigi).
162 if Nkind
(Exp
) /= N_Integer_Literal
then
163 Rewrite
(Exp
, Make_Integer_Literal
(Loc
, Expr_Value
(Exp
)));
166 -- A complex case arises if the alignment clause applies to an
167 -- unconstrained object initialized with a function call. The
168 -- result of the call is placed on the secondary stack, and the
169 -- declaration is rewritten as a renaming of a dereference, which
170 -- fails expansion. We must introduce a temporary and assign its
171 -- value to the existing entity.
173 if Nkind
(Parent
(Ent
)) = N_Object_Renaming_Declaration
174 and then not Is_Entity_Name
(Renamed_Object
(Ent
))
177 Decl
: constant Node_Id
:= Parent
(Ent
);
178 Loc
: constant Source_Ptr
:= Sloc
(N
);
179 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
184 -- Replace entity with temporary and reanalyze
186 Set_Defining_Identifier
(Decl
, Temp
);
187 Set_Analyzed
(Decl
, False);
190 -- Introduce new declaration for entity but do not reanalyze
191 -- because entity is already in scope. Type and expression
192 -- are already resolved.
195 Make_Object_Declaration
(Loc
,
196 Defining_Identifier
=> Ent
,
198 New_Occurrence_Of
(Etype
(Ent
), Loc
),
199 Expression
=> New_Occurrence_Of
(Temp
, Loc
));
201 Set_Renamed_Object
(Ent
, Empty
);
202 Insert_After
(Decl
, New_Decl
);
211 when Attribute_Storage_Size
=>
213 -- If the type is a task type, then assign the value of the
214 -- storage size to the Size variable associated with the task.
215 -- Insert the assignment right after the declaration of the Size
220 -- task_typeZ := expression
222 if Ekind
(Ent
) = E_Task_Type
then
228 Make_Assignment_Statement
(Loc
,
230 New_Occurrence_Of
(Storage_Size_Variable
(Ent
), Loc
),
232 Convert_To
(RTE
(RE_Size_Type
), Expression
(N
)));
234 -- If the clause is not generated by an aspect, insert
235 -- the assignment here. Freezing rules ensure that this
236 -- is safe, or clause will have been rejected already.
238 if Is_List_Member
(N
) then
239 Insert_After
(N
, Assign
);
241 -- Otherwise, insert assignment after task declaration.
245 (Parent
(Storage_Size_Variable
(Entity
(N
))), Assign
);
251 -- For Storage_Size for an access type, create a variable to hold
252 -- the value of the specified size with name typeV and expand an
253 -- assignment statement to initialize this value.
255 elsif Is_Access_Type
(Ent
) then
257 -- We don't need the variable for a storage size of zero
259 if not No_Pool_Assigned
(Ent
) then
261 Make_Defining_Identifier
(Loc
,
262 Chars
=> New_External_Name
(Chars
(Ent
), 'V'));
264 -- Insert the declaration of the object. If the expression
265 -- is not static it may depend on some other type that is
266 -- not frozen yet, so attach the declaration that captures
267 -- the value of the expression to the actions of the freeze
268 -- node of the current type.
271 Decl
: constant Node_Id
:=
272 Make_Object_Declaration
(Loc
,
273 Defining_Identifier
=> V
,
275 New_Occurrence_Of
(RTE
(RE_Storage_Offset
), Loc
),
278 (RTE
(RE_Storage_Offset
), Expression
(N
)));
280 if not Is_OK_Static_Expression
(Expression
(N
))
281 and then Present
(Freeze_Node
(Ent
))
283 if No
(Actions
(Freeze_Node
(Ent
))) then
284 Set_Actions
(Freeze_Node
(Ent
), New_List
(Decl
));
286 Append
(Decl
, Actions
(Freeze_Node
(Ent
)));
290 Insert_Action
(N
, Decl
);
294 Set_Storage_Size_Variable
(Ent
, Entity_Id
(V
));
298 -- Other attributes require no expansion
303 end Expand_N_Attribute_Definition_Clause
;
305 -----------------------------
306 -- Expand_N_Free_Statement --
307 -----------------------------
309 procedure Expand_N_Free_Statement
(N
: Node_Id
) is
310 Expr
: constant Node_Id
:= Expression
(N
);
314 -- Certain run-time configurations and targets do not provide support
315 -- for controlled types.
317 if Restriction_Active
(No_Finalization
) then
321 -- Use the base type to perform the check for finalization master
325 if Ekind
(Typ
) = E_Access_Subtype
then
329 -- Handle private access types
331 if Is_Private_Type
(Typ
)
332 and then Present
(Full_View
(Typ
))
334 Typ
:= Full_View
(Typ
);
337 -- Do not create a custom Deallocate when freeing an object with
338 -- suppressed finalization. In such cases the object is never attached
339 -- to a master, so it does not need to be detached. Use a regular free
340 -- statement instead.
342 if No
(Finalization_Master
(Typ
)) then
346 -- Use a temporary to store the result of a complex expression. Perform
347 -- the following transformation:
349 -- Free (Complex_Expression);
351 -- Temp : constant Type_Of_Expression := Complex_Expression;
354 if Nkind
(Expr
) /= N_Identifier
then
356 Expr_Typ
: constant Entity_Id
:= Etype
(Expr
);
357 Loc
: constant Source_Ptr
:= Sloc
(N
);
362 Temp_Id
:= Make_Temporary
(Loc
, 'T');
364 Make_Object_Declaration
(Loc
,
365 Defining_Identifier
=> Temp_Id
,
366 Object_Definition
=> New_Occurrence_Of
(Expr_Typ
, Loc
),
367 Expression
=> Relocate_Node
(Expr
)));
369 New_Expr
:= New_Occurrence_Of
(Temp_Id
, Loc
);
370 Set_Etype
(New_Expr
, Expr_Typ
);
372 Set_Expression
(N
, New_Expr
);
376 -- Create a custom Deallocate for a controlled object. This routine
377 -- ensures that the hidden list header will be deallocated along with
378 -- the actual object.
380 Build_Allocate_Deallocate_Proc
(N
, Is_Allocate
=> False);
381 end Expand_N_Free_Statement
;
383 ----------------------------
384 -- Expand_N_Freeze_Entity --
385 ----------------------------
387 procedure Expand_N_Freeze_Entity
(N
: Node_Id
) is
388 E
: constant Entity_Id
:= Entity
(N
);
391 Delete
: Boolean := False;
393 In_Other_Scope
: Boolean;
394 In_Outer_Scope
: Boolean;
397 -- If there are delayed aspect specifications, we insert them just
398 -- before the freeze node. They are already analyzed so we don't need
399 -- to reanalyze them (they were analyzed before the type was frozen),
400 -- but we want them in the tree for the back end, and so that the
401 -- listing from sprint is clearer on where these occur logically.
403 if Has_Delayed_Aspects
(E
) then
409 -- Look for aspect specs for this entity
411 Ritem
:= First_Rep_Item
(E
);
412 while Present
(Ritem
) loop
413 if Nkind
(Ritem
) = N_Aspect_Specification
414 and then Entity
(Ritem
) = E
416 Aitem
:= Aspect_Rep_Item
(Ritem
);
418 -- Skip this for aspects (e.g. Current_Value) for which
419 -- there is no corresponding pragma or attribute.
423 -- Also skip if we have a null statement rather than a
424 -- delayed aspect (this happens when we are ignoring rep
425 -- items from use of the -gnatI switch).
427 and then Nkind
(Aitem
) /= N_Null_Statement
429 pragma Assert
(Is_Delayed_Aspect
(Aitem
));
430 Insert_Before
(N
, Aitem
);
434 Next_Rep_Item
(Ritem
);
439 -- Processing for objects
441 if Is_Object
(E
) then
442 if Present
(Address_Clause
(E
)) then
443 Apply_Address_Clause_Check
(E
, N
);
446 -- Analyze actions in freeze node, if any
448 if Present
(Actions
(N
)) then
452 Act
:= First
(Actions
(N
));
453 while Present
(Act
) loop
460 -- If initialization statements have been captured in a compound
461 -- statement, insert them back into the tree now.
463 Explode_Initialization_Compound_Statement
(E
);
466 -- Only other items requiring any front end action are types and
469 elsif not Is_Type
(E
) and then not Is_Subprogram
(E
) then
473 -- Here E is a type or a subprogram
475 E_Scope
:= Scope
(E
);
477 -- This is an error protection against previous errors
480 Check_Error_Detected
;
484 -- The entity may be a subtype declared for a constrained record
485 -- component, in which case the relevant scope is the scope of
486 -- the record. This happens for class-wide subtypes created for
487 -- a constrained type extension with inherited discriminants.
490 and then Ekind
(E_Scope
) not in Concurrent_Kind
492 E_Scope
:= Scope
(E_Scope
);
494 -- The entity may be a subtype declared for an iterator
496 elsif Ekind
(E_Scope
) = E_Loop
then
497 E_Scope
:= Scope
(E_Scope
);
500 -- Remember that we are processing a freezing entity and its freezing
501 -- nodes. This flag (non-zero = set) is used to avoid the need of
502 -- climbing through the tree while processing the freezing actions (ie.
503 -- to avoid generating spurious warnings or to avoid killing constant
504 -- indications while processing the code associated with freezing
505 -- actions). We use a counter to deal with nesting.
507 Inside_Freezing_Actions
:= Inside_Freezing_Actions
+ 1;
509 -- If we are freezing entities defined in protected types, they belong
510 -- in the enclosing scope, given that the original type has been
511 -- expanded away. The same is true for entities in task types, in
512 -- particular the parameter records of entries (Entities in bodies are
513 -- all frozen within the body). If we are in the task body, this is a
514 -- proper scope. If we are within a subprogram body, the proper scope
515 -- is the corresponding spec. This may happen for itypes generated in
516 -- the bodies of protected operations.
518 if Ekind
(E_Scope
) = E_Protected_Type
519 or else (Ekind
(E_Scope
) = E_Task_Type
520 and then not Has_Completion
(E_Scope
))
522 E_Scope
:= Scope
(E_Scope
);
524 elsif Ekind
(E_Scope
) = E_Subprogram_Body
then
525 E_Scope
:= Corresponding_Spec
(Unit_Declaration_Node
(E_Scope
));
528 -- If the scope of the entity is in open scopes, it is the current one
529 -- or an enclosing one, including a loop, a block, or a subprogram.
531 if In_Open_Scopes
(E_Scope
) then
532 In_Other_Scope
:= False;
533 In_Outer_Scope
:= E_Scope
/= Current_Scope
;
535 -- Otherwise it is a local package or a different compilation unit
538 In_Other_Scope
:= True;
539 In_Outer_Scope
:= False;
542 -- If the entity being frozen is defined in a scope that is not
543 -- currently on the scope stack, we must establish the proper
544 -- visibility before freezing the entity and related subprograms.
546 if In_Other_Scope
then
547 Push_Scope
(E_Scope
);
549 -- Finalizers are little odd in terms of freezing. The spec of the
550 -- procedure appears in the declarations while the body appears in
551 -- the statement part of a single construct. Since the finalizer must
552 -- be called by the At_End handler of the construct, the spec is
553 -- manually frozen right after its declaration. The only side effect
554 -- of this action appears in contexts where the construct is not in
555 -- its final resting place. These contexts are:
557 -- * Entry bodies - The declarations and statements are moved to
558 -- the procedure equivalen of the entry.
559 -- * Protected subprograms - The declarations and statements are
560 -- moved to the non-protected version of the subprogram.
561 -- * Task bodies - The declarations and statements are moved to the
562 -- task body procedure.
563 -- * Blocks that will be rewritten as subprograms when unnesting
566 -- Visible declarations do not need to be installed in these three
567 -- cases since it does not make semantic sense to do so. All entities
568 -- referenced by a finalizer are visible and already resolved, plus
569 -- the enclosing scope may not have visible declarations at all.
571 if Ekind
(E
) = E_Procedure
572 and then Is_Finalizer
(E
)
575 or else (Is_Subprogram
(E_Scope
)
576 and then Is_Protected_Type
(Scope
(E_Scope
)))
577 or else Is_Task_Type
(E_Scope
)
578 or else Ekind
(E_Scope
) = E_Block
)
582 Install_Visible_Declarations
(E_Scope
);
585 if Is_Concurrent_Type
(E_Scope
)
586 or else Is_Package_Or_Generic_Package
(E_Scope
)
588 Install_Private_Declarations
(E_Scope
);
591 -- If the entity is in an outer scope, then that scope needs to
592 -- temporarily become the current scope so that operations created
593 -- during type freezing will be declared in the right scope and
594 -- can properly override any corresponding inherited operations.
596 elsif In_Outer_Scope
then
597 Push_Scope
(E_Scope
);
600 -- If type, freeze the type
603 Delete
:= Freeze_Type
(N
);
605 -- And for enumeration type, build the enumeration tables
607 if Is_Enumeration_Type
(E
) then
608 Build_Enumeration_Image_Tables
(E
, N
);
611 -- If subprogram, freeze the subprogram
613 elsif Is_Subprogram
(E
) then
614 Exp_Ch6
.Freeze_Subprogram
(N
);
616 -- Ada 2005 (AI-251): Remove the freezing node associated with the
617 -- entities internally used by the frontend to register primitives
618 -- covering abstract interfaces. The call to Freeze_Subprogram has
619 -- already expanded the code that fills the corresponding entry in
620 -- its secondary dispatch table and therefore the code generator
621 -- has nothing else to do with this freezing node.
623 Delete
:= Present
(Interface_Alias
(E
));
626 -- Analyze actions generated by freezing. The init_proc contains source
627 -- expressions that may raise Constraint_Error, and the assignment
628 -- procedure for complex types needs checks on individual component
629 -- assignments, but all other freezing actions should be compiled with
632 if Present
(Actions
(N
)) then
633 Decl
:= First
(Actions
(N
));
634 while Present
(Decl
) loop
635 if Nkind
(Decl
) = N_Subprogram_Body
636 and then (Is_Init_Proc
(Defining_Entity
(Decl
))
638 Chars
(Defining_Entity
(Decl
)) = Name_uAssign
)
642 -- A subprogram body created for a renaming_as_body completes
643 -- a previous declaration, which may be in a different scope.
644 -- Establish the proper scope before analysis.
646 elsif Nkind
(Decl
) = N_Subprogram_Body
647 and then Present
(Corresponding_Spec
(Decl
))
648 and then Scope
(Corresponding_Spec
(Decl
)) /= Current_Scope
650 Push_Scope
(Scope
(Corresponding_Spec
(Decl
)));
651 Analyze
(Decl
, Suppress
=> All_Checks
);
654 -- We treat generated equality specially, if validity checks are
655 -- enabled, in order to detect components default-initialized
656 -- with invalid values.
658 elsif Nkind
(Decl
) = N_Subprogram_Body
659 and then Chars
(Defining_Entity
(Decl
)) = Name_Op_Eq
660 and then Validity_Checks_On
661 and then Initialize_Scalars
664 Save_Force
: constant Boolean := Force_Validity_Checks
;
666 Force_Validity_Checks
:= True;
668 Force_Validity_Checks
:= Save_Force
;
671 -- All other freezing actions
674 Analyze
(Decl
, Suppress
=> All_Checks
);
681 -- If we are to delete this N_Freeze_Entity, do so by rewriting so that
682 -- a loop on all nodes being inserted will work propertly.
685 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
688 -- Pop scope if we installed one for the analysis
690 if In_Other_Scope
then
691 if Ekind
(Current_Scope
) = E_Package
then
692 End_Package_Scope
(E_Scope
);
697 elsif In_Outer_Scope
then
701 -- Restore previous value of the nesting-level counter that records
702 -- whether we are inside a (possibly nested) call to this procedure.
704 Inside_Freezing_Actions
:= Inside_Freezing_Actions
- 1;
705 end Expand_N_Freeze_Entity
;
707 -------------------------------------------
708 -- Expand_N_Record_Representation_Clause --
709 -------------------------------------------
711 -- The only expansion required is for the case of a mod clause present,
712 -- which is removed, and translated into an alignment representation
713 -- clause inserted immediately after the record rep clause with any
714 -- initial pragmas inserted at the start of the component clause list.
716 procedure Expand_N_Record_Representation_Clause
(N
: Node_Id
) is
717 Loc
: constant Source_Ptr
:= Sloc
(N
);
718 Rectype
: constant Entity_Id
:= Entity
(Identifier
(N
));
725 if Present
(Mod_Clause
(N
)) and then not Ignore_Rep_Clauses
then
726 Mod_Val
:= Expr_Value
(Expression
(Mod_Clause
(N
)));
727 Citems
:= Pragmas_Before
(Mod_Clause
(N
));
729 if Present
(Citems
) then
730 Append_List_To
(Citems
, Component_Clauses
(N
));
731 Set_Component_Clauses
(N
, Citems
);
735 Make_Attribute_Definition_Clause
(Loc
,
736 Name
=> New_Occurrence_Of
(Base_Type
(Rectype
), Loc
),
737 Chars
=> Name_Alignment
,
738 Expression
=> Make_Integer_Literal
(Loc
, Mod_Val
));
740 Set_From_At_Mod
(AtM_Nod
);
741 Insert_After
(N
, AtM_Nod
);
742 Set_Mod_Clause
(N
, Empty
);
745 -- If the record representation clause has no components, then
746 -- completely remove it. Note that we also have to remove
747 -- ourself from the Rep Item list.
749 if Is_Empty_List
(Component_Clauses
(N
)) then
750 if First_Rep_Item
(Rectype
) = N
then
751 Set_First_Rep_Item
(Rectype
, Next_Rep_Item
(N
));
753 Repitem
:= First_Rep_Item
(Rectype
);
754 while Present
(Next_Rep_Item
(Repitem
)) loop
755 if Next_Rep_Item
(Repitem
) = N
then
756 Set_Next_Rep_Item
(Repitem
, Next_Rep_Item
(N
));
760 Next_Rep_Item
(Repitem
);
765 Make_Null_Statement
(Loc
));
767 end Expand_N_Record_Representation_Clause
;