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