OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [freeze.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                               F R E E Z E                                --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
with Atree;    use Atree;
27
with Debug;    use Debug;
28
with Einfo;    use Einfo;
29
with Elists;   use Elists;
30
with Errout;   use Errout;
31
with Exp_Ch3;  use Exp_Ch3;
32
with Exp_Ch7;  use Exp_Ch7;
33
with Exp_Disp; use Exp_Disp;
34
with Exp_Pakd; use Exp_Pakd;
35
with Exp_Util; use Exp_Util;
36
with Exp_Tss;  use Exp_Tss;
37
with Layout;   use Layout;
38
with Lib;      use Lib;
39
with Namet;    use Namet;
40
with Nlists;   use Nlists;
41
with Nmake;    use Nmake;
42
with Opt;      use Opt;
43
with Restrict; use Restrict;
44
with Rident;   use Rident;
45
with Rtsfind; use Rtsfind;
46
with Sem;      use Sem;
47
with Sem_Aux;  use Sem_Aux;
48
with Sem_Cat;  use Sem_Cat;
49
with Sem_Ch6;  use Sem_Ch6;
50
with Sem_Ch7;  use Sem_Ch7;
51
with Sem_Ch8;  use Sem_Ch8;
52
with Sem_Ch13; use Sem_Ch13;
53
with Sem_Eval; use Sem_Eval;
54
with Sem_Mech; use Sem_Mech;
55
with Sem_Prag; use Sem_Prag;
56
with Sem_Res;  use Sem_Res;
57
with Sem_Util; use Sem_Util;
58
with Sinfo;    use Sinfo;
59
with Snames;   use Snames;
60
with Stand;    use Stand;
61
with Targparm; use Targparm;
62
with Tbuild;   use Tbuild;
63
with Ttypes;   use Ttypes;
64
with Uintp;    use Uintp;
65
with Urealp;   use Urealp;
66
 
67
package body Freeze is
68
 
69
   -----------------------
70
   -- Local Subprograms --
71
   -----------------------
72
 
73
   procedure Adjust_Esize_For_Alignment (Typ : Entity_Id);
74
   --  Typ is a type that is being frozen. If no size clause is given,
75
   --  but a default Esize has been computed, then this default Esize is
76
   --  adjusted up if necessary to be consistent with a given alignment,
77
   --  but never to a value greater than Long_Long_Integer'Size. This
78
   --  is used for all discrete types and for fixed-point types.
79
 
80
   procedure Build_And_Analyze_Renamed_Body
81
     (Decl  : Node_Id;
82
      New_S : Entity_Id;
83
      After : in out Node_Id);
84
   --  Build body for a renaming declaration, insert in tree and analyze
85
 
86
   procedure Check_Address_Clause (E : Entity_Id);
87
   --  Apply legality checks to address clauses for object declarations,
88
   --  at the point the object is frozen.
89
 
90
   procedure Check_Strict_Alignment (E : Entity_Id);
91
   --  E is a base type. If E is tagged or has a component that is aliased
92
   --  or tagged or contains something this is aliased or tagged, set
93
   --  Strict_Alignment.
94
 
95
   procedure Check_Unsigned_Type (E : Entity_Id);
96
   pragma Inline (Check_Unsigned_Type);
97
   --  If E is a fixed-point or discrete type, then all the necessary work
98
   --  to freeze it is completed except for possible setting of the flag
99
   --  Is_Unsigned_Type, which is done by this procedure. The call has no
100
   --  effect if the entity E is not a discrete or fixed-point type.
101
 
102
   procedure Freeze_And_Append
103
     (Ent    : Entity_Id;
104
      N      : Node_Id;
105
      Result : in out List_Id);
106
   --  Freezes Ent using Freeze_Entity, and appends the resulting list of
107
   --  nodes to Result, modifying Result from No_List if necessary. N has
108
   --  the same usage as in Freeze_Entity.
109
 
110
   procedure Freeze_Enumeration_Type (Typ : Entity_Id);
111
   --  Freeze enumeration type. The Esize field is set as processing
112
   --  proceeds (i.e. set by default when the type is declared and then
113
   --  adjusted by rep clauses. What this procedure does is to make sure
114
   --  that if a foreign convention is specified, and no specific size
115
   --  is given, then the size must be at least Integer'Size.
116
 
117
   procedure Freeze_Static_Object (E : Entity_Id);
118
   --  If an object is frozen which has Is_Statically_Allocated set, then
119
   --  all referenced types must also be marked with this flag. This routine
120
   --  is in charge of meeting this requirement for the object entity E.
121
 
122
   procedure Freeze_Subprogram (E : Entity_Id);
123
   --  Perform freezing actions for a subprogram (create extra formals,
124
   --  and set proper default mechanism values). Note that this routine
125
   --  is not called for internal subprograms, for which neither of these
126
   --  actions is needed (or desirable, we do not want for example to have
127
   --  these extra formals present in initialization procedures, where they
128
   --  would serve no purpose). In this call E is either a subprogram or
129
   --  a subprogram type (i.e. an access to a subprogram).
130
 
131
   function Is_Fully_Defined (T : Entity_Id) return Boolean;
132
   --  True if T is not private and has no private components, or has a full
133
   --  view. Used to determine whether the designated type of an access type
134
   --  should be frozen when the access type is frozen. This is done when an
135
   --  allocator is frozen, or an expression that may involve attributes of
136
   --  the designated type. Otherwise freezing the access type does not freeze
137
   --  the designated type.
138
 
139
   procedure Process_Default_Expressions
140
     (E     : Entity_Id;
141
      After : in out Node_Id);
142
   --  This procedure is called for each subprogram to complete processing of
143
   --  default expressions at the point where all types are known to be frozen.
144
   --  The expressions must be analyzed in full, to make sure that all error
145
   --  processing is done (they have only been pre-analyzed). If the expression
146
   --  is not an entity or literal, its analysis may generate code which must
147
   --  not be executed. In that case we build a function body to hold that
148
   --  code. This wrapper function serves no other purpose (it used to be
149
   --  called to evaluate the default, but now the default is inlined at each
150
   --  point of call).
151
 
152
   procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id);
153
   --  Typ is a record or array type that is being frozen. This routine sets
154
   --  the default component alignment from the scope stack values if the
155
   --  alignment is otherwise not specified.
156
 
157
   procedure Check_Debug_Info_Needed (T : Entity_Id);
158
   --  As each entity is frozen, this routine is called to deal with the
159
   --  setting of Debug_Info_Needed for the entity. This flag is set if
160
   --  the entity comes from source, or if we are in Debug_Generated_Code
161
   --  mode or if the -gnatdV debug flag is set. However, it never sets
162
   --  the flag if Debug_Info_Off is set. This procedure also ensures that
163
   --  subsidiary entities have the flag set as required.
164
 
165
   procedure Undelay_Type (T : Entity_Id);
166
   --  T is a type of a component that we know to be an Itype. We don't want
167
   --  this to have a Freeze_Node, so ensure it doesn't. Do the same for any
168
   --  Full_View or Corresponding_Record_Type.
169
 
170
   procedure Warn_Overlay
171
     (Expr : Node_Id;
172
      Typ  : Entity_Id;
173
      Nam  : Node_Id);
174
   --  Expr is the expression for an address clause for entity Nam whose type
175
   --  is Typ. If Typ has a default initialization, and there is no explicit
176
   --  initialization in the source declaration, check whether the address
177
   --  clause might cause overlaying of an entity, and emit a warning on the
178
   --  side effect that the initialization will cause.
179
 
180
   -------------------------------
181
   -- Adjust_Esize_For_Alignment --
182
   -------------------------------
183
 
184
   procedure Adjust_Esize_For_Alignment (Typ : Entity_Id) is
185
      Align : Uint;
186
 
187
   begin
188
      if Known_Esize (Typ) and then Known_Alignment (Typ) then
189
         Align := Alignment_In_Bits (Typ);
190
 
191
         if Align > Esize (Typ)
192
           and then Align <= Standard_Long_Long_Integer_Size
193
         then
194
            Set_Esize (Typ, Align);
195
         end if;
196
      end if;
197
   end Adjust_Esize_For_Alignment;
198
 
199
   ------------------------------------
200
   -- Build_And_Analyze_Renamed_Body --
201
   ------------------------------------
202
 
203
   procedure Build_And_Analyze_Renamed_Body
204
     (Decl  : Node_Id;
205
      New_S : Entity_Id;
206
      After : in out Node_Id)
207
   is
208
      Body_Decl    : constant Node_Id := Unit_Declaration_Node (New_S);
209
      Ent          : constant Entity_Id := Defining_Entity (Decl);
210
      Body_Node    : Node_Id;
211
      Renamed_Subp : Entity_Id;
212
 
213
   begin
214
      --  If the renamed subprogram is intrinsic, there is no need for a
215
      --  wrapper body: we set the alias that will be called and expanded which
216
      --  completes the declaration. This transformation is only legal if the
217
      --  renamed entity has already been elaborated.
218
 
219
      --  Note that it is legal for a renaming_as_body to rename an intrinsic
220
      --  subprogram, as long as the renaming occurs before the new entity
221
      --  is frozen. See RM 8.5.4 (5).
222
 
223
      if Nkind (Body_Decl) = N_Subprogram_Renaming_Declaration
224
        and then Is_Entity_Name (Name (Body_Decl))
225
      then
226
         Renamed_Subp := Entity (Name (Body_Decl));
227
      else
228
         Renamed_Subp := Empty;
229
      end if;
230
 
231
      if Present (Renamed_Subp)
232
        and then Is_Intrinsic_Subprogram (Renamed_Subp)
233
        and then
234
          (not In_Same_Source_Unit (Renamed_Subp, Ent)
235
            or else Sloc (Renamed_Subp) < Sloc (Ent))
236
 
237
        --  We can make the renaming entity intrinsic if the renamed function
238
        --  has an interface name, or if it is one of the shift/rotate
239
        --  operations known to the compiler.
240
 
241
        and then (Present (Interface_Name (Renamed_Subp))
242
                   or else Chars (Renamed_Subp) = Name_Rotate_Left
243
                   or else Chars (Renamed_Subp) = Name_Rotate_Right
244
                   or else Chars (Renamed_Subp) = Name_Shift_Left
245
                   or else Chars (Renamed_Subp) = Name_Shift_Right
246
                   or else Chars (Renamed_Subp) = Name_Shift_Right_Arithmetic)
247
      then
248
         Set_Interface_Name (Ent, Interface_Name (Renamed_Subp));
249
 
250
         if Present (Alias (Renamed_Subp)) then
251
            Set_Alias (Ent, Alias (Renamed_Subp));
252
         else
253
            Set_Alias (Ent, Renamed_Subp);
254
         end if;
255
 
256
         Set_Is_Intrinsic_Subprogram (Ent);
257
         Set_Has_Completion (Ent);
258
 
259
      else
260
         Body_Node := Build_Renamed_Body (Decl, New_S);
261
         Insert_After (After, Body_Node);
262
         Mark_Rewrite_Insertion (Body_Node);
263
         Analyze (Body_Node);
264
         After := Body_Node;
265
      end if;
266
   end Build_And_Analyze_Renamed_Body;
267
 
268
   ------------------------
269
   -- Build_Renamed_Body --
270
   ------------------------
271
 
272
   function Build_Renamed_Body
273
     (Decl  : Node_Id;
274
      New_S : Entity_Id) return Node_Id
275
   is
276
      Loc : constant Source_Ptr := Sloc (New_S);
277
      --  We use for the source location of the renamed body, the location of
278
      --  the spec entity. It might seem more natural to use the location of
279
      --  the renaming declaration itself, but that would be wrong, since then
280
      --  the body we create would look as though it was created far too late,
281
      --  and this could cause problems with elaboration order analysis,
282
      --  particularly in connection with instantiations.
283
 
284
      N          : constant Node_Id := Unit_Declaration_Node (New_S);
285
      Nam        : constant Node_Id := Name (N);
286
      Old_S      : Entity_Id;
287
      Spec       : constant Node_Id := New_Copy_Tree (Specification (Decl));
288
      Actuals    : List_Id := No_List;
289
      Call_Node  : Node_Id;
290
      Call_Name  : Node_Id;
291
      Body_Node  : Node_Id;
292
      Formal     : Entity_Id;
293
      O_Formal   : Entity_Id;
294
      Param_Spec : Node_Id;
295
 
296
      Pref : Node_Id := Empty;
297
      --  If the renamed entity is a primitive operation given in prefix form,
298
      --  the prefix is the target object and it has to be added as the first
299
      --  actual in the generated call.
300
 
301
   begin
302
      --  Determine the entity being renamed, which is the target of the call
303
      --  statement. If the name is an explicit dereference, this is a renaming
304
      --  of a subprogram type rather than a subprogram. The name itself is
305
      --  fully analyzed.
306
 
307
      if Nkind (Nam) = N_Selected_Component then
308
         Old_S := Entity (Selector_Name (Nam));
309
 
310
      elsif Nkind (Nam) = N_Explicit_Dereference then
311
         Old_S := Etype (Nam);
312
 
313
      elsif Nkind (Nam) = N_Indexed_Component then
314
         if Is_Entity_Name (Prefix (Nam)) then
315
            Old_S := Entity (Prefix (Nam));
316
         else
317
            Old_S := Entity (Selector_Name (Prefix (Nam)));
318
         end if;
319
 
320
      elsif Nkind (Nam) = N_Character_Literal then
321
         Old_S := Etype (New_S);
322
 
323
      else
324
         Old_S := Entity (Nam);
325
      end if;
326
 
327
      if Is_Entity_Name (Nam) then
328
 
329
         --  If the renamed entity is a predefined operator, retain full name
330
         --  to ensure its visibility.
331
 
332
         if Ekind (Old_S) = E_Operator
333
           and then Nkind (Nam) = N_Expanded_Name
334
         then
335
            Call_Name := New_Copy (Name (N));
336
         else
337
            Call_Name := New_Reference_To (Old_S, Loc);
338
         end if;
339
 
340
      else
341
         if Nkind (Nam) = N_Selected_Component
342
           and then Present (First_Formal (Old_S))
343
           and then
344
             (Is_Controlling_Formal (First_Formal (Old_S))
345
                or else Is_Class_Wide_Type (Etype (First_Formal (Old_S))))
346
         then
347
 
348
            --  Retrieve the target object, to be added as a first actual
349
            --  in the call.
350
 
351
            Call_Name := New_Occurrence_Of (Old_S, Loc);
352
            Pref := Prefix (Nam);
353
 
354
         else
355
            Call_Name := New_Copy (Name (N));
356
         end if;
357
 
358
         --  Original name may have been overloaded, but is fully resolved now
359
 
360
         Set_Is_Overloaded (Call_Name, False);
361
      end if;
362
 
363
      --  For simple renamings, subsequent calls can be expanded directly as
364
      --  calls to the renamed entity. The body must be generated in any case
365
      --  for calls that may appear elsewhere. This is not done in the case
366
      --  where the subprogram is an instantiation because the actual proper
367
      --  body has not been built yet.
368
 
369
      if Ekind_In (Old_S, E_Function, E_Procedure)
370
        and then Nkind (Decl) = N_Subprogram_Declaration
371
        and then not Is_Generic_Instance (Old_S)
372
      then
373
         Set_Body_To_Inline (Decl, Old_S);
374
      end if;
375
 
376
      --  The body generated for this renaming is an internal artifact, and
377
      --  does not  constitute a freeze point for the called entity.
378
 
379
      Set_Must_Not_Freeze (Call_Name);
380
 
381
      Formal := First_Formal (Defining_Entity (Decl));
382
 
383
      if Present (Pref) then
384
         declare
385
            Pref_Type : constant Entity_Id := Etype (Pref);
386
            Form_Type : constant Entity_Id := Etype (First_Formal (Old_S));
387
 
388
         begin
389
            --  The controlling formal may be an access parameter, or the
390
            --  actual may be an access value, so adjust accordingly.
391
 
392
            if Is_Access_Type (Pref_Type)
393
              and then not Is_Access_Type (Form_Type)
394
            then
395
               Actuals := New_List
396
                 (Make_Explicit_Dereference (Loc, Relocate_Node (Pref)));
397
 
398
            elsif Is_Access_Type (Form_Type)
399
              and then not Is_Access_Type (Pref)
400
            then
401
               Actuals := New_List
402
                 (Make_Attribute_Reference (Loc,
403
                   Attribute_Name => Name_Access,
404
                   Prefix => Relocate_Node (Pref)));
405
            else
406
               Actuals := New_List (Pref);
407
            end if;
408
         end;
409
 
410
      elsif Present (Formal) then
411
         Actuals := New_List;
412
 
413
      else
414
         Actuals := No_List;
415
      end if;
416
 
417
      if Present (Formal) then
418
         while Present (Formal) loop
419
            Append (New_Reference_To (Formal, Loc), Actuals);
420
            Next_Formal (Formal);
421
         end loop;
422
      end if;
423
 
424
      --  If the renamed entity is an entry, inherit its profile. For other
425
      --  renamings as bodies, both profiles must be subtype conformant, so it
426
      --  is not necessary to replace the profile given in the declaration.
427
      --  However, default values that are aggregates are rewritten when
428
      --  partially analyzed, so we recover the original aggregate to insure
429
      --  that subsequent conformity checking works. Similarly, if the default
430
      --  expression was constant-folded, recover the original expression.
431
 
432
      Formal := First_Formal (Defining_Entity (Decl));
433
 
434
      if Present (Formal) then
435
         O_Formal := First_Formal (Old_S);
436
         Param_Spec := First (Parameter_Specifications (Spec));
437
         while Present (Formal) loop
438
            if Is_Entry (Old_S) then
439
               if Nkind (Parameter_Type (Param_Spec)) /=
440
                                                    N_Access_Definition
441
               then
442
                  Set_Etype (Formal, Etype (O_Formal));
443
                  Set_Entity (Parameter_Type (Param_Spec), Etype (O_Formal));
444
               end if;
445
 
446
            elsif Nkind (Default_Value (O_Formal)) = N_Aggregate
447
              or else Nkind (Original_Node (Default_Value (O_Formal))) /=
448
                                           Nkind (Default_Value (O_Formal))
449
            then
450
               Set_Expression (Param_Spec,
451
                 New_Copy_Tree (Original_Node (Default_Value (O_Formal))));
452
            end if;
453
 
454
            Next_Formal (Formal);
455
            Next_Formal (O_Formal);
456
            Next (Param_Spec);
457
         end loop;
458
      end if;
459
 
460
      --  If the renamed entity is a function, the generated body contains a
461
      --  return statement. Otherwise, build a procedure call. If the entity is
462
      --  an entry, subsequent analysis of the call will transform it into the
463
      --  proper entry or protected operation call. If the renamed entity is
464
      --  a character literal, return it directly.
465
 
466
      if Ekind (Old_S) = E_Function
467
        or else Ekind (Old_S) = E_Operator
468
        or else (Ekind (Old_S) = E_Subprogram_Type
469
                  and then Etype (Old_S) /= Standard_Void_Type)
470
      then
471
         Call_Node :=
472
           Make_Simple_Return_Statement (Loc,
473
              Expression =>
474
                Make_Function_Call (Loc,
475
                  Name => Call_Name,
476
                  Parameter_Associations => Actuals));
477
 
478
      elsif Ekind (Old_S) = E_Enumeration_Literal then
479
         Call_Node :=
480
           Make_Simple_Return_Statement (Loc,
481
              Expression => New_Occurrence_Of (Old_S, Loc));
482
 
483
      elsif Nkind (Nam) = N_Character_Literal then
484
         Call_Node :=
485
           Make_Simple_Return_Statement (Loc,
486
             Expression => Call_Name);
487
 
488
      else
489
         Call_Node :=
490
           Make_Procedure_Call_Statement (Loc,
491
             Name => Call_Name,
492
             Parameter_Associations => Actuals);
493
      end if;
494
 
495
      --  Create entities for subprogram body and formals
496
 
497
      Set_Defining_Unit_Name (Spec,
498
        Make_Defining_Identifier (Loc, Chars => Chars (New_S)));
499
 
500
      Param_Spec := First (Parameter_Specifications (Spec));
501
      while Present (Param_Spec) loop
502
         Set_Defining_Identifier (Param_Spec,
503
           Make_Defining_Identifier (Loc,
504
             Chars => Chars (Defining_Identifier (Param_Spec))));
505
         Next (Param_Spec);
506
      end loop;
507
 
508
      Body_Node :=
509
        Make_Subprogram_Body (Loc,
510
          Specification => Spec,
511
          Declarations => New_List,
512
          Handled_Statement_Sequence =>
513
            Make_Handled_Sequence_Of_Statements (Loc,
514
              Statements => New_List (Call_Node)));
515
 
516
      if Nkind (Decl) /= N_Subprogram_Declaration then
517
         Rewrite (N,
518
           Make_Subprogram_Declaration (Loc,
519
             Specification => Specification (N)));
520
      end if;
521
 
522
      --  Link the body to the entity whose declaration it completes. If
523
      --  the body is analyzed when the renamed entity is frozen, it may
524
      --  be necessary to restore the proper scope (see package Exp_Ch13).
525
 
526
      if Nkind (N) =  N_Subprogram_Renaming_Declaration
527
        and then Present (Corresponding_Spec (N))
528
      then
529
         Set_Corresponding_Spec (Body_Node, Corresponding_Spec (N));
530
      else
531
         Set_Corresponding_Spec (Body_Node, New_S);
532
      end if;
533
 
534
      return Body_Node;
535
   end Build_Renamed_Body;
536
 
537
   --------------------------
538
   -- Check_Address_Clause --
539
   --------------------------
540
 
541
   procedure Check_Address_Clause (E : Entity_Id) is
542
      Addr : constant Node_Id   := Address_Clause (E);
543
      Expr : Node_Id;
544
      Decl : constant Node_Id   := Declaration_Node (E);
545
      Typ  : constant Entity_Id := Etype (E);
546
 
547
   begin
548
      if Present (Addr) then
549
         Expr := Expression (Addr);
550
 
551
         if Needs_Constant_Address (Decl, Typ) then
552
            Check_Constant_Address_Clause (Expr, E);
553
 
554
            --  Has_Delayed_Freeze was set on E when the address clause was
555
            --  analyzed. Reset the flag now unless freeze actions were
556
            --  attached to it in the mean time.
557
 
558
            if No (Freeze_Node (E)) then
559
               Set_Has_Delayed_Freeze (E, False);
560
            end if;
561
         end if;
562
 
563
         --  If Rep_Clauses are to be ignored, remove address clause from
564
         --  list attached to entity, because it may be illegal for gigi,
565
         --  for example by breaking order of elaboration..
566
 
567
         if Ignore_Rep_Clauses then
568
            declare
569
               Rep : Node_Id;
570
 
571
            begin
572
               Rep := First_Rep_Item (E);
573
 
574
               if Rep = Addr then
575
                  Set_First_Rep_Item (E, Next_Rep_Item (Addr));
576
 
577
               else
578
                  while Present (Rep)
579
                    and then Next_Rep_Item (Rep) /= Addr
580
                  loop
581
                     Rep := Next_Rep_Item (Rep);
582
                  end loop;
583
               end if;
584
 
585
               if Present (Rep) then
586
                  Set_Next_Rep_Item (Rep, Next_Rep_Item (Addr));
587
               end if;
588
            end;
589
 
590
            Rewrite (Addr, Make_Null_Statement (Sloc (E)));
591
 
592
         elsif not Error_Posted (Expr)
593
           and then not Needs_Finalization (Typ)
594
         then
595
            Warn_Overlay (Expr, Typ, Name (Addr));
596
         end if;
597
      end if;
598
   end Check_Address_Clause;
599
 
600
   -----------------------------
601
   -- Check_Compile_Time_Size --
602
   -----------------------------
603
 
604
   procedure Check_Compile_Time_Size (T : Entity_Id) is
605
 
606
      procedure Set_Small_Size (T : Entity_Id; S : Uint);
607
      --  Sets the compile time known size (32 bits or less) in the Esize
608
      --  field, of T checking for a size clause that was given which attempts
609
      --  to give a smaller size, and also checking for an alignment clause.
610
 
611
      function Size_Known (T : Entity_Id) return Boolean;
612
      --  Recursive function that does all the work
613
 
614
      function Static_Discriminated_Components (T : Entity_Id) return Boolean;
615
      --  If T is a constrained subtype, its size is not known if any of its
616
      --  discriminant constraints is not static and it is not a null record.
617
      --  The test is conservative and doesn't check that the components are
618
      --  in fact constrained by non-static discriminant values. Could be made
619
      --  more precise ???
620
 
621
      --------------------
622
      -- Set_Small_Size --
623
      --------------------
624
 
625
      procedure Set_Small_Size (T : Entity_Id; S : Uint) is
626
      begin
627
         if S > 32 then
628
            return;
629
 
630
         --  Check for bad size clause given
631
 
632
         elsif Has_Size_Clause (T) then
633
            if RM_Size (T) < S then
634
               Error_Msg_Uint_1 := S;
635
               Error_Msg_NE
636
                 ("size for& too small, minimum allowed is ^",
637
                  Size_Clause (T), T);
638
            end if;
639
 
640
         --  Set size if not set already
641
 
642
         elsif Unknown_RM_Size (T) then
643
            Set_RM_Size (T, S);
644
         end if;
645
      end Set_Small_Size;
646
 
647
      ----------------
648
      -- Size_Known --
649
      ----------------
650
 
651
      function Size_Known (T : Entity_Id) return Boolean is
652
         Index : Entity_Id;
653
         Comp  : Entity_Id;
654
         Ctyp  : Entity_Id;
655
         Low   : Node_Id;
656
         High  : Node_Id;
657
 
658
      begin
659
         if Size_Known_At_Compile_Time (T) then
660
            return True;
661
 
662
         --  Always True for scalar types. This is true even for generic formal
663
         --  scalar types. We used to return False in the latter case, but the
664
         --  size is known at compile time, even in the template, we just do
665
         --  not know the exact size but that's not the point of this routine.
666
 
667
         elsif Is_Scalar_Type (T)
668
           or else Is_Task_Type (T)
669
         then
670
            return True;
671
 
672
         --  Array types
673
 
674
         elsif Is_Array_Type (T) then
675
 
676
            --  String literals always have known size, and we can set it
677
 
678
            if Ekind (T) = E_String_Literal_Subtype then
679
               Set_Small_Size (T, Component_Size (T)
680
                               * String_Literal_Length (T));
681
               return True;
682
 
683
            --  Unconstrained types never have known at compile time size
684
 
685
            elsif not Is_Constrained (T) then
686
               return False;
687
 
688
            --  Don't do any recursion on type with error posted, since we may
689
            --  have a malformed type that leads us into a loop.
690
 
691
            elsif Error_Posted (T) then
692
               return False;
693
 
694
            --  Otherwise if component size unknown, then array size unknown
695
 
696
            elsif not Size_Known (Component_Type (T)) then
697
               return False;
698
            end if;
699
 
700
            --  Check for all indexes static, and also compute possible size
701
            --  (in case it is less than 32 and may be packable).
702
 
703
            declare
704
               Esiz : Uint := Component_Size (T);
705
               Dim  : Uint;
706
 
707
            begin
708
               Index := First_Index (T);
709
               while Present (Index) loop
710
                  if Nkind (Index) = N_Range then
711
                     Get_Index_Bounds (Index, Low, High);
712
 
713
                  elsif Error_Posted (Scalar_Range (Etype (Index))) then
714
                     return False;
715
 
716
                  else
717
                     Low  := Type_Low_Bound (Etype (Index));
718
                     High := Type_High_Bound (Etype (Index));
719
                  end if;
720
 
721
                  if not Compile_Time_Known_Value (Low)
722
                    or else not Compile_Time_Known_Value (High)
723
                    or else Etype (Index) = Any_Type
724
                  then
725
                     return False;
726
 
727
                  else
728
                     Dim := Expr_Value (High) - Expr_Value (Low) + 1;
729
 
730
                     if Dim >= 0 then
731
                        Esiz := Esiz * Dim;
732
                     else
733
                        Esiz := Uint_0;
734
                     end if;
735
                  end if;
736
 
737
                  Next_Index (Index);
738
               end loop;
739
 
740
               Set_Small_Size (T, Esiz);
741
               return True;
742
            end;
743
 
744
         --  Access types always have known at compile time sizes
745
 
746
         elsif Is_Access_Type (T) then
747
            return True;
748
 
749
         --  For non-generic private types, go to underlying type if present
750
 
751
         elsif Is_Private_Type (T)
752
           and then not Is_Generic_Type (T)
753
           and then Present (Underlying_Type (T))
754
         then
755
            --  Don't do any recursion on type with error posted, since we may
756
            --  have a malformed type that leads us into a loop.
757
 
758
            if Error_Posted (T) then
759
               return False;
760
            else
761
               return Size_Known (Underlying_Type (T));
762
            end if;
763
 
764
         --  Record types
765
 
766
         elsif Is_Record_Type (T) then
767
 
768
            --  A class-wide type is never considered to have a known size
769
 
770
            if Is_Class_Wide_Type (T) then
771
               return False;
772
 
773
            --  A subtype of a variant record must not have non-static
774
            --  discriminated components.
775
 
776
            elsif T /= Base_Type (T)
777
              and then not Static_Discriminated_Components (T)
778
            then
779
               return False;
780
 
781
            --  Don't do any recursion on type with error posted, since we may
782
            --  have a malformed type that leads us into a loop.
783
 
784
            elsif Error_Posted (T) then
785
               return False;
786
            end if;
787
 
788
            --  Now look at the components of the record
789
 
790
            declare
791
               --  The following two variables are used to keep track of the
792
               --  size of packed records if we can tell the size of the packed
793
               --  record in the front end. Packed_Size_Known is True if so far
794
               --  we can figure out the size. It is initialized to True for a
795
               --  packed record, unless the record has discriminants. The
796
               --  reason we eliminate the discriminated case is that we don't
797
               --  know the way the back end lays out discriminated packed
798
               --  records. If Packed_Size_Known is True, then Packed_Size is
799
               --  the size in bits so far.
800
 
801
               Packed_Size_Known : Boolean :=
802
                                     Is_Packed (T)
803
                                       and then not Has_Discriminants (T);
804
 
805
               Packed_Size : Uint := Uint_0;
806
 
807
            begin
808
               --  Test for variant part present
809
 
810
               if Has_Discriminants (T)
811
                 and then Present (Parent (T))
812
                 and then Nkind (Parent (T)) = N_Full_Type_Declaration
813
                 and then Nkind (Type_Definition (Parent (T))) =
814
                                               N_Record_Definition
815
                 and then not Null_Present (Type_Definition (Parent (T)))
816
                 and then Present (Variant_Part
817
                            (Component_List (Type_Definition (Parent (T)))))
818
               then
819
                  --  If variant part is present, and type is unconstrained,
820
                  --  then we must have defaulted discriminants, or a size
821
                  --  clause must be present for the type, or else the size
822
                  --  is definitely not known at compile time.
823
 
824
                  if not Is_Constrained (T)
825
                    and then
826
                      No (Discriminant_Default_Value (First_Discriminant (T)))
827
                    and then Unknown_RM_Size (T)
828
                  then
829
                     return False;
830
                  end if;
831
               end if;
832
 
833
               --  Loop through components
834
 
835
               Comp := First_Component_Or_Discriminant (T);
836
               while Present (Comp) loop
837
                  Ctyp := Etype (Comp);
838
 
839
                  --  We do not know the packed size if there is a component
840
                  --  clause present (we possibly could, but this would only
841
                  --  help in the case of a record with partial rep clauses.
842
                  --  That's because in the case of full rep clauses, the
843
                  --  size gets figured out anyway by a different circuit).
844
 
845
                  if Present (Component_Clause (Comp)) then
846
                     Packed_Size_Known := False;
847
                  end if;
848
 
849
                  --  We need to identify a component that is an array where
850
                  --  the index type is an enumeration type with non-standard
851
                  --  representation, and some bound of the type depends on a
852
                  --  discriminant.
853
 
854
                  --  This is because gigi computes the size by doing a
855
                  --  substitution of the appropriate discriminant value in
856
                  --  the size expression for the base type, and gigi is not
857
                  --  clever enough to evaluate the resulting expression (which
858
                  --  involves a call to rep_to_pos) at compile time.
859
 
860
                  --  It would be nice if gigi would either recognize that
861
                  --  this expression can be computed at compile time, or
862
                  --  alternatively figured out the size from the subtype
863
                  --  directly, where all the information is at hand ???
864
 
865
                  if Is_Array_Type (Etype (Comp))
866
                    and then Present (Packed_Array_Type (Etype (Comp)))
867
                  then
868
                     declare
869
                        Ocomp  : constant Entity_Id :=
870
                                   Original_Record_Component (Comp);
871
                        OCtyp  : constant Entity_Id := Etype (Ocomp);
872
                        Ind    : Node_Id;
873
                        Indtyp : Entity_Id;
874
                        Lo, Hi : Node_Id;
875
 
876
                     begin
877
                        Ind := First_Index (OCtyp);
878
                        while Present (Ind) loop
879
                           Indtyp := Etype (Ind);
880
 
881
                           if Is_Enumeration_Type (Indtyp)
882
                             and then Has_Non_Standard_Rep (Indtyp)
883
                           then
884
                              Lo := Type_Low_Bound  (Indtyp);
885
                              Hi := Type_High_Bound (Indtyp);
886
 
887
                              if Is_Entity_Name (Lo)
888
                                and then Ekind (Entity (Lo)) = E_Discriminant
889
                              then
890
                                 return False;
891
 
892
                              elsif Is_Entity_Name (Hi)
893
                                and then Ekind (Entity (Hi)) = E_Discriminant
894
                              then
895
                                 return False;
896
                              end if;
897
                           end if;
898
 
899
                           Next_Index (Ind);
900
                        end loop;
901
                     end;
902
                  end if;
903
 
904
                  --  Clearly size of record is not known if the size of one of
905
                  --  the components is not known.
906
 
907
                  if not Size_Known (Ctyp) then
908
                     return False;
909
                  end if;
910
 
911
                  --  Accumulate packed size if possible
912
 
913
                  if Packed_Size_Known then
914
 
915
                     --  We can only deal with elementary types, since for
916
                     --  non-elementary components, alignment enters into the
917
                     --  picture, and we don't know enough to handle proper
918
                     --  alignment in this context. Packed arrays count as
919
                     --  elementary if the representation is a modular type.
920
 
921
                     if Is_Elementary_Type (Ctyp)
922
                       or else (Is_Array_Type (Ctyp)
923
                                 and then Present (Packed_Array_Type (Ctyp))
924
                                 and then Is_Modular_Integer_Type
925
                                            (Packed_Array_Type (Ctyp)))
926
                     then
927
                        --  If RM_Size is known and static, then we can keep
928
                        --  accumulating the packed size.
929
 
930
                        if Known_Static_RM_Size (Ctyp) then
931
 
932
                           --  A little glitch, to be removed sometime ???
933
                           --  gigi does not understand zero sizes yet.
934
 
935
                           if RM_Size (Ctyp) = Uint_0 then
936
                              Packed_Size_Known := False;
937
 
938
                           --  Normal case where we can keep accumulating the
939
                           --  packed array size.
940
 
941
                           else
942
                              Packed_Size := Packed_Size + RM_Size (Ctyp);
943
                           end if;
944
 
945
                        --  If we have a field whose RM_Size is not known then
946
                        --  we can't figure out the packed size here.
947
 
948
                        else
949
                           Packed_Size_Known := False;
950
                        end if;
951
 
952
                     --  If we have a non-elementary type we can't figure out
953
                     --  the packed array size (alignment issues).
954
 
955
                     else
956
                        Packed_Size_Known := False;
957
                     end if;
958
                  end if;
959
 
960
                  Next_Component_Or_Discriminant (Comp);
961
               end loop;
962
 
963
               if Packed_Size_Known then
964
                  Set_Small_Size (T, Packed_Size);
965
               end if;
966
 
967
               return True;
968
            end;
969
 
970
         --  All other cases, size not known at compile time
971
 
972
         else
973
            return False;
974
         end if;
975
      end Size_Known;
976
 
977
      -------------------------------------
978
      -- Static_Discriminated_Components --
979
      -------------------------------------
980
 
981
      function Static_Discriminated_Components
982
        (T : Entity_Id) return Boolean
983
      is
984
         Constraint : Elmt_Id;
985
 
986
      begin
987
         if Has_Discriminants (T)
988
           and then Present (Discriminant_Constraint (T))
989
           and then Present (First_Component (T))
990
         then
991
            Constraint := First_Elmt (Discriminant_Constraint (T));
992
            while Present (Constraint) loop
993
               if not Compile_Time_Known_Value (Node (Constraint)) then
994
                  return False;
995
               end if;
996
 
997
               Next_Elmt (Constraint);
998
            end loop;
999
         end if;
1000
 
1001
         return True;
1002
      end Static_Discriminated_Components;
1003
 
1004
   --  Start of processing for Check_Compile_Time_Size
1005
 
1006
   begin
1007
      Set_Size_Known_At_Compile_Time (T, Size_Known (T));
1008
   end Check_Compile_Time_Size;
1009
 
1010
   -----------------------------
1011
   -- Check_Debug_Info_Needed --
1012
   -----------------------------
1013
 
1014
   procedure Check_Debug_Info_Needed (T : Entity_Id) is
1015
   begin
1016
      if Debug_Info_Off (T) then
1017
         return;
1018
 
1019
      elsif Comes_From_Source (T)
1020
        or else Debug_Generated_Code
1021
        or else Debug_Flag_VV
1022
        or else Needs_Debug_Info (T)
1023
      then
1024
         Set_Debug_Info_Needed (T);
1025
      end if;
1026
   end Check_Debug_Info_Needed;
1027
 
1028
   ----------------------------
1029
   -- Check_Strict_Alignment --
1030
   ----------------------------
1031
 
1032
   procedure Check_Strict_Alignment (E : Entity_Id) is
1033
      Comp  : Entity_Id;
1034
 
1035
   begin
1036
      if Is_Tagged_Type (E) or else Is_Concurrent_Type (E) then
1037
         Set_Strict_Alignment (E);
1038
 
1039
      elsif Is_Array_Type (E) then
1040
         Set_Strict_Alignment (E, Strict_Alignment (Component_Type (E)));
1041
 
1042
      elsif Is_Record_Type (E) then
1043
         if Is_Limited_Record (E) then
1044
            Set_Strict_Alignment (E);
1045
            return;
1046
         end if;
1047
 
1048
         Comp := First_Component (E);
1049
         while Present (Comp) loop
1050
            if not Is_Type (Comp)
1051
              and then (Strict_Alignment (Etype (Comp))
1052
                         or else Is_Aliased (Comp))
1053
            then
1054
               Set_Strict_Alignment (E);
1055
               return;
1056
            end if;
1057
 
1058
            Next_Component (Comp);
1059
         end loop;
1060
      end if;
1061
   end Check_Strict_Alignment;
1062
 
1063
   -------------------------
1064
   -- Check_Unsigned_Type --
1065
   -------------------------
1066
 
1067
   procedure Check_Unsigned_Type (E : Entity_Id) is
1068
      Ancestor : Entity_Id;
1069
      Lo_Bound : Node_Id;
1070
      Btyp     : Entity_Id;
1071
 
1072
   begin
1073
      if not Is_Discrete_Or_Fixed_Point_Type (E) then
1074
         return;
1075
      end if;
1076
 
1077
      --  Do not attempt to analyze case where range was in error
1078
 
1079
      if No (Scalar_Range (E))
1080
        or else Error_Posted (Scalar_Range (E))
1081
      then
1082
         return;
1083
      end if;
1084
 
1085
      --  The situation that is non trivial is something like
1086
 
1087
      --     subtype x1 is integer range -10 .. +10;
1088
      --     subtype x2 is x1 range 0 .. V1;
1089
      --     subtype x3 is x2 range V2 .. V3;
1090
      --     subtype x4 is x3 range V4 .. V5;
1091
 
1092
      --  where Vn are variables. Here the base type is signed, but we still
1093
      --  know that x4 is unsigned because of the lower bound of x2.
1094
 
1095
      --  The only way to deal with this is to look up the ancestor chain
1096
 
1097
      Ancestor := E;
1098
      loop
1099
         if Ancestor = Any_Type or else Etype (Ancestor) = Any_Type then
1100
            return;
1101
         end if;
1102
 
1103
         Lo_Bound := Type_Low_Bound (Ancestor);
1104
 
1105
         if Compile_Time_Known_Value (Lo_Bound) then
1106
 
1107
            if Expr_Rep_Value (Lo_Bound) >= 0 then
1108
               Set_Is_Unsigned_Type (E, True);
1109
            end if;
1110
 
1111
            return;
1112
 
1113
         else
1114
            Ancestor := Ancestor_Subtype (Ancestor);
1115
 
1116
            --  If no ancestor had a static lower bound, go to base type
1117
 
1118
            if No (Ancestor) then
1119
 
1120
               --  Note: the reason we still check for a compile time known
1121
               --  value for the base type is that at least in the case of
1122
               --  generic formals, we can have bounds that fail this test,
1123
               --  and there may be other cases in error situations.
1124
 
1125
               Btyp := Base_Type (E);
1126
 
1127
               if Btyp = Any_Type or else Etype (Btyp) = Any_Type then
1128
                  return;
1129
               end if;
1130
 
1131
               Lo_Bound := Type_Low_Bound (Base_Type (E));
1132
 
1133
               if Compile_Time_Known_Value (Lo_Bound)
1134
                 and then Expr_Rep_Value (Lo_Bound) >= 0
1135
               then
1136
                  Set_Is_Unsigned_Type (E, True);
1137
               end if;
1138
 
1139
               return;
1140
            end if;
1141
         end if;
1142
      end loop;
1143
   end Check_Unsigned_Type;
1144
 
1145
   -------------------------
1146
   -- Is_Atomic_Aggregate --
1147
   -------------------------
1148
 
1149
   function  Is_Atomic_Aggregate
1150
     (E   : Entity_Id;
1151
      Typ : Entity_Id) return Boolean
1152
   is
1153
      Loc   : constant Source_Ptr := Sloc (E);
1154
      New_N : Node_Id;
1155
      Par   : Node_Id;
1156
      Temp  : Entity_Id;
1157
 
1158
   begin
1159
      Par := Parent (E);
1160
 
1161
      --  Array may be qualified, so find outer context
1162
 
1163
      if Nkind (Par) = N_Qualified_Expression then
1164
         Par := Parent (Par);
1165
      end if;
1166
 
1167
      if Nkind_In (Par, N_Object_Declaration, N_Assignment_Statement)
1168
        and then Comes_From_Source (Par)
1169
      then
1170
         Temp := Make_Temporary (Loc, 'T', E);
1171
         New_N :=
1172
           Make_Object_Declaration (Loc,
1173
             Defining_Identifier => Temp,
1174
             Object_Definition   => New_Occurrence_Of (Typ, Loc),
1175
             Expression          => Relocate_Node (E));
1176
         Insert_Before (Par, New_N);
1177
         Analyze (New_N);
1178
 
1179
         Set_Expression (Par, New_Occurrence_Of (Temp, Loc));
1180
         return True;
1181
 
1182
      else
1183
         return False;
1184
      end if;
1185
   end Is_Atomic_Aggregate;
1186
 
1187
   ----------------
1188
   -- Freeze_All --
1189
   ----------------
1190
 
1191
   --  Note: the easy coding for this procedure would be to just build a
1192
   --  single list of freeze nodes and then insert them and analyze them
1193
   --  all at once. This won't work, because the analysis of earlier freeze
1194
   --  nodes may recursively freeze types which would otherwise appear later
1195
   --  on in the freeze list. So we must analyze and expand the freeze nodes
1196
   --  as they are generated.
1197
 
1198
   procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is
1199
      E     : Entity_Id;
1200
      Decl  : Node_Id;
1201
 
1202
      procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id);
