gcc/ada/exp_pakd.adb

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