Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/freeze.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 ------------------------------------------------------------------------------ | |
2 -- -- | |
3 -- GNAT COMPILER COMPONENTS -- | |
4 -- -- | |
5 -- F R E E Z E -- | |
6 -- -- | |
7 -- B o d y -- | |
8 -- -- | |
9 -- Copyright (C) 1992-2017, 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 ------------------------------------------------------------------------------ | |
25 | |
26 with Aspects; use Aspects; | |
27 with Atree; use Atree; | |
28 with Checks; use Checks; | |
29 with Contracts; use Contracts; | |
30 with Debug; use Debug; | |
31 with Einfo; use Einfo; | |
32 with Elists; use Elists; | |
33 with Errout; use Errout; | |
34 with Exp_Ch3; use Exp_Ch3; | |
35 with Exp_Ch7; use Exp_Ch7; | |
36 with Exp_Disp; use Exp_Disp; | |
37 with Exp_Pakd; use Exp_Pakd; | |
38 with Exp_Util; use Exp_Util; | |
39 with Exp_Tss; use Exp_Tss; | |
40 with Ghost; use Ghost; | |
41 with Layout; use Layout; | |
42 with Lib; use Lib; | |
43 with Namet; use Namet; | |
44 with Nlists; use Nlists; | |
45 with Nmake; use Nmake; | |
46 with Opt; use Opt; | |
47 with Restrict; use Restrict; | |
48 with Rident; use Rident; | |
49 with Rtsfind; use Rtsfind; | |
50 with Sem; use Sem; | |
51 with Sem_Aux; use Sem_Aux; | |
52 with Sem_Cat; use Sem_Cat; | |
53 with Sem_Ch6; use Sem_Ch6; | |
54 with Sem_Ch7; use Sem_Ch7; | |
55 with Sem_Ch8; use Sem_Ch8; | |
56 with Sem_Ch13; use Sem_Ch13; | |
57 with Sem_Eval; use Sem_Eval; | |
58 with Sem_Mech; use Sem_Mech; | |
59 with Sem_Prag; use Sem_Prag; | |
60 with Sem_Res; use Sem_Res; | |
61 with Sem_Util; use Sem_Util; | |
62 with Sinfo; use Sinfo; | |
63 with Snames; use Snames; | |
64 with Stand; use Stand; | |
65 with Targparm; use Targparm; | |
66 with Tbuild; use Tbuild; | |
67 with Ttypes; use Ttypes; | |
68 with Uintp; use Uintp; | |
69 with Urealp; use Urealp; | |
70 with Warnsw; use Warnsw; | |
71 | |
72 package body Freeze is | |
73 | |
74 ----------------------- | |
75 -- Local Subprograms -- | |
76 ----------------------- | |
77 | |
78 procedure Adjust_Esize_For_Alignment (Typ : Entity_Id); | |
79 -- Typ is a type that is being frozen. If no size clause is given, | |
80 -- but a default Esize has been computed, then this default Esize is | |
81 -- adjusted up if necessary to be consistent with a given alignment, | |
82 -- but never to a value greater than Long_Long_Integer'Size. This | |
83 -- is used for all discrete types and for fixed-point types. | |
84 | |
85 procedure Build_And_Analyze_Renamed_Body | |
86 (Decl : Node_Id; | |
87 New_S : Entity_Id; | |
88 After : in out Node_Id); | |
89 -- Build body for a renaming declaration, insert in tree and analyze | |
90 | |
91 procedure Check_Address_Clause (E : Entity_Id); | |
92 -- Apply legality checks to address clauses for object declarations, | |
93 -- at the point the object is frozen. Also ensure any initialization is | |
94 -- performed only after the object has been frozen. | |
95 | |
96 procedure Check_Component_Storage_Order | |
97 (Encl_Type : Entity_Id; | |
98 Comp : Entity_Id; | |
99 ADC : Node_Id; | |
100 Comp_ADC_Present : out Boolean); | |
101 -- For an Encl_Type that has a Scalar_Storage_Order attribute definition | |
102 -- clause, verify that the component type has an explicit and compatible | |
103 -- attribute/aspect. For arrays, Comp is Empty; for records, it is the | |
104 -- entity of the component under consideration. For an Encl_Type that | |
105 -- does not have a Scalar_Storage_Order attribute definition clause, | |
106 -- verify that the component also does not have such a clause. | |
107 -- ADC is the attribute definition clause if present (or Empty). On return, | |
108 -- Comp_ADC_Present is set True if the component has a Scalar_Storage_Order | |
109 -- attribute definition clause. | |
110 | |
111 procedure Check_Debug_Info_Needed (T : Entity_Id); | |
112 -- As each entity is frozen, this routine is called to deal with the | |
113 -- setting of Debug_Info_Needed for the entity. This flag is set if | |
114 -- the entity comes from source, or if we are in Debug_Generated_Code | |
115 -- mode or if the -gnatdV debug flag is set. However, it never sets | |
116 -- the flag if Debug_Info_Off is set. This procedure also ensures that | |
117 -- subsidiary entities have the flag set as required. | |
118 | |
119 procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id); | |
120 -- When an expression function is frozen by a use of it, the expression | |
121 -- itself is frozen. Check that the expression does not include references | |
122 -- to deferred constants without completion. We report this at the freeze | |
123 -- point of the function, to provide a better error message. | |
124 -- | |
125 -- In most cases the expression itself is frozen by the time the function | |
126 -- itself is frozen, because the formals will be frozen by then. However, | |
127 -- Attribute references to outer types are freeze points for those types; | |
128 -- this routine generates the required freeze nodes for them. | |
129 | |
130 procedure Check_Inherited_Conditions (R : Entity_Id); | |
131 -- For a tagged derived type, create wrappers for inherited operations | |
132 -- that have a class-wide condition, so it can be properly rewritten if | |
133 -- it involves calls to other overriding primitives. | |
134 | |
135 procedure Check_Strict_Alignment (E : Entity_Id); | |
136 -- E is a base type. If E is tagged or has a component that is aliased | |
137 -- or tagged or contains something this is aliased or tagged, set | |
138 -- Strict_Alignment. | |
139 | |
140 procedure Check_Unsigned_Type (E : Entity_Id); | |
141 pragma Inline (Check_Unsigned_Type); | |
142 -- If E is a fixed-point or discrete type, then all the necessary work | |
143 -- to freeze it is completed except for possible setting of the flag | |
144 -- Is_Unsigned_Type, which is done by this procedure. The call has no | |
145 -- effect if the entity E is not a discrete or fixed-point type. | |
146 | |
147 procedure Freeze_And_Append | |
148 (Ent : Entity_Id; | |
149 N : Node_Id; | |
150 Result : in out List_Id); | |
151 -- Freezes Ent using Freeze_Entity, and appends the resulting list of | |
152 -- nodes to Result, modifying Result from No_List if necessary. N has | |
153 -- the same usage as in Freeze_Entity. | |
154 | |
155 procedure Freeze_Enumeration_Type (Typ : Entity_Id); | |
156 -- Freeze enumeration type. The Esize field is set as processing | |
157 -- proceeds (i.e. set by default when the type is declared and then | |
158 -- adjusted by rep clauses. What this procedure does is to make sure | |
159 -- that if a foreign convention is specified, and no specific size | |
160 -- is given, then the size must be at least Integer'Size. | |
161 | |
162 procedure Freeze_Static_Object (E : Entity_Id); | |
163 -- If an object is frozen which has Is_Statically_Allocated set, then | |
164 -- all referenced types must also be marked with this flag. This routine | |
165 -- is in charge of meeting this requirement for the object entity E. | |
166 | |
167 procedure Freeze_Subprogram (E : Entity_Id); | |
168 -- Perform freezing actions for a subprogram (create extra formals, | |
169 -- and set proper default mechanism values). Note that this routine | |
170 -- is not called for internal subprograms, for which neither of these | |
171 -- actions is needed (or desirable, we do not want for example to have | |
172 -- these extra formals present in initialization procedures, where they | |
173 -- would serve no purpose). In this call E is either a subprogram or | |
174 -- a subprogram type (i.e. an access to a subprogram). | |
175 | |
176 function Is_Fully_Defined (T : Entity_Id) return Boolean; | |
177 -- True if T is not private and has no private components, or has a full | |
178 -- view. Used to determine whether the designated type of an access type | |
179 -- should be frozen when the access type is frozen. This is done when an | |
180 -- allocator is frozen, or an expression that may involve attributes of | |
181 -- the designated type. Otherwise freezing the access type does not freeze | |
182 -- the designated type. | |
183 | |
184 procedure Process_Default_Expressions | |
185 (E : Entity_Id; | |
186 After : in out Node_Id); | |
187 -- This procedure is called for each subprogram to complete processing of | |
188 -- default expressions at the point where all types are known to be frozen. | |
189 -- The expressions must be analyzed in full, to make sure that all error | |
190 -- processing is done (they have only been pre-analyzed). If the expression | |
191 -- is not an entity or literal, its analysis may generate code which must | |
192 -- not be executed. In that case we build a function body to hold that | |
193 -- code. This wrapper function serves no other purpose (it used to be | |
194 -- called to evaluate the default, but now the default is inlined at each | |
195 -- point of call). | |
196 | |
197 procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id); | |
198 -- Typ is a record or array type that is being frozen. This routine sets | |
199 -- the default component alignment from the scope stack values if the | |
200 -- alignment is otherwise not specified. | |
201 | |
202 procedure Set_SSO_From_Default (T : Entity_Id); | |
203 -- T is a record or array type that is being frozen. If it is a base type, | |
204 -- and if SSO_Set_Low/High_By_Default is set, then Reverse_Storage order | |
205 -- will be set appropriately. Note that an explicit occurrence of aspect | |
206 -- Scalar_Storage_Order or an explicit setting of this aspect with an | |
207 -- attribute definition clause occurs, then these two flags are reset in | |
208 -- any case, so call will have no effect. | |
209 | |
210 procedure Undelay_Type (T : Entity_Id); | |
211 -- T is a type of a component that we know to be an Itype. We don't want | |
212 -- this to have a Freeze_Node, so ensure it doesn't. Do the same for any | |
213 -- Full_View or Corresponding_Record_Type. | |
214 | |
215 procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Node_Id); | |
216 -- Expr is the expression for an address clause for entity Nam whose type | |
217 -- is Typ. If Typ has a default initialization, and there is no explicit | |
218 -- initialization in the source declaration, check whether the address | |
219 -- clause might cause overlaying of an entity, and emit a warning on the | |
220 -- side effect that the initialization will cause. | |
221 | |
222 ------------------------------- | |
223 -- Adjust_Esize_For_Alignment -- | |
224 ------------------------------- | |
225 | |
226 procedure Adjust_Esize_For_Alignment (Typ : Entity_Id) is | |
227 Align : Uint; | |
228 | |
229 begin | |
230 if Known_Esize (Typ) and then Known_Alignment (Typ) then | |
231 Align := Alignment_In_Bits (Typ); | |
232 | |
233 if Align > Esize (Typ) | |
234 and then Align <= Standard_Long_Long_Integer_Size | |
235 then | |
236 Set_Esize (Typ, Align); | |
237 end if; | |
238 end if; | |
239 end Adjust_Esize_For_Alignment; | |
240 | |
241 ------------------------------------ | |
242 -- Build_And_Analyze_Renamed_Body -- | |
243 ------------------------------------ | |
244 | |
245 procedure Build_And_Analyze_Renamed_Body | |
246 (Decl : Node_Id; | |
247 New_S : Entity_Id; | |
248 After : in out Node_Id) | |
249 is | |
250 Body_Decl : constant Node_Id := Unit_Declaration_Node (New_S); | |
251 Ent : constant Entity_Id := Defining_Entity (Decl); | |
252 Body_Node : Node_Id; | |
253 Renamed_Subp : Entity_Id; | |
254 | |
255 begin | |
256 -- If the renamed subprogram is intrinsic, there is no need for a | |
257 -- wrapper body: we set the alias that will be called and expanded which | |
258 -- completes the declaration. This transformation is only legal if the | |
259 -- renamed entity has already been elaborated. | |
260 | |
261 -- Note that it is legal for a renaming_as_body to rename an intrinsic | |
262 -- subprogram, as long as the renaming occurs before the new entity | |
263 -- is frozen (RM 8.5.4 (5)). | |
264 | |
265 if Nkind (Body_Decl) = N_Subprogram_Renaming_Declaration | |
266 and then Is_Entity_Name (Name (Body_Decl)) | |
267 then | |
268 Renamed_Subp := Entity (Name (Body_Decl)); | |
269 else | |
270 Renamed_Subp := Empty; | |
271 end if; | |
272 | |
273 if Present (Renamed_Subp) | |
274 and then Is_Intrinsic_Subprogram (Renamed_Subp) | |
275 and then | |
276 (not In_Same_Source_Unit (Renamed_Subp, Ent) | |
277 or else Sloc (Renamed_Subp) < Sloc (Ent)) | |
278 | |
279 -- We can make the renaming entity intrinsic if the renamed function | |
280 -- has an interface name, or if it is one of the shift/rotate | |
281 -- operations known to the compiler. | |
282 | |
283 and then | |
284 (Present (Interface_Name (Renamed_Subp)) | |
285 or else Nam_In (Chars (Renamed_Subp), Name_Rotate_Left, | |
286 Name_Rotate_Right, | |
287 Name_Shift_Left, | |
288 Name_Shift_Right, | |
289 Name_Shift_Right_Arithmetic)) | |
290 then | |
291 Set_Interface_Name (Ent, Interface_Name (Renamed_Subp)); | |
292 | |
293 if Present (Alias (Renamed_Subp)) then | |
294 Set_Alias (Ent, Alias (Renamed_Subp)); | |
295 else | |
296 Set_Alias (Ent, Renamed_Subp); | |
297 end if; | |
298 | |
299 Set_Is_Intrinsic_Subprogram (Ent); | |
300 Set_Has_Completion (Ent); | |
301 | |
302 else | |
303 Body_Node := Build_Renamed_Body (Decl, New_S); | |
304 Insert_After (After, Body_Node); | |
305 Mark_Rewrite_Insertion (Body_Node); | |
306 Analyze (Body_Node); | |
307 After := Body_Node; | |
308 end if; | |
309 end Build_And_Analyze_Renamed_Body; | |
310 | |
311 ------------------------ | |
312 -- Build_Renamed_Body -- | |
313 ------------------------ | |
314 | |
315 function Build_Renamed_Body | |
316 (Decl : Node_Id; | |
317 New_S : Entity_Id) return Node_Id | |
318 is | |
319 Loc : constant Source_Ptr := Sloc (New_S); | |
320 -- We use for the source location of the renamed body, the location of | |
321 -- the spec entity. It might seem more natural to use the location of | |
322 -- the renaming declaration itself, but that would be wrong, since then | |
323 -- the body we create would look as though it was created far too late, | |
324 -- and this could cause problems with elaboration order analysis, | |
325 -- particularly in connection with instantiations. | |
326 | |
327 N : constant Node_Id := Unit_Declaration_Node (New_S); | |
328 Nam : constant Node_Id := Name (N); | |
329 Old_S : Entity_Id; | |
330 Spec : constant Node_Id := New_Copy_Tree (Specification (Decl)); | |
331 Actuals : List_Id := No_List; | |
332 Call_Node : Node_Id; | |
333 Call_Name : Node_Id; | |
334 Body_Node : Node_Id; | |
335 Formal : Entity_Id; | |
336 O_Formal : Entity_Id; | |
337 Param_Spec : Node_Id; | |
338 | |
339 Pref : Node_Id := Empty; | |
340 -- If the renamed entity is a primitive operation given in prefix form, | |
341 -- the prefix is the target object and it has to be added as the first | |
342 -- actual in the generated call. | |
343 | |
344 begin | |
345 -- Determine the entity being renamed, which is the target of the call | |
346 -- statement. If the name is an explicit dereference, this is a renaming | |
347 -- of a subprogram type rather than a subprogram. The name itself is | |
348 -- fully analyzed. | |
349 | |
350 if Nkind (Nam) = N_Selected_Component then | |
351 Old_S := Entity (Selector_Name (Nam)); | |
352 | |
353 elsif Nkind (Nam) = N_Explicit_Dereference then | |
354 Old_S := Etype (Nam); | |
355 | |
356 elsif Nkind (Nam) = N_Indexed_Component then | |
357 if Is_Entity_Name (Prefix (Nam)) then | |
358 Old_S := Entity (Prefix (Nam)); | |
359 else | |
360 Old_S := Entity (Selector_Name (Prefix (Nam))); | |
361 end if; | |
362 | |
363 elsif Nkind (Nam) = N_Character_Literal then | |
364 Old_S := Etype (New_S); | |
365 | |
366 else | |
367 Old_S := Entity (Nam); | |
368 end if; | |
369 | |
370 if Is_Entity_Name (Nam) then | |
371 | |
372 -- If the renamed entity is a predefined operator, retain full name | |
373 -- to ensure its visibility. | |
374 | |
375 if Ekind (Old_S) = E_Operator | |
376 and then Nkind (Nam) = N_Expanded_Name | |
377 then | |
378 Call_Name := New_Copy (Name (N)); | |
379 else | |
380 Call_Name := New_Occurrence_Of (Old_S, Loc); | |
381 end if; | |
382 | |
383 else | |
384 if Nkind (Nam) = N_Selected_Component | |
385 and then Present (First_Formal (Old_S)) | |
386 and then | |
387 (Is_Controlling_Formal (First_Formal (Old_S)) | |
388 or else Is_Class_Wide_Type (Etype (First_Formal (Old_S)))) | |
389 then | |
390 | |
391 -- Retrieve the target object, to be added as a first actual | |
392 -- in the call. | |
393 | |
394 Call_Name := New_Occurrence_Of (Old_S, Loc); | |
395 Pref := Prefix (Nam); | |
396 | |
397 else | |
398 Call_Name := New_Copy (Name (N)); | |
399 end if; | |
400 | |
401 -- Original name may have been overloaded, but is fully resolved now | |
402 | |
403 Set_Is_Overloaded (Call_Name, False); | |
404 end if; | |
405 | |
406 -- For simple renamings, subsequent calls can be expanded directly as | |
407 -- calls to the renamed entity. The body must be generated in any case | |
408 -- for calls that may appear elsewhere. This is not done in the case | |
409 -- where the subprogram is an instantiation because the actual proper | |
410 -- body has not been built yet. | |
411 | |
412 if Ekind_In (Old_S, E_Function, E_Procedure) | |
413 and then Nkind (Decl) = N_Subprogram_Declaration | |
414 and then not Is_Generic_Instance (Old_S) | |
415 then | |
416 Set_Body_To_Inline (Decl, Old_S); | |
417 end if; | |
418 | |
419 -- Check whether the return type is a limited view. If the subprogram | |
420 -- is already frozen the generated body may have a non-limited view | |
421 -- of the type, that must be used, because it is the one in the spec | |
422 -- of the renaming declaration. | |
423 | |
424 if Ekind (Old_S) = E_Function | |
425 and then Is_Entity_Name (Result_Definition (Spec)) | |
426 then | |
427 declare | |
428 Ret_Type : constant Entity_Id := Etype (Result_Definition (Spec)); | |
429 begin | |
430 if Has_Non_Limited_View (Ret_Type) then | |
431 Set_Result_Definition | |
432 (Spec, New_Occurrence_Of (Non_Limited_View (Ret_Type), Loc)); | |
433 end if; | |
434 end; | |
435 end if; | |
436 | |
437 -- The body generated for this renaming is an internal artifact, and | |
438 -- does not constitute a freeze point for the called entity. | |
439 | |
440 Set_Must_Not_Freeze (Call_Name); | |
441 | |
442 Formal := First_Formal (Defining_Entity (Decl)); | |
443 | |
444 if Present (Pref) then | |
445 declare | |
446 Pref_Type : constant Entity_Id := Etype (Pref); | |
447 Form_Type : constant Entity_Id := Etype (First_Formal (Old_S)); | |
448 | |
449 begin | |
450 -- The controlling formal may be an access parameter, or the | |
451 -- actual may be an access value, so adjust accordingly. | |
452 | |
453 if Is_Access_Type (Pref_Type) | |
454 and then not Is_Access_Type (Form_Type) | |
455 then | |
456 Actuals := New_List | |
457 (Make_Explicit_Dereference (Loc, Relocate_Node (Pref))); | |
458 | |
459 elsif Is_Access_Type (Form_Type) | |
460 and then not Is_Access_Type (Pref) | |
461 then | |
462 Actuals := | |
463 New_List ( | |
464 Make_Attribute_Reference (Loc, | |
465 Attribute_Name => Name_Access, | |
466 Prefix => Relocate_Node (Pref))); | |
467 else | |
468 Actuals := New_List (Pref); | |
469 end if; | |
470 end; | |
471 | |
472 elsif Present (Formal) then | |
473 Actuals := New_List; | |
474 | |
475 else | |
476 Actuals := No_List; | |
477 end if; | |
478 | |
479 if Present (Formal) then | |
480 while Present (Formal) loop | |
481 Append (New_Occurrence_Of (Formal, Loc), Actuals); | |
482 Next_Formal (Formal); | |
483 end loop; | |
484 end if; | |
485 | |
486 -- If the renamed entity is an entry, inherit its profile. For other | |
487 -- renamings as bodies, both profiles must be subtype conformant, so it | |
488 -- is not necessary to replace the profile given in the declaration. | |
489 -- However, default values that are aggregates are rewritten when | |
490 -- partially analyzed, so we recover the original aggregate to insure | |
491 -- that subsequent conformity checking works. Similarly, if the default | |
492 -- expression was constant-folded, recover the original expression. | |
493 | |
494 Formal := First_Formal (Defining_Entity (Decl)); | |
495 | |
496 if Present (Formal) then | |
497 O_Formal := First_Formal (Old_S); | |
498 Param_Spec := First (Parameter_Specifications (Spec)); | |
499 while Present (Formal) loop | |
500 if Is_Entry (Old_S) then | |
501 if Nkind (Parameter_Type (Param_Spec)) /= | |
502 N_Access_Definition | |
503 then | |
504 Set_Etype (Formal, Etype (O_Formal)); | |
505 Set_Entity (Parameter_Type (Param_Spec), Etype (O_Formal)); | |
506 end if; | |
507 | |
508 elsif Nkind (Default_Value (O_Formal)) = N_Aggregate | |
509 or else Nkind (Original_Node (Default_Value (O_Formal))) /= | |
510 Nkind (Default_Value (O_Formal)) | |
511 then | |
512 Set_Expression (Param_Spec, | |
513 New_Copy_Tree (Original_Node (Default_Value (O_Formal)))); | |
514 end if; | |
515 | |
516 Next_Formal (Formal); | |
517 Next_Formal (O_Formal); | |
518 Next (Param_Spec); | |
519 end loop; | |
520 end if; | |
521 | |
522 -- If the renamed entity is a function, the generated body contains a | |
523 -- return statement. Otherwise, build a procedure call. If the entity is | |
524 -- an entry, subsequent analysis of the call will transform it into the | |
525 -- proper entry or protected operation call. If the renamed entity is | |
526 -- a character literal, return it directly. | |
527 | |
528 if Ekind (Old_S) = E_Function | |
529 or else Ekind (Old_S) = E_Operator | |
530 or else (Ekind (Old_S) = E_Subprogram_Type | |
531 and then Etype (Old_S) /= Standard_Void_Type) | |
532 then | |
533 Call_Node := | |
534 Make_Simple_Return_Statement (Loc, | |
535 Expression => | |
536 Make_Function_Call (Loc, | |
537 Name => Call_Name, | |
538 Parameter_Associations => Actuals)); | |
539 | |
540 elsif Ekind (Old_S) = E_Enumeration_Literal then | |
541 Call_Node := | |
542 Make_Simple_Return_Statement (Loc, | |
543 Expression => New_Occurrence_Of (Old_S, Loc)); | |
544 | |
545 elsif Nkind (Nam) = N_Character_Literal then | |
546 Call_Node := | |
547 Make_Simple_Return_Statement (Loc, Expression => Call_Name); | |
548 | |
549 else | |
550 Call_Node := | |
551 Make_Procedure_Call_Statement (Loc, | |
552 Name => Call_Name, | |
553 Parameter_Associations => Actuals); | |
554 end if; | |
555 | |
556 -- Create entities for subprogram body and formals | |
557 | |
558 Set_Defining_Unit_Name (Spec, | |
559 Make_Defining_Identifier (Loc, Chars => Chars (New_S))); | |
560 | |
561 Param_Spec := First (Parameter_Specifications (Spec)); | |
562 while Present (Param_Spec) loop | |
563 Set_Defining_Identifier (Param_Spec, | |
564 Make_Defining_Identifier (Loc, | |
565 Chars => Chars (Defining_Identifier (Param_Spec)))); | |
566 Next (Param_Spec); | |
567 end loop; | |
568 | |
569 Body_Node := | |
570 Make_Subprogram_Body (Loc, | |
571 Specification => Spec, | |
572 Declarations => New_List, | |
573 Handled_Statement_Sequence => | |
574 Make_Handled_Sequence_Of_Statements (Loc, | |
575 Statements => New_List (Call_Node))); | |
576 | |
577 if Nkind (Decl) /= N_Subprogram_Declaration then | |
578 Rewrite (N, | |
579 Make_Subprogram_Declaration (Loc, | |
580 Specification => Specification (N))); | |
581 end if; | |
582 | |
583 -- Link the body to the entity whose declaration it completes. If | |
584 -- the body is analyzed when the renamed entity is frozen, it may | |
585 -- be necessary to restore the proper scope (see package Exp_Ch13). | |
586 | |
587 if Nkind (N) = N_Subprogram_Renaming_Declaration | |
588 and then Present (Corresponding_Spec (N)) | |
589 then | |
590 Set_Corresponding_Spec (Body_Node, Corresponding_Spec (N)); | |
591 else | |
592 Set_Corresponding_Spec (Body_Node, New_S); | |
593 end if; | |
594 | |
595 return Body_Node; | |
596 end Build_Renamed_Body; | |
597 | |
598 -------------------------- | |
599 -- Check_Address_Clause -- | |
600 -------------------------- | |
601 | |
602 procedure Check_Address_Clause (E : Entity_Id) is | |
603 Addr : constant Node_Id := Address_Clause (E); | |
604 Typ : constant Entity_Id := Etype (E); | |
605 Decl : Node_Id; | |
606 Expr : Node_Id; | |
607 Init : Node_Id; | |
608 Lhs : Node_Id; | |
609 Tag_Assign : Node_Id; | |
610 | |
611 begin | |
612 if Present (Addr) then | |
613 | |
614 -- For a deferred constant, the initialization value is on full view | |
615 | |
616 if Ekind (E) = E_Constant and then Present (Full_View (E)) then | |
617 Decl := Declaration_Node (Full_View (E)); | |
618 else | |
619 Decl := Declaration_Node (E); | |
620 end if; | |
621 | |
622 Expr := Expression (Addr); | |
623 | |
624 if Needs_Constant_Address (Decl, Typ) then | |
625 Check_Constant_Address_Clause (Expr, E); | |
626 | |
627 -- Has_Delayed_Freeze was set on E when the address clause was | |
628 -- analyzed, and must remain set because we want the address | |
629 -- clause to be elaborated only after any entity it references | |
630 -- has been elaborated. | |
631 end if; | |
632 | |
633 -- If Rep_Clauses are to be ignored, remove address clause from | |
634 -- list attached to entity, because it may be illegal for gigi, | |
635 -- for example by breaking order of elaboration.. | |
636 | |
637 if Ignore_Rep_Clauses then | |
638 declare | |
639 Rep : Node_Id; | |
640 | |
641 begin | |
642 Rep := First_Rep_Item (E); | |
643 | |
644 if Rep = Addr then | |
645 Set_First_Rep_Item (E, Next_Rep_Item (Addr)); | |
646 | |
647 else | |
648 while Present (Rep) | |
649 and then Next_Rep_Item (Rep) /= Addr | |
650 loop | |
651 Rep := Next_Rep_Item (Rep); | |
652 end loop; | |
653 end if; | |
654 | |
655 if Present (Rep) then | |
656 Set_Next_Rep_Item (Rep, Next_Rep_Item (Addr)); | |
657 end if; | |
658 end; | |
659 | |
660 -- And now remove the address clause | |
661 | |
662 Kill_Rep_Clause (Addr); | |
663 | |
664 elsif not Error_Posted (Expr) | |
665 and then not Needs_Finalization (Typ) | |
666 then | |
667 Warn_Overlay (Expr, Typ, Name (Addr)); | |
668 end if; | |
669 | |
670 Init := Expression (Decl); | |
671 | |
672 -- If a variable, or a non-imported constant, overlays a constant | |
673 -- object and has an initialization value, then the initialization | |
674 -- may end up writing into read-only memory. Detect the cases of | |
675 -- statically identical values and remove the initialization. In | |
676 -- the other cases, give a warning. We will give other warnings | |
677 -- later for the variable if it is assigned. | |
678 | |
679 if (Ekind (E) = E_Variable | |
680 or else (Ekind (E) = E_Constant | |
681 and then not Is_Imported (E))) | |
682 and then Overlays_Constant (E) | |
683 and then Present (Init) | |
684 then | |
685 declare | |
686 O_Ent : Entity_Id; | |
687 Off : Boolean; | |
688 | |
689 begin | |
690 Find_Overlaid_Entity (Addr, O_Ent, Off); | |
691 | |
692 if Ekind (O_Ent) = E_Constant | |
693 and then Etype (O_Ent) = Typ | |
694 and then Present (Constant_Value (O_Ent)) | |
695 and then Compile_Time_Compare | |
696 (Init, | |
697 Constant_Value (O_Ent), | |
698 Assume_Valid => True) = EQ | |
699 then | |
700 Set_No_Initialization (Decl); | |
701 return; | |
702 | |
703 elsif Comes_From_Source (Init) | |
704 and then Address_Clause_Overlay_Warnings | |
705 then | |
706 Error_Msg_Sloc := Sloc (Addr); | |
707 Error_Msg_NE | |
708 ("??constant& may be modified via address clause#", | |
709 Decl, O_Ent); | |
710 end if; | |
711 end; | |
712 end if; | |
713 | |
714 if Present (Init) then | |
715 | |
716 -- Capture initialization value at point of declaration, | |
717 -- and make explicit assignment legal, because object may | |
718 -- be a constant. | |
719 | |
720 Remove_Side_Effects (Init); | |
721 Lhs := New_Occurrence_Of (E, Sloc (Decl)); | |
722 Set_Assignment_OK (Lhs); | |
723 | |
724 -- Move initialization to freeze actions, once the object has | |
725 -- been frozen and the address clause alignment check has been | |
726 -- performed. | |
727 | |
728 Append_Freeze_Action (E, | |
729 Make_Assignment_Statement (Sloc (Decl), | |
730 Name => Lhs, | |
731 Expression => Expression (Decl))); | |
732 | |
733 Set_No_Initialization (Decl); | |
734 | |
735 -- If the objet is tagged, check whether the tag must be | |
736 -- reassigned explicitly. | |
737 | |
738 Tag_Assign := Make_Tag_Assignment (Decl); | |
739 if Present (Tag_Assign) then | |
740 Append_Freeze_Action (E, Tag_Assign); | |
741 end if; | |
742 end if; | |
743 end if; | |
744 end Check_Address_Clause; | |
745 | |
746 ----------------------------- | |
747 -- Check_Compile_Time_Size -- | |
748 ----------------------------- | |
749 | |
750 procedure Check_Compile_Time_Size (T : Entity_Id) is | |
751 | |
752 procedure Set_Small_Size (T : Entity_Id; S : Uint); | |
753 -- Sets the compile time known size (64 bits or less) in the RM_Size | |
754 -- field of T, checking for a size clause that was given which attempts | |
755 -- to give a smaller size. | |
756 | |
757 function Size_Known (T : Entity_Id) return Boolean; | |
758 -- Recursive function that does all the work | |
759 | |
760 function Static_Discriminated_Components (T : Entity_Id) return Boolean; | |
761 -- If T is a constrained subtype, its size is not known if any of its | |
762 -- discriminant constraints is not static and it is not a null record. | |
763 -- The test is conservative and doesn't check that the components are | |
764 -- in fact constrained by non-static discriminant values. Could be made | |
765 -- more precise ??? | |
766 | |
767 -------------------- | |
768 -- Set_Small_Size -- | |
769 -------------------- | |
770 | |
771 procedure Set_Small_Size (T : Entity_Id; S : Uint) is | |
772 begin | |
773 if S > 64 then | |
774 return; | |
775 | |
776 -- Check for bad size clause given | |
777 | |
778 elsif Has_Size_Clause (T) then | |
779 if RM_Size (T) < S then | |
780 Error_Msg_Uint_1 := S; | |
781 Error_Msg_NE | |
782 ("size for& too small, minimum allowed is ^", | |
783 Size_Clause (T), T); | |
784 end if; | |
785 | |
786 -- Set size if not set already | |
787 | |
788 elsif Unknown_RM_Size (T) then | |
789 Set_RM_Size (T, S); | |
790 end if; | |
791 end Set_Small_Size; | |
792 | |
793 ---------------- | |
794 -- Size_Known -- | |
795 ---------------- | |
796 | |
797 function Size_Known (T : Entity_Id) return Boolean is | |
798 Index : Entity_Id; | |
799 Comp : Entity_Id; | |
800 Ctyp : Entity_Id; | |
801 Low : Node_Id; | |
802 High : Node_Id; | |
803 | |
804 begin | |
805 if Size_Known_At_Compile_Time (T) then | |
806 return True; | |
807 | |
808 -- Always True for elementary types, even generic formal elementary | |
809 -- types. We used to return False in the latter case, but the size | |
810 -- is known at compile time, even in the template, we just do not | |
811 -- know the exact size but that's not the point of this routine. | |
812 | |
813 elsif Is_Elementary_Type (T) or else Is_Task_Type (T) then | |
814 return True; | |
815 | |
816 -- Array types | |
817 | |
818 elsif Is_Array_Type (T) then | |
819 | |
820 -- String literals always have known size, and we can set it | |
821 | |
822 if Ekind (T) = E_String_Literal_Subtype then | |
823 Set_Small_Size | |
824 (T, Component_Size (T) * String_Literal_Length (T)); | |
825 return True; | |
826 | |
827 -- Unconstrained types never have known at compile time size | |
828 | |
829 elsif not Is_Constrained (T) then | |
830 return False; | |
831 | |
832 -- Don't do any recursion on type with error posted, since we may | |
833 -- have a malformed type that leads us into a loop. | |
834 | |
835 elsif Error_Posted (T) then | |
836 return False; | |
837 | |
838 -- Otherwise if component size unknown, then array size unknown | |
839 | |
840 elsif not Size_Known (Component_Type (T)) then | |
841 return False; | |
842 end if; | |
843 | |
844 -- Check for all indexes static, and also compute possible size | |
845 -- (in case it is not greater than 64 and may be packable). | |
846 | |
847 declare | |
848 Size : Uint := Component_Size (T); | |
849 Dim : Uint; | |
850 | |
851 begin | |
852 Index := First_Index (T); | |
853 while Present (Index) loop | |
854 if Nkind (Index) = N_Range then | |
855 Get_Index_Bounds (Index, Low, High); | |
856 | |
857 elsif Error_Posted (Scalar_Range (Etype (Index))) then | |
858 return False; | |
859 | |
860 else | |
861 Low := Type_Low_Bound (Etype (Index)); | |
862 High := Type_High_Bound (Etype (Index)); | |
863 end if; | |
864 | |
865 if not Compile_Time_Known_Value (Low) | |
866 or else not Compile_Time_Known_Value (High) | |
867 or else Etype (Index) = Any_Type | |
868 then | |
869 return False; | |
870 | |
871 else | |
872 Dim := Expr_Value (High) - Expr_Value (Low) + 1; | |
873 | |
874 if Dim >= 0 then | |
875 Size := Size * Dim; | |
876 else | |
877 Size := Uint_0; | |
878 end if; | |
879 end if; | |
880 | |
881 Next_Index (Index); | |
882 end loop; | |
883 | |
884 Set_Small_Size (T, Size); | |
885 return True; | |
886 end; | |
887 | |
888 -- For non-generic private types, go to underlying type if present | |
889 | |
890 elsif Is_Private_Type (T) | |
891 and then not Is_Generic_Type (T) | |
892 and then Present (Underlying_Type (T)) | |
893 then | |
894 -- Don't do any recursion on type with error posted, since we may | |
895 -- have a malformed type that leads us into a loop. | |
896 | |
897 if Error_Posted (T) then | |
898 return False; | |
899 else | |
900 return Size_Known (Underlying_Type (T)); | |
901 end if; | |
902 | |
903 -- Record types | |
904 | |
905 elsif Is_Record_Type (T) then | |
906 | |
907 -- A class-wide type is never considered to have a known size | |
908 | |
909 if Is_Class_Wide_Type (T) then | |
910 return False; | |
911 | |
912 -- A subtype of a variant record must not have non-static | |
913 -- discriminated components. | |
914 | |
915 elsif T /= Base_Type (T) | |
916 and then not Static_Discriminated_Components (T) | |
917 then | |
918 return False; | |
919 | |
920 -- Don't do any recursion on type with error posted, since we may | |
921 -- have a malformed type that leads us into a loop. | |
922 | |
923 elsif Error_Posted (T) then | |
924 return False; | |
925 end if; | |
926 | |
927 -- Now look at the components of the record | |
928 | |
929 declare | |
930 -- The following two variables are used to keep track of the | |
931 -- size of packed records if we can tell the size of the packed | |
932 -- record in the front end. Packed_Size_Known is True if so far | |
933 -- we can figure out the size. It is initialized to True for a | |
934 -- packed record, unless the record has discriminants or atomic | |
935 -- components or independent components. | |
936 | |
937 -- The reason we eliminate the discriminated case is that | |
938 -- we don't know the way the back end lays out discriminated | |
939 -- packed records. If Packed_Size_Known is True, then | |
940 -- Packed_Size is the size in bits so far. | |
941 | |
942 Packed_Size_Known : Boolean := | |
943 Is_Packed (T) | |
944 and then not Has_Discriminants (T) | |
945 and then not Has_Atomic_Components (T) | |
946 and then not Has_Independent_Components (T); | |
947 | |
948 Packed_Size : Uint := Uint_0; | |
949 -- Size in bits so far | |
950 | |
951 begin | |
952 -- Test for variant part present | |
953 | |
954 if Has_Discriminants (T) | |
955 and then Present (Parent (T)) | |
956 and then Nkind (Parent (T)) = N_Full_Type_Declaration | |
957 and then Nkind (Type_Definition (Parent (T))) = | |
958 N_Record_Definition | |
959 and then not Null_Present (Type_Definition (Parent (T))) | |
960 and then | |
961 Present (Variant_Part | |
962 (Component_List (Type_Definition (Parent (T))))) | |
963 then | |
964 -- If variant part is present, and type is unconstrained, | |
965 -- then we must have defaulted discriminants, or a size | |
966 -- clause must be present for the type, or else the size | |
967 -- is definitely not known at compile time. | |
968 | |
969 if not Is_Constrained (T) | |
970 and then | |
971 No (Discriminant_Default_Value (First_Discriminant (T))) | |
972 and then Unknown_RM_Size (T) | |
973 then | |
974 return False; | |
975 end if; | |
976 end if; | |
977 | |
978 -- Loop through components | |
979 | |
980 Comp := First_Component_Or_Discriminant (T); | |
981 while Present (Comp) loop | |
982 Ctyp := Etype (Comp); | |
983 | |
984 -- We do not know the packed size if there is a component | |
985 -- clause present (we possibly could, but this would only | |
986 -- help in the case of a record with partial rep clauses. | |
987 -- That's because in the case of full rep clauses, the | |
988 -- size gets figured out anyway by a different circuit). | |
989 | |
990 if Present (Component_Clause (Comp)) then | |
991 Packed_Size_Known := False; | |
992 end if; | |
993 | |
994 -- We do not know the packed size for an atomic/VFA type | |
995 -- or component, or an independent type or component, or a | |
996 -- by-reference type or aliased component (because packing | |
997 -- does not touch these). | |
998 | |
999 if Is_Atomic_Or_VFA (Ctyp) | |
1000 or else Is_Atomic_Or_VFA (Comp) | |
1001 or else Is_Independent (Ctyp) | |
1002 or else Is_Independent (Comp) | |
1003 or else Is_By_Reference_Type (Ctyp) | |
1004 or else Is_Aliased (Comp) | |
1005 then | |
1006 Packed_Size_Known := False; | |
1007 end if; | |
1008 | |
1009 -- We need to identify a component that is an array where | |
1010 -- the index type is an enumeration type with non-standard | |
1011 -- representation, and some bound of the type depends on a | |
1012 -- discriminant. | |
1013 | |
1014 -- This is because gigi computes the size by doing a | |
1015 -- substitution of the appropriate discriminant value in | |
1016 -- the size expression for the base type, and gigi is not | |
1017 -- clever enough to evaluate the resulting expression (which | |
1018 -- involves a call to rep_to_pos) at compile time. | |
1019 | |
1020 -- It would be nice if gigi would either recognize that | |
1021 -- this expression can be computed at compile time, or | |
1022 -- alternatively figured out the size from the subtype | |
1023 -- directly, where all the information is at hand ??? | |
1024 | |
1025 if Is_Array_Type (Etype (Comp)) | |
1026 and then Present (Packed_Array_Impl_Type (Etype (Comp))) | |
1027 then | |
1028 declare | |
1029 Ocomp : constant Entity_Id := | |
1030 Original_Record_Component (Comp); | |
1031 OCtyp : constant Entity_Id := Etype (Ocomp); | |
1032 Ind : Node_Id; | |
1033 Indtyp : Entity_Id; | |
1034 Lo, Hi : Node_Id; | |
1035 | |
1036 begin | |
1037 Ind := First_Index (OCtyp); | |
1038 while Present (Ind) loop | |
1039 Indtyp := Etype (Ind); | |
1040 | |
1041 if Is_Enumeration_Type (Indtyp) | |
1042 and then Has_Non_Standard_Rep (Indtyp) | |
1043 then | |
1044 Lo := Type_Low_Bound (Indtyp); | |
1045 Hi := Type_High_Bound (Indtyp); | |
1046 | |
1047 if Is_Entity_Name (Lo) | |
1048 and then Ekind (Entity (Lo)) = E_Discriminant | |
1049 then | |
1050 return False; | |
1051 | |
1052 elsif Is_Entity_Name (Hi) | |
1053 and then Ekind (Entity (Hi)) = E_Discriminant | |
1054 then | |
1055 return False; | |
1056 end if; | |
1057 end if; | |
1058 | |
1059 Next_Index (Ind); | |
1060 end loop; | |
1061 end; | |
1062 end if; | |
1063 | |
1064 -- Clearly size of record is not known if the size of one of | |
1065 -- the components is not known. | |
1066 | |
1067 if not Size_Known (Ctyp) then | |
1068 return False; | |
1069 end if; | |
1070 | |
1071 -- Accumulate packed size if possible | |
1072 | |
1073 if Packed_Size_Known then | |
1074 | |
1075 -- We can deal with elementary types, small packed arrays | |
1076 -- if the representation is a modular type and also small | |
1077 -- record types (if the size is not greater than 64, but | |
1078 -- the condition is checked by Set_Small_Size). | |
1079 | |
1080 if Is_Elementary_Type (Ctyp) | |
1081 or else (Is_Array_Type (Ctyp) | |
1082 and then Present | |
1083 (Packed_Array_Impl_Type (Ctyp)) | |
1084 and then Is_Modular_Integer_Type | |
1085 (Packed_Array_Impl_Type (Ctyp))) | |
1086 or else Is_Record_Type (Ctyp) | |
1087 then | |
1088 -- If RM_Size is known and static, then we can keep | |
1089 -- accumulating the packed size. | |
1090 | |
1091 if Known_Static_RM_Size (Ctyp) then | |
1092 | |
1093 Packed_Size := Packed_Size + RM_Size (Ctyp); | |
1094 | |
1095 -- If we have a field whose RM_Size is not known then | |
1096 -- we can't figure out the packed size here. | |
1097 | |
1098 else | |
1099 Packed_Size_Known := False; | |
1100 end if; | |
1101 | |
1102 -- For other types we can't figure out the packed size | |
1103 | |
1104 else | |
1105 Packed_Size_Known := False; | |
1106 end if; | |
1107 end if; | |
1108 | |
1109 Next_Component_Or_Discriminant (Comp); | |
1110 end loop; | |
1111 | |
1112 if Packed_Size_Known then | |
1113 Set_Small_Size (T, Packed_Size); | |
1114 end if; | |
1115 | |
1116 return True; | |
1117 end; | |
1118 | |
1119 -- All other cases, size not known at compile time | |
1120 | |
1121 else | |
1122 return False; | |
1123 end if; | |
1124 end Size_Known; | |
1125 | |
1126 ------------------------------------- | |
1127 -- Static_Discriminated_Components -- | |
1128 ------------------------------------- | |
1129 | |
1130 function Static_Discriminated_Components | |
1131 (T : Entity_Id) return Boolean | |
1132 is | |
1133 Constraint : Elmt_Id; | |
1134 | |
1135 begin | |
1136 if Has_Discriminants (T) | |
1137 and then Present (Discriminant_Constraint (T)) | |
1138 and then Present (First_Component (T)) | |
1139 then | |
1140 Constraint := First_Elmt (Discriminant_Constraint (T)); | |
1141 while Present (Constraint) loop | |
1142 if not Compile_Time_Known_Value (Node (Constraint)) then | |
1143 return False; | |
1144 end if; | |
1145 | |
1146 Next_Elmt (Constraint); | |
1147 end loop; | |
1148 end if; | |
1149 | |
1150 return True; | |
1151 end Static_Discriminated_Components; | |
1152 | |
1153 -- Start of processing for Check_Compile_Time_Size | |
1154 | |
1155 begin | |
1156 Set_Size_Known_At_Compile_Time (T, Size_Known (T)); | |
1157 end Check_Compile_Time_Size; | |
1158 | |
1159 ----------------------------------- | |
1160 -- Check_Component_Storage_Order -- | |
1161 ----------------------------------- | |
1162 | |
1163 procedure Check_Component_Storage_Order | |
1164 (Encl_Type : Entity_Id; | |
1165 Comp : Entity_Id; | |
1166 ADC : Node_Id; | |
1167 Comp_ADC_Present : out Boolean) | |
1168 is | |
1169 Comp_Base : Entity_Id; | |
1170 Comp_ADC : Node_Id; | |
1171 Encl_Base : Entity_Id; | |
1172 Err_Node : Node_Id; | |
1173 | |
1174 Component_Aliased : Boolean; | |
1175 | |
1176 Comp_Byte_Aligned : Boolean; | |
1177 pragma Warnings (Off, Comp_Byte_Aligned); | |
1178 -- Set for the record case, True if Comp is aligned on byte boundaries | |
1179 -- (in which case it is allowed to have different storage order). | |
1180 | |
1181 Comp_SSO_Differs : Boolean; | |
1182 -- Set True when the component is a nested composite, and it does not | |
1183 -- have the same scalar storage order as Encl_Type. | |
1184 | |
1185 begin | |
1186 -- Record case | |
1187 | |
1188 if Present (Comp) then | |
1189 Err_Node := Comp; | |
1190 Comp_Base := Etype (Comp); | |
1191 | |
1192 if Is_Tag (Comp) then | |
1193 Comp_Byte_Aligned := True; | |
1194 Component_Aliased := False; | |
1195 | |
1196 else | |
1197 -- If a component clause is present, check if the component starts | |
1198 -- and ends on byte boundaries. Otherwise conservatively assume it | |
1199 -- does so only in the case where the record is not packed. | |
1200 | |
1201 if Present (Component_Clause (Comp)) then | |
1202 Comp_Byte_Aligned := | |
1203 (Normalized_First_Bit (Comp) mod System_Storage_Unit = 0) | |
1204 and then | |
1205 (Esize (Comp) mod System_Storage_Unit = 0); | |
1206 else | |
1207 Comp_Byte_Aligned := not Is_Packed (Encl_Type); | |
1208 end if; | |
1209 | |
1210 Component_Aliased := Is_Aliased (Comp); | |
1211 end if; | |
1212 | |
1213 -- Array case | |
1214 | |
1215 else | |
1216 Err_Node := Encl_Type; | |
1217 Comp_Base := Component_Type (Encl_Type); | |
1218 | |
1219 Component_Aliased := Has_Aliased_Components (Encl_Type); | |
1220 end if; | |
1221 | |
1222 -- Note: the Reverse_Storage_Order flag is set on the base type, but | |
1223 -- the attribute definition clause is attached to the first subtype. | |
1224 -- Also, if the base type is incomplete or private, go to full view | |
1225 -- if known | |
1226 | |
1227 Encl_Base := Base_Type (Encl_Type); | |
1228 if Present (Underlying_Type (Encl_Base)) then | |
1229 Encl_Base := Underlying_Type (Encl_Base); | |
1230 end if; | |
1231 | |
1232 Comp_Base := Base_Type (Comp_Base); | |
1233 if Present (Underlying_Type (Comp_Base)) then | |
1234 Comp_Base := Underlying_Type (Comp_Base); | |
1235 end if; | |
1236 | |
1237 Comp_ADC := | |
1238 Get_Attribute_Definition_Clause | |
1239 (First_Subtype (Comp_Base), Attribute_Scalar_Storage_Order); | |
1240 Comp_ADC_Present := Present (Comp_ADC); | |
1241 | |
1242 -- Case of record or array component: check storage order compatibility. | |
1243 -- But, if the record has Complex_Representation, then it is treated as | |
1244 -- a scalar in the back end so the storage order is irrelevant. | |
1245 | |
1246 if (Is_Record_Type (Comp_Base) | |
1247 and then not Has_Complex_Representation (Comp_Base)) | |
1248 or else Is_Array_Type (Comp_Base) | |
1249 then | |
1250 Comp_SSO_Differs := | |
1251 Reverse_Storage_Order (Encl_Base) /= | |
1252 Reverse_Storage_Order (Comp_Base); | |
1253 | |
1254 -- Parent and extension must have same storage order | |
1255 | |
1256 if Present (Comp) and then Chars (Comp) = Name_uParent then | |
1257 if Comp_SSO_Differs then | |
1258 Error_Msg_N | |
1259 ("record extension must have same scalar storage order as " | |
1260 & "parent", Err_Node); | |
1261 end if; | |
1262 | |
1263 -- If component and composite SSO differs, check that component | |
1264 -- falls on byte boundaries and isn't bit packed. | |
1265 | |
1266 elsif Comp_SSO_Differs then | |
1267 | |
1268 -- Component SSO differs from enclosing composite: | |
1269 | |
1270 -- Reject if composite is a bit-packed array, as it is rewritten | |
1271 -- into an array of scalars. | |
1272 | |
1273 if Is_Bit_Packed_Array (Encl_Base) then | |
1274 Error_Msg_N | |
1275 ("type of packed array must have same scalar storage order " | |
1276 & "as component", Err_Node); | |
1277 | |
1278 -- Reject if not byte aligned | |
1279 | |
1280 elsif Is_Record_Type (Encl_Base) | |
1281 and then not Comp_Byte_Aligned | |
1282 then | |
1283 Error_Msg_N | |
1284 ("type of non-byte-aligned component must have same scalar " | |
1285 & "storage order as enclosing composite", Err_Node); | |
1286 | |
1287 -- Warn if specified only for the outer composite | |
1288 | |
1289 elsif Present (ADC) and then No (Comp_ADC) then | |
1290 Error_Msg_NE | |
1291 ("scalar storage order specified for & does not apply to " | |
1292 & "component?", Err_Node, Encl_Base); | |
1293 end if; | |
1294 end if; | |
1295 | |
1296 -- Enclosing type has explicit SSO: non-composite component must not | |
1297 -- be aliased. | |
1298 | |
1299 elsif Present (ADC) and then Component_Aliased then | |
1300 Error_Msg_N | |
1301 ("aliased component not permitted for type with explicit " | |
1302 & "Scalar_Storage_Order", Err_Node); | |
1303 end if; | |
1304 end Check_Component_Storage_Order; | |
1305 | |
1306 ----------------------------- | |
1307 -- Check_Debug_Info_Needed -- | |
1308 ----------------------------- | |
1309 | |
1310 procedure Check_Debug_Info_Needed (T : Entity_Id) is | |
1311 begin | |
1312 if Debug_Info_Off (T) then | |
1313 return; | |
1314 | |
1315 elsif Comes_From_Source (T) | |
1316 or else Debug_Generated_Code | |
1317 or else Debug_Flag_VV | |
1318 or else Needs_Debug_Info (T) | |
1319 then | |
1320 Set_Debug_Info_Needed (T); | |
1321 end if; | |
1322 end Check_Debug_Info_Needed; | |
1323 | |
1324 ------------------------------- | |
1325 -- Check_Expression_Function -- | |
1326 ------------------------------- | |
1327 | |
1328 procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id) is | |
1329 function Find_Constant (Nod : Node_Id) return Traverse_Result; | |
1330 -- Function to search for deferred constant | |
1331 | |
1332 ------------------- | |
1333 -- Find_Constant -- | |
1334 ------------------- | |
1335 | |
1336 function Find_Constant (Nod : Node_Id) return Traverse_Result is | |
1337 begin | |
1338 -- When a constant is initialized with the result of a dispatching | |
1339 -- call, the constant declaration is rewritten as a renaming of the | |
1340 -- displaced function result. This scenario is not a premature use of | |
1341 -- a constant even though the Has_Completion flag is not set. | |
1342 | |
1343 if Is_Entity_Name (Nod) | |
1344 and then Present (Entity (Nod)) | |
1345 and then Ekind (Entity (Nod)) = E_Constant | |
1346 and then Scope (Entity (Nod)) = Current_Scope | |
1347 and then Nkind (Declaration_Node (Entity (Nod))) = | |
1348 N_Object_Declaration | |
1349 and then not Is_Imported (Entity (Nod)) | |
1350 and then not Has_Completion (Entity (Nod)) | |
1351 and then not Is_Frozen (Entity (Nod)) | |
1352 then | |
1353 Error_Msg_NE | |
1354 ("premature use of& in call or instance", N, Entity (Nod)); | |
1355 | |
1356 elsif Nkind (Nod) = N_Attribute_Reference then | |
1357 Analyze (Prefix (Nod)); | |
1358 | |
1359 if Is_Entity_Name (Prefix (Nod)) | |
1360 and then Is_Type (Entity (Prefix (Nod))) | |
1361 then | |
1362 Freeze_Before (N, Entity (Prefix (Nod))); | |
1363 end if; | |
1364 end if; | |
1365 | |
1366 return OK; | |
1367 end Find_Constant; | |
1368 | |
1369 procedure Check_Deferred is new Traverse_Proc (Find_Constant); | |
1370 | |
1371 -- Local variables | |
1372 | |
1373 Decl : Node_Id; | |
1374 | |
1375 -- Start of processing for Check_Expression_Function | |
1376 | |
1377 begin | |
1378 Decl := Original_Node (Unit_Declaration_Node (Nam)); | |
1379 | |
1380 -- The subprogram body created for the expression function is not | |
1381 -- itself a freeze point. | |
1382 | |
1383 if Scope (Nam) = Current_Scope | |
1384 and then Nkind (Decl) = N_Expression_Function | |
1385 and then Nkind (N) /= N_Subprogram_Body | |
1386 then | |
1387 Check_Deferred (Expression (Decl)); | |
1388 end if; | |
1389 end Check_Expression_Function; | |
1390 | |
1391 -------------------------------- | |
1392 -- Check_Inherited_Conditions -- | |
1393 -------------------------------- | |
1394 | |
1395 procedure Check_Inherited_Conditions (R : Entity_Id) is | |
1396 Prim_Ops : constant Elist_Id := Primitive_Operations (R); | |
1397 Decls : List_Id; | |
1398 Needs_Wrapper : Boolean; | |
1399 Op_Node : Elmt_Id; | |
1400 Par_Prim : Entity_Id; | |
1401 Prim : Entity_Id; | |
1402 | |
1403 procedure Build_Inherited_Condition_Pragmas (Subp : Entity_Id); | |
1404 -- Build corresponding pragmas for an operation whose ancestor has | |
1405 -- class-wide pre/postconditions. If the operation is inherited, the | |
1406 -- pragmas force the creation of a wrapper for the inherited operation. | |
1407 -- If the ancestor is being overridden, the pragmas are constructed only | |
1408 -- to verify their legality, in case they contain calls to other | |
1409 -- primitives that may haven been overridden. | |
1410 | |
1411 --------------------------------------- | |
1412 -- Build_Inherited_Condition_Pragmas -- | |
1413 --------------------------------------- | |
1414 | |
1415 procedure Build_Inherited_Condition_Pragmas (Subp : Entity_Id) is | |
1416 A_Post : Node_Id; | |
1417 A_Pre : Node_Id; | |
1418 New_Prag : Node_Id; | |
1419 | |
1420 begin | |
1421 A_Pre := Get_Class_Wide_Pragma (Par_Prim, Pragma_Precondition); | |
1422 | |
1423 if Present (A_Pre) then | |
1424 New_Prag := New_Copy_Tree (A_Pre); | |
1425 Build_Class_Wide_Expression | |
1426 (Prag => New_Prag, | |
1427 Subp => Prim, | |
1428 Par_Subp => Par_Prim, | |
1429 Adjust_Sloc => False, | |
1430 Needs_Wrapper => Needs_Wrapper); | |
1431 | |
1432 if Needs_Wrapper | |
1433 and then not Comes_From_Source (Subp) | |
1434 and then Expander_Active | |
1435 then | |
1436 Append (New_Prag, Decls); | |
1437 end if; | |
1438 end if; | |
1439 | |
1440 A_Post := Get_Class_Wide_Pragma (Par_Prim, Pragma_Postcondition); | |
1441 | |
1442 if Present (A_Post) then | |
1443 New_Prag := New_Copy_Tree (A_Post); | |
1444 Build_Class_Wide_Expression | |
1445 (Prag => New_Prag, | |
1446 Subp => Prim, | |
1447 Par_Subp => Par_Prim, | |
1448 Adjust_Sloc => False, | |
1449 Needs_Wrapper => Needs_Wrapper); | |
1450 | |
1451 if Needs_Wrapper | |
1452 and then not Comes_From_Source (Subp) | |
1453 and then Expander_Active | |
1454 then | |
1455 Append (New_Prag, Decls); | |
1456 end if; | |
1457 end if; | |
1458 end Build_Inherited_Condition_Pragmas; | |
1459 | |
1460 -- Start of processing for Check_Inherited_Conditions | |
1461 | |
1462 begin | |
1463 Op_Node := First_Elmt (Prim_Ops); | |
1464 while Present (Op_Node) loop | |
1465 Prim := Node (Op_Node); | |
1466 | |
1467 -- Map the overridden primitive to the overriding one. This takes | |
1468 -- care of all overridings and is done only once. | |
1469 | |
1470 if Present (Overridden_Operation (Prim)) | |
1471 and then Comes_From_Source (Prim) | |
1472 then | |
1473 Par_Prim := Overridden_Operation (Prim); | |
1474 Update_Primitives_Mapping (Par_Prim, Prim); | |
1475 end if; | |
1476 | |
1477 Next_Elmt (Op_Node); | |
1478 end loop; | |
1479 | |
1480 -- Perform validity checks on the inherited conditions of overriding | |
1481 -- operations, for conformance with LSP, and apply SPARK-specific | |
1482 -- restrictions on inherited conditions. | |
1483 | |
1484 Op_Node := First_Elmt (Prim_Ops); | |
1485 while Present (Op_Node) loop | |
1486 Prim := Node (Op_Node); | |
1487 | |
1488 if Present (Overridden_Operation (Prim)) | |
1489 and then Comes_From_Source (Prim) | |
1490 then | |
1491 Par_Prim := Overridden_Operation (Prim); | |
1492 | |
1493 -- Analyze the contract items of the overridden operation, before | |
1494 -- they are rewritten as pragmas. | |
1495 | |
1496 Analyze_Entry_Or_Subprogram_Contract (Par_Prim); | |
1497 | |
1498 -- In GNATprove mode this is where we can collect the inherited | |
1499 -- conditions, because we do not create the Check pragmas that | |
1500 -- normally convey the the modified class-wide conditions on | |
1501 -- overriding operations. | |
1502 | |
1503 if GNATprove_Mode then | |
1504 Collect_Inherited_Class_Wide_Conditions (Prim); | |
1505 | |
1506 -- Otherwise build the corresponding pragmas to check for legality | |
1507 -- of the inherited condition. | |
1508 | |
1509 else | |
1510 Build_Inherited_Condition_Pragmas (Prim); | |
1511 end if; | |
1512 end if; | |
1513 | |
1514 Next_Elmt (Op_Node); | |
1515 end loop; | |
1516 | |
1517 -- Now examine the inherited operations to check whether they require | |
1518 -- a wrapper to handle inherited conditions that call other primitives, | |
1519 -- so that LSP can be verified/enforced. | |
1520 | |
1521 Op_Node := First_Elmt (Prim_Ops); | |
1522 Needs_Wrapper := False; | |
1523 | |
1524 while Present (Op_Node) loop | |
1525 Decls := Empty_List; | |
1526 Prim := Node (Op_Node); | |
1527 | |
1528 if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then | |
1529 Par_Prim := Alias (Prim); | |
1530 | |
1531 -- Analyze the contract items of the parent operation, and | |
1532 -- determine whether a wrapper is needed. This is determined | |
1533 -- when the condition is rewritten in sem_prag, using the | |
1534 -- mapping between overridden and overriding operations built | |
1535 -- in the loop above. | |
1536 | |
1537 Analyze_Entry_Or_Subprogram_Contract (Par_Prim); | |
1538 Build_Inherited_Condition_Pragmas (Prim); | |
1539 end if; | |
1540 | |
1541 if Needs_Wrapper | |
1542 and then not Is_Abstract_Subprogram (Par_Prim) | |
1543 and then Expander_Active | |
1544 then | |
1545 -- We need to build a new primitive that overrides the inherited | |
1546 -- one, and whose inherited expression has been updated above. | |
1547 -- These expressions are the arguments of pragmas that are part | |
1548 -- of the declarations of the wrapper. The wrapper holds a single | |
1549 -- statement that is a call to the class-wide clone, where the | |
1550 -- controlling actuals are conversions to the corresponding type | |
1551 -- in the parent primitive: | |
1552 | |
1553 -- procedure New_Prim (F1 : T1; ...); | |
1554 -- procedure New_Prim (F1 : T1; ...) is | |
1555 -- pragma Check (Precondition, Expr); | |
1556 -- begin | |
1557 -- Par_Prim_Clone (Par_Type (F1), ...); | |
1558 -- end; | |
1559 | |
1560 -- If the primitive is a function the statement is a return | |
1561 -- statement with a call. | |
1562 | |
1563 declare | |
1564 Loc : constant Source_Ptr := Sloc (R); | |
1565 Par_R : constant Node_Id := Parent (R); | |
1566 New_Body : Node_Id; | |
1567 New_Decl : Node_Id; | |
1568 New_Spec : Node_Id; | |
1569 | |
1570 begin | |
1571 New_Spec := Build_Overriding_Spec (Par_Prim, R); | |
1572 New_Decl := | |
1573 Make_Subprogram_Declaration (Loc, | |
1574 Specification => New_Spec); | |
1575 | |
1576 -- Insert the declaration and the body of the wrapper after | |
1577 -- type declaration that generates inherited operation. For | |
1578 -- a null procedure, the declaration implies a null body. | |
1579 | |
1580 if Nkind (New_Spec) = N_Procedure_Specification | |
1581 and then Null_Present (New_Spec) | |
1582 then | |
1583 Insert_After_And_Analyze (Par_R, New_Decl); | |
1584 | |
1585 else | |
1586 -- Build body as wrapper to a call to the already built | |
1587 -- class-wide clone. | |
1588 | |
1589 New_Body := | |
1590 Build_Class_Wide_Clone_Call | |
1591 (Loc, Decls, Par_Prim, New_Spec); | |
1592 | |
1593 Insert_List_After_And_Analyze | |
1594 (Par_R, New_List (New_Decl, New_Body)); | |
1595 end if; | |
1596 end; | |
1597 | |
1598 Needs_Wrapper := False; | |
1599 end if; | |
1600 | |
1601 Next_Elmt (Op_Node); | |
1602 end loop; | |
1603 end Check_Inherited_Conditions; | |
1604 | |
1605 ---------------------------- | |
1606 -- Check_Strict_Alignment -- | |
1607 ---------------------------- | |
1608 | |
1609 procedure Check_Strict_Alignment (E : Entity_Id) is | |
1610 Comp : Entity_Id; | |
1611 | |
1612 begin | |
1613 if Is_Tagged_Type (E) or else Is_Concurrent_Type (E) then | |
1614 Set_Strict_Alignment (E); | |
1615 | |
1616 elsif Is_Array_Type (E) then | |
1617 Set_Strict_Alignment (E, Strict_Alignment (Component_Type (E))); | |
1618 | |
1619 elsif Is_Record_Type (E) then | |
1620 if Is_Limited_Record (E) then | |
1621 Set_Strict_Alignment (E); | |
1622 return; | |
1623 end if; | |
1624 | |
1625 Comp := First_Component (E); | |
1626 while Present (Comp) loop | |
1627 if not Is_Type (Comp) | |
1628 and then (Strict_Alignment (Etype (Comp)) | |
1629 or else Is_Aliased (Comp)) | |
1630 then | |
1631 Set_Strict_Alignment (E); | |
1632 return; | |
1633 end if; | |
1634 | |
1635 Next_Component (Comp); | |
1636 end loop; | |
1637 end if; | |
1638 end Check_Strict_Alignment; | |
1639 | |
1640 ------------------------- | |
1641 -- Check_Unsigned_Type -- | |
1642 ------------------------- | |
1643 | |
1644 procedure Check_Unsigned_Type (E : Entity_Id) is | |
1645 Ancestor : Entity_Id; | |
1646 Lo_Bound : Node_Id; | |
1647 Btyp : Entity_Id; | |
1648 | |
1649 begin | |
1650 if not Is_Discrete_Or_Fixed_Point_Type (E) then | |
1651 return; | |
1652 end if; | |
1653 | |
1654 -- Do not attempt to analyze case where range was in error | |
1655 | |
1656 if No (Scalar_Range (E)) or else Error_Posted (Scalar_Range (E)) then | |
1657 return; | |
1658 end if; | |
1659 | |
1660 -- The situation that is nontrivial is something like: | |
1661 | |
1662 -- subtype x1 is integer range -10 .. +10; | |
1663 -- subtype x2 is x1 range 0 .. V1; | |
1664 -- subtype x3 is x2 range V2 .. V3; | |
1665 -- subtype x4 is x3 range V4 .. V5; | |
1666 | |
1667 -- where Vn are variables. Here the base type is signed, but we still | |
1668 -- know that x4 is unsigned because of the lower bound of x2. | |
1669 | |
1670 -- The only way to deal with this is to look up the ancestor chain | |
1671 | |
1672 Ancestor := E; | |
1673 loop | |
1674 if Ancestor = Any_Type or else Etype (Ancestor) = Any_Type then | |
1675 return; | |
1676 end if; | |
1677 | |
1678 Lo_Bound := Type_Low_Bound (Ancestor); | |
1679 | |
1680 if Compile_Time_Known_Value (Lo_Bound) then | |
1681 if Expr_Rep_Value (Lo_Bound) >= 0 then | |
1682 Set_Is_Unsigned_Type (E, True); | |
1683 end if; | |
1684 | |
1685 return; | |
1686 | |
1687 else | |
1688 Ancestor := Ancestor_Subtype (Ancestor); | |
1689 | |
1690 -- If no ancestor had a static lower bound, go to base type | |
1691 | |
1692 if No (Ancestor) then | |
1693 | |
1694 -- Note: the reason we still check for a compile time known | |
1695 -- value for the base type is that at least in the case of | |
1696 -- generic formals, we can have bounds that fail this test, | |
1697 -- and there may be other cases in error situations. | |
1698 | |
1699 Btyp := Base_Type (E); | |
1700 | |
1701 if Btyp = Any_Type or else Etype (Btyp) = Any_Type then | |
1702 return; | |
1703 end if; | |
1704 | |
1705 Lo_Bound := Type_Low_Bound (Base_Type (E)); | |
1706 | |
1707 if Compile_Time_Known_Value (Lo_Bound) | |
1708 and then Expr_Rep_Value (Lo_Bound) >= 0 | |
1709 then | |
1710 Set_Is_Unsigned_Type (E, True); | |
1711 end if; | |
1712 | |
1713 return; | |
1714 end if; | |
1715 end if; | |
1716 end loop; | |
1717 end Check_Unsigned_Type; | |
1718 | |
1719 ----------------------------- | |
1720 -- Is_Atomic_VFA_Aggregate -- | |
1721 ----------------------------- | |
1722 | |
1723 function Is_Atomic_VFA_Aggregate (N : Node_Id) return Boolean is | |
1724 Loc : constant Source_Ptr := Sloc (N); | |
1725 New_N : Node_Id; | |
1726 Par : Node_Id; | |
1727 Temp : Entity_Id; | |
1728 Typ : Entity_Id; | |
1729 | |
1730 begin | |
1731 Par := Parent (N); | |
1732 | |
1733 -- Array may be qualified, so find outer context | |
1734 | |
1735 if Nkind (Par) = N_Qualified_Expression then | |
1736 Par := Parent (Par); | |
1737 end if; | |
1738 | |
1739 if not Comes_From_Source (Par) then | |
1740 return False; | |
1741 end if; | |
1742 | |
1743 case Nkind (Par) is | |
1744 when N_Assignment_Statement => | |
1745 Typ := Etype (Name (Par)); | |
1746 | |
1747 if not Is_Atomic_Or_VFA (Typ) | |
1748 and then not (Is_Entity_Name (Name (Par)) | |
1749 and then Is_Atomic_Or_VFA (Entity (Name (Par)))) | |
1750 then | |
1751 return False; | |
1752 end if; | |
1753 | |
1754 when N_Object_Declaration => | |
1755 Typ := Etype (Defining_Identifier (Par)); | |
1756 | |
1757 if not Is_Atomic_Or_VFA (Typ) | |
1758 and then not Is_Atomic_Or_VFA (Defining_Identifier (Par)) | |
1759 then | |
1760 return False; | |
1761 end if; | |
1762 | |
1763 when others => | |
1764 return False; | |
1765 end case; | |
1766 | |
1767 Temp := Make_Temporary (Loc, 'T', N); | |
1768 New_N := | |
1769 Make_Object_Declaration (Loc, | |
1770 Defining_Identifier => Temp, | |
1771 Object_Definition => New_Occurrence_Of (Typ, Loc), | |
1772 Expression => Relocate_Node (N)); | |
1773 Insert_Before (Par, New_N); | |
1774 Analyze (New_N); | |
1775 | |
1776 Set_Expression (Par, New_Occurrence_Of (Temp, Loc)); | |
1777 return True; | |
1778 end Is_Atomic_VFA_Aggregate; | |
1779 | |
1780 ----------------------------------------------- | |
1781 -- Explode_Initialization_Compound_Statement -- | |
1782 ----------------------------------------------- | |
1783 | |
1784 procedure Explode_Initialization_Compound_Statement (E : Entity_Id) is | |
1785 Init_Stmts : constant Node_Id := Initialization_Statements (E); | |
1786 | |
1787 begin | |
1788 if Present (Init_Stmts) | |
1789 and then Nkind (Init_Stmts) = N_Compound_Statement | |
1790 then | |
1791 Insert_List_Before (Init_Stmts, Actions (Init_Stmts)); | |
1792 | |
1793 -- Note that we rewrite Init_Stmts into a NULL statement, rather than | |
1794 -- just removing it, because Freeze_All may rely on this particular | |
1795 -- Node_Id still being present in the enclosing list to know where to | |
1796 -- stop freezing. | |
1797 | |
1798 Rewrite (Init_Stmts, Make_Null_Statement (Sloc (Init_Stmts))); | |
1799 | |
1800 Set_Initialization_Statements (E, Empty); | |
1801 end if; | |
1802 end Explode_Initialization_Compound_Statement; | |
1803 | |
1804 ---------------- | |
1805 -- Freeze_All -- | |
1806 ---------------- | |
1807 | |
1808 -- Note: the easy coding for this procedure would be to just build a | |
1809 -- single list of freeze nodes and then insert them and analyze them | |
1810 -- all at once. This won't work, because the analysis of earlier freeze | |
1811 -- nodes may recursively freeze types which would otherwise appear later | |
1812 -- on in the freeze list. So we must analyze and expand the freeze nodes | |
1813 -- as they are generated. | |
1814 | |
1815 procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is | |
1816 procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id); | |
1817 -- This is the internal recursive routine that does freezing of entities | |
1818 -- (but NOT the analysis of default expressions, which should not be | |
1819 -- recursive, we don't want to analyze those till we are sure that ALL | |
1820 -- the types are frozen). | |
1821 | |
1822 -------------------- | |
1823 -- Freeze_All_Ent -- | |
1824 -------------------- | |
1825 | |
1826 procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id) is | |
1827 E : Entity_Id; | |
1828 Flist : List_Id; | |
1829 Lastn : Node_Id; | |
1830 | |
1831 procedure Process_Flist; | |
1832 -- If freeze nodes are present, insert and analyze, and reset cursor | |
1833 -- for next insertion. | |
1834 | |
1835 ------------------- | |
1836 -- Process_Flist -- | |
1837 ------------------- | |
1838 | |
1839 procedure Process_Flist is | |
1840 begin | |
1841 if Is_Non_Empty_List (Flist) then | |
1842 Lastn := Next (After); | |
1843 Insert_List_After_And_Analyze (After, Flist); | |
1844 | |
1845 if Present (Lastn) then | |
1846 After := Prev (Lastn); | |
1847 else | |
1848 After := Last (List_Containing (After)); | |
1849 end if; | |
1850 end if; | |
1851 end Process_Flist; | |
1852 | |
1853 -- Start of processing for Freeze_All_Ent | |
1854 | |
1855 begin | |
1856 E := From; | |
1857 while Present (E) loop | |
1858 | |
1859 -- If the entity is an inner package which is not a package | |
1860 -- renaming, then its entities must be frozen at this point. Note | |
1861 -- that such entities do NOT get frozen at the end of the nested | |
1862 -- package itself (only library packages freeze). | |
1863 | |
1864 -- Same is true for task declarations, where anonymous records | |
1865 -- created for entry parameters must be frozen. | |
1866 | |
1867 if Ekind (E) = E_Package | |
1868 and then No (Renamed_Object (E)) | |
1869 and then not Is_Child_Unit (E) | |
1870 and then not Is_Frozen (E) | |
1871 then | |
1872 Push_Scope (E); | |
1873 | |
1874 Install_Visible_Declarations (E); | |
1875 Install_Private_Declarations (E); | |
1876 Freeze_All (First_Entity (E), After); | |
1877 | |
1878 End_Package_Scope (E); | |
1879 | |
1880 if Is_Generic_Instance (E) | |
1881 and then Has_Delayed_Freeze (E) | |
1882 then | |
1883 Set_Has_Delayed_Freeze (E, False); | |
1884 Expand_N_Package_Declaration (Unit_Declaration_Node (E)); | |
1885 end if; | |
1886 | |
1887 elsif Ekind (E) in Task_Kind | |
1888 and then Nkind_In (Parent (E), N_Single_Task_Declaration, | |
1889 N_Task_Type_Declaration) | |
1890 then | |
1891 Push_Scope (E); | |
1892 Freeze_All (First_Entity (E), After); | |
1893 End_Scope; | |
1894 | |
1895 -- For a derived tagged type, we must ensure that all the | |
1896 -- primitive operations of the parent have been frozen, so that | |
1897 -- their addresses will be in the parent's dispatch table at the | |
1898 -- point it is inherited. | |
1899 | |
1900 elsif Ekind (E) = E_Record_Type | |
1901 and then Is_Tagged_Type (E) | |
1902 and then Is_Tagged_Type (Etype (E)) | |
1903 and then Is_Derived_Type (E) | |
1904 then | |
1905 declare | |
1906 Prim_List : constant Elist_Id := | |
1907 Primitive_Operations (Etype (E)); | |
1908 | |
1909 Prim : Elmt_Id; | |
1910 Subp : Entity_Id; | |
1911 | |
1912 begin | |
1913 Prim := First_Elmt (Prim_List); | |
1914 while Present (Prim) loop | |
1915 Subp := Node (Prim); | |
1916 | |
1917 if Comes_From_Source (Subp) | |
1918 and then not Is_Frozen (Subp) | |
1919 then | |
1920 Flist := Freeze_Entity (Subp, After); | |
1921 Process_Flist; | |
1922 end if; | |
1923 | |
1924 Next_Elmt (Prim); | |
1925 end loop; | |
1926 end; | |
1927 end if; | |
1928 | |
1929 if not Is_Frozen (E) then | |
1930 Flist := Freeze_Entity (E, After); | |
1931 Process_Flist; | |
1932 | |
1933 -- If already frozen, and there are delayed aspects, this is where | |
1934 -- we do the visibility check for these aspects (see Sem_Ch13 spec | |
1935 -- for a description of how we handle aspect visibility). | |
1936 | |
1937 elsif Has_Delayed_Aspects (E) then | |
1938 | |
1939 -- Retrieve the visibility to the discriminants in order to | |
1940 -- analyze properly the aspects. | |
1941 | |
1942 Push_Scope_And_Install_Discriminants (E); | |
1943 | |
1944 declare | |
1945 Ritem : Node_Id; | |
1946 | |
1947 begin | |
1948 Ritem := First_Rep_Item (E); | |
1949 while Present (Ritem) loop | |
1950 if Nkind (Ritem) = N_Aspect_Specification | |
1951 and then Entity (Ritem) = E | |
1952 and then Is_Delayed_Aspect (Ritem) | |
1953 then | |
1954 Check_Aspect_At_End_Of_Declarations (Ritem); | |
1955 end if; | |
1956 | |
1957 Ritem := Next_Rep_Item (Ritem); | |
1958 end loop; | |
1959 end; | |
1960 | |
1961 Uninstall_Discriminants_And_Pop_Scope (E); | |
1962 end if; | |
1963 | |
1964 -- If an incomplete type is still not frozen, this may be a | |
1965 -- premature freezing because of a body declaration that follows. | |
1966 -- Indicate where the freezing took place. Freezing will happen | |
1967 -- if the body comes from source, but not if it is internally | |
1968 -- generated, for example as the body of a type invariant. | |
1969 | |
1970 -- If the freezing is caused by the end of the current declarative | |
1971 -- part, it is a Taft Amendment type, and there is no error. | |
1972 | |
1973 if not Is_Frozen (E) | |
1974 and then Ekind (E) = E_Incomplete_Type | |
1975 then | |
1976 declare | |
1977 Bod : constant Node_Id := Next (After); | |
1978 | |
1979 begin | |
1980 -- The presence of a body freezes all entities previously | |
1981 -- declared in the current list of declarations, but this | |
1982 -- does not apply if the body does not come from source. | |
1983 -- A type invariant is transformed into a subprogram body | |
1984 -- which is placed at the end of the private part of the | |
1985 -- current package, but this body does not freeze incomplete | |
1986 -- types that may be declared in this private part. | |
1987 | |
1988 if (Nkind_In (Bod, N_Entry_Body, | |
1989 N_Package_Body, | |
1990 N_Protected_Body, | |
1991 N_Subprogram_Body, | |
1992 N_Task_Body) | |
1993 or else Nkind (Bod) in N_Body_Stub) | |
1994 and then | |
1995 List_Containing (After) = List_Containing (Parent (E)) | |
1996 and then Comes_From_Source (Bod) | |
1997 then | |
1998 Error_Msg_Sloc := Sloc (Next (After)); | |
1999 Error_Msg_NE | |
2000 ("type& is frozen# before its full declaration", | |
2001 Parent (E), E); | |
2002 end if; | |
2003 end; | |
2004 end if; | |
2005 | |
2006 Next_Entity (E); | |
2007 end loop; | |
2008 end Freeze_All_Ent; | |
2009 | |
2010 -- Local variables | |
2011 | |
2012 Decl : Node_Id; | |
2013 E : Entity_Id; | |
2014 Item : Entity_Id; | |
2015 | |
2016 -- Start of processing for Freeze_All | |
2017 | |
2018 begin | |
2019 Freeze_All_Ent (From, After); | |
2020 | |
2021 -- Now that all types are frozen, we can deal with default expressions | |
2022 -- that require us to build a default expression functions. This is the | |
2023 -- point at which such functions are constructed (after all types that | |
2024 -- might be used in such expressions have been frozen). | |
2025 | |
2026 -- For subprograms that are renaming_as_body, we create the wrapper | |
2027 -- bodies as needed. | |
2028 | |
2029 -- We also add finalization chains to access types whose designated | |
2030 -- types are controlled. This is normally done when freezing the type, | |
2031 -- but this misses recursive type definitions where the later members | |
2032 -- of the recursion introduce controlled components. | |
2033 | |
2034 -- Loop through entities | |
2035 | |
2036 E := From; | |
2037 while Present (E) loop | |
2038 if Is_Subprogram (E) then | |
2039 if not Default_Expressions_Processed (E) then | |
2040 Process_Default_Expressions (E, After); | |
2041 end if; | |
2042 | |
2043 if not Has_Completion (E) then | |
2044 Decl := Unit_Declaration_Node (E); | |
2045 | |
2046 if Nkind (Decl) = N_Subprogram_Renaming_Declaration then | |
2047 if Error_Posted (Decl) then | |
2048 Set_Has_Completion (E); | |
2049 else | |
2050 Build_And_Analyze_Renamed_Body (Decl, E, After); | |
2051 end if; | |
2052 | |
2053 elsif Nkind (Decl) = N_Subprogram_Declaration | |
2054 and then Present (Corresponding_Body (Decl)) | |
2055 and then | |
2056 Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) = | |
2057 N_Subprogram_Renaming_Declaration | |
2058 then | |
2059 Build_And_Analyze_Renamed_Body | |
2060 (Decl, Corresponding_Body (Decl), After); | |
2061 end if; | |
2062 end if; | |
2063 | |
2064 -- Freeze the default expressions of entries, entry families, and | |
2065 -- protected subprograms. | |
2066 | |
2067 elsif Is_Concurrent_Type (E) then | |
2068 Item := First_Entity (E); | |
2069 while Present (Item) loop | |
2070 if (Is_Entry (Item) or else Is_Subprogram (Item)) | |
2071 and then not Default_Expressions_Processed (Item) | |
2072 then | |
2073 Process_Default_Expressions (Item, After); | |
2074 end if; | |
2075 | |
2076 Next_Entity (Item); | |
2077 end loop; | |
2078 end if; | |
2079 | |
2080 -- Historical note: We used to create a finalization master for an | |
2081 -- access type whose designated type is not controlled, but contains | |
2082 -- private controlled compoments. This form of postprocessing is no | |
2083 -- longer needed because the finalization master is now created when | |
2084 -- the access type is frozen (see Exp_Ch3.Freeze_Type). | |
2085 | |
2086 Next_Entity (E); | |
2087 end loop; | |
2088 end Freeze_All; | |
2089 | |
2090 ----------------------- | |
2091 -- Freeze_And_Append -- | |
2092 ----------------------- | |
2093 | |
2094 procedure Freeze_And_Append | |
2095 (Ent : Entity_Id; | |
2096 N : Node_Id; | |
2097 Result : in out List_Id) | |
2098 is | |
2099 L : constant List_Id := Freeze_Entity (Ent, N); | |
2100 begin | |
2101 if Is_Non_Empty_List (L) then | |
2102 if Result = No_List then | |
2103 Result := L; | |
2104 else | |
2105 Append_List (L, Result); | |
2106 end if; | |
2107 end if; | |
2108 end Freeze_And_Append; | |
2109 | |
2110 ------------------- | |
2111 -- Freeze_Before -- | |
2112 ------------------- | |
2113 | |
2114 procedure Freeze_Before | |
2115 (N : Node_Id; | |
2116 T : Entity_Id; | |
2117 Do_Freeze_Profile : Boolean := True) | |
2118 is | |
2119 -- Freeze T, then insert the generated Freeze nodes before the node N. | |
2120 -- Flag Freeze_Profile is used when T is an overloadable entity, and | |
2121 -- indicates whether its profile should be frozen at the same time. | |
2122 | |
2123 Freeze_Nodes : constant List_Id := | |
2124 Freeze_Entity (T, N, Do_Freeze_Profile); | |
2125 Pack : constant Entity_Id := Scope (T); | |
2126 | |
2127 begin | |
2128 if Ekind (T) = E_Function then | |
2129 Check_Expression_Function (N, T); | |
2130 end if; | |
2131 | |
2132 if Is_Non_Empty_List (Freeze_Nodes) then | |
2133 | |
2134 -- If the entity is a type declared in an inner package, it may be | |
2135 -- frozen by an outer declaration before the package itself is | |
2136 -- frozen. Install the package scope to analyze the freeze nodes, | |
2137 -- which may include generated subprograms such as predicate | |
2138 -- functions, etc. | |
2139 | |
2140 if Is_Type (T) and then From_Nested_Package (T) then | |
2141 Push_Scope (Pack); | |
2142 Install_Visible_Declarations (Pack); | |
2143 Install_Private_Declarations (Pack); | |
2144 Insert_Actions (N, Freeze_Nodes); | |
2145 End_Package_Scope (Pack); | |
2146 | |
2147 else | |
2148 Insert_Actions (N, Freeze_Nodes); | |
2149 end if; | |
2150 end if; | |
2151 end Freeze_Before; | |
2152 | |
2153 ------------------- | |
2154 -- Freeze_Entity -- | |
2155 ------------------- | |
2156 | |
2157 -- WARNING: This routine manages Ghost regions. Return statements must be | |
2158 -- replaced by gotos which jump to the end of the routine and restore the | |
2159 -- Ghost mode. | |
2160 | |
2161 function Freeze_Entity | |
2162 (E : Entity_Id; | |
2163 N : Node_Id; | |
2164 Do_Freeze_Profile : Boolean := True) return List_Id | |
2165 is | |
2166 Loc : constant Source_Ptr := Sloc (N); | |
2167 Atype : Entity_Id; | |
2168 Comp : Entity_Id; | |
2169 F_Node : Node_Id; | |
2170 Formal : Entity_Id; | |
2171 Indx : Node_Id; | |
2172 | |
2173 Has_Default_Initialization : Boolean := False; | |
2174 -- This flag gets set to true for a variable with default initialization | |
2175 | |
2176 Result : List_Id := No_List; | |
2177 -- List of freezing actions, left at No_List if none | |
2178 | |
2179 Test_E : Entity_Id := E; | |
2180 -- This could use a comment ??? | |
2181 | |
2182 procedure Add_To_Result (N : Node_Id); | |
2183 -- N is a freezing action to be appended to the Result | |
2184 | |
2185 function After_Last_Declaration return Boolean; | |
2186 -- If Loc is a freeze_entity that appears after the last declaration | |
2187 -- in the scope, inhibit error messages on late completion. | |
2188 | |
2189 procedure Check_Current_Instance (Comp_Decl : Node_Id); | |
2190 -- Check that an Access or Unchecked_Access attribute with a prefix | |
2191 -- which is the current instance type can only be applied when the type | |
2192 -- is limited. | |
2193 | |
2194 procedure Check_Suspicious_Convention (Rec_Type : Entity_Id); | |
2195 -- Give a warning for pragma Convention with language C or C++ applied | |
2196 -- to a discriminated record type. This is suppressed for the unchecked | |
2197 -- union case, since the whole point in this case is interface C. We | |
2198 -- also do not generate this within instantiations, since we will have | |
2199 -- generated a message on the template. | |
2200 | |
2201 procedure Check_Suspicious_Modulus (Utype : Entity_Id); | |
2202 -- Give warning for modulus of 8, 16, 32, or 64 given as an explicit | |
2203 -- integer literal without an explicit corresponding size clause. The | |
2204 -- caller has checked that Utype is a modular integer type. | |
2205 | |
2206 procedure Freeze_Array_Type (Arr : Entity_Id); | |
2207 -- Freeze array type, including freezing index and component types | |
2208 | |
2209 procedure Freeze_Object_Declaration (E : Entity_Id); | |
2210 -- Perform checks and generate freeze node if needed for a constant or | |
2211 -- variable declared by an object declaration. | |
2212 | |
2213 function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id; | |
2214 -- Create Freeze_Generic_Entity nodes for types declared in a generic | |
2215 -- package. Recurse on inner generic packages. | |
2216 | |
2217 function Freeze_Profile (E : Entity_Id) return Boolean; | |
2218 -- Freeze formals and return type of subprogram. If some type in the | |
2219 -- profile is incomplete and we are in an instance, freezing of the | |
2220 -- entity will take place elsewhere, and the function returns False. | |
2221 | |
2222 procedure Freeze_Record_Type (Rec : Entity_Id); | |
2223 -- Freeze record type, including freezing component types, and freezing | |
2224 -- primitive operations if this is a tagged type. | |
2225 | |
2226 function Has_Boolean_Aspect_Import (E : Entity_Id) return Boolean; | |
2227 -- Determine whether an arbitrary entity is subject to Boolean aspect | |
2228 -- Import and its value is specified as True. | |
2229 | |
2230 procedure Inherit_Freeze_Node | |
2231 (Fnod : Node_Id; | |
2232 Typ : Entity_Id); | |
2233 -- Set type Typ's freeze node to refer to Fnode. This routine ensures | |
2234 -- that any attributes attached to Typ's original node are preserved. | |
2235 | |
2236 procedure Wrap_Imported_Subprogram (E : Entity_Id); | |
2237 -- If E is an entity for an imported subprogram with pre/post-conditions | |
2238 -- then this procedure will create a wrapper to ensure that proper run- | |
2239 -- time checking of the pre/postconditions. See body for details. | |
2240 | |
2241 ------------------- | |
2242 -- Add_To_Result -- | |
2243 ------------------- | |
2244 | |
2245 procedure Add_To_Result (N : Node_Id) is | |
2246 begin | |
2247 if No (Result) then | |
2248 Result := New_List (N); | |
2249 else | |
2250 Append (N, Result); | |
2251 end if; | |
2252 end Add_To_Result; | |
2253 | |
2254 ---------------------------- | |
2255 -- After_Last_Declaration -- | |
2256 ---------------------------- | |
2257 | |
2258 function After_Last_Declaration return Boolean is | |
2259 Spec : constant Node_Id := Parent (Current_Scope); | |
2260 | |
2261 begin | |
2262 if Nkind (Spec) = N_Package_Specification then | |
2263 if Present (Private_Declarations (Spec)) then | |
2264 return Loc >= Sloc (Last (Private_Declarations (Spec))); | |
2265 elsif Present (Visible_Declarations (Spec)) then | |
2266 return Loc >= Sloc (Last (Visible_Declarations (Spec))); | |
2267 else | |
2268 return False; | |
2269 end if; | |
2270 | |
2271 else | |
2272 return False; | |
2273 end if; | |
2274 end After_Last_Declaration; | |
2275 | |
2276 ---------------------------- | |
2277 -- Check_Current_Instance -- | |
2278 ---------------------------- | |
2279 | |
2280 procedure Check_Current_Instance (Comp_Decl : Node_Id) is | |
2281 | |
2282 function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean; | |
2283 -- Determine whether Typ is compatible with the rules for aliased | |
2284 -- views of types as defined in RM 3.10 in the various dialects. | |
2285 | |
2286 function Process (N : Node_Id) return Traverse_Result; | |
2287 -- Process routine to apply check to given node | |
2288 | |
2289 ----------------------------- | |
2290 -- Is_Aliased_View_Of_Type -- | |
2291 ----------------------------- | |
2292 | |
2293 function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean is | |
2294 Typ_Decl : constant Node_Id := Parent (Typ); | |
2295 | |
2296 begin | |
2297 -- Common case | |
2298 | |
2299 if Nkind (Typ_Decl) = N_Full_Type_Declaration | |
2300 and then Limited_Present (Type_Definition (Typ_Decl)) | |
2301 then | |
2302 return True; | |
2303 | |
2304 -- The following paragraphs describe what a legal aliased view of | |
2305 -- a type is in the various dialects of Ada. | |
2306 | |
2307 -- Ada 95 | |
2308 | |
2309 -- The current instance of a limited type, and a formal parameter | |
2310 -- or generic formal object of a tagged type. | |
2311 | |
2312 -- Ada 95 limited type | |
2313 -- * Type with reserved word "limited" | |
2314 -- * A protected or task type | |
2315 -- * A composite type with limited component | |
2316 | |
2317 elsif Ada_Version <= Ada_95 then | |
2318 return Is_Limited_Type (Typ); | |
2319 | |
2320 -- Ada 2005 | |
2321 | |
2322 -- The current instance of a limited tagged type, a protected | |
2323 -- type, a task type, or a type that has the reserved word | |
2324 -- "limited" in its full definition ... a formal parameter or | |
2325 -- generic formal object of a tagged type. | |
2326 | |
2327 -- Ada 2005 limited type | |
2328 -- * Type with reserved word "limited", "synchronized", "task" | |
2329 -- or "protected" | |
2330 -- * A composite type with limited component | |
2331 -- * A derived type whose parent is a non-interface limited type | |
2332 | |
2333 elsif Ada_Version = Ada_2005 then | |
2334 return | |
2335 (Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ)) | |
2336 or else | |
2337 (Is_Derived_Type (Typ) | |
2338 and then not Is_Interface (Etype (Typ)) | |
2339 and then Is_Limited_Type (Etype (Typ))); | |
2340 | |
2341 -- Ada 2012 and beyond | |
2342 | |
2343 -- The current instance of an immutably limited type ... a formal | |
2344 -- parameter or generic formal object of a tagged type. | |
2345 | |
2346 -- Ada 2012 limited type | |
2347 -- * Type with reserved word "limited", "synchronized", "task" | |
2348 -- or "protected" | |
2349 -- * A composite type with limited component | |
2350 -- * A derived type whose parent is a non-interface limited type | |
2351 -- * An incomplete view | |
2352 | |
2353 -- Ada 2012 immutably limited type | |
2354 -- * Explicitly limited record type | |
2355 -- * Record extension with "limited" present | |
2356 -- * Non-formal limited private type that is either tagged | |
2357 -- or has at least one access discriminant with a default | |
2358 -- expression | |
2359 -- * Task type, protected type or synchronized interface | |
2360 -- * Type derived from immutably limited type | |
2361 | |
2362 else | |
2363 return | |
2364 Is_Immutably_Limited_Type (Typ) | |
2365 or else Is_Incomplete_Type (Typ); | |
2366 end if; | |
2367 end Is_Aliased_View_Of_Type; | |
2368 | |
2369 ------------- | |
2370 -- Process -- | |
2371 ------------- | |
2372 | |
2373 function Process (N : Node_Id) return Traverse_Result is | |
2374 begin | |
2375 case Nkind (N) is | |
2376 when N_Attribute_Reference => | |
2377 if Nam_In (Attribute_Name (N), Name_Access, | |
2378 Name_Unchecked_Access) | |
2379 and then Is_Entity_Name (Prefix (N)) | |
2380 and then Is_Type (Entity (Prefix (N))) | |
2381 and then Entity (Prefix (N)) = E | |
2382 then | |
2383 if Ada_Version < Ada_2012 then | |
2384 Error_Msg_N | |
2385 ("current instance must be a limited type", | |
2386 Prefix (N)); | |
2387 else | |
2388 Error_Msg_N | |
2389 ("current instance must be an immutably limited " | |
2390 & "type (RM-2012, 7.5 (8.1/3))", Prefix (N)); | |
2391 end if; | |
2392 | |
2393 return Abandon; | |
2394 | |
2395 else | |
2396 return OK; | |
2397 end if; | |
2398 | |
2399 when others => | |
2400 return OK; | |
2401 end case; | |
2402 end Process; | |
2403 | |
2404 procedure Traverse is new Traverse_Proc (Process); | |
2405 | |
2406 -- Local variables | |
2407 | |
2408 Rec_Type : constant Entity_Id := | |
2409 Scope (Defining_Identifier (Comp_Decl)); | |
2410 | |
2411 -- Start of processing for Check_Current_Instance | |
2412 | |
2413 begin | |
2414 if not Is_Aliased_View_Of_Type (Rec_Type) then | |
2415 Traverse (Comp_Decl); | |
2416 end if; | |
2417 end Check_Current_Instance; | |
2418 | |
2419 --------------------------------- | |
2420 -- Check_Suspicious_Convention -- | |
2421 --------------------------------- | |
2422 | |
2423 procedure Check_Suspicious_Convention (Rec_Type : Entity_Id) is | |
2424 begin | |
2425 if Has_Discriminants (Rec_Type) | |
2426 and then Is_Base_Type (Rec_Type) | |
2427 and then not Is_Unchecked_Union (Rec_Type) | |
2428 and then (Convention (Rec_Type) = Convention_C | |
2429 or else | |
2430 Convention (Rec_Type) = Convention_CPP) | |
2431 and then Comes_From_Source (Rec_Type) | |
2432 and then not In_Instance | |
2433 and then not Has_Warnings_Off (Rec_Type) | |
2434 then | |
2435 declare | |
2436 Cprag : constant Node_Id := | |
2437 Get_Rep_Pragma (Rec_Type, Name_Convention); | |
2438 A2 : Node_Id; | |
2439 | |
2440 begin | |
2441 if Present (Cprag) then | |
2442 A2 := Next (First (Pragma_Argument_Associations (Cprag))); | |
2443 | |
2444 if Convention (Rec_Type) = Convention_C then | |
2445 Error_Msg_N | |
2446 ("?x?discriminated record has no direct equivalent in " | |
2447 & "C", A2); | |
2448 else | |
2449 Error_Msg_N | |
2450 ("?x?discriminated record has no direct equivalent in " | |
2451 & "C++", A2); | |
2452 end if; | |
2453 | |
2454 Error_Msg_NE | |
2455 ("\?x?use of convention for type& is dubious", | |
2456 A2, Rec_Type); | |
2457 end if; | |
2458 end; | |
2459 end if; | |
2460 end Check_Suspicious_Convention; | |
2461 | |
2462 ------------------------------ | |
2463 -- Check_Suspicious_Modulus -- | |
2464 ------------------------------ | |
2465 | |
2466 procedure Check_Suspicious_Modulus (Utype : Entity_Id) is | |
2467 Decl : constant Node_Id := Declaration_Node (Underlying_Type (Utype)); | |
2468 | |
2469 begin | |
2470 if not Warn_On_Suspicious_Modulus_Value then | |
2471 return; | |
2472 end if; | |
2473 | |
2474 if Nkind (Decl) = N_Full_Type_Declaration then | |
2475 declare | |
2476 Tdef : constant Node_Id := Type_Definition (Decl); | |
2477 | |
2478 begin | |
2479 if Nkind (Tdef) = N_Modular_Type_Definition then | |
2480 declare | |
2481 Modulus : constant Node_Id := | |
2482 Original_Node (Expression (Tdef)); | |
2483 | |
2484 begin | |
2485 if Nkind (Modulus) = N_Integer_Literal then | |
2486 declare | |
2487 Modv : constant Uint := Intval (Modulus); | |
2488 Sizv : constant Uint := RM_Size (Utype); | |
2489 | |
2490 begin | |
2491 -- First case, modulus and size are the same. This | |
2492 -- happens if you have something like mod 32, with | |
2493 -- an explicit size of 32, this is for sure a case | |
2494 -- where the warning is given, since it is seems | |
2495 -- very unlikely that someone would want e.g. a | |
2496 -- five bit type stored in 32 bits. It is much | |
2497 -- more likely they wanted a 32-bit type. | |
2498 | |
2499 if Modv = Sizv then | |
2500 null; | |
2501 | |
2502 -- Second case, the modulus is 32 or 64 and no | |
2503 -- size clause is present. This is a less clear | |
2504 -- case for giving the warning, but in the case | |
2505 -- of 32/64 (5-bit or 6-bit types) these seem rare | |
2506 -- enough that it is a likely error (and in any | |
2507 -- case using 2**5 or 2**6 in these cases seems | |
2508 -- clearer. We don't include 8 or 16 here, simply | |
2509 -- because in practice 3-bit and 4-bit types are | |
2510 -- more common and too many false positives if | |
2511 -- we warn in these cases. | |
2512 | |
2513 elsif not Has_Size_Clause (Utype) | |
2514 and then (Modv = Uint_32 or else Modv = Uint_64) | |
2515 then | |
2516 null; | |
2517 | |
2518 -- No warning needed | |
2519 | |
2520 else | |
2521 return; | |
2522 end if; | |
2523 | |
2524 -- If we fall through, give warning | |
2525 | |
2526 Error_Msg_Uint_1 := Modv; | |
2527 Error_Msg_N | |
2528 ("?M?2 '*'*^' may have been intended here", | |
2529 Modulus); | |
2530 end; | |
2531 end if; | |
2532 end; | |
2533 end if; | |
2534 end; | |
2535 end if; | |
2536 end Check_Suspicious_Modulus; | |
2537 | |
2538 ----------------------- | |
2539 -- Freeze_Array_Type -- | |
2540 ----------------------- | |
2541 | |
2542 procedure Freeze_Array_Type (Arr : Entity_Id) is | |
2543 FS : constant Entity_Id := First_Subtype (Arr); | |
2544 Ctyp : constant Entity_Id := Component_Type (Arr); | |
2545 Clause : Entity_Id; | |
2546 | |
2547 Non_Standard_Enum : Boolean := False; | |
2548 -- Set true if any of the index types is an enumeration type with a | |
2549 -- non-standard representation. | |
2550 | |
2551 begin | |
2552 Freeze_And_Append (Ctyp, N, Result); | |
2553 | |
2554 Indx := First_Index (Arr); | |
2555 while Present (Indx) loop | |
2556 Freeze_And_Append (Etype (Indx), N, Result); | |
2557 | |
2558 if Is_Enumeration_Type (Etype (Indx)) | |
2559 and then Has_Non_Standard_Rep (Etype (Indx)) | |
2560 then | |
2561 Non_Standard_Enum := True; | |
2562 end if; | |
2563 | |
2564 Next_Index (Indx); | |
2565 end loop; | |
2566 | |
2567 -- Processing that is done only for base types | |
2568 | |
2569 if Ekind (Arr) = E_Array_Type then | |
2570 | |
2571 -- Deal with default setting of reverse storage order | |
2572 | |
2573 Set_SSO_From_Default (Arr); | |
2574 | |
2575 -- Propagate flags for component type | |
2576 | |
2577 if Is_Controlled (Component_Type (Arr)) | |
2578 or else Has_Controlled_Component (Ctyp) | |
2579 then | |
2580 Set_Has_Controlled_Component (Arr); | |
2581 end if; | |
2582 | |
2583 if Has_Unchecked_Union (Component_Type (Arr)) then | |
2584 Set_Has_Unchecked_Union (Arr); | |
2585 end if; | |
2586 | |
2587 -- The array type requires its own invariant procedure in order to | |
2588 -- verify the component invariant over all elements. In GNATprove | |
2589 -- mode, the component invariants are checked by other means. They | |
2590 -- should not be added to the array type invariant procedure, so | |
2591 -- that the procedure can be used to check the array type | |
2592 -- invariants if any. | |
2593 | |
2594 if Has_Invariants (Component_Type (Arr)) | |
2595 and then not GNATprove_Mode | |
2596 then | |
2597 Set_Has_Own_Invariants (Arr); | |
2598 | |
2599 -- The array type is an implementation base type. Propagate the | |
2600 -- same property to the first subtype. | |
2601 | |
2602 if Is_Itype (Arr) then | |
2603 Set_Has_Own_Invariants (First_Subtype (Arr)); | |
2604 end if; | |
2605 end if; | |
2606 | |
2607 -- Warn for pragma Pack overriding foreign convention | |
2608 | |
2609 if Has_Foreign_Convention (Ctyp) | |
2610 and then Has_Pragma_Pack (Arr) | |
2611 then | |
2612 declare | |
2613 CN : constant Name_Id := | |
2614 Get_Convention_Name (Convention (Ctyp)); | |
2615 PP : constant Node_Id := | |
2616 Get_Pragma (First_Subtype (Arr), Pragma_Pack); | |
2617 begin | |
2618 if Present (PP) then | |
2619 Error_Msg_Name_1 := CN; | |
2620 Error_Msg_Sloc := Sloc (Arr); | |
2621 Error_Msg_N | |
2622 ("pragma Pack affects convention % components #??", PP); | |
2623 Error_Msg_Name_1 := CN; | |
2624 Error_Msg_N | |
2625 ("\array components may not have % compatible " | |
2626 & "representation??", PP); | |
2627 end if; | |
2628 end; | |
2629 end if; | |
2630 | |
2631 -- If packing was requested or if the component size was | |
2632 -- set explicitly, then see if bit packing is required. This | |
2633 -- processing is only done for base types, since all of the | |
2634 -- representation aspects involved are type-related. | |
2635 | |
2636 -- This is not just an optimization, if we start processing the | |
2637 -- subtypes, they interfere with the settings on the base type | |
2638 -- (this is because Is_Packed has a slightly different meaning | |
2639 -- before and after freezing). | |
2640 | |
2641 declare | |
2642 Csiz : Uint; | |
2643 Esiz : Uint; | |
2644 | |
2645 begin | |
2646 if (Is_Packed (Arr) or else Has_Pragma_Pack (Arr)) | |
2647 and then Known_Static_RM_Size (Ctyp) | |
2648 and then not Has_Component_Size_Clause (Arr) | |
2649 then | |
2650 Csiz := UI_Max (RM_Size (Ctyp), 1); | |
2651 | |
2652 elsif Known_Component_Size (Arr) then | |
2653 Csiz := Component_Size (Arr); | |
2654 | |
2655 elsif not Known_Static_Esize (Ctyp) then | |
2656 Csiz := Uint_0; | |
2657 | |
2658 else | |
2659 Esiz := Esize (Ctyp); | |
2660 | |
2661 -- We can set the component size if it is less than 16, | |
2662 -- rounding it up to the next storage unit size. | |
2663 | |
2664 if Esiz <= 8 then | |
2665 Csiz := Uint_8; | |
2666 elsif Esiz <= 16 then | |
2667 Csiz := Uint_16; | |
2668 else | |
2669 Csiz := Uint_0; | |
2670 end if; | |
2671 | |
2672 -- Set component size up to match alignment if it would | |
2673 -- otherwise be less than the alignment. This deals with | |
2674 -- cases of types whose alignment exceeds their size (the | |
2675 -- padded type cases). | |
2676 | |
2677 if Csiz /= 0 then | |
2678 declare | |
2679 A : constant Uint := Alignment_In_Bits (Ctyp); | |
2680 begin | |
2681 if Csiz < A then | |
2682 Csiz := A; | |
2683 end if; | |
2684 end; | |
2685 end if; | |
2686 end if; | |
2687 | |
2688 -- Case of component size that may result in bit packing | |
2689 | |
2690 if 1 <= Csiz and then Csiz <= 64 then | |
2691 declare | |
2692 Ent : constant Entity_Id := | |
2693 First_Subtype (Arr); | |
2694 Pack_Pragma : constant Node_Id := | |
2695 Get_Rep_Pragma (Ent, Name_Pack); | |
2696 Comp_Size_C : constant Node_Id := | |
2697 Get_Attribute_Definition_Clause | |
2698 (Ent, Attribute_Component_Size); | |
2699 | |
2700 begin | |
2701 -- Warn if we have pack and component size so that the | |
2702 -- pack is ignored. | |
2703 | |
2704 -- Note: here we must check for the presence of a | |
2705 -- component size before checking for a Pack pragma to | |
2706 -- deal with the case where the array type is a derived | |
2707 -- type whose parent is currently private. | |
2708 | |
2709 if Present (Comp_Size_C) | |
2710 and then Has_Pragma_Pack (Ent) | |
2711 and then Warn_On_Redundant_Constructs | |
2712 then | |
2713 Error_Msg_Sloc := Sloc (Comp_Size_C); | |
2714 Error_Msg_NE | |
2715 ("?r?pragma Pack for& ignored!", Pack_Pragma, Ent); | |
2716 Error_Msg_N | |
2717 ("\?r?explicit component size given#!", Pack_Pragma); | |
2718 Set_Is_Packed (Base_Type (Ent), False); | |
2719 Set_Is_Bit_Packed_Array (Base_Type (Ent), False); | |
2720 end if; | |
2721 | |
2722 -- Set component size if not already set by a component | |
2723 -- size clause. | |
2724 | |
2725 if not Present (Comp_Size_C) then | |
2726 Set_Component_Size (Arr, Csiz); | |
2727 end if; | |
2728 | |
2729 -- Check for base type of 8, 16, 32 bits, where an | |
2730 -- unsigned subtype has a length one less than the | |
2731 -- base type (e.g. Natural subtype of Integer). | |
2732 | |
2733 -- In such cases, if a component size was not set | |
2734 -- explicitly, then generate a warning. | |
2735 | |
2736 if Has_Pragma_Pack (Arr) | |
2737 and then not Present (Comp_Size_C) | |
2738 and then (Csiz = 7 or else Csiz = 15 or else Csiz = 31) | |
2739 and then Esize (Base_Type (Ctyp)) = Csiz + 1 | |
2740 then | |
2741 Error_Msg_Uint_1 := Csiz; | |
2742 | |
2743 if Present (Pack_Pragma) then | |
2744 Error_Msg_N | |
2745 ("??pragma Pack causes component size to be ^!", | |
2746 Pack_Pragma); | |
2747 Error_Msg_N | |
2748 ("\??use Component_Size to set desired value!", | |
2749 Pack_Pragma); | |
2750 end if; | |
2751 end if; | |
2752 | |
2753 -- Bit packing is never needed for 8, 16, 32, 64 | |
2754 | |
2755 if Addressable (Csiz) then | |
2756 | |
2757 -- If the Esize of the component is known and equal to | |
2758 -- the component size then even packing is not needed. | |
2759 | |
2760 if Known_Static_Esize (Component_Type (Arr)) | |
2761 and then Esize (Component_Type (Arr)) = Csiz | |
2762 then | |
2763 -- Here the array was requested to be packed, but | |
2764 -- the packing request had no effect whatsoever, | |
2765 -- so flag Is_Packed is reset. | |
2766 | |
2767 -- Note: semantically this means that we lose track | |
2768 -- of the fact that a derived type inherited pragma | |
2769 -- Pack that was non-effective, but that is fine. | |
2770 | |
2771 -- We regard a Pack pragma as a request to set a | |
2772 -- representation characteristic, and this request | |
2773 -- may be ignored. | |
2774 | |
2775 Set_Is_Packed (Base_Type (Arr), False); | |
2776 Set_Has_Non_Standard_Rep (Base_Type (Arr), False); | |
2777 else | |
2778 Set_Is_Packed (Base_Type (Arr), True); | |
2779 Set_Has_Non_Standard_Rep (Base_Type (Arr), True); | |
2780 end if; | |
2781 | |
2782 Set_Is_Bit_Packed_Array (Base_Type (Arr), False); | |
2783 | |
2784 -- Bit packing is not needed for multiples of the storage | |
2785 -- unit if the type is composite because the back end can | |
2786 -- byte pack composite types. | |
2787 | |
2788 elsif Csiz mod System_Storage_Unit = 0 | |
2789 and then Is_Composite_Type (Ctyp) | |
2790 then | |
2791 | |
2792 Set_Is_Packed (Base_Type (Arr), True); | |
2793 Set_Has_Non_Standard_Rep (Base_Type (Arr), True); | |
2794 Set_Is_Bit_Packed_Array (Base_Type (Arr), False); | |
2795 | |
2796 -- In all other cases, bit packing is needed | |
2797 | |
2798 else | |
2799 Set_Is_Packed (Base_Type (Arr), True); | |
2800 Set_Has_Non_Standard_Rep (Base_Type (Arr), True); | |
2801 Set_Is_Bit_Packed_Array (Base_Type (Arr), True); | |
2802 end if; | |
2803 end; | |
2804 end if; | |
2805 end; | |
2806 | |
2807 -- Check for Aliased or Atomic_Components/Atomic/VFA with | |
2808 -- unsuitable packing or explicit component size clause given. | |
2809 | |
2810 if (Has_Aliased_Components (Arr) | |
2811 or else Has_Atomic_Components (Arr) | |
2812 or else Is_Atomic_Or_VFA (Ctyp)) | |
2813 and then | |
2814 (Has_Component_Size_Clause (Arr) or else Is_Packed (Arr)) | |
2815 then | |
2816 Alias_Atomic_Check : declare | |
2817 | |
2818 procedure Complain_CS (T : String); | |
2819 -- Outputs error messages for incorrect CS clause or pragma | |
2820 -- Pack for aliased or atomic/VFA components (T is "aliased" | |
2821 -- or "atomic/vfa"); | |
2822 | |
2823 ----------------- | |
2824 -- Complain_CS -- | |
2825 ----------------- | |
2826 | |
2827 procedure Complain_CS (T : String) is | |
2828 begin | |
2829 if Has_Component_Size_Clause (Arr) then | |
2830 Clause := | |
2831 Get_Attribute_Definition_Clause | |
2832 (FS, Attribute_Component_Size); | |
2833 | |
2834 Error_Msg_N | |
2835 ("incorrect component size for " | |
2836 & T & " components", Clause); | |
2837 Error_Msg_Uint_1 := Esize (Ctyp); | |
2838 Error_Msg_N | |
2839 ("\only allowed value is^", Clause); | |
2840 | |
2841 else | |
2842 Error_Msg_N | |
2843 ("cannot pack " & T & " components", | |
2844 Get_Rep_Pragma (FS, Name_Pack)); | |
2845 end if; | |
2846 end Complain_CS; | |
2847 | |
2848 -- Start of processing for Alias_Atomic_Check | |
2849 | |
2850 begin | |
2851 -- If object size of component type isn't known, we cannot | |
2852 -- be sure so we defer to the back end. | |
2853 | |
2854 if not Known_Static_Esize (Ctyp) then | |
2855 null; | |
2856 | |
2857 -- Case where component size has no effect. First check for | |
2858 -- object size of component type multiple of the storage | |
2859 -- unit size. | |
2860 | |
2861 elsif Esize (Ctyp) mod System_Storage_Unit = 0 | |
2862 | |
2863 -- OK in both packing case and component size case if RM | |
2864 -- size is known and static and same as the object size. | |
2865 | |
2866 and then | |
2867 ((Known_Static_RM_Size (Ctyp) | |
2868 and then Esize (Ctyp) = RM_Size (Ctyp)) | |
2869 | |
2870 -- Or if we have an explicit component size clause and | |
2871 -- the component size and object size are equal. | |
2872 | |
2873 or else | |
2874 (Has_Component_Size_Clause (Arr) | |
2875 and then Component_Size (Arr) = Esize (Ctyp))) | |
2876 then | |
2877 null; | |
2878 | |
2879 elsif Has_Aliased_Components (Arr) then | |
2880 Complain_CS ("aliased"); | |
2881 | |
2882 elsif Has_Atomic_Components (Arr) | |
2883 or else Is_Atomic (Ctyp) | |
2884 then | |
2885 Complain_CS ("atomic"); | |
2886 | |
2887 elsif Is_Volatile_Full_Access (Ctyp) then | |
2888 Complain_CS ("volatile full access"); | |
2889 end if; | |
2890 end Alias_Atomic_Check; | |
2891 end if; | |
2892 | |
2893 -- Check for Independent_Components/Independent with unsuitable | |
2894 -- packing or explicit component size clause given. | |
2895 | |
2896 if (Has_Independent_Components (Arr) or else Is_Independent (Ctyp)) | |
2897 and then | |
2898 (Has_Component_Size_Clause (Arr) or else Is_Packed (Arr)) | |
2899 then | |
2900 begin | |
2901 -- If object size of component type isn't known, we cannot | |
2902 -- be sure so we defer to the back end. | |
2903 | |
2904 if not Known_Static_Esize (Ctyp) then | |
2905 null; | |
2906 | |
2907 -- Case where component size has no effect. First check for | |
2908 -- object size of component type multiple of the storage | |
2909 -- unit size. | |
2910 | |
2911 elsif Esize (Ctyp) mod System_Storage_Unit = 0 | |
2912 | |
2913 -- OK in both packing case and component size case if RM | |
2914 -- size is known and multiple of the storage unit size. | |
2915 | |
2916 and then | |
2917 ((Known_Static_RM_Size (Ctyp) | |
2918 and then RM_Size (Ctyp) mod System_Storage_Unit = 0) | |
2919 | |
2920 -- Or if we have an explicit component size clause and | |
2921 -- the component size is larger than the object size. | |
2922 | |
2923 or else | |
2924 (Has_Component_Size_Clause (Arr) | |
2925 and then Component_Size (Arr) >= Esize (Ctyp))) | |
2926 then | |
2927 null; | |
2928 | |
2929 else | |
2930 if Has_Component_Size_Clause (Arr) then | |
2931 Clause := | |
2932 Get_Attribute_Definition_Clause | |
2933 (FS, Attribute_Component_Size); | |
2934 | |
2935 Error_Msg_N | |
2936 ("incorrect component size for " | |
2937 & "independent components", Clause); | |
2938 Error_Msg_Uint_1 := Esize (Ctyp); | |
2939 Error_Msg_N | |
2940 ("\minimum allowed is^", Clause); | |
2941 | |
2942 else | |
2943 Error_Msg_N | |
2944 ("cannot pack independent components", | |
2945 Get_Rep_Pragma (FS, Name_Pack)); | |
2946 end if; | |
2947 end if; | |
2948 end; | |
2949 end if; | |
2950 | |
2951 -- Warn for case of atomic type | |
2952 | |
2953 Clause := Get_Rep_Pragma (FS, Name_Atomic); | |
2954 | |
2955 if Present (Clause) | |
2956 and then not Addressable (Component_Size (FS)) | |
2957 then | |
2958 Error_Msg_NE | |
2959 ("non-atomic components of type& may not be " | |
2960 & "accessible by separate tasks??", Clause, Arr); | |
2961 | |
2962 if Has_Component_Size_Clause (Arr) then | |
2963 Error_Msg_Sloc := Sloc (Get_Attribute_Definition_Clause | |
2964 (FS, Attribute_Component_Size)); | |
2965 Error_Msg_N ("\because of component size clause#??", Clause); | |
2966 | |
2967 elsif Has_Pragma_Pack (Arr) then | |
2968 Error_Msg_Sloc := Sloc (Get_Rep_Pragma (FS, Name_Pack)); | |
2969 Error_Msg_N ("\because of pragma Pack#??", Clause); | |
2970 end if; | |
2971 end if; | |
2972 | |
2973 -- Check for scalar storage order | |
2974 | |
2975 declare | |
2976 Dummy : Boolean; | |
2977 begin | |
2978 Check_Component_Storage_Order | |
2979 (Encl_Type => Arr, | |
2980 Comp => Empty, | |
2981 ADC => Get_Attribute_Definition_Clause | |
2982 (First_Subtype (Arr), | |
2983 Attribute_Scalar_Storage_Order), | |
2984 Comp_ADC_Present => Dummy); | |
2985 end; | |
2986 | |
2987 -- Processing that is done only for subtypes | |
2988 | |
2989 else | |
2990 -- Acquire alignment from base type | |
2991 | |
2992 if Unknown_Alignment (Arr) then | |
2993 Set_Alignment (Arr, Alignment (Base_Type (Arr))); | |
2994 Adjust_Esize_Alignment (Arr); | |
2995 end if; | |
2996 end if; | |
2997 | |
2998 -- Specific checks for bit-packed arrays | |
2999 | |
3000 if Is_Bit_Packed_Array (Arr) then | |
3001 | |
3002 -- Check number of elements for bit-packed arrays that come from | |
3003 -- source and have compile time known ranges. The bit-packed | |
3004 -- arrays circuitry does not support arrays with more than | |
3005 -- Integer'Last + 1 elements, and when this restriction is | |
3006 -- violated, causes incorrect data access. | |
3007 | |
3008 -- For the case where this is not compile time known, a run-time | |
3009 -- check should be generated??? | |
3010 | |
3011 if Comes_From_Source (Arr) and then Is_Constrained (Arr) then | |
3012 declare | |
3013 Elmts : Uint; | |
3014 Index : Node_Id; | |
3015 Ilen : Node_Id; | |
3016 Ityp : Entity_Id; | |
3017 | |
3018 begin | |
3019 Elmts := Uint_1; | |
3020 Index := First_Index (Arr); | |
3021 while Present (Index) loop | |
3022 Ityp := Etype (Index); | |
3023 | |
3024 -- Never generate an error if any index is of a generic | |
3025 -- type. We will check this in instances. | |
3026 | |
3027 if Is_Generic_Type (Ityp) then | |
3028 Elmts := Uint_0; | |
3029 exit; | |
3030 end if; | |
3031 | |
3032 Ilen := | |
3033 Make_Attribute_Reference (Loc, | |
3034 Prefix => New_Occurrence_Of (Ityp, Loc), | |
3035 Attribute_Name => Name_Range_Length); | |
3036 Analyze_And_Resolve (Ilen); | |
3037 | |
3038 -- No attempt is made to check number of elements if not | |
3039 -- compile time known. | |
3040 | |
3041 if Nkind (Ilen) /= N_Integer_Literal then | |
3042 Elmts := Uint_0; | |
3043 exit; | |
3044 end if; | |
3045 | |
3046 Elmts := Elmts * Intval (Ilen); | |
3047 Next_Index (Index); | |
3048 end loop; | |
3049 | |
3050 if Elmts > Intval (High_Bound | |
3051 (Scalar_Range (Standard_Integer))) + 1 | |
3052 then | |
3053 Error_Msg_N | |
3054 ("bit packed array type may not have " | |
3055 & "more than Integer''Last+1 elements", Arr); | |
3056 end if; | |
3057 end; | |
3058 end if; | |
3059 | |
3060 -- Check size | |
3061 | |
3062 if Known_RM_Size (Arr) then | |
3063 declare | |
3064 SizC : constant Node_Id := Size_Clause (Arr); | |
3065 Discard : Boolean; | |
3066 | |
3067 begin | |
3068 -- It is not clear if it is possible to have no size clause | |
3069 -- at this stage, but it is not worth worrying about. Post | |
3070 -- error on the entity name in the size clause if present, | |
3071 -- else on the type entity itself. | |
3072 | |
3073 if Present (SizC) then | |
3074 Check_Size (Name (SizC), Arr, RM_Size (Arr), Discard); | |
3075 else | |
3076 Check_Size (Arr, Arr, RM_Size (Arr), Discard); | |
3077 end if; | |
3078 end; | |
3079 end if; | |
3080 end if; | |
3081 | |
3082 -- If any of the index types was an enumeration type with a non- | |
3083 -- standard rep clause, then we indicate that the array type is | |
3084 -- always packed (even if it is not bit-packed). | |
3085 | |
3086 if Non_Standard_Enum then | |
3087 Set_Has_Non_Standard_Rep (Base_Type (Arr)); | |
3088 Set_Is_Packed (Base_Type (Arr)); | |
3089 end if; | |
3090 | |
3091 Set_Component_Alignment_If_Not_Set (Arr); | |
3092 | |
3093 -- If the array is packed and bit-packed or packed to eliminate holes | |
3094 -- in the non-contiguous enumeration index types, we must create the | |
3095 -- packed array type to be used to actually implement the type. This | |
3096 -- is only needed for real array types (not for string literal types, | |
3097 -- since they are present only for the front end). | |
3098 | |
3099 if Is_Packed (Arr) | |
3100 and then (Is_Bit_Packed_Array (Arr) or else Non_Standard_Enum) | |
3101 and then Ekind (Arr) /= E_String_Literal_Subtype | |
3102 then | |
3103 Create_Packed_Array_Impl_Type (Arr); | |
3104 Freeze_And_Append (Packed_Array_Impl_Type (Arr), N, Result); | |
3105 | |
3106 -- Make sure that we have the necessary routines to implement the | |
3107 -- packing, and complain now if not. Note that we only test this | |
3108 -- for constrained array types. | |
3109 | |
3110 if Is_Constrained (Arr) | |
3111 and then Is_Bit_Packed_Array (Arr) | |
3112 and then Present (Packed_Array_Impl_Type (Arr)) | |
3113 and then Is_Array_Type (Packed_Array_Impl_Type (Arr)) | |
3114 then | |
3115 declare | |
3116 CS : constant Uint := Component_Size (Arr); | |
3117 RE : constant RE_Id := Get_Id (UI_To_Int (CS)); | |
3118 | |
3119 begin | |
3120 if RE /= RE_Null | |
3121 and then not RTE_Available (RE) | |
3122 then | |
3123 Error_Msg_CRT | |
3124 ("packing of " & UI_Image (CS) & "-bit components", | |
3125 First_Subtype (Etype (Arr))); | |
3126 | |
3127 -- Cancel the packing | |
3128 | |
3129 Set_Is_Packed (Base_Type (Arr), False); | |
3130 Set_Is_Bit_Packed_Array (Base_Type (Arr), False); | |
3131 Set_Packed_Array_Impl_Type (Arr, Empty); | |
3132 goto Skip_Packed; | |
3133 end if; | |
3134 end; | |
3135 end if; | |
3136 | |
3137 -- Size information of packed array type is copied to the array | |
3138 -- type, since this is really the representation. But do not | |
3139 -- override explicit existing size values. If the ancestor subtype | |
3140 -- is constrained the Packed_Array_Impl_Type will be inherited | |
3141 -- from it, but the size may have been provided already, and | |
3142 -- must not be overridden either. | |
3143 | |
3144 if not Has_Size_Clause (Arr) | |
3145 and then | |
3146 (No (Ancestor_Subtype (Arr)) | |
3147 or else not Has_Size_Clause (Ancestor_Subtype (Arr))) | |
3148 then | |
3149 Set_Esize (Arr, Esize (Packed_Array_Impl_Type (Arr))); | |
3150 Set_RM_Size (Arr, RM_Size (Packed_Array_Impl_Type (Arr))); | |
3151 end if; | |
3152 | |
3153 if not Has_Alignment_Clause (Arr) then | |
3154 Set_Alignment (Arr, Alignment (Packed_Array_Impl_Type (Arr))); | |
3155 end if; | |
3156 end if; | |
3157 | |
3158 <<Skip_Packed>> | |
3159 | |
3160 -- For non-packed arrays set the alignment of the array to the | |
3161 -- alignment of the component type if it is unknown. Skip this | |
3162 -- in atomic/VFA case (atomic/VFA arrays may need larger alignments). | |
3163 | |
3164 if not Is_Packed (Arr) | |
3165 and then Unknown_Alignment (Arr) | |
3166 and then Known_Alignment (Ctyp) | |
3167 and then Known_Static_Component_Size (Arr) | |
3168 and then Known_Static_Esize (Ctyp) | |
3169 and then Esize (Ctyp) = Component_Size (Arr) | |
3170 and then not Is_Atomic_Or_VFA (Arr) | |
3171 then | |
3172 Set_Alignment (Arr, Alignment (Component_Type (Arr))); | |
3173 end if; | |
3174 | |
3175 -- A Ghost type cannot have a component of protected or task type | |
3176 -- (SPARK RM 6.9(19)). | |
3177 | |
3178 if Is_Ghost_Entity (Arr) and then Is_Concurrent_Type (Ctyp) then | |
3179 Error_Msg_N | |
3180 ("ghost array type & cannot have concurrent component type", | |
3181 Arr); | |
3182 end if; | |
3183 end Freeze_Array_Type; | |
3184 | |
3185 ------------------------------- | |
3186 -- Freeze_Object_Declaration -- | |
3187 ------------------------------- | |
3188 | |
3189 procedure Freeze_Object_Declaration (E : Entity_Id) is | |
3190 begin | |
3191 -- Abstract type allowed only for C++ imported variables or constants | |
3192 | |
3193 -- Note: we inhibit this check for objects that do not come from | |
3194 -- source because there is at least one case (the expansion of | |
3195 -- x'Class'Input where x is abstract) where we legitimately | |
3196 -- generate an abstract object. | |
3197 | |
3198 if Is_Abstract_Type (Etype (E)) | |
3199 and then Comes_From_Source (Parent (E)) | |
3200 and then not (Is_Imported (E) and then Is_CPP_Class (Etype (E))) | |
3201 then | |
3202 Error_Msg_N ("type of object cannot be abstract", | |
3203 Object_Definition (Parent (E))); | |
3204 | |
3205 if Is_CPP_Class (Etype (E)) then | |
3206 Error_Msg_NE | |
3207 ("\} may need a cpp_constructor", | |
3208 Object_Definition (Parent (E)), Etype (E)); | |
3209 | |
3210 elsif Present (Expression (Parent (E))) then | |
3211 Error_Msg_N -- CODEFIX | |
3212 ("\maybe a class-wide type was meant", | |
3213 Object_Definition (Parent (E))); | |
3214 end if; | |
3215 end if; | |
3216 | |
3217 -- For object created by object declaration, perform required | |
3218 -- categorization (preelaborate and pure) checks. Defer these | |
3219 -- checks to freeze time since pragma Import inhibits default | |
3220 -- initialization and thus pragma Import affects these checks. | |
3221 | |
3222 Validate_Object_Declaration (Declaration_Node (E)); | |
3223 | |
3224 -- If there is an address clause, check that it is valid | |
3225 -- and if need be move initialization to the freeze node. | |
3226 | |
3227 Check_Address_Clause (E); | |
3228 | |
3229 -- Similar processing is needed for aspects that may affect | |
3230 -- object layout, like Alignment, if there is an initialization | |
3231 -- expression. We don't do this if there is a pragma Linker_Section, | |
3232 -- because it would prevent the back end from statically initializing | |
3233 -- the object; we don't want elaboration code in that case. | |
3234 | |
3235 if Has_Delayed_Aspects (E) | |
3236 and then Expander_Active | |
3237 and then Is_Array_Type (Etype (E)) | |
3238 and then Present (Expression (Parent (E))) | |
3239 and then No (Linker_Section_Pragma (E)) | |
3240 then | |
3241 declare | |
3242 Decl : constant Node_Id := Parent (E); | |
3243 Lhs : constant Node_Id := New_Occurrence_Of (E, Loc); | |
3244 | |
3245 begin | |
3246 | |
3247 -- Capture initialization value at point of declaration, and | |
3248 -- make explicit assignment legal, because object may be a | |
3249 -- constant. | |
3250 | |
3251 Remove_Side_Effects (Expression (Decl)); | |
3252 Set_Assignment_OK (Lhs); | |
3253 | |
3254 -- Move initialization to freeze actions. | |
3255 | |
3256 Append_Freeze_Action (E, | |
3257 Make_Assignment_Statement (Loc, | |
3258 Name => Lhs, | |
3259 Expression => Expression (Decl))); | |
3260 | |
3261 Set_No_Initialization (Decl); | |
3262 -- Set_Is_Frozen (E, False); | |
3263 end; | |
3264 end if; | |
3265 | |
3266 -- Reset Is_True_Constant for non-constant aliased object. We | |
3267 -- consider that the fact that a non-constant object is aliased may | |
3268 -- indicate that some funny business is going on, e.g. an aliased | |
3269 -- object is passed by reference to a procedure which captures the | |
3270 -- address of the object, which is later used to assign a new value, | |
3271 -- even though the compiler thinks that it is not modified. Such | |
3272 -- code is highly dubious, but we choose to make it "work" for | |
3273 -- non-constant aliased objects. | |
3274 | |
3275 -- Note that we used to do this for all aliased objects, whether or | |
3276 -- not constant, but this caused anomalies down the line because we | |
3277 -- ended up with static objects that were not Is_True_Constant. Not | |
3278 -- resetting Is_True_Constant for (aliased) constant objects ensures | |
3279 -- that this anomaly never occurs. | |
3280 | |
3281 -- However, we don't do that for internal entities. We figure that if | |
3282 -- we deliberately set Is_True_Constant for an internal entity, e.g. | |
3283 -- a dispatch table entry, then we mean it. | |
3284 | |
3285 if Ekind (E) /= E_Constant | |
3286 and then (Is_Aliased (E) or else Is_Aliased (Etype (E))) | |
3287 and then not Is_Internal_Name (Chars (E)) | |
3288 then | |
3289 Set_Is_True_Constant (E, False); | |
3290 end if; | |
3291 | |
3292 -- If the object needs any kind of default initialization, an error | |
3293 -- must be issued if No_Default_Initialization applies. The check | |
3294 -- doesn't apply to imported objects, which are not ever default | |
3295 -- initialized, and is why the check is deferred until freezing, at | |
3296 -- which point we know if Import applies. Deferred constants are also | |
3297 -- exempted from this test because their completion is explicit, or | |
3298 -- through an import pragma. | |
3299 | |
3300 if Ekind (E) = E_Constant and then Present (Full_View (E)) then | |
3301 null; | |
3302 | |
3303 elsif Comes_From_Source (E) | |
3304 and then not Is_Imported (E) | |
3305 and then not Has_Init_Expression (Declaration_Node (E)) | |
3306 and then | |
3307 ((Has_Non_Null_Base_Init_Proc (Etype (E)) | |
3308 and then not No_Initialization (Declaration_Node (E)) | |
3309 and then not Initialization_Suppressed (Etype (E))) | |
3310 or else | |
3311 (Needs_Simple_Initialization (Etype (E)) | |
3312 and then not Is_Internal (E))) | |
3313 then | |
3314 Has_Default_Initialization := True; | |
3315 Check_Restriction | |
3316 (No_Default_Initialization, Declaration_Node (E)); | |
3317 end if; | |
3318 | |
3319 -- Check that a Thread_Local_Storage variable does not have | |
3320 -- default initialization, and any explicit initialization must | |
3321 -- either be the null constant or a static constant. | |
3322 | |
3323 if Has_Pragma_Thread_Local_Storage (E) then | |
3324 declare | |
3325 Decl : constant Node_Id := Declaration_Node (E); | |
3326 begin | |
3327 if Has_Default_Initialization | |
3328 or else | |
3329 (Has_Init_Expression (Decl) | |
3330 and then | |
3331 (No (Expression (Decl)) | |
3332 or else not | |
3333 (Is_OK_Static_Expression (Expression (Decl)) | |
3334 or else Nkind (Expression (Decl)) = N_Null))) | |
3335 then | |
3336 Error_Msg_NE | |
3337 ("Thread_Local_Storage variable& is " | |
3338 & "improperly initialized", Decl, E); | |
3339 Error_Msg_NE | |
3340 ("\only allowed initialization is explicit " | |
3341 & "NULL or static expression", Decl, E); | |
3342 end if; | |
3343 end; | |
3344 end if; | |
3345 | |
3346 -- For imported objects, set Is_Public unless there is also an | |
3347 -- address clause, which means that there is no external symbol | |
3348 -- needed for the Import (Is_Public may still be set for other | |
3349 -- unrelated reasons). Note that we delayed this processing | |
3350 -- till freeze time so that we can be sure not to set the flag | |
3351 -- if there is an address clause. If there is such a clause, | |
3352 -- then the only purpose of the Import pragma is to suppress | |
3353 -- implicit initialization. | |
3354 | |
3355 if Is_Imported (E) and then No (Address_Clause (E)) then | |
3356 Set_Is_Public (E); | |
3357 end if; | |
3358 | |
3359 -- For source objects that are not Imported and are library | |
3360 -- level, if no linker section pragma was given inherit the | |
3361 -- appropriate linker section from the corresponding type. | |
3362 | |
3363 if Comes_From_Source (E) | |
3364 and then not Is_Imported (E) | |
3365 and then Is_Library_Level_Entity (E) | |
3366 and then No (Linker_Section_Pragma (E)) | |
3367 then | |
3368 Set_Linker_Section_Pragma | |
3369 (E, Linker_Section_Pragma (Etype (E))); | |
3370 end if; | |
3371 | |
3372 -- For convention C objects of an enumeration type, warn if the | |
3373 -- size is not integer size and no explicit size given. Skip | |
3374 -- warning for Boolean, and Character, assume programmer expects | |
3375 -- 8-bit sizes for these cases. | |
3376 | |
3377 if (Convention (E) = Convention_C | |
3378 or else | |
3379 Convention (E) = Convention_CPP) | |
3380 and then Is_Enumeration_Type (Etype (E)) | |
3381 and then not Is_Character_Type (Etype (E)) | |
3382 and then not Is_Boolean_Type (Etype (E)) | |
3383 and then Esize (Etype (E)) < Standard_Integer_Size | |
3384 and then not Has_Size_Clause (E) | |
3385 then | |
3386 Error_Msg_Uint_1 := UI_From_Int (Standard_Integer_Size); | |
3387 Error_Msg_N | |
3388 ("??convention C enumeration object has size less than ^", E); | |
3389 Error_Msg_N ("\??use explicit size clause to set size", E); | |
3390 end if; | |
3391 end Freeze_Object_Declaration; | |
3392 | |
3393 ----------------------------- | |
3394 -- Freeze_Generic_Entities -- | |
3395 ----------------------------- | |
3396 | |
3397 function Freeze_Generic_Entities (Pack : Entity_Id) return List_Id is | |
3398 E : Entity_Id; | |
3399 F : Node_Id; | |
3400 Flist : List_Id; | |
3401 | |
3402 begin | |
3403 Flist := New_List; | |
3404 E := First_Entity (Pack); | |
3405 while Present (E) loop | |
3406 if Is_Type (E) and then not Is_Generic_Type (E) then | |
3407 F := Make_Freeze_Generic_Entity (Sloc (Pack)); | |
3408 Set_Entity (F, E); | |
3409 Append_To (Flist, F); | |
3410 | |
3411 elsif Ekind (E) = E_Generic_Package then | |
3412 Append_List_To (Flist, Freeze_Generic_Entities (E)); | |
3413 end if; | |
3414 | |
3415 Next_Entity (E); | |
3416 end loop; | |
3417 | |
3418 return Flist; | |
3419 end Freeze_Generic_Entities; | |
3420 | |
3421 -------------------- | |
3422 -- Freeze_Profile -- | |
3423 -------------------- | |
3424 | |
3425 function Freeze_Profile (E : Entity_Id) return Boolean is | |
3426 F_Type : Entity_Id; | |
3427 R_Type : Entity_Id; | |
3428 Warn_Node : Node_Id; | |
3429 | |
3430 begin | |
3431 -- Loop through formals | |
3432 | |
3433 Formal := First_Formal (E); | |
3434 while Present (Formal) loop | |
3435 F_Type := Etype (Formal); | |
3436 | |
3437 -- AI05-0151: incomplete types can appear in a profile. By the | |
3438 -- time the entity is frozen, the full view must be available, | |
3439 -- unless it is a limited view. | |
3440 | |
3441 if Is_Incomplete_Type (F_Type) | |
3442 and then Present (Full_View (F_Type)) | |
3443 and then not From_Limited_With (F_Type) | |
3444 then | |
3445 F_Type := Full_View (F_Type); | |
3446 Set_Etype (Formal, F_Type); | |
3447 end if; | |
3448 | |
3449 if not From_Limited_With (F_Type) then | |
3450 Freeze_And_Append (F_Type, N, Result); | |
3451 end if; | |
3452 | |
3453 if Is_Private_Type (F_Type) | |
3454 and then Is_Private_Type (Base_Type (F_Type)) | |
3455 and then No (Full_View (Base_Type (F_Type))) | |
3456 and then not Is_Generic_Type (F_Type) | |
3457 and then not Is_Derived_Type (F_Type) | |
3458 then | |
3459 -- If the type of a formal is incomplete, subprogram is being | |
3460 -- frozen prematurely. Within an instance (but not within a | |
3461 -- wrapper package) this is an artifact of our need to regard | |
3462 -- the end of an instantiation as a freeze point. Otherwise it | |
3463 -- is a definite error. | |
3464 | |
3465 if In_Instance then | |
3466 Set_Is_Frozen (E, False); | |
3467 Result := No_List; | |
3468 return False; | |
3469 | |
3470 elsif not After_Last_Declaration | |
3471 and then not Freezing_Library_Level_Tagged_Type | |
3472 then | |
3473 Error_Msg_Node_1 := F_Type; | |
3474 Error_Msg | |
3475 ("type & must be fully defined before this point", Loc); | |
3476 end if; | |
3477 end if; | |
3478 | |
3479 -- Check suspicious parameter for C function. These tests apply | |
3480 -- only to exported/imported subprograms. | |
3481 | |
3482 if Warn_On_Export_Import | |
3483 and then Comes_From_Source (E) | |
3484 and then (Convention (E) = Convention_C | |
3485 or else | |
3486 Convention (E) = Convention_CPP) | |
3487 and then (Is_Imported (E) or else Is_Exported (E)) | |
3488 and then Convention (E) /= Convention (Formal) | |
3489 and then not Has_Warnings_Off (E) | |
3490 and then not Has_Warnings_Off (F_Type) | |
3491 and then not Has_Warnings_Off (Formal) | |
3492 then | |
3493 -- Qualify mention of formals with subprogram name | |
3494 | |
3495 Error_Msg_Qual_Level := 1; | |
3496 | |
3497 -- Check suspicious use of fat C pointer | |
3498 | |
3499 if Is_Access_Type (F_Type) | |
3500 and then Esize (F_Type) > Ttypes.System_Address_Size | |
3501 then | |
3502 Error_Msg_N | |
3503 ("?x?type of & does not correspond to C pointer!", Formal); | |
3504 | |
3505 -- Check suspicious return of boolean | |
3506 | |
3507 elsif Root_Type (F_Type) = Standard_Boolean | |
3508 and then Convention (F_Type) = Convention_Ada | |
3509 and then not Has_Warnings_Off (F_Type) | |
3510 and then not Has_Size_Clause (F_Type) | |
3511 then | |
3512 Error_Msg_N | |
3513 ("& is an 8-bit Ada Boolean?x?", Formal); | |
3514 Error_Msg_N | |
3515 ("\use appropriate corresponding type in C " | |
3516 & "(e.g. char)?x?", Formal); | |
3517 | |
3518 -- Check suspicious tagged type | |
3519 | |
3520 elsif (Is_Tagged_Type (F_Type) | |
3521 or else | |
3522 (Is_Access_Type (F_Type) | |
3523 and then Is_Tagged_Type (Designated_Type (F_Type)))) | |
3524 and then Convention (E) = Convention_C | |
3525 then | |
3526 Error_Msg_N | |
3527 ("?x?& involves a tagged type which does not " | |
3528 & "correspond to any C type!", Formal); | |
3529 | |
3530 -- Check wrong convention subprogram pointer | |
3531 | |
3532 elsif Ekind (F_Type) = E_Access_Subprogram_Type | |
3533 and then not Has_Foreign_Convention (F_Type) | |
3534 then | |
3535 Error_Msg_N | |
3536 ("?x?subprogram pointer & should " | |
3537 & "have foreign convention!", Formal); | |
3538 Error_Msg_Sloc := Sloc (F_Type); | |
3539 Error_Msg_NE | |
3540 ("\?x?add Convention pragma to declaration of &#", | |
3541 Formal, F_Type); | |
3542 end if; | |
3543 | |
3544 -- Turn off name qualification after message output | |
3545 | |
3546 Error_Msg_Qual_Level := 0; | |
3547 end if; | |
3548 | |
3549 -- Check for unconstrained array in exported foreign convention | |
3550 -- case. | |
3551 | |
3552 if Has_Foreign_Convention (E) | |
3553 and then not Is_Imported (E) | |
3554 and then Is_Array_Type (F_Type) | |
3555 and then not Is_Constrained (F_Type) | |
3556 and then Warn_On_Export_Import | |
3557 then | |
3558 Error_Msg_Qual_Level := 1; | |
3559 | |
3560 -- If this is an inherited operation, place the warning on | |
3561 -- the derived type declaration, rather than on the original | |
3562 -- subprogram. | |
3563 | |
3564 if Nkind (Original_Node (Parent (E))) = N_Full_Type_Declaration | |
3565 then | |
3566 Warn_Node := Parent (E); | |
3567 | |
3568 if Formal = First_Formal (E) then | |
3569 Error_Msg_NE ("??in inherited operation&", Warn_Node, E); | |
3570 end if; | |
3571 else | |
3572 Warn_Node := Formal; | |
3573 end if; | |
3574 | |
3575 Error_Msg_NE ("?x?type of argument& is unconstrained array", | |
3576 Warn_Node, Formal); | |
3577 Error_Msg_NE ("?x?foreign caller must pass bounds explicitly", | |
3578 Warn_Node, Formal); | |
3579 Error_Msg_Qual_Level := 0; | |
3580 end if; | |
3581 | |
3582 if not From_Limited_With (F_Type) then | |
3583 if Is_Access_Type (F_Type) then | |
3584 F_Type := Designated_Type (F_Type); | |
3585 end if; | |
3586 | |
3587 -- If the formal is an anonymous_access_to_subprogram | |
3588 -- freeze the subprogram type as well, to prevent | |
3589 -- scope anomalies in gigi, because there is no other | |
3590 -- clear point at which it could be frozen. | |
3591 | |
3592 if Is_Itype (Etype (Formal)) | |
3593 and then Ekind (F_Type) = E_Subprogram_Type | |
3594 then | |
3595 Freeze_And_Append (F_Type, N, Result); | |
3596 end if; | |
3597 end if; | |
3598 | |
3599 Next_Formal (Formal); | |
3600 end loop; | |
3601 | |
3602 -- Case of function: similar checks on return type | |
3603 | |
3604 if Ekind (E) = E_Function then | |
3605 | |
3606 -- Freeze return type | |
3607 | |
3608 R_Type := Etype (E); | |
3609 | |
3610 -- AI05-0151: the return type may have been incomplete at the | |
3611 -- point of declaration. Replace it with the full view, unless the | |
3612 -- current type is a limited view. In that case the full view is | |
3613 -- in a different unit, and gigi finds the non-limited view after | |
3614 -- the other unit is elaborated. | |
3615 | |
3616 if Ekind (R_Type) = E_Incomplete_Type | |
3617 and then Present (Full_View (R_Type)) | |
3618 and then not From_Limited_With (R_Type) | |
3619 then | |
3620 R_Type := Full_View (R_Type); | |
3621 Set_Etype (E, R_Type); | |
3622 end if; | |
3623 | |
3624 Freeze_And_Append (R_Type, N, Result); | |
3625 | |
3626 -- Check suspicious return type for C function | |
3627 | |
3628 if Warn_On_Export_Import | |
3629 and then (Convention (E) = Convention_C | |
3630 or else | |
3631 Convention (E) = Convention_CPP) | |
3632 and then (Is_Imported (E) or else Is_Exported (E)) | |
3633 then | |
3634 -- Check suspicious return of fat C pointer | |
3635 | |
3636 if Is_Access_Type (R_Type) | |
3637 and then Esize (R_Type) > Ttypes.System_Address_Size | |
3638 and then not Has_Warnings_Off (E) | |
3639 and then not Has_Warnings_Off (R_Type) | |
3640 then | |
3641 Error_Msg_N | |
3642 ("?x?return type of& does not correspond to C pointer!", | |
3643 E); | |
3644 | |
3645 -- Check suspicious return of boolean | |
3646 | |
3647 elsif Root_Type (R_Type) = Standard_Boolean | |
3648 and then Convention (R_Type) = Convention_Ada | |
3649 and then not Has_Warnings_Off (E) | |
3650 and then not Has_Warnings_Off (R_Type) | |
3651 and then not Has_Size_Clause (R_Type) | |
3652 then | |
3653 declare | |
3654 N : constant Node_Id := | |
3655 Result_Definition (Declaration_Node (E)); | |
3656 begin | |
3657 Error_Msg_NE | |
3658 ("return type of & is an 8-bit Ada Boolean?x?", N, E); | |
3659 Error_Msg_NE | |
3660 ("\use appropriate corresponding type in C " | |
3661 & "(e.g. char)?x?", N, E); | |
3662 end; | |
3663 | |
3664 -- Check suspicious return tagged type | |
3665 | |
3666 elsif (Is_Tagged_Type (R_Type) | |
3667 or else (Is_Access_Type (R_Type) | |
3668 and then | |
3669 Is_Tagged_Type | |
3670 (Designated_Type (R_Type)))) | |
3671 and then Convention (E) = Convention_C | |
3672 and then not Has_Warnings_Off (E) | |
3673 and then not Has_Warnings_Off (R_Type) | |
3674 then | |
3675 Error_Msg_N ("?x?return type of & does not " | |
3676 & "correspond to C type!", E); | |
3677 | |
3678 -- Check return of wrong convention subprogram pointer | |
3679 | |
3680 elsif Ekind (R_Type) = E_Access_Subprogram_Type | |
3681 and then not Has_Foreign_Convention (R_Type) | |
3682 and then not Has_Warnings_Off (E) | |
3683 and then not Has_Warnings_Off (R_Type) | |
3684 then | |
3685 Error_Msg_N ("?x?& should return a foreign " | |
3686 & "convention subprogram pointer", E); | |
3687 Error_Msg_Sloc := Sloc (R_Type); | |
3688 Error_Msg_NE | |
3689 ("\?x?add Convention pragma to declaration of& #", | |
3690 E, R_Type); | |
3691 end if; | |
3692 end if; | |
3693 | |
3694 -- Give warning for suspicious return of a result of an | |
3695 -- unconstrained array type in a foreign convention function. | |
3696 | |
3697 if Has_Foreign_Convention (E) | |
3698 | |
3699 -- We are looking for a return of unconstrained array | |
3700 | |
3701 and then Is_Array_Type (R_Type) | |
3702 and then not Is_Constrained (R_Type) | |
3703 | |
3704 -- Exclude imported routines, the warning does not belong on | |
3705 -- the import, but rather on the routine definition. | |
3706 | |
3707 and then not Is_Imported (E) | |
3708 | |
3709 -- Check that general warning is enabled, and that it is not | |
3710 -- suppressed for this particular case. | |
3711 | |
3712 and then Warn_On_Export_Import | |
3713 and then not Has_Warnings_Off (E) | |
3714 and then not Has_Warnings_Off (R_Type) | |
3715 then | |
3716 Error_Msg_N | |
3717 ("?x?foreign convention function& should not return " | |
3718 & "unconstrained array!", E); | |
3719 end if; | |
3720 end if; | |
3721 | |
3722 -- Check suspicious use of Import in pure unit (cases where the RM | |
3723 -- allows calls to be omitted). | |
3724 | |
3725 if Is_Imported (E) | |
3726 | |
3727 -- It might be suspicious if the compilation unit has the Pure | |
3728 -- aspect/pragma. | |
3729 | |
3730 and then Has_Pragma_Pure (Cunit_Entity (Current_Sem_Unit)) | |
3731 | |
3732 -- The RM allows omission of calls only in the case of | |
3733 -- library-level subprograms (see RM-10.2.1(18)). | |
3734 | |
3735 and then Is_Library_Level_Entity (E) | |
3736 | |
3737 -- Ignore internally generated entity. This happens in some cases | |
3738 -- of subprograms in specs, where we generate an implied body. | |
3739 | |
3740 and then Comes_From_Source (Import_Pragma (E)) | |
3741 | |
3742 -- Assume run-time knows what it is doing | |
3743 | |
3744 and then not GNAT_Mode | |
3745 | |
3746 -- Assume explicit Pure_Function means import is pure | |
3747 | |
3748 and then not Has_Pragma_Pure_Function (E) | |
3749 | |
3750 -- Don't need warning in relaxed semantics mode | |
3751 | |
3752 and then not Relaxed_RM_Semantics | |
3753 | |
3754 -- Assume convention Intrinsic is OK, since this is specialized. | |
3755 -- This deals with the DEC unit current_exception.ads | |
3756 | |
3757 and then Convention (E) /= Convention_Intrinsic | |
3758 | |
3759 -- Assume that ASM interface knows what it is doing. This deals | |
3760 -- with e.g. unsigned.ads in the AAMP back end. | |
3761 | |
3762 and then Convention (E) /= Convention_Assembler | |
3763 then | |
3764 Error_Msg_N | |
3765 ("pragma Import in Pure unit??", Import_Pragma (E)); | |
3766 Error_Msg_NE | |
3767 ("\calls to & may be omitted (RM 10.2.1(18/3))??", | |
3768 Import_Pragma (E), E); | |
3769 end if; | |
3770 | |
3771 return True; | |
3772 end Freeze_Profile; | |
3773 | |
3774 ------------------------ | |
3775 -- Freeze_Record_Type -- | |
3776 ------------------------ | |
3777 | |
3778 procedure Freeze_Record_Type (Rec : Entity_Id) is | |
3779 ADC : Node_Id; | |
3780 Comp : Entity_Id; | |
3781 IR : Node_Id; | |
3782 Prev : Entity_Id; | |
3783 | |
3784 Junk : Boolean; | |
3785 pragma Warnings (Off, Junk); | |
3786 | |
3787 Aliased_Component : Boolean := False; | |
3788 -- Set True if we find at least one component which is aliased. This | |
3789 -- is used to prevent Implicit_Packing of the record, since packing | |
3790 -- cannot modify the size of alignment of an aliased component. | |
3791 | |
3792 All_Elem_Components : Boolean := True; | |
3793 -- True if all components are of a type whose underlying type is | |
3794 -- elementary. | |
3795 | |
3796 All_Sized_Components : Boolean := True; | |
3797 -- True if all components have a known RM_Size | |
3798 | |
3799 All_Storage_Unit_Components : Boolean := True; | |
3800 -- True if all components have an RM_Size that is a multiple of the | |
3801 -- storage unit. | |
3802 | |
3803 Elem_Component_Total_Esize : Uint := Uint_0; | |
3804 -- Accumulates total Esize values of all elementary components. Used | |
3805 -- for processing of Implicit_Packing. | |
3806 | |
3807 Placed_Component : Boolean := False; | |
3808 -- Set True if we find at least one component with a component | |
3809 -- clause (used to warn about useless Bit_Order pragmas, and also | |
3810 -- to detect cases where Implicit_Packing may have an effect). | |
3811 | |
3812 Rec_Pushed : Boolean := False; | |
3813 -- Set True if the record type scope Rec has been pushed on the scope | |
3814 -- stack. Needed for the analysis of delayed aspects specified to the | |
3815 -- components of Rec. | |
3816 | |
3817 Sized_Component_Total_RM_Size : Uint := Uint_0; | |
3818 -- Accumulates total RM_Size values of all sized components. Used | |
3819 -- for processing of Implicit_Packing. | |
3820 | |
3821 Sized_Component_Total_Round_RM_Size : Uint := Uint_0; | |
3822 -- Accumulates total RM_Size values of all sized components, rounded | |
3823 -- individually to a multiple of the storage unit. | |
3824 | |
3825 SSO_ADC : Node_Id; | |
3826 -- Scalar_Storage_Order attribute definition clause for the record | |
3827 | |
3828 SSO_ADC_Component : Boolean := False; | |
3829 -- Set True if we find at least one component whose type has a | |
3830 -- Scalar_Storage_Order attribute definition clause. | |
3831 | |
3832 Unplaced_Component : Boolean := False; | |
3833 -- Set True if we find at least one component with no component | |
3834 -- clause (used to warn about useless Pack pragmas). | |
3835 | |
3836 function Check_Allocator (N : Node_Id) return Node_Id; | |
3837 -- If N is an allocator, possibly wrapped in one or more level of | |
3838 -- qualified expression(s), return the inner allocator node, else | |
3839 -- return Empty. | |
3840 | |
3841 procedure Check_Itype (Typ : Entity_Id); | |
3842 -- If the component subtype is an access to a constrained subtype of | |
3843 -- an already frozen type, make the subtype frozen as well. It might | |
3844 -- otherwise be frozen in the wrong scope, and a freeze node on | |
3845 -- subtype has no effect. Similarly, if the component subtype is a | |
3846 -- regular (not protected) access to subprogram, set the anonymous | |
3847 -- subprogram type to frozen as well, to prevent an out-of-scope | |
3848 -- freeze node at some eventual point of call. Protected operations | |
3849 -- are handled elsewhere. | |
3850 | |
3851 procedure Freeze_Choices_In_Variant_Part (VP : Node_Id); | |
3852 -- Make sure that all types mentioned in Discrete_Choices of the | |
3853 -- variants referenceed by the Variant_Part VP are frozen. This is | |
3854 -- a recursive routine to deal with nested variants. | |
3855 | |
3856 --------------------- | |
3857 -- Check_Allocator -- | |
3858 --------------------- | |
3859 | |
3860 function Check_Allocator (N : Node_Id) return Node_Id is | |
3861 Inner : Node_Id; | |
3862 begin | |
3863 Inner := N; | |
3864 loop | |
3865 if Nkind (Inner) = N_Allocator then | |
3866 return Inner; | |
3867 elsif Nkind (Inner) = N_Qualified_Expression then | |
3868 Inner := Expression (Inner); | |
3869 else | |
3870 return Empty; | |
3871 end if; | |
3872 end loop; | |
3873 end Check_Allocator; | |
3874 | |
3875 ----------------- | |
3876 -- Check_Itype -- | |
3877 ----------------- | |
3878 | |
3879 procedure Check_Itype (Typ : Entity_Id) is | |
3880 Desig : constant Entity_Id := Designated_Type (Typ); | |
3881 | |
3882 begin | |
3883 if not Is_Frozen (Desig) | |
3884 and then Is_Frozen (Base_Type (Desig)) | |
3885 then | |
3886 Set_Is_Frozen (Desig); | |
3887 | |
3888 -- In addition, add an Itype_Reference to ensure that the | |
3889 -- access subtype is elaborated early enough. This cannot be | |
3890 -- done if the subtype may depend on discriminants. | |
3891 | |
3892 if Ekind (Comp) = E_Component | |
3893 and then Is_Itype (Etype (Comp)) | |
3894 and then not Has_Discriminants (Rec) | |
3895 then | |
3896 IR := Make_Itype_Reference (Sloc (Comp)); | |
3897 Set_Itype (IR, Desig); | |
3898 Add_To_Result (IR); | |
3899 end if; | |
3900 | |
3901 elsif Ekind (Typ) = E_Anonymous_Access_Subprogram_Type | |
3902 and then Convention (Desig) /= Convention_Protected | |
3903 then | |
3904 Set_Is_Frozen (Desig); | |
3905 end if; | |
3906 end Check_Itype; | |
3907 | |
3908 ------------------------------------ | |
3909 -- Freeze_Choices_In_Variant_Part -- | |
3910 ------------------------------------ | |
3911 | |
3912 procedure Freeze_Choices_In_Variant_Part (VP : Node_Id) is | |
3913 pragma Assert (Nkind (VP) = N_Variant_Part); | |
3914 | |
3915 Variant : Node_Id; | |
3916 Choice : Node_Id; | |
3917 CL : Node_Id; | |
3918 | |
3919 begin | |
3920 -- Loop through variants | |
3921 | |
3922 Variant := First_Non_Pragma (Variants (VP)); | |
3923 while Present (Variant) loop | |
3924 | |
3925 -- Loop through choices, checking that all types are frozen | |
3926 | |
3927 Choice := First_Non_Pragma (Discrete_Choices (Variant)); | |
3928 while Present (Choice) loop | |
3929 if Nkind (Choice) in N_Has_Etype | |
3930 and then Present (Etype (Choice)) | |
3931 then | |
3932 Freeze_And_Append (Etype (Choice), N, Result); | |
3933 end if; | |
3934 | |
3935 Next_Non_Pragma (Choice); | |
3936 end loop; | |
3937 | |
3938 -- Check for nested variant part to process | |
3939 | |
3940 CL := Component_List (Variant); | |
3941 | |
3942 if not Null_Present (CL) then | |
3943 if Present (Variant_Part (CL)) then | |
3944 Freeze_Choices_In_Variant_Part (Variant_Part (CL)); | |
3945 end if; | |
3946 end if; | |
3947 | |
3948 Next_Non_Pragma (Variant); | |
3949 end loop; | |
3950 end Freeze_Choices_In_Variant_Part; | |
3951 | |
3952 -- Start of processing for Freeze_Record_Type | |
3953 | |
3954 begin | |
3955 -- Deal with delayed aspect specifications for components. The | |
3956 -- analysis of the aspect is required to be delayed to the freeze | |
3957 -- point, thus we analyze the pragma or attribute definition | |
3958 -- clause in the tree at this point. We also analyze the aspect | |
3959 -- specification node at the freeze point when the aspect doesn't | |
3960 -- correspond to pragma/attribute definition clause. | |
3961 | |
3962 Comp := First_Entity (Rec); | |
3963 while Present (Comp) loop | |
3964 if Ekind (Comp) = E_Component | |
3965 and then Has_Delayed_Aspects (Comp) | |
3966 then | |
3967 if not Rec_Pushed then | |
3968 Push_Scope (Rec); | |
3969 Rec_Pushed := True; | |
3970 | |
3971 -- The visibility to the discriminants must be restored in | |
3972 -- order to properly analyze the aspects. | |
3973 | |
3974 if Has_Discriminants (Rec) then | |
3975 Install_Discriminants (Rec); | |
3976 end if; | |
3977 end if; | |
3978 | |
3979 Analyze_Aspects_At_Freeze_Point (Comp); | |
3980 end if; | |
3981 | |
3982 Next_Entity (Comp); | |
3983 end loop; | |
3984 | |
3985 -- Pop the scope if Rec scope has been pushed on the scope stack | |
3986 -- during the delayed aspect analysis process. | |
3987 | |
3988 if Rec_Pushed then | |
3989 if Has_Discriminants (Rec) then | |
3990 Uninstall_Discriminants (Rec); | |
3991 end if; | |
3992 | |
3993 Pop_Scope; | |
3994 end if; | |
3995 | |
3996 -- Freeze components and embedded subtypes | |
3997 | |
3998 Comp := First_Entity (Rec); | |
3999 Prev := Empty; | |
4000 while Present (Comp) loop | |
4001 if Is_Aliased (Comp) then | |
4002 Aliased_Component := True; | |
4003 end if; | |
4004 | |
4005 -- Handle the component and discriminant case | |
4006 | |
4007 if Ekind_In (Comp, E_Component, E_Discriminant) then | |
4008 declare | |
4009 CC : constant Node_Id := Component_Clause (Comp); | |
4010 | |
4011 begin | |
4012 -- Freezing a record type freezes the type of each of its | |
4013 -- components. However, if the type of the component is | |
4014 -- part of this record, we do not want or need a separate | |
4015 -- Freeze_Node. Note that Is_Itype is wrong because that's | |
4016 -- also set in private type cases. We also can't check for | |
4017 -- the Scope being exactly Rec because of private types and | |
4018 -- record extensions. | |
4019 | |
4020 if Is_Itype (Etype (Comp)) | |
4021 and then Is_Record_Type (Underlying_Type | |
4022 (Scope (Etype (Comp)))) | |
4023 then | |
4024 Undelay_Type (Etype (Comp)); | |
4025 end if; | |
4026 | |
4027 Freeze_And_Append (Etype (Comp), N, Result); | |
4028 | |
4029 -- Warn for pragma Pack overriding foreign convention | |
4030 | |
4031 if Has_Foreign_Convention (Etype (Comp)) | |
4032 and then Has_Pragma_Pack (Rec) | |
4033 | |
4034 -- Don't warn for aliased components, since override | |
4035 -- cannot happen in that case. | |
4036 | |
4037 and then not Is_Aliased (Comp) | |
4038 then | |
4039 declare | |
4040 CN : constant Name_Id := | |
4041 Get_Convention_Name (Convention (Etype (Comp))); | |
4042 PP : constant Node_Id := | |
4043 Get_Pragma (Rec, Pragma_Pack); | |
4044 begin | |
4045 if Present (PP) then | |
4046 Error_Msg_Name_1 := CN; | |
4047 Error_Msg_Sloc := Sloc (Comp); | |
4048 Error_Msg_N | |
4049 ("pragma Pack affects convention % component#??", | |
4050 PP); | |
4051 Error_Msg_Name_1 := CN; | |
4052 Error_Msg_NE | |
4053 ("\component & may not have % compatible " | |
4054 & "representation??", PP, Comp); | |
4055 end if; | |
4056 end; | |
4057 end if; | |
4058 | |
4059 -- Check for error of component clause given for variable | |
4060 -- sized type. We have to delay this test till this point, | |
4061 -- since the component type has to be frozen for us to know | |
4062 -- if it is variable length. | |
4063 | |
4064 if Present (CC) then | |
4065 Placed_Component := True; | |
4066 | |
4067 -- We omit this test in a generic context, it will be | |
4068 -- applied at instantiation time. | |
4069 | |
4070 if Inside_A_Generic then | |
4071 null; | |
4072 | |
4073 -- Also omit this test in CodePeer mode, since we do not | |
4074 -- have sufficient info on size and rep clauses. | |
4075 | |
4076 elsif CodePeer_Mode then | |
4077 null; | |
4078 | |
4079 -- Omit check if component has a generic type. This can | |
4080 -- happen in an instantiation within a generic in ASIS | |
4081 -- mode, where we force freeze actions without full | |
4082 -- expansion. | |
4083 | |
4084 elsif Is_Generic_Type (Etype (Comp)) then | |
4085 null; | |
4086 | |
4087 -- Do the check | |
4088 | |
4089 elsif not | |
4090 Size_Known_At_Compile_Time | |
4091 (Underlying_Type (Etype (Comp))) | |
4092 then | |
4093 Error_Msg_N | |
4094 ("component clause not allowed for variable " & | |
4095 "length component", CC); | |
4096 end if; | |
4097 | |
4098 else | |
4099 Unplaced_Component := True; | |
4100 end if; | |
4101 | |
4102 -- Case of component requires byte alignment | |
4103 | |
4104 if Must_Be_On_Byte_Boundary (Etype (Comp)) then | |
4105 | |
4106 -- Set the enclosing record to also require byte align | |
4107 | |
4108 Set_Must_Be_On_Byte_Boundary (Rec); | |
4109 | |
4110 -- Check for component clause that is inconsistent with | |
4111 -- the required byte boundary alignment. | |
4112 | |
4113 if Present (CC) | |
4114 and then Normalized_First_Bit (Comp) mod | |
4115 System_Storage_Unit /= 0 | |
4116 then | |
4117 Error_Msg_N | |
4118 ("component & must be byte aligned", | |
4119 Component_Name (Component_Clause (Comp))); | |
4120 end if; | |
4121 end if; | |
4122 end; | |
4123 end if; | |
4124 | |
4125 -- Gather data for possible Implicit_Packing later. Note that at | |
4126 -- this stage we might be dealing with a real component, or with | |
4127 -- an implicit subtype declaration. | |
4128 | |
4129 if Known_Static_RM_Size (Etype (Comp)) then | |
4130 declare | |
4131 Comp_Type : constant Entity_Id := Etype (Comp); | |
4132 Comp_Size : constant Uint := RM_Size (Comp_Type); | |
4133 SSU : constant Int := Ttypes.System_Storage_Unit; | |
4134 | |
4135 begin | |
4136 Sized_Component_Total_RM_Size := | |
4137 Sized_Component_Total_RM_Size + Comp_Size; | |
4138 | |
4139 Sized_Component_Total_Round_RM_Size := | |
4140 Sized_Component_Total_Round_RM_Size + | |
4141 (Comp_Size + SSU - 1) / SSU * SSU; | |
4142 | |
4143 if Present (Underlying_Type (Comp_Type)) | |
4144 and then Is_Elementary_Type (Underlying_Type (Comp_Type)) | |
4145 then | |
4146 Elem_Component_Total_Esize := | |
4147 Elem_Component_Total_Esize + Esize (Comp_Type); | |
4148 else | |
4149 All_Elem_Components := False; | |
4150 | |
4151 if Comp_Size mod SSU /= 0 then | |
4152 All_Storage_Unit_Components := False; | |
4153 end if; | |
4154 end if; | |
4155 end; | |
4156 else | |
4157 All_Sized_Components := False; | |
4158 end if; | |
4159 | |
4160 -- If the component is an Itype with Delayed_Freeze and is either | |
4161 -- a record or array subtype and its base type has not yet been | |
4162 -- frozen, we must remove this from the entity list of this record | |
4163 -- and put it on the entity list of the scope of its base type. | |
4164 -- Note that we know that this is not the type of a component | |
4165 -- since we cleared Has_Delayed_Freeze for it in the previous | |
4166 -- loop. Thus this must be the Designated_Type of an access type, | |
4167 -- which is the type of a component. | |
4168 | |
4169 if Is_Itype (Comp) | |
4170 and then Is_Type (Scope (Comp)) | |
4171 and then Is_Composite_Type (Comp) | |
4172 and then Base_Type (Comp) /= Comp | |
4173 and then Has_Delayed_Freeze (Comp) | |
4174 and then not Is_Frozen (Base_Type (Comp)) | |
4175 then | |
4176 declare | |
4177 Will_Be_Frozen : Boolean := False; | |
4178 S : Entity_Id; | |
4179 | |
4180 begin | |
4181 -- We have a difficult case to handle here. Suppose Rec is | |
4182 -- subtype being defined in a subprogram that's created as | |
4183 -- part of the freezing of Rec'Base. In that case, we know | |
4184 -- that Comp'Base must have already been frozen by the time | |
4185 -- we get to elaborate this because Gigi doesn't elaborate | |
4186 -- any bodies until it has elaborated all of the declarative | |
4187 -- part. But Is_Frozen will not be set at this point because | |
4188 -- we are processing code in lexical order. | |
4189 | |
4190 -- We detect this case by going up the Scope chain of Rec | |
4191 -- and seeing if we have a subprogram scope before reaching | |
4192 -- the top of the scope chain or that of Comp'Base. If we | |
4193 -- do, then mark that Comp'Base will actually be frozen. If | |
4194 -- so, we merely undelay it. | |
4195 | |
4196 S := Scope (Rec); | |
4197 while Present (S) loop | |
4198 if Is_Subprogram (S) then | |
4199 Will_Be_Frozen := True; | |
4200 exit; | |
4201 elsif S = Scope (Base_Type (Comp)) then | |
4202 exit; | |
4203 end if; | |
4204 | |
4205 S := Scope (S); | |
4206 end loop; | |
4207 | |
4208 if Will_Be_Frozen then | |
4209 Undelay_Type (Comp); | |
4210 | |
4211 else | |
4212 if Present (Prev) then | |
4213 Set_Next_Entity (Prev, Next_Entity (Comp)); | |
4214 else | |
4215 Set_First_Entity (Rec, Next_Entity (Comp)); | |
4216 end if; | |
4217 | |
4218 -- Insert in entity list of scope of base type (which | |
4219 -- must be an enclosing scope, because still unfrozen). | |
4220 | |
4221 Append_Entity (Comp, Scope (Base_Type (Comp))); | |
4222 end if; | |
4223 end; | |
4224 | |
4225 -- If the component is an access type with an allocator as default | |
4226 -- value, the designated type will be frozen by the corresponding | |
4227 -- expression in init_proc. In order to place the freeze node for | |
4228 -- the designated type before that for the current record type, | |
4229 -- freeze it now. | |
4230 | |
4231 -- Same process if the component is an array of access types, | |
4232 -- initialized with an aggregate. If the designated type is | |
4233 -- private, it cannot contain allocators, and it is premature | |
4234 -- to freeze the type, so we check for this as well. | |
4235 | |
4236 elsif Is_Access_Type (Etype (Comp)) | |
4237 and then Present (Parent (Comp)) | |
4238 and then Present (Expression (Parent (Comp))) | |
4239 then | |
4240 declare | |
4241 Alloc : constant Node_Id := | |
4242 Check_Allocator (Expression (Parent (Comp))); | |
4243 | |
4244 begin | |
4245 if Present (Alloc) then | |
4246 | |
4247 -- If component is pointer to a class-wide type, freeze | |
4248 -- the specific type in the expression being allocated. | |
4249 -- The expression may be a subtype indication, in which | |
4250 -- case freeze the subtype mark. | |
4251 | |
4252 if Is_Class_Wide_Type | |
4253 (Designated_Type (Etype (Comp))) | |
4254 then | |
4255 if Is_Entity_Name (Expression (Alloc)) then | |
4256 Freeze_And_Append | |
4257 (Entity (Expression (Alloc)), N, Result); | |
4258 | |
4259 elsif Nkind (Expression (Alloc)) = N_Subtype_Indication | |
4260 then | |
4261 Freeze_And_Append | |
4262 (Entity (Subtype_Mark (Expression (Alloc))), | |
4263 N, Result); | |
4264 end if; | |
4265 | |
4266 elsif Is_Itype (Designated_Type (Etype (Comp))) then | |
4267 Check_Itype (Etype (Comp)); | |
4268 | |
4269 else | |
4270 Freeze_And_Append | |
4271 (Designated_Type (Etype (Comp)), N, Result); | |
4272 end if; | |
4273 end if; | |
4274 end; | |
4275 | |
4276 elsif Is_Access_Type (Etype (Comp)) | |
4277 and then Is_Itype (Designated_Type (Etype (Comp))) | |
4278 then | |
4279 Check_Itype (Etype (Comp)); | |
4280 | |
4281 -- Freeze the designated type when initializing a component with | |
4282 -- an aggregate in case the aggregate contains allocators. | |
4283 | |
4284 -- type T is ...; | |
4285 -- type T_Ptr is access all T; | |
4286 -- type T_Array is array ... of T_Ptr; | |
4287 | |
4288 -- type Rec is record | |
4289 -- Comp : T_Array := (others => ...); | |
4290 -- end record; | |
4291 | |
4292 elsif Is_Array_Type (Etype (Comp)) | |
4293 and then Is_Access_Type (Component_Type (Etype (Comp))) | |
4294 then | |
4295 declare | |
4296 Comp_Par : constant Node_Id := Parent (Comp); | |
4297 Desig_Typ : constant Entity_Id := | |
4298 Designated_Type | |
4299 (Component_Type (Etype (Comp))); | |
4300 | |
4301 begin | |
4302 -- The only case when this sort of freezing is not done is | |
4303 -- when the designated type is class-wide and the root type | |
4304 -- is the record owning the component. This scenario results | |
4305 -- in a circularity because the class-wide type requires | |
4306 -- primitives that have not been created yet as the root | |
4307 -- type is in the process of being frozen. | |
4308 | |
4309 -- type Rec is tagged; | |
4310 -- type Rec_Ptr is access all Rec'Class; | |
4311 -- type Rec_Array is array ... of Rec_Ptr; | |
4312 | |
4313 -- type Rec is record | |
4314 -- Comp : Rec_Array := (others => ...); | |
4315 -- end record; | |
4316 | |
4317 if Is_Class_Wide_Type (Desig_Typ) | |
4318 and then Root_Type (Desig_Typ) = Rec | |
4319 then | |
4320 null; | |
4321 | |
4322 elsif Is_Fully_Defined (Desig_Typ) | |
4323 and then Present (Comp_Par) | |
4324 and then Nkind (Comp_Par) = N_Component_Declaration | |
4325 and then Present (Expression (Comp_Par)) | |
4326 and then Nkind (Expression (Comp_Par)) = N_Aggregate | |
4327 then | |
4328 Freeze_And_Append (Desig_Typ, N, Result); | |
4329 end if; | |
4330 end; | |
4331 end if; | |
4332 | |
4333 Prev := Comp; | |
4334 Next_Entity (Comp); | |
4335 end loop; | |
4336 | |
4337 SSO_ADC := | |
4338 Get_Attribute_Definition_Clause | |
4339 (Rec, Attribute_Scalar_Storage_Order); | |
4340 | |
4341 -- If the record type has Complex_Representation, then it is treated | |
4342 -- as a scalar in the back end so the storage order is irrelevant. | |
4343 | |
4344 if Has_Complex_Representation (Rec) then | |
4345 if Present (SSO_ADC) then | |
4346 Error_Msg_N | |
4347 ("??storage order has no effect with Complex_Representation", | |
4348 SSO_ADC); | |
4349 end if; | |
4350 | |
4351 else | |
4352 -- Deal with default setting of reverse storage order | |
4353 | |
4354 Set_SSO_From_Default (Rec); | |
4355 | |
4356 -- Check consistent attribute setting on component types | |
4357 | |
4358 declare | |
4359 Comp_ADC_Present : Boolean; | |
4360 begin | |
4361 Comp := First_Component (Rec); | |
4362 while Present (Comp) loop | |
4363 Check_Component_Storage_Order | |
4364 (Encl_Type => Rec, | |
4365 Comp => Comp, | |
4366 ADC => SSO_ADC, | |
4367 Comp_ADC_Present => Comp_ADC_Present); | |
4368 SSO_ADC_Component := SSO_ADC_Component or Comp_ADC_Present; | |
4369 Next_Component (Comp); | |
4370 end loop; | |
4371 end; | |
4372 | |
4373 -- Now deal with reverse storage order/bit order issues | |
4374 | |
4375 if Present (SSO_ADC) then | |
4376 | |
4377 -- Check compatibility of Scalar_Storage_Order with Bit_Order, | |
4378 -- if the former is specified. | |
4379 | |
4380 if Reverse_Bit_Order (Rec) /= Reverse_Storage_Order (Rec) then | |
4381 | |
4382 -- Note: report error on Rec, not on SSO_ADC, as ADC may | |
4383 -- apply to some ancestor type. | |
4384 | |
4385 Error_Msg_Sloc := Sloc (SSO_ADC); | |
4386 Error_Msg_N | |
4387 ("scalar storage order for& specified# inconsistent with " | |
4388 & "bit order", Rec); | |
4389 end if; | |
4390 | |
4391 -- Warn if there is a Scalar_Storage_Order attribute definition | |
4392 -- clause but no component clause, no component that itself has | |
4393 -- such an attribute definition, and no pragma Pack. | |
4394 | |
4395 if not (Placed_Component | |
4396 or else | |
4397 SSO_ADC_Component | |
4398 or else | |
4399 Is_Packed (Rec)) | |
4400 then | |
4401 Error_Msg_N | |
4402 ("??scalar storage order specified but no component " | |
4403 & "clause", SSO_ADC); | |
4404 end if; | |
4405 end if; | |
4406 end if; | |
4407 | |
4408 -- Deal with Bit_Order aspect | |
4409 | |
4410 ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order); | |
4411 | |
4412 if Present (ADC) and then Base_Type (Rec) = Rec then | |
4413 if not (Placed_Component | |
4414 or else Present (SSO_ADC) | |
4415 or else Is_Packed (Rec)) | |
4416 then | |
4417 -- Warn if clause has no effect when no component clause is | |
4418 -- present, but suppress warning if the Bit_Order is required | |
4419 -- due to the presence of a Scalar_Storage_Order attribute. | |
4420 | |
4421 Error_Msg_N | |
4422 ("??bit order specification has no effect", ADC); | |
4423 Error_Msg_N | |
4424 ("\??since no component clauses were specified", ADC); | |
4425 | |
4426 -- Here is where we do the processing to adjust component clauses | |
4427 -- for reversed bit order, when not using reverse SSO. If an error | |
4428 -- has been reported on Rec already (such as SSO incompatible with | |
4429 -- bit order), don't bother adjusting as this may generate extra | |
4430 -- noise. | |
4431 | |
4432 elsif Reverse_Bit_Order (Rec) | |
4433 and then not Reverse_Storage_Order (Rec) | |
4434 and then not Error_Posted (Rec) | |
4435 then | |
4436 Adjust_Record_For_Reverse_Bit_Order (Rec); | |
4437 | |
4438 -- Case where we have both an explicit Bit_Order and the same | |
4439 -- Scalar_Storage_Order: leave record untouched, the back-end | |
4440 -- will take care of required layout conversions. | |
4441 | |
4442 else | |
4443 null; | |
4444 | |
4445 end if; | |
4446 end if; | |
4447 | |
4448 -- Complete error checking on record representation clause (e.g. | |
4449 -- overlap of components). This is called after adjusting the | |
4450 -- record for reverse bit order. | |
4451 | |
4452 declare | |
4453 RRC : constant Node_Id := Get_Record_Representation_Clause (Rec); | |
4454 begin | |
4455 if Present (RRC) then | |
4456 Check_Record_Representation_Clause (RRC); | |
4457 end if; | |
4458 end; | |
4459 | |
4460 -- Check for useless pragma Pack when all components placed. We only | |
4461 -- do this check for record types, not subtypes, since a subtype may | |
4462 -- have all its components placed, and it still makes perfectly good | |
4463 -- sense to pack other subtypes or the parent type. We do not give | |
4464 -- this warning if Optimize_Alignment is set to Space, since the | |
4465 -- pragma Pack does have an effect in this case (it always resets | |
4466 -- the alignment to one). | |
4467 | |
4468 if Ekind (Rec) = E_Record_Type | |
4469 and then Is_Packed (Rec) | |
4470 and then not Unplaced_Component | |
4471 and then Optimize_Alignment /= 'S' | |
4472 then | |
4473 -- Reset packed status. Probably not necessary, but we do it so | |
4474 -- that there is no chance of the back end doing something strange | |
4475 -- with this redundant indication of packing. | |
4476 | |
4477 Set_Is_Packed (Rec, False); | |
4478 | |
4479 -- Give warning if redundant constructs warnings on | |
4480 | |
4481 if Warn_On_Redundant_Constructs then | |
4482 Error_Msg_N -- CODEFIX | |
4483 ("??pragma Pack has no effect, no unplaced components", | |
4484 Get_Rep_Pragma (Rec, Name_Pack)); | |
4485 end if; | |
4486 end if; | |
4487 | |
4488 -- If this is the record corresponding to a remote type, freeze the | |
4489 -- remote type here since that is what we are semantically freezing. | |
4490 -- This prevents the freeze node for that type in an inner scope. | |
4491 | |
4492 if Ekind (Rec) = E_Record_Type then | |
4493 if Present (Corresponding_Remote_Type (Rec)) then | |
4494 Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result); | |
4495 end if; | |
4496 | |
4497 -- Check for controlled components, unchecked unions, and type | |
4498 -- invariants. | |
4499 | |
4500 Comp := First_Component (Rec); | |
4501 while Present (Comp) loop | |
4502 | |
4503 -- Do not set Has_Controlled_Component on a class-wide | |
4504 -- equivalent type. See Make_CW_Equivalent_Type. | |
4505 | |
4506 if not Is_Class_Wide_Equivalent_Type (Rec) | |
4507 and then | |
4508 (Has_Controlled_Component (Etype (Comp)) | |
4509 or else | |
4510 (Chars (Comp) /= Name_uParent | |
4511 and then Is_Controlled (Etype (Comp))) | |
4512 or else | |
4513 (Is_Protected_Type (Etype (Comp)) | |
4514 and then | |
4515 Present (Corresponding_Record_Type (Etype (Comp))) | |
4516 and then | |
4517 Has_Controlled_Component | |
4518 (Corresponding_Record_Type (Etype (Comp))))) | |
4519 then | |
4520 Set_Has_Controlled_Component (Rec); | |
4521 end if; | |
4522 | |
4523 if Has_Unchecked_Union (Etype (Comp)) then | |
4524 Set_Has_Unchecked_Union (Rec); | |
4525 end if; | |
4526 | |
4527 -- The record type requires its own invariant procedure in | |
4528 -- order to verify the invariant of each individual component. | |
4529 -- Do not consider internal components such as _parent because | |
4530 -- parent class-wide invariants are always inherited. | |
4531 -- In GNATprove mode, the component invariants are checked by | |
4532 -- other means. They should not be added to the record type | |
4533 -- invariant procedure, so that the procedure can be used to | |
4534 -- check the recordy type invariants if any. | |
4535 | |
4536 if Comes_From_Source (Comp) | |
4537 and then Has_Invariants (Etype (Comp)) | |
4538 and then not GNATprove_Mode | |
4539 then | |
4540 Set_Has_Own_Invariants (Rec); | |
4541 end if; | |
4542 | |
4543 -- Scan component declaration for likely misuses of current | |
4544 -- instance, either in a constraint or a default expression. | |
4545 | |
4546 if Has_Per_Object_Constraint (Comp) then | |
4547 Check_Current_Instance (Parent (Comp)); | |
4548 end if; | |
4549 | |
4550 Next_Component (Comp); | |
4551 end loop; | |
4552 end if; | |
4553 | |
4554 -- Enforce the restriction that access attributes with a current | |
4555 -- instance prefix can only apply to limited types. This comment | |
4556 -- is floating here, but does not seem to belong here??? | |
4557 | |
4558 -- Set component alignment if not otherwise already set | |
4559 | |
4560 Set_Component_Alignment_If_Not_Set (Rec); | |
4561 | |
4562 -- For first subtypes, check if there are any fixed-point fields with | |
4563 -- component clauses, where we must check the size. This is not done | |
4564 -- till the freeze point since for fixed-point types, we do not know | |
4565 -- the size until the type is frozen. Similar processing applies to | |
4566 -- bit-packed arrays. | |
4567 | |
4568 if Is_First_Subtype (Rec) then | |
4569 Comp := First_Component (Rec); | |
4570 while Present (Comp) loop | |
4571 if Present (Component_Clause (Comp)) | |
4572 and then (Is_Fixed_Point_Type (Etype (Comp)) | |
4573 or else Is_Bit_Packed_Array (Etype (Comp))) | |
4574 then | |
4575 Check_Size | |
4576 (Component_Name (Component_Clause (Comp)), | |
4577 Etype (Comp), | |
4578 Esize (Comp), | |
4579 Junk); | |
4580 end if; | |
4581 | |
4582 Next_Component (Comp); | |
4583 end loop; | |
4584 end if; | |
4585 | |
4586 -- See if Size is too small as is (and implicit packing might help) | |
4587 | |
4588 if not Is_Packed (Rec) | |
4589 | |
4590 -- No implicit packing if even one component is explicitly placed | |
4591 | |
4592 and then not Placed_Component | |
4593 | |
4594 -- Or even one component is aliased | |
4595 | |
4596 and then not Aliased_Component | |
4597 | |
4598 -- Must have size clause and all sized components | |
4599 | |
4600 and then Has_Size_Clause (Rec) | |
4601 and then All_Sized_Components | |
4602 | |
4603 -- Do not try implicit packing on records with discriminants, too | |
4604 -- complicated, especially in the variant record case. | |
4605 | |
4606 and then not Has_Discriminants (Rec) | |
4607 | |
4608 -- We want to implicitly pack if the specified size of the record | |
4609 -- is less than the sum of the object sizes (no point in packing | |
4610 -- if this is not the case), if we can compute it, i.e. if we have | |
4611 -- only elementary components. Otherwise, we have at least one | |
4612 -- composite component and we want to implicitly pack only if bit | |
4613 -- packing is required for it, as we are sure in this case that | |
4614 -- the back end cannot do the expected layout without packing. | |
4615 | |
4616 and then | |
4617 ((All_Elem_Components | |
4618 and then RM_Size (Rec) < Elem_Component_Total_Esize) | |
4619 or else | |
4620 (not All_Elem_Components | |
4621 and then not All_Storage_Unit_Components | |
4622 and then RM_Size (Rec) < Sized_Component_Total_Round_RM_Size)) | |
4623 | |
4624 -- And the total RM size cannot be greater than the specified size | |
4625 -- since otherwise packing will not get us where we have to be. | |
4626 | |
4627 and then Sized_Component_Total_RM_Size <= RM_Size (Rec) | |
4628 | |
4629 -- Never do implicit packing in CodePeer or SPARK modes since | |
4630 -- we don't do any packing in these modes, since this generates | |
4631 -- over-complex code that confuses static analysis, and in | |
4632 -- general, neither CodePeer not GNATprove care about the | |
4633 -- internal representation of objects. | |
4634 | |
4635 and then not (CodePeer_Mode or GNATprove_Mode) | |
4636 then | |
4637 -- If implicit packing enabled, do it | |
4638 | |
4639 if Implicit_Packing then | |
4640 Set_Is_Packed (Rec); | |
4641 | |
4642 -- Otherwise flag the size clause | |
4643 | |
4644 else | |
4645 declare | |
4646 Sz : constant Node_Id := Size_Clause (Rec); | |
4647 begin | |
4648 Error_Msg_NE -- CODEFIX | |
4649 ("size given for& too small", Sz, Rec); | |
4650 Error_Msg_N -- CODEFIX | |
4651 ("\use explicit pragma Pack " | |
4652 & "or use pragma Implicit_Packing", Sz); | |
4653 end; | |
4654 end if; | |
4655 end if; | |
4656 | |
4657 -- The following checks are relevant only when SPARK_Mode is on as | |
4658 -- they are not standard Ada legality rules. | |
4659 | |
4660 if SPARK_Mode = On then | |
4661 | |
4662 -- A discriminated type cannot be effectively volatile | |
4663 -- (SPARK RM 7.1.3(5)). | |
4664 | |
4665 if Is_Effectively_Volatile (Rec) then | |
4666 if Has_Discriminants (Rec) then | |
4667 Error_Msg_N ("discriminated type & cannot be volatile", Rec); | |
4668 end if; | |
4669 | |
4670 -- A non-effectively volatile record type cannot contain | |
4671 -- effectively volatile components (SPARK RM 7.1.3(6)). | |
4672 | |
4673 else | |
4674 Comp := First_Component (Rec); | |
4675 while Present (Comp) loop | |
4676 if Comes_From_Source (Comp) | |
4677 and then Is_Effectively_Volatile (Etype (Comp)) | |
4678 then | |
4679 Error_Msg_Name_1 := Chars (Rec); | |
4680 Error_Msg_N | |
4681 ("component & of non-volatile type % cannot be " | |
4682 & "volatile", Comp); | |
4683 end if; | |
4684 | |
4685 Next_Component (Comp); | |
4686 end loop; | |
4687 end if; | |
4688 | |
4689 -- A type which does not yield a synchronized object cannot have | |
4690 -- a component that yields a synchronized object (SPARK RM 9.5). | |
4691 | |
4692 if not Yields_Synchronized_Object (Rec) then | |
4693 Comp := First_Component (Rec); | |
4694 while Present (Comp) loop | |
4695 if Comes_From_Source (Comp) | |
4696 and then Yields_Synchronized_Object (Etype (Comp)) | |
4697 then | |
4698 Error_Msg_Name_1 := Chars (Rec); | |
4699 Error_Msg_N | |
4700 ("component & of non-synchronized type % cannot be " | |
4701 & "synchronized", Comp); | |
4702 end if; | |
4703 | |
4704 Next_Component (Comp); | |
4705 end loop; | |
4706 end if; | |
4707 | |
4708 -- A Ghost type cannot have a component of protected or task type | |
4709 -- (SPARK RM 6.9(19)). | |
4710 | |
4711 if Is_Ghost_Entity (Rec) then | |
4712 Comp := First_Component (Rec); | |
4713 while Present (Comp) loop | |
4714 if Comes_From_Source (Comp) | |
4715 and then Is_Concurrent_Type (Etype (Comp)) | |
4716 then | |
4717 Error_Msg_Name_1 := Chars (Rec); | |
4718 Error_Msg_N | |
4719 ("component & of ghost type % cannot be concurrent", | |
4720 Comp); | |
4721 end if; | |
4722 | |
4723 Next_Component (Comp); | |
4724 end loop; | |
4725 end if; | |
4726 end if; | |
4727 | |
4728 -- Make sure that if we have an iterator aspect, then we have | |
4729 -- either Constant_Indexing or Variable_Indexing. | |
4730 | |
4731 declare | |
4732 Iterator_Aspect : Node_Id; | |
4733 | |
4734 begin | |
4735 Iterator_Aspect := Find_Aspect (Rec, Aspect_Iterator_Element); | |
4736 | |
4737 if No (Iterator_Aspect) then | |
4738 Iterator_Aspect := Find_Aspect (Rec, Aspect_Default_Iterator); | |
4739 end if; | |
4740 | |
4741 if Present (Iterator_Aspect) then | |
4742 if Has_Aspect (Rec, Aspect_Constant_Indexing) | |
4743 or else | |
4744 Has_Aspect (Rec, Aspect_Variable_Indexing) | |
4745 then | |
4746 null; | |
4747 else | |
4748 Error_Msg_N | |
4749 ("Iterator_Element requires indexing aspect", | |
4750 Iterator_Aspect); | |
4751 end if; | |
4752 end if; | |
4753 end; | |
4754 | |
4755 -- All done if not a full record definition | |
4756 | |
4757 if Ekind (Rec) /= E_Record_Type then | |
4758 return; | |
4759 end if; | |
4760 | |
4761 -- Finally we need to check the variant part to make sure that | |
4762 -- all types within choices are properly frozen as part of the | |
4763 -- freezing of the record type. | |
4764 | |
4765 Check_Variant_Part : declare | |
4766 D : constant Node_Id := Declaration_Node (Rec); | |
4767 T : Node_Id; | |
4768 C : Node_Id; | |
4769 | |
4770 begin | |
4771 -- Find component list | |
4772 | |
4773 C := Empty; | |
4774 | |
4775 if Nkind (D) = N_Full_Type_Declaration then | |
4776 T := Type_Definition (D); | |
4777 | |
4778 if Nkind (T) = N_Record_Definition then | |
4779 C := Component_List (T); | |
4780 | |
4781 elsif Nkind (T) = N_Derived_Type_Definition | |
4782 and then Present (Record_Extension_Part (T)) | |
4783 then | |
4784 C := Component_List (Record_Extension_Part (T)); | |
4785 end if; | |
4786 end if; | |
4787 | |
4788 -- Case of variant part present | |
4789 | |
4790 if Present (C) and then Present (Variant_Part (C)) then | |
4791 Freeze_Choices_In_Variant_Part (Variant_Part (C)); | |
4792 end if; | |
4793 | |
4794 -- Note: we used to call Check_Choices here, but it is too early, | |
4795 -- since predicated subtypes are frozen here, but their freezing | |
4796 -- actions are in Analyze_Freeze_Entity, which has not been called | |
4797 -- yet for entities frozen within this procedure, so we moved that | |
4798 -- call to the Analyze_Freeze_Entity for the record type. | |
4799 | |
4800 end Check_Variant_Part; | |
4801 | |
4802 -- Check that all the primitives of an interface type are abstract | |
4803 -- or null procedures. | |
4804 | |
4805 if Is_Interface (Rec) | |
4806 and then not Error_Posted (Parent (Rec)) | |
4807 then | |
4808 declare | |
4809 Elmt : Elmt_Id; | |
4810 Subp : Entity_Id; | |
4811 | |
4812 begin | |
4813 Elmt := First_Elmt (Primitive_Operations (Rec)); | |
4814 while Present (Elmt) loop | |
4815 Subp := Node (Elmt); | |
4816 | |
4817 if not Is_Abstract_Subprogram (Subp) | |
4818 | |
4819 -- Avoid reporting the error on inherited primitives | |
4820 | |
4821 and then Comes_From_Source (Subp) | |
4822 then | |
4823 Error_Msg_Name_1 := Chars (Subp); | |
4824 | |
4825 if Ekind (Subp) = E_Procedure then | |
4826 if not Null_Present (Parent (Subp)) then | |
4827 Error_Msg_N | |
4828 ("interface procedure % must be abstract or null", | |
4829 Parent (Subp)); | |
4830 end if; | |
4831 else | |
4832 Error_Msg_N | |
4833 ("interface function % must be abstract", | |
4834 Parent (Subp)); | |
4835 end if; | |
4836 end if; | |
4837 | |
4838 Next_Elmt (Elmt); | |
4839 end loop; | |
4840 end; | |
4841 end if; | |
4842 | |
4843 -- For a derived tagged type, check whether inherited primitives | |
4844 -- might require a wrapper to handle class-wide conditions. | |
4845 | |
4846 if Is_Tagged_Type (Rec) and then Is_Derived_Type (Rec) then | |
4847 Check_Inherited_Conditions (Rec); | |
4848 end if; | |
4849 end Freeze_Record_Type; | |
4850 | |
4851 ------------------------------- | |
4852 -- Has_Boolean_Aspect_Import -- | |
4853 ------------------------------- | |
4854 | |
4855 function Has_Boolean_Aspect_Import (E : Entity_Id) return Boolean is | |
4856 Decl : constant Node_Id := Declaration_Node (E); | |
4857 Asp : Node_Id; | |
4858 Expr : Node_Id; | |
4859 | |
4860 begin | |
4861 if Has_Aspects (Decl) then | |
4862 Asp := First (Aspect_Specifications (Decl)); | |
4863 while Present (Asp) loop | |
4864 Expr := Expression (Asp); | |
4865 | |
4866 -- The value of aspect Import is True when the expression is | |
4867 -- either missing or it is explicitly set to True. | |
4868 | |
4869 if Get_Aspect_Id (Asp) = Aspect_Import | |
4870 and then (No (Expr) | |
4871 or else (Compile_Time_Known_Value (Expr) | |
4872 and then Is_True (Expr_Value (Expr)))) | |
4873 then | |
4874 return True; | |
4875 end if; | |
4876 | |
4877 Next (Asp); | |
4878 end loop; | |
4879 end if; | |
4880 | |
4881 return False; | |
4882 end Has_Boolean_Aspect_Import; | |
4883 | |
4884 ------------------------- | |
4885 -- Inherit_Freeze_Node -- | |
4886 ------------------------- | |
4887 | |
4888 procedure Inherit_Freeze_Node | |
4889 (Fnod : Node_Id; | |
4890 Typ : Entity_Id) | |
4891 is | |
4892 Typ_Fnod : constant Node_Id := Freeze_Node (Typ); | |
4893 | |
4894 begin | |
4895 Set_Freeze_Node (Typ, Fnod); | |
4896 Set_Entity (Fnod, Typ); | |
4897 | |
4898 -- The input type had an existing node. Propagate relevant attributes | |
4899 -- from the old freeze node to the inherited freeze node. | |
4900 | |
4901 -- ??? if both freeze nodes have attributes, would they differ? | |
4902 | |
4903 if Present (Typ_Fnod) then | |
4904 | |
4905 -- Attribute Access_Types_To_Process | |
4906 | |
4907 if Present (Access_Types_To_Process (Typ_Fnod)) | |
4908 and then No (Access_Types_To_Process (Fnod)) | |
4909 then | |
4910 Set_Access_Types_To_Process (Fnod, | |
4911 Access_Types_To_Process (Typ_Fnod)); | |
4912 end if; | |
4913 | |
4914 -- Attribute Actions | |
4915 | |
4916 if Present (Actions (Typ_Fnod)) and then No (Actions (Fnod)) then | |
4917 Set_Actions (Fnod, Actions (Typ_Fnod)); | |
4918 end if; | |
4919 | |
4920 -- Attribute First_Subtype_Link | |
4921 | |
4922 if Present (First_Subtype_Link (Typ_Fnod)) | |
4923 and then No (First_Subtype_Link (Fnod)) | |
4924 then | |
4925 Set_First_Subtype_Link (Fnod, First_Subtype_Link (Typ_Fnod)); | |
4926 end if; | |
4927 | |
4928 -- Attribute TSS_Elist | |
4929 | |
4930 if Present (TSS_Elist (Typ_Fnod)) | |
4931 and then No (TSS_Elist (Fnod)) | |
4932 then | |
4933 Set_TSS_Elist (Fnod, TSS_Elist (Typ_Fnod)); | |
4934 end if; | |
4935 end if; | |
4936 end Inherit_Freeze_Node; | |
4937 | |
4938 ------------------------------ | |
4939 -- Wrap_Imported_Subprogram -- | |
4940 ------------------------------ | |
4941 | |
4942 -- The issue here is that our normal approach of checking preconditions | |
4943 -- and postconditions does not work for imported procedures, since we | |
4944 -- are not generating code for the body. To get around this we create | |
4945 -- a wrapper, as shown by the following example: | |
4946 | |
4947 -- procedure K (A : Integer); | |
4948 -- pragma Import (C, K); | |
4949 | |
4950 -- The spec is rewritten by removing the effects of pragma Import, but | |
4951 -- leaving the convention unchanged, as though the source had said: | |
4952 | |
4953 -- procedure K (A : Integer); | |
4954 -- pragma Convention (C, K); | |
4955 | |
4956 -- and we create a body, added to the entity K freeze actions, which | |
4957 -- looks like: | |
4958 | |
4959 -- procedure K (A : Integer) is | |
4960 -- procedure K (A : Integer); | |
4961 -- pragma Import (C, K); | |
4962 -- begin | |
4963 -- K (A); | |
4964 -- end K; | |
4965 | |
4966 -- Now the contract applies in the normal way to the outer procedure, | |
4967 -- and the inner procedure has no contracts, so there is no problem | |
4968 -- in just calling it to get the original effect. | |
4969 | |
4970 -- In the case of a function, we create an appropriate return statement | |
4971 -- for the subprogram body that calls the inner procedure. | |
4972 | |
4973 procedure Wrap_Imported_Subprogram (E : Entity_Id) is | |
4974 function Copy_Import_Pragma return Node_Id; | |
4975 -- Obtain a copy of the Import_Pragma which belongs to subprogram E | |
4976 | |
4977 ------------------------ | |
4978 -- Copy_Import_Pragma -- | |
4979 ------------------------ | |
4980 | |
4981 function Copy_Import_Pragma return Node_Id is | |
4982 | |
4983 -- The subprogram should have an import pragma, otherwise it does | |
4984 -- need a wrapper. | |
4985 | |
4986 Prag : constant Node_Id := Import_Pragma (E); | |
4987 pragma Assert (Present (Prag)); | |
4988 | |
4989 -- Save all semantic fields of the pragma | |
4990 | |
4991 Save_Asp : constant Node_Id := Corresponding_Aspect (Prag); | |
4992 Save_From : constant Boolean := From_Aspect_Specification (Prag); | |
4993 Save_Prag : constant Node_Id := Next_Pragma (Prag); | |
4994 Save_Rep : constant Node_Id := Next_Rep_Item (Prag); | |
4995 | |
4996 Result : Node_Id; | |
4997 | |
4998 begin | |
4999 -- Reset all semantic fields. This avoids a potential infinite | |
5000 -- loop when the pragma comes from an aspect as the duplication | |
5001 -- will copy the aspect, then copy the corresponding pragma and | |
5002 -- so on. | |
5003 | |
5004 Set_Corresponding_Aspect (Prag, Empty); | |
5005 Set_From_Aspect_Specification (Prag, False); | |
5006 Set_Next_Pragma (Prag, Empty); | |
5007 Set_Next_Rep_Item (Prag, Empty); | |
5008 | |
5009 Result := Copy_Separate_Tree (Prag); | |
5010 | |
5011 -- Restore the original semantic fields | |
5012 | |
5013 Set_Corresponding_Aspect (Prag, Save_Asp); | |
5014 Set_From_Aspect_Specification (Prag, Save_From); | |
5015 Set_Next_Pragma (Prag, Save_Prag); | |
5016 Set_Next_Rep_Item (Prag, Save_Rep); | |
5017 | |
5018 return Result; | |
5019 end Copy_Import_Pragma; | |
5020 | |
5021 -- Local variables | |
5022 | |
5023 Loc : constant Source_Ptr := Sloc (E); | |
5024 CE : constant Name_Id := Chars (E); | |
5025 Bod : Node_Id; | |
5026 Forml : Entity_Id; | |
5027 Parms : List_Id; | |
5028 Prag : Node_Id; | |
5029 Spec : Node_Id; | |
5030 Stmt : Node_Id; | |
5031 | |
5032 -- Start of processing for Wrap_Imported_Subprogram | |
5033 | |
5034 begin | |
5035 -- Nothing to do if not imported | |
5036 | |
5037 if not Is_Imported (E) then | |
5038 return; | |
5039 | |
5040 -- Test enabling conditions for wrapping | |
5041 | |
5042 elsif Is_Subprogram (E) | |
5043 and then Present (Contract (E)) | |
5044 and then Present (Pre_Post_Conditions (Contract (E))) | |
5045 and then not GNATprove_Mode | |
5046 then | |
5047 -- Here we do the wrap | |
5048 | |
5049 -- Note on calls to Copy_Separate_Tree. The trees we are copying | |
5050 -- here are fully analyzed, but we definitely want fully syntactic | |
5051 -- unanalyzed trees in the body we construct, so that the analysis | |
5052 -- generates the right visibility, and that is exactly what the | |
5053 -- calls to Copy_Separate_Tree give us. | |
5054 | |
5055 Prag := Copy_Import_Pragma; | |
5056 | |
5057 -- Fix up spec so it is no longer imported and has convention Ada | |
5058 | |
5059 Set_Has_Completion (E, False); | |
5060 Set_Import_Pragma (E, Empty); | |
5061 Set_Interface_Name (E, Empty); | |
5062 Set_Is_Imported (E, False); | |
5063 Set_Convention (E, Convention_Ada); | |
5064 | |
5065 -- Grab the subprogram declaration and specification | |
5066 | |
5067 Spec := Declaration_Node (E); | |
5068 | |
5069 -- Build parameter list that we need | |
5070 | |
5071 Parms := New_List; | |
5072 Forml := First_Formal (E); | |
5073 while Present (Forml) loop | |
5074 Append_To (Parms, Make_Identifier (Loc, Chars (Forml))); | |
5075 Next_Formal (Forml); | |
5076 end loop; | |
5077 | |
5078 -- Build the call | |
5079 | |
5080 if Ekind_In (E, E_Function, E_Generic_Function) then | |
5081 Stmt := | |
5082 Make_Simple_Return_Statement (Loc, | |
5083 Expression => | |
5084 Make_Function_Call (Loc, | |
5085 Name => Make_Identifier (Loc, CE), | |
5086 Parameter_Associations => Parms)); | |
5087 | |
5088 else | |
5089 Stmt := | |
5090 Make_Procedure_Call_Statement (Loc, | |
5091 Name => Make_Identifier (Loc, CE), | |
5092 Parameter_Associations => Parms); | |
5093 end if; | |
5094 | |
5095 -- Now build the body | |
5096 | |
5097 Bod := | |
5098 Make_Subprogram_Body (Loc, | |
5099 Specification => | |
5100 Copy_Separate_Tree (Spec), | |
5101 Declarations => New_List ( | |
5102 Make_Subprogram_Declaration (Loc, | |
5103 Specification => Copy_Separate_Tree (Spec)), | |
5104 Prag), | |
5105 Handled_Statement_Sequence => | |
5106 Make_Handled_Sequence_Of_Statements (Loc, | |
5107 Statements => New_List (Stmt), | |
5108 End_Label => Make_Identifier (Loc, CE))); | |
5109 | |
5110 -- Append the body to freeze result | |
5111 | |
5112 Add_To_Result (Bod); | |
5113 return; | |
5114 | |
5115 -- Case of imported subprogram that does not get wrapped | |
5116 | |
5117 else | |
5118 -- Set Is_Public. All imported entities need an external symbol | |
5119 -- created for them since they are always referenced from another | |
5120 -- object file. Note this used to be set when we set Is_Imported | |
5121 -- back in Sem_Prag, but now we delay it to this point, since we | |
5122 -- don't want to set this flag if we wrap an imported subprogram. | |
5123 | |
5124 Set_Is_Public (E); | |
5125 end if; | |
5126 end Wrap_Imported_Subprogram; | |
5127 | |
5128 -- Local variables | |
5129 | |
5130 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; | |
5131 -- Save the Ghost mode to restore on exit | |
5132 | |
5133 -- Start of processing for Freeze_Entity | |
5134 | |
5135 begin | |
5136 -- The entity being frozen may be subject to pragma Ghost. Set the mode | |
5137 -- now to ensure that any nodes generated during freezing are properly | |
5138 -- flagged as Ghost. | |
5139 | |
5140 Set_Ghost_Mode (E); | |
5141 | |
5142 -- We are going to test for various reasons why this entity need not be | |
5143 -- frozen here, but in the case of an Itype that's defined within a | |
5144 -- record, that test actually applies to the record. | |
5145 | |
5146 if Is_Itype (E) and then Is_Record_Type (Scope (E)) then | |
5147 Test_E := Scope (E); | |
5148 elsif Is_Itype (E) and then Present (Underlying_Type (Scope (E))) | |
5149 and then Is_Record_Type (Underlying_Type (Scope (E))) | |
5150 then | |
5151 Test_E := Underlying_Type (Scope (E)); | |
5152 end if; | |
5153 | |
5154 -- Do not freeze if already frozen since we only need one freeze node | |
5155 | |
5156 if Is_Frozen (E) then | |
5157 Result := No_List; | |
5158 goto Leave; | |
5159 | |
5160 elsif Ekind (E) = E_Generic_Package then | |
5161 Result := Freeze_Generic_Entities (E); | |
5162 goto Leave; | |
5163 | |
5164 -- It is improper to freeze an external entity within a generic because | |
5165 -- its freeze node will appear in a non-valid context. The entity will | |
5166 -- be frozen in the proper scope after the current generic is analyzed. | |
5167 -- However, aspects must be analyzed because they may be queried later | |
5168 -- within the generic itself, and the corresponding pragma or attribute | |
5169 -- definition has not been analyzed yet. | |
5170 | |
5171 elsif Inside_A_Generic and then External_Ref_In_Generic (Test_E) then | |
5172 if Has_Delayed_Aspects (E) then | |
5173 Analyze_Aspects_At_Freeze_Point (E); | |
5174 end if; | |
5175 | |
5176 Result := No_List; | |
5177 goto Leave; | |
5178 | |
5179 -- AI05-0213: A formal incomplete type does not freeze the actual. In | |
5180 -- the instance, the same applies to the subtype renaming the actual. | |
5181 | |
5182 elsif Is_Private_Type (E) | |
5183 and then Is_Generic_Actual_Type (E) | |
5184 and then No (Full_View (Base_Type (E))) | |
5185 and then Ada_Version >= Ada_2012 | |
5186 then | |
5187 Result := No_List; | |
5188 goto Leave; | |
5189 | |
5190 -- Formal subprograms are never frozen | |
5191 | |
5192 elsif Is_Formal_Subprogram (E) then | |
5193 Result := No_List; | |
5194 goto Leave; | |
5195 | |
5196 -- Generic types are never frozen as they lack delayed semantic checks | |
5197 | |
5198 elsif Is_Generic_Type (E) then | |
5199 Result := No_List; | |
5200 goto Leave; | |
5201 | |
5202 -- Do not freeze a global entity within an inner scope created during | |
5203 -- expansion. A call to subprogram E within some internal procedure | |
5204 -- (a stream attribute for example) might require freezing E, but the | |
5205 -- freeze node must appear in the same declarative part as E itself. | |
5206 -- The two-pass elaboration mechanism in gigi guarantees that E will | |
5207 -- be frozen before the inner call is elaborated. We exclude constants | |
5208 -- from this test, because deferred constants may be frozen early, and | |
5209 -- must be diagnosed (e.g. in the case of a deferred constant being used | |
5210 -- in a default expression). If the enclosing subprogram comes from | |
5211 -- source, or is a generic instance, then the freeze point is the one | |
5212 -- mandated by the language, and we freeze the entity. A subprogram that | |
5213 -- is a child unit body that acts as a spec does not have a spec that | |
5214 -- comes from source, but can only come from source. | |
5215 | |
5216 elsif In_Open_Scopes (Scope (Test_E)) | |
5217 and then Scope (Test_E) /= Current_Scope | |
5218 and then Ekind (Test_E) /= E_Constant | |
5219 then | |
5220 declare | |
5221 S : Entity_Id; | |
5222 | |
5223 begin | |
5224 S := Current_Scope; | |
5225 while Present (S) loop | |
5226 if Is_Overloadable (S) then | |
5227 if Comes_From_Source (S) | |
5228 or else Is_Generic_Instance (S) | |
5229 or else Is_Child_Unit (S) | |
5230 then | |
5231 exit; | |
5232 else | |
5233 Result := No_List; | |
5234 goto Leave; | |
5235 end if; | |
5236 end if; | |
5237 | |
5238 S := Scope (S); | |
5239 end loop; | |
5240 end; | |
5241 | |
5242 -- Similarly, an inlined instance body may make reference to global | |
5243 -- entities, but these references cannot be the proper freezing point | |
5244 -- for them, and in the absence of inlining freezing will take place in | |
5245 -- their own scope. Normally instance bodies are analyzed after the | |
5246 -- enclosing compilation, and everything has been frozen at the proper | |
5247 -- place, but with front-end inlining an instance body is compiled | |
5248 -- before the end of the enclosing scope, and as a result out-of-order | |
5249 -- freezing must be prevented. | |
5250 | |
5251 elsif Front_End_Inlining | |
5252 and then In_Instance_Body | |
5253 and then Present (Scope (Test_E)) | |
5254 then | |
5255 declare | |
5256 S : Entity_Id; | |
5257 | |
5258 begin | |
5259 S := Scope (Test_E); | |
5260 while Present (S) loop | |
5261 if Is_Generic_Instance (S) then | |
5262 exit; | |
5263 else | |
5264 S := Scope (S); | |
5265 end if; | |
5266 end loop; | |
5267 | |
5268 if No (S) then | |
5269 Result := No_List; | |
5270 goto Leave; | |
5271 end if; | |
5272 end; | |
5273 end if; | |
5274 | |
5275 -- Add checks to detect proper initialization of scalars that may appear | |
5276 -- as subprogram parameters. | |
5277 | |
5278 if Is_Subprogram (E) and then Check_Validity_Of_Parameters then | |
5279 Apply_Parameter_Validity_Checks (E); | |
5280 end if; | |
5281 | |
5282 -- Deal with delayed aspect specifications. The analysis of the aspect | |
5283 -- is required to be delayed to the freeze point, thus we analyze the | |
5284 -- pragma or attribute definition clause in the tree at this point. We | |
5285 -- also analyze the aspect specification node at the freeze point when | |
5286 -- the aspect doesn't correspond to pragma/attribute definition clause. | |
5287 -- In addition, a derived type may have inherited aspects that were | |
5288 -- delayed in the parent, so these must also be captured now. | |
5289 | |
5290 if Has_Delayed_Aspects (E) | |
5291 or else May_Inherit_Delayed_Rep_Aspects (E) | |
5292 then | |
5293 Analyze_Aspects_At_Freeze_Point (E); | |
5294 end if; | |
5295 | |
5296 -- Here to freeze the entity | |
5297 | |
5298 Set_Is_Frozen (E); | |
5299 | |
5300 -- Case of entity being frozen is other than a type | |
5301 | |
5302 if not Is_Type (E) then | |
5303 | |
5304 -- If entity is exported or imported and does not have an external | |
5305 -- name, now is the time to provide the appropriate default name. | |
5306 -- Skip this if the entity is stubbed, since we don't need a name | |
5307 -- for any stubbed routine. For the case on intrinsics, if no | |
5308 -- external name is specified, then calls will be handled in | |
5309 -- Exp_Intr.Expand_Intrinsic_Call, and no name is needed. If an | |
5310 -- external name is provided, then Expand_Intrinsic_Call leaves | |
5311 -- calls in place for expansion by GIGI. | |
5312 | |
5313 if (Is_Imported (E) or else Is_Exported (E)) | |
5314 and then No (Interface_Name (E)) | |
5315 and then Convention (E) /= Convention_Stubbed | |
5316 and then Convention (E) /= Convention_Intrinsic | |
5317 then | |
5318 Set_Encoded_Interface_Name | |
5319 (E, Get_Default_External_Name (E)); | |
5320 | |
5321 -- If entity is an atomic object appearing in a declaration and | |
5322 -- the expression is an aggregate, assign it to a temporary to | |
5323 -- ensure that the actual assignment is done atomically rather | |
5324 -- than component-wise (the assignment to the temp may be done | |
5325 -- component-wise, but that is harmless). | |
5326 | |
5327 elsif Is_Atomic_Or_VFA (E) | |
5328 and then Nkind (Parent (E)) = N_Object_Declaration | |
5329 and then Present (Expression (Parent (E))) | |
5330 and then Nkind (Expression (Parent (E))) = N_Aggregate | |
5331 and then Is_Atomic_VFA_Aggregate (Expression (Parent (E))) | |
5332 then | |
5333 null; | |
5334 end if; | |
5335 | |
5336 -- Subprogram case | |
5337 | |
5338 if Is_Subprogram (E) then | |
5339 | |
5340 -- Check for needing to wrap imported subprogram | |
5341 | |
5342 Wrap_Imported_Subprogram (E); | |
5343 | |
5344 -- Freeze all parameter types and the return type (RM 13.14(14)). | |
5345 -- However skip this for internal subprograms. This is also where | |
5346 -- any extra formal parameters are created since we now know | |
5347 -- whether the subprogram will use a foreign convention. | |
5348 | |
5349 -- In Ada 2012, freezing a subprogram does not always freeze the | |
5350 -- corresponding profile (see AI05-019). An attribute reference | |
5351 -- is not a freezing point of the profile. Flag Do_Freeze_Profile | |
5352 -- indicates whether the profile should be frozen now. | |
5353 -- Other constructs that should not freeze ??? | |
5354 | |
5355 -- This processing doesn't apply to internal entities (see below) | |
5356 | |
5357 if not Is_Internal (E) and then Do_Freeze_Profile then | |
5358 if not Freeze_Profile (E) then | |
5359 goto Leave; | |
5360 end if; | |
5361 end if; | |
5362 | |
5363 -- Must freeze its parent first if it is a derived subprogram | |
5364 | |
5365 if Present (Alias (E)) then | |
5366 Freeze_And_Append (Alias (E), N, Result); | |
5367 end if; | |
5368 | |
5369 -- We don't freeze internal subprograms, because we don't normally | |
5370 -- want addition of extra formals or mechanism setting to happen | |
5371 -- for those. However we do pass through predefined dispatching | |
5372 -- cases, since extra formals may be needed in some cases, such as | |
5373 -- for the stream 'Input function (build-in-place formals). | |
5374 | |
5375 if not Is_Internal (E) | |
5376 or else Is_Predefined_Dispatching_Operation (E) | |
5377 then | |
5378 Freeze_Subprogram (E); | |
5379 end if; | |
5380 | |
5381 -- If warning on suspicious contracts then check for the case of | |
5382 -- a postcondition other than False for a No_Return subprogram. | |
5383 | |
5384 if No_Return (E) | |
5385 and then Warn_On_Suspicious_Contract | |
5386 and then Present (Contract (E)) | |
5387 then | |
5388 declare | |
5389 Prag : Node_Id := Pre_Post_Conditions (Contract (E)); | |
5390 Exp : Node_Id; | |
5391 | |
5392 begin | |
5393 while Present (Prag) loop | |
5394 if Nam_In (Pragma_Name_Unmapped (Prag), | |
5395 Name_Post, | |
5396 Name_Postcondition, | |
5397 Name_Refined_Post) | |
5398 then | |
5399 Exp := | |
5400 Expression | |
5401 (First (Pragma_Argument_Associations (Prag))); | |
5402 | |
5403 if Nkind (Exp) /= N_Identifier | |
5404 or else Chars (Exp) /= Name_False | |
5405 then | |
5406 Error_Msg_NE | |
5407 ("useless postcondition, & is marked " | |
5408 & "No_Return?T?", Exp, E); | |
5409 end if; | |
5410 end if; | |
5411 | |
5412 Prag := Next_Pragma (Prag); | |
5413 end loop; | |
5414 end; | |
5415 end if; | |
5416 | |
5417 -- Here for other than a subprogram or type | |
5418 | |
5419 else | |
5420 -- If entity has a type, and it is not a generic unit, then | |
5421 -- freeze it first (RM 13.14(10)). | |
5422 | |
5423 if Present (Etype (E)) | |
5424 and then Ekind (E) /= E_Generic_Function | |
5425 then | |
5426 Freeze_And_Append (Etype (E), N, Result); | |
5427 | |
5428 -- For an object of an anonymous array type, aspects on the | |
5429 -- object declaration apply to the type itself. This is the | |
5430 -- case for Atomic_Components, Volatile_Components, and | |
5431 -- Independent_Components. In these cases analysis of the | |
5432 -- generated pragma will mark the anonymous types accordingly, | |
5433 -- and the object itself does not require a freeze node. | |
5434 | |
5435 if Ekind (E) = E_Variable | |
5436 and then Is_Itype (Etype (E)) | |
5437 and then Is_Array_Type (Etype (E)) | |
5438 and then Has_Delayed_Aspects (E) | |
5439 then | |
5440 Set_Has_Delayed_Aspects (E, False); | |
5441 Set_Has_Delayed_Freeze (E, False); | |
5442 Set_Freeze_Node (E, Empty); | |
5443 end if; | |
5444 end if; | |
5445 | |
5446 -- Special processing for objects created by object declaration | |
5447 | |
5448 if Nkind (Declaration_Node (E)) = N_Object_Declaration then | |
5449 Freeze_Object_Declaration (E); | |
5450 end if; | |
5451 | |
5452 -- Check that a constant which has a pragma Volatile[_Components] | |
5453 -- or Atomic[_Components] also has a pragma Import (RM C.6(13)). | |
5454 | |
5455 -- Note: Atomic[_Components] also sets Volatile[_Components] | |
5456 | |
5457 if Ekind (E) = E_Constant | |
5458 and then (Has_Volatile_Components (E) or else Is_Volatile (E)) | |
5459 and then not Is_Imported (E) | |
5460 and then not Has_Boolean_Aspect_Import (E) | |
5461 then | |
5462 -- Make sure we actually have a pragma, and have not merely | |
5463 -- inherited the indication from elsewhere (e.g. an address | |
5464 -- clause, which is not good enough in RM terms). | |
5465 | |
5466 if Has_Rep_Pragma (E, Name_Atomic) | |
5467 or else | |
5468 Has_Rep_Pragma (E, Name_Atomic_Components) | |
5469 then | |
5470 Error_Msg_N | |
5471 ("stand alone atomic constant must be " & | |
5472 "imported (RM C.6(13))", E); | |
5473 | |
5474 elsif Has_Rep_Pragma (E, Name_Volatile) | |
5475 or else | |
5476 Has_Rep_Pragma (E, Name_Volatile_Components) | |
5477 then | |
5478 Error_Msg_N | |
5479 ("stand alone volatile constant must be " & | |
5480 "imported (RM C.6(13))", E); | |
5481 end if; | |
5482 end if; | |
5483 | |
5484 -- Static objects require special handling | |
5485 | |
5486 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) | |
5487 and then Is_Statically_Allocated (E) | |
5488 then | |
5489 Freeze_Static_Object (E); | |
5490 end if; | |
5491 | |
5492 -- Remaining step is to layout objects | |
5493 | |
5494 if Ekind_In (E, E_Variable, E_Constant, E_Loop_Parameter) | |
5495 or else Is_Formal (E) | |
5496 then | |
5497 Layout_Object (E); | |
5498 end if; | |
5499 | |
5500 -- For an object that does not have delayed freezing, and whose | |
5501 -- initialization actions have been captured in a compound | |
5502 -- statement, move them back now directly within the enclosing | |
5503 -- statement sequence. | |
5504 | |
5505 if Ekind_In (E, E_Constant, E_Variable) | |
5506 and then not Has_Delayed_Freeze (E) | |
5507 then | |
5508 Explode_Initialization_Compound_Statement (E); | |
5509 end if; | |
5510 | |
5511 -- Do not generate a freeze node for a generic unit | |
5512 | |
5513 if Is_Generic_Unit (E) then | |
5514 Result := No_List; | |
5515 goto Leave; | |
5516 end if; | |
5517 end if; | |
5518 | |
5519 -- Case of a type or subtype being frozen | |
5520 | |
5521 else | |
5522 -- We used to check here that a full type must have preelaborable | |
5523 -- initialization if it completes a private type specified with | |
5524 -- pragma Preelaborable_Initialization, but that missed cases where | |
5525 -- the types occur within a generic package, since the freezing | |
5526 -- that occurs within a containing scope generally skips traversal | |
5527 -- of a generic unit's declarations (those will be frozen within | |
5528 -- instances). This check was moved to Analyze_Package_Specification. | |
5529 | |
5530 -- The type may be defined in a generic unit. This can occur when | |
5531 -- freezing a generic function that returns the type (which is | |
5532 -- defined in a parent unit). It is clearly meaningless to freeze | |
5533 -- this type. However, if it is a subtype, its size may be determi- | |
5534 -- nable and used in subsequent checks, so might as well try to | |
5535 -- compute it. | |
5536 | |
5537 -- In Ada 2012, Freeze_Entities is also used in the front end to | |
5538 -- trigger the analysis of aspect expressions, so in this case we | |
5539 -- want to continue the freezing process. | |
5540 | |
5541 -- Is_Generic_Unit (Scope (E)) is dubious here, do we want instead | |
5542 -- In_Generic_Scope (E)??? | |
5543 | |
5544 if Present (Scope (E)) | |
5545 and then Is_Generic_Unit (Scope (E)) | |
5546 and then | |
5547 (not Has_Predicates (E) | |
5548 and then not Has_Delayed_Freeze (E)) | |
5549 then | |
5550 Check_Compile_Time_Size (E); | |
5551 Result := No_List; | |
5552 goto Leave; | |
5553 end if; | |
5554 | |
5555 -- Check for error of Type_Invariant'Class applied to an untagged | |
5556 -- type (check delayed to freeze time when full type is available). | |
5557 | |
5558 declare | |
5559 Prag : constant Node_Id := Get_Pragma (E, Pragma_Invariant); | |
5560 begin | |
5561 if Present (Prag) | |
5562 and then Class_Present (Prag) | |
5563 and then not Is_Tagged_Type (E) | |
5564 then | |
5565 Error_Msg_NE | |
5566 ("Type_Invariant''Class cannot be specified for &", Prag, E); | |
5567 Error_Msg_N | |
5568 ("\can only be specified for a tagged type", Prag); | |
5569 end if; | |
5570 end; | |
5571 | |
5572 if Is_Ghost_Entity (E) then | |
5573 | |
5574 -- A Ghost type cannot be concurrent (SPARK RM 6.9(19)). Verify | |
5575 -- this legality rule first to five a finer-grained diagnostic. | |
5576 | |
5577 if Is_Concurrent_Type (E) then | |
5578 Error_Msg_N ("ghost type & cannot be concurrent", E); | |
5579 | |
5580 -- A Ghost type cannot be effectively volatile (SPARK RM 6.9(7)) | |
5581 | |
5582 elsif Is_Effectively_Volatile (E) then | |
5583 Error_Msg_N ("ghost type & cannot be volatile", E); | |
5584 end if; | |
5585 end if; | |
5586 | |
5587 -- Deal with special cases of freezing for subtype | |
5588 | |
5589 if E /= Base_Type (E) then | |
5590 | |
5591 -- Before we do anything else, a specific test for the case of a | |
5592 -- size given for an array where the array would need to be packed | |
5593 -- in order for the size to be honored, but is not. This is the | |
5594 -- case where implicit packing may apply. The reason we do this so | |
5595 -- early is that, if we have implicit packing, the layout of the | |
5596 -- base type is affected, so we must do this before we freeze the | |
5597 -- base type. | |
5598 | |
5599 -- We could do this processing only if implicit packing is enabled | |
5600 -- since in all other cases, the error would be caught by the back | |
5601 -- end. However, we choose to do the check even if we do not have | |
5602 -- implicit packing enabled, since this allows us to give a more | |
5603 -- useful error message (advising use of pragma Implicit_Packing | |
5604 -- or pragma Pack). | |
5605 | |
5606 if Is_Array_Type (E) then | |
5607 declare | |
5608 Ctyp : constant Entity_Id := Component_Type (E); | |
5609 Rsiz : constant Uint := RM_Size (Ctyp); | |
5610 SZ : constant Node_Id := Size_Clause (E); | |
5611 Btyp : constant Entity_Id := Base_Type (E); | |
5612 | |
5613 Lo : Node_Id; | |
5614 Hi : Node_Id; | |
5615 Indx : Node_Id; | |
5616 | |
5617 Dim : Uint; | |
5618 Num_Elmts : Uint := Uint_1; | |
5619 -- Number of elements in array | |
5620 | |
5621 begin | |
5622 -- Check enabling conditions. These are straightforward | |
5623 -- except for the test for a limited composite type. This | |
5624 -- eliminates the rare case of a array of limited components | |
5625 -- where there are issues of whether or not we can go ahead | |
5626 -- and pack the array (since we can't freely pack and unpack | |
5627 -- arrays if they are limited). | |
5628 | |
5629 -- Note that we check the root type explicitly because the | |
5630 -- whole point is we are doing this test before we have had | |
5631 -- a chance to freeze the base type (and it is that freeze | |
5632 -- action that causes stuff to be inherited). | |
5633 | |
5634 -- The conditions on the size are identical to those used in | |
5635 -- Freeze_Array_Type to set the Is_Packed flag. | |
5636 | |
5637 if Has_Size_Clause (E) | |
5638 and then Known_Static_RM_Size (E) | |
5639 and then not Is_Packed (E) | |
5640 and then not Has_Pragma_Pack (E) | |
5641 and then not Has_Component_Size_Clause (E) | |
5642 and then Known_Static_RM_Size (Ctyp) | |
5643 and then Rsiz <= 64 | |
5644 and then not (Addressable (Rsiz) | |
5645 and then Known_Static_Esize (Ctyp) | |
5646 and then Esize (Ctyp) = Rsiz) | |
5647 and then not (Rsiz mod System_Storage_Unit = 0 | |
5648 and then Is_Composite_Type (Ctyp)) | |
5649 and then not Is_Limited_Composite (E) | |
5650 and then not Is_Packed (Root_Type (E)) | |
5651 and then not Has_Component_Size_Clause (Root_Type (E)) | |
5652 and then not (CodePeer_Mode or GNATprove_Mode) | |
5653 then | |
5654 -- Compute number of elements in array | |
5655 | |
5656 Indx := First_Index (E); | |
5657 while Present (Indx) loop | |
5658 Get_Index_Bounds (Indx, Lo, Hi); | |
5659 | |
5660 if not (Compile_Time_Known_Value (Lo) | |
5661 and then | |
5662 Compile_Time_Known_Value (Hi)) | |
5663 then | |
5664 goto No_Implicit_Packing; | |
5665 end if; | |
5666 | |
5667 Dim := Expr_Value (Hi) - Expr_Value (Lo) + 1; | |
5668 | |
5669 if Dim >= 0 then | |
5670 Num_Elmts := Num_Elmts * Dim; | |
5671 else | |
5672 Num_Elmts := Uint_0; | |
5673 end if; | |
5674 | |
5675 Next_Index (Indx); | |
5676 end loop; | |
5677 | |
5678 -- What we are looking for here is the situation where | |
5679 -- the RM_Size given would be exactly right if there was | |
5680 -- a pragma Pack, resulting in the component size being | |
5681 -- the RM_Size of the component type. | |
5682 | |
5683 if RM_Size (E) = Num_Elmts * Rsiz then | |
5684 | |
5685 -- For implicit packing mode, just set the component | |
5686 -- size and Freeze_Array_Type will do the rest. | |
5687 | |
5688 if Implicit_Packing then | |
5689 Set_Component_Size (Btyp, Rsiz); | |
5690 | |
5691 -- Otherwise give an error message | |
5692 | |
5693 else | |
5694 Error_Msg_NE | |
5695 ("size given for& too small", SZ, E); | |
5696 Error_Msg_N -- CODEFIX | |
5697 ("\use explicit pragma Pack or use pragma " | |
5698 & "Implicit_Packing", SZ); | |
5699 end if; | |
5700 end if; | |
5701 end if; | |
5702 end; | |
5703 end if; | |
5704 | |
5705 <<No_Implicit_Packing>> | |
5706 | |
5707 -- If ancestor subtype present, freeze that first. Note that this | |
5708 -- will also get the base type frozen. Need RM reference ??? | |
5709 | |
5710 Atype := Ancestor_Subtype (E); | |
5711 | |
5712 if Present (Atype) then | |
5713 Freeze_And_Append (Atype, N, Result); | |
5714 | |
5715 -- No ancestor subtype present | |
5716 | |
5717 else | |
5718 -- See if we have a nearest ancestor that has a predicate. | |
5719 -- That catches the case of derived type with a predicate. | |
5720 -- Need RM reference here ??? | |
5721 | |
5722 Atype := Nearest_Ancestor (E); | |
5723 | |
5724 if Present (Atype) and then Has_Predicates (Atype) then | |
5725 Freeze_And_Append (Atype, N, Result); | |
5726 end if; | |
5727 | |
5728 -- Freeze base type before freezing the entity (RM 13.14(15)) | |
5729 | |
5730 if E /= Base_Type (E) then | |
5731 Freeze_And_Append (Base_Type (E), N, Result); | |
5732 end if; | |
5733 end if; | |
5734 | |
5735 -- A subtype inherits all the type-related representation aspects | |
5736 -- from its parents (RM 13.1(8)). | |
5737 | |
5738 Inherit_Aspects_At_Freeze_Point (E); | |
5739 | |
5740 -- For a derived type, freeze its parent type first (RM 13.14(15)) | |
5741 | |
5742 elsif Is_Derived_Type (E) then | |
5743 Freeze_And_Append (Etype (E), N, Result); | |
5744 Freeze_And_Append (First_Subtype (Etype (E)), N, Result); | |
5745 | |
5746 -- A derived type inherits each type-related representation aspect | |
5747 -- of its parent type that was directly specified before the | |
5748 -- declaration of the derived type (RM 13.1(15)). | |
5749 | |
5750 Inherit_Aspects_At_Freeze_Point (E); | |
5751 end if; | |
5752 | |
5753 -- Check for incompatible size and alignment for record type | |
5754 | |
5755 if Warn_On_Size_Alignment | |
5756 and then Is_Record_Type (E) | |
5757 and then Has_Size_Clause (E) and then Has_Alignment_Clause (E) | |
5758 | |
5759 -- If explicit Object_Size clause given assume that the programmer | |
5760 -- knows what he is doing, and expects the compiler behavior. | |
5761 | |
5762 and then not Has_Object_Size_Clause (E) | |
5763 | |
5764 -- Check for size not a multiple of alignment | |
5765 | |
5766 and then RM_Size (E) mod (Alignment (E) * System_Storage_Unit) /= 0 | |
5767 then | |
5768 declare | |
5769 SC : constant Node_Id := Size_Clause (E); | |
5770 AC : constant Node_Id := Alignment_Clause (E); | |
5771 Loc : Node_Id; | |
5772 Abits : constant Uint := Alignment (E) * System_Storage_Unit; | |
5773 | |
5774 begin | |
5775 if Present (SC) and then Present (AC) then | |
5776 | |
5777 -- Give a warning | |
5778 | |
5779 if Sloc (SC) > Sloc (AC) then | |
5780 Loc := SC; | |
5781 Error_Msg_NE | |
5782 ("?Z?size is not a multiple of alignment for &", | |
5783 Loc, E); | |
5784 Error_Msg_Sloc := Sloc (AC); | |
5785 Error_Msg_Uint_1 := Alignment (E); | |
5786 Error_Msg_N ("\?Z?alignment of ^ specified #", Loc); | |
5787 | |
5788 else | |
5789 Loc := AC; | |
5790 Error_Msg_NE | |
5791 ("?Z?size is not a multiple of alignment for &", | |
5792 Loc, E); | |
5793 Error_Msg_Sloc := Sloc (SC); | |
5794 Error_Msg_Uint_1 := RM_Size (E); | |
5795 Error_Msg_N ("\?Z?size of ^ specified #", Loc); | |
5796 end if; | |
5797 | |
5798 Error_Msg_Uint_1 := ((RM_Size (E) / Abits) + 1) * Abits; | |
5799 Error_Msg_N ("\?Z?Object_Size will be increased to ^", Loc); | |
5800 end if; | |
5801 end; | |
5802 end if; | |
5803 | |
5804 -- Array type | |
5805 | |
5806 if Is_Array_Type (E) then | |
5807 Freeze_Array_Type (E); | |
5808 | |
5809 -- For a class-wide type, the corresponding specific type is | |
5810 -- frozen as well (RM 13.14(15)) | |
5811 | |
5812 elsif Is_Class_Wide_Type (E) then | |
5813 Freeze_And_Append (Root_Type (E), N, Result); | |
5814 | |
5815 -- If the base type of the class-wide type is still incomplete, | |
5816 -- the class-wide remains unfrozen as well. This is legal when | |
5817 -- E is the formal of a primitive operation of some other type | |
5818 -- which is being frozen. | |
5819 | |
5820 if not Is_Frozen (Root_Type (E)) then | |
5821 Set_Is_Frozen (E, False); | |
5822 goto Leave; | |
5823 end if; | |
5824 | |
5825 -- The equivalent type associated with a class-wide subtype needs | |
5826 -- to be frozen to ensure that its layout is done. | |
5827 | |
5828 if Ekind (E) = E_Class_Wide_Subtype | |
5829 and then Present (Equivalent_Type (E)) | |
5830 then | |
5831 Freeze_And_Append (Equivalent_Type (E), N, Result); | |
5832 end if; | |
5833 | |
5834 -- Generate an itype reference for a library-level class-wide type | |
5835 -- at the freeze point. Otherwise the first explicit reference to | |
5836 -- the type may appear in an inner scope which will be rejected by | |
5837 -- the back-end. | |
5838 | |
5839 if Is_Itype (E) | |
5840 and then Is_Compilation_Unit (Scope (E)) | |
5841 then | |
5842 declare | |
5843 Ref : constant Node_Id := Make_Itype_Reference (Loc); | |
5844 | |
5845 begin | |
5846 Set_Itype (Ref, E); | |
5847 | |
5848 -- From a gigi point of view, a class-wide subtype derives | |
5849 -- from its record equivalent type. As a result, the itype | |
5850 -- reference must appear after the freeze node of the | |
5851 -- equivalent type or gigi will reject the reference. | |
5852 | |
5853 if Ekind (E) = E_Class_Wide_Subtype | |
5854 and then Present (Equivalent_Type (E)) | |
5855 then | |
5856 Insert_After (Freeze_Node (Equivalent_Type (E)), Ref); | |
5857 else | |
5858 Add_To_Result (Ref); | |
5859 end if; | |
5860 end; | |
5861 end if; | |
5862 | |
5863 -- For a record type or record subtype, freeze all component types | |
5864 -- (RM 13.14(15)). We test for E_Record_(sub)Type here, rather than | |
5865 -- using Is_Record_Type, because we don't want to attempt the freeze | |
5866 -- for the case of a private type with record extension (we will do | |
5867 -- that later when the full type is frozen). | |
5868 | |
5869 elsif Ekind_In (E, E_Record_Type, E_Record_Subtype) then | |
5870 if not In_Generic_Scope (E) then | |
5871 Freeze_Record_Type (E); | |
5872 end if; | |
5873 | |
5874 -- Report a warning if a discriminated record base type has a | |
5875 -- convention with language C or C++ applied to it. This check is | |
5876 -- done even within generic scopes (but not in instantiations), | |
5877 -- which is why we don't do it as part of Freeze_Record_Type. | |
5878 | |
5879 Check_Suspicious_Convention (E); | |
5880 | |
5881 -- For a concurrent type, freeze corresponding record type. This does | |
5882 -- not correspond to any specific rule in the RM, but the record type | |
5883 -- is essentially part of the concurrent type. Also freeze all local | |
5884 -- entities. This includes record types created for entry parameter | |
5885 -- blocks and whatever local entities may appear in the private part. | |
5886 | |
5887 elsif Is_Concurrent_Type (E) then | |
5888 if Present (Corresponding_Record_Type (E)) then | |
5889 Freeze_And_Append (Corresponding_Record_Type (E), N, Result); | |
5890 end if; | |
5891 | |
5892 Comp := First_Entity (E); | |
5893 while Present (Comp) loop | |
5894 if Is_Type (Comp) then | |
5895 Freeze_And_Append (Comp, N, Result); | |
5896 | |
5897 elsif (Ekind (Comp)) /= E_Function then | |
5898 | |
5899 -- The guard on the presence of the Etype seems to be needed | |
5900 -- for some CodePeer (-gnatcC) cases, but not clear why??? | |
5901 | |
5902 if Present (Etype (Comp)) then | |
5903 if Is_Itype (Etype (Comp)) | |
5904 and then Underlying_Type (Scope (Etype (Comp))) = E | |
5905 then | |
5906 Undelay_Type (Etype (Comp)); | |
5907 end if; | |
5908 | |
5909 Freeze_And_Append (Etype (Comp), N, Result); | |
5910 end if; | |
5911 end if; | |
5912 | |
5913 Next_Entity (Comp); | |
5914 end loop; | |
5915 | |
5916 -- Private types are required to point to the same freeze node as | |
5917 -- their corresponding full views. The freeze node itself has to | |
5918 -- point to the partial view of the entity (because from the partial | |
5919 -- view, we can retrieve the full view, but not the reverse). | |
5920 -- However, in order to freeze correctly, we need to freeze the full | |
5921 -- view. If we are freezing at the end of a scope (or within the | |
5922 -- scope) of the private type, the partial and full views will have | |
5923 -- been swapped, the full view appears first in the entity chain and | |
5924 -- the swapping mechanism ensures that the pointers are properly set | |
5925 -- (on scope exit). | |
5926 | |
5927 -- If we encounter the partial view before the full view (e.g. when | |
5928 -- freezing from another scope), we freeze the full view, and then | |
5929 -- set the pointers appropriately since we cannot rely on swapping to | |
5930 -- fix things up (subtypes in an outer scope might not get swapped). | |
5931 | |
5932 -- If the full view is itself private, the above requirements apply | |
5933 -- to the underlying full view instead of the full view. But there is | |
5934 -- no swapping mechanism for the underlying full view so we need to | |
5935 -- set the pointers appropriately in both cases. | |
5936 | |
5937 elsif Is_Incomplete_Or_Private_Type (E) | |
5938 and then not Is_Generic_Type (E) | |
5939 then | |
5940 -- The construction of the dispatch table associated with library | |
5941 -- level tagged types forces freezing of all the primitives of the | |
5942 -- type, which may cause premature freezing of the partial view. | |
5943 -- For example: | |
5944 | |
5945 -- package Pkg is | |
5946 -- type T is tagged private; | |
5947 -- type DT is new T with private; | |
5948 -- procedure Prim (X : in out T; Y : in out DT'Class); | |
5949 -- private | |
5950 -- type T is tagged null record; | |
5951 -- Obj : T; | |
5952 -- type DT is new T with null record; | |
5953 -- end; | |
5954 | |
5955 -- In this case the type will be frozen later by the usual | |
5956 -- mechanism: an object declaration, an instantiation, or the | |
5957 -- end of a declarative part. | |
5958 | |
5959 if Is_Library_Level_Tagged_Type (E) | |
5960 and then not Present (Full_View (E)) | |
5961 then | |
5962 Set_Is_Frozen (E, False); | |
5963 goto Leave; | |
5964 | |
5965 -- Case of full view present | |
5966 | |
5967 elsif Present (Full_View (E)) then | |
5968 | |
5969 -- If full view has already been frozen, then no further | |
5970 -- processing is required | |
5971 | |
5972 if Is_Frozen (Full_View (E)) then | |
5973 Set_Has_Delayed_Freeze (E, False); | |
5974 Set_Freeze_Node (E, Empty); | |
5975 | |
5976 -- Otherwise freeze full view and patch the pointers so that | |
5977 -- the freeze node will elaborate both views in the back end. | |
5978 -- However, if full view is itself private, freeze underlying | |
5979 -- full view instead and patch the pointers so that the freeze | |
5980 -- node will elaborate the three views in the back end. | |
5981 | |
5982 else | |
5983 declare | |
5984 Full : Entity_Id := Full_View (E); | |
5985 | |
5986 begin | |
5987 if Is_Private_Type (Full) | |
5988 and then Present (Underlying_Full_View (Full)) | |
5989 then | |
5990 Full := Underlying_Full_View (Full); | |
5991 end if; | |
5992 | |
5993 Freeze_And_Append (Full, N, Result); | |
5994 | |
5995 if Full /= Full_View (E) | |
5996 and then Has_Delayed_Freeze (Full_View (E)) | |
5997 then | |
5998 F_Node := Freeze_Node (Full); | |
5999 | |
6000 if Present (F_Node) then | |
6001 Inherit_Freeze_Node | |
6002 (Fnod => F_Node, | |
6003 Typ => Full_View (E)); | |
6004 else | |
6005 Set_Has_Delayed_Freeze (Full_View (E), False); | |
6006 Set_Freeze_Node (Full_View (E), Empty); | |
6007 end if; | |
6008 end if; | |
6009 | |
6010 if Has_Delayed_Freeze (E) then | |
6011 F_Node := Freeze_Node (Full_View (E)); | |
6012 | |
6013 if Present (F_Node) then | |
6014 Inherit_Freeze_Node | |
6015 (Fnod => F_Node, | |
6016 Typ => E); | |
6017 else | |
6018 -- {Incomplete,Private}_Subtypes with Full_Views | |
6019 -- constrained by discriminants. | |
6020 | |
6021 Set_Has_Delayed_Freeze (E, False); | |
6022 Set_Freeze_Node (E, Empty); | |
6023 end if; | |
6024 end if; | |
6025 end; | |
6026 end if; | |
6027 | |
6028 Check_Debug_Info_Needed (E); | |
6029 | |
6030 -- AI-117 requires that the convention of a partial view be the | |
6031 -- same as the convention of the full view. Note that this is a | |
6032 -- recognized breach of privacy, but it's essential for logical | |
6033 -- consistency of representation, and the lack of a rule in | |
6034 -- RM95 was an oversight. | |
6035 | |
6036 Set_Convention (E, Convention (Full_View (E))); | |
6037 | |
6038 Set_Size_Known_At_Compile_Time (E, | |
6039 Size_Known_At_Compile_Time (Full_View (E))); | |
6040 | |
6041 -- Size information is copied from the full view to the | |
6042 -- incomplete or private view for consistency. | |
6043 | |
6044 -- We skip this is the full view is not a type. This is very | |
6045 -- strange of course, and can only happen as a result of | |
6046 -- certain illegalities, such as a premature attempt to derive | |
6047 -- from an incomplete type. | |
6048 | |
6049 if Is_Type (Full_View (E)) then | |
6050 Set_Size_Info (E, Full_View (E)); | |
6051 Set_RM_Size (E, RM_Size (Full_View (E))); | |
6052 end if; | |
6053 | |
6054 goto Leave; | |
6055 | |
6056 -- Case of underlying full view present | |
6057 | |
6058 elsif Is_Private_Type (E) | |
6059 and then Present (Underlying_Full_View (E)) | |
6060 then | |
6061 if not Is_Frozen (Underlying_Full_View (E)) then | |
6062 Freeze_And_Append (Underlying_Full_View (E), N, Result); | |
6063 end if; | |
6064 | |
6065 -- Patch the pointers so that the freeze node will elaborate | |
6066 -- both views in the back end. | |
6067 | |
6068 if Has_Delayed_Freeze (E) then | |
6069 F_Node := Freeze_Node (Underlying_Full_View (E)); | |
6070 | |
6071 if Present (F_Node) then | |
6072 Inherit_Freeze_Node | |
6073 (Fnod => F_Node, | |
6074 Typ => E); | |
6075 else | |
6076 Set_Has_Delayed_Freeze (E, False); | |
6077 Set_Freeze_Node (E, Empty); | |
6078 end if; | |
6079 end if; | |
6080 | |
6081 Check_Debug_Info_Needed (E); | |
6082 | |
6083 goto Leave; | |
6084 | |
6085 -- Case of no full view present. If entity is derived or subtype, | |
6086 -- it is safe to freeze, correctness depends on the frozen status | |
6087 -- of parent. Otherwise it is either premature usage, or a Taft | |
6088 -- amendment type, so diagnosis is at the point of use and the | |
6089 -- type might be frozen later. | |
6090 | |
6091 elsif E /= Base_Type (E) or else Is_Derived_Type (E) then | |
6092 null; | |
6093 | |
6094 else | |
6095 Set_Is_Frozen (E, False); | |
6096 Result := No_List; | |
6097 goto Leave; | |
6098 end if; | |
6099 | |
6100 -- For access subprogram, freeze types of all formals, the return | |
6101 -- type was already frozen, since it is the Etype of the function. | |
6102 -- Formal types can be tagged Taft amendment types, but otherwise | |
6103 -- they cannot be incomplete. | |
6104 | |
6105 elsif Ekind (E) = E_Subprogram_Type then | |
6106 Formal := First_Formal (E); | |
6107 while Present (Formal) loop | |
6108 if Ekind (Etype (Formal)) = E_Incomplete_Type | |
6109 and then No (Full_View (Etype (Formal))) | |
6110 then | |
6111 if Is_Tagged_Type (Etype (Formal)) then | |
6112 null; | |
6113 | |
6114 -- AI05-151: Incomplete types are allowed in access to | |
6115 -- subprogram specifications. | |
6116 | |
6117 elsif Ada_Version < Ada_2012 then | |
6118 Error_Msg_NE | |
6119 ("invalid use of incomplete type&", E, Etype (Formal)); | |
6120 end if; | |
6121 end if; | |
6122 | |
6123 Freeze_And_Append (Etype (Formal), N, Result); | |
6124 Next_Formal (Formal); | |
6125 end loop; | |
6126 | |
6127 Freeze_Subprogram (E); | |
6128 | |
6129 -- For access to a protected subprogram, freeze the equivalent type | |
6130 -- (however this is not set if we are not generating code or if this | |
6131 -- is an anonymous type used just for resolution). | |
6132 | |
6133 elsif Is_Access_Protected_Subprogram_Type (E) then | |
6134 if Present (Equivalent_Type (E)) then | |
6135 Freeze_And_Append (Equivalent_Type (E), N, Result); | |
6136 end if; | |
6137 end if; | |
6138 | |
6139 -- Generic types are never seen by the back-end, and are also not | |
6140 -- processed by the expander (since the expander is turned off for | |
6141 -- generic processing), so we never need freeze nodes for them. | |
6142 | |
6143 if Is_Generic_Type (E) then | |
6144 goto Leave; | |
6145 end if; | |
6146 | |
6147 -- Some special processing for non-generic types to complete | |
6148 -- representation details not known till the freeze point. | |
6149 | |
6150 if Is_Fixed_Point_Type (E) then | |
6151 Freeze_Fixed_Point_Type (E); | |
6152 | |
6153 -- Some error checks required for ordinary fixed-point type. Defer | |
6154 -- these till the freeze-point since we need the small and range | |
6155 -- values. We only do these checks for base types | |
6156 | |
6157 if Is_Ordinary_Fixed_Point_Type (E) and then Is_Base_Type (E) then | |
6158 if Small_Value (E) < Ureal_2_M_80 then | |
6159 Error_Msg_Name_1 := Name_Small; | |
6160 Error_Msg_N | |
6161 ("`&''%` too small, minimum allowed is 2.0'*'*(-80)", E); | |
6162 | |
6163 elsif Small_Value (E) > Ureal_2_80 then | |
6164 Error_Msg_Name_1 := Name_Small; | |
6165 Error_Msg_N | |
6166 ("`&''%` too large, maximum allowed is 2.0'*'*80", E); | |
6167 end if; | |
6168 | |
6169 if Expr_Value_R (Type_Low_Bound (E)) < Ureal_M_10_36 then | |
6170 Error_Msg_Name_1 := Name_First; | |
6171 Error_Msg_N | |
6172 ("`&''%` too small, minimum allowed is -10.0'*'*36", E); | |
6173 end if; | |
6174 | |
6175 if Expr_Value_R (Type_High_Bound (E)) > Ureal_10_36 then | |
6176 Error_Msg_Name_1 := Name_Last; | |
6177 Error_Msg_N | |
6178 ("`&''%` too large, maximum allowed is 10.0'*'*36", E); | |
6179 end if; | |
6180 end if; | |
6181 | |
6182 elsif Is_Enumeration_Type (E) then | |
6183 Freeze_Enumeration_Type (E); | |
6184 | |
6185 elsif Is_Integer_Type (E) then | |
6186 Adjust_Esize_For_Alignment (E); | |
6187 | |
6188 if Is_Modular_Integer_Type (E) | |
6189 and then Warn_On_Suspicious_Modulus_Value | |
6190 then | |
6191 Check_Suspicious_Modulus (E); | |
6192 end if; | |
6193 | |
6194 -- The pool applies to named and anonymous access types, but not | |
6195 -- to subprogram and to internal types generated for 'Access | |
6196 -- references. | |
6197 | |
6198 elsif Is_Access_Type (E) | |
6199 and then not Is_Access_Subprogram_Type (E) | |
6200 and then Ekind (E) /= E_Access_Attribute_Type | |
6201 then | |
6202 -- If a pragma Default_Storage_Pool applies, and this type has no | |
6203 -- Storage_Pool or Storage_Size clause (which must have occurred | |
6204 -- before the freezing point), then use the default. This applies | |
6205 -- only to base types. | |
6206 | |
6207 -- None of this applies to access to subprograms, for which there | |
6208 -- are clearly no pools. | |
6209 | |
6210 if Present (Default_Pool) | |
6211 and then Is_Base_Type (E) | |
6212 and then not Has_Storage_Size_Clause (E) | |
6213 and then No (Associated_Storage_Pool (E)) | |
6214 then | |
6215 -- Case of pragma Default_Storage_Pool (null) | |
6216 | |
6217 if Nkind (Default_Pool) = N_Null then | |
6218 Set_No_Pool_Assigned (E); | |
6219 | |
6220 -- Case of pragma Default_Storage_Pool (storage_pool_NAME) | |
6221 | |
6222 else | |
6223 Set_Associated_Storage_Pool (E, Entity (Default_Pool)); | |
6224 end if; | |
6225 end if; | |
6226 | |
6227 -- Check restriction for standard storage pool | |
6228 | |
6229 if No (Associated_Storage_Pool (E)) then | |
6230 Check_Restriction (No_Standard_Storage_Pools, E); | |
6231 end if; | |
6232 | |
6233 -- Deal with error message for pure access type. This is not an | |
6234 -- error in Ada 2005 if there is no pool (see AI-366). | |
6235 | |
6236 if Is_Pure_Unit_Access_Type (E) | |
6237 and then (Ada_Version < Ada_2005 | |
6238 or else not No_Pool_Assigned (E)) | |
6239 and then not Is_Generic_Unit (Scope (E)) | |
6240 then | |
6241 Error_Msg_N ("named access type not allowed in pure unit", E); | |
6242 | |
6243 if Ada_Version >= Ada_2005 then | |
6244 Error_Msg_N | |
6245 ("\would be legal if Storage_Size of 0 given??", E); | |
6246 | |
6247 elsif No_Pool_Assigned (E) then | |
6248 Error_Msg_N | |
6249 ("\would be legal in Ada 2005??", E); | |
6250 | |
6251 else | |
6252 Error_Msg_N | |
6253 ("\would be legal in Ada 2005 if " | |
6254 & "Storage_Size of 0 given??", E); | |
6255 end if; | |
6256 end if; | |
6257 end if; | |
6258 | |
6259 -- Case of composite types | |
6260 | |
6261 if Is_Composite_Type (E) then | |
6262 | |
6263 -- AI-117 requires that all new primitives of a tagged type must | |
6264 -- inherit the convention of the full view of the type. Inherited | |
6265 -- and overriding operations are defined to inherit the convention | |
6266 -- of their parent or overridden subprogram (also specified in | |
6267 -- AI-117), which will have occurred earlier (in Derive_Subprogram | |
6268 -- and New_Overloaded_Entity). Here we set the convention of | |
6269 -- primitives that are still convention Ada, which will ensure | |
6270 -- that any new primitives inherit the type's convention. Class- | |
6271 -- wide types can have a foreign convention inherited from their | |
6272 -- specific type, but are excluded from this since they don't have | |
6273 -- any associated primitives. | |
6274 | |
6275 if Is_Tagged_Type (E) | |
6276 and then not Is_Class_Wide_Type (E) | |
6277 and then Convention (E) /= Convention_Ada | |
6278 then | |
6279 declare | |
6280 Prim_List : constant Elist_Id := Primitive_Operations (E); | |
6281 Prim : Elmt_Id; | |
6282 | |
6283 begin | |
6284 Prim := First_Elmt (Prim_List); | |
6285 while Present (Prim) loop | |
6286 if Convention (Node (Prim)) = Convention_Ada then | |
6287 Set_Convention (Node (Prim), Convention (E)); | |
6288 end if; | |
6289 | |
6290 Next_Elmt (Prim); | |
6291 end loop; | |
6292 end; | |
6293 end if; | |
6294 | |
6295 -- If the type is a simple storage pool type, then this is where | |
6296 -- we attempt to locate and validate its Allocate, Deallocate, and | |
6297 -- Storage_Size operations (the first is required, and the latter | |
6298 -- two are optional). We also verify that the full type for a | |
6299 -- private type is allowed to be a simple storage pool type. | |
6300 | |
6301 if Present (Get_Rep_Pragma (E, Name_Simple_Storage_Pool_Type)) | |
6302 and then (Is_Base_Type (E) or else Has_Private_Declaration (E)) | |
6303 then | |
6304 -- If the type is marked Has_Private_Declaration, then this is | |
6305 -- a full type for a private type that was specified with the | |
6306 -- pragma Simple_Storage_Pool_Type, and here we ensure that the | |
6307 -- pragma is allowed for the full type (for example, it can't | |
6308 -- be an array type, or a nonlimited record type). | |
6309 | |
6310 if Has_Private_Declaration (E) then | |
6311 if (not Is_Record_Type (E) or else not Is_Limited_View (E)) | |
6312 and then not Is_Private_Type (E) | |
6313 then | |
6314 Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type; | |
6315 Error_Msg_N | |
6316 ("pragma% can only apply to full type that is an " & | |
6317 "explicitly limited type", E); | |
6318 end if; | |
6319 end if; | |
6320 | |
6321 Validate_Simple_Pool_Ops : declare | |
6322 Pool_Type : Entity_Id renames E; | |
6323 Address_Type : constant Entity_Id := RTE (RE_Address); | |
6324 Stg_Cnt_Type : constant Entity_Id := RTE (RE_Storage_Count); | |
6325 | |
6326 procedure Validate_Simple_Pool_Op_Formal | |
6327 (Pool_Op : Entity_Id; | |
6328 Pool_Op_Formal : in out Entity_Id; | |
6329 Expected_Mode : Formal_Kind; | |
6330 Expected_Type : Entity_Id; | |
6331 Formal_Name : String; | |
6332 OK_Formal : in out Boolean); | |
6333 -- Validate one formal Pool_Op_Formal of the candidate pool | |
6334 -- operation Pool_Op. The formal must be of Expected_Type | |
6335 -- and have mode Expected_Mode. OK_Formal will be set to | |
6336 -- False if the formal doesn't match. If OK_Formal is False | |
6337 -- on entry, then the formal will effectively be ignored | |
6338 -- (because validation of the pool op has already failed). | |
6339 -- Upon return, Pool_Op_Formal will be updated to the next | |
6340 -- formal, if any. | |
6341 | |
6342 procedure Validate_Simple_Pool_Operation | |
6343 (Op_Name : Name_Id); | |
6344 -- Search for and validate a simple pool operation with the | |
6345 -- name Op_Name. If the name is Allocate, then there must be | |
6346 -- exactly one such primitive operation for the simple pool | |
6347 -- type. If the name is Deallocate or Storage_Size, then | |
6348 -- there can be at most one such primitive operation. The | |
6349 -- profile of the located primitive must conform to what | |
6350 -- is expected for each operation. | |
6351 | |
6352 ------------------------------------ | |
6353 -- Validate_Simple_Pool_Op_Formal -- | |
6354 ------------------------------------ | |
6355 | |
6356 procedure Validate_Simple_Pool_Op_Formal | |
6357 (Pool_Op : Entity_Id; | |
6358 Pool_Op_Formal : in out Entity_Id; | |
6359 Expected_Mode : Formal_Kind; | |
6360 Expected_Type : Entity_Id; | |
6361 Formal_Name : String; | |
6362 OK_Formal : in out Boolean) | |
6363 is | |
6364 begin | |
6365 -- If OK_Formal is False on entry, then simply ignore | |
6366 -- the formal, because an earlier formal has already | |
6367 -- been flagged. | |
6368 | |
6369 if not OK_Formal then | |
6370 return; | |
6371 | |
6372 -- If no formal is passed in, then issue an error for a | |
6373 -- missing formal. | |
6374 | |
6375 elsif not Present (Pool_Op_Formal) then | |
6376 Error_Msg_NE | |
6377 ("simple storage pool op missing formal " & | |
6378 Formal_Name & " of type&", Pool_Op, Expected_Type); | |
6379 OK_Formal := False; | |
6380 | |
6381 return; | |
6382 end if; | |
6383 | |
6384 if Etype (Pool_Op_Formal) /= Expected_Type then | |
6385 | |
6386 -- If the pool type was expected for this formal, then | |
6387 -- this will not be considered a candidate operation | |
6388 -- for the simple pool, so we unset OK_Formal so that | |
6389 -- the op and any later formals will be ignored. | |
6390 | |
6391 if Expected_Type = Pool_Type then | |
6392 OK_Formal := False; | |
6393 | |
6394 return; | |
6395 | |
6396 else | |
6397 Error_Msg_NE | |
6398 ("wrong type for formal " & Formal_Name & | |
6399 " of simple storage pool op; expected type&", | |
6400 Pool_Op_Formal, Expected_Type); | |
6401 end if; | |
6402 end if; | |
6403 | |
6404 -- Issue error if formal's mode is not the expected one | |
6405 | |
6406 if Ekind (Pool_Op_Formal) /= Expected_Mode then | |
6407 Error_Msg_N | |
6408 ("wrong mode for formal of simple storage pool op", | |
6409 Pool_Op_Formal); | |
6410 end if; | |
6411 | |
6412 -- Advance to the next formal | |
6413 | |
6414 Next_Formal (Pool_Op_Formal); | |
6415 end Validate_Simple_Pool_Op_Formal; | |
6416 | |
6417 ------------------------------------ | |
6418 -- Validate_Simple_Pool_Operation -- | |
6419 ------------------------------------ | |
6420 | |
6421 procedure Validate_Simple_Pool_Operation | |
6422 (Op_Name : Name_Id) | |
6423 is | |
6424 Op : Entity_Id; | |
6425 Found_Op : Entity_Id := Empty; | |
6426 Formal : Entity_Id; | |
6427 Is_OK : Boolean; | |
6428 | |
6429 begin | |
6430 pragma Assert | |
6431 (Nam_In (Op_Name, Name_Allocate, | |
6432 Name_Deallocate, | |
6433 Name_Storage_Size)); | |
6434 | |
6435 Error_Msg_Name_1 := Op_Name; | |
6436 | |
6437 -- For each homonym declared immediately in the scope | |
6438 -- of the simple storage pool type, determine whether | |
6439 -- the homonym is an operation of the pool type, and, | |
6440 -- if so, check that its profile is as expected for | |
6441 -- a simple pool operation of that name. | |
6442 | |
6443 Op := Get_Name_Entity_Id (Op_Name); | |
6444 while Present (Op) loop | |
6445 if Ekind_In (Op, E_Function, E_Procedure) | |
6446 and then Scope (Op) = Current_Scope | |
6447 then | |
6448 Formal := First_Entity (Op); | |
6449 | |
6450 Is_OK := True; | |
6451 | |
6452 -- The first parameter must be of the pool type | |
6453 -- in order for the operation to qualify. | |
6454 | |
6455 if Op_Name = Name_Storage_Size then | |
6456 Validate_Simple_Pool_Op_Formal | |
6457 (Op, Formal, E_In_Parameter, Pool_Type, | |
6458 "Pool", Is_OK); | |
6459 else | |
6460 Validate_Simple_Pool_Op_Formal | |
6461 (Op, Formal, E_In_Out_Parameter, Pool_Type, | |
6462 "Pool", Is_OK); | |
6463 end if; | |
6464 | |
6465 -- If another operation with this name has already | |
6466 -- been located for the type, then flag an error, | |
6467 -- since we only allow the type to have a single | |
6468 -- such primitive. | |
6469 | |
6470 if Present (Found_Op) and then Is_OK then | |
6471 Error_Msg_NE | |
6472 ("only one % operation allowed for " & | |
6473 "simple storage pool type&", Op, Pool_Type); | |
6474 end if; | |
6475 | |
6476 -- In the case of Allocate and Deallocate, a formal | |
6477 -- of type System.Address is required. | |
6478 | |
6479 if Op_Name = Name_Allocate then | |
6480 Validate_Simple_Pool_Op_Formal | |
6481 (Op, Formal, E_Out_Parameter, | |
6482 Address_Type, "Storage_Address", Is_OK); | |
6483 | |
6484 elsif Op_Name = Name_Deallocate then | |
6485 Validate_Simple_Pool_Op_Formal | |
6486 (Op, Formal, E_In_Parameter, | |
6487 Address_Type, "Storage_Address", Is_OK); | |
6488 end if; | |
6489 | |
6490 -- In the case of Allocate and Deallocate, formals | |
6491 -- of type Storage_Count are required as the third | |
6492 -- and fourth parameters. | |
6493 | |
6494 if Op_Name /= Name_Storage_Size then | |
6495 Validate_Simple_Pool_Op_Formal | |
6496 (Op, Formal, E_In_Parameter, | |
6497 Stg_Cnt_Type, "Size_In_Storage_Units", Is_OK); | |
6498 Validate_Simple_Pool_Op_Formal | |
6499 (Op, Formal, E_In_Parameter, | |
6500 Stg_Cnt_Type, "Alignment", Is_OK); | |
6501 end if; | |
6502 | |
6503 -- If no mismatched formals have been found (Is_OK) | |
6504 -- and no excess formals are present, then this | |
6505 -- operation has been validated, so record it. | |
6506 | |
6507 if not Present (Formal) and then Is_OK then | |
6508 Found_Op := Op; | |
6509 end if; | |
6510 end if; | |
6511 | |
6512 Op := Homonym (Op); | |
6513 end loop; | |
6514 | |
6515 -- There must be a valid Allocate operation for the type, | |
6516 -- so issue an error if none was found. | |
6517 | |
6518 if Op_Name = Name_Allocate | |
6519 and then not Present (Found_Op) | |
6520 then | |
6521 Error_Msg_N ("missing % operation for simple " & | |
6522 "storage pool type", Pool_Type); | |
6523 | |
6524 elsif Present (Found_Op) then | |
6525 | |
6526 -- Simple pool operations can't be abstract | |
6527 | |
6528 if Is_Abstract_Subprogram (Found_Op) then | |
6529 Error_Msg_N | |
6530 ("simple storage pool operation must not be " & | |
6531 "abstract", Found_Op); | |
6532 end if; | |
6533 | |
6534 -- The Storage_Size operation must be a function with | |
6535 -- Storage_Count as its result type. | |
6536 | |
6537 if Op_Name = Name_Storage_Size then | |
6538 if Ekind (Found_Op) = E_Procedure then | |
6539 Error_Msg_N | |
6540 ("% operation must be a function", Found_Op); | |
6541 | |
6542 elsif Etype (Found_Op) /= Stg_Cnt_Type then | |
6543 Error_Msg_NE | |
6544 ("wrong result type for%, expected type&", | |
6545 Found_Op, Stg_Cnt_Type); | |
6546 end if; | |
6547 | |
6548 -- Allocate and Deallocate must be procedures | |
6549 | |
6550 elsif Ekind (Found_Op) = E_Function then | |
6551 Error_Msg_N | |
6552 ("% operation must be a procedure", Found_Op); | |
6553 end if; | |
6554 end if; | |
6555 end Validate_Simple_Pool_Operation; | |
6556 | |
6557 -- Start of processing for Validate_Simple_Pool_Ops | |
6558 | |
6559 begin | |
6560 Validate_Simple_Pool_Operation (Name_Allocate); | |
6561 Validate_Simple_Pool_Operation (Name_Deallocate); | |
6562 Validate_Simple_Pool_Operation (Name_Storage_Size); | |
6563 end Validate_Simple_Pool_Ops; | |
6564 end if; | |
6565 end if; | |
6566 | |
6567 -- Now that all types from which E may depend are frozen, see if the | |
6568 -- size is known at compile time, if it must be unsigned, or if | |
6569 -- strict alignment is required | |
6570 | |
6571 Check_Compile_Time_Size (E); | |
6572 Check_Unsigned_Type (E); | |
6573 | |
6574 if Base_Type (E) = E then | |
6575 Check_Strict_Alignment (E); | |
6576 end if; | |
6577 | |
6578 -- Do not allow a size clause for a type which does not have a size | |
6579 -- that is known at compile time | |
6580 | |
6581 if Has_Size_Clause (E) | |
6582 and then not Size_Known_At_Compile_Time (E) | |
6583 then | |
6584 -- Suppress this message if errors posted on E, even if we are | |
6585 -- in all errors mode, since this is often a junk message | |
6586 | |
6587 if not Error_Posted (E) then | |
6588 Error_Msg_N | |
6589 ("size clause not allowed for variable length type", | |
6590 Size_Clause (E)); | |
6591 end if; | |
6592 end if; | |
6593 | |
6594 -- Now we set/verify the representation information, in particular | |
6595 -- the size and alignment values. This processing is not required for | |
6596 -- generic types, since generic types do not play any part in code | |
6597 -- generation, and so the size and alignment values for such types | |
6598 -- are irrelevant. Ditto for types declared within a generic unit, | |
6599 -- which may have components that depend on generic parameters, and | |
6600 -- that will be recreated in an instance. | |
6601 | |
6602 if Inside_A_Generic then | |
6603 null; | |
6604 | |
6605 -- Otherwise we call the layout procedure | |
6606 | |
6607 else | |
6608 Layout_Type (E); | |
6609 end if; | |
6610 | |
6611 -- If this is an access to subprogram whose designated type is itself | |
6612 -- a subprogram type, the return type of this anonymous subprogram | |
6613 -- type must be decorated as well. | |
6614 | |
6615 if Ekind (E) = E_Anonymous_Access_Subprogram_Type | |
6616 and then Ekind (Designated_Type (E)) = E_Subprogram_Type | |
6617 then | |
6618 Layout_Type (Etype (Designated_Type (E))); | |
6619 end if; | |
6620 | |
6621 -- If the type has a Defaut_Value/Default_Component_Value aspect, | |
6622 -- this is where we analye the expression (after the type is frozen, | |
6623 -- since in the case of Default_Value, we are analyzing with the | |
6624 -- type itself, and we treat Default_Component_Value similarly for | |
6625 -- the sake of uniformity). | |
6626 | |
6627 if Is_First_Subtype (E) and then Has_Default_Aspect (E) then | |
6628 declare | |
6629 Nam : Name_Id; | |
6630 Exp : Node_Id; | |
6631 Typ : Entity_Id; | |
6632 | |
6633 begin | |
6634 if Is_Scalar_Type (E) then | |
6635 Nam := Name_Default_Value; | |
6636 Typ := E; | |
6637 Exp := Default_Aspect_Value (Typ); | |
6638 else | |
6639 Nam := Name_Default_Component_Value; | |
6640 Typ := Component_Type (E); | |
6641 Exp := Default_Aspect_Component_Value (E); | |
6642 end if; | |
6643 | |
6644 Analyze_And_Resolve (Exp, Typ); | |
6645 | |
6646 if Etype (Exp) /= Any_Type then | |
6647 if not Is_OK_Static_Expression (Exp) then | |
6648 Error_Msg_Name_1 := Nam; | |
6649 Flag_Non_Static_Expr | |
6650 ("aspect% requires static expression", Exp); | |
6651 end if; | |
6652 end if; | |
6653 end; | |
6654 end if; | |
6655 | |
6656 -- End of freeze processing for type entities | |
6657 end if; | |
6658 | |
6659 -- Here is where we logically freeze the current entity. If it has a | |
6660 -- freeze node, then this is the point at which the freeze node is | |
6661 -- linked into the result list. | |
6662 | |
6663 if Has_Delayed_Freeze (E) then | |
6664 | |
6665 -- If a freeze node is already allocated, use it, otherwise allocate | |
6666 -- a new one. The preallocation happens in the case of anonymous base | |
6667 -- types, where we preallocate so that we can set First_Subtype_Link. | |
6668 -- Note that we reset the Sloc to the current freeze location. | |
6669 | |
6670 if Present (Freeze_Node (E)) then | |
6671 F_Node := Freeze_Node (E); | |
6672 Set_Sloc (F_Node, Loc); | |
6673 | |
6674 else | |
6675 F_Node := New_Node (N_Freeze_Entity, Loc); | |
6676 Set_Freeze_Node (E, F_Node); | |
6677 Set_Access_Types_To_Process (F_Node, No_Elist); | |
6678 Set_TSS_Elist (F_Node, No_Elist); | |
6679 Set_Actions (F_Node, No_List); | |
6680 end if; | |
6681 | |
6682 Set_Entity (F_Node, E); | |
6683 Add_To_Result (F_Node); | |
6684 | |
6685 -- A final pass over record types with discriminants. If the type | |
6686 -- has an incomplete declaration, there may be constrained access | |
6687 -- subtypes declared elsewhere, which do not depend on the discrimi- | |
6688 -- nants of the type, and which are used as component types (i.e. | |
6689 -- the full view is a recursive type). The designated types of these | |
6690 -- subtypes can only be elaborated after the type itself, and they | |
6691 -- need an itype reference. | |
6692 | |
6693 if Ekind (E) = E_Record_Type and then Has_Discriminants (E) then | |
6694 declare | |
6695 Comp : Entity_Id; | |
6696 IR : Node_Id; | |
6697 Typ : Entity_Id; | |
6698 | |
6699 begin | |
6700 Comp := First_Component (E); | |
6701 while Present (Comp) loop | |
6702 Typ := Etype (Comp); | |
6703 | |
6704 if Ekind (Comp) = E_Component | |
6705 and then Is_Access_Type (Typ) | |
6706 and then Scope (Typ) /= E | |
6707 and then Base_Type (Designated_Type (Typ)) = E | |
6708 and then Is_Itype (Designated_Type (Typ)) | |
6709 then | |
6710 IR := Make_Itype_Reference (Sloc (Comp)); | |
6711 Set_Itype (IR, Designated_Type (Typ)); | |
6712 Append (IR, Result); | |
6713 end if; | |
6714 | |
6715 Next_Component (Comp); | |
6716 end loop; | |
6717 end; | |
6718 end if; | |
6719 end if; | |
6720 | |
6721 -- When a type is frozen, the first subtype of the type is frozen as | |
6722 -- well (RM 13.14(15)). This has to be done after freezing the type, | |
6723 -- since obviously the first subtype depends on its own base type. | |
6724 | |
6725 if Is_Type (E) then | |
6726 Freeze_And_Append (First_Subtype (E), N, Result); | |
6727 | |
6728 -- If we just froze a tagged non-class wide record, then freeze the | |
6729 -- corresponding class-wide type. This must be done after the tagged | |
6730 -- type itself is frozen, because the class-wide type refers to the | |
6731 -- tagged type which generates the class. | |
6732 | |
6733 if Is_Tagged_Type (E) | |
6734 and then not Is_Class_Wide_Type (E) | |
6735 and then Present (Class_Wide_Type (E)) | |
6736 then | |
6737 Freeze_And_Append (Class_Wide_Type (E), N, Result); | |
6738 end if; | |
6739 end if; | |
6740 | |
6741 Check_Debug_Info_Needed (E); | |
6742 | |
6743 -- Special handling for subprograms | |
6744 | |
6745 if Is_Subprogram (E) then | |
6746 | |
6747 -- If subprogram has address clause then reset Is_Public flag, since | |
6748 -- we do not want the backend to generate external references. | |
6749 | |
6750 if Present (Address_Clause (E)) | |
6751 and then not Is_Library_Level_Entity (E) | |
6752 then | |
6753 Set_Is_Public (E, False); | |
6754 end if; | |
6755 end if; | |
6756 | |
6757 <<Leave>> | |
6758 Restore_Ghost_Mode (Saved_GM); | |
6759 | |
6760 return Result; | |
6761 end Freeze_Entity; | |
6762 | |
6763 ----------------------------- | |
6764 -- Freeze_Enumeration_Type -- | |
6765 ----------------------------- | |
6766 | |
6767 procedure Freeze_Enumeration_Type (Typ : Entity_Id) is | |
6768 begin | |
6769 -- By default, if no size clause is present, an enumeration type with | |
6770 -- Convention C is assumed to interface to a C enum, and has integer | |
6771 -- size. This applies to types. For subtypes, verify that its base | |
6772 -- type has no size clause either. Treat other foreign conventions | |
6773 -- in the same way, and also make sure alignment is set right. | |
6774 | |
6775 if Has_Foreign_Convention (Typ) | |
6776 and then not Has_Size_Clause (Typ) | |
6777 and then not Has_Size_Clause (Base_Type (Typ)) | |
6778 and then Esize (Typ) < Standard_Integer_Size | |
6779 | |
6780 -- Don't do this if Short_Enums on target | |
6781 | |
6782 and then not Target_Short_Enums | |
6783 then | |
6784 Init_Esize (Typ, Standard_Integer_Size); | |
6785 Set_Alignment (Typ, Alignment (Standard_Integer)); | |
6786 | |
6787 -- Normal Ada case or size clause present or not Long_C_Enums on target | |
6788 | |
6789 else | |
6790 -- If the enumeration type interfaces to C, and it has a size clause | |
6791 -- that specifies less than int size, it warrants a warning. The | |
6792 -- user may intend the C type to be an enum or a char, so this is | |
6793 -- not by itself an error that the Ada compiler can detect, but it | |
6794 -- it is a worth a heads-up. For Boolean and Character types we | |
6795 -- assume that the programmer has the proper C type in mind. | |
6796 | |
6797 if Convention (Typ) = Convention_C | |
6798 and then Has_Size_Clause (Typ) | |
6799 and then Esize (Typ) /= Esize (Standard_Integer) | |
6800 and then not Is_Boolean_Type (Typ) | |
6801 and then not Is_Character_Type (Typ) | |
6802 | |
6803 -- Don't do this if Short_Enums on target | |
6804 | |
6805 and then not Target_Short_Enums | |
6806 then | |
6807 Error_Msg_N | |
6808 ("C enum types have the size of a C int??", Size_Clause (Typ)); | |
6809 end if; | |
6810 | |
6811 Adjust_Esize_For_Alignment (Typ); | |
6812 end if; | |
6813 end Freeze_Enumeration_Type; | |
6814 | |
6815 ----------------------- | |
6816 -- Freeze_Expression -- | |
6817 ----------------------- | |
6818 | |
6819 procedure Freeze_Expression (N : Node_Id) is | |
6820 In_Spec_Exp : constant Boolean := In_Spec_Expression; | |
6821 Typ : Entity_Id; | |
6822 Nam : Entity_Id; | |
6823 Desig_Typ : Entity_Id; | |
6824 P : Node_Id; | |
6825 Parent_P : Node_Id; | |
6826 | |
6827 Freeze_Outside : Boolean := False; | |
6828 -- This flag is set true if the entity must be frozen outside the | |
6829 -- current subprogram. This happens in the case of expander generated | |
6830 -- subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do | |
6831 -- not freeze all entities like other bodies, but which nevertheless | |
6832 -- may reference entities that have to be frozen before the body and | |
6833 -- obviously cannot be frozen inside the body. | |
6834 | |
6835 function Find_Aggregate_Component_Desig_Type return Entity_Id; | |
6836 -- If the expression is an array aggregate, the type of the component | |
6837 -- expressions is also frozen. If the component type is an access type | |
6838 -- and the expressions include allocators, the designed type is frozen | |
6839 -- as well. | |
6840 | |
6841 function In_Expanded_Body (N : Node_Id) return Boolean; | |
6842 -- Given an N_Handled_Sequence_Of_Statements node N, determines whether | |
6843 -- it is the handled statement sequence of an expander-generated | |
6844 -- subprogram (init proc, stream subprogram, or renaming as body). | |
6845 -- If so, this is not a freezing context. | |
6846 | |
6847 ----------------------------------------- | |
6848 -- Find_Aggregate_Component_Desig_Type -- | |
6849 ----------------------------------------- | |
6850 | |
6851 function Find_Aggregate_Component_Desig_Type return Entity_Id is | |
6852 Assoc : Node_Id; | |
6853 Exp : Node_Id; | |
6854 | |
6855 begin | |
6856 if Present (Expressions (N)) then | |
6857 Exp := First (Expressions (N)); | |
6858 while Present (Exp) loop | |
6859 if Nkind (Exp) = N_Allocator then | |
6860 return Designated_Type (Component_Type (Etype (N))); | |
6861 end if; | |
6862 | |
6863 Next (Exp); | |
6864 end loop; | |
6865 end if; | |
6866 | |
6867 if Present (Component_Associations (N)) then | |
6868 Assoc := First (Component_Associations (N)); | |
6869 while Present (Assoc) loop | |
6870 if Nkind (Expression (Assoc)) = N_Allocator then | |
6871 return Designated_Type (Component_Type (Etype (N))); | |
6872 end if; | |
6873 | |
6874 Next (Assoc); | |
6875 end loop; | |
6876 end if; | |
6877 | |
6878 return Empty; | |
6879 end Find_Aggregate_Component_Desig_Type; | |
6880 | |
6881 ---------------------- | |
6882 -- In_Expanded_Body -- | |
6883 ---------------------- | |
6884 | |
6885 function In_Expanded_Body (N : Node_Id) return Boolean is | |
6886 P : Node_Id; | |
6887 Id : Entity_Id; | |
6888 | |
6889 begin | |
6890 if Nkind (N) = N_Subprogram_Body then | |
6891 P := N; | |
6892 else | |
6893 P := Parent (N); | |
6894 end if; | |
6895 | |
6896 if Nkind (P) /= N_Subprogram_Body then | |
6897 return False; | |
6898 | |
6899 else | |
6900 Id := Defining_Unit_Name (Specification (P)); | |
6901 | |
6902 -- The following are expander-created bodies, or bodies that | |
6903 -- are not freeze points. | |
6904 | |
6905 if Nkind (Id) = N_Defining_Identifier | |
6906 and then (Is_Init_Proc (Id) | |
6907 or else Is_TSS (Id, TSS_Stream_Input) | |
6908 or else Is_TSS (Id, TSS_Stream_Output) | |
6909 or else Is_TSS (Id, TSS_Stream_Read) | |
6910 or else Is_TSS (Id, TSS_Stream_Write) | |
6911 or else Nkind_In (Original_Node (P), | |
6912 N_Subprogram_Renaming_Declaration, | |
6913 N_Expression_Function)) | |
6914 then | |
6915 return True; | |
6916 else | |
6917 return False; | |
6918 end if; | |
6919 end if; | |
6920 end In_Expanded_Body; | |
6921 | |
6922 -- Start of processing for Freeze_Expression | |
6923 | |
6924 begin | |
6925 -- Immediate return if freezing is inhibited. This flag is set by the | |
6926 -- analyzer to stop freezing on generated expressions that would cause | |
6927 -- freezing if they were in the source program, but which are not | |
6928 -- supposed to freeze, since they are created. | |
6929 | |
6930 if Must_Not_Freeze (N) then | |
6931 return; | |
6932 end if; | |
6933 | |
6934 -- If expression is non-static, then it does not freeze in a default | |
6935 -- expression, see section "Handling of Default Expressions" in the | |
6936 -- spec of package Sem for further details. Note that we have to make | |
6937 -- sure that we actually have a real expression (if we have a subtype | |
6938 -- indication, we can't test Is_OK_Static_Expression). However, we | |
6939 -- exclude the case of the prefix of an attribute of a static scalar | |
6940 -- subtype from this early return, because static subtype attributes | |
6941 -- should always cause freezing, even in default expressions, but | |
6942 -- the attribute may not have been marked as static yet (because in | |
6943 -- Resolve_Attribute, the call to Eval_Attribute follows the call of | |
6944 -- Freeze_Expression on the prefix). | |
6945 | |
6946 if In_Spec_Exp | |
6947 and then Nkind (N) in N_Subexpr | |
6948 and then not Is_OK_Static_Expression (N) | |
6949 and then (Nkind (Parent (N)) /= N_Attribute_Reference | |
6950 or else not (Is_Entity_Name (N) | |
6951 and then Is_Type (Entity (N)) | |
6952 and then Is_OK_Static_Subtype (Entity (N)))) | |
6953 then | |
6954 return; | |
6955 end if; | |
6956 | |
6957 -- Freeze type of expression if not frozen already | |
6958 | |
6959 Typ := Empty; | |
6960 | |
6961 if Nkind (N) in N_Has_Etype then | |
6962 if not Is_Frozen (Etype (N)) then | |
6963 Typ := Etype (N); | |
6964 | |
6965 -- Base type may be an derived numeric type that is frozen at | |
6966 -- the point of declaration, but first_subtype is still unfrozen. | |
6967 | |
6968 elsif not Is_Frozen (First_Subtype (Etype (N))) then | |
6969 Typ := First_Subtype (Etype (N)); | |
6970 end if; | |
6971 end if; | |
6972 | |
6973 -- For entity name, freeze entity if not frozen already. A special | |
6974 -- exception occurs for an identifier that did not come from source. | |
6975 -- We don't let such identifiers freeze a non-internal entity, i.e. | |
6976 -- an entity that did come from source, since such an identifier was | |
6977 -- generated by the expander, and cannot have any semantic effect on | |
6978 -- the freezing semantics. For example, this stops the parameter of | |
6979 -- an initialization procedure from freezing the variable. | |
6980 | |
6981 if Is_Entity_Name (N) | |
6982 and then not Is_Frozen (Entity (N)) | |
6983 and then (Nkind (N) /= N_Identifier | |
6984 or else Comes_From_Source (N) | |
6985 or else not Comes_From_Source (Entity (N))) | |
6986 then | |
6987 Nam := Entity (N); | |
6988 | |
6989 if Present (Nam) and then Ekind (Nam) = E_Function then | |
6990 Check_Expression_Function (N, Nam); | |
6991 end if; | |
6992 | |
6993 else | |
6994 Nam := Empty; | |
6995 end if; | |
6996 | |
6997 -- For an allocator freeze designated type if not frozen already | |
6998 | |
6999 -- For an aggregate whose component type is an access type, freeze the | |
7000 -- designated type now, so that its freeze does not appear within the | |
7001 -- loop that might be created in the expansion of the aggregate. If the | |
7002 -- designated type is a private type without full view, the expression | |
7003 -- cannot contain an allocator, so the type is not frozen. | |
7004 | |
7005 -- For a function, we freeze the entity when the subprogram declaration | |
7006 -- is frozen, but a function call may appear in an initialization proc. | |
7007 -- before the declaration is frozen. We need to generate the extra | |
7008 -- formals, if any, to ensure that the expansion of the call includes | |
7009 -- the proper actuals. This only applies to Ada subprograms, not to | |
7010 -- imported ones. | |
7011 | |
7012 Desig_Typ := Empty; | |
7013 | |
7014 case Nkind (N) is | |
7015 when N_Allocator => | |
7016 Desig_Typ := Designated_Type (Etype (N)); | |
7017 | |
7018 when N_Aggregate => | |
7019 if Is_Array_Type (Etype (N)) | |
7020 and then Is_Access_Type (Component_Type (Etype (N))) | |
7021 then | |
7022 | |
7023 -- Check whether aggregate includes allocators. | |
7024 | |
7025 Desig_Typ := Find_Aggregate_Component_Desig_Type; | |
7026 end if; | |
7027 | |
7028 when N_Indexed_Component | |
7029 | N_Selected_Component | |
7030 | N_Slice | |
7031 => | |
7032 if Is_Access_Type (Etype (Prefix (N))) then | |
7033 Desig_Typ := Designated_Type (Etype (Prefix (N))); | |
7034 end if; | |
7035 | |
7036 when N_Identifier => | |
7037 if Present (Nam) | |
7038 and then Ekind (Nam) = E_Function | |
7039 and then Nkind (Parent (N)) = N_Function_Call | |
7040 and then Convention (Nam) = Convention_Ada | |
7041 then | |
7042 Create_Extra_Formals (Nam); | |
7043 end if; | |
7044 | |
7045 when others => | |
7046 null; | |
7047 end case; | |
7048 | |
7049 if Desig_Typ /= Empty | |
7050 and then (Is_Frozen (Desig_Typ) | |
7051 or else (not Is_Fully_Defined (Desig_Typ))) | |
7052 then | |
7053 Desig_Typ := Empty; | |
7054 end if; | |
7055 | |
7056 -- All done if nothing needs freezing | |
7057 | |
7058 if No (Typ) | |
7059 and then No (Nam) | |
7060 and then No (Desig_Typ) | |
7061 then | |
7062 return; | |
7063 end if; | |
7064 | |
7065 -- Examine the enclosing context by climbing the parent chain. The | |
7066 -- traversal serves two purposes - to detect scenarios where freezeing | |
7067 -- is not needed and to find the proper insertion point for the freeze | |
7068 -- nodes. Although somewhat similar to Insert_Actions, this traversal | |
7069 -- is freezing semantics-sensitive. Inserting freeze nodes blindly in | |
7070 -- the tree may result in types being frozen too early. | |
7071 | |
7072 P := N; | |
7073 loop | |
7074 Parent_P := Parent (P); | |
7075 | |
7076 -- If we don't have a parent, then we are not in a well-formed tree. | |
7077 -- This is an unusual case, but there are some legitimate situations | |
7078 -- in which this occurs, notably when the expressions in the range of | |
7079 -- a type declaration are resolved. We simply ignore the freeze | |
7080 -- request in this case. Is this right ??? | |
7081 | |
7082 if No (Parent_P) then | |
7083 return; | |
7084 end if; | |
7085 | |
7086 -- See if we have got to an appropriate point in the tree | |
7087 | |
7088 case Nkind (Parent_P) is | |
7089 | |
7090 -- A special test for the exception of (RM 13.14(8)) for the case | |
7091 -- of per-object expressions (RM 3.8(18)) occurring in component | |
7092 -- definition or a discrete subtype definition. Note that we test | |
7093 -- for a component declaration which includes both cases we are | |
7094 -- interested in, and furthermore the tree does not have explicit | |
7095 -- nodes for either of these two constructs. | |
7096 | |
7097 when N_Component_Declaration => | |
7098 | |
7099 -- The case we want to test for here is an identifier that is | |
7100 -- a per-object expression, this is either a discriminant that | |
7101 -- appears in a context other than the component declaration | |
7102 -- or it is a reference to the type of the enclosing construct. | |
7103 | |
7104 -- For either of these cases, we skip the freezing | |
7105 | |
7106 if not In_Spec_Expression | |
7107 and then Nkind (N) = N_Identifier | |
7108 and then (Present (Entity (N))) | |
7109 then | |
7110 -- We recognize the discriminant case by just looking for | |
7111 -- a reference to a discriminant. It can only be one for | |
7112 -- the enclosing construct. Skip freezing in this case. | |
7113 | |
7114 if Ekind (Entity (N)) = E_Discriminant then | |
7115 return; | |
7116 | |
7117 -- For the case of a reference to the enclosing record, | |
7118 -- (or task or protected type), we look for a type that | |
7119 -- matches the current scope. | |
7120 | |
7121 elsif Entity (N) = Current_Scope then | |
7122 return; | |
7123 end if; | |
7124 end if; | |
7125 | |
7126 -- If we have an enumeration literal that appears as the choice in | |
7127 -- the aggregate of an enumeration representation clause, then | |
7128 -- freezing does not occur (RM 13.14(10)). | |
7129 | |
7130 when N_Enumeration_Representation_Clause => | |
7131 | |
7132 -- The case we are looking for is an enumeration literal | |
7133 | |
7134 if (Nkind (N) = N_Identifier or Nkind (N) = N_Character_Literal) | |
7135 and then Is_Enumeration_Type (Etype (N)) | |
7136 then | |
7137 -- If enumeration literal appears directly as the choice, | |
7138 -- do not freeze (this is the normal non-overloaded case) | |
7139 | |
7140 if Nkind (Parent (N)) = N_Component_Association | |
7141 and then First (Choices (Parent (N))) = N | |
7142 then | |
7143 return; | |
7144 | |
7145 -- If enumeration literal appears as the name of function | |
7146 -- which is the choice, then also do not freeze. This | |
7147 -- happens in the overloaded literal case, where the | |
7148 -- enumeration literal is temporarily changed to a function | |
7149 -- call for overloading analysis purposes. | |
7150 | |
7151 elsif Nkind (Parent (N)) = N_Function_Call | |
7152 and then | |
7153 Nkind (Parent (Parent (N))) = N_Component_Association | |
7154 and then | |
7155 First (Choices (Parent (Parent (N)))) = Parent (N) | |
7156 then | |
7157 return; | |
7158 end if; | |
7159 end if; | |
7160 | |
7161 -- Normally if the parent is a handled sequence of statements, | |
7162 -- then the current node must be a statement, and that is an | |
7163 -- appropriate place to insert a freeze node. | |
7164 | |
7165 when N_Handled_Sequence_Of_Statements => | |
7166 | |
7167 -- An exception occurs when the sequence of statements is for | |
7168 -- an expander generated body that did not do the usual freeze | |
7169 -- all operation. In this case we usually want to freeze | |
7170 -- outside this body, not inside it, and we skip past the | |
7171 -- subprogram body that we are inside. | |
7172 | |
7173 if In_Expanded_Body (Parent_P) then | |
7174 declare | |
7175 Subp : constant Node_Id := Parent (Parent_P); | |
7176 Spec : Entity_Id; | |
7177 | |
7178 begin | |
7179 -- Freeze the entity only when it is declared inside the | |
7180 -- body of the expander generated procedure. This case | |
7181 -- is recognized by the scope of the entity or its type, | |
7182 -- which is either the spec for some enclosing body, or | |
7183 -- (in the case of init_procs, for which there are no | |
7184 -- separate specs) the current scope. | |
7185 | |
7186 if Nkind (Subp) = N_Subprogram_Body then | |
7187 Spec := Corresponding_Spec (Subp); | |
7188 | |
7189 if (Present (Typ) and then Scope (Typ) = Spec) | |
7190 or else | |
7191 (Present (Nam) and then Scope (Nam) = Spec) | |
7192 then | |
7193 exit; | |
7194 | |
7195 elsif Present (Typ) | |
7196 and then Scope (Typ) = Current_Scope | |
7197 and then Defining_Entity (Subp) = Current_Scope | |
7198 then | |
7199 exit; | |
7200 end if; | |
7201 end if; | |
7202 | |
7203 -- An expression function may act as a completion of | |
7204 -- a function declaration. As such, it can reference | |
7205 -- entities declared between the two views: | |
7206 | |
7207 -- Hidden []; -- 1 | |
7208 -- function F return ...; | |
7209 -- private | |
7210 -- function Hidden return ...; | |
7211 -- function F return ... is (Hidden); -- 2 | |
7212 | |
7213 -- Refering to the example above, freezing the expression | |
7214 -- of F (2) would place Hidden's freeze node (1) in the | |
7215 -- wrong place. Avoid explicit freezing and let the usual | |
7216 -- scenarios do the job - for example, reaching the end | |
7217 -- of the private declarations, or a call to F. | |
7218 | |
7219 if Nkind (Original_Node (Subp)) = | |
7220 N_Expression_Function | |
7221 then | |
7222 null; | |
7223 | |
7224 -- Freeze outside the body | |
7225 | |
7226 else | |
7227 Parent_P := Parent (Parent_P); | |
7228 Freeze_Outside := True; | |
7229 end if; | |
7230 end; | |
7231 | |
7232 -- Here if normal case where we are in handled statement | |
7233 -- sequence and want to do the insertion right there. | |
7234 | |
7235 else | |
7236 exit; | |
7237 end if; | |
7238 | |
7239 -- If parent is a body or a spec or a block, then the current node | |
7240 -- is a statement or declaration and we can insert the freeze node | |
7241 -- before it. | |
7242 | |
7243 when N_Block_Statement | |
7244 | N_Entry_Body | |
7245 | N_Package_Body | |
7246 | N_Package_Specification | |
7247 | N_Protected_Body | |
7248 | N_Subprogram_Body | |
7249 | N_Task_Body | |
7250 => | |
7251 exit; | |
7252 | |
7253 -- The expander is allowed to define types in any statements list, | |
7254 -- so any of the following parent nodes also mark a freezing point | |
7255 -- if the actual node is in a list of statements or declarations. | |
7256 | |
7257 when N_Abortable_Part | |
7258 | N_Accept_Alternative | |
7259 | N_And_Then | |
7260 | N_Case_Statement_Alternative | |
7261 | N_Compilation_Unit_Aux | |
7262 | N_Conditional_Entry_Call | |
7263 | N_Delay_Alternative | |
7264 | N_Elsif_Part | |
7265 | N_Entry_Call_Alternative | |
7266 | N_Exception_Handler | |
7267 | N_Extended_Return_Statement | |
7268 | N_Freeze_Entity | |
7269 | N_If_Statement | |
7270 | N_Or_Else | |
7271 | N_Selective_Accept | |
7272 | N_Triggering_Alternative | |
7273 => | |
7274 exit when Is_List_Member (P); | |
7275 | |
7276 -- Freeze nodes produced by an expression coming from the Actions | |
7277 -- list of a N_Expression_With_Actions node must remain within the | |
7278 -- Actions list. Inserting the freeze nodes further up the tree | |
7279 -- may lead to use before declaration issues in the case of array | |
7280 -- types. | |
7281 | |
7282 when N_Expression_With_Actions => | |
7283 if Is_List_Member (P) | |
7284 and then List_Containing (P) = Actions (Parent_P) | |
7285 then | |
7286 exit; | |
7287 end if; | |
7288 | |
7289 -- Note: N_Loop_Statement is a special case. A type that appears | |
7290 -- in the source can never be frozen in a loop (this occurs only | |
7291 -- because of a loop expanded by the expander), so we keep on | |
7292 -- going. Otherwise we terminate the search. Same is true of any | |
7293 -- entity which comes from source. (if they have predefined type, | |
7294 -- that type does not appear to come from source, but the entity | |
7295 -- should not be frozen here). | |
7296 | |
7297 when N_Loop_Statement => | |
7298 exit when not Comes_From_Source (Etype (N)) | |
7299 and then (No (Nam) or else not Comes_From_Source (Nam)); | |
7300 | |
7301 -- For all other cases, keep looking at parents | |
7302 | |
7303 when others => | |
7304 null; | |
7305 end case; | |
7306 | |
7307 -- We fall through the case if we did not yet find the proper | |
7308 -- place in the free for inserting the freeze node, so climb. | |
7309 | |
7310 P := Parent_P; | |
7311 end loop; | |
7312 | |
7313 -- If the expression appears in a record or an initialization procedure, | |
7314 -- the freeze nodes are collected and attached to the current scope, to | |
7315 -- be inserted and analyzed on exit from the scope, to insure that | |
7316 -- generated entities appear in the correct scope. If the expression is | |
7317 -- a default for a discriminant specification, the scope is still void. | |
7318 -- The expression can also appear in the discriminant part of a private | |
7319 -- or concurrent type. | |
7320 | |
7321 -- If the expression appears in a constrained subcomponent of an | |
7322 -- enclosing record declaration, the freeze nodes must be attached to | |
7323 -- the outer record type so they can eventually be placed in the | |
7324 -- enclosing declaration list. | |
7325 | |
7326 -- The other case requiring this special handling is if we are in a | |
7327 -- default expression, since in that case we are about to freeze a | |
7328 -- static type, and the freeze scope needs to be the outer scope, not | |
7329 -- the scope of the subprogram with the default parameter. | |
7330 | |
7331 -- For default expressions and other spec expressions in generic units, | |
7332 -- the Move_Freeze_Nodes mechanism (see sem_ch12.adb) takes care of | |
7333 -- placing them at the proper place, after the generic unit. | |
7334 | |
7335 if (In_Spec_Exp and not Inside_A_Generic) | |
7336 or else Freeze_Outside | |
7337 or else (Is_Type (Current_Scope) | |
7338 and then (not Is_Concurrent_Type (Current_Scope) | |
7339 or else not Has_Completion (Current_Scope))) | |
7340 or else Ekind (Current_Scope) = E_Void | |
7341 then | |
7342 declare | |
7343 N : constant Node_Id := Current_Scope; | |
7344 Freeze_Nodes : List_Id := No_List; | |
7345 Pos : Int := Scope_Stack.Last; | |
7346 | |
7347 begin | |
7348 if Present (Desig_Typ) then | |
7349 Freeze_And_Append (Desig_Typ, N, Freeze_Nodes); | |
7350 end if; | |
7351 | |
7352 if Present (Typ) then | |
7353 Freeze_And_Append (Typ, N, Freeze_Nodes); | |
7354 end if; | |
7355 | |
7356 if Present (Nam) then | |
7357 Freeze_And_Append (Nam, N, Freeze_Nodes); | |
7358 end if; | |
7359 | |
7360 -- The current scope may be that of a constrained component of | |
7361 -- an enclosing record declaration, or of a loop of an enclosing | |
7362 -- quantified expression, which is above the current scope in the | |
7363 -- scope stack. Indeed in the context of a quantified expression, | |
7364 -- a scope is created and pushed above the current scope in order | |
7365 -- to emulate the loop-like behavior of the quantified expression. | |
7366 -- If the expression is within a top-level pragma, as for a pre- | |
7367 -- condition on a library-level subprogram, nothing to do. | |
7368 | |
7369 if not Is_Compilation_Unit (Current_Scope) | |
7370 and then (Is_Record_Type (Scope (Current_Scope)) | |
7371 or else Nkind (Parent (Current_Scope)) = | |
7372 N_Quantified_Expression) | |
7373 then | |
7374 Pos := Pos - 1; | |
7375 end if; | |
7376 | |
7377 if Is_Non_Empty_List (Freeze_Nodes) then | |
7378 if No (Scope_Stack.Table (Pos).Pending_Freeze_Actions) then | |
7379 Scope_Stack.Table (Pos).Pending_Freeze_Actions := | |
7380 Freeze_Nodes; | |
7381 else | |
7382 Append_List (Freeze_Nodes, | |
7383 Scope_Stack.Table (Pos).Pending_Freeze_Actions); | |
7384 end if; | |
7385 end if; | |
7386 end; | |
7387 | |
7388 return; | |
7389 end if; | |
7390 | |
7391 -- Now we have the right place to do the freezing. First, a special | |
7392 -- adjustment, if we are in spec-expression analysis mode, these freeze | |
7393 -- actions must not be thrown away (normally all inserted actions are | |
7394 -- thrown away in this mode. However, the freeze actions are from static | |
7395 -- expressions and one of the important reasons we are doing this | |
7396 -- special analysis is to get these freeze actions. Therefore we turn | |
7397 -- off the In_Spec_Expression mode to propagate these freeze actions. | |
7398 -- This also means they get properly analyzed and expanded. | |
7399 | |
7400 In_Spec_Expression := False; | |
7401 | |
7402 -- Freeze the designated type of an allocator (RM 13.14(13)) | |
7403 | |
7404 if Present (Desig_Typ) then | |
7405 Freeze_Before (P, Desig_Typ); | |
7406 end if; | |
7407 | |
7408 -- Freeze type of expression (RM 13.14(10)). Note that we took care of | |
7409 -- the enumeration representation clause exception in the loop above. | |
7410 | |
7411 if Present (Typ) then | |
7412 Freeze_Before (P, Typ); | |
7413 end if; | |
7414 | |
7415 -- Freeze name if one is present (RM 13.14(11)) | |
7416 | |
7417 if Present (Nam) then | |
7418 Freeze_Before (P, Nam); | |
7419 end if; | |
7420 | |
7421 -- Restore In_Spec_Expression flag | |
7422 | |
7423 In_Spec_Expression := In_Spec_Exp; | |
7424 end Freeze_Expression; | |
7425 | |
7426 ----------------------------- | |
7427 -- Freeze_Fixed_Point_Type -- | |
7428 ----------------------------- | |
7429 | |
7430 -- Certain fixed-point types and subtypes, including implicit base types | |
7431 -- and declared first subtypes, have not yet set up a range. This is | |
7432 -- because the range cannot be set until the Small and Size values are | |
7433 -- known, and these are not known till the type is frozen. | |
7434 | |
7435 -- To signal this case, Scalar_Range contains an unanalyzed syntactic range | |
7436 -- whose bounds are unanalyzed real literals. This routine will recognize | |
7437 -- this case, and transform this range node into a properly typed range | |
7438 -- with properly analyzed and resolved values. | |
7439 | |
7440 procedure Freeze_Fixed_Point_Type (Typ : Entity_Id) is | |
7441 Rng : constant Node_Id := Scalar_Range (Typ); | |
7442 Lo : constant Node_Id := Low_Bound (Rng); | |
7443 Hi : constant Node_Id := High_Bound (Rng); | |
7444 Btyp : constant Entity_Id := Base_Type (Typ); | |
7445 Brng : constant Node_Id := Scalar_Range (Btyp); | |
7446 BLo : constant Node_Id := Low_Bound (Brng); | |
7447 BHi : constant Node_Id := High_Bound (Brng); | |
7448 Small : constant Ureal := Small_Value (Typ); | |
7449 Loval : Ureal; | |
7450 Hival : Ureal; | |
7451 Atype : Entity_Id; | |
7452 | |
7453 Orig_Lo : Ureal; | |
7454 Orig_Hi : Ureal; | |
7455 -- Save original bounds (for shaving tests) | |
7456 | |
7457 Actual_Size : Nat; | |
7458 -- Actual size chosen | |
7459 | |
7460 function Fsize (Lov, Hiv : Ureal) return Nat; | |
7461 -- Returns size of type with given bounds. Also leaves these | |
7462 -- bounds set as the current bounds of the Typ. | |
7463 | |
7464 ----------- | |
7465 -- Fsize -- | |
7466 ----------- | |
7467 | |
7468 function Fsize (Lov, Hiv : Ureal) return Nat is | |
7469 begin | |
7470 Set_Realval (Lo, Lov); | |
7471 Set_Realval (Hi, Hiv); | |
7472 return Minimum_Size (Typ); | |
7473 end Fsize; | |
7474 | |
7475 -- Start of processing for Freeze_Fixed_Point_Type | |
7476 | |
7477 begin | |
7478 -- If Esize of a subtype has not previously been set, set it now | |
7479 | |
7480 if Unknown_Esize (Typ) then | |
7481 Atype := Ancestor_Subtype (Typ); | |
7482 | |
7483 if Present (Atype) then | |
7484 Set_Esize (Typ, Esize (Atype)); | |
7485 else | |
7486 Set_Esize (Typ, Esize (Base_Type (Typ))); | |
7487 end if; | |
7488 end if; | |
7489 | |
7490 -- Immediate return if the range is already analyzed. This means that | |
7491 -- the range is already set, and does not need to be computed by this | |
7492 -- routine. | |
7493 | |
7494 if Analyzed (Rng) then | |
7495 return; | |
7496 end if; | |
7497 | |
7498 -- Immediate return if either of the bounds raises Constraint_Error | |
7499 | |
7500 if Raises_Constraint_Error (Lo) | |
7501 or else Raises_Constraint_Error (Hi) | |
7502 then | |
7503 return; | |
7504 end if; | |
7505 | |
7506 Loval := Realval (Lo); | |
7507 Hival := Realval (Hi); | |
7508 | |
7509 Orig_Lo := Loval; | |
7510 Orig_Hi := Hival; | |
7511 | |
7512 -- Ordinary fixed-point case | |
7513 | |
7514 if Is_Ordinary_Fixed_Point_Type (Typ) then | |
7515 | |
7516 -- For the ordinary fixed-point case, we are allowed to fudge the | |
7517 -- end-points up or down by small. Generally we prefer to fudge up, | |
7518 -- i.e. widen the bounds for non-model numbers so that the end points | |
7519 -- are included. However there are cases in which this cannot be | |
7520 -- done, and indeed cases in which we may need to narrow the bounds. | |
7521 -- The following circuit makes the decision. | |
7522 | |
7523 -- Note: our terminology here is that Incl_EP means that the bounds | |
7524 -- are widened by Small if necessary to include the end points, and | |
7525 -- Excl_EP means that the bounds are narrowed by Small to exclude the | |
7526 -- end-points if this reduces the size. | |
7527 | |
7528 -- Note that in the Incl case, all we care about is including the | |
7529 -- end-points. In the Excl case, we want to narrow the bounds as | |
7530 -- much as permitted by the RM, to give the smallest possible size. | |
7531 | |
7532 Fudge : declare | |
7533 Loval_Incl_EP : Ureal; | |
7534 Hival_Incl_EP : Ureal; | |
7535 | |
7536 Loval_Excl_EP : Ureal; | |
7537 Hival_Excl_EP : Ureal; | |
7538 | |
7539 Size_Incl_EP : Nat; | |
7540 Size_Excl_EP : Nat; | |
7541 | |
7542 Model_Num : Ureal; | |
7543 First_Subt : Entity_Id; | |
7544 Actual_Lo : Ureal; | |
7545 Actual_Hi : Ureal; | |
7546 | |
7547 begin | |
7548 -- First step. Base types are required to be symmetrical. Right | |
7549 -- now, the base type range is a copy of the first subtype range. | |
7550 -- This will be corrected before we are done, but right away we | |
7551 -- need to deal with the case where both bounds are non-negative. | |
7552 -- In this case, we set the low bound to the negative of the high | |
7553 -- bound, to make sure that the size is computed to include the | |
7554 -- required sign. Note that we do not need to worry about the | |
7555 -- case of both bounds negative, because the sign will be dealt | |
7556 -- with anyway. Furthermore we can't just go making such a bound | |
7557 -- symmetrical, since in a twos-complement system, there is an | |
7558 -- extra negative value which could not be accommodated on the | |
7559 -- positive side. | |
7560 | |
7561 if Typ = Btyp | |
7562 and then not UR_Is_Negative (Loval) | |
7563 and then Hival > Loval | |
7564 then | |
7565 Loval := -Hival; | |
7566 Set_Realval (Lo, Loval); | |
7567 end if; | |
7568 | |
7569 -- Compute the fudged bounds. If the number is a model number, | |
7570 -- then we do nothing to include it, but we are allowed to backoff | |
7571 -- to the next adjacent model number when we exclude it. If it is | |
7572 -- not a model number then we straddle the two values with the | |
7573 -- model numbers on either side. | |
7574 | |
7575 Model_Num := UR_Trunc (Loval / Small) * Small; | |
7576 | |
7577 if Loval = Model_Num then | |
7578 Loval_Incl_EP := Model_Num; | |
7579 else | |
7580 Loval_Incl_EP := Model_Num - Small; | |
7581 end if; | |
7582 | |
7583 -- The low value excluding the end point is Small greater, but | |
7584 -- we do not do this exclusion if the low value is positive, | |
7585 -- since it can't help the size and could actually hurt by | |
7586 -- crossing the high bound. | |
7587 | |
7588 if UR_Is_Negative (Loval_Incl_EP) then | |
7589 Loval_Excl_EP := Loval_Incl_EP + Small; | |
7590 | |
7591 -- If the value went from negative to zero, then we have the | |
7592 -- case where Loval_Incl_EP is the model number just below | |
7593 -- zero, so we want to stick to the negative value for the | |
7594 -- base type to maintain the condition that the size will | |
7595 -- include signed values. | |
7596 | |
7597 if Typ = Btyp | |
7598 and then UR_Is_Zero (Loval_Excl_EP) | |
7599 then | |
7600 Loval_Excl_EP := Loval_Incl_EP; | |
7601 end if; | |
7602 | |
7603 else | |
7604 Loval_Excl_EP := Loval_Incl_EP; | |
7605 end if; | |
7606 | |
7607 -- Similar processing for upper bound and high value | |
7608 | |
7609 Model_Num := UR_Trunc (Hival / Small) * Small; | |
7610 | |
7611 if Hival = Model_Num then | |
7612 Hival_Incl_EP := Model_Num; | |
7613 else | |
7614 Hival_Incl_EP := Model_Num + Small; | |
7615 end if; | |
7616 | |
7617 if UR_Is_Positive (Hival_Incl_EP) then | |
7618 Hival_Excl_EP := Hival_Incl_EP - Small; | |
7619 else | |
7620 Hival_Excl_EP := Hival_Incl_EP; | |
7621 end if; | |
7622 | |
7623 -- One further adjustment is needed. In the case of subtypes, we | |
7624 -- cannot go outside the range of the base type, or we get | |
7625 -- peculiarities, and the base type range is already set. This | |
7626 -- only applies to the Incl values, since clearly the Excl values | |
7627 -- are already as restricted as they are allowed to be. | |
7628 | |
7629 if Typ /= Btyp then | |
7630 Loval_Incl_EP := UR_Max (Loval_Incl_EP, Realval (BLo)); | |
7631 Hival_Incl_EP := UR_Min (Hival_Incl_EP, Realval (BHi)); | |
7632 end if; | |
7633 | |
7634 -- Get size including and excluding end points | |
7635 | |
7636 Size_Incl_EP := Fsize (Loval_Incl_EP, Hival_Incl_EP); | |
7637 Size_Excl_EP := Fsize (Loval_Excl_EP, Hival_Excl_EP); | |
7638 | |
7639 -- No need to exclude end-points if it does not reduce size | |
7640 | |
7641 if Fsize (Loval_Incl_EP, Hival_Excl_EP) = Size_Excl_EP then | |
7642 Loval_Excl_EP := Loval_Incl_EP; | |
7643 end if; | |
7644 | |
7645 if Fsize (Loval_Excl_EP, Hival_Incl_EP) = Size_Excl_EP then | |
7646 Hival_Excl_EP := Hival_Incl_EP; | |
7647 end if; | |
7648 | |
7649 -- Now we set the actual size to be used. We want to use the | |
7650 -- bounds fudged up to include the end-points but only if this | |
7651 -- can be done without violating a specifically given size | |
7652 -- size clause or causing an unacceptable increase in size. | |
7653 | |
7654 -- Case of size clause given | |
7655 | |
7656 if Has_Size_Clause (Typ) then | |
7657 | |
7658 -- Use the inclusive size only if it is consistent with | |
7659 -- the explicitly specified size. | |
7660 | |
7661 if Size_Incl_EP <= RM_Size (Typ) then | |
7662 Actual_Lo := Loval_Incl_EP; | |
7663 Actual_Hi := Hival_Incl_EP; | |
7664 Actual_Size := Size_Incl_EP; | |
7665 | |
7666 -- If the inclusive size is too large, we try excluding | |
7667 -- the end-points (will be caught later if does not work). | |
7668 | |
7669 else | |
7670 Actual_Lo := Loval_Excl_EP; | |
7671 Actual_Hi := Hival_Excl_EP; | |
7672 Actual_Size := Size_Excl_EP; | |
7673 end if; | |
7674 | |
7675 -- Case of size clause not given | |
7676 | |
7677 else | |
7678 -- If we have a base type whose corresponding first subtype | |
7679 -- has an explicit size that is large enough to include our | |
7680 -- end-points, then do so. There is no point in working hard | |
7681 -- to get a base type whose size is smaller than the specified | |
7682 -- size of the first subtype. | |
7683 | |
7684 First_Subt := First_Subtype (Typ); | |
7685 | |
7686 if Has_Size_Clause (First_Subt) | |
7687 and then Size_Incl_EP <= Esize (First_Subt) | |
7688 then | |
7689 Actual_Size := Size_Incl_EP; | |
7690 Actual_Lo := Loval_Incl_EP; | |
7691 Actual_Hi := Hival_Incl_EP; | |
7692 | |
7693 -- If excluding the end-points makes the size smaller and | |
7694 -- results in a size of 8,16,32,64, then we take the smaller | |
7695 -- size. For the 64 case, this is compulsory. For the other | |
7696 -- cases, it seems reasonable. We like to include end points | |
7697 -- if we can, but not at the expense of moving to the next | |
7698 -- natural boundary of size. | |
7699 | |
7700 elsif Size_Incl_EP /= Size_Excl_EP | |
7701 and then Addressable (Size_Excl_EP) | |
7702 then | |
7703 Actual_Size := Size_Excl_EP; | |
7704 Actual_Lo := Loval_Excl_EP; | |
7705 Actual_Hi := Hival_Excl_EP; | |
7706 | |
7707 -- Otherwise we can definitely include the end points | |
7708 | |
7709 else | |
7710 Actual_Size := Size_Incl_EP; | |
7711 Actual_Lo := Loval_Incl_EP; | |
7712 Actual_Hi := Hival_Incl_EP; | |
7713 end if; | |
7714 | |
7715 -- One pathological case: normally we never fudge a low bound | |
7716 -- down, since it would seem to increase the size (if it has | |
7717 -- any effect), but for ranges containing single value, or no | |
7718 -- values, the high bound can be small too large. Consider: | |
7719 | |
7720 -- type t is delta 2.0**(-14) | |
7721 -- range 131072.0 .. 0; | |
7722 | |
7723 -- That lower bound is *just* outside the range of 32 bits, and | |
7724 -- does need fudging down in this case. Note that the bounds | |
7725 -- will always have crossed here, since the high bound will be | |
7726 -- fudged down if necessary, as in the case of: | |
7727 | |
7728 -- type t is delta 2.0**(-14) | |
7729 -- range 131072.0 .. 131072.0; | |
7730 | |
7731 -- So we detect the situation by looking for crossed bounds, | |
7732 -- and if the bounds are crossed, and the low bound is greater | |
7733 -- than zero, we will always back it off by small, since this | |
7734 -- is completely harmless. | |
7735 | |
7736 if Actual_Lo > Actual_Hi then | |
7737 if UR_Is_Positive (Actual_Lo) then | |
7738 Actual_Lo := Loval_Incl_EP - Small; | |
7739 Actual_Size := Fsize (Actual_Lo, Actual_Hi); | |
7740 | |
7741 -- And of course, we need to do exactly the same parallel | |
7742 -- fudge for flat ranges in the negative region. | |
7743 | |
7744 elsif UR_Is_Negative (Actual_Hi) then | |
7745 Actual_Hi := Hival_Incl_EP + Small; | |
7746 Actual_Size := Fsize (Actual_Lo, Actual_Hi); | |
7747 end if; | |
7748 end if; | |
7749 end if; | |
7750 | |
7751 Set_Realval (Lo, Actual_Lo); | |
7752 Set_Realval (Hi, Actual_Hi); | |
7753 end Fudge; | |
7754 | |
7755 -- For the decimal case, none of this fudging is required, since there | |
7756 -- are no end-point problems in the decimal case (the end-points are | |
7757 -- always included). | |
7758 | |
7759 else | |
7760 Actual_Size := Fsize (Loval, Hival); | |
7761 end if; | |
7762 | |
7763 -- At this stage, the actual size has been calculated and the proper | |
7764 -- required bounds are stored in the low and high bounds. | |
7765 | |
7766 if Actual_Size > 64 then | |
7767 Error_Msg_Uint_1 := UI_From_Int (Actual_Size); | |
7768 Error_Msg_N | |
7769 ("size required (^) for type& too large, maximum allowed is 64", | |
7770 Typ); | |
7771 Actual_Size := 64; | |
7772 end if; | |
7773 | |
7774 -- Check size against explicit given size | |
7775 | |
7776 if Has_Size_Clause (Typ) then | |
7777 if Actual_Size > RM_Size (Typ) then | |
7778 Error_Msg_Uint_1 := RM_Size (Typ); | |
7779 Error_Msg_Uint_2 := UI_From_Int (Actual_Size); | |
7780 Error_Msg_NE | |
7781 ("size given (^) for type& too small, minimum allowed is ^", | |
7782 Size_Clause (Typ), Typ); | |
7783 | |
7784 else | |
7785 Actual_Size := UI_To_Int (Esize (Typ)); | |
7786 end if; | |
7787 | |
7788 -- Increase size to next natural boundary if no size clause given | |
7789 | |
7790 else | |
7791 if Actual_Size <= 8 then | |
7792 Actual_Size := 8; | |
7793 elsif Actual_Size <= 16 then | |
7794 Actual_Size := 16; | |
7795 elsif Actual_Size <= 32 then | |
7796 Actual_Size := 32; | |
7797 else | |
7798 Actual_Size := 64; | |
7799 end if; | |
7800 | |
7801 Init_Esize (Typ, Actual_Size); | |
7802 Adjust_Esize_For_Alignment (Typ); | |
7803 end if; | |
7804 | |
7805 -- If we have a base type, then expand the bounds so that they extend to | |
7806 -- the full width of the allocated size in bits, to avoid junk range | |
7807 -- checks on intermediate computations. | |
7808 | |
7809 if Base_Type (Typ) = Typ then | |
7810 Set_Realval (Lo, -(Small * (Uint_2 ** (Actual_Size - 1)))); | |
7811 Set_Realval (Hi, (Small * (Uint_2 ** (Actual_Size - 1) - 1))); | |
7812 end if; | |
7813 | |
7814 -- Final step is to reanalyze the bounds using the proper type | |
7815 -- and set the Corresponding_Integer_Value fields of the literals. | |
7816 | |
7817 Set_Etype (Lo, Empty); | |
7818 Set_Analyzed (Lo, False); | |
7819 Analyze (Lo); | |
7820 | |
7821 -- Resolve with universal fixed if the base type, and the base type if | |
7822 -- it is a subtype. Note we can't resolve the base type with itself, | |
7823 -- that would be a reference before definition. | |
7824 | |
7825 if Typ = Btyp then | |
7826 Resolve (Lo, Universal_Fixed); | |
7827 else | |
7828 Resolve (Lo, Btyp); | |
7829 end if; | |
7830 | |
7831 -- Set corresponding integer value for bound | |
7832 | |
7833 Set_Corresponding_Integer_Value | |
7834 (Lo, UR_To_Uint (Realval (Lo) / Small)); | |
7835 | |
7836 -- Similar processing for high bound | |
7837 | |
7838 Set_Etype (Hi, Empty); | |
7839 Set_Analyzed (Hi, False); | |
7840 Analyze (Hi); | |
7841 | |
7842 if Typ = Btyp then | |
7843 Resolve (Hi, Universal_Fixed); | |
7844 else | |
7845 Resolve (Hi, Btyp); | |
7846 end if; | |
7847 | |
7848 Set_Corresponding_Integer_Value | |
7849 (Hi, UR_To_Uint (Realval (Hi) / Small)); | |
7850 | |
7851 -- Set type of range to correspond to bounds | |
7852 | |
7853 Set_Etype (Rng, Etype (Lo)); | |
7854 | |
7855 -- Set Esize to calculated size if not set already | |
7856 | |
7857 if Unknown_Esize (Typ) then | |
7858 Init_Esize (Typ, Actual_Size); | |
7859 end if; | |
7860 | |
7861 -- Set RM_Size if not already set. If already set, check value | |
7862 | |
7863 declare | |
7864 Minsiz : constant Uint := UI_From_Int (Minimum_Size (Typ)); | |
7865 | |
7866 begin | |
7867 if RM_Size (Typ) /= Uint_0 then | |
7868 if RM_Size (Typ) < Minsiz then | |
7869 Error_Msg_Uint_1 := RM_Size (Typ); | |
7870 Error_Msg_Uint_2 := Minsiz; | |
7871 Error_Msg_NE | |
7872 ("size given (^) for type& too small, minimum allowed is ^", | |
7873 Size_Clause (Typ), Typ); | |
7874 end if; | |
7875 | |
7876 else | |
7877 Set_RM_Size (Typ, Minsiz); | |
7878 end if; | |
7879 end; | |
7880 | |
7881 -- Check for shaving | |
7882 | |
7883 if Comes_From_Source (Typ) then | |
7884 | |
7885 -- In SPARK mode the given bounds must be strictly representable | |
7886 | |
7887 if SPARK_Mode = On then | |
7888 if Orig_Lo < Expr_Value_R (Lo) then | |
7889 Error_Msg_NE | |
7890 ("declared low bound of type & is outside type range", | |
7891 Lo, Typ); | |
7892 end if; | |
7893 | |
7894 if Orig_Hi > Expr_Value_R (Hi) then | |
7895 Error_Msg_NE | |
7896 ("declared high bound of type & is outside type range", | |
7897 Hi, Typ); | |
7898 end if; | |
7899 | |
7900 else | |
7901 if Orig_Lo < Expr_Value_R (Lo) then | |
7902 Error_Msg_N | |
7903 ("declared low bound of type & is outside type range??", Typ); | |
7904 Error_Msg_N | |
7905 ("\low bound adjusted up by delta (RM 3.5.9(13))??", Typ); | |
7906 end if; | |
7907 | |
7908 if Orig_Hi > Expr_Value_R (Hi) then | |
7909 Error_Msg_N | |
7910 ("declared high bound of type & is outside type range??", | |
7911 Typ); | |
7912 Error_Msg_N | |
7913 ("\high bound adjusted down by delta (RM 3.5.9(13))??", Typ); | |
7914 end if; | |
7915 end if; | |
7916 end if; | |
7917 end Freeze_Fixed_Point_Type; | |
7918 | |
7919 ------------------ | |
7920 -- Freeze_Itype -- | |
7921 ------------------ | |
7922 | |
7923 procedure Freeze_Itype (T : Entity_Id; N : Node_Id) is | |
7924 L : List_Id; | |
7925 | |
7926 begin | |
7927 Set_Has_Delayed_Freeze (T); | |
7928 L := Freeze_Entity (T, N); | |
7929 | |
7930 if Is_Non_Empty_List (L) then | |
7931 Insert_Actions (N, L); | |
7932 end if; | |
7933 end Freeze_Itype; | |
7934 | |
7935 -------------------------- | |
7936 -- Freeze_Static_Object -- | |
7937 -------------------------- | |
7938 | |
7939 procedure Freeze_Static_Object (E : Entity_Id) is | |
7940 | |
7941 Cannot_Be_Static : exception; | |
7942 -- Exception raised if the type of a static object cannot be made | |
7943 -- static. This happens if the type depends on non-global objects. | |
7944 | |
7945 procedure Ensure_Expression_Is_SA (N : Node_Id); | |
7946 -- Called to ensure that an expression used as part of a type definition | |
7947 -- is statically allocatable, which means that the expression type is | |
7948 -- statically allocatable, and the expression is either static, or a | |
7949 -- reference to a library level constant. | |
7950 | |
7951 procedure Ensure_Type_Is_SA (Typ : Entity_Id); | |
7952 -- Called to mark a type as static, checking that it is possible | |
7953 -- to set the type as static. If it is not possible, then the | |
7954 -- exception Cannot_Be_Static is raised. | |
7955 | |
7956 ----------------------------- | |
7957 -- Ensure_Expression_Is_SA -- | |
7958 ----------------------------- | |
7959 | |
7960 procedure Ensure_Expression_Is_SA (N : Node_Id) is | |
7961 Ent : Entity_Id; | |
7962 | |
7963 begin | |
7964 Ensure_Type_Is_SA (Etype (N)); | |
7965 | |
7966 if Is_OK_Static_Expression (N) then | |
7967 return; | |
7968 | |
7969 elsif Nkind (N) = N_Identifier then | |
7970 Ent := Entity (N); | |
7971 | |
7972 if Present (Ent) | |
7973 and then Ekind (Ent) = E_Constant | |
7974 and then Is_Library_Level_Entity (Ent) | |
7975 then | |
7976 return; | |
7977 end if; | |
7978 end if; | |
7979 | |
7980 raise Cannot_Be_Static; | |
7981 end Ensure_Expression_Is_SA; | |
7982 | |
7983 ----------------------- | |
7984 -- Ensure_Type_Is_SA -- | |
7985 ----------------------- | |
7986 | |
7987 procedure Ensure_Type_Is_SA (Typ : Entity_Id) is | |
7988 N : Node_Id; | |
7989 C : Entity_Id; | |
7990 | |
7991 begin | |
7992 -- If type is library level, we are all set | |
7993 | |
7994 if Is_Library_Level_Entity (Typ) then | |
7995 return; | |
7996 end if; | |
7997 | |
7998 -- We are also OK if the type already marked as statically allocated, | |
7999 -- which means we processed it before. | |
8000 | |
8001 if Is_Statically_Allocated (Typ) then | |
8002 return; | |
8003 end if; | |
8004 | |
8005 -- Mark type as statically allocated | |
8006 | |
8007 Set_Is_Statically_Allocated (Typ); | |
8008 | |
8009 -- Check that it is safe to statically allocate this type | |
8010 | |
8011 if Is_Scalar_Type (Typ) or else Is_Real_Type (Typ) then | |
8012 Ensure_Expression_Is_SA (Type_Low_Bound (Typ)); | |
8013 Ensure_Expression_Is_SA (Type_High_Bound (Typ)); | |
8014 | |
8015 elsif Is_Array_Type (Typ) then | |
8016 N := First_Index (Typ); | |
8017 while Present (N) loop | |
8018 Ensure_Type_Is_SA (Etype (N)); | |
8019 Next_Index (N); | |
8020 end loop; | |
8021 | |
8022 Ensure_Type_Is_SA (Component_Type (Typ)); | |
8023 | |
8024 elsif Is_Access_Type (Typ) then | |
8025 if Ekind (Designated_Type (Typ)) = E_Subprogram_Type then | |
8026 | |
8027 declare | |
8028 F : Entity_Id; | |
8029 T : constant Entity_Id := Etype (Designated_Type (Typ)); | |
8030 | |
8031 begin | |
8032 if T /= Standard_Void_Type then | |
8033 Ensure_Type_Is_SA (T); | |
8034 end if; | |
8035 | |
8036 F := First_Formal (Designated_Type (Typ)); | |
8037 while Present (F) loop | |
8038 Ensure_Type_Is_SA (Etype (F)); | |
8039 Next_Formal (F); | |
8040 end loop; | |
8041 end; | |
8042 | |
8043 else | |
8044 Ensure_Type_Is_SA (Designated_Type (Typ)); | |
8045 end if; | |
8046 | |
8047 elsif Is_Record_Type (Typ) then | |
8048 C := First_Entity (Typ); | |
8049 while Present (C) loop | |
8050 if Ekind (C) = E_Discriminant | |
8051 or else Ekind (C) = E_Component | |
8052 then | |
8053 Ensure_Type_Is_SA (Etype (C)); | |
8054 | |
8055 elsif Is_Type (C) then | |
8056 Ensure_Type_Is_SA (C); | |
8057 end if; | |
8058 | |
8059 Next_Entity (C); | |
8060 end loop; | |
8061 | |
8062 elsif Ekind (Typ) = E_Subprogram_Type then | |
8063 Ensure_Type_Is_SA (Etype (Typ)); | |
8064 | |
8065 C := First_Formal (Typ); | |
8066 while Present (C) loop | |
8067 Ensure_Type_Is_SA (Etype (C)); | |
8068 Next_Formal (C); | |
8069 end loop; | |
8070 | |
8071 else | |
8072 raise Cannot_Be_Static; | |
8073 end if; | |
8074 end Ensure_Type_Is_SA; | |
8075 | |
8076 -- Start of processing for Freeze_Static_Object | |
8077 | |
8078 begin | |
8079 Ensure_Type_Is_SA (Etype (E)); | |
8080 | |
8081 exception | |
8082 when Cannot_Be_Static => | |
8083 | |
8084 -- If the object that cannot be static is imported or exported, then | |
8085 -- issue an error message saying that this object cannot be imported | |
8086 -- or exported. If it has an address clause it is an overlay in the | |
8087 -- current partition and the static requirement is not relevant. | |
8088 -- Do not issue any error message when ignoring rep clauses. | |
8089 | |
8090 if Ignore_Rep_Clauses then | |
8091 null; | |
8092 | |
8093 elsif Is_Imported (E) then | |
8094 if No (Address_Clause (E)) then | |
8095 Error_Msg_N | |
8096 ("& cannot be imported (local type is not constant)", E); | |
8097 end if; | |
8098 | |
8099 -- Otherwise must be exported, something is wrong if compiler | |
8100 -- is marking something as statically allocated which cannot be). | |
8101 | |
8102 else pragma Assert (Is_Exported (E)); | |
8103 Error_Msg_N | |
8104 ("& cannot be exported (local type is not constant)", E); | |
8105 end if; | |
8106 end Freeze_Static_Object; | |
8107 | |
8108 ----------------------- | |
8109 -- Freeze_Subprogram -- | |
8110 ----------------------- | |
8111 | |
8112 procedure Freeze_Subprogram (E : Entity_Id) is | |
8113 procedure Set_Profile_Convention (Subp_Id : Entity_Id); | |
8114 -- Set the conventions of all anonymous access-to-subprogram formals and | |
8115 -- result subtype of subprogram Subp_Id to the convention of Subp_Id. | |
8116 | |
8117 ---------------------------- | |
8118 -- Set_Profile_Convention -- | |
8119 ---------------------------- | |
8120 | |
8121 procedure Set_Profile_Convention (Subp_Id : Entity_Id) is | |
8122 Conv : constant Convention_Id := Convention (Subp_Id); | |
8123 | |
8124 procedure Set_Type_Convention (Typ : Entity_Id); | |
8125 -- Set the convention of anonymous access-to-subprogram type Typ and | |
8126 -- its designated type to Conv. | |
8127 | |
8128 ------------------------- | |
8129 -- Set_Type_Convention -- | |
8130 ------------------------- | |
8131 | |
8132 procedure Set_Type_Convention (Typ : Entity_Id) is | |
8133 begin | |
8134 -- Set the convention on both the anonymous access-to-subprogram | |
8135 -- type and the subprogram type it points to because both types | |
8136 -- participate in conformance-related checks. | |
8137 | |
8138 if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then | |
8139 Set_Convention (Typ, Conv); | |
8140 Set_Convention (Designated_Type (Typ), Conv); | |
8141 end if; | |
8142 end Set_Type_Convention; | |
8143 | |
8144 -- Local variables | |
8145 | |
8146 Formal : Entity_Id; | |
8147 | |
8148 -- Start of processing for Set_Profile_Convention | |
8149 | |
8150 begin | |
8151 Formal := First_Formal (Subp_Id); | |
8152 while Present (Formal) loop | |
8153 Set_Type_Convention (Etype (Formal)); | |
8154 Next_Formal (Formal); | |
8155 end loop; | |
8156 | |
8157 if Ekind (Subp_Id) = E_Function then | |
8158 Set_Type_Convention (Etype (Subp_Id)); | |
8159 end if; | |
8160 end Set_Profile_Convention; | |
8161 | |
8162 -- Local variables | |
8163 | |
8164 F : Entity_Id; | |
8165 Retype : Entity_Id; | |
8166 | |
8167 -- Start of processing for Freeze_Subprogram | |
8168 | |
8169 begin | |
8170 -- Subprogram may not have an address clause unless it is imported | |
8171 | |
8172 if Present (Address_Clause (E)) then | |
8173 if not Is_Imported (E) then | |
8174 Error_Msg_N | |
8175 ("address clause can only be given for imported subprogram", | |
8176 Name (Address_Clause (E))); | |
8177 end if; | |
8178 end if; | |
8179 | |
8180 -- Reset the Pure indication on an imported subprogram unless an | |
8181 -- explicit Pure_Function pragma was present or the subprogram is an | |
8182 -- intrinsic. We do this because otherwise it is an insidious error | |
8183 -- to call a non-pure function from pure unit and have calls | |
8184 -- mysteriously optimized away. What happens here is that the Import | |
8185 -- can bypass the normal check to ensure that pure units call only pure | |
8186 -- subprograms. | |
8187 | |
8188 -- The reason for the intrinsic exception is that in general, intrinsic | |
8189 -- functions (such as shifts) are pure anyway. The only exceptions are | |
8190 -- the intrinsics in GNAT.Source_Info, and that unit is not marked Pure | |
8191 -- in any case, so no problem arises. | |
8192 | |
8193 if Is_Imported (E) | |
8194 and then Is_Pure (E) | |
8195 and then not Has_Pragma_Pure_Function (E) | |
8196 and then not Is_Intrinsic_Subprogram (E) | |
8197 then | |
8198 Set_Is_Pure (E, False); | |
8199 end if; | |
8200 | |
8201 -- We also reset the Pure indication on a subprogram with an Address | |
8202 -- parameter, because the parameter may be used as a pointer and the | |
8203 -- referenced data may change even if the address value does not. | |
8204 | |
8205 -- Note that if the programmer gave an explicit Pure_Function pragma, | |
8206 -- then we believe the programmer, and leave the subprogram Pure. We | |
8207 -- also suppress this check on run-time files. | |
8208 | |
8209 if Is_Pure (E) | |
8210 and then Is_Subprogram (E) | |
8211 and then not Has_Pragma_Pure_Function (E) | |
8212 and then not Is_Internal_Unit (Current_Sem_Unit) | |
8213 then | |
8214 Check_Function_With_Address_Parameter (E); | |
8215 end if; | |
8216 | |
8217 -- Ensure that all anonymous access-to-subprogram types inherit the | |
8218 -- convention of their related subprogram (RM 6.3.1 13.1/3). This is | |
8219 -- not done for a defaulted convention Ada because those types also | |
8220 -- default to Ada. Convention Protected must not be propagated when | |
8221 -- the subprogram is an entry because this would be illegal. The only | |
8222 -- way to force convention Protected on these kinds of types is to | |
8223 -- include keyword "protected" in the access definition. | |
8224 | |
8225 if Convention (E) /= Convention_Ada | |
8226 and then Convention (E) /= Convention_Protected | |
8227 then | |
8228 Set_Profile_Convention (E); | |
8229 end if; | |
8230 | |
8231 -- For non-foreign convention subprograms, this is where we create | |
8232 -- the extra formals (for accessibility level and constrained bit | |
8233 -- information). We delay this till the freeze point precisely so | |
8234 -- that we know the convention. | |
8235 | |
8236 if not Has_Foreign_Convention (E) then | |
8237 if No (Extra_Formals (E)) then | |
8238 Create_Extra_Formals (E); | |
8239 end if; | |
8240 | |
8241 Set_Mechanisms (E); | |
8242 | |
8243 -- If this is convention Ada and a Valued_Procedure, that's odd | |
8244 | |
8245 if Ekind (E) = E_Procedure | |
8246 and then Is_Valued_Procedure (E) | |
8247 and then Convention (E) = Convention_Ada | |
8248 and then Warn_On_Export_Import | |
8249 then | |
8250 Error_Msg_N | |
8251 ("??Valued_Procedure has no effect for convention Ada", E); | |
8252 Set_Is_Valued_Procedure (E, False); | |
8253 end if; | |
8254 | |
8255 -- Case of foreign convention | |
8256 | |
8257 else | |
8258 Set_Mechanisms (E); | |
8259 | |
8260 -- For foreign conventions, warn about return of unconstrained array | |
8261 | |
8262 if Ekind (E) = E_Function then | |
8263 Retype := Underlying_Type (Etype (E)); | |
8264 | |
8265 -- If no return type, probably some other error, e.g. a | |
8266 -- missing full declaration, so ignore. | |
8267 | |
8268 if No (Retype) then | |
8269 null; | |
8270 | |
8271 -- If the return type is generic, we have emitted a warning | |
8272 -- earlier on, and there is nothing else to check here. Specific | |
8273 -- instantiations may lead to erroneous behavior. | |
8274 | |
8275 elsif Is_Generic_Type (Etype (E)) then | |
8276 null; | |
8277 | |
8278 -- Display warning if returning unconstrained array | |
8279 | |
8280 elsif Is_Array_Type (Retype) | |
8281 and then not Is_Constrained (Retype) | |
8282 | |
8283 -- Check appropriate warning is enabled (should we check for | |
8284 -- Warnings (Off) on specific entities here, probably so???) | |
8285 | |
8286 and then Warn_On_Export_Import | |
8287 then | |
8288 Error_Msg_N | |
8289 ("?x?foreign convention function& should not return " & | |
8290 "unconstrained array", E); | |
8291 return; | |
8292 end if; | |
8293 end if; | |
8294 | |
8295 -- If any of the formals for an exported foreign convention | |
8296 -- subprogram have defaults, then emit an appropriate warning since | |
8297 -- this is odd (default cannot be used from non-Ada code) | |
8298 | |
8299 if Is_Exported (E) then | |
8300 F := First_Formal (E); | |
8301 while Present (F) loop | |
8302 if Warn_On_Export_Import | |
8303 and then Present (Default_Value (F)) | |
8304 then | |
8305 Error_Msg_N | |
8306 ("?x?parameter cannot be defaulted in non-Ada call", | |
8307 Default_Value (F)); | |
8308 end if; | |
8309 | |
8310 Next_Formal (F); | |
8311 end loop; | |
8312 end if; | |
8313 end if; | |
8314 | |
8315 -- Pragma Inline_Always is disallowed for dispatching subprograms | |
8316 -- because the address of such subprograms is saved in the dispatch | |
8317 -- table to support dispatching calls, and dispatching calls cannot | |
8318 -- be inlined. This is consistent with the restriction against using | |
8319 -- 'Access or 'Address on an Inline_Always subprogram. | |
8320 | |
8321 if Is_Dispatching_Operation (E) | |
8322 and then Has_Pragma_Inline_Always (E) | |
8323 then | |
8324 Error_Msg_N | |
8325 ("pragma Inline_Always not allowed for dispatching subprograms", E); | |
8326 end if; | |
8327 | |
8328 -- Because of the implicit representation of inherited predefined | |
8329 -- operators in the front-end, the overriding status of the operation | |
8330 -- may be affected when a full view of a type is analyzed, and this is | |
8331 -- not captured by the analysis of the corresponding type declaration. | |
8332 -- Therefore the correctness of a not-overriding indicator must be | |
8333 -- rechecked when the subprogram is frozen. | |
8334 | |
8335 if Nkind (E) = N_Defining_Operator_Symbol | |
8336 and then not Error_Posted (Parent (E)) | |
8337 then | |
8338 Check_Overriding_Indicator (E, Empty, Is_Primitive (E)); | |
8339 end if; | |
8340 | |
8341 if Modify_Tree_For_C | |
8342 and then Nkind (Parent (E)) = N_Function_Specification | |
8343 and then Is_Array_Type (Etype (E)) | |
8344 and then Is_Constrained (Etype (E)) | |
8345 and then not Is_Unchecked_Conversion_Instance (E) | |
8346 and then not Rewritten_For_C (E) | |
8347 then | |
8348 Build_Procedure_Form (Unit_Declaration_Node (E)); | |
8349 end if; | |
8350 end Freeze_Subprogram; | |
8351 | |
8352 ---------------------- | |
8353 -- Is_Fully_Defined -- | |
8354 ---------------------- | |
8355 | |
8356 function Is_Fully_Defined (T : Entity_Id) return Boolean is | |
8357 begin | |
8358 if Ekind (T) = E_Class_Wide_Type then | |
8359 return Is_Fully_Defined (Etype (T)); | |
8360 | |
8361 elsif Is_Array_Type (T) then | |
8362 return Is_Fully_Defined (Component_Type (T)); | |
8363 | |
8364 elsif Is_Record_Type (T) | |
8365 and not Is_Private_Type (T) | |
8366 then | |
8367 -- Verify that the record type has no components with private types | |
8368 -- without completion. | |
8369 | |
8370 declare | |
8371 Comp : Entity_Id; | |
8372 | |
8373 begin | |
8374 Comp := First_Component (T); | |
8375 while Present (Comp) loop | |
8376 if not Is_Fully_Defined (Etype (Comp)) then | |
8377 return False; | |
8378 end if; | |
8379 | |
8380 Next_Component (Comp); | |
8381 end loop; | |
8382 return True; | |
8383 end; | |
8384 | |
8385 -- For the designated type of an access to subprogram, all types in | |
8386 -- the profile must be fully defined. | |
8387 | |
8388 elsif Ekind (T) = E_Subprogram_Type then | |
8389 declare | |
8390 F : Entity_Id; | |
8391 | |
8392 begin | |
8393 F := First_Formal (T); | |
8394 while Present (F) loop | |
8395 if not Is_Fully_Defined (Etype (F)) then | |
8396 return False; | |
8397 end if; | |
8398 | |
8399 Next_Formal (F); | |
8400 end loop; | |
8401 | |
8402 return Is_Fully_Defined (Etype (T)); | |
8403 end; | |
8404 | |
8405 else | |
8406 return not Is_Private_Type (T) | |
8407 or else Present (Full_View (Base_Type (T))); | |
8408 end if; | |
8409 end Is_Fully_Defined; | |
8410 | |
8411 --------------------------------- | |
8412 -- Process_Default_Expressions -- | |
8413 --------------------------------- | |
8414 | |
8415 procedure Process_Default_Expressions | |
8416 (E : Entity_Id; | |
8417 After : in out Node_Id) | |
8418 is | |
8419 Loc : constant Source_Ptr := Sloc (E); | |
8420 Dbody : Node_Id; | |
8421 Formal : Node_Id; | |
8422 Dcopy : Node_Id; | |
8423 Dnam : Entity_Id; | |
8424 | |
8425 begin | |
8426 Set_Default_Expressions_Processed (E); | |
8427 | |
8428 -- A subprogram instance and its associated anonymous subprogram share | |
8429 -- their signature. The default expression functions are defined in the | |
8430 -- wrapper packages for the anonymous subprogram, and should not be | |
8431 -- generated again for the instance. | |
8432 | |
8433 if Is_Generic_Instance (E) | |
8434 and then Present (Alias (E)) | |
8435 and then Default_Expressions_Processed (Alias (E)) | |
8436 then | |
8437 return; | |
8438 end if; | |
8439 | |
8440 Formal := First_Formal (E); | |
8441 while Present (Formal) loop | |
8442 if Present (Default_Value (Formal)) then | |
8443 | |
8444 -- We work with a copy of the default expression because we | |
8445 -- do not want to disturb the original, since this would mess | |
8446 -- up the conformance checking. | |
8447 | |
8448 Dcopy := New_Copy_Tree (Default_Value (Formal)); | |
8449 | |
8450 -- The analysis of the expression may generate insert actions, | |
8451 -- which of course must not be executed. We wrap those actions | |
8452 -- in a procedure that is not called, and later on eliminated. | |
8453 -- The following cases have no side effects, and are analyzed | |
8454 -- directly. | |
8455 | |
8456 if Nkind (Dcopy) = N_Identifier | |
8457 or else Nkind_In (Dcopy, N_Expanded_Name, | |
8458 N_Integer_Literal, | |
8459 N_Character_Literal, | |
8460 N_String_Literal, | |
8461 N_Real_Literal) | |
8462 or else (Nkind (Dcopy) = N_Attribute_Reference | |
8463 and then Attribute_Name (Dcopy) = Name_Null_Parameter) | |
8464 or else Known_Null (Dcopy) | |
8465 then | |
8466 -- If there is no default function, we must still do a full | |
8467 -- analyze call on the default value, to ensure that all error | |
8468 -- checks are performed, e.g. those associated with static | |
8469 -- evaluation. Note: this branch will always be taken if the | |
8470 -- analyzer is turned off (but we still need the error checks). | |
8471 | |
8472 -- Note: the setting of parent here is to meet the requirement | |
8473 -- that we can only analyze the expression while attached to | |
8474 -- the tree. Really the requirement is that the parent chain | |
8475 -- be set, we don't actually need to be in the tree. | |
8476 | |
8477 Set_Parent (Dcopy, Declaration_Node (Formal)); | |
8478 Analyze (Dcopy); | |
8479 | |
8480 -- Default expressions are resolved with their own type if the | |
8481 -- context is generic, to avoid anomalies with private types. | |
8482 | |
8483 if Ekind (Scope (E)) = E_Generic_Package then | |
8484 Resolve (Dcopy); | |
8485 else | |
8486 Resolve (Dcopy, Etype (Formal)); | |
8487 end if; | |
8488 | |
8489 -- If that resolved expression will raise constraint error, | |
8490 -- then flag the default value as raising constraint error. | |
8491 -- This allows a proper error message on the calls. | |
8492 | |
8493 if Raises_Constraint_Error (Dcopy) then | |
8494 Set_Raises_Constraint_Error (Default_Value (Formal)); | |
8495 end if; | |
8496 | |
8497 -- If the default is a parameterless call, we use the name of | |
8498 -- the called function directly, and there is no body to build. | |
8499 | |
8500 elsif Nkind (Dcopy) = N_Function_Call | |
8501 and then No (Parameter_Associations (Dcopy)) | |
8502 then | |
8503 null; | |
8504 | |
8505 -- Else construct and analyze the body of a wrapper procedure | |
8506 -- that contains an object declaration to hold the expression. | |
8507 -- Given that this is done only to complete the analysis, it is | |
8508 -- simpler to build a procedure than a function which might | |
8509 -- involve secondary stack expansion. | |
8510 | |
8511 else | |
8512 Dnam := Make_Temporary (Loc, 'D'); | |
8513 | |
8514 Dbody := | |
8515 Make_Subprogram_Body (Loc, | |
8516 Specification => | |
8517 Make_Procedure_Specification (Loc, | |
8518 Defining_Unit_Name => Dnam), | |
8519 | |
8520 Declarations => New_List ( | |
8521 Make_Object_Declaration (Loc, | |
8522 Defining_Identifier => Make_Temporary (Loc, 'T'), | |
8523 Object_Definition => | |
8524 New_Occurrence_Of (Etype (Formal), Loc), | |
8525 Expression => New_Copy_Tree (Dcopy))), | |
8526 | |
8527 Handled_Statement_Sequence => | |
8528 Make_Handled_Sequence_Of_Statements (Loc, | |
8529 Statements => Empty_List)); | |
8530 | |
8531 Set_Scope (Dnam, Scope (E)); | |
8532 Set_Assignment_OK (First (Declarations (Dbody))); | |
8533 Set_Is_Eliminated (Dnam); | |
8534 Insert_After (After, Dbody); | |
8535 Analyze (Dbody); | |
8536 After := Dbody; | |
8537 end if; | |
8538 end if; | |
8539 | |
8540 Next_Formal (Formal); | |
8541 end loop; | |
8542 end Process_Default_Expressions; | |
8543 | |
8544 ---------------------------------------- | |
8545 -- Set_Component_Alignment_If_Not_Set -- | |
8546 ---------------------------------------- | |
8547 | |
8548 procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id) is | |
8549 begin | |
8550 -- Ignore if not base type, subtypes don't need anything | |
8551 | |
8552 if Typ /= Base_Type (Typ) then | |
8553 return; | |
8554 end if; | |
8555 | |
8556 -- Do not override existing representation | |
8557 | |
8558 if Is_Packed (Typ) then | |
8559 return; | |
8560 | |
8561 elsif Has_Specified_Layout (Typ) then | |
8562 return; | |
8563 | |
8564 elsif Component_Alignment (Typ) /= Calign_Default then | |
8565 return; | |
8566 | |
8567 else | |
8568 Set_Component_Alignment | |
8569 (Typ, Scope_Stack.Table | |
8570 (Scope_Stack.Last).Component_Alignment_Default); | |
8571 end if; | |
8572 end Set_Component_Alignment_If_Not_Set; | |
8573 | |
8574 -------------------------- | |
8575 -- Set_SSO_From_Default -- | |
8576 -------------------------- | |
8577 | |
8578 procedure Set_SSO_From_Default (T : Entity_Id) is | |
8579 Reversed : Boolean; | |
8580 | |
8581 begin | |
8582 -- Set default SSO for an array or record base type, except in case of | |
8583 -- a type extension (which always inherits the SSO of its parent type). | |
8584 | |
8585 if Is_Base_Type (T) | |
8586 and then (Is_Array_Type (T) | |
8587 or else (Is_Record_Type (T) | |
8588 and then not (Is_Tagged_Type (T) | |
8589 and then Is_Derived_Type (T)))) | |
8590 then | |
8591 Reversed := | |
8592 (Bytes_Big_Endian and then SSO_Set_Low_By_Default (T)) | |
8593 or else | |
8594 (not Bytes_Big_Endian and then SSO_Set_High_By_Default (T)); | |
8595 | |
8596 if (SSO_Set_Low_By_Default (T) or else SSO_Set_High_By_Default (T)) | |
8597 | |
8598 -- For a record type, if bit order is specified explicitly, | |
8599 -- then do not set SSO from default if not consistent. Note that | |
8600 -- we do not want to look at a Bit_Order attribute definition | |
8601 -- for a parent: if we were to inherit Bit_Order, then both | |
8602 -- SSO_Set_*_By_Default flags would have been cleared already | |
8603 -- (by Inherit_Aspects_At_Freeze_Point). | |
8604 | |
8605 and then not | |
8606 (Is_Record_Type (T) | |
8607 and then | |
8608 Has_Rep_Item (T, Name_Bit_Order, Check_Parents => False) | |
8609 and then Reverse_Bit_Order (T) /= Reversed) | |
8610 then | |
8611 -- If flags cause reverse storage order, then set the result. Note | |
8612 -- that we would have ignored the pragma setting the non default | |
8613 -- storage order in any case, hence the assertion at this point. | |
8614 | |
8615 pragma Assert | |
8616 (not Reversed or else Support_Nondefault_SSO_On_Target); | |
8617 | |
8618 Set_Reverse_Storage_Order (T, Reversed); | |
8619 | |
8620 -- For a record type, also set reversed bit order. Note: if a bit | |
8621 -- order has been specified explicitly, then this is a no-op. | |
8622 | |
8623 if Is_Record_Type (T) then | |
8624 Set_Reverse_Bit_Order (T, Reversed); | |
8625 end if; | |
8626 end if; | |
8627 end if; | |
8628 end Set_SSO_From_Default; | |
8629 | |
8630 ------------------ | |
8631 -- Undelay_Type -- | |
8632 ------------------ | |
8633 | |
8634 procedure Undelay_Type (T : Entity_Id) is | |
8635 begin | |
8636 Set_Has_Delayed_Freeze (T, False); | |
8637 Set_Freeze_Node (T, Empty); | |
8638 | |
8639 -- Since we don't want T to have a Freeze_Node, we don't want its | |
8640 -- Full_View or Corresponding_Record_Type to have one either. | |
8641 | |
8642 -- ??? Fundamentally, this whole handling is unpleasant. What we really | |
8643 -- want is to be sure that for an Itype that's part of record R and is a | |
8644 -- subtype of type T, that it's frozen after the later of the freeze | |
8645 -- points of R and T. We have no way of doing that directly, so what we | |
8646 -- do is force most such Itypes to be frozen as part of freezing R via | |
8647 -- this procedure and only delay the ones that need to be delayed | |
8648 -- (mostly the designated types of access types that are defined as part | |
8649 -- of the record). | |
8650 | |
8651 if Is_Private_Type (T) | |
8652 and then Present (Full_View (T)) | |
8653 and then Is_Itype (Full_View (T)) | |
8654 and then Is_Record_Type (Scope (Full_View (T))) | |
8655 then | |
8656 Undelay_Type (Full_View (T)); | |
8657 end if; | |
8658 | |
8659 if Is_Concurrent_Type (T) | |
8660 and then Present (Corresponding_Record_Type (T)) | |
8661 and then Is_Itype (Corresponding_Record_Type (T)) | |
8662 and then Is_Record_Type (Scope (Corresponding_Record_Type (T))) | |
8663 then | |
8664 Undelay_Type (Corresponding_Record_Type (T)); | |
8665 end if; | |
8666 end Undelay_Type; | |
8667 | |
8668 ------------------ | |
8669 -- Warn_Overlay -- | |
8670 ------------------ | |
8671 | |
8672 procedure Warn_Overlay (Expr : Node_Id; Typ : Entity_Id; Nam : Entity_Id) is | |
8673 Ent : constant Entity_Id := Entity (Nam); | |
8674 -- The object to which the address clause applies | |
8675 | |
8676 Init : Node_Id; | |
8677 Old : Entity_Id := Empty; | |
8678 Decl : Node_Id; | |
8679 | |
8680 begin | |
8681 -- No warning if address clause overlay warnings are off | |
8682 | |
8683 if not Address_Clause_Overlay_Warnings then | |
8684 return; | |
8685 end if; | |
8686 | |
8687 -- No warning if there is an explicit initialization | |
8688 | |
8689 Init := Original_Node (Expression (Declaration_Node (Ent))); | |
8690 | |
8691 if Present (Init) and then Comes_From_Source (Init) then | |
8692 return; | |
8693 end if; | |
8694 | |
8695 -- We only give the warning for non-imported entities of a type for | |
8696 -- which a non-null base init proc is defined, or for objects of access | |
8697 -- types with implicit null initialization, or when Normalize_Scalars | |
8698 -- applies and the type is scalar or a string type (the latter being | |
8699 -- tested for because predefined String types are initialized by inline | |
8700 -- code rather than by an init_proc). Note that we do not give the | |
8701 -- warning for Initialize_Scalars, since we suppressed initialization | |
8702 -- in this case. Also, do not warn if Suppress_Initialization is set. | |
8703 | |
8704 if Present (Expr) | |
8705 and then not Is_Imported (Ent) | |
8706 and then not Initialization_Suppressed (Typ) | |
8707 and then (Has_Non_Null_Base_Init_Proc (Typ) | |
8708 or else Is_Access_Type (Typ) | |
8709 or else (Normalize_Scalars | |
8710 and then (Is_Scalar_Type (Typ) | |
8711 or else Is_String_Type (Typ)))) | |
8712 then | |
8713 if Nkind (Expr) = N_Attribute_Reference | |
8714 and then Is_Entity_Name (Prefix (Expr)) | |
8715 then | |
8716 Old := Entity (Prefix (Expr)); | |
8717 | |
8718 elsif Is_Entity_Name (Expr) | |
8719 and then Ekind (Entity (Expr)) = E_Constant | |
8720 then | |
8721 Decl := Declaration_Node (Entity (Expr)); | |
8722 | |
8723 if Nkind (Decl) = N_Object_Declaration | |
8724 and then Present (Expression (Decl)) | |
8725 and then Nkind (Expression (Decl)) = N_Attribute_Reference | |
8726 and then Is_Entity_Name (Prefix (Expression (Decl))) | |
8727 then | |
8728 Old := Entity (Prefix (Expression (Decl))); | |
8729 | |
8730 elsif Nkind (Expr) = N_Function_Call then | |
8731 return; | |
8732 end if; | |
8733 | |
8734 -- A function call (most likely to To_Address) is probably not an | |
8735 -- overlay, so skip warning. Ditto if the function call was inlined | |
8736 -- and transformed into an entity. | |
8737 | |
8738 elsif Nkind (Original_Node (Expr)) = N_Function_Call then | |
8739 return; | |
8740 end if; | |
8741 | |
8742 -- If a pragma Import follows, we assume that it is for the current | |
8743 -- target of the address clause, and skip the warning. There may be | |
8744 -- a source pragma or an aspect that specifies import and generates | |
8745 -- the corresponding pragma. These will indicate that the entity is | |
8746 -- imported and that is checked above so that the spurious warning | |
8747 -- (generated when the entity is frozen) will be suppressed. The | |
8748 -- pragma may be attached to the aspect, so it is not yet a list | |
8749 -- member. | |
8750 | |
8751 if Is_List_Member (Parent (Expr)) then | |
8752 Decl := Next (Parent (Expr)); | |
8753 | |
8754 if Present (Decl) | |
8755 and then Nkind (Decl) = N_Pragma | |
8756 and then Pragma_Name (Decl) = Name_Import | |
8757 then | |
8758 return; | |
8759 end if; | |
8760 end if; | |
8761 | |
8762 -- Otherwise give warning message | |
8763 | |
8764 if Present (Old) then | |
8765 Error_Msg_Node_2 := Old; | |
8766 Error_Msg_N | |
8767 ("default initialization of & may modify &??", | |
8768 Nam); | |
8769 else | |
8770 Error_Msg_N | |
8771 ("default initialization of & may modify overlaid storage??", | |
8772 Nam); | |
8773 end if; | |
8774 | |
8775 -- Add friendly warning if initialization comes from a packed array | |
8776 -- component. | |
8777 | |
8778 if Is_Record_Type (Typ) then | |
8779 declare | |
8780 Comp : Entity_Id; | |
8781 | |
8782 begin | |
8783 Comp := First_Component (Typ); | |
8784 while Present (Comp) loop | |
8785 if Nkind (Parent (Comp)) = N_Component_Declaration | |
8786 and then Present (Expression (Parent (Comp))) | |
8787 then | |
8788 exit; | |
8789 elsif Is_Array_Type (Etype (Comp)) | |
8790 and then Present (Packed_Array_Impl_Type (Etype (Comp))) | |
8791 then | |
8792 Error_Msg_NE | |
8793 ("\packed array component& " & | |
8794 "will be initialized to zero??", | |
8795 Nam, Comp); | |
8796 exit; | |
8797 else | |
8798 Next_Component (Comp); | |
8799 end if; | |
8800 end loop; | |
8801 end; | |
8802 end if; | |
8803 | |
8804 Error_Msg_N | |
8805 ("\use pragma Import for & to " & | |
8806 "suppress initialization (RM B.1(24))??", | |
8807 Nam); | |
8808 end if; | |
8809 end Warn_Overlay; | |
8810 | |
8811 end Freeze; |