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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [sem_ch13.adb] - Blame information for rev 847

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                             S E M _ C H 1 3                              --
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.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
with Atree;    use Atree;
27
with Checks;   use Checks;
28
with Einfo;    use Einfo;
29
with Errout;   use Errout;
30
with Exp_Tss;  use Exp_Tss;
31
with Exp_Util; use Exp_Util;
32
with Lib;      use Lib;
33
with Lib.Xref; use Lib.Xref;
34
with Namet;    use Namet;
35
with Nlists;   use Nlists;
36
with Nmake;    use Nmake;
37
with Opt;      use Opt;
38
with Restrict; use Restrict;
39
with Rident;   use Rident;
40
with Rtsfind;  use Rtsfind;
41
with Sem;      use Sem;
42
with Sem_Aux;  use Sem_Aux;
43
with Sem_Ch3;  use Sem_Ch3;
44
with Sem_Ch8;  use Sem_Ch8;
45
with Sem_Eval; use Sem_Eval;
46
with Sem_Res;  use Sem_Res;
47
with Sem_Type; use Sem_Type;
48
with Sem_Util; use Sem_Util;
49
with Sem_Warn; use Sem_Warn;
50
with Snames;   use Snames;
51
with Stand;    use Stand;
52
with Sinfo;    use Sinfo;
53
with Table;
54
with Targparm; use Targparm;
55
with Ttypes;   use Ttypes;
56
with Tbuild;   use Tbuild;
57
with Urealp;   use Urealp;
58
 
59
with GNAT.Heap_Sort_G;
60
 
61
package body Sem_Ch13 is
62
 
63
   SSU : constant Pos := System_Storage_Unit;
64
   --  Convenient short hand for commonly used constant
65
 
66
   -----------------------
67
   -- Local Subprograms --
68
   -----------------------
69
 
70
   procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id);
71
   --  This routine is called after setting the Esize of type entity Typ.
72
   --  The purpose is to deal with the situation where an alignment has been
73
   --  inherited from a derived type that is no longer appropriate for the
74
   --  new Esize value. In this case, we reset the Alignment to unknown.
75
 
76
   procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id);
77
   --  Given two entities for record components or discriminants, checks
78
   --  if they have overlapping component clauses and issues errors if so.
79
 
80
   function Get_Alignment_Value (Expr : Node_Id) return Uint;
81
   --  Given the expression for an alignment value, returns the corresponding
82
   --  Uint value. If the value is inappropriate, then error messages are
83
   --  posted as required, and a value of No_Uint is returned.
84
 
85
   function Is_Operational_Item (N : Node_Id) return Boolean;
86
   --  A specification for a stream attribute is allowed before the full
87
   --  type is declared, as explained in AI-00137 and the corrigendum.
88
   --  Attributes that do not specify a representation characteristic are
89
   --  operational attributes.
90
 
91
   procedure New_Stream_Subprogram
92
     (N    : Node_Id;
93
      Ent  : Entity_Id;
94
      Subp : Entity_Id;
95
      Nam  : TSS_Name_Type);
96
   --  Create a subprogram renaming of a given stream attribute to the
97
   --  designated subprogram and then in the tagged case, provide this as a
98
   --  primitive operation, or in the non-tagged case make an appropriate TSS
99
   --  entry. This is more properly an expansion activity than just semantics,
100
   --  but the presence of user-defined stream functions for limited types is a
101
   --  legality check, which is why this takes place here rather than in
102
   --  exp_ch13, where it was previously. Nam indicates the name of the TSS
103
   --  function to be generated.
104
   --
105
   --  To avoid elaboration anomalies with freeze nodes, for untagged types
106
   --  we generate both a subprogram declaration and a subprogram renaming
107
   --  declaration, so that the attribute specification is handled as a
108
   --  renaming_as_body. For tagged types, the specification is one of the
109
   --  primitive specs.
110
 
111
   ----------------------------------------------
112
   -- Table for Validate_Unchecked_Conversions --
113
   ----------------------------------------------
114
 
115
   --  The following table collects unchecked conversions for validation.
116
   --  Entries are made by Validate_Unchecked_Conversion and then the
117
   --  call to Validate_Unchecked_Conversions does the actual error
118
   --  checking and posting of warnings. The reason for this delayed
119
   --  processing is to take advantage of back-annotations of size and
120
   --  alignment values performed by the back end.
121
 
122
   --  Note: the reason we store a Source_Ptr value instead of a Node_Id
123
   --  is that by the time Validate_Unchecked_Conversions is called, Sprint
124
   --  will already have modified all Sloc values if the -gnatD option is set.
125
 
126
   type UC_Entry is record
127
      Eloc   : Source_Ptr; -- node used for posting warnings
128
      Source : Entity_Id;  -- source type for unchecked conversion
129
      Target : Entity_Id;  -- target type for unchecked conversion
130
   end record;
131
 
132
   package Unchecked_Conversions is new Table.Table (
133
     Table_Component_Type => UC_Entry,
134
     Table_Index_Type     => Int,
135
     Table_Low_Bound      => 1,
136
     Table_Initial        => 50,
137
     Table_Increment      => 200,
138
     Table_Name           => "Unchecked_Conversions");
139
 
140
   ----------------------------------------
141
   -- Table for Validate_Address_Clauses --
142
   ----------------------------------------
143
 
144
   --  If an address clause has the form
145
 
146
   --    for X'Address use Expr
147
 
148
   --  where Expr is of the form Y'Address or recursively is a reference
149
   --  to a constant of either of these forms, and X and Y are entities of
150
   --  objects, then if Y has a smaller alignment than X, that merits a
151
   --  warning about possible bad alignment. The following table collects
152
   --  address clauses of this kind. We put these in a table so that they
153
   --  can be checked after the back end has completed annotation of the
154
   --  alignments of objects, since we can catch more cases that way.
155
 
156
   type Address_Clause_Check_Record is record
157
      N : Node_Id;
158
      --  The address clause
159
 
160
      X : Entity_Id;
161
      --  The entity of the object overlaying Y
162
 
163
      Y : Entity_Id;
164
      --  The entity of the object being overlaid
165
 
166
      Off : Boolean;
167
      --  Whether the address is offseted within Y
168
   end record;
169
 
170
   package Address_Clause_Checks is new Table.Table (
171
     Table_Component_Type => Address_Clause_Check_Record,
172
     Table_Index_Type     => Int,
173
     Table_Low_Bound      => 1,
174
     Table_Initial        => 20,
175
     Table_Increment      => 200,
176
     Table_Name           => "Address_Clause_Checks");
177
 
178
   -----------------------------------------
179
   -- Adjust_Record_For_Reverse_Bit_Order --
180
   -----------------------------------------
181
 
182
   procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is
183
      Max_Machine_Scalar_Size : constant Uint :=
184
                                  UI_From_Int
185
                                    (Standard_Long_Long_Integer_Size);
186
      --  We use this as the maximum machine scalar size in the sense of AI-133
187
 
188
      Num_CC : Natural;
189
      Comp   : Entity_Id;
190
      SSU    : constant Uint := UI_From_Int (System_Storage_Unit);
191
 
192
   begin
193
      --  This first loop through components does two things. First it deals
194
      --  with the case of components with component clauses whose length is
195
      --  greater than the maximum machine scalar size (either accepting them
196
      --  or rejecting as needed). Second, it counts the number of components
197
      --  with component clauses whose length does not exceed this maximum for
198
      --  later processing.
199
 
200
      Num_CC := 0;
201
      Comp   := First_Component_Or_Discriminant (R);
202
      while Present (Comp) loop
203
         declare
204
            CC : constant Node_Id := Component_Clause (Comp);
205
 
206
         begin
207
            if Present (CC) then
208
               declare
209
                  Fbit : constant Uint := Static_Integer (First_Bit (CC));
210
 
211
               begin
212
                  --  Case of component with size > max machine scalar
213
 
214
                  if Esize (Comp) > Max_Machine_Scalar_Size then
215
 
216
                     --  Must begin on byte boundary
217
 
218
                     if Fbit mod SSU /= 0 then
219
                        Error_Msg_N
220
                          ("illegal first bit value for reverse bit order",
221
                           First_Bit (CC));
222
                        Error_Msg_Uint_1 := SSU;
223
                        Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
224
 
225
                        Error_Msg_N
226
                          ("\must be a multiple of ^ if size greater than ^",
227
                           First_Bit (CC));
228
 
229
                     --  Must end on byte boundary
230
 
231
                     elsif Esize (Comp) mod SSU /= 0 then
232
                        Error_Msg_N
233
                          ("illegal last bit value for reverse bit order",
234
                           Last_Bit (CC));
235
                        Error_Msg_Uint_1 := SSU;
236
                        Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
237
 
238
                        Error_Msg_N
239
                          ("\must be a multiple of ^ if size greater than ^",
240
                           Last_Bit (CC));
241
 
242
                     --  OK, give warning if enabled
243
 
244
                     elsif Warn_On_Reverse_Bit_Order then
245
                        Error_Msg_N
246
                          ("multi-byte field specified with non-standard"
247
                           & " Bit_Order?", CC);
248
 
249
                        if Bytes_Big_Endian then
250
                           Error_Msg_N
251
                             ("\bytes are not reversed "
252
                              & "(component is big-endian)?", CC);
253
                        else
254
                           Error_Msg_N
255
                             ("\bytes are not reversed "
256
                              & "(component is little-endian)?", CC);
257
                        end if;
258
                     end if;
259
 
260
                     --  Case where size is not greater than max machine
261
                     --  scalar. For now, we just count these.
262
 
263
                  else
264
                     Num_CC := Num_CC + 1;
265
                  end if;
266
               end;
267
            end if;
268
         end;
269
 
270
         Next_Component_Or_Discriminant (Comp);
271
      end loop;
272
 
273
      --  We need to sort the component clauses on the basis of the Position
274
      --  values in the clause, so we can group clauses with the same Position.
275
      --  together to determine the relevant machine scalar size.
276
 
277
      declare
278
         Comps : array (0 .. Num_CC) of Entity_Id;
279
         --  Array to collect component and discriminant entities. The data
280
         --  starts at index 1, the 0'th entry is for the sort routine.
281
 
282
         function CP_Lt (Op1, Op2 : Natural) return Boolean;
283
         --  Compare routine for Sort
284
 
285
         procedure CP_Move (From : Natural; To : Natural);
286
         --  Move routine for Sort
287
 
288
         package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
289
 
290
         Start : Natural;
291
         Stop  : Natural;
292
         --  Start and stop positions in component list of set of components
293
         --  with the same starting position (that constitute components in
294
         --  a single machine scalar).
295
 
296
         MaxL : Uint;
297
         --  Maximum last bit value of any component in this set
298
 
299
         MSS : Uint;
300
         --  Corresponding machine scalar size
301
 
302
         -----------
303
         -- CP_Lt --
304
         -----------
305
 
306
         function CP_Lt (Op1, Op2 : Natural) return Boolean is
307
         begin
308
            return Position (Component_Clause (Comps (Op1))) <
309
                   Position (Component_Clause (Comps (Op2)));
310
         end CP_Lt;
311
 
312
         -------------
313
         -- CP_Move --
314
         -------------
315
 
316
         procedure CP_Move (From : Natural; To : Natural) is
317
         begin
318
            Comps (To) := Comps (From);
319
         end CP_Move;
320
 
321
      begin
322
         --  Collect the component clauses
323
 
324
         Num_CC := 0;
325
         Comp   := First_Component_Or_Discriminant (R);
326
         while Present (Comp) loop
327
            if Present (Component_Clause (Comp))
328
              and then Esize (Comp) <= Max_Machine_Scalar_Size
329
            then
330
               Num_CC := Num_CC + 1;
331
               Comps (Num_CC) := Comp;
332
            end if;
333
 
334
            Next_Component_Or_Discriminant (Comp);
335
         end loop;
336
 
337
         --  Sort by ascending position number
338
 
339
         Sorting.Sort (Num_CC);
340
 
341
         --  We now have all the components whose size does not exceed the max
342
         --  machine scalar value, sorted by starting position. In this loop
343
         --  we gather groups of clauses starting at the same position, to
344
         --  process them in accordance with Ada 2005 AI-133.
345
 
346
         Stop := 0;
347
         while Stop < Num_CC loop
348
            Start := Stop + 1;
349
            Stop  := Start;
350
            MaxL  :=
351
              Static_Integer (Last_Bit (Component_Clause (Comps (Start))));
352
            while Stop < Num_CC loop
353
               if Static_Integer
354
                    (Position (Component_Clause (Comps (Stop + 1)))) =
355
                  Static_Integer
356
                    (Position (Component_Clause (Comps (Stop))))
357
               then
358
                  Stop := Stop + 1;
359
                  MaxL :=
360
                    UI_Max
361
                      (MaxL,
362
                       Static_Integer
363
                         (Last_Bit (Component_Clause (Comps (Stop)))));
364
               else
365
                  exit;
366
               end if;
367
            end loop;
368
 
369
            --  Now we have a group of component clauses from Start to Stop
370
            --  whose positions are identical, and MaxL is the maximum last bit
371
            --  value of any of these components.
372
 
373
            --  We need to determine the corresponding machine scalar size.
374
            --  This loop assumes that machine scalar sizes are even, and that
375
            --  each possible machine scalar has twice as many bits as the
376
            --  next smaller one.
377
 
378
            MSS := Max_Machine_Scalar_Size;
379
            while MSS mod 2 = 0
380
              and then (MSS / 2) >= SSU
381
              and then (MSS / 2) > MaxL
382
            loop
383
               MSS := MSS / 2;
384
            end loop;
385
 
386
            --  Here is where we fix up the Component_Bit_Offset value to
387
            --  account for the reverse bit order. Some examples of what needs
388
            --  to be done for the case of a machine scalar size of 8 are:
389
 
390
            --    First_Bit .. Last_Bit     Component_Bit_Offset
391
            --      old          new          old       new
392
 
393
            --     0 .. 0       7 .. 7         0         7
394
            --     0 .. 1       6 .. 7         0         6
395
            --     0 .. 2       5 .. 7         0         5
396
            --     0 .. 7       0 .. 7         0         4
397
 
398
            --     1 .. 1       6 .. 6         1         6
399
            --     1 .. 4       3 .. 6         1         3
400
            --     4 .. 7       0 .. 3         4         0
401
 
402
            --  The general rule is that the first bit is obtained by
403
            --  subtracting the old ending bit from machine scalar size - 1.
404
 
405
            for C in Start .. Stop loop
406
               declare
407
                  Comp : constant Entity_Id := Comps (C);
408
                  CC   : constant Node_Id   := Component_Clause (Comp);
409
                  LB   : constant Uint := Static_Integer (Last_Bit (CC));
410
                  NFB  : constant Uint := MSS - Uint_1 - LB;
411
                  NLB  : constant Uint := NFB + Esize (Comp) - 1;
412
                  Pos  : constant Uint := Static_Integer (Position (CC));
413
 
414
               begin
415
                  if Warn_On_Reverse_Bit_Order then
416
                     Error_Msg_Uint_1 := MSS;
417
                     Error_Msg_N
418
                       ("info: reverse bit order in machine " &
419
                       "scalar of length^?", First_Bit (CC));
420
                     Error_Msg_Uint_1 := NFB;
421
                     Error_Msg_Uint_2 := NLB;
422
 
423
                     if Bytes_Big_Endian then
424
                        Error_Msg_NE
425
                          ("?\info: big-endian range for "
426
                           & "component & is ^ .. ^",
427
                           First_Bit (CC), Comp);
428
                     else
429
                        Error_Msg_NE
430
                          ("?\info: little-endian range "
431
                           & "for component & is ^ .. ^",
432
                           First_Bit (CC), Comp);
433
                     end if;
434
                  end if;
435
 
436
                  Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
437
                  Set_Normalized_First_Bit (Comp, NFB mod SSU);
438
               end;
439
            end loop;
440
         end loop;
441
      end;
442
   end Adjust_Record_For_Reverse_Bit_Order;
443
 
444
   --------------------------------------
445
   -- Alignment_Check_For_Esize_Change --
446
   --------------------------------------
447
 
448
   procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id) is
449
   begin
450
      --  If the alignment is known, and not set by a rep clause, and is
451
      --  inconsistent with the size being set, then reset it to unknown,
452
      --  we assume in this case that the size overrides the inherited
453
      --  alignment, and that the alignment must be recomputed.
454
 
455
      if Known_Alignment (Typ)
456
        and then not Has_Alignment_Clause (Typ)
457
        and then Esize (Typ) mod (Alignment (Typ) * SSU) /= 0
458
      then
459
         Init_Alignment (Typ);
460
      end if;
461
   end Alignment_Check_For_Esize_Change;
462
 
463
   -----------------------
464
   -- Analyze_At_Clause --
465
   -----------------------
466
 
467
   --  An at clause is replaced by the corresponding Address attribute
468
   --  definition clause that is the preferred approach in Ada 95.
469
 
470
   procedure Analyze_At_Clause (N : Node_Id) is
471
      CS : constant Boolean := Comes_From_Source (N);
472
 
473
   begin
474
      --  This is an obsolescent feature
475
 
476
      Check_Restriction (No_Obsolescent_Features, N);
477
 
478
      if Warn_On_Obsolescent_Feature then
479
         Error_Msg_N
480
           ("at clause is an obsolescent feature (RM J.7(2))?", N);
481
         Error_Msg_N
482
           ("\use address attribute definition clause instead?", N);
483
      end if;
484
 
485
      --  Rewrite as address clause
486
 
487
      Rewrite (N,
488
        Make_Attribute_Definition_Clause (Sloc (N),
489
          Name  => Identifier (N),
490
          Chars => Name_Address,
491
          Expression => Expression (N)));
492
 
493
      --  We preserve Comes_From_Source, since logically the clause still
494
      --  comes from the source program even though it is changed in form.
495
 
496
      Set_Comes_From_Source (N, CS);
497
 
498
      --  Analyze rewritten clause
499
 
500
      Analyze_Attribute_Definition_Clause (N);
501
   end Analyze_At_Clause;
502
 
503
   -----------------------------------------
504
   -- Analyze_Attribute_Definition_Clause --
505
   -----------------------------------------
506
 
507
   procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is
508
      Loc   : constant Source_Ptr   := Sloc (N);
509
      Nam   : constant Node_Id      := Name (N);
510
      Attr  : constant Name_Id      := Chars (N);
511
      Expr  : constant Node_Id      := Expression (N);
512
      Id    : constant Attribute_Id := Get_Attribute_Id (Attr);
513
      Ent   : Entity_Id;
514
      U_Ent : Entity_Id;
515
 
516
      FOnly : Boolean := False;
517
      --  Reset to True for subtype specific attribute (Alignment, Size)
518
      --  and for stream attributes, i.e. those cases where in the call
519
      --  to Rep_Item_Too_Late, FOnly is set True so that only the freezing
520
      --  rules are checked. Note that the case of stream attributes is not
521
      --  clear from the RM, but see AI95-00137. Also, the RM seems to
522
      --  disallow Storage_Size for derived task types, but that is also
523
      --  clearly unintentional.
524
 
525
      procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type);
526
      --  Common processing for 'Read, 'Write, 'Input and 'Output attribute
527
      --  definition clauses.
528
 
529
      -----------------------------------
530
      -- Analyze_Stream_TSS_Definition --
531
      -----------------------------------
532
 
533
      procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is
534
         Subp : Entity_Id := Empty;
535
         I    : Interp_Index;
536
         It   : Interp;
537
         Pnam : Entity_Id;
538
 
539
         Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read);
540
 
541
         function Has_Good_Profile (Subp : Entity_Id) return Boolean;
542
         --  Return true if the entity is a subprogram with an appropriate
543
         --  profile for the attribute being defined.
544
 
545
         ----------------------
546
         -- Has_Good_Profile --
547
         ----------------------
548
 
549
         function Has_Good_Profile (Subp : Entity_Id) return Boolean is
550
            F              : Entity_Id;
551
            Is_Function    : constant Boolean := (TSS_Nam = TSS_Stream_Input);
552
            Expected_Ekind : constant array (Boolean) of Entity_Kind :=
553
                               (False => E_Procedure, True => E_Function);
554
            Typ            : Entity_Id;
555
 
556
         begin
557
            if Ekind (Subp) /= Expected_Ekind (Is_Function) then
558
               return False;
559
            end if;
560
 
561
            F := First_Formal (Subp);
562
 
563
            if No (F)
564
              or else Ekind (Etype (F)) /= E_Anonymous_Access_Type
565
              or else Designated_Type (Etype (F)) /=
566
                               Class_Wide_Type (RTE (RE_Root_Stream_Type))
567
            then
568
               return False;
569
            end if;
570
 
571
            if not Is_Function then
572
               Next_Formal (F);
573
 
574
               declare
575
                  Expected_Mode : constant array (Boolean) of Entity_Kind :=
576
                                    (False => E_In_Parameter,
577
                                     True  => E_Out_Parameter);
578
               begin
579
                  if Parameter_Mode (F) /= Expected_Mode (Is_Read) then
580
                     return False;
581
                  end if;
582
               end;
583
 
584
               Typ := Etype (F);
585
 
586
            else
587
               Typ := Etype (Subp);
588
            end if;
589
 
590
            return Base_Type (Typ) = Base_Type (Ent)
591
              and then No (Next_Formal (F));
592
         end Has_Good_Profile;
593
 
594
      --  Start of processing for Analyze_Stream_TSS_Definition
595
 
596
      begin
597
         FOnly := True;
598
 
599
         if not Is_Type (U_Ent) then
600
            Error_Msg_N ("local name must be a subtype", Nam);
601
            return;
602
         end if;
603
 
604
         Pnam := TSS (Base_Type (U_Ent), TSS_Nam);
605
 
606
         --  If Pnam is present, it can be either inherited from an ancestor
607
         --  type (in which case it is legal to redefine it for this type), or
608
         --  be a previous definition of the attribute for the same type (in
609
         --  which case it is illegal).
610
 
611
         --  In the first case, it will have been analyzed already, and we
