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