2014-03-25 Richard Biener <rguenther@suse.de>
[official-gcc.git] / gcc / ada / exp_ch13.adb
blobc87132732a33389658ff0ba8970b7d0b45565d11
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-2013, 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 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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
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;
37 with Opt; use Opt;
38 with Restrict; use Restrict;
39 with Rident; use Rident;
40 with Rtsfind; use Rtsfind;
41 with Sem; use Sem;
42 with Sem_Aux; use Sem_Aux;
43 with Sem_Ch7; use Sem_Ch7;
44 with Sem_Ch8; use Sem_Ch8;
45 with Sem_Eval; use Sem_Eval;
46 with Sem_Util; use Sem_Util;
47 with Sinfo; use Sinfo;
48 with Snames; use Snames;
49 with Targparm; use Targparm;
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);
65 Ent : Entity_Id;
66 V : Node_Id;
68 begin
69 Ent := Entity (Name (N));
71 if Is_Type (Ent) then
72 Ent := Underlying_Type (Ent);
73 end if;
75 case Get_Attribute_Id (Chars (N)) is
77 -------------
78 -- Address --
79 -------------
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).
107 declare
108 Decl : constant Node_Id := Declaration_Node (Ent);
109 Typ : constant Entity_Id := Etype (Ent);
111 begin
112 if Nkind (Decl) = N_Object_Declaration
113 and then Present (Expression (Decl))
114 and then Nkind (Expression (Decl)) /= N_Null
115 and then
116 not Comes_From_Source (Original_Node (Expression (Decl)))
117 then
118 if Present (Base_Init_Proc (Typ))
119 and then
120 Present (Static_Initialization (Base_Init_Proc (Typ)))
121 then
122 null;
124 elsif Init_Or_Norm_Scalars
125 and then
126 (Is_Scalar_Type (Typ) or else Is_String_Type (Typ))
127 then
128 null;
130 else
131 Set_Expression (Decl, Empty);
132 end if;
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.
139 elsif Nkind (Decl) = N_Object_Declaration
140 and then not Needs_Constant_Address (Decl, Typ)
141 then
142 Remove_Side_Effects (Exp);
143 end if;
144 end;
146 ---------------
147 -- Alignment --
148 ---------------
150 when Attribute_Alignment =>
152 -- As required by Gigi, we guarantee that the operand is an
153 -- integer literal (this simplifies things in Gigi).
155 if Nkind (Exp) /= N_Integer_Literal then
156 Rewrite
157 (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
158 end if;
160 -- A complex case arises if the alignment clause applies to an
161 -- unconstrained object initialized with a function call. The
162 -- result of the call is placed on the secondary stack, and the
163 -- declaration is rewritten as a renaming of a dereference, which
164 -- fails expansion. We must introduce a temporary and assign its
165 -- value to the existing entity.
167 if Nkind (Parent (Ent)) = N_Object_Renaming_Declaration
168 and then not Is_Entity_Name (Renamed_Object (Ent))
169 then
170 declare
171 Loc : constant Source_Ptr := Sloc (N);
172 Decl : constant Node_Id := Parent (Ent);
173 Temp : constant Entity_Id := Make_Temporary (Loc, 'T');
174 New_Decl : Node_Id;
176 begin
177 -- Replace entity with temporary and reanalyze
179 Set_Defining_Identifier (Decl, Temp);
180 Set_Analyzed (Decl, False);
181 Analyze (Decl);
183 -- Introduce new declaration for entity but do not reanalyze
184 -- because entity is already in scope. Type and expression
185 -- are already resolved.
187 New_Decl :=
188 Make_Object_Declaration (Loc,
189 Defining_Identifier => Ent,
190 Object_Definition =>
191 New_Occurrence_Of (Etype (Ent), Loc),
192 Expression => New_Occurrence_Of (Temp, Loc));
194 Set_Renamed_Object (Ent, Empty);
195 Insert_After (Decl, New_Decl);
196 Set_Analyzed (Decl);
197 end;
198 end if;
200 ------------------
201 -- Storage_Size --
202 ------------------
204 when Attribute_Storage_Size =>
206 -- If the type is a task type, then assign the value of the
207 -- storage size to the Size variable associated with the task.
208 -- Insert the assignment right after the declaration of the Size
209 -- variable.
211 -- Generate:
213 -- task_typeZ := expression
215 if Ekind (Ent) = E_Task_Type then
216 declare
217 Assign : Node_Id;
219 begin
220 Assign :=
221 Make_Assignment_Statement (Loc,
222 Name =>
223 New_Occurrence_Of (Storage_Size_Variable (Ent), Loc),
224 Expression =>
225 Convert_To (RTE (RE_Size_Type), Expression (N)));
227 -- If the clause is not generated by an aspect, insert
228 -- the assignment here. Freezing rules ensure that this
229 -- is safe, or clause will have been rejected already.
231 if Is_List_Member (N) then
232 Insert_After (N, Assign);
234 -- Otherwise, insert assignment after task declaration.
236 else
237 Insert_After
238 (Parent (Storage_Size_Variable (Entity (N))), Assign);
239 end if;
241 Analyze (Assign);
242 end;
244 -- For Storage_Size for an access type, create a variable to hold
245 -- the value of the specified size with name typeV and expand an
246 -- assignment statement to initialize this value.
248 elsif Is_Access_Type (Ent) then
250 -- We don't need the variable for a storage size of zero
252 if not No_Pool_Assigned (Ent) then
253 V :=
254 Make_Defining_Identifier (Loc,
255 Chars => New_External_Name (Chars (Ent), 'V'));
257 -- Insert the declaration of the object
259 Insert_Action (N,
260 Make_Object_Declaration (Loc,
261 Defining_Identifier => V,
262 Object_Definition =>
263 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
264 Expression =>
265 Convert_To (RTE (RE_Storage_Offset), Expression (N))));
267 Set_Storage_Size_Variable (Ent, Entity_Id (V));
268 end if;
269 end if;
271 -- Other attributes require no expansion
273 when others =>
274 null;
276 end case;
277 end Expand_N_Attribute_Definition_Clause;
279 -----------------------------
280 -- Expand_N_Free_Statement --
281 -----------------------------
283 procedure Expand_N_Free_Statement (N : Node_Id) is
284 Expr : constant Node_Id := Expression (N);
285 Typ : Entity_Id;
287 begin
288 -- Certain run-time configurations and targets do not provide support
289 -- for controlled types.
291 if Restriction_Active (No_Finalization) then
292 return;
294 -- Do not create a specialized Deallocate since .NET/JVM compilers do
295 -- not support pools and address arithmetic.
297 elsif VM_Target /= No_VM then
298 return;
299 end if;
301 -- Use the base type to perform the check for finalization master
303 Typ := Etype (Expr);
305 if Ekind (Typ) = E_Access_Subtype then
306 Typ := Etype (Typ);
307 end if;
309 -- Handle private access types
311 if Is_Private_Type (Typ)
312 and then Present (Full_View (Typ))
313 then
314 Typ := Full_View (Typ);
315 end if;
317 -- Do not create a custom Deallocate when freeing an object with
318 -- suppressed finalization. In such cases the object is never attached
319 -- to a master, so it does not need to be detached. Use a regular free
320 -- statement instead.
322 if No (Finalization_Master (Typ)) then
323 return;
324 end if;
326 -- Use a temporary to store the result of a complex expression. Perform
327 -- the following transformation:
329 -- Free (Complex_Expression);
331 -- Temp : constant Type_Of_Expression := Complex_Expression;
332 -- Free (Temp);
334 if Nkind (Expr) /= N_Identifier then
335 declare
336 Expr_Typ : constant Entity_Id := Etype (Expr);
337 Loc : constant Source_Ptr := Sloc (N);
338 New_Expr : Node_Id;
339 Temp_Id : Entity_Id;
341 begin
342 Temp_Id := Make_Temporary (Loc, 'T');
343 Insert_Action (N,
344 Make_Object_Declaration (Loc,
345 Defining_Identifier => Temp_Id,
346 Object_Definition =>
347 New_Occurrence_Of (Expr_Typ, Loc),
348 Expression =>
349 Relocate_Node (Expr)));
351 New_Expr := New_Occurrence_Of (Temp_Id, Loc);
352 Set_Etype (New_Expr, Expr_Typ);
354 Set_Expression (N, New_Expr);
355 end;
356 end if;
358 -- Create a custom Deallocate for a controlled object. This routine
359 -- ensures that the hidden list header will be deallocated along with
360 -- the actual object.
362 Build_Allocate_Deallocate_Proc (N, Is_Allocate => False);
363 end Expand_N_Free_Statement;
365 ----------------------------
366 -- Expand_N_Freeze_Entity --
367 ----------------------------
369 procedure Expand_N_Freeze_Entity (N : Node_Id) is
370 E : constant Entity_Id := Entity (N);
371 E_Scope : Entity_Id;
372 In_Other_Scope : Boolean;
373 In_Outer_Scope : Boolean;
374 Decl : Node_Id;
375 Delete : Boolean := False;
377 begin
378 -- If there are delayed aspect specifications, we insert them just
379 -- before the freeze node. They are already analyzed so we don't need
380 -- to reanalyze them (they were analyzed before the type was frozen),
381 -- but we want them in the tree for the back end, and so that the
382 -- listing from sprint is clearer on where these occur logically.
384 if Has_Delayed_Aspects (E) then
385 declare
386 Aitem : Node_Id;
387 Ritem : Node_Id;
389 begin
390 -- Look for aspect specs for this entity
392 Ritem := First_Rep_Item (E);
393 while Present (Ritem) loop
394 if Nkind (Ritem) = N_Aspect_Specification
395 and then Entity (Ritem) = E
396 then
397 Aitem := Aspect_Rep_Item (Ritem);
399 -- Skip this for aspects (e.g. Current_Value) for which
400 -- there is no corresponding pragma or attribute.
402 if Present (Aitem) then
403 pragma Assert (Is_Delayed_Aspect (Aitem));
404 Insert_Before (N, Aitem);
405 end if;
406 end if;
408 Next_Rep_Item (Ritem);
409 end loop;
410 end;
411 end if;
413 -- Processing for objects with address clauses
415 if Is_Object (E) and then Present (Address_Clause (E)) then
416 Apply_Address_Clause_Check (E, N);
417 return;
419 -- Only other items requiring any front end action are types and
420 -- subprograms.
422 elsif not Is_Type (E) and then not Is_Subprogram (E) then
423 return;
424 end if;
426 -- Here E is a type or a subprogram
428 E_Scope := Scope (E);
430 -- This is an error protection against previous errors
432 if No (E_Scope) then
433 Check_Error_Detected;
434 return;
435 end if;
437 -- Remember that we are processing a freezing entity and its freezing
438 -- nodes. This flag (non-zero = set) is used to avoid the need of
439 -- climbing through the tree while processing the freezing actions (ie.
440 -- to avoid generating spurious warnings or to avoid killing constant
441 -- indications while processing the code associated with freezing
442 -- actions). We use a counter to deal with nesting.
444 Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
446 -- If we are freezing entities defined in protected types, they belong
447 -- in the enclosing scope, given that the original type has been
448 -- expanded away. The same is true for entities in task types, in
449 -- particular the parameter records of entries (Entities in bodies are
450 -- all frozen within the body). If we are in the task body, this is a
451 -- proper scope. If we are within a subprogram body, the proper scope
452 -- is the corresponding spec. This may happen for itypes generated in
453 -- the bodies of protected operations.
455 if Ekind (E_Scope) = E_Protected_Type
456 or else (Ekind (E_Scope) = E_Task_Type
457 and then not Has_Completion (E_Scope))
458 then
459 E_Scope := Scope (E_Scope);
461 elsif Ekind (E_Scope) = E_Subprogram_Body then
462 E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
463 end if;
465 -- If the scope of the entity is in open scopes, it is the current one
466 -- or an enclosing one, including a loop, a block, or a subprogram.
468 if In_Open_Scopes (E_Scope) then
469 In_Other_Scope := False;
470 In_Outer_Scope := E_Scope /= Current_Scope;
472 -- Otherwise it is a local package or a different compilation unit
474 else
475 In_Other_Scope := True;
476 In_Outer_Scope := False;
477 end if;
479 -- If the entity being frozen is defined in a scope that is not
480 -- currently on the scope stack, we must establish the proper
481 -- visibility before freezing the entity and related subprograms.
483 if In_Other_Scope then
484 Push_Scope (E_Scope);
486 -- Finalizers are little odd in terms of freezing. The spec of the
487 -- procedure appears in the declarations while the body appears in
488 -- the statement part of a single construct. Since the finalizer must
489 -- be called by the At_End handler of the construct, the spec is
490 -- manually frozen right after its declaration. The only side effect
491 -- of this action appears in contexts where the construct is not in
492 -- its final resting place. These contexts are:
494 -- * Entry bodies - The declarations and statements are moved to
495 -- the procedure equivalen of the entry.
496 -- * Protected subprograms - The declarations and statements are
497 -- moved to the non-protected version of the subprogram.
498 -- * Task bodies - The declarations and statements are moved to the
499 -- task body procedure.
501 -- Visible declarations do not need to be installed in these three
502 -- cases since it does not make semantic sense to do so. All entities
503 -- referenced by a finalizer are visible and already resolved, plus
504 -- the enclosing scope may not have visible declarations at all.
506 if Ekind (E) = E_Procedure
507 and then Is_Finalizer (E)
508 and then
509 (Is_Entry (E_Scope)
510 or else (Is_Subprogram (E_Scope)
511 and then Is_Protected_Type (Scope (E_Scope)))
512 or else Is_Task_Type (E_Scope))
513 then
514 null;
515 else
516 Install_Visible_Declarations (E_Scope);
517 end if;
519 if Is_Package_Or_Generic_Package (E_Scope) or else
520 Is_Protected_Type (E_Scope) or else
521 Is_Task_Type (E_Scope)
522 then
523 Install_Private_Declarations (E_Scope);
524 end if;
526 -- If the entity is in an outer scope, then that scope needs to
527 -- temporarily become the current scope so that operations created
528 -- during type freezing will be declared in the right scope and
529 -- can properly override any corresponding inherited operations.
531 elsif In_Outer_Scope then
532 Push_Scope (E_Scope);
533 end if;
535 -- If type, freeze the type
537 if Is_Type (E) then
538 Delete := Freeze_Type (N);
540 -- And for enumeration type, build the enumeration tables
542 if Is_Enumeration_Type (E) then
543 Build_Enumeration_Image_Tables (E, N);
544 end if;
546 -- If subprogram, freeze the subprogram
548 elsif Is_Subprogram (E) then
549 Freeze_Subprogram (N);
551 -- Ada 2005 (AI-251): Remove the freezing node associated with the
552 -- entities internally used by the frontend to register primitives
553 -- covering abstract interfaces. The call to Freeze_Subprogram has
554 -- already expanded the code that fills the corresponding entry in
555 -- its secondary dispatch table and therefore the code generator
556 -- has nothing else to do with this freezing node.
558 Delete := Present (Interface_Alias (E));
559 end if;
561 -- Analyze actions generated by freezing. The init_proc contains source
562 -- expressions that may raise Constraint_Error, and the assignment
563 -- procedure for complex types needs checks on individual component
564 -- assignments, but all other freezing actions should be compiled with
565 -- all checks off.
567 if Present (Actions (N)) then
568 Decl := First (Actions (N));
569 while Present (Decl) loop
570 if Nkind (Decl) = N_Subprogram_Body
571 and then (Is_Init_Proc (Defining_Entity (Decl))
572 or else
573 Chars (Defining_Entity (Decl)) = Name_uAssign)
574 then
575 Analyze (Decl);
577 -- A subprogram body created for a renaming_as_body completes
578 -- a previous declaration, which may be in a different scope.
579 -- Establish the proper scope before analysis.
581 elsif Nkind (Decl) = N_Subprogram_Body
582 and then Present (Corresponding_Spec (Decl))
583 and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
584 then
585 Push_Scope (Scope (Corresponding_Spec (Decl)));
586 Analyze (Decl, Suppress => All_Checks);
587 Pop_Scope;
589 -- We treat generated equality specially, if validity checks are
590 -- enabled, in order to detect components default-initialized
591 -- with invalid values.
593 elsif Nkind (Decl) = N_Subprogram_Body
594 and then Chars (Defining_Entity (Decl)) = Name_Op_Eq
595 and then Validity_Checks_On
596 and then Initialize_Scalars
597 then
598 declare
599 Save_Force : constant Boolean := Force_Validity_Checks;
600 begin
601 Force_Validity_Checks := True;
602 Analyze (Decl);
603 Force_Validity_Checks := Save_Force;
604 end;
606 -- All other freezing actions
608 else
609 Analyze (Decl, Suppress => All_Checks);
610 end if;
612 Next (Decl);
613 end loop;
614 end if;
616 -- If we are to delete this N_Freeze_Entity, do so by rewriting so that
617 -- a loop on all nodes being inserted will work propertly.
619 if Delete then
620 Rewrite (N, Make_Null_Statement (Sloc (N)));
621 end if;
623 -- Pop scope if we installed one for the analysis
625 if In_Other_Scope then
626 if Ekind (Current_Scope) = E_Package then
627 End_Package_Scope (E_Scope);
628 else
629 End_Scope;
630 end if;
632 elsif In_Outer_Scope then
633 Pop_Scope;
634 end if;
636 -- Restore previous value of the nesting-level counter that records
637 -- whether we are inside a (possibly nested) call to this procedure.
639 Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
640 end Expand_N_Freeze_Entity;
642 -------------------------------------------
643 -- Expand_N_Record_Representation_Clause --
644 -------------------------------------------
646 -- The only expansion required is for the case of a mod clause present,
647 -- which is removed, and translated into an alignment representation
648 -- clause inserted immediately after the record rep clause with any
649 -- initial pragmas inserted at the start of the component clause list.
651 procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
652 Loc : constant Source_Ptr := Sloc (N);
653 Rectype : constant Entity_Id := Entity (Identifier (N));
654 Mod_Val : Uint;
655 Citems : List_Id;
656 Repitem : Node_Id;
657 AtM_Nod : Node_Id;
659 begin
660 if Present (Mod_Clause (N)) and then not Ignore_Rep_Clauses then
661 Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
662 Citems := Pragmas_Before (Mod_Clause (N));
664 if Present (Citems) then
665 Append_List_To (Citems, Component_Clauses (N));
666 Set_Component_Clauses (N, Citems);
667 end if;
669 AtM_Nod :=
670 Make_Attribute_Definition_Clause (Loc,
671 Name => New_Occurrence_Of (Base_Type (Rectype), Loc),
672 Chars => Name_Alignment,
673 Expression => Make_Integer_Literal (Loc, Mod_Val));
675 Set_From_At_Mod (AtM_Nod);
676 Insert_After (N, AtM_Nod);
677 Set_Mod_Clause (N, Empty);
678 end if;
680 -- If the record representation clause has no components, then
681 -- completely remove it. Note that we also have to remove
682 -- ourself from the Rep Item list.
684 if Is_Empty_List (Component_Clauses (N)) then
685 if First_Rep_Item (Rectype) = N then
686 Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
687 else
688 Repitem := First_Rep_Item (Rectype);
689 while Present (Next_Rep_Item (Repitem)) loop
690 if Next_Rep_Item (Repitem) = N then
691 Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
692 exit;
693 end if;
695 Next_Rep_Item (Repitem);
696 end loop;
697 end if;
699 Rewrite (N,
700 Make_Null_Statement (Loc));
701 end if;
702 end Expand_N_Record_Representation_Clause;
704 end Exp_Ch13;