612
         --  can check that its profile does not match the expected profile
613
         --  for a stream attribute of U_Ent. In the second case, either Pnam
614
         --  has been analyzed (and has the expected profile), or it has not
615
         --  been analyzed yet (case of a type that has not been frozen yet
616
         --  and for which the stream attribute has been set using Set_TSS).
617
 
618
         if Present (Pnam)
619
           and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam))
620
         then
621
            Error_Msg_Sloc := Sloc (Pnam);
622
            Error_Msg_Name_1 := Attr;
623
            Error_Msg_N ("% attribute already defined #", Nam);
624
            return;
625
         end if;
626
 
627
         Analyze (Expr);
628
 
629
         if Is_Entity_Name (Expr) then
630
            if not Is_Overloaded (Expr) then
631
               if Has_Good_Profile (Entity (Expr)) then
632
                  Subp := Entity (Expr);
633
               end if;
634
 
635
            else
636
               Get_First_Interp (Expr, I, It);
637
               while Present (It.Nam) loop
638
                  if Has_Good_Profile (It.Nam) then
639
                     Subp := It.Nam;
640
                     exit;
641
                  end if;
642
 
643
                  Get_Next_Interp (I, It);
644
               end loop;
645
            end if;
646
         end if;
647
 
648
         if Present (Subp) then
649
            if Is_Abstract_Subprogram (Subp) then
650
               Error_Msg_N ("stream subprogram must not be abstract", Expr);
651
               return;
652
            end if;
653
 
654
            Set_Entity (Expr, Subp);
655
            Set_Etype (Expr, Etype (Subp));
656
 
657
            New_Stream_Subprogram (N, U_Ent, Subp, TSS_Nam);
658
 
659
         else
660
            Error_Msg_Name_1 := Attr;
661
            Error_Msg_N ("incorrect expression for% attribute", Expr);
662
         end if;
663
      end Analyze_Stream_TSS_Definition;
664
 
665
   --  Start of processing for Analyze_Attribute_Definition_Clause
666
 
667
   begin
668
      --  Process Ignore_Rep_Clauses option
669
 
670
      if Ignore_Rep_Clauses then
671
         case Id is
672
 
673
            --  The following should be ignored. They do not affect legality
674
            --  and may be target dependent. The basic idea of -gnatI is to
675
            --  ignore any rep clauses that may be target dependent but do not
676
            --  affect legality (except possibly to be rejected because they
677
            --  are incompatible with the compilation target).
678
 
679
            when Attribute_Alignment      |
680
                 Attribute_Bit_Order      |
681
                 Attribute_Component_Size |
682
                 Attribute_Machine_Radix  |
683
                 Attribute_Object_Size    |
684
                 Attribute_Size           |
685
                 Attribute_Small          |
686
                 Attribute_Stream_Size    |
687
                 Attribute_Value_Size     =>
688
 
689
               Rewrite (N, Make_Null_Statement (Sloc (N)));
690
               return;
691
 
692
            --  The following should not be ignored, because in the first place
693
            --  they are reasonably portable, and should not cause problems in
694
            --  compiling code from another target, and also they do affect
695
            --  legality, e.g. failing to provide a stream attribute for a
696
            --  type may make a program illegal.
697
 
698
            when Attribute_External_Tag   |
699
                 Attribute_Input          |
700
                 Attribute_Output         |
701
                 Attribute_Read           |
702
                 Attribute_Storage_Pool   |
703
                 Attribute_Storage_Size   |
704
                 Attribute_Write          =>
705
               null;
706
 
707
            --  Other cases are errors, which will be caught below
708
 
709
            when others =>
710
               null;
711
         end case;
712
      end if;
713
 
714
      Analyze (Nam);
715
      Ent := Entity (Nam);
716
 
717
      if Rep_Item_Too_Early (Ent, N) then
718
         return;
719
      end if;
720
 
721
      --  Rep clause applies to full view of incomplete type or private type if
722
      --  we have one (if not, this is a premature use of the type). However,
723
      --  certain semantic checks need to be done on the specified entity (i.e.
724
      --  the private view), so we save it in Ent.
725
 
726
      if Is_Private_Type (Ent)
727
        and then Is_Derived_Type (Ent)
728
        and then not Is_Tagged_Type (Ent)
729
        and then No (Full_View (Ent))
730
      then
731
         --  If this is a private type whose completion is a derivation from
732
         --  another private type, there is no full view, and the attribute
733
         --  belongs to the type itself, not its underlying parent.
734
 
735
         U_Ent := Ent;
736
 
737
      elsif Ekind (Ent) = E_Incomplete_Type then
738
 
739
         --  The attribute applies to the full view, set the entity of the
740
         --  attribute definition accordingly.
741
 
742
         Ent := Underlying_Type (Ent);
743
         U_Ent := Ent;
744
         Set_Entity (Nam, Ent);
745
 
746
      else
747
         U_Ent := Underlying_Type (Ent);
748
      end if;
749
 
750
      --  Complete other routine error checks
751
 
752
      if Etype (Nam) = Any_Type then
753
         return;
754
 
755
      elsif Scope (Ent) /= Current_Scope then
756
         Error_Msg_N ("entity must be declared in this scope", Nam);
757
         return;
758
 
759
      elsif No (U_Ent) then
760
         U_Ent := Ent;
761
 
762
      elsif Is_Type (U_Ent)
763
        and then not Is_First_Subtype (U_Ent)
764
        and then Id /= Attribute_Object_Size
765
        and then Id /= Attribute_Value_Size
766
        and then not From_At_Mod (N)
767
      then
768
         Error_Msg_N ("cannot specify attribute for subtype", Nam);
769
         return;
770
      end if;
771
 
772
      --  Switch on particular attribute
773
 
774
      case Id is
775
 
776
         -------------
777
         -- Address --
778
         -------------
779
 
780
         --  Address attribute definition clause
781
 
782
         when Attribute_Address => Address : begin
783
 
784
            --  A little error check, catch for X'Address use X'Address;
785
 
786
            if Nkind (Nam) = N_Identifier
787
              and then Nkind (Expr) = N_Attribute_Reference
788
              and then Attribute_Name (Expr) = Name_Address
789
              and then Nkind (Prefix (Expr)) = N_Identifier
790
              and then Chars (Nam) = Chars (Prefix (Expr))
791
            then
792
               Error_Msg_NE
793
                 ("address for & is self-referencing", Prefix (Expr), Ent);
794
               return;
795
            end if;
796
 
797
            --  Not that special case, carry on with analysis of expression
798
 
799
            Analyze_And_Resolve (Expr, RTE (RE_Address));
800
 
801
            --  Even when ignoring rep clauses we need to indicate that the
802
            --  entity has an address clause and thus it is legal to declare
803
            --  it imported.
804
 
805
            if Ignore_Rep_Clauses then
806
               if Ekind (U_Ent) = E_Variable
807
                 or else Ekind (U_Ent) = E_Constant
808
               then
809
                  Record_Rep_Item (U_Ent, N);
810
               end if;
811
 
812
               return;
813
            end if;
814
 
815
            if Present (Address_Clause (U_Ent)) then
816
               Error_Msg_N ("address already given for &", Nam);
817
 
818
            --  Case of address clause for subprogram
819
 
820
            elsif Is_Subprogram (U_Ent) then
821
               if Has_Homonym (U_Ent) then
822
                  Error_Msg_N
823
                    ("address clause cannot be given " &
824
                     "for overloaded subprogram",
825
                     Nam);
826
                  return;
827
               end if;
828
 
829
               --  For subprograms, all address clauses are permitted, and we
830
               --  mark the subprogram as having a deferred freeze so that Gigi
831
               --  will not elaborate it too soon.
832
 
833
               --  Above needs more comments, what is too soon about???
834
 
835
               Set_Has_Delayed_Freeze (U_Ent);
836
 
837
            --  Case of address clause for entry
838
 
839
            elsif Ekind (U_Ent) = E_Entry then
840
               if Nkind (Parent (N)) = N_Task_Body then
841
                  Error_Msg_N
842
                    ("entry address must be specified in task spec", Nam);
843
                  return;
844
               end if;
845
 
846
               --  For entries, we require a constant address
847
 
848
               Check_Constant_Address_Clause (Expr, U_Ent);
849
 
850
               --  Special checks for task types
851
 
852
               if Is_Task_Type (Scope (U_Ent))
853
                 and then Comes_From_Source (Scope (U_Ent))
854
               then
855
                  Error_Msg_N
856
                    ("?entry address declared for entry in task type", N);
857
                  Error_Msg_N
858
                    ("\?only one task can be declared of this type", N);
859
               end if;
860
 
861
               --  Entry address clauses are obsolescent
862
 
863
               Check_Restriction (No_Obsolescent_Features, N);
864
 
865
               if Warn_On_Obsolescent_Feature then
866
                  Error_Msg_N
867
                    ("attaching interrupt to task entry is an " &
868
                     "obsolescent feature (RM J.7.1)?", N);
869
                  Error_Msg_N
870
                    ("\use interrupt procedure instead?", N);
871
               end if;
872
 
873
            --  Case of an address clause for a controlled object which we
874
            --  consider to be erroneous.
875
 
876
            elsif Is_Controlled (Etype (U_Ent))
877
              or else Has_Controlled_Component (Etype (U_Ent))
878
            then
879
               Error_Msg_NE
880
                 ("?controlled object& must not be overlaid", Nam, U_Ent);
881
               Error_Msg_N
882
                 ("\?Program_Error will be raised at run time", Nam);
883
               Insert_Action (Declaration_Node (U_Ent),
884
                 Make_Raise_Program_Error (Loc,
885
                   Reason => PE_Overlaid_Controlled_Object));
886
               return;
887
 
888
            --  Case of address clause for a (non-controlled) object
889
 
890
            elsif
891
              Ekind (U_Ent) = E_Variable
892
                or else
893
              Ekind (U_Ent) = E_Constant
894
            then
895
               declare
896
                  Expr  : constant Node_Id := Expression (N);
897
                  O_Ent : Entity_Id;
898
                  Off   : Boolean;
899
 
900
               begin
901
                  --  Exported variables cannot have an address clause, because
902
                  --  this cancels the effect of the pragma Export.
903
 
904
                  if Is_Exported (U_Ent) then
905
                     Error_Msg_N
906
                       ("cannot export object with address clause", Nam);
907
                     return;
908
                  end if;
909
 
910
                  Find_Overlaid_Entity (N, O_Ent, Off);
911
 
912
                  --  Overlaying controlled objects is erroneous
913
 
914
                  if Present (O_Ent)
915
                    and then (Has_Controlled_Component (Etype (O_Ent))
916
                                or else Is_Controlled (Etype (O_Ent)))
917
                  then
918
                     Error_Msg_N
919
                       ("?cannot overlay with controlled object", Expr);
920
                     Error_Msg_N
921
                       ("\?Program_Error will be raised at run time", Expr);
922
                     Insert_Action (Declaration_Node (U_Ent),
923
                       Make_Raise_Program_Error (Loc,
924
                         Reason => PE_Overlaid_Controlled_Object));
925
                     return;
926
 
927
                  elsif Present (O_Ent)
928
                    and then Ekind (U_Ent) = E_Constant
929
                    and then not Is_Constant_Object (O_Ent)
930
                  then
931
                     Error_Msg_N ("constant overlays a variable?", Expr);
932
 
933
                  elsif Present (Renamed_Object (U_Ent)) then
934
                     Error_Msg_N
935
                       ("address clause not allowed"
936
                          & " for a renaming declaration (RM 13.1(6))", Nam);
937
                     return;
938
 
939
                  --  Imported variables can have an address clause, but then
940
                  --  the import is pretty meaningless except to suppress
941
                  --  initializations, so we do not need such variables to
942
                  --  be statically allocated (and in fact it causes trouble
943
                  --  if the address clause is a local value).
944
 
945
                  elsif Is_Imported (U_Ent) then
946
                     Set_Is_Statically_Allocated (U_Ent, False);
947
                  end if;
948
 
949
                  --  We mark a possible modification of a variable with an
950
                  --  address clause, since it is likely aliasing is occurring.
951
 
952
                  Note_Possible_Modification (Nam, Sure => False);
953
 
954
                  --  Here we are checking for explicit overlap of one variable
955
                  --  by another, and if we find this then mark the overlapped
956
                  --  variable as also being volatile to prevent unwanted
957
                  --  optimizations. This is a significant pessimization so
958
                  --  avoid it when there is an offset, i.e. when the object
959
                  --  is composite; they cannot be optimized easily anyway.
960
 
961
                  if Present (O_Ent)
962
                    and then Is_Object (O_Ent)
963
                    and then not Off
964
                  then
965
                     Set_Treat_As_Volatile (O_Ent);
966
                  end if;
967
 
968
                  --  Legality checks on the address clause for initialized
969
                  --  objects is deferred until the freeze point, because
970
                  --  a subsequent pragma might indicate that the object is
971
                  --  imported and thus not initialized.
972
 
973
                  Set_Has_Delayed_Freeze (U_Ent);
974
 
975
                  --  If an initialization call has been generated for this
976
                  --  object, it needs to be deferred to after the freeze node
977
                  --  we have just now added, otherwise GIGI will see a
978
                  --  reference to the variable (as actual to the IP call)
979
                  --  before its definition.
980
 
981
                  declare
982
                     Init_Call : constant Node_Id := Find_Init_Call (U_Ent, N);
983
                  begin
984
                     if Present (Init_Call) then
985
                        Remove (Init_Call);
986
                        Append_Freeze_Action (U_Ent, Init_Call);
987
                     end if;
988
                  end;
989
 
990
                  if Is_Exported (U_Ent) then
991
                     Error_Msg_N
992
                       ("& cannot be exported if an address clause is given",
993
                        Nam);
994
                     Error_Msg_N
995
                       ("\define and export a variable " &
996
                        "that holds its address instead",
997
                        Nam);
998
                  end if;
999
 
1000
                  --  Entity has delayed freeze, so we will generate an
1001
                  --  alignment check at the freeze point unless suppressed.
1002
 
1003
                  if not Range_Checks_Suppressed (U_Ent)
1004
                    and then not Alignment_Checks_Suppressed (U_Ent)
1005
                  then
1006
                     Set_Check_Address_Alignment (N);
1007
                  end if;
1008
 
1009
                  --  Kill the size check code, since we are not allocating
1010
                  --  the variable, it is somewhere else.
1011
 
1012
                  Kill_Size_Check_Code (U_Ent);
1013
 
1014
                  --  If the address clause is of the form:
1015
 
1016
                  --    for Y'Address use X'Address
1017
 
1018
                  --  or
1019
 
1020
                  --    Const : constant Address := X'Address;
1021
                  --    ...
1022
                  --    for Y'Address use Const;
1023
 
1024
                  --  then we make an entry in the table for checking the size
1025
                  --  and alignment of the overlaying variable. We defer this
1026
                  --  check till after code generation to take full advantage
1027
                  --  of the annotation done by the back end. This entry is
1028
                  --  only made if the address clause comes from source.
1029
 
1030
                  if Address_Clause_Overlay_Warnings
1031
                    and then Comes_From_Source (N)
1032
                    and then Present (O_Ent)
1033
                    and then Is_Object (O_Ent)
1034
                  then
1035
                     Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off));
1036
 
1037
                     --  If variable overlays a constant view, and we are
1038
                     --  warning on overlays, then mark the variable as
1039
                     --  overlaying a constant (we will give warnings later
1040
                     --  if this variable is assigned).
1041
 
1042
                     if Is_Constant_Object (O_Ent)
1043
                       and then Ekind (U_Ent) = E_Variable
1044
                     then
1045
                        Set_Overlays_Constant (U_Ent);
1046
                     end if;
1047
                  end if;
1048
               end;
1049
 
1050
            --  Not a valid entity for an address clause
1051
 
1052
            else
1053
               Error_Msg_N ("address cannot be given for &", Nam);
1054
            end if;
1055
         end Address;
1056
 
1057
         ---------------
1058
         -- Alignment --
1059
         ---------------
1060
 
1061
         --  Alignment attribute definition clause
1062
 
1063
         when Attribute_Alignment => Alignment : declare
1064
            Align : constant Uint := Get_Alignment_Value (Expr);
1065
 
1066
         begin
1067
            FOnly := True;
1068
 
1069
            if not Is_Type (U_Ent)
1070
              and then Ekind (U_Ent) /= E_Variable
1071
              and then Ekind (U_Ent) /= E_Constant
1072
            then
1073
               Error_Msg_N ("alignment cannot be given for &", Nam);
1074
 
1075
            elsif Has_Alignment_Clause (U_Ent) then
1076
               Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent));
1077
               Error_Msg_N ("alignment clause previously given#", N);
1078
 
1079
            elsif Align /= No_Uint then
1080
               Set_Has_Alignment_Clause (U_Ent);
1081
               Set_Alignment            (U_Ent, Align);
1082
 
1083
               --  For an array type, U_Ent is the first subtype. In that case,
1084
               --  also set the alignment of the anonymous base type so that
1085
               --  other subtypes (such as the itypes for aggregates of the
1086
               --  type) also receive the expected alignment.
1087
 
1088
               if Is_Array_Type (U_Ent) then
1089
                  Set_Alignment (Base_Type (U_Ent), Align);
1090
               end if;
1091
            end if;
1092
         end Alignment;
1093
 
1094
         ---------------
1095
         -- Bit_Order --
1096
         ---------------
1097
 
1098
         --  Bit_Order attribute definition clause
1099
 
1100
         when Attribute_Bit_Order => Bit_Order : declare
1101
         begin
1102
            if not Is_Record_Type (U_Ent) then
1103
               Error_Msg_N
1104
                 ("Bit_Order can only be defined for record type", Nam);
1105
 
1106
            else
1107
               Analyze_And_Resolve (Expr, RTE (RE_Bit_Order));
1108
 
1109
               if Etype (Expr) = Any_Type then
1110
                  return;
1111
 
1112
               elsif not Is_Static_Expression (Expr) then
1113
                  Flag_Non_Static_Expr
1114
                    ("Bit_Order requires static expression!", Expr);
1115
 
1116
               else
1117
                  if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
1118
                     Set_Reverse_Bit_Order (U_Ent, True);
1119
                  end if;
1120
               end if;
1121
            end if;
1122
         end Bit_Order;
1123
 
1124
         --------------------
1125
         -- Component_Size --
1126
         --------------------
1127
 
1128
         --  Component_Size attribute definition clause
1129
 
1130
         when Attribute_Component_Size => Component_Size_Case : declare
1131
            Csize    : constant Uint := Static_Integer (Expr);
1132
            Btype    : Entity_Id;
1133
            Biased   : Boolean;
1134
            New_Ctyp : Entity_Id;
1135
            Decl     : Node_Id;
1136
 
1137
         begin
1138
            if not Is_Array_Type (U_Ent) then
1139
               Error_Msg_N ("component size requires array type", Nam);
1140
               return;
1141
            end if;
1142
 
1143
            Btype := Base_Type (U_Ent);
1144
 
1145
            if Has_Component_Size_Clause (Btype) then
1146
               Error_Msg_N
1147
                 ("component size clause for& previously given", Nam);
1148
 
1149
            elsif Csize /= No_Uint then
1150
               Check_Size (Expr, Component_Type (Btype), Csize, Biased);
1151
 
1152
               if Has_Aliased_Components (Btype)
1153
                 and then Csize < 32
1154
                 and then Csize /= 8
1155
                 and then Csize /= 16
1156
               then
1157
                  Error_Msg_N
1158
                    ("component size incorrect for aliased components", N);
1159
                  return;
1160
               end if;
1161
 
1162
               --  For the biased case, build a declaration for a subtype
1163
               --  that will be used to represent the biased subtype that
1164
               --  reflects the biased representation of components. We need
1165
               --  this subtype to get proper conversions on referencing
1166
               --  elements of the array. Note that component size clauses
1167
               --  are ignored in VM mode.
1168
 
1169
               if VM_Target = No_VM then
1170
                  if Biased then
1171
                     New_Ctyp :=
1172
                       Make_Defining_Identifier (Loc,
1173
                         Chars =>
1174
                           New_External_Name (Chars (U_Ent), 'C', 0, 'T'));
1175
 
1176
                     Decl :=
1177
                       Make_Subtype_Declaration (Loc,
1178
                         Defining_Identifier => New_Ctyp,
1179
                         Subtype_Indication  =>
1180
                           New_Occurrence_Of (Component_Type (Btype), Loc));
1181
 
1182
                     Set_Parent (Decl, N);
1183
                     Analyze (Decl, Suppress => All_Checks);
1184
 
1185
                     Set_Has_Delayed_Freeze        (New_Ctyp, False);
1186
                     Set_Esize                     (New_Ctyp, Csize);
1187
                     Set_RM_Size                   (New_Ctyp, Csize);
1188
                     Init_Alignment                (New_Ctyp);
1189
                     Set_Has_Biased_Representation (New_Ctyp, True);
1190
                     Set_Is_Itype                  (New_Ctyp, True);
1191
                     Set_Associated_Node_For_Itype (New_Ctyp, U_Ent);
1192
 
1193
                     Set_Component_Type (Btype, New_Ctyp);
1194
 
1195
                     if Warn_On_Biased_Representation then
1196
                        Error_Msg_N
1197
                          ("?component size clause forces biased "
1198
                           & "representation", N);
1199
                     end if;
1200
                  end if;
1201
 
1202
                  Set_Component_Size (Btype, Csize);
1203
 
1204
               --  For VM case, we ignore component size clauses
1205
 
1206
               else
1207
                  --  Give a warning unless we are in GNAT mode, in which case
1208
                  --  the warning is suppressed since it is not useful.
1209
 
1210
                  if not GNAT_Mode then
1211
                     Error_Msg_N
1212
                       ("?component size ignored in this configuration", N);
1213
                  end if;
1214
               end if;
1215
 
1216
               Set_Has_Component_Size_Clause (Btype, True);
1217
               Set_Has_Non_Standard_Rep      (Btype, True);
