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