OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [ada/] [freeze.adb] - Blame information for rev 384

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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