1218
            end if;
1219
         end Component_Size_Case;
1220
 
1221
         ------------------
1222
         -- External_Tag --
1223
         ------------------
1224
 
1225
         when Attribute_External_Tag => External_Tag :
1226
         begin
1227
            if not Is_Tagged_Type (U_Ent) then
1228
               Error_Msg_N ("should be a tagged type", Nam);
1229
            end if;
1230
 
1231
            Analyze_And_Resolve (Expr, Standard_String);
1232
 
1233
            if not Is_Static_Expression (Expr) then
1234
               Flag_Non_Static_Expr
1235
                 ("static string required for tag name!", Nam);
1236
            end if;
1237
 
1238
            if VM_Target = No_VM then
1239
               Set_Has_External_Tag_Rep_Clause (U_Ent);
1240
            else
1241
               Error_Msg_Name_1 := Attr;
1242
               Error_Msg_N
1243
                 ("% attribute unsupported in this configuration", Nam);
1244
            end if;
1245
 
1246
            if not Is_Library_Level_Entity (U_Ent) then
1247
               Error_Msg_NE
1248
                 ("?non-unique external tag supplied for &", N, U_Ent);
1249
               Error_Msg_N
1250
                 ("?\same external tag applies to all subprogram calls", N);
1251
               Error_Msg_N
1252
                 ("?\corresponding internal tag cannot be obtained", N);
1253
            end if;
1254
         end External_Tag;
1255
 
1256
         -----------
1257
         -- Input --
1258
         -----------
1259
 
1260
         when Attribute_Input =>
1261
            Analyze_Stream_TSS_Definition (TSS_Stream_Input);
1262
            Set_Has_Specified_Stream_Input (Ent);
1263
 
1264
         -------------------
1265
         -- Machine_Radix --
1266
         -------------------
1267
 
1268
         --  Machine radix attribute definition clause
1269
 
1270
         when Attribute_Machine_Radix => Machine_Radix : declare
1271
            Radix : constant Uint := Static_Integer (Expr);
1272
 
1273
         begin
1274
            if not Is_Decimal_Fixed_Point_Type (U_Ent) then
1275
               Error_Msg_N ("decimal fixed-point type expected for &", Nam);
1276
 
1277
            elsif Has_Machine_Radix_Clause (U_Ent) then
1278
               Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent));
1279
               Error_Msg_N ("machine radix clause previously given#", N);
1280
 
1281
            elsif Radix /= No_Uint then
1282
               Set_Has_Machine_Radix_Clause (U_Ent);
1283
               Set_Has_Non_Standard_Rep (Base_Type (U_Ent));
1284
 
1285
               if Radix = 2 then
1286
                  null;
1287
               elsif Radix = 10 then
1288
                  Set_Machine_Radix_10 (U_Ent);
1289
               else
1290
                  Error_Msg_N ("machine radix value must be 2 or 10", Expr);
1291
               end if;
1292
            end if;
1293
         end Machine_Radix;
1294
 
1295
         -----------------
1296
         -- Object_Size --
1297
         -----------------
1298
 
1299
         --  Object_Size attribute definition clause
1300
 
1301
         when Attribute_Object_Size => Object_Size : declare
1302
            Size : constant Uint := Static_Integer (Expr);
1303
 
1304
            Biased : Boolean;
1305
            pragma Warnings (Off, Biased);
1306
 
1307
         begin
1308
            if not Is_Type (U_Ent) then
1309
               Error_Msg_N ("Object_Size cannot be given for &", Nam);
1310
 
1311
            elsif Has_Object_Size_Clause (U_Ent) then
1312
               Error_Msg_N ("Object_Size already given for &", Nam);
1313
 
1314
            else
1315
               Check_Size (Expr, U_Ent, Size, Biased);
1316
 
1317
               if Size /= 8
1318
                    and then
1319
                  Size /= 16
1320
                    and then
1321
                  Size /= 32
1322
                    and then
1323
                  UI_Mod (Size, 64) /= 0
1324
               then
1325
                  Error_Msg_N
1326
                    ("Object_Size must be 8, 16, 32, or multiple of 64",
1327
                     Expr);
1328
               end if;
1329
 
1330
               Set_Esize (U_Ent, Size);
1331
               Set_Has_Object_Size_Clause (U_Ent);
1332
               Alignment_Check_For_Esize_Change (U_Ent);
1333
            end if;
1334
         end Object_Size;
1335
 
1336
         ------------
1337
         -- Output --
1338
         ------------
1339
 
1340
         when Attribute_Output =>
1341
            Analyze_Stream_TSS_Definition (TSS_Stream_Output);
1342
            Set_Has_Specified_Stream_Output (Ent);
1343
 
1344
         ----------
1345
         -- Read --
1346
         ----------
1347
 
1348
         when Attribute_Read =>
1349
            Analyze_Stream_TSS_Definition (TSS_Stream_Read);
1350
            Set_Has_Specified_Stream_Read (Ent);
1351
 
1352
         ----------
1353
         -- Size --
1354
         ----------
1355
 
1356
         --  Size attribute definition clause
1357
 
1358
         when Attribute_Size => Size : declare
1359
            Size   : constant Uint := Static_Integer (Expr);
1360
            Etyp   : Entity_Id;
1361
            Biased : Boolean;
1362
 
1363
         begin
1364
            FOnly := True;
1365
 
1366
            if Has_Size_Clause (U_Ent) then
1367
               Error_Msg_N ("size already given for &", Nam);
1368
 
1369
            elsif not Is_Type (U_Ent)
1370
              and then Ekind (U_Ent) /= E_Variable
1371
              and then Ekind (U_Ent) /= E_Constant
1372
            then
1373
               Error_Msg_N ("size cannot be given for &", Nam);
1374
 
1375
            elsif Is_Array_Type (U_Ent)
1376
              and then not Is_Constrained (U_Ent)
1377
            then
1378
               Error_Msg_N
1379
                 ("size cannot be given for unconstrained array", Nam);
1380
 
1381
            elsif Size /= No_Uint then
1382
               if Is_Type (U_Ent) then
1383
                  Etyp := U_Ent;
1384
               else
1385
                  Etyp := Etype (U_Ent);
1386
               end if;
1387
 
1388
               --  Check size, note that Gigi is in charge of checking that the
1389
               --  size of an array or record type is OK. Also we do not check
1390
               --  the size in the ordinary fixed-point case, since it is too
1391
               --  early to do so (there may be subsequent small clause that
1392
               --  affects the size). We can check the size if a small clause
1393
               --  has already been given.
1394
 
1395
               if not Is_Ordinary_Fixed_Point_Type (U_Ent)
1396
                 or else Has_Small_Clause (U_Ent)
1397
               then
1398
                  Check_Size (Expr, Etyp, Size, Biased);
1399
                     Set_Has_Biased_Representation (U_Ent, Biased);
1400
 
1401
                  if Biased and Warn_On_Biased_Representation then
1402
                     Error_Msg_N
1403
                       ("?size clause forces biased representation", N);
1404
                  end if;
1405
               end if;
1406
 
1407
               --  For types set RM_Size and Esize if possible
1408
 
1409
               if Is_Type (U_Ent) then
1410
                  Set_RM_Size (U_Ent, Size);
1411
 
1412
                  --  For scalar types, increase Object_Size to power of 2, but
1413
                  --  not less than a storage unit in any case (i.e., normally
1414
                  --  this means it will be byte addressable).
1415
 
1416
                  if Is_Scalar_Type (U_Ent) then
1417
                     if Size <= System_Storage_Unit then
1418
                        Init_Esize (U_Ent, System_Storage_Unit);
1419
                     elsif Size <= 16 then
1420
                        Init_Esize (U_Ent, 16);
1421
                     elsif Size <= 32 then
1422
                        Init_Esize (U_Ent, 32);
1423
                     else
1424
                        Set_Esize  (U_Ent, (Size + 63) / 64 * 64);
1425
                     end if;
1426
 
1427
                  --  For all other types, object size = value size. The
1428
                  --  backend will adjust as needed.
1429
 
1430
                  else
1431
                     Set_Esize (U_Ent, Size);
1432
                  end if;
1433
 
1434
                  Alignment_Check_For_Esize_Change (U_Ent);
1435
 
1436
               --  For objects, set Esize only
1437
 
1438
               else
1439
                  if Is_Elementary_Type (Etyp) then
1440
                     if Size /= System_Storage_Unit
1441
                          and then
1442
                        Size /= System_Storage_Unit * 2
1443
                          and then
1444
                        Size /= System_Storage_Unit * 4
1445
                           and then
1446
                        Size /= System_Storage_Unit * 8
1447
                     then
1448
                        Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
1449
                        Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
1450
                        Error_Msg_N
1451
                          ("size for primitive object must be a power of 2"
1452
                            & " in the range ^-^", N);
1453
                     end if;
1454
                  end if;
1455
 
1456
                  Set_Esize (U_Ent, Size);
1457
               end if;
1458
 
1459
               Set_Has_Size_Clause (U_Ent);
1460
            end if;
1461
         end Size;
1462
 
1463
         -----------
1464
         -- Small --
1465
         -----------
1466
 
1467
         --  Small attribute definition clause
1468
 
1469
         when Attribute_Small => Small : declare
1470
            Implicit_Base : constant Entity_Id := Base_Type (U_Ent);
1471
            Small         : Ureal;
1472
 
1473
         begin
1474
            Analyze_And_Resolve (Expr, Any_Real);
1475
 
1476
            if Etype (Expr) = Any_Type then
1477
               return;
1478
 
1479
            elsif not Is_Static_Expression (Expr) then
1480
               Flag_Non_Static_Expr
1481
                 ("small requires static expression!", Expr);
1482
               return;
1483
 
1484
            else
1485
               Small := Expr_Value_R (Expr);
1486
 
1487
               if Small <= Ureal_0 then
1488
                  Error_Msg_N ("small value must be greater than zero", Expr);
1489
                  return;
1490
               end if;
1491
 
1492
            end if;
1493
 
1494
            if not Is_Ordinary_Fixed_Point_Type (U_Ent) then
1495
               Error_Msg_N
1496
                 ("small requires an ordinary fixed point type", Nam);
1497
 
1498
            elsif Has_Small_Clause (U_Ent) then
1499
               Error_Msg_N ("small already given for &", Nam);
1500
 
1501
            elsif Small > Delta_Value (U_Ent) then
1502
               Error_Msg_N
1503
                 ("small value must not be greater then delta value", Nam);
1504
 
1505
            else
1506
               Set_Small_Value (U_Ent, Small);
1507
               Set_Small_Value (Implicit_Base, Small);
1508
               Set_Has_Small_Clause (U_Ent);
1509
               Set_Has_Small_Clause (Implicit_Base);
1510
               Set_Has_Non_Standard_Rep (Implicit_Base);
1511
            end if;
1512
         end Small;
1513
 
1514
         ------------------
1515
         -- Storage_Pool --
1516
         ------------------
1517
 
1518
         --  Storage_Pool attribute definition clause
1519
 
1520
         when Attribute_Storage_Pool => Storage_Pool : declare
1521
            Pool : Entity_Id;
1522
            T    : Entity_Id;
1523
 
1524
         begin
1525
            if Ekind (U_Ent) = E_Access_Subprogram_Type then
1526
               Error_Msg_N
1527
                 ("storage pool cannot be given for access-to-subprogram type",
1528
                  Nam);
1529
               return;
1530
 
1531
            elsif Ekind (U_Ent) /= E_Access_Type
1532
              and then Ekind (U_Ent) /= E_General_Access_Type
1533
            then
1534
               Error_Msg_N
1535
                 ("storage pool can only be given for access types", Nam);
1536
               return;
1537
 
1538
            elsif Is_Derived_Type (U_Ent) then
1539
               Error_Msg_N
1540
                 ("storage pool cannot be given for a derived access type",
1541
                  Nam);
1542
 
1543
            elsif Has_Storage_Size_Clause (U_Ent) then
1544
               Error_Msg_N ("storage size already given for &", Nam);
1545
               return;
1546
 
1547
            elsif Present (Associated_Storage_Pool (U_Ent)) then
1548
               Error_Msg_N ("storage pool already given for &", Nam);
1549
               return;
1550
            end if;
1551
 
1552
            Analyze_And_Resolve
1553
              (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
1554
 
1555
            if not Denotes_Variable (Expr) then
1556
               Error_Msg_N ("storage pool must be a variable", Expr);
1557
               return;
1558
            end if;
1559
 
1560
            if Nkind (Expr) = N_Type_Conversion then
1561
               T := Etype (Expression (Expr));
1562
            else
1563
               T := Etype (Expr);
1564
            end if;
1565
 
1566
            --  The Stack_Bounded_Pool is used internally for implementing
1567
            --  access types with a Storage_Size. Since it only work
1568
            --  properly when used on one specific type, we need to check
1569
            --  that it is not hijacked improperly:
1570
            --    type T is access Integer;
1571
            --    for T'Storage_Size use n;
1572
            --    type Q is access Float;
1573
            --    for Q'Storage_Size use T'Storage_Size; -- incorrect
1574
 
1575
            if RTE_Available (RE_Stack_Bounded_Pool)
1576
              and then Base_Type (T) = RTE (RE_Stack_Bounded_Pool)
1577
            then
1578
               Error_Msg_N ("non-shareable internal Pool", Expr);
1579
               return;
1580
            end if;
1581
 
1582
            --  If the argument is a name that is not an entity name, then
1583
            --  we construct a renaming operation to define an entity of
1584
            --  type storage pool.
1585
 
1586
            if not Is_Entity_Name (Expr)
1587
              and then Is_Object_Reference (Expr)
1588
            then
1589
               Pool :=
1590
                 Make_Defining_Identifier (Loc,
1591
                   Chars => New_Internal_Name ('P'));
1592
 
1593
               declare
1594
                  Rnode : constant Node_Id :=
1595
                            Make_Object_Renaming_Declaration (Loc,
1596
                              Defining_Identifier => Pool,
1597
                              Subtype_Mark        =>
1598
                                New_Occurrence_Of (Etype (Expr), Loc),
1599
                              Name => Expr);
1600
 
1601
               begin
1602
                  Insert_Before (N, Rnode);
1603
                  Analyze (Rnode);
1604
                  Set_Associated_Storage_Pool (U_Ent, Pool);
1605
               end;
1606
 
1607
            elsif Is_Entity_Name (Expr) then
1608
               Pool := Entity (Expr);
1609
 
1610
               --  If pool is a renamed object, get original one. This can
1611
               --  happen with an explicit renaming, and within instances.
1612
 
1613
               while Present (Renamed_Object (Pool))
1614
                 and then Is_Entity_Name (Renamed_Object (Pool))
1615
               loop
1616
                  Pool := Entity (Renamed_Object (Pool));
1617
               end loop;
1618
 
1619
               if Present (Renamed_Object (Pool))
1620
                 and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion
1621
                 and then Is_Entity_Name (Expression (Renamed_Object (Pool)))
1622
               then
1623
                  Pool := Entity (Expression (Renamed_Object (Pool)));
1624
               end if;
1625
 
1626
               Set_Associated_Storage_Pool (U_Ent, Pool);
1627
 
1628
            elsif Nkind (Expr) = N_Type_Conversion
1629
              and then Is_Entity_Name (Expression (Expr))
1630
              and then Nkind (Original_Node (Expr)) = N_Attribute_Reference
1631
            then
1632
               Pool := Entity (Expression (Expr));
1633
               Set_Associated_Storage_Pool (U_Ent, Pool);
1634
 
1635
            else
1636
               Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
1637
               return;
1638
            end if;
1639
         end Storage_Pool;
1640
 
1641
         ------------------
1642
         -- Storage_Size --
1643
         ------------------
1644
 
1645
         --  Storage_Size attribute definition clause
1646
 
1647
         when Attribute_Storage_Size => Storage_Size : declare
1648
            Btype : constant Entity_Id := Base_Type (U_Ent);
1649
            Sprag : Node_Id;
1650
 
1651
         begin
1652
            if Is_Task_Type (U_Ent) then
1653
               Check_Restriction (No_Obsolescent_Features, N);
1654
 
1655
               if Warn_On_Obsolescent_Feature then
1656
                  Error_Msg_N
1657
                    ("storage size clause for task is an " &
1658
                     "obsolescent feature (RM J.9)?", N);
1659
                  Error_Msg_N
1660
                    ("\use Storage_Size pragma instead?", N);
1661
               end if;
1662
 
1663
               FOnly := True;
1664
            end if;
1665
 
1666
            if not Is_Access_Type (U_Ent)
1667
              and then Ekind (U_Ent) /= E_Task_Type
1668
            then
1669
               Error_Msg_N ("storage size cannot be given for &", Nam);
1670
 
1671
            elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then
1672
               Error_Msg_N
1673
                 ("storage size cannot be given for a derived access type",
1674
                  Nam);
1675
 
1676
            elsif Has_Storage_Size_Clause (Btype) then
1677
               Error_Msg_N ("storage size already given for &", Nam);
1678
 
1679
            else
1680
               Analyze_And_Resolve (Expr, Any_Integer);
1681
 
1682
               if Is_Access_Type (U_Ent) then
1683
                  if Present (Associated_Storage_Pool (U_Ent)) then
1684
                     Error_Msg_N ("storage pool already given for &", Nam);
1685
                     return;
1686
                  end if;
1687
 
1688
                  if Compile_Time_Known_Value (Expr)
1689
                    and then Expr_Value (Expr) = 0
1690
                  then
1691
                     Set_No_Pool_Assigned (Btype);
1692
                  end if;
1693
 
1694
               else -- Is_Task_Type (U_Ent)
1695
                  Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size);
1696
 
1697
                  if Present (Sprag) then
1698
                     Error_Msg_Sloc := Sloc (Sprag);
1699
                     Error_Msg_N
1700
                       ("Storage_Size already specified#", Nam);
1701
                     return;
1702
                  end if;
1703
               end if;
1704
 
1705
               Set_Has_Storage_Size_Clause (Btype);
1706
            end if;
1707
         end Storage_Size;
1708
 
1709
         -----------------
1710
         -- Stream_Size --
1711
         -----------------
1712
 
1713
         when Attribute_Stream_Size => Stream_Size : declare
1714
            Size : constant Uint := Static_Integer (Expr);
1715
 
1716
         begin
1717
            if Ada_Version <= Ada_95 then
1718
               Check_Restriction (No_Implementation_Attributes, N);
1719
            end if;
1720
 
1721
            if Has_Stream_Size_Clause (U_Ent) then
1722
               Error_Msg_N ("Stream_Size already given for &", Nam);
1723
 
1724
            elsif Is_Elementary_Type (U_Ent) then
1725
               if Size /= System_Storage_Unit
1726
                    and then
1727
                  Size /= System_Storage_Unit * 2
1728
                    and then
1729
                  Size /= System_Storage_Unit * 4
1730
                     and then
1731
                  Size /= System_Storage_Unit * 8
1732
               then
1733
                  Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
1734
                  Error_Msg_N
1735
                    ("stream size for elementary type must be a"
1736
                       & " power of 2 and at least ^", N);
1737
 
1738
               elsif RM_Size (U_Ent) > Size then
1739
                  Error_Msg_Uint_1 := RM_Size (U_Ent);
1740
                  Error_Msg_N
1741
                    ("stream size for elementary type must be a"
1742
                       & " power of 2 and at least ^", N);
1743
               end if;
1744
 
1745
               Set_Has_Stream_Size_Clause (U_Ent);
1746
 
1747
            else
1748
               Error_Msg_N ("Stream_Size cannot be given for &", Nam);
1749
            end if;
1750
         end Stream_Size;
1751
 
1752
         ----------------
1753
         -- Value_Size --
1754
         ----------------
1755
 
1756
         --  Value_Size attribute definition clause
1757
 
1758
         when Attribute_Value_Size => Value_Size : declare
1759
            Size   : constant Uint := Static_Integer (Expr);
1760
            Biased : Boolean;
1761
 
1762
         begin
1763
            if not Is_Type (U_Ent) then
1764
               Error_Msg_N ("Value_Size cannot be given for &", Nam);
1765
 
1766
            elsif Present
1767
                   (Get_Attribute_Definition_Clause
1768
                     (U_Ent, Attribute_Value_Size))
1769
            then
1770
               Error_Msg_N ("Value_Size already given for &", Nam);
1771
 
1772
            elsif Is_Array_Type (U_Ent)
1773
              and then not Is_Constrained (U_Ent)
1774
            then
1775
               Error_Msg_N
1776
                 ("Value_Size cannot be given for unconstrained array", Nam);
1777
 
1778
            else
1779
               if Is_Elementary_Type (U_Ent) then
1780
                  Check_Size (Expr, U_Ent, Size, Biased);
1781
                  Set_Has_Biased_Representation (U_Ent, Biased);
1782
 
1783
                  if Biased and Warn_On_Biased_Representation then
1784
                     Error_Msg_N
1785
                       ("?value size clause forces biased representation", N);
1786
                  end if;
1787
               end if;
1788
 
1789
               Set_RM_Size (U_Ent, Size);
1790
            end if;
1791
         end Value_Size;
1792
 
1793
         -----------
1794
         -- Write --
1795
         -----------
1796
 
1797
         when Attribute_Write =>
1798
            Analyze_Stream_TSS_Definition (TSS_Stream_Write);
1799
            Set_Has_Specified_Stream_Write (Ent);
1800
 
1801
         --  All other attributes cannot be set
1802
 
1803
         when others =>
1804
            Error_Msg_N
1805
              ("attribute& cannot be set with definition clause", N);
1806
      end case;
1807
 
1808
      --  The test for the type being frozen must be performed after
1809
      --  any expression the clause has been analyzed since the expression
1810
      --  itself might cause freezing that makes the clause illegal.
1811
 
1812
      if Rep_Item_Too_Late (U_Ent, N, FOnly) then
1813
         return;
1814
      end if;
1815
   end Analyze_Attribute_Definition_Clause;
1816
 
1817
   ----------------------------
1818
   -- Analyze_Code_Statement --
1819
   ----------------------------
