|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- E X P _ C H 1 3 --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, 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
|
|
145
|
223
|
|
111
|
224 declare
|
|
|
225 Assign : Node_Id;
|
|
|
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
|
|
145
|
235 -- the assignment here. Freezing rules ensure that this
|
|
111
|
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
|
|
145
|
264 -- Insert the declaration of the object. If the expression
|
|
|
265 -- is not static it may depend on some other type that is
|
|
|
266 -- not frozen yet, so attach the declaration that captures
|
|
|
267 -- the value of the expression to the actions of the freeze
|
|
|
268 -- node of the current type.
|
|
111
|
269
|
|
145
|
270 declare
|
|
|
271 Decl : constant Node_Id :=
|
|
|
272 Make_Object_Declaration (Loc,
|
|
|
273 Defining_Identifier => V,
|
|
|
274 Object_Definition =>
|
|
|
275 New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
|
|
|
276 Expression =>
|
|
|
277 Convert_To
|
|
|
278 (RTE (RE_Storage_Offset), Expression (N)));
|
|
|
279 begin
|
|
|
280 if not Is_OK_Static_Expression (Expression (N))
|
|
|
281 and then Present (Freeze_Node (Ent))
|
|
|
282 then
|
|
|
283 if No (Actions (Freeze_Node (Ent))) then
|
|
|
284 Set_Actions (Freeze_Node (Ent), New_List (Decl));
|
|
|
285 else
|
|
|
286 Append (Decl, Actions (Freeze_Node (Ent)));
|
|
|
287 end if;
|
|
|
288
|
|
|
289 else
|
|
|
290 Insert_Action (N, Decl);
|
|
|
291 end if;
|
|
|
292 end;
|
|
111
|
293
|
|
|
294 Set_Storage_Size_Variable (Ent, Entity_Id (V));
|
|
|
295 end if;
|
|
|
296 end if;
|
|
|
297
|
|
|
298 -- Other attributes require no expansion
|
|
|
299
|
|
|
300 when others =>
|
|
|
301 null;
|
|
|
302 end case;
|
|
|
303 end Expand_N_Attribute_Definition_Clause;
|
|
|
304
|
|
|
305 -----------------------------
|
|
|
306 -- Expand_N_Free_Statement --
|
|
|
307 -----------------------------
|
|
|
308
|
|
|
309 procedure Expand_N_Free_Statement (N : Node_Id) is
|
|
|
310 Expr : constant Node_Id := Expression (N);
|
|
|
311 Typ : Entity_Id;
|
|
|
312
|
|
|
313 begin
|
|
|
314 -- Certain run-time configurations and targets do not provide support
|
|
|
315 -- for controlled types.
|
|
|
316
|
|
|
317 if Restriction_Active (No_Finalization) then
|
|
|
318 return;
|
|
|
319 end if;
|
|
|
320
|
|
|
321 -- Use the base type to perform the check for finalization master
|
|
|
322
|
|
|
323 Typ := Etype (Expr);
|
|
|
324
|
|
|
325 if Ekind (Typ) = E_Access_Subtype then
|
|
|
326 Typ := Etype (Typ);
|
|
|
327 end if;
|
|
|
328
|
|
|
329 -- Handle private access types
|
|
|
330
|
|
|
331 if Is_Private_Type (Typ)
|
|
|
332 and then Present (Full_View (Typ))
|
|
|
333 then
|
|
|
334 Typ := Full_View (Typ);
|
|
|
335 end if;
|
|
|
336
|
|
|
337 -- Do not create a custom Deallocate when freeing an object with
|
|
|
338 -- suppressed finalization. In such cases the object is never attached
|
|
|
339 -- to a master, so it does not need to be detached. Use a regular free
|
|
|
340 -- statement instead.
|
|
|
341
|
|
|
342 if No (Finalization_Master (Typ)) then
|
|
|
343 return;
|
|
|
344 end if;
|
|
|
345
|
|
|
346 -- Use a temporary to store the result of a complex expression. Perform
|
|
|
347 -- the following transformation:
|
|
|
348 --
|
|
|
349 -- Free (Complex_Expression);
|
|
|
350 --
|
|
|
351 -- Temp : constant Type_Of_Expression := Complex_Expression;
|
|
|
352 -- Free (Temp);
|
|
|
353
|
|
|
354 if Nkind (Expr) /= N_Identifier then
|
|
|
355 declare
|
|
|
356 Expr_Typ : constant Entity_Id := Etype (Expr);
|
|
|
357 Loc : constant Source_Ptr := Sloc (N);
|
|
|
358 New_Expr : Node_Id;
|
|
|
359 Temp_Id : Entity_Id;
|
|
|
360
|
|
|
361 begin
|
|
|
362 Temp_Id := Make_Temporary (Loc, 'T');
|
|
|
363 Insert_Action (N,
|
|
|
364 Make_Object_Declaration (Loc,
|
|
|
365 Defining_Identifier => Temp_Id,
|
|
|
366 Object_Definition => New_Occurrence_Of (Expr_Typ, Loc),
|
|
|
367 Expression => Relocate_Node (Expr)));
|
|
|
368
|
|
|
369 New_Expr := New_Occurrence_Of (Temp_Id, Loc);
|
|
|
370 Set_Etype (New_Expr, Expr_Typ);
|
|
|
371
|
|
|
372 Set_Expression (N, New_Expr);
|
|
|
373 end;
|
|
|
374 end if;
|
|
|
375
|
|
|
376 -- Create a custom Deallocate for a controlled object. This routine
|
|
|
377 -- ensures that the hidden list header will be deallocated along with
|
|
|
378 -- the actual object.
|
|
|
379
|
|
|
380 Build_Allocate_Deallocate_Proc (N, Is_Allocate => False);
|
|
|
381 end Expand_N_Free_Statement;
|
|
|
382
|
|
|
383 ----------------------------
|
|
|
384 -- Expand_N_Freeze_Entity --
|
|
|
385 ----------------------------
|
|
|
386
|
|
|
387 procedure Expand_N_Freeze_Entity (N : Node_Id) is
|
|
|
388 E : constant Entity_Id := Entity (N);
|
|
|
389
|
|
|
390 Decl : Node_Id;
|
|
|
391 Delete : Boolean := False;
|
|
|
392 E_Scope : Entity_Id;
|
|
|
393 In_Other_Scope : Boolean;
|
|
|
394 In_Outer_Scope : Boolean;
|
|
|
395
|
|
|
396 begin
|
|
|
397 -- If there are delayed aspect specifications, we insert them just
|
|
|
398 -- before the freeze node. They are already analyzed so we don't need
|
|
|
399 -- to reanalyze them (they were analyzed before the type was frozen),
|
|
|
400 -- but we want them in the tree for the back end, and so that the
|
|
|
401 -- listing from sprint is clearer on where these occur logically.
|
|
|
402
|
|
|
403 if Has_Delayed_Aspects (E) then
|
|
|
404 declare
|
|
|
405 Aitem : Node_Id;
|
|
|
406 Ritem : Node_Id;
|
|
|
407
|
|
|
408 begin
|
|
|
409 -- Look for aspect specs for this entity
|
|
|
410
|
|
|
411 Ritem := First_Rep_Item (E);
|
|
|
412 while Present (Ritem) loop
|
|
|
413 if Nkind (Ritem) = N_Aspect_Specification
|
|
|
414 and then Entity (Ritem) = E
|
|
|
415 then
|
|
|
416 Aitem := Aspect_Rep_Item (Ritem);
|
|
|
417
|
|
|
418 -- Skip this for aspects (e.g. Current_Value) for which
|
|
|
419 -- there is no corresponding pragma or attribute.
|
|
|
420
|
|
|
421 if Present (Aitem)
|
|
|
422
|
|
|
423 -- Also skip if we have a null statement rather than a
|
|
|
424 -- delayed aspect (this happens when we are ignoring rep
|
|
|
425 -- items from use of the -gnatI switch).
|
|
|
426
|
|
|
427 and then Nkind (Aitem) /= N_Null_Statement
|
|
|
428 then
|
|
|
429 pragma Assert (Is_Delayed_Aspect (Aitem));
|
|
|
430 Insert_Before (N, Aitem);
|
|
|
431 end if;
|
|
|
432 end if;
|
|
|
433
|
|
|
434 Next_Rep_Item (Ritem);
|
|
|
435 end loop;
|
|
|
436 end;
|
|
|
437 end if;
|
|
|
438
|
|
|
439 -- Processing for objects
|
|
|
440
|
|
|
441 if Is_Object (E) then
|
|
|
442 if Present (Address_Clause (E)) then
|
|
|
443 Apply_Address_Clause_Check (E, N);
|
|
|
444 end if;
|
|
|
445
|
|
|
446 -- Analyze actions in freeze node, if any
|
|
|
447
|
|
|
448 if Present (Actions (N)) then
|
|
|
449 declare
|
|
|
450 Act : Node_Id;
|
|
|
451 begin
|
|
|
452 Act := First (Actions (N));
|
|
|
453 while Present (Act) loop
|
|
|
454 Analyze (Act);
|
|
|
455 Next (Act);
|
|
|
456 end loop;
|
|
|
457 end;
|
|
|
458 end if;
|
|
|
459
|
|
|
460 -- If initialization statements have been captured in a compound
|
|
|
461 -- statement, insert them back into the tree now.
|
|
|
462
|
|
|
463 Explode_Initialization_Compound_Statement (E);
|
|
|
464 return;
|
|
|
465
|
|
|
466 -- Only other items requiring any front end action are types and
|
|
|
467 -- subprograms.
|
|
|
468
|
|
|
469 elsif not Is_Type (E) and then not Is_Subprogram (E) then
|
|
|
470 return;
|
|
|
471 end if;
|
|
|
472
|
|
|
473 -- Here E is a type or a subprogram
|
|
|
474
|
|
|
475 E_Scope := Scope (E);
|
|
|
476
|
|
|
477 -- This is an error protection against previous errors
|
|
|
478
|
|
|
479 if No (E_Scope) then
|
|
|
480 Check_Error_Detected;
|
|
|
481 return;
|
|
|
482 end if;
|
|
|
483
|
|
|
484 -- The entity may be a subtype declared for a constrained record
|
|
|
485 -- component, in which case the relevant scope is the scope of
|
|
|
486 -- the record. This happens for class-wide subtypes created for
|
|
|
487 -- a constrained type extension with inherited discriminants.
|
|
|
488
|
|
|
489 if Is_Type (E_Scope)
|
|
|
490 and then Ekind (E_Scope) not in Concurrent_Kind
|
|
|
491 then
|
|
|
492 E_Scope := Scope (E_Scope);
|
|
131
|
493
|
|
|
494 -- The entity may be a subtype declared for an iterator
|
|
|
495
|
|
|
496 elsif Ekind (E_Scope) = E_Loop then
|
|
|
497 E_Scope := Scope (E_Scope);
|
|
111
|
498 end if;
|
|
|
499
|
|
|
500 -- Remember that we are processing a freezing entity and its freezing
|
|
|
501 -- nodes. This flag (non-zero = set) is used to avoid the need of
|
|
|
502 -- climbing through the tree while processing the freezing actions (ie.
|
|
|
503 -- to avoid generating spurious warnings or to avoid killing constant
|
|
|
504 -- indications while processing the code associated with freezing
|
|
|
505 -- actions). We use a counter to deal with nesting.
|
|
|
506
|
|
|
507 Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
|
|
|
508
|
|
|
509 -- If we are freezing entities defined in protected types, they belong
|
|
|
510 -- in the enclosing scope, given that the original type has been
|
|
|
511 -- expanded away. The same is true for entities in task types, in
|
|
|
512 -- particular the parameter records of entries (Entities in bodies are
|
|
|
513 -- all frozen within the body). If we are in the task body, this is a
|
|
|
514 -- proper scope. If we are within a subprogram body, the proper scope
|
|
|
515 -- is the corresponding spec. This may happen for itypes generated in
|
|
|
516 -- the bodies of protected operations.
|
|
|
517
|
|
|
518 if Ekind (E_Scope) = E_Protected_Type
|
|
|
519 or else (Ekind (E_Scope) = E_Task_Type
|
|
|
520 and then not Has_Completion (E_Scope))
|
|
|
521 then
|
|
|
522 E_Scope := Scope (E_Scope);
|
|
|
523
|
|
|
524 elsif Ekind (E_Scope) = E_Subprogram_Body then
|
|
|
525 E_Scope := Corresponding_Spec (Unit_Declaration_Node (E_Scope));
|
|
|
526 end if;
|
|
|
527
|
|
|
528 -- If the scope of the entity is in open scopes, it is the current one
|
|
|
529 -- or an enclosing one, including a loop, a block, or a subprogram.
|
|
|
530
|
|
|
531 if In_Open_Scopes (E_Scope) then
|
|
|
532 In_Other_Scope := False;
|
|
|
533 In_Outer_Scope := E_Scope /= Current_Scope;
|
|
|
534
|
|
|
535 -- Otherwise it is a local package or a different compilation unit
|
|
|
536
|
|
|
537 else
|
|
|
538 In_Other_Scope := True;
|
|
|
539 In_Outer_Scope := False;
|
|
|
540 end if;
|
|
|
541
|
|
|
542 -- If the entity being frozen is defined in a scope that is not
|
|
|
543 -- currently on the scope stack, we must establish the proper
|
|
|
544 -- visibility before freezing the entity and related subprograms.
|
|
|
545
|
|
|
546 if In_Other_Scope then
|
|
|
547 Push_Scope (E_Scope);
|
|
|
548
|
|
|
549 -- Finalizers are little odd in terms of freezing. The spec of the
|
|
|
550 -- procedure appears in the declarations while the body appears in
|
|
|
551 -- the statement part of a single construct. Since the finalizer must
|
|
|
552 -- be called by the At_End handler of the construct, the spec is
|
|
|
553 -- manually frozen right after its declaration. The only side effect
|
|
|
554 -- of this action appears in contexts where the construct is not in
|
|
|
555 -- its final resting place. These contexts are:
|
|
|
556
|
|
|
557 -- * Entry bodies - The declarations and statements are moved to
|
|
|
558 -- the procedure equivalen of the entry.
|
|
|
559 -- * Protected subprograms - The declarations and statements are
|
|
|
560 -- moved to the non-protected version of the subprogram.
|
|
|
561 -- * Task bodies - The declarations and statements are moved to the
|
|
|
562 -- task body procedure.
|
|
145
|
563 -- * Blocks that will be rewritten as subprograms when unnesting
|
|
|
564 -- is in effect.
|
|
111
|
565
|
|
|
566 -- Visible declarations do not need to be installed in these three
|
|
|
567 -- cases since it does not make semantic sense to do so. All entities
|
|
|
568 -- referenced by a finalizer are visible and already resolved, plus
|
|
|
569 -- the enclosing scope may not have visible declarations at all.
|
|
|
570
|
|
|
571 if Ekind (E) = E_Procedure
|
|
|
572 and then Is_Finalizer (E)
|
|
|
573 and then
|
|
|
574 (Is_Entry (E_Scope)
|
|
|
575 or else (Is_Subprogram (E_Scope)
|
|
|
576 and then Is_Protected_Type (Scope (E_Scope)))
|
|
145
|
577 or else Is_Task_Type (E_Scope)
|
|
|
578 or else Ekind (E_Scope) = E_Block)
|
|
111
|
579 then
|
|
|
580 null;
|
|
|
581 else
|
|
|
582 Install_Visible_Declarations (E_Scope);
|
|
|
583 end if;
|
|
|
584
|
|
|
585 if Is_Package_Or_Generic_Package (E_Scope) or else
|
|
|
586 Is_Protected_Type (E_Scope) or else
|
|
|
587 Is_Task_Type (E_Scope)
|
|
|
588 then
|
|
|
589 Install_Private_Declarations (E_Scope);
|
|
|
590 end if;
|
|
|
591
|
|
|
592 -- If the entity is in an outer scope, then that scope needs to
|
|
|
593 -- temporarily become the current scope so that operations created
|
|
|
594 -- during type freezing will be declared in the right scope and
|
|
|
595 -- can properly override any corresponding inherited operations.
|
|
|
596
|
|
|
597 elsif In_Outer_Scope then
|
|
|
598 Push_Scope (E_Scope);
|
|
|
599 end if;
|
|
|
600
|
|
|
601 -- If type, freeze the type
|
|
|
602
|
|
|
603 if Is_Type (E) then
|
|
|
604 Delete := Freeze_Type (N);
|
|
|
605
|
|
|
606 -- And for enumeration type, build the enumeration tables
|
|
|
607
|
|
|
608 if Is_Enumeration_Type (E) then
|
|
|
609 Build_Enumeration_Image_Tables (E, N);
|
|
|
610 end if;
|
|
|
611
|
|
|
612 -- If subprogram, freeze the subprogram
|
|
|
613
|
|
|
614 elsif Is_Subprogram (E) then
|
|
|
615 Exp_Ch6.Freeze_Subprogram (N);
|
|
|
616
|
|
|
617 -- Ada 2005 (AI-251): Remove the freezing node associated with the
|
|
|
618 -- entities internally used by the frontend to register primitives
|
|
|
619 -- covering abstract interfaces. The call to Freeze_Subprogram has
|
|
|
620 -- already expanded the code that fills the corresponding entry in
|
|
|
621 -- its secondary dispatch table and therefore the code generator
|
|
|
622 -- has nothing else to do with this freezing node.
|
|
|
623
|
|
|
624 Delete := Present (Interface_Alias (E));
|
|
|
625 end if;
|
|
|
626
|
|
|
627 -- Analyze actions generated by freezing. The init_proc contains source
|
|
|
628 -- expressions that may raise Constraint_Error, and the assignment
|
|
|
629 -- procedure for complex types needs checks on individual component
|
|
|
630 -- assignments, but all other freezing actions should be compiled with
|
|
|
631 -- all checks off.
|
|
|
632
|
|
|
633 if Present (Actions (N)) then
|
|
|
634 Decl := First (Actions (N));
|
|
|
635 while Present (Decl) loop
|
|
|
636 if Nkind (Decl) = N_Subprogram_Body
|
|
|
637 and then (Is_Init_Proc (Defining_Entity (Decl))
|
|
|
638 or else
|
|
|
639 Chars (Defining_Entity (Decl)) = Name_uAssign)
|
|
|
640 then
|
|
|
641 Analyze (Decl);
|
|
|
642
|
|
|
643 -- A subprogram body created for a renaming_as_body completes
|
|
|
644 -- a previous declaration, which may be in a different scope.
|
|
|
645 -- Establish the proper scope before analysis.
|
|
|
646
|
|
|
647 elsif Nkind (Decl) = N_Subprogram_Body
|
|
|
648 and then Present (Corresponding_Spec (Decl))
|
|
|
649 and then Scope (Corresponding_Spec (Decl)) /= Current_Scope
|
|
|
650 then
|
|
|
651 Push_Scope (Scope (Corresponding_Spec (Decl)));
|
|
|
652 Analyze (Decl, Suppress => All_Checks);
|
|
|
653 Pop_Scope;
|
|
|
654
|
|
|
655 -- We treat generated equality specially, if validity checks are
|
|
|
656 -- enabled, in order to detect components default-initialized
|
|
|
657 -- with invalid values.
|
|
|
658
|
|
|
659 elsif Nkind (Decl) = N_Subprogram_Body
|
|
|
660 and then Chars (Defining_Entity (Decl)) = Name_Op_Eq
|
|
|
661 and then Validity_Checks_On
|
|
|
662 and then Initialize_Scalars
|
|
|
663 then
|
|
|
664 declare
|
|
|
665 Save_Force : constant Boolean := Force_Validity_Checks;
|
|
|
666 begin
|
|
|
667 Force_Validity_Checks := True;
|
|
|
668 Analyze (Decl);
|
|
|
669 Force_Validity_Checks := Save_Force;
|
|
|
670 end;
|
|
|
671
|
|
|
672 -- All other freezing actions
|
|
|
673
|
|
|
674 else
|
|
|
675 Analyze (Decl, Suppress => All_Checks);
|
|
|
676 end if;
|
|
|
677
|
|
|
678 Next (Decl);
|
|
|
679 end loop;
|
|
|
680 end if;
|
|
|
681
|
|
|
682 -- If we are to delete this N_Freeze_Entity, do so by rewriting so that
|
|
|
683 -- a loop on all nodes being inserted will work propertly.
|
|
|
684
|
|
|
685 if Delete then
|
|
|
686 Rewrite (N, Make_Null_Statement (Sloc (N)));
|
|
|
687 end if;
|
|
|
688
|
|
|
689 -- Pop scope if we installed one for the analysis
|
|
|
690
|
|
|
691 if In_Other_Scope then
|
|
|
692 if Ekind (Current_Scope) = E_Package then
|
|
|
693 End_Package_Scope (E_Scope);
|
|
|
694 else
|
|
|
695 End_Scope;
|
|
|
696 end if;
|
|
|
697
|
|
|
698 elsif In_Outer_Scope then
|
|
|
699 Pop_Scope;
|
|
|
700 end if;
|
|
|
701
|
|
|
702 -- Restore previous value of the nesting-level counter that records
|
|
|
703 -- whether we are inside a (possibly nested) call to this procedure.
|
|
|
704
|
|
|
705 Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
|
|
|
706 end Expand_N_Freeze_Entity;
|
|
|
707
|
|
|
708 -------------------------------------------
|
|
|
709 -- Expand_N_Record_Representation_Clause --
|
|
|
710 -------------------------------------------
|
|
|
711
|
|
|
712 -- The only expansion required is for the case of a mod clause present,
|
|
|
713 -- which is removed, and translated into an alignment representation
|
|
|
714 -- clause inserted immediately after the record rep clause with any
|
|
|
715 -- initial pragmas inserted at the start of the component clause list.
|
|
|
716
|
|
|
717 procedure Expand_N_Record_Representation_Clause (N : Node_Id) is
|
|
|
718 Loc : constant Source_Ptr := Sloc (N);
|
|
|
719 Rectype : constant Entity_Id := Entity (Identifier (N));
|
|
|
720 Mod_Val : Uint;
|
|
|
721 Citems : List_Id;
|
|
|
722 Repitem : Node_Id;
|
|
|
723 AtM_Nod : Node_Id;
|
|
|
724
|
|
|
725 begin
|
|
|
726 if Present (Mod_Clause (N)) and then not Ignore_Rep_Clauses then
|
|
|
727 Mod_Val := Expr_Value (Expression (Mod_Clause (N)));
|
|
|
728 Citems := Pragmas_Before (Mod_Clause (N));
|
|
|
729
|
|
|
730 if Present (Citems) then
|
|
|
731 Append_List_To (Citems, Component_Clauses (N));
|
|
|
732 Set_Component_Clauses (N, Citems);
|
|
|
733 end if;
|
|
|
734
|
|
|
735 AtM_Nod :=
|
|
|
736 Make_Attribute_Definition_Clause (Loc,
|
|
|
737 Name => New_Occurrence_Of (Base_Type (Rectype), Loc),
|
|
|
738 Chars => Name_Alignment,
|
|
|
739 Expression => Make_Integer_Literal (Loc, Mod_Val));
|
|
|
740
|
|
|
741 Set_From_At_Mod (AtM_Nod);
|
|
|
742 Insert_After (N, AtM_Nod);
|
|
|
743 Set_Mod_Clause (N, Empty);
|
|
|
744 end if;
|
|
|
745
|
|
|
746 -- If the record representation clause has no components, then
|
|
145
|
747 -- completely remove it. Note that we also have to remove
|
|
111
|
748 -- ourself from the Rep Item list.
|
|
|
749
|
|
|
750 if Is_Empty_List (Component_Clauses (N)) then
|
|
|
751 if First_Rep_Item (Rectype) = N then
|
|
|
752 Set_First_Rep_Item (Rectype, Next_Rep_Item (N));
|
|
|
753 else
|
|
|
754 Repitem := First_Rep_Item (Rectype);
|
|
|
755 while Present (Next_Rep_Item (Repitem)) loop
|
|
|
756 if Next_Rep_Item (Repitem) = N then
|
|
|
757 Set_Next_Rep_Item (Repitem, Next_Rep_Item (N));
|
|
|
758 exit;
|
|
|
759 end if;
|
|
|
760
|
|
|
761 Next_Rep_Item (Repitem);
|
|
|
762 end loop;
|
|
|
763 end if;
|
|
|
764
|
|
|
765 Rewrite (N,
|
|
|
766 Make_Null_Statement (Loc));
|
|
|
767 end if;
|
|
|
768 end Expand_N_Record_Representation_Clause;
|
|
|
769
|
|
|
770 end Exp_Ch13;
|
