1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                             E X P _ P A K D                              --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2021, 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
26with Atree;          use Atree;
27with Checks;         use Checks;
28with Einfo;          use Einfo;
29with Einfo.Entities; use Einfo.Entities;
30with Einfo.Utils;    use Einfo.Utils;
31with Errout;         use Errout;
32with Exp_Dbug;       use Exp_Dbug;
33with Exp_Util;       use Exp_Util;
34with Layout;         use Layout;
35with Lib.Xref;       use Lib.Xref;
36with Namet;          use Namet;
37with Nlists;         use Nlists;
38with Nmake;          use Nmake;
39with Opt;            use Opt;
40with Sem;            use Sem;
41with Sem_Aux;        use Sem_Aux;
42with Sem_Ch3;        use Sem_Ch3;
43with Sem_Ch8;        use Sem_Ch8;
44with Sem_Ch13;       use Sem_Ch13;
45with Sem_Eval;       use Sem_Eval;
46with Sem_Res;        use Sem_Res;
47with Sem_Util;       use Sem_Util;
48with Sinfo;          use Sinfo;
49with Sinfo.Nodes;    use Sinfo.Nodes;
50with Sinfo.Utils;    use Sinfo.Utils;
51with Snames;         use Snames;
52with Stand;          use Stand;
53with Targparm;       use Targparm;
54with Tbuild;         use Tbuild;
55with Ttypes;         use Ttypes;
56with Uintp;          use Uintp;
57
58package body Exp_Pakd is
59
60   ---------------------------
61   -- Endian Considerations --
62   ---------------------------
63
64   --  As described in the specification, bit numbering in a packed array
65   --  is consistent with bit numbering in a record representation clause,
66   --  and hence dependent on the endianness of the machine:
67
68   --    For little-endian machines, element zero is at the right hand end
69   --    (low order end) of a bit field.
70
71   --    For big-endian machines, element zero is at the left hand end
72   --    (high order end) of a bit field.
73
74   --  The shifts that are used to right justify a field therefore differ in
75   --  the two cases. For the little-endian case, we can simply use the bit
76   --  number (i.e. the element number * element size) as the count for a right
77   --  shift. For the big-endian case, we have to subtract the shift count from
78   --  an appropriate constant to use in the right shift. We use rotates
79   --  instead of shifts (which is necessary in the store case to preserve
80   --  other fields), and we expect that the backend will be able to change the
81   --  right rotate into a left rotate, avoiding the subtract, if the machine
82   --  architecture provides such an instruction.
83
84   -----------------------
85   -- Local Subprograms --
86   -----------------------
87
88   procedure Compute_Linear_Subscript
89     (Atyp   : Entity_Id;
90      N      : Node_Id;
91      Subscr : out Node_Id);
92   --  Given a constrained array type Atyp, and an indexed component node N
93   --  referencing an array object of this type, build an expression of type
94   --  Standard.Integer representing the zero-based linear subscript value.
95   --  This expression includes any required range checks.
96
97   function Compute_Number_Components
98      (N   : Node_Id;
99       Typ : Entity_Id) return Node_Id;
100   --  Build an expression that multiplies the length of the dimensions of the
101   --  array, used to control array equality checks.
102
103   procedure Convert_To_PAT_Type (Aexp : Node_Id);
104   --  Given an expression of a packed array type, builds a corresponding
105   --  expression whose type is the implementation type used to represent
106   --  the packed array. Aexp is analyzed and resolved on entry and on exit.
107
108   procedure Get_Base_And_Bit_Offset
109     (N      : Node_Id;
110      Base   : out Node_Id;
111      Offset : out Node_Id);
112   --  Given a node N for a name which involves a packed array reference,
113   --  return the base object of the reference and build an expression of
114   --  type Standard.Integer representing the zero-based offset in bits
115   --  from Base'Address to the first bit of the reference.
116
117   function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean;
118   --  There are two versions of the Set routines, the ones used when the
119   --  object is known to be sufficiently well aligned given the number of
120   --  bits, and the ones used when the object is not known to be aligned.
121   --  This routine is used to determine which set to use. Obj is a reference
122   --  to the object, and Csiz is the component size of the packed array.
123   --  True is returned if the alignment of object is known to be sufficient,
124   --  defined as 1 for odd bit sizes, 4 for bit sizes divisible by 4, and
125   --  2 otherwise.
126
127   function Make_Shift_Left (N : Node_Id; S : Node_Id) return Node_Id;
128   --  Build a left shift node, checking for the case of a shift count of zero
129
130   function Make_Shift_Right (N : Node_Id; S : Node_Id) return Node_Id;
131   --  Build a right shift node, checking for the case of a shift count of zero
132
133   function RJ_Unchecked_Convert_To
134     (Typ  : Entity_Id;
135      Expr : Node_Id) return Node_Id;
136   --  The packed array code does unchecked conversions which in some cases
137   --  may involve non-discrete types with differing sizes. The semantics of
138   --  such conversions is potentially endianness dependent, and the effect
139   --  we want here for such a conversion is to do the conversion in size as
140   --  though numeric items are involved, and we extend or truncate on the
141   --  left side. This happens naturally in the little-endian case, but in
142   --  the big endian case we can get left justification, when what we want
143   --  is right justification. This routine does the unchecked conversion in
144   --  a stepwise manner to ensure that it gives the expected result. Hence
145   --  the name (RJ = Right justified). The parameters Typ and Expr are as
146   --  for the case of a normal Unchecked_Convert_To call.
147
148   procedure Setup_Enumeration_Packed_Array_Reference (N : Node_Id);
149   --  This routine is called in the Get and Set case for arrays that are
150   --  packed but not bit-packed, meaning that they have at least one
151   --  subscript that is of an enumeration type with a non-standard
152   --  representation. This routine modifies the given node to properly
153   --  reference the corresponding packed array type.
154
155   procedure Setup_Inline_Packed_Array_Reference
156     (N      : Node_Id;
157      Atyp   : Entity_Id;
158      Obj    : in out Node_Id;
159      Cmask  : out Uint;
160      Shift  : out Node_Id);
161   --  This procedure performs common processing on the N_Indexed_Component
162   --  parameter given as N, whose prefix is a reference to a packed array.
163   --  This is used for the get and set when the component size is 1, 2, 4,
164   --  or for other component sizes when the packed array type is a modular
165   --  type (i.e. the cases that are handled with inline code).
166   --
167   --  On entry:
168   --
169   --    N is the N_Indexed_Component node for the packed array reference
170   --
171   --    Atyp is the constrained array type (the actual subtype has been
172   --    computed if necessary to obtain the constraints, but this is still
173   --    the original array type, not the Packed_Array_Impl_Type value).
174   --
175   --    Obj is the object which is to be indexed. It is always of type Atyp.
176   --
177   --  On return:
178   --
179   --    Obj is the object containing the desired bit field. It is of type
180   --    Unsigned, Long_Unsigned, or Long_Long_Unsigned, and is either the
181   --    entire value, for the small static case, or the proper selected byte
182   --    from the array in the large or dynamic case. This node is analyzed
183   --    and resolved on return.
184   --
185   --    Shift is a node representing the shift count to be used in the
186   --    rotate right instruction that positions the field for access.
187   --    This node is analyzed and resolved on return.
188   --
189   --    Cmask is a mask corresponding to the width of the component field.
190   --    Its value is 2 ** Csize - 1 (e.g. 2#1111# for component size of 4).
191   --
192   --  Note: in some cases the call to this routine may generate actions
193   --  (for handling multi-use references and the generation of the packed
194   --  array type on the fly). Such actions are inserted into the tree
195   --  directly using Insert_Action.
196
197   function Revert_Storage_Order (N : Node_Id) return Node_Id;
198   --  Perform appropriate justification and byte ordering adjustments for N,
199   --  an element of a packed array type, when both the component type and
200   --  the enclosing packed array type have reverse scalar storage order.
201   --  On little-endian targets, the value is left justified before byte
202   --  swapping. The Etype of the returned expression is an integer type of
203   --  an appropriate power-of-2 size.
204
205   --------------------------
206   -- Revert_Storage_Order --
207   --------------------------
208
209   function Revert_Storage_Order (N : Node_Id) return Node_Id is
210      Loc     : constant Source_Ptr := Sloc (N);
211      T       : constant Entity_Id := Etype (N);
212      T_Size  : constant Uint := RM_Size (T);
213
214      Swap_RE : RE_Id;
215      Swap_F  : Entity_Id;
216      Swap_T  : Entity_Id;
217      --  Swapping function
218
219      Arg      : Node_Id;
220      Adjusted : Node_Id;
221      Shift    : Uint;
222
223   begin
224      if T_Size <= 8 then
225
226         --  Array component size is less than a byte: no swapping needed
227
228         Swap_F := Empty;
229         Swap_T := RTE (RE_Unsigned_8);
230
231      else
232         --  Select byte swapping function depending on array component size
233
234         if T_Size <= 16 then
235            Swap_RE := RE_Bswap_16;
236
237         elsif T_Size <= 32 then
238            Swap_RE := RE_Bswap_32;
239
240         elsif T_Size <= 64 then
241            Swap_RE := RE_Bswap_64;
242
243         else pragma Assert (T_Size <= 128);
244            Swap_RE := RE_Bswap_128;
245         end if;
246
247         Swap_F := RTE (Swap_RE);
248         Swap_T := Etype (Swap_F);
249
250      end if;
251
252      Shift := Esize (Swap_T) - T_Size;
253
254      Arg := RJ_Unchecked_Convert_To (Swap_T, N);
255
256      if not Bytes_Big_Endian and then Shift > Uint_0 then
257         Arg :=
258           Make_Op_Shift_Left (Loc,
259             Left_Opnd  => Arg,
260             Right_Opnd => Make_Integer_Literal (Loc, Shift));
261      end if;
262
263      if Present (Swap_F) then
264         Adjusted :=
265           Make_Function_Call (Loc,
266             Name                   => New_Occurrence_Of (Swap_F, Loc),
267             Parameter_Associations => New_List (Arg));
268      else
269         Adjusted := Arg;
270      end if;
271
272      Set_Etype (Adjusted, Swap_T);
273      return Adjusted;
274   end Revert_Storage_Order;
275
276   ------------------------------
277   -- Compute_Linear_Subscript --
278   ------------------------------
279
280   procedure Compute_Linear_Subscript
281     (Atyp   : Entity_Id;
282      N      : Node_Id;
283      Subscr : out Node_Id)
284   is
285      Loc    : constant Source_Ptr := Sloc (N);
286      Oldsub : Node_Id;
287      Newsub : Node_Id;
288      Indx   : Node_Id;
289      Styp   : Entity_Id;
290
291   begin
292      Subscr := Empty;
293
294      --  Loop through dimensions
295
296      Indx   := First_Index (Atyp);
297      Oldsub := First (Expressions (N));
298
299      while Present (Indx) loop
300         Styp := Etype (Indx);
301         Newsub := Relocate_Node (Oldsub);
302
303         --  Get expression for the subscript value. First, if Do_Range_Check
304         --  is set on a subscript, then we must do a range check against the
305         --  original bounds (not the bounds of the packed array type). We do
306         --  this by introducing a subtype conversion.
307
308         if Do_Range_Check (Newsub)
309           and then Etype (Newsub) /= Styp
310         then
311            Newsub := Convert_To (Styp, Newsub);
312         end if;
313
314         --  Now evolve the expression for the subscript. First convert
315         --  the subscript to be zero based and of an integer type.
316
317         --  Case of integer type, where we just subtract to get lower bound
318
319         if Is_Integer_Type (Styp) then
320
321            --  If length of integer type is smaller than standard integer,
322            --  then we convert to integer first, then do the subtract
323
324            --  Integer (subscript) - Integer (Styp'First)
325
326            if Esize (Styp) < Standard_Integer_Size then
327               Newsub :=
328                 Make_Op_Subtract (Loc,
329                   Left_Opnd => Convert_To (Standard_Integer, Newsub),
330                 Right_Opnd =>
331                   Convert_To (Standard_Integer,
332                     Make_Attribute_Reference (Loc,
333                       Prefix         => New_Occurrence_Of (Styp, Loc),
334                       Attribute_Name => Name_First)));
335
336            --  For larger integer types, subtract first, then convert to
337            --  integer, this deals with strange long long integer bounds.
338
339            --    Integer (subscript - Styp'First)
340
341            else
342               Newsub :=
343                 Convert_To (Standard_Integer,
344                   Make_Op_Subtract (Loc,
345                     Left_Opnd => Newsub,
346                   Right_Opnd =>
347                     Make_Attribute_Reference (Loc,
348                       Prefix         => New_Occurrence_Of (Styp, Loc),
349                       Attribute_Name => Name_First)));
350            end if;
351
352         --  For the enumeration case, we have to use 'Pos to get the value
353         --  to work with before subtracting the lower bound.
354
355         --    Integer (Styp'Pos (subscr)) - Integer (Styp'Pos (Styp'First));
356
357         --  This is not quite right for bizarre cases where the size of the
358         --  enumeration type is > Integer'Size bits due to rep clause ???
359
360         else
361            pragma Assert (Is_Enumeration_Type (Styp));
362
363            Newsub :=
364              Make_Op_Subtract (Loc,
365                Left_Opnd => Convert_To (Standard_Integer,
366                  Make_Attribute_Reference (Loc,
367                    Prefix         => New_Occurrence_Of (Styp, Loc),
368                    Attribute_Name => Name_Pos,
369                    Expressions    => New_List (Newsub))),
370
371                Right_Opnd =>
372                  Convert_To (Standard_Integer,
373                    Make_Attribute_Reference (Loc,
374                      Prefix         => New_Occurrence_Of (Styp, Loc),
375                      Attribute_Name => Name_Pos,
376                      Expressions    => New_List (
377                        Make_Attribute_Reference (Loc,
378                          Prefix         => New_Occurrence_Of (Styp, Loc),
379                          Attribute_Name => Name_First)))));
380         end if;
381
382         Set_Paren_Count (Newsub, 1);
383
384         --  For the first subscript, we just copy that subscript value
385
386         if No (Subscr) then
387            Subscr := Newsub;
388
389         --  Otherwise, we must multiply what we already have by the current
390         --  stride and then add in the new value to the evolving subscript.
391
392         else
393            Subscr :=
394              Make_Op_Add (Loc,
395                Left_Opnd =>
396                  Make_Op_Multiply (Loc,
397                    Left_Opnd  => Subscr,
398                    Right_Opnd =>
399                      Make_Attribute_Reference (Loc,
400                        Attribute_Name => Name_Range_Length,
401                        Prefix         => New_Occurrence_Of (Styp, Loc))),
402                Right_Opnd => Newsub);
403         end if;
404
405         --  Move to next subscript
406
407         Next_Index (Indx);
408         Next (Oldsub);
409      end loop;
410   end Compute_Linear_Subscript;
411
412   -------------------------------
413   -- Compute_Number_Components --
414   -------------------------------
415
416   function Compute_Number_Components
417      (N   : Node_Id;
418       Typ : Entity_Id) return Node_Id
419   is
420      Loc      : constant Source_Ptr := Sloc (N);
421      Len_Expr : Node_Id;
422
423   begin
424      Len_Expr :=
425        Make_Attribute_Reference (Loc,
426          Attribute_Name => Name_Length,
427          Prefix         => New_Occurrence_Of (Typ, Loc),
428          Expressions    => New_List (Make_Integer_Literal (Loc, 1)));
429
430      for J in 2 .. Number_Dimensions (Typ) loop
431         Len_Expr :=
432           Make_Op_Multiply (Loc,
433             Left_Opnd  => Len_Expr,
434             Right_Opnd =>
435               Make_Attribute_Reference (Loc,
436                Attribute_Name => Name_Length,
437                Prefix         => New_Occurrence_Of (Typ, Loc),
438                Expressions    => New_List (Make_Integer_Literal (Loc, J))));
439      end loop;
440
441      return Len_Expr;
442   end Compute_Number_Components;
443
444   -------------------------
445   -- Convert_To_PAT_Type --
446   -------------------------
447
448   --  The PAT is always obtained from the actual subtype
449
450   procedure Convert_To_PAT_Type (Aexp : Node_Id) is
451      Act_ST : Entity_Id;
452
453   begin
454      Convert_To_Actual_Subtype (Aexp);
455      Act_ST := Underlying_Type (Etype (Aexp));
456      Create_Packed_Array_Impl_Type (Act_ST);
457
458      --  Just replace the etype with the packed array type. This works because
459      --  the expression will not be further analyzed, and Gigi considers the
460      --  two types equivalent in any case.
461
462      --  This is not strictly the case ??? If the reference is an actual in
463      --  call, the expansion of the prefix is delayed, and must be reanalyzed,
464      --  see Reset_Packed_Prefix. On the other hand, if the prefix is a simple
465      --  array reference, reanalysis can produce spurious type errors when the
466      --  PAT type is replaced again with the original type of the array. Same
467      --  for the case of a dereference. Ditto for function calls: expansion
468      --  may introduce additional actuals which will trigger errors if call is
469      --  reanalyzed. The following is correct and minimal, but the handling of
470      --  more complex packed expressions in actuals is confused. Probably the
471      --  problem only remains for actuals in calls.
472
473      Set_Etype (Aexp, Packed_Array_Impl_Type (Act_ST));
474
475      if Is_Entity_Name (Aexp)
476        or else
477           (Nkind (Aexp) = N_Indexed_Component
478             and then Is_Entity_Name (Prefix (Aexp)))
479        or else Nkind (Aexp) in N_Explicit_Dereference | N_Function_Call
480      then
481         Set_Analyzed (Aexp);
482      end if;
483   end Convert_To_PAT_Type;
484
485   -----------------------------------
486   -- Create_Packed_Array_Impl_Type --
487   -----------------------------------
488
489   procedure Create_Packed_Array_Impl_Type (Typ : Entity_Id) is
490      Loc      : constant Source_Ptr := Sloc (Typ);
491      Ctyp     : constant Entity_Id  := Component_Type (Typ);
492      Csize    : constant Uint       := Component_Size (Typ);
493
494      Ancest   : Entity_Id;
495      PB_Type  : Entity_Id;
496      PASize   : Uint := No_Uint;
497      Decl     : Node_Id;
498      PAT      : Entity_Id;
499      Len_Expr : Node_Id;
500      Len_Bits : Uint;
501      Bits_U1  : Node_Id;
502      PAT_High : Node_Id;
503      Btyp     : Entity_Id;
504      Lit      : Node_Id;
505
506      procedure Install_PAT;
507      --  This procedure is called with Decl set to the declaration for the
508      --  packed array type. It creates the type and installs it as required.
509
510      procedure Set_PB_Type;
511      --  Set PB_Type to [Rev_]Packed_Bytes{1,2,4} as required by the alignment
512      --  and the scalar storage order requirements (see documentation in the
513      --  spec of this package).
514
515      -----------------
516      -- Install_PAT --
517      -----------------
518
519      procedure Install_PAT is
520         Pushed_Scope : Boolean := False;
521
522      begin
523         --  We do not want to put the declaration we have created in the tree
524         --  since it is often hard, and sometimes impossible to find a proper
525         --  place for it (the impossible case arises for a packed array type
526         --  with bounds depending on the discriminant, a declaration cannot
527         --  be put inside the record, and the reference to the discriminant
528         --  cannot be outside the record).
529
530         --  The solution is to analyze the declaration while temporarily
531         --  attached to the tree at an appropriate point, and then we install
532         --  the resulting type as an Itype in the packed array type field of
533         --  the original type, so that no explicit declaration is required.
534
535         --  Note: the packed type is created in the scope of its parent type.
536         --  There are at least some cases where the current scope is deeper,
537         --  and so when this is the case, we temporarily reset the scope
538         --  for the definition. This is clearly safe, since the first use
539         --  of the packed array type will be the implicit reference from
540         --  the corresponding unpacked type when it is elaborated.
541
542         if Is_Itype (Typ) then
543            Set_Parent (Decl, Associated_Node_For_Itype (Typ));
544         else
545            Set_Parent (Decl, Declaration_Node (Typ));
546         end if;
547
548         if Scope (Typ) /= Current_Scope then
549            Push_Scope (Scope (Typ));
550            Pushed_Scope := True;
551         end if;
552
553         Set_Is_Itype (PAT, True);
554         Set_Is_Packed_Array_Impl_Type (PAT, True);
555         Set_Packed_Array_Impl_Type (Typ, PAT);
556         Analyze (Decl, Suppress => All_Checks);
557
558         if Pushed_Scope then
559            Pop_Scope;
560         end if;
561
562         --  Set Esize and RM_Size to the actual size of the packed object
563         --  Do not reset RM_Size if already set, as happens in the case of
564         --  a modular type.
565
566         if Present (PASize) then
567            if not Known_Esize (PAT) then
568               Set_Esize (PAT, PASize);
569            end if;
570
571            if not Known_RM_Size (PAT) then
572               Set_RM_Size (PAT, PASize);
573            end if;
574         end if;
575
576         Adjust_Esize_Alignment (PAT);
577
578         --  Set remaining fields of packed array type
579
580         Reinit_Alignment              (PAT);
581         Set_Parent                    (PAT, Empty);
582         Set_Associated_Node_For_Itype (PAT, Typ);
583         Set_Original_Array_Type       (PAT, Typ);
584
585         --  Propagate representation aspects
586
587         Set_Is_Atomic               (PAT, Is_Atomic                (Typ));
588         Set_Is_Independent          (PAT, Is_Independent           (Typ));
589         Set_Is_Volatile             (PAT, Is_Volatile              (Typ));
590         Set_Is_Volatile_Full_Access (PAT, Is_Volatile_Full_Access  (Typ));
591         Set_Treat_As_Volatile       (PAT, Treat_As_Volatile        (Typ));
592
593         --  We definitely do not want to delay freezing for packed array
594         --  types. This is of particular importance for the itypes that are
595         --  generated for record components depending on discriminants where
596         --  there is no place to put the freeze node.
597
598         Set_Has_Delayed_Freeze (PAT, False);
599         Set_Has_Delayed_Freeze (Etype (PAT), False);
600
601         --  If we did allocate a freeze node, then clear out the reference
602         --  since it is obsolete (should we delete the freeze node???)
603
604         Set_Freeze_Node (PAT, Empty);
605         Set_Freeze_Node (Etype (PAT), Empty);
606      end Install_PAT;
607
608      -----------------
609      -- Set_PB_Type --
610      -----------------
611
612      procedure Set_PB_Type is
613      begin
614         --  If the user has specified an explicit alignment for the
615         --  type or component, take it into account.
616
617         if Csize <= 2 or else Csize = 4 or else Csize mod 2 /= 0
618           or else (Known_Alignment (Typ) and then Alignment (Typ) = 1)
619           or else Component_Alignment (Typ) = Calign_Storage_Unit
620         then
621            if Reverse_Storage_Order (Typ) then
622               PB_Type := RTE (RE_Rev_Packed_Bytes1);
623            else
624               PB_Type := RTE (RE_Packed_Bytes1);
625            end if;
626
627         elsif Csize mod 4 /= 0
628           or else (Known_Alignment (Typ) and then Alignment (Typ) = 2)
629         then
630            if Reverse_Storage_Order (Typ) then
631               PB_Type := RTE (RE_Rev_Packed_Bytes2);
632            else
633               PB_Type := RTE (RE_Packed_Bytes2);
634            end if;
635
636         else
637            if Reverse_Storage_Order (Typ) then
638               PB_Type := RTE (RE_Rev_Packed_Bytes4);
639            else
640               PB_Type := RTE (RE_Packed_Bytes4);
641            end if;
642         end if;
643
644         --  The Rev_Packed_Bytes{1,2,4} types cannot be directly declared with
645         --  the reverse scalar storage order in System.Unsigned_Types because
646         --  their component type is aliased and the combination would then be
647         --  flagged as illegal by the compiler. Moreover changing the compiler
648         --  would not address the bootstrap path issue with earlier versions.
649
650         Set_Reverse_Storage_Order (PB_Type, Reverse_Storage_Order (Typ));
651      end Set_PB_Type;
652
653   --  Start of processing for Create_Packed_Array_Impl_Type
654
655   begin
656      --  If we already have a packed array type, nothing to do
657
658      if Present (Packed_Array_Impl_Type (Typ)) then
659         return;
660      end if;
661
662      --  If our immediate ancestor subtype is constrained, and it already
663      --  has a packed array type, then just share the same type, since the
664      --  bounds must be the same. If the ancestor is not an array type but
665      --  a private type, as can happen with multiple instantiations, create
666      --  a new packed type, to avoid privacy issues.
667
668      if Ekind (Typ) = E_Array_Subtype then
669         Ancest := Ancestor_Subtype (Typ);
670
671         if Present (Ancest)
672           and then Is_Array_Type (Ancest)
673           and then Is_Constrained (Ancest)
674           and then Present (Packed_Array_Impl_Type (Ancest))
675         then
676            Set_Packed_Array_Impl_Type (Typ, Packed_Array_Impl_Type (Ancest));
677            return;
678         end if;
679      end if;
680
681      --  We preset the result type size from the size of the original array
682      --  type, since this size clearly belongs to the packed array type. The
683      --  size of the conceptual unpacked type is always set to unknown.
684
685      if Known_RM_Size (Typ) then
686         PASize := RM_Size (Typ);
687      end if;
688
689      --  Case of an array where at least one index is of an enumeration
690      --  type with a non-standard representation, but the component size
691      --  is not appropriate for bit packing. This is the case where we
692      --  have Is_Packed set (we would never be in this unit otherwise),
693      --  but Is_Bit_Packed_Array is false.
694
695      --  Note that if the component size is appropriate for bit packing,
696      --  then the circuit for the computation of the subscript properly
697      --  deals with the non-standard enumeration type case by taking the
698      --  Pos anyway.
699
700      if not Is_Bit_Packed_Array (Typ) then
701
702         --  Here we build a declaration:
703
704         --    type tttP is array (index1, index2, ...) of component_type
705
706         --  where index1, index2, are the index types. These are the same
707         --  as the index types of the original array, except for the non-
708         --  standard representation enumeration type case, where we have
709         --  two subcases.
710
711         --  For the unconstrained array case, we use
712
713         --    Natural range <>
714
715         --  For the constrained case, we use
716
717         --    Natural range Enum_Type'Pos (Enum_Type'First) ..
718         --                  Enum_Type'Pos (Enum_Type'Last);
719
720         --  Note that tttP is created even if no index subtype is a non
721         --  standard enumeration, because we still need to remove padding
722         --  normally inserted for component alignment.
723
724         PAT :=
725           Make_Defining_Identifier (Loc,
726             Chars => New_External_Name (Chars (Typ), 'P'));
727
728         declare
729            Indexes   : constant List_Id := New_List;
730            Indx      : Node_Id;
731            Indx_Typ  : Entity_Id;
732            Enum_Case : Boolean;
733            Typedef   : Node_Id;
734
735         begin
736            Indx := First_Index (Typ);
737
738            while Present (Indx) loop
739               Indx_Typ := Etype (Indx);
740
741               Enum_Case := Is_Enumeration_Type (Indx_Typ)
742                              and then Has_Non_Standard_Rep (Indx_Typ);
743
744               --  Unconstrained case
745
746               if not Is_Constrained (Typ) then
747                  if Enum_Case then
748                     Indx_Typ := Standard_Natural;
749                  end if;
750
751                  Append_To (Indexes, New_Occurrence_Of (Indx_Typ, Loc));
752
753               --  Constrained case
754
755               else
756                  if not Enum_Case then
757                     Append_To (Indexes, New_Occurrence_Of (Indx_Typ, Loc));
758
759                  else
760                     Append_To (Indexes,
761                       Make_Subtype_Indication (Loc,
762                         Subtype_Mark =>
763                           New_Occurrence_Of (Standard_Natural, Loc),
764                         Constraint =>
765                           Make_Range_Constraint (Loc,
766                             Range_Expression =>
767                               Make_Range (Loc,
768                                 Low_Bound =>
769                                   Make_Attribute_Reference (Loc,
770                                     Prefix         =>
771                                       New_Occurrence_Of (Indx_Typ, Loc),
772                                     Attribute_Name => Name_Pos,
773                                     Expressions    => New_List (
774                                       Make_Attribute_Reference (Loc,
775                                         Prefix         =>
776                                           New_Occurrence_Of (Indx_Typ, Loc),
777                                         Attribute_Name => Name_First))),
778
779                                 High_Bound =>
780                                   Make_Attribute_Reference (Loc,
781                                     Prefix         =>
782                                       New_Occurrence_Of (Indx_Typ, Loc),
783                                     Attribute_Name => Name_Pos,
784                                     Expressions    => New_List (
785                                       Make_Attribute_Reference (Loc,
786                                         Prefix         =>
787                                           New_Occurrence_Of (Indx_Typ, Loc),
788                                         Attribute_Name => Name_Last)))))));
789
790                  end if;
791               end if;
792
793               Next_Index (Indx);
794            end loop;
795
796            if not Is_Constrained (Typ) then
797               Typedef :=
798                 Make_Unconstrained_Array_Definition (Loc,
799                   Subtype_Marks => Indexes,
800                   Component_Definition =>
801                     Make_Component_Definition (Loc,
802                       Aliased_Present    => False,
803                       Subtype_Indication =>
804                          New_Occurrence_Of (Ctyp, Loc)));
805
806            else
807               Typedef :=
808                  Make_Constrained_Array_Definition (Loc,
809                    Discrete_Subtype_Definitions => Indexes,
810                    Component_Definition =>
811                      Make_Component_Definition (Loc,
812                        Aliased_Present    => False,
813                        Subtype_Indication =>
814                          New_Occurrence_Of (Ctyp, Loc)));
815            end if;
816
817            Decl :=
818              Make_Full_Type_Declaration (Loc,
819                Defining_Identifier => PAT,
820                Type_Definition     => Typedef);
821         end;
822
823         Install_PAT;
824
825         --  Propagate the reverse storage order flag to the base type
826
827         Set_Reverse_Storage_Order (Etype (PAT), Reverse_Storage_Order (Typ));
828         return;
829
830      --  Case of bit-packing required for unconstrained array. We create
831      --  a subtype that is equivalent to use Packed_Bytes{1,2,4} as needed.
832
833      elsif not Is_Constrained (Typ) then
834
835         --  When generating standard DWARF (i.e when GNAT_Encodings is not
836         --  DWARF_GNAT_Encodings_All), the ___XP suffix will be stripped
837         --  by the back-end but generate it anyway to ease compiler debugging.
838         --  This will help to distinguish implementation types from original
839         --  packed arrays.
840
841         PAT :=
842           Make_Defining_Identifier (Loc,
843             Chars => Make_Packed_Array_Impl_Type_Name (Typ, Csize));
844
845         Set_PB_Type;
846
847         Decl :=
848           Make_Subtype_Declaration (Loc,
849             Defining_Identifier => PAT,
850               Subtype_Indication => New_Occurrence_Of (PB_Type, Loc));
851
852         Install_PAT;
853         return;
854
855      --  Remaining code is for the case of bit-packing for constrained array
856
857      --  The name of the packed array subtype is
858
859      --    ttt___XPsss
860
861      --  where sss is the component size in bits and ttt is the name of
862      --  the parent packed type.
863
864      else
865         PAT :=
866           Make_Defining_Identifier (Loc,
867             Chars => Make_Packed_Array_Impl_Type_Name (Typ, Csize));
868
869         --  Build an expression for the length of the array in bits.
870         --  This is the product of the length of each of the dimensions
871
872         Len_Expr := Compute_Number_Components (Typ, Typ);
873
874         --  Temporarily attach the length expression to the tree and analyze
875         --  and resolve it, so that we can test its value. We assume that the
876         --  total length fits in type Integer. This expression may involve
877         --  discriminants, so we treat it as a default/per-object expression.
878
879         Set_Parent (Len_Expr, Typ);
880         Preanalyze_Spec_Expression (Len_Expr, Standard_Long_Long_Integer);
881
882         --  Use a modular type if possible. We can do this if we have
883         --  static bounds, and the length is small enough, and the length
884         --  is not zero. We exclude the zero length case because the size
885         --  of things is always at least one, and the zero length object
886         --  would have an anomalous size.
887
888         if Compile_Time_Known_Value (Len_Expr) then
889            Len_Bits := Expr_Value (Len_Expr) * Csize;
890
891            --  Check for size known to be too large
892
893            if Len_Bits >
894              Uint_2 ** (Standard_Integer_Size - 1) * System_Storage_Unit
895            then
896               if System_Storage_Unit = 8 then
897                  Error_Msg_N
898                    ("packed array size cannot exceed " &
899                     "Integer''Last bytes", Typ);
900               else
901                  Error_Msg_N
902                    ("packed array size cannot exceed " &
903                     "Integer''Last storage units", Typ);
904               end if;
905
906               --  Reset length to arbitrary not too high value to continue
907
908               Len_Expr := Make_Integer_Literal (Loc, 65535);
909               Analyze_And_Resolve (Len_Expr, Standard_Long_Long_Integer);
910            end if;
911
912            --  We normally consider small enough to mean no larger than the
913            --  value of System_Max_Binary_Modulus_Power, checking that in the
914            --  case of values longer than word size, we have long shifts.
915
916            if Len_Bits > 0
917              and then
918                (Len_Bits <= System_Word_Size
919                   or else (Len_Bits <= System_Max_Binary_Modulus_Power
920                              and then Support_Long_Shifts_On_Target))
921            then
922               --  We can use the modular type, it has the form:
923
924               --    subtype tttPn is btyp
925               --      range 0 .. 2 ** ((Typ'Length (1)
926               --                * ... * Typ'Length (n)) * Csize) - 1;
927
928               --  The bounds are statically known, and btyp is one of the
929               --  unsigned types, depending on the length.
930
931               Btyp := Small_Integer_Type_For (Len_Bits, Uns => True);
932               Lit := Make_Integer_Literal (Loc, 2 ** Len_Bits - 1);
933               Set_Print_In_Hex (Lit);
934
935               Decl :=
936                 Make_Subtype_Declaration (Loc,
937                   Defining_Identifier => PAT,
938                     Subtype_Indication =>
939                       Make_Subtype_Indication (Loc,
940                         Subtype_Mark => New_Occurrence_Of (Btyp, Loc),
941
942                         Constraint =>
943                           Make_Range_Constraint (Loc,
944                             Range_Expression =>
945                               Make_Range (Loc,
946                                 Low_Bound =>
947                                   Make_Integer_Literal (Loc, 0),
948                                 High_Bound => Lit))));
949
950               if Present (PASize) then
951                  PASize := Len_Bits;
952               end if;
953
954               Install_PAT;
955
956               --  Propagate a given alignment to the modular type. This can
957               --  cause it to be under-aligned, but that's OK.
958
959               if Present (Alignment_Clause (Typ)) then
960                  Set_Alignment (PAT, Alignment (Typ));
961               end if;
962
963               return;
964            end if;
965         end if;
966
967         --  Could not use a modular type, for all other cases, we build
968         --  a packed array subtype:
969
970         --    subtype tttPn is
971         --      System.Packed_Bytes{1,2,4} (0 .. (Bits + 7) / 8 - 1);
972
973         --  Bits is the length of the array in bits
974
975         Set_PB_Type;
976
977         Bits_U1 :=
978           Make_Op_Add (Loc,
979             Left_Opnd =>
980               Make_Op_Multiply (Loc,
981                 Left_Opnd  =>
982                   Make_Integer_Literal (Loc, Csize),
983                 Right_Opnd => Len_Expr),
984
985             Right_Opnd =>
986               Make_Integer_Literal (Loc, 7));
987
988         Set_Paren_Count (Bits_U1, 1);
989
990         PAT_High :=
991           Make_Op_Subtract (Loc,
992             Left_Opnd =>
993               Make_Op_Divide (Loc,
994                 Left_Opnd => Bits_U1,
995                 Right_Opnd => Make_Integer_Literal (Loc, 8)),
996             Right_Opnd => Make_Integer_Literal (Loc, 1));
997
998         Decl :=
999           Make_Subtype_Declaration (Loc,
1000             Defining_Identifier => PAT,
1001               Subtype_Indication =>
1002                 Make_Subtype_Indication (Loc,
1003                   Subtype_Mark => New_Occurrence_Of (PB_Type, Loc),
1004                   Constraint =>
1005                     Make_Index_Or_Discriminant_Constraint (Loc,
1006                       Constraints => New_List (
1007                         Make_Range (Loc,
1008                           Low_Bound =>
1009                             Make_Integer_Literal (Loc, 0),
1010                           High_Bound =>
1011                             Convert_To (Standard_Integer, PAT_High))))));
1012
1013         Install_PAT;
1014
1015         --  Currently the code in this unit requires that packed arrays
1016         --  represented by non-modular arrays of bytes be on a byte
1017         --  boundary for bit sizes handled by System.Pack_nn units.
1018         --  That's because these units assume the array being accessed
1019         --  starts on a byte boundary.
1020
1021         if Get_Id (UI_To_Int (Csize)) /= RE_Null then
1022            Set_Must_Be_On_Byte_Boundary (Typ);
1023         end if;
1024      end if;
1025   end Create_Packed_Array_Impl_Type;
1026
1027   -----------------------------------
1028   -- Expand_Bit_Packed_Element_Set --
1029   -----------------------------------
1030
1031   procedure Expand_Bit_Packed_Element_Set (N : Node_Id) is
1032      Loc : constant Source_Ptr := Sloc (N);
1033      Lhs : constant Node_Id    := Name (N);
1034
1035      Ass_OK : constant Boolean := Assignment_OK (Lhs);
1036      --  Used to preserve assignment OK status when assignment is rewritten
1037
1038      Expr : Node_Id;
1039
1040      Rhs  : Node_Id := Expression (N);
1041      --  Initially Rhs is the right hand side value, it will be replaced
1042      --  later by an appropriate unchecked conversion for the assignment.
1043
1044      Obj   : Node_Id;
1045      Atyp  : Entity_Id;
1046      PAT   : Entity_Id;
1047      Ctyp  : Entity_Id;
1048      Csiz  : Int;
1049      Cmask : Uint;
1050
1051      Shift : Node_Id;
1052      --  The expression for the shift value that is required
1053
1054      Shift_Used : Boolean := False;
1055      --  Set True if Shift has been used in the generated code at least once,
1056      --  so that it must be duplicated if used again.
1057
1058      New_Lhs : Node_Id;
1059      New_Rhs : Node_Id;
1060
1061      Rhs_Val_Known : Boolean;
1062      Rhs_Val       : Uint;
1063      --  If the value of the right hand side as an integer constant is
1064      --  known at compile time, Rhs_Val_Known is set True, and Rhs_Val
1065      --  contains the value. Otherwise Rhs_Val_Known is set False, and
1066      --  the Rhs_Val is undefined.
1067
1068      function Get_Shift return Node_Id;
1069      --  Function used to get the value of Shift, making sure that it
1070      --  gets duplicated if the function is called more than once.
1071
1072      ---------------
1073      -- Get_Shift --
1074      ---------------
1075
1076      function Get_Shift return Node_Id is
1077      begin
1078         --  If we used the shift value already, then duplicate it. We
1079         --  set a temporary parent in case actions have to be inserted.
1080
1081         if Shift_Used then
1082            Set_Parent (Shift, N);
1083            return Duplicate_Subexpr_No_Checks (Shift);
1084
1085         --  If first time, use Shift unchanged, and set flag for first use
1086
1087         else
1088            Shift_Used := True;
1089            return Shift;
1090         end if;
1091      end Get_Shift;
1092
1093   --  Start of processing for Expand_Bit_Packed_Element_Set
1094
1095   begin
1096      pragma Assert (Is_Bit_Packed_Array (Etype (Prefix (Lhs))));
1097
1098      Obj := Relocate_Node (Prefix (Lhs));
1099      Convert_To_Actual_Subtype (Obj);
1100      Atyp := Etype (Obj);
1101      PAT  := Packed_Array_Impl_Type (Atyp);
1102      Ctyp := Component_Type (Atyp);
1103      Csiz := UI_To_Int (Component_Size (Atyp));
1104
1105      --  We remove side effects, in case the rhs modifies the lhs, because we
1106      --  are about to transform the rhs into an expression that first READS
1107      --  the lhs, so we can do the necessary shifting and masking. Example:
1108      --  "X(2) := F(...);" where F modifies X(3). Otherwise, the side effect
1109      --  will be lost.
1110
1111      Remove_Side_Effects (Rhs);
1112
1113      --  We convert the right hand side to the proper subtype to ensure
1114      --  that an appropriate range check is made (since the normal range
1115      --  check from assignment will be lost in the transformations). This
1116      --  conversion is analyzed immediately so that subsequent processing
1117      --  can work with an analyzed Rhs (and e.g. look at its Etype)
1118
1119      --  If the right-hand side is a string literal, create a temporary for
1120      --  it, constant-folding is not ready to wrap the bit representation
1121      --  of a string literal.
1122
1123      if Nkind (Rhs) = N_String_Literal then
1124         declare
1125            Decl : Node_Id;
1126         begin
1127            Decl :=
1128              Make_Object_Declaration (Loc,
1129                Defining_Identifier => Make_Temporary (Loc, 'T', Rhs),
1130                Object_Definition   => New_Occurrence_Of (Ctyp, Loc),
1131                Expression          => New_Copy_Tree (Rhs));
1132
1133            Insert_Actions (N, New_List (Decl));
1134            Rhs := New_Occurrence_Of (Defining_Identifier (Decl), Loc);
1135         end;
1136      end if;
1137
1138      Rhs := Convert_To (Ctyp, Rhs);
1139      Set_Parent (Rhs, N);
1140
1141      --  If we are building the initialization procedure for a packed array,
1142      --  and Initialize_Scalars is enabled, each component assignment is an
1143      --  out-of-range value by design. Compile this value without checks,
1144      --  because a call to the array init_proc must not raise an exception.
1145
1146      --  Condition is not consistent with description above, Within_Init_Proc
1147      --  is True also when we are building the IP for a record or protected
1148      --  type that has a packed array component???
1149
1150      if Within_Init_Proc
1151        and then Initialize_Scalars
1152      then
1153         Analyze_And_Resolve (Rhs, Ctyp, Suppress => All_Checks);
1154      else
1155         Analyze_And_Resolve (Rhs, Ctyp);
1156      end if;
1157
1158      --  If any of the indices has a nonstandard representation, introduce
1159      --  the proper Rep_To_Pos conversion, which in turn will generate index
1160      --  checks when needed. We do this on a copy of the index expression,
1161      --  rather that rewriting the LHS altogether.
1162
1163      Expr := First (Expressions (Lhs));
1164      while Present (Expr) loop
1165         declare
1166            Expr_Typ : constant Entity_Id  := Etype (Expr);
1167            Loc      : constant Source_Ptr := Sloc  (Expr);
1168
1169            Expr_Copy : Node_Id;
1170
1171         begin
1172            if Is_Enumeration_Type (Expr_Typ)
1173              and then Has_Non_Standard_Rep (Expr_Typ)
1174            then
1175               Expr_Copy :=
1176                 Make_Attribute_Reference (Loc,
1177                   Prefix         => New_Occurrence_Of (Expr_Typ, Loc),
1178                   Attribute_Name => Name_Pos,
1179                   Expressions    => New_List (Relocate_Node (Expr)));
1180               Set_Parent (Expr_Copy, N);
1181               Analyze_And_Resolve (Expr_Copy, Standard_Natural);
1182            end if;
1183         end;
1184
1185         Next (Expr);
1186      end loop;
1187
1188      --  Case of component size 1,2,4 or any component size for the modular
1189      --  case. These are the cases for which we can inline the code.
1190
1191      if Csiz = 1 or else Csiz = 2 or else Csiz = 4
1192        or else (Present (PAT) and then Is_Modular_Integer_Type (PAT))
1193      then
1194         Setup_Inline_Packed_Array_Reference (Lhs, Atyp, Obj, Cmask, Shift);
1195
1196         --  The statement to be generated is:
1197
1198         --    Obj := atyp!((Obj and Mask1) or (shift_left (rhs, Shift)))
1199
1200         --  or in the case of a freestanding Reverse_Storage_Order object,
1201
1202         --    Obj := Swap (atyp!((Swap (Obj) and Mask1)
1203         --                         or (shift_left (rhs, Shift))))
1204
1205         --      where Mask1 is obtained by shifting Cmask left Shift bits
1206         --      and then complementing the result.
1207
1208         --      the "and Mask1" is omitted if rhs is constant and all 1 bits
1209
1210         --      the "or ..." is omitted if rhs is constant and all 0 bits
1211
1212         --      rhs is converted to the appropriate type
1213
1214         --      The result is converted back to the array type, since
1215         --      otherwise we lose knowledge of the packed nature.
1216
1217         --  Determine if right side is all 0 bits or all 1 bits
1218
1219         if Compile_Time_Known_Value (Rhs) then
1220            Rhs_Val       := Expr_Rep_Value (Rhs);
1221            Rhs_Val_Known := True;
1222
1223         --  The following test catches the case of an unchecked conversion of
1224         --  an integer literal. This results from optimizing aggregates of
1225         --  packed types.
1226
1227         elsif Nkind (Rhs) = N_Unchecked_Type_Conversion
1228           and then Compile_Time_Known_Value (Expression (Rhs))
1229         then
1230            Rhs_Val       := Expr_Rep_Value (Expression (Rhs));
1231            Rhs_Val_Known := True;
1232
1233         else
1234            Rhs_Val       := No_Uint;
1235            Rhs_Val_Known := False;
1236         end if;
1237
1238         --  Some special checks for the case where the right hand value is
1239         --  known at compile time. Basically we have to take care of the
1240         --  implicit conversion to the subtype of the component object.
1241
1242         if Rhs_Val_Known then
1243
1244            --  If we have a biased component type then we must manually do the
1245            --  biasing, since we are taking responsibility in this case for
1246            --  constructing the exact bit pattern to be used.
1247
1248            if Has_Biased_Representation (Ctyp) then
1249               Rhs_Val := Rhs_Val - Expr_Rep_Value (Type_Low_Bound (Ctyp));
1250            end if;
1251
1252            --  For a negative value, we manually convert the two's complement
1253            --  value to a corresponding unsigned value, so that the proper
1254            --  field width is maintained. If we did not do this, we would
1255            --  get too many leading sign bits later on.
1256
1257            if Rhs_Val < 0 then
1258               Rhs_Val := 2 ** UI_From_Int (Csiz) + Rhs_Val;
1259            end if;
1260         end if;
1261
1262         --  Now create copies removing side effects. Note that in some complex
1263         --  cases, this may cause the fact that we have already set a packed
1264         --  array type on Obj to get lost. So we save the type of Obj, and
1265         --  make sure it is reset properly.
1266
1267         declare
1268            T : constant Entity_Id := Etype (Obj);
1269         begin
1270            New_Lhs := Duplicate_Subexpr (Obj, Name_Req => True);
1271            New_Rhs := Duplicate_Subexpr_No_Checks (Obj);
1272            Set_Etype (Obj, T);
1273            Set_Etype (New_Lhs, T);
1274            Set_Etype (New_Rhs, T);
1275         end;
1276
1277         --  First we deal with the "and"
1278
1279         if not Rhs_Val_Known or else Rhs_Val /= Cmask then
1280            declare
1281               Mask1 : Node_Id;
1282               Lit   : Node_Id;
1283
1284            begin
1285               if Compile_Time_Known_Value (Shift) then
1286                  Mask1 :=
1287                    Make_Integer_Literal (Loc,
1288                      Modulus (Etype (Obj)) - 1 -
1289                                 (Cmask * (2 ** Expr_Value (Get_Shift))));
1290                  Set_Print_In_Hex (Mask1);
1291
1292               else
1293                  Lit := Make_Integer_Literal (Loc, Cmask);
1294                  Set_Print_In_Hex (Lit);
1295                  Mask1 :=
1296                    Make_Op_Not (Loc,
1297                      Right_Opnd => Make_Shift_Left (Lit, Get_Shift));
1298               end if;
1299
1300               New_Rhs :=
1301                 Make_Op_And (Loc,
1302                   Left_Opnd  => New_Rhs,
1303                   Right_Opnd => Mask1);
1304            end;
1305         end if;
1306
1307         --  Then deal with the "or"
1308
1309         if not Rhs_Val_Known or else Rhs_Val /= 0 then
1310            declare
1311               Or_Rhs : Node_Id;
1312
1313               procedure Fixup_Rhs;
1314               --  Adjust Rhs by bias if biased representation for components
1315               --  or remove extraneous high order sign bits if signed.
1316
1317               procedure Fixup_Rhs is
1318                  Etyp : constant Entity_Id := Etype (Rhs);
1319
1320               begin
1321                  --  For biased case, do the required biasing by simply
1322                  --  converting to the biased subtype (the conversion
1323                  --  will generate the required bias).
1324
1325                  if Has_Biased_Representation (Ctyp) then
1326                     Rhs := Convert_To (Ctyp, Rhs);
1327
1328                  --  For a signed integer type that is not biased, generate
1329                  --  a conversion to unsigned to strip high order sign bits.
1330
1331                  elsif Is_Signed_Integer_Type (Ctyp) then
1332                     Rhs := Unchecked_Convert_To (RTE (Bits_Id (Csiz)), Rhs);
1333                  end if;
1334
1335                  --  Set Etype, since it can be referenced before the node is
1336                  --  completely analyzed.
1337
1338                  Set_Etype (Rhs, Etyp);
1339
1340                  --  We now need to do an unchecked conversion of the
1341                  --  result to the target type, but it is important that
1342                  --  this conversion be a right justified conversion and
1343                  --  not a left justified conversion.
1344
1345                  Rhs := RJ_Unchecked_Convert_To (Etype (Obj), Rhs);
1346               end Fixup_Rhs;
1347
1348            begin
1349               if Rhs_Val_Known
1350                 and then Compile_Time_Known_Value (Get_Shift)
1351               then
1352                  Or_Rhs :=
1353                    Make_Integer_Literal (Loc,
1354                      Rhs_Val * (2 ** Expr_Value (Get_Shift)));
1355                  Set_Print_In_Hex (Or_Rhs);
1356
1357               else
1358                  --  We have to convert the right hand side to Etype (Obj).
1359                  --  A special case arises if what we have now is a Val
1360                  --  attribute reference whose expression type is Etype (Obj).
1361                  --  This happens for assignments of fields from the same
1362                  --  array. In this case we get the required right hand side
1363                  --  by simply removing the inner attribute reference.
1364
1365                  if Nkind (Rhs) = N_Attribute_Reference
1366                    and then Attribute_Name (Rhs) = Name_Val
1367                    and then Etype (First (Expressions (Rhs))) = Etype (Obj)
1368                  then
1369                     Rhs := Relocate_Node (First (Expressions (Rhs)));
1370                     Fixup_Rhs;
1371
1372                  --  If the value of the right hand side is a known integer
1373                  --  value, then just replace it by an untyped constant,
1374                  --  which will be properly retyped when we analyze and
1375                  --  resolve the expression.
1376
1377                  elsif Rhs_Val_Known then
1378
1379                     --  Note that Rhs_Val has already been normalized to
1380                     --  be an unsigned value with the proper number of bits.
1381
1382                     Rhs := Make_Integer_Literal (Loc, Rhs_Val);
1383
1384                  --  Otherwise we need an unchecked conversion
1385
1386                  else
1387                     Fixup_Rhs;
1388                  end if;
1389
1390                  Or_Rhs := Make_Shift_Left (Rhs, Get_Shift);
1391               end if;
1392
1393               if Nkind (New_Rhs) = N_Op_And then
1394                  Set_Paren_Count (New_Rhs, 1);
1395                  Set_Etype (New_Rhs, Etype (Left_Opnd (New_Rhs)));
1396               end if;
1397
1398               New_Rhs :=
1399                 Make_Op_Or (Loc,
1400                   Left_Opnd  => New_Rhs,
1401                   Right_Opnd => Or_Rhs);
1402            end;
1403         end if;
1404
1405         --  Now do the rewrite
1406
1407         Rewrite (N,
1408           Make_Assignment_Statement (Loc,
1409             Name       => New_Lhs,
1410             Expression =>
1411               Unchecked_Convert_To (Etype (New_Lhs), New_Rhs)));
1412         Set_Assignment_OK (Name (N), Ass_OK);
1413
1414      --  All other component sizes for non-modular case
1415
1416      else
1417         --  We generate
1418
1419         --    Set_nn (Arr'address, Subscr, Bits_nn!(Rhs))
1420
1421         --  where Subscr is the computed linear subscript
1422
1423         declare
1424            Bits_nn : constant Entity_Id := RTE (Bits_Id (Csiz));
1425            Set_nn  : Entity_Id;
1426            Subscr  : Node_Id;
1427            Atyp    : Entity_Id;
1428            Rev_SSO : Node_Id;
1429
1430         begin
1431            if No (Bits_nn) then
1432
1433               --  Error, most likely High_Integrity_Mode restriction
1434
1435               return;
1436            end if;
1437
1438            --  Acquire proper Set entity. We use the aligned or unaligned
1439            --  case as appropriate.
1440
1441            if Known_Aligned_Enough (Obj, Csiz) then
1442               Set_nn := RTE (Set_Id (Csiz));
1443            else
1444               Set_nn := RTE (SetU_Id (Csiz));
1445            end if;
1446
1447            --  Now generate the set reference
1448
1449            Obj := Relocate_Node (Prefix (Lhs));
1450            Convert_To_Actual_Subtype (Obj);
1451            Atyp := Etype (Obj);
1452            Compute_Linear_Subscript (Atyp, Lhs, Subscr);
1453
1454            --  Set indication of whether the packed array has reverse SSO
1455
1456            Rev_SSO :=
1457              New_Occurrence_Of
1458                (Boolean_Literals (Reverse_Storage_Order (Atyp)), Loc);
1459
1460            --  Below we must make the assumption that Obj is
1461            --  at least byte aligned, since otherwise its address
1462            --  cannot be taken. The assumption holds since the
1463            --  only arrays that can be misaligned are small packed
1464            --  arrays which are implemented as a modular type, and
1465            --  that is not the case here.
1466
1467            Rewrite (N,
1468              Make_Procedure_Call_Statement (Loc,
1469                  Name => New_Occurrence_Of (Set_nn, Loc),
1470                  Parameter_Associations => New_List (
1471                    Make_Attribute_Reference (Loc,
1472                      Prefix         => Obj,
1473                      Attribute_Name => Name_Address),
1474                    Subscr,
1475                    Unchecked_Convert_To (Bits_nn, Convert_To (Ctyp, Rhs)),
1476                    Rev_SSO)));
1477
1478         end;
1479      end if;
1480
1481      Analyze (N, Suppress => All_Checks);
1482   end Expand_Bit_Packed_Element_Set;
1483
1484   -------------------------------------
1485   -- Expand_Packed_Address_Reference --
1486   -------------------------------------
1487
1488   procedure Expand_Packed_Address_Reference (N : Node_Id) is
1489      Loc    : constant Source_Ptr := Sloc (N);
1490      Base   : Node_Id;
1491      Offset : Node_Id;
1492
1493   begin
1494      --  We build an expression that has the form
1495
1496      --    outer_object'Address
1497      --      + (linear-subscript * component_size  for each array reference
1498      --      +  field'Bit_Position                 for each record field
1499      --      +  ...
1500      --      +  ...) / Storage_Unit;
1501
1502      Get_Base_And_Bit_Offset (Prefix (N), Base, Offset);
1503
1504      Rewrite (N,
1505        Unchecked_Convert_To (RTE (RE_Address),
1506          Make_Op_Add (Loc,
1507            Left_Opnd =>
1508              Unchecked_Convert_To (RTE (RE_Integer_Address),
1509                Make_Attribute_Reference (Loc,
1510                  Prefix         => Base,
1511                  Attribute_Name => Name_Address)),
1512
1513            Right_Opnd =>
1514              Unchecked_Convert_To (RTE (RE_Integer_Address),
1515                Make_Op_Divide (Loc,
1516                  Left_Opnd => Offset,
1517                  Right_Opnd =>
1518                    Make_Integer_Literal (Loc, System_Storage_Unit))))));
1519
1520      Analyze_And_Resolve (N, RTE (RE_Address));
1521   end Expand_Packed_Address_Reference;
1522
1523   ---------------------------------
1524   -- Expand_Packed_Bit_Reference --
1525   ---------------------------------
1526
1527   procedure Expand_Packed_Bit_Reference (N : Node_Id) is
1528      Loc    : constant Source_Ptr := Sloc (N);
1529      Base   : Node_Id;
1530      Offset : Node_Id;
1531
1532   begin
1533      --  We build an expression that has the form
1534
1535      --    (linear-subscript * component_size      for each array reference
1536      --      +  field'Bit_Position                 for each record field
1537      --      +  ...
1538      --      +  ...) mod Storage_Unit;
1539
1540      Get_Base_And_Bit_Offset (Prefix (N), Base, Offset);
1541
1542      Rewrite (N,
1543        Unchecked_Convert_To (Standard_Natural,
1544          Make_Op_Mod (Loc,
1545            Left_Opnd => Offset,
1546            Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit))));
1547
1548      Analyze_And_Resolve (N, Standard_Natural);
1549   end Expand_Packed_Bit_Reference;
1550
1551   ------------------------------------
1552   -- Expand_Packed_Boolean_Operator --
1553   ------------------------------------
1554
1555   --  This routine expands "a op b" for the packed cases
1556
1557   procedure Expand_Packed_Boolean_Operator (N : Node_Id) is
1558      Loc : constant Source_Ptr := Sloc (N);
1559      Typ : constant Entity_Id  := Etype (N);
1560      L   : constant Node_Id    := Relocate_Node (Left_Opnd  (N));
1561      R   :          Node_Id    := Relocate_Node (Right_Opnd (N));
1562
1563      Ltyp : Entity_Id;
1564      Rtyp : Entity_Id;
1565      PAT  : Entity_Id;
1566
1567   begin
1568      Convert_To_Actual_Subtype (L);
1569      Convert_To_Actual_Subtype (R);
1570
1571      Ensure_Defined (Etype (L), N);
1572      Ensure_Defined (Etype (R), N);
1573
1574      Apply_Length_Check (R, Etype (L));
1575
1576      Ltyp := Etype (L);
1577      Rtyp := Etype (R);
1578
1579      --  Deal with silly case of XOR where the subcomponent has a range
1580      --  True .. True where an exception must be raised.
1581
1582      if Nkind (N) = N_Op_Xor then
1583         R := Duplicate_Subexpr (R);
1584         Silly_Boolean_Array_Xor_Test (N, R, Rtyp);
1585      end if;
1586
1587      --  Now that silliness is taken care of, get packed array type
1588
1589      Convert_To_PAT_Type (L);
1590      Convert_To_PAT_Type (R);
1591
1592      PAT := Etype (L);
1593
1594      --  For the modular case, we expand a op b into
1595
1596      --    rtyp!(pat!(a) op pat!(b))
1597
1598      --  where rtyp is the Etype of the left operand. Note that we do not
1599      --  convert to the base type, since this would be unconstrained, and
1600      --  hence not have a corresponding packed array type set.
1601
1602      --  Note that both operands must be modular for this code to be used
1603
1604      if Is_Modular_Integer_Type (PAT)
1605           and then
1606         Is_Modular_Integer_Type (Etype (R))
1607      then
1608         declare
1609            P : Node_Id;
1610
1611         begin
1612            if Nkind (N) = N_Op_And then
1613               P := Make_Op_And (Loc, L, R);
1614
1615            elsif Nkind (N) = N_Op_Or then
1616               P := Make_Op_Or  (Loc, L, R);
1617
1618            else -- Nkind (N) = N_Op_Xor
1619               P := Make_Op_Xor (Loc, L, R);
1620            end if;
1621
1622            Rewrite (N, Unchecked_Convert_To (Ltyp, P));
1623         end;
1624
1625      --  For the array case, we insert the actions
1626
1627      --    Result : Ltype;
1628
1629      --    System.Bit_Ops.Bit_And/Or/Xor
1630      --     (Left'Address,
1631      --      Ltype'Length * Ltype'Component_Size;
1632      --      Right'Address,
1633      --      Rtype'Length * Rtype'Component_Size
1634      --      Result'Address);
1635
1636      --  where Left and Right are the Packed_Bytes{1,2,4} operands and
1637      --  the second argument and fourth arguments are the lengths of the
1638      --  operands in bits. Then we replace the expression by a reference
1639      --  to Result.
1640
1641      --  Note that if we are mixing a modular and array operand, everything
1642      --  works fine, since we ensure that the modular representation has the
1643      --  same physical layout as the array representation (that's what the
1644      --  left justified modular stuff in the big-endian case is about).
1645
1646      else
1647         declare
1648            Result_Ent : constant Entity_Id := Make_Temporary (Loc, 'T');
1649            E_Id       : RE_Id;
1650
1651         begin
1652            if Nkind (N) = N_Op_And then
1653               E_Id := RE_Bit_And;
1654
1655            elsif Nkind (N) = N_Op_Or then
1656               E_Id := RE_Bit_Or;
1657
1658            else -- Nkind (N) = N_Op_Xor
1659               E_Id := RE_Bit_Xor;
1660            end if;
1661
1662            Insert_Actions (N, New_List (
1663
1664              Make_Object_Declaration (Loc,
1665                Defining_Identifier => Result_Ent,
1666                Object_Definition => New_Occurrence_Of (Ltyp, Loc)),
1667
1668              Make_Procedure_Call_Statement (Loc,
1669                Name => New_Occurrence_Of (RTE (E_Id), Loc),
1670                  Parameter_Associations => New_List (
1671
1672                    Make_Byte_Aligned_Attribute_Reference (Loc,
1673                      Prefix         => L,
1674                      Attribute_Name => Name_Address),
1675
1676                    Make_Op_Multiply (Loc,
1677                      Left_Opnd =>
1678                        Make_Attribute_Reference (Loc,
1679                          Prefix         =>
1680                            New_Occurrence_Of
1681                              (Etype (First_Index (Ltyp)), Loc),
1682                          Attribute_Name => Name_Range_Length),
1683
1684                      Right_Opnd =>
1685                        Make_Integer_Literal (Loc, Component_Size (Ltyp))),
1686
1687                    Make_Byte_Aligned_Attribute_Reference (Loc,
1688                      Prefix         => R,
1689                      Attribute_Name => Name_Address),
1690
1691                    Make_Op_Multiply (Loc,
1692                      Left_Opnd =>
1693                        Make_Attribute_Reference (Loc,
1694                          Prefix         =>
1695                            New_Occurrence_Of
1696                              (Etype (First_Index (Rtyp)), Loc),
1697                          Attribute_Name => Name_Range_Length),
1698
1699                      Right_Opnd =>
1700                        Make_Integer_Literal (Loc, Component_Size (Rtyp))),
1701
1702                    Make_Byte_Aligned_Attribute_Reference (Loc,
1703                      Prefix => New_Occurrence_Of (Result_Ent, Loc),
1704                      Attribute_Name => Name_Address)))));
1705
1706            Rewrite (N,
1707              New_Occurrence_Of (Result_Ent, Loc));
1708         end;
1709      end if;
1710
1711      Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
1712   end Expand_Packed_Boolean_Operator;
1713
1714   -------------------------------------
1715   -- Expand_Packed_Element_Reference --
1716   -------------------------------------
1717
1718   procedure Expand_Packed_Element_Reference (N : Node_Id) is
1719      Loc   : constant Source_Ptr := Sloc (N);
1720      Obj   : Node_Id;
1721      Atyp  : Entity_Id;
1722      PAT   : Entity_Id;
1723      Ctyp  : Entity_Id;
1724      Csiz  : Int;
1725      Shift : Node_Id;
1726      Cmask : Uint;
1727      Lit   : Node_Id;
1728      Arg   : Node_Id;
1729
1730   begin
1731      --  If the node is an actual in a call, the prefix has not been fully
1732      --  expanded, to account for the additional expansion for in-out actuals
1733      --  (see expand_actuals for details). If the prefix itself is a packed
1734      --  reference as well, we have to recurse to complete the transformation
1735      --  of the prefix.
1736
1737      if Nkind (Prefix (N)) = N_Indexed_Component
1738        and then not Analyzed (Prefix (N))
1739        and then Is_Bit_Packed_Array (Etype (Prefix (Prefix (N))))
1740      then
1741         Expand_Packed_Element_Reference (Prefix (N));
1742      end if;
1743
1744      --  The prefix may be rewritten below as a conversion. If it is a source
1745      --  entity generate reference to it now, to prevent spurious warnings
1746      --  about unused entities.
1747
1748      if Is_Entity_Name (Prefix (N))
1749        and then Comes_From_Source (Prefix (N))
1750      then
1751         Generate_Reference (Entity (Prefix (N)), Prefix (N), 'r');
1752      end if;
1753
1754      --  If not bit packed, we have the enumeration case, which is easily
1755      --  dealt with (just adjust the subscripts of the indexed component)
1756
1757      --  Note: this leaves the result as an indexed component, which is
1758      --  still a variable, so can be used in the assignment case, as is
1759      --  required in the enumeration case.
1760
1761      if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
1762         Setup_Enumeration_Packed_Array_Reference (N);
1763         return;
1764      end if;
1765
1766      --  Remaining processing is for the bit-packed case
1767
1768      Obj := Relocate_Node (Prefix (N));
1769      Convert_To_Actual_Subtype (Obj);
1770      Atyp := Etype (Obj);
1771      PAT  := Packed_Array_Impl_Type (Atyp);
1772      Ctyp := Component_Type (Atyp);
1773      Csiz := UI_To_Int (Component_Size (Atyp));
1774
1775      --  Case of component size 1,2,4 or any component size for the modular
1776      --  case. These are the cases for which we can inline the code.
1777
1778      if Csiz = 1 or else Csiz = 2 or else Csiz = 4
1779        or else (Present (PAT) and then Is_Modular_Integer_Type (PAT))
1780      then
1781         Setup_Inline_Packed_Array_Reference (N, Atyp, Obj, Cmask, Shift);
1782         Lit := Make_Integer_Literal (Loc, Cmask);
1783         Set_Print_In_Hex (Lit);
1784
1785         --  We generate a shift right to position the field, followed by a
1786         --  masking operation to extract the bit field, and we finally do an
1787         --  unchecked conversion to convert the result to the required target.
1788
1789         --  Note that the unchecked conversion automatically deals with the
1790         --  bias if we are dealing with a biased representation. What will
1791         --  happen is that we temporarily generate the biased representation,
1792         --  but almost immediately that will be converted to the original
1793         --  unbiased component type, and the bias will disappear.
1794
1795         Arg :=
1796           Make_Op_And (Loc,
1797             Left_Opnd  => Make_Shift_Right (Obj, Shift),
1798             Right_Opnd => Lit);
1799         Set_Etype (Arg, Ctyp);
1800
1801         --  Component extraction is performed on a native endianness scalar
1802         --  value: if Atyp has reverse storage order, then it has been byte
1803         --  swapped, and if the component being extracted is itself of a
1804         --  composite type with reverse storage order, then we need to swap
1805         --  it back to its expected endianness after extraction.
1806
1807         if Reverse_Storage_Order (Atyp)
1808           and then (Is_Record_Type (Ctyp) or else Is_Array_Type (Ctyp))
1809           and then Reverse_Storage_Order (Ctyp)
1810         then
1811            Arg := Revert_Storage_Order (Arg);
1812         end if;
1813
1814         --  We needed to analyze this before we do the unchecked convert
1815         --  below, but we need it temporarily attached to the tree for
1816         --  this analysis (hence the temporary Set_Parent call).
1817
1818         Set_Parent (Arg, Parent (N));
1819         Analyze_And_Resolve (Arg);
1820
1821         Rewrite (N, RJ_Unchecked_Convert_To (Ctyp, Arg));
1822
1823      --  All other component sizes for non-modular case
1824
1825      else
1826         --  We generate
1827
1828         --    Component_Type!(Get_nn (Arr'address, Subscr))
1829
1830         --  where Subscr is the computed linear subscript
1831
1832         declare
1833            Get_nn  : Entity_Id;
1834            Subscr  : Node_Id;
1835            Rev_SSO : constant Node_Id :=
1836              New_Occurrence_Of
1837                (Boolean_Literals (Reverse_Storage_Order (Atyp)), Loc);
1838
1839         begin
1840            --  Acquire proper Get entity. We use the aligned or unaligned
1841            --  case as appropriate.
1842
1843            if Known_Aligned_Enough (Obj, Csiz) then
1844               Get_nn := RTE (Get_Id (Csiz));
1845            else
1846               Get_nn := RTE (GetU_Id (Csiz));
1847            end if;
1848
1849            --  Now generate the get reference
1850
1851            Compute_Linear_Subscript (Atyp, N, Subscr);
1852
1853            --  Below we make the assumption that Obj is at least byte
1854            --  aligned, since otherwise its address cannot be taken.
1855            --  The assumption holds since the only arrays that can be
1856            --  misaligned are small packed arrays which are implemented
1857            --  as a modular type, and that is not the case here.
1858
1859            Rewrite (N,
1860              Unchecked_Convert_To (Ctyp,
1861                Make_Function_Call (Loc,
1862                  Name => New_Occurrence_Of (Get_nn, Loc),
1863                  Parameter_Associations => New_List (
1864                    Make_Attribute_Reference (Loc,
1865                      Prefix         => Obj,
1866                      Attribute_Name => Name_Address),
1867                    Subscr,
1868                    Rev_SSO))));
1869         end;
1870      end if;
1871
1872      Analyze_And_Resolve (N, Ctyp, Suppress => All_Checks);
1873   end Expand_Packed_Element_Reference;
1874
1875   ----------------------
1876   -- Expand_Packed_Eq --
1877   ----------------------
1878
1879   --  Handles expansion of "=" on packed array types
1880
1881   procedure Expand_Packed_Eq (N : Node_Id) is
1882      Loc : constant Source_Ptr := Sloc (N);
1883      L   : constant Node_Id    := Relocate_Node (Left_Opnd  (N));
1884      R   : constant Node_Id    := Relocate_Node (Right_Opnd (N));
1885
1886      LLexpr : Node_Id;
1887      RLexpr : Node_Id;
1888
1889      Ltyp : Entity_Id;
1890      Rtyp : Entity_Id;
1891      PAT  : Entity_Id;
1892
1893   begin
1894      Convert_To_Actual_Subtype (L);
1895      Convert_To_Actual_Subtype (R);
1896      Ltyp := Underlying_Type (Etype (L));
1897      Rtyp := Underlying_Type (Etype (R));
1898
1899      Convert_To_PAT_Type (L);
1900      Convert_To_PAT_Type (R);
1901      PAT := Etype (L);
1902
1903      LLexpr :=
1904        Make_Op_Multiply (Loc,
1905          Left_Opnd  => Compute_Number_Components (N, Ltyp),
1906          Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Ltyp)));
1907
1908      RLexpr :=
1909        Make_Op_Multiply (Loc,
1910          Left_Opnd  => Compute_Number_Components (N, Rtyp),
1911          Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Rtyp)));
1912
1913      --  For the modular case, we transform the comparison to:
1914
1915      --    Ltyp'Length = Rtyp'Length and then PAT!(L) = PAT!(R)
1916
1917      --  where PAT is the packed array type. This works fine, since in the
1918      --  modular case we guarantee that the unused bits are always zeroes.
1919      --  We do have to compare the lengths because we could be comparing
1920      --  two different subtypes of the same base type. We can only do this
1921      --  if the PATs on both sides are the same.
1922
1923      if Is_Modular_Integer_Type (PAT) and then PAT = Etype (R) then
1924         Rewrite (N,
1925           Make_And_Then (Loc,
1926             Left_Opnd =>
1927               Make_Op_Eq (Loc,
1928                 Left_Opnd  => LLexpr,
1929                 Right_Opnd => RLexpr),
1930
1931             Right_Opnd =>
1932               Make_Op_Eq (Loc,
1933                 Left_Opnd => L,
1934                 Right_Opnd => R)));
1935
1936      --  For the non-modular case, we call a runtime routine
1937
1938      --    System.Bit_Ops.Bit_Eq
1939      --      (L'Address, L_Length, R'Address, R_Length)
1940
1941      --  where PAT is the packed array type, and the lengths are the lengths
1942      --  in bits of the original packed arrays. This routine takes care of
1943      --  not comparing the unused bits in the last byte.
1944
1945      else
1946         Rewrite (N,
1947           Make_Function_Call (Loc,
1948             Name => New_Occurrence_Of (RTE (RE_Bit_Eq), Loc),
1949             Parameter_Associations => New_List (
1950               Make_Byte_Aligned_Attribute_Reference (Loc,
1951                 Prefix         => L,
1952                 Attribute_Name => Name_Address),
1953
1954               LLexpr,
1955
1956               Make_Byte_Aligned_Attribute_Reference (Loc,
1957                 Prefix         => R,
1958                 Attribute_Name => Name_Address),
1959
1960               RLexpr)));
1961      end if;
1962
1963      Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
1964   end Expand_Packed_Eq;
1965
1966   -----------------------
1967   -- Expand_Packed_Not --
1968   -----------------------
1969
1970   --  Handles expansion of "not" on packed array types
1971
1972   procedure Expand_Packed_Not (N : Node_Id) is
1973      Loc  : constant Source_Ptr := Sloc (N);
1974      Typ  : constant Entity_Id  := Etype (N);
1975      Opnd : constant Node_Id    := Relocate_Node (Right_Opnd (N));
1976
1977      Rtyp : Entity_Id;
1978      PAT  : Entity_Id;
1979      Lit  : Node_Id;
1980      Size : Unat;
1981
1982   begin
1983      Convert_To_Actual_Subtype (Opnd);
1984      Rtyp := Etype (Opnd);
1985
1986      --  Deal with silly False..False and True..True subtype case
1987
1988      Silly_Boolean_Array_Not_Test (N, Rtyp);
1989
1990      --  Now that the silliness is taken care of, get packed array type
1991
1992      Convert_To_PAT_Type (Opnd);
1993      PAT := Etype (Opnd);
1994
1995      --  For the case where the packed array type is a modular type, "not A"
1996      --  expands simply into:
1997
1998      --     Rtyp!(PAT!(A) xor Mask)
1999
2000      --  where PAT is the packed array type, Mask is a mask of all 1 bits of
2001      --  length equal to the size of this packed type, and Rtyp is the actual
2002      --  actual subtype of the operand. Preserve old behavior in case size is
2003      --  not set.
2004
2005      if Known_RM_Size (PAT) then
2006         Size := RM_Size (PAT);
2007      else
2008         Size := Uint_0;
2009      end if;
2010      Lit := Make_Integer_Literal (Loc, 2 ** Size - 1);
2011      Set_Print_In_Hex (Lit);
2012
2013      if not Is_Array_Type (PAT) then
2014         Rewrite (N,
2015           Unchecked_Convert_To (Rtyp,
2016             Make_Op_Xor (Loc,
2017               Left_Opnd  => Opnd,
2018               Right_Opnd => Lit)));
2019
2020      --  For the array case, we insert the actions
2021
2022      --    Result : Typ;
2023
2024      --    System.Bit_Ops.Bit_Not
2025      --     (Opnd'Address,
2026      --      Typ'Length * Typ'Component_Size,
2027      --      Result'Address);
2028
2029      --  where Opnd is the Packed_Bytes{1,2,4} operand and the second argument
2030      --  is the length of the operand in bits. We then replace the expression
2031      --  with a reference to Result.
2032
2033      else
2034         declare
2035            Result_Ent : constant Entity_Id := Make_Temporary (Loc, 'T');
2036
2037         begin
2038            Insert_Actions (N, New_List (
2039              Make_Object_Declaration (Loc,
2040                Defining_Identifier => Result_Ent,
2041                Object_Definition   => New_Occurrence_Of (Rtyp, Loc)),
2042
2043              Make_Procedure_Call_Statement (Loc,
2044                Name => New_Occurrence_Of (RTE (RE_Bit_Not), Loc),
2045                  Parameter_Associations => New_List (
2046                    Make_Byte_Aligned_Attribute_Reference (Loc,
2047                      Prefix         => Opnd,
2048                      Attribute_Name => Name_Address),
2049
2050                    Make_Op_Multiply (Loc,
2051                      Left_Opnd =>
2052                        Make_Attribute_Reference (Loc,
2053                          Prefix         =>
2054                            New_Occurrence_Of
2055                              (Etype (First_Index (Rtyp)), Loc),
2056                          Attribute_Name => Name_Range_Length),
2057
2058                      Right_Opnd =>
2059                        Make_Integer_Literal (Loc, Component_Size (Rtyp))),
2060
2061                    Make_Byte_Aligned_Attribute_Reference (Loc,
2062                      Prefix         => New_Occurrence_Of (Result_Ent, Loc),
2063                      Attribute_Name => Name_Address)))));
2064
2065            Rewrite (N, New_Occurrence_Of (Result_Ent, Loc));
2066         end;
2067      end if;
2068
2069      Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
2070   end Expand_Packed_Not;
2071
2072   -----------------------------
2073   -- Get_Base_And_Bit_Offset --
2074   -----------------------------
2075
2076   procedure Get_Base_And_Bit_Offset
2077     (N      : Node_Id;
2078      Base   : out Node_Id;
2079      Offset : out Node_Id)
2080   is
2081      Loc    : Source_Ptr;
2082      Term   : Node_Id;
2083      Atyp   : Entity_Id;
2084      Subscr : Node_Id;
2085
2086   begin
2087      Base   := N;
2088      Offset := Empty;
2089
2090      --  We build up an expression serially that has the form
2091
2092      --    linear-subscript * component_size       for each array reference
2093      --      +  field'Bit_Position                 for each record field
2094      --      +  ...
2095
2096      loop
2097         Loc := Sloc (Base);
2098
2099         if Nkind (Base) = N_Indexed_Component then
2100            Convert_To_Actual_Subtype (Prefix (Base));
2101            Atyp := Etype (Prefix (Base));
2102            Compute_Linear_Subscript (Atyp, Base, Subscr);
2103
2104            Term :=
2105              Make_Op_Multiply (Loc,
2106                Left_Opnd => Subscr,
2107                Right_Opnd =>
2108                 Make_Attribute_Reference (Loc,
2109                   Prefix         => New_Occurrence_Of (Atyp, Loc),
2110                   Attribute_Name => Name_Component_Size));
2111
2112         elsif Nkind (Base) = N_Selected_Component then
2113            Term :=
2114              Make_Attribute_Reference (Loc,
2115                Prefix         => Selector_Name (Base),
2116                Attribute_Name => Name_Bit_Position);
2117
2118         else
2119            return;
2120         end if;
2121
2122         if No (Offset) then
2123            Offset := Term;
2124
2125         else
2126            Offset :=
2127              Make_Op_Add (Loc,
2128                Left_Opnd  => Offset,
2129                Right_Opnd => Term);
2130         end if;
2131
2132         Base := Prefix (Base);
2133      end loop;
2134   end Get_Base_And_Bit_Offset;
2135
2136   -------------------------------------
2137   -- Involves_Packed_Array_Reference --
2138   -------------------------------------
2139
2140   function Involves_Packed_Array_Reference (N : Node_Id) return Boolean is
2141   begin
2142      if Nkind (N) = N_Indexed_Component
2143        and then Is_Bit_Packed_Array (Etype (Prefix (N)))
2144      then
2145         return True;
2146
2147      elsif Nkind (N) = N_Selected_Component then
2148         return Involves_Packed_Array_Reference (Prefix (N));
2149
2150      else
2151         return False;
2152      end if;
2153   end Involves_Packed_Array_Reference;
2154
2155   --------------------------
2156   -- Known_Aligned_Enough --
2157   --------------------------
2158
2159   function Known_Aligned_Enough (Obj : Node_Id; Csiz : Nat) return Boolean is
2160      Typ : constant Entity_Id := Etype (Obj);
2161
2162      function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean;
2163      --  If the component is in a record that contains previous packed
2164      --  components, consider it unaligned because the back-end might
2165      --  choose to pack the rest of the record. Lead to less efficient code,
2166      --  but safer vis-a-vis of back-end choices.
2167
2168      --------------------------------
2169      -- In_Partially_Packed_Record --
2170      --------------------------------
2171
2172      function In_Partially_Packed_Record (Comp : Entity_Id) return Boolean is
2173         Rec_Type  : constant Entity_Id := Scope (Comp);
2174         Prev_Comp : Entity_Id;
2175
2176      begin
2177         Prev_Comp := First_Entity (Rec_Type);
2178         while Present (Prev_Comp) loop
2179            if Is_Packed (Etype (Prev_Comp)) then
2180               return True;
2181
2182            elsif Prev_Comp = Comp then
2183               return False;
2184            end if;
2185
2186            Next_Entity (Prev_Comp);
2187         end loop;
2188
2189         return False;
2190      end  In_Partially_Packed_Record;
2191
2192   --  Start of processing for Known_Aligned_Enough
2193
2194   begin
2195      --  Odd bit sizes don't need alignment anyway
2196
2197      if Csiz mod 2 = 1 then
2198         return True;
2199
2200      --  If we have a specified alignment, see if it is sufficient, if not
2201      --  then we can't possibly be aligned enough in any case.
2202
2203      elsif Known_Alignment (Etype (Obj)) then
2204         --  Alignment required is 4 if size is a multiple of 4, and
2205         --  2 otherwise (e.g. 12 bits requires 4, 10 bits requires 2)
2206
2207         if Alignment (Etype (Obj)) < 4 - (Csiz mod 4) then
2208            return False;
2209         end if;
2210      end if;
2211
2212      --  OK, alignment should be sufficient, if object is aligned
2213
2214      --  If object is strictly aligned, then it is definitely aligned
2215
2216      if Strict_Alignment (Typ) then
2217         return True;
2218
2219      --  Case of subscripted array reference
2220
2221      elsif Nkind (Obj) = N_Indexed_Component then
2222
2223         --  If we have a pointer to an array, then this is definitely
2224         --  aligned, because pointers always point to aligned versions.
2225
2226         if Is_Access_Type (Etype (Prefix (Obj))) then
2227            return True;
2228
2229         --  Otherwise, go look at the prefix
2230
2231         else
2232            return Known_Aligned_Enough (Prefix (Obj), Csiz);
2233         end if;
2234
2235      --  Case of record field
2236
2237      elsif Nkind (Obj) = N_Selected_Component then
2238
2239         --  What is significant here is whether the record type is packed
2240
2241         if Is_Record_Type (Etype (Prefix (Obj)))
2242           and then Is_Packed (Etype (Prefix (Obj)))
2243         then
2244            return False;
2245
2246         --  Or the component has a component clause which might cause
2247         --  the component to become unaligned (we can't tell if the
2248         --  backend is doing alignment computations).
2249
2250         elsif Present (Component_Clause (Entity (Selector_Name (Obj)))) then
2251            return False;
2252
2253         elsif In_Partially_Packed_Record (Entity (Selector_Name (Obj))) then
2254            return False;
2255
2256         --  In all other cases, go look at prefix
2257
2258         else
2259            return Known_Aligned_Enough (Prefix (Obj), Csiz);
2260         end if;
2261
2262      elsif Nkind (Obj) = N_Type_Conversion then
2263         return Known_Aligned_Enough (Expression (Obj), Csiz);
2264
2265      --  For a formal parameter, it is safer to assume that it is not
2266      --  aligned, because the formal may be unconstrained while the actual
2267      --  is constrained. In this situation, a small constrained packed
2268      --  array, represented in modular form, may be unaligned.
2269
2270      elsif Is_Entity_Name (Obj) then
2271         return not Is_Formal (Entity (Obj));
2272      else
2273
2274      --  If none of the above, must be aligned
2275         return True;
2276      end if;
2277   end Known_Aligned_Enough;
2278
2279   ---------------------
2280   -- Make_Shift_Left --
2281   ---------------------
2282
2283   function Make_Shift_Left (N : Node_Id; S : Node_Id) return Node_Id is
2284      Nod : Node_Id;
2285
2286   begin
2287      if Compile_Time_Known_Value (S) and then Expr_Value (S) = 0 then
2288         return N;
2289      else
2290         Nod :=
2291           Make_Op_Shift_Left (Sloc (N),
2292             Left_Opnd  => N,
2293             Right_Opnd => S);
2294         Set_Shift_Count_OK (Nod, True);
2295         return Nod;
2296      end if;
2297   end Make_Shift_Left;
2298
2299   ----------------------
2300   -- Make_Shift_Right --
2301   ----------------------
2302
2303   function Make_Shift_Right (N : Node_Id; S : Node_Id) return Node_Id is
2304      Nod : Node_Id;
2305
2306   begin
2307      if Compile_Time_Known_Value (S) and then Expr_Value (S) = 0 then
2308         return N;
2309      else
2310         Nod :=
2311           Make_Op_Shift_Right (Sloc (N),
2312             Left_Opnd  => N,
2313             Right_Opnd => S);
2314         Set_Shift_Count_OK (Nod, True);
2315         return Nod;
2316      end if;
2317   end Make_Shift_Right;
2318
2319   -----------------------------
2320   -- RJ_Unchecked_Convert_To --
2321   -----------------------------
2322
2323   function RJ_Unchecked_Convert_To
2324     (Typ  : Entity_Id;
2325      Expr : Node_Id) return Node_Id
2326   is
2327      Source_Typ : constant Entity_Id := Etype (Expr);
2328      Target_Typ : constant Entity_Id := Typ;
2329
2330      Src : Node_Id := Expr;
2331
2332      Source_Siz : Nat;
2333      Target_Siz : Nat;
2334
2335   begin
2336      Source_Siz := UI_To_Int (RM_Size (Source_Typ));
2337      Target_Siz := UI_To_Int (RM_Size (Target_Typ));
2338
2339      --  For a little-endian target type stored byte-swapped on a
2340      --  big-endian machine, do not mask to Target_Siz bits.
2341
2342      if Bytes_Big_Endian
2343           and then (Is_Record_Type (Target_Typ)
2344                       or else
2345                     Is_Array_Type (Target_Typ))
2346           and then Reverse_Storage_Order (Target_Typ)
2347      then
2348         Source_Siz := Target_Siz;
2349      end if;
2350
2351      --  First step, if the source type is not a discrete type, then we first
2352      --  convert to a modular type of the source length, since otherwise, on
2353      --  a big-endian machine, we get left-justification. We do it for little-
2354      --  endian machines as well, because there might be junk bits that are
2355      --  not cleared if the type is not numeric. This can be done only if the
2356      --  source siz is different from 0 (i.e. known), otherwise we must trust
2357      --  the type declarations (case of non-discrete components).
2358
2359      if Source_Siz /= 0
2360        and then Source_Siz /= Target_Siz
2361        and then not Is_Discrete_Type (Source_Typ)
2362      then
2363         Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src);
2364      end if;
2365
2366      --  In the big endian case, if the lengths of the two types differ, then
2367      --  we must worry about possible left justification in the conversion,
2368      --  and avoiding that is what this is all about.
2369
2370      if Bytes_Big_Endian and then Source_Siz /= Target_Siz then
2371
2372         --  Next step. If the target is not a discrete type, then we first
2373         --  convert to a modular type of the target length, since otherwise,
2374         --  on a big-endian machine, we get left-justification.
2375
2376         if not Is_Discrete_Type (Target_Typ) then
2377            Src := Unchecked_Convert_To (RTE (Bits_Id (Target_Siz)), Src);
2378         end if;
2379      end if;
2380
2381      --  And now we can do the final conversion to the target type
2382
2383      return Unchecked_Convert_To (Target_Typ, Src);
2384   end RJ_Unchecked_Convert_To;
2385
2386   ----------------------------------------------
2387   -- Setup_Enumeration_Packed_Array_Reference --
2388   ----------------------------------------------
2389
2390   --  All we have to do here is to find the subscripts that correspond to the
2391   --  index positions that have non-standard enumeration types and insert a
2392   --  Pos attribute to get the proper subscript value.
2393
2394   --  Finally the prefix must be uncheck-converted to the corresponding packed
2395   --  array type.
2396
2397   --  Note that the component type is unchanged, so we do not need to fiddle
2398   --  with the types (Gigi always automatically takes the packed array type if
2399   --  it is set, as it will be in this case).
2400
2401   procedure Setup_Enumeration_Packed_Array_Reference (N : Node_Id) is
2402      Pfx   : constant Node_Id   := Prefix (N);
2403      Typ   : constant Entity_Id := Etype (N);
2404      Exprs : constant List_Id   := Expressions (N);
2405      Expr  : Node_Id;
2406
2407   begin
2408      --  If the array is unconstrained, then we replace the array reference
2409      --  with its actual subtype. This actual subtype will have a packed array
2410      --  type with appropriate bounds.
2411
2412      if not Is_Constrained (Packed_Array_Impl_Type (Etype (Pfx))) then
2413         Convert_To_Actual_Subtype (Pfx);
2414      end if;
2415
2416      Expr := First (Exprs);
2417      while Present (Expr) loop
2418         declare
2419            Loc      : constant Source_Ptr := Sloc (Expr);
2420            Expr_Typ : constant Entity_Id := Etype (Expr);
2421
2422         begin
2423            if Is_Enumeration_Type (Expr_Typ)
2424              and then Has_Non_Standard_Rep (Expr_Typ)
2425            then
2426               Rewrite (Expr,
2427                 Make_Attribute_Reference (Loc,
2428                   Prefix         => New_Occurrence_Of (Expr_Typ, Loc),
2429                   Attribute_Name => Name_Pos,
2430                   Expressions    => New_List (Relocate_Node (Expr))));
2431               Analyze_And_Resolve (Expr, Standard_Natural);
2432            end if;
2433         end;
2434
2435         Next (Expr);
2436      end loop;
2437
2438      Rewrite (N,
2439        Make_Indexed_Component (Sloc (N),
2440          Prefix      =>
2441            Unchecked_Convert_To (Packed_Array_Impl_Type (Etype (Pfx)), Pfx),
2442          Expressions => Exprs));
2443
2444      Analyze_And_Resolve (N, Typ);
2445   end Setup_Enumeration_Packed_Array_Reference;
2446
2447   -----------------------------------------
2448   -- Setup_Inline_Packed_Array_Reference --
2449   -----------------------------------------
2450
2451   procedure Setup_Inline_Packed_Array_Reference
2452     (N      : Node_Id;
2453      Atyp   : Entity_Id;
2454      Obj    : in out Node_Id;
2455      Cmask  : out Uint;
2456      Shift  : out Node_Id)
2457   is
2458      Loc  : constant Source_Ptr := Sloc (N);
2459      PAT  : Entity_Id;
2460      Otyp : Entity_Id;
2461      Csiz : Uint;
2462      Osiz : Uint;
2463
2464   begin
2465      Csiz := Component_Size (Atyp);
2466
2467      Convert_To_PAT_Type (Obj);
2468      PAT := Etype (Obj);
2469
2470      Cmask := 2 ** Csiz - 1;
2471
2472      if Is_Array_Type (PAT) then
2473         Otyp := Component_Type (PAT);
2474         Osiz := Component_Size (PAT);
2475
2476      else
2477         Otyp := PAT;
2478
2479         --  In the case where the PAT is a modular type, we want the actual
2480         --  size in bits of the modular value we use. This is neither the
2481         --  Object_Size nor the Value_Size, either of which may have been
2482         --  reset to strange values, but rather the minimum size. Note that
2483         --  since this is a modular type with full range, the issue of
2484         --  biased representation does not arise.
2485
2486         Osiz := UI_From_Int (Minimum_Size (Otyp));
2487      end if;
2488
2489      Compute_Linear_Subscript (Atyp, N, Shift);
2490
2491      --  If the component size is not 1, then the subscript must be multiplied
2492      --  by the component size to get the shift count.
2493
2494      if Csiz /= 1 then
2495         Shift :=
2496           Make_Op_Multiply (Loc,
2497             Left_Opnd  => Make_Integer_Literal (Loc, Csiz),
2498             Right_Opnd => Shift);
2499      end if;
2500
2501      --  If we have the array case, then this shift count must be broken down
2502      --  into a byte subscript, and a shift within the byte.
2503
2504      if Is_Array_Type (PAT) then
2505
2506         declare
2507            New_Shift : Node_Id;
2508
2509         begin
2510            --  We must analyze shift, since we will duplicate it
2511
2512            Set_Parent (Shift, N);
2513            Analyze_And_Resolve
2514              (Shift, Standard_Integer, Suppress => All_Checks);
2515
2516            --  The shift count within the word is
2517            --    shift mod Osiz
2518
2519            New_Shift :=
2520              Make_Op_Mod (Loc,
2521                Left_Opnd  => Duplicate_Subexpr (Shift),
2522                Right_Opnd => Make_Integer_Literal (Loc, Osiz));
2523
2524            --  The subscript to be used on the PAT array is
2525            --    shift / Osiz
2526
2527            Obj :=
2528              Make_Indexed_Component (Loc,
2529                Prefix => Obj,
2530                Expressions => New_List (
2531                  Make_Op_Divide (Loc,
2532                    Left_Opnd  => Duplicate_Subexpr (Shift),
2533                    Right_Opnd => Make_Integer_Literal (Loc, Osiz))));
2534
2535            Shift := New_Shift;
2536         end;
2537
2538      --  For the modular integer case, the object to be manipulated is the
2539      --  entire array, so Obj is unchanged. Note that we will reset its type
2540      --  to PAT before returning to the caller.
2541
2542      else
2543         null;
2544      end if;
2545
2546      --  The one remaining step is to modify the shift count for the
2547      --  big-endian case. Consider the following example in a byte:
2548
2549      --     xxxxxxxx  bits of byte
2550      --     vvvvvvvv  bits of value
2551      --     33221100  little-endian numbering
2552      --     00112233  big-endian numbering
2553
2554      --  Here we have the case of 2-bit fields
2555
2556      --  For the little-endian case, we already have the proper shift count
2557      --  set, e.g. for element 2, the shift count is 2*2 = 4.
2558
2559      --  For the big endian case, we have to adjust the shift count, computing
2560      --  it as (N - F) - Shift, where N is the number of bits in an element of
2561      --  the array used to implement the packed array, F is the number of bits
2562      --  in a source array element, and Shift is the count so far computed.
2563
2564      --  We also have to adjust if the storage order is reversed
2565
2566      if Bytes_Big_Endian xor Reverse_Storage_Order (Base_Type (Atyp)) then
2567         Shift :=
2568           Make_Op_Subtract (Loc,
2569             Left_Opnd  => Make_Integer_Literal (Loc, Osiz - Csiz),
2570             Right_Opnd => Shift);
2571      end if;
2572
2573      Set_Parent (Shift, N);
2574      Set_Parent (Obj, N);
2575      Analyze_And_Resolve (Obj,   Otyp,             Suppress => All_Checks);
2576      Analyze_And_Resolve (Shift, Standard_Integer, Suppress => All_Checks);
2577
2578      --  Make sure final type of object is the appropriate packed type
2579
2580      Set_Etype (Obj, Otyp);
2581
2582   end Setup_Inline_Packed_Array_Reference;
2583
2584end Exp_Pakd;
2585