1820
 
1821
   procedure Analyze_Code_Statement (N : Node_Id) is
1822
      HSS   : constant Node_Id   := Parent (N);
1823
      SBody : constant Node_Id   := Parent (HSS);
1824
      Subp  : constant Entity_Id := Current_Scope;
1825
      Stmt  : Node_Id;
1826
      Decl  : Node_Id;
1827
      StmtO : Node_Id;
1828
      DeclO : Node_Id;
1829
 
1830
   begin
1831
      --  Analyze and check we get right type, note that this implements the
1832
      --  requirement (RM 13.8(1)) that Machine_Code be with'ed, since that
1833
      --  is the only way that Asm_Insn could possibly be visible.
1834
 
1835
      Analyze_And_Resolve (Expression (N));
1836
 
1837
      if Etype (Expression (N)) = Any_Type then
1838
         return;
1839
      elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then
1840
         Error_Msg_N ("incorrect type for code statement", N);
1841
         return;
1842
      end if;
1843
 
1844
      Check_Code_Statement (N);
1845
 
1846
      --  Make sure we appear in the handled statement sequence of a
1847
      --  subprogram (RM 13.8(3)).
1848
 
1849
      if Nkind (HSS) /= N_Handled_Sequence_Of_Statements
1850
        or else Nkind (SBody) /= N_Subprogram_Body
1851
      then
1852
         Error_Msg_N
1853
           ("code statement can only appear in body of subprogram", N);
1854
         return;
1855
      end if;
1856
 
1857
      --  Do remaining checks (RM 13.8(3)) if not already done
1858
 
1859
      if not Is_Machine_Code_Subprogram (Subp) then
1860
         Set_Is_Machine_Code_Subprogram (Subp);
1861
 
1862
         --  No exception handlers allowed
1863
 
1864
         if Present (Exception_Handlers (HSS)) then
1865
            Error_Msg_N
1866
              ("exception handlers not permitted in machine code subprogram",
1867
               First (Exception_Handlers (HSS)));
1868
         end if;
1869
 
1870
         --  No declarations other than use clauses and pragmas (we allow
1871
         --  certain internally generated declarations as well).
1872
 
1873
         Decl := First (Declarations (SBody));
1874
         while Present (Decl) loop
1875
            DeclO := Original_Node (Decl);
1876
            if Comes_From_Source (DeclO)
1877
              and not Nkind_In (DeclO, N_Pragma,
1878
                                       N_Use_Package_Clause,
1879
                                       N_Use_Type_Clause,
1880
                                       N_Implicit_Label_Declaration)
1881
            then
1882
               Error_Msg_N
1883
                 ("this declaration not allowed in machine code subprogram",
1884
                  DeclO);
1885
            end if;
1886
 
1887
            Next (Decl);
1888
         end loop;
1889
 
1890
         --  No statements other than code statements, pragmas, and labels.
1891
         --  Again we allow certain internally generated statements.
1892
 
1893
         Stmt := First (Statements (HSS));
1894
         while Present (Stmt) loop
1895
            StmtO := Original_Node (Stmt);
1896
            if Comes_From_Source (StmtO)
1897
              and then not Nkind_In (StmtO, N_Pragma,
1898
                                            N_Label,
1899
                                            N_Code_Statement)
1900
            then
1901
               Error_Msg_N
1902
                 ("this statement is not allowed in machine code subprogram",
1903
                  StmtO);
1904
            end if;
1905
 
1906
            Next (Stmt);
1907
         end loop;
1908
      end if;
1909
   end Analyze_Code_Statement;
1910
 
1911
   -----------------------------------------------
1912
   -- Analyze_Enumeration_Representation_Clause --
1913
   -----------------------------------------------
1914
 
1915
   procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is
1916
      Ident    : constant Node_Id    := Identifier (N);
1917
      Aggr     : constant Node_Id    := Array_Aggregate (N);
1918
      Enumtype : Entity_Id;
1919
      Elit     : Entity_Id;
1920
      Expr     : Node_Id;
1921
      Assoc    : Node_Id;
1922
      Choice   : Node_Id;
1923
      Val      : Uint;
1924
      Err      : Boolean := False;
1925
 
1926
      Lo  : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer));
1927
      Hi  : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer));
1928
      Min : Uint;
1929
      Max : Uint;
1930
 
1931
   begin
1932
      if Ignore_Rep_Clauses then
1933
         return;
1934
      end if;
1935
 
1936
      --  First some basic error checks
1937
 
1938
      Find_Type (Ident);
1939
      Enumtype := Entity (Ident);
1940
 
1941
      if Enumtype = Any_Type
1942
        or else Rep_Item_Too_Early (Enumtype, N)
1943
      then
1944
         return;
1945
      else
1946
         Enumtype := Underlying_Type (Enumtype);
1947
      end if;
1948
 
1949
      if not Is_Enumeration_Type (Enumtype) then
1950
         Error_Msg_NE
1951
           ("enumeration type required, found}",
1952
            Ident, First_Subtype (Enumtype));
1953
         return;
1954
      end if;
1955
 
1956
      --  Ignore rep clause on generic actual type. This will already have
1957
      --  been flagged on the template as an error, and this is the safest
1958
      --  way to ensure we don't get a junk cascaded message in the instance.
1959
 
1960
      if Is_Generic_Actual_Type (Enumtype) then
1961
         return;
1962
 
1963
      --  Type must be in current scope
1964
 
1965
      elsif Scope (Enumtype) /= Current_Scope then
1966
         Error_Msg_N ("type must be declared in this scope", Ident);
1967
         return;
1968
 
1969
      --  Type must be a first subtype
1970
 
1971
      elsif not Is_First_Subtype (Enumtype) then
1972
         Error_Msg_N ("cannot give enumeration rep clause for subtype", N);
1973
         return;
1974
 
1975
      --  Ignore duplicate rep clause
1976
 
1977
      elsif Has_Enumeration_Rep_Clause (Enumtype) then
1978
         Error_Msg_N ("duplicate enumeration rep clause ignored", N);
1979
         return;
1980
 
1981
      --  Don't allow rep clause for standard [wide_[wide_]]character
1982
 
1983
      elsif Is_Standard_Character_Type (Enumtype) then
1984
         Error_Msg_N ("enumeration rep clause not allowed for this type", N);
1985
         return;
1986
 
1987
      --  Check that the expression is a proper aggregate (no parentheses)
1988
 
1989
      elsif Paren_Count (Aggr) /= 0 then
1990
         Error_Msg
1991
           ("extra parentheses surrounding aggregate not allowed",
1992
            First_Sloc (Aggr));
1993
         return;
1994
 
1995
      --  All tests passed, so set rep clause in place
1996
 
1997
      else
1998
         Set_Has_Enumeration_Rep_Clause (Enumtype);
1999
         Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype));
2000
      end if;
2001
 
2002
      --  Now we process the aggregate. Note that we don't use the normal
2003
      --  aggregate code for this purpose, because we don't want any of the
2004
      --  normal expansion activities, and a number of special semantic
2005
      --  rules apply (including the component type being any integer type)
2006
 
2007
      Elit := First_Literal (Enumtype);
2008
 
2009
      --  First the positional entries if any
2010
 
2011
      if Present (Expressions (Aggr)) then
2012
         Expr := First (Expressions (Aggr));
2013
         while Present (Expr) loop
2014
            if No (Elit) then
2015
               Error_Msg_N ("too many entries in aggregate", Expr);
2016
               return;
2017
            end if;
2018
 
2019
            Val := Static_Integer (Expr);
2020
 
2021
            --  Err signals that we found some incorrect entries processing
2022
            --  the list. The final checks for completeness and ordering are
2023
            --  skipped in this case.
2024
 
2025
            if Val = No_Uint then
2026
               Err := True;
2027
            elsif Val < Lo or else Hi < Val then
2028
               Error_Msg_N ("value outside permitted range", Expr);
2029
               Err := True;
2030
            end if;
2031
 
2032
            Set_Enumeration_Rep (Elit, Val);
2033
            Set_Enumeration_Rep_Expr (Elit, Expr);
2034
            Next (Expr);
2035
            Next (Elit);
2036
         end loop;
2037
      end if;
2038
 
2039
      --  Now process the named entries if present
2040
 
2041
      if Present (Component_Associations (Aggr)) then
2042
         Assoc := First (Component_Associations (Aggr));
2043
         while Present (Assoc) loop
2044
            Choice := First (Choices (Assoc));
2045
 
2046
            if Present (Next (Choice)) then
2047
               Error_Msg_N
2048
                 ("multiple choice not allowed here", Next (Choice));
2049
               Err := True;
2050
            end if;
2051
 
2052
            if Nkind (Choice) = N_Others_Choice then
2053
               Error_Msg_N ("others choice not allowed here", Choice);
2054
               Err := True;
2055
 
2056
            elsif Nkind (Choice) = N_Range then
2057
               --  ??? should allow zero/one element range here
2058
               Error_Msg_N ("range not allowed here", Choice);
2059
               Err := True;
2060
 
2061
            else
2062
               Analyze_And_Resolve (Choice, Enumtype);
2063
 
2064
               if Is_Entity_Name (Choice)
2065
                 and then Is_Type (Entity (Choice))
2066
               then
2067
                  Error_Msg_N ("subtype name not allowed here", Choice);
2068
                  Err := True;
2069
                  --  ??? should allow static subtype with zero/one entry
2070
 
2071
               elsif Etype (Choice) = Base_Type (Enumtype) then
2072
                  if not Is_Static_Expression (Choice) then
2073
                     Flag_Non_Static_Expr
2074
                       ("non-static expression used for choice!", Choice);
2075
                     Err := True;
2076
 
2077
                  else
2078
                     Elit := Expr_Value_E (Choice);
2079
 
2080
                     if Present (Enumeration_Rep_Expr (Elit)) then
2081
                        Error_Msg_Sloc := Sloc (Enumeration_Rep_Expr (Elit));
2082
                        Error_Msg_NE
2083
                          ("representation for& previously given#",
2084
                           Choice, Elit);
2085
                        Err := True;
2086
                     end if;
2087
 
2088
                     Set_Enumeration_Rep_Expr (Elit, Choice);
2089
 
2090
                     Expr := Expression (Assoc);
2091
                     Val := Static_Integer (Expr);
2092
 
2093
                     if Val = No_Uint then
2094
                        Err := True;
2095
 
2096
                     elsif Val < Lo or else Hi < Val then
2097
                        Error_Msg_N ("value outside permitted range", Expr);
2098
                        Err := True;
2099
                     end if;
2100
 
2101
                     Set_Enumeration_Rep (Elit, Val);
2102
                  end if;
2103
               end if;
2104
            end if;
2105
 
2106
            Next (Assoc);
2107
         end loop;
2108
      end if;
2109
 
2110
      --  Aggregate is fully processed. Now we check that a full set of
2111
      --  representations was given, and that they are in range and in order.
2112
      --  These checks are only done if no other errors occurred.
2113
 
2114
      if not Err then
2115
         Min  := No_Uint;
2116
         Max  := No_Uint;
2117
 
2118
         Elit := First_Literal (Enumtype);
2119
         while Present (Elit) loop
2120
            if No (Enumeration_Rep_Expr (Elit)) then
2121
               Error_Msg_NE ("missing representation for&!", N, Elit);
2122
 
2123
            else
2124
               Val := Enumeration_Rep (Elit);
2125
 
2126
               if Min = No_Uint then
2127
                  Min := Val;
2128
               end if;
2129
 
2130
               if Val /= No_Uint then
2131
                  if Max /= No_Uint and then Val <= Max then
2132
                     Error_Msg_NE
2133
                       ("enumeration value for& not ordered!",
2134
                                       Enumeration_Rep_Expr (Elit), Elit);
2135
                  end if;
2136
 
2137
                  Max := Val;
2138
               end if;
2139
 
2140
               --  If there is at least one literal whose representation
2141
               --  is not equal to the Pos value, then note that this
2142
               --  enumeration type has a non-standard representation.
2143
 
2144
               if Val /= Enumeration_Pos (Elit) then
2145
                  Set_Has_Non_Standard_Rep (Base_Type (Enumtype));
2146
               end if;
2147
            end if;
2148
 
2149
            Next (Elit);
2150
         end loop;
2151
 
2152
         --  Now set proper size information
2153
 
2154
         declare
2155
            Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype));
2156
 
2157
         begin
2158
            if Has_Size_Clause (Enumtype) then
2159
               if Esize (Enumtype) >= Minsize then
2160
                  null;
2161
 
2162
               else
2163
                  Minsize :=
2164
                    UI_From_Int (Minimum_Size (Enumtype, Biased => True));
2165
 
2166
                  if Esize (Enumtype) < Minsize then
2167
                     Error_Msg_N ("previously given size is too small", N);
2168
 
2169
                  else
2170
                     Set_Has_Biased_Representation (Enumtype);
2171
                  end if;
2172
               end if;
2173
 
2174
            else
2175
               Set_RM_Size    (Enumtype, Minsize);
2176
               Set_Enum_Esize (Enumtype);
2177
            end if;
2178
 
2179
            Set_RM_Size   (Base_Type (Enumtype), RM_Size   (Enumtype));
2180
            Set_Esize     (Base_Type (Enumtype), Esize     (Enumtype));
2181
            Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype));
2182
         end;
2183
      end if;
2184
 
2185
      --  We repeat the too late test in case it froze itself!
2186
 
2187
      if Rep_Item_Too_Late (Enumtype, N) then
2188
         null;
2189
      end if;
2190
   end Analyze_Enumeration_Representation_Clause;
2191
 
2192
   ----------------------------
2193
   -- Analyze_Free_Statement --
2194
   ----------------------------
2195
 
2196
   procedure Analyze_Free_Statement (N : Node_Id) is
2197
   begin
2198
      Analyze (Expression (N));
2199
   end Analyze_Free_Statement;
2200
 
2201
   ---------------------------
2202
   -- Analyze_Freeze_Entity --
2203
   ---------------------------
2204
 
2205
   procedure Analyze_Freeze_Entity (N : Node_Id) is
2206
      E : constant Entity_Id := Entity (N);
2207
 
2208
   begin
2209
      --  For tagged types covering interfaces add internal entities that link
2210
      --  the primitives of the interfaces with the primitives that cover them.
2211
 
2212
      --  Note: These entities were originally generated only when generating
2213
      --  code because their main purpose was to provide support to initialize
2214
      --  the secondary dispatch tables. They are now generated also when
2215
      --  compiling with no code generation to provide ASIS the relationship
2216
      --  between interface primitives and tagged type primitives.
2217
 
2218
      if Ada_Version >= Ada_05
2219
        and then Ekind (E) = E_Record_Type
2220
        and then Is_Tagged_Type (E)
2221
        and then not Is_Interface (E)
2222
        and then Has_Interfaces (E)
2223
      then
2224
         Add_Internal_Interface_Entities (E);
2225
      end if;
2226
   end Analyze_Freeze_Entity;
2227
 
2228
   ------------------------------------------
2229
   -- Analyze_Record_Representation_Clause --
2230
   ------------------------------------------
2231
 
2232
   procedure Analyze_Record_Representation_Clause (N : Node_Id) is
2233
      Loc     : constant Source_Ptr := Sloc (N);
2234
      Ident   : constant Node_Id    := Identifier (N);
2235
      Rectype : Entity_Id;
2236
      Fent    : Entity_Id;
2237
      CC      : Node_Id;
2238
      Posit   : Uint;
2239
      Fbit    : Uint;
2240
      Lbit    : Uint;
2241
      Hbit    : Uint := Uint_0;
2242
      Comp    : Entity_Id;
2243
      Ocomp   : Entity_Id;
2244
      Pcomp   : Entity_Id;
2245
      Biased  : Boolean;
2246
 
2247
      Max_Bit_So_Far : Uint;
2248
      --  Records the maximum bit position so far. If all field positions
2249
      --  are monotonically increasing, then we can skip the circuit for
2250
      --  checking for overlap, since no overlap is possible.
2251
 
2252
      Tagged_Parent : Entity_Id := Empty;
2253
      --  This is set in the case of a derived tagged type for which we have
2254
      --  Is_Fully_Repped_Tagged_Type True (indicating that all components are
2255
      --  positioned by record representation clauses). In this case we must
2256
      --  check for overlap between components of this tagged type, and the
2257
      --  components of its parent. Tagged_Parent will point to this parent
2258
      --  type. For all other cases Tagged_Parent is left set to Empty.
2259
 
2260
      Parent_Last_Bit : Uint;
2261
      --  Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the
2262
      --  last bit position for any field in the parent type. We only need to
2263
      --  check overlap for fields starting below this point.
2264
 
2265
      Overlap_Check_Required : Boolean;
2266
      --  Used to keep track of whether or not an overlap check is required
2267
 
2268
      Ccount : Natural := 0;
2269
      --  Number of component clauses in record rep clause
2270
 
2271
      CR_Pragma : Node_Id := Empty;
2272
      --  Points to N_Pragma node if Complete_Representation pragma present
2273
 
2274
   begin
2275
      if Ignore_Rep_Clauses then
2276
         return;
2277
      end if;
2278
 
2279
      Find_Type (Ident);
2280
      Rectype := Entity (Ident);
2281
 
2282
      if Rectype = Any_Type
2283
        or else Rep_Item_Too_Early (Rectype, N)
2284
      then
2285
         return;
2286
      else
2287
         Rectype := Underlying_Type (Rectype);
2288
      end if;
2289
 
2290
      --  First some basic error checks
2291
 
2292
      if not Is_Record_Type (Rectype) then
2293
         Error_Msg_NE
2294
           ("record type required, found}", Ident, First_Subtype (Rectype));
2295
         return;
2296
 
2297
      elsif Is_Unchecked_Union (Rectype) then
2298
         Error_Msg_N
2299
           ("record rep clause not allowed for Unchecked_Union", N);
2300
 
2301
      elsif Scope (Rectype) /= Current_Scope then
2302
         Error_Msg_N ("type must be declared in this scope", N);
2303
         return;
2304
 
2305
      elsif not Is_First_Subtype (Rectype) then
2306
         Error_Msg_N ("cannot give record rep clause for subtype", N);
2307
         return;
2308
 
2309
      elsif Has_Record_Rep_Clause (Rectype) then
2310
         Error_Msg_N ("duplicate record rep clause ignored", N);
2311
         return;
2312
 
2313
      elsif Rep_Item_Too_Late (Rectype, N) then
2314
         return;
2315
      end if;
2316
 
2317
      if Present (Mod_Clause (N)) then
2318
         declare
2319
            Loc     : constant Source_Ptr := Sloc (N);
2320
            M       : constant Node_Id := Mod_Clause (N);
2321
            P       : constant List_Id := Pragmas_Before (M);
2322
            AtM_Nod : Node_Id;
2323
 
2324
            Mod_Val : Uint;
2325
            pragma Warnings (Off, Mod_Val);
2326
 
2327
         begin
2328
            Check_Restriction (No_Obsolescent_Features, Mod_Clause (N));
2329
 
2330
            if Warn_On_Obsolescent_Feature then
2331
               Error_Msg_N
2332
                 ("mod clause is an obsolescent feature (RM J.8)?", N);
2333
               Error_Msg_N
2334
                 ("\use alignment attribute definition clause instead?", N);
2335
            end if;
2336
 
2337
            if Present (P) then
2338
               Analyze_List (P);
2339
            end if;
2340
 
2341
            --  In ASIS_Mode mode, expansion is disabled, but we must convert
2342
            --  the Mod clause into an alignment clause anyway, so that the
2343
            --  back-end can compute and back-annotate properly the size and
2344
            --  alignment of types that may include this record.
2345
 
2346
            --  This seems dubious, this destroys the source tree in a manner
2347
            --  not detectable by ASIS ???
2348
 
2349
            if Operating_Mode = Check_Semantics
2350
              and then ASIS_Mode
2351
            then
2352
               AtM_Nod :=
2353
                 Make_Attribute_Definition_Clause (Loc,
2354
                   Name       => New_Reference_To (Base_Type (Rectype), Loc),
2355
                   Chars      => Name_Alignment,
2356
                   Expression => Relocate_Node (Expression (M)));
2357
 
2358
               Set_From_At_Mod (AtM_Nod);
2359
               Insert_After (N, AtM_Nod);
2360
               Mod_Val := Get_Alignment_Value (Expression (AtM_Nod));
2361
               Set_Mod_Clause (N, Empty);
2362
 
2363
            else
2364
               --  Get the alignment value to perform error checking
2365
 
2366
               Mod_Val := Get_Alignment_Value (Expression (M));
2367
 
2368
            end if;
2369
         end;
2370
      end if;
2371
 
2372
      --  For untagged types, clear any existing component clauses for the
2373
      --  type. If the type is derived, this is what allows us to override
2374
      --  a rep clause for the parent. For type extensions, the representation
2375
      --  of the inherited components is inherited, so we want to keep previous
2376
      --  component clauses for completeness.
2377
 
2378
      if not Is_Tagged_Type (Rectype) then
2379
         Comp := First_Component_Or_Discriminant (Rectype);
2380
         while Present (Comp) loop
2381
            Set_Component_Clause (Comp, Empty);
2382
            Next_Component_Or_Discriminant (Comp);
2383
         end loop;
2384
      end if;
2385
 
2386
      --  See if we have a fully repped derived tagged type
2387
 
2388
      declare
2389
         PS : constant Entity_Id := Parent_Subtype (Rectype);
2390
 
2391
      begin
2392
         if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then
2393
            Tagged_Parent := PS;
2394
 
2395
            --  Find maximum bit of any component of the parent type
2396
 
2397
            Parent_Last_Bit := UI_From_Int (System_Address_Size - 1);
2398
            Pcomp := First_Entity (Tagged_Parent);
2399
            while Present (Pcomp) loop
2400
               if Ekind (Pcomp) = E_Discriminant
2401
                    or else
2402
                  Ekind (Pcomp) = E_Component
2403
               then
2404
                  if Component_Bit_Offset (Pcomp) /= No_Uint
