1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ C H 1 3 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-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 Einfo; use Einfo; 30with Errout; use Errout; 31with Exp_Tss; use Exp_Tss; 32with Exp_Util; use Exp_Util; 33with Hostparm; use Hostparm; 34with Lib; use Lib; 35with Nlists; use Nlists; 36with Nmake; use Nmake; 37with Opt; use Opt; 38with Rtsfind; use Rtsfind; 39with Sem; use Sem; 40with Sem_Ch8; use Sem_Ch8; 41with Sem_Eval; use Sem_Eval; 42with Sem_Res; use Sem_Res; 43with Sem_Type; use Sem_Type; 44with Sem_Util; use Sem_Util; 45with Snames; use Snames; 46with Stand; use Stand; 47with Sinfo; use Sinfo; 48with Table; 49with Ttypes; use Ttypes; 50with Tbuild; use Tbuild; 51with Urealp; use Urealp; 52 53with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; 54 55package body Sem_Ch13 is 56 57 SSU : constant Pos := System_Storage_Unit; 58 -- Convenient short hand for commonly used constant 59 60 ----------------------- 61 -- Local Subprograms -- 62 ----------------------- 63 64 procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id); 65 -- This routine is called after setting the Esize of type entity Typ. 66 -- The purpose is to deal with the situation where an aligment has been 67 -- inherited from a derived type that is no longer appropriate for the 68 -- new Esize value. In this case, we reset the Alignment to unknown. 69 70 procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); 71 -- Given two entities for record components or discriminants, checks 72 -- if they hav overlapping component clauses and issues errors if so. 73 74 function Get_Alignment_Value (Expr : Node_Id) return Uint; 75 -- Given the expression for an alignment value, returns the corresponding 76 -- Uint value. If the value is inappropriate, then error messages are 77 -- posted as required, and a value of No_Uint is returned. 78 79 function Is_Operational_Item (N : Node_Id) return Boolean; 80 -- A specification for a stream attribute is allowed before the full 81 -- type is declared, as explained in AI-00137 and the corrigendum. 82 -- Attributes that do not specify a representation characteristic are 83 -- operational attributes. 84 85 function Address_Aliased_Entity (N : Node_Id) return Entity_Id; 86 -- If expression N is of the form E'Address, return E. 87 88 procedure Mark_Aliased_Address_As_Volatile (N : Node_Id); 89 -- This is used for processing of an address representation clause. If 90 -- the expression N is of the form of K'Address, then the entity that 91 -- is associated with K is marked as volatile. 92 93 procedure New_Stream_Function 94 (N : Node_Id; 95 Ent : Entity_Id; 96 Subp : Entity_Id; 97 Nam : TSS_Name_Type); 98 -- Create a function renaming of a given stream attribute to the 99 -- designated subprogram and then in the tagged case, provide this as 100 -- a primitive operation, or in the non-tagged case make an appropriate 101 -- TSS entry. Used for Input. This is more properly an expansion activity 102 -- than just semantics, but the presence of user-defined stream functions 103 -- for limited types is a legality check, which is why this takes place 104 -- here rather than in exp_ch13, where it was previously. Nam indicates 105 -- the name of the TSS function to be generated. 106 -- 107 -- To avoid elaboration anomalies with freeze nodes, for untagged types 108 -- we generate both a subprogram declaration and a subprogram renaming 109 -- declaration, so that the attribute specification is handled as a 110 -- renaming_as_body. For tagged types, the specification is one of the 111 -- primitive specs. 112 113 procedure New_Stream_Procedure 114 (N : Node_Id; 115 Ent : Entity_Id; 116 Subp : Entity_Id; 117 Nam : TSS_Name_Type; 118 Out_P : Boolean := False); 119 -- Create a procedure renaming of a given stream attribute to the 120 -- designated subprogram and then in the tagged case, provide this as 121 -- a primitive operation, or in the non-tagged case make an appropriate 122 -- TSS entry. Used for Read, Output, Write. Nam indicates the name of 123 -- the TSS procedure to be generated. 124 125 ---------------------------------------------- 126 -- Table for Validate_Unchecked_Conversions -- 127 ---------------------------------------------- 128 129 -- The following table collects unchecked conversions for validation. 130 -- Entries are made by Validate_Unchecked_Conversion and then the 131 -- call to Validate_Unchecked_Conversions does the actual error 132 -- checking and posting of warnings. The reason for this delayed 133 -- processing is to take advantage of back-annotations of size and 134 -- alignment values peformed by the back end. 135 136 type UC_Entry is record 137 Enode : Node_Id; -- node used for posting warnings 138 Source : Entity_Id; -- source type for unchecked conversion 139 Target : Entity_Id; -- target type for unchecked conversion 140 end record; 141 142 package Unchecked_Conversions is new Table.Table ( 143 Table_Component_Type => UC_Entry, 144 Table_Index_Type => Int, 145 Table_Low_Bound => 1, 146 Table_Initial => 50, 147 Table_Increment => 200, 148 Table_Name => "Unchecked_Conversions"); 149 150 ---------------------------- 151 -- Address_Aliased_Entity -- 152 ---------------------------- 153 154 function Address_Aliased_Entity (N : Node_Id) return Entity_Id is 155 begin 156 if Nkind (N) = N_Attribute_Reference 157 and then Attribute_Name (N) = Name_Address 158 then 159 declare 160 Nam : Node_Id := Prefix (N); 161 begin 162 while False 163 or else Nkind (Nam) = N_Selected_Component 164 or else Nkind (Nam) = N_Indexed_Component 165 loop 166 Nam := Prefix (Nam); 167 end loop; 168 169 if Is_Entity_Name (Nam) then 170 return Entity (Nam); 171 end if; 172 end; 173 end if; 174 175 return Empty; 176 end Address_Aliased_Entity; 177 178 -------------------------------------- 179 -- Alignment_Check_For_Esize_Change -- 180 -------------------------------------- 181 182 procedure Alignment_Check_For_Esize_Change (Typ : Entity_Id) is 183 begin 184 -- If the alignment is known, and not set by a rep clause, and is 185 -- inconsistent with the size being set, then reset it to unknown, 186 -- we assume in this case that the size overrides the inherited 187 -- alignment, and that the alignment must be recomputed. 188 189 if Known_Alignment (Typ) 190 and then not Has_Alignment_Clause (Typ) 191 and then Esize (Typ) mod (Alignment (Typ) * SSU) /= 0 192 then 193 Init_Alignment (Typ); 194 end if; 195 end Alignment_Check_For_Esize_Change; 196 197 ----------------------- 198 -- Analyze_At_Clause -- 199 ----------------------- 200 201 -- An at clause is replaced by the corresponding Address attribute 202 -- definition clause that is the preferred approach in Ada 95. 203 204 procedure Analyze_At_Clause (N : Node_Id) is 205 begin 206 if Warn_On_Obsolescent_Feature then 207 Error_Msg_N 208 ("at clause is an obsolescent feature ('R'M 'J.7(2))?", N); 209 Error_Msg_N 210 ("|use address attribute definition clause instead?", N); 211 end if; 212 213 Rewrite (N, 214 Make_Attribute_Definition_Clause (Sloc (N), 215 Name => Identifier (N), 216 Chars => Name_Address, 217 Expression => Expression (N))); 218 Analyze_Attribute_Definition_Clause (N); 219 end Analyze_At_Clause; 220 221 ----------------------------------------- 222 -- Analyze_Attribute_Definition_Clause -- 223 ----------------------------------------- 224 225 procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is 226 Loc : constant Source_Ptr := Sloc (N); 227 Nam : constant Node_Id := Name (N); 228 Attr : constant Name_Id := Chars (N); 229 Expr : constant Node_Id := Expression (N); 230 Id : constant Attribute_Id := Get_Attribute_Id (Attr); 231 Ent : Entity_Id; 232 U_Ent : Entity_Id; 233 234 FOnly : Boolean := False; 235 -- Reset to True for subtype specific attribute (Alignment, Size) 236 -- and for stream attributes, i.e. those cases where in the call 237 -- to Rep_Item_Too_Late, FOnly is set True so that only the freezing 238 -- rules are checked. Note that the case of stream attributes is not 239 -- clear from the RM, but see AI95-00137. Also, the RM seems to 240 -- disallow Storage_Size for derived task types, but that is also 241 -- clearly unintentional. 242 243 begin 244 Analyze (Nam); 245 Ent := Entity (Nam); 246 247 if Rep_Item_Too_Early (Ent, N) then 248 return; 249 end if; 250 251 -- Rep clause applies to full view of incomplete type or private type 252 -- if we have one (if not, this is a premature use of the type). 253 -- However, certain semantic checks need to be done on the specified 254 -- entity (i.e. the private view), so we save it in Ent. 255 256 if Is_Private_Type (Ent) 257 and then Is_Derived_Type (Ent) 258 and then not Is_Tagged_Type (Ent) 259 and then No (Full_View (Ent)) 260 then 261 -- If this is a private type whose completion is a derivation 262 -- from another private type, there is no full view, and the 263 -- attribute belongs to the type itself, not its underlying parent. 264 265 U_Ent := Ent; 266 267 elsif Ekind (Ent) = E_Incomplete_Type then 268 Ent := Underlying_Type (Ent); 269 U_Ent := Ent; 270 else 271 U_Ent := Underlying_Type (Ent); 272 end if; 273 274 -- Complete other routine error checks 275 276 if Etype (Nam) = Any_Type then 277 return; 278 279 elsif Scope (Ent) /= Current_Scope then 280 Error_Msg_N ("entity must be declared in this scope", Nam); 281 return; 282 283 elsif No (U_Ent) then 284 U_Ent := Ent; 285 286 elsif Is_Type (U_Ent) 287 and then not Is_First_Subtype (U_Ent) 288 and then Id /= Attribute_Object_Size 289 and then Id /= Attribute_Value_Size 290 and then not From_At_Mod (N) 291 then 292 Error_Msg_N ("cannot specify attribute for subtype", Nam); 293 return; 294 295 end if; 296 297 -- Switch on particular attribute 298 299 case Id is 300 301 ------------- 302 -- Address -- 303 ------------- 304 305 -- Address attribute definition clause 306 307 when Attribute_Address => Address : begin 308 Analyze_And_Resolve (Expr, RTE (RE_Address)); 309 310 if Present (Address_Clause (U_Ent)) then 311 Error_Msg_N ("address already given for &", Nam); 312 313 -- Case of address clause for subprogram 314 315 elsif Is_Subprogram (U_Ent) then 316 if Has_Homonym (U_Ent) then 317 Error_Msg_N 318 ("address clause cannot be given " & 319 "for overloaded subprogram", 320 Nam); 321 end if; 322 323 -- For subprograms, all address clauses are permitted, 324 -- and we mark the subprogram as having a deferred freeze 325 -- so that Gigi will not elaborate it too soon. 326 327 -- Above needs more comments, what is too soon about??? 328 329 Set_Has_Delayed_Freeze (U_Ent); 330 331 -- Case of address clause for entry 332 333 elsif Ekind (U_Ent) = E_Entry then 334 if Nkind (Parent (N)) = N_Task_Body then 335 Error_Msg_N 336 ("entry address must be specified in task spec", Nam); 337 end if; 338 339 -- For entries, we require a constant address 340 341 Check_Constant_Address_Clause (Expr, U_Ent); 342 343 if Is_Task_Type (Scope (U_Ent)) 344 and then Comes_From_Source (Scope (U_Ent)) 345 then 346 Error_Msg_N 347 ("?entry address declared for entry in task type", N); 348 Error_Msg_N 349 ("\?only one task can be declared of this type", N); 350 end if; 351 352 if Warn_On_Obsolescent_Feature then 353 Error_Msg_N 354 ("attaching interrupt to task entry is an " & 355 "obsolescent feature ('R'M 'J.7.1)?", N); 356 Error_Msg_N 357 ("|use interrupt procedure instead?", N); 358 end if; 359 360 -- Case of an address clause for a controlled object: 361 -- erroneous execution. 362 363 elsif Is_Controlled (Etype (U_Ent)) then 364 Error_Msg_NE 365 ("?controlled object& must not be overlaid", Nam, U_Ent); 366 Error_Msg_N 367 ("\?Program_Error will be raised at run time", Nam); 368 Insert_Action (Declaration_Node (U_Ent), 369 Make_Raise_Program_Error (Loc, 370 Reason => PE_Overlaid_Controlled_Object)); 371 372 -- Case of address clause for a (non-controlled) object 373 374 elsif 375 Ekind (U_Ent) = E_Variable 376 or else 377 Ekind (U_Ent) = E_Constant 378 then 379 declare 380 Expr : constant Node_Id := Expression (N); 381 Aent : constant Entity_Id := Address_Aliased_Entity (Expr); 382 383 begin 384 -- Exported variables cannot have an address clause, 385 -- because this cancels the effect of the pragma Export 386 387 if Is_Exported (U_Ent) then 388 Error_Msg_N 389 ("cannot export object with address clause", Nam); 390 391 -- Overlaying controlled objects is erroneous 392 393 elsif Present (Aent) 394 and then Is_Controlled (Etype (Aent)) 395 then 396 Error_Msg_N 397 ("?controlled object must not be overlaid", Expr); 398 Error_Msg_N 399 ("\?Program_Error will be raised at run time", Expr); 400 Insert_Action (Declaration_Node (U_Ent), 401 Make_Raise_Program_Error (Loc, 402 Reason => PE_Overlaid_Controlled_Object)); 403 404 elsif Present (Aent) 405 and then Ekind (U_Ent) = E_Constant 406 and then Ekind (Aent) /= E_Constant 407 then 408 Error_Msg_N ("constant overlays a variable?", Expr); 409 410 elsif Present (Renamed_Object (U_Ent)) then 411 Error_Msg_N 412 ("address clause not allowed" 413 & " for a renaming declaration ('R'M 13.1(6))", Nam); 414 415 -- Imported variables can have an address clause, but then 416 -- the import is pretty meaningless except to suppress 417 -- initializations, so we do not need such variables to 418 -- be statically allocated (and in fact it causes trouble 419 -- if the address clause is a local value). 420 421 elsif Is_Imported (U_Ent) then 422 Set_Is_Statically_Allocated (U_Ent, False); 423 end if; 424 425 -- We mark a possible modification of a variable with an 426 -- address clause, since it is likely aliasing is occurring. 427 428 Note_Possible_Modification (Nam); 429 430 -- Here we are checking for explicit overlap of one 431 -- variable by another, and if we find this, then we 432 -- mark the overlapped variable as also being aliased. 433 434 -- First case is where we have an explicit 435 436 -- for J'Address use K'Address; 437 438 -- In this case, we mark K as volatile 439 440 Mark_Aliased_Address_As_Volatile (Expr); 441 442 -- Second case is where we have a constant whose 443 -- definition is of the form of an adress as in: 444 445 -- A : constant Address := K'Address; 446 -- ... 447 -- for B'Address use A; 448 449 -- In this case we also mark K as volatile 450 451 if Is_Entity_Name (Expr) then 452 declare 453 Ent : constant Entity_Id := Entity (Expr); 454 Decl : constant Node_Id := Declaration_Node (Ent); 455 456 begin 457 if Ekind (Ent) = E_Constant 458 and then Nkind (Decl) = N_Object_Declaration 459 and then Present (Expression (Decl)) 460 then 461 Mark_Aliased_Address_As_Volatile 462 (Expression (Decl)); 463 end if; 464 end; 465 end if; 466 467 -- Legality checks on the address clause for initialized 468 -- objects is deferred until the freeze point, because 469 -- a subsequent pragma might indicate that the object is 470 -- imported and thus not initialized. 471 472 Set_Has_Delayed_Freeze (U_Ent); 473 474 if Is_Exported (U_Ent) then 475 Error_Msg_N 476 ("& cannot be exported if an address clause is given", 477 Nam); 478 Error_Msg_N 479 ("\define and export a variable " & 480 "that holds its address instead", 481 Nam); 482 end if; 483 484 -- Entity has delayed freeze, so we will generate 485 -- an alignment check at the freeze point. 486 487 Set_Check_Address_Alignment 488 (N, not Range_Checks_Suppressed (U_Ent)); 489 490 -- Kill the size check code, since we are not allocating 491 -- the variable, it is somewhere else. 492 493 Kill_Size_Check_Code (U_Ent); 494 end; 495 496 -- Not a valid entity for an address clause 497 498 else 499 Error_Msg_N ("address cannot be given for &", Nam); 500 end if; 501 end Address; 502 503 --------------- 504 -- Alignment -- 505 --------------- 506 507 -- Alignment attribute definition clause 508 509 when Attribute_Alignment => Alignment_Block : declare 510 Align : constant Uint := Get_Alignment_Value (Expr); 511 512 begin 513 FOnly := True; 514 515 if not Is_Type (U_Ent) 516 and then Ekind (U_Ent) /= E_Variable 517 and then Ekind (U_Ent) /= E_Constant 518 then 519 Error_Msg_N ("alignment cannot be given for &", Nam); 520 521 elsif Has_Alignment_Clause (U_Ent) then 522 Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent)); 523 Error_Msg_N ("alignment clause previously given#", N); 524 525 elsif Align /= No_Uint then 526 Set_Has_Alignment_Clause (U_Ent); 527 Set_Alignment (U_Ent, Align); 528 end if; 529 end Alignment_Block; 530 531 --------------- 532 -- Bit_Order -- 533 --------------- 534 535 -- Bit_Order attribute definition clause 536 537 when Attribute_Bit_Order => Bit_Order : declare 538 begin 539 if not Is_Record_Type (U_Ent) then 540 Error_Msg_N 541 ("Bit_Order can only be defined for record type", Nam); 542 543 else 544 Analyze_And_Resolve (Expr, RTE (RE_Bit_Order)); 545 546 if Etype (Expr) = Any_Type then 547 return; 548 549 elsif not Is_Static_Expression (Expr) then 550 Flag_Non_Static_Expr 551 ("Bit_Order requires static expression!", Expr); 552 553 else 554 if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then 555 Set_Reverse_Bit_Order (U_Ent, True); 556 end if; 557 end if; 558 end if; 559 end Bit_Order; 560 561 -------------------- 562 -- Component_Size -- 563 -------------------- 564 565 -- Component_Size attribute definition clause 566 567 when Attribute_Component_Size => Component_Size_Case : declare 568 Csize : constant Uint := Static_Integer (Expr); 569 Btype : Entity_Id; 570 Biased : Boolean; 571 New_Ctyp : Entity_Id; 572 Decl : Node_Id; 573 574 begin 575 if not Is_Array_Type (U_Ent) then 576 Error_Msg_N ("component size requires array type", Nam); 577 return; 578 end if; 579 580 Btype := Base_Type (U_Ent); 581 582 if Has_Component_Size_Clause (Btype) then 583 Error_Msg_N 584 ("component size clase for& previously given", Nam); 585 586 elsif Csize /= No_Uint then 587 Check_Size (Expr, Component_Type (Btype), Csize, Biased); 588 589 if Has_Aliased_Components (Btype) 590 and then Csize < 32 591 and then Csize /= 8 592 and then Csize /= 16 593 then 594 Error_Msg_N 595 ("component size incorrect for aliased components", N); 596 return; 597 end if; 598 599 -- For the biased case, build a declaration for a subtype 600 -- that will be used to represent the biased subtype that 601 -- reflects the biased representation of components. We need 602 -- this subtype to get proper conversions on referencing 603 -- elements of the array. 604 605 if Biased then 606 New_Ctyp := 607 Make_Defining_Identifier (Loc, 608 Chars => New_External_Name (Chars (U_Ent), 'C', 0, 'T')); 609 610 Decl := 611 Make_Subtype_Declaration (Loc, 612 Defining_Identifier => New_Ctyp, 613 Subtype_Indication => 614 New_Occurrence_Of (Component_Type (Btype), Loc)); 615 616 Set_Parent (Decl, N); 617 Analyze (Decl, Suppress => All_Checks); 618 619 Set_Has_Delayed_Freeze (New_Ctyp, False); 620 Set_Esize (New_Ctyp, Csize); 621 Set_RM_Size (New_Ctyp, Csize); 622 Init_Alignment (New_Ctyp); 623 Set_Has_Biased_Representation (New_Ctyp, True); 624 Set_Is_Itype (New_Ctyp, True); 625 Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); 626 627 Set_Component_Type (Btype, New_Ctyp); 628 end if; 629 630 Set_Component_Size (Btype, Csize); 631 Set_Has_Component_Size_Clause (Btype, True); 632 Set_Has_Non_Standard_Rep (Btype, True); 633 end if; 634 end Component_Size_Case; 635 636 ------------------ 637 -- External_Tag -- 638 ------------------ 639 640 when Attribute_External_Tag => External_Tag : 641 begin 642 if not Is_Tagged_Type (U_Ent) then 643 Error_Msg_N ("should be a tagged type", Nam); 644 end if; 645 646 Analyze_And_Resolve (Expr, Standard_String); 647 648 if not Is_Static_Expression (Expr) then 649 Flag_Non_Static_Expr 650 ("static string required for tag name!", Nam); 651 end if; 652 653 Set_Has_External_Tag_Rep_Clause (U_Ent); 654 end External_Tag; 655 656 ----------- 657 -- Input -- 658 ----------- 659 660 when Attribute_Input => Input : declare 661 Subp : Entity_Id := Empty; 662 I : Interp_Index; 663 It : Interp; 664 Pnam : Entity_Id; 665 666 function Has_Good_Profile (Subp : Entity_Id) return Boolean; 667 -- Return true if the entity is a function with an appropriate 668 -- profile for the Input attribute. 669 670 ---------------------- 671 -- Has_Good_Profile -- 672 ---------------------- 673 674 function Has_Good_Profile (Subp : Entity_Id) return Boolean is 675 F : Entity_Id; 676 Ok : Boolean := False; 677 678 begin 679 if Ekind (Subp) = E_Function then 680 F := First_Formal (Subp); 681 682 if Present (F) and then No (Next_Formal (F)) then 683 if Ekind (Etype (F)) = E_Anonymous_Access_Type 684 and then 685 Designated_Type (Etype (F)) = 686 Class_Wide_Type (RTE (RE_Root_Stream_Type)) 687 then 688 Ok := Base_Type (Etype (Subp)) = Base_Type (Ent); 689 end if; 690 end if; 691 end if; 692 693 return Ok; 694 end Has_Good_Profile; 695 696 -- Start of processing for Input attribute definition 697 698 begin 699 FOnly := True; 700 701 if not Is_Type (U_Ent) then 702 Error_Msg_N ("local name must be a subtype", Nam); 703 return; 704 705 else 706 Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Input); 707 708 if Present (Pnam) 709 and then Base_Type (Etype (Pnam)) = Base_Type (U_Ent) 710 then 711 Error_Msg_Sloc := Sloc (Pnam); 712 Error_Msg_N ("input attribute already defined #", Nam); 713 return; 714 end if; 715 end if; 716 717 Analyze (Expr); 718 719 if Is_Entity_Name (Expr) then 720 if not Is_Overloaded (Expr) then 721 if Has_Good_Profile (Entity (Expr)) then 722 Subp := Entity (Expr); 723 end if; 724 725 else 726 Get_First_Interp (Expr, I, It); 727 728 while Present (It.Nam) loop 729 if Has_Good_Profile (It.Nam) then 730 Subp := It.Nam; 731 exit; 732 end if; 733 734 Get_Next_Interp (I, It); 735 end loop; 736 end if; 737 end if; 738 739 if Present (Subp) then 740 Set_Entity (Expr, Subp); 741 Set_Etype (Expr, Etype (Subp)); 742 New_Stream_Function (N, U_Ent, Subp, TSS_Stream_Input); 743 else 744 Error_Msg_N ("incorrect expression for input attribute", Expr); 745 return; 746 end if; 747 end Input; 748 749 ------------------- 750 -- Machine_Radix -- 751 ------------------- 752 753 -- Machine radix attribute definition clause 754 755 when Attribute_Machine_Radix => Machine_Radix : declare 756 Radix : constant Uint := Static_Integer (Expr); 757 758 begin 759 if not Is_Decimal_Fixed_Point_Type (U_Ent) then 760 Error_Msg_N ("decimal fixed-point type expected for &", Nam); 761 762 elsif Has_Machine_Radix_Clause (U_Ent) then 763 Error_Msg_Sloc := Sloc (Alignment_Clause (U_Ent)); 764 Error_Msg_N ("machine radix clause previously given#", N); 765 766 elsif Radix /= No_Uint then 767 Set_Has_Machine_Radix_Clause (U_Ent); 768 Set_Has_Non_Standard_Rep (Base_Type (U_Ent)); 769 770 if Radix = 2 then 771 null; 772 elsif Radix = 10 then 773 Set_Machine_Radix_10 (U_Ent); 774 else 775 Error_Msg_N ("machine radix value must be 2 or 10", Expr); 776 end if; 777 end if; 778 end Machine_Radix; 779 780 ----------------- 781 -- Object_Size -- 782 ----------------- 783 784 -- Object_Size attribute definition clause 785 786 when Attribute_Object_Size => Object_Size : declare 787 Size : constant Uint := Static_Integer (Expr); 788 Biased : Boolean; 789 790 begin 791 if not Is_Type (U_Ent) then 792 Error_Msg_N ("Object_Size cannot be given for &", Nam); 793 794 elsif Has_Object_Size_Clause (U_Ent) then 795 Error_Msg_N ("Object_Size already given for &", Nam); 796 797 else 798 Check_Size (Expr, U_Ent, Size, Biased); 799 800 if Size /= 8 801 and then 802 Size /= 16 803 and then 804 Size /= 32 805 and then 806 UI_Mod (Size, 64) /= 0 807 then 808 Error_Msg_N 809 ("Object_Size must be 8, 16, 32, or multiple of 64", 810 Expr); 811 end if; 812 813 Set_Esize (U_Ent, Size); 814 Set_Has_Object_Size_Clause (U_Ent); 815 Alignment_Check_For_Esize_Change (U_Ent); 816 end if; 817 end Object_Size; 818 819 ------------ 820 -- Output -- 821 ------------ 822 823 when Attribute_Output => Output : declare 824 Subp : Entity_Id := Empty; 825 I : Interp_Index; 826 It : Interp; 827 Pnam : Entity_Id; 828 829 function Has_Good_Profile (Subp : Entity_Id) return Boolean; 830 -- Return true if the entity is a procedure with an 831 -- appropriate profile for the output attribute. 832 833 ---------------------- 834 -- Has_Good_Profile -- 835 ---------------------- 836 837 function Has_Good_Profile (Subp : Entity_Id) return Boolean is 838 F : Entity_Id; 839 Ok : Boolean := False; 840 841 begin 842 if Ekind (Subp) = E_Procedure then 843 F := First_Formal (Subp); 844 845 if Present (F) then 846 if Ekind (Etype (F)) = E_Anonymous_Access_Type 847 and then 848 Designated_Type (Etype (F)) = 849 Class_Wide_Type (RTE (RE_Root_Stream_Type)) 850 then 851 Next_Formal (F); 852 Ok := Present (F) 853 and then Parameter_Mode (F) = E_In_Parameter 854 and then Base_Type (Etype (F)) = Base_Type (Ent) 855 and then No (Next_Formal (F)); 856 end if; 857 end if; 858 end if; 859 860 return Ok; 861 end Has_Good_Profile; 862 863 -- Start of processing for Output attribute definition 864 865 begin 866 FOnly := True; 867 868 if not Is_Type (U_Ent) then 869 Error_Msg_N ("local name must be a subtype", Nam); 870 return; 871 872 else 873 Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Output); 874 875 if Present (Pnam) 876 and then 877 Base_Type (Etype (Next_Formal (First_Formal (Pnam)))) 878 = Base_Type (U_Ent) 879 then 880 Error_Msg_Sloc := Sloc (Pnam); 881 Error_Msg_N ("output attribute already defined #", Nam); 882 return; 883 end if; 884 end if; 885 886 Analyze (Expr); 887 888 if Is_Entity_Name (Expr) then 889 if not Is_Overloaded (Expr) then 890 if Has_Good_Profile (Entity (Expr)) then 891 Subp := Entity (Expr); 892 end if; 893 894 else 895 Get_First_Interp (Expr, I, It); 896 897 while Present (It.Nam) loop 898 if Has_Good_Profile (It.Nam) then 899 Subp := It.Nam; 900 exit; 901 end if; 902 903 Get_Next_Interp (I, It); 904 end loop; 905 end if; 906 end if; 907 908 if Present (Subp) then 909 Set_Entity (Expr, Subp); 910 Set_Etype (Expr, Etype (Subp)); 911 New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Output); 912 else 913 Error_Msg_N ("incorrect expression for output attribute", Expr); 914 return; 915 end if; 916 end Output; 917 918 ---------- 919 -- Read -- 920 ---------- 921 922 when Attribute_Read => Read : declare 923 Subp : Entity_Id := Empty; 924 I : Interp_Index; 925 It : Interp; 926 Pnam : Entity_Id; 927 928 function Has_Good_Profile (Subp : Entity_Id) return Boolean; 929 -- Return true if the entity is a procedure with an appropriate 930 -- profile for the Read attribute. 931 932 ---------------------- 933 -- Has_Good_Profile -- 934 ---------------------- 935 936 function Has_Good_Profile (Subp : Entity_Id) return Boolean is 937 F : Entity_Id; 938 Ok : Boolean := False; 939 940 begin 941 if Ekind (Subp) = E_Procedure then 942 F := First_Formal (Subp); 943 944 if Present (F) then 945 if Ekind (Etype (F)) = E_Anonymous_Access_Type 946 and then 947 Designated_Type (Etype (F)) = 948 Class_Wide_Type (RTE (RE_Root_Stream_Type)) 949 then 950 Next_Formal (F); 951 Ok := Present (F) 952 and then Parameter_Mode (F) = E_Out_Parameter 953 and then Base_Type (Etype (F)) = Base_Type (Ent) 954 and then No (Next_Formal (F)); 955 end if; 956 end if; 957 end if; 958 959 return Ok; 960 end Has_Good_Profile; 961 962 -- Start of processing for Read attribute definition 963 964 begin 965 FOnly := True; 966 967 if not Is_Type (U_Ent) then 968 Error_Msg_N ("local name must be a subtype", Nam); 969 return; 970 971 else 972 Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Read); 973 974 if Present (Pnam) 975 and then Base_Type (Etype (Next_Formal (First_Formal (Pnam)))) 976 = Base_Type (U_Ent) 977 then 978 Error_Msg_Sloc := Sloc (Pnam); 979 Error_Msg_N ("read attribute already defined #", Nam); 980 return; 981 end if; 982 end if; 983 984 Analyze (Expr); 985 986 if Is_Entity_Name (Expr) then 987 if not Is_Overloaded (Expr) then 988 if Has_Good_Profile (Entity (Expr)) then 989 Subp := Entity (Expr); 990 end if; 991 992 else 993 Get_First_Interp (Expr, I, It); 994 995 while Present (It.Nam) loop 996 if Has_Good_Profile (It.Nam) then 997 Subp := It.Nam; 998 exit; 999 end if; 1000 1001 Get_Next_Interp (I, It); 1002 end loop; 1003 end if; 1004 end if; 1005 1006 if Present (Subp) then 1007 Set_Entity (Expr, Subp); 1008 Set_Etype (Expr, Etype (Subp)); 1009 New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Read, True); 1010 else 1011 Error_Msg_N ("incorrect expression for read attribute", Expr); 1012 return; 1013 end if; 1014 end Read; 1015 1016 ---------- 1017 -- Size -- 1018 ---------- 1019 1020 -- Size attribute definition clause 1021 1022 when Attribute_Size => Size : declare 1023 Size : constant Uint := Static_Integer (Expr); 1024 Etyp : Entity_Id; 1025 Biased : Boolean; 1026 1027 begin 1028 FOnly := True; 1029 1030 if Has_Size_Clause (U_Ent) then 1031 Error_Msg_N ("size already given for &", Nam); 1032 1033 elsif not Is_Type (U_Ent) 1034 and then Ekind (U_Ent) /= E_Variable 1035 and then Ekind (U_Ent) /= E_Constant 1036 then 1037 Error_Msg_N ("size cannot be given for &", Nam); 1038 1039 elsif Is_Array_Type (U_Ent) 1040 and then not Is_Constrained (U_Ent) 1041 then 1042 Error_Msg_N 1043 ("size cannot be given for unconstrained array", Nam); 1044 1045 elsif Size /= No_Uint then 1046 if Is_Type (U_Ent) then 1047 Etyp := U_Ent; 1048 else 1049 Etyp := Etype (U_Ent); 1050 end if; 1051 1052 -- Check size, note that Gigi is in charge of checking 1053 -- that the size of an array or record type is OK. Also 1054 -- we do not check the size in the ordinary fixed-point 1055 -- case, since it is too early to do so (there may be a 1056 -- subsequent small clause that affects the size). We can 1057 -- check the size if a small clause has already been given. 1058 1059 if not Is_Ordinary_Fixed_Point_Type (U_Ent) 1060 or else Has_Small_Clause (U_Ent) 1061 then 1062 Check_Size (Expr, Etyp, Size, Biased); 1063 Set_Has_Biased_Representation (U_Ent, Biased); 1064 end if; 1065 1066 -- For types set RM_Size and Esize if possible 1067 1068 if Is_Type (U_Ent) then 1069 Set_RM_Size (U_Ent, Size); 1070 1071 -- For scalar types, increase Object_Size to power of 2, 1072 -- but not less than a storage unit in any case (i.e., 1073 -- normally this means it will be byte addressable). 1074 1075 if Is_Scalar_Type (U_Ent) then 1076 if Size <= System_Storage_Unit then 1077 Init_Esize (U_Ent, System_Storage_Unit); 1078 elsif Size <= 16 then 1079 Init_Esize (U_Ent, 16); 1080 elsif Size <= 32 then 1081 Init_Esize (U_Ent, 32); 1082 else 1083 Set_Esize (U_Ent, (Size + 63) / 64 * 64); 1084 end if; 1085 1086 -- For all other types, object size = value size. The 1087 -- backend will adjust as needed. 1088 1089 else 1090 Set_Esize (U_Ent, Size); 1091 end if; 1092 1093 Alignment_Check_For_Esize_Change (U_Ent); 1094 1095 -- For objects, set Esize only 1096 1097 else 1098 if Is_Elementary_Type (Etyp) then 1099 if Size /= System_Storage_Unit 1100 and then 1101 Size /= System_Storage_Unit * 2 1102 and then 1103 Size /= System_Storage_Unit * 4 1104 and then 1105 Size /= System_Storage_Unit * 8 1106 then 1107 Error_Msg_N 1108 ("size for primitive object must be power of 2", N); 1109 end if; 1110 end if; 1111 1112 Set_Esize (U_Ent, Size); 1113 end if; 1114 1115 Set_Has_Size_Clause (U_Ent); 1116 end if; 1117 end Size; 1118 1119 ----------- 1120 -- Small -- 1121 ----------- 1122 1123 -- Small attribute definition clause 1124 1125 when Attribute_Small => Small : declare 1126 Implicit_Base : constant Entity_Id := Base_Type (U_Ent); 1127 Small : Ureal; 1128 1129 begin 1130 Analyze_And_Resolve (Expr, Any_Real); 1131 1132 if Etype (Expr) = Any_Type then 1133 return; 1134 1135 elsif not Is_Static_Expression (Expr) then 1136 Flag_Non_Static_Expr 1137 ("small requires static expression!", Expr); 1138 return; 1139 1140 else 1141 Small := Expr_Value_R (Expr); 1142 1143 if Small <= Ureal_0 then 1144 Error_Msg_N ("small value must be greater than zero", Expr); 1145 return; 1146 end if; 1147 1148 end if; 1149 1150 if not Is_Ordinary_Fixed_Point_Type (U_Ent) then 1151 Error_Msg_N 1152 ("small requires an ordinary fixed point type", Nam); 1153 1154 elsif Has_Small_Clause (U_Ent) then 1155 Error_Msg_N ("small already given for &", Nam); 1156 1157 elsif Small > Delta_Value (U_Ent) then 1158 Error_Msg_N 1159 ("small value must not be greater then delta value", Nam); 1160 1161 else 1162 Set_Small_Value (U_Ent, Small); 1163 Set_Small_Value (Implicit_Base, Small); 1164 Set_Has_Small_Clause (U_Ent); 1165 Set_Has_Small_Clause (Implicit_Base); 1166 Set_Has_Non_Standard_Rep (Implicit_Base); 1167 end if; 1168 end Small; 1169 1170 ------------------ 1171 -- Storage_Size -- 1172 ------------------ 1173 1174 -- Storage_Size attribute definition clause 1175 1176 when Attribute_Storage_Size => Storage_Size : declare 1177 Btype : constant Entity_Id := Base_Type (U_Ent); 1178 Sprag : Node_Id; 1179 1180 begin 1181 if Is_Task_Type (U_Ent) then 1182 if Warn_On_Obsolescent_Feature then 1183 Error_Msg_N 1184 ("storage size clause for task is an " & 1185 "obsolescent feature ('R'M 'J.9)?", N); 1186 Error_Msg_N 1187 ("|use Storage_Size pragma instead?", N); 1188 end if; 1189 1190 FOnly := True; 1191 end if; 1192 1193 if not Is_Access_Type (U_Ent) 1194 and then Ekind (U_Ent) /= E_Task_Type 1195 then 1196 Error_Msg_N ("storage size cannot be given for &", Nam); 1197 1198 elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then 1199 Error_Msg_N 1200 ("storage size cannot be given for a derived access type", 1201 Nam); 1202 1203 elsif Has_Storage_Size_Clause (Btype) then 1204 Error_Msg_N ("storage size already given for &", Nam); 1205 1206 else 1207 Analyze_And_Resolve (Expr, Any_Integer); 1208 1209 if Is_Access_Type (U_Ent) then 1210 1211 if Present (Associated_Storage_Pool (U_Ent)) then 1212 Error_Msg_N ("storage pool already given for &", Nam); 1213 return; 1214 end if; 1215 1216 if Compile_Time_Known_Value (Expr) 1217 and then Expr_Value (Expr) = 0 1218 then 1219 Set_No_Pool_Assigned (Btype); 1220 end if; 1221 1222 else -- Is_Task_Type (U_Ent) 1223 Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size); 1224 1225 if Present (Sprag) then 1226 Error_Msg_Sloc := Sloc (Sprag); 1227 Error_Msg_N 1228 ("Storage_Size already specified#", Nam); 1229 return; 1230 end if; 1231 end if; 1232 1233 Set_Has_Storage_Size_Clause (Btype); 1234 end if; 1235 end Storage_Size; 1236 1237 ------------------ 1238 -- Storage_Pool -- 1239 ------------------ 1240 1241 -- Storage_Pool attribute definition clause 1242 1243 when Attribute_Storage_Pool => Storage_Pool : declare 1244 Pool : Entity_Id; 1245 1246 begin 1247 if Ekind (U_Ent) /= E_Access_Type 1248 and then Ekind (U_Ent) /= E_General_Access_Type 1249 then 1250 Error_Msg_N ( 1251 "storage pool can only be given for access types", Nam); 1252 return; 1253 1254 elsif Is_Derived_Type (U_Ent) then 1255 Error_Msg_N 1256 ("storage pool cannot be given for a derived access type", 1257 Nam); 1258 1259 elsif Has_Storage_Size_Clause (U_Ent) then 1260 Error_Msg_N ("storage size already given for &", Nam); 1261 return; 1262 1263 elsif Present (Associated_Storage_Pool (U_Ent)) then 1264 Error_Msg_N ("storage pool already given for &", Nam); 1265 return; 1266 end if; 1267 1268 Analyze_And_Resolve 1269 (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); 1270 1271 -- If the argument is a name that is not an entity name, then 1272 -- we construct a renaming operation to define an entity of 1273 -- type storage pool. 1274 1275 if not Is_Entity_Name (Expr) 1276 and then Is_Object_Reference (Expr) 1277 then 1278 Pool := 1279 Make_Defining_Identifier (Loc, 1280 Chars => New_Internal_Name ('P')); 1281 1282 declare 1283 Rnode : constant Node_Id := 1284 Make_Object_Renaming_Declaration (Loc, 1285 Defining_Identifier => Pool, 1286 Subtype_Mark => 1287 New_Occurrence_Of (Etype (Expr), Loc), 1288 Name => Expr); 1289 1290 begin 1291 Insert_Before (N, Rnode); 1292 Analyze (Rnode); 1293 Set_Associated_Storage_Pool (U_Ent, Pool); 1294 end; 1295 1296 elsif Is_Entity_Name (Expr) then 1297 Pool := Entity (Expr); 1298 1299 -- If pool is a renamed object, get original one. This can 1300 -- happen with an explicit renaming, and within instances. 1301 1302 while Present (Renamed_Object (Pool)) 1303 and then Is_Entity_Name (Renamed_Object (Pool)) 1304 loop 1305 Pool := Entity (Renamed_Object (Pool)); 1306 end loop; 1307 1308 if Present (Renamed_Object (Pool)) 1309 and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion 1310 and then Is_Entity_Name (Expression (Renamed_Object (Pool))) 1311 then 1312 Pool := Entity (Expression (Renamed_Object (Pool))); 1313 end if; 1314 1315 if Present (Etype (Pool)) 1316 and then Etype (Pool) /= RTE (RE_Stack_Bounded_Pool) 1317 and then Etype (Pool) /= RTE (RE_Unbounded_Reclaim_Pool) 1318 then 1319 Set_Associated_Storage_Pool (U_Ent, Pool); 1320 else 1321 Error_Msg_N ("Non sharable GNAT Pool", Expr); 1322 end if; 1323 1324 -- The pool may be specified as the Storage_Pool of some other 1325 -- type. It is rewritten as a class_wide conversion of the 1326 -- corresponding pool entity. 1327 1328 elsif Nkind (Expr) = N_Type_Conversion 1329 and then Is_Entity_Name (Expression (Expr)) 1330 and then Nkind (Original_Node (Expr)) = N_Attribute_Reference 1331 then 1332 Pool := Entity (Expression (Expr)); 1333 1334 if Present (Etype (Pool)) 1335 and then Etype (Pool) /= RTE (RE_Stack_Bounded_Pool) 1336 and then Etype (Pool) /= RTE (RE_Unbounded_Reclaim_Pool) 1337 then 1338 Set_Associated_Storage_Pool (U_Ent, Pool); 1339 else 1340 Error_Msg_N ("Non sharable GNAT Pool", Expr); 1341 end if; 1342 1343 else 1344 Error_Msg_N ("incorrect reference to a Storage Pool", Expr); 1345 return; 1346 end if; 1347 end Storage_Pool; 1348 1349 ---------------- 1350 -- Value_Size -- 1351 ---------------- 1352 1353 -- Value_Size attribute definition clause 1354 1355 when Attribute_Value_Size => Value_Size : declare 1356 Size : constant Uint := Static_Integer (Expr); 1357 Biased : Boolean; 1358 1359 begin 1360 if not Is_Type (U_Ent) then 1361 Error_Msg_N ("Value_Size cannot be given for &", Nam); 1362 1363 elsif Present 1364 (Get_Attribute_Definition_Clause 1365 (U_Ent, Attribute_Value_Size)) 1366 then 1367 Error_Msg_N ("Value_Size already given for &", Nam); 1368 1369 else 1370 if Is_Elementary_Type (U_Ent) then 1371 Check_Size (Expr, U_Ent, Size, Biased); 1372 Set_Has_Biased_Representation (U_Ent, Biased); 1373 end if; 1374 1375 Set_RM_Size (U_Ent, Size); 1376 end if; 1377 end Value_Size; 1378 1379 ----------- 1380 -- Write -- 1381 ----------- 1382 1383 -- Write attribute definition clause 1384 -- check for class-wide case will be performed later 1385 1386 when Attribute_Write => Write : declare 1387 Subp : Entity_Id := Empty; 1388 I : Interp_Index; 1389 It : Interp; 1390 Pnam : Entity_Id; 1391 1392 function Has_Good_Profile (Subp : Entity_Id) return Boolean; 1393 -- Return true if the entity is a procedure with an 1394 -- appropriate profile for the write attribute. 1395 1396 function Has_Good_Profile (Subp : Entity_Id) return Boolean is 1397 F : Entity_Id; 1398 Ok : Boolean := False; 1399 1400 begin 1401 if Ekind (Subp) = E_Procedure then 1402 F := First_Formal (Subp); 1403 1404 if Present (F) then 1405 if Ekind (Etype (F)) = E_Anonymous_Access_Type 1406 and then 1407 Designated_Type (Etype (F)) = 1408 Class_Wide_Type (RTE (RE_Root_Stream_Type)) 1409 then 1410 Next_Formal (F); 1411 Ok := Present (F) 1412 and then Parameter_Mode (F) = E_In_Parameter 1413 and then Base_Type (Etype (F)) = Base_Type (Ent) 1414 and then No (Next_Formal (F)); 1415 end if; 1416 end if; 1417 end if; 1418 1419 return Ok; 1420 end Has_Good_Profile; 1421 1422 -- Start of processing for Write attribute definition 1423 1424 begin 1425 FOnly := True; 1426 1427 if not Is_Type (U_Ent) then 1428 Error_Msg_N ("local name must be a subtype", Nam); 1429 return; 1430 end if; 1431 1432 Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Write); 1433 1434 if Present (Pnam) 1435 and then Base_Type (Etype (Next_Formal (First_Formal (Pnam)))) 1436 = Base_Type (U_Ent) 1437 then 1438 Error_Msg_Sloc := Sloc (Pnam); 1439 Error_Msg_N ("write attribute already defined #", Nam); 1440 return; 1441 end if; 1442 1443 Analyze (Expr); 1444 1445 if Is_Entity_Name (Expr) then 1446 if not Is_Overloaded (Expr) then 1447 if Has_Good_Profile (Entity (Expr)) then 1448 Subp := Entity (Expr); 1449 end if; 1450 1451 else 1452 Get_First_Interp (Expr, I, It); 1453 1454 while Present (It.Nam) loop 1455 if Has_Good_Profile (It.Nam) then 1456 Subp := It.Nam; 1457 exit; 1458 end if; 1459 1460 Get_Next_Interp (I, It); 1461 end loop; 1462 end if; 1463 end if; 1464 1465 if Present (Subp) then 1466 Set_Entity (Expr, Subp); 1467 Set_Etype (Expr, Etype (Subp)); 1468 New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Write); 1469 else 1470 Error_Msg_N ("incorrect expression for write attribute", Expr); 1471 return; 1472 end if; 1473 end Write; 1474 1475 -- All other attributes cannot be set 1476 1477 when others => 1478 Error_Msg_N 1479 ("attribute& cannot be set with definition clause", N); 1480 1481 end case; 1482 1483 -- The test for the type being frozen must be performed after 1484 -- any expression the clause has been analyzed since the expression 1485 -- itself might cause freezing that makes the clause illegal. 1486 1487 if Rep_Item_Too_Late (U_Ent, N, FOnly) then 1488 return; 1489 end if; 1490 end Analyze_Attribute_Definition_Clause; 1491 1492 ---------------------------- 1493 -- Analyze_Code_Statement -- 1494 ---------------------------- 1495 1496 procedure Analyze_Code_Statement (N : Node_Id) is 1497 HSS : constant Node_Id := Parent (N); 1498 SBody : constant Node_Id := Parent (HSS); 1499 Subp : constant Entity_Id := Current_Scope; 1500 Stmt : Node_Id; 1501 Decl : Node_Id; 1502 StmtO : Node_Id; 1503 DeclO : Node_Id; 1504 1505 begin 1506 -- Analyze and check we get right type, note that this implements the 1507 -- requirement (RM 13.8(1)) that Machine_Code be with'ed, since that 1508 -- is the only way that Asm_Insn could possibly be visible. 1509 1510 Analyze_And_Resolve (Expression (N)); 1511 1512 if Etype (Expression (N)) = Any_Type then 1513 return; 1514 elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then 1515 Error_Msg_N ("incorrect type for code statement", N); 1516 return; 1517 end if; 1518 1519 -- Make sure we appear in the handled statement sequence of a 1520 -- subprogram (RM 13.8(3)). 1521 1522 if Nkind (HSS) /= N_Handled_Sequence_Of_Statements 1523 or else Nkind (SBody) /= N_Subprogram_Body 1524 then 1525 Error_Msg_N 1526 ("code statement can only appear in body of subprogram", N); 1527 return; 1528 end if; 1529 1530 -- Do remaining checks (RM 13.8(3)) if not already done 1531 1532 if not Is_Machine_Code_Subprogram (Subp) then 1533 Set_Is_Machine_Code_Subprogram (Subp); 1534 1535 -- No exception handlers allowed 1536 1537 if Present (Exception_Handlers (HSS)) then 1538 Error_Msg_N 1539 ("exception handlers not permitted in machine code subprogram", 1540 First (Exception_Handlers (HSS))); 1541 end if; 1542 1543 -- No declarations other than use clauses and pragmas (we allow 1544 -- certain internally generated declarations as well). 1545 1546 Decl := First (Declarations (SBody)); 1547 while Present (Decl) loop 1548 DeclO := Original_Node (Decl); 1549 if Comes_From_Source (DeclO) 1550 and then Nkind (DeclO) /= N_Pragma 1551 and then Nkind (DeclO) /= N_Use_Package_Clause 1552 and then Nkind (DeclO) /= N_Use_Type_Clause 1553 and then Nkind (DeclO) /= N_Implicit_Label_Declaration 1554 then 1555 Error_Msg_N 1556 ("this declaration not allowed in machine code subprogram", 1557 DeclO); 1558 end if; 1559 1560 Next (Decl); 1561 end loop; 1562 1563 -- No statements other than code statements, pragmas, and labels. 1564 -- Again we allow certain internally generated statements. 1565 1566 Stmt := First (Statements (HSS)); 1567 while Present (Stmt) loop 1568 StmtO := Original_Node (Stmt); 1569 if Comes_From_Source (StmtO) 1570 and then Nkind (StmtO) /= N_Pragma 1571 and then Nkind (StmtO) /= N_Label 1572 and then Nkind (StmtO) /= N_Code_Statement 1573 then 1574 Error_Msg_N 1575 ("this statement is not allowed in machine code subprogram", 1576 StmtO); 1577 end if; 1578 1579 Next (Stmt); 1580 end loop; 1581 end if; 1582 end Analyze_Code_Statement; 1583 1584 ----------------------------------------------- 1585 -- Analyze_Enumeration_Representation_Clause -- 1586 ----------------------------------------------- 1587 1588 procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is 1589 Ident : constant Node_Id := Identifier (N); 1590 Aggr : constant Node_Id := Array_Aggregate (N); 1591 Enumtype : Entity_Id; 1592 Elit : Entity_Id; 1593 Expr : Node_Id; 1594 Assoc : Node_Id; 1595 Choice : Node_Id; 1596 Val : Uint; 1597 Err : Boolean := False; 1598 1599 Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer)); 1600 Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer)); 1601 Min : Uint; 1602 Max : Uint; 1603 1604 begin 1605 -- First some basic error checks 1606 1607 Find_Type (Ident); 1608 Enumtype := Entity (Ident); 1609 1610 if Enumtype = Any_Type 1611 or else Rep_Item_Too_Early (Enumtype, N) 1612 then 1613 return; 1614 else 1615 Enumtype := Underlying_Type (Enumtype); 1616 end if; 1617 1618 if not Is_Enumeration_Type (Enumtype) then 1619 Error_Msg_NE 1620 ("enumeration type required, found}", 1621 Ident, First_Subtype (Enumtype)); 1622 return; 1623 end if; 1624 1625 -- Ignore rep clause on generic actual type. This will already have 1626 -- been flagged on the template as an error, and this is the safest 1627 -- way to ensure we don't get a junk cascaded message in the instance. 1628 1629 if Is_Generic_Actual_Type (Enumtype) then 1630 return; 1631 1632 -- Type must be in current scope 1633 1634 elsif Scope (Enumtype) /= Current_Scope then 1635 Error_Msg_N ("type must be declared in this scope", Ident); 1636 return; 1637 1638 -- Type must be a first subtype 1639 1640 elsif not Is_First_Subtype (Enumtype) then 1641 Error_Msg_N ("cannot give enumeration rep clause for subtype", N); 1642 return; 1643 1644 -- Ignore duplicate rep clause 1645 1646 elsif Has_Enumeration_Rep_Clause (Enumtype) then 1647 Error_Msg_N ("duplicate enumeration rep clause ignored", N); 1648 return; 1649 1650 -- Don't allow rep clause if root type is standard [wide_]character 1651 1652 elsif Root_Type (Enumtype) = Standard_Character 1653 or else Root_Type (Enumtype) = Standard_Wide_Character 1654 then 1655 Error_Msg_N ("enumeration rep clause not allowed for this type", N); 1656 return; 1657 1658 -- All tests passed, so set rep clause in place 1659 1660 else 1661 Set_Has_Enumeration_Rep_Clause (Enumtype); 1662 Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype)); 1663 end if; 1664 1665 -- Now we process the aggregate. Note that we don't use the normal 1666 -- aggregate code for this purpose, because we don't want any of the 1667 -- normal expansion activities, and a number of special semantic 1668 -- rules apply (including the component type being any integer type) 1669 1670 -- Badent signals that we found some incorrect entries processing 1671 -- the list. The final checks for completeness and ordering are 1672 -- skipped in this case. 1673 1674 Elit := First_Literal (Enumtype); 1675 1676 -- First the positional entries if any 1677 1678 if Present (Expressions (Aggr)) then 1679 Expr := First (Expressions (Aggr)); 1680 while Present (Expr) loop 1681 if No (Elit) then 1682 Error_Msg_N ("too many entries in aggregate", Expr); 1683 return; 1684 end if; 1685 1686 Val := Static_Integer (Expr); 1687 1688 if Val = No_Uint then 1689 Err := True; 1690 1691 elsif Val < Lo or else Hi < Val then 1692 Error_Msg_N ("value outside permitted range", Expr); 1693 Err := True; 1694 end if; 1695 1696 Set_Enumeration_Rep (Elit, Val); 1697 Set_Enumeration_Rep_Expr (Elit, Expr); 1698 Next (Expr); 1699 Next (Elit); 1700 end loop; 1701 end if; 1702 1703 -- Now process the named entries if present 1704 1705 if Present (Component_Associations (Aggr)) then 1706 Assoc := First (Component_Associations (Aggr)); 1707 while Present (Assoc) loop 1708 Choice := First (Choices (Assoc)); 1709 1710 if Present (Next (Choice)) then 1711 Error_Msg_N 1712 ("multiple choice not allowed here", Next (Choice)); 1713 Err := True; 1714 end if; 1715 1716 if Nkind (Choice) = N_Others_Choice then 1717 Error_Msg_N ("others choice not allowed here", Choice); 1718 Err := True; 1719 1720 elsif Nkind (Choice) = N_Range then 1721 -- ??? should allow zero/one element range here 1722 Error_Msg_N ("range not allowed here", Choice); 1723 Err := True; 1724 1725 else 1726 Analyze_And_Resolve (Choice, Enumtype); 1727 1728 if Is_Entity_Name (Choice) 1729 and then Is_Type (Entity (Choice)) 1730 then 1731 Error_Msg_N ("subtype name not allowed here", Choice); 1732 Err := True; 1733 -- ??? should allow static subtype with zero/one entry 1734 1735 elsif Etype (Choice) = Base_Type (Enumtype) then 1736 if not Is_Static_Expression (Choice) then 1737 Flag_Non_Static_Expr 1738 ("non-static expression used for choice!", Choice); 1739 Err := True; 1740 1741 else 1742 Elit := Expr_Value_E (Choice); 1743 1744 if Present (Enumeration_Rep_Expr (Elit)) then 1745 Error_Msg_Sloc := Sloc (Enumeration_Rep_Expr (Elit)); 1746 Error_Msg_NE 1747 ("representation for& previously given#", 1748 Choice, Elit); 1749 Err := True; 1750 end if; 1751 1752 Set_Enumeration_Rep_Expr (Elit, Choice); 1753 1754 Expr := Expression (Assoc); 1755 Val := Static_Integer (Expr); 1756 1757 if Val = No_Uint then 1758 Err := True; 1759 1760 elsif Val < Lo or else Hi < Val then 1761 Error_Msg_N ("value outside permitted range", Expr); 1762 Err := True; 1763 end if; 1764 1765 Set_Enumeration_Rep (Elit, Val); 1766 end if; 1767 end if; 1768 end if; 1769 1770 Next (Assoc); 1771 end loop; 1772 end if; 1773 1774 -- Aggregate is fully processed. Now we check that a full set of 1775 -- representations was given, and that they are in range and in order. 1776 -- These checks are only done if no other errors occurred. 1777 1778 if not Err then 1779 Min := No_Uint; 1780 Max := No_Uint; 1781 1782 Elit := First_Literal (Enumtype); 1783 while Present (Elit) loop 1784 if No (Enumeration_Rep_Expr (Elit)) then 1785 Error_Msg_NE ("missing representation for&!", N, Elit); 1786 1787 else 1788 Val := Enumeration_Rep (Elit); 1789 1790 if Min = No_Uint then 1791 Min := Val; 1792 end if; 1793 1794 if Val /= No_Uint then 1795 if Max /= No_Uint and then Val <= Max then 1796 Error_Msg_NE 1797 ("enumeration value for& not ordered!", 1798 Enumeration_Rep_Expr (Elit), Elit); 1799 end if; 1800 1801 Max := Val; 1802 end if; 1803 1804 -- If there is at least one literal whose representation 1805 -- is not equal to the Pos value, then note that this 1806 -- enumeration type has a non-standard representation. 1807 1808 if Val /= Enumeration_Pos (Elit) then 1809 Set_Has_Non_Standard_Rep (Base_Type (Enumtype)); 1810 end if; 1811 end if; 1812 1813 Next (Elit); 1814 end loop; 1815 1816 -- Now set proper size information 1817 1818 declare 1819 Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype)); 1820 1821 begin 1822 if Has_Size_Clause (Enumtype) then 1823 if Esize (Enumtype) >= Minsize then 1824 null; 1825 1826 else 1827 Minsize := 1828 UI_From_Int (Minimum_Size (Enumtype, Biased => True)); 1829 1830 if Esize (Enumtype) < Minsize then 1831 Error_Msg_N ("previously given size is too small", N); 1832 1833 else 1834 Set_Has_Biased_Representation (Enumtype); 1835 end if; 1836 end if; 1837 1838 else 1839 Set_RM_Size (Enumtype, Minsize); 1840 Set_Enum_Esize (Enumtype); 1841 end if; 1842 1843 Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype)); 1844 Set_Esize (Base_Type (Enumtype), Esize (Enumtype)); 1845 Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype)); 1846 end; 1847 end if; 1848 1849 -- We repeat the too late test in case it froze itself! 1850 1851 if Rep_Item_Too_Late (Enumtype, N) then 1852 null; 1853 end if; 1854 end Analyze_Enumeration_Representation_Clause; 1855 1856 ---------------------------- 1857 -- Analyze_Free_Statement -- 1858 ---------------------------- 1859 1860 procedure Analyze_Free_Statement (N : Node_Id) is 1861 begin 1862 Analyze (Expression (N)); 1863 end Analyze_Free_Statement; 1864 1865 ------------------------------------------ 1866 -- Analyze_Record_Representation_Clause -- 1867 ------------------------------------------ 1868 1869 procedure Analyze_Record_Representation_Clause (N : Node_Id) is 1870 Loc : constant Source_Ptr := Sloc (N); 1871 Ident : constant Node_Id := Identifier (N); 1872 Rectype : Entity_Id; 1873 Fent : Entity_Id; 1874 CC : Node_Id; 1875 Posit : Uint; 1876 Fbit : Uint; 1877 Lbit : Uint; 1878 Hbit : Uint := Uint_0; 1879 Comp : Entity_Id; 1880 Ocomp : Entity_Id; 1881 Biased : Boolean; 1882 1883 Max_Bit_So_Far : Uint; 1884 -- Records the maximum bit position so far. If all field positions 1885 -- are monotonically increasing, then we can skip the circuit for 1886 -- checking for overlap, since no overlap is possible. 1887 1888 Overlap_Check_Required : Boolean; 1889 -- Used to keep track of whether or not an overlap check is required 1890 1891 Ccount : Natural := 0; 1892 -- Number of component clauses in record rep clause 1893 1894 begin 1895 Find_Type (Ident); 1896 Rectype := Entity (Ident); 1897 1898 if Rectype = Any_Type 1899 or else Rep_Item_Too_Early (Rectype, N) 1900 then 1901 return; 1902 else 1903 Rectype := Underlying_Type (Rectype); 1904 end if; 1905 1906 -- First some basic error checks 1907 1908 if not Is_Record_Type (Rectype) then 1909 Error_Msg_NE 1910 ("record type required, found}", Ident, First_Subtype (Rectype)); 1911 return; 1912 1913 elsif Is_Unchecked_Union (Rectype) then 1914 Error_Msg_N 1915 ("record rep clause not allowed for Unchecked_Union", N); 1916 1917 elsif Scope (Rectype) /= Current_Scope then 1918 Error_Msg_N ("type must be declared in this scope", N); 1919 return; 1920 1921 elsif not Is_First_Subtype (Rectype) then 1922 Error_Msg_N ("cannot give record rep clause for subtype", N); 1923 return; 1924 1925 elsif Has_Record_Rep_Clause (Rectype) then 1926 Error_Msg_N ("duplicate record rep clause ignored", N); 1927 return; 1928 1929 elsif Rep_Item_Too_Late (Rectype, N) then 1930 return; 1931 end if; 1932 1933 if Present (Mod_Clause (N)) then 1934 declare 1935 Loc : constant Source_Ptr := Sloc (N); 1936 M : constant Node_Id := Mod_Clause (N); 1937 P : constant List_Id := Pragmas_Before (M); 1938 AtM_Nod : Node_Id; 1939 1940 Mod_Val : Uint; 1941 pragma Warnings (Off, Mod_Val); 1942 1943 begin 1944 if Warn_On_Obsolescent_Feature then 1945 Error_Msg_N 1946 ("mod clause is an obsolescent feature ('R'M 'J.8)?", N); 1947 Error_Msg_N 1948 ("|use alignment attribute definition clause instead?", N); 1949 end if; 1950 1951 if Present (P) then 1952 Analyze_List (P); 1953 end if; 1954 1955 -- In ASIS_Mode mode, expansion is disabled, but we must 1956 -- convert the Mod clause into an alignment clause anyway, so 1957 -- that the back-end can compute and back-annotate properly the 1958 -- size and alignment of types that may include this record. 1959 1960 if Operating_Mode = Check_Semantics 1961 and then ASIS_Mode 1962 then 1963 AtM_Nod := 1964 Make_Attribute_Definition_Clause (Loc, 1965 Name => New_Reference_To (Base_Type (Rectype), Loc), 1966 Chars => Name_Alignment, 1967 Expression => Relocate_Node (Expression (M))); 1968 1969 Set_From_At_Mod (AtM_Nod); 1970 Insert_After (N, AtM_Nod); 1971 Mod_Val := Get_Alignment_Value (Expression (AtM_Nod)); 1972 Set_Mod_Clause (N, Empty); 1973 1974 else 1975 -- Get the alignment value to perform error checking 1976 1977 Mod_Val := Get_Alignment_Value (Expression (M)); 1978 1979 end if; 1980 end; 1981 end if; 1982 1983 -- Clear any existing component clauses for the type (this happens 1984 -- with derived types, where we are now overriding the original) 1985 1986 Fent := First_Entity (Rectype); 1987 1988 Comp := Fent; 1989 while Present (Comp) loop 1990 if Ekind (Comp) = E_Component 1991 or else Ekind (Comp) = E_Discriminant 1992 then 1993 Set_Component_Clause (Comp, Empty); 1994 end if; 1995 1996 Next_Entity (Comp); 1997 end loop; 1998 1999 -- All done if no component clauses 2000 2001 CC := First (Component_Clauses (N)); 2002 2003 if No (CC) then 2004 return; 2005 end if; 2006 2007 -- If a tag is present, then create a component clause that places 2008 -- it at the start of the record (otherwise gigi may place it after 2009 -- other fields that have rep clauses). 2010 2011 if Nkind (Fent) = N_Defining_Identifier 2012 and then Chars (Fent) = Name_uTag 2013 then 2014 Set_Component_Bit_Offset (Fent, Uint_0); 2015 Set_Normalized_Position (Fent, Uint_0); 2016 Set_Normalized_First_Bit (Fent, Uint_0); 2017 Set_Normalized_Position_Max (Fent, Uint_0); 2018 Init_Esize (Fent, System_Address_Size); 2019 2020 Set_Component_Clause (Fent, 2021 Make_Component_Clause (Loc, 2022 Component_Name => 2023 Make_Identifier (Loc, 2024 Chars => Name_uTag), 2025 2026 Position => 2027 Make_Integer_Literal (Loc, 2028 Intval => Uint_0), 2029 2030 First_Bit => 2031 Make_Integer_Literal (Loc, 2032 Intval => Uint_0), 2033 2034 Last_Bit => 2035 Make_Integer_Literal (Loc, 2036 UI_From_Int (System_Address_Size)))); 2037 2038 Ccount := Ccount + 1; 2039 end if; 2040 2041 -- A representation like this applies to the base type 2042 2043 Set_Has_Record_Rep_Clause (Base_Type (Rectype)); 2044 Set_Has_Non_Standard_Rep (Base_Type (Rectype)); 2045 Set_Has_Specified_Layout (Base_Type (Rectype)); 2046 2047 Max_Bit_So_Far := Uint_Minus_1; 2048 Overlap_Check_Required := False; 2049 2050 -- Process the component clauses 2051 2052 while Present (CC) loop 2053 2054 -- If pragma, just analyze it 2055 2056 if Nkind (CC) = N_Pragma then 2057 Analyze (CC); 2058 2059 -- Processing for real component clause 2060 2061 else 2062 Ccount := Ccount + 1; 2063 Posit := Static_Integer (Position (CC)); 2064 Fbit := Static_Integer (First_Bit (CC)); 2065 Lbit := Static_Integer (Last_Bit (CC)); 2066 2067 if Posit /= No_Uint 2068 and then Fbit /= No_Uint 2069 and then Lbit /= No_Uint 2070 then 2071 if Posit < 0 then 2072 Error_Msg_N 2073 ("position cannot be negative", Position (CC)); 2074 2075 elsif Fbit < 0 then 2076 Error_Msg_N 2077 ("first bit cannot be negative", First_Bit (CC)); 2078 2079 -- Values look OK, so find the corresponding record component 2080 -- Even though the syntax allows an attribute reference for 2081 -- implementation-defined components, GNAT does not allow the 2082 -- tag to get an explicit position. 2083 2084 elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then 2085 2086 if Attribute_Name (Component_Name (CC)) = Name_Tag then 2087 Error_Msg_N ("position of tag cannot be specified", CC); 2088 else 2089 Error_Msg_N ("illegal component name", CC); 2090 end if; 2091 2092 else 2093 Comp := First_Entity (Rectype); 2094 while Present (Comp) loop 2095 exit when Chars (Comp) = Chars (Component_Name (CC)); 2096 Next_Entity (Comp); 2097 end loop; 2098 2099 if No (Comp) then 2100 2101 -- Maybe component of base type that is absent from 2102 -- statically constrained first subtype. 2103 2104 Comp := First_Entity (Base_Type (Rectype)); 2105 while Present (Comp) loop 2106 exit when Chars (Comp) = Chars (Component_Name (CC)); 2107 Next_Entity (Comp); 2108 end loop; 2109 end if; 2110 2111 if No (Comp) then 2112 Error_Msg_N 2113 ("component clause is for non-existent field", CC); 2114 2115 elsif Present (Component_Clause (Comp)) then 2116 Error_Msg_Sloc := Sloc (Component_Clause (Comp)); 2117 Error_Msg_N 2118 ("component clause previously given#", CC); 2119 2120 else 2121 -- Update Fbit and Lbit to the actual bit number. 2122 2123 Fbit := Fbit + UI_From_Int (SSU) * Posit; 2124 Lbit := Lbit + UI_From_Int (SSU) * Posit; 2125 2126 if Fbit <= Max_Bit_So_Far then 2127 Overlap_Check_Required := True; 2128 else 2129 Max_Bit_So_Far := Lbit; 2130 end if; 2131 2132 if Has_Size_Clause (Rectype) 2133 and then Esize (Rectype) <= Lbit 2134 then 2135 Error_Msg_N 2136 ("bit number out of range of specified size", 2137 Last_Bit (CC)); 2138 else 2139 Set_Component_Clause (Comp, CC); 2140 Set_Component_Bit_Offset (Comp, Fbit); 2141 Set_Esize (Comp, 1 + (Lbit - Fbit)); 2142 Set_Normalized_First_Bit (Comp, Fbit mod SSU); 2143 Set_Normalized_Position (Comp, Fbit / SSU); 2144 2145 Set_Normalized_Position_Max 2146 (Fent, Normalized_Position (Fent)); 2147 2148 if Is_Tagged_Type (Rectype) 2149 and then Fbit < System_Address_Size 2150 then 2151 Error_Msg_NE 2152 ("component overlaps tag field of&", 2153 CC, Rectype); 2154 end if; 2155 2156 -- This information is also set in the corresponding 2157 -- component of the base type, found by accessing the 2158 -- Original_Record_Component link if it is present. 2159 2160 Ocomp := Original_Record_Component (Comp); 2161 2162 if Hbit < Lbit then 2163 Hbit := Lbit; 2164 end if; 2165 2166 Check_Size 2167 (Component_Name (CC), 2168 Etype (Comp), 2169 Esize (Comp), 2170 Biased); 2171 2172 Set_Has_Biased_Representation (Comp, Biased); 2173 2174 if Present (Ocomp) then 2175 Set_Component_Clause (Ocomp, CC); 2176 Set_Component_Bit_Offset (Ocomp, Fbit); 2177 Set_Normalized_First_Bit (Ocomp, Fbit mod SSU); 2178 Set_Normalized_Position (Ocomp, Fbit / SSU); 2179 Set_Esize (Ocomp, 1 + (Lbit - Fbit)); 2180 2181 Set_Normalized_Position_Max 2182 (Ocomp, Normalized_Position (Ocomp)); 2183 2184 Set_Has_Biased_Representation 2185 (Ocomp, Has_Biased_Representation (Comp)); 2186 end if; 2187 2188 if Esize (Comp) < 0 then 2189 Error_Msg_N ("component size is negative", CC); 2190 end if; 2191 end if; 2192 end if; 2193 end if; 2194 end if; 2195 end if; 2196 2197 Next (CC); 2198 end loop; 2199 2200 -- Now that we have processed all the component clauses, check for 2201 -- overlap. We have to leave this till last, since the components 2202 -- can appear in any arbitrary order in the representation clause. 2203 2204 -- We do not need this check if all specified ranges were monotonic, 2205 -- as recorded by Overlap_Check_Required being False at this stage. 2206 2207 -- This first section checks if there are any overlapping entries 2208 -- at all. It does this by sorting all entries and then seeing if 2209 -- there are any overlaps. If there are none, then that is decisive, 2210 -- but if there are overlaps, they may still be OK (they may result 2211 -- from fields in different variants). 2212 2213 if Overlap_Check_Required then 2214 Overlap_Check1 : declare 2215 2216 OC_Fbit : array (0 .. Ccount) of Uint; 2217 -- First-bit values for component clauses, the value is the 2218 -- offset of the first bit of the field from start of record. 2219 -- The zero entry is for use in sorting. 2220 2221 OC_Lbit : array (0 .. Ccount) of Uint; 2222 -- Last-bit values for component clauses, the value is the 2223 -- offset of the last bit of the field from start of record. 2224 -- The zero entry is for use in sorting. 2225 2226 OC_Count : Natural := 0; 2227 -- Count of entries in OC_Fbit and OC_Lbit 2228 2229 function OC_Lt (Op1, Op2 : Natural) return Boolean; 2230 -- Compare routine for Sort (See GNAT.Heap_Sort_A) 2231 2232 procedure OC_Move (From : Natural; To : Natural); 2233 -- Move routine for Sort (see GNAT.Heap_Sort_A) 2234 2235 function OC_Lt (Op1, Op2 : Natural) return Boolean is 2236 begin 2237 return OC_Fbit (Op1) < OC_Fbit (Op2); 2238 end OC_Lt; 2239 2240 procedure OC_Move (From : Natural; To : Natural) is 2241 begin 2242 OC_Fbit (To) := OC_Fbit (From); 2243 OC_Lbit (To) := OC_Lbit (From); 2244 end OC_Move; 2245 2246 begin 2247 CC := First (Component_Clauses (N)); 2248 while Present (CC) loop 2249 if Nkind (CC) /= N_Pragma then 2250 Posit := Static_Integer (Position (CC)); 2251 Fbit := Static_Integer (First_Bit (CC)); 2252 Lbit := Static_Integer (Last_Bit (CC)); 2253 2254 if Posit /= No_Uint 2255 and then Fbit /= No_Uint 2256 and then Lbit /= No_Uint 2257 then 2258 OC_Count := OC_Count + 1; 2259 Posit := Posit * SSU; 2260 OC_Fbit (OC_Count) := Fbit + Posit; 2261 OC_Lbit (OC_Count) := Lbit + Posit; 2262 end if; 2263 end if; 2264 2265 Next (CC); 2266 end loop; 2267 2268 Sort 2269 (OC_Count, 2270 OC_Move'Unrestricted_Access, 2271 OC_Lt'Unrestricted_Access); 2272 2273 Overlap_Check_Required := False; 2274 for J in 1 .. OC_Count - 1 loop 2275 if OC_Lbit (J) >= OC_Fbit (J + 1) then 2276 Overlap_Check_Required := True; 2277 exit; 2278 end if; 2279 end loop; 2280 end Overlap_Check1; 2281 end if; 2282 2283 -- If Overlap_Check_Required is still True, then we have to do 2284 -- the full scale overlap check, since we have at least two fields 2285 -- that do overlap, and we need to know if that is OK since they 2286 -- are in the same variant, or whether we have a definite problem 2287 2288 if Overlap_Check_Required then 2289 Overlap_Check2 : declare 2290 C1_Ent, C2_Ent : Entity_Id; 2291 -- Entities of components being checked for overlap 2292 2293 Clist : Node_Id; 2294 -- Component_List node whose Component_Items are being checked 2295 2296 Citem : Node_Id; 2297 -- Component declaration for component being checked 2298 2299 begin 2300 C1_Ent := First_Entity (Base_Type (Rectype)); 2301 2302 -- Loop through all components in record. For each component check 2303 -- for overlap with any of the preceding elements on the component 2304 -- list containing the component, and also, if the component is in 2305 -- a variant, check against components outside the case structure. 2306 -- This latter test is repeated recursively up the variant tree. 2307 2308 Main_Component_Loop : while Present (C1_Ent) loop 2309 if Ekind (C1_Ent) /= E_Component 2310 and then Ekind (C1_Ent) /= E_Discriminant 2311 then 2312 goto Continue_Main_Component_Loop; 2313 end if; 2314 2315 -- Skip overlap check if entity has no declaration node. This 2316 -- happens with discriminants in constrained derived types. 2317 -- Probably we are missing some checks as a result, but that 2318 -- does not seem terribly serious ??? 2319 2320 if No (Declaration_Node (C1_Ent)) then 2321 goto Continue_Main_Component_Loop; 2322 end if; 2323 2324 Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); 2325 2326 -- Loop through component lists that need checking. Check the 2327 -- current component list and all lists in variants above us. 2328 2329 Component_List_Loop : loop 2330 2331 -- If derived type definition, go to full declaration 2332 -- If at outer level, check discriminants if there are any 2333 2334 if Nkind (Clist) = N_Derived_Type_Definition then 2335 Clist := Parent (Clist); 2336 end if; 2337 2338 -- Outer level of record definition, check discriminants 2339 2340 if Nkind (Clist) = N_Full_Type_Declaration 2341 or else Nkind (Clist) = N_Private_Type_Declaration 2342 then 2343 if Has_Discriminants (Defining_Identifier (Clist)) then 2344 C2_Ent := 2345 First_Discriminant (Defining_Identifier (Clist)); 2346 2347 while Present (C2_Ent) loop 2348 exit when C1_Ent = C2_Ent; 2349 Check_Component_Overlap (C1_Ent, C2_Ent); 2350 Next_Discriminant (C2_Ent); 2351 end loop; 2352 end if; 2353 2354 -- Record extension case 2355 2356 elsif Nkind (Clist) = N_Derived_Type_Definition then 2357 Clist := Empty; 2358 2359 -- Otherwise check one component list 2360 2361 else 2362 Citem := First (Component_Items (Clist)); 2363 2364 while Present (Citem) loop 2365 if Nkind (Citem) = N_Component_Declaration then 2366 C2_Ent := Defining_Identifier (Citem); 2367 exit when C1_Ent = C2_Ent; 2368 Check_Component_Overlap (C1_Ent, C2_Ent); 2369 end if; 2370 2371 Next (Citem); 2372 end loop; 2373 end if; 2374 2375 -- Check for variants above us (the parent of the Clist can 2376 -- be a variant, in which case its parent is a variant part, 2377 -- and the parent of the variant part is a component list 2378 -- whose components must all be checked against the current 2379 -- component for overlap. 2380 2381 if Nkind (Parent (Clist)) = N_Variant then 2382 Clist := Parent (Parent (Parent (Clist))); 2383 2384 -- Check for possible discriminant part in record, this is 2385 -- treated essentially as another level in the recursion. 2386 -- For this case we have the parent of the component list 2387 -- is the record definition, and its parent is the full 2388 -- type declaration which contains the discriminant 2389 -- specifications. 2390 2391 elsif Nkind (Parent (Clist)) = N_Record_Definition then 2392 Clist := Parent (Parent ((Clist))); 2393 2394 -- If neither of these two cases, we are at the top of 2395 -- the tree 2396 2397 else 2398 exit Component_List_Loop; 2399 end if; 2400 end loop Component_List_Loop; 2401 2402 <<Continue_Main_Component_Loop>> 2403 Next_Entity (C1_Ent); 2404 2405 end loop Main_Component_Loop; 2406 end Overlap_Check2; 2407 end if; 2408 2409 -- For records that have component clauses for all components, and 2410 -- whose size is less than or equal to 32, we need to know the size 2411 -- in the front end to activate possible packed array processing 2412 -- where the component type is a record. 2413 2414 -- At this stage Hbit + 1 represents the first unused bit from all 2415 -- the component clauses processed, so if the component clauses are 2416 -- complete, then this is the length of the record. 2417 2418 -- For records longer than System.Storage_Unit, and for those where 2419 -- not all components have component clauses, the back end determines 2420 -- the length (it may for example be appopriate to round up the size 2421 -- to some convenient boundary, based on alignment considerations etc). 2422 2423 if Unknown_RM_Size (Rectype) 2424 and then Hbit + 1 <= 32 2425 then 2426 -- Nothing to do if at least one component with no component clause 2427 2428 Comp := First_Entity (Rectype); 2429 while Present (Comp) loop 2430 if Ekind (Comp) = E_Component 2431 or else Ekind (Comp) = E_Discriminant 2432 then 2433 if No (Component_Clause (Comp)) then 2434 return; 2435 end if; 2436 end if; 2437 2438 Next_Entity (Comp); 2439 end loop; 2440 2441 -- If we fall out of loop, all components have component clauses 2442 -- and so we can set the size to the maximum value. 2443 2444 Set_RM_Size (Rectype, Hbit + 1); 2445 end if; 2446 end Analyze_Record_Representation_Clause; 2447 2448 ----------------------------- 2449 -- Check_Component_Overlap -- 2450 ----------------------------- 2451 2452 procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is 2453 begin 2454 if Present (Component_Clause (C1_Ent)) 2455 and then Present (Component_Clause (C2_Ent)) 2456 then 2457 -- Exclude odd case where we have two tag fields in the same 2458 -- record, both at location zero. This seems a bit strange, 2459 -- but it seems to happen in some circumstances ??? 2460 2461 if Chars (C1_Ent) = Name_uTag 2462 and then Chars (C2_Ent) = Name_uTag 2463 then 2464 return; 2465 end if; 2466 2467 -- Here we check if the two fields overlap 2468 2469 declare 2470 S1 : constant Uint := Component_Bit_Offset (C1_Ent); 2471 S2 : constant Uint := Component_Bit_Offset (C2_Ent); 2472 E1 : constant Uint := S1 + Esize (C1_Ent); 2473 E2 : constant Uint := S2 + Esize (C2_Ent); 2474 2475 begin 2476 if E2 <= S1 or else E1 <= S2 then 2477 null; 2478 else 2479 Error_Msg_Node_2 := 2480 Component_Name (Component_Clause (C2_Ent)); 2481 Error_Msg_Sloc := Sloc (Error_Msg_Node_2); 2482 Error_Msg_Node_1 := 2483 Component_Name (Component_Clause (C1_Ent)); 2484 Error_Msg_N 2485 ("component& overlaps & #", 2486 Component_Name (Component_Clause (C1_Ent))); 2487 end if; 2488 end; 2489 end if; 2490 end Check_Component_Overlap; 2491 2492 ----------------------------------- 2493 -- Check_Constant_Address_Clause -- 2494 ----------------------------------- 2495 2496 procedure Check_Constant_Address_Clause 2497 (Expr : Node_Id; 2498 U_Ent : Entity_Id) 2499 is 2500 procedure Check_At_Constant_Address (Nod : Node_Id); 2501 -- Checks that the given node N represents a name whose 'Address 2502 -- is constant (in the same sense as OK_Constant_Address_Clause, 2503 -- i.e. the address value is the same at the point of declaration 2504 -- of U_Ent and at the time of elaboration of the address clause. 2505 2506 procedure Check_Expr_Constants (Nod : Node_Id); 2507 -- Checks that Nod meets the requirements for a constant address 2508 -- clause in the sense of the enclosing procedure. 2509 2510 procedure Check_List_Constants (Lst : List_Id); 2511 -- Check that all elements of list Lst meet the requirements for a 2512 -- constant address clause in the sense of the enclosing procedure. 2513 2514 ------------------------------- 2515 -- Check_At_Constant_Address -- 2516 ------------------------------- 2517 2518 procedure Check_At_Constant_Address (Nod : Node_Id) is 2519 begin 2520 if Is_Entity_Name (Nod) then 2521 if Present (Address_Clause (Entity ((Nod)))) then 2522 Error_Msg_NE 2523 ("invalid address clause for initialized object &!", 2524 Nod, U_Ent); 2525 Error_Msg_NE 2526 ("address for& cannot" & 2527 " depend on another address clause! ('R'M 13.1(22))!", 2528 Nod, U_Ent); 2529 2530 elsif In_Same_Source_Unit (Entity (Nod), U_Ent) 2531 and then Sloc (U_Ent) < Sloc (Entity (Nod)) 2532 then 2533 Error_Msg_NE 2534 ("invalid address clause for initialized object &!", 2535 Nod, U_Ent); 2536 Error_Msg_Name_1 := Chars (Entity (Nod)); 2537 Error_Msg_Name_2 := Chars (U_Ent); 2538 Error_Msg_N 2539 ("\% must be defined before % ('R'M 13.1(22))!", 2540 Nod); 2541 end if; 2542 2543 elsif Nkind (Nod) = N_Selected_Component then 2544 declare 2545 T : constant Entity_Id := Etype (Prefix (Nod)); 2546 2547 begin 2548 if (Is_Record_Type (T) 2549 and then Has_Discriminants (T)) 2550 or else 2551 (Is_Access_Type (T) 2552 and then Is_Record_Type (Designated_Type (T)) 2553 and then Has_Discriminants (Designated_Type (T))) 2554 then 2555 Error_Msg_NE 2556 ("invalid address clause for initialized object &!", 2557 Nod, U_Ent); 2558 Error_Msg_N 2559 ("\address cannot depend on component" & 2560 " of discriminated record ('R'M 13.1(22))!", 2561 Nod); 2562 else 2563 Check_At_Constant_Address (Prefix (Nod)); 2564 end if; 2565 end; 2566 2567 elsif Nkind (Nod) = N_Indexed_Component then 2568 Check_At_Constant_Address (Prefix (Nod)); 2569 Check_List_Constants (Expressions (Nod)); 2570 2571 else 2572 Check_Expr_Constants (Nod); 2573 end if; 2574 end Check_At_Constant_Address; 2575 2576 -------------------------- 2577 -- Check_Expr_Constants -- 2578 -------------------------- 2579 2580 procedure Check_Expr_Constants (Nod : Node_Id) is 2581 Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent); 2582 Ent : Entity_Id := Empty; 2583 2584 begin 2585 if Nkind (Nod) in N_Has_Etype 2586 and then Etype (Nod) = Any_Type 2587 then 2588 return; 2589 end if; 2590 2591 case Nkind (Nod) is 2592 when N_Empty | N_Error => 2593 return; 2594 2595 when N_Identifier | N_Expanded_Name => 2596 Ent := Entity (Nod); 2597 2598 -- We need to look at the original node if it is different 2599 -- from the node, since we may have rewritten things and 2600 -- substituted an identifier representing the rewrite. 2601 2602 if Original_Node (Nod) /= Nod then 2603 Check_Expr_Constants (Original_Node (Nod)); 2604 2605 -- If the node is an object declaration without initial 2606 -- value, some code has been expanded, and the expression 2607 -- is not constant, even if the constituents might be 2608 -- acceptable, as in A'Address + offset. 2609 2610 if Ekind (Ent) = E_Variable 2611 and then Nkind (Declaration_Node (Ent)) 2612 = N_Object_Declaration 2613 and then 2614 No (Expression (Declaration_Node (Ent))) 2615 then 2616 Error_Msg_NE 2617 ("invalid address clause for initialized object &!", 2618 Nod, U_Ent); 2619 2620 -- If entity is constant, it may be the result of expanding 2621 -- a check. We must verify that its declaration appears 2622 -- before the object in question, else we also reject the 2623 -- address clause. 2624 2625 elsif Ekind (Ent) = E_Constant 2626 and then In_Same_Source_Unit (Ent, U_Ent) 2627 and then Sloc (Ent) > Loc_U_Ent 2628 then 2629 Error_Msg_NE 2630 ("invalid address clause for initialized object &!", 2631 Nod, U_Ent); 2632 end if; 2633 2634 return; 2635 end if; 2636 2637 -- Otherwise look at the identifier and see if it is OK. 2638 2639 if Ekind (Ent) = E_Named_Integer 2640 or else 2641 Ekind (Ent) = E_Named_Real 2642 or else 2643 Is_Type (Ent) 2644 then 2645 return; 2646 2647 elsif 2648 Ekind (Ent) = E_Constant 2649 or else 2650 Ekind (Ent) = E_In_Parameter 2651 then 2652 -- This is the case where we must have Ent defined 2653 -- before U_Ent. Clearly if they are in different 2654 -- units this requirement is met since the unit 2655 -- containing Ent is already processed. 2656 2657 if not In_Same_Source_Unit (Ent, U_Ent) then 2658 return; 2659 2660 -- Otherwise location of Ent must be before the 2661 -- location of U_Ent, that's what prior defined means. 2662 2663 elsif Sloc (Ent) < Loc_U_Ent then 2664 return; 2665 2666 else 2667 Error_Msg_NE 2668 ("invalid address clause for initialized object &!", 2669 Nod, U_Ent); 2670 Error_Msg_Name_1 := Chars (Ent); 2671 Error_Msg_Name_2 := Chars (U_Ent); 2672 Error_Msg_N 2673 ("\% must be defined before % ('R'M 13.1(22))!", 2674 Nod); 2675 end if; 2676 2677 elsif Nkind (Original_Node (Nod)) = N_Function_Call then 2678 Check_Expr_Constants (Original_Node (Nod)); 2679 2680 else 2681 Error_Msg_NE 2682 ("invalid address clause for initialized object &!", 2683 Nod, U_Ent); 2684 2685 if Comes_From_Source (Ent) then 2686 Error_Msg_Name_1 := Chars (Ent); 2687 Error_Msg_N 2688 ("\reference to variable% not allowed" 2689 & " ('R'M 13.1(22))!", Nod); 2690 else 2691 Error_Msg_N 2692 ("non-static expression not allowed" 2693 & " ('R'M 13.1(22))!", Nod); 2694 end if; 2695 end if; 2696 2697 when N_Integer_Literal | 2698 N_Real_Literal | 2699 N_String_Literal | 2700 N_Character_Literal => 2701 return; 2702 2703 when N_Range => 2704 Check_Expr_Constants (Low_Bound (Nod)); 2705 Check_Expr_Constants (High_Bound (Nod)); 2706 2707 when N_Explicit_Dereference => 2708 Check_Expr_Constants (Prefix (Nod)); 2709 2710 when N_Indexed_Component => 2711 Check_Expr_Constants (Prefix (Nod)); 2712 Check_List_Constants (Expressions (Nod)); 2713 2714 when N_Slice => 2715 Check_Expr_Constants (Prefix (Nod)); 2716 Check_Expr_Constants (Discrete_Range (Nod)); 2717 2718 when N_Selected_Component => 2719 Check_Expr_Constants (Prefix (Nod)); 2720 2721 when N_Attribute_Reference => 2722 2723 if Attribute_Name (Nod) = Name_Address 2724 or else 2725 Attribute_Name (Nod) = Name_Access 2726 or else 2727 Attribute_Name (Nod) = Name_Unchecked_Access 2728 or else 2729 Attribute_Name (Nod) = Name_Unrestricted_Access 2730 then 2731 Check_At_Constant_Address (Prefix (Nod)); 2732 2733 else 2734 Check_Expr_Constants (Prefix (Nod)); 2735 Check_List_Constants (Expressions (Nod)); 2736 end if; 2737 2738 when N_Aggregate => 2739 Check_List_Constants (Component_Associations (Nod)); 2740 Check_List_Constants (Expressions (Nod)); 2741 2742 when N_Component_Association => 2743 Check_Expr_Constants (Expression (Nod)); 2744 2745 when N_Extension_Aggregate => 2746 Check_Expr_Constants (Ancestor_Part (Nod)); 2747 Check_List_Constants (Component_Associations (Nod)); 2748 Check_List_Constants (Expressions (Nod)); 2749 2750 when N_Null => 2751 return; 2752 2753 when N_Binary_Op | N_And_Then | N_Or_Else | N_In | N_Not_In => 2754 Check_Expr_Constants (Left_Opnd (Nod)); 2755 Check_Expr_Constants (Right_Opnd (Nod)); 2756 2757 when N_Unary_Op => 2758 Check_Expr_Constants (Right_Opnd (Nod)); 2759 2760 when N_Type_Conversion | 2761 N_Qualified_Expression | 2762 N_Allocator => 2763 Check_Expr_Constants (Expression (Nod)); 2764 2765 when N_Unchecked_Type_Conversion => 2766 Check_Expr_Constants (Expression (Nod)); 2767 2768 -- If this is a rewritten unchecked conversion, subtypes 2769 -- in this node are those created within the instance. 2770 -- To avoid order of elaboration issues, replace them 2771 -- with their base types. Note that address clauses can 2772 -- cause order of elaboration problems because they are 2773 -- elaborated by the back-end at the point of definition, 2774 -- and may mention entities declared in between (as long 2775 -- as everything is static). It is user-friendly to allow 2776 -- unchecked conversions in this context. 2777 2778 if Nkind (Original_Node (Nod)) = N_Function_Call then 2779 Set_Etype (Expression (Nod), 2780 Base_Type (Etype (Expression (Nod)))); 2781 Set_Etype (Nod, Base_Type (Etype (Nod))); 2782 end if; 2783 2784 when N_Function_Call => 2785 if not Is_Pure (Entity (Name (Nod))) then 2786 Error_Msg_NE 2787 ("invalid address clause for initialized object &!", 2788 Nod, U_Ent); 2789 2790 Error_Msg_NE 2791 ("\function & is not pure ('R'M 13.1(22))!", 2792 Nod, Entity (Name (Nod))); 2793 2794 else 2795 Check_List_Constants (Parameter_Associations (Nod)); 2796 end if; 2797 2798 when N_Parameter_Association => 2799 Check_Expr_Constants (Explicit_Actual_Parameter (Nod)); 2800 2801 when others => 2802 Error_Msg_NE 2803 ("invalid address clause for initialized object &!", 2804 Nod, U_Ent); 2805 Error_Msg_NE 2806 ("\must be constant defined before& ('R'M 13.1(22))!", 2807 Nod, U_Ent); 2808 end case; 2809 end Check_Expr_Constants; 2810 2811 -------------------------- 2812 -- Check_List_Constants -- 2813 -------------------------- 2814 2815 procedure Check_List_Constants (Lst : List_Id) is 2816 Nod1 : Node_Id; 2817 2818 begin 2819 if Present (Lst) then 2820 Nod1 := First (Lst); 2821 while Present (Nod1) loop 2822 Check_Expr_Constants (Nod1); 2823 Next (Nod1); 2824 end loop; 2825 end if; 2826 end Check_List_Constants; 2827 2828 -- Start of processing for Check_Constant_Address_Clause 2829 2830 begin 2831 Check_Expr_Constants (Expr); 2832 end Check_Constant_Address_Clause; 2833 2834 ---------------- 2835 -- Check_Size -- 2836 ---------------- 2837 2838 procedure Check_Size 2839 (N : Node_Id; 2840 T : Entity_Id; 2841 Siz : Uint; 2842 Biased : out Boolean) 2843 is 2844 UT : constant Entity_Id := Underlying_Type (T); 2845 M : Uint; 2846 2847 begin 2848 Biased := False; 2849 2850 -- Dismiss cases for generic types or types with previous errors 2851 2852 if No (UT) 2853 or else UT = Any_Type 2854 or else Is_Generic_Type (UT) 2855 or else Is_Generic_Type (Root_Type (UT)) 2856 then 2857 return; 2858 2859 -- Check case of bit packed array 2860 2861 elsif Is_Array_Type (UT) 2862 and then Known_Static_Component_Size (UT) 2863 and then Is_Bit_Packed_Array (UT) 2864 then 2865 declare 2866 Asiz : Uint; 2867 Indx : Node_Id; 2868 Ityp : Entity_Id; 2869 2870 begin 2871 Asiz := Component_Size (UT); 2872 Indx := First_Index (UT); 2873 loop 2874 Ityp := Etype (Indx); 2875 2876 -- If non-static bound, then we are not in the business of 2877 -- trying to check the length, and indeed an error will be 2878 -- issued elsewhere, since sizes of non-static array types 2879 -- cannot be set implicitly or explicitly. 2880 2881 if not Is_Static_Subtype (Ityp) then 2882 return; 2883 end if; 2884 2885 -- Otherwise accumulate next dimension 2886 2887 Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) - 2888 Expr_Value (Type_Low_Bound (Ityp)) + 2889 Uint_1); 2890 2891 Next_Index (Indx); 2892 exit when No (Indx); 2893 end loop; 2894 2895 if Asiz <= Siz then 2896 return; 2897 else 2898 Error_Msg_Uint_1 := Asiz; 2899 Error_Msg_NE 2900 ("size for& too small, minimum allowed is ^", N, T); 2901 Set_Esize (T, Asiz); 2902 Set_RM_Size (T, Asiz); 2903 end if; 2904 end; 2905 2906 -- All other composite types are ignored 2907 2908 elsif Is_Composite_Type (UT) then 2909 return; 2910 2911 -- For fixed-point types, don't check minimum if type is not frozen, 2912 -- since we don't know all the characteristics of the type that can 2913 -- affect the size (e.g. a specified small) till freeze time. 2914 2915 elsif Is_Fixed_Point_Type (UT) 2916 and then not Is_Frozen (UT) 2917 then 2918 null; 2919 2920 -- Cases for which a minimum check is required 2921 2922 else 2923 -- Ignore if specified size is correct for the type 2924 2925 if Known_Esize (UT) and then Siz = Esize (UT) then 2926 return; 2927 end if; 2928 2929 -- Otherwise get minimum size 2930 2931 M := UI_From_Int (Minimum_Size (UT)); 2932 2933 if Siz < M then 2934 2935 -- Size is less than minimum size, but one possibility remains 2936 -- that we can manage with the new size if we bias the type 2937 2938 M := UI_From_Int (Minimum_Size (UT, Biased => True)); 2939 2940 if Siz < M then 2941 Error_Msg_Uint_1 := M; 2942 Error_Msg_NE 2943 ("size for& too small, minimum allowed is ^", N, T); 2944 Set_Esize (T, M); 2945 Set_RM_Size (T, M); 2946 else 2947 Biased := True; 2948 end if; 2949 end if; 2950 end if; 2951 end Check_Size; 2952 2953 ------------------------- 2954 -- Get_Alignment_Value -- 2955 ------------------------- 2956 2957 function Get_Alignment_Value (Expr : Node_Id) return Uint is 2958 Align : constant Uint := Static_Integer (Expr); 2959 2960 begin 2961 if Align = No_Uint then 2962 return No_Uint; 2963 2964 elsif Align <= 0 then 2965 Error_Msg_N ("alignment value must be positive", Expr); 2966 return No_Uint; 2967 2968 else 2969 for J in Int range 0 .. 64 loop 2970 declare 2971 M : constant Uint := Uint_2 ** J; 2972 2973 begin 2974 exit when M = Align; 2975 2976 if M > Align then 2977 Error_Msg_N 2978 ("alignment value must be power of 2", Expr); 2979 return No_Uint; 2980 end if; 2981 end; 2982 end loop; 2983 2984 return Align; 2985 end if; 2986 end Get_Alignment_Value; 2987 2988 ---------------- 2989 -- Initialize -- 2990 ---------------- 2991 2992 procedure Initialize is 2993 begin 2994 Unchecked_Conversions.Init; 2995 end Initialize; 2996 2997 ------------------------- 2998 -- Is_Operational_Item -- 2999 ------------------------- 3000 3001 function Is_Operational_Item (N : Node_Id) return Boolean is 3002 begin 3003 if Nkind (N) /= N_Attribute_Definition_Clause then 3004 return False; 3005 else 3006 declare 3007 Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); 3008 3009 begin 3010 return Id = Attribute_Input 3011 or else Id = Attribute_Output 3012 or else Id = Attribute_Read 3013 or else Id = Attribute_Write 3014 or else Id = Attribute_External_Tag; 3015 end; 3016 end if; 3017 end Is_Operational_Item; 3018 3019 -------------------------------------- 3020 -- Mark_Aliased_Address_As_Volatile -- 3021 -------------------------------------- 3022 3023 procedure Mark_Aliased_Address_As_Volatile (N : Node_Id) is 3024 Ent : constant Entity_Id := Address_Aliased_Entity (N); 3025 3026 begin 3027 if Present (Ent) then 3028 Set_Treat_As_Volatile (Ent); 3029 end if; 3030 end Mark_Aliased_Address_As_Volatile; 3031 3032 ------------------ 3033 -- Minimum_Size -- 3034 ------------------ 3035 3036 function Minimum_Size 3037 (T : Entity_Id; 3038 Biased : Boolean := False) 3039 return Nat 3040 is 3041 Lo : Uint := No_Uint; 3042 Hi : Uint := No_Uint; 3043 LoR : Ureal := No_Ureal; 3044 HiR : Ureal := No_Ureal; 3045 LoSet : Boolean := False; 3046 HiSet : Boolean := False; 3047 B : Uint; 3048 S : Nat; 3049 Ancest : Entity_Id; 3050 R_Typ : constant Entity_Id := Root_Type (T); 3051 3052 begin 3053 -- If bad type, return 0 3054 3055 if T = Any_Type then 3056 return 0; 3057 3058 -- For generic types, just return zero. There cannot be any legitimate 3059 -- need to know such a size, but this routine may be called with a 3060 -- generic type as part of normal processing. 3061 3062 elsif Is_Generic_Type (R_Typ) 3063 or else R_Typ = Any_Type 3064 then 3065 return 0; 3066 3067 -- Access types 3068 3069 elsif Is_Access_Type (T) then 3070 return System_Address_Size; 3071 3072 -- Floating-point types 3073 3074 elsif Is_Floating_Point_Type (T) then 3075 return UI_To_Int (Esize (R_Typ)); 3076 3077 -- Discrete types 3078 3079 elsif Is_Discrete_Type (T) then 3080 3081 -- The following loop is looking for the nearest compile time 3082 -- known bounds following the ancestor subtype chain. The idea 3083 -- is to find the most restrictive known bounds information. 3084 3085 Ancest := T; 3086 loop 3087 if Ancest = Any_Type or else Etype (Ancest) = Any_Type then 3088 return 0; 3089 end if; 3090 3091 if not LoSet then 3092 if Compile_Time_Known_Value (Type_Low_Bound (Ancest)) then 3093 Lo := Expr_Rep_Value (Type_Low_Bound (Ancest)); 3094 LoSet := True; 3095 exit when HiSet; 3096 end if; 3097 end if; 3098 3099 if not HiSet then 3100 if Compile_Time_Known_Value (Type_High_Bound (Ancest)) then 3101 Hi := Expr_Rep_Value (Type_High_Bound (Ancest)); 3102 HiSet := True; 3103 exit when LoSet; 3104 end if; 3105 end if; 3106 3107 Ancest := Ancestor_Subtype (Ancest); 3108 3109 if No (Ancest) then 3110 Ancest := Base_Type (T); 3111 3112 if Is_Generic_Type (Ancest) then 3113 return 0; 3114 end if; 3115 end if; 3116 end loop; 3117 3118 -- Fixed-point types. We can't simply use Expr_Value to get the 3119 -- Corresponding_Integer_Value values of the bounds, since these 3120 -- do not get set till the type is frozen, and this routine can 3121 -- be called before the type is frozen. Similarly the test for 3122 -- bounds being static needs to include the case where we have 3123 -- unanalyzed real literals for the same reason. 3124 3125 elsif Is_Fixed_Point_Type (T) then 3126 3127 -- The following loop is looking for the nearest compile time 3128 -- known bounds following the ancestor subtype chain. The idea 3129 -- is to find the most restrictive known bounds information. 3130 3131 Ancest := T; 3132 loop 3133 if Ancest = Any_Type or else Etype (Ancest) = Any_Type then 3134 return 0; 3135 end if; 3136 3137 if not LoSet then 3138 if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal 3139 or else Compile_Time_Known_Value (Type_Low_Bound (Ancest)) 3140 then 3141 LoR := Expr_Value_R (Type_Low_Bound (Ancest)); 3142 LoSet := True; 3143 exit when HiSet; 3144 end if; 3145 end if; 3146 3147 if not HiSet then 3148 if Nkind (Type_High_Bound (Ancest)) = N_Real_Literal 3149 or else Compile_Time_Known_Value (Type_High_Bound (Ancest)) 3150 then 3151 HiR := Expr_Value_R (Type_High_Bound (Ancest)); 3152 HiSet := True; 3153 exit when LoSet; 3154 end if; 3155 end if; 3156 3157 Ancest := Ancestor_Subtype (Ancest); 3158 3159 if No (Ancest) then 3160 Ancest := Base_Type (T); 3161 3162 if Is_Generic_Type (Ancest) then 3163 return 0; 3164 end if; 3165 end if; 3166 end loop; 3167 3168 Lo := UR_To_Uint (LoR / Small_Value (T)); 3169 Hi := UR_To_Uint (HiR / Small_Value (T)); 3170 3171 -- No other types allowed 3172 3173 else 3174 raise Program_Error; 3175 end if; 3176 3177 -- Fall through with Hi and Lo set. Deal with biased case. 3178 3179 if (Biased and then not Is_Fixed_Point_Type (T)) 3180 or else Has_Biased_Representation (T) 3181 then 3182 Hi := Hi - Lo; 3183 Lo := Uint_0; 3184 end if; 3185 3186 -- Signed case. Note that we consider types like range 1 .. -1 to be 3187 -- signed for the purpose of computing the size, since the bounds 3188 -- have to be accomodated in the base type. 3189 3190 if Lo < 0 or else Hi < 0 then 3191 S := 1; 3192 B := Uint_1; 3193 3194 -- S = size, B = 2 ** (size - 1) (can accommodate -B .. +(B - 1)) 3195 -- Note that we accommodate the case where the bounds cross. This 3196 -- can happen either because of the way the bounds are declared 3197 -- or because of the algorithm in Freeze_Fixed_Point_Type. 3198 3199 while Lo < -B 3200 or else Hi < -B 3201 or else Lo >= B 3202 or else Hi >= B 3203 loop 3204 B := Uint_2 ** S; 3205 S := S + 1; 3206 end loop; 3207 3208 -- Unsigned case 3209 3210 else 3211 -- If both bounds are positive, make sure that both are represen- 3212 -- table in the case where the bounds are crossed. This can happen 3213 -- either because of the way the bounds are declared, or because of 3214 -- the algorithm in Freeze_Fixed_Point_Type. 3215 3216 if Lo > Hi then 3217 Hi := Lo; 3218 end if; 3219 3220 -- S = size, (can accommodate 0 .. (2**size - 1)) 3221 3222 S := 0; 3223 while Hi >= Uint_2 ** S loop 3224 S := S + 1; 3225 end loop; 3226 end if; 3227 3228 return S; 3229 end Minimum_Size; 3230 3231 ------------------------- 3232 -- New_Stream_Function -- 3233 ------------------------- 3234 3235 procedure New_Stream_Function 3236 (N : Node_Id; 3237 Ent : Entity_Id; 3238 Subp : Entity_Id; 3239 Nam : TSS_Name_Type) 3240 is 3241 Loc : constant Source_Ptr := Sloc (N); 3242 Sname : constant Name_Id := Make_TSS_Name (Base_Type (Ent), Nam); 3243 Subp_Id : Entity_Id; 3244 Subp_Decl : Node_Id; 3245 F : Entity_Id; 3246 Etyp : Entity_Id; 3247 3248 function Build_Spec return Node_Id; 3249 -- Used for declaration and renaming declaration, so that this is 3250 -- treated as a renaming_as_body. 3251 3252 ---------------- 3253 -- Build_Spec -- 3254 ---------------- 3255 3256 function Build_Spec return Node_Id is 3257 begin 3258 Subp_Id := Make_Defining_Identifier (Loc, Sname); 3259 3260 return 3261 Make_Function_Specification (Loc, 3262 Defining_Unit_Name => Subp_Id, 3263 Parameter_Specifications => 3264 New_List ( 3265 Make_Parameter_Specification (Loc, 3266 Defining_Identifier => 3267 Make_Defining_Identifier (Loc, Name_S), 3268 Parameter_Type => 3269 Make_Access_Definition (Loc, 3270 Subtype_Mark => 3271 New_Reference_To ( 3272 Designated_Type (Etype (F)), Loc)))), 3273 3274 Subtype_Mark => 3275 New_Reference_To (Etyp, Loc)); 3276 end Build_Spec; 3277 3278 -- Start of processing for New_Stream_Function 3279 3280 begin 3281 F := First_Formal (Subp); 3282 Etyp := Etype (Subp); 3283 3284 if not Is_Tagged_Type (Ent) then 3285 Subp_Decl := 3286 Make_Subprogram_Declaration (Loc, 3287 Specification => Build_Spec); 3288 Insert_Action (N, Subp_Decl); 3289 end if; 3290 3291 Subp_Decl := 3292 Make_Subprogram_Renaming_Declaration (Loc, 3293 Specification => Build_Spec, 3294 Name => New_Reference_To (Subp, Loc)); 3295 3296 if Is_Tagged_Type (Ent) and then not Is_Limited_Type (Ent) then 3297 Set_TSS (Base_Type (Ent), Subp_Id); 3298 else 3299 Insert_Action (N, Subp_Decl); 3300 Copy_TSS (Subp_Id, Base_Type (Ent)); 3301 end if; 3302 end New_Stream_Function; 3303 3304 -------------------------- 3305 -- New_Stream_Procedure -- 3306 -------------------------- 3307 3308 procedure New_Stream_Procedure 3309 (N : Node_Id; 3310 Ent : Entity_Id; 3311 Subp : Entity_Id; 3312 Nam : TSS_Name_Type; 3313 Out_P : Boolean := False) 3314 is 3315 Loc : constant Source_Ptr := Sloc (N); 3316 Sname : constant Name_Id := Make_TSS_Name (Base_Type (Ent), Nam); 3317 Subp_Id : Entity_Id; 3318 Subp_Decl : Node_Id; 3319 F : Entity_Id; 3320 Etyp : Entity_Id; 3321 3322 function Build_Spec return Node_Id; 3323 -- Used for declaration and renaming declaration, so that this is 3324 -- treated as a renaming_as_body. 3325 3326 ---------------- 3327 -- Build_Spec -- 3328 ---------------- 3329 3330 function Build_Spec return Node_Id is 3331 begin 3332 Subp_Id := Make_Defining_Identifier (Loc, Sname); 3333 3334 return 3335 Make_Procedure_Specification (Loc, 3336 Defining_Unit_Name => Subp_Id, 3337 Parameter_Specifications => 3338 New_List ( 3339 Make_Parameter_Specification (Loc, 3340 Defining_Identifier => 3341 Make_Defining_Identifier (Loc, Name_S), 3342 Parameter_Type => 3343 Make_Access_Definition (Loc, 3344 Subtype_Mark => 3345 New_Reference_To ( 3346 Designated_Type (Etype (F)), Loc))), 3347 3348 Make_Parameter_Specification (Loc, 3349 Defining_Identifier => 3350 Make_Defining_Identifier (Loc, Name_V), 3351 Out_Present => Out_P, 3352 Parameter_Type => 3353 New_Reference_To (Etyp, Loc)))); 3354 end Build_Spec; 3355 3356 -- Start of processing for New_Stream_Procedure 3357 3358 begin 3359 F := First_Formal (Subp); 3360 Etyp := Etype (Next_Formal (F)); 3361 3362 if not Is_Tagged_Type (Ent) then 3363 Subp_Decl := 3364 Make_Subprogram_Declaration (Loc, 3365 Specification => Build_Spec); 3366 Insert_Action (N, Subp_Decl); 3367 end if; 3368 3369 Subp_Decl := 3370 Make_Subprogram_Renaming_Declaration (Loc, 3371 Specification => Build_Spec, 3372 Name => New_Reference_To (Subp, Loc)); 3373 3374 if Is_Tagged_Type (Ent) and then not Is_Limited_Type (Ent) then 3375 Set_TSS (Base_Type (Ent), Subp_Id); 3376 else 3377 Insert_Action (N, Subp_Decl); 3378 Copy_TSS (Subp_Id, Base_Type (Ent)); 3379 end if; 3380 end New_Stream_Procedure; 3381 3382 --------------------- 3383 -- Record_Rep_Item -- 3384 --------------------- 3385 3386 procedure Record_Rep_Item (T : Entity_Id; N : Node_Id) is 3387 begin 3388 Set_Next_Rep_Item (N, First_Rep_Item (T)); 3389 Set_First_Rep_Item (T, N); 3390 end Record_Rep_Item; 3391 3392 ------------------------ 3393 -- Rep_Item_Too_Early -- 3394 ------------------------ 3395 3396 function Rep_Item_Too_Early 3397 (T : Entity_Id; 3398 N : Node_Id) 3399 return Boolean 3400 is 3401 begin 3402 -- Cannot apply rep items that are not operational items 3403 -- to generic types 3404 3405 if Is_Operational_Item (N) then 3406 return False; 3407 3408 elsif Is_Type (T) 3409 and then Is_Generic_Type (Root_Type (T)) 3410 then 3411 Error_Msg_N 3412 ("representation item not allowed for generic type", N); 3413 return True; 3414 end if; 3415 3416 -- Otherwise check for incompleted type 3417 3418 if Is_Incomplete_Or_Private_Type (T) 3419 and then No (Underlying_Type (T)) 3420 then 3421 Error_Msg_N 3422 ("representation item must be after full type declaration", N); 3423 return True; 3424 3425 -- If the type has incompleted components, a representation clause is 3426 -- illegal but stream attributes and Convention pragmas are correct. 3427 3428 elsif Has_Private_Component (T) then 3429 if Nkind (N) = N_Pragma then 3430 return False; 3431 else 3432 Error_Msg_N 3433 ("representation item must appear after type is fully defined", 3434 N); 3435 return True; 3436 end if; 3437 else 3438 return False; 3439 end if; 3440 end Rep_Item_Too_Early; 3441 3442 ----------------------- 3443 -- Rep_Item_Too_Late -- 3444 ----------------------- 3445 3446 function Rep_Item_Too_Late 3447 (T : Entity_Id; 3448 N : Node_Id; 3449 FOnly : Boolean := False) 3450 return Boolean 3451 is 3452 S : Entity_Id; 3453 Parent_Type : Entity_Id; 3454 3455 procedure Too_Late; 3456 -- Output the too late message 3457 3458 procedure Too_Late is 3459 begin 3460 Error_Msg_N ("representation item appears too late!", N); 3461 end Too_Late; 3462 3463 -- Start of processing for Rep_Item_Too_Late 3464 3465 begin 3466 -- First make sure entity is not frozen (RM 13.1(9)). Exclude imported 3467 -- types, which may be frozen if they appear in a representation clause 3468 -- for a local type. 3469 3470 if Is_Frozen (T) 3471 and then not From_With_Type (T) 3472 then 3473 Too_Late; 3474 S := First_Subtype (T); 3475 3476 if Present (Freeze_Node (S)) then 3477 Error_Msg_NE 3478 ("?no more representation items for }!", Freeze_Node (S), S); 3479 end if; 3480 3481 return True; 3482 3483 -- Check for case of non-tagged derived type whose parent either has 3484 -- primitive operations, or is a by reference type (RM 13.1(10)). 3485 3486 elsif Is_Type (T) 3487 and then not FOnly 3488 and then Is_Derived_Type (T) 3489 and then not Is_Tagged_Type (T) 3490 then 3491 Parent_Type := Etype (Base_Type (T)); 3492 3493 if Has_Primitive_Operations (Parent_Type) then 3494 Too_Late; 3495 Error_Msg_NE 3496 ("primitive operations already defined for&!", N, Parent_Type); 3497 return True; 3498 3499 elsif Is_By_Reference_Type (Parent_Type) then 3500 Too_Late; 3501 Error_Msg_NE 3502 ("parent type & is a by reference type!", N, Parent_Type); 3503 return True; 3504 end if; 3505 end if; 3506 3507 -- No error, link item into head of chain of rep items for the entity 3508 3509 Record_Rep_Item (T, N); 3510 return False; 3511 end Rep_Item_Too_Late; 3512 3513 ------------------------- 3514 -- Same_Representation -- 3515 ------------------------- 3516 3517 function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is 3518 T1 : constant Entity_Id := Underlying_Type (Typ1); 3519 T2 : constant Entity_Id := Underlying_Type (Typ2); 3520 3521 begin 3522 -- A quick check, if base types are the same, then we definitely have 3523 -- the same representation, because the subtype specific representation 3524 -- attributes (Size and Alignment) do not affect representation from 3525 -- the point of view of this test. 3526 3527 if Base_Type (T1) = Base_Type (T2) then 3528 return True; 3529 3530 elsif Is_Private_Type (Base_Type (T2)) 3531 and then Base_Type (T1) = Full_View (Base_Type (T2)) 3532 then 3533 return True; 3534 end if; 3535 3536 -- Tagged types never have differing representations 3537 3538 if Is_Tagged_Type (T1) then 3539 return True; 3540 end if; 3541 3542 -- Representations are definitely different if conventions differ 3543 3544 if Convention (T1) /= Convention (T2) then 3545 return False; 3546 end if; 3547 3548 -- Representations are different if component alignments differ 3549 3550 if (Is_Record_Type (T1) or else Is_Array_Type (T1)) 3551 and then 3552 (Is_Record_Type (T2) or else Is_Array_Type (T2)) 3553 and then Component_Alignment (T1) /= Component_Alignment (T2) 3554 then 3555 return False; 3556 end if; 3557 3558 -- For arrays, the only real issue is component size. If we know the 3559 -- component size for both arrays, and it is the same, then that's 3560 -- good enough to know we don't have a change of representation. 3561 3562 if Is_Array_Type (T1) then 3563 if Known_Component_Size (T1) 3564 and then Known_Component_Size (T2) 3565 and then Component_Size (T1) = Component_Size (T2) 3566 then 3567 return True; 3568 end if; 3569 end if; 3570 3571 -- Types definitely have same representation if neither has non-standard 3572 -- representation since default representations are always consistent. 3573 -- If only one has non-standard representation, and the other does not, 3574 -- then we consider that they do not have the same representation. They 3575 -- might, but there is no way of telling early enough. 3576 3577 if Has_Non_Standard_Rep (T1) then 3578 if not Has_Non_Standard_Rep (T2) then 3579 return False; 3580 end if; 3581 else 3582 return not Has_Non_Standard_Rep (T2); 3583 end if; 3584 3585 -- Here the two types both have non-standard representation, and we 3586 -- need to determine if they have the same non-standard representation 3587 3588 -- For arrays, we simply need to test if the component sizes are the 3589 -- same. Pragma Pack is reflected in modified component sizes, so this 3590 -- check also deals with pragma Pack. 3591 3592 if Is_Array_Type (T1) then 3593 return Component_Size (T1) = Component_Size (T2); 3594 3595 -- Tagged types always have the same representation, because it is not 3596 -- possible to specify different representations for common fields. 3597 3598 elsif Is_Tagged_Type (T1) then 3599 return True; 3600 3601 -- Case of record types 3602 3603 elsif Is_Record_Type (T1) then 3604 3605 -- Packed status must conform 3606 3607 if Is_Packed (T1) /= Is_Packed (T2) then 3608 return False; 3609 3610 -- Otherwise we must check components. Typ2 maybe a constrained 3611 -- subtype with fewer components, so we compare the components 3612 -- of the base types. 3613 3614 else 3615 Record_Case : declare 3616 CD1, CD2 : Entity_Id; 3617 3618 function Same_Rep return Boolean; 3619 -- CD1 and CD2 are either components or discriminants. This 3620 -- function tests whether the two have the same representation 3621 3622 function Same_Rep return Boolean is 3623 begin 3624 if No (Component_Clause (CD1)) then 3625 return No (Component_Clause (CD2)); 3626 3627 else 3628 return 3629 Present (Component_Clause (CD2)) 3630 and then 3631 Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2) 3632 and then 3633 Esize (CD1) = Esize (CD2); 3634 end if; 3635 end Same_Rep; 3636 3637 -- Start processing for Record_Case 3638 3639 begin 3640 if Has_Discriminants (T1) then 3641 CD1 := First_Discriminant (T1); 3642 CD2 := First_Discriminant (T2); 3643 3644 -- The number of discriminants may be different if the 3645 -- derived type has fewer (constrained by values). The 3646 -- invisible discriminants retain the representation of 3647 -- the original, so the discrepancy does not per se 3648 -- indicate a different representation. 3649 3650 while Present (CD1) 3651 and then Present (CD2) 3652 loop 3653 if not Same_Rep then 3654 return False; 3655 else 3656 Next_Discriminant (CD1); 3657 Next_Discriminant (CD2); 3658 end if; 3659 end loop; 3660 end if; 3661 3662 CD1 := First_Component (Underlying_Type (Base_Type (T1))); 3663 CD2 := First_Component (Underlying_Type (Base_Type (T2))); 3664 3665 while Present (CD1) loop 3666 if not Same_Rep then 3667 return False; 3668 else 3669 Next_Component (CD1); 3670 Next_Component (CD2); 3671 end if; 3672 end loop; 3673 3674 return True; 3675 end Record_Case; 3676 end if; 3677 3678 -- For enumeration types, we must check each literal to see if the 3679 -- representation is the same. Note that we do not permit enumeration 3680 -- reprsentation clauses for Character and Wide_Character, so these 3681 -- cases were already dealt with. 3682 3683 elsif Is_Enumeration_Type (T1) then 3684 3685 Enumeration_Case : declare 3686 L1, L2 : Entity_Id; 3687 3688 begin 3689 L1 := First_Literal (T1); 3690 L2 := First_Literal (T2); 3691 3692 while Present (L1) loop 3693 if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then 3694 return False; 3695 else 3696 Next_Literal (L1); 3697 Next_Literal (L2); 3698 end if; 3699 end loop; 3700 3701 return True; 3702 3703 end Enumeration_Case; 3704 3705 -- Any other types have the same representation for these purposes 3706 3707 else 3708 return True; 3709 end if; 3710 end Same_Representation; 3711 3712 -------------------- 3713 -- Set_Enum_Esize -- 3714 -------------------- 3715 3716 procedure Set_Enum_Esize (T : Entity_Id) is 3717 Lo : Uint; 3718 Hi : Uint; 3719 Sz : Nat; 3720 3721 begin 3722 Init_Alignment (T); 3723 3724 -- Find the minimum standard size (8,16,32,64) that fits 3725 3726 Lo := Enumeration_Rep (Entity (Type_Low_Bound (T))); 3727 Hi := Enumeration_Rep (Entity (Type_High_Bound (T))); 3728 3729 if Lo < 0 then 3730 if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then 3731 Sz := Standard_Character_Size; -- May be > 8 on some targets 3732 3733 elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then 3734 Sz := 16; 3735 3736 elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then 3737 Sz := 32; 3738 3739 else pragma Assert (Lo >= -Uint_2**63 and then Hi < Uint_2**63); 3740 Sz := 64; 3741 end if; 3742 3743 else 3744 if Hi < Uint_2**08 then 3745 Sz := Standard_Character_Size; -- May be > 8 on some targets 3746 3747 elsif Hi < Uint_2**16 then 3748 Sz := 16; 3749 3750 elsif Hi < Uint_2**32 then 3751 Sz := 32; 3752 3753 else pragma Assert (Hi < Uint_2**63); 3754 Sz := 64; 3755 end if; 3756 end if; 3757 3758 -- That minimum is the proper size unless we have a foreign convention 3759 -- and the size required is 32 or less, in which case we bump the size 3760 -- up to 32. This is required for C and C++ and seems reasonable for 3761 -- all other foreign conventions. 3762 3763 if Has_Foreign_Convention (T) 3764 and then Esize (T) < Standard_Integer_Size 3765 then 3766 Init_Esize (T, Standard_Integer_Size); 3767 3768 else 3769 Init_Esize (T, Sz); 3770 end if; 3771 end Set_Enum_Esize; 3772 3773 ----------------------------------- 3774 -- Validate_Unchecked_Conversion -- 3775 ----------------------------------- 3776 3777 procedure Validate_Unchecked_Conversion 3778 (N : Node_Id; 3779 Act_Unit : Entity_Id) 3780 is 3781 Source : Entity_Id; 3782 Target : Entity_Id; 3783 Vnode : Node_Id; 3784 3785 begin 3786 -- Obtain source and target types. Note that we call Ancestor_Subtype 3787 -- here because the processing for generic instantiation always makes 3788 -- subtypes, and we want the original frozen actual types. 3789 3790 -- If we are dealing with private types, then do the check on their 3791 -- fully declared counterparts if the full declarations have been 3792 -- encountered (they don't have to be visible, but they must exist!) 3793 3794 Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit))); 3795 3796 if Is_Private_Type (Source) 3797 and then Present (Underlying_Type (Source)) 3798 then 3799 Source := Underlying_Type (Source); 3800 end if; 3801 3802 Target := Ancestor_Subtype (Etype (Act_Unit)); 3803 3804 -- If either type is generic, the instantiation happens within a 3805 -- generic unit, and there is nothing to check. The proper check 3806 -- will happen when the enclosing generic is instantiated. 3807 3808 if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then 3809 return; 3810 end if; 3811 3812 if Is_Private_Type (Target) 3813 and then Present (Underlying_Type (Target)) 3814 then 3815 Target := Underlying_Type (Target); 3816 end if; 3817 3818 -- Source may be unconstrained array, but not target 3819 3820 if Is_Array_Type (Target) 3821 and then not Is_Constrained (Target) 3822 then 3823 Error_Msg_N 3824 ("unchecked conversion to unconstrained array not allowed", N); 3825 return; 3826 end if; 3827 3828 -- Make entry in unchecked conversion table for later processing 3829 -- by Validate_Unchecked_Conversions, which will check sizes and 3830 -- alignments (using values set by the back-end where possible). 3831 -- This is only done if the appropriate warning is active 3832 3833 if Warn_On_Unchecked_Conversion then 3834 Unchecked_Conversions.Append 3835 (New_Val => UC_Entry' 3836 (Enode => N, 3837 Source => Source, 3838 Target => Target)); 3839 3840 -- If both sizes are known statically now, then back end annotation 3841 -- is not required to do a proper check but if either size is not 3842 -- known statically, then we need the annotation. 3843 3844 if Known_Static_RM_Size (Source) 3845 and then Known_Static_RM_Size (Target) 3846 then 3847 null; 3848 else 3849 Back_Annotate_Rep_Info := True; 3850 end if; 3851 end if; 3852 3853 -- Generate N_Validate_Unchecked_Conversion node for back end if 3854 -- the back end needs to perform special validation checks. At the 3855 -- current time, only the JVM version requires such checks. 3856 3857 if Java_VM then 3858 Vnode := 3859 Make_Validate_Unchecked_Conversion (Sloc (N)); 3860 Set_Source_Type (Vnode, Source); 3861 Set_Target_Type (Vnode, Target); 3862 Insert_After (N, Vnode); 3863 end if; 3864 end Validate_Unchecked_Conversion; 3865 3866 ------------------------------------ 3867 -- Validate_Unchecked_Conversions -- 3868 ------------------------------------ 3869 3870 procedure Validate_Unchecked_Conversions is 3871 begin 3872 for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop 3873 declare 3874 T : UC_Entry renames Unchecked_Conversions.Table (N); 3875 3876 Enode : constant Node_Id := T.Enode; 3877 Source : constant Entity_Id := T.Source; 3878 Target : constant Entity_Id := T.Target; 3879 3880 Source_Siz : Uint; 3881 Target_Siz : Uint; 3882 3883 begin 3884 -- This validation check, which warns if we have unequal sizes 3885 -- for unchecked conversion, and thus potentially implementation 3886 -- dependent semantics, is one of the few occasions on which we 3887 -- use the official RM size instead of Esize. See description 3888 -- in Einfo "Handling of Type'Size Values" for details. 3889 3890 if Serious_Errors_Detected = 0 3891 and then Known_Static_RM_Size (Source) 3892 and then Known_Static_RM_Size (Target) 3893 then 3894 Source_Siz := RM_Size (Source); 3895 Target_Siz := RM_Size (Target); 3896 3897 if Source_Siz /= Target_Siz then 3898 Error_Msg_N 3899 ("types for unchecked conversion have different sizes?", 3900 Enode); 3901 3902 if All_Errors_Mode then 3903 Error_Msg_Name_1 := Chars (Source); 3904 Error_Msg_Uint_1 := Source_Siz; 3905 Error_Msg_Name_2 := Chars (Target); 3906 Error_Msg_Uint_2 := Target_Siz; 3907 Error_Msg_N 3908 ("\size of % is ^, size of % is ^?", Enode); 3909 3910 Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz); 3911 3912 if Is_Discrete_Type (Source) 3913 and then Is_Discrete_Type (Target) 3914 then 3915 if Source_Siz > Target_Siz then 3916 Error_Msg_N 3917 ("\^ high order bits of source will be ignored?", 3918 Enode); 3919 3920 elsif Is_Unsigned_Type (Source) then 3921 Error_Msg_N 3922 ("\source will be extended with ^ high order " & 3923 "zero bits?", Enode); 3924 3925 else 3926 Error_Msg_N 3927 ("\source will be extended with ^ high order " & 3928 "sign bits?", 3929 Enode); 3930 end if; 3931 3932 elsif Source_Siz < Target_Siz then 3933 if Is_Discrete_Type (Target) then 3934 if Bytes_Big_Endian then 3935 Error_Msg_N 3936 ("\target value will include ^ undefined " & 3937 "low order bits?", 3938 Enode); 3939 else 3940 Error_Msg_N 3941 ("\target value will include ^ undefined " & 3942 "high order bits?", 3943 Enode); 3944 end if; 3945 3946 else 3947 Error_Msg_N 3948 ("\^ trailing bits of target value will be " & 3949 "undefined?", Enode); 3950 end if; 3951 3952 else pragma Assert (Source_Siz > Target_Siz); 3953 Error_Msg_N 3954 ("\^ trailing bits of source will be ignored?", 3955 Enode); 3956 end if; 3957 end if; 3958 end if; 3959 end if; 3960 3961 -- If both types are access types, we need to check the alignment. 3962 -- If the alignment of both is specified, we can do it here. 3963 3964 if Serious_Errors_Detected = 0 3965 and then Ekind (Source) in Access_Kind 3966 and then Ekind (Target) in Access_Kind 3967 and then Target_Strict_Alignment 3968 and then Present (Designated_Type (Source)) 3969 and then Present (Designated_Type (Target)) 3970 then 3971 declare 3972 D_Source : constant Entity_Id := Designated_Type (Source); 3973 D_Target : constant Entity_Id := Designated_Type (Target); 3974 3975 begin 3976 if Known_Alignment (D_Source) 3977 and then Known_Alignment (D_Target) 3978 then 3979 declare 3980 Source_Align : constant Uint := Alignment (D_Source); 3981 Target_Align : constant Uint := Alignment (D_Target); 3982 3983 begin 3984 if Source_Align < Target_Align 3985 and then not Is_Tagged_Type (D_Source) 3986 then 3987 Error_Msg_Uint_1 := Target_Align; 3988 Error_Msg_Uint_2 := Source_Align; 3989 Error_Msg_Node_2 := D_Source; 3990 Error_Msg_NE 3991 ("alignment of & (^) is stricter than " & 3992 "alignment of & (^)?", Enode, D_Target); 3993 3994 if All_Errors_Mode then 3995 Error_Msg_N 3996 ("\resulting access value may have invalid " & 3997 "alignment?", Enode); 3998 end if; 3999 end if; 4000 end; 4001 end if; 4002 end; 4003 end if; 4004 end; 4005 end loop; 4006 end Validate_Unchecked_Conversions; 4007 4008end Sem_Ch13; 4009