1203
      --  This is the internal recursive routine that does freezing of entities
1204
      --  (but NOT the analysis of default expressions, which should not be
1205
      --  recursive, we don't want to analyze those till we are sure that ALL
1206
      --  the types are frozen).
1207
 
1208
      --------------------
1209
      -- Freeze_All_Ent --
1210
      --------------------
1211
 
1212
      procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id) is
1213
         E     : Entity_Id;
1214
         Flist : List_Id;
1215
         Lastn : Node_Id;
1216
 
1217
         procedure Process_Flist;
1218
         --  If freeze nodes are present, insert and analyze, and reset cursor
1219
         --  for next insertion.
1220
 
1221
         -------------------
1222
         -- Process_Flist --
1223
         -------------------
1224
 
1225
         procedure Process_Flist is
1226
         begin
1227
            if Is_Non_Empty_List (Flist) then
1228
               Lastn := Next (After);
1229
               Insert_List_After_And_Analyze (After, Flist);
1230
 
1231
               if Present (Lastn) then
1232
                  After := Prev (Lastn);
1233
               else
1234
                  After := Last (List_Containing (After));
1235
               end if;
1236
            end if;
1237
         end Process_Flist;
1238
 
1239
      --  Start or processing for Freeze_All_Ent
1240
 
1241
      begin
1242
         E := From;
1243
         while Present (E) loop
1244
 
1245
            --  If the entity is an inner package which is not a package
1246
            --  renaming, then its entities must be frozen at this point. Note
1247
            --  that such entities do NOT get frozen at the end of the nested
1248
            --  package itself (only library packages freeze).
1249
 
1250
            --  Same is true for task declarations, where anonymous records
1251
            --  created for entry parameters must be frozen.
1252
 
1253
            if Ekind (E) = E_Package
1254
              and then No (Renamed_Object (E))
1255
              and then not Is_Child_Unit (E)
1256
              and then not Is_Frozen (E)
1257
            then
1258
               Push_Scope (E);
1259
               Install_Visible_Declarations (E);
1260
               Install_Private_Declarations (E);
1261
 
1262
               Freeze_All (First_Entity (E), After);
1263
 
1264
               End_Package_Scope (E);
1265
 
1266
               if Is_Generic_Instance (E)
1267
                 and then Has_Delayed_Freeze (E)
1268
               then
1269
                  Set_Has_Delayed_Freeze (E, False);
1270
                  Expand_N_Package_Declaration (Unit_Declaration_Node (E));
1271
               end if;
1272
 
1273
            elsif Ekind (E) in Task_Kind
1274
              and then
1275
                (Nkind (Parent (E)) = N_Task_Type_Declaration
1276
                   or else
1277
                 Nkind (Parent (E)) = N_Single_Task_Declaration)
1278
            then
1279
               Push_Scope (E);
1280
               Freeze_All (First_Entity (E), After);
1281
               End_Scope;
1282
 
1283
            --  For a derived tagged type, we must ensure that all the
1284
            --  primitive operations of the parent have been frozen, so that
1285
            --  their addresses will be in the parent's dispatch table at the
1286
            --  point it is inherited.
1287
 
1288
            elsif Ekind (E) = E_Record_Type
1289
              and then Is_Tagged_Type (E)
1290
              and then Is_Tagged_Type (Etype (E))
1291
              and then Is_Derived_Type (E)
1292
            then
1293
               declare
1294
                  Prim_List : constant Elist_Id :=
1295
                               Primitive_Operations (Etype (E));
1296
 
1297
                  Prim : Elmt_Id;
1298
                  Subp : Entity_Id;
1299
 
1300
               begin
1301
                  Prim := First_Elmt (Prim_List);
1302
                  while Present (Prim) loop
1303
                     Subp := Node (Prim);
1304
 
1305
                     if Comes_From_Source (Subp)
1306
                       and then not Is_Frozen (Subp)
1307
                     then
1308
                        Flist := Freeze_Entity (Subp, After);
1309
                        Process_Flist;
1310
                     end if;
1311
 
1312
                     Next_Elmt (Prim);
1313
                  end loop;
1314
               end;
1315
            end if;
1316
 
1317
            if not Is_Frozen (E) then
1318
               Flist := Freeze_Entity (E, After);
1319
               Process_Flist;
1320
 
1321
            --  If already frozen, and there are delayed aspects, this is where
1322
            --  we do the visibility check for these aspects (see Sem_Ch13 spec
1323
            --  for a description of how we handle aspect visibility).
1324
 
1325
            elsif Has_Delayed_Aspects (E) then
1326
               declare
1327
                  Ritem : Node_Id;
1328
 
1329
               begin
1330
                  Ritem := First_Rep_Item (E);
1331
                  while Present (Ritem) loop
1332
                     if Nkind (Ritem) = N_Aspect_Specification
1333
                       and then Entity (Ritem) = E
1334
                       and then Is_Delayed_Aspect (Ritem)
1335
                     then
1336
                        Check_Aspect_At_End_Of_Declarations (Ritem);
1337
                     end if;
1338
 
1339
                     Ritem := Next_Rep_Item (Ritem);
1340
                  end loop;
1341
               end;
1342
            end if;
1343
 
1344
            --  If an incomplete type is still not frozen, this may be a
1345
            --  premature freezing because of a body declaration that follows.
1346
            --  Indicate where the freezing took place. Freezing will happen
1347
            --  if the body comes from source, but not if it is internally
1348
            --  generated, for example as the body of a type invariant.
1349
 
1350
            --  If the freezing is caused by the end of the current declarative
1351
            --  part, it is a Taft Amendment type, and there is no error.
1352
 
1353
            if not Is_Frozen (E)
1354
              and then Ekind (E) = E_Incomplete_Type
1355
            then
1356
               declare
1357
                  Bod : constant Node_Id := Next (After);
1358
 
1359
               begin
1360
                  --  The presence of a body freezes all entities previously
1361
                  --  declared in the current list of declarations, but this
1362
                  --  does not apply if the body does not come from source.
1363
                  --  A type invariant is transformed into a subprogram body
1364
                  --  which is placed at the end of the private part of the
1365
                  --  current package, but this body does not freeze incomplete
1366
                  --  types that may be declared in this private part.
1367
 
1368
                  if (Nkind_In (Bod, N_Subprogram_Body,
1369
                                     N_Entry_Body,
1370
                                     N_Package_Body,
1371
                                     N_Protected_Body,
1372
                                     N_Task_Body)
1373
                        or else Nkind (Bod) in N_Body_Stub)
1374
                    and then
1375
                      List_Containing (After) = List_Containing (Parent (E))
1376
                    and then Comes_From_Source (Bod)
1377
                  then
1378
                     Error_Msg_Sloc := Sloc (Next (After));
1379
                     Error_Msg_NE
1380
                       ("type& is frozen# before its full declaration",
1381
                         Parent (E), E);
1382
                  end if;
1383
               end;
1384
            end if;
1385
 
1386
            Next_Entity (E);
1387
         end loop;
1388
      end Freeze_All_Ent;
1389
 
1390
   --  Start of processing for Freeze_All
1391
 
1392
   begin
1393
      Freeze_All_Ent (From, After);
1394
 
1395
      --  Now that all types are frozen, we can deal with default expressions
1396
      --  that require us to build a default expression functions. This is the
1397
      --  point at which such functions are constructed (after all types that
1398
      --  might be used in such expressions have been frozen).
1399
 
1400
      --  For subprograms that are renaming_as_body, we create the wrapper
1401
      --  bodies as needed.
1402
 
1403
      --  We also add finalization chains to access types whose designated
1404
      --  types are controlled. This is normally done when freezing the type,
1405
      --  but this misses recursive type definitions where the later members
1406
      --  of the recursion introduce controlled components.
1407
 
1408
      --  Loop through entities
1409
 
1410
      E := From;
1411
      while Present (E) loop
1412
         if Is_Subprogram (E) then
1413
 
1414
            if not Default_Expressions_Processed (E) then
1415
               Process_Default_Expressions (E, After);
1416
            end if;
1417
 
1418
            if not Has_Completion (E) then
1419
               Decl := Unit_Declaration_Node (E);
1420
 
1421
               if Nkind (Decl) = N_Subprogram_Renaming_Declaration then
1422
                  if Error_Posted (Decl) then
1423
                     Set_Has_Completion (E);
1424
                  else
1425
                     Build_And_Analyze_Renamed_Body (Decl, E, After);
1426
                  end if;
1427
 
1428
               elsif Nkind (Decl) = N_Subprogram_Declaration
1429
                 and then Present (Corresponding_Body (Decl))
1430
                 and then
1431
                   Nkind (Unit_Declaration_Node (Corresponding_Body (Decl)))
1432
                                          = N_Subprogram_Renaming_Declaration
1433
               then
1434
                  Build_And_Analyze_Renamed_Body
1435
                    (Decl, Corresponding_Body (Decl), After);
1436
               end if;
1437
            end if;
1438
 
1439
         elsif Ekind (E) in Task_Kind
1440
           and then
1441
             (Nkind (Parent (E)) = N_Task_Type_Declaration
1442
                or else
1443
              Nkind (Parent (E)) = N_Single_Task_Declaration)
1444
         then
1445
            declare
1446
               Ent : Entity_Id;
1447
 
1448
            begin
1449
               Ent := First_Entity (E);
1450
               while Present (Ent) loop
1451
                  if Is_Entry (Ent)
1452
                    and then not Default_Expressions_Processed (Ent)
1453
                  then
1454
                     Process_Default_Expressions (Ent, After);
1455
                  end if;
1456
 
1457
                  Next_Entity (Ent);
1458
               end loop;
1459
            end;
1460
 
1461
         --  We add finalization masters to access types whose designated types
1462
         --  require finalization. This is normally done when freezing the
1463
         --  type, but this misses recursive type definitions where the later
1464
         --  members of the recursion introduce controlled components (such as
1465
         --  can happen when incomplete types are involved), as well cases
1466
         --  where a component type is private and the controlled full type
1467
         --  occurs after the access type is frozen. Cases that don't need a
1468
         --  finalization master are generic formal types (the actual type will
1469
         --  have it) and types with Java and CIL conventions, since those are
1470
         --  used for API bindings. (Are there any other cases that should be
1471
         --  excluded here???)
1472
 
1473
         elsif Is_Access_Type (E)
1474
           and then Comes_From_Source (E)
1475
           and then not Is_Generic_Type (E)
1476
           and then Needs_Finalization (Designated_Type (E))
1477
         then
1478
            Build_Finalization_Master (E);
1479
         end if;
1480
 
1481
         Next_Entity (E);
1482
      end loop;
1483
   end Freeze_All;
1484
 
1485
   -----------------------
1486
   -- Freeze_And_Append --
1487
   -----------------------
1488
 
1489
   procedure Freeze_And_Append
1490
     (Ent    : Entity_Id;
1491
      N      : Node_Id;
1492
      Result : in out List_Id)
1493
   is
1494
      L : constant List_Id := Freeze_Entity (Ent, N);
1495
   begin
1496
      if Is_Non_Empty_List (L) then
1497
         if Result = No_List then
1498
            Result := L;
1499
         else
1500
            Append_List (L, Result);
1501
         end if;
1502
      end if;
1503
   end Freeze_And_Append;
1504
 
1505
   -------------------
1506
   -- Freeze_Before --
1507
   -------------------
1508
 
1509
   procedure Freeze_Before (N : Node_Id; T : Entity_Id) is
1510
      Freeze_Nodes : constant List_Id := Freeze_Entity (T, N);
1511
   begin
1512
      if Is_Non_Empty_List (Freeze_Nodes) then
1513
         Insert_Actions (N, Freeze_Nodes);
1514
      end if;
1515
   end Freeze_Before;
1516
 
1517
   -------------------
1518
   -- Freeze_Entity --
1519
   -------------------
1520
 
1521
   function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id is
1522
      Loc    : constant Source_Ptr := Sloc (N);
1523
      Test_E : Entity_Id := E;
1524
      Comp   : Entity_Id;
1525
      F_Node : Node_Id;
1526
      Indx   : Node_Id;
1527
      Formal : Entity_Id;
1528
      Atype  : Entity_Id;
1529
 
1530
      Result : List_Id := No_List;
1531
      --  List of freezing actions, left at No_List if none
1532
 
1533
      Has_Default_Initialization : Boolean := False;
1534
      --  This flag gets set to true for a variable with default initialization
1535
 
1536
      procedure Add_To_Result (N : Node_Id);
1537
      --  N is a freezing action to be appended to the Result
1538
 
1539
      procedure Check_Current_Instance (Comp_Decl : Node_Id);
1540
      --  Check that an Access or Unchecked_Access attribute with a prefix
1541
      --  which is the current instance type can only be applied when the type
1542
      --  is limited.
1543
 
1544
      procedure Check_Suspicious_Modulus (Utype : Entity_Id);
1545
      --  Give warning for modulus of 8, 16, 32, or 64 given as an explicit
1546
      --  integer literal without an explicit corresponding size clause. The
1547
      --  caller has checked that Utype is a modular integer type.
1548
 
1549
      function After_Last_Declaration return Boolean;
1550
      --  If Loc is a freeze_entity that appears after the last declaration
1551
      --  in the scope, inhibit error messages on late completion.
1552
 
1553
      procedure Freeze_Record_Type (Rec : Entity_Id);
1554
      --  Freeze each component, handle some representation clauses, and freeze
1555
      --  primitive operations if this is a tagged type.
1556
 
1557
      -------------------
1558
      -- Add_To_Result --
1559
      -------------------
1560
 
1561
      procedure Add_To_Result (N : Node_Id) is
1562
      begin
1563
         if No (Result) then
1564
            Result := New_List (N);
1565
         else
1566
            Append (N, Result);
1567
         end if;
1568
      end Add_To_Result;
1569
 
1570
      ----------------------------
1571
      -- After_Last_Declaration --
1572
      ----------------------------
1573
 
1574
      function After_Last_Declaration return Boolean is
1575
         Spec : constant Node_Id := Parent (Current_Scope);
1576
      begin
1577
         if Nkind (Spec) = N_Package_Specification then
1578
            if Present (Private_Declarations (Spec)) then
1579
               return Loc >= Sloc (Last (Private_Declarations (Spec)));
1580
            elsif Present (Visible_Declarations (Spec)) then
1581
               return Loc >= Sloc (Last (Visible_Declarations (Spec)));
1582
            else
1583
               return False;
1584
            end if;
1585
         else
1586
            return False;
1587
         end if;
1588
      end After_Last_Declaration;
1589
 
1590
      ----------------------------
1591
      -- Check_Current_Instance --
1592
      ----------------------------
1593
 
1594
      procedure Check_Current_Instance (Comp_Decl : Node_Id) is
1595
 
1596
         function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean;
1597
         --  Determine whether Typ is compatible with the rules for aliased
1598
         --  views of types as defined in RM 3.10 in the various dialects.
1599
 
1600
         function Process (N : Node_Id) return Traverse_Result;
1601
         --  Process routine to apply check to given node
1602
 
1603
         -----------------------------
1604
         -- Is_Aliased_View_Of_Type --
1605
         -----------------------------
1606
 
1607
         function Is_Aliased_View_Of_Type (Typ : Entity_Id) return Boolean is
1608
            Typ_Decl : constant Node_Id := Parent (Typ);
1609
 
1610
         begin
1611
            --  Common case
1612
 
1613
            if Nkind (Typ_Decl) = N_Full_Type_Declaration
1614
              and then Limited_Present (Type_Definition (Typ_Decl))
1615
            then
1616
               return True;
1617
 
1618
            --  The following paragraphs describe what a legal aliased view of
1619
            --  a type is in the various dialects of Ada.
1620
 
1621
            --  Ada 95
1622
 
1623
            --  The current instance of a limited type, and a formal parameter
1624
            --  or generic formal object of a tagged type.
1625
 
1626
            --  Ada 95 limited type
1627
            --    * Type with reserved word "limited"
1628
            --    * A protected or task type
1629
            --    * A composite type with limited component
1630
 
1631
            elsif Ada_Version <= Ada_95 then
1632
               return Is_Limited_Type (Typ);
1633
 
1634
            --  Ada 2005
1635
 
1636
            --  The current instance of a limited tagged type, a protected
1637
            --  type, a task type, or a type that has the reserved word
1638
            --  "limited" in its full definition ... a formal parameter or
1639
            --  generic formal object of a tagged type.
1640
 
1641
            --  Ada 2005 limited type
1642
            --    * Type with reserved word "limited", "synchronized", "task"
1643
            --      or "protected"
1644
            --    * A composite type with limited component
1645
            --    * A derived type whose parent is a non-interface limited type
1646
 
1647
            elsif Ada_Version = Ada_2005 then
1648
               return
1649
                 (Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ))
1650
                   or else
1651
                     (Is_Derived_Type (Typ)
1652
                       and then not Is_Interface (Etype (Typ))
1653
                       and then Is_Limited_Type (Etype (Typ)));
1654
 
1655
            --  Ada 2012 and beyond
1656
 
1657
            --  The current instance of an immutably limited type ... a formal
1658
            --  parameter or generic formal object of a tagged type.
1659
 
1660
            --  Ada 2012 limited type
1661
            --    * Type with reserved word "limited", "synchronized", "task"
1662
            --      or "protected"
1663
            --    * A composite type with limited component
1664
            --    * A derived type whose parent is a non-interface limited type
1665
            --    * An incomplete view
1666
 
1667
            --  Ada 2012 immutably limited type
1668
            --    * Explicitly limited record type
1669
            --    * Record extension with "limited" present
1670
            --    * Non-formal limited private type that is either tagged
1671
            --      or has at least one access discriminant with a default
1672
            --      expression
1673
            --    * Task type, protected type or synchronized interface
1674
            --    * Type derived from immutably limited type
1675
 
1676
            else
1677
               return
1678
                 Is_Immutably_Limited_Type (Typ)
1679
                   or else Is_Incomplete_Type (Typ);
1680
            end if;
1681
         end Is_Aliased_View_Of_Type;
1682
 
1683
         -------------
1684
         -- Process --
1685
         -------------
1686
 
1687
         function Process (N : Node_Id) return Traverse_Result is
1688
         begin
1689
            case Nkind (N) is
1690
               when N_Attribute_Reference =>