2405
                    and then Known_Static_Esize (Pcomp)
2406
                  then
2407
                     Parent_Last_Bit :=
2408
                       UI_Max
2409
                         (Parent_Last_Bit,
2410
                          Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1);
2411
                  end if;
2412
 
2413
                  Next_Entity (Pcomp);
2414
               end if;
2415
            end loop;
2416
         end if;
2417
      end;
2418
 
2419
      --  All done if no component clauses
2420
 
2421
      CC := First (Component_Clauses (N));
2422
 
2423
      if No (CC) then
2424
         return;
2425
      end if;
2426
 
2427
      --  If a tag is present, then create a component clause that places it
2428
      --  at the start of the record (otherwise gigi may place it after other
2429
      --  fields that have rep clauses).
2430
 
2431
      Fent := First_Entity (Rectype);
2432
 
2433
      if Nkind (Fent) = N_Defining_Identifier
2434
        and then Chars (Fent) = Name_uTag
2435
      then
2436
         Set_Component_Bit_Offset    (Fent, Uint_0);
2437
         Set_Normalized_Position     (Fent, Uint_0);
2438
         Set_Normalized_First_Bit    (Fent, Uint_0);
2439
         Set_Normalized_Position_Max (Fent, Uint_0);
2440
         Init_Esize                  (Fent, System_Address_Size);
2441
 
2442
         Set_Component_Clause (Fent,
2443
           Make_Component_Clause (Loc,
2444
             Component_Name =>
2445
               Make_Identifier (Loc,
2446
                 Chars => Name_uTag),
2447
 
2448
             Position  =>
2449
               Make_Integer_Literal (Loc,
2450
                 Intval => Uint_0),
2451
 
2452
             First_Bit =>
2453
               Make_Integer_Literal (Loc,
2454
                 Intval => Uint_0),
2455
 
2456
             Last_Bit  =>
2457
               Make_Integer_Literal (Loc,
2458
                 UI_From_Int (System_Address_Size))));
2459
 
2460
         Ccount := Ccount + 1;
2461
      end if;
2462
 
2463
      --  A representation like this applies to the base type
2464
 
2465
      Set_Has_Record_Rep_Clause (Base_Type (Rectype));
2466
      Set_Has_Non_Standard_Rep  (Base_Type (Rectype));
2467
      Set_Has_Specified_Layout  (Base_Type (Rectype));
2468
 
2469
      Max_Bit_So_Far := Uint_Minus_1;
2470
      Overlap_Check_Required := False;
2471
 
2472
      --  Process the component clauses
2473
 
2474
      while Present (CC) loop
2475
 
2476
         --  Pragma
2477
 
2478
         if Nkind (CC) = N_Pragma then
2479
            Analyze (CC);
2480
 
2481
            --  The only pragma of interest is Complete_Representation
2482
 
2483
            if Pragma_Name (CC) = Name_Complete_Representation then
2484
               CR_Pragma := CC;
2485
            end if;
2486
 
2487
         --  Processing for real component clause
2488
 
2489
         else
2490
            Ccount := Ccount + 1;
2491
            Posit := Static_Integer (Position  (CC));
2492
            Fbit  := Static_Integer (First_Bit (CC));
2493
            Lbit  := Static_Integer (Last_Bit  (CC));
2494
 
2495
            if Posit /= No_Uint
2496
              and then Fbit /= No_Uint
2497
              and then Lbit /= No_Uint
2498
            then
2499
               if Posit < 0 then
2500
                  Error_Msg_N
2501
                    ("position cannot be negative", Position (CC));
2502
 
2503
               elsif Fbit < 0 then
2504
                  Error_Msg_N
2505
                    ("first bit cannot be negative", First_Bit (CC));
2506
 
2507
               --  The Last_Bit specified in a component clause must not be
2508
               --  less than the First_Bit minus one (RM-13.5.1(10)).
2509
 
2510
               elsif Lbit < Fbit - 1 then
2511
                  Error_Msg_N
2512
                    ("last bit cannot be less than first bit minus one",
2513
                     Last_Bit (CC));
2514
 
2515
               --  Values look OK, so find the corresponding record component
2516
               --  Even though the syntax allows an attribute reference for
2517
               --  implementation-defined components, GNAT does not allow the
2518
               --  tag to get an explicit position.
2519
 
2520
               elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then
2521
                  if Attribute_Name (Component_Name (CC)) = Name_Tag then
2522
                     Error_Msg_N ("position of tag cannot be specified", CC);
2523
                  else
2524
                     Error_Msg_N ("illegal component name", CC);
2525
                  end if;
2526
 
2527
               else
2528
                  Comp := First_Entity (Rectype);
2529
                  while Present (Comp) loop
2530
                     exit when Chars (Comp) = Chars (Component_Name (CC));
2531
                     Next_Entity (Comp);
2532
                  end loop;
2533
 
2534
                  if No (Comp) then
2535
 
2536
                     --  Maybe component of base type that is absent from
2537
                     --  statically constrained first subtype.
2538
 
2539
                     Comp := First_Entity (Base_Type (Rectype));
2540
                     while Present (Comp) loop
2541
                        exit when Chars (Comp) = Chars (Component_Name (CC));
2542
                        Next_Entity (Comp);
2543
                     end loop;
2544
                  end if;
2545
 
2546
                  if No (Comp) then
2547
                     Error_Msg_N
2548
                       ("component clause is for non-existent field", CC);
2549
 
2550
                  elsif Present (Component_Clause (Comp)) then
2551
 
2552
                     --  Diagnose duplicate rep clause, or check consistency
2553
                     --  if this is an inherited component. In a double fault,
2554
                     --  there may be a duplicate inconsistent clause for an
2555
                     --  inherited component.
2556
 
2557
                     if Scope (Original_Record_Component (Comp)) = Rectype
2558
                       or else Parent (Component_Clause (Comp)) = N
2559
                     then
2560
                        Error_Msg_Sloc := Sloc (Component_Clause (Comp));
2561
                        Error_Msg_N ("component clause previously given#", CC);
2562
 
2563
                     else
2564
                        declare
2565
                           Rep1 : constant Node_Id := Component_Clause (Comp);
2566
                        begin
2567
                           if Intval (Position (Rep1)) /=
2568
                                                   Intval (Position (CC))
2569
                             or else Intval (First_Bit (Rep1)) /=
2570
                                                   Intval (First_Bit (CC))
2571
                             or else Intval (Last_Bit (Rep1)) /=
2572
                                                   Intval (Last_Bit (CC))
2573
                           then
2574
                              Error_Msg_N ("component clause inconsistent "
2575
                                & "with representation of ancestor", CC);
2576
                           elsif Warn_On_Redundant_Constructs then
2577
                              Error_Msg_N ("?redundant component clause "
2578
                                & "for inherited component!", CC);
2579
                           end if;
2580
                        end;
2581
                     end if;
2582
 
2583
                  --  Normal case where this is the first component clause we
2584
                  --  have seen for this entity, so set it up properly.
2585
 
2586
                  else
2587
                     --  Make reference for field in record rep clause and set
2588
                     --  appropriate entity field in the field identifier.
2589
 
2590
                     Generate_Reference
2591
                       (Comp, Component_Name (CC), Set_Ref => False);
2592
                     Set_Entity (Component_Name (CC), Comp);
2593
 
2594
                     --  Update Fbit and Lbit to the actual bit number
2595
 
2596
                     Fbit := Fbit + UI_From_Int (SSU) * Posit;
2597
                     Lbit := Lbit + UI_From_Int (SSU) * Posit;
2598
 
2599
                     if Fbit <= Max_Bit_So_Far then
2600
                        Overlap_Check_Required := True;
2601
                     else
2602
                        Max_Bit_So_Far := Lbit;
2603
                     end if;
2604
 
2605
                     if Has_Size_Clause (Rectype)
2606
                       and then Esize (Rectype) <= Lbit
2607
                     then
2608
                        Error_Msg_N
2609
                          ("bit number out of range of specified size",
2610
                           Last_Bit (CC));
2611
                     else
2612
                        Set_Component_Clause     (Comp, CC);
2613
                        Set_Component_Bit_Offset (Comp, Fbit);
2614
                        Set_Esize                (Comp, 1 + (Lbit - Fbit));
2615
                        Set_Normalized_First_Bit (Comp, Fbit mod SSU);
2616
                        Set_Normalized_Position  (Comp, Fbit / SSU);
2617
 
2618
                        Set_Normalized_Position_Max
2619
                          (Fent, Normalized_Position (Fent));
2620
 
2621
                        if Is_Tagged_Type (Rectype)
2622
                          and then Fbit < System_Address_Size
2623
                        then
2624
                           Error_Msg_NE
2625
                             ("component overlaps tag field of&",
2626
                              Component_Name (CC), Rectype);
2627
                        end if;
2628
 
2629
                        --  This information is also set in the corresponding
2630
                        --  component of the base type, found by accessing the
2631
                        --  Original_Record_Component link if it is present.
2632
 
2633
                        Ocomp := Original_Record_Component (Comp);
2634
 
2635
                        if Hbit < Lbit then
2636
                           Hbit := Lbit;
2637
                        end if;
2638
 
2639
                        Check_Size
2640
                          (Component_Name (CC),
2641
                           Etype (Comp),
2642
                           Esize (Comp),
2643
                           Biased);
2644
 
2645
                        Set_Has_Biased_Representation (Comp, Biased);
2646
 
2647
                        if Biased and Warn_On_Biased_Representation then
2648
                           Error_Msg_F
2649
                             ("?component clause forces biased "
2650
                              & "representation", CC);
2651
                        end if;
2652
 
2653
                        if Present (Ocomp) then
2654
                           Set_Component_Clause     (Ocomp, CC);
2655
                           Set_Component_Bit_Offset (Ocomp, Fbit);
2656
                           Set_Normalized_First_Bit (Ocomp, Fbit mod SSU);
2657
                           Set_Normalized_Position  (Ocomp, Fbit / SSU);
2658
                           Set_Esize                (Ocomp, 1 + (Lbit - Fbit));
2659
 
2660
                           Set_Normalized_Position_Max
2661
                             (Ocomp, Normalized_Position (Ocomp));
2662
 
2663
                           Set_Has_Biased_Representation
2664
                             (Ocomp, Has_Biased_Representation (Comp));
2665
                        end if;
2666
 
2667
                        if Esize (Comp) < 0 then
2668
                           Error_Msg_N ("component size is negative", CC);
2669
                        end if;
2670
                     end if;
2671
 
2672
                     --  If OK component size, check parent type overlap if
2673
                     --  this component might overlap a parent field.
2674
 
2675
                     if Present (Tagged_Parent)
2676
                       and then Fbit <= Parent_Last_Bit
2677
                     then
2678
                        Pcomp := First_Entity (Tagged_Parent);
2679
                        while Present (Pcomp) loop
2680
                           if (Ekind (Pcomp) = E_Discriminant
2681
                                or else
2682
                               Ekind (Pcomp) = E_Component)
2683
                             and then not Is_Tag (Pcomp)
2684
                             and then Chars (Pcomp) /= Name_uParent
2685
                           then
2686
                              Check_Component_Overlap (Comp, Pcomp);
2687
                           end if;
2688
 
2689
                           Next_Entity (Pcomp);
2690
                        end loop;
2691
                     end if;
2692
                  end if;
2693
               end if;
2694
            end if;
2695
         end if;
2696
 
2697
         Next (CC);
2698
      end loop;
2699
 
2700
      --  Now that we have processed all the component clauses, check for
2701
      --  overlap. We have to leave this till last, since the components can
2702
      --  appear in any arbitrary order in the representation clause.
2703
 
2704
      --  We do not need this check if all specified ranges were monotonic,
2705
      --  as recorded by Overlap_Check_Required being False at this stage.
2706
 
2707
      --  This first section checks if there are any overlapping entries at
2708
      --  all. It does this by sorting all entries and then seeing if there are
2709
      --  any overlaps. If there are none, then that is decisive, but if there
2710
      --  are overlaps, they may still be OK (they may result from fields in
2711
      --  different variants).
2712
 
2713
      if Overlap_Check_Required then
2714
         Overlap_Check1 : declare
2715
 
2716
            OC_Fbit : array (0 .. Ccount) of Uint;
2717
            --  First-bit values for component clauses, the value is the offset
2718
            --  of the first bit of the field from start of record. The zero
2719
            --  entry is for use in sorting.
2720
 
2721
            OC_Lbit : array (0 .. Ccount) of Uint;
2722
            --  Last-bit values for component clauses, the value is the offset
2723
            --  of the last bit of the field from start of record. The zero
2724
            --  entry is for use in sorting.
2725
 
2726
            OC_Count : Natural := 0;
2727
            --  Count of entries in OC_Fbit and OC_Lbit
2728
 
2729
            function OC_Lt (Op1, Op2 : Natural) return Boolean;
2730
            --  Compare routine for Sort
2731
 
2732
            procedure OC_Move (From : Natural; To : Natural);
2733
            --  Move routine for Sort
2734
 
2735
            package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt);
2736
 
2737
            -----------
2738
            -- OC_Lt --
2739
            -----------
2740
 
2741
            function OC_Lt (Op1, Op2 : Natural) return Boolean is
2742
            begin
2743
               return OC_Fbit (Op1) < OC_Fbit (Op2);
2744
            end OC_Lt;
2745
 
2746
            -------------
2747
            -- OC_Move --
2748
            -------------
2749
 
2750
            procedure OC_Move (From : Natural; To : Natural) is
2751
            begin
2752
               OC_Fbit (To) := OC_Fbit (From);
2753
               OC_Lbit (To) := OC_Lbit (From);
2754
            end OC_Move;
2755
 
2756
         --  Start of processing for Overlap_Check
2757
 
2758
         begin
2759
            CC := First (Component_Clauses (N));
2760
            while Present (CC) loop
2761
               if Nkind (CC) /= N_Pragma then
2762
                  Posit := Static_Integer (Position  (CC));
2763
                  Fbit  := Static_Integer (First_Bit (CC));
2764
                  Lbit  := Static_Integer (Last_Bit  (CC));
2765
 
2766
                  if Posit /= No_Uint
2767
                    and then Fbit /= No_Uint
2768
                    and then Lbit /= No_Uint
2769
                  then
2770
                     OC_Count := OC_Count + 1;
2771
                     Posit := Posit * SSU;
2772
                     OC_Fbit (OC_Count) := Fbit + Posit;
2773
                     OC_Lbit (OC_Count) := Lbit + Posit;
2774
                  end if;
2775
               end if;
2776
 
2777
               Next (CC);
2778
            end loop;
2779
 
2780
            Sorting.Sort (OC_Count);
2781
 
2782
            Overlap_Check_Required := False;
2783
            for J in 1 .. OC_Count - 1 loop
2784
               if OC_Lbit (J) >= OC_Fbit (J + 1) then
2785
                  Overlap_Check_Required := True;
2786
                  exit;
2787
               end if;
2788
            end loop;
2789
         end Overlap_Check1;
2790
      end if;
2791
 
2792
      --  If Overlap_Check_Required is still True, then we have to do the full
2793
      --  scale overlap check, since we have at least two fields that do
2794
      --  overlap, and we need to know if that is OK since they are in
2795
      --  different variant, or whether we have a definite problem.
2796
 
2797
      if Overlap_Check_Required then
2798
         Overlap_Check2 : declare
2799
            C1_Ent, C2_Ent : Entity_Id;
2800
            --  Entities of components being checked for overlap
2801
 
2802
            Clist : Node_Id;
2803
            --  Component_List node whose Component_Items are being checked
2804
 
2805
            Citem : Node_Id;
2806
            --  Component declaration for component being checked
2807
 
2808
         begin
2809
            C1_Ent := First_Entity (Base_Type (Rectype));
2810
 
2811
            --  Loop through all components in record. For each component check
2812
            --  for overlap with any of the preceding elements on the component
2813
            --  list containing the component and also, if the component is in
2814
            --  a variant, check against components outside the case structure.
2815
            --  This latter test is repeated recursively up the variant tree.
2816
 
2817
            Main_Component_Loop : while Present (C1_Ent) loop
2818
               if Ekind (C1_Ent) /= E_Component
2819
                 and then Ekind (C1_Ent) /= E_Discriminant
2820
               then
2821
                  goto Continue_Main_Component_Loop;
2822
               end if;
2823
 
2824
               --  Skip overlap check if entity has no declaration node. This
2825
               --  happens with discriminants in constrained derived types.
2826
               --  Probably we are missing some checks as a result, but that
2827
               --  does not seem terribly serious ???
2828
 
2829
               if No (Declaration_Node (C1_Ent)) then
2830
                  goto Continue_Main_Component_Loop;
2831
               end if;
2832
 
2833
               Clist := Parent (List_Containing (Declaration_Node (C1_Ent)));
2834
 
2835
               --  Loop through component lists that need checking. Check the
2836
               --  current component list and all lists in variants above us.
2837
 
2838
               Component_List_Loop : loop
2839
 
2840
                  --  If derived type definition, go to full declaration
2841
                  --  If at outer level, check discriminants if there are any.
2842
 
2843
                  if Nkind (Clist) = N_Derived_Type_Definition then
2844
                     Clist := Parent (Clist);
2845
                  end if;
2846
 
2847
                  --  Outer level of record definition, check discriminants
2848
 
2849
                  if Nkind_In (Clist, N_Full_Type_Declaration,
2850
                                      N_Private_Type_Declaration)
2851
                  then
2852
                     if Has_Discriminants (Defining_Identifier (Clist)) then
2853
                        C2_Ent :=
2854
                          First_Discriminant (Defining_Identifier (Clist));
2855
                        while Present (C2_Ent) loop
2856
                           exit when C1_Ent = C2_Ent;
2857
                           Check_Component_Overlap (C1_Ent, C2_Ent);
2858
                           Next_Discriminant (C2_Ent);
2859
                        end loop;
2860
                     end if;
2861
 
2862
                  --  Record extension case
2863
 
2864
                  elsif Nkind (Clist) = N_Derived_Type_Definition then
2865
                     Clist := Empty;
2866
 
2867
                  --  Otherwise check one component list
2868
 
2869
                  else
2870
                     Citem := First (Component_Items (Clist));
2871
 
2872
                     while Present (Citem) loop
2873
                        if Nkind (Citem) = N_Component_Declaration then
2874
                           C2_Ent := Defining_Identifier (Citem);
2875
                           exit when C1_Ent = C2_Ent;
2876
                           Check_Component_Overlap (C1_Ent, C2_Ent);
2877
                        end if;
2878
 
2879
                        Next (Citem);
2880
                     end loop;
2881
                  end if;
2882
 
2883
                  --  Check for variants above us (the parent of the Clist can
2884
                  --  be a variant, in which case its parent is a variant part,
2885
                  --  and the parent of the variant part is a component list
2886
                  --  whose components must all be checked against the current
2887
                  --  component for overlap).
2888
 
2889
                  if Nkind (Parent (Clist)) = N_Variant then
2890
                     Clist := Parent (Parent (Parent (Clist)));
2891
 
2892
                  --  Check for possible discriminant part in record, this is
2893
                  --  treated essentially as another level in the recursion.
2894
                  --  For this case the parent of the component list is the
2895
                  --  record definition, and its parent is the full type
2896
                  --  declaration containing the discriminant specifications.
2897
 
2898
                  elsif Nkind (Parent (Clist)) = N_Record_Definition then
2899
                     Clist := Parent (Parent ((Clist)));
2900
 
2901
                  --  If neither of these two cases, we are at the top of
2902
                  --  the tree.
2903
 
2904
                  else
2905
                     exit Component_List_Loop;
2906
                  end if;
2907
               end loop Component_List_Loop;
2908
 
2909
               <<Continue_Main_Component_Loop>>
2910
                  Next_Entity (C1_Ent);
2911
 
2912
            end loop Main_Component_Loop;
2913
         end Overlap_Check2;
2914
      end if;
2915
 
2916
      --  For records that have component clauses for all components, and whose
2917
      --  size is less than or equal to 32, we need to know the size in the
2918
      --  front end to activate possible packed array processing where the
2919
      --  component type is a record.
2920
 
2921
      --  At this stage Hbit + 1 represents the first unused bit from all the
2922
      --  component clauses processed, so if the component clauses are
2923
      --  complete, then this is the length of the record.
2924
 
2925
      --  For records longer than System.Storage_Unit, and for those where not
2926
      --  all components have component clauses, the back end determines the
2927
      --  length (it may for example be appropriate to round up the size
2928
      --  to some convenient boundary, based on alignment considerations, etc).
2929
 
2930
      if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then
2931
 
2932
         --  Nothing to do if at least one component has no component clause
2933
 
2934
         Comp := First_Component_Or_Discriminant (Rectype);
2935
         while Present (Comp) loop
2936
            exit when No (Component_Clause (Comp));
2937
            Next_Component_Or_Discriminant (Comp);
2938
         end loop;
2939
 
2940
         --  If we fall out of loop, all components have component clauses
2941
         --  and so we can set the size to the maximum value.
2942
 
2943
         if No (Comp) then
2944
            Set_RM_Size (Rectype, Hbit + 1);
2945
         end if;
2946
      end if;
2947
 
2948
      --  Check missing components if Complete_Representation pragma appeared
2949
 
2950
      if Present (CR_Pragma) then
2951
         Comp := First_Component_Or_Discriminant (Rectype);
2952
         while Present (Comp) loop
2953
            if No (Component_Clause (Comp)) then
2954
               Error_Msg_NE
2955
                 ("missing component clause for &", CR_Pragma, Comp);
2956
            end if;
2957
 
2958
            Next_Component_Or_Discriminant (Comp);
2959
         end loop;
2960
 
2961
      --  If no Complete_Representation pragma, warn if missing components
2962
 
2963
      elsif Warn_On_Unrepped_Components then
2964
         declare
2965
            Num_Repped_Components   : Nat := 0;
2966
            Num_Unrepped_Components : Nat := 0;
2967
 
2968
         begin
2969
            --  First count number of repped and unrepped components
2970
 
