PR target/16201
[official-gcc.git] / gcc / ada / exp_ch13.adb
blob60a11478cb7dec65e1563008c55e10672f18f0f0
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ C H 1 3 --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
10 -- --
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. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
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;
38 with Sem; use Sem;
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);
66 Ent : Entity_Id;
67 V : Node_Id;
69 begin
70 Ent := Entity (Name (N));
72 if Is_Type (Ent) then
73 Ent := Underlying_Type (Ent);
74 end if;
76 case Get_Attribute_Id (Chars (N)) is
78 -------------
79 -- Address --
80 -------------
82 when Attribute_Address =>
84 -- If there is an initialization which did not come from
85 -- the source program, then it is an artifact of our
86 -- expansion, and we suppress it. The case we are most
87 -- concerned about here is the initialization of a packed
88 -- array to all false, which seems inappropriate for a
89 -- variable to which an address clause is applied. The
90 -- expression may itself have been rewritten if the type is a
91 -- packed array, so we need to examine whether the original
92 -- node is in the source.
94 declare
95 Decl : constant Node_Id := Declaration_Node (Ent);
96 begin
97 if Nkind (Decl) = N_Object_Declaration
98 and then Present (Expression (Decl))
99 and then
100 not Comes_From_Source (Original_Node (Expression (Decl)))
101 then
102 Set_Expression (Decl, Empty);
103 end if;
104 end;
106 ---------------
107 -- Alignment --
108 ---------------
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
116 Rewrite
117 (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
118 end if;
120 ------------------
121 -- Storage_Size --
122 ------------------
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
131 Insert_Action (N,
132 Make_Assignment_Statement (Loc,
133 Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
134 Expression =>
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'));
146 Insert_Action (N,
147 Make_Object_Declaration (Loc,
148 Defining_Identifier => V,
149 Object_Definition =>
150 New_Reference_To (RTE (RE_Storage_Offset), Loc),
151 Expression =>
152 Convert_To (RTE (RE_Storage_Offset), Expression (N))));
154 Set_Storage_Size_Variable (Ent, Entity_Id (V));
155 end if;
157 -- Other attributes require no expansion
159 when others =>
160 null;
162 end case;
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));
173 Old_Val : constant String_Id := Strval (Expr_Value_S (Expression (N)));
174 New_Val : String_Id;
175 E : Entity_Id;
177 begin
178 -- For the rep clause "for x'external_tag use y" generate:
180 -- xV : constant string := y;
181 -- Set_External_Tag (x'tag, xV'Address);
182 -- Register_Tag (x'tag);
184 -- note that register_tag has been delayed up to now because
185 -- the external_tag must be set before registering.
187 -- Create a new nul terminated string if it is not already
189 if String_Length (Old_Val) > 0
190 and then Get_String_Char (Old_Val, String_Length (Old_Val)) = 0
191 then
192 New_Val := Old_Val;
193 else
194 Start_String (Old_Val);
195 Store_String_Char (Get_Char_Code (ASCII.NUL));
196 New_Val := End_String;
197 end if;
199 E :=
200 Make_Defining_Identifier (Loc,
201 New_External_Name (Chars (Ent), 'A'));
203 -- The generated actions must be elaborated at the subsequent
204 -- freeze point, not at the point of the attribute definition.
206 Append_Freeze_Action (Ent,
207 Make_Object_Declaration (Loc,
208 Defining_Identifier => E,
209 Constant_Present => True,
210 Object_Definition =>
211 New_Reference_To (Standard_String, Loc),
212 Expression =>
213 Make_String_Literal (Loc, Strval => New_Val)));
215 Append_Freeze_Actions (Ent, New_List (
216 Make_Procedure_Call_Statement (Loc,
217 Name => New_Reference_To (RTE (RE_Set_External_Tag), Loc),
218 Parameter_Associations => New_List (
219 Make_Attribute_Reference (Loc,
220 Attribute_Name => Name_Tag,
221 Prefix => New_Occurrence_Of (Ent, Loc)),
223 Make_Attribute_Reference (Loc,
224 Attribute_Name => Name_Address,
225 Prefix => New_Occurrence_Of (E, Loc)))),
227 Make_Procedure_Call_Statement (Loc,
228 Name => New_Reference_To (RTE (RE_Register_Tag), Loc),
229 Parameter_Associations => New_List (
230 Make_Attribute_Reference (Loc,
231 Attribute_Name => Name_Tag,
232 Prefix => New_Occurrence_Of (Ent, Loc))))));
233 end Expand_External_Tag_Definition;
235 ----------------------------
236 -- Expand_N_Freeze_Entity --
237 ----------------------------
239 procedure Expand_N_Freeze_Entity (N : Node_Id) is
240 E : constant Entity_Id := Entity (N);
241 E_Scope : Entity_Id;
242 S : Entity_Id;
243 In_Other_Scope : Boolean;
244 In_Outer_Scope : Boolean;
245 Decl : Node_Id;
247 begin
248 -- For object, with address clause, check alignment is OK
250 if Is_Object (E) then
251 Apply_Alignment_Check (E, N);
253 -- Only other items requiring any front end action are
254 -- types and subprograms.
256 elsif not Is_Type (E) and then not Is_Subprogram (E) then
257 return;
258 end if;
260 -- Here E is a type or a subprogram
262 E_Scope := Scope (E);
264 -- This is an error protection against previous errors
266 if No (E_Scope) then
267 return;
268 end if;
270 -- If we are freezing entities defined in protected types, they
271 -- belong in the enclosing scope, given that the original type
272 -- has been expanded away. The same is true for entities in task types,
273 -- in particular the parameter records of entries (Entities in bodies
274 -- are all frozen within the body). If we are in the task body, this
275 -- is a proper scope.
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))
280 then
281 E_Scope := Scope (E_Scope);
282 end if;
284 S := Current_Scope;
285 while S /= Standard_Standard and then S /= E_Scope loop
286 S := Scope (S);
287 end 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
297 New_Scope (E_Scope);
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)
304 then
305 Install_Private_Declarations (E_Scope);
306 end if;
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
314 New_Scope (E_Scope);
315 end if;
317 -- If type, freeze the type
319 if Is_Type (E) then
320 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)
329 then
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.
335 declare
336 Def : constant Node_Id :=
337 Get_Attribute_Definition_Clause
338 (E, Attribute_External_Tag);
340 begin
341 if Present (Def) and then Entity (Name (Def)) = E then
342 Expand_External_Tag_Definition (Def);
343 end if;
344 end;
345 end if;
347 -- If subprogram, freeze the subprogram
349 elsif Is_Subprogram (E) then
350 Freeze_Subprogram (N);
351 end if;
353 -- Analyze actions generated by freezing. The init_proc contains
354 -- source expressions that may raise constraint_error, and the
355 -- assignment procedure for complex types needs checks on individual
356 -- component assignments, but all other freezing actions should be
357 -- compiled with all checks off.
359 if Present (Actions (N)) then
360 Decl := First (Actions (N));
362 while Present (Decl) loop
364 if Nkind (Decl) = N_Subprogram_Body
365 and then (Is_Init_Proc (Defining_Entity (Decl))
366 or else
367 Chars (Defining_Entity (Decl)) = Name_uAssign)
368 then
369 Analyze (Decl);
371 -- A subprogram body created for a renaming_as_body completes
372 -- a previous declaration, which may be in a different scope.
373 -- Establish the proper scope before analysis.
375 elsif Nkind (Decl) = N_Subprogram_Body
376 and then Present (Corresponding_Spec (Decl))
377 and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
378 then
379 New_Scope (Scope (Corresponding_Spec (Decl)));
380 Analyze (Decl, Suppress => All_Checks);
381 Pop_Scope;
383 else
384 Analyze (Decl, Suppress => All_Checks);
385 end if;
387 Next (Decl);
388 end loop;
389 end if;
391 if In_Other_Scope then
392 if Ekind (Current_Scope) = E_Package then
393 End_Package_Scope (E_Scope);
394 else
395 End_Scope;
396 end if;
398 elsif In_Outer_Scope then
399 Pop_Scope;
400 end if;
401 end Expand_N_Freeze_Entity;
403 -------------------------------------------
404 -- Expand_N_Record_Representation_Clause --
405 -------------------------------------------
407 -- The only expansion required is for the case of a mod clause present,
408 -- which is removed, and translated into an alignment representation
409 -- clause inserted immediately after the record rep clause with any
410 -- initial pragmas inserted at the start of the component clause list.
412 procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
413 Loc : constant Source_Ptr := Sloc (N);
414 Rectype : constant Entity_Id := Entity (Identifier (N));
415 Mod_Val : Uint;
416 Citems : List_Id;
417 Repitem : Node_Id;
418 AtM_Nod : Node_Id;
420 begin
421 if Present (Mod_Clause (N)) then
422 Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
423 Citems := Pragmas_Before (Mod_Clause (N));
425 if Present (Citems) then
426 Append_List_To (Citems, Component_Clauses (N));
427 Set_Component_Clauses (N, Citems);
428 end if;
430 AtM_Nod :=
431 Make_Attribute_Definition_Clause (Loc,
432 Name => New_Reference_To (Base_Type (Rectype), Loc),
433 Chars => Name_Alignment,
434 Expression => Make_Integer_Literal (Loc, Mod_Val));
436 Set_From_At_Mod (AtM_Nod);
437 Insert_After (N, AtM_Nod);
438 Set_Mod_Clause (N, Empty);
439 end if;
441 -- If the record representation clause has no components, then
442 -- completely remove it. Note that we also have to remove
443 -- ourself from the Rep Item list.
445 if Is_Empty_List (Component_Clauses (N)) then
446 if First_Rep_Item (Rectype) = N then
447 Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
448 else
449 Repitem := First_Rep_Item (Rectype);
450 while Present (Next_Rep_Item (Repitem)) loop
451 if Next_Rep_Item (Repitem) = N then
452 Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
453 exit;
454 end if;
456 Next_Rep_Item (Repitem);
457 end loop;
458 end if;
460 Rewrite (N,
461 Make_Null_Statement (Loc));
462 end if;
463 end Expand_N_Record_Representation_Clause;
465 end Exp_Ch13;