OSDN Git Service

2010-10-08 Robert Dewar <dewar@adacore.com>
[pf3gnuchains/gcc-fork.git] / gcc / ada / sem_ch13.adb
1 ------------------------------------------------------------------------------
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-2010, 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 Elists;   use Elists;
30 with Errout;   use Errout;
31 with Exp_Disp; use Exp_Disp;
32 with Exp_Tss;  use Exp_Tss;
33 with Exp_Util; use Exp_Util;
34 with Lib;      use Lib;
35 with Lib.Xref; use Lib.Xref;
36 with Namet;    use Namet;
37 with Nlists;   use Nlists;
38 with Nmake;    use Nmake;
39 with Opt;      use Opt;
40 with Restrict; use Restrict;
41 with Rident;   use Rident;
42 with Rtsfind;  use Rtsfind;
43 with Sem;      use Sem;
44 with Sem_Aux;  use Sem_Aux;
45 with Sem_Ch3;  use Sem_Ch3;
46 with Sem_Ch8;  use Sem_Ch8;
47 with Sem_Eval; use Sem_Eval;
48 with Sem_Res;  use Sem_Res;
49 with Sem_Type; use Sem_Type;
50 with Sem_Util; use Sem_Util;
51 with Sem_Warn; use Sem_Warn;
52 with Snames;   use Snames;
53 with Stand;    use Stand;
54 with Sinfo;    use Sinfo;
55 with Targparm; use Targparm;
56 with Ttypes;   use Ttypes;
57 with Tbuild;   use Tbuild;
58 with Urealp;   use Urealp;
59
60 with GNAT.Heap_Sort_G;
61
62 package body Sem_Ch13 is
63
64    SSU : constant Pos := System_Storage_Unit;
65    --  Convenient short hand for commonly used constant
66
67    -----------------------
68    -- Local Subprograms --
69    -----------------------
70
71    procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id);
72    --  This routine is called after setting the Esize of type entity Typ.
73    --  The purpose is to deal with the situation where an alignment has been
74    --  inherited from a derived type that is no longer appropriate for the
75    --  new Esize value. In this case, we reset the Alignment to unknown.
76
77    function Get_Alignment_Value (Expr : Node_Id) return Uint;
78    --  Given the expression for an alignment value, returns the corresponding
79    --  Uint value. If the value is inappropriate, then error messages are
80    --  posted as required, and a value of No_Uint is returned.
81
82    function Is_Operational_Item (N : Node_Id) return Boolean;
83    --  A specification for a stream attribute is allowed before the full
84    --  type is declared, as explained in AI-00137 and the corrigendum.
85    --  Attributes that do not specify a representation characteristic are
86    --  operational attributes.
87
88    procedure New_Stream_Subprogram
89      (N    : Node_Id;
90       Ent  : Entity_Id;
91       Subp : Entity_Id;
92       Nam  : TSS_Name_Type);
93    --  Create a subprogram renaming of a given stream attribute to the
94    --  designated subprogram and then in the tagged case, provide this as a
95    --  primitive operation, or in the non-tagged case make an appropriate TSS
96    --  entry. This is more properly an expansion activity than just semantics,
97    --  but the presence of user-defined stream functions for limited types is a
98    --  legality check, which is why this takes place here rather than in
99    --  exp_ch13, where it was previously. Nam indicates the name of the TSS
100    --  function to be generated.
101    --
102    --  To avoid elaboration anomalies with freeze nodes, for untagged types
103    --  we generate both a subprogram declaration and a subprogram renaming
104    --  declaration, so that the attribute specification is handled as a
105    --  renaming_as_body. For tagged types, the specification is one of the
106    --  primitive specs.
107
108    procedure Set_Biased
109      (E      : Entity_Id;
110       N      : Node_Id;
111       Msg    : String;
112       Biased : Boolean := True);
113    --  If Biased is True, sets Has_Biased_Representation flag for E, and
114    --  outputs a warning message at node N if Warn_On_Biased_Representation is
115    --  is True. This warning inserts the string Msg to describe the construct
116    --  causing biasing.
117
118    ----------------------------------------------
119    -- Table for Validate_Unchecked_Conversions --
120    ----------------------------------------------
121
122    --  The following table collects unchecked conversions for validation.
123    --  Entries are made by Validate_Unchecked_Conversion and then the
124    --  call to Validate_Unchecked_Conversions does the actual error
125    --  checking and posting of warnings. The reason for this delayed
126    --  processing is to take advantage of back-annotations of size and
127    --  alignment values performed by the back end.
128
129    --  Note: the reason we store a Source_Ptr value instead of a Node_Id
130    --  is that by the time Validate_Unchecked_Conversions is called, Sprint
131    --  will already have modified all Sloc values if the -gnatD option is set.
132
133    type UC_Entry is record
134       Eloc   : Source_Ptr; -- node used for posting warnings
135       Source : Entity_Id;  -- source type for unchecked conversion
136       Target : Entity_Id;  -- target type for unchecked conversion
137    end record;
138
139    package Unchecked_Conversions is new Table.Table (
140      Table_Component_Type => UC_Entry,
141      Table_Index_Type     => Int,
142      Table_Low_Bound      => 1,
143      Table_Initial        => 50,
144      Table_Increment      => 200,
145      Table_Name           => "Unchecked_Conversions");
146
147    ----------------------------------------
148    -- Table for Validate_Address_Clauses --
149    ----------------------------------------
150
151    --  If an address clause has the form
152
153    --    for X'Address use Expr
154
155    --  where Expr is of the form Y'Address or recursively is a reference
156    --  to a constant of either of these forms, and X and Y are entities of
157    --  objects, then if Y has a smaller alignment than X, that merits a
158    --  warning about possible bad alignment. The following table collects
159    --  address clauses of this kind. We put these in a table so that they
160    --  can be checked after the back end has completed annotation of the
161    --  alignments of objects, since we can catch more cases that way.
162
163    type Address_Clause_Check_Record is record
164       N : Node_Id;
165       --  The address clause
166
167       X : Entity_Id;
168       --  The entity of the object overlaying Y
169
170       Y : Entity_Id;
171       --  The entity of the object being overlaid
172
173       Off : Boolean;
174       --  Whether the address is offseted within Y
175    end record;
176
177    package Address_Clause_Checks is new Table.Table (
178      Table_Component_Type => Address_Clause_Check_Record,
179      Table_Index_Type     => Int,
180      Table_Low_Bound      => 1,
181      Table_Initial        => 20,
182      Table_Increment      => 200,
183      Table_Name           => "Address_Clause_Checks");
184
185    -----------------------------------------
186    -- Adjust_Record_For_Reverse_Bit_Order --
187    -----------------------------------------
188
189    procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is
190       Comp : Node_Id;
191       CC   : Node_Id;
192
193    begin
194       --  Processing depends on version of Ada
195
196       --  For Ada 95, we just renumber bits within a storage unit. We do the
197       --  same for Ada 83 mode, since we recognize pragma Bit_Order in Ada 83,
198       --  and are free to add this extension.
199
200       if Ada_Version < Ada_2005 then
201          Comp := First_Component_Or_Discriminant (R);
202          while Present (Comp) loop
203             CC := Component_Clause (Comp);
204
205             --  If component clause is present, then deal with the non-default
206             --  bit order case for Ada 95 mode.
207
208             --  We only do this processing for the base type, and in fact that
209             --  is important, since otherwise if there are record subtypes, we
210             --  could reverse the bits once for each subtype, which is wrong.
211
212             if Present (CC)
213               and then Ekind (R) = E_Record_Type
214             then
215                declare
216                   CFB : constant Uint    := Component_Bit_Offset (Comp);
217                   CSZ : constant Uint    := Esize (Comp);
218                   CLC : constant Node_Id := Component_Clause (Comp);
219                   Pos : constant Node_Id := Position (CLC);
220                   FB  : constant Node_Id := First_Bit (CLC);
221
222                   Storage_Unit_Offset : constant Uint :=
223                                           CFB / System_Storage_Unit;
224
225                   Start_Bit : constant Uint :=
226                                 CFB mod System_Storage_Unit;
227
228                begin
229                   --  Cases where field goes over storage unit boundary
230
231                   if Start_Bit + CSZ > System_Storage_Unit then
232
233                      --  Allow multi-byte field but generate warning
234
235                      if Start_Bit mod System_Storage_Unit = 0
236                        and then CSZ mod System_Storage_Unit = 0
237                      then
238                         Error_Msg_N
239                           ("multi-byte field specified with non-standard"
240                            & " Bit_Order?", CLC);
241
242                         if Bytes_Big_Endian then
243                            Error_Msg_N
244                              ("bytes are not reversed "
245                               & "(component is big-endian)?", CLC);
246                         else
247                            Error_Msg_N
248                              ("bytes are not reversed "
249                               & "(component is little-endian)?", CLC);
250                         end if;
251
252                         --  Do not allow non-contiguous field
253
254                      else
255                         Error_Msg_N
256                           ("attempt to specify non-contiguous field "
257                            & "not permitted", CLC);
258                         Error_Msg_N
259                           ("\caused by non-standard Bit_Order "
260                            & "specified", CLC);
261                         Error_Msg_N
262                           ("\consider possibility of using "
263                            & "Ada 2005 mode here", CLC);
264                      end if;
265
266                   --  Case where field fits in one storage unit
267
268                   else
269                      --  Give warning if suspicious component clause
270
271                      if Intval (FB) >= System_Storage_Unit
272                        and then Warn_On_Reverse_Bit_Order
273                      then
274                         Error_Msg_N
275                           ("?Bit_Order clause does not affect " &
276                            "byte ordering", Pos);
277                         Error_Msg_Uint_1 :=
278                           Intval (Pos) + Intval (FB) /
279                           System_Storage_Unit;
280                         Error_Msg_N
281                           ("?position normalized to ^ before bit " &
282                            "order interpreted", Pos);
283                      end if;
284
285                      --  Here is where we fix up the Component_Bit_Offset value
286                      --  to account for the reverse bit order. Some examples of
287                      --  what needs to be done are:
288
289                      --    First_Bit .. Last_Bit     Component_Bit_Offset
290                      --      old          new          old       new
291
292                      --     0 .. 0       7 .. 7         0         7
293                      --     0 .. 1       6 .. 7         0         6
294                      --     0 .. 2       5 .. 7         0         5
295                      --     0 .. 7       0 .. 7         0         4
296
297                      --     1 .. 1       6 .. 6         1         6
298                      --     1 .. 4       3 .. 6         1         3
299                      --     4 .. 7       0 .. 3         4         0
300
301                      --  The rule is that the first bit is is obtained by
302                      --  subtracting the old ending bit from storage_unit - 1.
303
304                      Set_Component_Bit_Offset
305                        (Comp,
306                         (Storage_Unit_Offset * System_Storage_Unit) +
307                           (System_Storage_Unit - 1) -
308                           (Start_Bit + CSZ - 1));
309
310                      Set_Normalized_First_Bit
311                        (Comp,
312                         Component_Bit_Offset (Comp) mod
313                           System_Storage_Unit);
314                   end if;
315                end;
316             end if;
317
318             Next_Component_Or_Discriminant (Comp);
319          end loop;
320
321       --  For Ada 2005, we do machine scalar processing, as fully described In
322       --  AI-133. This involves gathering all components which start at the
323       --  same byte offset and processing them together. Same approach is still
324       --  valid in later versions including Ada 2012.
325
326       else
327          declare
328             Max_Machine_Scalar_Size : constant Uint :=
329                                         UI_From_Int
330                                           (Standard_Long_Long_Integer_Size);
331             --  We use this as the maximum machine scalar size
332
333             Num_CC : Natural;
334             SSU    : constant Uint := UI_From_Int (System_Storage_Unit);
335
336          begin
337             --  This first loop through components does two things. First it
338             --  deals with the case of components with component clauses whose
339             --  length is greater than the maximum machine scalar size (either
340             --  accepting them or rejecting as needed). Second, it counts the
341             --  number of components with component clauses whose length does
342             --  not exceed this maximum for later processing.
343
344             Num_CC := 0;
345             Comp   := First_Component_Or_Discriminant (R);
346             while Present (Comp) loop
347                CC := Component_Clause (Comp);
348
349                if Present (CC) then
350                   declare
351                      Fbit : constant Uint :=
352                               Static_Integer (First_Bit (CC));
353
354                   begin
355                      --  Case of component with size > max machine scalar
356
357                      if Esize (Comp) > Max_Machine_Scalar_Size then
358
359                         --  Must begin on byte boundary
360
361                         if Fbit mod SSU /= 0 then
362                            Error_Msg_N
363                              ("illegal first bit value for "
364                               & "reverse bit order",
365                               First_Bit (CC));
366                            Error_Msg_Uint_1 := SSU;
367                            Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
368
369                            Error_Msg_N
370                              ("\must be a multiple of ^ "
371                               & "if size greater than ^",
372                               First_Bit (CC));
373
374                            --  Must end on byte boundary
375
376                         elsif Esize (Comp) mod SSU /= 0 then
377                            Error_Msg_N
378                              ("illegal last bit value for "
379                               & "reverse bit order",
380                               Last_Bit (CC));
381                            Error_Msg_Uint_1 := SSU;
382                            Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
383
384                            Error_Msg_N
385                              ("\must be a multiple of ^ if size "
386                               & "greater than ^",
387                               Last_Bit (CC));
388
389                            --  OK, give warning if enabled
390
391                         elsif Warn_On_Reverse_Bit_Order then
392                            Error_Msg_N
393                              ("multi-byte field specified with "
394                               & "  non-standard Bit_Order?", CC);
395
396                            if Bytes_Big_Endian then
397                               Error_Msg_N
398                                 ("\bytes are not reversed "
399                                  & "(component is big-endian)?", CC);
400                            else
401                               Error_Msg_N
402                                 ("\bytes are not reversed "
403                                  & "(component is little-endian)?", CC);
404                            end if;
405                         end if;
406
407                         --  Case where size is not greater than max machine
408                         --  scalar. For now, we just count these.
409
410                      else
411                         Num_CC := Num_CC + 1;
412                      end if;
413                   end;
414                end if;
415
416                Next_Component_Or_Discriminant (Comp);
417             end loop;
418
419             --  We need to sort the component clauses on the basis of the
420             --  Position values in the clause, so we can group clauses with
421             --  the same Position. together to determine the relevant machine
422             --  scalar size.
423
424             Sort_CC : declare
425                Comps : array (0 .. Num_CC) of Entity_Id;
426                --  Array to collect component and discriminant entities. The
427                --  data starts at index 1, the 0'th entry is for the sort
428                --  routine.
429
430                function CP_Lt (Op1, Op2 : Natural) return Boolean;
431                --  Compare routine for Sort
432
433                procedure CP_Move (From : Natural; To : Natural);
434                --  Move routine for Sort
435
436                package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
437
438                Start : Natural;
439                Stop  : Natural;
440                --  Start and stop positions in the component list of the set of
441                --  components with the same starting position (that constitute
442                --  components in a single machine scalar).
443
444                MaxL  : Uint;
445                --  Maximum last bit value of any component in this set
446
447                MSS   : Uint;
448                --  Corresponding machine scalar size
449
450                -----------
451                -- CP_Lt --
452                -----------
453
454                function CP_Lt (Op1, Op2 : Natural) return Boolean is
455                begin
456                   return Position (Component_Clause (Comps (Op1))) <
457                     Position (Component_Clause (Comps (Op2)));
458                end CP_Lt;
459
460                -------------
461                -- CP_Move --
462                -------------
463
464                procedure CP_Move (From : Natural; To : Natural) is
465                begin
466                   Comps (To) := Comps (From);
467                end CP_Move;
468
469                --  Start of processing for Sort_CC
470
471             begin
472                --  Collect the component clauses
473
474                Num_CC := 0;
475                Comp   := First_Component_Or_Discriminant (R);
476                while Present (Comp) loop
477                   if Present (Component_Clause (Comp))
478                     and then Esize (Comp) <= Max_Machine_Scalar_Size
479                   then
480                      Num_CC := Num_CC + 1;
481                      Comps (Num_CC) := Comp;
482                   end if;
483
484                   Next_Component_Or_Discriminant (Comp);
485                end loop;
486
487                --  Sort by ascending position number
488
489                Sorting.Sort (Num_CC);
490
491                --  We now have all the components whose size does not exceed
492                --  the max machine scalar value, sorted by starting position.
493                --  In this loop we gather groups of clauses starting at the
494                --  same position, to process them in accordance with AI-133.
495
496                Stop := 0;
497                while Stop < Num_CC loop
498                   Start := Stop + 1;
499                   Stop  := Start;
500                   MaxL  :=
501                     Static_Integer
502                       (Last_Bit (Component_Clause (Comps (Start))));
503                   while Stop < Num_CC loop
504                      if Static_Integer
505                           (Position (Component_Clause (Comps (Stop + 1)))) =
506                         Static_Integer
507                           (Position (Component_Clause (Comps (Stop))))
508                      then
509                         Stop := Stop + 1;
510                         MaxL :=
511                           UI_Max
512                             (MaxL,
513                              Static_Integer
514                                (Last_Bit
515                                   (Component_Clause (Comps (Stop)))));
516                      else
517                         exit;
518                      end if;
519                   end loop;
520
521                   --  Now we have a group of component clauses from Start to
522                   --  Stop whose positions are identical, and MaxL is the
523                   --  maximum last bit value of any of these components.
524
525                   --  We need to determine the corresponding machine scalar
526                   --  size. This loop assumes that machine scalar sizes are
527                   --  even, and that each possible machine scalar has twice
528                   --  as many bits as the next smaller one.
529
530                   MSS := Max_Machine_Scalar_Size;
531                   while MSS mod 2 = 0
532                     and then (MSS / 2) >= SSU
533                     and then (MSS / 2) > MaxL
534                   loop
535                      MSS := MSS / 2;
536                   end loop;
537
538                   --  Here is where we fix up the Component_Bit_Offset value
539                   --  to account for the reverse bit order. Some examples of
540                   --  what needs to be done for the case of a machine scalar
541                   --  size of 8 are:
542
543                   --    First_Bit .. Last_Bit     Component_Bit_Offset
544                   --      old          new          old       new
545
546                   --     0 .. 0       7 .. 7         0         7
547                   --     0 .. 1       6 .. 7         0         6
548                   --     0 .. 2       5 .. 7         0         5
549                   --     0 .. 7       0 .. 7         0         4
550
551                   --     1 .. 1       6 .. 6         1         6
552                   --     1 .. 4       3 .. 6         1         3
553                   --     4 .. 7       0 .. 3         4         0
554
555                   --  The rule is that the first bit is obtained by subtracting
556                   --  the old ending bit from machine scalar size - 1.
557
558                   for C in Start .. Stop loop
559                      declare
560                         Comp : constant Entity_Id := Comps (C);
561                         CC   : constant Node_Id   :=
562                                  Component_Clause (Comp);
563                         LB   : constant Uint :=
564                                  Static_Integer (Last_Bit (CC));
565                         NFB  : constant Uint := MSS - Uint_1 - LB;
566                         NLB  : constant Uint := NFB + Esize (Comp) - 1;
567                         Pos  : constant Uint :=
568                                  Static_Integer (Position (CC));
569
570                      begin
571                         if Warn_On_Reverse_Bit_Order then
572                            Error_Msg_Uint_1 := MSS;
573                            Error_Msg_N
574                              ("info: reverse bit order in machine " &
575                               "scalar of length^?", First_Bit (CC));
576                            Error_Msg_Uint_1 := NFB;
577                            Error_Msg_Uint_2 := NLB;
578
579                            if Bytes_Big_Endian then
580                               Error_Msg_NE
581                                 ("?\info: big-endian range for "
582                                  & "component & is ^ .. ^",
583                                  First_Bit (CC), Comp);
584                            else
585                               Error_Msg_NE
586                                 ("?\info: little-endian range "
587                                  & "for component & is ^ .. ^",
588                                  First_Bit (CC), Comp);
589                            end if;
590                         end if;
591
592                         Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
593                         Set_Normalized_First_Bit (Comp, NFB mod SSU);
594                      end;
595                   end loop;
596                end loop;
597             end Sort_CC;
598          end;
599       end if;
600    end Adjust_Record_For_Reverse_Bit_Order;
601
602    --------------------------------------
603    -- Alignment_Check_For_Esize_Change --
604    --------------------------------------
605
606    procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id) is
607    begin
608       --  If the alignment is known, and not set by a rep clause, and is
609       --  inconsistent with the size being set, then reset it to unknown,
610       --  we assume in this case that the size overrides the inherited
611       --  alignment, and that the alignment must be recomputed.
612
613       if Known_Alignment (Typ)
614         and then not Has_Alignment_Clause (Typ)
615         and then Esize (Typ) mod (Alignment (Typ) * SSU) /= 0
616       then
617          Init_Alignment (Typ);
618       end if;
619    end Alignment_Check_For_Esize_Change;
620
621    -----------------------
622    -- Analyze_At_Clause --
623    -----------------------
624
625    --  An at clause is replaced by the corresponding Address attribute
626    --  definition clause that is the preferred approach in Ada 95.
627
628    procedure Analyze_At_Clause (N : Node_Id) is
629       CS : constant Boolean := Comes_From_Source (N);
630
631    begin
632       --  This is an obsolescent feature
633
634       Check_Restriction (No_Obsolescent_Features, N);
635
636       if Warn_On_Obsolescent_Feature then
637          Error_Msg_N
638            ("at clause is an obsolescent feature (RM J.7(2))?", N);
639          Error_Msg_N
640            ("\use address attribute definition clause instead?", N);
641       end if;
642
643       --  Rewrite as address clause
644
645       Rewrite (N,
646         Make_Attribute_Definition_Clause (Sloc (N),
647           Name  => Identifier (N),
648           Chars => Name_Address,
649           Expression => Expression (N)));
650
651       --  We preserve Comes_From_Source, since logically the clause still
652       --  comes from the source program even though it is changed in form.
653
654       Set_Comes_From_Source (N, CS);
655
656       --  Analyze rewritten clause
657
658       Analyze_Attribute_Definition_Clause (N);
659    end Analyze_At_Clause;
660
661    -----------------------------------------
662    -- Analyze_Attribute_Definition_Clause --
663    -----------------------------------------
664
665    procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is
666       Loc   : constant Source_Ptr   := Sloc (N);
667       Nam   : constant Node_Id      := Name (N);
668       Attr  : constant Name_Id      := Chars (N);
669       Expr  : constant Node_Id      := Expression (N);
670       Id    : constant Attribute_Id := Get_Attribute_Id (Attr);
671       Ent   : Entity_Id;
672       U_Ent : Entity_Id;
673
674       FOnly : Boolean := False;
675       --  Reset to True for subtype specific attribute (Alignment, Size)
676       --  and for stream attributes, i.e. those cases where in the call
677       --  to Rep_Item_Too_Late, FOnly is set True so that only the freezing
678       --  rules are checked. Note that the case of stream attributes is not
679       --  clear from the RM, but see AI95-00137. Also, the RM seems to
680       --  disallow Storage_Size for derived task types, but that is also
681       --  clearly unintentional.
682
683       procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type);
684       --  Common processing for 'Read, 'Write, 'Input and 'Output attribute
685       --  definition clauses.
686
687       -----------------------------------
688       -- Analyze_Stream_TSS_Definition --
689       -----------------------------------
690
691       procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is
692          Subp : Entity_Id := Empty;
693          I    : Interp_Index;
694          It   : Interp;
695          Pnam : Entity_Id;
696
697          Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read);
698
699          function Has_Good_Profile (Subp : Entity_Id) return Boolean;
700          --  Return true if the entity is a subprogram with an appropriate
701          --  profile for the attribute being defined.
702
703          ----------------------
704          -- Has_Good_Profile --
705          ----------------------
706
707          function Has_Good_Profile (Subp : Entity_Id) return Boolean is
708             F              : Entity_Id;
709             Is_Function    : constant Boolean := (TSS_Nam = TSS_Stream_Input);
710             Expected_Ekind : constant array (Boolean) of Entity_Kind :=
711                                (False => E_Procedure, True => E_Function);
712             Typ            : Entity_Id;
713
714          begin
715             if Ekind (Subp) /= Expected_Ekind (Is_Function) then
716                return False;
717             end if;
718
719             F := First_Formal (Subp);
720
721             if No (F)
722               or else Ekind (Etype (F)) /= E_Anonymous_Access_Type
723               or else Designated_Type (Etype (F)) /=
724                                Class_Wide_Type (RTE (RE_Root_Stream_Type))
725             then
726                return False;
727             end if;
728
729             if not Is_Function then
730                Next_Formal (F);
731
732                declare
733                   Expected_Mode : constant array (Boolean) of Entity_Kind :=
734                                     (False => E_In_Parameter,
735                                      True  => E_Out_Parameter);
736                begin
737                   if Parameter_Mode (F) /= Expected_Mode (Is_Read) then
738                      return False;
739                   end if;
740                end;
741
742                Typ := Etype (F);
743
744             else
745                Typ := Etype (Subp);
746             end if;
747
748             return Base_Type (Typ) = Base_Type (Ent)
749               and then No (Next_Formal (F));
750          end Has_Good_Profile;
751
752       --  Start of processing for Analyze_Stream_TSS_Definition
753
754       begin
755          FOnly := True;
756
757          if not Is_Type (U_Ent) then
758             Error_Msg_N ("local name must be a subtype", Nam);
759             return;
760          end if;
761
762          Pnam := TSS (Base_Type (U_Ent), TSS_Nam);
763
764          --  If Pnam is present, it can be either inherited from an ancestor
765          --  type (in which case it is legal to redefine it for this type), or
766          --  be a previous definition of the attribute for the same type (in
767          --  which case it is illegal).
768
769          --  In the first case, it will have been analyzed already, and we
770          --  can check that its profile does not match the expected profile
771          --  for a stream attribute of U_Ent. In the second case, either Pnam
772          --  has been analyzed (and has the expected profile), or it has not
773          --  been analyzed yet (case of a type that has not been frozen yet
774          --  and for which the stream attribute has been set using Set_TSS).
775
776          if Present (Pnam)
777            and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam))
778          then
779             Error_Msg_Sloc := Sloc (Pnam);
780             Error_Msg_Name_1 := Attr;
781             Error_Msg_N ("% attribute already defined #", Nam);
782             return;
783          end if;
784
785          Analyze (Expr);
786
787          if Is_Entity_Name (Expr) then
788             if not Is_Overloaded (Expr) then
789                if Has_Good_Profile (Entity (Expr)) then
790                   Subp := Entity (Expr);
791                end if;
792
793             else
794                Get_First_Interp (Expr, I, It);
795                while Present (It.Nam) loop
796                   if Has_Good_Profile (It.Nam) then
797                      Subp := It.Nam;
798                      exit;
799                   end if;
800
801                   Get_Next_Interp (I, It);
802                end loop;
803             end if;
804          end if;
805
806          if Present (Subp) then
807             if Is_Abstract_Subprogram (Subp) then
808                Error_Msg_N ("stream subprogram must not be abstract", Expr);
809                return;
810             end if;
811
812             Set_Entity (Expr, Subp);
813             Set_Etype (Expr, Etype (Subp));
814
815             New_Stream_Subprogram (N, U_Ent, Subp, TSS_Nam);
816
817          else
818             Error_Msg_Name_1 := Attr;
819             Error_Msg_N ("incorrect expression for% attribute", Expr);
820          end if;
821       end Analyze_Stream_TSS_Definition;
822
823    --  Start of processing for Analyze_Attribute_Definition_Clause
824
825    begin
826       --  Process Ignore_Rep_Clauses option
827
828       if Ignore_Rep_Clauses then
829          case Id is
830
831             --  The following should be ignored. They do not affect legality
832             --  and may be target dependent. The basic idea of -gnatI is to
833             --  ignore any rep clauses that may be target dependent but do not
834             --  affect legality (except possibly to be rejected because they
835             --  are incompatible with the compilation target).
836
837             when Attribute_Alignment      |
838                  Attribute_Bit_Order      |
839                  Attribute_Component_Size |
840                  Attribute_Machine_Radix  |
841                  Attribute_Object_Size    |
842                  Attribute_Size           |
843                  Attribute_Small          |
844                  Attribute_Stream_Size    |
845                  Attribute_Value_Size     =>
846
847                Rewrite (N, Make_Null_Statement (Sloc (N)));
848                return;
849
850             --  The following should not be ignored, because in the first place
851             --  they are reasonably portable, and should not cause problems in
852             --  compiling code from another target, and also they do affect
853             --  legality, e.g. failing to provide a stream attribute for a
854             --  type may make a program illegal.
855
856             when Attribute_External_Tag   |
857                  Attribute_Input          |
858                  Attribute_Output         |
859                  Attribute_Read           |
860                  Attribute_Storage_Pool   |
861                  Attribute_Storage_Size   |
862                  Attribute_Write          =>
863                null;
864
865             --  Other cases are errors ("attribute& cannot be set with
866             --  definition clause"), which will be caught below.
867
868             when others =>
869                null;
870          end case;
871       end if;
872
873       Analyze (Nam);
874       Ent := Entity (Nam);
875
876       if Rep_Item_Too_Early (Ent, N) then
877          return;
878       end if;
879
880       --  Rep clause applies to full view of incomplete type or private type if
881       --  we have one (if not, this is a premature use of the type). However,
882       --  certain semantic checks need to be done on the specified entity (i.e.
883       --  the private view), so we save it in Ent.
884
885       if Is_Private_Type (Ent)
886         and then Is_Derived_Type (Ent)
887         and then not Is_Tagged_Type (Ent)
888         and then No (Full_View (Ent))
889       then
890          --  If this is a private type whose completion is a derivation from
891          --  another private type, there is no full view, and the attribute
892          --  belongs to the type itself, not its underlying parent.
893
894          U_Ent := Ent;
895
896       elsif Ekind (Ent) = E_Incomplete_Type then
897
898          --  The attribute applies to the full view, set the entity of the
899          --  attribute definition accordingly.
900
901          Ent := Underlying_Type (Ent);
902          U_Ent := Ent;
903          Set_Entity (Nam, Ent);
904
905       else
906          U_Ent := Underlying_Type (Ent);
907       end if;
908
909       --  Complete other routine error checks
910
911       if Etype (Nam) = Any_Type then
912          return;
913
914       elsif Scope (Ent) /= Current_Scope then
915          Error_Msg_N ("entity must be declared in this scope", Nam);
916          return;
917
918       elsif No (U_Ent) then
919          U_Ent := Ent;
920
921       elsif Is_Type (U_Ent)
922         and then not Is_First_Subtype (U_Ent)
923         and then Id /= Attribute_Object_Size
924         and then Id /= Attribute_Value_Size
925         and then not From_At_Mod (N)
926       then
927          Error_Msg_N ("cannot specify attribute for subtype", Nam);
928          return;
929       end if;
930
931       --  Switch on particular attribute
932
933       case Id is
934
935          -------------
936          -- Address --
937          -------------
938
939          --  Address attribute definition clause
940
941          when Attribute_Address => Address : begin
942
943             --  A little error check, catch for X'Address use X'Address;
944
945             if Nkind (Nam) = N_Identifier
946               and then Nkind (Expr) = N_Attribute_Reference
947               and then Attribute_Name (Expr) = Name_Address
948               and then Nkind (Prefix (Expr)) = N_Identifier
949               and then Chars (Nam) = Chars (Prefix (Expr))
950             then
951                Error_Msg_NE
952                  ("address for & is self-referencing", Prefix (Expr), Ent);
953                return;
954             end if;
955
956             --  Not that special case, carry on with analysis of expression
957
958             Analyze_And_Resolve (Expr, RTE (RE_Address));
959
960             --  Even when ignoring rep clauses we need to indicate that the
961             --  entity has an address clause and thus it is legal to declare
962             --  it imported.
963
964             if Ignore_Rep_Clauses then
965                if Ekind_In (U_Ent, E_Variable, E_Constant) then
966                   Record_Rep_Item (U_Ent, N);
967                end if;
968
969                return;
970             end if;
971
972             if Present (Address_Clause (U_Ent)) then
973                Error_Msg_N ("address already given for &", Nam);
974
975             --  Case of address clause for subprogram
976
977             elsif Is_Subprogram (U_Ent) then
978                if Has_Homonym (U_Ent) then
979                   Error_Msg_N
980                     ("address clause cannot be given " &
981                      "for overloaded subprogram",
982                      Nam);
983                   return;
984                end if;
985
986                --  For subprograms, all address clauses are permitted, and we
987                --  mark the subprogram as having a deferred freeze so that Gigi
988                --  will not elaborate it too soon.
989
990                --  Above needs more comments, what is too soon about???
991
992                Set_Has_Delayed_Freeze (U_Ent);
993
994             --  Case of address clause for entry
995
996             elsif Ekind (U_Ent) = E_Entry then
997                if Nkind (Parent (N)) = N_Task_Body then
998                   Error_Msg_N
999                     ("entry address must be specified in task spec", Nam);
1000                   return;
1001                end if;
1002
1003                --  For entries, we require a constant address
1004
1005                Check_Constant_Address_Clause (Expr, U_Ent);
1006
1007                --  Special checks for task types
1008
1009                if Is_Task_Type (Scope (U_Ent))
1010                  and then Comes_From_Source (Scope (U_Ent))
1011                then
1012                   Error_Msg_N
1013                     ("?entry address declared for entry in task type", N);
1014                   Error_Msg_N
1015                     ("\?only one task can be declared of this type", N);
1016                end if;
1017
1018                --  Entry address clauses are obsolescent
1019
1020                Check_Restriction (No_Obsolescent_Features, N);
1021
1022                if Warn_On_Obsolescent_Feature then
1023                   Error_Msg_N
1024                     ("attaching interrupt to task entry is an " &
1025                      "obsolescent feature (RM J.7.1)?", N);
1026                   Error_Msg_N
1027                     ("\use interrupt procedure instead?", N);
1028                end if;
1029
1030             --  Case of an address clause for a controlled object which we
1031             --  consider to be erroneous.
1032
1033             elsif Is_Controlled (Etype (U_Ent))
1034               or else Has_Controlled_Component (Etype (U_Ent))
1035             then
1036                Error_Msg_NE
1037                  ("?controlled object& must not be overlaid", Nam, U_Ent);
1038                Error_Msg_N
1039                  ("\?Program_Error will be raised at run time", Nam);
1040                Insert_Action (Declaration_Node (U_Ent),
1041                  Make_Raise_Program_Error (Loc,
1042                    Reason => PE_Overlaid_Controlled_Object));
1043                return;
1044
1045             --  Case of address clause for a (non-controlled) object
1046
1047             elsif
1048               Ekind (U_Ent) = E_Variable
1049                 or else
1050               Ekind (U_Ent) = E_Constant
1051             then
1052                declare
1053                   Expr  : constant Node_Id := Expression (N);
1054                   O_Ent : Entity_Id;
1055                   Off   : Boolean;
1056
1057                begin
1058                   --  Exported variables cannot have an address clause, because
1059                   --  this cancels the effect of the pragma Export.
1060
1061                   if Is_Exported (U_Ent) then
1062                      Error_Msg_N
1063                        ("cannot export object with address clause", Nam);
1064                      return;
1065                   end if;
1066
1067                   Find_Overlaid_Entity (N, O_Ent, Off);
1068
1069                   --  Overlaying controlled objects is erroneous
1070
1071                   if Present (O_Ent)
1072                     and then (Has_Controlled_Component (Etype (O_Ent))
1073                                 or else Is_Controlled (Etype (O_Ent)))
1074                   then
1075                      Error_Msg_N
1076                        ("?cannot overlay with controlled object", Expr);
1077                      Error_Msg_N
1078                        ("\?Program_Error will be raised at run time", Expr);
1079                      Insert_Action (Declaration_Node (U_Ent),
1080                        Make_Raise_Program_Error (Loc,
1081                          Reason => PE_Overlaid_Controlled_Object));
1082                      return;
1083
1084                   elsif Present (O_Ent)
1085                     and then Ekind (U_Ent) = E_Constant
1086                     and then not Is_Constant_Object (O_Ent)
1087                   then
1088                      Error_Msg_N ("constant overlays a variable?", Expr);
1089
1090                   elsif Present (Renamed_Object (U_Ent)) then
1091                      Error_Msg_N
1092                        ("address clause not allowed"
1093                           & " for a renaming declaration (RM 13.1(6))", Nam);
1094                      return;
1095
1096                   --  Imported variables can have an address clause, but then
1097                   --  the import is pretty meaningless except to suppress
1098                   --  initializations, so we do not need such variables to
1099                   --  be statically allocated (and in fact it causes trouble
1100                   --  if the address clause is a local value).
1101
1102                   elsif Is_Imported (U_Ent) then
1103                      Set_Is_Statically_Allocated (U_Ent, False);
1104                   end if;
1105
1106                   --  We mark a possible modification of a variable with an
1107                   --  address clause, since it is likely aliasing is occurring.
1108
1109                   Note_Possible_Modification (Nam, Sure => False);
1110
1111                   --  Here we are checking for explicit overlap of one variable
1112                   --  by another, and if we find this then mark the overlapped
1113                   --  variable as also being volatile to prevent unwanted
1114                   --  optimizations. This is a significant pessimization so
1115                   --  avoid it when there is an offset, i.e. when the object
1116                   --  is composite; they cannot be optimized easily anyway.
1117
1118                   if Present (O_Ent)
1119                     and then Is_Object (O_Ent)
1120                     and then not Off
1121                   then
1122                      Set_Treat_As_Volatile (O_Ent);
1123                   end if;
1124
1125                   --  Legality checks on the address clause for initialized
1126                   --  objects is deferred until the freeze point, because
1127                   --  a subsequent pragma might indicate that the object is
1128                   --  imported and thus not initialized.
1129
1130                   Set_Has_Delayed_Freeze (U_Ent);
1131
1132                   --  If an initialization call has been generated for this
1133                   --  object, it needs to be deferred to after the freeze node
1134                   --  we have just now added, otherwise GIGI will see a
1135                   --  reference to the variable (as actual to the IP call)
1136                   --  before its definition.
1137
1138                   declare
1139                      Init_Call : constant Node_Id := Find_Init_Call (U_Ent, N);
1140                   begin
1141                      if Present (Init_Call) then
1142                         Remove (Init_Call);
1143                         Append_Freeze_Action (U_Ent, Init_Call);
1144                      end if;
1145                   end;
1146
1147                   if Is_Exported (U_Ent) then
1148                      Error_Msg_N
1149                        ("& cannot be exported if an address clause is given",
1150                         Nam);
1151                      Error_Msg_N
1152                        ("\define and export a variable " &
1153                         "that holds its address instead",
1154                         Nam);
1155                   end if;
1156
1157                   --  Entity has delayed freeze, so we will generate an
1158                   --  alignment check at the freeze point unless suppressed.
1159
1160                   if not Range_Checks_Suppressed (U_Ent)
1161                     and then not Alignment_Checks_Suppressed (U_Ent)
1162                   then
1163                      Set_Check_Address_Alignment (N);
1164                   end if;
1165
1166                   --  Kill the size check code, since we are not allocating
1167                   --  the variable, it is somewhere else.
1168
1169                   Kill_Size_Check_Code (U_Ent);
1170
1171                   --  If the address clause is of the form:
1172
1173                   --    for Y'Address use X'Address
1174
1175                   --  or
1176
1177                   --    Const : constant Address := X'Address;
1178                   --    ...
1179                   --    for Y'Address use Const;
1180
1181                   --  then we make an entry in the table for checking the size
1182                   --  and alignment of the overlaying variable. We defer this
1183                   --  check till after code generation to take full advantage
1184                   --  of the annotation done by the back end. This entry is
1185                   --  only made if the address clause comes from source.
1186                   --  If the entity has a generic type, the check will be
1187                   --  performed in the instance if the actual type justifies
1188                   --  it, and we do not insert the clause in the table to
1189                   --  prevent spurious warnings.
1190
1191                   if Address_Clause_Overlay_Warnings
1192                     and then Comes_From_Source (N)
1193                     and then Present (O_Ent)
1194                     and then Is_Object (O_Ent)
1195                   then
1196                      if not Is_Generic_Type (Etype (U_Ent)) then
1197                         Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off));
1198                      end if;
1199
1200                      --  If variable overlays a constant view, and we are
1201                      --  warning on overlays, then mark the variable as
1202                      --  overlaying a constant (we will give warnings later
1203                      --  if this variable is assigned).
1204
1205                      if Is_Constant_Object (O_Ent)
1206                        and then Ekind (U_Ent) = E_Variable
1207                      then
1208                         Set_Overlays_Constant (U_Ent);
1209                      end if;
1210                   end if;
1211                end;
1212
1213             --  Not a valid entity for an address clause
1214
1215             else
1216                Error_Msg_N ("address cannot be given for &", Nam);
1217             end if;
1218          end Address;
1219
1220          ---------------
1221          -- Alignment --
1222          ---------------
1223
1224          --  Alignment attribute definition clause
1225
1226          when Attribute_Alignment => Alignment : declare
1227             Align : constant Uint := Get_Alignment_Value (Expr);
1228
1229          begin
1230             FOnly := True;
1231
1232             if not Is_Type (U_Ent)
1233               and then Ekind (U_Ent) /= E_Variable
1234               and then Ekind (U_Ent) /= E_Constant
1235             then
1236                Error_Msg_N ("alignment cannot be given for &", Nam);
1237
1238             elsif Has_Alignment_Clause (U_Ent) then
1239                Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent));
1240                Error_Msg_N ("alignment clause previously given#", N);
1241
1242             elsif Align /= No_Uint then
1243                Set_Has_Alignment_Clause (U_Ent);
1244                Set_Alignment            (U_Ent, Align);
1245
1246                --  For an array type, U_Ent is the first subtype. In that case,
1247                --  also set the alignment of the anonymous base type so that
1248                --  other subtypes (such as the itypes for aggregates of the
1249                --  type) also receive the expected alignment.
1250
1251                if Is_Array_Type (U_Ent) then
1252                   Set_Alignment (Base_Type (U_Ent), Align);
1253                end if;
1254             end if;
1255          end Alignment;
1256
1257          ---------------
1258          -- Bit_Order --
1259          ---------------
1260
1261          --  Bit_Order attribute definition clause
1262
1263          when Attribute_Bit_Order => Bit_Order : declare
1264          begin
1265             if not Is_Record_Type (U_Ent) then
1266                Error_Msg_N
1267                  ("Bit_Order can only be defined for record type", Nam);
1268
1269             else
1270                Analyze_And_Resolve (Expr, RTE (RE_Bit_Order));
1271
1272                if Etype (Expr) = Any_Type then
1273                   return;
1274
1275                elsif not Is_Static_Expression (Expr) then
1276                   Flag_Non_Static_Expr
1277                     ("Bit_Order requires static expression!", Expr);
1278
1279                else
1280                   if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
1281                      Set_Reverse_Bit_Order (U_Ent, True);
1282                   end if;
1283                end if;
1284             end if;
1285          end Bit_Order;
1286
1287          --------------------
1288          -- Component_Size --
1289          --------------------
1290
1291          --  Component_Size attribute definition clause
1292
1293          when Attribute_Component_Size => Component_Size_Case : declare
1294             Csize    : constant Uint := Static_Integer (Expr);
1295             Ctyp     : Entity_Id;
1296             Btype    : Entity_Id;
1297             Biased   : Boolean;
1298             New_Ctyp : Entity_Id;
1299             Decl     : Node_Id;
1300
1301          begin
1302             if not Is_Array_Type (U_Ent) then
1303                Error_Msg_N ("component size requires array type", Nam);
1304                return;
1305             end if;
1306
1307             Btype := Base_Type (U_Ent);
1308             Ctyp := Component_Type (Btype);
1309
1310             if Has_Component_Size_Clause (Btype) then
1311                Error_Msg_N
1312                  ("component size clause for& previously given", Nam);
1313
1314             elsif Rep_Item_Too_Early (Btype, N) then
1315                null;
1316
1317             elsif Csize /= No_Uint then
1318                Check_Size (Expr, Ctyp, Csize, Biased);
1319
1320                --  For the biased case, build a declaration for a subtype
1321                --  that will be used to represent the biased subtype that
1322                --  reflects the biased representation of components. We need
1323                --  this subtype to get proper conversions on referencing
1324                --  elements of the array. Note that component size clauses
1325                --  are ignored in VM mode.
1326
1327                if VM_Target = No_VM then
1328                   if Biased then
1329                      New_Ctyp :=
1330                        Make_Defining_Identifier (Loc,
1331                          Chars =>
1332                            New_External_Name (Chars (U_Ent), 'C', 0, 'T'));
1333
1334                      Decl :=
1335                        Make_Subtype_Declaration (Loc,
1336                          Defining_Identifier => New_Ctyp,
1337                          Subtype_Indication  =>
1338                            New_Occurrence_Of (Component_Type (Btype), Loc));
1339
1340                      Set_Parent (Decl, N);
1341                      Analyze (Decl, Suppress => All_Checks);
1342
1343                      Set_Has_Delayed_Freeze        (New_Ctyp, False);
1344                      Set_Esize                     (New_Ctyp, Csize);
1345                      Set_RM_Size                   (New_Ctyp, Csize);
1346                      Init_Alignment                (New_Ctyp);
1347                      Set_Is_Itype                  (New_Ctyp, True);
1348                      Set_Associated_Node_For_Itype (New_Ctyp, U_Ent);
1349
1350                      Set_Component_Type (Btype, New_Ctyp);
1351                      Set_Biased (New_Ctyp, N, "component size clause");
1352                   end if;
1353
1354                   Set_Component_Size (Btype, Csize);
1355
1356                --  For VM case, we ignore component size clauses
1357
1358                else
1359                   --  Give a warning unless we are in GNAT mode, in which case
1360                   --  the warning is suppressed since it is not useful.
1361
1362                   if not GNAT_Mode then
1363                      Error_Msg_N
1364                        ("?component size ignored in this configuration", N);
1365                   end if;
1366                end if;
1367
1368                --  Deal with warning on overridden size
1369
1370                if Warn_On_Overridden_Size
1371                  and then Has_Size_Clause (Ctyp)
1372                  and then RM_Size (Ctyp) /= Csize
1373                then
1374                   Error_Msg_NE
1375                     ("?component size overrides size clause for&",
1376                      N, Ctyp);
1377                end if;
1378
1379                Set_Has_Component_Size_Clause (Btype, True);
1380                Set_Has_Non_Standard_Rep (Btype, True);
1381             end if;
1382          end Component_Size_Case;
1383
1384          ------------------
1385          -- External_Tag --
1386          ------------------
1387
1388          when Attribute_External_Tag => External_Tag :
1389          begin
1390             if not Is_Tagged_Type (U_Ent) then
1391                Error_Msg_N ("should be a tagged type", Nam);
1392             end if;
1393
1394             Analyze_And_Resolve (Expr, Standard_String);
1395
1396             if not Is_Static_Expression (Expr) then
1397                Flag_Non_Static_Expr
1398                  ("static string required for tag name!", Nam);
1399             end if;
1400
1401             if VM_Target = No_VM then
1402                Set_Has_External_Tag_Rep_Clause (U_Ent);
1403             else
1404                Error_Msg_Name_1 := Attr;
1405                Error_Msg_N
1406                  ("% attribute unsupported in this configuration", Nam);
1407             end if;
1408
1409             if not Is_Library_Level_Entity (U_Ent) then
1410                Error_Msg_NE
1411                  ("?non-unique external tag supplied for &", N, U_Ent);
1412                Error_Msg_N
1413                  ("?\same external tag applies to all subprogram calls", N);
1414                Error_Msg_N
1415                  ("?\corresponding internal tag cannot be obtained", N);
1416             end if;
1417          end External_Tag;
1418
1419          -----------
1420          -- Input --
1421          -----------
1422
1423          when Attribute_Input =>
1424             Analyze_Stream_TSS_Definition (TSS_Stream_Input);
1425             Set_Has_Specified_Stream_Input (Ent);
1426
1427          -------------------
1428          -- Machine_Radix --
1429          -------------------
1430
1431          --  Machine radix attribute definition clause
1432
1433          when Attribute_Machine_Radix => Machine_Radix : declare
1434             Radix : constant Uint := Static_Integer (Expr);
1435
1436          begin
1437             if not Is_Decimal_Fixed_Point_Type (U_Ent) then
1438                Error_Msg_N ("decimal fixed-point type expected for &", Nam);
1439
1440             elsif Has_Machine_Radix_Clause (U_Ent) then
1441                Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent));
1442                Error_Msg_N ("machine radix clause previously given#", N);
1443
1444             elsif Radix /= No_Uint then
1445                Set_Has_Machine_Radix_Clause (U_Ent);
1446                Set_Has_Non_Standard_Rep (Base_Type (U_Ent));
1447
1448                if Radix = 2 then
1449                   null;
1450                elsif Radix = 10 then
1451                   Set_Machine_Radix_10 (U_Ent);
1452                else
1453                   Error_Msg_N ("machine radix value must be 2 or 10", Expr);
1454                end if;
1455             end if;
1456          end Machine_Radix;
1457
1458          -----------------
1459          -- Object_Size --
1460          -----------------
1461
1462          --  Object_Size attribute definition clause
1463
1464          when Attribute_Object_Size => Object_Size : declare
1465             Size : constant Uint := Static_Integer (Expr);
1466
1467             Biased : Boolean;
1468             pragma Warnings (Off, Biased);
1469
1470          begin
1471             if not Is_Type (U_Ent) then
1472                Error_Msg_N ("Object_Size cannot be given for &", Nam);
1473
1474             elsif Has_Object_Size_Clause (U_Ent) then
1475                Error_Msg_N ("Object_Size already given for &", Nam);
1476
1477             else
1478                Check_Size (Expr, U_Ent, Size, Biased);
1479
1480                if Size /= 8
1481                     and then
1482                   Size /= 16
1483                     and then
1484                   Size /= 32
1485                     and then
1486                   UI_Mod (Size, 64) /= 0
1487                then
1488                   Error_Msg_N
1489                     ("Object_Size must be 8, 16, 32, or multiple of 64",
1490                      Expr);
1491                end if;
1492
1493                Set_Esize (U_Ent, Size);
1494                Set_Has_Object_Size_Clause (U_Ent);
1495                Alignment_Check_For_Esize_Change (U_Ent);
1496             end if;
1497          end Object_Size;
1498
1499          ------------
1500          -- Output --
1501          ------------
1502
1503          when Attribute_Output =>
1504             Analyze_Stream_TSS_Definition (TSS_Stream_Output);
1505             Set_Has_Specified_Stream_Output (Ent);
1506
1507          ----------
1508          -- Read --
1509          ----------
1510
1511          when Attribute_Read =>
1512             Analyze_Stream_TSS_Definition (TSS_Stream_Read);
1513             Set_Has_Specified_Stream_Read (Ent);
1514
1515          ----------
1516          -- Size --
1517          ----------
1518
1519          --  Size attribute definition clause
1520
1521          when Attribute_Size => Size : declare
1522             Size   : constant Uint := Static_Integer (Expr);
1523             Etyp   : Entity_Id;
1524             Biased : Boolean;
1525
1526          begin
1527             FOnly := True;
1528
1529             if Has_Size_Clause (U_Ent) then
1530                Error_Msg_N ("size already given for &", Nam);
1531
1532             elsif not Is_Type (U_Ent)
1533               and then Ekind (U_Ent) /= E_Variable
1534               and then Ekind (U_Ent) /= E_Constant
1535             then
1536                Error_Msg_N ("size cannot be given for &", Nam);
1537
1538             elsif Is_Array_Type (U_Ent)
1539               and then not Is_Constrained (U_Ent)
1540             then
1541                Error_Msg_N
1542                  ("size cannot be given for unconstrained array", Nam);
1543
1544             elsif Size /= No_Uint then
1545
1546                if VM_Target /= No_VM and then not GNAT_Mode then
1547
1548                   --  Size clause is not handled properly on VM targets.
1549                   --  Display a warning unless we are in GNAT mode, in which
1550                   --  case this is useless.
1551
1552                   Error_Msg_N
1553                     ("?size clauses are ignored in this configuration", N);
1554                end if;
1555
1556                if Is_Type (U_Ent) then
1557                   Etyp := U_Ent;
1558                else
1559                   Etyp := Etype (U_Ent);
1560                end if;
1561
1562                --  Check size, note that Gigi is in charge of checking that the
1563                --  size of an array or record type is OK. Also we do not check
1564                --  the size in the ordinary fixed-point case, since it is too
1565                --  early to do so (there may be subsequent small clause that
1566                --  affects the size). We can check the size if a small clause
1567                --  has already been given.
1568
1569                if not Is_Ordinary_Fixed_Point_Type (U_Ent)
1570                  or else Has_Small_Clause (U_Ent)
1571                then
1572                   Check_Size (Expr, Etyp, Size, Biased);
1573                   Set_Biased (U_Ent, N, "size clause", Biased);
1574                end if;
1575
1576                --  For types set RM_Size and Esize if possible
1577
1578                if Is_Type (U_Ent) then
1579                   Set_RM_Size (U_Ent, Size);
1580
1581                   --  For scalar types, increase Object_Size to power of 2, but
1582                   --  not less than a storage unit in any case (i.e., normally
1583                   --  this means it will be byte addressable).
1584
1585                   if Is_Scalar_Type (U_Ent) then
1586                      if Size <= System_Storage_Unit then
1587                         Init_Esize (U_Ent, System_Storage_Unit);
1588                      elsif Size <= 16 then
1589                         Init_Esize (U_Ent, 16);
1590                      elsif Size <= 32 then
1591                         Init_Esize (U_Ent, 32);
1592                      else
1593                         Set_Esize  (U_Ent, (Size + 63) / 64 * 64);
1594                      end if;
1595
1596                   --  For all other types, object size = value size. The
1597                   --  backend will adjust as needed.
1598
1599                   else
1600                      Set_Esize (U_Ent, Size);
1601                   end if;
1602
1603                   Alignment_Check_For_Esize_Change (U_Ent);
1604
1605                --  For objects, set Esize only
1606
1607                else
1608                   if Is_Elementary_Type (Etyp) then
1609                      if Size /= System_Storage_Unit
1610                           and then
1611                         Size /= System_Storage_Unit * 2
1612                           and then
1613                         Size /= System_Storage_Unit * 4
1614                            and then
1615                         Size /= System_Storage_Unit * 8
1616                      then
1617                         Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
1618                         Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
1619                         Error_Msg_N
1620                           ("size for primitive object must be a power of 2"
1621                             & " in the range ^-^", N);
1622                      end if;
1623                   end if;
1624
1625                   Set_Esize (U_Ent, Size);
1626                end if;
1627
1628                Set_Has_Size_Clause (U_Ent);
1629             end if;
1630          end Size;
1631
1632          -----------
1633          -- Small --
1634          -----------
1635
1636          --  Small attribute definition clause
1637
1638          when Attribute_Small => Small : declare
1639             Implicit_Base : constant Entity_Id := Base_Type (U_Ent);
1640             Small         : Ureal;
1641
1642          begin
1643             Analyze_And_Resolve (Expr, Any_Real);
1644
1645             if Etype (Expr) = Any_Type then
1646                return;
1647
1648             elsif not Is_Static_Expression (Expr) then
1649                Flag_Non_Static_Expr
1650                  ("small requires static expression!", Expr);
1651                return;
1652
1653             else
1654                Small := Expr_Value_R (Expr);
1655
1656                if Small <= Ureal_0 then
1657                   Error_Msg_N ("small value must be greater than zero", Expr);
1658                   return;
1659                end if;
1660
1661             end if;
1662
1663             if not Is_Ordinary_Fixed_Point_Type (U_Ent) then
1664                Error_Msg_N
1665                  ("small requires an ordinary fixed point type", Nam);
1666
1667             elsif Has_Small_Clause (U_Ent) then
1668                Error_Msg_N ("small already given for &", Nam);
1669
1670             elsif Small > Delta_Value (U_Ent) then
1671                Error_Msg_N
1672                  ("small value must not be greater then delta value", Nam);
1673
1674             else
1675                Set_Small_Value (U_Ent, Small);
1676                Set_Small_Value (Implicit_Base, Small);
1677                Set_Has_Small_Clause (U_Ent);
1678                Set_Has_Small_Clause (Implicit_Base);
1679                Set_Has_Non_Standard_Rep (Implicit_Base);
1680             end if;
1681          end Small;
1682
1683          ------------------
1684          -- Storage_Pool --
1685          ------------------
1686
1687          --  Storage_Pool attribute definition clause
1688
1689          when Attribute_Storage_Pool => Storage_Pool : declare
1690             Pool : Entity_Id;
1691             T    : Entity_Id;
1692
1693          begin
1694             if Ekind (U_Ent) = E_Access_Subprogram_Type then
1695                Error_Msg_N
1696                  ("storage pool cannot be given for access-to-subprogram type",
1697                   Nam);
1698                return;
1699
1700             elsif not
1701               Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type)
1702             then
1703                Error_Msg_N
1704                  ("storage pool can only be given for access types", Nam);
1705                return;
1706
1707             elsif Is_Derived_Type (U_Ent) then
1708                Error_Msg_N
1709                  ("storage pool cannot be given for a derived access type",
1710                   Nam);
1711
1712             elsif Has_Storage_Size_Clause (U_Ent) then
1713                Error_Msg_N ("storage size already given for &", Nam);
1714                return;
1715
1716             elsif Present (Associated_Storage_Pool (U_Ent)) then
1717                Error_Msg_N ("storage pool already given for &", Nam);
1718                return;
1719             end if;
1720
1721             Analyze_And_Resolve
1722               (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
1723
1724             if not Denotes_Variable (Expr) then
1725                Error_Msg_N ("storage pool must be a variable", Expr);
1726                return;
1727             end if;
1728
1729             if Nkind (Expr) = N_Type_Conversion then
1730                T := Etype (Expression (Expr));
1731             else
1732                T := Etype (Expr);
1733             end if;
1734
1735             --  The Stack_Bounded_Pool is used internally for implementing
1736             --  access types with a Storage_Size. Since it only work
1737             --  properly when used on one specific type, we need to check
1738             --  that it is not hijacked improperly:
1739             --    type T is access Integer;
1740             --    for T'Storage_Size use n;
1741             --    type Q is access Float;
1742             --    for Q'Storage_Size use T'Storage_Size; -- incorrect
1743
1744             if RTE_Available (RE_Stack_Bounded_Pool)
1745               and then Base_Type (T) = RTE (RE_Stack_Bounded_Pool)
1746             then
1747                Error_Msg_N ("non-shareable internal Pool", Expr);
1748                return;
1749             end if;
1750
1751             --  If the argument is a name that is not an entity name, then
1752             --  we construct a renaming operation to define an entity of
1753             --  type storage pool.
1754
1755             if not Is_Entity_Name (Expr)
1756               and then Is_Object_Reference (Expr)
1757             then
1758                Pool := Make_Temporary (Loc, 'P', Expr);
1759
1760                declare
1761                   Rnode : constant Node_Id :=
1762                             Make_Object_Renaming_Declaration (Loc,
1763                               Defining_Identifier => Pool,
1764                               Subtype_Mark        =>
1765                                 New_Occurrence_Of (Etype (Expr), Loc),
1766                               Name                => Expr);
1767
1768                begin
1769                   Insert_Before (N, Rnode);
1770                   Analyze (Rnode);
1771                   Set_Associated_Storage_Pool (U_Ent, Pool);
1772                end;
1773
1774             elsif Is_Entity_Name (Expr) then
1775                Pool := Entity (Expr);
1776
1777                --  If pool is a renamed object, get original one. This can
1778                --  happen with an explicit renaming, and within instances.
1779
1780                while Present (Renamed_Object (Pool))
1781                  and then Is_Entity_Name (Renamed_Object (Pool))
1782                loop
1783                   Pool := Entity (Renamed_Object (Pool));
1784                end loop;
1785
1786                if Present (Renamed_Object (Pool))
1787                  and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion
1788                  and then Is_Entity_Name (Expression (Renamed_Object (Pool)))
1789                then
1790                   Pool := Entity (Expression (Renamed_Object (Pool)));
1791                end if;
1792
1793                Set_Associated_Storage_Pool (U_Ent, Pool);
1794
1795             elsif Nkind (Expr) = N_Type_Conversion
1796               and then Is_Entity_Name (Expression (Expr))
1797               and then Nkind (Original_Node (Expr)) = N_Attribute_Reference
1798             then
1799                Pool := Entity (Expression (Expr));
1800                Set_Associated_Storage_Pool (U_Ent, Pool);
1801
1802             else
1803                Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
1804                return;
1805             end if;
1806          end Storage_Pool;
1807
1808          ------------------
1809          -- Storage_Size --
1810          ------------------
1811
1812          --  Storage_Size attribute definition clause
1813
1814          when Attribute_Storage_Size => Storage_Size : declare
1815             Btype : constant Entity_Id := Base_Type (U_Ent);
1816             Sprag : Node_Id;
1817
1818          begin
1819             if Is_Task_Type (U_Ent) then
1820                Check_Restriction (No_Obsolescent_Features, N);
1821
1822                if Warn_On_Obsolescent_Feature then
1823                   Error_Msg_N
1824                     ("storage size clause for task is an " &
1825                      "obsolescent feature (RM J.9)?", N);
1826                   Error_Msg_N ("\use Storage_Size pragma instead?", N);
1827                end if;
1828
1829                FOnly := True;
1830             end if;
1831
1832             if not Is_Access_Type (U_Ent)
1833               and then Ekind (U_Ent) /= E_Task_Type
1834             then
1835                Error_Msg_N ("storage size cannot be given for &", Nam);
1836
1837             elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then
1838                Error_Msg_N
1839                  ("storage size cannot be given for a derived access type",
1840                   Nam);
1841
1842             elsif Has_Storage_Size_Clause (Btype) then
1843                Error_Msg_N ("storage size already given for &", Nam);
1844
1845             else
1846                Analyze_And_Resolve (Expr, Any_Integer);
1847
1848                if Is_Access_Type (U_Ent) then
1849                   if Present (Associated_Storage_Pool (U_Ent)) then
1850                      Error_Msg_N ("storage pool already given for &", Nam);
1851                      return;
1852                   end if;
1853
1854                   if Is_OK_Static_Expression (Expr)
1855                     and then Expr_Value (Expr) = 0
1856                   then
1857                      Set_No_Pool_Assigned (Btype);
1858                   end if;
1859
1860                else -- Is_Task_Type (U_Ent)
1861                   Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size);
1862
1863                   if Present (Sprag) then
1864                      Error_Msg_Sloc := Sloc (Sprag);
1865                      Error_Msg_N
1866                        ("Storage_Size already specified#", Nam);
1867                      return;
1868                   end if;
1869                end if;
1870
1871                Set_Has_Storage_Size_Clause (Btype);
1872             end if;
1873          end Storage_Size;
1874
1875          -----------------
1876          -- Stream_Size --
1877          -----------------
1878
1879          when Attribute_Stream_Size => Stream_Size : declare
1880             Size : constant Uint := Static_Integer (Expr);
1881
1882          begin
1883             if Ada_Version <= Ada_95 then
1884                Check_Restriction (No_Implementation_Attributes, N);
1885             end if;
1886
1887             if Has_Stream_Size_Clause (U_Ent) then
1888                Error_Msg_N ("Stream_Size already given for &", Nam);
1889
1890             elsif Is_Elementary_Type (U_Ent) then
1891                if Size /= System_Storage_Unit
1892                     and then
1893                   Size /= System_Storage_Unit * 2
1894                     and then
1895                   Size /= System_Storage_Unit * 4
1896                      and then
1897                   Size /= System_Storage_Unit * 8
1898                then
1899                   Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
1900                   Error_Msg_N
1901                     ("stream size for elementary type must be a"
1902                        & " power of 2 and at least ^", N);
1903
1904                elsif RM_Size (U_Ent) > Size then
1905                   Error_Msg_Uint_1 := RM_Size (U_Ent);
1906                   Error_Msg_N
1907                     ("stream size for elementary type must be a"
1908                        & " power of 2 and at least ^", N);
1909                end if;
1910
1911                Set_Has_Stream_Size_Clause (U_Ent);
1912
1913             else
1914                Error_Msg_N ("Stream_Size cannot be given for &", Nam);
1915             end if;
1916          end Stream_Size;
1917
1918          ----------------
1919          -- Value_Size --
1920          ----------------
1921
1922          --  Value_Size attribute definition clause
1923
1924          when Attribute_Value_Size => Value_Size : declare
1925             Size   : constant Uint := Static_Integer (Expr);
1926             Biased : Boolean;
1927
1928          begin
1929             if not Is_Type (U_Ent) then
1930                Error_Msg_N ("Value_Size cannot be given for &", Nam);
1931
1932             elsif Present
1933                    (Get_Attribute_Definition_Clause
1934                      (U_Ent, Attribute_Value_Size))
1935             then
1936                Error_Msg_N ("Value_Size already given for &", Nam);
1937
1938             elsif Is_Array_Type (U_Ent)
1939               and then not Is_Constrained (U_Ent)
1940             then
1941                Error_Msg_N
1942                  ("Value_Size cannot be given for unconstrained array", Nam);
1943
1944             else
1945                if Is_Elementary_Type (U_Ent) then
1946                   Check_Size (Expr, U_Ent, Size, Biased);
1947                   Set_Biased (U_Ent, N, "value size clause", Biased);
1948                end if;
1949
1950                Set_RM_Size (U_Ent, Size);
1951             end if;
1952          end Value_Size;
1953
1954          -----------
1955          -- Write --
1956          -----------
1957
1958          when Attribute_Write =>
1959             Analyze_Stream_TSS_Definition (TSS_Stream_Write);
1960             Set_Has_Specified_Stream_Write (Ent);
1961
1962          --  All other attributes cannot be set
1963
1964          when others =>
1965             Error_Msg_N
1966               ("attribute& cannot be set with definition clause", N);
1967       end case;
1968
1969       --  The test for the type being frozen must be performed after
1970       --  any expression the clause has been analyzed since the expression
1971       --  itself might cause freezing that makes the clause illegal.
1972
1973       if Rep_Item_Too_Late (U_Ent, N, FOnly) then
1974          return;
1975       end if;
1976    end Analyze_Attribute_Definition_Clause;
1977
1978    ----------------------------
1979    -- Analyze_Code_Statement --
1980    ----------------------------
1981
1982    procedure Analyze_Code_Statement (N : Node_Id) is
1983       HSS   : constant Node_Id   := Parent (N);
1984       SBody : constant Node_Id   := Parent (HSS);
1985       Subp  : constant Entity_Id := Current_Scope;
1986       Stmt  : Node_Id;
1987       Decl  : Node_Id;
1988       StmtO : Node_Id;
1989       DeclO : Node_Id;
1990
1991    begin
1992       --  Analyze and check we get right type, note that this implements the
1993       --  requirement (RM 13.8(1)) that Machine_Code be with'ed, since that
1994       --  is the only way that Asm_Insn could possibly be visible.
1995
1996       Analyze_And_Resolve (Expression (N));
1997
1998       if Etype (Expression (N)) = Any_Type then
1999          return;
2000       elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then
2001          Error_Msg_N ("incorrect type for code statement", N);
2002          return;
2003       end if;
2004
2005       Check_Code_Statement (N);
2006
2007       --  Make sure we appear in the handled statement sequence of a
2008       --  subprogram (RM 13.8(3)).
2009
2010       if Nkind (HSS) /= N_Handled_Sequence_Of_Statements
2011         or else Nkind (SBody) /= N_Subprogram_Body
2012       then
2013          Error_Msg_N
2014            ("code statement can only appear in body of subprogram", N);
2015          return;
2016       end if;
2017
2018       --  Do remaining checks (RM 13.8(3)) if not already done
2019
2020       if not Is_Machine_Code_Subprogram (Subp) then
2021          Set_Is_Machine_Code_Subprogram (Subp);
2022
2023          --  No exception handlers allowed
2024
2025          if Present (Exception_Handlers (HSS)) then
2026             Error_Msg_N
2027               ("exception handlers not permitted in machine code subprogram",
2028                First (Exception_Handlers (HSS)));
2029          end if;
2030
2031          --  No declarations other than use clauses and pragmas (we allow
2032          --  certain internally generated declarations as well).
2033
2034          Decl := First (Declarations (SBody));
2035          while Present (Decl) loop
2036             DeclO := Original_Node (Decl);
2037             if Comes_From_Source (DeclO)
2038               and not Nkind_In (DeclO, N_Pragma,
2039                                        N_Use_Package_Clause,
2040                                        N_Use_Type_Clause,
2041                                        N_Implicit_Label_Declaration)
2042             then
2043                Error_Msg_N
2044                  ("this declaration not allowed in machine code subprogram",
2045                   DeclO);
2046             end if;
2047
2048             Next (Decl);
2049          end loop;
2050
2051          --  No statements other than code statements, pragmas, and labels.
2052          --  Again we allow certain internally generated statements.
2053
2054          Stmt := First (Statements (HSS));
2055          while Present (Stmt) loop
2056             StmtO := Original_Node (Stmt);
2057             if Comes_From_Source (StmtO)
2058               and then not Nkind_In (StmtO, N_Pragma,
2059                                             N_Label,
2060                                             N_Code_Statement)
2061             then
2062                Error_Msg_N
2063                  ("this statement is not allowed in machine code subprogram",
2064                   StmtO);
2065             end if;
2066
2067             Next (Stmt);
2068          end loop;
2069       end if;
2070    end Analyze_Code_Statement;
2071
2072    -----------------------------------------------
2073    -- Analyze_Enumeration_Representation_Clause --
2074    -----------------------------------------------
2075
2076    procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is
2077       Ident    : constant Node_Id    := Identifier (N);
2078       Aggr     : constant Node_Id    := Array_Aggregate (N);
2079       Enumtype : Entity_Id;
2080       Elit     : Entity_Id;
2081       Expr     : Node_Id;
2082       Assoc    : Node_Id;
2083       Choice   : Node_Id;
2084       Val      : Uint;
2085       Err      : Boolean := False;
2086
2087       Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer));
2088       Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer));
2089       --  Allowed range of universal integer (= allowed range of enum lit vals)
2090
2091       Min : Uint;
2092       Max : Uint;
2093       --  Minimum and maximum values of entries
2094
2095       Max_Node : Node_Id;
2096       --  Pointer to node for literal providing max value
2097
2098    begin
2099       if Ignore_Rep_Clauses then
2100          return;
2101       end if;
2102
2103       --  First some basic error checks
2104
2105       Find_Type (Ident);
2106       Enumtype := Entity (Ident);
2107
2108       if Enumtype = Any_Type
2109         or else Rep_Item_Too_Early (Enumtype, N)
2110       then
2111          return;
2112       else
2113          Enumtype := Underlying_Type (Enumtype);
2114       end if;
2115
2116       if not Is_Enumeration_Type (Enumtype) then
2117          Error_Msg_NE
2118            ("enumeration type required, found}",
2119             Ident, First_Subtype (Enumtype));
2120          return;
2121       end if;
2122
2123       --  Ignore rep clause on generic actual type. This will already have
2124       --  been flagged on the template as an error, and this is the safest
2125       --  way to ensure we don't get a junk cascaded message in the instance.
2126
2127       if Is_Generic_Actual_Type (Enumtype) then
2128          return;
2129
2130       --  Type must be in current scope
2131
2132       elsif Scope (Enumtype) /= Current_Scope then
2133          Error_Msg_N ("type must be declared in this scope", Ident);
2134          return;
2135
2136       --  Type must be a first subtype
2137
2138       elsif not Is_First_Subtype (Enumtype) then
2139          Error_Msg_N ("cannot give enumeration rep clause for subtype", N);
2140          return;
2141
2142       --  Ignore duplicate rep clause
2143
2144       elsif Has_Enumeration_Rep_Clause (Enumtype) then
2145          Error_Msg_N ("duplicate enumeration rep clause ignored", N);
2146          return;
2147
2148       --  Don't allow rep clause for standard [wide_[wide_]]character
2149
2150       elsif Is_Standard_Character_Type (Enumtype) then
2151          Error_Msg_N ("enumeration rep clause not allowed for this type", N);
2152          return;
2153
2154       --  Check that the expression is a proper aggregate (no parentheses)
2155
2156       elsif Paren_Count (Aggr) /= 0 then
2157          Error_Msg
2158            ("extra parentheses surrounding aggregate not allowed",
2159             First_Sloc (Aggr));
2160          return;
2161
2162       --  All tests passed, so set rep clause in place
2163
2164       else
2165          Set_Has_Enumeration_Rep_Clause (Enumtype);
2166          Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype));
2167       end if;
2168
2169       --  Now we process the aggregate. Note that we don't use the normal
2170       --  aggregate code for this purpose, because we don't want any of the
2171       --  normal expansion activities, and a number of special semantic
2172       --  rules apply (including the component type being any integer type)
2173
2174       Elit := First_Literal (Enumtype);
2175
2176       --  First the positional entries if any
2177
2178       if Present (Expressions (Aggr)) then
2179          Expr := First (Expressions (Aggr));
2180          while Present (Expr) loop
2181             if No (Elit) then
2182                Error_Msg_N ("too many entries in aggregate", Expr);
2183                return;
2184             end if;
2185
2186             Val := Static_Integer (Expr);
2187
2188             --  Err signals that we found some incorrect entries processing
2189             --  the list. The final checks for completeness and ordering are
2190             --  skipped in this case.
2191
2192             if Val = No_Uint then
2193                Err := True;
2194             elsif Val < Lo or else Hi < Val then
2195                Error_Msg_N ("value outside permitted range", Expr);
2196                Err := True;
2197             end if;
2198
2199             Set_Enumeration_Rep (Elit, Val);
2200             Set_Enumeration_Rep_Expr (Elit, Expr);
2201             Next (Expr);
2202             Next (Elit);
2203          end loop;
2204       end if;
2205
2206       --  Now process the named entries if present
2207
2208       if Present (Component_Associations (Aggr)) then
2209          Assoc := First (Component_Associations (Aggr));
2210          while Present (Assoc) loop
2211             Choice := First (Choices (Assoc));
2212
2213             if Present (Next (Choice)) then
2214                Error_Msg_N
2215                  ("multiple choice not allowed here", Next (Choice));
2216                Err := True;
2217             end if;
2218
2219             if Nkind (Choice) = N_Others_Choice then
2220                Error_Msg_N ("others choice not allowed here", Choice);
2221                Err := True;
2222
2223             elsif Nkind (Choice) = N_Range then
2224                --  ??? should allow zero/one element range here
2225                Error_Msg_N ("range not allowed here", Choice);
2226                Err := True;
2227
2228             else
2229                Analyze_And_Resolve (Choice, Enumtype);
2230
2231                if Is_Entity_Name (Choice)
2232                  and then Is_Type (Entity (Choice))
2233                then
2234                   Error_Msg_N ("subtype name not allowed here", Choice);
2235                   Err := True;
2236                   --  ??? should allow static subtype with zero/one entry
2237
2238                elsif Etype (Choice) = Base_Type (Enumtype) then
2239                   if not Is_Static_Expression (Choice) then
2240                      Flag_Non_Static_Expr
2241                        ("non-static expression used for choice!", Choice);
2242                      Err := True;
2243
2244                   else
2245                      Elit := Expr_Value_E (Choice);
2246
2247                      if Present (Enumeration_Rep_Expr (Elit)) then
2248                         Error_Msg_Sloc := Sloc (Enumeration_Rep_Expr (Elit));
2249                         Error_Msg_NE
2250                           ("representation for& previously given#",
2251                            Choice, Elit);
2252                         Err := True;
2253                      end if;
2254
2255                      Set_Enumeration_Rep_Expr (Elit, Expression (Assoc));
2256
2257                      Expr := Expression (Assoc);
2258                      Val := Static_Integer (Expr);
2259
2260                      if Val = No_Uint then
2261                         Err := True;
2262
2263                      elsif Val < Lo or else Hi < Val then
2264                         Error_Msg_N ("value outside permitted range", Expr);
2265                         Err := True;
2266                      end if;
2267
2268                      Set_Enumeration_Rep (Elit, Val);
2269                   end if;
2270                end if;
2271             end if;
2272
2273             Next (Assoc);
2274          end loop;
2275       end if;
2276
2277       --  Aggregate is fully processed. Now we check that a full set of
2278       --  representations was given, and that they are in range and in order.
2279       --  These checks are only done if no other errors occurred.
2280
2281       if not Err then
2282          Min  := No_Uint;
2283          Max  := No_Uint;
2284
2285          Elit := First_Literal (Enumtype);
2286          while Present (Elit) loop
2287             if No (Enumeration_Rep_Expr (Elit)) then
2288                Error_Msg_NE ("missing representation for&!", N, Elit);
2289
2290             else
2291                Val := Enumeration_Rep (Elit);
2292
2293                if Min = No_Uint then
2294                   Min := Val;
2295                end if;
2296
2297                if Val /= No_Uint then
2298                   if Max /= No_Uint and then Val <= Max then
2299                      Error_Msg_NE
2300                        ("enumeration value for& not ordered!",
2301                         Enumeration_Rep_Expr (Elit), Elit);
2302                   end if;
2303
2304                   Max_Node := Enumeration_Rep_Expr (Elit);
2305                   Max := Val;
2306                end if;
2307
2308                --  If there is at least one literal whose representation is not
2309                --  equal to the Pos value, then note that this enumeration type
2310                --  has a non-standard representation.
2311
2312                if Val /= Enumeration_Pos (Elit) then
2313                   Set_Has_Non_Standard_Rep (Base_Type (Enumtype));
2314                end if;
2315             end if;
2316
2317             Next (Elit);
2318          end loop;
2319
2320          --  Now set proper size information
2321
2322          declare
2323             Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype));
2324
2325          begin
2326             if Has_Size_Clause (Enumtype) then
2327
2328                --  All OK, if size is OK now
2329
2330                if RM_Size (Enumtype) >= Minsize then
2331                   null;
2332
2333                else
2334                   --  Try if we can get by with biasing
2335
2336                   Minsize :=
2337                     UI_From_Int (Minimum_Size (Enumtype, Biased => True));
2338
2339                   --  Error message if even biasing does not work
2340
2341                   if RM_Size (Enumtype) < Minsize then
2342                      Error_Msg_Uint_1 := RM_Size (Enumtype);
2343                      Error_Msg_Uint_2 := Max;
2344                      Error_Msg_N
2345                        ("previously given size (^) is too small "
2346                         & "for this value (^)", Max_Node);
2347
2348                   --  If biasing worked, indicate that we now have biased rep
2349
2350                   else
2351                      Set_Biased
2352                        (Enumtype, Size_Clause (Enumtype), "size clause");
2353                   end if;
2354                end if;
2355
2356             else
2357                Set_RM_Size    (Enumtype, Minsize);
2358                Set_Enum_Esize (Enumtype);
2359             end if;
2360
2361             Set_RM_Size   (Base_Type (Enumtype), RM_Size   (Enumtype));
2362             Set_Esize     (Base_Type (Enumtype), Esize     (Enumtype));
2363             Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype));
2364          end;
2365       end if;
2366
2367       --  We repeat the too late test in case it froze itself!
2368
2369       if Rep_Item_Too_Late (Enumtype, N) then
2370          null;
2371       end if;
2372    end Analyze_Enumeration_Representation_Clause;
2373
2374    ----------------------------
2375    -- Analyze_Free_Statement --
2376    ----------------------------
2377
2378    procedure Analyze_Free_Statement (N : Node_Id) is
2379    begin
2380       Analyze (Expression (N));
2381    end Analyze_Free_Statement;
2382
2383    ---------------------------
2384    -- Analyze_Freeze_Entity --
2385    ---------------------------
2386
2387    procedure Analyze_Freeze_Entity (N : Node_Id) is
2388       E : constant Entity_Id := Entity (N);
2389
2390    begin
2391       --  Remember that we are processing a freezing entity. Required to
2392       --  ensure correct decoration of internal entities associated with
2393       --  interfaces (see New_Overloaded_Entity).
2394
2395       Inside_Freezing_Actions := Inside_Freezing_Actions + 1;
2396
2397       --  For tagged types covering interfaces add internal entities that link
2398       --  the primitives of the interfaces with the primitives that cover them.
2399       --  Note: These entities were originally generated only when generating
2400       --  code because their main purpose was to provide support to initialize
2401       --  the secondary dispatch tables. They are now generated also when
2402       --  compiling with no code generation to provide ASIS the relationship
2403       --  between interface primitives and tagged type primitives. They are
2404       --  also used to locate primitives covering interfaces when processing
2405       --  generics (see Derive_Subprograms).
2406
2407       if Ada_Version >= Ada_05
2408         and then Ekind (E) = E_Record_Type
2409         and then Is_Tagged_Type (E)
2410         and then not Is_Interface (E)
2411         and then Has_Interfaces (E)
2412       then
2413          --  This would be a good common place to call the routine that checks
2414          --  overriding of interface primitives (and thus factorize calls to
2415          --  Check_Abstract_Overriding located at different contexts in the
2416          --  compiler). However, this is not possible because it causes
2417          --  spurious errors in case of late overriding.
2418
2419          Add_Internal_Interface_Entities (E);
2420       end if;
2421
2422       --  Check CPP types
2423
2424       if Ekind (E) = E_Record_Type
2425         and then Is_CPP_Class (E)
2426         and then Is_Tagged_Type (E)
2427         and then Tagged_Type_Expansion
2428         and then Expander_Active
2429       then
2430          if CPP_Num_Prims (E) = 0 then
2431
2432             --  If the CPP type has user defined components then it must import
2433             --  primitives from C++. This is required because if the C++ class
2434             --  has no primitives then the C++ compiler does not added the _tag
2435             --  component to the type.
2436
2437             pragma Assert (Chars (First_Entity (E)) = Name_uTag);
2438
2439             if First_Entity (E) /= Last_Entity (E) then
2440                Error_Msg_N
2441                  ("?'C'P'P type must import at least one primitive from C++",
2442                   E);
2443             end if;
2444          end if;
2445
2446          --  Check that all its primitives are abstract or imported from C++.
2447          --  Check also availability of the C++ constructor.
2448
2449          declare
2450             Has_Constructors : constant Boolean := Has_CPP_Constructors (E);
2451             Elmt             : Elmt_Id;
2452             Error_Reported   : Boolean := False;
2453             Prim             : Node_Id;
2454
2455          begin
2456             Elmt := First_Elmt (Primitive_Operations (E));
2457             while Present (Elmt) loop
2458                Prim := Node (Elmt);
2459
2460                if Comes_From_Source (Prim) then
2461                   if Is_Abstract_Subprogram (Prim) then
2462                      null;
2463
2464                   elsif not Is_Imported (Prim)
2465                     or else Convention (Prim) /= Convention_CPP
2466                   then
2467                      Error_Msg_N
2468                        ("?primitives of 'C'P'P types must be imported from C++"
2469                         & " or abstract", Prim);
2470
2471                   elsif not Has_Constructors
2472                      and then not Error_Reported
2473                   then
2474                      Error_Msg_Name_1 := Chars (E);
2475                      Error_Msg_N
2476                        ("?'C'P'P constructor required for type %", Prim);
2477                      Error_Reported := True;
2478                   end if;
2479                end if;
2480
2481                Next_Elmt (Elmt);
2482             end loop;
2483          end;
2484       end if;
2485
2486       Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
2487    end Analyze_Freeze_Entity;
2488
2489    ------------------------------------------
2490    -- Analyze_Record_Representation_Clause --
2491    ------------------------------------------
2492
2493    --  Note: we check as much as we can here, but we can't do any checks
2494    --  based on the position values (e.g. overlap checks) until freeze time
2495    --  because especially in Ada 2005 (machine scalar mode), the processing
2496    --  for non-standard bit order can substantially change the positions.
2497    --  See procedure Check_Record_Representation_Clause (called from Freeze)
2498    --  for the remainder of this processing.
2499
2500    procedure Analyze_Record_Representation_Clause (N : Node_Id) is
2501       Ident   : constant Node_Id := Identifier (N);
2502       Biased  : Boolean;
2503       CC      : Node_Id;
2504       Comp    : Entity_Id;
2505       Fbit    : Uint;
2506       Hbit    : Uint := Uint_0;
2507       Lbit    : Uint;
2508       Ocomp   : Entity_Id;
2509       Posit   : Uint;
2510       Rectype : Entity_Id;
2511
2512       CR_Pragma : Node_Id := Empty;
2513       --  Points to N_Pragma node if Complete_Representation pragma present
2514
2515    begin
2516       if Ignore_Rep_Clauses then
2517          return;
2518       end if;
2519
2520       Find_Type (Ident);
2521       Rectype := Entity (Ident);
2522
2523       if Rectype = Any_Type
2524         or else Rep_Item_Too_Early (Rectype, N)
2525       then
2526          return;
2527       else
2528          Rectype := Underlying_Type (Rectype);
2529       end if;
2530
2531       --  First some basic error checks
2532
2533       if not Is_Record_Type (Rectype) then
2534          Error_Msg_NE
2535            ("record type required, found}", Ident, First_Subtype (Rectype));
2536          return;
2537
2538       elsif Scope (Rectype) /= Current_Scope then
2539          Error_Msg_N ("type must be declared in this scope", N);
2540          return;
2541
2542       elsif not Is_First_Subtype (Rectype) then
2543          Error_Msg_N ("cannot give record rep clause for subtype", N);
2544          return;
2545
2546       elsif Has_Record_Rep_Clause (Rectype) then
2547          Error_Msg_N ("duplicate record rep clause ignored", N);
2548          return;
2549
2550       elsif Rep_Item_Too_Late (Rectype, N) then
2551          return;
2552       end if;
2553
2554       if Present (Mod_Clause (N)) then
2555          declare
2556             Loc     : constant Source_Ptr := Sloc (N);
2557             M       : constant Node_Id := Mod_Clause (N);
2558             P       : constant List_Id := Pragmas_Before (M);
2559             AtM_Nod : Node_Id;
2560
2561             Mod_Val : Uint;
2562             pragma Warnings (Off, Mod_Val);
2563
2564          begin
2565             Check_Restriction (No_Obsolescent_Features, Mod_Clause (N));
2566
2567             if Warn_On_Obsolescent_Feature then
2568                Error_Msg_N
2569                  ("mod clause is an obsolescent feature (RM J.8)?", N);
2570                Error_Msg_N
2571                  ("\use alignment attribute definition clause instead?", N);
2572             end if;
2573
2574             if Present (P) then
2575                Analyze_List (P);
2576             end if;
2577
2578             --  In ASIS_Mode mode, expansion is disabled, but we must convert
2579             --  the Mod clause into an alignment clause anyway, so that the
2580             --  back-end can compute and back-annotate properly the size and
2581             --  alignment of types that may include this record.
2582
2583             --  This seems dubious, this destroys the source tree in a manner
2584             --  not detectable by ASIS ???
2585
2586             if Operating_Mode = Check_Semantics
2587               and then ASIS_Mode
2588             then
2589                AtM_Nod :=
2590                  Make_Attribute_Definition_Clause (Loc,
2591                    Name       => New_Reference_To (Base_Type (Rectype), Loc),
2592                    Chars      => Name_Alignment,
2593                    Expression => Relocate_Node (Expression (M)));
2594
2595                Set_From_At_Mod (AtM_Nod);
2596                Insert_After (N, AtM_Nod);
2597                Mod_Val := Get_Alignment_Value (Expression (AtM_Nod));
2598                Set_Mod_Clause (N, Empty);
2599
2600             else
2601                --  Get the alignment value to perform error checking
2602
2603                Mod_Val := Get_Alignment_Value (Expression (M));
2604             end if;
2605          end;
2606       end if;
2607
2608       --  For untagged types, clear any existing component clauses for the
2609       --  type. If the type is derived, this is what allows us to override
2610       --  a rep clause for the parent. For type extensions, the representation
2611       --  of the inherited components is inherited, so we want to keep previous
2612       --  component clauses for completeness.
2613
2614       if not Is_Tagged_Type (Rectype) then
2615          Comp := First_Component_Or_Discriminant (Rectype);
2616          while Present (Comp) loop
2617             Set_Component_Clause (Comp, Empty);
2618             Next_Component_Or_Discriminant (Comp);
2619          end loop;
2620       end if;
2621
2622       --  All done if no component clauses
2623
2624       CC := First (Component_Clauses (N));
2625
2626       if No (CC) then
2627          return;
2628       end if;
2629
2630       --  A representation like this applies to the base type
2631
2632       Set_Has_Record_Rep_Clause (Base_Type (Rectype));
2633       Set_Has_Non_Standard_Rep  (Base_Type (Rectype));
2634       Set_Has_Specified_Layout  (Base_Type (Rectype));
2635
2636       --  Process the component clauses
2637
2638       while Present (CC) loop
2639
2640          --  Pragma
2641
2642          if Nkind (CC) = N_Pragma then
2643             Analyze (CC);
2644
2645             --  The only pragma of interest is Complete_Representation
2646
2647             if Pragma_Name (CC) = Name_Complete_Representation then
2648                CR_Pragma := CC;
2649             end if;
2650
2651          --  Processing for real component clause
2652
2653          else
2654             Posit := Static_Integer (Position  (CC));
2655             Fbit  := Static_Integer (First_Bit (CC));
2656             Lbit  := Static_Integer (Last_Bit  (CC));
2657
2658             if Posit /= No_Uint
2659               and then Fbit /= No_Uint
2660               and then Lbit /= No_Uint
2661             then
2662                if Posit < 0 then
2663                   Error_Msg_N
2664                     ("position cannot be negative", Position (CC));
2665
2666                elsif Fbit < 0 then
2667                   Error_Msg_N
2668                     ("first bit cannot be negative", First_Bit (CC));
2669
2670                --  The Last_Bit specified in a component clause must not be
2671                --  less than the First_Bit minus one (RM-13.5.1(10)).
2672
2673                elsif Lbit < Fbit - 1 then
2674                   Error_Msg_N
2675                     ("last bit cannot be less than first bit minus one",
2676                      Last_Bit (CC));
2677
2678                --  Values look OK, so find the corresponding record component
2679                --  Even though the syntax allows an attribute reference for
2680                --  implementation-defined components, GNAT does not allow the
2681                --  tag to get an explicit position.
2682
2683                elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then
2684                   if Attribute_Name (Component_Name (CC)) = Name_Tag then
2685                      Error_Msg_N ("position of tag cannot be specified", CC);
2686                   else
2687                      Error_Msg_N ("illegal component name", CC);
2688                   end if;
2689
2690                else
2691                   Comp := First_Entity (Rectype);
2692                   while Present (Comp) loop
2693                      exit when Chars (Comp) = Chars (Component_Name (CC));
2694                      Next_Entity (Comp);
2695                   end loop;
2696
2697                   if No (Comp) then
2698
2699                      --  Maybe component of base type that is absent from
2700                      --  statically constrained first subtype.
2701
2702                      Comp := First_Entity (Base_Type (Rectype));
2703                      while Present (Comp) loop
2704                         exit when Chars (Comp) = Chars (Component_Name (CC));
2705                         Next_Entity (Comp);
2706                      end loop;
2707                   end if;
2708
2709                   if No (Comp) then
2710                      Error_Msg_N
2711                        ("component clause is for non-existent field", CC);
2712
2713                   --  Ada 2012 (AI05-0026): Any name that denotes a
2714                   --  discriminant of an object of an unchecked union type
2715                   --  shall not occur within a record_representation_clause.
2716
2717                   --  The general restriction of using record rep clauses on
2718                   --  Unchecked_Union types has now been lifted. Since it is
2719                   --  possible to introduce a record rep clause which mentions
2720                   --  the discriminant of an Unchecked_Union in non-Ada 2012
2721                   --  code, this check is applied to all versions of the
2722                   --  language.
2723
2724                   elsif Ekind (Comp) = E_Discriminant
2725                     and then Is_Unchecked_Union (Rectype)
2726                   then
2727                      Error_Msg_N
2728                        ("cannot reference discriminant of Unchecked_Union",
2729                         Component_Name (CC));
2730
2731                   elsif Present (Component_Clause (Comp)) then
2732
2733                      --  Diagnose duplicate rep clause, or check consistency
2734                      --  if this is an inherited component. In a double fault,
2735                      --  there may be a duplicate inconsistent clause for an
2736                      --  inherited component.
2737
2738                      if Scope (Original_Record_Component (Comp)) = Rectype
2739                        or else Parent (Component_Clause (Comp)) = N
2740                      then
2741                         Error_Msg_Sloc := Sloc (Component_Clause (Comp));
2742                         Error_Msg_N ("component clause previously given#", CC);
2743
2744                      else
2745                         declare
2746                            Rep1 : constant Node_Id := Component_Clause (Comp);
2747                         begin
2748                            if Intval (Position (Rep1)) /=
2749                                                    Intval (Position (CC))
2750                              or else Intval (First_Bit (Rep1)) /=
2751                                                    Intval (First_Bit (CC))
2752                              or else Intval (Last_Bit (Rep1)) /=
2753                                                    Intval (Last_Bit (CC))
2754                            then
2755                               Error_Msg_N ("component clause inconsistent "
2756                                 & "with representation of ancestor", CC);
2757                            elsif Warn_On_Redundant_Constructs then
2758                               Error_Msg_N ("?redundant component clause "
2759                                 & "for inherited component!", CC);
2760                            end if;
2761                         end;
2762                      end if;
2763
2764                   --  Normal case where this is the first component clause we
2765                   --  have seen for this entity, so set it up properly.
2766
2767                   else
2768                      --  Make reference for field in record rep clause and set
2769                      --  appropriate entity field in the field identifier.
2770
2771                      Generate_Reference
2772                        (Comp, Component_Name (CC), Set_Ref => False);
2773                      Set_Entity (Component_Name (CC), Comp);
2774
2775                      --  Update Fbit and Lbit to the actual bit number
2776
2777                      Fbit := Fbit + UI_From_Int (SSU) * Posit;
2778                      Lbit := Lbit + UI_From_Int (SSU) * Posit;
2779
2780                      if Has_Size_Clause (Rectype)
2781                        and then Esize (Rectype) <= Lbit
2782                      then
2783                         Error_Msg_N
2784                           ("bit number out of range of specified size",
2785                            Last_Bit (CC));
2786                      else
2787                         Set_Component_Clause     (Comp, CC);
2788                         Set_Component_Bit_Offset (Comp, Fbit);
2789                         Set_Esize                (Comp, 1 + (Lbit - Fbit));
2790                         Set_Normalized_First_Bit (Comp, Fbit mod SSU);
2791                         Set_Normalized_Position  (Comp, Fbit / SSU);
2792
2793                         if Warn_On_Overridden_Size
2794                           and then Has_Size_Clause (Etype (Comp))
2795                           and then RM_Size (Etype (Comp)) /= Esize (Comp)
2796                         then
2797                            Error_Msg_NE
2798                              ("?component size overrides size clause for&",
2799                               Component_Name (CC), Etype (Comp));
2800                         end if;
2801
2802                         --  This information is also set in the corresponding
2803                         --  component of the base type, found by accessing the
2804                         --  Original_Record_Component link if it is present.
2805
2806                         Ocomp := Original_Record_Component (Comp);
2807
2808                         if Hbit < Lbit then
2809                            Hbit := Lbit;
2810                         end if;
2811
2812                         Check_Size
2813                           (Component_Name (CC),
2814                            Etype (Comp),
2815                            Esize (Comp),
2816                            Biased);
2817
2818                         Set_Biased
2819                           (Comp, First_Node (CC), "component clause", Biased);
2820
2821                         if Present (Ocomp) then
2822                            Set_Component_Clause     (Ocomp, CC);
2823                            Set_Component_Bit_Offset (Ocomp, Fbit);
2824                            Set_Normalized_First_Bit (Ocomp, Fbit mod SSU);
2825                            Set_Normalized_Position  (Ocomp, Fbit / SSU);
2826                            Set_Esize                (Ocomp, 1 + (Lbit - Fbit));
2827
2828                            Set_Normalized_Position_Max
2829                              (Ocomp, Normalized_Position (Ocomp));
2830
2831                            --  Note: we don't use Set_Biased here, because we
2832                            --  already gave a warning above if needed, and we
2833                            --  would get a duplicate for the same name here.
2834
2835                            Set_Has_Biased_Representation
2836                              (Ocomp, Has_Biased_Representation (Comp));
2837                         end if;
2838
2839                         if Esize (Comp) < 0 then
2840                            Error_Msg_N ("component size is negative", CC);
2841                         end if;
2842                      end if;
2843                   end if;
2844                end if;
2845             end if;
2846          end if;
2847
2848          Next (CC);
2849       end loop;
2850
2851       --  Check missing components if Complete_Representation pragma appeared
2852
2853       if Present (CR_Pragma) then
2854          Comp := First_Component_Or_Discriminant (Rectype);
2855          while Present (Comp) loop
2856             if No (Component_Clause (Comp)) then
2857                Error_Msg_NE
2858                  ("missing component clause for &", CR_Pragma, Comp);
2859             end if;
2860
2861             Next_Component_Or_Discriminant (Comp);
2862          end loop;
2863
2864          --  If no Complete_Representation pragma, warn if missing components
2865
2866       elsif Warn_On_Unrepped_Components then
2867          declare
2868             Num_Repped_Components   : Nat := 0;
2869             Num_Unrepped_Components : Nat := 0;
2870
2871          begin
2872             --  First count number of repped and unrepped components
2873
2874             Comp := First_Component_Or_Discriminant (Rectype);
2875             while Present (Comp) loop
2876                if Present (Component_Clause (Comp)) then
2877                   Num_Repped_Components := Num_Repped_Components + 1;
2878                else
2879                   Num_Unrepped_Components := Num_Unrepped_Components + 1;
2880                end if;
2881
2882                Next_Component_Or_Discriminant (Comp);
2883             end loop;
2884
2885             --  We are only interested in the case where there is at least one
2886             --  unrepped component, and at least half the components have rep
2887             --  clauses. We figure that if less than half have them, then the
2888             --  partial rep clause is really intentional. If the component
2889             --  type has no underlying type set at this point (as for a generic
2890             --  formal type), we don't know enough to give a warning on the
2891             --  component.
2892
2893             if Num_Unrepped_Components > 0
2894               and then Num_Unrepped_Components < Num_Repped_Components
2895             then
2896                Comp := First_Component_Or_Discriminant (Rectype);
2897                while Present (Comp) loop
2898                   if No (Component_Clause (Comp))
2899                     and then Comes_From_Source (Comp)
2900                     and then Present (Underlying_Type (Etype (Comp)))
2901                     and then (Is_Scalar_Type (Underlying_Type (Etype (Comp)))
2902                                or else Size_Known_At_Compile_Time
2903                                          (Underlying_Type (Etype (Comp))))
2904                     and then not Has_Warnings_Off (Rectype)
2905                   then
2906                      Error_Msg_Sloc := Sloc (Comp);
2907                      Error_Msg_NE
2908                        ("?no component clause given for & declared #",
2909                         N, Comp);
2910                   end if;
2911
2912                   Next_Component_Or_Discriminant (Comp);
2913                end loop;
2914             end if;
2915          end;
2916       end if;
2917    end Analyze_Record_Representation_Clause;
2918
2919    -----------------------------------
2920    -- Check_Constant_Address_Clause --
2921    -----------------------------------
2922
2923    procedure Check_Constant_Address_Clause
2924      (Expr  : Node_Id;
2925       U_Ent : Entity_Id)
2926    is
2927       procedure Check_At_Constant_Address (Nod : Node_Id);
2928       --  Checks that the given node N represents a name whose 'Address is
2929       --  constant (in the same sense as OK_Constant_Address_Clause, i.e. the
2930       --  address value is the same at the point of declaration of U_Ent and at
2931       --  the time of elaboration of the address clause.
2932
2933       procedure Check_Expr_Constants (Nod : Node_Id);
2934       --  Checks that Nod meets the requirements for a constant address clause
2935       --  in the sense of the enclosing procedure.
2936
2937       procedure Check_List_Constants (Lst : List_Id);
2938       --  Check that all elements of list Lst meet the requirements for a
2939       --  constant address clause in the sense of the enclosing procedure.
2940
2941       -------------------------------
2942       -- Check_At_Constant_Address --
2943       -------------------------------
2944
2945       procedure Check_At_Constant_Address (Nod : Node_Id) is
2946       begin
2947          if Is_Entity_Name (Nod) then
2948             if Present (Address_Clause (Entity ((Nod)))) then
2949                Error_Msg_NE
2950                  ("invalid address clause for initialized object &!",
2951                            Nod, U_Ent);
2952                Error_Msg_NE
2953                  ("address for& cannot" &
2954                     " depend on another address clause! (RM 13.1(22))!",
2955                   Nod, U_Ent);
2956
2957             elsif In_Same_Source_Unit (Entity (Nod), U_Ent)
2958               and then Sloc (U_Ent) < Sloc (Entity (Nod))
2959             then
2960                Error_Msg_NE
2961                  ("invalid address clause for initialized object &!",
2962                   Nod, U_Ent);
2963                Error_Msg_Node_2 := U_Ent;
2964                Error_Msg_NE
2965                  ("\& must be defined before & (RM 13.1(22))!",
2966                   Nod, Entity (Nod));
2967             end if;
2968
2969          elsif Nkind (Nod) = N_Selected_Component then
2970             declare
2971                T : constant Entity_Id := Etype (Prefix (Nod));
2972
2973             begin
2974                if (Is_Record_Type (T)
2975                     and then Has_Discriminants (T))
2976                  or else
2977                   (Is_Access_Type (T)
2978                      and then Is_Record_Type (Designated_Type (T))
2979                      and then Has_Discriminants (Designated_Type (T)))
2980                then
2981                   Error_Msg_NE
2982                     ("invalid address clause for initialized object &!",
2983                      Nod, U_Ent);
2984                   Error_Msg_N
2985                     ("\address cannot depend on component" &
2986                      " of discriminated record (RM 13.1(22))!",
2987                      Nod);
2988                else
2989                   Check_At_Constant_Address (Prefix (Nod));
2990                end if;
2991             end;
2992
2993          elsif Nkind (Nod) = N_Indexed_Component then
2994             Check_At_Constant_Address (Prefix (Nod));
2995             Check_List_Constants (Expressions (Nod));
2996
2997          else
2998             Check_Expr_Constants (Nod);
2999          end if;
3000       end Check_At_Constant_Address;
3001
3002       --------------------------
3003       -- Check_Expr_Constants --
3004       --------------------------
3005
3006       procedure Check_Expr_Constants (Nod : Node_Id) is
3007          Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent);
3008          Ent       : Entity_Id           := Empty;
3009
3010       begin
3011          if Nkind (Nod) in N_Has_Etype
3012            and then Etype (Nod) = Any_Type
3013          then
3014             return;
3015          end if;
3016
3017          case Nkind (Nod) is
3018             when N_Empty | N_Error =>
3019                return;
3020
3021             when N_Identifier | N_Expanded_Name =>
3022                Ent := Entity (Nod);
3023
3024                --  We need to look at the original node if it is different
3025                --  from the node, since we may have rewritten things and
3026                --  substituted an identifier representing the rewrite.
3027
3028                if Original_Node (Nod) /= Nod then
3029                   Check_Expr_Constants (Original_Node (Nod));
3030
3031                   --  If the node is an object declaration without initial
3032                   --  value, some code has been expanded, and the expression
3033                   --  is not constant, even if the constituents might be
3034                   --  acceptable, as in A'Address + offset.
3035
3036                   if Ekind (Ent) = E_Variable
3037                     and then
3038                       Nkind (Declaration_Node (Ent)) = N_Object_Declaration
3039                     and then
3040                       No (Expression (Declaration_Node (Ent)))
3041                   then
3042                      Error_Msg_NE
3043                        ("invalid address clause for initialized object &!",
3044                         Nod, U_Ent);
3045
3046                   --  If entity is constant, it may be the result of expanding
3047                   --  a check. We must verify that its declaration appears
3048                   --  before the object in question, else we also reject the
3049                   --  address clause.
3050
3051                   elsif Ekind (Ent) = E_Constant
3052                     and then In_Same_Source_Unit (Ent, U_Ent)
3053                     and then Sloc (Ent) > Loc_U_Ent
3054                   then
3055                      Error_Msg_NE
3056                        ("invalid address clause for initialized object &!",
3057                         Nod, U_Ent);
3058                   end if;
3059
3060                   return;
3061                end if;
3062
3063                --  Otherwise look at the identifier and see if it is OK
3064
3065                if Ekind_In (Ent, E_Named_Integer, E_Named_Real)
3066                  or else Is_Type (Ent)
3067                then
3068                   return;
3069
3070                elsif
3071                   Ekind (Ent) = E_Constant
3072                     or else
3073                   Ekind (Ent) = E_In_Parameter
3074                then
3075                   --  This is the case where we must have Ent defined before
3076                   --  U_Ent. Clearly if they are in different units this
3077                   --  requirement is met since the unit containing Ent is
3078                   --  already processed.
3079
3080                   if not In_Same_Source_Unit (Ent, U_Ent) then
3081                      return;
3082
3083                   --  Otherwise location of Ent must be before the location
3084                   --  of U_Ent, that's what prior defined means.
3085
3086                   elsif Sloc (Ent) < Loc_U_Ent then
3087                      return;
3088
3089                   else
3090                      Error_Msg_NE
3091                        ("invalid address clause for initialized object &!",
3092                         Nod, U_Ent);
3093                      Error_Msg_Node_2 := U_Ent;
3094                      Error_Msg_NE
3095                        ("\& must be defined before & (RM 13.1(22))!",
3096                         Nod, Ent);
3097                   end if;
3098
3099                elsif Nkind (Original_Node (Nod)) = N_Function_Call then