2971
            Comp := First_Component_Or_Discriminant (Rectype);
2972
            while Present (Comp) loop
2973
               if Present (Component_Clause (Comp)) then
2974
                  Num_Repped_Components := Num_Repped_Components + 1;
2975
               else
2976
                  Num_Unrepped_Components := Num_Unrepped_Components + 1;
2977
               end if;
2978
 
2979
               Next_Component_Or_Discriminant (Comp);
2980
            end loop;
2981
 
2982
            --  We are only interested in the case where there is at least one
2983
            --  unrepped component, and at least half the components have rep
2984
            --  clauses. We figure that if less than half have them, then the
2985
            --  partial rep clause is really intentional. If the component
2986
            --  type has no underlying type set at this point (as for a generic
2987
            --  formal type), we don't know enough to give a warning on the
2988
            --  component.
2989
 
2990
            if Num_Unrepped_Components > 0
2991
              and then Num_Unrepped_Components < Num_Repped_Components
2992
            then
2993
               Comp := First_Component_Or_Discriminant (Rectype);
2994
               while Present (Comp) loop
2995
                  if No (Component_Clause (Comp))
2996
                    and then Comes_From_Source (Comp)
2997
                    and then Present (Underlying_Type (Etype (Comp)))
2998
                    and then (Is_Scalar_Type (Underlying_Type (Etype (Comp)))
2999
                                or else Size_Known_At_Compile_Time
3000
                                             (Underlying_Type (Etype (Comp))))
3001
                    and then not Has_Warnings_Off (Rectype)
3002
                  then
3003
                     Error_Msg_Sloc := Sloc (Comp);
3004
                     Error_Msg_NE
3005
                       ("?no component clause given for & declared #",
3006
                        N, Comp);
3007
                  end if;
3008
 
3009
                  Next_Component_Or_Discriminant (Comp);
3010
               end loop;
3011
            end if;
3012
         end;
3013
      end if;
3014
   end Analyze_Record_Representation_Clause;
3015
 
3016
   -----------------------------
3017
   -- Check_Component_Overlap --
3018
   -----------------------------
3019
 
3020
   procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is
3021
   begin
3022
      if Present (Component_Clause (C1_Ent))
3023
        and then Present (Component_Clause (C2_Ent))
3024
      then
3025
         --  Exclude odd case where we have two tag fields in the same record,
3026
         --  both at location zero. This seems a bit strange, but it seems to
3027
         --  happen in some circumstances ???
3028
 
3029
         if Chars (C1_Ent) = Name_uTag
3030
           and then Chars (C2_Ent) = Name_uTag
3031
         then
3032
            return;
3033
         end if;
3034
 
3035
         --  Here we check if the two fields overlap
3036
 
3037
         declare
3038
            S1 : constant Uint := Component_Bit_Offset (C1_Ent);
3039
            S2 : constant Uint := Component_Bit_Offset (C2_Ent);
3040
            E1 : constant Uint := S1 + Esize (C1_Ent);
3041
            E2 : constant Uint := S2 + Esize (C2_Ent);
3042
 
3043
         begin
3044
            if E2 <= S1 or else E1 <= S2 then
3045
               null;
3046
            else
3047
               Error_Msg_Node_2 :=
3048
                 Component_Name (Component_Clause (C2_Ent));
3049
               Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
3050
               Error_Msg_Node_1 :=
3051
                 Component_Name (Component_Clause (C1_Ent));
3052
               Error_Msg_N
3053
                 ("component& overlaps & #",
3054
                  Component_Name (Component_Clause (C1_Ent)));
3055
            end if;
3056
         end;
3057
      end if;
3058
   end Check_Component_Overlap;
3059
 
3060
   -----------------------------------
3061
   -- Check_Constant_Address_Clause --
3062
   -----------------------------------
3063
 
3064
   procedure Check_Constant_Address_Clause
3065
     (Expr  : Node_Id;
3066
      U_Ent : Entity_Id)
3067
   is
3068
      procedure Check_At_Constant_Address (Nod : Node_Id);
3069
      --  Checks that the given node N represents a name whose 'Address is
3070
      --  constant (in the same sense as OK_Constant_Address_Clause, i.e. the
3071
      --  address value is the same at the point of declaration of U_Ent and at
3072
      --  the time of elaboration of the address clause.
3073
 
3074
      procedure Check_Expr_Constants (Nod : Node_Id);
3075
      --  Checks that Nod meets the requirements for a constant address clause
3076
      --  in the sense of the enclosing procedure.
3077
 
3078
      procedure Check_List_Constants (Lst : List_Id);
3079
      --  Check that all elements of list Lst meet the requirements for a
3080
      --  constant address clause in the sense of the enclosing procedure.
3081
 
3082
      -------------------------------
3083
      -- Check_At_Constant_Address --
3084
      -------------------------------
3085
 
3086
      procedure Check_At_Constant_Address (Nod : Node_Id) is
3087
      begin
3088
         if Is_Entity_Name (Nod) then
3089
            if Present (Address_Clause (Entity ((Nod)))) then
3090
               Error_Msg_NE
3091
                 ("invalid address clause for initialized object &!",
3092
                           Nod, U_Ent);
3093
               Error_Msg_NE
3094
                 ("address for& cannot" &
3095
                    " depend on another address clause! (RM 13.1(22))!",
3096
                  Nod, U_Ent);
3097
 
3098
            elsif In_Same_Source_Unit (Entity (Nod), U_Ent)
3099
              and then Sloc (U_Ent) < Sloc (Entity (Nod))
3100
            then
3101
               Error_Msg_NE
3102
                 ("invalid address clause for initialized object &!",
3103
                  Nod, U_Ent);
3104
               Error_Msg_Node_2 := U_Ent;
3105
               Error_Msg_NE
3106
                 ("\& must be defined before & (RM 13.1(22))!",
3107
                  Nod, Entity (Nod));
3108
            end if;
3109
 
3110
         elsif Nkind (Nod) = N_Selected_Component then
3111
            declare
3112
               T : constant Entity_Id := Etype (Prefix (Nod));
3113
 
3114
            begin
3115
               if (Is_Record_Type (T)
3116
                    and then Has_Discriminants (T))
3117
                 or else
3118
                  (Is_Access_Type (T)
3119
                     and then Is_Record_Type (Designated_Type (T))
3120
                     and then Has_Discriminants (Designated_Type (T)))
3121
               then
3122
                  Error_Msg_NE
3123
                    ("invalid address clause for initialized object &!",
3124
                     Nod, U_Ent);
3125
                  Error_Msg_N
3126
                    ("\address cannot depend on component" &
3127
                     " of discriminated record (RM 13.1(22))!",
3128
                     Nod);
3129
               else
3130
                  Check_At_Constant_Address (Prefix (Nod));
3131
               end if;
3132
            end;
3133
 
3134
         elsif Nkind (Nod) = N_Indexed_Component then
3135
            Check_At_Constant_Address (Prefix (Nod));
3136
            Check_List_Constants (Expressions (Nod));
3137
 
3138
         else
3139
            Check_Expr_Constants (Nod);
3140
         end if;
3141
      end Check_At_Constant_Address;
3142
 
3143
      --------------------------
3144
      -- Check_Expr_Constants --
3145
      --------------------------
3146
 
3147
      procedure Check_Expr_Constants (Nod : Node_Id) is
3148
         Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent);
3149
         Ent       : Entity_Id           := Empty;
3150
 
3151
      begin
3152
         if Nkind (Nod) in N_Has_Etype
3153
           and then Etype (Nod) = Any_Type
3154
         then
3155
            return;
3156
         end if;
3157
 
3158
         case Nkind (Nod) is
3159
            when N_Empty | N_Error =>
3160
               return;
3161
 
3162
            when N_Identifier | N_Expanded_Name =>
3163
               Ent := Entity (Nod);
3164
 
3165
               --  We need to look at the original node if it is different
3166
               --  from the node, since we may have rewritten things and
3167
               --  substituted an identifier representing the rewrite.
3168
 
3169
               if Original_Node (Nod) /= Nod then
3170
                  Check_Expr_Constants (Original_Node (Nod));
3171
 
3172
                  --  If the node is an object declaration without initial
3173
                  --  value, some code has been expanded, and the expression
3174
                  --  is not constant, even if the constituents might be
3175
                  --  acceptable, as in A'Address + offset.
3176
 
3177
                  if Ekind (Ent) = E_Variable
3178
                    and then
3179
                      Nkind (Declaration_Node (Ent)) = N_Object_Declaration
3180
                    and then
3181
                      No (Expression (Declaration_Node (Ent)))
3182
                  then
3183
                     Error_Msg_NE
3184
                       ("invalid address clause for initialized object &!",
3185
                        Nod, U_Ent);
3186
 
3187
                  --  If entity is constant, it may be the result of expanding
3188
                  --  a check. We must verify that its declaration appears
3189
                  --  before the object in question, else we also reject the
3190
                  --  address clause.
3191
 
3192
                  elsif Ekind (Ent) = E_Constant
3193
                    and then In_Same_Source_Unit (Ent, U_Ent)
3194
                    and then Sloc (Ent) > Loc_U_Ent
3195
                  then
3196
                     Error_Msg_NE
3197
                       ("invalid address clause for initialized object &!",
3198
                        Nod, U_Ent);
3199
                  end if;
3200
 
3201
                  return;
3202
               end if;
3203
 
3204
               --  Otherwise look at the identifier and see if it is OK
3205
 
3206
               if Ekind (Ent) = E_Named_Integer
3207
                    or else
3208
                  Ekind (Ent) = E_Named_Real
3209
                    or else
3210
                  Is_Type (Ent)
3211
               then
3212
                  return;
3213
 
3214
               elsif
3215
                  Ekind (Ent) = E_Constant
3216
                    or else
3217
                  Ekind (Ent) = E_In_Parameter
3218
               then
3219
                  --  This is the case where we must have Ent defined before
3220
                  --  U_Ent. Clearly if they are in different units this
3221
                  --  requirement is met since the unit containing Ent is
3222
                  --  already processed.
3223
 
3224
                  if not In_Same_Source_Unit (Ent, U_Ent) then
3225
                     return;
3226
 
3227
                  --  Otherwise location of Ent must be before the location
3228
                  --  of U_Ent, that's what prior defined means.
3229
 
3230
                  elsif Sloc (Ent) < Loc_U_Ent then
3231
                     return;
3232
 
3233
                  else
3234
                     Error_Msg_NE
3235
                       ("invalid address clause for initialized object &!",
3236
                        Nod, U_Ent);
3237
                     Error_Msg_Node_2 := U_Ent;
3238
                     Error_Msg_NE
3239
                       ("\& must be defined before & (RM 13.1(22))!",
3240
                        Nod, Ent);
3241
                  end if;
3242
 
3243
               elsif Nkind (Original_Node (Nod)) = N_Function_Call then
3244
                  Check_Expr_Constants (Original_Node (Nod));
3245
 
3246
               else
3247
                  Error_Msg_NE
3248
                    ("invalid address clause for initialized object &!",
3249
                     Nod, U_Ent);
3250
 
3251
                  if Comes_From_Source (Ent) then
3252
                     Error_Msg_NE
3253
                       ("\reference to variable& not allowed"
3254
                          & " (RM 13.1(22))!", Nod, Ent);
3255
                  else
3256
                     Error_Msg_N
3257
                       ("non-static expression not allowed"
3258
                          & " (RM 13.1(22))!", Nod);
3259
                  end if;
3260
               end if;
3261
 
3262
            when N_Integer_Literal   =>
3263
 
3264
               --  If this is a rewritten unchecked conversion, in a system
3265
               --  where Address is an integer type, always use the base type
3266
               --  for a literal value. This is user-friendly and prevents
3267
               --  order-of-elaboration issues with instances of unchecked
3268
               --  conversion.
3269
 
3270
               if Nkind (Original_Node (Nod)) = N_Function_Call then
3271
                  Set_Etype (Nod, Base_Type (Etype (Nod)));
3272
               end if;
3273
 
3274
            when N_Real_Literal      |
3275
                 N_String_Literal    |
3276
                 N_Character_Literal =>
3277
               return;
3278
 
3279
            when N_Range =>
3280
               Check_Expr_Constants (Low_Bound (Nod));
3281
               Check_Expr_Constants (High_Bound (Nod));
3282
 
3283
            when N_Explicit_Dereference =>
3284
               Check_Expr_Constants (Prefix (Nod));
3285
 
3286
            when N_Indexed_Component =>
3287
               Check_Expr_Constants (Prefix (Nod));
3288
               Check_List_Constants (Expressions (Nod));
3289
 
3290
            when N_Slice =>
3291
               Check_Expr_Constants (Prefix (Nod));
3292
               Check_Expr_Constants (Discrete_Range (Nod));
3293
 
3294
            when N_Selected_Component =>
3295
               Check_Expr_Constants (Prefix (Nod));
3296
 
3297
            when N_Attribute_Reference =>
3298
               if Attribute_Name (Nod) = Name_Address
3299
                   or else
3300
                  Attribute_Name (Nod) = Name_Access
3301
                    or else
3302
                  Attribute_Name (Nod) = Name_Unchecked_Access
3303
                    or else
3304
                  Attribute_Name (Nod) = Name_Unrestricted_Access
3305
               then
3306
                  Check_At_Constant_Address (Prefix (Nod));
3307
 
3308
               else
3309
                  Check_Expr_Constants (Prefix (Nod));
3310
                  Check_List_Constants (Expressions (Nod));
3311
               end if;
3312
 
3313
            when N_Aggregate =>
3314
               Check_List_Constants (Component_Associations (Nod));
3315
               Check_List_Constants (Expressions (Nod));
3316
 
3317
            when N_Component_Association =>
3318
               Check_Expr_Constants (Expression (Nod));
3319
 
3320
            when N_Extension_Aggregate =>
3321
               Check_Expr_Constants (Ancestor_Part (Nod));
3322
               Check_List_Constants (Component_Associations (Nod));
3323
               Check_List_Constants (Expressions (Nod));
3324
 
3325
            when N_Null =>
3326
               return;
3327
 
3328
            when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
3329
               Check_Expr_Constants (Left_Opnd (Nod));
3330
               Check_Expr_Constants (Right_Opnd (Nod));
3331
 
3332
            when N_Unary_Op =>
3333
               Check_Expr_Constants (Right_Opnd (Nod));
3334
 
3335
            when N_Type_Conversion           |
3336
                 N_Qualified_Expression      |
3337
                 N_Allocator                 =>
3338
               Check_Expr_Constants (Expression (Nod));
3339
 
3340
            when N_Unchecked_Type_Conversion =>
3341
               Check_Expr_Constants (Expression (Nod));
3342
 
3343
               --  If this is a rewritten unchecked conversion, subtypes in
3344
               --  this node are those created within the instance. To avoid
3345
               --  order of elaboration issues, replace them with their base
3346
               --  types. Note that address clauses can cause order of
3347
               --  elaboration problems because they are elaborated by the
3348
               --  back-end at the point of definition, and may mention
3349
               --  entities declared in between (as long as everything is
3350
               --  static). It is user-friendly to allow unchecked conversions
3351
               --  in this context.
3352
 
3353
               if Nkind (Original_Node (Nod)) = N_Function_Call then
3354
                  Set_Etype (Expression (Nod),
3355
                    Base_Type (Etype (Expression (Nod))));
3356
                  Set_Etype (Nod, Base_Type (Etype (Nod)));
3357
               end if;
3358
 
3359
            when N_Function_Call =>
3360
               if not Is_Pure (Entity (Name (Nod))) then
3361
                  Error_Msg_NE
3362
                    ("invalid address clause for initialized object &!",
3363
                     Nod, U_Ent);
3364
 
3365
                  Error_Msg_NE
3366
                    ("\function & is not pure (RM 13.1(22))!",
3367
                     Nod, Entity (Name (Nod)));
3368
 
3369
               else
3370
                  Check_List_Constants (Parameter_Associations (Nod));
3371
               end if;
3372
 
3373
            when N_Parameter_Association =>
3374
               Check_Expr_Constants (Explicit_Actual_Parameter (Nod));
3375
 
3376
            when others =>
3377
               Error_Msg_NE
3378
                 ("invalid address clause for initialized object &!",
3379
                  Nod, U_Ent);
3380
               Error_Msg_NE
3381
                 ("\must be constant defined before& (RM 13.1(22))!",
3382
                  Nod, U_Ent);
3383
         end case;
3384
      end Check_Expr_Constants;
3385
 
3386
      --------------------------
3387
      -- Check_List_Constants --
3388
      --------------------------
3389
 
3390
      procedure Check_List_Constants (Lst : List_Id) is
3391
         Nod1 : Node_Id;
3392
 
3393
      begin
3394
         if Present (Lst) then
3395
            Nod1 := First (Lst);
3396
            while Present (Nod1) loop
3397
               Check_Expr_Constants (Nod1);
3398
               Next (Nod1);
3399
            end loop;
3400
         end if;
3401
      end Check_List_Constants;
3402
 
3403
   --  Start of processing for Check_Constant_Address_Clause
3404
 
3405
   begin
3406
      Check_Expr_Constants (Expr);
3407
   end Check_Constant_Address_Clause;
3408
 
3409
   ----------------
3410
   -- Check_Size --
3411
   ----------------
3412
 
3413
   procedure Check_Size
3414
     (N      : Node_Id;
3415
      T      : Entity_Id;
3416
      Siz    : Uint;
3417
      Biased : out Boolean)
3418
   is
3419
      UT : constant Entity_Id := Underlying_Type (T);
3420
      M  : Uint;
3421
 
3422
   begin
3423
      Biased := False;
3424
 
3425
      --  Dismiss cases for generic types or types with previous errors
3426
 
3427
      if No (UT)
3428
        or else UT = Any_Type
3429
        or else Is_Generic_Type (UT)
3430
        or else Is_Generic_Type (Root_Type (UT))
3431
      then
3432
         return;
3433
 
3434
      --  Check case of bit packed array
3435
 
3436
      elsif Is_Array_Type (UT)
3437
        and then Known_Static_Component_Size (UT)
3438
        and then Is_Bit_Packed_Array (UT)
3439
      then
3440
         declare
3441
            Asiz : Uint;
3442
            Indx : Node_Id;
3443
            Ityp : Entity_Id;
3444
 
3445
         begin
3446
            Asiz := Component_Size (UT);
3447
            Indx := First_Index (UT);
3448
            loop
3449
               Ityp := Etype (Indx);
3450
 
3451
               --  If non-static bound, then we are not in the business of
3452
               --  trying to check the length, and indeed an error will be
3453
               --  issued elsewhere, since sizes of non-static array types
3454
               --  cannot be set implicitly or explicitly.
3455
 
3456
               if not Is_Static_Subtype (Ityp) then
3457
                  return;
3458
               end if;
3459
 
3460
               --  Otherwise accumulate next dimension
3461
 
3462
               Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) -
3463
                               Expr_Value (Type_Low_Bound  (Ityp)) +
3464
                               Uint_1);
3465
 
3466
               Next_Index (Indx);
3467
               exit when No (Indx);
3468
            end loop;
3469
 
3470
            if Asiz <= Siz then
3471
               return;
3472
            else
3473
               Error_Msg_Uint_1 := Asiz;
3474
               Error_Msg_NE
3475
                 ("size for& too small, minimum allowed is ^", N, T);
3476
               Set_Esize   (T, Asiz);
3477
               Set_RM_Size (T, Asiz);
3478
            end if;
3479
         end;
3480
 
3481
      --  All other composite types are ignored
3482
 
3483
      elsif Is_Composite_Type (UT) then
3484
         return;
3485
 
3486
      --  For fixed-point types, don't check minimum if type is not frozen,
3487
      --  since we don't know all the characteristics of the type that can
3488
      --  affect the size (e.g. a specified small) till freeze time.
3489
 
3490
      elsif Is_Fixed_Point_Type (UT)
3491
        and then not Is_Frozen (UT)
3492
      then
3493
         null;
3494
 
3495
      --  Cases for which a minimum check is required
3496
 
3497
      else
3498
         --  Ignore if specified size is correct for the type
3499
 
3500
         if Known_Esize (UT) and then Siz = Esize (UT) then
3501
            return;
3502
         end if;
3503
 
3504
         --  Otherwise get minimum size
3505
 
3506
         M := UI_From_Int (Minimum_Size (UT));
3507
 
3508
         if Siz < M then
3509
 
3510
            --  Size is less than minimum size, but one possibility remains
3511
            --  that we can manage with the new size if we bias the type.
3512
 
3513
            M := UI_From_Int (Minimum_Size (UT, Biased => True));
3514
 
3515
            if Siz < M then
3516
               Error_Msg_Uint_1 := M;
3517
               Error_Msg_NE
3518
                 ("size for& too small, minimum allowed is ^", N, T);
3519
               Set_Esize (T, M);
3520
               Set_RM_Size (T, M);
3521
            else
3522
               Biased := True;
3523
            end if;
3524
         end if;
3525
      end if;
3526
   end Check_Size;
3527
 
3528
   -------------------------
3529
   -- Get_Alignment_Value --
3530
   -------------------------
3531
 
3532
   function Get_Alignment_Value (Expr : Node_Id) return Uint is
3533
      Align : constant Uint := Static_Integer (Expr);
3534
 
3535
   begin
3536
      if Align = No_Uint then
3537
         return No_Uint;
3538
 
3539
      elsif Align <= 0 then
3540
         Error_Msg_N ("alignment value must be positive", Expr);
3541
         return No_Uint;
3542
 
3543
      else
3544
         for J in Int range 0 .. 64 loop
3545
            declare
3546
               M : constant Uint := Uint_2 ** J;
3547
 
3548
            begin
3549
               exit when M = Align;
3550
 
3551
               if M > Align then
3552
                  Error_Msg_N
3553
                    ("alignment value must be power of 2", Expr);
3554
                  return No_Uint;
3555
               end if;
3556
            end;
3557
         end loop;
3558
 
3559
         return Align;
3560
      end if;
3561
   end Get_Alignment_Value;
3562
 
