|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- E X P _ C H 1 3 --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
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 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
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;
|
|
|
31 with Exp_Imgv; use Exp_Imgv;
|
|
|
32 with Exp_Tss; use Exp_Tss;
|
|
|
33 with Exp_Util; use Exp_Util;
|
|
|
34 with Freeze; use Freeze;
|
|
|
35 with Namet; use Namet;
|
|
|
36 with Nlists; use Nlists;
|
|
|
37 with Nmake; use Nmake;
|
|
|
38 with Opt; use Opt;
|
|
|
39 with Restrict; use Restrict;
|
|
|
40 with Rident; use Rident;
|
|
|
41 with Rtsfind; use Rtsfind;
|
|
|
42 with Sem; use Sem;
|
|
|
43 with Sem_Aux; use Sem_Aux;
|
|
|
44 with Sem_Ch7; use Sem_Ch7;
|
|
|
45 with Sem_Ch8; use Sem_Ch8;
|
|
|
46 with Sem_Eval; use Sem_Eval;
|
|
|
47 with Sem_Util; use Sem_Util;
|
|
|
48 with Sinfo; use Sinfo;
|
|
|
49 with Snames; use Snames;
|
|
|
50 with Tbuild; use Tbuild;
|
|
|
51 with Uintp; use Uintp;
|
|
|
52 with Validsw; use Validsw;
|
|
|
53
|
|
|
54 package body Exp_Ch13 is
|
|
|
55
|
|
|
56 ------------------------------------------
|
|
|
57 -- Expand_N_Attribute_Definition_Clause --
|
|
|
58 ------------------------------------------
|
|
|
59
|
|
|
60 -- Expansion action depends on attribute involved
|
|
|
61
|
|
|
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;
|
|
|
67
|
|
|
68 begin
|
|
|
69 Ent := Entity (Name (N));
|
|
|
70
|
|
|
71 if Is_Type (Ent) then
|
|
|
72 Ent := Underlying_Type (Ent);
|
|
|
73 end if;
|
|
|
74
|
|
|
75 case Get_Attribute_Id (Chars (N)) is
|
|
|
76
|
|
|
77 -------------
|
|
|
78 -- Address --
|
|
|
79 -------------
|
|
|
80
|
|
|
81 when Attribute_Address =>
|
|
|
82
|
|
|
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.
|
|
|
93
|
|
|
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.
|
|
|
98
|
|
|
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).
|
|
|
106
|
|
|
107 declare
|
|
|
108 Decl : constant Node_Id := Declaration_Node (Ent);
|
|
|
109 Typ : constant Entity_Id := Etype (Ent);
|
|
|
110
|
|
|
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;
|
|
|
123
|
|
|
124 elsif Init_Or_Norm_Scalars
|
|
|
125 and then (Is_Scalar_Type (Typ)
|
|
|
126 or else Is_String_Type (Typ))
|
|
|
127 then
|
|
|
128 null;
|
|
|
129
|
|
|
130 else
|
|
|
131 Set_Expression (Decl, Empty);
|
|
|
132 end if;
|
|
|
133
|
|
|
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.
|
|
|
138 -- If the attribute comes from an aspect specification it
|
|
|
139 -- is being elaborated at the freeze point and side effects
|
|
|
140 -- need not be removed (and shouldn't, if the expression
|
|
|
141 -- depends on other entities that have delayed freeze).
|
|
|
142 -- This is another consequence of the delayed analysis of
|
|
|
143 -- aspects, and a real semantic difference.
|
|
|
144
|
|
|
145 elsif Nkind (Decl) = N_Object_Declaration
|
|
|
146 and then not Needs_Constant_Address (Decl, Typ)
|
|
|
147 and then not From_Aspect_Specification (N)
|
|
|
148 then
|
|
|
149 Remove_Side_Effects (Exp);
|
|
|
150 end if;
|
|
|
151 end;
|
|
|
152
|
|
|
153 ---------------
|
|
|
154 -- Alignment --
|
|
|
155 ---------------
|
|
|
156
|
|
|
157 when Attribute_Alignment =>
|
|
|
158
|
|
|
159 -- As required by Gigi, we guarantee that the operand is an
|
|
|
160 -- integer literal (this simplifies things in Gigi).
|
|
|
161
|
|
|
162 if Nkind (Exp) /= N_Integer_Literal then
|
|
|
163 Rewrite (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
|
|
|
164 end if;
|
|
|
165
|
|
|
166 -- A complex case arises if the alignment clause applies to an
|
|
|
167 -- unconstrained object initialized with a function call. The
|
|
|
168 -- result of the call is placed on the secondary stack, and the
|
|
|
169 -- declaration is rewritten as a renaming of a dereference, which
|
|
|
170 -- fails expansion. We must introduce a temporary and assign its
|
|
|
171 -- value to the existing entity.
|
|
|
172
|
|
|
173 if Nkind (Parent (Ent)) = N_Object_Renaming_Declaration
|
|
|
174 and then not Is_Entity_Name (Renamed_Object (Ent))
|
|
|
175 then
|
|
|
176 declare
|
|
|
177 Decl : constant Node_Id := Parent (Ent);
|
|
|
178 Loc : constant Source_Ptr := Sloc (N);
|
|
|
179 Temp : constant Entity_Id := Make_Temporary (Loc, 'T');
|
|
|
180
|
|
|
181 New_Decl : Node_Id;
|
|
|
182
|
|
|
183 begin
|
|
|
184 -- Replace entity with temporary and reanalyze
|
|
|
185
|
|
|
186 Set_Defining_Identifier (Decl, Temp);
|
|
|
187 Set_Analyzed (Decl, False);
|
|
|
188 Analyze (Decl);
|
|
|
189
|
|
|
190 -- Introduce new declaration for entity but do not reanalyze
|
|
|
191 -- because entity is already in scope. Type and expression
|
|
|
192 -- are already resolved.
|
|
|
193
|
|
|
194 New_Decl :=
|
|
|
195 Make_Object_Declaration (Loc,
|
|
|
196 Defining_Identifier => Ent,
|
|
|
197 Object_Definition =>
|
|
|
198 New_Occurrence_Of (Etype (Ent), Loc),
|
|
|
199 Expression => New_Occurrence_Of (Temp, Loc));
|
|
|
200
|
|
|
201 Set_Renamed_Object (Ent, Empty);
|
|
|
202 Insert_After (Decl, New_Decl);
|
|
|
203 Set_Analyzed (Decl);
|
|
|
204 end;
|
|
|
205 end if;
|
|
|
206
|
|
|
207 ------------------
|
|
|
208 -- Storage_Size --
|
|
|
209 ------------------
|
|
|
210
|
|
|
211 when Attribute_Storage_Size =>
|
|
|
212
|
|
|
213 -- If the type is a task type, then assign the value of the
|
|
|
214 -- storage size to the Size variable associated with the task.
|
|
|
215 -- Insert the assignment right after the declaration of the Size
|
|
|
216 -- variable.
|
|
|
217
|
|
|
218 -- Generate:
|
|
|
219
|
|
|
220 -- task_typeZ := expression
|
|
|
221
|
|
|
222 if Ekind (Ent) = E_Task_Type then
|
|
|
223 declare
|
|
|
224 Assign : Node_Id;
|
|
|
225
|
|
|
226 begin
|
|
|
227 Assign :=
|
|
|
228 Make_Assignment_Statement (Loc,
|
|
|
229 Name =>
|
|
|
230 New_Occurrence_Of (Storage_Size_Variable (Ent), Loc),
|
|
|
231 Expression =>
|
|
|
232 Convert_To (RTE (RE_Size_Type), Expression (N)));
|
|
|
233
|
|
|
234 -- If the clause is not generated by an aspect, insert
|
|
|
235 -- the assignment here. Freezing rules ensure that this
|
|
|
236 -- is safe, or clause will have been rejected already.
|
|
|
237
|
|
|
238 if Is_List_Member (N) then
|
|
|
239 Insert_After (N, Assign);
|
|
|
240
|
|
|
241 -- Otherwise, insert assignment after task declaration.
|
|
|
242
|
|
|
243 else
|
|
|
244 Insert_After
|
|
|
245 (Parent (Storage_Size_Variable (Entity (N))), Assign);
|
|
|
246 end if;
|
|
|
247
|
|
|
248 Analyze (Assign);
|
|
|
249 end;
|
|
|
250
|
|
|
251 -- For Storage_Size for an access type, create a variable to hold
|
|
|
252 -- the value of the specified size with name typeV and expand an
|
|
|
253 -- assignment statement to initialize this value.
|
|
|
254
|
|
|
255 elsif Is_Access_Type (Ent) then
|
|
|
256
|
|
|
257 -- We don't need the variable for a storage size of zero
|
|
|
258
|
|
|
259 if not No_Pool_Assigned (Ent) then
|
|
|
260 V :=
|
|
|
261 Make_Defining_Identifier (Loc,
|
|
|
262 Chars => New_External_Name (Chars (Ent), 'V'));
|
|
|
263
|
|
|
264 -- Insert the declaration of the object
|
|
|
265
|
|
|
266 Insert_Action (N,
|
|
|
267 Make_Object_Declaration (Loc,
|
|
|
268 Defining_Identifier => V,
|
|
|
269 Object_Definition =>
|
|
|
270 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
|
|
|
271 Expression =>
|
|
|
272 Convert_To (RTE (RE_Storage_Offset), Expression (N))));
|
|
|
273
|
|
|
274 Set_Storage_Size_Variable (Ent, Entity_Id (V));
|
|
|
275 end if;
|
|
|
276 end if;
|
|
|
277
|
|
|
278 -- Other attributes require no expansion
|
|
|
279
|
|
|
280 when others =>
|
|
|
281 null;
|
|
|
282 end case;
|
|
|
283 end Expand_N_Attribute_Definition_Clause;
|
|
|
284
|
|
|
285 -----------------------------
|
|
|
286 -- Expand_N_Free_Statement --
|
|
|
287 -----------------------------
|
|
|
288
|
|
|
289 procedure Expand_N_Free_Statement (N : Node_Id) is
|
|
|
290 Expr : constant Node_Id := Expression (N);
|
|
|
291 Typ : Entity_Id;
|
|
|
292
|
|
|
293 begin
|
|
|
294 -- Certain run-time configurations and targets do not provide support
|
|
|
295 -- for controlled types.
|
|
|
296
|
|
|
297 if Restriction_Active (No_Finalization) then
|
|
|
298 return;
|
|
|
299 end if;
|
|
|
300
|
|
|
301 -- Use the base type to perform the check for finalization master
|
|
|
302
|
|
|
303 Typ := Etype (Expr);
|
|
|
304
|
|
|
305 if Ekind (Typ) = E_Access_Subtype then
|
|
|
306 Typ := Etype (Typ);
|
|
|
307 end if;
|
|
|
308
|
|
|
309 -- Handle private access types
|
|
|
310
|
|
|
311 if Is_Private_Type (Typ)
|
|
|
312 and then Present (Full_View (Typ))
|
|
|
313 then
|
|
|
314 Typ := Full_View (Typ);
|
|
|
315 end if;
|
|
|
316
|
|
|
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.
|
|
|
321
|
|
|
322 if No (Finalization_Master (Typ)) then
|
|
|
323 return;
|
|
|
324 end if;
|
|
|
325
|
|
|
326 -- Use a temporary to store the result of a complex expression. Perform
|
|
|
327 -- the following transformation:
|
|
|
328 --
|
|
|
329 -- Free (Complex_Expression);
|
|
|
330 --
|
|
|
331 -- Temp : constant Type_Of_Expression := Complex_Expression;
|
|
|
332 -- Free (Temp);
|
|
|
333
|
|
|
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;
|
|
|
340
|
|
|
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 => New_Occurrence_Of (Expr_Typ, Loc),
|
|
|
347 Expression => Relocate_Node (Expr)));
|
|
|
348
|
|
|
349 New_Expr := New_Occurrence_Of (Temp_Id, Loc);
|
|
|
350 Set_Etype (New_Expr, Expr_Typ);
|
|
|
351
|
|
|
352 Set_Expression (N, New_Expr);
|
|
|
353 end;
|
|
|
354 end if;
|
|
|
355
|
|
|
356 -- Create a custom Deallocate for a controlled object. This routine
|
|
|
357 -- ensures that the hidden list header will be deallocated along with
|
|
|
358 -- the actual object.
|
|
|
359
|
|
|
360 Build_Allocate_Deallocate_Proc (N, Is_Allocate => False);
|
|
|
361 end Expand_N_Free_Statement;
|
|
|
362
|
|
|
363 ----------------------------
|
|
|
364 -- Expand_N_Freeze_Entity --
|
|
|
365 ----------------------------
|
|
|
366
|
|
|
367 procedure Expand_N_Freeze_Entity (N : Node_Id) is
|
|
|
368 E : constant Entity_Id := Entity (N);
|
|
|
369
|
|
|
370 Decl : Node_Id;
|
|
|
371 Delete : Boolean := False;
|
|
|
372 E_Scope : Entity_Id;
|
|
|
373 In_Other_Scope : Boolean;
|
|
|
374 In_Outer_Scope : Boolean;
|
|
|
375
|
|
|
376 begin
|
|
|
377 -- If there are delayed aspect specifications, we insert them just
|
|
|
378 -- before the freeze node. They are already analyzed so we don't need
|
|
|
379 -- to reanalyze them (they were analyzed before the type was frozen),
|
|
|
380 -- but we want them in the tree for the back end, and so that the
|
|
|
381 -- listing from sprint is clearer on where these occur logically.
|
|
|
382
|
|
|
383 if Has_Delayed_Aspects (E) then
|
|
|
384 declare
|
|
|
385 Aitem : Node_Id;
|
|
|
386 Ritem : Node_Id;
|
|
|
387
|
|
|
388 begin
|
|
|
389 -- Look for aspect specs for this entity
|
|
|
390
|
|
|
391 Ritem := First_Rep_Item (E);
|
|
|
392 while Present (Ritem) loop
|
|
|
393 if Nkind (Ritem) = N_Aspect_Specification
|
|
|
394 and then Entity (Ritem) = E
|
|
|
395 then
|
|
|
396 Aitem := Aspect_Rep_Item (Ritem);
|
|
|
397
|
|
|
398 -- Skip this for aspects (e.g. Current_Value) for which
|
|
|
399 -- there is no corresponding pragma or attribute.
|
|
|
400
|
|
|
401 if Present (Aitem)
|
|
|
402
|
|
|
403 -- Also skip if we have a null statement rather than a
|
|
|
404 -- delayed aspect (this happens when we are ignoring rep
|
|
|
405 -- items from use of the -gnatI switch).
|
|
|
406
|
|
|
407 and then Nkind (Aitem) /= N_Null_Statement
|
|
|
408 then
|
|
|
409 pragma Assert (Is_Delayed_Aspect (Aitem));
|
|
|
410 Insert_Before (N, Aitem);
|
|
|
411 end if;
|
|
|
412 end if;
|
|
|
413
|
|
|
414 Next_Rep_Item (Ritem);
|
|
|
415 end loop;
|
|
|
416 end;
|
|
|
417 end if;
|
|
|
418
|
|
|
419 -- Processing for objects
|
|
|
420
|
|
|
421 if Is_Object (E) then
|
|
|
422 if Present (Address_Clause (E)) then
|
|
|
423 Apply_Address_Clause_Check (E, N);
|
|
|
424 end if;
|
|
|
425
|
|
|
426 -- Analyze actions in freeze node, if any
|
|
|
427
|
|
|
428 if Present (Actions (N)) then
|
|
|
429 declare
|
|
|
430 Act : Node_Id;
|
|
|
431 begin
|
|
|
432 Act := First (Actions (N));
|
|
|
433 while Present (Act) loop
|
|
|
434 Analyze (Act);
|
|
|
435 Next (Act);
|
|
|
436 end loop;
|
|
|
437 end;
|
|
|
438 end if;
|
|
|
439
|
|
|
440 -- If initialization statements have been captured in a compound
|
|
|
441 -- statement, insert them back into the tree now.
|
|
|
442
|
|
|
443 Explode_Initialization_Compound_Statement (E);
|
|
|
444 return;
|
|
|
445
|
|
|
446 -- Only other items requiring any front end action are types and
|
|
|
447 -- subprograms.
|
|
|
448
|
|
|
449 elsif not Is_Type (E) and then not Is_Subprogram (E) then
|
|
|
450 return;
|
|
|
451 end if;
|
|
|
452
|
|
|
453 -- Here E is a type or a subprogram
|
|
|
454
|
|
|
455 E_Scope := Scope (E);
|
|
|
456
|
|
|
457 -- This is an error protection against previous errors
|
|
|
458
|
|
|
459 if No (E_Scope) then
|
|
|
460 Check_Error_Detected;
|
|
|
461 return;
|
|
|
462 end if;
|
|
|
463
|
|
|
464 -- The entity may be a subtype declared for a constrained record
|
|
|
465 -- component, in which case the relevant scope is the scope of
|
|
|
466 -- the record. This happens for class-wide subtypes created for
|
|
|
467 -- a constrained type extension with inherited discriminants.
|
|
|
468
|
|
|
469 if Is_Type (E_Scope)
|
|
|
470 and then Ekind (E_Scope) not in Concurrent_Kind
|
|
|
471 then
|
|
|
472 E_Scope := Scope (E_Scope);
|
|
131
|
473
|
|
|
474 -- The entity may be a subtype declared for an iterator
|
|
|
475
|
|
|
476 elsif Ekind (E_Scope) = E_Loop then
|
|
|
477 E_Scope := Scope (E_Scope);
|
|
111
|
478 end if;
|
|
|
479
|
|
|
480 -- Remember that we are processing a freezing entity and its freezing
|
|
|
481 -- nodes. This flag (non-zero = set) is used to avoid the need of
|
|
|
482 -- climbing through the tree while processing the freezing actions (ie.
|
|
|
483 -- to avoid generating spurious warnings or to avoid killing constant
|
|
|
484 -- indications while processing the code associated with freezing
|
|
|
485 -- actions). We use a counter to deal with nesting.
|
|
|
486
|
|
|
487 Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
|
|
|
488
|
|
|
489 -- If we are freezing entities defined in protected types, they belong
|
|
|
490 -- in the enclosing scope, given that the original type has been
|
|
|
491 -- expanded away. The same is true for entities in task types, in
|
|
|
492 -- particular the parameter records of entries (Entities in bodies are
|
|
|
493 -- all frozen within the body). If we are in the task body, this is a
|
|
|
494 -- proper scope. If we are within a subprogram body, the proper scope
|
|
|
495 -- is the corresponding spec. This may happen for itypes generated in
|
|
|
496 -- the bodies of protected operations.
|
|
|
497
|
|
|
498 if Ekind (E_Scope) = E_Protected_Type
|
|
|
499 or else (Ekind (E_Scope) = E_Task_Type
|
|
|
500 and then not Has_Completion (E_Scope))
|
|
|
501 then
|
|
|
502 E_Scope := Scope (E_Scope);
|
|
|
503
|
|
|
504 elsif Ekind (E_Scope) = E_Subprogram_Body then
|
|
|
505 E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
|
|
|
506 end if;
|
|
|
507
|
|
|
508 -- If the scope of the entity is in open scopes, it is the current one
|
|
|
509 -- or an enclosing one, including a loop, a block, or a subprogram.
|
|
|
510
|
|
|
511 if In_Open_Scopes (E_Scope) then
|
|
|
512 In_Other_Scope := False;
|
|
|
513 In_Outer_Scope := E_Scope /= Current_Scope;
|
|
|
514
|
|
|
515 -- Otherwise it is a local package or a different compilation unit
|
|
|
516
|
|
|
517 else
|
|
|
518 In_Other_Scope := True;
|
|
|
519 In_Outer_Scope := False;
|
|
|
520 end if;
|
|
|
521
|
|
|
522 -- If the entity being frozen is defined in a scope that is not
|
|
|
523 -- currently on the scope stack, we must establish the proper
|
|
|
524 -- visibility before freezing the entity and related subprograms.
|
|
|
525
|
|
|
526 if In_Other_Scope then
|
|
|
527 Push_Scope (E_Scope);
|
|
|
528
|
|
|
529 -- Finalizers are little odd in terms of freezing. The spec of the
|
|
|
530 -- procedure appears in the declarations while the body appears in
|
|
|
531 -- the statement part of a single construct. Since the finalizer must
|
|
|
532 -- be called by the At_End handler of the construct, the spec is
|
|
|
533 -- manually frozen right after its declaration. The only side effect
|
|
|
534 -- of this action appears in contexts where the construct is not in
|
|
|
535 -- its final resting place. These contexts are:
|
|
|
536
|
|
|
537 -- * Entry bodies - The declarations and statements are moved to
|
|
|
538 -- the procedure equivalen of the entry.
|
|
|
539 -- * Protected subprograms - The declarations and statements are
|
|
|
540 -- moved to the non-protected version of the subprogram.
|
|
|
541 -- * Task bodies - The declarations and statements are moved to the
|
|
|
542 -- task body procedure.
|
|
|
543
|
|
|
544 -- Visible declarations do not need to be installed in these three
|
|
|
545 -- cases since it does not make semantic sense to do so. All entities
|
|
|
546 -- referenced by a finalizer are visible and already resolved, plus
|
|
|
547 -- the enclosing scope may not have visible declarations at all.
|
|
|
548
|
|
|
549 if Ekind (E) = E_Procedure
|
|
|
550 and then Is_Finalizer (E)
|
|
|
551 and then
|
|
|
552 (Is_Entry (E_Scope)
|
|
|
553 or else (Is_Subprogram (E_Scope)
|
|
|
554 and then Is_Protected_Type (Scope (E_Scope)))
|
|
|
555 or else Is_Task_Type (E_Scope))
|
|
|
556 then
|
|
|
557 null;
|
|
|
558 else
|
|
|
559 Install_Visible_Declarations (E_Scope);
|
|
|
560 end if;
|
|
|
561
|
|
|
562 if Is_Package_Or_Generic_Package (E_Scope) or else
|
|
|
563 Is_Protected_Type (E_Scope) or else
|
|
|
564 Is_Task_Type (E_Scope)
|
|
|
565 then
|
|
|
566 Install_Private_Declarations (E_Scope);
|
|
|
567 end if;
|
|
|
568
|
|
|
569 -- If the entity is in an outer scope, then that scope needs to
|
|
|
570 -- temporarily become the current scope so that operations created
|
|
|
571 -- during type freezing will be declared in the right scope and
|
|
|
572 -- can properly override any corresponding inherited operations.
|
|
|
573
|
|
|
574 elsif In_Outer_Scope then
|
|
|
575 Push_Scope (E_Scope);
|
|
|
576 end if;
|
|
|
577
|
|
|
578 -- If type, freeze the type
|
|
|
579
|
|
|
580 if Is_Type (E) then
|
|
|
581 Delete := Freeze_Type (N);
|
|
|
582
|
|
|
583 -- And for enumeration type, build the enumeration tables
|
|
|
584
|
|
|
585 if Is_Enumeration_Type (E) then
|
|
|
586 Build_Enumeration_Image_Tables (E, N);
|
|
|
587 end if;
|
|
|
588
|
|
|
589 -- If subprogram, freeze the subprogram
|
|
|
590
|
|
|
591 elsif Is_Subprogram (E) then
|
|
|
592 Exp_Ch6.Freeze_Subprogram (N);
|
|
|
593
|
|
|
594 -- Ada 2005 (AI-251): Remove the freezing node associated with the
|
|
|
595 -- entities internally used by the frontend to register primitives
|
|
|
596 -- covering abstract interfaces. The call to Freeze_Subprogram has
|
|
|
597 -- already expanded the code that fills the corresponding entry in
|
|
|
598 -- its secondary dispatch table and therefore the code generator
|
|
|
599 -- has nothing else to do with this freezing node.
|
|
|
600
|
|
|
601 Delete := Present (Interface_Alias (E));
|
|
|
602 end if;
|
|
|
603
|
|
|
604 -- Analyze actions generated by freezing. The init_proc contains source
|
|
|
605 -- expressions that may raise Constraint_Error, and the assignment
|
|
|
606 -- procedure for complex types needs checks on individual component
|
|
|
607 -- assignments, but all other freezing actions should be compiled with
|
|
|
608 -- all checks off.
|
|
|
609
|
|
|
610 if Present (Actions (N)) then
|
|
|
611 Decl := First (Actions (N));
|
|
|
612 while Present (Decl) loop
|
|
|
613 if Nkind (Decl) = N_Subprogram_Body
|
|
|
614 and then (Is_Init_Proc (Defining_Entity (Decl))
|
|
|
615 or else
|
|
|
616 Chars (Defining_Entity (Decl)) = Name_uAssign)
|
|
|
617 then
|
|
|
618 Analyze (Decl);
|
|
|
619
|
|
|
620 -- A subprogram body created for a renaming_as_body completes
|
|
|
621 -- a previous declaration, which may be in a different scope.
|
|
|
622 -- Establish the proper scope before analysis.
|
|
|
623
|
|
|
624 elsif Nkind (Decl) = N_Subprogram_Body
|
|
|
625 and then Present (Corresponding_Spec (Decl))
|
|
|
626 and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
|
|
|
627 then
|
|
|
628 Push_Scope (Scope (Corresponding_Spec (Decl)));
|
|
|
629 Analyze (Decl, Suppress => All_Checks);
|
|
|
630 Pop_Scope;
|
|
|
631
|
|
|
632 -- We treat generated equality specially, if validity checks are
|
|
|
633 -- enabled, in order to detect components default-initialized
|
|
|
634 -- with invalid values.
|
|
|
635
|
|
|
636 elsif Nkind (Decl) = N_Subprogram_Body
|
|
|
637 and then Chars (Defining_Entity (Decl)) = Name_Op_Eq
|
|
|
638 and then Validity_Checks_On
|
|
|
639 and then Initialize_Scalars
|
|
|
640 then
|
|
|
641 declare
|
|
|
642 Save_Force : constant Boolean := Force_Validity_Checks;
|
|
|
643 begin
|
|
|
644 Force_Validity_Checks := True;
|
|
|
645 Analyze (Decl);
|
|
|
646 Force_Validity_Checks := Save_Force;
|
|
|
647 end;
|
|
|
648
|
|
|
649 -- All other freezing actions
|
|
|
650
|
|
|
651 else
|
|
|
652 Analyze (Decl, Suppress => All_Checks);
|
|
|
653 end if;
|
|
|
654
|
|
|
655 Next (Decl);
|
|
|
656 end loop;
|
|
|
657 end if;
|
|
|
658
|
|
|
659 -- If we are to delete this N_Freeze_Entity, do so by rewriting so that
|
|
|
660 -- a loop on all nodes being inserted will work propertly.
|
|
|
661
|
|
|
662 if Delete then
|
|
|
663 Rewrite (N, Make_Null_Statement (Sloc (N)));
|
|
|
664 end if;
|
|
|
665
|
|
|
666 -- Pop scope if we installed one for the analysis
|
|
|
667
|
|
|
668 if In_Other_Scope then
|
|
|
669 if Ekind (Current_Scope) = E_Package then
|
|
|
670 End_Package_Scope (E_Scope);
|
|
|
671 else
|
|
|
672 End_Scope;
|
|
|
673 end if;
|
|
|
674
|
|
|
675 elsif In_Outer_Scope then
|
|
|
676 Pop_Scope;
|
|
|
677 end if;
|
|
|
678
|
|
|
679 -- Restore previous value of the nesting-level counter that records
|
|
|
680 -- whether we are inside a (possibly nested) call to this procedure.
|
|
|
681
|
|
|
682 Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
|
|
|
683 end Expand_N_Freeze_Entity;
|
|
|
684
|
|
|
685 -------------------------------------------
|
|
|
686 -- Expand_N_Record_Representation_Clause --
|
|
|
687 -------------------------------------------
|
|
|
688
|
|
|
689 -- The only expansion required is for the case of a mod clause present,
|
|
|
690 -- which is removed, and translated into an alignment representation
|
|
|
691 -- clause inserted immediately after the record rep clause with any
|
|
|
692 -- initial pragmas inserted at the start of the component clause list.
|
|
|
693
|
|
|
694 procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
|
|
|
695 Loc : constant Source_Ptr := Sloc (N);
|
|
|
696 Rectype : constant Entity_Id := Entity (Identifier (N));
|
|
|
697 Mod_Val : Uint;
|
|
|
698 Citems : List_Id;
|
|
|
699 Repitem : Node_Id;
|
|
|
700 AtM_Nod : Node_Id;
|
|
|
701
|
|
|
702 begin
|
|
|
703 if Present (Mod_Clause (N)) and then not Ignore_Rep_Clauses then
|
|
|
704 Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
|
|
|
705 Citems := Pragmas_Before (Mod_Clause (N));
|
|
|
706
|
|
|
707 if Present (Citems) then
|
|
|
708 Append_List_To (Citems, Component_Clauses (N));
|
|
|
709 Set_Component_Clauses (N, Citems);
|
|
|
710 end if;
|
|
|
711
|
|
|
712 AtM_Nod :=
|
|
|
713 Make_Attribute_Definition_Clause (Loc,
|
|
|
714 Name => New_Occurrence_Of (Base_Type (Rectype), Loc),
|
|
|
715 Chars => Name_Alignment,
|
|
|
716 Expression => Make_Integer_Literal (Loc, Mod_Val));
|
|
|
717
|
|
|
718 Set_From_At_Mod (AtM_Nod);
|
|
|
719 Insert_After (N, AtM_Nod);
|
|
|
720 Set_Mod_Clause (N, Empty);
|
|
|
721 end if;
|
|
|
722
|
|
|
723 -- If the record representation clause has no components, then
|
|
|
724 -- completely remove it. Note that we also have to remove
|
|
|
725 -- ourself from the Rep Item list.
|
|
|
726
|
|
|
727 if Is_Empty_List (Component_Clauses (N)) then
|
|
|
728 if First_Rep_Item (Rectype) = N then
|
|
|
729 Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
|
|
|
730 else
|
|
|
731 Repitem := First_Rep_Item (Rectype);
|
|
|
732 while Present (Next_Rep_Item (Repitem)) loop
|
|
|
733 if Next_Rep_Item (Repitem) = N then
|
|
|
734 Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
|
|
|
735 exit;
|
|
|
736 end if;
|
|
|
737
|
|
|
738 Next_Rep_Item (Repitem);
|
|
|
739 end loop;
|
|
|
740 end if;
|
|
|
741
|
|
|
742 Rewrite (N,
|
|
|
743 Make_Null_Statement (Loc));
|
|
|
744 end if;
|
|
|
745 end Expand_N_Record_Representation_Clause;
|
|
|
746
|
|
|
747 end Exp_Ch13;
|