1691
                  if (Attribute_Name (N) = Name_Access
1692
                        or else
1693
                      Attribute_Name (N) = Name_Unchecked_Access)
1694
                    and then Is_Entity_Name (Prefix (N))
1695
                    and then Is_Type (Entity (Prefix (N)))
1696
                    and then Entity (Prefix (N)) = E
1697
                  then
1698
                     Error_Msg_N
1699
                       ("current instance must be a limited type", Prefix (N));
1700
                     return Abandon;
1701
                  else
1702
                     return OK;
1703
                  end if;
1704
 
1705
               when others => return OK;
1706
            end case;
1707
         end Process;
1708
 
1709
         procedure Traverse is new Traverse_Proc (Process);
1710
 
1711
         --  Local variables
1712
 
1713
         Rec_Type : constant Entity_Id :=
1714
                      Scope (Defining_Identifier (Comp_Decl));
1715
 
1716
      --  Start of processing for Check_Current_Instance
1717
 
1718
      begin
1719
         if not Is_Aliased_View_Of_Type (Rec_Type) then
1720
            Traverse (Comp_Decl);
1721
         end if;
1722
      end Check_Current_Instance;
1723
 
1724
      ------------------------------
1725
      -- Check_Suspicious_Modulus --
1726
      ------------------------------
1727
 
1728
      procedure Check_Suspicious_Modulus (Utype : Entity_Id) is
1729
         Decl : constant Node_Id := Declaration_Node (Underlying_Type (Utype));
1730
 
1731
      begin
1732
         if Nkind (Decl) = N_Full_Type_Declaration then
1733
            declare
1734
               Tdef : constant Node_Id := Type_Definition (Decl);
1735
 
1736
            begin
1737
               if Nkind (Tdef) = N_Modular_Type_Definition then
1738
                  declare
1739
                     Modulus : constant Node_Id :=
1740
                                 Original_Node (Expression (Tdef));
1741
                  begin
1742
                     if Nkind (Modulus) = N_Integer_Literal then
1743
                        declare
1744
                           Modv : constant Uint := Intval (Modulus);
1745
                           Sizv : constant Uint := RM_Size (Utype);
1746
 
1747
                        begin
1748
                           --  First case, modulus and size are the same. This
1749
                           --  happens if you have something like mod 32, with
1750
                           --  an explicit size of 32, this is for sure a case
1751
                           --  where the warning is given, since it is seems
1752
                           --  very unlikely that someone would want e.g. a
1753
                           --  five bit type stored in 32 bits. It is much
1754
                           --  more likely they wanted a 32-bit type.
1755
 
1756
                           if Modv = Sizv then
1757
                              null;
1758
 
1759
                           --  Second case, the modulus is 32 or 64 and no
1760
                           --  size clause is present. This is a less clear
1761
                           --  case for giving the warning, but in the case
1762
                           --  of 32/64 (5-bit or 6-bit types) these seem rare
1763
                           --  enough that it is a likely error (and in any
1764
                           --  case using 2**5 or 2**6 in these cases seems
1765
                           --  clearer. We don't include 8 or 16 here, simply
1766
                           --  because in practice 3-bit and 4-bit types are
1767
                           --  more common and too many false positives if
1768
                           --  we warn in these cases.
1769
 
1770
                           elsif not Has_Size_Clause (Utype)
1771
                             and then (Modv = Uint_32 or else Modv = Uint_64)
1772
                           then
1773
                              null;
1774
 
1775
                           --  No warning needed
1776
 
1777
                           else
1778
                              return;
1779
                           end if;
1780
 
1781
                           --  If we fall through, give warning
1782
 
1783
                           Error_Msg_Uint_1 := Modv;
1784
                           Error_Msg_N
1785
                             ("?2 '*'*^' may have been intended here",
1786
                              Modulus);
1787
                        end;
1788
                     end if;
1789
                  end;
1790
               end if;
1791
            end;
1792
         end if;
1793
      end Check_Suspicious_Modulus;
1794
 
1795
      ------------------------
1796
      -- Freeze_Record_Type --
1797
      ------------------------
1798
 
1799
      procedure Freeze_Record_Type (Rec : Entity_Id) is
1800
         Comp : Entity_Id;
1801
         IR   : Node_Id;
1802
         ADC  : Node_Id;
1803
         Prev : Entity_Id;
1804
 
1805
         Junk : Boolean;
1806
         pragma Warnings (Off, Junk);
1807
 
1808
         Unplaced_Component : Boolean := False;
1809
         --  Set True if we find at least one component with no component
1810
         --  clause (used to warn about useless Pack pragmas).
1811
 
1812
         Placed_Component : Boolean := False;
1813
         --  Set True if we find at least one component with a component
1814
         --  clause (used to warn about useless Bit_Order pragmas, and also
1815
         --  to detect cases where Implicit_Packing may have an effect).
1816
 
1817
         All_Scalar_Components : Boolean := True;
1818
         --  Set False if we encounter a component of a non-scalar type
1819
 
1820
         Scalar_Component_Total_RM_Size : Uint := Uint_0;
1821
         Scalar_Component_Total_Esize   : Uint := Uint_0;
1822
         --  Accumulates total RM_Size values and total Esize values of all
1823
         --  scalar components. Used for processing of Implicit_Packing.
1824
 
1825
         function Check_Allocator (N : Node_Id) return Node_Id;
1826
         --  If N is an allocator, possibly wrapped in one or more level of
1827
         --  qualified expression(s), return the inner allocator node, else
1828
         --  return Empty.
1829
 
1830
         procedure Check_Itype (Typ : Entity_Id);
1831
         --  If the component subtype is an access to a constrained subtype of
1832
         --  an already frozen type, make the subtype frozen as well. It might
1833
         --  otherwise be frozen in the wrong scope, and a freeze node on
1834
         --  subtype has no effect. Similarly, if the component subtype is a
1835
         --  regular (not protected) access to subprogram, set the anonymous
1836
         --  subprogram type to frozen as well, to prevent an out-of-scope
1837
         --  freeze node at some eventual point of call. Protected operations
1838
         --  are handled elsewhere.
1839
 
1840
         ---------------------
1841
         -- Check_Allocator --
1842
         ---------------------
1843
 
1844
         function Check_Allocator (N : Node_Id) return Node_Id is
1845
            Inner : Node_Id;
1846
         begin
1847
            Inner := N;
1848
            loop
1849
               if Nkind (Inner) = N_Allocator then
1850
                  return Inner;
1851
               elsif Nkind (Inner) = N_Qualified_Expression then
1852
                  Inner := Expression (Inner);
1853
               else
1854
                  return Empty;
1855
               end if;
1856
            end loop;
1857
         end Check_Allocator;
1858
 
1859
         -----------------
1860
         -- Check_Itype --
1861
         -----------------
1862
 
1863
         procedure Check_Itype (Typ : Entity_Id) is
1864
            Desig : constant Entity_Id := Designated_Type (Typ);
1865
 
1866
         begin
1867
            if not Is_Frozen (Desig)
1868
              and then Is_Frozen (Base_Type (Desig))
1869
            then
1870
               Set_Is_Frozen (Desig);
1871
 
1872
               --  In addition, add an Itype_Reference to ensure that the
1873
               --  access subtype is elaborated early enough. This cannot be
1874
               --  done if the subtype may depend on discriminants.
1875
 
1876
               if Ekind (Comp) = E_Component
1877
                 and then Is_Itype (Etype (Comp))
1878
                 and then not Has_Discriminants (Rec)
1879
               then
1880
                  IR := Make_Itype_Reference (Sloc (Comp));
1881
                  Set_Itype (IR, Desig);
1882
                  Add_To_Result (IR);
1883
               end if;
1884
 
1885
            elsif Ekind (Typ) = E_Anonymous_Access_Subprogram_Type
1886
              and then Convention (Desig) /= Convention_Protected
1887
            then
1888
               Set_Is_Frozen (Desig);
1889
            end if;
1890
         end Check_Itype;
1891
 
1892
      --  Start of processing for Freeze_Record_Type
1893
 
1894
      begin
1895
         --  Freeze components and embedded subtypes
1896
 
1897
         Comp := First_Entity (Rec);
1898
         Prev := Empty;
1899
         while Present (Comp) loop
1900
 
1901
            --  First handle the component case
1902
 
1903
            if Ekind (Comp) = E_Component
1904
              or else Ekind (Comp) = E_Discriminant
1905
            then
1906
               declare
1907
                  CC : constant Node_Id := Component_Clause (Comp);
1908
 
1909
               begin
1910
                  --  Freezing a record type freezes the type of each of its
1911
                  --  components. However, if the type of the component is
1912
                  --  part of this record, we do not want or need a separate
1913
                  --  Freeze_Node. Note that Is_Itype is wrong because that's
1914
                  --  also set in private type cases. We also can't check for
1915
                  --  the Scope being exactly Rec because of private types and
1916
                  --  record extensions.
1917
 
1918
                  if Is_Itype (Etype (Comp))
1919
                    and then Is_Record_Type (Underlying_Type
1920
                                             (Scope (Etype (Comp))))
1921
                  then
1922
                     Undelay_Type (Etype (Comp));
1923
                  end if;
1924
 
1925
                  Freeze_And_Append (Etype (Comp), N, Result);
1926
 
1927
                  --  Check for error of component clause given for variable
1928
                  --  sized type. We have to delay this test till this point,
1929
                  --  since the component type has to be frozen for us to know
1930
                  --  if it is variable length. We omit this test in a generic
1931
                  --  context, it will be applied at instantiation time.
1932
 
1933
                  --  We also omit this test in CodePeer mode, since we do not
1934
                  --  have sufficient info on size and representation clauses.
1935
 
1936
                  if Present (CC) then
1937
                     Placed_Component := True;
1938
 
1939
                     if Inside_A_Generic then
1940
                        null;
1941
 
1942
                     elsif CodePeer_Mode then
1943
                        null;
1944
 
1945
                     elsif not
1946
                       Size_Known_At_Compile_Time
1947
                         (Underlying_Type (Etype (Comp)))
1948
                     then
1949
                        Error_Msg_N
1950
                          ("component clause not allowed for variable " &
1951
                           "length component", CC);
1952
                     end if;
1953
 
1954
                  else
1955
                     Unplaced_Component := True;
1956
                  end if;
1957
 
1958
                  --  Case of component requires byte alignment
1959
 
1960
                  if Must_Be_On_Byte_Boundary (Etype (Comp)) then
1961
 
1962
                     --  Set the enclosing record to also require byte align
1963
 
1964
                     Set_Must_Be_On_Byte_Boundary (Rec);
1965
 
1966
                     --  Check for component clause that is inconsistent with
1967
                     --  the required byte boundary alignment.
1968
 
1969
                     if Present (CC)
1970
                       and then Normalized_First_Bit (Comp) mod
1971
                                  System_Storage_Unit /= 0
1972
                     then
1973
                        Error_Msg_N
1974
                          ("component & must be byte aligned",
1975
                           Component_Name (Component_Clause (Comp)));
1976
                     end if;
1977
                  end if;
1978
               end;
1979
            end if;
1980
 
1981
            --  Gather data for possible Implicit_Packing later. Note that at
1982
            --  this stage we might be dealing with a real component, or with
1983
            --  an implicit subtype declaration.
1984
 
1985
            if not Is_Scalar_Type (Etype (Comp)) then
1986
               All_Scalar_Components := False;
1987
            else
1988
               Scalar_Component_Total_RM_Size :=
1989
                 Scalar_Component_Total_RM_Size + RM_Size (Etype (Comp));
1990
               Scalar_Component_Total_Esize :=
1991
                 Scalar_Component_Total_Esize + Esize (Etype (Comp));
1992
            end if;
1993
 
1994
            --  If the component is an Itype with Delayed_Freeze and is either
1995
            --  a record or array subtype and its base type has not yet been
1996
            --  frozen, we must remove this from the entity list of this record
1997
            --  and put it on the entity list of the scope of its base type.
1998
            --  Note that we know that this is not the type of a component
1999
            --  since we cleared Has_Delayed_Freeze for it in the previous
2000
            --  loop. Thus this must be the Designated_Type of an access type,
2001
            --  which is the type of a component.
2002
 
2003
            if Is_Itype (Comp)
2004
              and then Is_Type (Scope (Comp))
2005
              and then Is_Composite_Type (Comp)
2006
              and then Base_Type (Comp) /= Comp
2007
              and then Has_Delayed_Freeze (Comp)
2008
              and then not Is_Frozen (Base_Type (Comp))
2009
            then
2010
               declare
2011
                  Will_Be_Frozen : Boolean := False;
2012
                  S              : Entity_Id;
2013
 
2014
               begin
2015
                  --  We have a pretty bad kludge here. Suppose Rec is subtype
2016
                  --  being defined in a subprogram that's created as part of
2017
                  --  the freezing of Rec'Base. In that case, we know that
2018
                  --  Comp'Base must have already been frozen by the time we
2019
                  --  get to elaborate this because Gigi doesn't elaborate any
2020
                  --  bodies until it has elaborated all of the declarative
2021
                  --  part. But Is_Frozen will not be set at this point because
2022
                  --  we are processing code in lexical order.
2023
 
2024
                  --  We detect this case by going up the Scope chain of Rec
2025
                  --  and seeing if we have a subprogram scope before reaching
2026
                  --  the top of the scope chain or that of Comp'Base. If we
2027
                  --  do, then mark that Comp'Base will actually be frozen. If
2028
                  --  so, we merely undelay it.
2029
 
2030
                  S := Scope (Rec);
2031
                  while Present (S) loop
2032
                     if Is_Subprogram (S) then
2033
                        Will_Be_Frozen := True;
2034
                        exit;
2035
                     elsif S = Scope (Base_Type (Comp)) then
2036
                        exit;
2037
                     end if;
2038
 
2039
                     S := Scope (S);
2040
                  end loop;
2041
 
2042
                  if Will_Be_Frozen then
2043
                     Undelay_Type (Comp);
2044
                  else
2045
                     if Present (Prev) then
2046
                        Set_Next_Entity (Prev, Next_Entity (Comp));
2047
                     else
2048
                        Set_First_Entity (Rec, Next_Entity (Comp));
2049
                     end if;
2050
 
2051
                     --  Insert in entity list of scope of base type (which
2052
                     --  must be an enclosing scope, because still unfrozen).
2053
 
2054
                     Append_Entity (Comp, Scope (Base_Type (Comp)));
2055
                  end if;
2056
               end;
2057
 
2058
            --  If the component is an access type with an allocator as default
2059
            --  value, the designated type will be frozen by the corresponding
2060
            --  expression in init_proc. In order to place the freeze node for
2061
            --  the designated type before that for the current record type,
2062
            --  freeze it now.
2063
 
2064
            --  Same process if the component is an array of access types,
2065
            --  initialized with an aggregate. If the designated type is
2066
            --  private, it cannot contain allocators, and it is premature
2067
            --  to freeze the type, so we check for this as well.
2068
 
2069
            elsif Is_Access_Type (Etype (Comp))
2070
              and then Present (Parent (Comp))
2071
              and then Present (Expression (Parent (Comp)))
2072
            then
2073
               declare
2074
                  Alloc : constant Node_Id :=
2075
                            Check_Allocator (Expression (Parent (Comp)));
2076
 
2077
               begin
2078
                  if Present (Alloc) then
2079
 
2080
                     --  If component is pointer to a classwide type, freeze
2081
                     --  the specific type in the expression being allocated.
2082
                     --  The expression may be a subtype indication, in which
2083
                     --  case freeze the subtype mark.
2084
 
2085
                     if Is_Class_Wide_Type
2086
                          (Designated_Type (Etype (Comp)))
2087
                     then
2088
                        if Is_Entity_Name (Expression (Alloc)) then
2089
                           Freeze_And_Append
2090
                             (Entity (Expression (Alloc)), N, Result);
2091
                        elsif
2092
                          Nkind (Expression (Alloc)) = N_Subtype_Indication
2093
                        then
2094
                           Freeze_And_Append
2095
                            (Entity (Subtype_Mark (Expression (Alloc))),
2096
                             N, Result);
2097
                        end if;
2098
 
2099
                     elsif Is_Itype (Designated_Type (Etype (Comp))) then
2100
                        Check_Itype (Etype (Comp));
2101
 
2102
                     else
2103
                        Freeze_And_Append
2104
                          (Designated_Type (Etype (Comp)), N, Result);
2105
                     end if;
2106
                  end if;
2107
               end;
2108
 
2109
            elsif Is_Access_Type (Etype (Comp))
2110
              and then Is_Itype (Designated_Type (Etype (Comp)))
2111
            then
2112
               Check_Itype (Etype (Comp));
2113
 
2114
            elsif Is_Array_Type (Etype (Comp))
2115
              and then Is_Access_Type (Component_Type (Etype (Comp)))
2116
              and then Present (Parent (Comp))
2117
              and then Nkind (Parent (Comp)) = N_Component_Declaration
2118
              and then Present (Expression (Parent (Comp)))
2119
              and then Nkind (Expression (Parent (Comp))) = N_Aggregate
2120
              and then Is_Fully_Defined
2121
                 (Designated_Type (Component_Type (Etype (Comp))))
2122
            then
2123
               Freeze_And_Append
2124
                 (Designated_Type
2125
                   (Component_Type (Etype (Comp))), N, Result);
2126
            end if;
2127
 
2128
            Prev := Comp;
2129
            Next_Entity (Comp);
2130
         end loop;
2131
 
2132
         --  Deal with Bit_Order aspect specifying a non-default bit order
2133
 
2134
         if Reverse_Bit_Order (Rec) and then Base_Type (Rec) = Rec then
2135
            if not Placed_Component then
2136
               ADC :=
2137
                 Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order);
2138
               Error_Msg_N ("?Bit_Order specification has no effect", ADC);
2139
               Error_Msg_N
2140
                 ("\?since no component clauses were specified", ADC);
2141
 
2142
            --  Here is where we do the processing for reversed bit order
2143
 
2144
            else
2145
               Adjust_Record_For_Reverse_Bit_Order (Rec);
2146
            end if;
2147
         end if;
2148
 
2149
         --  Complete error checking on record representation clause (e.g.
2150
         --  overlap of components). This is called after adjusting the
2151
         --  record for reverse bit order.
2152
 
2153
         declare
2154
            RRC : constant Node_Id := Get_Record_Representation_Clause (Rec);
2155
         begin
2156
            if Present (RRC) then
2157
               Check_Record_Representation_Clause (RRC);
2158
            end if;
2159
         end;
2160
 
2161
         --  Set OK_To_Reorder_Components depending on debug flags
2162
 
2163
         if Is_Base_Type (Rec) and then Convention (Rec) = Convention_Ada then
2164
            if (Has_Discriminants (Rec) and then Debug_Flag_Dot_V)
2165
                  or else
2166
               (not Has_Discriminants (Rec) and then Debug_Flag_Dot_R)
2167
            then
2168
               Set_OK_To_Reorder_Components (Rec);
2169
            end if;
2170
         end if;
2171
 
2172
         --  Check for useless pragma Pack when all components placed. We only
2173
         --  do this check for record types, not subtypes, since a subtype may
2174
         --  have all its components placed, and it still makes perfectly good
2175
         --  sense to pack other subtypes or the parent type. We do not give
2176
         --  this warning if Optimize_Alignment is set to Space, since the
2177
         --  pragma Pack does have an effect in this case (it always resets
2178
         --  the alignment to one).
2179
 
2180
         if Ekind (Rec) = E_Record_Type
2181
           and then Is_Packed (Rec)
2182
           and then not Unplaced_Component
2183
           and then Optimize_Alignment /= 'S'
2184
         then
2185
            --  Reset packed status. Probably not necessary, but we do it so
2186
            --  that there is no chance of the back end doing something strange
2187
            --  with this redundant indication of packing.
2188
 
2189
            Set_Is_Packed (Rec, False);
2190
 
2191
            --  Give warning if redundant constructs warnings on
2192
 
2193
            if Warn_On_Redundant_Constructs then
2194
               Error_Msg_N -- CODEFIX
2195
                 ("?pragma Pack has no effect, no unplaced components",
2196
                  Get_Rep_Pragma (Rec, Name_Pack));
2197
            end if;
2198
         end if;
2199
 
2200
         --  If this is the record corresponding to a remote type, freeze the
2201
         --  remote type here since that is what we are semantically freezing.
2202
         --  This prevents the freeze node for that type in an inner scope.
2203
 
2204
         --  Also, Check for controlled components and unchecked unions.
2205
         --  Finally, enforce the restriction that access attributes with a
2206
         --  current instance prefix can only apply to limited types.
2207
 
2208
         if Ekind (Rec) = E_Record_Type then
2209
            if Present (Corresponding_Remote_Type (Rec)) then
2210
               Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result);
2211
            end if;
2212
 
2213
            Comp := First_Component (Rec);
2214
            while Present (Comp) loop
2215
 
2216
               --  Do not set Has_Controlled_Component on a class-wide
2217
               --  equivalent type. See Make_CW_Equivalent_Type.
2218
 
2219
               if not Is_Class_Wide_Equivalent_Type (Rec)
2220
                 and then (Has_Controlled_Component (Etype (Comp))
2221
                            or else (Chars (Comp) /= Name_uParent
2222
                                      and then Is_Controlled (Etype (Comp)))
2223
                            or else (Is_Protected_Type (Etype (Comp))
2224
                                      and then Present
2225
                                        (Corresponding_Record_Type
2226
                                          (Etype (Comp)))
2227
                                      and then Has_Controlled_Component
2228
                                        (Corresponding_Record_Type
2229
                                          (Etype (Comp)))))
2230
               then
2231
                  Set_Has_Controlled_Component (Rec);
2232
               end if;
2233
 
2234
               if Has_Unchecked_Union (Etype (Comp)) then
2235
                  Set_Has_Unchecked_Union (Rec);
2236
               end if;
2237
 
2238
               --  Scan component declaration for likely misuses of current
2239
               --  instance, either in a constraint or a default expression.
2240
 
2241
               if Has_Per_Object_Constraint (Comp) then
2242
                  Check_Current_Instance (Parent (Comp));
2243
               end if;
2244
 
2245
               Next_Component (Comp);
2246
            end loop;
2247
         end if;
2248
 
2249
         Set_Component_Alignment_If_Not_Set (Rec);
2250
 
2251
         --  For first subtypes, check if there are any fixed-point fields with
2252
         --  component clauses, where we must check the size. This is not done
2253
         --  till the freeze point, since for fixed-point types, we do not know
2254
         --  the size until the type is frozen. Similar processing applies to
2255
         --  bit packed arrays.
2256
 
2257
         if Is_First_Subtype (Rec) then
2258
            Comp := First_Component (Rec);
2259
            while Present (Comp) loop
2260
               if Present (Component_Clause (Comp))
2261
                 and then (Is_Fixed_Point_Type (Etype (Comp))
2262
                             or else
2263
                           Is_Bit_Packed_Array (Etype (Comp)))
2264
               then
2265
                  Check_Size
2266
                    (Component_Name (Component_Clause (Comp)),
2267
                     Etype (Comp),
2268
                     Esize (Comp),
2269
                     Junk);
2270
               end if;
2271
 
2272
               Next_Component (Comp);
2273
            end loop;
2274
         end if;
2275
 
2276
         --  Generate warning for applying C or C++ convention to a record
2277
         --  with discriminants. This is suppressed for the unchecked union
2278
         --  case, since the whole point in this case is interface C. We also
2279
         --  do not generate this within instantiations, since we will have
2280
         --  generated a message on the template.
2281
 
2282
         if Has_Discriminants (E)
2283
           and then not Is_Unchecked_Union (E)
2284
           and then (Convention (E) = Convention_C
2285
                       or else
2286
                     Convention (E) = Convention_CPP)
2287
           and then Comes_From_Source (E)
2288
           and then not In_Instance
2289
           and then not Has_Warnings_Off (E)
2290
           and then not Has_Warnings_Off (Base_Type (E))
2291
         then
2292
            declare
2293
               Cprag : constant Node_Id := Get_Rep_Pragma (E, Name_Convention);
2294
               A2    : Node_Id;
2295
 
2296
            begin
2297
               if Present (Cprag) then
2298
                  A2 := Next (First (Pragma_Argument_Associations (Cprag)));
2299
 
2300
                  if Convention (E) = Convention_C then
2301
                     Error_Msg_N
2302
                       ("?variant record has no direct equivalent in C", A2);
2303
                  else
2304
                     Error_Msg_N
2305
                       ("?variant record has no direct equivalent in C++", A2);
2306
                  end if;
2307
 
2308
                  Error_Msg_NE
2309
                    ("\?use of convention for type& is dubious", A2, E);
2310
               end if;
2311
            end;
2312
         end if;
2313
 
2314
         --  See if Size is too small as is (and implicit packing might help)
2315
 
2316
         if not Is_Packed (Rec)
2317
 
2318
           --  No implicit packing if even one component is explicitly placed
2319
 
2320
           and then not Placed_Component
2321
 
2322
           --  Must have size clause and all scalar components
2323
 
2324
           and then Has_Size_Clause (Rec)
2325
           and then All_Scalar_Components
2326
 
2327
           --  Do not try implicit packing on records with discriminants, too
2328
           --  complicated, especially in the variant record case.
2329
 
2330
           and then not Has_Discriminants (Rec)
2331
 
2332
           --  We can implicitly pack if the specified size of the record is
2333
           --  less than the sum of the object sizes (no point in packing if
2334
           --  this is not the case).
2335
 
2336
           and then RM_Size (Rec) < Scalar_Component_Total_Esize
2337
 
2338
           --  And the total RM size cannot be greater than the specified size
2339
           --  since otherwise packing will not get us where we have to be!
2340
 
2341
           and then RM_Size (Rec) >= Scalar_Component_Total_RM_Size
2342
 
2343
           --  Never do implicit packing in CodePeer or Alfa modes since
2344
           --  we don't do any packing in these modes, since this generates
2345
           --  over-complex code that confuses static analysis, and in
2346
           --  general, neither CodePeer not GNATprove care about the
2347
           --  internal representation of objects.
2348
 
2349
           and then not (CodePeer_Mode or Alfa_Mode)
2350
         then
2351
            --  If implicit packing enabled, do it
2352
 
2353
            if Implicit_Packing then
2354
               Set_Is_Packed (Rec);
2355
 
2356
               --  Otherwise flag the size clause
2357
 
2358
            else
2359
               declare
2360
                  Sz : constant Node_Id := Size_Clause (Rec);
2361
               begin
2362
                  Error_Msg_NE -- CODEFIX
2363
                    ("size given for& too small", Sz, Rec);
2364
                  Error_Msg_N -- CODEFIX
2365
                    ("\use explicit pragma Pack "
2366
                     & "or use pragma Implicit_Packing", Sz);
2367
               end;
2368
            end if;
2369
         end if;
2370
      end Freeze_Record_Type;
2371
 
2372
   --  Start of processing for Freeze_Entity
2373
 
2374
   begin
2375
      --  We are going to test for various reasons why this entity need not be
2376
      --  frozen here, but in the case of an Itype that's defined within a
2377
      --  record, that test actually applies to the record.
2378
 
2379
      if Is_Itype (E) and then Is_Record_Type (Scope (E)) then
2380
         Test_E := Scope (E);
2381
      elsif Is_Itype (E) and then Present (Underlying_Type (Scope (E)))
2382
        and then Is_Record_Type (Underlying_Type (Scope (E)))
2383
      then
2384
         Test_E := Underlying_Type (Scope (E));
2385
      end if;
2386
 
2387
      --  Do not freeze if already frozen since we only need one freeze node
2388
 
2389
      if Is_Frozen (E) then
2390
         return No_List;
2391
 
2392
      --  It is improper to freeze an external entity within a generic because
2393
      --  its freeze node will appear in a non-valid context. The entity will
2394
      --  be frozen in the proper scope after the current generic is analyzed.
2395
 
2396
      elsif Inside_A_Generic and then External_Ref_In_Generic (Test_E) then
2397
         return No_List;
2398
 
2399
      --  AI05-0213: A formal incomplete type does not freeze the actual. In
2400
      --  the instance, the same applies to the subtype renaming the actual.
2401
 
2402
      elsif Is_Private_Type (E)
2403
        and then Is_Generic_Actual_Type (E)
2404
        and then No (Full_View (Base_Type (E)))
2405
        and then Ada_Version >= Ada_2012
2406
      then
2407
         return No_List;
2408
 
2409
      --  Do not freeze a global entity within an inner scope created during
2410
      --  expansion. A call to subprogram E within some internal procedure
2411
      --  (a stream attribute for example) might require freezing E, but the
2412
      --  freeze node must appear in the same declarative part as E itself.
2413
      --  The two-pass elaboration mechanism in gigi guarantees that E will
2414
      --  be frozen before the inner call is elaborated. We exclude constants
2415
      --  from this test, because deferred constants may be frozen early, and
2416
      --  must be diagnosed (e.g. in the case of a deferred constant being used
2417
      --  in a default expression). If the enclosing subprogram comes from
2418
      --  source, or is a generic instance, then the freeze point is the one
2419
      --  mandated by the language, and we freeze the entity. A subprogram that
2420
      --  is a child unit body that acts as a spec does not have a spec that
2421
      --  comes from source, but can only come from source.
2422
 
2423
      elsif In_Open_Scopes (Scope (Test_E))
2424
        and then Scope (Test_E) /= Current_Scope
2425
        and then Ekind (Test_E) /= E_Constant
2426
      then
2427
         declare
2428
            S : Entity_Id;
2429
 
2430
         begin
2431
            S := Current_Scope;
2432
            while Present (S) loop
2433
               if Is_Overloadable (S) then
2434
                  if Comes_From_Source (S)
2435
                    or else Is_Generic_Instance (S)
2436
                    or else Is_Child_Unit (S)
2437
                  then
2438
                     exit;
2439
                  else
2440
                     return No_List;
2441
                  end if;
2442
               end if;
2443
 
2444
               S := Scope (S);
2445
            end loop;
2446
         end;
2447
 
2448
      --  Similarly, an inlined instance body may make reference to global
2449
      --  entities, but these references cannot be the proper freezing point
2450
      --  for them, and in the absence of inlining freezing will take place in
2451
      --  their own scope. Normally instance bodies are analyzed after the
2452
      --  enclosing compilation, and everything has been frozen at the proper
2453
      --  place, but with front-end inlining an instance body is compiled
2454
      --  before the end of the enclosing scope, and as a result out-of-order
2455
      --  freezing must be prevented.
2456
 
2457
      elsif Front_End_Inlining
2458
        and then In_Instance_Body
2459
        and then Present (Scope (Test_E))
2460
      then
2461
         declare
2462
            S : Entity_Id;
2463
 
2464
         begin
2465
            S := Scope (Test_E);
2466
            while Present (S) loop
2467
               if Is_Generic_Instance (S) then
2468
                  exit;
2469
               else
2470
                  S := Scope (S);
2471
               end if;
2472
            end loop;
2473
 
2474
            if No (S) then
2475
               return No_List;
2476
            end if;
2477
         end;
2478
      end if;
2479
 
