1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002, 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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_Util
; use Exp_Util
;
34 with Nlists
; use Nlists
;
35 with Nmake
; use Nmake
;
36 with Rtsfind
; use Rtsfind
;
38 with Sem_Ch7
; use Sem_Ch7
;
39 with Sem_Ch8
; use Sem_Ch8
;
40 with Sem_Eval
; use Sem_Eval
;
41 with Sem_Util
; use Sem_Util
;
42 with Sinfo
; use Sinfo
;
43 with Snames
; use Snames
;
44 with Stand
; use Stand
;
45 with Stringt
; use Stringt
;
46 with Tbuild
; use Tbuild
;
47 with Uintp
; use Uintp
;
49 package body Exp_Ch13
is
51 procedure Expand_External_Tag_Definition
(N
: Node_Id
);
52 -- The code to assign and register an external tag must be elaborated
53 -- after the dispatch table has been created, so the expansion of the
54 -- attribute definition node is delayed until after the type is frozen.
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
84 -- the source program, then it is an artifact of our
85 -- expansion, and we suppress it. The case we are most
86 -- concerned about here is the initialization of a packed
87 -- array to all false, which seems inappropriate for a
88 -- variable to which an address clause is applied. The
89 -- expression may itself have been rewritten if the type is a
90 -- packed array, so we need to examine whether the original
91 -- node is in the source.
94 Decl
: constant Node_Id
:= Declaration_Node
(Ent
);
97 if Nkind
(Decl
) = N_Object_Declaration
98 and then Present
(Expression
(Decl
))
100 not Comes_From_Source
(Original_Node
(Expression
(Decl
)))
102 Set_Expression
(Decl
, Empty
);
110 when Attribute_Alignment
=>
112 -- As required by Gigi, we guarantee that the operand is an
113 -- integer literal (this simplifies things in Gigi).
115 if Nkind
(Exp
) /= N_Integer_Literal
then
117 (Exp
, Make_Integer_Literal
(Loc
, Expr_Value
(Exp
)));
124 when Attribute_Storage_Size
=>
126 -- If the type is a task type, then assign the value of the
127 -- storage size to the Size variable associated with the task.
128 -- task_typeZ := expression
130 if Ekind
(Ent
) = E_Task_Type
then
132 Make_Assignment_Statement
(Loc
,
133 Name
=> New_Reference_To
(Storage_Size_Variable
(Ent
), Loc
),
135 Convert_To
(RTE
(RE_Size_Type
), Expression
(N
))));
137 -- For Storage_Size for an access type, create a variable to hold
138 -- the value of the specified size with name typeV and expand an
139 -- assignment statement to initialze this value.
141 elsif Is_Access_Type
(Ent
) then
143 V
:= Make_Defining_Identifier
(Loc
,
144 New_External_Name
(Chars
(Ent
), 'V'));
147 Make_Object_Declaration
(Loc
,
148 Defining_Identifier
=> V
,
150 New_Reference_To
(RTE
(RE_Storage_Offset
), Loc
),
152 Convert_To
(RTE
(RE_Storage_Offset
), Expression
(N
))));
154 Set_Storage_Size_Variable
(Ent
, Entity_Id
(V
));
157 -- Other attributes require no expansion
164 end Expand_N_Attribute_Definition_Clause
;
166 -------------------------------------
167 -- Expand_External_Tag_Definition --
168 -------------------------------------
170 procedure Expand_External_Tag_Definition
(N
: Node_Id
) is
171 Loc
: constant Source_Ptr
:= Sloc
(N
);
172 Ent
: constant Entity_Id
:= Entity
(Name
(N
));
174 Old_Val
: String_Id
:= Strval
(Expr_Value_S
(Expression
(N
)));
179 -- For the rep clause "for x'external_tag use y" generate:
181 -- xV : constant string := y;
182 -- Set_External_Tag (x'tag, xV'Address);
183 -- Register_Tag (x'tag);
185 -- note that register_tag has been delayed up to now because
186 -- the external_tag must be set before registering.
188 -- Create a new nul terminated string if it is not already
190 if String_Length
(Old_Val
) > 0
191 and then Get_String_Char
(Old_Val
, String_Length
(Old_Val
)) = 0
195 Start_String
(Old_Val
);
196 Store_String_Char
(Get_Char_Code
(ASCII
.NUL
));
197 New_Val
:= End_String
;
201 Make_Defining_Identifier
(Loc
,
202 New_External_Name
(Chars
(Ent
), 'A'));
204 -- The generated actions must be elaborated at the subsequent
205 -- freeze point, not at the point of the attribute definition.
207 Append_Freeze_Action
(Ent
,
208 Make_Object_Declaration
(Loc
,
209 Defining_Identifier
=> E
,
210 Constant_Present
=> True,
212 New_Reference_To
(Standard_String
, Loc
),
214 Make_String_Literal
(Loc
, Strval
=> New_Val
)));
216 Append_Freeze_Actions
(Ent
, New_List
(
217 Make_Procedure_Call_Statement
(Loc
,
218 Name
=> New_Reference_To
(RTE
(RE_Set_External_Tag
), Loc
),
219 Parameter_Associations
=> New_List
(
220 Make_Attribute_Reference
(Loc
,
221 Attribute_Name
=> Name_Tag
,
222 Prefix
=> New_Occurrence_Of
(Ent
, Loc
)),
224 Make_Attribute_Reference
(Loc
,
225 Attribute_Name
=> Name_Address
,
226 Prefix
=> New_Occurrence_Of
(E
, Loc
)))),
228 Make_Procedure_Call_Statement
(Loc
,
229 Name
=> New_Reference_To
(RTE
(RE_Register_Tag
), Loc
),
230 Parameter_Associations
=> New_List
(
231 Make_Attribute_Reference
(Loc
,
232 Attribute_Name
=> Name_Tag
,
233 Prefix
=> New_Occurrence_Of
(Ent
, Loc
))))));
234 end Expand_External_Tag_Definition
;
236 ----------------------------
237 -- Expand_N_Freeze_Entity --
238 ----------------------------
240 procedure Expand_N_Freeze_Entity
(N
: Node_Id
) is
241 E
: constant Entity_Id
:= Entity
(N
);
244 In_Other_Scope
: Boolean;
245 In_Outer_Scope
: Boolean;
249 -- For object, with address clause, check alignment is OK
251 if Is_Object
(E
) then
252 Apply_Alignment_Check
(E
, N
);
254 -- Only other items requiring any front end action are
255 -- types and subprograms.
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 -- If we are freezing entities defined in protected types, they
266 -- belong in the enclosing scope, given that the original type
267 -- has been expanded away. The same is true for entities in task types,
268 -- in particular the parameter records of entries (Entities in bodies
269 -- are all frozen within the body). If we are in the task body, this
270 -- is a proper scope.
272 if Ekind
(E_Scope
) = E_Protected_Type
273 or else (Ekind
(E_Scope
) = E_Task_Type
274 and then not Has_Completion
(E_Scope
))
276 E_Scope
:= Scope
(E_Scope
);
280 while S
/= Standard_Standard
and then S
/= E_Scope
loop
284 In_Other_Scope
:= not (S
= E_Scope
);
285 In_Outer_Scope
:= (not In_Other_Scope
) and then (S
/= Current_Scope
);
287 -- If the entity being frozen is defined in a scope that is not
288 -- currently on the scope stack, we must establish the proper
289 -- visibility before freezing the entity and related subprograms.
291 if In_Other_Scope
then
293 Install_Visible_Declarations
(E_Scope
);
295 if Ekind
(E_Scope
) = E_Package
or else
296 Ekind
(E_Scope
) = E_Generic_Package
or else
297 Is_Protected_Type
(E_Scope
) or else
298 Is_Task_Type
(E_Scope
)
300 Install_Private_Declarations
(E_Scope
);
303 -- If the entity is in an outer scope, then that scope needs to
304 -- temporarily become the current scope so that operations created
305 -- during type freezing will be declared in the right scope and
306 -- can properly override any corresponding inherited operations.
308 elsif In_Outer_Scope
then
312 -- If type, freeze the type
317 -- And for enumeration type, build the enumeration tables
319 if Is_Enumeration_Type
(E
) then
320 Build_Enumeration_Image_Tables
(E
, N
);
322 elsif Is_Tagged_Type
(E
)
323 and then Is_First_Subtype
(E
)
326 -- Check for a definition of External_Tag, whose expansion must
327 -- be delayed until the dispatch table is built.
331 Get_Attribute_Definition_Clause
(E
, Attribute_External_Tag
);
333 if Present
(Def
) then
334 Expand_External_Tag_Definition
(Def
);
339 -- If subprogram, freeze the subprogram
341 elsif Is_Subprogram
(E
) then
342 Freeze_Subprogram
(N
);
345 -- Analyze actions generated by freezing. The init_proc contains
346 -- source expressions that may raise constraint_error, and the
347 -- assignment procedure for complex types needs checks on individual
348 -- component assignments, but all other freezing actions should be
349 -- compiled with all checks off.
351 if Present
(Actions
(N
)) then
352 Decl
:= First
(Actions
(N
));
354 while Present
(Decl
) loop
356 if Nkind
(Decl
) = N_Subprogram_Body
357 and then (Chars
(Defining_Entity
(Decl
)) = Name_uInit_Proc
358 or else Chars
(Defining_Entity
(Decl
)) = Name_uAssign
)
362 -- A subprogram body created for a renaming_as_body completes
363 -- a previous declaration, which may be in a different scope.
364 -- Establish the proper scope before analysis.
366 elsif Nkind
(Decl
) = N_Subprogram_Body
367 and then Present
(Corresponding_Spec
(Decl
))
368 and then Scope
(Corresponding_Spec
(Decl
)) /= Current_Scope
370 New_Scope
(Scope
(Corresponding_Spec
(Decl
)));
371 Analyze
(Decl
, Suppress
=> All_Checks
);
375 Analyze
(Decl
, Suppress
=> All_Checks
);
382 if In_Other_Scope
then
383 if Ekind
(Current_Scope
) = E_Package
then
384 End_Package_Scope
(E_Scope
);
389 elsif In_Outer_Scope
then
392 end Expand_N_Freeze_Entity
;
394 -------------------------------------------
395 -- Expand_N_Record_Representation_Clause --
396 -------------------------------------------
398 -- The only expansion required is for the case of a mod clause present,
399 -- which is removed, and translated into an alignment representation
400 -- clause inserted immediately after the record rep clause with any
401 -- initial pragmas inserted at the start of the component clause list.
403 procedure Expand_N_Record_Representation_Clause
(N
: Node_Id
) is
404 Loc
: constant Source_Ptr
:= Sloc
(N
);
405 Rectype
: constant Entity_Id
:= Entity
(Identifier
(N
));
412 if Present
(Mod_Clause
(N
)) then
413 Mod_Val
:= Expr_Value
(Expression
(Mod_Clause
(N
)));
414 Citems
:= Pragmas_Before
(Mod_Clause
(N
));
416 if Present
(Citems
) then
417 Append_List_To
(Citems
, Component_Clauses
(N
));
418 Set_Component_Clauses
(N
, Citems
);
422 Make_Attribute_Definition_Clause
(Loc
,
423 Name
=> New_Reference_To
(Base_Type
(Rectype
), Loc
),
424 Chars
=> Name_Alignment
,
425 Expression
=> Make_Integer_Literal
(Loc
, Mod_Val
));
427 Set_From_At_Mod
(AtM_Nod
);
428 Insert_After
(N
, AtM_Nod
);
429 Set_Mod_Clause
(N
, Empty
);
432 -- If the record representation clause has no components, then
433 -- completely remove it. Note that we also have to remove
434 -- ourself from the Rep Item list.
436 if Is_Empty_List
(Component_Clauses
(N
)) then
437 if First_Rep_Item
(Rectype
) = N
then
438 Set_First_Rep_Item
(Rectype
, Next_Rep_Item
(N
));
440 Repitem
:= First_Rep_Item
(Rectype
);
441 while Present
(Next_Rep_Item
(Repitem
)) loop
442 if Next_Rep_Item
(Repitem
) = N
then
443 Set_Next_Rep_Item
(Repitem
, Next_Rep_Item
(N
));
447 Next_Rep_Item
(Repitem
);
452 Make_Null_Statement
(Loc
));
454 end Expand_N_Record_Representation_Clause
;