3563
   ----------------
3564
   -- Initialize --
3565
   ----------------
3566
 
3567
   procedure Initialize is
3568
   begin
3569
      Unchecked_Conversions.Init;
3570
   end Initialize;
3571
 
3572
   -------------------------
3573
   -- Is_Operational_Item --
3574
   -------------------------
3575
 
3576
   function Is_Operational_Item (N : Node_Id) return Boolean is
3577
   begin
3578
      if Nkind (N) /= N_Attribute_Definition_Clause then
3579
         return False;
3580
      else
3581
         declare
3582
            Id    : constant Attribute_Id := Get_Attribute_Id (Chars (N));
3583
         begin
3584
            return   Id = Attribute_Input
3585
              or else Id = Attribute_Output
3586
              or else Id = Attribute_Read
3587
              or else Id = Attribute_Write
3588
              or else Id = Attribute_External_Tag;
3589
         end;
3590
      end if;
3591
   end Is_Operational_Item;
3592
 
3593
   ------------------
3594
   -- Minimum_Size --
3595
   ------------------
3596
 
3597
   function Minimum_Size
3598
     (T      : Entity_Id;
3599
      Biased : Boolean := False) return Nat
3600
   is
3601
      Lo     : Uint    := No_Uint;
3602
      Hi     : Uint    := No_Uint;
3603
      LoR    : Ureal   := No_Ureal;
3604
      HiR    : Ureal   := No_Ureal;
3605
      LoSet  : Boolean := False;
3606
      HiSet  : Boolean := False;
3607
      B      : Uint;
3608
      S      : Nat;
3609
      Ancest : Entity_Id;
3610
      R_Typ  : constant Entity_Id := Root_Type (T);
3611
 
3612
   begin
3613
      --  If bad type, return 0
3614
 
3615
      if T = Any_Type then
3616
         return 0;
3617
 
3618
      --  For generic types, just return zero. There cannot be any legitimate
3619
      --  need to know such a size, but this routine may be called with a
3620
      --  generic type as part of normal processing.
3621
 
3622
      elsif Is_Generic_Type (R_Typ)
3623
        or else R_Typ = Any_Type
3624
      then
3625
         return 0;
3626
 
3627
         --  Access types. Normally an access type cannot have a size smaller
3628
         --  than the size of System.Address. The exception is on VMS, where
3629
         --  we have short and long addresses, and it is possible for an access
3630
         --  type to have a short address size (and thus be less than the size
3631
         --  of System.Address itself). We simply skip the check for VMS, and
3632
         --  leave it to the back end to do the check.
3633
 
3634
      elsif Is_Access_Type (T) then
3635
         if OpenVMS_On_Target then
3636
            return 0;
3637
         else
3638
            return System_Address_Size;
3639
         end if;
3640
 
3641
      --  Floating-point types
3642
 
3643
      elsif Is_Floating_Point_Type (T) then
3644
         return UI_To_Int (Esize (R_Typ));
3645
 
3646
      --  Discrete types
3647
 
3648
      elsif Is_Discrete_Type (T) then
3649
 
3650
         --  The following loop is looking for the nearest compile time known
3651
         --  bounds following the ancestor subtype chain. The idea is to find
3652
         --  the most restrictive known bounds information.
3653
 
3654
         Ancest := T;
3655
         loop
3656
            if Ancest = Any_Type or else Etype (Ancest) = Any_Type then
3657
               return 0;
3658
            end if;
3659
 
3660
            if not LoSet then
3661
               if Compile_Time_Known_Value (Type_Low_Bound (Ancest)) then
3662
                  Lo := Expr_Rep_Value (Type_Low_Bound (Ancest));
3663
                  LoSet := True;
3664
                  exit when HiSet;
3665
               end if;
3666
            end if;
3667
 
3668
            if not HiSet then
3669
               if Compile_Time_Known_Value (Type_High_Bound (Ancest)) then
3670
                  Hi := Expr_Rep_Value (Type_High_Bound (Ancest));
3671
                  HiSet := True;
3672
                  exit when LoSet;
3673
               end if;
3674
            end if;
3675
 
3676
            Ancest := Ancestor_Subtype (Ancest);
3677
 
3678
            if No (Ancest) then
3679
               Ancest := Base_Type (T);
3680
 
3681
               if Is_Generic_Type (Ancest) then
3682
                  return 0;
3683
               end if;
3684
            end if;
3685
         end loop;
3686
 
3687
      --  Fixed-point types. We can't simply use Expr_Value to get the
3688
      --  Corresponding_Integer_Value values of the bounds, since these do not
3689
      --  get set till the type is frozen, and this routine can be called
3690
      --  before the type is frozen. Similarly the test for bounds being static
3691
      --  needs to include the case where we have unanalyzed real literals for
3692
      --  the same reason.
3693
 
3694
      elsif Is_Fixed_Point_Type (T) then
3695
 
3696
         --  The following loop is looking for the nearest compile time known
3697
         --  bounds following the ancestor subtype chain. The idea is to find
3698
         --  the most restrictive known bounds information.
3699
 
3700
         Ancest := T;
3701
         loop
3702
            if Ancest = Any_Type or else Etype (Ancest) = Any_Type then
3703
               return 0;
3704
            end if;
3705
 
3706
            --  Note: In the following two tests for LoSet and HiSet, it may
3707
            --  seem redundant to test for N_Real_Literal here since normally
3708
            --  one would assume that the test for the value being known at
3709
            --  compile time includes this case. However, there is a glitch.
3710
            --  If the real literal comes from folding a non-static expression,
3711
            --  then we don't consider any non- static expression to be known
3712
            --  at compile time if we are in configurable run time mode (needed
3713
            --  in some cases to give a clearer definition of what is and what
3714
            --  is not accepted). So the test is indeed needed. Without it, we
3715
            --  would set neither Lo_Set nor Hi_Set and get an infinite loop.
3716
 
3717
            if not LoSet then
3718
               if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal
3719
                 or else Compile_Time_Known_Value (Type_Low_Bound (Ancest))
3720
               then
3721
                  LoR := Expr_Value_R (Type_Low_Bound (Ancest));
3722
                  LoSet := True;
3723
                  exit when HiSet;
3724
               end if;
3725
            end if;
3726
 
3727
            if not HiSet then
3728
               if Nkind (Type_High_Bound (Ancest)) = N_Real_Literal
3729
                 or else Compile_Time_Known_Value (Type_High_Bound (Ancest))
3730
               then
3731
                  HiR := Expr_Value_R (Type_High_Bound (Ancest));
3732
                  HiSet := True;
3733
                  exit when LoSet;
3734
               end if;
3735
            end if;
3736
 
3737
            Ancest := Ancestor_Subtype (Ancest);
3738
 
3739
            if No (Ancest) then
3740
               Ancest := Base_Type (T);
3741
 
3742
               if Is_Generic_Type (Ancest) then
3743
                  return 0;
3744
               end if;
3745
            end if;
3746
         end loop;
3747
 
3748
         Lo := UR_To_Uint (LoR / Small_Value (T));
3749
         Hi := UR_To_Uint (HiR / Small_Value (T));
3750
 
3751
      --  No other types allowed
3752
 
3753
      else
3754
         raise Program_Error;
3755
      end if;
3756
 
3757
      --  Fall through with Hi and Lo set. Deal with biased case
3758
 
3759
      if (Biased
3760
           and then not Is_Fixed_Point_Type (T)
3761
           and then not (Is_Enumeration_Type (T)
3762
                          and then Has_Non_Standard_Rep (T)))
3763
        or else Has_Biased_Representation (T)
3764
      then
3765
         Hi := Hi - Lo;
3766
         Lo := Uint_0;
3767
      end if;
3768
 
3769
      --  Signed case. Note that we consider types like range 1 .. -1 to be
3770
      --  signed for the purpose of computing the size, since the bounds have
3771
      --  to be accommodated in the base type.
3772
 
3773
      if Lo < 0 or else Hi < 0 then
3774
         S := 1;
3775
         B := Uint_1;
3776
 
3777
         --  S = size, B = 2 ** (size - 1) (can accommodate -B .. +(B - 1))
3778
         --  Note that we accommodate the case where the bounds cross. This
3779
         --  can happen either because of the way the bounds are declared
3780
         --  or because of the algorithm in Freeze_Fixed_Point_Type.
3781
 
3782
         while Lo < -B
3783
           or else Hi < -B
3784
           or else Lo >= B
3785
           or else Hi >= B
3786
         loop
3787
            B := Uint_2 ** S;
3788
            S := S + 1;
3789
         end loop;
3790
 
3791
      --  Unsigned case
3792
 
3793
      else
3794
         --  If both bounds are positive, make sure that both are represen-
3795
         --  table in the case where the bounds are crossed. This can happen
3796
         --  either because of the way the bounds are declared, or because of
3797
         --  the algorithm in Freeze_Fixed_Point_Type.
3798
 
3799
         if Lo > Hi then
3800
            Hi := Lo;
3801
         end if;
3802
 
3803
         --  S = size, (can accommodate 0 .. (2**size - 1))
3804
 
3805
         S := 0;
3806
         while Hi >= Uint_2 ** S loop
3807
            S := S + 1;
3808
         end loop;
3809
      end if;
3810
 
3811
      return S;
3812
   end Minimum_Size;
3813
 
3814
   ---------------------------
3815
   -- New_Stream_Subprogram --
3816
   ---------------------------
3817
 
3818
   procedure New_Stream_Subprogram
3819
     (N     : Node_Id;
3820
      Ent   : Entity_Id;
3821
      Subp  : Entity_Id;
3822
      Nam   : TSS_Name_Type)
3823
   is
3824
      Loc       : constant Source_Ptr := Sloc (N);
3825
      Sname     : constant Name_Id    := Make_TSS_Name (Base_Type (Ent), Nam);
3826
      Subp_Id   : Entity_Id;
3827
      Subp_Decl : Node_Id;
3828
      F         : Entity_Id;
3829
      Etyp      : Entity_Id;
3830
 
3831
      Defer_Declaration : constant Boolean :=
3832
                            Is_Tagged_Type (Ent) or else Is_Private_Type (Ent);
3833
      --  For a tagged type, there is a declaration for each stream attribute
3834
      --  at the freeze point, and we must generate only a completion of this
3835
      --  declaration. We do the same for private types, because the full view
3836
      --  might be tagged. Otherwise we generate a declaration at the point of
3837
      --  the attribute definition clause.
3838
 
3839
      function Build_Spec return Node_Id;
3840
      --  Used for declaration and renaming declaration, so that this is
3841
      --  treated as a renaming_as_body.
3842
 
3843
      ----------------
3844
      -- Build_Spec --
3845
      ----------------
3846
 
3847
      function Build_Spec return Node_Id is
3848
         Out_P   : constant Boolean := (Nam = TSS_Stream_Read);
3849
         Formals : List_Id;
3850
         Spec    : Node_Id;
3851
         T_Ref   : constant Node_Id := New_Reference_To (Etyp, Loc);
3852
 
3853
      begin
3854
         Subp_Id := Make_Defining_Identifier (Loc, Sname);
3855
 
3856
         --  S : access Root_Stream_Type'Class
3857
 
3858
         Formals := New_List (
3859
                      Make_Parameter_Specification (Loc,
3860
                        Defining_Identifier =>
3861
                          Make_Defining_Identifier (Loc, Name_S),
3862
                        Parameter_Type =>
3863
                          Make_Access_Definition (Loc,
3864
                            Subtype_Mark =>
3865
                              New_Reference_To (
3866
                                Designated_Type (Etype (F)), Loc))));
3867
 
3868
         if Nam = TSS_Stream_Input then
3869
            Spec := Make_Function_Specification (Loc,
3870
                      Defining_Unit_Name       => Subp_Id,
3871
                      Parameter_Specifications => Formals,
3872
                      Result_Definition        => T_Ref);
3873
         else
3874
            --  V : [out] T
3875
 
3876
            Append_To (Formals,
3877
              Make_Parameter_Specification (Loc,
3878
                Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
3879
                Out_Present         => Out_P,
3880
                Parameter_Type      => T_Ref));
3881
 
3882
            Spec := Make_Procedure_Specification (Loc,
3883
                      Defining_Unit_Name       => Subp_Id,
3884
                      Parameter_Specifications => Formals);
3885
         end if;
3886
 
3887
         return Spec;
3888
      end Build_Spec;
3889
 
3890
   --  Start of processing for New_Stream_Subprogram
3891
 
3892
   begin
3893
      F := First_Formal (Subp);
3894
 
3895
      if Ekind (Subp) = E_Procedure then
3896
         Etyp := Etype (Next_Formal (F));
3897
      else
3898
         Etyp := Etype (Subp);
3899
      end if;
3900
 
3901
      --  Prepare subprogram declaration and insert it as an action on the
3902
      --  clause node. The visibility for this entity is used to test for
3903
      --  visibility of the attribute definition clause (in the sense of
3904
      --  8.3(23) as amended by AI-195).
3905
 
3906
      if not Defer_Declaration then
3907
         Subp_Decl :=
3908
           Make_Subprogram_Declaration (Loc,
3909
             Specification => Build_Spec);
3910
 
3911
      --  For a tagged type, there is always a visible declaration for each
3912
      --  stream TSS (it is a predefined primitive operation), and the
3913
      --  completion of this declaration occurs at the freeze point, which is
3914
      --  not always visible at places where the attribute definition clause is
3915
      --  visible. So, we create a dummy entity here for the purpose of
3916
      --  tracking the visibility of the attribute definition clause itself.
3917
 
3918
      else
3919
         Subp_Id :=
3920
           Make_Defining_Identifier (Loc,
3921
             Chars => New_External_Name (Sname, 'V'));
3922
         Subp_Decl :=
3923
           Make_Object_Declaration (Loc,
3924
             Defining_Identifier => Subp_Id,
3925
             Object_Definition   => New_Occurrence_Of (Standard_Boolean, Loc));
3926
      end if;
3927
 
3928
      Insert_Action (N, Subp_Decl);
3929
      Set_Entity (N, Subp_Id);
3930
 
3931
      Subp_Decl :=
3932
        Make_Subprogram_Renaming_Declaration (Loc,
3933
          Specification => Build_Spec,
3934
          Name => New_Reference_To (Subp, Loc));
3935
 
3936
      if Defer_Declaration then
3937
         Set_TSS (Base_Type (Ent), Subp_Id);
3938
      else
3939
         Insert_Action (N, Subp_Decl);
3940
         Copy_TSS (Subp_Id, Base_Type (Ent));
3941
      end if;
3942
   end New_Stream_Subprogram;
3943
 
3944
   ------------------------
3945
   -- Rep_Item_Too_Early --
3946
   ------------------------
3947
 
3948
   function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is
3949
   begin
3950
      --  Cannot apply non-operational rep items to generic types
3951
 
3952
      if Is_Operational_Item (N) then
3953
         return False;
3954
 
3955
      elsif Is_Type (T)
3956
        and then Is_Generic_Type (Root_Type (T))
3957
      then
3958
         Error_Msg_N
3959
           ("representation item not allowed for generic type", N);
3960
         return True;
3961
      end if;
3962
 
3963
      --  Otherwise check for incomplete type
3964
 
3965
      if Is_Incomplete_Or_Private_Type (T)
3966
        and then No (Underlying_Type (T))
3967
      then
3968
         Error_Msg_N
3969
           ("representation item must be after full type declaration", N);
3970
         return True;
3971
 
3972
      --  If the type has incomplete components, a representation clause is
3973
      --  illegal but stream attributes and Convention pragmas are correct.
3974
 
3975
      elsif Has_Private_Component (T) then
3976
         if Nkind (N) = N_Pragma then
3977
            return False;
3978
         else
3979
            Error_Msg_N
3980
              ("representation item must appear after type is fully defined",
3981
                N);
3982
            return True;
3983
         end if;
3984
      else
3985
         return False;
3986
      end if;
3987
   end Rep_Item_Too_Early;
3988
 
3989
   -----------------------
3990
   -- Rep_Item_Too_Late --
3991
   -----------------------
3992
 
3993
   function Rep_Item_Too_Late
3994
     (T     : Entity_Id;
3995
      N     : Node_Id;
3996
      FOnly : Boolean := False) return Boolean
3997
   is
3998
      S           : Entity_Id;
3999
      Parent_Type : Entity_Id;
4000
 
4001
      procedure Too_Late;
4002
      --  Output the too late message. Note that this is not considered a
4003
      --  serious error, since the effect is simply that we ignore the
4004
      --  representation clause in this case.
4005
 
4006
      --------------
4007
      -- Too_Late --
4008
      --------------
4009
 
4010
      procedure Too_Late is
4011
      begin
4012
         Error_Msg_N ("|representation item appears too late!", N);
4013
      end Too_Late;
4014
 
4015
   --  Start of processing for Rep_Item_Too_Late
4016
 
4017
   begin
4018
      --  First make sure entity is not frozen (RM 13.1(9)). Exclude imported
4019
      --  types, which may be frozen if they appear in a representation clause
4020
      --  for a local type.
4021
 
4022
      if Is_Frozen (T)
4023
        and then not From_With_Type (T)
4024
      then
4025
         Too_Late;
4026
         S := First_Subtype (T);
4027
 
4028
         if Present (Freeze_Node (S)) then
4029
            Error_Msg_NE
4030
              ("?no more representation items for }", Freeze_Node (S), S);
4031
         end if;
4032
 
4033
         return True;
4034
 
4035
      --  Check for case of non-tagged derived type whose parent either has
4036
      --  primitive operations, or is a by reference type (RM 13.1(10)).
4037
 
4038
      elsif Is_Type (T)
4039
        and then not FOnly
4040
        and then Is_Derived_Type (T)
4041
        and then not Is_Tagged_Type (T)
4042
      then
4043
         Parent_Type := Etype (Base_Type (T));
4044
 
4045
         if Has_Primitive_Operations (Parent_Type) then
4046
            Too_Late;
4047
            Error_Msg_NE
4048
              ("primitive operations already defined for&!", N, Parent_Type);
4049
            return True;
4050
 
4051
         elsif Is_By_Reference_Type (Parent_Type) then
4052
            Too_Late;
4053
            Error_Msg_NE
4054
              ("parent type & is a by reference type!", N, Parent_Type);
4055
            return True;
4056
         end if;
4057
      end if;
4058
 
4059
      --  No error, link item into head of chain of rep items for the entity,
4060
      --  but avoid chaining if we have an overloadable entity, and the pragma
4061
      --  is one that can apply to multiple overloaded entities.
4062
 
4063
      if Is_Overloadable (T)
4064
        and then Nkind (N) = N_Pragma
4065
      then
4066
         declare
4067
            Pname : constant Name_Id := Pragma_Name (N);
4068
         begin
4069
            if Pname = Name_Convention or else
4070
               Pname = Name_Import     or else
4071
               Pname = Name_Export     or else
4072
               Pname = Name_External   or else
4073
               Pname = Name_Interface
4074
            then
4075
               return False;
4076
            end if;
4077
         end;
4078
      end if;
4079
 
4080
      Record_Rep_Item (T, N);
4081
      return False;
4082
   end Rep_Item_Too_Late;
4083
 
4084
   -------------------------
4085
   -- Same_Representation --
4086
   -------------------------
4087
 
4088
   function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is
4089
      T1 : constant Entity_Id := Underlying_Type (Typ1);
4090
      T2 : constant Entity_Id := Underlying_Type (Typ2);
4091
 
4092
   begin
4093
      --  A quick check, if base types are the same, then we definitely have
4094
      --  the same representation, because the subtype specific representation
4095
      --  attributes (Size and Alignment) do not affect representation from
4096
      --  the point of view of this test.
4097
 
4098
      if Base_Type (T1) = Base_Type (T2) then
4099
         return True;
4100
 
4101
      elsif Is_Private_Type (Base_Type (T2))
4102
        and then Base_Type (T1) = Full_View (Base_Type (T2))
4103
      then
4104
         return True;
4105
      end if;
4106
 
4107
      --  Tagged types never have differing representations
4108
 
4109
      if Is_Tagged_Type (T1) then
4110
         return True;
4111
      end if;
4112
 
4113
      --  Representations are definitely different if conventions differ
4114
 
4115
      if Convention (T1) /= Convention (T2) then
4116
         return False;
4117
      end if;
4118
 
4119
      --  Representations are different if component alignments differ
4120
 
4121
      if (Is_Record_Type (T1) or else Is_Array_Type (T1))
4122
        and then
4123
         (Is_Record_Type (T2) or else Is_Array_Type (T2))
4124
        and then Component_Alignment (T1) /= Component_Alignment (T2)
4125
      then
4126
         return False;
4127
      end if;
4128
 
4129
      --  For arrays, the only real issue is component size. If we know the
4130
      --  component size for both arrays, and it is the same, then that's
4131
      --  good enough to know we don't have a change of representation.
4132
 
4133
      if Is_Array_Type (T1) then
4134
         if Known_Component_Size (T1)
4135
           and then Known_Component_Size (T2)
4136
           and then Component_Size (T1) = Component_Size (T2)
4137
         then
4138
            return True;
4139
         end if;
4140
      end if;
4141
 
4142
      --  Types definitely have same representation if neither has non-standard
4143
      --  representation since default representations are always consistent.
4144
      --  If only one has non-standard representation, and the other does not,
4145
      --  then we consider that they do not have the same representation. They
4146
      --  might, but there is no way of telling early enough.
4147
 
4148
      if Has_Non_Standard_Rep (T1) then
4149
         if not Has_Non_Standard_Rep (T2) then
4150
            return False;
4151
         end if;
4152
      else
4153
         return not Has_Non_Standard_Rep (T2);
4154
      end if;
4155
 
4156
      --  Here the two types both have non-standard representation, and we need
4157
      --  to determine if they have the same non-standard representation.
4158
 
4159
      --  For arrays, we simply need to test if the component sizes are the
4160
      --  same. Pragma Pack is reflected in modified component sizes, so this
4161
      --  check also deals with pragma Pack.
4162
 
4163
      if Is_Array_Type (T1) then