2480
      --  Deal with delayed aspect specifications. The analysis of the aspect
2481
      --  is required to be delayed to the freeze point, so we evaluate the
2482
      --  pragma or attribute definition clause in the tree at this point.
2483
 
2484
      if Has_Delayed_Aspects (E) then
2485
         declare
2486
            Ritem : Node_Id;
2487
            Aitem : Node_Id;
2488
 
2489
         begin
2490
            --  Look for aspect specification entries for this entity
2491
 
2492
            Ritem := First_Rep_Item (E);
2493
            while Present (Ritem) loop
2494
               if Nkind (Ritem) = N_Aspect_Specification
2495
                 and then Entity (Ritem) = E
2496
                 and then Is_Delayed_Aspect (Ritem)
2497
                 and then Scope (E) = Current_Scope
2498
               then
2499
                  Aitem := Aspect_Rep_Item (Ritem);
2500
 
2501
                  --  Skip if this is an aspect with no corresponding pragma
2502
                  --  or attribute definition node (such as Default_Value).
2503
 
2504
                  if Present (Aitem) then
2505
                     Set_Parent (Aitem, Ritem);
2506
                     Analyze (Aitem);
2507
                  end if;
2508
               end if;
2509
 
2510
               Next_Rep_Item (Ritem);
2511
            end loop;
2512
         end;
2513
      end if;
2514
 
2515
      --  Here to freeze the entity
2516
 
2517
      Set_Is_Frozen (E);
2518
 
2519
      --  Case of entity being frozen is other than a type
2520
 
2521
      if not Is_Type (E) then
2522
 
2523
         --  If entity is exported or imported and does not have an external
2524
         --  name, now is the time to provide the appropriate default name.
2525
         --  Skip this if the entity is stubbed, since we don't need a name
2526
         --  for any stubbed routine. For the case on intrinsics, if no
2527
         --  external name is specified, then calls will be handled in
2528
         --  Exp_Intr.Expand_Intrinsic_Call, and no name is needed. If an
2529
         --  external name is provided, then Expand_Intrinsic_Call leaves
2530
         --  calls in place for expansion by GIGI.
2531
 
2532
         if (Is_Imported (E) or else Is_Exported (E))
2533
           and then No (Interface_Name (E))
2534
           and then Convention (E) /= Convention_Stubbed
2535
           and then Convention (E) /= Convention_Intrinsic
2536
         then
2537
            Set_Encoded_Interface_Name
2538
              (E, Get_Default_External_Name (E));
2539
 
2540
         --  If entity is an atomic object appearing in a declaration and
2541
         --  the expression is an aggregate, assign it to a temporary to
2542
         --  ensure that the actual assignment is done atomically rather
2543
         --  than component-wise (the assignment to the temp may be done
2544
         --  component-wise, but that is harmless).
2545
 
2546
         elsif Is_Atomic (E)
2547
           and then Nkind (Parent (E)) = N_Object_Declaration
2548
           and then Present (Expression (Parent (E)))
2549
           and then Nkind (Expression (Parent (E))) = N_Aggregate
2550
           and then Is_Atomic_Aggregate (Expression (Parent (E)), Etype (E))
2551
         then
2552
            null;
2553
         end if;
2554
 
2555
         --  For a subprogram, freeze all parameter types and also the return
2556
         --  type (RM 13.14(14)). However skip this for internal subprograms.
2557
         --  This is also the point where any extra formal parameters are
2558
         --  created since we now know whether the subprogram will use a
2559
         --  foreign convention.
2560
 
2561
         if Is_Subprogram (E) then
2562
            if not Is_Internal (E) then
2563
               declare
2564
                  F_Type    : Entity_Id;
2565
                  R_Type    : Entity_Id;
2566
                  Warn_Node : Node_Id;
2567
 
2568
               begin
2569
                  --  Loop through formals
2570
 
2571
                  Formal := First_Formal (E);
2572
                  while Present (Formal) loop
2573
                     F_Type := Etype (Formal);
2574
 
2575
                     --  AI05-0151 : incomplete types can appear in a profile.
2576
                     --  By the time the entity is frozen, the full view must
2577
                     --  be available, unless it is a limited view.
2578
 
2579
                     if Is_Incomplete_Type (F_Type)
2580
                       and then Present (Full_View (F_Type))
2581
                     then
2582
                        F_Type := Full_View (F_Type);
2583
                        Set_Etype (Formal, F_Type);
2584
                     end if;
2585
 
2586
                     Freeze_And_Append (F_Type, N, Result);
2587
 
2588
                     if Is_Private_Type (F_Type)
2589
                       and then Is_Private_Type (Base_Type (F_Type))
2590
                       and then No (Full_View (Base_Type (F_Type)))
2591
                       and then not Is_Generic_Type (F_Type)
2592
                       and then not Is_Derived_Type (F_Type)
2593
                     then
2594
                        --  If the type of a formal is incomplete, subprogram
2595
                        --  is being frozen prematurely. Within an instance
2596
                        --  (but not within a wrapper package) this is an
2597
                        --  artifact of our need to regard the end of an
2598
                        --  instantiation as a freeze point. Otherwise it is
2599
                        --  a definite error.
2600
 
2601
                        if In_Instance then
2602
                           Set_Is_Frozen (E, False);
2603
                           return No_List;
2604
 
2605
                        elsif not After_Last_Declaration
2606
                          and then not Freezing_Library_Level_Tagged_Type
2607
                        then
2608
                           Error_Msg_Node_1 := F_Type;
2609
                           Error_Msg
2610
                             ("type& must be fully defined before this point",
2611
                               Loc);
2612
                        end if;
2613
                     end if;
2614
 
2615
                     --  Check suspicious parameter for C function. These tests
2616
                     --  apply only to exported/imported subprograms.
2617
 
2618
                     if Warn_On_Export_Import
2619
                       and then Comes_From_Source (E)
2620
                       and then (Convention (E) = Convention_C
2621
                                   or else
2622
                                 Convention (E) = Convention_CPP)
2623
                       and then (Is_Imported (E) or else Is_Exported (E))
2624
                       and then Convention (E) /= Convention (Formal)
2625
                       and then not Has_Warnings_Off (E)
2626
                       and then not Has_Warnings_Off (F_Type)
2627
                       and then not Has_Warnings_Off (Formal)
2628
                     then
2629
                        --  Qualify mention of formals with subprogram name
2630
 
2631
                        Error_Msg_Qual_Level := 1;
2632
 
2633
                        --  Check suspicious use of fat C pointer
2634
 
2635
                        if Is_Access_Type (F_Type)
2636
                          and then Esize (F_Type) > Ttypes.System_Address_Size
2637
                        then
2638
                           Error_Msg_N
2639
                             ("?type of & does not correspond to C pointer!",
2640
                              Formal);
2641
 
2642
                        --  Check suspicious return of boolean
2643
 
2644
                        elsif Root_Type (F_Type) = Standard_Boolean
2645
                          and then Convention (F_Type) = Convention_Ada
2646
                          and then not Has_Warnings_Off (F_Type)
2647
                          and then not Has_Size_Clause (F_Type)
2648
                          and then VM_Target = No_VM
2649
                        then
2650
                           Error_Msg_N ("& is an 8-bit Ada Boolean?", Formal);
2651
                           Error_Msg_N
2652
                             ("\use appropriate corresponding type in C "
2653
                              & "(e.g. char)?", Formal);
2654
 
2655
                        --  Check suspicious tagged type
2656
 
2657
                        elsif (Is_Tagged_Type (F_Type)
2658
                                or else (Is_Access_Type (F_Type)
2659
                                           and then
2660
                                             Is_Tagged_Type
2661
                                               (Designated_Type (F_Type))))
2662
                          and then Convention (E) = Convention_C
2663
                        then
2664
                           Error_Msg_N
2665
                             ("?& involves a tagged type which does not "
2666
                              & "correspond to any C type!", Formal);
2667
 
2668
                        --  Check wrong convention subprogram pointer
2669
 
2670
                        elsif Ekind (F_Type) = E_Access_Subprogram_Type
2671
                          and then not Has_Foreign_Convention (F_Type)
2672
                        then
2673
                           Error_Msg_N
2674
                             ("?subprogram pointer & should "
2675
                              & "have foreign convention!", Formal);
2676
                           Error_Msg_Sloc := Sloc (F_Type);
2677
                           Error_Msg_NE
2678
                             ("\?add Convention pragma to declaration of &#",
2679
                              Formal, F_Type);
2680
                        end if;
2681
 
2682
                        --  Turn off name qualification after message output
2683
 
2684
                        Error_Msg_Qual_Level := 0;
2685
                     end if;
2686
 
2687
                     --  Check for unconstrained array in exported foreign
2688
                     --  convention case.
2689
 
2690
                     if Has_Foreign_Convention (E)
2691
                       and then not Is_Imported (E)
2692
                       and then Is_Array_Type (F_Type)
2693
                       and then not Is_Constrained (F_Type)
2694
                       and then Warn_On_Export_Import
2695
 
2696
                       --  Exclude VM case, since both .NET and JVM can handle
2697
                       --  unconstrained arrays without a problem.
2698
 
2699
                       and then VM_Target = No_VM
2700
                     then
2701
                        Error_Msg_Qual_Level := 1;
2702
 
2703
                        --  If this is an inherited operation, place the
2704
                        --  warning on the derived type declaration, rather
2705
                        --  than on the original subprogram.
2706
 
2707
                        if Nkind (Original_Node (Parent (E))) =
2708
                          N_Full_Type_Declaration
2709
                        then
2710
                           Warn_Node := Parent (E);
2711
 
2712
                           if Formal = First_Formal (E) then
2713
                              Error_Msg_NE
2714
                                ("?in inherited operation&", Warn_Node, E);
2715
                           end if;
2716
                        else
2717
                           Warn_Node := Formal;
2718
                        end if;
2719
 
2720
                        Error_Msg_NE
2721
                          ("?type of argument& is unconstrained array",
2722
                           Warn_Node, Formal);
2723
                        Error_Msg_NE
2724
                          ("?foreign caller must pass bounds explicitly",
2725
                           Warn_Node, Formal);
2726
                        Error_Msg_Qual_Level := 0;
2727
                     end if;
2728
 
2729
                     if not From_With_Type (F_Type) then
2730
                        if Is_Access_Type (F_Type) then
2731
                           F_Type := Designated_Type (F_Type);
2732
                        end if;
2733
 
2734
                        --  If the formal is an anonymous_access_to_subprogram
2735
                        --  freeze the  subprogram type as well, to prevent
2736
                        --  scope anomalies in gigi, because there is no other
2737
                        --  clear point at which it could be frozen.
2738
 
2739
                        if Is_Itype (Etype (Formal))
2740
                          and then Ekind (F_Type) = E_Subprogram_Type
2741
                        then
2742
                           Freeze_And_Append (F_Type, N, Result);
2743
                        end if;
2744
                     end if;
2745
 
2746
                     Next_Formal (Formal);
2747
                  end loop;
2748
 
2749
                  --  Case of function: similar checks on return type
2750
 
2751
                  if Ekind (E) = E_Function then
2752
 
2753
                     --  Freeze return type
2754
 
2755
                     R_Type := Etype (E);
2756
 
2757
                     --  AI05-0151: the return type may have been incomplete
2758
                     --  at the point of declaration.
2759
 
2760
                     if Ekind (R_Type) = E_Incomplete_Type
2761
                       and then Present (Full_View (R_Type))
2762
                     then
2763
                        R_Type := Full_View (R_Type);
2764
                        Set_Etype (E, R_Type);
2765
                     end if;
2766
 
2767
                     Freeze_And_Append (R_Type, N, Result);
2768
 
2769
                     --  Check suspicious return type for C function
2770
 
2771
                     if Warn_On_Export_Import
2772
                       and then (Convention (E) = Convention_C
2773
                                   or else
2774
                                 Convention (E) = Convention_CPP)
2775
                       and then (Is_Imported (E) or else Is_Exported (E))
2776
                     then
2777
                        --  Check suspicious return of fat C pointer
2778
 
2779
                        if Is_Access_Type (R_Type)
2780
                          and then Esize (R_Type) > Ttypes.System_Address_Size
2781
                          and then not Has_Warnings_Off (E)
2782
                          and then not Has_Warnings_Off (R_Type)
2783
                        then
2784
                           Error_Msg_N
2785
                             ("?return type of& does not "
2786
                              & "correspond to C pointer!", E);
2787
 
2788
                        --  Check suspicious return of boolean
2789
 
2790
                        elsif Root_Type (R_Type) = Standard_Boolean
2791
                          and then Convention (R_Type) = Convention_Ada
2792
                          and then VM_Target = No_VM
2793
                          and then not Has_Warnings_Off (E)
2794
                          and then not Has_Warnings_Off (R_Type)
2795
                          and then not Has_Size_Clause (R_Type)
2796
                        then
2797
                           declare
2798
                              N : constant Node_Id :=
2799
                                    Result_Definition (Declaration_Node (E));
2800
                           begin
2801
                              Error_Msg_NE
2802
                                ("return type of & is an 8-bit Ada Boolean?",
2803
                                 N, E);
2804
                              Error_Msg_NE
2805
                                ("\use appropriate corresponding type in C "
2806
                                 & "(e.g. char)?", N, E);
2807
                           end;
2808
 
2809
                        --  Check suspicious return tagged type
2810
 
2811
                        elsif (Is_Tagged_Type (R_Type)
2812
                                or else (Is_Access_Type (R_Type)
2813
                                           and then
2814
                                             Is_Tagged_Type
2815
                                               (Designated_Type (R_Type))))
2816
                          and then Convention (E) = Convention_C
2817
                          and then not Has_Warnings_Off (E)
2818
                          and then not Has_Warnings_Off (R_Type)
2819
                        then
2820
                           Error_Msg_N
2821
                             ("?return type of & does not "
2822
                              & "correspond to C type!", E);
2823
 
2824
                        --  Check return of wrong convention subprogram pointer
2825
 
2826
                        elsif Ekind (R_Type) = E_Access_Subprogram_Type
2827
                          and then not Has_Foreign_Convention (R_Type)
2828
                          and then not Has_Warnings_Off (E)
2829
                          and then not Has_Warnings_Off (R_Type)
2830
                        then
2831
                           Error_Msg_N
2832
                             ("?& should return a foreign "
2833
                              & "convention subprogram pointer", E);
2834
                           Error_Msg_Sloc := Sloc (R_Type);
2835
                           Error_Msg_NE
2836
                             ("\?add Convention pragma to declaration of& #",
2837
                              E, R_Type);
2838
                        end if;
2839
                     end if;
2840
 
2841
                     --  Give warning for suspicious return of a result of an
2842
                     --  unconstrained array type in a foreign convention
2843
                     --  function.
2844
 
2845
                     if Has_Foreign_Convention (E)
2846
 
2847
                       --  We are looking for a return of unconstrained array
2848
 
2849
                       and then Is_Array_Type (R_Type)
2850
                       and then not Is_Constrained (R_Type)
2851
 
2852
                       --  Exclude imported routines, the warning does not
2853
                       --  belong on the import, but rather on the routine
2854
                       --  definition.
2855
 
2856
                       and then not Is_Imported (E)
2857
 
2858
                       --  Exclude VM case, since both .NET and JVM can handle
2859
                       --  return of unconstrained arrays without a problem.
2860
 
2861
                       and then VM_Target = No_VM
2862
 
2863
                       --  Check that general warning is enabled, and that it
2864
                       --  is not suppressed for this particular case.
2865
 
2866
                       and then Warn_On_Export_Import
2867
                       and then not Has_Warnings_Off (E)
2868
                       and then not Has_Warnings_Off (R_Type)
2869
                     then
2870
                        Error_Msg_N
2871
                          ("?foreign convention function& should not " &
2872
                           "return unconstrained array!", E);
2873
                     end if;
2874
                  end if;
2875
               end;
2876
            end if;
2877
 
2878
            --  Must freeze its parent first if it is a derived subprogram
2879
 
2880
            if Present (Alias (E)) then
2881
               Freeze_And_Append (Alias (E), N, Result);
2882
            end if;
2883
 
2884
            --  We don't freeze internal subprograms, because we don't normally
2885
            --  want addition of extra formals or mechanism setting to happen
2886
            --  for those. However we do pass through predefined dispatching
2887
            --  cases, since extra formals may be needed in some cases, such as
2888
            --  for the stream 'Input function (build-in-place formals).
2889
 
2890
            if not Is_Internal (E)
2891
              or else Is_Predefined_Dispatching_Operation (E)
2892
            then
2893
               Freeze_Subprogram (E);
2894
            end if;
2895
 
2896
         --  Here for other than a subprogram or type
2897
 
2898
         else
2899
            --  If entity has a type, and it is not a generic unit, then
2900
            --  freeze it first (RM 13.14(10)).
2901
 
2902
            if Present (Etype (E))
2903
              and then Ekind (E) /= E_Generic_Function
2904
            then
2905
               Freeze_And_Append (Etype (E), N, Result);
2906
            end if;
2907
 
2908
            --  Special processing for objects created by object declaration
2909
 
2910
            if Nkind (Declaration_Node (E)) = N_Object_Declaration then
2911
 
2912
               --  Abstract type allowed only for C++ imported variables or
2913
               --  constants.
2914
 
2915
               --  Note: we inhibit this check for objects that do not come
2916
               --  from source because there is at least one case (the
2917
               --  expansion of x'Class'Input where x is abstract) where we
2918
               --  legitimately generate an abstract object.
2919
 
2920
               if Is_Abstract_Type (Etype (E))
2921
                 and then Comes_From_Source (Parent (E))
2922
                 and then not (Is_Imported (E)
2923
                                 and then Is_CPP_Class (Etype (E)))
2924
               then
2925
                  Error_Msg_N ("type of object cannot be abstract",
2926
                               Object_Definition (Parent (E)));
2927
 
2928
                  if Is_CPP_Class (Etype (E)) then
2929
                     Error_Msg_NE
2930
                       ("\} may need a cpp_constructor",
2931
                       Object_Definition (Parent (E)), Etype (E));
2932
                  end if;
2933
               end if;
2934
 
2935
               --  For object created by object declaration, perform required
2936
               --  categorization (preelaborate and pure) checks. Defer these
2937
               --  checks to freeze time since pragma Import inhibits default
2938
               --  initialization and thus pragma Import affects these checks.
2939
 
2940
               Validate_Object_Declaration (Declaration_Node (E));
2941
 
2942
               --  If there is an address clause, check that it is valid
2943
 
2944
               Check_Address_Clause (E);
2945
 
2946
               --  If the object needs any kind of default initialization, an
2947
               --  error must be issued if No_Default_Initialization applies.
2948
               --  The check doesn't apply to imported objects, which are not
2949
               --  ever default initialized, and is why the check is deferred
2950
               --  until freezing, at which point we know if Import applies.
2951
               --  Deferred constants are also exempted from this test because
2952
               --  their completion is explicit, or through an import pragma.
2953
 
2954
               if Ekind (E) = E_Constant
2955
                 and then Present (Full_View (E))
2956
               then
2957
                  null;
2958
 
2959
               elsif Comes_From_Source (E)
2960
                 and then not Is_Imported (E)
2961
                 and then not Has_Init_Expression (Declaration_Node (E))
2962
                 and then
2963
                   ((Has_Non_Null_Base_Init_Proc (Etype (E))
2964
                      and then not No_Initialization (Declaration_Node (E))
2965
                      and then not Is_Value_Type (Etype (E))
2966
                      and then not Initialization_Suppressed (Etype (E)))
2967
                    or else
2968
                      (Needs_Simple_Initialization (Etype (E))
2969
                        and then not Is_Internal (E)))
2970
               then
2971
                  Has_Default_Initialization := True;
2972
                  Check_Restriction
2973
                    (No_Default_Initialization, Declaration_Node (E));
2974
               end if;
2975
 
2976
               --  Check that a Thread_Local_Storage variable does not have
2977
               --  default initialization, and any explicit initialization must
2978
               --  either be the null constant or a static constant.
2979
 
2980
               if Has_Pragma_Thread_Local_Storage (E) then
2981
                  declare
2982
                     Decl : constant Node_Id := Declaration_Node (E);
2983
                  begin
2984
                     if Has_Default_Initialization
2985
                       or else
2986
                         (Has_Init_Expression (Decl)
2987
                            and then
2988
                             (No (Expression (Decl))
2989
                                or else not
2990
                                  (Is_Static_Expression (Expression (Decl))
2991
                                     or else
2992
                                   Nkind (Expression (Decl)) = N_Null)))
2993
                     then
2994
                        Error_Msg_NE
2995
                          ("Thread_Local_Storage variable& is "
2996
                           & "improperly initialized", Decl, E);
2997
                        Error_Msg_NE
2998
                          ("\only allowed initialization is explicit "
2999
                           & "NULL or static expression", Decl, E);
3000
                     end if;
3001
                  end;
3002
               end if;
3003
 
3004
               --  For imported objects, set Is_Public unless there is also an
3005
               --  address clause, which means that there is no external symbol
3006
               --  needed for the Import (Is_Public may still be set for other
3007
               --  unrelated reasons). Note that we delayed this processing
3008
               --  till freeze time so that we can be sure not to set the flag
3009
               --  if there is an address clause. If there is such a clause,
3010
               --  then the only purpose of the Import pragma is to suppress
3011
               --  implicit initialization.
3012
 
3013
               if Is_Imported (E)
3014
                 and then No (Address_Clause (E))
3015
               then
3016
                  Set_Is_Public (E);
3017
               end if;
3018
 
3019
               --  For convention C objects of an enumeration type, warn if
3020
               --  the size is not integer size and no explicit size given.
3021
               --  Skip warning for Boolean, and Character, assume programmer
3022
               --  expects 8-bit sizes for these cases.
3023
 
3024
               if (Convention (E) = Convention_C
3025
                    or else
3026
                   Convention (E) = Convention_CPP)
3027
                 and then Is_Enumeration_Type (Etype (E))
3028
                 and then not Is_Character_Type (Etype (E))
3029
                 and then not Is_Boolean_Type (Etype (E))
3030
                 and then Esize (Etype (E)) < Standard_Integer_Size
3031
                 and then not Has_Size_Clause (E)
3032
               then
3033
                  Error_Msg_Uint_1 := UI_From_Int (Standard_Integer_Size);
3034
                  Error_Msg_N
3035
                    ("?convention C enumeration object has size less than ^",
3036
                     E);
3037
                  Error_Msg_N ("\?use explicit size clause to set size", E);
3038
               end if;
3039
            end if;
3040
 
3041
            --  Check that a constant which has a pragma Volatile[_Components]
3042
            --  or Atomic[_Components] also has a pragma Import (RM C.6(13)).
3043
 
3044
            --  Note: Atomic[_Components] also sets Volatile[_Components]
3045
 
3046
            if Ekind (E) = E_Constant
3047
              and then (Has_Volatile_Components (E) or else Is_Volatile (E))
3048
              and then not Is_Imported (E)
3049
            then
3050
               --  Make sure we actually have a pragma, and have not merely
3051
               --  inherited the indication from elsewhere (e.g. an address
3052
               --  clause, which is not good enough in RM terms!)
3053
 
3054
               if Has_Rep_Pragma (E, Name_Atomic)
3055
                    or else
3056
                  Has_Rep_Pragma (E, Name_Atomic_Components)
3057
               then
3058
                  Error_Msg_N
3059
                    ("stand alone atomic constant must be " &
3060
                     "imported (RM C.6(13))", E);
3061
 
3062
               elsif Has_Rep_Pragma (E, Name_Volatile)
3063
                       or else
3064
                     Has_Rep_Pragma (E, Name_Volatile_Components)
3065
               then
3066
                  Error_Msg_N
3067
                    ("stand alone volatile constant must be " &
3068
                     "imported (RM C.6(13))", E);
3069
               end if;
3070
            end if;
3071
 
3072
            --  Static objects require special handling
3073
 
3074
            if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
3075
              and then Is_Statically_Allocated (E)
3076
            then
3077
               Freeze_Static_Object (E);
3078
            end if;
3079
 
3080
            --  Remaining step is to layout objects
3081
 
3082
            if Ekind (E) = E_Variable
3083
                 or else
3084
               Ekind (E) = E_Constant
3085
                 or else
3086
               Ekind (E) = E_Loop_Parameter
3087
                 or else
3088
               Is_Formal (E)
3089
            then
3090
               Layout_Object (E);
3091
            end if;
3092
         end if;
3093
 
3094
      --  Case of a type or subtype being frozen
3095
 
3096
      else
3097
         --  We used to check here that a full type must have preelaborable
3098
         --  initialization if it completes a private type specified with
3099
         --  pragma Preelaborable_Initialization, but that missed cases where
3100
         --  the types occur within a generic package, since the freezing
3101
         --  that occurs within a containing scope generally skips traversal
3102
         --  of a generic unit's declarations (those will be frozen within
3103
         --  instances). This check was moved to Analyze_Package_Specification.
3104
 
3105
         --  The type may be defined in a generic unit. This can occur when
3106
         --  freezing a generic function that returns the type (which is
3107
         --  defined in a parent unit). It is clearly meaningless to freeze
3108
         --  this type. However, if it is a subtype, its size may be determi-
3109
         --  nable and used in subsequent checks, so might as well try to
3110
         --  compute it.
3111
 
3112
         --  In Ada 2012, Freeze_Entities is also used in the front end to
3113
         --  trigger the analysis of aspect expressions, so in this case we
3114
         --  want to continue the freezing process.
3115
 
3116
         if Present (Scope (E))
3117
           and then Is_Generic_Unit (Scope (E))
3118
           and then not Has_Predicates (E)
3119
         then
3120
            Check_Compile_Time_Size (E);
3121
            return No_List;
3122
         end if;
3123
 
3124
         --  Deal with special cases of freezing for subtype
3125
 
3126
         if E /= Base_Type (E) then
3127
 
3128
            --  Before we do anything else, a specialized test for the case of
3129
            --  a size given for an array where the array needs to be packed,
3130
            --  but was not so the size cannot be honored. This would of course
3131
            --  be caught by the backend, and indeed we don't catch all cases.
3132
            --  The point is that we can give a better error message in those
3133
            --  cases that we do catch with the circuitry here. Also if pragma
3134
            --  Implicit_Packing is set, this is where the packing occurs.
3135
 
3136
            --  The reason we do this so early is that the processing in the
3137
            --  automatic packing case affects the layout of the base type, so
3138
            --  it must be done before we freeze the base type.
3139
 
3140
            if Is_Array_Type (E) then
3141
               declare
3142
                  Lo, Hi : Node_Id;
3143
                  Ctyp   : constant Entity_Id := Component_Type (E);
3144
 
3145
               begin
3146
                  --  Check enabling conditions. These are straightforward
3147
                  --  except for the test for a limited composite type. This
3148
                  --  eliminates the rare case of a array of limited components
3149
                  --  where there are issues of whether or not we can go ahead
3150
                  --  and pack the array (since we can't freely pack and unpack
3151
                  --  arrays if they are limited).
3152
 
3153
                  --  Note that we check the root type explicitly because the
3154
                  --  whole point is we are doing this test before we have had
3155
                  --  a chance to freeze the base type (and it is that freeze
3156
                  --  action that causes stuff to be inherited).
3157
 
3158
                  if Present (Size_Clause (E))
3159
                    and then Known_Static_RM_Size (E)
3160
                    and then not Is_Packed (E)
3161
                    and then not Has_Pragma_Pack (E)
3162
                    and then Number_Dimensions (E) = 1
3163
                    and then not Has_Component_Size_Clause (E)
3164
                    and then Known_Static_RM_Size (Ctyp)
3165
                    and then not Is_Limited_Composite (E)
3166
                    and then not Is_Packed (Root_Type (E))
3167
                    and then not Has_Component_Size_Clause (Root_Type (E))
3168
                    and then not (CodePeer_Mode or Alfa_Mode)
3169
                  then
3170
                     Get_Index_Bounds (First_Index (E), Lo, Hi);
3171
 
3172
                     if Compile_Time_Known_Value (Lo)
3173
                       and then Compile_Time_Known_Value (Hi)
3174
                       and then Known_Static_RM_Size (Ctyp)
3175
                       and then RM_Size (Ctyp) < 64
3176
                     then
3177
                        declare
3178
                           Lov  : constant Uint      := Expr_Value (Lo);
3179
                           Hiv  : constant Uint      := Expr_Value (Hi);
3180
                           Len  : constant Uint      := UI_Max
3181
                                                         (Uint_0,
3182
                                                          Hiv - Lov + 1);
3183
                           Rsiz : constant Uint      := RM_Size (Ctyp);
3184
                           SZ   : constant Node_Id   := Size_Clause (E);
3185
                           Btyp : constant Entity_Id := Base_Type (E);
3186
 
3187
                        --  What we are looking for here is the situation where
3188
                        --  the RM_Size given would be exactly right if there
3189
                        --  was a pragma Pack (resulting in the component size
3190
                        --  being the same as the RM_Size). Furthermore, the
3191
                        --  component type size must be an odd size (not a
3192
                        --  multiple of storage unit). If the component RM size
3193
                        --  is an exact number of storage units that is a power
3194
                        --  of two, the array is not packed and has a standard
3195
                        --  representation.
3196
 
3197
                        begin
3198
                           if RM_Size (E) = Len * Rsiz
3199
                             and then Rsiz mod System_Storage_Unit /= 0
3200
                           then
3201
                              --  For implicit packing mode, just set the
3202
                              --  component size silently.
3203
 
3204
                              if Implicit_Packing then
3205
                                 Set_Component_Size       (Btyp, Rsiz);
3206
                                 Set_Is_Bit_Packed_Array  (Btyp);
3207
                                 Set_Is_Packed            (Btyp);
3208
                                 Set_Has_Non_Standard_Rep (Btyp);
3209
 
3210
                                 --  Otherwise give an error message
3211
 
3212
                              else
3213
                                 Error_Msg_NE
3214
                                   ("size given for& too small", SZ, E);
3215
                                 Error_Msg_N -- CODEFIX
3216
                                   ("\use explicit pragma Pack "
3217
                                    & "or use pragma Implicit_Packing", SZ);
3218
                              end if;
3219
 
3220
                           elsif RM_Size (E) = Len * Rsiz
3221
                             and then Implicit_Packing
3222
                             and then
3223
                               (Rsiz / System_Storage_Unit = 1
3224
                                 or else Rsiz / System_Storage_Unit = 2
3225
                                 or else Rsiz / System_Storage_Unit = 4)
3226
                           then
3227
 
3228
                              --  Not a packed array, but indicate the desired
3229
                              --  component size, for the back-end.
3230
 
3231
                              Set_Component_Size (Btyp, Rsiz);
3232
                           end if;
3233
                        end;
3234
                     end if;
3235
                  end if;
3236
               end;
3237
            end if;
3238
 
3239
            --  If ancestor subtype present, freeze that first. Note that this
3240
            --  will also get the base type frozen. Need RM reference ???
3241
 
3242
            Atype := Ancestor_Subtype (E);
3243
 
3244
            if Present (Atype) then
3245
               Freeze_And_Append (Atype, N, Result);
