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