1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- L A Y O U T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-2012, 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 Debug; use Debug; 29with Einfo; use Einfo; 30with Errout; use Errout; 31with Exp_Ch3; use Exp_Ch3; 32with Exp_Util; use Exp_Util; 33with Namet; use Namet; 34with Nlists; use Nlists; 35with Nmake; use Nmake; 36with Opt; use Opt; 37with Repinfo; use Repinfo; 38with Sem; use Sem; 39with Sem_Aux; use Sem_Aux; 40with Sem_Ch13; use Sem_Ch13; 41with Sem_Eval; use Sem_Eval; 42with Sem_Util; use Sem_Util; 43with Sinfo; use Sinfo; 44with Snames; use Snames; 45with Stand; use Stand; 46with Targparm; use Targparm; 47with Tbuild; use Tbuild; 48with Ttypes; use Ttypes; 49with Uintp; use Uintp; 50 51package body Layout is 52 53 ------------------------ 54 -- Local Declarations -- 55 ------------------------ 56 57 SSU : constant Int := Ttypes.System_Storage_Unit; 58 -- Short hand for System_Storage_Unit 59 60 Vname : constant Name_Id := Name_uV; 61 -- Formal parameter name used for functions generated for size offset 62 -- values that depend on the discriminant. All such functions have the 63 -- following form: 64 -- 65 -- function xxx (V : vtyp) return Unsigned is 66 -- begin 67 -- return ... expression involving V.discrim 68 -- end xxx; 69 70 ----------------------- 71 -- Local Subprograms -- 72 ----------------------- 73 74 function Assoc_Add 75 (Loc : Source_Ptr; 76 Left_Opnd : Node_Id; 77 Right_Opnd : Node_Id) return Node_Id; 78 -- This is like Make_Op_Add except that it optimizes some cases knowing 79 -- that associative rearrangement is allowed for constant folding if one 80 -- of the operands is a compile time known value. 81 82 function Assoc_Multiply 83 (Loc : Source_Ptr; 84 Left_Opnd : Node_Id; 85 Right_Opnd : Node_Id) return Node_Id; 86 -- This is like Make_Op_Multiply except that it optimizes some cases 87 -- knowing that associative rearrangement is allowed for constant folding 88 -- if one of the operands is a compile time known value 89 90 function Assoc_Subtract 91 (Loc : Source_Ptr; 92 Left_Opnd : Node_Id; 93 Right_Opnd : Node_Id) return Node_Id; 94 -- This is like Make_Op_Subtract except that it optimizes some cases 95 -- knowing that associative rearrangement is allowed for constant folding 96 -- if one of the operands is a compile time known value 97 98 function Bits_To_SU (N : Node_Id) return Node_Id; 99 -- This is used when we cross the boundary from static sizes in bits to 100 -- dynamic sizes in storage units. If the argument N is anything other 101 -- than an integer literal, it is returned unchanged, but if it is an 102 -- integer literal, then it is taken as a size in bits, and is replaced 103 -- by the corresponding size in storage units. 104 105 function Compute_Length (Lo : Node_Id; Hi : Node_Id) return Node_Id; 106 -- Given expressions for the low bound (Lo) and the high bound (Hi), 107 -- Build an expression for the value hi-lo+1, converted to type 108 -- Standard.Unsigned. Takes care of the case where the operands 109 -- are of an enumeration type (so that the subtraction cannot be 110 -- done directly) by applying the Pos operator to Hi/Lo first. 111 112 procedure Compute_Size_Depends_On_Discriminant (E : Entity_Id); 113 -- Given an array type or an array subtype E, compute whether its size 114 -- depends on the value of one or more discriminants and set the flag 115 -- Size_Depends_On_Discriminant accordingly. This need not be called 116 -- in front end layout mode since it does the computation on its own. 117 118 function Expr_From_SO_Ref 119 (Loc : Source_Ptr; 120 D : SO_Ref; 121 Comp : Entity_Id := Empty) return Node_Id; 122 -- Given a value D from a size or offset field, return an expression 123 -- representing the value stored. If the value is known at compile time, 124 -- then an N_Integer_Literal is returned with the appropriate value. If 125 -- the value references a constant entity, then an N_Identifier node 126 -- referencing this entity is returned. If the value denotes a size 127 -- function, then returns a call node denoting the given function, with 128 -- a single actual parameter that either refers to the parameter V of 129 -- an enclosing size function (if Comp is Empty or its type doesn't match 130 -- the function's formal), or else is a selected component V.c when Comp 131 -- denotes a component c whose type matches that of the function formal. 132 -- The Loc value is used for the Sloc value of constructed notes. 133 134 function SO_Ref_From_Expr 135 (Expr : Node_Id; 136 Ins_Type : Entity_Id; 137 Vtype : Entity_Id := Empty; 138 Make_Func : Boolean := False) return Dynamic_SO_Ref; 139 -- This routine is used in the case where a size/offset value is dynamic 140 -- and is represented by the expression Expr. SO_Ref_From_Expr checks if 141 -- the Expr contains a reference to the identifier V, and if so builds 142 -- a function depending on discriminants of the formal parameter V which 143 -- is of type Vtype. Otherwise, if the parameter Make_Func is True, then 144 -- Expr will be encapsulated in a parameterless function; if Make_Func is 145 -- False, then a constant entity with the value Expr is built. The result 146 -- is a Dynamic_SO_Ref to the created entity. Note that Vtype can be 147 -- omitted if Expr does not contain any reference to V, the created entity. 148 -- The declaration created is inserted in the freeze actions of Ins_Type, 149 -- which also supplies the Sloc for created nodes. This function also takes 150 -- care of making sure that the expression is properly analyzed and 151 -- resolved (which may not be the case yet if we build the expression 152 -- in this unit). 153 154 function Get_Max_SU_Size (E : Entity_Id) return Node_Id; 155 -- E is an array type or subtype that has at least one index bound that 156 -- is the value of a record discriminant. For such an array, the function 157 -- computes an expression that yields the maximum possible size of the 158 -- array in storage units. The result is not defined for any other type, 159 -- or for arrays that do not depend on discriminants, and it is a fatal 160 -- error to call this unless Size_Depends_On_Discriminant (E) is True. 161 162 procedure Layout_Array_Type (E : Entity_Id); 163 -- Front-end layout of non-bit-packed array type or subtype 164 165 procedure Layout_Record_Type (E : Entity_Id); 166 -- Front-end layout of record type 167 168 procedure Rewrite_Integer (N : Node_Id; V : Uint); 169 -- Rewrite node N with an integer literal whose value is V. The Sloc for 170 -- the new node is taken from N, and the type of the literal is set to a 171 -- copy of the type of N on entry. 172 173 procedure Set_And_Check_Static_Size 174 (E : Entity_Id; 175 Esiz : SO_Ref; 176 RM_Siz : SO_Ref); 177 -- This procedure is called to check explicit given sizes (possibly stored 178 -- in the Esize and RM_Size fields of E) against computed Object_Size 179 -- (Esiz) and Value_Size (RM_Siz) values. Appropriate errors and warnings 180 -- are posted if specified sizes are inconsistent with specified sizes. On 181 -- return, Esize and RM_Size fields of E are set (either from previously 182 -- given values, or from the newly computed values, as appropriate). 183 184 procedure Set_Composite_Alignment (E : Entity_Id); 185 -- This procedure is called for record types and subtypes, and also for 186 -- atomic array types and subtypes. If no alignment is set, and the size 187 -- is 2 or 4 (or 8 if the word size is 8), then the alignment is set to 188 -- match the size. 189 190 ---------------------------- 191 -- Adjust_Esize_Alignment -- 192 ---------------------------- 193 194 procedure Adjust_Esize_Alignment (E : Entity_Id) is 195 Abits : Int; 196 Esize_Set : Boolean; 197 198 begin 199 -- Nothing to do if size unknown 200 201 if Unknown_Esize (E) then 202 return; 203 end if; 204 205 -- Determine if size is constrained by an attribute definition clause 206 -- which must be obeyed. If so, we cannot increase the size in this 207 -- routine. 208 209 -- For a type, the issue is whether an object size clause has been set. 210 -- A normal size clause constrains only the value size (RM_Size) 211 212 if Is_Type (E) then 213 Esize_Set := Has_Object_Size_Clause (E); 214 215 -- For an object, the issue is whether a size clause is present 216 217 else 218 Esize_Set := Has_Size_Clause (E); 219 end if; 220 221 -- If size is known it must be a multiple of the storage unit size 222 223 if Esize (E) mod SSU /= 0 then 224 225 -- If not, and size specified, then give error 226 227 if Esize_Set then 228 Error_Msg_NE 229 ("size for& not a multiple of storage unit size", 230 Size_Clause (E), E); 231 return; 232 233 -- Otherwise bump up size to a storage unit boundary 234 235 else 236 Set_Esize (E, (Esize (E) + SSU - 1) / SSU * SSU); 237 end if; 238 end if; 239 240 -- Now we have the size set, it must be a multiple of the alignment 241 -- nothing more we can do here if the alignment is unknown here. 242 243 if Unknown_Alignment (E) then 244 return; 245 end if; 246 247 -- At this point both the Esize and Alignment are known, so we need 248 -- to make sure they are consistent. 249 250 Abits := UI_To_Int (Alignment (E)) * SSU; 251 252 if Esize (E) mod Abits = 0 then 253 return; 254 end if; 255 256 -- Here we have a situation where the Esize is not a multiple of the 257 -- alignment. We must either increase Esize or reduce the alignment to 258 -- correct this situation. 259 260 -- The case in which we can decrease the alignment is where the 261 -- alignment was not set by an alignment clause, and the type in 262 -- question is a discrete type, where it is definitely safe to reduce 263 -- the alignment. For example: 264 265 -- t : integer range 1 .. 2; 266 -- for t'size use 8; 267 268 -- In this situation, the initial alignment of t is 4, copied from 269 -- the Integer base type, but it is safe to reduce it to 1 at this 270 -- stage, since we will only be loading a single storage unit. 271 272 if Is_Discrete_Type (Etype (E)) 273 and then not Has_Alignment_Clause (E) 274 then 275 loop 276 Abits := Abits / 2; 277 exit when Esize (E) mod Abits = 0; 278 end loop; 279 280 Init_Alignment (E, Abits / SSU); 281 return; 282 end if; 283 284 -- Now the only possible approach left is to increase the Esize but we 285 -- can't do that if the size was set by a specific clause. 286 287 if Esize_Set then 288 Error_Msg_NE 289 ("size for& is not a multiple of alignment", 290 Size_Clause (E), E); 291 292 -- Otherwise we can indeed increase the size to a multiple of alignment 293 294 else 295 Set_Esize (E, ((Esize (E) + (Abits - 1)) / Abits) * Abits); 296 end if; 297 end Adjust_Esize_Alignment; 298 299 --------------- 300 -- Assoc_Add -- 301 --------------- 302 303 function Assoc_Add 304 (Loc : Source_Ptr; 305 Left_Opnd : Node_Id; 306 Right_Opnd : Node_Id) return Node_Id 307 is 308 L : Node_Id; 309 R : Uint; 310 311 begin 312 -- Case of right operand is a constant 313 314 if Compile_Time_Known_Value (Right_Opnd) then 315 L := Left_Opnd; 316 R := Expr_Value (Right_Opnd); 317 318 -- Case of left operand is a constant 319 320 elsif Compile_Time_Known_Value (Left_Opnd) then 321 L := Right_Opnd; 322 R := Expr_Value (Left_Opnd); 323 324 -- Neither operand is a constant, do the addition with no optimization 325 326 else 327 return Make_Op_Add (Loc, Left_Opnd, Right_Opnd); 328 end if; 329 330 -- Case of left operand is an addition 331 332 if Nkind (L) = N_Op_Add then 333 334 -- (C1 + E) + C2 = (C1 + C2) + E 335 336 if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then 337 Rewrite_Integer 338 (Sinfo.Left_Opnd (L), 339 Expr_Value (Sinfo.Left_Opnd (L)) + R); 340 return L; 341 342 -- (E + C1) + C2 = E + (C1 + C2) 343 344 elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then 345 Rewrite_Integer 346 (Sinfo.Right_Opnd (L), 347 Expr_Value (Sinfo.Right_Opnd (L)) + R); 348 return L; 349 end if; 350 351 -- Case of left operand is a subtraction 352 353 elsif Nkind (L) = N_Op_Subtract then 354 355 -- (C1 - E) + C2 = (C1 + C2) + E 356 357 if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then 358 Rewrite_Integer 359 (Sinfo.Left_Opnd (L), 360 Expr_Value (Sinfo.Left_Opnd (L)) + R); 361 return L; 362 363 -- (E - C1) + C2 = E - (C1 - C2) 364 365 elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then 366 Rewrite_Integer 367 (Sinfo.Right_Opnd (L), 368 Expr_Value (Sinfo.Right_Opnd (L)) - R); 369 return L; 370 end if; 371 end if; 372 373 -- Not optimizable, do the addition 374 375 return Make_Op_Add (Loc, Left_Opnd, Right_Opnd); 376 end Assoc_Add; 377 378 -------------------- 379 -- Assoc_Multiply -- 380 -------------------- 381 382 function Assoc_Multiply 383 (Loc : Source_Ptr; 384 Left_Opnd : Node_Id; 385 Right_Opnd : Node_Id) return Node_Id 386 is 387 L : Node_Id; 388 R : Uint; 389 390 begin 391 -- Case of right operand is a constant 392 393 if Compile_Time_Known_Value (Right_Opnd) then 394 L := Left_Opnd; 395 R := Expr_Value (Right_Opnd); 396 397 -- Case of left operand is a constant 398 399 elsif Compile_Time_Known_Value (Left_Opnd) then 400 L := Right_Opnd; 401 R := Expr_Value (Left_Opnd); 402 403 -- Neither operand is a constant, do the multiply with no optimization 404 405 else 406 return Make_Op_Multiply (Loc, Left_Opnd, Right_Opnd); 407 end if; 408 409 -- Case of left operand is an multiplication 410 411 if Nkind (L) = N_Op_Multiply then 412 413 -- (C1 * E) * C2 = (C1 * C2) + E 414 415 if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then 416 Rewrite_Integer 417 (Sinfo.Left_Opnd (L), 418 Expr_Value (Sinfo.Left_Opnd (L)) * R); 419 return L; 420 421 -- (E * C1) * C2 = E * (C1 * C2) 422 423 elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then 424 Rewrite_Integer 425 (Sinfo.Right_Opnd (L), 426 Expr_Value (Sinfo.Right_Opnd (L)) * R); 427 return L; 428 end if; 429 end if; 430 431 -- Not optimizable, do the multiplication 432 433 return Make_Op_Multiply (Loc, Left_Opnd, Right_Opnd); 434 end Assoc_Multiply; 435 436 -------------------- 437 -- Assoc_Subtract -- 438 -------------------- 439 440 function Assoc_Subtract 441 (Loc : Source_Ptr; 442 Left_Opnd : Node_Id; 443 Right_Opnd : Node_Id) return Node_Id 444 is 445 L : Node_Id; 446 R : Uint; 447 448 begin 449 -- Case of right operand is a constant 450 451 if Compile_Time_Known_Value (Right_Opnd) then 452 L := Left_Opnd; 453 R := Expr_Value (Right_Opnd); 454 455 -- Right operand is a constant, do the subtract with no optimization 456 457 else 458 return Make_Op_Subtract (Loc, Left_Opnd, Right_Opnd); 459 end if; 460 461 -- Case of left operand is an addition 462 463 if Nkind (L) = N_Op_Add then 464 465 -- (C1 + E) - C2 = (C1 - C2) + E 466 467 if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then 468 Rewrite_Integer 469 (Sinfo.Left_Opnd (L), 470 Expr_Value (Sinfo.Left_Opnd (L)) - R); 471 return L; 472 473 -- (E + C1) - C2 = E + (C1 - C2) 474 475 elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then 476 Rewrite_Integer 477 (Sinfo.Right_Opnd (L), 478 Expr_Value (Sinfo.Right_Opnd (L)) - R); 479 return L; 480 end if; 481 482 -- Case of left operand is a subtraction 483 484 elsif Nkind (L) = N_Op_Subtract then 485 486 -- (C1 - E) - C2 = (C1 - C2) + E 487 488 if Compile_Time_Known_Value (Sinfo.Left_Opnd (L)) then 489 Rewrite_Integer 490 (Sinfo.Left_Opnd (L), 491 Expr_Value (Sinfo.Left_Opnd (L)) + R); 492 return L; 493 494 -- (E - C1) - C2 = E - (C1 + C2) 495 496 elsif Compile_Time_Known_Value (Sinfo.Right_Opnd (L)) then 497 Rewrite_Integer 498 (Sinfo.Right_Opnd (L), 499 Expr_Value (Sinfo.Right_Opnd (L)) + R); 500 return L; 501 end if; 502 end if; 503 504 -- Not optimizable, do the subtraction 505 506 return Make_Op_Subtract (Loc, Left_Opnd, Right_Opnd); 507 end Assoc_Subtract; 508 509 ---------------- 510 -- Bits_To_SU -- 511 ---------------- 512 513 function Bits_To_SU (N : Node_Id) return Node_Id is 514 begin 515 if Nkind (N) = N_Integer_Literal then 516 Set_Intval (N, (Intval (N) + (SSU - 1)) / SSU); 517 end if; 518 519 return N; 520 end Bits_To_SU; 521 522 -------------------- 523 -- Compute_Length -- 524 -------------------- 525 526 function Compute_Length (Lo : Node_Id; Hi : Node_Id) return Node_Id is 527 Loc : constant Source_Ptr := Sloc (Lo); 528 Typ : constant Entity_Id := Etype (Lo); 529 Lo_Op : Node_Id; 530 Hi_Op : Node_Id; 531 Lo_Dim : Uint; 532 Hi_Dim : Uint; 533 534 begin 535 -- If the bounds are First and Last attributes for the same dimension 536 -- and both have prefixes that denotes the same entity, then we create 537 -- and return a Length attribute. This may allow the back end to 538 -- generate better code in cases where it already has the length. 539 540 if Nkind (Lo) = N_Attribute_Reference 541 and then Attribute_Name (Lo) = Name_First 542 and then Nkind (Hi) = N_Attribute_Reference 543 and then Attribute_Name (Hi) = Name_Last 544 and then Is_Entity_Name (Prefix (Lo)) 545 and then Is_Entity_Name (Prefix (Hi)) 546 and then Entity (Prefix (Lo)) = Entity (Prefix (Hi)) 547 then 548 Lo_Dim := Uint_1; 549 Hi_Dim := Uint_1; 550 551 if Present (First (Expressions (Lo))) then 552 Lo_Dim := Expr_Value (First (Expressions (Lo))); 553 end if; 554 555 if Present (First (Expressions (Hi))) then 556 Hi_Dim := Expr_Value (First (Expressions (Hi))); 557 end if; 558 559 if Lo_Dim = Hi_Dim then 560 return 561 Make_Attribute_Reference (Loc, 562 Prefix => New_Occurrence_Of 563 (Entity (Prefix (Lo)), Loc), 564 Attribute_Name => Name_Length, 565 Expressions => New_List 566 (Make_Integer_Literal (Loc, Lo_Dim))); 567 end if; 568 end if; 569 570 Lo_Op := New_Copy_Tree (Lo); 571 Hi_Op := New_Copy_Tree (Hi); 572 573 -- If type is enumeration type, then use Pos attribute to convert 574 -- to integer type for which subtraction is a permitted operation. 575 576 if Is_Enumeration_Type (Typ) then 577 Lo_Op := 578 Make_Attribute_Reference (Loc, 579 Prefix => New_Occurrence_Of (Typ, Loc), 580 Attribute_Name => Name_Pos, 581 Expressions => New_List (Lo_Op)); 582 583 Hi_Op := 584 Make_Attribute_Reference (Loc, 585 Prefix => New_Occurrence_Of (Typ, Loc), 586 Attribute_Name => Name_Pos, 587 Expressions => New_List (Hi_Op)); 588 end if; 589 590 return 591 Assoc_Add (Loc, 592 Left_Opnd => 593 Assoc_Subtract (Loc, 594 Left_Opnd => Hi_Op, 595 Right_Opnd => Lo_Op), 596 Right_Opnd => Make_Integer_Literal (Loc, 1)); 597 end Compute_Length; 598 599 ---------------------- 600 -- Expr_From_SO_Ref -- 601 ---------------------- 602 603 function Expr_From_SO_Ref 604 (Loc : Source_Ptr; 605 D : SO_Ref; 606 Comp : Entity_Id := Empty) return Node_Id 607 is 608 Ent : Entity_Id; 609 610 begin 611 if Is_Dynamic_SO_Ref (D) then 612 Ent := Get_Dynamic_SO_Entity (D); 613 614 if Is_Discrim_SO_Function (Ent) then 615 616 -- If a component is passed in whose type matches the type of 617 -- the function formal, then select that component from the "V" 618 -- parameter rather than passing "V" directly. 619 620 if Present (Comp) 621 and then Base_Type (Etype (Comp)) 622 = Base_Type (Etype (First_Formal (Ent))) 623 then 624 return 625 Make_Function_Call (Loc, 626 Name => New_Occurrence_Of (Ent, Loc), 627 Parameter_Associations => New_List ( 628 Make_Selected_Component (Loc, 629 Prefix => Make_Identifier (Loc, Vname), 630 Selector_Name => New_Occurrence_Of (Comp, Loc)))); 631 632 else 633 return 634 Make_Function_Call (Loc, 635 Name => New_Occurrence_Of (Ent, Loc), 636 Parameter_Associations => New_List ( 637 Make_Identifier (Loc, Vname))); 638 end if; 639 640 else 641 return New_Occurrence_Of (Ent, Loc); 642 end if; 643 644 else 645 return Make_Integer_Literal (Loc, D); 646 end if; 647 end Expr_From_SO_Ref; 648 649 --------------------- 650 -- Get_Max_SU_Size -- 651 --------------------- 652 653 function Get_Max_SU_Size (E : Entity_Id) return Node_Id is 654 Loc : constant Source_Ptr := Sloc (E); 655 Indx : Node_Id; 656 Ityp : Entity_Id; 657 Lo : Node_Id; 658 Hi : Node_Id; 659 S : Uint; 660 Len : Node_Id; 661 662 type Val_Status_Type is (Const, Dynamic); 663 664 type Val_Type (Status : Val_Status_Type := Const) is 665 record 666 case Status is 667 when Const => Val : Uint; 668 when Dynamic => Nod : Node_Id; 669 end case; 670 end record; 671 -- Shows the status of the value so far. Const means that the value is 672 -- constant, and Val is the current constant value. Dynamic means that 673 -- the value is dynamic, and in this case Nod is the Node_Id of the 674 -- expression to compute the value. 675 676 Size : Val_Type; 677 -- Calculated value so far if Size.Status = Const, 678 -- or expression value so far if Size.Status = Dynamic. 679 680 SU_Convert_Required : Boolean := False; 681 -- This is set to True if the final result must be converted from bits 682 -- to storage units (rounding up to a storage unit boundary). 683 684 ----------------------- 685 -- Local Subprograms -- 686 ----------------------- 687 688 procedure Max_Discrim (N : in out Node_Id); 689 -- If the node N represents a discriminant, replace it by the maximum 690 -- value of the discriminant. 691 692 procedure Min_Discrim (N : in out Node_Id); 693 -- If the node N represents a discriminant, replace it by the minimum 694 -- value of the discriminant. 695 696 ----------------- 697 -- Max_Discrim -- 698 ----------------- 699 700 procedure Max_Discrim (N : in out Node_Id) is 701 begin 702 if Nkind (N) = N_Identifier 703 and then Ekind (Entity (N)) = E_Discriminant 704 then 705 N := Type_High_Bound (Etype (N)); 706 end if; 707 end Max_Discrim; 708 709 ----------------- 710 -- Min_Discrim -- 711 ----------------- 712 713 procedure Min_Discrim (N : in out Node_Id) is 714 begin 715 if Nkind (N) = N_Identifier 716 and then Ekind (Entity (N)) = E_Discriminant 717 then 718 N := Type_Low_Bound (Etype (N)); 719 end if; 720 end Min_Discrim; 721 722 -- Start of processing for Get_Max_SU_Size 723 724 begin 725 pragma Assert (Size_Depends_On_Discriminant (E)); 726 727 -- Initialize status from component size 728 729 if Known_Static_Component_Size (E) then 730 Size := (Const, Component_Size (E)); 731 732 else 733 Size := (Dynamic, Expr_From_SO_Ref (Loc, Component_Size (E))); 734 end if; 735 736 -- Loop through indexes 737 738 Indx := First_Index (E); 739 while Present (Indx) loop 740 Ityp := Etype (Indx); 741 Lo := Type_Low_Bound (Ityp); 742 Hi := Type_High_Bound (Ityp); 743 744 Min_Discrim (Lo); 745 Max_Discrim (Hi); 746 747 -- Value of the current subscript range is statically known 748 749 if Compile_Time_Known_Value (Lo) 750 and then Compile_Time_Known_Value (Hi) 751 then 752 S := Expr_Value (Hi) - Expr_Value (Lo) + 1; 753 754 -- If known flat bound, entire size of array is zero! 755 756 if S <= 0 then 757 return Make_Integer_Literal (Loc, 0); 758 end if; 759 760 -- Current value is constant, evolve value 761 762 if Size.Status = Const then 763 Size.Val := Size.Val * S; 764 765 -- Current value is dynamic 766 767 else 768 -- An interesting little optimization, if we have a pending 769 -- conversion from bits to storage units, and the current 770 -- length is a multiple of the storage unit size, then we 771 -- can take the factor out here statically, avoiding some 772 -- extra dynamic computations at the end. 773 774 if SU_Convert_Required and then S mod SSU = 0 then 775 S := S / SSU; 776 SU_Convert_Required := False; 777 end if; 778 779 Size.Nod := 780 Assoc_Multiply (Loc, 781 Left_Opnd => Size.Nod, 782 Right_Opnd => 783 Make_Integer_Literal (Loc, Intval => S)); 784 end if; 785 786 -- Value of the current subscript range is dynamic 787 788 else 789 -- If the current size value is constant, then here is where we 790 -- make a transition to dynamic values, which are always stored 791 -- in storage units, However, we do not want to convert to SU's 792 -- too soon, consider the case of a packed array of single bits, 793 -- we want to do the SU conversion after computing the size in 794 -- this case. 795 796 if Size.Status = Const then 797 798 -- If the current value is a multiple of the storage unit, 799 -- then most certainly we can do the conversion now, simply 800 -- by dividing the current value by the storage unit value. 801 -- If this works, we set SU_Convert_Required to False. 802 803 if Size.Val mod SSU = 0 then 804 805 Size := 806 (Dynamic, Make_Integer_Literal (Loc, Size.Val / SSU)); 807 SU_Convert_Required := False; 808 809 -- Otherwise, we go ahead and convert the value in bits, and 810 -- set SU_Convert_Required to True to ensure that the final 811 -- value is indeed properly converted. 812 813 else 814 Size := (Dynamic, Make_Integer_Literal (Loc, Size.Val)); 815 SU_Convert_Required := True; 816 end if; 817 end if; 818 819 -- Length is hi-lo+1 820 821 Len := Compute_Length (Lo, Hi); 822 823 -- Check possible range of Len 824 825 declare 826 OK : Boolean; 827 LLo : Uint; 828 LHi : Uint; 829 pragma Warnings (Off, LHi); 830 831 begin 832 Set_Parent (Len, E); 833 Determine_Range (Len, OK, LLo, LHi); 834 835 Len := Convert_To (Standard_Unsigned, Len); 836 837 -- If we cannot verify that range cannot be super-flat, we need 838 -- a max with zero, since length must be non-negative. 839 840 if not OK or else LLo < 0 then 841 Len := 842 Make_Attribute_Reference (Loc, 843 Prefix => 844 New_Occurrence_Of (Standard_Unsigned, Loc), 845 Attribute_Name => Name_Max, 846 Expressions => New_List ( 847 Make_Integer_Literal (Loc, 0), 848 Len)); 849 end if; 850 end; 851 end if; 852 853 Next_Index (Indx); 854 end loop; 855 856 -- Here after processing all bounds to set sizes. If the value is a 857 -- constant, then it is bits, so we convert to storage units. 858 859 if Size.Status = Const then 860 return Bits_To_SU (Make_Integer_Literal (Loc, Size.Val)); 861 862 -- Case where the value is dynamic 863 864 else 865 -- Do convert from bits to SU's if needed 866 867 if SU_Convert_Required then 868 869 -- The expression required is (Size.Nod + SU - 1) / SU 870 871 Size.Nod := 872 Make_Op_Divide (Loc, 873 Left_Opnd => 874 Make_Op_Add (Loc, 875 Left_Opnd => Size.Nod, 876 Right_Opnd => Make_Integer_Literal (Loc, SSU - 1)), 877 Right_Opnd => Make_Integer_Literal (Loc, SSU)); 878 end if; 879 880 return Size.Nod; 881 end if; 882 end Get_Max_SU_Size; 883 884 ----------------------- 885 -- Layout_Array_Type -- 886 ----------------------- 887 888 procedure Layout_Array_Type (E : Entity_Id) is 889 Loc : constant Source_Ptr := Sloc (E); 890 Ctyp : constant Entity_Id := Component_Type (E); 891 Indx : Node_Id; 892 Ityp : Entity_Id; 893 Lo : Node_Id; 894 Hi : Node_Id; 895 S : Uint; 896 Len : Node_Id; 897 898 Insert_Typ : Entity_Id; 899 -- This is the type with which any generated constants or functions 900 -- will be associated (i.e. inserted into the freeze actions). This 901 -- is normally the type being laid out. The exception occurs when 902 -- we are laying out Itype's which are local to a record type, and 903 -- whose scope is this record type. Such types do not have freeze 904 -- nodes (because we have no place to put them). 905 906 ------------------------------------ 907 -- How An Array Type is Laid Out -- 908 ------------------------------------ 909 910 -- Here is what goes on. We need to multiply the component size of the 911 -- array (which has already been set) by the length of each of the 912 -- indexes. If all these values are known at compile time, then the 913 -- resulting size of the array is the appropriate constant value. 914 915 -- If the component size or at least one bound is dynamic (but no 916 -- discriminants are present), then the size will be computed as an 917 -- expression that calculates the proper size. 918 919 -- If there is at least one discriminant bound, then the size is also 920 -- computed as an expression, but this expression contains discriminant 921 -- values which are obtained by selecting from a function parameter, and 922 -- the size is given by a function that is passed the variant record in 923 -- question, and whose body is the expression. 924 925 type Val_Status_Type is (Const, Dynamic, Discrim); 926 927 type Val_Type (Status : Val_Status_Type := Const) is 928 record 929 case Status is 930 when Const => 931 Val : Uint; 932 -- Calculated value so far if Val_Status = Const 933 934 when Dynamic | Discrim => 935 Nod : Node_Id; 936 -- Expression value so far if Val_Status /= Const 937 938 end case; 939 end record; 940 -- Records the value or expression computed so far. Const means that 941 -- the value is constant, and Val is the current constant value. 942 -- Dynamic means that the value is dynamic, and in this case Nod is 943 -- the Node_Id of the expression to compute the value, and Discrim 944 -- means that at least one bound is a discriminant, in which case Nod 945 -- is the expression so far (which will be the body of the function). 946 947 Size : Val_Type; 948 -- Value of size computed so far. See comments above 949 950 Vtyp : Entity_Id := Empty; 951 -- Variant record type for the formal parameter of the discriminant 952 -- function V if Status = Discrim. 953 954 SU_Convert_Required : Boolean := False; 955 -- This is set to True if the final result must be converted from 956 -- bits to storage units (rounding up to a storage unit boundary). 957 958 Storage_Divisor : Uint := UI_From_Int (SSU); 959 -- This is the amount that a nonstatic computed size will be divided 960 -- by to convert it from bits to storage units. This is normally 961 -- equal to SSU, but can be reduced in the case of packed components 962 -- that fit evenly into a storage unit. 963 964 Make_Size_Function : Boolean := False; 965 -- Indicates whether to request that SO_Ref_From_Expr should 966 -- encapsulate the array size expression in a function. 967 968 procedure Discrimify (N : in out Node_Id); 969 -- If N represents a discriminant, then the Size.Status is set to 970 -- Discrim, and Vtyp is set. The parameter N is replaced with the 971 -- proper expression to extract the discriminant value from V. 972 973 ---------------- 974 -- Discrimify -- 975 ---------------- 976 977 procedure Discrimify (N : in out Node_Id) is 978 Decl : Node_Id; 979 Typ : Entity_Id; 980 981 begin 982 if Nkind (N) = N_Identifier 983 and then Ekind (Entity (N)) = E_Discriminant 984 then 985 Set_Size_Depends_On_Discriminant (E); 986 987 if Size.Status /= Discrim then 988 Decl := Parent (Parent (Entity (N))); 989 Size := (Discrim, Size.Nod); 990 Vtyp := Defining_Identifier (Decl); 991 end if; 992 993 Typ := Etype (N); 994 995 N := 996 Make_Selected_Component (Loc, 997 Prefix => Make_Identifier (Loc, Vname), 998 Selector_Name => New_Occurrence_Of (Entity (N), Loc)); 999 1000 -- Set the Etype attributes of the selected name and its prefix. 1001 -- Analyze_And_Resolve can't be called here because the Vname 1002 -- entity denoted by the prefix will not yet exist (it's created 1003 -- by SO_Ref_From_Expr, called at the end of Layout_Array_Type). 1004 1005 Set_Etype (Prefix (N), Vtyp); 1006 Set_Etype (N, Typ); 1007 end if; 1008 end Discrimify; 1009 1010 -- Start of processing for Layout_Array_Type 1011 1012 begin 1013 -- Default alignment is component alignment 1014 1015 if Unknown_Alignment (E) then 1016 Set_Alignment (E, Alignment (Ctyp)); 1017 end if; 1018 1019 -- Calculate proper type for insertions 1020 1021 if Is_Record_Type (Underlying_Type (Scope (E))) then 1022 Insert_Typ := Underlying_Type (Scope (E)); 1023 else 1024 Insert_Typ := E; 1025 end if; 1026 1027 -- If the component type is a generic formal type then there's no point 1028 -- in determining a size for the array type. 1029 1030 if Is_Generic_Type (Ctyp) then 1031 return; 1032 end if; 1033 1034 -- Deal with component size if base type 1035 1036 if Ekind (E) = E_Array_Type then 1037 1038 -- Cannot do anything if Esize of component type unknown 1039 1040 if Unknown_Esize (Ctyp) then 1041 return; 1042 end if; 1043 1044 -- Set component size if not set already 1045 1046 if Unknown_Component_Size (E) then 1047 Set_Component_Size (E, Esize (Ctyp)); 1048 end if; 1049 end if; 1050 1051 -- (RM 13.3 (48)) says that the size of an unconstrained array 1052 -- is implementation defined. We choose to leave it as Unknown 1053 -- here, and the actual behavior is determined by the back end. 1054 1055 if not Is_Constrained (E) then 1056 return; 1057 end if; 1058 1059 -- Initialize status from component size 1060 1061 if Known_Static_Component_Size (E) then 1062 Size := (Const, Component_Size (E)); 1063 1064 else 1065 Size := (Dynamic, Expr_From_SO_Ref (Loc, Component_Size (E))); 1066 end if; 1067 1068 -- Loop to process array indexes 1069 1070 Indx := First_Index (E); 1071 while Present (Indx) loop 1072 Ityp := Etype (Indx); 1073 1074 -- If an index of the array is a generic formal type then there is 1075 -- no point in determining a size for the array type. 1076 1077 if Is_Generic_Type (Ityp) then 1078 return; 1079 end if; 1080 1081 Lo := Type_Low_Bound (Ityp); 1082 Hi := Type_High_Bound (Ityp); 1083 1084 -- Value of the current subscript range is statically known 1085 1086 if Compile_Time_Known_Value (Lo) 1087 and then Compile_Time_Known_Value (Hi) 1088 then 1089 S := Expr_Value (Hi) - Expr_Value (Lo) + 1; 1090 1091 -- If known flat bound, entire size of array is zero! 1092 1093 if S <= 0 then 1094 Set_Esize (E, Uint_0); 1095 Set_RM_Size (E, Uint_0); 1096 return; 1097 end if; 1098 1099 -- If constant, evolve value 1100 1101 if Size.Status = Const then 1102 Size.Val := Size.Val * S; 1103 1104 -- Current value is dynamic 1105 1106 else 1107 -- An interesting little optimization, if we have a pending 1108 -- conversion from bits to storage units, and the current 1109 -- length is a multiple of the storage unit size, then we 1110 -- can take the factor out here statically, avoiding some 1111 -- extra dynamic computations at the end. 1112 1113 if SU_Convert_Required and then S mod SSU = 0 then 1114 S := S / SSU; 1115 SU_Convert_Required := False; 1116 end if; 1117 1118 -- Now go ahead and evolve the expression 1119 1120 Size.Nod := 1121 Assoc_Multiply (Loc, 1122 Left_Opnd => Size.Nod, 1123 Right_Opnd => 1124 Make_Integer_Literal (Loc, Intval => S)); 1125 end if; 1126 1127 -- Value of the current subscript range is dynamic 1128 1129 else 1130 -- If the current size value is constant, then here is where we 1131 -- make a transition to dynamic values, which are always stored 1132 -- in storage units, However, we do not want to convert to SU's 1133 -- too soon, consider the case of a packed array of single bits, 1134 -- we want to do the SU conversion after computing the size in 1135 -- this case. 1136 1137 if Size.Status = Const then 1138 1139 -- If the current value is a multiple of the storage unit, 1140 -- then most certainly we can do the conversion now, simply 1141 -- by dividing the current value by the storage unit value. 1142 -- If this works, we set SU_Convert_Required to False. 1143 1144 if Size.Val mod SSU = 0 then 1145 Size := 1146 (Dynamic, Make_Integer_Literal (Loc, Size.Val / SSU)); 1147 SU_Convert_Required := False; 1148 1149 -- If the current value is a factor of the storage unit, then 1150 -- we can use a value of one for the size and reduce the 1151 -- strength of the later division. 1152 1153 elsif SSU mod Size.Val = 0 then 1154 Storage_Divisor := SSU / Size.Val; 1155 Size := (Dynamic, Make_Integer_Literal (Loc, Uint_1)); 1156 SU_Convert_Required := True; 1157 1158 -- Otherwise, we go ahead and convert the value in bits, and 1159 -- set SU_Convert_Required to True to ensure that the final 1160 -- value is indeed properly converted. 1161 1162 else 1163 Size := (Dynamic, Make_Integer_Literal (Loc, Size.Val)); 1164 SU_Convert_Required := True; 1165 end if; 1166 end if; 1167 1168 Discrimify (Lo); 1169 Discrimify (Hi); 1170 1171 -- Length is hi-lo+1 1172 1173 Len := Compute_Length (Lo, Hi); 1174 1175 -- If Len isn't a Length attribute, then its range needs to be 1176 -- checked a possible Max with zero needs to be computed. 1177 1178 if Nkind (Len) /= N_Attribute_Reference 1179 or else Attribute_Name (Len) /= Name_Length 1180 then 1181 declare 1182 OK : Boolean; 1183 LLo : Uint; 1184 LHi : Uint; 1185 1186 begin 1187 -- Check possible range of Len 1188 1189 Set_Parent (Len, E); 1190 Determine_Range (Len, OK, LLo, LHi); 1191 1192 Len := Convert_To (Standard_Unsigned, Len); 1193 1194 -- If range definitely flat or superflat, 1195 -- result size is zero 1196 1197 if OK and then LHi <= 0 then 1198 Set_Esize (E, Uint_0); 1199 Set_RM_Size (E, Uint_0); 1200 return; 1201 end if; 1202 1203 -- If we cannot verify that range cannot be super-flat, we 1204 -- need a max with zero, since length cannot be negative. 1205 1206 if not OK or else LLo < 0 then 1207 Len := 1208 Make_Attribute_Reference (Loc, 1209 Prefix => 1210 New_Occurrence_Of (Standard_Unsigned, Loc), 1211 Attribute_Name => Name_Max, 1212 Expressions => New_List ( 1213 Make_Integer_Literal (Loc, 0), 1214 Len)); 1215 end if; 1216 end; 1217 end if; 1218 1219 -- At this stage, Len has the expression for the length 1220 1221 Size.Nod := 1222 Assoc_Multiply (Loc, 1223 Left_Opnd => Size.Nod, 1224 Right_Opnd => Len); 1225 end if; 1226 1227 Next_Index (Indx); 1228 end loop; 1229 1230 -- Here after processing all bounds to set sizes. If the value is a 1231 -- constant, then it is bits, and the only thing we need to do is to 1232 -- check against explicit given size and do alignment adjust. 1233 1234 if Size.Status = Const then 1235 Set_And_Check_Static_Size (E, Size.Val, Size.Val); 1236 Adjust_Esize_Alignment (E); 1237 1238 -- Case where the value is dynamic 1239 1240 else 1241 -- Do convert from bits to SU's if needed 1242 1243 if SU_Convert_Required then 1244 1245 -- The expression required is: 1246 -- (Size.Nod + Storage_Divisor - 1) / Storage_Divisor 1247 1248 Size.Nod := 1249 Make_Op_Divide (Loc, 1250 Left_Opnd => 1251 Make_Op_Add (Loc, 1252 Left_Opnd => Size.Nod, 1253 Right_Opnd => Make_Integer_Literal 1254 (Loc, Storage_Divisor - 1)), 1255 Right_Opnd => Make_Integer_Literal (Loc, Storage_Divisor)); 1256 end if; 1257 1258 -- If the array entity is not declared at the library level and its 1259 -- not nested within a subprogram that is marked for inlining, then 1260 -- we request that the size expression be encapsulated in a function. 1261 -- Since this expression is not needed in most cases, we prefer not 1262 -- to incur the overhead of the computation on calls to the enclosing 1263 -- subprogram except for subprograms that require the size. 1264 1265 if not Is_Library_Level_Entity (E) then 1266 Make_Size_Function := True; 1267 1268 declare 1269 Parent_Subp : Entity_Id := Enclosing_Subprogram (E); 1270 1271 begin 1272 while Present (Parent_Subp) loop 1273 if Is_Inlined (Parent_Subp) then 1274 Make_Size_Function := False; 1275 exit; 1276 end if; 1277 1278 Parent_Subp := Enclosing_Subprogram (Parent_Subp); 1279 end loop; 1280 end; 1281 end if; 1282 1283 -- Now set the dynamic size (the Value_Size is always the same as the 1284 -- Object_Size for arrays whose length is dynamic). 1285 1286 -- ??? If Size.Status = Dynamic, Vtyp will not have been set. 1287 -- The added initialization sets it to Empty now, but is this 1288 -- correct? 1289 1290 Set_Esize 1291 (E, 1292 SO_Ref_From_Expr 1293 (Size.Nod, Insert_Typ, Vtyp, Make_Func => Make_Size_Function)); 1294 Set_RM_Size (E, Esize (E)); 1295 end if; 1296 end Layout_Array_Type; 1297 1298 ------------------------------------------ 1299 -- Compute_Size_Depends_On_Discriminant -- 1300 ------------------------------------------ 1301 1302 procedure Compute_Size_Depends_On_Discriminant (E : Entity_Id) is 1303 Indx : Node_Id; 1304 Ityp : Entity_Id; 1305 Lo : Node_Id; 1306 Hi : Node_Id; 1307 Res : Boolean := False; 1308 1309 begin 1310 -- Loop to process array indexes 1311 1312 Indx := First_Index (E); 1313 while Present (Indx) loop 1314 Ityp := Etype (Indx); 1315 1316 -- If an index of the array is a generic formal type then there is 1317 -- no point in determining a size for the array type. 1318 1319 if Is_Generic_Type (Ityp) then 1320 return; 1321 end if; 1322 1323 Lo := Type_Low_Bound (Ityp); 1324 Hi := Type_High_Bound (Ityp); 1325 1326 if (Nkind (Lo) = N_Identifier 1327 and then Ekind (Entity (Lo)) = E_Discriminant) 1328 or else 1329 (Nkind (Hi) = N_Identifier 1330 and then Ekind (Entity (Hi)) = E_Discriminant) 1331 then 1332 Res := True; 1333 end if; 1334 1335 Next_Index (Indx); 1336 end loop; 1337 1338 if Res then 1339 Set_Size_Depends_On_Discriminant (E); 1340 end if; 1341 end Compute_Size_Depends_On_Discriminant; 1342 1343 ------------------- 1344 -- Layout_Object -- 1345 ------------------- 1346 1347 procedure Layout_Object (E : Entity_Id) is 1348 T : constant Entity_Id := Etype (E); 1349 1350 begin 1351 -- Nothing to do if backend does layout 1352 1353 if not Frontend_Layout_On_Target then 1354 return; 1355 end if; 1356 1357 -- Set size if not set for object and known for type. Use the RM_Size if 1358 -- that is known for the type and Esize is not. 1359 1360 if Unknown_Esize (E) then 1361 if Known_Esize (T) then 1362 Set_Esize (E, Esize (T)); 1363 1364 elsif Known_RM_Size (T) then 1365 Set_Esize (E, RM_Size (T)); 1366 end if; 1367 end if; 1368 1369 -- Set alignment from type if unknown and type alignment known 1370 1371 if Unknown_Alignment (E) and then Known_Alignment (T) then 1372 Set_Alignment (E, Alignment (T)); 1373 end if; 1374 1375 -- Make sure size and alignment are consistent 1376 1377 Adjust_Esize_Alignment (E); 1378 1379 -- Final adjustment, if we don't know the alignment, and the Esize was 1380 -- not set by an explicit Object_Size attribute clause, then we reset 1381 -- the Esize to unknown, since we really don't know it. 1382 1383 if Unknown_Alignment (E) 1384 and then not Has_Size_Clause (E) 1385 then 1386 Set_Esize (E, Uint_0); 1387 end if; 1388 end Layout_Object; 1389 1390 ------------------------ 1391 -- Layout_Record_Type -- 1392 ------------------------ 1393 1394 procedure Layout_Record_Type (E : Entity_Id) is 1395 Loc : constant Source_Ptr := Sloc (E); 1396 Decl : Node_Id; 1397 1398 Comp : Entity_Id; 1399 -- Current component being laid out 1400 1401 Prev_Comp : Entity_Id; 1402 -- Previous laid out component 1403 1404 procedure Get_Next_Component_Location 1405 (Prev_Comp : Entity_Id; 1406 Align : Uint; 1407 New_Npos : out SO_Ref; 1408 New_Fbit : out SO_Ref; 1409 New_NPMax : out SO_Ref; 1410 Force_SU : Boolean); 1411 -- Given the previous component in Prev_Comp, which is already laid 1412 -- out, and the alignment of the following component, lays out the 1413 -- following component, and returns its starting position in New_Npos 1414 -- (Normalized_Position value), New_Fbit (Normalized_First_Bit value), 1415 -- and New_NPMax (Normalized_Position_Max value). If Prev_Comp is empty 1416 -- (no previous component is present), then New_Npos, New_Fbit and 1417 -- New_NPMax are all set to zero on return. This procedure is also 1418 -- used to compute the size of a record or variant by giving it the 1419 -- last component, and the record alignment. Force_SU is used to force 1420 -- the new component location to be aligned on a storage unit boundary, 1421 -- even in a packed record, False means that the new position does not 1422 -- need to be bumped to a storage unit boundary, True means a storage 1423 -- unit boundary is always required. 1424 1425 procedure Layout_Component (Comp : Entity_Id; Prev_Comp : Entity_Id); 1426 -- Lays out component Comp, given Prev_Comp, the previously laid-out 1427 -- component (Prev_Comp = Empty if no components laid out yet). The 1428 -- alignment of the record itself is also updated if needed. Both 1429 -- Comp and Prev_Comp can be either components or discriminants. 1430 1431 procedure Layout_Components 1432 (From : Entity_Id; 1433 To : Entity_Id; 1434 Esiz : out SO_Ref; 1435 RM_Siz : out SO_Ref); 1436 -- This procedure lays out the components of the given component list 1437 -- which contains the components starting with From and ending with To. 1438 -- The Next_Entity chain is used to traverse the components. On entry, 1439 -- Prev_Comp is set to the component preceding the list, so that the 1440 -- list is laid out after this component. Prev_Comp is set to Empty if 1441 -- the component list is to be laid out starting at the start of the 1442 -- record. On return, the components are all laid out, and Prev_Comp is 1443 -- set to the last laid out component. On return, Esiz is set to the 1444 -- resulting Object_Size value, which is the length of the record up 1445 -- to and including the last laid out entity. For Esiz, the value is 1446 -- adjusted to match the alignment of the record. RM_Siz is similarly 1447 -- set to the resulting Value_Size value, which is the same length, but 1448 -- not adjusted to meet the alignment. Note that in the case of variant 1449 -- records, Esiz represents the maximum size. 1450 1451 procedure Layout_Non_Variant_Record; 1452 -- Procedure called to lay out a non-variant record type or subtype 1453 1454 procedure Layout_Variant_Record; 1455 -- Procedure called to lay out a variant record type. Decl is set to the 1456 -- full type declaration for the variant record. 1457 1458 --------------------------------- 1459 -- Get_Next_Component_Location -- 1460 --------------------------------- 1461 1462 procedure Get_Next_Component_Location 1463 (Prev_Comp : Entity_Id; 1464 Align : Uint; 1465 New_Npos : out SO_Ref; 1466 New_Fbit : out SO_Ref; 1467 New_NPMax : out SO_Ref; 1468 Force_SU : Boolean) 1469 is 1470 begin 1471 -- No previous component, return zero position 1472 1473 if No (Prev_Comp) then 1474 New_Npos := Uint_0; 1475 New_Fbit := Uint_0; 1476 New_NPMax := Uint_0; 1477 return; 1478 end if; 1479 1480 -- Here we have a previous component 1481 1482 declare 1483 Loc : constant Source_Ptr := Sloc (Prev_Comp); 1484 1485 Old_Npos : constant SO_Ref := Normalized_Position (Prev_Comp); 1486 Old_Fbit : constant SO_Ref := Normalized_First_Bit (Prev_Comp); 1487 Old_NPMax : constant SO_Ref := Normalized_Position_Max (Prev_Comp); 1488 Old_Esiz : constant SO_Ref := Esize (Prev_Comp); 1489 1490 Old_Maxsz : Node_Id; 1491 -- Expression representing maximum size of previous component 1492 1493 begin 1494 -- Case where previous field had a dynamic size 1495 1496 if Is_Dynamic_SO_Ref (Esize (Prev_Comp)) then 1497 1498 -- If the previous field had a dynamic length, then it is 1499 -- required to occupy an integral number of storage units, 1500 -- and start on a storage unit boundary. This means that 1501 -- the Normalized_First_Bit value is zero in the previous 1502 -- component, and the new value is also set to zero. 1503 1504 New_Fbit := Uint_0; 1505 1506 -- In this case, the new position is given by an expression 1507 -- that is the sum of old normalized position and old size. 1508 1509 New_Npos := 1510 SO_Ref_From_Expr 1511 (Assoc_Add (Loc, 1512 Left_Opnd => 1513 Expr_From_SO_Ref (Loc, Old_Npos), 1514 Right_Opnd => 1515 Expr_From_SO_Ref (Loc, Old_Esiz, Prev_Comp)), 1516 Ins_Type => E, 1517 Vtype => E); 1518 1519 -- Get maximum size of previous component 1520 1521 if Size_Depends_On_Discriminant (Etype (Prev_Comp)) then 1522 Old_Maxsz := Get_Max_SU_Size (Etype (Prev_Comp)); 1523 else 1524 Old_Maxsz := Expr_From_SO_Ref (Loc, Old_Esiz, Prev_Comp); 1525 end if; 1526 1527 -- Now we can compute the new max position. If the max size 1528 -- is static and the old position is static, then we can 1529 -- compute the new position statically. 1530 1531 if Nkind (Old_Maxsz) = N_Integer_Literal 1532 and then Known_Static_Normalized_Position_Max (Prev_Comp) 1533 then 1534 New_NPMax := Old_NPMax + Intval (Old_Maxsz); 1535 1536 -- Otherwise new max position is dynamic 1537 1538 else 1539 New_NPMax := 1540 SO_Ref_From_Expr 1541 (Assoc_Add (Loc, 1542 Left_Opnd => Expr_From_SO_Ref (Loc, Old_NPMax), 1543 Right_Opnd => Old_Maxsz), 1544 Ins_Type => E, 1545 Vtype => E); 1546 end if; 1547 1548 -- Previous field has known static Esize 1549 1550 else 1551 New_Fbit := Old_Fbit + Old_Esiz; 1552 1553 -- Bump New_Fbit to storage unit boundary if required 1554 1555 if New_Fbit /= 0 and then Force_SU then 1556 New_Fbit := (New_Fbit + SSU - 1) / SSU * SSU; 1557 end if; 1558 1559 -- If old normalized position is static, we can go ahead and 1560 -- compute the new normalized position directly. 1561 1562 if Known_Static_Normalized_Position (Prev_Comp) then 1563 New_Npos := Old_Npos; 1564 1565 if New_Fbit >= SSU then 1566 New_Npos := New_Npos + New_Fbit / SSU; 1567 New_Fbit := New_Fbit mod SSU; 1568 end if; 1569 1570 -- Bump alignment if stricter than prev 1571 1572 if Align > Alignment (Etype (Prev_Comp)) then 1573 New_Npos := (New_Npos + Align - 1) / Align * Align; 1574 end if; 1575 1576 -- The max position is always equal to the position if 1577 -- the latter is static, since arrays depending on the 1578 -- values of discriminants never have static sizes. 1579 1580 New_NPMax := New_Npos; 1581 return; 1582 1583 -- Case of old normalized position is dynamic 1584 1585 else 1586 -- If new bit position is within the current storage unit, 1587 -- we can just copy the old position as the result position 1588 -- (we have already set the new first bit value). 1589 1590 if New_Fbit < SSU then 1591 New_Npos := Old_Npos; 1592 New_NPMax := Old_NPMax; 1593 1594 -- If new bit position is past the current storage unit, we 1595 -- need to generate a new dynamic value for the position 1596 -- ??? need to deal with alignment 1597 1598 else 1599 New_Npos := 1600 SO_Ref_From_Expr 1601 (Assoc_Add (Loc, 1602 Left_Opnd => Expr_From_SO_Ref (Loc, Old_Npos), 1603 Right_Opnd => 1604 Make_Integer_Literal (Loc, 1605 Intval => New_Fbit / SSU)), 1606 Ins_Type => E, 1607 Vtype => E); 1608 1609 New_NPMax := 1610 SO_Ref_From_Expr 1611 (Assoc_Add (Loc, 1612 Left_Opnd => Expr_From_SO_Ref (Loc, Old_NPMax), 1613 Right_Opnd => 1614 Make_Integer_Literal (Loc, 1615 Intval => New_Fbit / SSU)), 1616 Ins_Type => E, 1617 Vtype => E); 1618 New_Fbit := New_Fbit mod SSU; 1619 end if; 1620 end if; 1621 end if; 1622 end; 1623 end Get_Next_Component_Location; 1624 1625 ---------------------- 1626 -- Layout_Component -- 1627 ---------------------- 1628 1629 procedure Layout_Component (Comp : Entity_Id; Prev_Comp : Entity_Id) is 1630 Ctyp : constant Entity_Id := Etype (Comp); 1631 ORC : constant Entity_Id := Original_Record_Component (Comp); 1632 Npos : SO_Ref; 1633 Fbit : SO_Ref; 1634 NPMax : SO_Ref; 1635 Forc : Boolean; 1636 1637 begin 1638 -- Increase alignment of record if necessary. Note that we do not 1639 -- do this for packed records, which have an alignment of one by 1640 -- default, or for records for which an explicit alignment was 1641 -- specified with an alignment clause. 1642 1643 if not Is_Packed (E) 1644 and then not Has_Alignment_Clause (E) 1645 and then Alignment (Ctyp) > Alignment (E) 1646 then 1647 Set_Alignment (E, Alignment (Ctyp)); 1648 end if; 1649 1650 -- If original component set, then use same layout 1651 1652 if Present (ORC) and then ORC /= Comp then 1653 Set_Normalized_Position (Comp, Normalized_Position (ORC)); 1654 Set_Normalized_First_Bit (Comp, Normalized_First_Bit (ORC)); 1655 Set_Normalized_Position_Max (Comp, Normalized_Position_Max (ORC)); 1656 Set_Component_Bit_Offset (Comp, Component_Bit_Offset (ORC)); 1657 Set_Esize (Comp, Esize (ORC)); 1658 return; 1659 end if; 1660 1661 -- Parent field is always at start of record, this will overlap 1662 -- the actual fields that are part of the parent, and that's fine 1663 1664 if Chars (Comp) = Name_uParent then 1665 Set_Normalized_Position (Comp, Uint_0); 1666 Set_Normalized_First_Bit (Comp, Uint_0); 1667 Set_Normalized_Position_Max (Comp, Uint_0); 1668 Set_Component_Bit_Offset (Comp, Uint_0); 1669 Set_Esize (Comp, Esize (Ctyp)); 1670 return; 1671 end if; 1672 1673 -- Check case of type of component has a scope of the record we are 1674 -- laying out. When this happens, the type in question is an Itype 1675 -- that has not yet been laid out (that's because such types do not 1676 -- get frozen in the normal manner, because there is no place for 1677 -- the freeze nodes). 1678 1679 if Scope (Ctyp) = E then 1680 Layout_Type (Ctyp); 1681 end if; 1682 1683 -- If component already laid out, then we are done 1684 1685 if Known_Normalized_Position (Comp) then 1686 return; 1687 end if; 1688 1689 -- Set size of component from type. We use the Esize except in a 1690 -- packed record, where we use the RM_Size (since that is what the 1691 -- RM_Size value, as distinct from the Object_Size is useful for!) 1692 1693 if Is_Packed (E) then 1694 Set_Esize (Comp, RM_Size (Ctyp)); 1695 else 1696 Set_Esize (Comp, Esize (Ctyp)); 1697 end if; 1698 1699 -- Compute the component position from the previous one. See if 1700 -- current component requires being on a storage unit boundary. 1701 1702 -- If record is not packed, we always go to a storage unit boundary 1703 1704 if not Is_Packed (E) then 1705 Forc := True; 1706 1707 -- Packed cases 1708 1709 else 1710 -- Elementary types do not need SU boundary in packed record 1711 1712 if Is_Elementary_Type (Ctyp) then 1713 Forc := False; 1714 1715 -- Packed array types with a modular packed array type do not 1716 -- force a storage unit boundary (since the code generation 1717 -- treats these as equivalent to the underlying modular type), 1718 1719 elsif Is_Array_Type (Ctyp) 1720 and then Is_Bit_Packed_Array (Ctyp) 1721 and then Is_Modular_Integer_Type (Packed_Array_Type (Ctyp)) 1722 then 1723 Forc := False; 1724 1725 -- Record types with known length less than or equal to the length 1726 -- of long long integer can also be unaligned, since they can be 1727 -- treated as scalars. 1728 1729 elsif Is_Record_Type (Ctyp) 1730 and then not Is_Dynamic_SO_Ref (Esize (Ctyp)) 1731 and then Esize (Ctyp) <= Esize (Standard_Long_Long_Integer) 1732 then 1733 Forc := False; 1734 1735 -- All other cases force a storage unit boundary, even when packed 1736 1737 else 1738 Forc := True; 1739 end if; 1740 end if; 1741 1742 -- Now get the next component location 1743 1744 Get_Next_Component_Location 1745 (Prev_Comp, Alignment (Ctyp), Npos, Fbit, NPMax, Forc); 1746 Set_Normalized_Position (Comp, Npos); 1747 Set_Normalized_First_Bit (Comp, Fbit); 1748 Set_Normalized_Position_Max (Comp, NPMax); 1749 1750 -- Set Component_Bit_Offset in the static case 1751 1752 if Known_Static_Normalized_Position (Comp) 1753 and then Known_Normalized_First_Bit (Comp) 1754 then 1755 Set_Component_Bit_Offset (Comp, SSU * Npos + Fbit); 1756 end if; 1757 end Layout_Component; 1758 1759 ----------------------- 1760 -- Layout_Components -- 1761 ----------------------- 1762 1763 procedure Layout_Components 1764 (From : Entity_Id; 1765 To : Entity_Id; 1766 Esiz : out SO_Ref; 1767 RM_Siz : out SO_Ref) 1768 is 1769 End_Npos : SO_Ref; 1770 End_Fbit : SO_Ref; 1771 End_NPMax : SO_Ref; 1772 1773 begin 1774 -- Only lay out components if there are some to lay out! 1775 1776 if Present (From) then 1777 1778 -- Lay out components with no component clauses 1779 1780 Comp := From; 1781 loop 1782 if Ekind (Comp) = E_Component 1783 or else Ekind (Comp) = E_Discriminant 1784 then 1785 -- The compatibility of component clauses with composite 1786 -- types isn't checked in Sem_Ch13, so we check it here. 1787 1788 if Present (Component_Clause (Comp)) then 1789 if Is_Composite_Type (Etype (Comp)) 1790 and then Esize (Comp) < RM_Size (Etype (Comp)) 1791 then 1792 Error_Msg_Uint_1 := RM_Size (Etype (Comp)); 1793 Error_Msg_NE 1794 ("size for & too small, minimum allowed is ^", 1795 Component_Clause (Comp), 1796 Comp); 1797 end if; 1798 1799 else 1800 Layout_Component (Comp, Prev_Comp); 1801 Prev_Comp := Comp; 1802 end if; 1803 end if; 1804 1805 exit when Comp = To; 1806 Next_Entity (Comp); 1807 end loop; 1808 end if; 1809 1810 -- Set size fields, both are zero if no components 1811 1812 if No (Prev_Comp) then 1813 Esiz := Uint_0; 1814 RM_Siz := Uint_0; 1815 1816 -- If record subtype with non-static discriminants, then we don't 1817 -- know which variant will be the one which gets chosen. We don't 1818 -- just want to set the maximum size from the base, because the 1819 -- size should depend on the particular variant. 1820 1821 -- What we do is to use the RM_Size of the base type, which has 1822 -- the necessary conditional computation of the size, using the 1823 -- size information for the particular variant chosen. Records 1824 -- with default discriminants for example have an Esize that is 1825 -- set to the maximum of all variants, but that's not what we 1826 -- want for a constrained subtype. 1827 1828 elsif Ekind (E) = E_Record_Subtype 1829 and then not Has_Static_Discriminants (E) 1830 then 1831 declare 1832 BT : constant Node_Id := Base_Type (E); 1833 begin 1834 Esiz := RM_Size (BT); 1835 RM_Siz := RM_Size (BT); 1836 Set_Alignment (E, Alignment (BT)); 1837 end; 1838 1839 else 1840 -- First the object size, for which we align past the last field 1841 -- to the alignment of the record (the object size is required to 1842 -- be a multiple of the alignment). 1843 1844 Get_Next_Component_Location 1845 (Prev_Comp, 1846 Alignment (E), 1847 End_Npos, 1848 End_Fbit, 1849 End_NPMax, 1850 Force_SU => True); 1851 1852 -- If the resulting normalized position is a dynamic reference, 1853 -- then the size is dynamic, and is stored in storage units. In 1854 -- this case, we set the RM_Size to the same value, it is simply 1855 -- not worth distinguishing Esize and RM_Size values in the 1856 -- dynamic case, since the RM has nothing to say about them. 1857 1858 -- Note that a size cannot have been given in this case, since 1859 -- size specifications cannot be given for variable length types. 1860 1861 declare 1862 Align : constant Uint := Alignment (E); 1863 1864 begin 1865 if Is_Dynamic_SO_Ref (End_Npos) then 1866 RM_Siz := End_Npos; 1867 1868 -- Set the Object_Size allowing for the alignment. In the 1869 -- dynamic case, we must do the actual runtime computation. 1870 -- We can skip this in the non-packed record case if the 1871 -- last component has a smaller alignment than the overall 1872 -- record alignment. 1873 1874 if Is_Dynamic_SO_Ref (End_NPMax) then 1875 Esiz := End_NPMax; 1876 1877 if Is_Packed (E) 1878 or else Alignment (Etype (Prev_Comp)) < Align 1879 then 1880 -- The expression we build is: 1881 -- (expr + align - 1) / align * align 1882 1883 Esiz := 1884 SO_Ref_From_Expr 1885 (Expr => 1886 Make_Op_Multiply (Loc, 1887 Left_Opnd => 1888 Make_Op_Divide (Loc, 1889 Left_Opnd => 1890 Make_Op_Add (Loc, 1891 Left_Opnd => 1892 Expr_From_SO_Ref (Loc, Esiz), 1893 Right_Opnd => 1894 Make_Integer_Literal (Loc, 1895 Intval => Align - 1)), 1896 Right_Opnd => 1897 Make_Integer_Literal (Loc, Align)), 1898 Right_Opnd => 1899 Make_Integer_Literal (Loc, Align)), 1900 Ins_Type => E, 1901 Vtype => E); 1902 end if; 1903 1904 -- Here Esiz is static, so we can adjust the alignment 1905 -- directly go give the required aligned value. 1906 1907 else 1908 Esiz := (End_NPMax + Align - 1) / Align * Align * SSU; 1909 end if; 1910 1911 -- Case where computed size is static 1912 1913 else 1914 -- The ending size was computed in Npos in storage units, 1915 -- but the actual size is stored in bits, so adjust 1916 -- accordingly. We also adjust the size to match the 1917 -- alignment here. 1918 1919 Esiz := (End_NPMax + Align - 1) / Align * Align * SSU; 1920 1921 -- Compute the resulting Value_Size (RM_Size). For this 1922 -- purpose we do not force alignment of the record or 1923 -- storage size alignment of the result. 1924 1925 Get_Next_Component_Location 1926 (Prev_Comp, 1927 Uint_0, 1928 End_Npos, 1929 End_Fbit, 1930 End_NPMax, 1931 Force_SU => False); 1932 1933 RM_Siz := End_Npos * SSU + End_Fbit; 1934 Set_And_Check_Static_Size (E, Esiz, RM_Siz); 1935 end if; 1936 end; 1937 end if; 1938 end Layout_Components; 1939 1940 ------------------------------- 1941 -- Layout_Non_Variant_Record -- 1942 ------------------------------- 1943 1944 procedure Layout_Non_Variant_Record is 1945 Esiz : SO_Ref; 1946 RM_Siz : SO_Ref; 1947 begin 1948 Layout_Components (First_Entity (E), Last_Entity (E), Esiz, RM_Siz); 1949 Set_Esize (E, Esiz); 1950 Set_RM_Size (E, RM_Siz); 1951 end Layout_Non_Variant_Record; 1952 1953 --------------------------- 1954 -- Layout_Variant_Record -- 1955 --------------------------- 1956 1957 procedure Layout_Variant_Record is 1958 Tdef : constant Node_Id := Type_Definition (Decl); 1959 First_Discr : Entity_Id; 1960 Last_Discr : Entity_Id; 1961 Esiz : SO_Ref; 1962 1963 RM_Siz : SO_Ref; 1964 pragma Warnings (Off, SO_Ref); 1965 1966 RM_Siz_Expr : Node_Id := Empty; 1967 -- Expression for the evolving RM_Siz value. This is typically an if 1968 -- expression which involves tests of discriminant values that are 1969 -- formed as references to the entity V. At the end of scanning all 1970 -- the components, a suitable function is constructed in which V is 1971 -- the parameter. 1972 1973 ----------------------- 1974 -- Local Subprograms -- 1975 ----------------------- 1976 1977 procedure Layout_Component_List 1978 (Clist : Node_Id; 1979 Esiz : out SO_Ref; 1980 RM_Siz_Expr : out Node_Id); 1981 -- Recursive procedure, called to lay out one component list Esiz 1982 -- and RM_Siz_Expr are set to the Object_Size and Value_Size values 1983 -- respectively representing the record size up to and including the 1984 -- last component in the component list (including any variants in 1985 -- this component list). RM_Siz_Expr is returned as an expression 1986 -- which may in the general case involve some references to the 1987 -- discriminants of the current record value, referenced by selecting 1988 -- from the entity V. 1989 1990 --------------------------- 1991 -- Layout_Component_List -- 1992 --------------------------- 1993 1994 procedure Layout_Component_List 1995 (Clist : Node_Id; 1996 Esiz : out SO_Ref; 1997 RM_Siz_Expr : out Node_Id) 1998 is 1999 Citems : constant List_Id := Component_Items (Clist); 2000 Vpart : constant Node_Id := Variant_Part (Clist); 2001 Prv : Node_Id; 2002 Var : Node_Id; 2003 RM_Siz : Uint; 2004 RMS_Ent : Entity_Id; 2005 2006 begin 2007 if Is_Non_Empty_List (Citems) then 2008 Layout_Components 2009 (From => Defining_Identifier (First (Citems)), 2010 To => Defining_Identifier (Last (Citems)), 2011 Esiz => Esiz, 2012 RM_Siz => RM_Siz); 2013 else 2014 Layout_Components (Empty, Empty, Esiz, RM_Siz); 2015 end if; 2016 2017 -- Case where no variants are present in the component list 2018 2019 if No (Vpart) then 2020 2021 -- The Esiz value has been correctly set by the call to 2022 -- Layout_Components, so there is nothing more to be done. 2023 2024 -- For RM_Siz, we have an SO_Ref value, which we must convert 2025 -- to an appropriate expression. 2026 2027 if Is_Static_SO_Ref (RM_Siz) then 2028 RM_Siz_Expr := 2029 Make_Integer_Literal (Loc, 2030 Intval => RM_Siz); 2031 2032 else 2033 RMS_Ent := Get_Dynamic_SO_Entity (RM_Siz); 2034 2035 -- If the size is represented by a function, then we create 2036 -- an appropriate function call using V as the parameter to 2037 -- the call. 2038 2039 if Is_Discrim_SO_Function (RMS_Ent) then 2040 RM_Siz_Expr := 2041 Make_Function_Call (Loc, 2042 Name => New_Occurrence_Of (RMS_Ent, Loc), 2043 Parameter_Associations => New_List ( 2044 Make_Identifier (Loc, Vname))); 2045 2046 -- If the size is represented by a constant, then the 2047 -- expression we want is a reference to this constant 2048 2049 else 2050 RM_Siz_Expr := New_Occurrence_Of (RMS_Ent, Loc); 2051 end if; 2052 end if; 2053 2054 -- Case where variants are present in this component list 2055 2056 else 2057 declare 2058 EsizV : SO_Ref; 2059 RM_SizV : Node_Id; 2060 Dchoice : Node_Id; 2061 Discrim : Node_Id; 2062 Dtest : Node_Id; 2063 D_List : List_Id; 2064 D_Entity : Entity_Id; 2065 2066 begin 2067 RM_Siz_Expr := Empty; 2068 Prv := Prev_Comp; 2069 2070 Var := Last (Variants (Vpart)); 2071 while Present (Var) loop 2072 Prev_Comp := Prv; 2073 Layout_Component_List 2074 (Component_List (Var), EsizV, RM_SizV); 2075 2076 -- Set the Object_Size. If this is the first variant, 2077 -- we just set the size of this first variant. 2078 2079 if Var = Last (Variants (Vpart)) then 2080 Esiz := EsizV; 2081 2082 -- Otherwise the Object_Size is formed as a maximum 2083 -- of Esiz so far from previous variants, and the new 2084 -- Esiz value from the variant we just processed. 2085 2086 -- If both values are static, we can just compute the 2087 -- maximum directly to save building junk nodes. 2088 2089 elsif not Is_Dynamic_SO_Ref (Esiz) 2090 and then not Is_Dynamic_SO_Ref (EsizV) 2091 then 2092 Esiz := UI_Max (Esiz, EsizV); 2093 2094 -- If either value is dynamic, then we have to generate 2095 -- an appropriate Standard_Unsigned'Max attribute call. 2096 -- If one of the values is static then it needs to be 2097 -- converted from bits to storage units to be compatible 2098 -- with the dynamic value. 2099 2100 else 2101 if Is_Static_SO_Ref (Esiz) then 2102 Esiz := (Esiz + SSU - 1) / SSU; 2103 end if; 2104 2105 if Is_Static_SO_Ref (EsizV) then 2106 EsizV := (EsizV + SSU - 1) / SSU; 2107 end if; 2108 2109 Esiz := 2110 SO_Ref_From_Expr 2111 (Make_Attribute_Reference (Loc, 2112 Attribute_Name => Name_Max, 2113 Prefix => 2114 New_Occurrence_Of (Standard_Unsigned, Loc), 2115 Expressions => New_List ( 2116 Expr_From_SO_Ref (Loc, Esiz), 2117 Expr_From_SO_Ref (Loc, EsizV))), 2118 Ins_Type => E, 2119 Vtype => E); 2120 end if; 2121 2122 -- Now deal with Value_Size (RM_Siz). We are aiming at 2123 -- an expression that looks like: 2124 2125 -- if xxDx (V.disc) then rmsiz1 2126 -- else if xxDx (V.disc) then rmsiz2 2127 -- else ... 2128 2129 -- Where rmsiz1, rmsiz2... are the RM_Siz values for the 2130 -- individual variants, and xxDx are the discriminant 2131 -- checking functions generated for the variant type. 2132 2133 -- If this is the first variant, we simply set the result 2134 -- as the expression. Note that this takes care of the 2135 -- others case. 2136 2137 if No (RM_Siz_Expr) then 2138 2139 -- If this is the only variant and the size is a 2140 -- literal, then use bit size as is, otherwise convert 2141 -- to storage units and continue to the next variant. 2142 2143 if No (Prev (Var)) 2144 and then Nkind (RM_SizV) = N_Integer_Literal 2145 then 2146 RM_Siz_Expr := RM_SizV; 2147 else 2148 RM_Siz_Expr := Bits_To_SU (RM_SizV); 2149 end if; 2150 2151 -- Otherwise construct the appropriate test 2152 2153 else 2154 -- The test to be used in general is a call to the 2155 -- discriminant checking function. However, it is 2156 -- definitely worth special casing the very common 2157 -- case where a single value is involved. 2158 2159 Dchoice := First (Discrete_Choices (Var)); 2160 2161 if No (Next (Dchoice)) 2162 and then Nkind (Dchoice) /= N_Range 2163 then 2164 -- Discriminant to be tested 2165 2166 Discrim := 2167 Make_Selected_Component (Loc, 2168 Prefix => 2169 Make_Identifier (Loc, Vname), 2170 Selector_Name => 2171 New_Occurrence_Of 2172 (Entity (Name (Vpart)), Loc)); 2173 2174 Dtest := 2175 Make_Op_Eq (Loc, 2176 Left_Opnd => Discrim, 2177 Right_Opnd => New_Copy (Dchoice)); 2178 2179 -- Generate a call to the discriminant-checking 2180 -- function for the variant. Note that the result 2181 -- has to be complemented since the function returns 2182 -- False when the passed discriminant value matches. 2183 2184 else 2185 -- The checking function takes all of the type's 2186 -- discriminants as parameters, so a list of all 2187 -- the selected discriminants must be constructed. 2188 2189 D_List := New_List; 2190 D_Entity := First_Discriminant (E); 2191 while Present (D_Entity) loop 2192 Append ( 2193 Make_Selected_Component (Loc, 2194 Prefix => 2195 Make_Identifier (Loc, Vname), 2196 Selector_Name => 2197 New_Occurrence_Of (D_Entity, Loc)), 2198 D_List); 2199 2200 D_Entity := Next_Discriminant (D_Entity); 2201 end loop; 2202 2203 Dtest := 2204 Make_Op_Not (Loc, 2205 Right_Opnd => 2206 Make_Function_Call (Loc, 2207 Name => 2208 New_Occurrence_Of 2209 (Dcheck_Function (Var), Loc), 2210 Parameter_Associations => 2211 D_List)); 2212 end if; 2213 2214 RM_Siz_Expr := 2215 Make_If_Expression (Loc, 2216 Expressions => 2217 New_List 2218 (Dtest, Bits_To_SU (RM_SizV), RM_Siz_Expr)); 2219 end if; 2220 2221 Prev (Var); 2222 end loop; 2223 end; 2224 end if; 2225 end Layout_Component_List; 2226 2227 -- Start of processing for Layout_Variant_Record 2228 2229 begin 2230 -- We need the discriminant checking functions, since we generate 2231 -- calls to these functions for the RM_Size expression, so make 2232 -- sure that these functions have been constructed in time. 2233 2234 Build_Discr_Checking_Funcs (Decl); 2235 2236 -- Lay out the discriminants 2237 2238 First_Discr := First_Discriminant (E); 2239 Last_Discr := First_Discr; 2240 while Present (Next_Discriminant (Last_Discr)) loop 2241 Next_Discriminant (Last_Discr); 2242 end loop; 2243 2244 Layout_Components 2245 (From => First_Discr, 2246 To => Last_Discr, 2247 Esiz => Esiz, 2248 RM_Siz => RM_Siz); 2249 2250 -- Lay out the main component list (this will make recursive calls 2251 -- to lay out all component lists nested within variants). 2252 2253 Layout_Component_List (Component_List (Tdef), Esiz, RM_Siz_Expr); 2254 Set_Esize (E, Esiz); 2255 2256 -- If the RM_Size is a literal, set its value 2257 2258 if Nkind (RM_Siz_Expr) = N_Integer_Literal then 2259 Set_RM_Size (E, Intval (RM_Siz_Expr)); 2260 2261 -- Otherwise we construct a dynamic SO_Ref 2262 2263 else 2264 Set_RM_Size (E, 2265 SO_Ref_From_Expr 2266 (RM_Siz_Expr, 2267 Ins_Type => E, 2268 Vtype => E)); 2269 end if; 2270 end Layout_Variant_Record; 2271 2272 -- Start of processing for Layout_Record_Type 2273 2274 begin 2275 -- If this is a cloned subtype, just copy the size fields from the 2276 -- original, nothing else needs to be done in this case, since the 2277 -- components themselves are all shared. 2278 2279 if (Ekind (E) = E_Record_Subtype 2280 or else 2281 Ekind (E) = E_Class_Wide_Subtype) 2282 and then Present (Cloned_Subtype (E)) 2283 then 2284 Set_Esize (E, Esize (Cloned_Subtype (E))); 2285 Set_RM_Size (E, RM_Size (Cloned_Subtype (E))); 2286 Set_Alignment (E, Alignment (Cloned_Subtype (E))); 2287 2288 -- Another special case, class-wide types. The RM says that the size 2289 -- of such types is implementation defined (RM 13.3(48)). What we do 2290 -- here is to leave the fields set as unknown values, and the backend 2291 -- determines the actual behavior. 2292 2293 elsif Ekind (E) = E_Class_Wide_Type then 2294 null; 2295 2296 -- All other cases 2297 2298 else 2299 -- Initialize alignment conservatively to 1. This value will be 2300 -- increased as necessary during processing of the record. 2301 2302 if Unknown_Alignment (E) then 2303 Set_Alignment (E, Uint_1); 2304 end if; 2305 2306 -- Initialize previous component. This is Empty unless there are 2307 -- components which have already been laid out by component clauses. 2308 -- If there are such components, we start our lay out of the 2309 -- remaining components following the last such component. 2310 2311 Prev_Comp := Empty; 2312 2313 Comp := First_Component_Or_Discriminant (E); 2314 while Present (Comp) loop 2315 if Present (Component_Clause (Comp)) then 2316 if No (Prev_Comp) 2317 or else 2318 Component_Bit_Offset (Comp) > 2319 Component_Bit_Offset (Prev_Comp) 2320 then 2321 Prev_Comp := Comp; 2322 end if; 2323 end if; 2324 2325 Next_Component_Or_Discriminant (Comp); 2326 end loop; 2327 2328 -- We have two separate circuits, one for non-variant records and 2329 -- one for variant records. For non-variant records, we simply go 2330 -- through the list of components. This handles all the non-variant 2331 -- cases including those cases of subtypes where there is no full 2332 -- type declaration, so the tree cannot be used to drive the layout. 2333 -- For variant records, we have to drive the layout from the tree 2334 -- since we need to understand the variant structure in this case. 2335 2336 if Present (Full_View (E)) then 2337 Decl := Declaration_Node (Full_View (E)); 2338 else 2339 Decl := Declaration_Node (E); 2340 end if; 2341 2342 -- Scan all the components 2343 2344 if Nkind (Decl) = N_Full_Type_Declaration 2345 and then Has_Discriminants (E) 2346 and then Nkind (Type_Definition (Decl)) = N_Record_Definition 2347 and then Present (Component_List (Type_Definition (Decl))) 2348 and then 2349 Present (Variant_Part (Component_List (Type_Definition (Decl)))) 2350 then 2351 Layout_Variant_Record; 2352 else 2353 Layout_Non_Variant_Record; 2354 end if; 2355 end if; 2356 end Layout_Record_Type; 2357 2358 ----------------- 2359 -- Layout_Type -- 2360 ----------------- 2361 2362 procedure Layout_Type (E : Entity_Id) is 2363 Desig_Type : Entity_Id; 2364 2365 begin 2366 -- For string literal types, for now, kill the size always, this is 2367 -- because gigi does not like or need the size to be set ??? 2368 2369 if Ekind (E) = E_String_Literal_Subtype then 2370 Set_Esize (E, Uint_0); 2371 Set_RM_Size (E, Uint_0); 2372 return; 2373 end if; 2374 2375 -- For access types, set size/alignment. This is system address size, 2376 -- except for fat pointers (unconstrained array access types), where the 2377 -- size is two times the address size, to accommodate the two pointers 2378 -- that are required for a fat pointer (data and template). Note that 2379 -- E_Access_Protected_Subprogram_Type is not an access type for this 2380 -- purpose since it is not a pointer but is equivalent to a record. For 2381 -- access subtypes, copy the size from the base type since Gigi 2382 -- represents them the same way. 2383 2384 if Is_Access_Type (E) then 2385 2386 Desig_Type := Underlying_Type (Designated_Type (E)); 2387 2388 -- If we only have a limited view of the type, see whether the 2389 -- non-limited view is available. 2390 2391 if From_With_Type (Designated_Type (E)) 2392 and then Ekind (Designated_Type (E)) = E_Incomplete_Type 2393 and then Present (Non_Limited_View (Designated_Type (E))) 2394 then 2395 Desig_Type := Non_Limited_View (Designated_Type (E)); 2396 end if; 2397 2398 -- If Esize already set (e.g. by a size clause), then nothing further 2399 -- to be done here. 2400 2401 if Known_Esize (E) then 2402 null; 2403 2404 -- Access to subprogram is a strange beast, and we let the backend 2405 -- figure out what is needed (it may be some kind of fat pointer, 2406 -- including the static link for example. 2407 2408 elsif Is_Access_Protected_Subprogram_Type (E) then 2409 null; 2410 2411 -- For access subtypes, copy the size information from base type 2412 2413 elsif Ekind (E) = E_Access_Subtype then 2414 Set_Size_Info (E, Base_Type (E)); 2415 Set_RM_Size (E, RM_Size (Base_Type (E))); 2416 2417 -- For other access types, we use either address size, or, if a fat 2418 -- pointer is used (pointer-to-unconstrained array case), twice the 2419 -- address size to accommodate a fat pointer. 2420 2421 elsif Present (Desig_Type) 2422 and then Is_Array_Type (Desig_Type) 2423 and then not Is_Constrained (Desig_Type) 2424 and then not Has_Completion_In_Body (Desig_Type) 2425 and then not Debug_Flag_6 2426 then 2427 Init_Size (E, 2 * System_Address_Size); 2428 2429 -- Check for bad convention set 2430 2431 if Warn_On_Export_Import 2432 and then 2433 (Convention (E) = Convention_C 2434 or else 2435 Convention (E) = Convention_CPP) 2436 then 2437 Error_Msg_N 2438 ("?x?this access type does not correspond to C pointer", E); 2439 end if; 2440 2441 -- If the designated type is a limited view it is unanalyzed. We can 2442 -- examine the declaration itself to determine whether it will need a 2443 -- fat pointer. 2444 2445 elsif Present (Desig_Type) 2446 and then Present (Parent (Desig_Type)) 2447 and then Nkind (Parent (Desig_Type)) = N_Full_Type_Declaration 2448 and then 2449 Nkind (Type_Definition (Parent (Desig_Type))) 2450 = N_Unconstrained_Array_Definition 2451 and then not Debug_Flag_6 2452 then 2453 Init_Size (E, 2 * System_Address_Size); 2454 2455 -- When the target is AAMP, access-to-subprogram types are fat 2456 -- pointers consisting of the subprogram address and a static link, 2457 -- with the exception of library-level access types (including 2458 -- library-level anonymous access types, such as for components), 2459 -- where a simple subprogram address is used. 2460 2461 elsif AAMP_On_Target 2462 and then 2463 ((Ekind (E) = E_Access_Subprogram_Type 2464 and then Present (Enclosing_Subprogram (E))) 2465 or else 2466 (Ekind (E) = E_Anonymous_Access_Subprogram_Type 2467 and then 2468 (not Is_Local_Anonymous_Access (E) 2469 or else Present (Enclosing_Subprogram (E))))) 2470 then 2471 Init_Size (E, 2 * System_Address_Size); 2472 else 2473 Init_Size (E, System_Address_Size); 2474 end if; 2475 2476 -- On VMS, reset size to 32 for convention C access type if no 2477 -- explicit size clause is given and the default size is 64. Really 2478 -- we do not know the size, since depending on options for the VMS 2479 -- compiler, the size of a pointer type can be 32 or 64, but choosing 2480 -- 32 as the default improves compatibility with legacy VMS code. 2481 2482 -- Note: we do not use Has_Size_Clause in the test below, because we 2483 -- want to catch the case of a derived type inheriting a size clause. 2484 -- We want to consider this to be an explicit size clause for this 2485 -- purpose, since it would be weird not to inherit the size in this 2486 -- case. 2487 2488 -- We do NOT do this if we are in -gnatdm mode on a non-VMS target 2489 -- since in that case we want the normal pointer representation. 2490 2491 if Opt.True_VMS_Target 2492 and then (Convention (E) = Convention_C 2493 or else 2494 Convention (E) = Convention_CPP) 2495 and then No (Get_Attribute_Definition_Clause (E, Attribute_Size)) 2496 and then Esize (E) = 64 2497 then 2498 Init_Size (E, 32); 2499 end if; 2500 2501 Set_Elem_Alignment (E); 2502 2503 -- Scalar types: set size and alignment 2504 2505 elsif Is_Scalar_Type (E) then 2506 2507 -- For discrete types, the RM_Size and Esize must be set already, 2508 -- since this is part of the earlier processing and the front end is 2509 -- always required to lay out the sizes of such types (since they are 2510 -- available as static attributes). All we do is to check that this 2511 -- rule is indeed obeyed! 2512 2513 if Is_Discrete_Type (E) then 2514 2515 -- If the RM_Size is not set, then here is where we set it 2516 2517 -- Note: an RM_Size of zero looks like not set here, but this 2518 -- is a rare case, and we can simply reset it without any harm. 2519 2520 if not Known_RM_Size (E) then 2521 Set_Discrete_RM_Size (E); 2522 end if; 2523 2524 -- If Esize for a discrete type is not set then set it 2525 2526 if not Known_Esize (E) then 2527 declare 2528 S : Int := 8; 2529 2530 begin 2531 loop 2532 -- If size is big enough, set it and exit 2533 2534 if S >= RM_Size (E) then 2535 Init_Esize (E, S); 2536 exit; 2537 2538 -- If the RM_Size is greater than 64 (happens only when 2539 -- strange values are specified by the user, then Esize 2540 -- is simply a copy of RM_Size, it will be further 2541 -- refined later on) 2542 2543 elsif S = 64 then 2544 Set_Esize (E, RM_Size (E)); 2545 exit; 2546 2547 -- Otherwise double possible size and keep trying 2548 2549 else 2550 S := S * 2; 2551 end if; 2552 end loop; 2553 end; 2554 end if; 2555 2556 -- For non-discrete scalar types, if the RM_Size is not set, then set 2557 -- it now to a copy of the Esize if the Esize is set. 2558 2559 else 2560 if Known_Esize (E) and then Unknown_RM_Size (E) then 2561 Set_RM_Size (E, Esize (E)); 2562 end if; 2563 end if; 2564 2565 Set_Elem_Alignment (E); 2566 2567 -- Non-elementary (composite) types 2568 2569 else 2570 -- For packed arrays, take size and alignment values from the packed 2571 -- array type if a packed array type has been created and the fields 2572 -- are not currently set. 2573 2574 if Is_Array_Type (E) and then Present (Packed_Array_Type (E)) then 2575 declare 2576 PAT : constant Entity_Id := Packed_Array_Type (E); 2577 2578 begin 2579 if Unknown_Esize (E) then 2580 Set_Esize (E, Esize (PAT)); 2581 end if; 2582 2583 if Unknown_RM_Size (E) then 2584 Set_RM_Size (E, RM_Size (PAT)); 2585 end if; 2586 2587 if Unknown_Alignment (E) then 2588 Set_Alignment (E, Alignment (PAT)); 2589 end if; 2590 end; 2591 end if; 2592 2593 -- If Esize is set, and RM_Size is not, RM_Size is copied from Esize. 2594 -- At least for now this seems reasonable, and is in any case needed 2595 -- for compatibility with old versions of gigi. 2596 2597 if Known_Esize (E) and then Unknown_RM_Size (E) then 2598 Set_RM_Size (E, Esize (E)); 2599 end if; 2600 2601 -- For array base types, set component size if object size of the 2602 -- component type is known and is a small power of 2 (8, 16, 32, 64), 2603 -- since this is what will always be used. 2604 2605 if Ekind (E) = E_Array_Type 2606 and then Unknown_Component_Size (E) 2607 then 2608 declare 2609 CT : constant Entity_Id := Component_Type (E); 2610 2611 begin 2612 -- For some reasons, access types can cause trouble, So let's 2613 -- just do this for scalar types ??? 2614 2615 if Present (CT) 2616 and then Is_Scalar_Type (CT) 2617 and then Known_Static_Esize (CT) 2618 then 2619 declare 2620 S : constant Uint := Esize (CT); 2621 begin 2622 if Addressable (S) then 2623 Set_Component_Size (E, S); 2624 end if; 2625 end; 2626 end if; 2627 end; 2628 end if; 2629 end if; 2630 2631 -- Lay out array and record types if front end layout set 2632 2633 if Frontend_Layout_On_Target then 2634 if Is_Array_Type (E) and then not Is_Bit_Packed_Array (E) then 2635 Layout_Array_Type (E); 2636 elsif Is_Record_Type (E) then 2637 Layout_Record_Type (E); 2638 end if; 2639 2640 -- Case of backend layout, we still do a little in the front end 2641 2642 else 2643 -- Processing for record types 2644 2645 if Is_Record_Type (E) then 2646 2647 -- Special remaining processing for record types with a known 2648 -- size of 16, 32, or 64 bits whose alignment is not yet set. 2649 -- For these types, we set a corresponding alignment matching 2650 -- the size if possible, or as large as possible if not. 2651 2652 if Convention (E) = Convention_Ada 2653 and then not Debug_Flag_Q 2654 then 2655 Set_Composite_Alignment (E); 2656 end if; 2657 2658 -- Processing for array types 2659 2660 elsif Is_Array_Type (E) then 2661 2662 -- For arrays that are required to be atomic, we do the same 2663 -- processing as described above for short records, since we 2664 -- really need to have the alignment set for the whole array. 2665 2666 if Is_Atomic (E) and then not Debug_Flag_Q then 2667 Set_Composite_Alignment (E); 2668 end if; 2669 2670 -- For unpacked array types, set an alignment of 1 if we know 2671 -- that the component alignment is not greater than 1. The reason 2672 -- we do this is to avoid unnecessary copying of slices of such 2673 -- arrays when passed to subprogram parameters (see special test 2674 -- in Exp_Ch6.Expand_Actuals). 2675 2676 if not Is_Packed (E) 2677 and then Unknown_Alignment (E) 2678 then 2679 if Known_Static_Component_Size (E) 2680 and then Component_Size (E) = 1 2681 then 2682 Set_Alignment (E, Uint_1); 2683 end if; 2684 end if; 2685 2686 -- We need to know whether the size depends on the value of one 2687 -- or more discriminants to select the return mechanism. Skip if 2688 -- errors are present, to prevent cascaded messages. 2689 2690 if Serious_Errors_Detected = 0 then 2691 Compute_Size_Depends_On_Discriminant (E); 2692 end if; 2693 2694 end if; 2695 end if; 2696 2697 -- Final step is to check that Esize and RM_Size are compatible 2698 2699 if Known_Static_Esize (E) and then Known_Static_RM_Size (E) then 2700 if Esize (E) < RM_Size (E) then 2701 2702 -- Esize is less than RM_Size. That's not good. First we test 2703 -- whether this was set deliberately with an Object_Size clause 2704 -- and if so, object to the clause. 2705 2706 if Has_Object_Size_Clause (E) then 2707 Error_Msg_Uint_1 := RM_Size (E); 2708 Error_Msg_F 2709 ("object size is too small, minimum allowed is ^", 2710 Expression (Get_Attribute_Definition_Clause 2711 (E, Attribute_Object_Size))); 2712 end if; 2713 2714 -- Adjust Esize up to RM_Size value 2715 2716 declare 2717 Size : constant Uint := RM_Size (E); 2718 2719 begin 2720 Set_Esize (E, RM_Size (E)); 2721 2722 -- For scalar types, increase Object_Size to power of 2, but 2723 -- not less than a storage unit in any case (i.e., normally 2724 -- this means it will be storage-unit addressable). 2725 2726 if Is_Scalar_Type (E) then 2727 if Size <= System_Storage_Unit then 2728 Init_Esize (E, System_Storage_Unit); 2729 elsif Size <= 16 then 2730 Init_Esize (E, 16); 2731 elsif Size <= 32 then 2732 Init_Esize (E, 32); 2733 else 2734 Set_Esize (E, (Size + 63) / 64 * 64); 2735 end if; 2736 2737 -- Finally, make sure that alignment is consistent with 2738 -- the newly assigned size. 2739 2740 while Alignment (E) * System_Storage_Unit < Esize (E) 2741 and then Alignment (E) < Maximum_Alignment 2742 loop 2743 Set_Alignment (E, 2 * Alignment (E)); 2744 end loop; 2745 end if; 2746 end; 2747 end if; 2748 end if; 2749 end Layout_Type; 2750 2751 --------------------- 2752 -- Rewrite_Integer -- 2753 --------------------- 2754 2755 procedure Rewrite_Integer (N : Node_Id; V : Uint) is 2756 Loc : constant Source_Ptr := Sloc (N); 2757 Typ : constant Entity_Id := Etype (N); 2758 begin 2759 Rewrite (N, Make_Integer_Literal (Loc, Intval => V)); 2760 Set_Etype (N, Typ); 2761 end Rewrite_Integer; 2762 2763 ------------------------------- 2764 -- Set_And_Check_Static_Size -- 2765 ------------------------------- 2766 2767 procedure Set_And_Check_Static_Size 2768 (E : Entity_Id; 2769 Esiz : SO_Ref; 2770 RM_Siz : SO_Ref) 2771 is 2772 SC : Node_Id; 2773 2774 procedure Check_Size_Too_Small (Spec : Uint; Min : Uint); 2775 -- Spec is the number of bit specified in the size clause, and Min is 2776 -- the minimum computed size. An error is given that the specified size 2777 -- is too small if Spec < Min, and in this case both Esize and RM_Size 2778 -- are set to unknown in E. The error message is posted on node SC. 2779 2780 procedure Check_Unused_Bits (Spec : Uint; Max : Uint); 2781 -- Spec is the number of bits specified in the size clause, and Max is 2782 -- the maximum computed size. A warning is given about unused bits if 2783 -- Spec > Max. This warning is posted on node SC. 2784 2785 -------------------------- 2786 -- Check_Size_Too_Small -- 2787 -------------------------- 2788 2789 procedure Check_Size_Too_Small (Spec : Uint; Min : Uint) is 2790 begin 2791 if Spec < Min then 2792 Error_Msg_Uint_1 := Min; 2793 Error_Msg_NE ("size for & too small, minimum allowed is ^", SC, E); 2794 Init_Esize (E); 2795 Init_RM_Size (E); 2796 end if; 2797 end Check_Size_Too_Small; 2798 2799 ----------------------- 2800 -- Check_Unused_Bits -- 2801 ----------------------- 2802 2803 procedure Check_Unused_Bits (Spec : Uint; Max : Uint) is 2804 begin 2805 if Spec > Max then 2806 Error_Msg_Uint_1 := Spec - Max; 2807 Error_Msg_NE ("??^ bits of & unused", SC, E); 2808 end if; 2809 end Check_Unused_Bits; 2810 2811 -- Start of processing for Set_And_Check_Static_Size 2812 2813 begin 2814 -- Case where Object_Size (Esize) is already set by a size clause 2815 2816 if Known_Static_Esize (E) then 2817 SC := Size_Clause (E); 2818 2819 if No (SC) then 2820 SC := Get_Attribute_Definition_Clause (E, Attribute_Object_Size); 2821 end if; 2822 2823 -- Perform checks on specified size against computed sizes 2824 2825 if Present (SC) then 2826 Check_Unused_Bits (Esize (E), Esiz); 2827 Check_Size_Too_Small (Esize (E), RM_Siz); 2828 end if; 2829 end if; 2830 2831 -- Case where Value_Size (RM_Size) is set by specific Value_Size clause 2832 -- (we do not need to worry about Value_Size being set by a Size clause, 2833 -- since that will have set Esize as well, and we already took care of 2834 -- that case). 2835 2836 if Known_Static_RM_Size (E) then 2837 SC := Get_Attribute_Definition_Clause (E, Attribute_Value_Size); 2838 2839 -- Perform checks on specified size against computed sizes 2840 2841 if Present (SC) then 2842 Check_Unused_Bits (RM_Size (E), Esiz); 2843 Check_Size_Too_Small (RM_Size (E), RM_Siz); 2844 end if; 2845 end if; 2846 2847 -- Set sizes if unknown 2848 2849 if Unknown_Esize (E) then 2850 Set_Esize (E, Esiz); 2851 end if; 2852 2853 if Unknown_RM_Size (E) then 2854 Set_RM_Size (E, RM_Siz); 2855 end if; 2856 end Set_And_Check_Static_Size; 2857 2858 ----------------------------- 2859 -- Set_Composite_Alignment -- 2860 ----------------------------- 2861 2862 procedure Set_Composite_Alignment (E : Entity_Id) is 2863 Siz : Uint; 2864 Align : Nat; 2865 2866 begin 2867 -- If alignment is already set, then nothing to do 2868 2869 if Known_Alignment (E) then 2870 return; 2871 end if; 2872 2873 -- Alignment is not known, see if we can set it, taking into account 2874 -- the setting of the Optimize_Alignment mode. 2875 2876 -- If Optimize_Alignment is set to Space, then we try to give packed 2877 -- records an aligmment of 1, unless there is some reason we can't. 2878 2879 if Optimize_Alignment_Space (E) 2880 and then Is_Record_Type (E) 2881 and then Is_Packed (E) 2882 then 2883 -- No effect for record with atomic components 2884 2885 if Is_Atomic (E) then 2886 Error_Msg_N ("Optimize_Alignment has no effect for &??", E); 2887 Error_Msg_N ("\pragma ignored for atomic record??", E); 2888 return; 2889 end if; 2890 2891 -- No effect if independent components 2892 2893 if Has_Independent_Components (E) then 2894 Error_Msg_N ("Optimize_Alignment has no effect for &??", E); 2895 Error_Msg_N 2896 ("\pragma ignored for record with independent components??", E); 2897 return; 2898 end if; 2899 2900 -- No effect if any component is atomic or is a by reference type 2901 2902 declare 2903 Ent : Entity_Id; 2904 begin 2905 Ent := First_Component_Or_Discriminant (E); 2906 while Present (Ent) loop 2907 if Is_By_Reference_Type (Etype (Ent)) 2908 or else Is_Atomic (Etype (Ent)) 2909 or else Is_Atomic (Ent) 2910 then 2911 Error_Msg_N ("Optimize_Alignment has no effect for &??", E); 2912 Error_Msg_N 2913 ("\pragma is ignored if atomic components present??", E); 2914 return; 2915 else 2916 Next_Component_Or_Discriminant (Ent); 2917 end if; 2918 end loop; 2919 end; 2920 2921 -- Optimize_Alignment has no effect on variable length record 2922 2923 if not Size_Known_At_Compile_Time (E) then 2924 Error_Msg_N ("Optimize_Alignment has no effect for &??", E); 2925 Error_Msg_N ("\pragma is ignored for variable length record??", E); 2926 return; 2927 end if; 2928 2929 -- All tests passed, we can set alignment to 1 2930 2931 Align := 1; 2932 2933 -- Not a record, or not packed 2934 2935 else 2936 -- The only other cases we worry about here are where the size is 2937 -- statically known at compile time. 2938 2939 if Known_Static_Esize (E) then 2940 Siz := Esize (E); 2941 2942 elsif Unknown_Esize (E) 2943 and then Known_Static_RM_Size (E) 2944 then 2945 Siz := RM_Size (E); 2946 2947 else 2948 return; 2949 end if; 2950 2951 -- Size is known, alignment is not set 2952 2953 -- Reset alignment to match size if the known size is exactly 2, 4, 2954 -- or 8 storage units. 2955 2956 if Siz = 2 * System_Storage_Unit then 2957 Align := 2; 2958 elsif Siz = 4 * System_Storage_Unit then 2959 Align := 4; 2960 elsif Siz = 8 * System_Storage_Unit then 2961 Align := 8; 2962 2963 -- If Optimize_Alignment is set to Space, then make sure the 2964 -- alignment matches the size, for example, if the size is 17 2965 -- bytes then we want an alignment of 1 for the type. 2966 2967 elsif Optimize_Alignment_Space (E) then 2968 if Siz mod (8 * System_Storage_Unit) = 0 then 2969 Align := 8; 2970 elsif Siz mod (4 * System_Storage_Unit) = 0 then 2971 Align := 4; 2972 elsif Siz mod (2 * System_Storage_Unit) = 0 then 2973 Align := 2; 2974 else 2975 Align := 1; 2976 end if; 2977 2978 -- If Optimize_Alignment is set to Time, then we reset for odd 2979 -- "in between sizes", for example a 17 bit record is given an 2980 -- alignment of 4. Note that this matches the old VMS behavior 2981 -- in versions of GNAT prior to 6.1.1. 2982 2983 elsif Optimize_Alignment_Time (E) 2984 and then Siz > System_Storage_Unit 2985 and then Siz <= 8 * System_Storage_Unit 2986 then 2987 if Siz <= 2 * System_Storage_Unit then 2988 Align := 2; 2989 elsif Siz <= 4 * System_Storage_Unit then 2990 Align := 4; 2991 else -- Siz <= 8 * System_Storage_Unit then 2992 Align := 8; 2993 end if; 2994 2995 -- No special alignment fiddling needed 2996 2997 else 2998 return; 2999 end if; 3000 end if; 3001 3002 -- Here we have Set Align to the proposed improved value. Make sure the 3003 -- value set does not exceed Maximum_Alignment for the target. 3004 3005 if Align > Maximum_Alignment then 3006 Align := Maximum_Alignment; 3007 end if; 3008 3009 -- Further processing for record types only to reduce the alignment 3010 -- set by the above processing in some specific cases. We do not 3011 -- do this for atomic records, since we need max alignment there, 3012 3013 if Is_Record_Type (E) and then not Is_Atomic (E) then 3014 3015 -- For records, there is generally no point in setting alignment 3016 -- higher than word size since we cannot do better than move by 3017 -- words in any case. Omit this if we are optimizing for time, 3018 -- since conceivably we may be able to do better. 3019 3020 if Align > System_Word_Size / System_Storage_Unit 3021 and then not Optimize_Alignment_Time (E) 3022 then 3023 Align := System_Word_Size / System_Storage_Unit; 3024 end if; 3025 3026 -- Check components. If any component requires a higher alignment, 3027 -- then we set that higher alignment in any case. Don't do this if 3028 -- we have Optimize_Alignment set to Space. Note that that covers 3029 -- the case of packed records, where we already set alignment to 1. 3030 3031 if not Optimize_Alignment_Space (E) then 3032 declare 3033 Comp : Entity_Id; 3034 3035 begin 3036 Comp := First_Component (E); 3037 while Present (Comp) loop 3038 if Known_Alignment (Etype (Comp)) then 3039 declare 3040 Calign : constant Uint := Alignment (Etype (Comp)); 3041 3042 begin 3043 -- The cases to process are when the alignment of the 3044 -- component type is larger than the alignment we have 3045 -- so far, and either there is no component clause for 3046 -- the component, or the length set by the component 3047 -- clause matches the length of the component type. 3048 3049 if Calign > Align 3050 and then 3051 (Unknown_Esize (Comp) 3052 or else (Known_Static_Esize (Comp) 3053 and then 3054 Esize (Comp) = 3055 Calign * System_Storage_Unit)) 3056 then 3057 Align := UI_To_Int (Calign); 3058 end if; 3059 end; 3060 end if; 3061 3062 Next_Component (Comp); 3063 end loop; 3064 end; 3065 end if; 3066 end if; 3067 3068 -- Set chosen alignment, and increase Esize if necessary to match the 3069 -- chosen alignment. 3070 3071 Set_Alignment (E, UI_From_Int (Align)); 3072 3073 if Known_Static_Esize (E) 3074 and then Esize (E) < Align * System_Storage_Unit 3075 then 3076 Set_Esize (E, UI_From_Int (Align * System_Storage_Unit)); 3077 end if; 3078 end Set_Composite_Alignment; 3079 3080 -------------------------- 3081 -- Set_Discrete_RM_Size -- 3082 -------------------------- 3083 3084 procedure Set_Discrete_RM_Size (Def_Id : Entity_Id) is 3085 FST : constant Entity_Id := First_Subtype (Def_Id); 3086 3087 begin 3088 -- All discrete types except for the base types in standard are 3089 -- constrained, so indicate this by setting Is_Constrained. 3090 3091 Set_Is_Constrained (Def_Id); 3092 3093 -- Set generic types to have an unknown size, since the representation 3094 -- of a generic type is irrelevant, in view of the fact that they have 3095 -- nothing to do with code. 3096 3097 if Is_Generic_Type (Root_Type (FST)) then 3098 Set_RM_Size (Def_Id, Uint_0); 3099 3100 -- If the subtype statically matches the first subtype, then it is 3101 -- required to have exactly the same layout. This is required by 3102 -- aliasing considerations. 3103 3104 elsif Def_Id /= FST and then 3105 Subtypes_Statically_Match (Def_Id, FST) 3106 then 3107 Set_RM_Size (Def_Id, RM_Size (FST)); 3108 Set_Size_Info (Def_Id, FST); 3109 3110 -- In all other cases the RM_Size is set to the minimum size. Note that 3111 -- this routine is never called for subtypes for which the RM_Size is 3112 -- set explicitly by an attribute clause. 3113 3114 else 3115 Set_RM_Size (Def_Id, UI_From_Int (Minimum_Size (Def_Id))); 3116 end if; 3117 end Set_Discrete_RM_Size; 3118 3119 ------------------------ 3120 -- Set_Elem_Alignment -- 3121 ------------------------ 3122 3123 procedure Set_Elem_Alignment (E : Entity_Id) is 3124 begin 3125 -- Do not set alignment for packed array types, unless we are doing 3126 -- front end layout, because otherwise this is always handled in the 3127 -- backend. 3128 3129 if Is_Packed_Array_Type (E) and then not Frontend_Layout_On_Target then 3130 return; 3131 3132 -- If there is an alignment clause, then we respect it 3133 3134 elsif Has_Alignment_Clause (E) then 3135 return; 3136 3137 -- If the size is not set, then don't attempt to set the alignment. This 3138 -- happens in the backend layout case for access-to-subprogram types. 3139 3140 elsif not Known_Static_Esize (E) then 3141 return; 3142 3143 -- For access types, do not set the alignment if the size is less than 3144 -- the allowed minimum size. This avoids cascaded error messages. 3145 3146 elsif Is_Access_Type (E) 3147 and then Esize (E) < System_Address_Size 3148 then 3149 return; 3150 end if; 3151 3152 -- Here we calculate the alignment as the largest power of two multiple 3153 -- of System.Storage_Unit that does not exceed either the object size of 3154 -- the type, or the maximum allowed alignment. 3155 3156 declare 3157 S : Int; 3158 A : Nat; 3159 3160 Max_Alignment : Nat; 3161 3162 begin 3163 -- The given Esize may be larger that int'last because of a previous 3164 -- error, and the call to UI_To_Int will fail, so use default. 3165 3166 if Esize (E) / SSU > Ttypes.Maximum_Alignment then 3167 S := Ttypes.Maximum_Alignment; 3168 3169 -- If this is an access type and the target doesn't have strict 3170 -- alignment and we are not doing front end layout, then cap the 3171 -- alignment to that of a regular access type. This will avoid 3172 -- giving fat pointers twice the usual alignment for no practical 3173 -- benefit since the misalignment doesn't really matter. 3174 3175 elsif Is_Access_Type (E) 3176 and then not Target_Strict_Alignment 3177 and then not Frontend_Layout_On_Target 3178 then 3179 S := System_Address_Size / SSU; 3180 3181 else 3182 S := UI_To_Int (Esize (E)) / SSU; 3183 end if; 3184 3185 -- If the default alignment of "double" floating-point types is 3186 -- specifically capped, enforce the cap. 3187 3188 if Ttypes.Target_Double_Float_Alignment > 0 3189 and then S = 8 3190 and then Is_Floating_Point_Type (E) 3191 then 3192 Max_Alignment := Ttypes.Target_Double_Float_Alignment; 3193 3194 -- If the default alignment of "double" or larger scalar types is 3195 -- specifically capped, enforce the cap. 3196 3197 elsif Ttypes.Target_Double_Scalar_Alignment > 0 3198 and then S >= 8 3199 and then Is_Scalar_Type (E) 3200 then 3201 Max_Alignment := Ttypes.Target_Double_Scalar_Alignment; 3202 3203 -- Otherwise enforce the overall alignment cap 3204 3205 else 3206 Max_Alignment := Ttypes.Maximum_Alignment; 3207 end if; 3208 3209 A := 1; 3210 while 2 * A <= Max_Alignment and then 2 * A <= S loop 3211 A := 2 * A; 3212 end loop; 3213 3214 -- If alignment is currently not set, then we can safetly set it to 3215 -- this new calculated value. 3216 3217 if Unknown_Alignment (E) then 3218 Init_Alignment (E, A); 3219 3220 -- Cases where we have inherited an alignment 3221 3222 -- For constructed types, always reset the alignment, these are 3223 -- Generally invisible to the user anyway, and that way we are 3224 -- sure that no constructed types have weird alignments. 3225 3226 elsif not Comes_From_Source (E) then 3227 Init_Alignment (E, A); 3228 3229 -- If this inherited alignment is the same as the one we computed, 3230 -- then obviously everything is fine, and we do not need to reset it. 3231 3232 elsif Alignment (E) = A then 3233 null; 3234 3235 -- Now we come to the difficult cases where we have inherited an 3236 -- alignment and size, but overridden the size but not the alignment. 3237 3238 elsif Has_Size_Clause (E) or else Has_Object_Size_Clause (E) then 3239 3240 -- This is tricky, it might be thought that we should try to 3241 -- inherit the alignment, since that's what the RM implies, but 3242 -- that leads to complex rules and oddities. Consider for example: 3243 3244 -- type R is new Character; 3245 -- for R'Size use 16; 3246 3247 -- It seems quite bogus in this case to inherit an alignment of 1 3248 -- from the parent type Character. Furthermore, if that's what the 3249 -- programmer really wanted for some odd reason, then they could 3250 -- specify the alignment they wanted. 3251 3252 -- Furthermore we really don't want to inherit the alignment in 3253 -- the case of a specified Object_Size for a subtype, since then 3254 -- there would be no way of overriding to give a reasonable value 3255 -- (we don't have an Object_Subtype attribute). Consider: 3256 3257 -- subtype R is new Character; 3258 -- for R'Object_Size use 16; 3259 3260 -- If we inherit the alignment of 1, then we have an odd 3261 -- inefficient alignment for the subtype, which cannot be fixed. 3262 3263 -- So we make the decision that if Size (or Object_Size) is given 3264 -- (and, in the case of a first subtype, the alignment is not set 3265 -- with a specific alignment clause). We reset the alignment to 3266 -- the appropriate value for the specified size. This is a nice 3267 -- simple rule to implement and document. 3268 3269 -- There is one slight glitch, which is that a confirming size 3270 -- clause can now change the alignment, which, if we really think 3271 -- that confirming rep clauses should have no effect, is a no-no. 3272 3273 -- type R is new Character; 3274 -- for R'Alignment use 2; 3275 -- type S is new R; 3276 -- for S'Size use Character'Size; 3277 3278 -- Now the alignment of S is 1 instead of 2, as a result of 3279 -- applying the above rule to the confirming rep clause for S. Not 3280 -- clear this is worth worrying about. If we recorded whether a 3281 -- size clause was confirming we could avoid this, but right now 3282 -- we have no way of doing that or easily figuring it out, so we 3283 -- don't bother. 3284 3285 -- Historical note. In versions of GNAT prior to Nov 6th, 2010, an 3286 -- odd distinction was made between inherited alignments greater 3287 -- than the computed alignment (where the larger alignment was 3288 -- inherited) and inherited alignments smaller than the computed 3289 -- alignment (where the smaller alignment was overridden). This 3290 -- was a dubious fix to get around an ACATS problem which seems 3291 -- to have disappeared anyway, and in any case, this peculiarity 3292 -- was never documented. 3293 3294 Init_Alignment (E, A); 3295 3296 -- If no Size (or Object_Size) was specified, then we inherited the 3297 -- object size, so we should inherit the alignment as well and not 3298 -- modify it. This takes care of cases like: 3299 3300 -- type R is new Integer; 3301 -- for R'Alignment use 1; 3302 -- subtype S is R; 3303 3304 -- Here we have R has a default Object_Size of 32, and a specified 3305 -- alignment of 1, and it seeems right for S to inherit both values. 3306 3307 else 3308 null; 3309 end if; 3310 end; 3311 end Set_Elem_Alignment; 3312 3313 ---------------------- 3314 -- SO_Ref_From_Expr -- 3315 ---------------------- 3316 3317 function SO_Ref_From_Expr 3318 (Expr : Node_Id; 3319 Ins_Type : Entity_Id; 3320 Vtype : Entity_Id := Empty; 3321 Make_Func : Boolean := False) return Dynamic_SO_Ref 3322 is 3323 Loc : constant Source_Ptr := Sloc (Ins_Type); 3324 K : constant Entity_Id := Make_Temporary (Loc, 'K'); 3325 Decl : Node_Id; 3326 3327 Vtype_Primary_View : Entity_Id; 3328 3329 function Check_Node_V_Ref (N : Node_Id) return Traverse_Result; 3330 -- Function used to check one node for reference to V 3331 3332 function Has_V_Ref is new Traverse_Func (Check_Node_V_Ref); 3333 -- Function used to traverse tree to check for reference to V 3334 3335 ---------------------- 3336 -- Check_Node_V_Ref -- 3337 ---------------------- 3338 3339 function Check_Node_V_Ref (N : Node_Id) return Traverse_Result is 3340 begin 3341 if Nkind (N) = N_Identifier then 3342 if Chars (N) = Vname then 3343 return Abandon; 3344 else 3345 return Skip; 3346 end if; 3347 3348 else 3349 return OK; 3350 end if; 3351 end Check_Node_V_Ref; 3352 3353 -- Start of processing for SO_Ref_From_Expr 3354 3355 begin 3356 -- Case of expression is an integer literal, in this case we just 3357 -- return the value (which must always be non-negative, since size 3358 -- and offset values can never be negative). 3359 3360 if Nkind (Expr) = N_Integer_Literal then 3361 pragma Assert (Intval (Expr) >= 0); 3362 return Intval (Expr); 3363 end if; 3364 3365 -- Case where there is a reference to V, create function 3366 3367 if Has_V_Ref (Expr) = Abandon then 3368 3369 pragma Assert (Present (Vtype)); 3370 3371 -- Check whether Vtype is a view of a private type and ensure that 3372 -- we use the primary view of the type (which is denoted by its 3373 -- Etype, whether it's the type's partial or full view entity). 3374 -- This is needed to make sure that we use the same (primary) view 3375 -- of the type for all V formals, whether the current view of the 3376 -- type is the partial or full view, so that types will always 3377 -- match on calls from one size function to another. 3378 3379 if Has_Private_Declaration (Vtype) then 3380 Vtype_Primary_View := Etype (Vtype); 3381 else 3382 Vtype_Primary_View := Vtype; 3383 end if; 3384 3385 Set_Is_Discrim_SO_Function (K); 3386 3387 Decl := 3388 Make_Subprogram_Body (Loc, 3389 3390 Specification => 3391 Make_Function_Specification (Loc, 3392 Defining_Unit_Name => K, 3393 Parameter_Specifications => New_List ( 3394 Make_Parameter_Specification (Loc, 3395 Defining_Identifier => 3396 Make_Defining_Identifier (Loc, Chars => Vname), 3397 Parameter_Type => 3398 New_Occurrence_Of (Vtype_Primary_View, Loc))), 3399 Result_Definition => 3400 New_Occurrence_Of (Standard_Unsigned, Loc)), 3401 3402 Declarations => Empty_List, 3403 3404 Handled_Statement_Sequence => 3405 Make_Handled_Sequence_Of_Statements (Loc, 3406 Statements => New_List ( 3407 Make_Simple_Return_Statement (Loc, 3408 Expression => Expr)))); 3409 3410 -- The caller requests that the expression be encapsulated in a 3411 -- parameterless function. 3412 3413 elsif Make_Func then 3414 Decl := 3415 Make_Subprogram_Body (Loc, 3416 3417 Specification => 3418 Make_Function_Specification (Loc, 3419 Defining_Unit_Name => K, 3420 Parameter_Specifications => Empty_List, 3421 Result_Definition => 3422 New_Occurrence_Of (Standard_Unsigned, Loc)), 3423 3424 Declarations => Empty_List, 3425 3426 Handled_Statement_Sequence => 3427 Make_Handled_Sequence_Of_Statements (Loc, 3428 Statements => New_List ( 3429 Make_Simple_Return_Statement (Loc, Expression => Expr)))); 3430 3431 -- No reference to V and function not requested, so create a constant 3432 3433 else 3434 Decl := 3435 Make_Object_Declaration (Loc, 3436 Defining_Identifier => K, 3437 Object_Definition => 3438 New_Occurrence_Of (Standard_Unsigned, Loc), 3439 Constant_Present => True, 3440 Expression => Expr); 3441 end if; 3442 3443 Append_Freeze_Action (Ins_Type, Decl); 3444 Analyze (Decl); 3445 return Create_Dynamic_SO_Ref (K); 3446 end SO_Ref_From_Expr; 3447 3448end Layout; 3449