3246
 
3247
            --  No ancestor subtype present
3248
 
3249
            else
3250
               --  See if we have a nearest ancestor that has a predicate.
3251
               --  That catches the case of derived type with a predicate.
3252
               --  Need RM reference here ???
3253
 
3254
               Atype := Nearest_Ancestor (E);
3255
 
3256
               if Present (Atype) and then Has_Predicates (Atype) then
3257
                  Freeze_And_Append (Atype, N, Result);
3258
               end if;
3259
 
3260
               --  Freeze base type before freezing the entity (RM 13.14(15))
3261
 
3262
               if E /= Base_Type (E) then
3263
                  Freeze_And_Append (Base_Type (E), N, Result);
3264
               end if;
3265
            end if;
3266
 
3267
         --  For a derived type, freeze its parent type first (RM 13.14(15))
3268
 
3269
         elsif Is_Derived_Type (E) then
3270
            Freeze_And_Append (Etype (E), N, Result);
3271
            Freeze_And_Append (First_Subtype (Etype (E)), N, Result);
3272
         end if;
3273
 
3274
         --  For array type, freeze index types and component type first
3275
         --  before freezing the array (RM 13.14(15)).
3276
 
3277
         if Is_Array_Type (E) then
3278
            declare
3279
               FS     : constant Entity_Id := First_Subtype (E);
3280
               Ctyp   : constant Entity_Id := Component_Type (E);
3281
               Clause : Entity_Id;
3282
 
3283
               Non_Standard_Enum : Boolean := False;
3284
               --  Set true if any of the index types is an enumeration type
3285
               --  with a non-standard representation.
3286
 
3287
            begin
3288
               Freeze_And_Append (Ctyp, N, Result);
3289
 
3290
               Indx := First_Index (E);
3291
               while Present (Indx) loop
3292
                  Freeze_And_Append (Etype (Indx), N, Result);
3293
 
3294
                  if Is_Enumeration_Type (Etype (Indx))
3295
                    and then Has_Non_Standard_Rep (Etype (Indx))
3296
                  then
3297
                     Non_Standard_Enum := True;
3298
                  end if;
3299
 
3300
                  Next_Index (Indx);
3301
               end loop;
3302
 
3303
               --  Processing that is done only for base types
3304
 
3305
               if Ekind (E) = E_Array_Type then
3306
 
3307
                  --  Propagate flags for component type
3308
 
3309
                  if Is_Controlled (Component_Type (E))
3310
                    or else Has_Controlled_Component (Ctyp)
3311
                  then
3312
                     Set_Has_Controlled_Component (E);
3313
                  end if;
3314
 
3315
                  if Has_Unchecked_Union (Component_Type (E)) then
3316
                     Set_Has_Unchecked_Union (E);
3317
                  end if;
3318
 
3319
                  --  If packing was requested or if the component size was set
3320
                  --  explicitly, then see if bit packing is required. This
3321
                  --  processing is only done for base types, since all the
3322
                  --  representation aspects involved are type-related. This
3323
                  --  is not just an optimization, if we start processing the
3324
                  --  subtypes, they interfere with the settings on the base
3325
                  --  type (this is because Is_Packed has a slightly different
3326
                  --  meaning before and after freezing).
3327
 
3328
                  declare
3329
                     Csiz : Uint;
3330
                     Esiz : Uint;
3331
 
3332
                  begin
3333
                     if (Is_Packed (E) or else Has_Pragma_Pack (E))
3334
                       and then Known_Static_RM_Size (Ctyp)
3335
                       and then not Has_Component_Size_Clause (E)
3336
                     then
3337
                        Csiz := UI_Max (RM_Size (Ctyp), 1);
3338
 
3339
                     elsif Known_Component_Size (E) then
3340
                        Csiz := Component_Size (E);
3341
 
3342
                     elsif not Known_Static_Esize (Ctyp) then
3343
                        Csiz := Uint_0;
3344
 
3345
                     else
3346
                        Esiz := Esize (Ctyp);
3347
 
3348
                        --  We can set the component size if it is less than
3349
                        --  16, rounding it up to the next storage unit size.
3350
 
3351
                        if Esiz <= 8 then
3352
                           Csiz := Uint_8;
3353
                        elsif Esiz <= 16 then
3354
                           Csiz := Uint_16;
3355
                        else
3356
                           Csiz := Uint_0;
3357
                        end if;
3358
 
3359
                        --  Set component size up to match alignment if it
3360
                        --  would otherwise be less than the alignment. This
3361
                        --  deals with cases of types whose alignment exceeds
3362
                        --  their size (padded types).
3363
 
3364
                        if Csiz /= 0 then
3365
                           declare
3366
                              A : constant Uint := Alignment_In_Bits (Ctyp);
3367
                           begin
3368
                              if Csiz < A then
3369
                                 Csiz := A;
3370
                              end if;
3371
                           end;
3372
                        end if;
3373
                     end if;
3374
 
3375
                     --  Case of component size that may result in packing
3376
 
3377
                     if 1 <= Csiz and then Csiz <= 64 then
3378
                        declare
3379
                           Ent         : constant Entity_Id :=
3380
                                           First_Subtype (E);
3381
                           Pack_Pragma : constant Node_Id :=
3382
                                           Get_Rep_Pragma (Ent, Name_Pack);
3383
                           Comp_Size_C : constant Node_Id :=
3384
                                           Get_Attribute_Definition_Clause
3385
                                             (Ent, Attribute_Component_Size);
3386
                        begin
3387
                           --  Warn if we have pack and component size so that
3388
                           --  the pack is ignored.
3389
 
3390
                           --  Note: here we must check for the presence of a
3391
                           --  component size before checking for a Pack pragma
3392
                           --  to deal with the case where the array type is a
3393
                           --  derived type whose parent is currently private.
3394
 
3395
                           if Present (Comp_Size_C)
3396
                             and then Has_Pragma_Pack (Ent)
3397
                             and then Warn_On_Redundant_Constructs
3398
                           then
3399
                              Error_Msg_Sloc := Sloc (Comp_Size_C);
3400
                              Error_Msg_NE
3401
                                ("?pragma Pack for& ignored!",
3402
                                 Pack_Pragma, Ent);
3403
                              Error_Msg_N
3404
                                ("\?explicit component size given#!",
3405
                                 Pack_Pragma);
3406
                              Set_Is_Packed (Base_Type (Ent), False);
3407
                              Set_Is_Bit_Packed_Array (Base_Type (Ent), False);
3408
                           end if;
3409
 
3410
                           --  Set component size if not already set by a
3411
                           --  component size clause.
3412
 
3413
                           if not Present (Comp_Size_C) then
3414
                              Set_Component_Size (E, Csiz);
3415
                           end if;
3416
 
3417
                           --  Check for base type of 8, 16, 32 bits, where an
3418
                           --  unsigned subtype has a length one less than the
3419
                           --  base type (e.g. Natural subtype of Integer).
3420
 
3421
                           --  In such cases, if a component size was not set
3422
                           --  explicitly, then generate a warning.
3423
 
3424
                           if Has_Pragma_Pack (E)
3425
                             and then not Present (Comp_Size_C)
3426
                             and then
3427
                               (Csiz = 7 or else Csiz = 15 or else Csiz = 31)
3428
                             and then Esize (Base_Type (Ctyp)) = Csiz + 1
3429
                           then
3430
                              Error_Msg_Uint_1 := Csiz;
3431
 
3432
                              if Present (Pack_Pragma) then
3433
                                 Error_Msg_N
3434
                                   ("?pragma Pack causes component size "
3435
                                    & "to be ^!", Pack_Pragma);
3436
                                 Error_Msg_N
3437
                                   ("\?use Component_Size to set "
3438
                                    & "desired value!", Pack_Pragma);
3439
                              end if;
3440
                           end if;
3441
 
3442
                           --  Actual packing is not needed for 8, 16, 32, 64.
3443
                           --  Also not needed for 24 if alignment is 1.
3444
 
3445
                           if        Csiz = 8
3446
                             or else Csiz = 16
3447
                             or else Csiz = 32
3448
                             or else Csiz = 64
3449
                             or else (Csiz = 24 and then Alignment (Ctyp) = 1)
3450
                           then
3451
                              --  Here the array was requested to be packed,
3452
                              --  but the packing request had no effect, so
3453
                              --  Is_Packed is reset.
3454
 
3455
                              --  Note: semantically this means that we lose
3456
                              --  track of the fact that a derived type
3457
                              --  inherited a pragma Pack that was non-
3458
                              --  effective, but that seems fine.
3459
 
3460
                              --  We regard a Pack pragma as a request to set
3461
                              --  a representation characteristic, and this
3462
                              --  request may be ignored.
3463
 
3464
                              Set_Is_Packed           (Base_Type (E), False);
3465
                              Set_Is_Bit_Packed_Array (Base_Type (E), False);
3466
 
3467
                              if Known_Static_Esize (Component_Type (E))
3468
                                and then Esize (Component_Type (E)) = Csiz
3469
                              then
3470
                                 Set_Has_Non_Standard_Rep
3471
                                   (Base_Type (E), False);
3472
                              end if;
3473
 
3474
                           --  In all other cases, packing is indeed needed
3475
 
3476
                           else
3477
                              Set_Has_Non_Standard_Rep (Base_Type (E), True);
3478
                              Set_Is_Bit_Packed_Array  (Base_Type (E), True);
3479
                              Set_Is_Packed            (Base_Type (E), True);
3480
                           end if;
3481
                        end;
3482
                     end if;
3483
                  end;
3484
 
3485
                  --  Check for Atomic_Components or Aliased with unsuitable
3486
                  --  packing or explicit component size clause given.
3487
 
3488
                  if (Has_Atomic_Components (E)
3489
                       or else Has_Aliased_Components (E))
3490
                    and then (Has_Component_Size_Clause (E)
3491
                               or else Is_Packed (E))
3492
                  then
3493
                     Alias_Atomic_Check : declare
3494
 
3495
                        procedure Complain_CS (T : String);
3496
                        --  Outputs error messages for incorrect CS clause or
3497
                        --  pragma Pack for aliased or atomic components (T is
3498
                        --  "aliased" or "atomic");
3499
 
3500
                        -----------------
3501
                        -- Complain_CS --
3502
                        -----------------
3503
 
3504
                        procedure Complain_CS (T : String) is
3505
                        begin
3506
                           if Has_Component_Size_Clause (E) then
3507
                              Clause :=
3508
                                Get_Attribute_Definition_Clause
3509
                                  (FS, Attribute_Component_Size);
3510
 
3511
                              if Known_Static_Esize (Ctyp) then
3512
                                 Error_Msg_N
3513
                                   ("incorrect component size for "
3514
                                    & T & " components", Clause);
3515
                                 Error_Msg_Uint_1 := Esize (Ctyp);
3516
                                 Error_Msg_N
3517
                                   ("\only allowed value is^", Clause);
3518
 
3519
                              else
3520
                                 Error_Msg_N
3521
                                   ("component size cannot be given for "
3522
                                    & T & " components", Clause);
3523
                              end if;
3524
 
3525
                           else
3526
                              Error_Msg_N
3527
                                ("cannot pack " & T & " components",
3528
                                 Get_Rep_Pragma (FS, Name_Pack));
3529
                           end if;
3530
 
3531
                           return;
3532
                        end Complain_CS;
3533
 
3534
                     --  Start of processing for Alias_Atomic_Check
3535
 
3536
                     begin
3537
 
3538
                        --  If object size of component type isn't known, we
3539
                        --  cannot be sure so we defer to the back end.
3540
 
3541
                        if not Known_Static_Esize (Ctyp) then
3542
                           null;
3543
 
3544
                        --  Case where component size has no effect. First
3545
                        --  check for object size of component type multiple
3546
                        --  of the storage unit size.
3547
 
3548
                        elsif Esize (Ctyp) mod System_Storage_Unit = 0
3549
 
3550
                          --  OK in both packing case and component size case
3551
                          --  if RM size is known and static and the same as
3552
                          --  the object size.
3553
 
3554
                          and then
3555
                            ((Known_Static_RM_Size (Ctyp)
3556
                               and then Esize (Ctyp) = RM_Size (Ctyp))
3557
 
3558
                             --  Or if we have an explicit component size
3559
                             --  clause and the component size and object size
3560
                             --  are equal.
3561
 
3562
                             or else
3563
                                 (Has_Component_Size_Clause (E)
3564
                                 and then Component_Size (E) = Esize (Ctyp)))
3565
                        then
3566
                           null;
3567
 
3568
                        elsif Has_Aliased_Components (E)
3569
                          or else Is_Aliased (Ctyp)
3570
                        then
3571
                           Complain_CS ("aliased");
3572
 
3573
                        elsif Has_Atomic_Components (E)
3574
                          or else Is_Atomic (Ctyp)
3575
                        then
3576
                           Complain_CS ("atomic");
3577
                        end if;
3578
                     end Alias_Atomic_Check;
3579
                  end if;
3580
 
3581
                  --  Warn for case of atomic type
3582
 
3583
                  Clause := Get_Rep_Pragma (FS, Name_Atomic);
3584
 
3585
                  if Present (Clause)
3586
                    and then not Addressable (Component_Size (FS))
3587
                  then
3588
                     Error_Msg_NE
3589
                       ("non-atomic components of type& may not be "
3590
                        & "accessible by separate tasks?", Clause, E);
3591
 
3592
                     if Has_Component_Size_Clause (E) then
3593
                        Error_Msg_Sloc :=
3594
                          Sloc
3595
                            (Get_Attribute_Definition_Clause
3596
                                 (FS, Attribute_Component_Size));
3597
                        Error_Msg_N
3598
                          ("\because of component size clause#?",
3599
                           Clause);
3600
 
3601
                     elsif Has_Pragma_Pack (E) then
3602
                        Error_Msg_Sloc :=
3603
                          Sloc (Get_Rep_Pragma (FS, Name_Pack));
3604
                        Error_Msg_N
3605
                          ("\because of pragma Pack#?", Clause);
3606
                     end if;
3607
                  end if;
3608
 
3609
               --  Processing that is done only for subtypes
3610
 
3611
               else
3612
                  --  Acquire alignment from base type
3613
 
3614
                  if Unknown_Alignment (E) then
3615
                     Set_Alignment (E, Alignment (Base_Type (E)));
3616
                     Adjust_Esize_Alignment (E);
3617
                  end if;
3618
               end if;
3619
 
3620
               --  For bit-packed arrays, check the size
3621
 
3622
               if Is_Bit_Packed_Array (E) and then Known_RM_Size (E) then
3623
                  declare
3624
                     SizC : constant Node_Id := Size_Clause (E);
3625
 
3626
                     Discard : Boolean;
3627
                     pragma Warnings (Off, Discard);
3628
 
3629
                  begin
3630
                     --  It is not clear if it is possible to have no size
3631
                     --  clause at this stage, but it is not worth worrying
3632
                     --  about. Post error on the entity name in the size
3633
                     --  clause if present, else on the type entity itself.
3634
 
3635
                     if Present (SizC) then
3636
                        Check_Size (Name (SizC), E, RM_Size (E), Discard);
3637
                     else
3638
                        Check_Size (E, E, RM_Size (E), Discard);
3639
                     end if;
3640
                  end;
3641
               end if;
3642
 
3643
               --  If any of the index types was an enumeration type with a
3644
               --  non-standard rep clause, then we indicate that the array
3645
               --  type is always packed (even if it is not bit packed).
3646
 
3647
               if Non_Standard_Enum then
3648
                  Set_Has_Non_Standard_Rep (Base_Type (E));
3649
                  Set_Is_Packed            (Base_Type (E));
3650
               end if;
3651
 
3652
               Set_Component_Alignment_If_Not_Set (E);
3653
 
3654
               --  If the array is packed, we must create the packed array
3655
               --  type to be used to actually implement the type. This is
3656
               --  only needed for real array types (not for string literal
3657
               --  types, since they are present only for the front end).
3658
 
3659
               if Is_Packed (E)
3660
                 and then Ekind (E) /= E_String_Literal_Subtype
3661
               then
3662
                  Create_Packed_Array_Type (E);
3663
                  Freeze_And_Append (Packed_Array_Type (E), N, Result);
3664
 
3665
                  --  Size information of packed array type is copied to the
3666
                  --  array type, since this is really the representation. But
3667
                  --  do not override explicit existing size values. If the
3668
                  --  ancestor subtype is constrained the packed_array_type
3669
                  --  will be inherited from it, but the size may have been
3670
                  --  provided already, and must not be overridden either.
3671
 
3672
                  if not Has_Size_Clause (E)
3673
                    and then
3674
                      (No (Ancestor_Subtype (E))
3675
                        or else not Has_Size_Clause (Ancestor_Subtype (E)))
3676
                  then
3677
                     Set_Esize     (E, Esize     (Packed_Array_Type (E)));
3678
                     Set_RM_Size   (E, RM_Size   (Packed_Array_Type (E)));
3679
                  end if;
3680
 
3681
                  if not Has_Alignment_Clause (E) then
3682
                     Set_Alignment (E, Alignment (Packed_Array_Type (E)));
3683
                  end if;
3684
               end if;
3685
 
3686
               --  For non-packed arrays set the alignment of the array to the
3687
               --  alignment of the component type if it is unknown. Skip this
3688
               --  in atomic case (atomic arrays may need larger alignments).
3689
 
3690
               if not Is_Packed (E)
3691
                 and then Unknown_Alignment (E)
3692
                 and then Known_Alignment (Ctyp)
3693
                 and then Known_Static_Component_Size (E)
3694
                 and then Known_Static_Esize (Ctyp)
3695
                 and then Esize (Ctyp) = Component_Size (E)
3696
                 and then not Is_Atomic (E)
3697
               then
3698
                  Set_Alignment (E, Alignment (Component_Type (E)));
3699
               end if;
3700
            end;
3701
 
3702
         --  For a class-wide type, the corresponding specific type is
3703
         --  frozen as well (RM 13.14(15))
3704
 
3705
         elsif Is_Class_Wide_Type (E) then
3706
            Freeze_And_Append (Root_Type (E), N, Result);
3707
 
3708
            --  If the base type of the class-wide type is still incomplete,
3709
            --  the class-wide remains unfrozen as well. This is legal when
3710
            --  E is the formal of a primitive operation of some other type
3711
            --  which is being frozen.
3712
 
3713
            if not Is_Frozen (Root_Type (E)) then
3714
               Set_Is_Frozen (E, False);
3715
               return Result;
3716
            end if;
3717
 
3718
            --  If the Class_Wide_Type is an Itype (when type is the anonymous
3719
            --  parent of a derived type) and it is a library-level entity,
3720
            --  generate an itype reference for it. Otherwise, its first
3721
            --  explicit reference may be in an inner scope, which will be
3722
            --  rejected by the back-end.
3723
 
3724
            if Is_Itype (E)
3725
              and then Is_Compilation_Unit (Scope (E))
3726
            then
3727
               declare
3728
                  Ref : constant Node_Id := Make_Itype_Reference (Loc);
3729
 
3730
               begin
3731
                  Set_Itype (Ref, E);
3732
                  Add_To_Result (Ref);
3733
               end;
3734
            end if;
3735
 
3736
            --  The equivalent type associated with a class-wide subtype needs
3737
            --  to be frozen to ensure that its layout is done.
3738
 
3739
            if Ekind (E) = E_Class_Wide_Subtype
3740
              and then Present (Equivalent_Type (E))
3741
            then
3742
               Freeze_And_Append (Equivalent_Type (E), N, Result);
3743
            end if;
3744
 
