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