OSDN Git Service

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