3745
         --  For a record (sub)type, freeze all the component types (RM
3746
         --  13.14(15). We test for E_Record_(sub)Type here, rather than using
3747
         --  Is_Record_Type, because we don't want to attempt the freeze for
3748
         --  the case of a private type with record extension (we will do that
3749
         --  later when the full type is frozen).
3750
 
3751
         elsif Ekind (E) = E_Record_Type
3752
           or else Ekind (E) = E_Record_Subtype
3753
         then
3754
            Freeze_Record_Type (E);
3755
 
3756
         --  For a concurrent type, freeze corresponding record type. This
3757
         --  does not correspond to any specific rule in the RM, but the
3758
         --  record type is essentially part of the concurrent type.
3759
         --  Freeze as well all local entities. This includes record types
3760
         --  created for entry parameter blocks, and whatever local entities
3761
         --  may appear in the private part.
3762
 
3763
         elsif Is_Concurrent_Type (E) then
3764
            if Present (Corresponding_Record_Type (E)) then
3765
               Freeze_And_Append
3766
                 (Corresponding_Record_Type (E), N, Result);
3767
            end if;
3768
 
3769
            Comp := First_Entity (E);
3770
            while Present (Comp) loop
3771
               if Is_Type (Comp) then
3772
                  Freeze_And_Append (Comp, N, Result);
3773
 
3774
               elsif (Ekind (Comp)) /= E_Function then
3775
                  if Is_Itype (Etype (Comp))
3776
                    and then Underlying_Type (Scope (Etype (Comp))) = E
3777
                  then
3778
                     Undelay_Type (Etype (Comp));
3779
                  end if;
3780
 
3781
                  Freeze_And_Append (Etype (Comp), N, Result);
3782
               end if;
3783
 
3784
               Next_Entity (Comp);
3785
            end loop;
3786
 
3787
         --  Private types are required to point to the same freeze node as
3788
         --  their corresponding full views. The freeze node itself has to
3789
         --  point to the partial view of the entity (because from the partial
3790
         --  view, we can retrieve the full view, but not the reverse).
3791
         --  However, in order to freeze correctly, we need to freeze the full
3792
         --  view. If we are freezing at the end of a scope (or within the
3793
         --  scope of the private type), the partial and full views will have
3794
         --  been swapped, the full view appears first in the entity chain and
3795
         --  the swapping mechanism ensures that the pointers are properly set
3796
         --  (on scope exit).
3797
 
3798
         --  If we encounter the partial view before the full view (e.g. when
3799
         --  freezing from another scope), we freeze the full view, and then
3800
         --  set the pointers appropriately since we cannot rely on swapping to
3801
         --  fix things up (subtypes in an outer scope might not get swapped).
3802
 
3803
         elsif Is_Incomplete_Or_Private_Type (E)
3804
           and then not Is_Generic_Type (E)
3805
         then
3806
            --  The construction of the dispatch table associated with library
3807
            --  level tagged types forces freezing of all the primitives of the
3808
            --  type, which may cause premature freezing of the partial view.
3809
            --  For example:
3810
 
3811
            --     package Pkg is
3812
            --        type T is tagged private;
3813
            --        type DT is new T with private;
3814
            --        procedure Prim (X : in out T; Y : in out DT'Class);
3815
            --     private
3816
            --        type T is tagged null record;
3817
            --        Obj : T;
3818
            --        type DT is new T with null record;
3819
            --     end;
3820
 
3821
            --  In this case the type will be frozen later by the usual
3822
            --  mechanism: an object declaration, an instantiation, or the
3823
            --  end of a declarative part.
3824
 
3825
            if Is_Library_Level_Tagged_Type (E)
3826
              and then not Present (Full_View (E))
3827
            then
3828
               Set_Is_Frozen (E, False);
3829
               return Result;
3830
 
3831
            --  Case of full view present
3832
 
3833
            elsif Present (Full_View (E)) then
3834
 
3835
               --  If full view has already been frozen, then no further
3836
               --  processing is required
3837
 
3838
               if Is_Frozen (Full_View (E)) then
3839
                  Set_Has_Delayed_Freeze (E, False);
3840
                  Set_Freeze_Node (E, Empty);
3841
                  Check_Debug_Info_Needed (E);
3842
 
3843
               --  Otherwise freeze full view and patch the pointers so that
3844
               --  the freeze node will elaborate both views in the back-end.
3845
 
3846
               else
3847
                  declare
3848
                     Full : constant Entity_Id := Full_View (E);
3849
 
3850
                  begin
3851
                     if Is_Private_Type (Full)
3852
                       and then Present (Underlying_Full_View (Full))
3853
                     then
3854
                        Freeze_And_Append
3855
                          (Underlying_Full_View (Full), N, Result);
3856
                     end if;
3857
 
3858
                     Freeze_And_Append (Full, N, Result);
3859
 
3860
                     if Has_Delayed_Freeze (E) then
3861
                        F_Node := Freeze_Node (Full);
3862
 
3863
                        if Present (F_Node) then
3864
                           Set_Freeze_Node (E, F_Node);
3865
                           Set_Entity (F_Node, E);
3866
 
3867
                        else
3868
                           --  {Incomplete,Private}_Subtypes with Full_Views
3869
                           --  constrained by discriminants.
3870
 
3871
                           Set_Has_Delayed_Freeze (E, False);
3872
                           Set_Freeze_Node (E, Empty);
3873
                        end if;
3874
                     end if;
3875
                  end;
3876
 
3877
                  Check_Debug_Info_Needed (E);
3878
               end if;
3879
 
3880
               --  AI-117 requires that the convention of a partial view be the
3881
               --  same as the convention of the full view. Note that this is a
3882
               --  recognized breach of privacy, but it's essential for logical
3883
               --  consistency of representation, and the lack of a rule in
3884
               --  RM95 was an oversight.
3885
 
3886
               Set_Convention (E, Convention (Full_View (E)));
3887
 
3888
               Set_Size_Known_At_Compile_Time (E,
3889
                 Size_Known_At_Compile_Time (Full_View (E)));
3890
 
3891
               --  Size information is copied from the full view to the
3892
               --  incomplete or private view for consistency.
3893
 
3894
               --  We skip this is the full view is not a type. This is very
3895
               --  strange of course, and can only happen as a result of
3896
               --  certain illegalities, such as a premature attempt to derive
3897
               --  from an incomplete type.
3898
 
3899
               if Is_Type (Full_View (E)) then
3900
                  Set_Size_Info (E, Full_View (E));
3901
                  Set_RM_Size   (E, RM_Size (Full_View (E)));
3902
               end if;
3903
 
3904
               return Result;
3905
 
3906
            --  Case of no full view present. If entity is derived or subtype,
3907
            --  it is safe to freeze, correctness depends on the frozen status
3908
            --  of parent. Otherwise it is either premature usage, or a Taft
3909
            --  amendment type, so diagnosis is at the point of use and the
3910
            --  type might be frozen later.
3911
 
3912
            elsif E /= Base_Type (E)
3913
              or else Is_Derived_Type (E)
3914
            then
3915
               null;
3916
 
3917
            else
3918
               Set_Is_Frozen (E, False);
3919
               return No_List;
3920
            end if;
3921
 
3922
         --  For access subprogram, freeze types of all formals, the return
3923
         --  type was already frozen, since it is the Etype of the function.
3924
         --  Formal types can be tagged Taft amendment types, but otherwise
3925
         --  they cannot be incomplete.
3926
 
3927
         elsif Ekind (E) = E_Subprogram_Type then
3928
            Formal := First_Formal (E);
3929
            while Present (Formal) loop
3930
               if Ekind (Etype (Formal)) = E_Incomplete_Type
3931
                 and then No (Full_View (Etype (Formal)))
3932
                 and then not Is_Value_Type (Etype (Formal))
3933
               then
3934
                  if Is_Tagged_Type (Etype (Formal)) then
3935
                     null;
3936
 
3937
                  --  AI05-151: Incomplete types are allowed in access to
3938
                  --  subprogram specifications.
3939
 
3940
                  elsif Ada_Version < Ada_2012 then
3941
                     Error_Msg_NE
3942
                       ("invalid use of incomplete type&", E, Etype (Formal));
3943
                  end if;
3944
               end if;
3945
 
3946
               Freeze_And_Append (Etype (Formal), N, Result);
3947
               Next_Formal (Formal);
3948
            end loop;
3949
 
3950
            Freeze_Subprogram (E);
3951
 
3952
         --  For access to a protected subprogram, freeze the equivalent type
3953
         --  (however this is not set if we are not generating code or if this
3954
         --  is an anonymous type used just for resolution).
3955
 
3956
         elsif Is_Access_Protected_Subprogram_Type (E) then
3957
            if Present (Equivalent_Type (E)) then
3958
               Freeze_And_Append (Equivalent_Type (E), N, Result);
3959
            end if;
3960
         end if;
3961
 
3962
         --  Generic types are never seen by the back-end, and are also not
3963
         --  processed by the expander (since the expander is turned off for
3964
         --  generic processing), so we never need freeze nodes for them.
3965
 
3966
         if Is_Generic_Type (E) then
3967
            return Result;
3968
         end if;
3969
 
3970
         --  Some special processing for non-generic types to complete
3971
         --  representation details not known till the freeze point.
3972
 
3973
         if Is_Fixed_Point_Type (E) then
3974
            Freeze_Fixed_Point_Type (E);
3975
 
3976
            --  Some error checks required for ordinary fixed-point type. Defer
3977
            --  these till the freeze-point since we need the small and range
3978
            --  values. We only do these checks for base types
3979
 
3980
            if Is_Ordinary_Fixed_Point_Type (E) and then Is_Base_Type (E) then
3981
               if Small_Value (E) < Ureal_2_M_80 then
3982
                  Error_Msg_Name_1 := Name_Small;
3983
                  Error_Msg_N
3984
                    ("`&''%` too small, minimum allowed is 2.0'*'*(-80)", E);
3985
 
3986
               elsif Small_Value (E) > Ureal_2_80 then
3987
                  Error_Msg_Name_1 := Name_Small;
3988
                  Error_Msg_N
3989
                    ("`&''%` too large, maximum allowed is 2.0'*'*80", E);
3990
               end if;
3991
 
3992
               if Expr_Value_R (Type_Low_Bound (E)) < Ureal_M_10_36 then
3993
                  Error_Msg_Name_1 := Name_First;
3994
                  Error_Msg_N
3995
                    ("`&''%` too small, minimum allowed is -10.0'*'*36", E);
3996
               end if;
3997
 
3998
               if Expr_Value_R (Type_High_Bound (E)) > Ureal_10_36 then
3999
                  Error_Msg_Name_1 := Name_Last;
4000
                  Error_Msg_N
4001
                    ("`&''%` too large, maximum allowed is 10.0'*'*36", E);
4002
               end if;
4003
            end if;
4004
 
4005
         elsif Is_Enumeration_Type (E) then
4006
            Freeze_Enumeration_Type (E);
4007
 
4008
         elsif Is_Integer_Type (E) then
4009
            Adjust_Esize_For_Alignment (E);
4010
 
4011
            if Is_Modular_Integer_Type (E)
4012
              and then Warn_On_Suspicious_Modulus_Value
4013
            then
4014
               Check_Suspicious_Modulus (E);
4015
            end if;
4016
 
4017
         elsif Is_Access_Type (E) then
4018
 
4019
            --  If a pragma Default_Storage_Pool applies, and this type has no
4020
            --  Storage_Pool or Storage_Size clause (which must have occurred
4021
            --  before the freezing point), then use the default. This applies
4022
            --  only to base types.
4023
 
4024
            if Present (Default_Pool)
4025
              and then Is_Base_Type (E)
4026
              and then not Has_Storage_Size_Clause (E)
4027
              and then No (Associated_Storage_Pool (E))
4028
            then
4029
               --  Case of pragma Default_Storage_Pool (null)
4030
 
4031
               if Nkind (Default_Pool) = N_Null then
4032
                  Set_No_Pool_Assigned (E);
4033
 
4034
               --  Case of pragma Default_Storage_Pool (storage_pool_NAME)
4035
 
4036
               else
4037
                  Set_Associated_Storage_Pool (E, Entity (Default_Pool));
4038
               end if;
4039
            end if;
4040
 
4041
            --  Check restriction for standard storage pool
4042
 
4043
            if No (Associated_Storage_Pool (E)) then
4044
               Check_Restriction (No_Standard_Storage_Pools, E);
4045
            end if;
4046
 
4047
            --  Deal with error message for pure access type. This is not an
4048
            --  error in Ada 2005 if there is no pool (see AI-366).
4049
 
4050
            if Is_Pure_Unit_Access_Type (E)
4051
              and then (Ada_Version < Ada_2005
4052
                         or else not No_Pool_Assigned (E))
4053
            then
4054
               Error_Msg_N ("named access type not allowed in pure unit", E);
4055
 
4056
               if Ada_Version >= Ada_2005 then
4057
                  Error_Msg_N
4058
                    ("\would be legal if Storage_Size of 0 given?", E);
4059
 
4060
               elsif No_Pool_Assigned (E) then
4061
                  Error_Msg_N
4062
                    ("\would be legal in Ada 2005?", E);
4063
 
4064
               else
4065
                  Error_Msg_N
4066
                    ("\would be legal in Ada 2005 if "
4067
                     & "Storage_Size of 0 given?", E);
4068
               end if;
4069
            end if;
4070
         end if;
4071
 
4072
         --  Case of composite types
4073
 
4074
         if Is_Composite_Type (E) then
4075
 
4076
            --  AI-117 requires that all new primitives of a tagged type must
4077
            --  inherit the convention of the full view of the type. Inherited
4078
            --  and overriding operations are defined to inherit the convention
4079
            --  of their parent or overridden subprogram (also specified in
4080
            --  AI-117), which will have occurred earlier (in Derive_Subprogram
4081
            --  and New_Overloaded_Entity). Here we set the convention of
4082
            --  primitives that are still convention Ada, which will ensure
4083
            --  that any new primitives inherit the type's convention. Class-
4084
            --  wide types can have a foreign convention inherited from their
4085
            --  specific type, but are excluded from this since they don't have
4086
            --  any associated primitives.
4087
 
4088
            if Is_Tagged_Type (E)
4089
              and then not Is_Class_Wide_Type (E)
4090
              and then Convention (E) /= Convention_Ada
4091
            then
4092
               declare
4093
                  Prim_List : constant Elist_Id := Primitive_Operations (E);
4094
                  Prim      : Elmt_Id;
4095
 
4096
               begin
4097
                  Prim := First_Elmt (Prim_List);
4098
                  while Present (Prim) loop
4099
                     if Convention (Node (Prim)) = Convention_Ada then
4100
                        Set_Convention (Node (Prim), Convention (E));
4101
                     end if;
4102
 
4103
                     Next_Elmt (Prim);
4104
                  end loop;
4105
               end;
4106
            end if;
4107
 
4108
            --  If the type is a simple storage pool type, then this is where
4109
            --  we attempt to locate and validate its Allocate, Deallocate, and
4110
            --  Storage_Size operations (the first is required, and the latter
4111
            --  two are optional). We also verify that the full type for a
4112
            --  private type is allowed to be a simple storage pool type.
4113
 
4114
            if Present (Get_Rep_Pragma (E, Name_Simple_Storage_Pool_Type))
4115
              and then (Is_Base_Type (E) or else Has_Private_Declaration (E))
4116
            then
4117
               --  If the type is marked Has_Private_Declaration, then this is
4118
               --  a full type for a private type that was specified with the
4119
               --  pragma Simple_Storage_Pool_Type, and here we ensure that the
4120
               --  pragma is allowed for the full type (for example, it can't
4121
               --  be an array type, or a nonlimited record type).
4122
 
4123
               if Has_Private_Declaration (E) then
4124
                  if (not Is_Record_Type (E)
4125
                       or else not Is_Immutably_Limited_Type (E))
4126
                    and then not Is_Private_Type (E)
4127
                  then
4128
                     Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type;
4129
                     Error_Msg_N
4130
                       ("pragma% can only apply to full type that is an " &
4131
                        "explicitly limited type", E);
4132
                  end if;
4133
               end if;
4134
 
4135
               Validate_Simple_Pool_Ops : declare
4136
                  Pool_Type    : Entity_Id renames E;
4137
                  Address_Type : constant Entity_Id := RTE (RE_Address);
4138
                  Stg_Cnt_Type : constant Entity_Id := RTE (RE_Storage_Count);
4139
 
4140
                  procedure Validate_Simple_Pool_Op_Formal
4141
                    (Pool_Op        : Entity_Id;
4142
                     Pool_Op_Formal : in out Entity_Id;
4143
                     Expected_Mode  : Formal_Kind;
4144
                     Expected_Type  : Entity_Id;
4145
                     Formal_Name    : String;
4146
                     OK_Formal      : in out Boolean);
4147
                  --  Validate one formal Pool_Op_Formal of the candidate pool
4148
                  --  operation Pool_Op. The formal must be of Expected_Type
4149
                  --  and have mode Expected_Mode. OK_Formal will be set to
4150
                  --  False if the formal doesn't match. If OK_Formal is False
4151
                  --  on entry, then the formal will effectively be ignored
4152
                  --  (because validation of the pool op has already failed).
4153
                  --  Upon return, Pool_Op_Formal will be updated to the next
4154
                  --  formal, if any.
4155
 
4156
                  procedure Validate_Simple_Pool_Operation (Op_Name : Name_Id);
4157
                  --  Search for and validate a simple pool operation with the
4158
                  --  name Op_Name. If the name is Allocate, then there must be
4159
                  --  exactly one such primitive operation for the simple pool
4160
                  --  type. If the name is Deallocate or Storage_Size, then
4161
                  --  there can be at most one such primitive operation. The
4162
                  --  profile of the located primitive must conform to what
4163
                  --  is expected for each operation.
4164
 
4165
                  ------------------------------------
4166
                  -- Validate_Simple_Pool_Op_Formal --
4167
                  ------------------------------------
4168
 
4169
                  procedure Validate_Simple_Pool_Op_Formal
4170
                    (Pool_Op        : Entity_Id;
4171
                     Pool_Op_Formal : in out Entity_Id;
4172
                     Expected_Mode  : Formal_Kind;
4173
                     Expected_Type  : Entity_Id;
4174
                     Formal_Name    : String;
4175
                     OK_Formal      : in out Boolean)
4176
                  is
4177
                  begin
4178
                     --  If OK_Formal is False on entry, then simply ignore
4179
                     --  the formal, because an earlier formal has already
4180
                     --  been flagged.
4181
 
4182
                     if not OK_Formal then
4183
                        return;
4184
 
4185
                     --  If no formal is passed in, then issue an error for a
4186
                     --  missing formal.
4187
 
4188
                     elsif not Present (Pool_Op_Formal) then
4189
                        Error_Msg_NE
4190
                          ("simple storage pool op missing formal " &
4191
                           Formal_Name & " of type&", Pool_Op, Expected_Type);
4192
                        OK_Formal := False;
4193
 
4194
                        return;
4195
                     end if;
4196
 
4197
                     if Etype (Pool_Op_Formal) /= Expected_Type then
4198
 
4199
                        --  If the pool type was expected for this formal, then
4200
                        --  this will not be considered a candidate operation
4201
                        --  for the simple pool, so we unset OK_Formal so that
4202
                        --  the op and any later formals will be ignored.
4203
 
4204
                        if Expected_Type = Pool_Type then
4205
                           OK_Formal := False;
4206
 
4207
                           return;
4208
 
4209
                        else
4210
                           Error_Msg_NE
4211
                             ("wrong type for formal " & Formal_Name &
4212
                              " of simple storage pool op; expected type&",
4213
                              Pool_Op_Formal, Expected_Type);
4214
                        end if;
4215
                     end if;
4216
 
4217
                     --  Issue error if formal's mode is not the expected one
4218
 
4219
                     if Ekind (Pool_Op_Formal) /= Expected_Mode then
4220
                        Error_Msg_N
4221
                          ("wrong mode for formal of simple storage pool op",
4222
                           Pool_Op_Formal);
4223
                     end if;
4224
 
4225
                     --  Advance to the next formal
4226
 
4227
                     Next_Formal (Pool_Op_Formal);
4228
                  end Validate_Simple_Pool_Op_Formal;
4229
 
4230
                  ------------------------------------
4231
                  -- Validate_Simple_Pool_Operation --
4232
                  ------------------------------------
4233
 
4234
                  procedure Validate_Simple_Pool_Operation
4235
                    (Op_Name : Name_Id)
4236
                  is
4237
                     Op       : Entity_Id;
4238
                     Found_Op : Entity_Id := Empty;
4239
                     Formal   : Entity_Id;
4240
                     Is_OK    : Boolean;
4241
 
4242
                  begin
4243
                     pragma Assert
4244
                       (Op_Name = Name_Allocate
4245
                         or else Op_Name = Name_Deallocate
4246
                         or else Op_Name = Name_Storage_Size);
4247
 
4248
                     Error_Msg_Name_1 := Op_Name;
4249
 
4250
                     --  For each homonym declared immediately in the scope
4251
                     --  of the simple storage pool type, determine whether
4252
                     --  the homonym is an operation of the pool type, and,
4253
                     --  if so, check that its profile is as expected for
4254
                     --  a simple pool operation of that name.
4255
 
4256
                     Op := Get_Name_Entity_Id (Op_Name);
4257
                     while Present (Op) loop
4258
                        if Ekind_In (Op, E_Function, E_Procedure)
4259
                          and then Scope (Op) = Current_Scope
4260
                        then
4261
                           Formal := First_Entity (Op);
4262
 
4263
                           Is_OK := True;
4264
 
4265
                           --  The first parameter must be of the pool type
4266
                           --  in order for the operation to qualify.
4267
 
4268
                           if Op_Name = Name_Storage_Size then
4269
                              Validate_Simple_Pool_Op_Formal
4270
                                (Op, Formal, E_In_Parameter, Pool_Type,
4271
                                 "Pool", Is_OK);
4272
                           else
4273
                              Validate_Simple_Pool_Op_Formal
4274
                                (Op, Formal, E_In_Out_Parameter, Pool_Type,
4275
                                 "Pool", Is_OK);
4276
                           end if;
4277
 
4278
                           --  If another operation with this name has already
4279
                           --  been located for the type, then flag an error,
4280
                           --  since we only allow the type to have a single
4281
                           --  such primitive.
4282
 
4283
                           if Present (Found_Op) and then Is_OK then
4284
                              Error_Msg_NE
4285
                                ("only one % operation allowed for " &
4286
                                 "simple storage pool type&", Op, Pool_Type);
4287
                           end if;
4288
 
4289
                           --  In the case of Allocate and Deallocate, a formal
4290
                           --  of type System.Address is required.
4291
 
4292
                           if Op_Name = Name_Allocate then
4293
                              Validate_Simple_Pool_Op_Formal
4294
                                (Op, Formal, E_Out_Parameter,
4295
                                 Address_Type, "Storage_Address", Is_OK);
4296
                           elsif Op_Name = Name_Deallocate then
4297
                              Validate_Simple_Pool_Op_Formal
4298
                                (Op, Formal, E_In_Parameter,
4299
                                 Address_Type, "Storage_Address", Is_OK);
4300
                           end if;
4301
 
4302
                           --  In the case of Allocate and Deallocate, formals
4303
                           --  of type Storage_Count are required as the third
4304
                           --  and fourth parameters.
4305
 
4306
                           if Op_Name /= Name_Storage_Size then
4307
                              Validate_Simple_Pool_Op_Formal
4308
                                (Op, Formal, E_In_Parameter,
4309
                                 Stg_Cnt_Type, "Size_In_Storage_Units", Is_OK);
4310
                              Validate_Simple_Pool_Op_Formal
4311
                                (Op, Formal, E_In_Parameter,
4312
                                 Stg_Cnt_Type, "Alignment", Is_OK);
4313
                           end if;
4314
 
4315
                           --  If no mismatched formals have been found (Is_OK)
4316
                           --  and no excess formals are present, then this
4317
                           --  operation has been validated, so record it.
4318
 
4319
                           if not Present (Formal) and then Is_OK then
4320
                              Found_Op := Op;
4321
                           end if;
4322
                        end if;
4323
 
4324
                        Op := Homonym (Op);
4325
                     end loop;
4326
 
4327
                     --  There must be a valid Allocate operation for the type,
4328
                     --  so issue an error if none was found.
4329
 
4330
                     if Op_Name = Name_Allocate
4331
                       and then not Present (Found_Op)
4332
                     then
4333
                        Error_Msg_N ("missing % operation for simple " &
4334
                                     "storage pool type", Pool_Type);
4335
 
4336
                     elsif Present (Found_Op) then
4337
 
4338
                        --  Simple pool operations can't be abstract
4339
 
4340
                        if Is_Abstract_Subprogram (Found_Op) then
4341
                           Error_Msg_N
4342
                             ("simple storage pool operation must not be " &
4343
                              "abstract", Found_Op);
4344
                        end if;
4345
 
4346
                        --  The Storage_Size operation must be a function with
4347
                        --  Storage_Count as its result type.
4348
 
4349
                        if Op_Name = Name_Storage_Size then
4350
                           if Ekind (Found_Op) = E_Procedure then
4351
                              Error_Msg_N
4352
                                ("% operation must be a function", Found_Op);
4353
 
4354
                           elsif Etype (Found_Op) /= Stg_Cnt_Type then
4355
                              Error_Msg_NE
4356
                                ("wrong result type for%, expected type&",
4357
                                 Found_Op, Stg_Cnt_Type);
4358
                           end if;
4359
 
4360
                        --  Allocate and Deallocate must be procedures
4361
 
4362
                        elsif Ekind (Found_Op) = E_Function then
4363
                           Error_Msg_N
4364
                             ("% operation must be a procedure", Found_Op);
4365
                        end if;
4366
                     end if;
4367
                  end Validate_Simple_Pool_Operation;
4368
 
4369
               --  Start of processing for Validate_Simple_Pool_Ops
4370
 
4371
               begin
4372
                  Validate_Simple_Pool_Operation (Name_Allocate);
4373
                  Validate_Simple_Pool_Operation (Name_Deallocate);
4374
                  Validate_Simple_Pool_Operation (Name_Storage_Size);
4375
               end Validate_Simple_Pool_Ops;
4376
            end if;
4377
         end if;
4378
 
4379
         --  Now that all types from which E may depend are frozen, see if the
4380
         --  size is known at compile time, if it must be unsigned, or if
4381
         --  strict alignment is required
4382
 
4383
         Check_Compile_Time_Size (E);
4384
         Check_Unsigned_Type (E);
4385
 
4386
         if Base_Type (E) = E then
4387
            Check_Strict_Alignment (E);
4388
         end if;
4389
 
4390
         --  Do not allow a size clause for a type which does not have a size
4391
         --  that is known at compile time
4392
 
4393
         if Has_Size_Clause (E)
4394
           and then not Size_Known_At_Compile_Time (E)
4395
         then
4396
            --  Suppress this message if errors posted on E, even if we are
4397
            --  in all errors mode, since this is often a junk message
4398
 
4399
            if not Error_Posted (E) then
4400
               Error_Msg_N
4401
                 ("size clause not allowed for variable length type",
4402
                  Size_Clause (E));
4403
            end if;
4404
         end if;
4405
 
4406
         --  Now we set/verify the representation information, in particular
4407
         --  the size and alignment values. This processing is not required for
4408
         --  generic types, since generic types do not play any part in code
4409
         --  generation, and so the size and alignment values for such types
4410
         --  are irrelevant. Ditto for types declared within a generic unit,
4411
         --  which may have components that depend on generic parameters, and
4412
         --  that will be recreated in an instance.
4413
 
4414
         if Inside_A_Generic then
4415
            null;
4416
 
4417
         --  Otherwise we call the layout procedure
4418
 
4419
         else
4420
            Layout_Type (E);
4421
         end if;
4422
 
4423
         --  If this is an access to subprogram whose designated type is itself
4424
         --  a subprogram type, the return type of this anonymous subprogram
4425
         --  type must be decorated as well.
4426
 
4427
         if Ekind (E) = E_Anonymous_Access_Subprogram_Type
4428
           and then Ekind (Designated_Type (E)) = E_Subprogram_Type
4429
         then
4430
            Layout_Type (Etype (Designated_Type (E)));
4431
         end if;
4432
 
4433
         --  If the type has a Defaut_Value/Default_Component_Value aspect,
4434
         --  this is where we analye the expression (after the type is frozen,
4435
         --  since in the case of Default_Value, we are analyzing with the
4436
         --  type itself, and we treat Default_Component_Value similarly for
4437
         --  the sake of uniformity.
4438
 
4439
         if Is_First_Subtype (E) and then Has_Default_Aspect (E) then
4440
            declare
4441
               Nam : Name_Id;
4442
               Exp : Node_Id;
4443
               Typ : Entity_Id;
4444
 
4445
            begin
4446
               if Is_Scalar_Type (E) then
4447
                  Nam := Name_Default_Value;
4448
                  Typ := E;
4449
                  Exp := Default_Aspect_Value (Typ);
4450
               else
4451
                  Nam := Name_Default_Component_Value;
4452
                  Typ := Component_Type (E);
4453
                  Exp := Default_Aspect_Component_Value (E);
4454
               end if;
4455
 
4456
               Analyze_And_Resolve (Exp, Typ);
4457
 
4458
               if Etype (Exp) /= Any_Type then
4459
                  if not Is_Static_Expression (Exp) then
4460
                     Error_Msg_Name_1 := Nam;
4461
                     Flag_Non_Static_Expr
4462
                       ("aspect% requires static expression", Exp);
4463
                  end if;
4464
               end if;
4465
            end;
4466
         end if;
4467
 
4468
         --  End of freeze processing for type entities
4469
      end if;
4470
 
4471
      --  Here is where we logically freeze the current entity. If it has a
4472
      --  freeze node, then this is the point at which the freeze node is
4473
      --  linked into the result list.
4474
 
4475
      if Has_Delayed_Freeze (E) then
4476
 
4477
         --  If a freeze node is already allocated, use it, otherwise allocate
4478
         --  a new one. The preallocation happens in the case of anonymous base
4479
         --  types, where we preallocate so that we can set First_Subtype_Link.
4480
         --  Note that we reset the Sloc to the current freeze location.
4481
 
4482
         if Present (Freeze_Node (E)) then
4483
            F_Node := Freeze_Node (E);
4484
            Set_Sloc (F_Node, Loc);
4485
 
4486
         else
4487
            F_Node := New_Node (N_Freeze_Entity, Loc);
4488
            Set_Freeze_Node (E, F_Node);
4489
            Set_Access_Types_To_Process (F_Node, No_Elist);
4490
            Set_TSS_Elist (F_Node, No_Elist);
4491
            Set_Actions (F_Node, No_List);
4492
         end if;
4493
 
4494
         Set_Entity (F_Node, E);
4495
         Add_To_Result (F_Node);
4496
 
4497
         --  A final pass over record types with discriminants. If the type
4498
         --  has an incomplete declaration, there may be constrained access
4499
         --  subtypes declared elsewhere, which do not depend on the discrimi-
4500
         --  nants of the type, and which are used as component types (i.e.
4501
         --  the full view is a recursive type). The designated types of these
4502
         --  subtypes can only be elaborated after the type itself, and they
4503
         --  need an itype reference.
4504
 
4505
         if Ekind (E) = E_Record_Type
4506
           and then Has_Discriminants (E)
4507
         then
4508
            declare
4509
               Comp : Entity_Id;
4510
               IR   : Node_Id;
4511
               Typ  : Entity_Id;
4512
 
4513
            begin
4514
               Comp := First_Component (E);
4515
               while Present (Comp) loop
4516
                  Typ  := Etype (Comp);
4517
 
4518
                  if Ekind (Comp) = E_Component
4519
                    and then Is_Access_Type (Typ)
4520
                    and then Scope (Typ) /= E
4521
                    and then Base_Type (Designated_Type (Typ)) = E
4522
                    and then Is_Itype (Designated_Type (Typ))
4523
                  then
4524
                     IR := Make_Itype_Reference (Sloc (Comp));
4525
                     Set_Itype (IR, Designated_Type (Typ));
4526
                     Append (IR, Result);
4527
                  end if;
4528
 
4529
                  Next_Component (Comp);
4530
               end loop;
4531
            end;
4532
         end if;
4533
      end if;
4534
 
4535
      --  When a type is frozen, the first subtype of the type is frozen as
4536
      --  well (RM 13.14(15)). This has to be done after freezing the type,
4537
      --  since obviously the first subtype depends on its own base type.
4538
 
4539
      if Is_Type (E) then
4540
         Freeze_And_Append (First_Subtype (E), N, Result);
4541
 
4542
         --  If we just froze a tagged non-class wide record, then freeze the
4543
         --  corresponding class-wide type. This must be done after the tagged
4544
         --  type itself is frozen, because the class-wide type refers to the
4545
         --  tagged type which generates the class.
4546
 
4547
         if Is_Tagged_Type (E)
4548
           and then not Is_Class_Wide_Type (E)
4549
           and then Present (Class_Wide_Type (E))
4550
         then
4551
            Freeze_And_Append (Class_Wide_Type (E), N, Result);
4552
         end if;
4553
      end if;
4554
 
4555
      Check_Debug_Info_Needed (E);
4556
 
4557
      --  Special handling for subprograms
4558
 
4559
      if Is_Subprogram (E) then
4560
 
4561
         --  If subprogram has address clause then reset Is_Public flag, since
4562
         --  we do not want the backend to generate external references.
4563
 
4564
         if Present (Address_Clause (E))
4565
           and then not Is_Library_Level_Entity (E)
4566
         then
4567
            Set_Is_Public (E, False);
4568
 
4569
         --  If no address clause and not intrinsic, then for imported
4570
         --  subprogram in main unit, generate descriptor if we are in
4571
         --  Propagate_Exceptions mode.
4572
 
4573
         --  This is very odd code, it makes a null result, why ???
4574
 
4575
         elsif Propagate_Exceptions
4576
           and then Is_Imported (E)
4577
           and then not Is_Intrinsic_Subprogram (E)
4578
           and then Convention (E) /= Convention_Stubbed
4579
         then
4580
            if Result = No_List then
4581
               Result := Empty_List;
4582
            end if;
4583
         end if;
4584
      end if;
4585
 
4586
      return Result;
4587
   end Freeze_Entity;
4588
 
4589
   -----------------------------
4590
   -- Freeze_Enumeration_Type --
4591
   -----------------------------
4592
 
4593
   procedure Freeze_Enumeration_Type (Typ : Entity_Id) is
4594
   begin
4595
      --  By default, if no size clause is present, an enumeration type with
4596
      --  Convention C is assumed to interface to a C enum, and has integer
4597
      --  size. This applies to types. For subtypes, verify that its base
4598
      --  type has no size clause either. Treat other foreign conventions
4599
      --  in the same way, and also make sure alignment is set right.
4600
 
4601
      if Has_Foreign_Convention (Typ)
4602
        and then not Has_Size_Clause (Typ)
4603
        and then not Has_Size_Clause (Base_Type (Typ))
4604
        and then Esize (Typ) < Standard_Integer_Size
4605
      then
4606
         Init_Esize (Typ, Standard_Integer_Size);
4607
         Set_Alignment (Typ, Alignment (Standard_Integer));
4608
 
4609
      else
4610
         --  If the enumeration type interfaces to C, and it has a size clause
4611
         --  that specifies less than int size, it warrants a warning. The
4612
         --  user may intend the C type to be an enum or a char, so this is
4613
         --  not by itself an error that the Ada compiler can detect, but it
4614
         --  it is a worth a heads-up. For Boolean and Character types we
4615
         --  assume that the programmer has the proper C type in mind.
4616
 
4617
         if Convention (Typ) = Convention_C
4618
           and then Has_Size_Clause (Typ)
4619
           and then Esize (Typ) /= Esize (Standard_Integer)
4620
           and then not Is_Boolean_Type (Typ)
4621
           and then not Is_Character_Type (Typ)
4622
         then
4623
            Error_Msg_N
4624
              ("C enum types have the size of a C int?", Size_Clause (Typ));
4625
         end if;
4626
 
4627
         Adjust_Esize_For_Alignment (Typ);
4628
      end if;
4629
   end Freeze_Enumeration_Type;
4630
 
4631
   -----------------------
4632
   -- Freeze_Expression --
4633
   -----------------------
4634
 
4635
   procedure Freeze_Expression (N : Node_Id) is
4636
      In_Spec_Exp : constant Boolean := In_Spec_Expression;
4637
      Typ         : Entity_Id;
4638
      Nam         : Entity_Id;
4639
      Desig_Typ   : Entity_Id;
4640
      P           : Node_Id;
4641
      Parent_P    : Node_Id;
4642
 
4643
      Freeze_Outside : Boolean := False;
4644
      --  This flag is set true if the entity must be frozen outside the
4645
      --  current subprogram. This happens in the case of expander generated
4646
      --  subprograms (_Init_Proc, _Input, _Output, _Read, _Write) which do
4647
      --  not freeze all entities like other bodies, but which nevertheless
4648
      --  may reference entities that have to be frozen before the body and
4649
      --  obviously cannot be frozen inside the body.
4650
 
4651
      function In_Exp_Body (N : Node_Id) return Boolean;
4652
      --  Given an N_Handled_Sequence_Of_Statements node N, determines whether
4653
      --  it is the handled statement sequence of an expander-generated
4654
      --  subprogram (init proc, stream subprogram, or renaming as body).
4655
      --  If so, this is not a freezing context.
4656
 
4657
      -----------------
4658
      -- In_Exp_Body --
4659
      -----------------
4660
 
4661
      function In_Exp_Body (N : Node_Id) return Boolean is
4662
         P  : Node_Id;
4663
         Id : Entity_Id;
4664
 
4665
      begin
4666
         if Nkind (N) = N_Subprogram_Body then
4667
            P := N;
4668
         else
4669
            P := Parent (N);
4670
         end if;
4671
 
4672
         if Nkind (P) /= N_Subprogram_Body then
4673
            return False;
4674
 
4675
         else
4676
            Id := Defining_Unit_Name (Specification (P));
4677
 
4678
            if Nkind (Id) = N_Defining_Identifier
4679
              and then (Is_Init_Proc (Id)              or else
4680
                        Is_TSS (Id, TSS_Stream_Input)  or else
4681
                        Is_TSS (Id, TSS_Stream_Output) or else
4682
                        Is_TSS (Id, TSS_Stream_Read)   or else
4683
                        Is_TSS (Id, TSS_Stream_Write)  or else
4684
                        Nkind (Original_Node (P)) =
4685
                          N_Subprogram_Renaming_Declaration)
4686
            then
4687
               return True;
4688
            else
4689
               return False;
4690
            end if;
4691
         end if;
4692
      end In_Exp_Body;
4693
 
4694
   --  Start of processing for Freeze_Expression
4695
 
4696
   begin
4697
      --  Immediate return if freezing is inhibited. This flag is set by the
4698
      --  analyzer to stop freezing on generated expressions that would cause
4699
      --  freezing if they were in the source program, but which are not
4700
      --  supposed to freeze, since they are created.
4701
 
4702
      if Must_Not_Freeze (N) then
4703
         return;
4704
      end if;
4705
 
4706
      --  If expression is non-static, then it does not freeze in a default
4707
      --  expression, see section "Handling of Default Expressions" in the
4708
      --  spec of package Sem for further details. Note that we have to make
4709
      --  sure that we actually have a real expression (if we have a subtype
4710
      --  indication, we can't test Is_Static_Expression!) However, we exclude
4711
      --  the case of the prefix of an attribute of a static scalar subtype
4712
      --  from this early return, because static subtype attributes should
4713
      --  always cause freezing, even in default expressions, but the attribute
4714
      --  may not have been marked as static yet (because in Resolve_Attribute,
4715
      --  the call to Eval_Attribute follows the call of Freeze_Expression on
4716
      --  the prefix).
4717
 
4718
      if In_Spec_Exp
4719
        and then Nkind (N) in N_Subexpr
4720
        and then not Is_Static_Expression (N)
4721
        and then (Nkind (Parent (N)) /= N_Attribute_Reference
4722
                   or else not (Is_Entity_Name (N)
4723
                                 and then Is_Type (Entity (N))
4724
                                 and then Is_Static_Subtype (Entity (N))))
4725
      then
4726
         return;
4727
      end if;
4728
 
4729
      --  Freeze type of expression if not frozen already
4730
 
4731
      Typ := Empty;
4732
 
4733
      if Nkind (N) in N_Has_Etype then
4734
         if not Is_Frozen (Etype (N)) then
4735
            Typ := Etype (N);
4736
 
4737
         --  Base type may be an derived numeric type that is frozen at
4738
         --  the point of declaration, but first_subtype is still unfrozen.
4739
 
4740
         elsif not Is_Frozen (First_Subtype (Etype (N))) then
4741
            Typ := First_Subtype (Etype (N));
4742
         end if;
4743
      end if;
4744
 
4745
      --  For entity name, freeze entity if not frozen already. A special
4746
      --  exception occurs for an identifier that did not come from source.
4747
      --  We don't let such identifiers freeze a non-internal entity, i.e.
4748
      --  an entity that did come from source, since such an identifier was
4749
      --  generated by the expander, and cannot have any semantic effect on
4750
      --  the freezing semantics. For example, this stops the parameter of
4751
      --  an initialization procedure from freezing the variable.
4752
 
4753
      if Is_Entity_Name (N)
4754
        and then not Is_Frozen (Entity (N))
4755
        and then (Nkind (N) /= N_Identifier
4756
                   or else Comes_From_Source (N)
4757
                   or else not Comes_From_Source (Entity (N)))
4758
      then
4759
         Nam := Entity (N);
4760
      else
4761
         Nam := Empty;
4762
      end if;
4763
 
4764
      --  For an allocator freeze designated type if not frozen already
4765
 
4766
      --  For an aggregate whose component type is an access type, freeze the
4767
      --  designated type now, so that its freeze does not appear within the
4768
      --  loop that might be created in the expansion of the aggregate. If the
4769
      --  designated type is a private type without full view, the expression
4770
      --  cannot contain an allocator, so the type is not frozen.
4771
 
4772
      --  For a function, we freeze the entity when the subprogram declaration
4773
      --  is frozen, but a function call may appear in an initialization proc.
4774
      --  before the declaration is frozen. We need to generate the extra
4775
      --  formals, if any, to ensure that the expansion of the call includes
4776
      --  the proper actuals. This only applies to Ada subprograms, not to
4777
      --  imported ones.
4778
 
4779
      Desig_Typ := Empty;
4780
 
4781
      case Nkind (N) is
4782
         when N_Allocator =>
4783
            Desig_Typ := Designated_Type (Etype (N));
4784
 
4785
         when N_Aggregate =>
4786
            if Is_Array_Type (Etype (N))
4787
              and then Is_Access_Type (Component_Type (Etype (N)))
4788
            then
4789
               Desig_Typ := Designated_Type (Component_Type (Etype (N)));
4790
            end if;
4791
 
4792
         when N_Selected_Component |
4793
            N_Indexed_Component    |
4794
            N_Slice                =>
4795
 
4796
            if Is_Access_Type (Etype (Prefix (N))) then
4797
               Desig_Typ := Designated_Type (Etype (Prefix (N)));
4798
            end if;
4799
 
4800
         when N_Identifier =>
4801
            if Present (Nam)
4802
              and then Ekind (Nam) = E_Function
4803
              and then Nkind (Parent (N)) = N_Function_Call
4804
              and then Convention (Nam) = Convention_Ada
4805
            then
4806
               Create_Extra_Formals (Nam);
4807
            end if;
4808
 
4809
         when others =>
4810
            null;
4811
      end case;
4812
 
4813
      if Desig_Typ /= Empty
4814
        and then (Is_Frozen (Desig_Typ)
4815
                   or else (not Is_Fully_Defined (Desig_Typ)))
4816
      then
4817
         Desig_Typ := Empty;
4818
      end if;
4819
 
4820
      --  All done if nothing needs freezing
4821
 
4822
      if No (Typ)
4823
        and then No (Nam)
4824
        and then No (Desig_Typ)
4825
      then
4826
         return;
4827
      end if;
4828
 
4829
      --  Loop for looking at the right place to insert the freeze nodes,
4830
      --  exiting from the loop when it is appropriate to insert the freeze
4831
      --  node before the current node P.
4832
 
4833
      --  Also checks some special exceptions to the freezing rules. These
4834
      --  cases result in a direct return, bypassing the freeze action.
4835
 
4836
      P := N;
4837
      loop
4838
         Parent_P := Parent (P);
4839
 
4840
         --  If we don't have a parent, then we are not in a well-formed tree.
4841
         --  This is an unusual case, but there are some legitimate situations
4842
         --  in which this occurs, notably when the expressions in the range of
4843
         --  a type declaration are resolved. We simply ignore the freeze
4844
         --  request in this case. Is this right ???
4845
 
4846
         if No (Parent_P) then
4847
            return;
4848
         end if;
4849
 
4850
         --  See if we have got to an appropriate point in the tree
4851
 
4852
         case Nkind (Parent_P) is
4853
 
4854
            --  A special test for the exception of (RM 13.14(8)) for the case
4855
            --  of per-object expressions (RM 3.8(18)) occurring in component
4856
            --  definition or a discrete subtype definition. Note that we test
4857
            --  for a component declaration which includes both cases we are
4858
            --  interested in, and furthermore the tree does not have explicit
4859
            --  nodes for either of these two constructs.
4860
 
4861
            when N_Component_Declaration =>
4862
 
4863
               --  The case we want to test for here is an identifier that is
4864
               --  a per-object expression, this is either a discriminant that
4865
               --  appears in a context other than the component declaration
4866
               --  or it is a reference to the type of the enclosing construct.
4867
 
4868
               --  For either of these cases, we skip the freezing
4869
 
4870
               if not In_Spec_Expression
4871
                 and then Nkind (N) = N_Identifier
4872
                 and then (Present (Entity (N)))
4873
               then
4874
                  --  We recognize the discriminant case by just looking for
4875
                  --  a reference to a discriminant. It can only be one for
4876
                  --  the enclosing construct. Skip freezing in this case.
4877
 
4878
                  if Ekind (Entity (N)) = E_Discriminant then
4879
                     return;
4880
 
4881
                  --  For the case of a reference to the enclosing record,
4882
                  --  (or task or protected type), we look for a type that
4883
                  --  matches the current scope.
4884
 
4885
                  elsif Entity (N) = Current_Scope then
4886
                     return;
4887
                  end if;
4888
               end if;
4889
 
4890
            --  If we have an enumeration literal that appears as the choice in
4891
            --  the aggregate of an enumeration representation clause, then
4892
            --  freezing does not occur (RM 13.14(10)).
4893
 
4894
            when N_Enumeration_Representation_Clause =>
4895
 
4896
               --  The case we are looking for is an enumeration literal
4897
 
4898
               if (Nkind (N) = N_Identifier or Nkind (N) = N_Character_Literal)
4899
                 and then Is_Enumeration_Type (Etype (N))
4900
               then
4901
                  --  If enumeration literal appears directly as the choice,
4902
                  --  do not freeze (this is the normal non-overloaded case)
4903
 
4904
                  if Nkind (Parent (N)) = N_Component_Association
4905
                    and then First (Choices (Parent (N))) = N
4906
                  then
4907
                     return;
4908
 
4909
                  --  If enumeration literal appears as the name of function
4910
                  --  which is the choice, then also do not freeze. This
4911
                  --  happens in the overloaded literal case, where the
4912
                  --  enumeration literal is temporarily changed to a function
4913
                  --  call for overloading analysis purposes.
4914
 
4915
                  elsif Nkind (Parent (N)) = N_Function_Call
4916
                     and then
4917
                       Nkind (Parent (Parent (N))) = N_Component_Association
4918
                     and then
4919
                       First (Choices (Parent (Parent (N)))) = Parent (N)
4920
                  then
4921
                     return;
4922
                  end if;
4923
               end if;
4924
 
4925
            --  Normally if the parent is a handled sequence of statements,
4926
            --  then the current node must be a statement, and that is an
4927
            --  appropriate place to insert a freeze node.
4928
 
4929
            when N_Handled_Sequence_Of_Statements =>
4930
 
4931
               --  An exception occurs when the sequence of statements is for
4932
               --  an expander generated body that did not do the usual freeze
4933
               --  all operation. In this case we usually want to freeze
4934
               --  outside this body, not inside it, and we skip past the
4935
               --  subprogram body that we are inside.
4936
 
4937
               if In_Exp_Body (Parent_P) then
4938
 
4939
                  --  However, we *do* want to freeze at this point if we have
4940
                  --  an entity to freeze, and that entity is declared *inside*
4941
                  --  the body of the expander generated procedure. This case
4942
                  --  is recognized by the scope of the type, which is either
4943
                  --  the spec for some enclosing body, or (in the case of
4944
                  --  init_procs, for which there are no separate specs) the
4945
                  --  current scope.
4946
 
4947
                  declare
4948
                     Subp : constant Node_Id := Parent (Parent_P);
4949
                     Cspc : Entity_Id;
4950
 
4951
                  begin
4952
                     if Nkind (Subp) = N_Subprogram_Body then
4953
                        Cspc := Corresponding_Spec (Subp);
4954
 
4955
                        if (Present (Typ) and then Scope (Typ) = Cspc)
4956
                             or else
4957
                           (Present (Nam) and then Scope (Nam) = Cspc)
4958
                        then
4959
                           exit;
4960
 
4961
                        elsif Present (Typ)
4962
                          and then Scope (Typ) = Current_Scope
4963
                          and then Current_Scope = Defining_Entity (Subp)
4964
                        then
4965
                           exit;
4966
                        end if;
4967
                     end if;
4968
                  end;
4969
 
4970
                  --  If not that exception to the exception, then this is
4971
                  --  where we delay the freeze till outside the body.
4972
 
4973
                  Parent_P := Parent (Parent_P);
4974
                  Freeze_Outside := True;
4975
 
4976
               --  Here if normal case where we are in handled statement
4977
               --  sequence and want to do the insertion right there.
4978
 
4979
               else
4980
                  exit;
4981
               end if;
4982
 
4983
            --  If parent is a body or a spec or a block, then the current node
4984
            --  is a statement or declaration and we can insert the freeze node
4985
            --  before it.
4986
 
4987
            when N_Block_Statement       |
4988
                 N_Entry_Body            |
4989
                 N_Package_Body          |
4990
                 N_Package_Specification |
4991
                 N_Protected_Body        |
4992
                 N_Subprogram_Body       |
4993
                 N_Task_Body             => exit;
4994
 
4995
            --  The expander is allowed to define types in any statements list,
4996
            --  so any of the following parent nodes also mark a freezing point
4997
            --  if the actual node is in a list of statements or declarations.
4998
 
4999
            when N_Abortable_Part             |
5000
                 N_Accept_Alternative         |
5001
                 N_And_Then                   |
5002
                 N_Case_Statement_Alternative |
5003
                 N_Compilation_Unit_Aux       |
5004
                 N_Conditional_Entry_Call     |
5005
                 N_Delay_Alternative          |
5006
                 N_Elsif_Part                 |
5007
                 N_Entry_Call_Alternative     |
5008
                 N_Exception_Handler          |
5009
                 N_Extended_Return_Statement  |
5010
                 N_Freeze_Entity              |
5011
                 N_If_Statement               |
5012
                 N_Or_Else                    |
5013
                 N_Selective_Accept           |
5014
                 N_Triggering_Alternative     =>
5015
 
5016
               exit when Is_List_Member (P);
5017
 
5018
            --  Note: The N_Loop_Statement is a special case. A type that
5019
            --  appears in the source can never be frozen in a loop (this
5020
            --  occurs only because of a loop expanded by the expander), so we
5021
            --  keep on going. Otherwise we terminate the search. Same is true
5022
            --  of any entity which comes from source. (if they have predefined
5023
            --  type, that type does not appear to come from source, but the
5024
            --  entity should not be frozen here).
5025
 
5026
            when N_Loop_Statement =>
5027
               exit when not Comes_From_Source (Etype (N))
5028
                 and then (No (Nam) or else not Comes_From_Source (Nam));
5029
 
5030
            --  For all other cases, keep looking at parents
5031
 
5032
            when others =>
5033
               null;
5034
         end case;
5035
 
5036
         --  We fall through the case if we did not yet find the proper
5037
         --  place in the free for inserting the freeze node, so climb!
5038
 
5039
         P := Parent_P;
5040
      end loop;
5041
 
5042
      --  If the expression appears in a record or an initialization procedure,
5043
      --  the freeze nodes are collected and attached to the current scope, to
5044
      --  be inserted and analyzed on exit from the scope, to insure that
5045
      --  generated entities appear in the correct scope. If the expression is
5046
      --  a default for a discriminant specification, the scope is still void.
5047
      --  The expression can also appear in the discriminant part of a private
5048
      --  or concurrent type.
5049
 
5050
      --  If the expression appears in a constrained subcomponent of an
5051
      --  enclosing record declaration, the freeze nodes must be attached to
5052
      --  the outer record type so they can eventually be placed in the
5053
      --  enclosing declaration list.
5054
 
5055
      --  The other case requiring this special handling is if we are in a
5056
      --  default expression, since in that case we are about to freeze a
5057
      --  static type, and the freeze scope needs to be the outer scope, not
5058
      --  the scope of the subprogram with the default parameter.
5059
 
5060
      --  For default expressions and other spec expressions in generic units,
5061
      --  the Move_Freeze_Nodes mechanism (see sem_ch12.adb) takes care of
5062
      --  placing them at the proper place, after the generic unit.
5063
 
5064
      if (In_Spec_Exp and not Inside_A_Generic)
5065
        or else Freeze_Outside
5066
        or else (Is_Type (Current_Scope)
5067
                  and then (not Is_Concurrent_Type (Current_Scope)
5068
                             or else not Has_Completion (Current_Scope)))
5069
        or else Ekind (Current_Scope) = E_Void
5070
      then
5071
         declare
5072
            N            : constant Node_Id    := Current_Scope;
5073
            Freeze_Nodes : List_Id             := No_List;
5074
            Pos          : Int                 := Scope_Stack.Last;
5075
 
5076
         begin
5077
            if Present (Desig_Typ) then
5078
               Freeze_And_Append (Desig_Typ, N, Freeze_Nodes);
5079
            end if;
5080
 
5081
            if Present (Typ) then
5082
               Freeze_And_Append (Typ, N, Freeze_Nodes);
5083
            end if;
5084
 
5085
            if Present (Nam) then
5086
               Freeze_And_Append (Nam, N, Freeze_Nodes);
5087
            end if;
5088
 
5089
            --  The current scope may be that of a constrained component of
5090
            --  an enclosing record declaration, which is above the current
5091
            --  scope in the scope stack.
5092
            --  If the expression is within a top-level pragma, as for a pre-
5093
            --  condition on a library-level subprogram, nothing to do.
5094
 
5095
            if not Is_Compilation_Unit (Current_Scope)
5096
              and then Is_Record_Type (Scope (Current_Scope))
5097
            then
5098
               Pos := Pos - 1;
5099
            end if;
5100
 
5101
            if Is_Non_Empty_List (Freeze_Nodes) then
5102
               if No (Scope_Stack.Table (Pos).Pending_Freeze_Actions) then
5103
                  Scope_Stack.Table (Pos).Pending_Freeze_Actions :=
5104
                    Freeze_Nodes;
5105
               else
5106
                  Append_List (Freeze_Nodes,
5107
                    Scope_Stack.Table (Pos).Pending_Freeze_Actions);
5108
               end if;
5109
            end if;
5110
         end;
5111
 
5112
         return;
5113
      end if;
5114
 
5115
      --  Now we have the right place to do the freezing. First, a special
5116
      --  adjustment, if we are in spec-expression analysis mode, these freeze
5117
      --  actions must not be thrown away (normally all inserted actions are
5118
      --  thrown away in this mode. However, the freeze actions are from static
5119
      --  expressions and one of the important reasons we are doing this
5120
      --  special analysis is to get these freeze actions. Therefore we turn
5121
      --  off the In_Spec_Expression mode to propagate these freeze actions.
5122
      --  This also means they get properly analyzed and expanded.
5123
 
5124
      In_Spec_Expression := False;
5125
 
5126
      --  Freeze the designated type of an allocator (RM 13.14(13))
5127
 
5128
      if Present (Desig_Typ) then
5129
         Freeze_Before (P, Desig_Typ);
5130
      end if;
5131
 
5132
      --  Freeze type of expression (RM 13.14(10)). Note that we took care of
5133
      --  the enumeration representation clause exception in the loop above.
5134
 
5135
      if Present (Typ) then
5136
         Freeze_Before (P, Typ);
5137
      end if;
5138
 
5139
      --  Freeze name if one is present (RM 13.14(11))
5140
 
5141
      if Present (Nam) then
5142
         Freeze_Before (P, Nam);
5143
      end if;
5144
 
5145
      --  Restore In_Spec_Expression flag
5146
 
5147
      In_Spec_Expression := In_Spec_Exp;
5148
   end Freeze_Expression;
5149
 
5150
   -----------------------------
5151
   -- Freeze_Fixed_Point_Type --
5152
   -----------------------------
5153
 
5154
   --  Certain fixed-point types and subtypes, including implicit base types
5155
   --  and declared first subtypes, have not yet set up a range. This is
5156
   --  because the range cannot be set until the Small and Size values are
5157
   --  known, and these are not known till the type is frozen.
5158
 
5159
   --  To signal this case, Scalar_Range contains an unanalyzed syntactic range
5160
   --  whose bounds are unanalyzed real literals. This routine will recognize
5161
   --  this case, and transform this range node into a properly typed range
5162
   --  with properly analyzed and resolved values.
5163
 
5164
   procedure Freeze_Fixed_Point_Type (Typ : Entity_Id) is
5165
      Rng   : constant Node_Id    := Scalar_Range (Typ);
5166
      Lo    : constant Node_Id    := Low_Bound (Rng);
5167
      Hi    : constant Node_Id    := High_Bound (Rng);
5168
      Btyp  : constant Entity_Id  := Base_Type (Typ);
5169
      Brng  : constant Node_Id    := Scalar_Range (Btyp);
5170
      BLo   : constant Node_Id    := Low_Bound (Brng);
5171
      BHi   : constant Node_Id    := High_Bound (Brng);
5172
      Small : constant Ureal      := Small_Value (Typ);
5173
      Loval : Ureal;
5174
      Hival : Ureal;
5175
      Atype : Entity_Id;
5176
 
5177
      Actual_Size : Nat;
5178
 
5179
      function Fsize (Lov, Hiv : Ureal) return Nat;
5180
      --  Returns size of type with given bounds. Also leaves these
5181
      --  bounds set as the current bounds of the Typ.
5182
 
5183
      -----------
5184
      -- Fsize --
5185
      -----------
5186
 
5187
      function Fsize (Lov, Hiv : Ureal) return Nat is
5188
      begin
5189
         Set_Realval (Lo, Lov);
5190
         Set_Realval (Hi, Hiv);
5191
         return Minimum_Size (Typ);
5192
      end Fsize;
5193
 
5194
   --  Start of processing for Freeze_Fixed_Point_Type
5195
 
5196
   begin
5197
      --  If Esize of a subtype has not previously been set, set it now
5198
 
5199
      if Unknown_Esize (Typ) then
5200
         Atype := Ancestor_Subtype (Typ);
5201
 
5202
         if Present (Atype) then
5203
            Set_Esize (Typ, Esize (Atype));
5204
         else
5205
            Set_Esize (Typ, Esize (Base_Type (Typ)));
5206
         end if;
5207
      end if;
5208
 
5209
      --  Immediate return if the range is already analyzed. This means that
5210
      --  the range is already set, and does not need to be computed by this
5211
      --  routine.
5212
 
5213
      if Analyzed (Rng) then
5214
         return;
5215
      end if;
5216
 
5217
      --  Immediate return if either of the bounds raises Constraint_Error
5218
 
5219
      if Raises_Constraint_Error (Lo)
5220
        or else Raises_Constraint_Error (Hi)
5221
      then
5222
         return;
5223
      end if;
5224
 
5225
      Loval := Realval (Lo);
5226
      Hival := Realval (Hi);
5227
 
5228
      --  Ordinary fixed-point case
5229
 
5230
      if Is_Ordinary_Fixed_Point_Type (Typ) then
5231
 
5232
         --  For the ordinary fixed-point case, we are allowed to fudge the
5233
         --  end-points up or down by small. Generally we prefer to fudge up,
5234
         --  i.e. widen the bounds for non-model numbers so that the end points
5235
         --  are included. However there are cases in which this cannot be
5236
         --  done, and indeed cases in which we may need to narrow the bounds.
5237
         --  The following circuit makes the decision.
5238
 
5239
         --  Note: our terminology here is that Incl_EP means that the bounds
5240
         --  are widened by Small if necessary to include the end points, and
5241
         --  Excl_EP means that the bounds are narrowed by Small to exclude the
5242
         --  end-points if this reduces the size.
5243
 
5244
         --  Note that in the Incl case, all we care about is including the
5245
         --  end-points. In the Excl case, we want to narrow the bounds as
5246
         --  much as permitted by the RM, to give the smallest possible size.
5247
 
5248
         Fudge : declare
5249
            Loval_Incl_EP : Ureal;
5250
            Hival_Incl_EP : Ureal;
5251
 
5252
            Loval_Excl_EP : Ureal;
5253
            Hival_Excl_EP : Ureal;
5254
 
5255
            Size_Incl_EP  : Nat;
5256
            Size_Excl_EP  : Nat;
5257
 
5258
            Model_Num     : Ureal;
5259
            First_Subt    : Entity_Id;
5260
            Actual_Lo     : Ureal;
5261
            Actual_Hi     : Ureal;
5262
 
5263
         begin
5264
            --  First step. Base types are required to be symmetrical. Right
5265
            --  now, the base type range is a copy of the first subtype range.
5266
            --  This will be corrected before we are done, but right away we
5267
            --  need to deal with the case where both bounds are non-negative.
5268
            --  In this case, we set the low bound to the negative of the high
5269
            --  bound, to make sure that the size is computed to include the
5270
            --  required sign. Note that we do not need to worry about the
5271
            --  case of both bounds negative, because the sign will be dealt
5272
            --  with anyway. Furthermore we can't just go making such a bound
5273
            --  symmetrical, since in a twos-complement system, there is an
5274
            --  extra negative value which could not be accommodated on the
5275
            --  positive side.
5276
 
5277
            if Typ = Btyp
5278
              and then not UR_Is_Negative (Loval)
5279
              and then Hival > Loval
5280
            then
5281
               Loval := -Hival;
5282
               Set_Realval (Lo, Loval);
5283
            end if;
5284
 
5285
            --  Compute the fudged bounds. If the number is a model number,
5286
            --  then we do nothing to include it, but we are allowed to backoff
5287
            --  to the next adjacent model number when we exclude it. If it is
5288
            --  not a model number then we straddle the two values with the
5289
            --  model numbers on either side.
5290
 
5291
            Model_Num := UR_Trunc (Loval / Small) * Small;
5292
 
5293
            if Loval = Model_Num then
5294
               Loval_Incl_EP := Model_Num;
5295
            else
5296
               Loval_Incl_EP := Model_Num - Small;
5297
            end if;
5298
 
5299
            --  The low value excluding the end point is Small greater, but
5300
            --  we do not do this exclusion if the low value is positive,
5301
            --  since it can't help the size and could actually hurt by
5302
            --  crossing the high bound.
5303
 
5304
            if UR_Is_Negative (Loval_Incl_EP) then
5305
               Loval_Excl_EP := Loval_Incl_EP + Small;
5306
 
5307
               --  If the value went from negative to zero, then we have the
5308
               --  case where Loval_Incl_EP is the model number just below
5309
               --  zero, so we want to stick to the negative value for the
5310
               --  base type to maintain the condition that the size will
5311
               --  include signed values.
5312
 
5313
               if Typ = Btyp
5314
                 and then UR_Is_Zero (Loval_Excl_EP)
5315
               then
5316
                  Loval_Excl_EP := Loval_Incl_EP;
5317
               end if;
5318
 
5319
            else
5320
               Loval_Excl_EP := Loval_Incl_EP;
5321
            end if;
5322
 
5323
            --  Similar processing for upper bound and high value
5324
 
5325
            Model_Num := UR_Trunc (Hival / Small) * Small;
5326
 
5327
            if Hival = Model_Num then
5328
               Hival_Incl_EP := Model_Num;
5329
            else
5330
               Hival_Incl_EP := Model_Num + Small;
5331
            end if;
5332
 
5333
            if UR_Is_Positive (Hival_Incl_EP) then
5334
               Hival_Excl_EP := Hival_Incl_EP - Small;
5335
            else
5336
               Hival_Excl_EP := Hival_Incl_EP;
5337
            end if;
5338
 
5339
            --  One further adjustment is needed. In the case of subtypes, we
5340
            --  cannot go outside the range of the base type, or we get
5341
            --  peculiarities, and the base type range is already set. This
5342
            --  only applies to the Incl values, since clearly the Excl values
5343
            --  are already as restricted as they are allowed to be.
5344
 
5345
            if Typ /= Btyp then
5346
               Loval_Incl_EP := UR_Max (Loval_Incl_EP, Realval (BLo));
5347
               Hival_Incl_EP := UR_Min (Hival_Incl_EP, Realval (BHi));
5348
            end if;
5349
 
5350
            --  Get size including and excluding end points
5351
 
5352
            Size_Incl_EP := Fsize (Loval_Incl_EP, Hival_Incl_EP);
5353
            Size_Excl_EP := Fsize (Loval_Excl_EP, Hival_Excl_EP);
5354
 
5355
            --  No need to exclude end-points if it does not reduce size
5356
 
5357
            if Fsize (Loval_Incl_EP, Hival_Excl_EP) = Size_Excl_EP then
5358
               Loval_Excl_EP := Loval_Incl_EP;
5359
            end if;
5360
 
5361
            if Fsize (Loval_Excl_EP, Hival_Incl_EP) = Size_Excl_EP then
5362
               Hival_Excl_EP := Hival_Incl_EP;
5363
            end if;
5364
 
5365
            --  Now we set the actual size to be used. We want to use the
5366
            --  bounds fudged up to include the end-points but only if this
5367
            --  can be done without violating a specifically given size
5368
            --  size clause or causing an unacceptable increase in size.
5369
 
5370
            --  Case of size clause given
5371
 
5372
            if Has_Size_Clause (Typ) then
5373
 
5374
               --  Use the inclusive size only if it is consistent with
5375
               --  the explicitly specified size.
5376
 
5377
               if Size_Incl_EP <= RM_Size (Typ) then
5378
                  Actual_Lo   := Loval_Incl_EP;
5379
                  Actual_Hi   := Hival_Incl_EP;
5380
                  Actual_Size := Size_Incl_EP;
5381
 
5382
               --  If the inclusive size is too large, we try excluding
5383
               --  the end-points (will be caught later if does not work).
5384
 
5385
               else
5386
                  Actual_Lo   := Loval_Excl_EP;
5387
                  Actual_Hi   := Hival_Excl_EP;
5388
                  Actual_Size := Size_Excl_EP;
5389
               end if;
5390
 
5391
            --  Case of size clause not given
5392
 
5393
            else
5394
               --  If we have a base type whose corresponding first subtype
5395
               --  has an explicit size that is large enough to include our
5396
               --  end-points, then do so. There is no point in working hard
5397
               --  to get a base type whose size is smaller than the specified
5398
               --  size of the first subtype.
5399
 
5400
               First_Subt := First_Subtype (Typ);
5401
 
5402
               if Has_Size_Clause (First_Subt)
5403
                 and then Size_Incl_EP <= Esize (First_Subt)
5404
               then
5405
                  Actual_Size := Size_Incl_EP;
5406
                  Actual_Lo   := Loval_Incl_EP;
5407
                  Actual_Hi   := Hival_Incl_EP;
5408
 
5409
               --  If excluding the end-points makes the size smaller and
5410
               --  results in a size of 8,16,32,64, then we take the smaller
5411
               --  size. For the 64 case, this is compulsory. For the other
5412
               --  cases, it seems reasonable. We like to include end points
5413
               --  if we can, but not at the expense of moving to the next
5414
               --  natural boundary of size.
5415
 
5416
               elsif Size_Incl_EP /= Size_Excl_EP
5417
                 and then Addressable (Size_Excl_EP)
5418
               then
5419
                  Actual_Size := Size_Excl_EP;
5420
                  Actual_Lo   := Loval_Excl_EP;
5421
                  Actual_Hi   := Hival_Excl_EP;
5422
 
5423
               --  Otherwise we can definitely include the end points
5424
 
5425
               else
5426
                  Actual_Size := Size_Incl_EP;
5427
                  Actual_Lo   := Loval_Incl_EP;
5428
                  Actual_Hi   := Hival_Incl_EP;
5429
               end if;
5430
 
5431
               --  One pathological case: normally we never fudge a low bound
5432
               --  down, since it would seem to increase the size (if it has
5433
               --  any effect), but for ranges containing single value, or no
5434
               --  values, the high bound can be small too large. Consider:
5435
 
5436
               --    type t is delta 2.0**(-14)
5437
               --      range 131072.0 .. 0;
5438
 
5439
               --  That lower bound is *just* outside the range of 32 bits, and
5440
               --  does need fudging down in this case. Note that the bounds
5441
               --  will always have crossed here, since the high bound will be
5442
               --  fudged down if necessary, as in the case of:
5443
 
5444
               --    type t is delta 2.0**(-14)
5445
               --      range 131072.0 .. 131072.0;
5446
 
5447
               --  So we detect the situation by looking for crossed bounds,
5448
               --  and if the bounds are crossed, and the low bound is greater
5449
               --  than zero, we will always back it off by small, since this
5450
               --  is completely harmless.
5451
 
5452
               if Actual_Lo > Actual_Hi then
5453
                  if UR_Is_Positive (Actual_Lo) then
5454
                     Actual_Lo   := Loval_Incl_EP - Small;
5455
                     Actual_Size := Fsize (Actual_Lo, Actual_Hi);
5456
 
5457
                  --  And of course, we need to do exactly the same parallel
5458
                  --  fudge for flat ranges in the negative region.
5459
 
5460
                  elsif UR_Is_Negative (Actual_Hi) then
5461
                     Actual_Hi := Hival_Incl_EP + Small;
5462
                     Actual_Size := Fsize (Actual_Lo, Actual_Hi);
5463
                  end if;
5464
               end if;
5465
            end if;
5466
 
5467
            Set_Realval (Lo, Actual_Lo);
5468
            Set_Realval (Hi, Actual_Hi);
5469
         end Fudge;
5470
 
5471
      --  For the decimal case, none of this fudging is required, since there
5472
      --  are no end-point problems in the decimal case (the end-points are
5473
      --  always included).
5474
 
5475
      else
5476
         Actual_Size := Fsize (Loval, Hival);
5477
      end if;
5478
 
5479
      --  At this stage, the actual size has been calculated and the proper
5480
      --  required bounds are stored in the low and high bounds.
5481
 
5482
      if Actual_Size > 64 then
5483
         Error_Msg_Uint_1 := UI_From_Int (Actual_Size);
5484
         Error_Msg_N
5485
           ("size required (^) for type& too large, maximum allowed is 64",
5486
            Typ);
5487
         Actual_Size := 64;
5488
      end if;
5489
 
5490
      --  Check size against explicit given size
5491
 
5492
      if Has_Size_Clause (Typ) then
5493
         if Actual_Size > RM_Size (Typ) then
5494
            Error_Msg_Uint_1 := RM_Size (Typ);
5495
            Error_Msg_Uint_2 := UI_From_Int (Actual_Size);
5496
            Error_Msg_NE
5497
              ("size given (^) for type& too small, minimum allowed is ^",
5498
               Size_Clause (Typ), Typ);
5499
 
5500
         else
5501
            Actual_Size := UI_To_Int (Esize (Typ));
5502
         end if;
5503
 
5504
      --  Increase size to next natural boundary if no size clause given
5505
 
5506
      else
5507
         if Actual_Size <= 8 then
5508
            Actual_Size := 8;
5509
         elsif Actual_Size <= 16 then
5510
            Actual_Size := 16;
5511
         elsif Actual_Size <= 32 then
5512
            Actual_Size := 32;
5513
         else
5514
            Actual_Size := 64;
5515
         end if;
5516
 
5517
         Init_Esize (Typ, Actual_Size);
5518
         Adjust_Esize_For_Alignment (Typ);
5519
      end if;
5520
 
5521
      --  If we have a base type, then expand the bounds so that they extend to
5522
      --  the full width of the allocated size in bits, to avoid junk range
5523
      --  checks on intermediate computations.
5524
 
5525
      if Base_Type (Typ) = Typ then
5526
         Set_Realval (Lo, -(Small * (Uint_2 ** (Actual_Size - 1))));
5527
         Set_Realval (Hi,  (Small * (Uint_2 ** (Actual_Size - 1) - 1)));
5528
      end if;
5529
 
5530
      --  Final step is to reanalyze the bounds using the proper type
5531
      --  and set the Corresponding_Integer_Value fields of the literals.
5532
 
5533
      Set_Etype (Lo, Empty);
5534
      Set_Analyzed (Lo, False);
5535
      Analyze (Lo);
5536
 
5537
      --  Resolve with universal fixed if the base type, and the base type if
5538
      --  it is a subtype. Note we can't resolve the base type with itself,
5539
      --  that would be a reference before definition.
5540
 
5541
      if Typ = Btyp then
5542
         Resolve (Lo, Universal_Fixed);
5543
      else
5544
         Resolve (Lo, Btyp);
5545
      end if;
5546
 
5547
      --  Set corresponding integer value for bound
5548
 
5549
      Set_Corresponding_Integer_Value
5550
        (Lo, UR_To_Uint (Realval (Lo) / Small));
5551
 
5552
      --  Similar processing for high bound
5553
 
5554
      Set_Etype (Hi, Empty);
5555
      Set_Analyzed (Hi, False);
5556
      Analyze (Hi);
5557
 
5558
      if Typ = Btyp then
5559
         Resolve (Hi, Universal_Fixed);
5560
      else
5561
         Resolve (Hi, Btyp);
5562
      end if;
5563
 
5564
      Set_Corresponding_Integer_Value
5565
        (Hi, UR_To_Uint (Realval (Hi) / Small));
5566
 
5567
      --  Set type of range to correspond to bounds
5568
 
5569
      Set_Etype (Rng, Etype (Lo));
5570
 
5571
      --  Set Esize to calculated size if not set already
5572
 
5573
      if Unknown_Esize (Typ) then
5574
         Init_Esize (Typ, Actual_Size);
5575
      end if;
5576
 
5577
      --  Set RM_Size if not already set. If already set, check value
5578
 
5579
      declare
5580
         Minsiz : constant Uint := UI_From_Int (Minimum_Size (Typ));
5581
 
5582
      begin
5583
         if RM_Size (Typ) /= Uint_0 then
5584
            if RM_Size (Typ) < Minsiz then
5585
               Error_Msg_Uint_1 := RM_Size (Typ);
5586
               Error_Msg_Uint_2 := Minsiz;
5587
               Error_Msg_NE
5588
                 ("size given (^) for type& too small, minimum allowed is ^",
5589
                  Size_Clause (Typ), Typ);
5590
            end if;
5591
 
5592
         else
5593
            Set_RM_Size (Typ, Minsiz);
5594
         end if;
5595
      end;
5596
   end Freeze_Fixed_Point_Type;
5597
 
5598
   ------------------
5599
   -- Freeze_Itype --
5600
   ------------------
5601
 
5602
   procedure Freeze_Itype (T : Entity_Id; N : Node_Id) is
5603
      L : List_Id;
5604
 
5605
   begin
5606
      Set_Has_Delayed_Freeze (T);
5607
      L := Freeze_Entity (T, N);
5608
 
5609
      if Is_Non_Empty_List (L) then
5610
         Insert_Actions (N, L);
5611
      end if;
5612
   end Freeze_Itype;
5613
 
5614
   --------------------------
5615
   -- Freeze_Static_Object --
5616
   --------------------------
5617
 
5618
   procedure Freeze_Static_Object (E : Entity_Id) is
5619
 
5620
      Cannot_Be_Static : exception;
5621
      --  Exception raised if the type of a static object cannot be made
5622
      --  static. This happens if the type depends on non-global objects.
5623
 
5624
      procedure Ensure_Expression_Is_SA (N : Node_Id);
5625
      --  Called to ensure that an expression used as part of a type definition
5626
      --  is statically allocatable, which means that the expression type is
5627
      --  statically allocatable, and the expression is either static, or a
5628
      --  reference to a library level constant.
5629
 
5630
      procedure Ensure_Type_Is_SA (Typ : Entity_Id);
5631
      --  Called to mark a type as static, checking that it is possible
5632
      --  to set the type as static. If it is not possible, then the
5633
      --  exception Cannot_Be_Static is raised.
5634
 
5635
      -----------------------------
5636
      -- Ensure_Expression_Is_SA --
5637
      -----------------------------
5638
 
5639
      procedure Ensure_Expression_Is_SA (N : Node_Id) is
5640
         Ent : Entity_Id;
5641
 
5642
      begin
5643
         Ensure_Type_Is_SA (Etype (N));
5644
 
5645
         if Is_Static_Expression (N) then
5646
            return;
5647
 
5648
         elsif Nkind (N) = N_Identifier then
5649
            Ent := Entity (N);
5650
 
5651
            if Present (Ent)
5652
              and then Ekind (Ent) = E_Constant
5653
              and then Is_Library_Level_Entity (Ent)
5654
            then
5655
               return;
5656
            end if;
5657
         end if;
5658
 
5659
         raise Cannot_Be_Static;
5660
      end Ensure_Expression_Is_SA;
5661
 
5662
      -----------------------
5663
      -- Ensure_Type_Is_SA --
5664
      -----------------------
5665
 
5666
      procedure Ensure_Type_Is_SA (Typ : Entity_Id) is
5667
         N : Node_Id;
5668
         C : Entity_Id;
5669
 
5670
      begin
5671
         --  If type is library level, we are all set
5672
 
5673
         if Is_Library_Level_Entity (Typ) then
5674
            return;
5675
         end if;
5676
 
5677
         --  We are also OK if the type already marked as statically allocated,
5678
         --  which means we processed it before.
5679
 
5680
         if Is_Statically_Allocated (Typ) then
5681
            return;
5682
         end if;
5683
 
5684
         --  Mark type as statically allocated
5685
 
5686
         Set_Is_Statically_Allocated (Typ);
5687
 
5688
         --  Check that it is safe to statically allocate this type
5689
 
5690
         if Is_Scalar_Type (Typ) or else Is_Real_Type (Typ) then
5691
            Ensure_Expression_Is_SA (Type_Low_Bound (Typ));
5692
            Ensure_Expression_Is_SA (Type_High_Bound (Typ));
5693
 
5694
         elsif Is_Array_Type (Typ) then
5695
            N := First_Index (Typ);
5696
            while Present (N) loop
5697
               Ensure_Type_Is_SA (Etype (N));
5698
               Next_Index (N);
5699
            end loop;
5700
 
5701
            Ensure_Type_Is_SA (Component_Type (Typ));
5702
 
5703
         elsif Is_Access_Type (Typ) then
5704
            if Ekind (Designated_Type (Typ)) = E_Subprogram_Type then
5705
 
5706
               declare
5707
                  F : Entity_Id;
5708
                  T : constant Entity_Id := Etype (Designated_Type (Typ));
5709
 
5710
               begin
5711
                  if T /= Standard_Void_Type then
5712
                     Ensure_Type_Is_SA (T);
5713
                  end if;
5714
 
5715
                  F := First_Formal (Designated_Type (Typ));
5716
                  while Present (F) loop
5717
                     Ensure_Type_Is_SA (Etype (F));
5718
                     Next_Formal (F);
5719
                  end loop;
5720
               end;
5721
 
5722
            else
5723
               Ensure_Type_Is_SA (Designated_Type (Typ));
5724
            end if;
5725
 
5726
         elsif Is_Record_Type (Typ) then
5727
            C := First_Entity (Typ);
5728
            while Present (C) loop
5729
               if Ekind (C) = E_Discriminant
5730
                 or else Ekind (C) = E_Component
5731
               then
5732
                  Ensure_Type_Is_SA (Etype (C));
5733
 
5734
               elsif Is_Type (C) then
5735
                  Ensure_Type_Is_SA (C);
5736
               end if;
5737
 
5738
               Next_Entity (C);
5739
            end loop;
5740
 
5741
         elsif Ekind (Typ) = E_Subprogram_Type then
5742
            Ensure_Type_Is_SA (Etype (Typ));
5743
 
5744
            C := First_Formal (Typ);
5745
            while Present (C) loop
5746
               Ensure_Type_Is_SA (Etype (C));
5747
               Next_Formal (C);
5748
            end loop;
5749
 
5750
         else
5751
            raise Cannot_Be_Static;
5752
         end if;
5753
      end Ensure_Type_Is_SA;
5754
 
5755
   --  Start of processing for Freeze_Static_Object
5756
 
5757
   begin
5758
      Ensure_Type_Is_SA (Etype (E));
5759
 
5760
   exception
5761
      when Cannot_Be_Static =>
5762
 
5763
         --  If the object that cannot be static is imported or exported, then
5764
         --  issue an error message saying that this object cannot be imported
5765
         --  or exported. If it has an address clause it is an overlay in the
5766
         --  current partition and the static requirement is not relevant.
5767
         --  Do not issue any error message when ignoring rep clauses.
5768
 
5769
         if Ignore_Rep_Clauses then
5770
            null;
5771
 
5772
         elsif Is_Imported (E) then
5773
            if No (Address_Clause (E)) then
5774
               Error_Msg_N
5775
                 ("& cannot be imported (local type is not constant)", E);
5776
            end if;
5777
 
5778
         --  Otherwise must be exported, something is wrong if compiler
5779
         --  is marking something as statically allocated which cannot be).
5780
 
5781
         else pragma Assert (Is_Exported (E));
5782
            Error_Msg_N
5783
              ("& cannot be exported (local type is not constant)", E);
5784
         end if;
5785
   end Freeze_Static_Object;
5786
 
5787
   -----------------------
5788
   -- Freeze_Subprogram --
5789
   -----------------------
5790
 
5791
   procedure Freeze_Subprogram (E : Entity_Id) is
5792
      Retype : Entity_Id;
5793
      F      : Entity_Id;
5794
 
5795
   begin
5796
      --  Subprogram may not have an address clause unless it is imported
5797
 
5798
      if Present (Address_Clause (E)) then
5799
         if not Is_Imported (E) then
5800
            Error_Msg_N
5801
              ("address clause can only be given " &
5802
               "for imported subprogram",
5803
               Name (Address_Clause (E)));
5804
         end if;
5805
      end if;
5806
 
5807
      --  Reset the Pure indication on an imported subprogram unless an
5808
      --  explicit Pure_Function pragma was present. We do this because
5809
      --  otherwise it is an insidious error to call a non-pure function from
5810
      --  pure unit and have calls mysteriously optimized away. What happens
5811
      --  here is that the Import can bypass the normal check to ensure that
5812
      --  pure units call only pure subprograms.
5813
 
5814
      if Is_Imported (E)
5815
        and then Is_Pure (E)
5816
        and then not Has_Pragma_Pure_Function (E)
5817
      then
5818
         Set_Is_Pure (E, False);
5819
      end if;
5820
 
5821
      --  For non-foreign convention subprograms, this is where we create
5822
      --  the extra formals (for accessibility level and constrained bit
5823
      --  information). We delay this till the freeze point precisely so
5824
      --  that we know the convention!
5825
 
5826
      if not Has_Foreign_Convention (E) then
5827
         Create_Extra_Formals (E);
5828
         Set_Mechanisms (E);
5829
 
5830
         --  If this is convention Ada and a Valued_Procedure, that's odd
5831
 
5832
         if Ekind (E) = E_Procedure
5833
           and then Is_Valued_Procedure (E)
5834
           and then Convention (E) = Convention_Ada
5835
           and then Warn_On_Export_Import
5836
         then
5837
            Error_Msg_N
5838
              ("?Valued_Procedure has no effect for convention Ada", E);
5839
            Set_Is_Valued_Procedure (E, False);
5840
         end if;
5841
 
5842
      --  Case of foreign convention
5843
 
5844
      else
5845
         Set_Mechanisms (E);
5846
 
5847
         --  For foreign conventions, warn about return of an
5848
         --  unconstrained array.
5849
 
5850
         --  Note: we *do* allow a return by descriptor for the VMS case,
5851
         --  though here there is probably more to be done ???
5852
 
5853
         if Ekind (E) = E_Function then
5854
            Retype := Underlying_Type (Etype (E));
5855
 
5856
            --  If no return type, probably some other error, e.g. a
5857
            --  missing full declaration, so ignore.
5858
 
5859
            if No (Retype) then
5860
               null;
5861
 
5862
            --  If the return type is generic, we have emitted a warning
5863
            --  earlier on, and there is nothing else to check here. Specific
5864
            --  instantiations may lead to erroneous behavior.
5865
 
5866
            elsif Is_Generic_Type (Etype (E)) then
5867
               null;
5868
 
5869
            --  Display warning if returning unconstrained array
5870
 
5871
            elsif Is_Array_Type (Retype)
5872
              and then not Is_Constrained (Retype)
5873
 
5874
              --  Exclude cases where descriptor mechanism is set, since the
5875
              --  VMS descriptor mechanisms allow such unconstrained returns.
5876
 
5877
              and then Mechanism (E) not in Descriptor_Codes
5878
 
5879
               --  Check appropriate warning is enabled (should we check for
5880
               --  Warnings (Off) on specific entities here, probably so???)
5881
 
5882
              and then Warn_On_Export_Import
5883
 
5884
              --  Exclude the VM case, since return of unconstrained arrays
5885
              --  is properly handled in both the JVM and .NET cases.
5886
 
5887
              and then VM_Target = No_VM
5888
            then
5889
               Error_Msg_N
5890
                ("?foreign convention function& should not return " &
5891
                  "unconstrained array", E);
5892
               return;
5893
            end if;
5894
         end if;
5895
 
5896
         --  If any of the formals for an exported foreign convention
5897
         --  subprogram have defaults, then emit an appropriate warning since
5898
         --  this is odd (default cannot be used from non-Ada code)
5899
 
5900
         if Is_Exported (E) then
5901
            F := First_Formal (E);
5902
            while Present (F) loop
5903
               if Warn_On_Export_Import
5904
                 and then Present (Default_Value (F))
5905
               then
5906
                  Error_Msg_N
5907
                    ("?parameter cannot be defaulted in non-Ada call",
5908
                     Default_Value (F));
5909
               end if;
5910
 
5911
               Next_Formal (F);
5912
            end loop;
5913
         end if;
5914
      end if;
5915
 
5916
      --  For VMS, descriptor mechanisms for parameters are allowed only for
5917
      --  imported/exported subprograms. Moreover, the NCA descriptor is not
5918
      --  allowed for parameters of exported subprograms.
5919
 
5920
      if OpenVMS_On_Target then
5921
         if Is_Exported (E) then
5922
            F := First_Formal (E);
5923
            while Present (F) loop
5924
               if Mechanism (F) = By_Descriptor_NCA then
5925
                  Error_Msg_N
5926
                    ("'N'C'A' descriptor for parameter not permitted", F);
5927
                  Error_Msg_N
5928
                    ("\can only be used for imported subprogram", F);
5929
               end if;
5930
 
5931
               Next_Formal (F);
5932
            end loop;
5933
 
5934
         elsif not Is_Imported (E) then
5935
            F := First_Formal (E);
5936
            while Present (F) loop
5937
               if Mechanism (F) in Descriptor_Codes then
5938
                  Error_Msg_N
5939
                    ("descriptor mechanism for parameter not permitted", F);
5940
                  Error_Msg_N
5941
                    ("\can only be used for imported/exported subprogram", F);
5942
               end if;
5943
 
5944
               Next_Formal (F);
5945
            end loop;
5946
         end if;
5947
      end if;
5948
 
5949
      --  Pragma Inline_Always is disallowed for dispatching subprograms
5950
      --  because the address of such subprograms is saved in the dispatch
5951
      --  table to support dispatching calls, and dispatching calls cannot
5952
      --  be inlined. This is consistent with the restriction against using
5953
      --  'Access or 'Address on an Inline_Always subprogram.
5954
 
5955
      if Is_Dispatching_Operation (E)
5956
        and then Has_Pragma_Inline_Always (E)
5957
      then
5958
         Error_Msg_N
5959
           ("pragma Inline_Always not allowed for dispatching subprograms", E);
5960
      end if;
5961
 
5962
      --  Because of the implicit representation of inherited predefined
5963
      --  operators in the front-end, the overriding status of the operation
5964
      --  may be affected when a full view of a type is analyzed, and this is
5965
      --  not captured by the analysis of the corresponding type declaration.
5966
      --  Therefore the correctness of a not-overriding indicator must be
5967
      --  rechecked when the subprogram is frozen.
5968
 
5969
      if Nkind (E) = N_Defining_Operator_Symbol
5970
        and then not Error_Posted (Parent (E))
5971
      then
5972
         Check_Overriding_Indicator (E, Empty, Is_Primitive (E));
5973
      end if;
5974
   end Freeze_Subprogram;
5975
 
5976
   ----------------------
5977
   -- Is_Fully_Defined --
5978
   ----------------------
5979
 
5980
   function Is_Fully_Defined (T : Entity_Id) return Boolean is
5981
   begin
5982
      if Ekind (T) = E_Class_Wide_Type then
5983
         return Is_Fully_Defined (Etype (T));
5984
 
5985
      elsif Is_Array_Type (T) then
5986
         return Is_Fully_Defined (Component_Type (T));
5987
 
5988
      elsif Is_Record_Type (T)
5989
        and not Is_Private_Type (T)
5990
      then
5991
         --  Verify that the record type has no components with private types
5992
         --  without completion.
5993
 
5994
         declare
5995
            Comp : Entity_Id;
5996
 
5997
         begin
5998
            Comp := First_Component (T);
5999
            while Present (Comp) loop
6000
               if not Is_Fully_Defined (Etype (Comp)) then
6001
                  return False;
6002
               end if;
6003
 
6004
               Next_Component (Comp);
6005
            end loop;
6006
            return True;
6007
         end;
6008
 
6009
      --  For the designated type of an access to subprogram, all types in
6010
      --  the profile must be fully defined.
6011
 
6012
      elsif Ekind (T) = E_Subprogram_Type then
6013
         declare
6014
            F : Entity_Id;
6015
 
6016
         begin
6017
            F := First_Formal (T);
6018
            while Present (F) loop
6019
               if not Is_Fully_Defined (Etype (F)) then
6020
                  return False;
6021
               end if;
6022
 
6023
               Next_Formal (F);
6024
            end loop;
6025
 
6026
            return Is_Fully_Defined (Etype (T));
6027
         end;
6028
 
6029
      else
6030
         return not Is_Private_Type (T)
6031
           or else Present (Full_View (Base_Type (T)));
6032
      end if;
6033
   end Is_Fully_Defined;
6034
 
6035
   ---------------------------------
6036
   -- Process_Default_Expressions --
6037
   ---------------------------------
6038
 
6039
   procedure Process_Default_Expressions
6040
     (E     : Entity_Id;
6041
      After : in out Node_Id)
6042
   is
6043
      Loc    : constant Source_Ptr := Sloc (E);
6044
      Dbody  : Node_Id;
6045
      Formal : Node_Id;
6046
      Dcopy  : Node_Id;
6047
      Dnam   : Entity_Id;
6048
 
6049
   begin
6050
      Set_Default_Expressions_Processed (E);
6051
 
6052
      --  A subprogram instance and its associated anonymous subprogram share
6053
      --  their signature. The default expression functions are defined in the
6054
      --  wrapper packages for the anonymous subprogram, and should not be
6055
      --  generated again for the instance.
6056
 
6057
      if Is_Generic_Instance (E)
6058
        and then Present (Alias (E))
6059
        and then Default_Expressions_Processed (Alias (E))
6060
      then
6061
         return;
6062
      end if;
6063
 
6064
      Formal := First_Formal (E);
6065
      while Present (Formal) loop
6066
         if Present (Default_Value (Formal)) then
6067
 
6068
            --  We work with a copy of the default expression because we
6069
            --  do not want to disturb the original, since this would mess
6070
            --  up the conformance checking.
6071
 
6072
            Dcopy := New_Copy_Tree (Default_Value (Formal));
6073
 
6074
            --  The analysis of the expression may generate insert actions,
6075
            --  which of course must not be executed. We wrap those actions
6076
            --  in a procedure that is not called, and later on eliminated.
6077
            --  The following cases have no side-effects, and are analyzed
6078
            --  directly.
6079
 
6080
            if Nkind (Dcopy) = N_Identifier
6081
              or else Nkind (Dcopy) = N_Expanded_Name
6082
              or else Nkind (Dcopy) = N_Integer_Literal
6083
              or else (Nkind (Dcopy) = N_Real_Literal
6084
                        and then not Vax_Float (Etype (Dcopy)))
6085
              or else Nkind (Dcopy) = N_Character_Literal
6086
              or else Nkind (Dcopy) = N_String_Literal
6087
              or else Known_Null (Dcopy)
6088
              or else (Nkind (Dcopy) = N_Attribute_Reference
6089
                        and then
6090
                       Attribute_Name (Dcopy) = Name_Null_Parameter)
6091
            then
6092
 
6093
               --  If there is no default function, we must still do a full
6094
               --  analyze call on the default value, to ensure that all error
6095
               --  checks are performed, e.g. those associated with static
6096
               --  evaluation. Note: this branch will always be taken if the
6097
               --  analyzer is turned off (but we still need the error checks).
6098
 
6099
               --  Note: the setting of parent here is to meet the requirement
6100
               --  that we can only analyze the expression while attached to
6101
               --  the tree. Really the requirement is that the parent chain
6102
               --  be set, we don't actually need to be in the tree.
6103
 
6104
               Set_Parent (Dcopy, Declaration_Node (Formal));
6105
               Analyze (Dcopy);
6106
 
6107
               --  Default expressions are resolved with their own type if the
6108
               --  context is generic, to avoid anomalies with private types.
6109
 
6110
               if Ekind (Scope (E)) = E_Generic_Package then
6111
                  Resolve (Dcopy);
6112
               else
6113
                  Resolve (Dcopy, Etype (Formal));
6114
               end if;
6115
 
6116
               --  If that resolved expression will raise constraint error,
6117
               --  then flag the default value as raising constraint error.
6118
               --  This allows a proper error message on the calls.
6119
 
6120
               if Raises_Constraint_Error (Dcopy) then
6121
                  Set_Raises_Constraint_Error (Default_Value (Formal));
6122
               end if;
6123
 
6124
            --  If the default is a parameterless call, we use the name of
6125
            --  the called function directly, and there is no body to build.
6126
 
6127
            elsif Nkind (Dcopy) = N_Function_Call
6128
              and then No (Parameter_Associations (Dcopy))
6129
            then
6130
               null;
6131
 
6132
            --  Else construct and analyze the body of a wrapper procedure
6133
            --  that contains an object declaration to hold the expression.
6134
            --  Given that this is done only to complete the analysis, it
6135
            --  simpler to build a procedure than a function which might
6136
            --  involve secondary stack expansion.
6137
 
6138
            else
6139
               Dnam := Make_Temporary (Loc, 'D');
6140
 
6141
               Dbody :=
6142
                 Make_Subprogram_Body (Loc,
6143
                   Specification =>
6144
                     Make_Procedure_Specification (Loc,
6145
                       Defining_Unit_Name => Dnam),
6146
 
6147
                   Declarations => New_List (
6148
                     Make_Object_Declaration (Loc,
6149
                       Defining_Identifier => Make_Temporary (Loc, 'T'),
6150
                       Object_Definition   =>
6151
                         New_Occurrence_Of (Etype (Formal), Loc),
6152
                       Expression          => New_Copy_Tree (Dcopy))),
6153
 
6154
                   Handled_Statement_Sequence =>
6155
                     Make_Handled_Sequence_Of_Statements (Loc,
6156
                       Statements => Empty_List));
6157
 
6158
               Set_Scope (Dnam, Scope (E));
6159
               Set_Assignment_OK (First (Declarations (Dbody)));
6160
               Set_Is_Eliminated (Dnam);
6161
               Insert_After (After, Dbody);
6162
               Analyze (Dbody);
6163
               After := Dbody;
6164
            end if;
6165
         end if;
6166
 
6167
         Next_Formal (Formal);
6168
      end loop;
6169
   end Process_Default_Expressions;
6170
 
6171
   ----------------------------------------
6172
   -- Set_Component_Alignment_If_Not_Set --
6173
   ----------------------------------------
6174
 
6175
   procedure Set_Component_Alignment_If_Not_Set (Typ : Entity_Id) is
6176
   begin
6177
      --  Ignore if not base type, subtypes don't need anything
6178
 
6179
      if Typ /= Base_Type (Typ) then
6180
         return;
6181
      end if;
6182
 
6183
      --  Do not override existing representation
6184
 
6185
      if Is_Packed (Typ) then
6186
         return;
6187
 
6188
      elsif Has_Specified_Layout (Typ) then
6189
         return;
6190
 
6191
      elsif Component_Alignment (Typ) /= Calign_Default then
6192
         return;
6193
 
6194
      else
6195
         Set_Component_Alignment
6196
           (Typ, Scope_Stack.Table
6197
                  (Scope_Stack.Last).Component_Alignment_Default);
6198
      end if;
6199
   end Set_Component_Alignment_If_Not_Set;
6200
 
6201
   ------------------
6202
   -- Undelay_Type --
6203
   ------------------
6204
 
6205
   procedure Undelay_Type (T : Entity_Id) is
6206
   begin
6207
      Set_Has_Delayed_Freeze (T, False);
6208
      Set_Freeze_Node (T, Empty);
6209
 
6210
      --  Since we don't want T to have a Freeze_Node, we don't want its
6211
      --  Full_View or Corresponding_Record_Type to have one either.
6212
 
6213
      --  ??? Fundamentally, this whole handling is a kludge. What we really
6214
      --  want is to be sure that for an Itype that's part of record R and is a
6215
      --  subtype of type T, that it's frozen after the later of the freeze
6216
      --  points of R and T. We have no way of doing that directly, so what we
6217
      --  do is force most such Itypes to be frozen as part of freezing R via
6218
      --  this procedure and only delay the ones that need to be delayed
6219
      --  (mostly the designated types of access types that are defined as part
6220
      --  of the record).
6221
 
6222
      if Is_Private_Type (T)
6223
        and then Present (Full_View (T))
6224
        and then Is_Itype (Full_View (T))
6225
        and then Is_Record_Type (Scope (Full_View (T)))
6226
      then
6227
         Undelay_Type (Full_View (T));
6228
      end if;
6229
 
6230
      if Is_Concurrent_Type (T)
6231
        and then Present (Corresponding_Record_Type (T))
6232
        and then Is_Itype (Corresponding_Record_Type (T))
6233
        and then Is_Record_Type (Scope (Corresponding_Record_Type (T)))
6234
      then
6235
         Undelay_Type (Corresponding_Record_Type (T));
6236
      end if;
6237
   end Undelay_Type;
6238
 
6239
   ------------------
6240
   -- Warn_Overlay --
6241
   ------------------
6242
 
6243
   procedure Warn_Overlay
6244
     (Expr : Node_Id;
6245
      Typ  : Entity_Id;
6246
      Nam  : Entity_Id)
6247
   is
6248
      Ent : constant Entity_Id := Entity (Nam);
6249
      --  The object to which the address clause applies
6250
 
6251
      Init : Node_Id;
6252
      Old  : Entity_Id := Empty;
6253
      Decl : Node_Id;
6254
 
6255
   begin
6256
      --  No warning if address clause overlay warnings are off
6257
 
6258
      if not Address_Clause_Overlay_Warnings then
6259
         return;
6260
      end if;
6261
 
6262
      --  No warning if there is an explicit initialization
6263
 
6264
      Init := Original_Node (Expression (Declaration_Node (Ent)));
6265
 
6266
      if Present (Init) and then Comes_From_Source (Init) then
6267
         return;
6268
      end if;
6269
 
6270
      --  We only give the warning for non-imported entities of a type for
6271
      --  which a non-null base init proc is defined, or for objects of access
6272
      --  types with implicit null initialization, or when Normalize_Scalars
6273
      --  applies and the type is scalar or a string type (the latter being
6274
      --  tested for because predefined String types are initialized by inline
6275
      --  code rather than by an init_proc). Note that we do not give the
6276
      --  warning for Initialize_Scalars, since we suppressed initialization
6277
      --  in this case. Also, do not warn if Suppress_Initialization is set.
6278
 
6279
      if Present (Expr)
6280
        and then not Is_Imported (Ent)
6281
        and then not Initialization_Suppressed (Typ)
6282
        and then (Has_Non_Null_Base_Init_Proc (Typ)
6283
                   or else Is_Access_Type (Typ)
6284
                   or else (Normalize_Scalars
6285
                             and then (Is_Scalar_Type (Typ)
6286
                                        or else Is_String_Type (Typ))))
6287
      then
6288
         if Nkind (Expr) = N_Attribute_Reference
6289
           and then Is_Entity_Name (Prefix (Expr))
6290
         then
6291
            Old := Entity (Prefix (Expr));
6292
 
6293
         elsif Is_Entity_Name (Expr)
6294
           and then Ekind (Entity (Expr)) = E_Constant
6295
         then
6296
            Decl := Declaration_Node (Entity (Expr));
6297
 
6298
            if Nkind (Decl) = N_Object_Declaration
6299
              and then Present (Expression (Decl))
6300
              and then Nkind (Expression (Decl)) = N_Attribute_Reference
6301
              and then Is_Entity_Name (Prefix (Expression (Decl)))
6302
            then
6303
               Old := Entity (Prefix (Expression (Decl)));
6304
 
6305
            elsif Nkind (Expr) = N_Function_Call then
6306
               return;
6307
            end if;
6308
 
6309
         --  A function call (most likely to To_Address) is probably not an
6310
         --  overlay, so skip warning. Ditto if the function call was inlined
6311
         --  and transformed into an entity.
6312
 
6313
         elsif Nkind (Original_Node (Expr)) = N_Function_Call then
6314
            return;
6315
         end if;
6316
 
6317
         Decl := Next (Parent (Expr));
6318
 
6319
         --  If a pragma Import follows, we assume that it is for the current
6320
         --  target of the address clause, and skip the warning.
6321
 
6322
         if Present (Decl)
6323
           and then Nkind (Decl) = N_Pragma
6324
           and then Pragma_Name (Decl) = Name_Import
6325
         then
6326
            return;
6327
         end if;
6328
 
6329
         if Present (Old) then
6330
            Error_Msg_Node_2 := Old;
6331
            Error_Msg_N
6332
              ("default initialization of & may modify &?",
6333
               Nam);
6334
         else
6335
            Error_Msg_N
6336
              ("default initialization of & may modify overlaid storage?",
6337
               Nam);
6338
         end if;
6339
 
6340
         --  Add friendly warning if initialization comes from a packed array
6341
         --  component.
6342
 
6343
         if Is_Record_Type (Typ)  then
6344
            declare
6345
               Comp : Entity_Id;
6346
 
6347
            begin
6348
               Comp := First_Component (Typ);
6349
               while Present (Comp) loop
6350
                  if Nkind (Parent (Comp)) = N_Component_Declaration
6351
                    and then Present (Expression (Parent (Comp)))
6352
                  then
6353
                     exit;
6354
                  elsif Is_Array_Type (Etype (Comp))
6355
                     and then Present (Packed_Array_Type (Etype (Comp)))
6356
                  then
6357
                     Error_Msg_NE
6358
                       ("\packed array component& " &
6359
                        "will be initialized to zero?",
6360
                        Nam, Comp);
6361
                     exit;
6362
                  else
6363
                     Next_Component (Comp);
6364
                  end if;
6365
               end loop;
6366
            end;
6367
         end if;
6368
 
6369
         Error_Msg_N
6370
           ("\use pragma Import for & to " &
6371
            "suppress initialization (RM B.1(24))?",
6372
            Nam);
6373
      end if;
6374
   end Warn_Overlay;
6375
 
6376
end Freeze;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.