1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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 Rtsfind; use Rtsfind;
40 with Sem_Ch7; use Sem_Ch7;
41 with Sem_Ch8; use Sem_Ch8;
42 with Sem_Eval; use Sem_Eval;
43 with Sem_Util; use Sem_Util;
44 with Sinfo; use Sinfo;
45 with Snames; use Snames;
46 with Stand; use Stand;
47 with Tbuild; use Tbuild;
48 with Uintp; use Uintp;
50 package body Exp_Ch13 is
52 ------------------------------------------
53 -- Expand_N_Attribute_Definition_Clause --
54 ------------------------------------------
56 -- Expansion action depends on attribute involved
58 procedure Expand_N_Attribute_Definition_Clause (N : Node_Id) is
59 Loc : constant Source_Ptr := Sloc (N);
60 Exp : constant Node_Id := Expression (N);
65 Ent := Entity (Name (N));
68 Ent := Underlying_Type (Ent);
71 case Get_Attribute_Id (Chars (N)) is
77 when Attribute_Address =>
79 -- If there is an initialization which did not come from the
80 -- source program, then it is an artifact of our expansion, and we
81 -- suppress it. The case we are most concerned about here is the
82 -- initialization of a packed array to all false, which seems
83 -- inappropriate for variable to which an address clause is
84 -- applied. The expression may itself have been rewritten if the
85 -- type is packed array, so we need to examine whether the
86 -- original node is in the source. An exception though is the case
87 -- of an access variable which is default initialized to null, and
88 -- such initialization is retained.
90 -- Furthermore, if the initialization is the equivalent aggregate
91 -- of the type initialization procedure, it replaces an implicit
92 -- call to the init proc, and must be respected. Note that for
93 -- packed types we do not build equivalent aggregates.
95 -- Also, if Init_Or_Norm_Scalars applies, then we need to retain
96 -- any default initialization for objects of scalar types and
97 -- types with scalar components. Normally a composite type will
98 -- have an init_proc in the presence of Init_Or_Norm_Scalars,
99 -- so when that flag is set we have just have to do a test for
100 -- scalar and string types (the predefined string types such as
101 -- String and Wide_String don't have an init_proc).
104 Decl : constant Node_Id := Declaration_Node (Ent);
105 Typ : constant Entity_Id := Etype (Ent);
108 if Nkind (Decl) = N_Object_Declaration
109 and then Present (Expression (Decl))
110 and then Nkind (Expression (Decl)) /= N_Null
112 not Comes_From_Source (Original_Node (Expression (Decl)))
114 if Present (Base_Init_Proc (Typ))
116 Present (Static_Initialization (Base_Init_Proc (Typ)))
120 elsif Init_Or_Norm_Scalars
122 (Is_Scalar_Type (Typ) or else Is_String_Type (Typ))
127 Set_Expression (Decl, Empty);
136 when Attribute_Alignment =>
138 -- As required by Gigi, we guarantee that the operand is an
139 -- integer literal (this simplifies things in Gigi).
141 if Nkind (Exp) /= N_Integer_Literal then
143 (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
150 when Attribute_Storage_Size =>
152 -- If the type is a task type, then assign the value of the
153 -- storage size to the Size variable associated with the task.
154 -- task_typeZ := expression
156 if Ekind (Ent) = E_Task_Type then
158 Make_Assignment_Statement (Loc,
159 Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
161 Convert_To (RTE (RE_Size_Type), Expression (N))));
163 -- For Storage_Size for an access type, create a variable to hold
164 -- the value of the specified size with name typeV and expand an
165 -- assignment statement to initialize this value.
167 elsif Is_Access_Type (Ent) then
169 -- We don't need the variable for a storage size of zero
171 if not No_Pool_Assigned (Ent) then
173 Make_Defining_Identifier (Loc,
174 Chars => New_External_Name (Chars (Ent), 'V'));
176 -- Insert the declaration of the object
179 Make_Object_Declaration (Loc,
180 Defining_Identifier => V,
182 New_Reference_To (RTE (RE_Storage_Offset), Loc),
184 Convert_To (RTE (RE_Storage_Offset), Expression (N))));
186 Set_Storage_Size_Variable (Ent, Entity_Id (V));
190 -- Other attributes require no expansion
196 end Expand_N_Attribute_Definition_Clause;
198 ----------------------------
199 -- Expand_N_Freeze_Entity --
200 ----------------------------
202 procedure Expand_N_Freeze_Entity (N : Node_Id) is
203 E : constant Entity_Id := Entity (N);
206 In_Other_Scope : Boolean;
207 In_Outer_Scope : Boolean;
209 Delete : Boolean := False;
212 -- Processing for objects with address clauses
214 if Is_Object (E) and then Present (Address_Clause (E)) then
215 Apply_Address_Clause_Check (E, N);
218 -- Only other items requiring any front end action are types and
221 elsif not Is_Type (E) and then not Is_Subprogram (E) then
225 -- Here E is a type or a subprogram
227 E_Scope := Scope (E);
229 -- This is an error protection against previous errors
235 -- Remember that we are processing a freezing entity and its freezing
236 -- nodes. This flag (non-zero = set) is used to avoid the need of
237 -- climbing through the tree while processing the freezing actions (ie.
238 -- to avoid generating spurious warnings or to avoid killing constant
239 -- indications while processing the code associated with freezing
240 -- actions). We use a counter to deal with nesting.
242 Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
244 -- If we are freezing entities defined in protected types, they belong
245 -- in the enclosing scope, given that the original type has been
246 -- expanded away. The same is true for entities in task types, in
247 -- particular the parameter records of entries (Entities in bodies are
248 -- all frozen within the body). If we are in the task body, this is a
249 -- proper scope. If we are within a subprogram body, the proper scope
250 -- is the corresponding spec. This may happen for itypes generated in
251 -- the bodies of protected operations.
253 if Ekind (E_Scope) = E_Protected_Type
254 or else (Ekind (E_Scope) = E_Task_Type
255 and then not Has_Completion (E_Scope))
257 E_Scope := Scope (E_Scope);
259 elsif Ekind (E_Scope) = E_Subprogram_Body then
260 E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
264 while S /= Standard_Standard and then S /= E_Scope loop
268 In_Other_Scope := not (S = E_Scope);
269 In_Outer_Scope := (not In_Other_Scope) and then (S /= Current_Scope);
271 -- If the entity being frozen is defined in a scope that is not
272 -- currently on the scope stack, we must establish the proper
273 -- visibility before freezing the entity and related subprograms.
275 if In_Other_Scope then
276 Push_Scope (E_Scope);
277 Install_Visible_Declarations (E_Scope);
279 if Is_Package_Or_Generic_Package (E_Scope) or else
280 Is_Protected_Type (E_Scope) or else
281 Is_Task_Type (E_Scope)
283 Install_Private_Declarations (E_Scope);
286 -- If the entity is in an outer scope, then that scope needs to
287 -- temporarily become the current scope so that operations created
288 -- during type freezing will be declared in the right scope and
289 -- can properly override any corresponding inherited operations.
291 elsif In_Outer_Scope then
292 Push_Scope (E_Scope);
295 -- If type, freeze the type
298 Delete := Freeze_Type (N);
300 -- And for enumeration type, build the enumeration tables
302 if Is_Enumeration_Type (E) then
303 Build_Enumeration_Image_Tables (E, N);
306 -- If subprogram, freeze the subprogram
308 elsif Is_Subprogram (E) then
309 Freeze_Subprogram (N);
311 -- Ada 2005 (AI-251): Remove the freezing node associated with the
312 -- entities internally used by the frontend to register primitives
313 -- covering abstract interfaces. The call to Freeze_Subprogram has
314 -- already expanded the code that fills the corresponding entry in
315 -- its secondary dispatch table and therefore the code generator
316 -- has nothing else to do with this freezing node.
318 Delete := Present (Interface_Alias (E));
321 -- Analyze actions generated by freezing. The init_proc contains source
322 -- expressions that may raise Constraint_Error, and the assignment
323 -- procedure for complex types needs checks on individual component
324 -- assignments, but all other freezing actions should be compiled with
327 if Present (Actions (N)) then
328 Decl := First (Actions (N));
329 while Present (Decl) loop
330 if Nkind (Decl) = N_Subprogram_Body
331 and then (Is_Init_Proc (Defining_Entity (Decl))
333 Chars (Defining_Entity (Decl)) = Name_uAssign)
337 -- A subprogram body created for a renaming_as_body completes
338 -- a previous declaration, which may be in a different scope.
339 -- Establish the proper scope before analysis.
341 elsif Nkind (Decl) = N_Subprogram_Body
342 and then Present (Corresponding_Spec (Decl))
343 and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
345 Push_Scope (Scope (Corresponding_Spec (Decl)));
346 Analyze (Decl, Suppress => All_Checks);
350 Analyze (Decl, Suppress => All_Checks);
357 -- If we are to delete this N_Freeze_Entity, do so by rewriting so that
358 -- a loop on all nodes being inserted will work propertly.
361 Rewrite (N, Make_Null_Statement (Sloc (N)));
364 if In_Other_Scope then
365 if Ekind (Current_Scope) = E_Package then
366 End_Package_Scope (E_Scope);
371 elsif In_Outer_Scope then
375 -- Restore previous value of the nesting-level counter that records
376 -- whether we are inside a (possibly nested) call to this procedure.
378 Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
379 end Expand_N_Freeze_Entity;
381 -------------------------------------------
382 -- Expand_N_Record_Representation_Clause --
383 -------------------------------------------
385 -- The only expansion required is for the case of a mod clause present,
386 -- which is removed, and translated into an alignment representation
387 -- clause inserted immediately after the record rep clause with any
388 -- initial pragmas inserted at the start of the component clause list.
390 procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
391 Loc : constant Source_Ptr := Sloc (N);
392 Rectype : constant Entity_Id := Entity (Identifier (N));
399 if Present (Mod_Clause (N)) and then not Ignore_Rep_Clauses then
400 Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
401 Citems := Pragmas_Before (Mod_Clause (N));
403 if Present (Citems) then
404 Append_List_To (Citems, Component_Clauses (N));
405 Set_Component_Clauses (N, Citems);
409 Make_Attribute_Definition_Clause (Loc,
410 Name => New_Reference_To (Base_Type (Rectype), Loc),
411 Chars => Name_Alignment,
412 Expression => Make_Integer_Literal (Loc, Mod_Val));
414 Set_From_At_Mod (AtM_Nod);
415 Insert_After (N, AtM_Nod);
416 Set_Mod_Clause (N, Empty);
419 -- If the record representation clause has no components, then
420 -- completely remove it. Note that we also have to remove
421 -- ourself from the Rep Item list.
423 if Is_Empty_List (Component_Clauses (N)) then
424 if First_Rep_Item (Rectype) = N then
425 Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
427 Repitem := First_Rep_Item (Rectype);
428 while Present (Next_Rep_Item (Repitem)) loop
429 if Next_Rep_Item (Repitem) = N then
430 Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
434 Next_Rep_Item (Repitem);
439 Make_Null_Statement (Loc));
441 end Expand_N_Record_Representation_Clause;