4164
         return Component_Size (T1) = Component_Size (T2);
4165
 
4166
      --  Tagged types always have the same representation, because it is not
4167
      --  possible to specify different representations for common fields.
4168
 
4169
      elsif Is_Tagged_Type (T1) then
4170
         return True;
4171
 
4172
      --  Case of record types
4173
 
4174
      elsif Is_Record_Type (T1) then
4175
 
4176
         --  Packed status must conform
4177
 
4178
         if Is_Packed (T1) /= Is_Packed (T2) then
4179
            return False;
4180
 
4181
         --  Otherwise we must check components. Typ2 maybe a constrained
4182
         --  subtype with fewer components, so we compare the components
4183
         --  of the base types.
4184
 
4185
         else
4186
            Record_Case : declare
4187
               CD1, CD2 : Entity_Id;
4188
 
4189
               function Same_Rep return Boolean;
4190
               --  CD1 and CD2 are either components or discriminants. This
4191
               --  function tests whether the two have the same representation
4192
 
4193
               --------------
4194
               -- Same_Rep --
4195
               --------------
4196
 
4197
               function Same_Rep return Boolean is
4198
               begin
4199
                  if No (Component_Clause (CD1)) then
4200
                     return No (Component_Clause (CD2));
4201
 
4202
                  else
4203
                     return
4204
                        Present (Component_Clause (CD2))
4205
                          and then
4206
                        Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2)
4207
                          and then
4208
                        Esize (CD1) = Esize (CD2);
4209
                  end if;
4210
               end Same_Rep;
4211
 
4212
            --  Start of processing for Record_Case
4213
 
4214
            begin
4215
               if Has_Discriminants (T1) then
4216
                  CD1 := First_Discriminant (T1);
4217
                  CD2 := First_Discriminant (T2);
4218
 
4219
                  --  The number of discriminants may be different if the
4220
                  --  derived type has fewer (constrained by values). The
4221
                  --  invisible discriminants retain the representation of
4222
                  --  the original, so the discrepancy does not per se
4223
                  --  indicate a different representation.
4224
 
4225
                  while Present (CD1)
4226
                    and then Present (CD2)
4227
                  loop
4228
                     if not Same_Rep then
4229
                        return False;
4230
                     else
4231
                        Next_Discriminant (CD1);
4232
                        Next_Discriminant (CD2);
4233
                     end if;
4234
                  end loop;
4235
               end if;
4236
 
4237
               CD1 := First_Component (Underlying_Type (Base_Type (T1)));
4238
               CD2 := First_Component (Underlying_Type (Base_Type (T2)));
4239
 
4240
               while Present (CD1) loop
4241
                  if not Same_Rep then
4242
                     return False;
4243
                  else
4244
                     Next_Component (CD1);
4245
                     Next_Component (CD2);
4246
                  end if;
4247
               end loop;
4248
 
4249
               return True;
4250
            end Record_Case;
4251
         end if;
4252
 
4253
      --  For enumeration types, we must check each literal to see if the
4254
      --  representation is the same. Note that we do not permit enumeration
4255
      --  representation clauses for Character and Wide_Character, so these
4256
      --  cases were already dealt with.
4257
 
4258
      elsif Is_Enumeration_Type (T1) then
4259
 
4260
         Enumeration_Case : declare
4261
            L1, L2 : Entity_Id;
4262
 
4263
         begin
4264
            L1 := First_Literal (T1);
4265
            L2 := First_Literal (T2);
4266
 
4267
            while Present (L1) loop
4268
               if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then
4269
                  return False;
4270
               else
4271
                  Next_Literal (L1);
4272
                  Next_Literal (L2);
4273
               end if;
4274
            end loop;
4275
 
4276
            return True;
4277
 
4278
         end Enumeration_Case;
4279
 
4280
      --  Any other types have the same representation for these purposes
4281
 
4282
      else
4283
         return True;
4284
      end if;
4285
   end Same_Representation;
4286
 
4287
   --------------------
4288
   -- Set_Enum_Esize --
4289
   --------------------
4290
 
4291
   procedure Set_Enum_Esize (T : Entity_Id) is
4292
      Lo : Uint;
4293
      Hi : Uint;
4294
      Sz : Nat;
4295
 
4296
   begin
4297
      Init_Alignment (T);
4298
 
4299
      --  Find the minimum standard size (8,16,32,64) that fits
4300
 
4301
      Lo := Enumeration_Rep (Entity (Type_Low_Bound (T)));
4302
      Hi := Enumeration_Rep (Entity (Type_High_Bound (T)));
4303
 
4304
      if Lo < 0 then
4305
         if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then
4306
            Sz := Standard_Character_Size;  -- May be > 8 on some targets
4307
 
4308
         elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then
4309
            Sz := 16;
4310
 
4311
         elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then
4312
            Sz := 32;
4313
 
4314
         else pragma Assert (Lo >= -Uint_2**63 and then Hi < Uint_2**63);
4315
            Sz := 64;
4316
         end if;
4317
 
4318
      else
4319
         if Hi < Uint_2**08 then
4320
            Sz := Standard_Character_Size;  -- May be > 8 on some targets
4321
 
4322
         elsif Hi < Uint_2**16 then
4323
            Sz := 16;
4324
 
4325
         elsif Hi < Uint_2**32 then
4326
            Sz := 32;
4327
 
4328
         else pragma Assert (Hi < Uint_2**63);
4329
            Sz := 64;
4330
         end if;
4331
      end if;
4332
 
4333
      --  That minimum is the proper size unless we have a foreign convention
4334
      --  and the size required is 32 or less, in which case we bump the size
4335
      --  up to 32. This is required for C and C++ and seems reasonable for
4336
      --  all other foreign conventions.
4337
 
4338
      if Has_Foreign_Convention (T)
4339
        and then Esize (T) < Standard_Integer_Size
4340
      then
4341
         Init_Esize (T, Standard_Integer_Size);
4342
      else
4343
         Init_Esize (T, Sz);
4344
      end if;
4345
   end Set_Enum_Esize;
4346
 
4347
   ------------------------------
4348
   -- Validate_Address_Clauses --
4349
   ------------------------------
4350
 
4351
   procedure Validate_Address_Clauses is
4352
   begin
4353
      for J in Address_Clause_Checks.First .. Address_Clause_Checks.Last loop
4354
         declare
4355
            ACCR : Address_Clause_Check_Record
4356
                     renames Address_Clause_Checks.Table (J);
4357
 
4358
            Expr : Node_Id;
4359
 
4360
            X_Alignment : Uint;
4361
            Y_Alignment : Uint;
4362
 
4363
            X_Size : Uint;
4364
            Y_Size : Uint;
4365
 
4366
         begin
4367
            --  Skip processing of this entry if warning already posted
4368
 
4369
            if not Address_Warning_Posted (ACCR.N) then
4370
 
4371
               Expr := Original_Node (Expression (ACCR.N));
4372
 
4373
               --  Get alignments
4374
 
4375
               X_Alignment := Alignment (ACCR.X);
4376
               Y_Alignment := Alignment (ACCR.Y);
4377
 
4378
               --  Similarly obtain sizes
4379
 
4380
               X_Size := Esize (ACCR.X);
4381
               Y_Size := Esize (ACCR.Y);
4382
 
4383
               --  Check for large object overlaying smaller one
4384
 
4385
               if Y_Size > Uint_0
4386
                 and then X_Size > Uint_0
4387
                 and then X_Size > Y_Size
4388
               then
4389
                  Error_Msg_NE
4390
                    ("?& overlays smaller object", ACCR.N, ACCR.X);
4391
                  Error_Msg_N
4392
                    ("\?program execution may be erroneous", ACCR.N);
4393
                  Error_Msg_Uint_1 := X_Size;
4394
                  Error_Msg_NE
4395
                    ("\?size of & is ^", ACCR.N, ACCR.X);
4396
                  Error_Msg_Uint_1 := Y_Size;
4397
                  Error_Msg_NE
4398
                    ("\?size of & is ^", ACCR.N, ACCR.Y);
4399
 
4400
               --  Check for inadequate alignment, both of the base object
4401
               --  and of the offset, if any.
4402
 
4403
               --  Note: we do not check the alignment if we gave a size
4404
               --  warning, since it would likely be redundant.
4405
 
4406
               elsif Y_Alignment /= Uint_0
4407
                 and then (Y_Alignment < X_Alignment
4408
                             or else (ACCR.Off
4409
                                        and then
4410
                                          Nkind (Expr) = N_Attribute_Reference
4411
                                        and then
4412
                                          Attribute_Name (Expr) = Name_Address
4413
                                        and then
4414
                                          Has_Compatible_Alignment
4415
                                            (ACCR.X, Prefix (Expr))
4416
                                             /= Known_Compatible))
4417
               then
4418
                  Error_Msg_NE
4419
                    ("?specified address for& may be inconsistent "
4420
                       & "with alignment",
4421
                     ACCR.N, ACCR.X);
4422
                  Error_Msg_N
4423
                    ("\?program execution may be erroneous (RM 13.3(27))",
4424
                     ACCR.N);
4425
                  Error_Msg_Uint_1 := X_Alignment;
4426
                  Error_Msg_NE
4427
                    ("\?alignment of & is ^",
4428
                     ACCR.N, ACCR.X);
4429
                  Error_Msg_Uint_1 := Y_Alignment;
4430
                  Error_Msg_NE
4431
                    ("\?alignment of & is ^",
4432
                     ACCR.N, ACCR.Y);
4433
                  if Y_Alignment >= X_Alignment then
4434
                     Error_Msg_N
4435
                      ("\?but offset is not multiple of alignment",
4436
                       ACCR.N);
4437
                  end if;
4438
               end if;
4439
            end if;
4440
         end;
4441
      end loop;
4442
   end Validate_Address_Clauses;
4443
 
4444
   -----------------------------------
4445
   -- Validate_Unchecked_Conversion --
4446
   -----------------------------------
4447
 
4448
   procedure Validate_Unchecked_Conversion
4449
     (N        : Node_Id;
4450
      Act_Unit : Entity_Id)
4451
   is
4452
      Source : Entity_Id;
4453
      Target : Entity_Id;
4454
      Vnode  : Node_Id;
4455
 
4456
   begin
4457
      --  Obtain source and target types. Note that we call Ancestor_Subtype
4458
      --  here because the processing for generic instantiation always makes
4459
      --  subtypes, and we want the original frozen actual types.
4460
 
4461
      --  If we are dealing with private types, then do the check on their
4462
      --  fully declared counterparts if the full declarations have been
4463
      --  encountered (they don't have to be visible, but they must exist!)
4464
 
4465
      Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit)));
4466
 
4467
      if Is_Private_Type (Source)
4468
        and then Present (Underlying_Type (Source))
4469
      then
4470
         Source := Underlying_Type (Source);
4471
      end if;
4472
 
4473
      Target := Ancestor_Subtype (Etype (Act_Unit));
4474
 
4475
      --  If either type is generic, the instantiation happens within a generic
4476
      --  unit, and there is nothing to check. The proper check
4477
      --  will happen when the enclosing generic is instantiated.
4478
 
4479
      if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then
4480
         return;
4481
      end if;
4482
 
4483
      if Is_Private_Type (Target)
4484
        and then Present (Underlying_Type (Target))
4485
      then
4486
         Target := Underlying_Type (Target);
4487
      end if;
4488
 
4489
      --  Source may be unconstrained array, but not target
4490
 
4491
      if Is_Array_Type (Target)
4492
        and then not Is_Constrained (Target)
4493
      then
4494
         Error_Msg_N
4495
           ("unchecked conversion to unconstrained array not allowed", N);
4496
         return;
4497
      end if;
4498
 
4499
      --  Warn if conversion between two different convention pointers
4500
 
4501
      if Is_Access_Type (Target)
4502
        and then Is_Access_Type (Source)
4503
        and then Convention (Target) /= Convention (Source)
4504
        and then Warn_On_Unchecked_Conversion
4505
      then
4506
         --  Give warnings for subprogram pointers only on most targets. The
4507
         --  exception is VMS, where data pointers can have different lengths
4508
         --  depending on the pointer convention.
4509
 
4510
         if Is_Access_Subprogram_Type (Target)
4511
           or else Is_Access_Subprogram_Type (Source)
4512
           or else OpenVMS_On_Target
4513
         then
4514
            Error_Msg_N
4515
              ("?conversion between pointers with different conventions!", N);
4516
         end if;
4517
      end if;
4518
 
4519
      --  Warn if one of the operands is Ada.Calendar.Time. Do not emit a
4520
      --  warning when compiling GNAT-related sources.
4521
 
4522
      if Warn_On_Unchecked_Conversion
4523
        and then not In_Predefined_Unit (N)
4524
        and then RTU_Loaded (Ada_Calendar)
4525
        and then
4526
          (Chars (Source) = Name_Time
4527
             or else
4528
           Chars (Target) = Name_Time)
4529
      then
4530
         --  If Ada.Calendar is loaded and the name of one of the operands is
4531
         --  Time, there is a good chance that this is Ada.Calendar.Time.
4532
 
4533
         declare
4534
            Calendar_Time : constant Entity_Id :=
4535
                              Full_View (RTE (RO_CA_Time));
4536
         begin
4537
            pragma Assert (Present (Calendar_Time));
4538
 
4539
            if Source = Calendar_Time
4540
              or else Target = Calendar_Time
4541
            then
4542
               Error_Msg_N
4543
                 ("?representation of 'Time values may change between " &
4544
                  "'G'N'A'T versions", N);
4545
            end if;
4546
         end;
4547
      end if;
4548
 
4549
      --  Make entry in unchecked conversion table for later processing by
4550
      --  Validate_Unchecked_Conversions, which will check sizes and alignments
4551
      --  (using values set by the back-end where possible). This is only done
4552
      --  if the appropriate warning is active.
4553
 
4554
      if Warn_On_Unchecked_Conversion then
4555
         Unchecked_Conversions.Append
4556
           (New_Val => UC_Entry'
4557
              (Eloc   => Sloc (N),
4558
               Source => Source,
4559
               Target => Target));
4560
 
4561
         --  If both sizes are known statically now, then back end annotation
4562
         --  is not required to do a proper check but if either size is not
4563
         --  known statically, then we need the annotation.
4564
 
4565
         if Known_Static_RM_Size (Source)
4566
           and then Known_Static_RM_Size (Target)
4567
         then
4568
            null;
4569
         else
4570
            Back_Annotate_Rep_Info := True;
4571
         end if;
4572
      end if;
4573
 
4574
      --  If unchecked conversion to access type, and access type is declared
4575
      --  in the same unit as the unchecked conversion, then set the
4576
      --  No_Strict_Aliasing flag (no strict aliasing is implicit in this
4577
      --  situation).
4578
 
4579
      if Is_Access_Type (Target) and then
4580
        In_Same_Source_Unit (Target, N)
4581
      then
4582
         Set_No_Strict_Aliasing (Implementation_Base_Type (Target));
4583
      end if;
4584
 
4585
      --  Generate N_Validate_Unchecked_Conversion node for back end in
4586
      --  case the back end needs to perform special validation checks.
4587
 
4588
      --  Shouldn't this be in Exp_Ch13, since the check only gets done
4589
      --  if we have full expansion and the back end is called ???
4590
 
4591
      Vnode :=
4592
        Make_Validate_Unchecked_Conversion (Sloc (N));
4593
      Set_Source_Type (Vnode, Source);
4594
      Set_Target_Type (Vnode, Target);
4595
 
4596
      --  If the unchecked conversion node is in a list, just insert before it.
4597
      --  If not we have some strange case, not worth bothering about.
4598
 
4599
      if Is_List_Member (N) then
4600
         Insert_After (N, Vnode);
4601
      end if;
4602
   end Validate_Unchecked_Conversion;
4603
 
4604
   ------------------------------------
4605
   -- Validate_Unchecked_Conversions --
4606
   ------------------------------------
4607
 
4608
   procedure Validate_Unchecked_Conversions is
4609
   begin
4610
      for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop
4611
         declare
4612
            T : UC_Entry renames Unchecked_Conversions.Table (N);
4613
 
4614
            Eloc   : constant Source_Ptr := T.Eloc;
4615
            Source : constant Entity_Id  := T.Source;
4616
            Target : constant Entity_Id  := T.Target;
4617
 
4618
            Source_Siz    : Uint;
4619
            Target_Siz    : Uint;
4620
 
4621
         begin
4622
            --  This validation check, which warns if we have unequal sizes for
4623
            --  unchecked conversion, and thus potentially implementation
4624
            --  dependent semantics, is one of the few occasions on which we
4625
            --  use the official RM size instead of Esize. See description in
4626
            --  Einfo "Handling of Type'Size Values" for details.
4627
 
4628
            if Serious_Errors_Detected = 0
4629
              and then Known_Static_RM_Size (Source)
4630
              and then Known_Static_RM_Size (Target)
4631
 
4632
              --  Don't do the check if warnings off for either type, note the
4633
              --  deliberate use of OR here instead of OR ELSE to get the flag
4634
              --  Warnings_Off_Used set for both types if appropriate.
4635
 
4636
              and then not (Has_Warnings_Off (Source)
4637
                              or
4638
                            Has_Warnings_Off (Target))
4639
            then
4640
               Source_Siz := RM_Size (Source);
4641
               Target_Siz := RM_Size (Target);
4642
 
4643
               if Source_Siz /= Target_Siz then
4644
                  Error_Msg
4645
                    ("?types for unchecked conversion have different sizes!",
4646
                     Eloc);
4647
 
4648
                  if All_Errors_Mode then
4649
                     Error_Msg_Name_1 := Chars (Source);
4650
                     Error_Msg_Uint_1 := Source_Siz;
4651
                     Error_Msg_Name_2 := Chars (Target);
4652
                     Error_Msg_Uint_2 := Target_Siz;
4653
                     Error_Msg ("\size of % is ^, size of % is ^?", Eloc);
4654
 
4655
                     Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz);
4656
 
4657
                     if Is_Discrete_Type (Source)
4658
                       and then Is_Discrete_Type (Target)
4659
                     then
4660
                        if Source_Siz > Target_Siz then
4661
                           Error_Msg
4662
                             ("\?^ high order bits of source will be ignored!",
4663
                              Eloc);
4664
 
4665
                        elsif Is_Unsigned_Type (Source) then
4666
                           Error_Msg
4667
                             ("\?source will be extended with ^ high order " &
4668
                              "zero bits?!", Eloc);
4669
 
4670
                        else
4671
                           Error_Msg
4672
                             ("\?source will be extended with ^ high order " &
4673
                              "sign bits!",
4674
                              Eloc);
4675
                        end if;
4676
 
4677
                     elsif Source_Siz < Target_Siz then
4678
                        if Is_Discrete_Type (Target) then
4679
                           if Bytes_Big_Endian then
4680
                              Error_Msg
4681
                                ("\?target value will include ^ undefined " &
4682
                                 "low order bits!",
4683
                                 Eloc);
4684
                           else
4685
                              Error_Msg
4686
                                ("\?target value will include ^ undefined " &
4687
                                 "high order bits!",
4688
                                 Eloc);
4689
                           end if;
4690
 
4691
                        else
4692
                           Error_Msg
4693
                             ("\?^ trailing bits of target value will be " &
4694
                              "undefined!", Eloc);
4695
                        end if;
4696
 
4697
                     else pragma Assert (Source_Siz > Target_Siz);
4698
                        Error_Msg
4699
                          ("\?^ trailing bits of source will be ignored!",
4700
                           Eloc);
4701
                     end if;
4702
                  end if;
4703
               end if;
4704
            end if;
4705
 
4706
            --  If both types are access types, we need to check the alignment.
4707
            --  If the alignment of both is specified, we can do it here.
4708
 
4709
            if Serious_Errors_Detected = 0
4710
              and then Ekind (Source) in Access_Kind
4711
              and then Ekind (Target) in Access_Kind
4712
              and then Target_Strict_Alignment
4713
              and then Present (Designated_Type (Source))
4714
              and then Present (Designated_Type (Target))
4715
            then
4716
               declare
4717
                  D_Source : constant Entity_Id := Designated_Type (Source);
4718
                  D_Target : constant Entity_Id := Designated_Type (Target);
4719
 
4720
               begin
4721
                  if Known_Alignment (D_Source)
4722
                    and then Known_Alignment (D_Target)
4723
                  then
4724
                     declare
4725
                        Source_Align : constant Uint := Alignment (D_Source);
4726
                        Target_Align : constant Uint := Alignment (D_Target);
4727
 
4728
                     begin
4729
                        if Source_Align < Target_Align
4730
                          and then not Is_Tagged_Type (D_Source)
4731
 
4732
                          --  Suppress warning if warnings suppressed on either
4733
                          --  type or either designated type. Note the use of
4734
                          --  OR here instead of OR ELSE. That is intentional,
4735
                          --  we would like to set flag Warnings_Off_Used in
4736
                          --  all types for which warnings are suppressed.
4737
 
4738
                          and then not (Has_Warnings_Off (D_Source)
4739
                                          or
4740
                                        Has_Warnings_Off (D_Target)
4741
                                          or
4742
                                        Has_Warnings_Off (Source)
4743
                                          or
4744
                                        Has_Warnings_Off (Target))
4745
                        then
4746
                           Error_Msg_Uint_1 := Target_Align;
4747
                           Error_Msg_Uint_2 := Source_Align;
4748
                           Error_Msg_Node_1 := D_Target;
4749
                           Error_Msg_Node_2 := D_Source;
4750
                           Error_Msg
4751
                             ("?alignment of & (^) is stricter than " &
4752
                              "alignment of & (^)!", Eloc);
4753
                           Error_Msg
4754
                             ("\?resulting access value may have invalid " &
4755
                              "alignment!", Eloc);
4756
                        end if;
4757
                     end;
4758
                  end if;
4759
               end;
4760
            end if;
4761
         end;
4762
      end loop;
4763
   end Validate_Unchecked_Conversions;
4764
 
4765
end Sem_Ch13;

powered by: WebSVN 2.1.0

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