1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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 Restrict; use Restrict;
39 with Rident; use Rident;
40 with Rtsfind; use Rtsfind;
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);
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 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).
108 Decl : constant Node_Id := Declaration_Node (Ent);
109 Typ : constant Entity_Id := Etype (Ent);
112 if Nkind (Decl) = N_Object_Declaration
113 and then Present (Expression (Decl))
114 and then Nkind (Expression (Decl)) /= N_Null
116 not Comes_From_Source (Original_Node (Expression (Decl)))
118 if Present (Base_Init_Proc (Typ))
120 Present (Static_Initialization (Base_Init_Proc (Typ)))
124 elsif Init_Or_Norm_Scalars
126 (Is_Scalar_Type (Typ) or else Is_String_Type (Typ))
131 Set_Expression (Decl, Empty);
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)
142 Remove_Side_Effects (Exp);
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
157 (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
164 when Attribute_Storage_Size =>
166 -- If the type is a task type, then assign the value of the
167 -- storage size to the Size variable associated with the task.
168 -- task_typeZ := expression
170 if Ekind (Ent) = E_Task_Type then
172 Make_Assignment_Statement (Loc,
173 Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
175 Convert_To (RTE (RE_Size_Type), Expression (N))));
177 -- For Storage_Size for an access type, create a variable to hold
178 -- the value of the specified size with name typeV and expand an
179 -- assignment statement to initialize this value.
181 elsif Is_Access_Type (Ent) then
183 -- We don't need the variable for a storage size of zero
185 if not No_Pool_Assigned (Ent) then
187 Make_Defining_Identifier (Loc,
188 Chars => New_External_Name (Chars (Ent), 'V'));
190 -- Insert the declaration of the object
193 Make_Object_Declaration (Loc,
194 Defining_Identifier => V,
196 New_Reference_To (RTE (RE_Storage_Offset), Loc),
198 Convert_To (RTE (RE_Storage_Offset), Expression (N))));
200 Set_Storage_Size_Variable (Ent, Entity_Id (V));
204 -- Other attributes require no expansion
210 end Expand_N_Attribute_Definition_Clause;
212 -----------------------------
213 -- Expand_N_Free_Statement --
214 -----------------------------
216 procedure Expand_N_Free_Statement (N : Node_Id) is
217 Expr : constant Node_Id := Expression (N);
221 -- Certain run-time configurations and targets do not provide support
222 -- for controlled types.
224 if Restriction_Active (No_Finalization) then
227 -- Do not create a specialized Deallocate since .NET/JVM compilers do
228 -- not support pools and address arithmetic.
230 elsif VM_Target /= No_VM then
234 -- Use the base type to perform the check for finalization master
238 if Ekind (Typ) = E_Access_Subtype then
242 -- Handle private access types
244 if Is_Private_Type (Typ)
245 and then Present (Full_View (Typ))
247 Typ := Full_View (Typ);
250 -- Do not create a custom Deallocate when freeing an object with
251 -- suppressed finalization. In such cases the object is never attached
252 -- to a master, so it does not need to be detached. Use a regular free
253 -- statement instead.
255 if No (Finalization_Master (Typ)) then
259 -- Use a temporary to store the result of a complex expression. Perform
260 -- the following transformation:
262 -- Free (Complex_Expression);
264 -- Temp : constant Type_Of_Expression := Complex_Expression;
267 if Nkind (Expr) /= N_Identifier then
269 Expr_Typ : constant Entity_Id := Etype (Expr);
270 Loc : constant Source_Ptr := Sloc (N);
275 Temp_Id := Make_Temporary (Loc, 'T');
277 Make_Object_Declaration (Loc,
278 Defining_Identifier => Temp_Id,
280 New_Reference_To (Expr_Typ, Loc),
282 Relocate_Node (Expr)));
284 New_Expr := New_Reference_To (Temp_Id, Loc);
285 Set_Etype (New_Expr, Expr_Typ);
287 Set_Expression (N, New_Expr);
291 -- Create a custom Deallocate for a controlled object. This routine
292 -- ensures that the hidden list header will be deallocated along with
293 -- the actual object.
295 Build_Allocate_Deallocate_Proc (N, Is_Allocate => False);
296 end Expand_N_Free_Statement;
298 ----------------------------
299 -- Expand_N_Freeze_Entity --
300 ----------------------------
302 procedure Expand_N_Freeze_Entity (N : Node_Id) is
303 E : constant Entity_Id := Entity (N);
305 In_Other_Scope : Boolean;
306 In_Outer_Scope : Boolean;
308 Delete : Boolean := False;
311 -- If there are delayed aspect specifications, we insert them just
312 -- before the freeze node. They are already analyzed so we don't need
313 -- to reanalyze them (they were analyzed before the type was frozen),
314 -- but we want them in the tree for the back end, and so that the
315 -- listing from sprint is clearer on where these occur logically.
317 if Has_Delayed_Aspects (E) then
323 -- Look for aspect specs for this entity
325 Ritem := First_Rep_Item (E);
326 while Present (Ritem) loop
327 if Nkind (Ritem) = N_Aspect_Specification
328 and then Entity (Ritem) = E
330 Aitem := Aspect_Rep_Item (Ritem);
332 -- Skip this for aspects (e.g. Current_Value) for which
333 -- there is no corresponding pragma or attribute.
335 if Present (Aitem) then
336 pragma Assert (Is_Delayed_Aspect (Aitem));
337 Insert_Before (N, Aitem);
341 Next_Rep_Item (Ritem);
346 -- Processing for objects with address clauses
348 if Is_Object (E) and then Present (Address_Clause (E)) then
349 Apply_Address_Clause_Check (E, N);
352 -- Only other items requiring any front end action are types and
355 elsif not Is_Type (E) and then not Is_Subprogram (E) then
359 -- Here E is a type or a subprogram
361 E_Scope := Scope (E);
363 -- This is an error protection against previous errors
369 -- Remember that we are processing a freezing entity and its freezing
370 -- nodes. This flag (non-zero = set) is used to avoid the need of
371 -- climbing through the tree while processing the freezing actions (ie.
372 -- to avoid generating spurious warnings or to avoid killing constant
373 -- indications while processing the code associated with freezing
374 -- actions). We use a counter to deal with nesting.
376 Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
378 -- If we are freezing entities defined in protected types, they belong
379 -- in the enclosing scope, given that the original type has been
380 -- expanded away. The same is true for entities in task types, in
381 -- particular the parameter records of entries (Entities in bodies are
382 -- all frozen within the body). If we are in the task body, this is a
383 -- proper scope. If we are within a subprogram body, the proper scope
384 -- is the corresponding spec. This may happen for itypes generated in
385 -- the bodies of protected operations.
387 if Ekind (E_Scope) = E_Protected_Type
388 or else (Ekind (E_Scope) = E_Task_Type
389 and then not Has_Completion (E_Scope))
391 E_Scope := Scope (E_Scope);
393 elsif Ekind (E_Scope) = E_Subprogram_Body then
394 E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
397 -- If the scope of the entity is in open scopes, it is the current one
398 -- or an enclosing one, including a loop, a block, or a subprogram.
400 if In_Open_Scopes (E_Scope) then
401 In_Other_Scope := False;
402 In_Outer_Scope := E_Scope /= Current_Scope;
404 -- Otherwise it is a local package or a different compilation unit
407 In_Other_Scope := True;
408 In_Outer_Scope := False;
411 -- If the entity being frozen is defined in a scope that is not
412 -- currently on the scope stack, we must establish the proper
413 -- visibility before freezing the entity and related subprograms.
415 if In_Other_Scope then
416 Push_Scope (E_Scope);
418 -- Finalizers are little odd in terms of freezing. The spec of the
419 -- procedure appears in the declarations while the body appears in
420 -- the statement part of a single construct. Since the finalizer must
421 -- be called by the At_End handler of the construct, the spec is
422 -- manually frozen right after its declaration. The only side effect
423 -- of this action appears in contexts where the construct is not in
424 -- its final resting place. These contexts are:
426 -- * Entry bodies - The declarations and statements are moved to
427 -- the procedure equivalen of the entry.
428 -- * Protected subprograms - The declarations and statements are
429 -- moved to the non-protected version of the subprogram.
430 -- * Task bodies - The declarations and statements are moved to the
431 -- task body procedure.
433 -- Visible declarations do not need to be installed in these three
434 -- cases since it does not make semantic sense to do so. All entities
435 -- referenced by a finalizer are visible and already resolved, plus
436 -- the enclosing scope may not have visible declarations at all.
438 if Ekind (E) = E_Procedure
439 and then Is_Finalizer (E)
442 or else (Is_Subprogram (E_Scope)
443 and then Is_Protected_Type (Scope (E_Scope)))
444 or else Is_Task_Type (E_Scope))
448 Install_Visible_Declarations (E_Scope);
451 if Is_Package_Or_Generic_Package (E_Scope) or else
452 Is_Protected_Type (E_Scope) or else
453 Is_Task_Type (E_Scope)
455 Install_Private_Declarations (E_Scope);
458 -- If the entity is in an outer scope, then that scope needs to
459 -- temporarily become the current scope so that operations created
460 -- during type freezing will be declared in the right scope and
461 -- can properly override any corresponding inherited operations.
463 elsif In_Outer_Scope then
464 Push_Scope (E_Scope);
467 -- If type, freeze the type
470 Delete := Freeze_Type (N);
472 -- And for enumeration type, build the enumeration tables
474 if Is_Enumeration_Type (E) then
475 Build_Enumeration_Image_Tables (E, N);
478 -- If subprogram, freeze the subprogram
480 elsif Is_Subprogram (E) then
481 Freeze_Subprogram (N);
483 -- Ada 2005 (AI-251): Remove the freezing node associated with the
484 -- entities internally used by the frontend to register primitives
485 -- covering abstract interfaces. The call to Freeze_Subprogram has
486 -- already expanded the code that fills the corresponding entry in
487 -- its secondary dispatch table and therefore the code generator
488 -- has nothing else to do with this freezing node.
490 Delete := Present (Interface_Alias (E));
493 -- Analyze actions generated by freezing. The init_proc contains source
494 -- expressions that may raise Constraint_Error, and the assignment
495 -- procedure for complex types needs checks on individual component
496 -- assignments, but all other freezing actions should be compiled with
499 if Present (Actions (N)) then
500 Decl := First (Actions (N));
501 while Present (Decl) loop
502 if Nkind (Decl) = N_Subprogram_Body
503 and then (Is_Init_Proc (Defining_Entity (Decl))
505 Chars (Defining_Entity (Decl)) = Name_uAssign)
509 -- A subprogram body created for a renaming_as_body completes
510 -- a previous declaration, which may be in a different scope.
511 -- Establish the proper scope before analysis.
513 elsif Nkind (Decl) = N_Subprogram_Body
514 and then Present (Corresponding_Spec (Decl))
515 and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
517 Push_Scope (Scope (Corresponding_Spec (Decl)));
518 Analyze (Decl, Suppress => All_Checks);
521 -- We treat generated equality specially, if validity checks are
522 -- enabled, in order to detect components default-initialized
523 -- with invalid values.
525 elsif Nkind (Decl) = N_Subprogram_Body
526 and then Chars (Defining_Entity (Decl)) = Name_Op_Eq
527 and then Validity_Checks_On
528 and then Initialize_Scalars
531 Save_Force : constant Boolean := Force_Validity_Checks;
533 Force_Validity_Checks := True;
535 Force_Validity_Checks := Save_Force;
539 Analyze (Decl, Suppress => All_Checks);
546 -- If we are to delete this N_Freeze_Entity, do so by rewriting so that
547 -- a loop on all nodes being inserted will work propertly.
550 Rewrite (N, Make_Null_Statement (Sloc (N)));
553 -- Pop scope if we installed one for the analysis
555 if In_Other_Scope then
556 if Ekind (Current_Scope) = E_Package then
557 End_Package_Scope (E_Scope);
562 elsif In_Outer_Scope then
566 -- Restore previous value of the nesting-level counter that records
567 -- whether we are inside a (possibly nested) call to this procedure.
569 Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
570 end Expand_N_Freeze_Entity;
572 -------------------------------------------
573 -- Expand_N_Record_Representation_Clause --
574 -------------------------------------------
576 -- The only expansion required is for the case of a mod clause present,
577 -- which is removed, and translated into an alignment representation
578 -- clause inserted immediately after the record rep clause with any
579 -- initial pragmas inserted at the start of the component clause list.
581 procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
582 Loc : constant Source_Ptr := Sloc (N);
583 Rectype : constant Entity_Id := Entity (Identifier (N));
590 if Present (Mod_Clause (N)) and then not Ignore_Rep_Clauses then
591 Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
592 Citems := Pragmas_Before (Mod_Clause (N));
594 if Present (Citems) then
595 Append_List_To (Citems, Component_Clauses (N));
596 Set_Component_Clauses (N, Citems);
600 Make_Attribute_Definition_Clause (Loc,
601 Name => New_Reference_To (Base_Type (Rectype), Loc),
602 Chars => Name_Alignment,
603 Expression => Make_Integer_Literal (Loc, Mod_Val));
605 Set_From_At_Mod (AtM_Nod);
606 Insert_After (N, AtM_Nod);
607 Set_Mod_Clause (N, Empty);
610 -- If the record representation clause has no components, then
611 -- completely remove it. Note that we also have to remove
612 -- ourself from the Rep Item list.
614 if Is_Empty_List (Component_Clauses (N)) then
615 if First_Rep_Item (Rectype) = N then
616 Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
618 Repitem := First_Rep_Item (Rectype);
619 while Present (Next_Rep_Item (Repitem)) loop
620 if Next_Rep_Item (Repitem) = N then
621 Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
625 Next_Rep_Item (Repitem);
630 Make_Null_Statement (Loc));
632 end Expand_N_Record_Representation_Clause;