1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Einfo
; use Einfo
;
30 with Exp_Ch3
; use Exp_Ch3
;
31 with Exp_Ch6
; use Exp_Ch6
;
32 with Exp_Imgv
; use Exp_Imgv
;
33 with Exp_Tss
; use Exp_Tss
;
34 with Exp_Util
; use Exp_Util
;
35 with Nlists
; use Nlists
;
36 with Nmake
; use Nmake
;
37 with Rtsfind
; use Rtsfind
;
39 with Sem_Ch7
; use Sem_Ch7
;
40 with Sem_Ch8
; use Sem_Ch8
;
41 with Sem_Eval
; use Sem_Eval
;
42 with Sem_Util
; use Sem_Util
;
43 with Sinfo
; use Sinfo
;
44 with Snames
; use Snames
;
45 with Stand
; use Stand
;
46 with Stringt
; use Stringt
;
47 with Tbuild
; use Tbuild
;
48 with Uintp
; use Uintp
;
50 package body Exp_Ch13
is
52 procedure Expand_External_Tag_Definition
(N
: Node_Id
);
53 -- The code to assign and register an external tag must be elaborated
54 -- after the dispatch table has been created, so the expansion of the
55 -- attribute definition node is delayed until after the type is frozen.
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.
94 Decl
: constant Node_Id
:= Declaration_Node
(Ent
);
96 if Nkind
(Decl
) = N_Object_Declaration
97 and then Present
(Expression
(Decl
))
99 not Comes_From_Source
(Original_Node
(Expression
(Decl
)))
101 Set_Expression
(Decl
, Empty
);
109 when Attribute_Alignment
=>
111 -- As required by Gigi, we guarantee that the operand is an
112 -- integer literal (this simplifies things in Gigi).
114 if Nkind
(Exp
) /= N_Integer_Literal
then
116 (Exp
, Make_Integer_Literal
(Loc
, Expr_Value
(Exp
)));
123 when Attribute_Storage_Size
=>
125 -- If the type is a task type, then assign the value of the
126 -- storage size to the Size variable associated with the task.
127 -- task_typeZ := expression
129 if Ekind
(Ent
) = E_Task_Type
then
131 Make_Assignment_Statement
(Loc
,
132 Name
=> New_Reference_To
(Storage_Size_Variable
(Ent
), Loc
),
134 Convert_To
(RTE
(RE_Size_Type
), Expression
(N
))));
136 -- For Storage_Size for an access type, create a variable to hold
137 -- the value of the specified size with name typeV and expand an
138 -- assignment statement to initialze this value.
140 elsif Is_Access_Type
(Ent
) then
141 V
:= Make_Defining_Identifier
(Loc
,
142 New_External_Name
(Chars
(Ent
), 'V'));
145 Make_Object_Declaration
(Loc
,
146 Defining_Identifier
=> V
,
148 New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
),
150 Convert_To
(RTE
(RE_Storage_Offset
), Expression
(N
))));
152 Set_Storage_Size_Variable
(Ent
, Entity_Id
(V
));
155 -- Other attributes require no expansion
162 end Expand_N_Attribute_Definition_Clause
;
164 -------------------------------------
165 -- Expand_External_Tag_Definition --
166 -------------------------------------
168 procedure Expand_External_Tag_Definition
(N
: Node_Id
) is
169 Loc
: constant Source_Ptr
:= Sloc
(N
);
170 Ent
: constant Entity_Id
:= Entity
(Name
(N
));
171 Old_Val
: constant String_Id
:= Strval
(Expr_Value_S
(Expression
(N
)));
176 -- For the rep clause "for x'external_tag use y" generate:
178 -- xV : constant string := y;
179 -- Set_External_Tag (x'tag, xV'Address);
180 -- Register_Tag (x'tag);
182 -- note that register_tag has been delayed up to now because
183 -- the external_tag must be set before registering.
185 -- Create a new nul terminated string if it is not already
187 if String_Length
(Old_Val
) > 0
188 and then Get_String_Char
(Old_Val
, String_Length
(Old_Val
)) = 0
192 Start_String
(Old_Val
);
193 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
194 New_Val
:= End_String
;
198 Make_Defining_Identifier
(Loc
,
199 New_External_Name
(Chars
(Ent
), 'A'));
201 -- The generated actions must be elaborated at the subsequent
202 -- freeze point, not at the point of the attribute definition.
204 Append_Freeze_Action
(Ent
,
205 Make_Object_Declaration
(Loc
,
206 Defining_Identifier
=> E
,
207 Constant_Present
=> True,
209 New_Reference_To
(Standard_String
, Loc
),
211 Make_String_Literal
(Loc
, Strval
=> New_Val
)));
213 Append_Freeze_Actions
(Ent
, New_List
(
214 Make_Procedure_Call_Statement
(Loc
,
215 Name
=> New_Reference_To
(RTE
(RE_Set_External_Tag
), Loc
),
216 Parameter_Associations
=> New_List
(
217 Make_Attribute_Reference
(Loc
,
218 Attribute_Name
=> Name_Tag
,
219 Prefix
=> New_Occurrence_Of
(Ent
, Loc
)),
221 Make_Attribute_Reference
(Loc
,
222 Attribute_Name
=> Name_Address
,
223 Prefix
=> New_Occurrence_Of
(E
, Loc
)))),
225 Make_Procedure_Call_Statement
(Loc
,
226 Name
=> New_Reference_To
(RTE
(RE_Register_Tag
), Loc
),
227 Parameter_Associations
=> New_List
(
228 Make_Attribute_Reference
(Loc
,
229 Attribute_Name
=> Name_Tag
,
230 Prefix
=> New_Occurrence_Of
(Ent
, Loc
))))));
231 end Expand_External_Tag_Definition
;
233 ----------------------------
234 -- Expand_N_Freeze_Entity --
235 ----------------------------
237 procedure Expand_N_Freeze_Entity
(N
: Node_Id
) is
238 E
: constant Entity_Id
:= Entity
(N
);
241 In_Other_Scope
: Boolean;
242 In_Outer_Scope
: Boolean;
244 Delete
: Boolean := False;
247 -- Processing for objects with address clauses
249 if Is_Object
(E
) and then Present
(Address_Clause
(E
)) then
250 Apply_Address_Clause_Check
(E
, N
);
253 -- Only other items requiring any front end action are types and
256 elsif not Is_Type
(E
) and then not Is_Subprogram
(E
) then
260 -- Here E is a type or a subprogram
262 E_Scope
:= Scope
(E
);
264 -- This is an error protection against previous errors
270 -- If we are freezing entities defined in protected types, they belong
271 -- in the enclosing scope, given that the original type has been
272 -- expanded away. The same is true for entities in task types, in
273 -- particular the parameter records of entries (Entities in bodies are
274 -- all frozen within the body). If we are in the task body, this is a
277 if Ekind
(E_Scope
) = E_Protected_Type
278 or else (Ekind
(E_Scope
) = E_Task_Type
279 and then not Has_Completion
(E_Scope
))
281 E_Scope
:= Scope
(E_Scope
);
285 while S
/= Standard_Standard
and then S
/= E_Scope
loop
289 In_Other_Scope
:= not (S
= E_Scope
);
290 In_Outer_Scope
:= (not In_Other_Scope
) and then (S
/= Current_Scope
);
292 -- If the entity being frozen is defined in a scope that is not
293 -- currently on the scope stack, we must establish the proper
294 -- visibility before freezing the entity and related subprograms.
296 if In_Other_Scope
then
298 Install_Visible_Declarations
(E_Scope
);
300 if Ekind
(E_Scope
) = E_Package
or else
301 Ekind
(E_Scope
) = E_Generic_Package
or else
302 Is_Protected_Type
(E_Scope
) or else
303 Is_Task_Type
(E_Scope
)
305 Install_Private_Declarations
(E_Scope
);
308 -- If the entity is in an outer scope, then that scope needs to
309 -- temporarily become the current scope so that operations created
310 -- during type freezing will be declared in the right scope and
311 -- can properly override any corresponding inherited operations.
313 elsif In_Outer_Scope
then
317 -- If type, freeze the type
320 Delete
:= Freeze_Type
(N
);
322 -- And for enumeration type, build the enumeration tables
324 if Is_Enumeration_Type
(E
) then
325 Build_Enumeration_Image_Tables
(E
, N
);
327 elsif Is_Tagged_Type
(E
)
328 and then Is_First_Subtype
(E
)
330 -- Check for a definition of External_Tag, whose expansion must
331 -- be delayed until the dispatch table is built. The clause
332 -- is considered only if it applies to this specific tagged
333 -- type, as opposed to one of its ancestors.
336 Def
: constant Node_Id
:=
337 Get_Attribute_Definition_Clause
338 (E
, Attribute_External_Tag
);
341 if Present
(Def
) and then Entity
(Name
(Def
)) = E
then
342 Expand_External_Tag_Definition
(Def
);
347 -- If subprogram, freeze the subprogram
349 elsif Is_Subprogram
(E
) then
350 Freeze_Subprogram
(N
);
352 -- Ada 2005 (AI-251): Remove the freezing node associated with the
353 -- entities internally used by the frontend to register primitives
354 -- covering abstract interfaces. The call to Freeze_Subprogram has
355 -- already expanded the code that fills the corresponding entry in
356 -- its secondary dispatch table and therefore the code generator
357 -- has nothing else to do with this freezing node.
359 Delete
:= Present
(Abstract_Interface_Alias
(E
));
362 -- Analyze actions generated by freezing. The init_proc contains source
363 -- expressions that may raise Constraint_Error, and the assignment
364 -- procedure for complex types needs checks on individual component
365 -- assignments, but all other freezing actions should be compiled with
368 if Present
(Actions
(N
)) then
369 Decl
:= First
(Actions
(N
));
370 while Present
(Decl
) loop
371 if Nkind
(Decl
) = N_Subprogram_Body
372 and then (Is_Init_Proc
(Defining_Entity
(Decl
))
374 Chars
(Defining_Entity
(Decl
)) = Name_uAssign
)
378 -- A subprogram body created for a renaming_as_body completes
379 -- a previous declaration, which may be in a different scope.
380 -- Establish the proper scope before analysis.
382 elsif Nkind
(Decl
) = N_Subprogram_Body
383 and then Present
(Corresponding_Spec
(Decl
))
384 and then Scope
(Corresponding_Spec
(Decl
)) /= Current_Scope
386 New_Scope
(Scope
(Corresponding_Spec
(Decl
)));
387 Analyze
(Decl
, Suppress
=> All_Checks
);
391 Analyze
(Decl
, Suppress
=> All_Checks
);
398 -- If we are to delete this N_Freeze_Entity, do so by rewriting so that
399 -- a loop on all nodes being inserted will work propertly.
402 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
405 if In_Other_Scope
then
406 if Ekind
(Current_Scope
) = E_Package
then
407 End_Package_Scope
(E_Scope
);
412 elsif In_Outer_Scope
then
415 end Expand_N_Freeze_Entity
;
417 -------------------------------------------
418 -- Expand_N_Record_Representation_Clause --
419 -------------------------------------------
421 -- The only expansion required is for the case of a mod clause present,
422 -- which is removed, and translated into an alignment representation
423 -- clause inserted immediately after the record rep clause with any
424 -- initial pragmas inserted at the start of the component clause list.
426 procedure Expand_N_Record_Representation_Clause
(N
: Node_Id
) is
427 Loc
: constant Source_Ptr
:= Sloc
(N
);
428 Rectype
: constant Entity_Id
:= Entity
(Identifier
(N
));
435 if Present
(Mod_Clause
(N
)) then
436 Mod_Val
:= Expr_Value
(Expression
(Mod_Clause
(N
)));
437 Citems
:= Pragmas_Before
(Mod_Clause
(N
));
439 if Present
(Citems
) then
440 Append_List_To
(Citems
, Component_Clauses
(N
));
441 Set_Component_Clauses
(N
, Citems
);
445 Make_Attribute_Definition_Clause
(Loc
,
446 Name
=> New_Reference_To
(Base_Type
(Rectype
), Loc
),
447 Chars
=> Name_Alignment
,
448 Expression
=> Make_Integer_Literal
(Loc
, Mod_Val
));
450 Set_From_At_Mod
(AtM_Nod
);
451 Insert_After
(N
, AtM_Nod
);
452 Set_Mod_Clause
(N
, Empty
);
455 -- If the record representation clause has no components, then
456 -- completely remove it. Note that we also have to remove
457 -- ourself from the Rep Item list.
459 if Is_Empty_List
(Component_Clauses
(N
)) then
460 if First_Rep_Item
(Rectype
) = N
then
461 Set_First_Rep_Item
(Rectype
, Next_Rep_Item
(N
));
463 Repitem
:= First_Rep_Item
(Rectype
);
464 while Present
(Next_Rep_Item
(Repitem
)) loop
465 if Next_Rep_Item
(Repitem
) = N
then
466 Set_Next_Rep_Item
(Repitem
, Next_Rep_Item
(N
));
470 Next_Rep_Item
(Repitem
);
475 Make_Null_Statement
(Loc
));
477 end Expand_N_Record_Representation_Clause
;