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 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 Rtsfind
; use Rtsfind
;
40 with Sem_Ch7
; use Sem_Ch7
;
41 with Sem_Ch8
; use Sem_Ch8
;
42 with Sem_Eval
; use Sem_Eval
;
43 with Sem_Util
; use Sem_Util
;
44 with Sinfo
; use Sinfo
;
45 with Snames
; use Snames
;
46 with Stand
; use Stand
;
47 with Tbuild
; use Tbuild
;
48 with Uintp
; use Uintp
;
49 with Validsw
; use Validsw
;
51 package body Exp_Ch13
is
53 ------------------------------------------
54 -- Expand_N_Attribute_Definition_Clause --
55 ------------------------------------------
57 -- Expansion action depends on attribute involved
59 procedure Expand_N_Attribute_Definition_Clause
(N
: Node_Id
) is
60 Loc
: constant Source_Ptr
:= Sloc
(N
);
61 Exp
: constant Node_Id
:= Expression
(N
);
66 Ent
:= Entity
(Name
(N
));
69 Ent
:= Underlying_Type
(Ent
);
72 case Get_Attribute_Id
(Chars
(N
)) is
78 when Attribute_Address
=>
80 -- If there is an initialization which did not come from the
81 -- source program, then it is an artifact of our expansion, and we
82 -- suppress it. The case we are most concerned about here is the
83 -- initialization of a packed array to all false, which seems
84 -- inappropriate for variable to which an address clause is
85 -- applied. The expression may itself have been rewritten if the
86 -- type is packed array, so we need to examine whether the
87 -- original node is in the source. An exception though is the case
88 -- of an access variable which is default initialized to null, and
89 -- such initialization is retained.
91 -- Furthermore, if the initialization is the equivalent aggregate
92 -- of the type initialization procedure, it replaces an implicit
93 -- call to the init proc, and must be respected. Note that for
94 -- packed types we do not build equivalent aggregates.
96 -- Also, if Init_Or_Norm_Scalars applies, then we need to retain
97 -- any default initialization for objects of scalar types and
98 -- types with scalar components. Normally a composite type will
99 -- have an init_proc in the presence of Init_Or_Norm_Scalars,
100 -- so when that flag is set we have just have to do a test for
101 -- scalar and string types (the predefined string types such as
102 -- String and Wide_String don't have an init_proc).
105 Decl
: constant Node_Id
:= Declaration_Node
(Ent
);
106 Typ
: constant Entity_Id
:= Etype
(Ent
);
109 if Nkind
(Decl
) = N_Object_Declaration
110 and then Present
(Expression
(Decl
))
111 and then Nkind
(Expression
(Decl
)) /= N_Null
113 not Comes_From_Source
(Original_Node
(Expression
(Decl
)))
115 if Present
(Base_Init_Proc
(Typ
))
117 Present
(Static_Initialization
(Base_Init_Proc
(Typ
)))
121 elsif Init_Or_Norm_Scalars
123 (Is_Scalar_Type
(Typ
) or else Is_String_Type
(Typ
))
128 Set_Expression
(Decl
, Empty
);
131 -- An object declaration to which an address clause applies
132 -- has a delayed freeze, but the address expression itself
133 -- must be elaborated at the point it appears. If the object
134 -- is controlled, additional checks apply elsewhere.
136 elsif Nkind
(Decl
) = N_Object_Declaration
137 and then not Needs_Constant_Address
(Decl
, Typ
)
139 Remove_Side_Effects
(Exp
);
147 when Attribute_Alignment
=>
149 -- As required by Gigi, we guarantee that the operand is an
150 -- integer literal (this simplifies things in Gigi).
152 if Nkind
(Exp
) /= N_Integer_Literal
then
154 (Exp
, Make_Integer_Literal
(Loc
, Expr_Value
(Exp
)));
161 when Attribute_Storage_Size
=>
163 -- If the type is a task type, then assign the value of the
164 -- storage size to the Size variable associated with the task.
165 -- task_typeZ := expression
167 if Ekind
(Ent
) = E_Task_Type
then
169 Make_Assignment_Statement
(Loc
,
170 Name
=> New_Reference_To
(Storage_Size_Variable
(Ent
), Loc
),
172 Convert_To
(RTE
(RE_Size_Type
), Expression
(N
))));
174 -- For Storage_Size for an access type, create a variable to hold
175 -- the value of the specified size with name typeV and expand an
176 -- assignment statement to initialize this value.
178 elsif Is_Access_Type
(Ent
) then
180 -- We don't need the variable for a storage size of zero
182 if not No_Pool_Assigned
(Ent
) then
184 Make_Defining_Identifier
(Loc
,
185 Chars
=> New_External_Name
(Chars
(Ent
), 'V'));
187 -- Insert the declaration of the object
190 Make_Object_Declaration
(Loc
,
191 Defining_Identifier
=> V
,
193 New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
),
195 Convert_To
(RTE
(RE_Storage_Offset
), Expression
(N
))));
197 Set_Storage_Size_Variable
(Ent
, Entity_Id
(V
));
201 -- Other attributes require no expansion
207 end Expand_N_Attribute_Definition_Clause
;
209 ----------------------------
210 -- Expand_N_Freeze_Entity --
211 ----------------------------
213 procedure Expand_N_Freeze_Entity
(N
: Node_Id
) is
214 E
: constant Entity_Id
:= Entity
(N
);
217 In_Other_Scope
: Boolean;
218 In_Outer_Scope
: Boolean;
220 Delete
: Boolean := False;
223 -- If there are delayed aspect specifications, we insert them just
224 -- before the freeze node. They are already analyzed so we don't need
225 -- to reanalyze them (they were analyzed before the type was frozen),
226 -- but we want them in the tree for the back end, and so that the
227 -- listing from sprint is clearer on where these occur logically.
229 if Has_Delayed_Aspects
(E
) then
235 Ritem
:= First_Rep_Item
(E
);
236 while Present
(Ritem
) loop
237 if Nkind
(Ritem
) = N_Aspect_Specification
then
238 Aitem
:= Aspect_Rep_Item
(Ritem
);
239 pragma Assert
(Is_Delayed_Aspect
(Aitem
));
240 Insert_Before
(N
, Aitem
);
243 Next_Rep_Item
(Ritem
);
248 -- Processing for objects with address clauses
250 if Is_Object
(E
) and then Present
(Address_Clause
(E
)) then
251 Apply_Address_Clause_Check
(E
, N
);
254 -- Only other items requiring any front end action are types and
257 elsif not Is_Type
(E
) and then not Is_Subprogram
(E
) then
261 -- Here E is a type or a subprogram
263 E_Scope
:= Scope
(E
);
265 -- This is an error protection against previous errors
271 -- Remember that we are processing a freezing entity and its freezing
272 -- nodes. This flag (non-zero = set) is used to avoid the need of
273 -- climbing through the tree while processing the freezing actions (ie.
274 -- to avoid generating spurious warnings or to avoid killing constant
275 -- indications while processing the code associated with freezing
276 -- actions). We use a counter to deal with nesting.
278 Inside_Freezing_Actions
:= Inside_Freezing_Actions
+ 1;
280 -- If we are freezing entities defined in protected types, they belong
281 -- in the enclosing scope, given that the original type has been
282 -- expanded away. The same is true for entities in task types, in
283 -- particular the parameter records of entries (Entities in bodies are
284 -- all frozen within the body). If we are in the task body, this is a
285 -- proper scope. If we are within a subprogram body, the proper scope
286 -- is the corresponding spec. This may happen for itypes generated in
287 -- the bodies of protected operations.
289 if Ekind
(E_Scope
) = E_Protected_Type
290 or else (Ekind
(E_Scope
) = E_Task_Type
291 and then not Has_Completion
(E_Scope
))
293 E_Scope
:= Scope
(E_Scope
);
295 elsif Ekind
(E_Scope
) = E_Subprogram_Body
then
296 E_Scope
:= Corresponding_Spec
(Unit_Declaration_Node
(E_Scope
));
300 while S
/= Standard_Standard
and then S
/= E_Scope
loop
304 In_Other_Scope
:= not (S
= E_Scope
);
305 In_Outer_Scope
:= (not In_Other_Scope
) and then (S
/= Current_Scope
);
307 -- If the entity being frozen is defined in a scope that is not
308 -- currently on the scope stack, we must establish the proper
309 -- visibility before freezing the entity and related subprograms.
311 if In_Other_Scope
then
312 Push_Scope
(E_Scope
);
313 Install_Visible_Declarations
(E_Scope
);
315 if Is_Package_Or_Generic_Package
(E_Scope
) or else
316 Is_Protected_Type
(E_Scope
) or else
317 Is_Task_Type
(E_Scope
)
319 Install_Private_Declarations
(E_Scope
);
322 -- If the entity is in an outer scope, then that scope needs to
323 -- temporarily become the current scope so that operations created
324 -- during type freezing will be declared in the right scope and
325 -- can properly override any corresponding inherited operations.
327 elsif In_Outer_Scope
then
328 Push_Scope
(E_Scope
);
331 -- If type, freeze the type
334 Delete
:= Freeze_Type
(N
);
336 -- And for enumeration type, build the enumeration tables
338 if Is_Enumeration_Type
(E
) then
339 Build_Enumeration_Image_Tables
(E
, N
);
342 -- If subprogram, freeze the subprogram
344 elsif Is_Subprogram
(E
) then
345 Freeze_Subprogram
(N
);
347 -- Ada 2005 (AI-251): Remove the freezing node associated with the
348 -- entities internally used by the frontend to register primitives
349 -- covering abstract interfaces. The call to Freeze_Subprogram has
350 -- already expanded the code that fills the corresponding entry in
351 -- its secondary dispatch table and therefore the code generator
352 -- has nothing else to do with this freezing node.
354 Delete
:= Present
(Interface_Alias
(E
));
357 -- Analyze actions generated by freezing. The init_proc contains source
358 -- expressions that may raise Constraint_Error, and the assignment
359 -- procedure for complex types needs checks on individual component
360 -- assignments, but all other freezing actions should be compiled with
363 if Present
(Actions
(N
)) then
364 Decl
:= First
(Actions
(N
));
365 while Present
(Decl
) loop
366 if Nkind
(Decl
) = N_Subprogram_Body
367 and then (Is_Init_Proc
(Defining_Entity
(Decl
))
369 Chars
(Defining_Entity
(Decl
)) = Name_uAssign
)
373 -- A subprogram body created for a renaming_as_body completes
374 -- a previous declaration, which may be in a different scope.
375 -- Establish the proper scope before analysis.
377 elsif Nkind
(Decl
) = N_Subprogram_Body
378 and then Present
(Corresponding_Spec
(Decl
))
379 and then Scope
(Corresponding_Spec
(Decl
)) /= Current_Scope
381 Push_Scope
(Scope
(Corresponding_Spec
(Decl
)));
382 Analyze
(Decl
, Suppress
=> All_Checks
);
385 -- We treat generated equality specially, if validity checks are
386 -- enabled, in order to detect components default-initialized
387 -- with invalid values.
389 elsif Nkind
(Decl
) = N_Subprogram_Body
390 and then Chars
(Defining_Entity
(Decl
)) = Name_Op_Eq
391 and then Validity_Checks_On
392 and then Initialize_Scalars
395 Save_Force
: constant Boolean := Force_Validity_Checks
;
397 Force_Validity_Checks
:= True;
399 Force_Validity_Checks
:= Save_Force
;
403 Analyze
(Decl
, Suppress
=> All_Checks
);
410 -- If we are to delete this N_Freeze_Entity, do so by rewriting so that
411 -- a loop on all nodes being inserted will work propertly.
414 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
417 -- Pop scope if we installed one for the analysis
419 if In_Other_Scope
then
420 if Ekind
(Current_Scope
) = E_Package
then
421 End_Package_Scope
(E_Scope
);
426 elsif In_Outer_Scope
then
430 -- Restore previous value of the nesting-level counter that records
431 -- whether we are inside a (possibly nested) call to this procedure.
433 Inside_Freezing_Actions
:= Inside_Freezing_Actions
- 1;
434 end Expand_N_Freeze_Entity
;
436 -------------------------------------------
437 -- Expand_N_Record_Representation_Clause --
438 -------------------------------------------
440 -- The only expansion required is for the case of a mod clause present,
441 -- which is removed, and translated into an alignment representation
442 -- clause inserted immediately after the record rep clause with any
443 -- initial pragmas inserted at the start of the component clause list.
445 procedure Expand_N_Record_Representation_Clause
(N
: Node_Id
) is
446 Loc
: constant Source_Ptr
:= Sloc
(N
);
447 Rectype
: constant Entity_Id
:= Entity
(Identifier
(N
));
454 if Present
(Mod_Clause
(N
)) and then not Ignore_Rep_Clauses
then
455 Mod_Val
:= Expr_Value
(Expression
(Mod_Clause
(N
)));
456 Citems
:= Pragmas_Before
(Mod_Clause
(N
));
458 if Present
(Citems
) then
459 Append_List_To
(Citems
, Component_Clauses
(N
));
460 Set_Component_Clauses
(N
, Citems
);
464 Make_Attribute_Definition_Clause
(Loc
,
465 Name
=> New_Reference_To
(Base_Type
(Rectype
), Loc
),
466 Chars
=> Name_Alignment
,
467 Expression
=> Make_Integer_Literal
(Loc
, Mod_Val
));
469 Set_From_At_Mod
(AtM_Nod
);
470 Insert_After
(N
, AtM_Nod
);
471 Set_Mod_Clause
(N
, Empty
);
474 -- If the record representation clause has no components, then
475 -- completely remove it. Note that we also have to remove
476 -- ourself from the Rep Item list.
478 if Is_Empty_List
(Component_Clauses
(N
)) then
479 if First_Rep_Item
(Rectype
) = N
then
480 Set_First_Rep_Item
(Rectype
, Next_Rep_Item
(N
));
482 Repitem
:= First_Rep_Item
(Rectype
);
483 while Present
(Next_Rep_Item
(Repitem
)) loop
484 if Next_Rep_Item
(Repitem
) = N
then
485 Set_Next_Rep_Item
(Repitem
, Next_Rep_Item
(N
));
489 Next_Rep_Item
(Repitem
);
494 Make_Null_Statement
(Loc
));
496 end Expand_N_Record_Representation_Clause
;