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