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-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Errout; use Errout; 32with Exp_Disp; use Exp_Disp; 33with Exp_Tss; use Exp_Tss; 34with Exp_Util; use Exp_Util; 35with Lib; use Lib; 36with Lib.Xref; use Lib.Xref; 37with Namet; use Namet; 38with Nlists; use Nlists; 39with Nmake; use Nmake; 40with Opt; use Opt; 41with Restrict; use Restrict; 42with Rident; use Rident; 43with Rtsfind; use Rtsfind; 44with Sem; use Sem; 45with Sem_Aux; use Sem_Aux; 46with Sem_Ch3; use Sem_Ch3; 47with Sem_Ch6; use Sem_Ch6; 48with Sem_Ch8; use Sem_Ch8; 49with Sem_Ch9; use Sem_Ch9; 50with Sem_Dim; use Sem_Dim; 51with Sem_Disp; use Sem_Disp; 52with Sem_Eval; use Sem_Eval; 53with Sem_Res; use Sem_Res; 54with Sem_Type; use Sem_Type; 55with Sem_Util; use Sem_Util; 56with Sem_Warn; use Sem_Warn; 57with Sinput; use Sinput; 58with Snames; use Snames; 59with Stand; use Stand; 60with Sinfo; use Sinfo; 61with Stringt; use Stringt; 62with Targparm; use Targparm; 63with Ttypes; use Ttypes; 64with Tbuild; use Tbuild; 65with Urealp; use Urealp; 66with Warnsw; use Warnsw; 67 68with GNAT.Heap_Sort_G; 69 70package body Sem_Ch13 is 71 72 SSU : constant Pos := System_Storage_Unit; 73 -- Convenient short hand for commonly used constant 74 75 ----------------------- 76 -- Local Subprograms -- 77 ----------------------- 78 79 procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint); 80 -- This routine is called after setting one of the sizes of type entity 81 -- Typ to Size. The purpose is to deal with the situation of a derived 82 -- type whose inherited alignment is no longer appropriate for the new 83 -- size value. In this case, we reset the Alignment to unknown. 84 85 procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id); 86 -- If Typ has predicates (indicated by Has_Predicates being set for Typ, 87 -- then either there are pragma Predicate entries on the rep chain for the 88 -- type (note that Predicate aspects are converted to pragma Predicate), or 89 -- there are inherited aspects from a parent type, or ancestor subtypes. 90 -- This procedure builds the spec and body for the Predicate function that 91 -- tests these predicates. N is the freeze node for the type. The spec of 92 -- the function is inserted before the freeze node, and the body of the 93 -- function is inserted after the freeze node. 94 95 procedure Build_Static_Predicate 96 (Typ : Entity_Id; 97 Expr : Node_Id; 98 Nam : Name_Id); 99 -- Given a predicated type Typ, where Typ is a discrete static subtype, 100 -- whose predicate expression is Expr, tests if Expr is a static predicate, 101 -- and if so, builds the predicate range list. Nam is the name of the one 102 -- argument to the predicate function. Occurrences of the type name in the 103 -- predicate expression have been replaced by identifier references to this 104 -- name, which is unique, so any identifier with Chars matching Nam must be 105 -- a reference to the type. If the predicate is non-static, this procedure 106 -- returns doing nothing. If the predicate is static, then the predicate 107 -- list is stored in Static_Predicate (Typ), and the Expr is rewritten as 108 -- a canonicalized membership operation. 109 110 function Get_Alignment_Value (Expr : Node_Id) return Uint; 111 -- Given the expression for an alignment value, returns the corresponding 112 -- Uint value. If the value is inappropriate, then error messages are 113 -- posted as required, and a value of No_Uint is returned. 114 115 function Is_Operational_Item (N : Node_Id) return Boolean; 116 -- A specification for a stream attribute is allowed before the full type 117 -- is declared, as explained in AI-00137 and the corrigendum. Attributes 118 -- that do not specify a representation characteristic are operational 119 -- attributes. 120 121 procedure New_Stream_Subprogram 122 (N : Node_Id; 123 Ent : Entity_Id; 124 Subp : Entity_Id; 125 Nam : TSS_Name_Type); 126 -- Create a subprogram renaming of a given stream attribute to the 127 -- designated subprogram and then in the tagged case, provide this as a 128 -- primitive operation, or in the non-tagged case make an appropriate TSS 129 -- entry. This is more properly an expansion activity than just semantics, 130 -- but the presence of user-defined stream functions for limited types is a 131 -- legality check, which is why this takes place here rather than in 132 -- exp_ch13, where it was previously. Nam indicates the name of the TSS 133 -- function to be generated. 134 -- 135 -- To avoid elaboration anomalies with freeze nodes, for untagged types 136 -- we generate both a subprogram declaration and a subprogram renaming 137 -- declaration, so that the attribute specification is handled as a 138 -- renaming_as_body. For tagged types, the specification is one of the 139 -- primitive specs. 140 141 generic 142 with procedure Replace_Type_Reference (N : Node_Id); 143 procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id); 144 -- This is used to scan an expression for a predicate or invariant aspect 145 -- replacing occurrences of the name TName (the name of the subtype to 146 -- which the aspect applies) with appropriate references to the parameter 147 -- of the predicate function or invariant procedure. The procedure passed 148 -- as a generic parameter does the actual replacement of node N, which is 149 -- either a simple direct reference to TName, or a selected component that 150 -- represents an appropriately qualified occurrence of TName. 151 152 procedure Set_Biased 153 (E : Entity_Id; 154 N : Node_Id; 155 Msg : String; 156 Biased : Boolean := True); 157 -- If Biased is True, sets Has_Biased_Representation flag for E, and 158 -- outputs a warning message at node N if Warn_On_Biased_Representation is 159 -- is True. This warning inserts the string Msg to describe the construct 160 -- causing biasing. 161 162 ---------------------------------------------- 163 -- Table for Validate_Unchecked_Conversions -- 164 ---------------------------------------------- 165 166 -- The following table collects unchecked conversions for validation. 167 -- Entries are made by Validate_Unchecked_Conversion and then the call 168 -- to Validate_Unchecked_Conversions does the actual error checking and 169 -- posting of warnings. The reason for this delayed processing is to take 170 -- advantage of back-annotations of size and alignment values performed by 171 -- the back end. 172 173 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is 174 -- that by the time Validate_Unchecked_Conversions is called, Sprint will 175 -- already have modified all Sloc values if the -gnatD option is set. 176 177 type UC_Entry is record 178 Eloc : Source_Ptr; -- node used for posting warnings 179 Source : Entity_Id; -- source type for unchecked conversion 180 Target : Entity_Id; -- target type for unchecked conversion 181 end record; 182 183 package Unchecked_Conversions is new Table.Table ( 184 Table_Component_Type => UC_Entry, 185 Table_Index_Type => Int, 186 Table_Low_Bound => 1, 187 Table_Initial => 50, 188 Table_Increment => 200, 189 Table_Name => "Unchecked_Conversions"); 190 191 ---------------------------------------- 192 -- Table for Validate_Address_Clauses -- 193 ---------------------------------------- 194 195 -- If an address clause has the form 196 197 -- for X'Address use Expr 198 199 -- where Expr is of the form Y'Address or recursively is a reference to a 200 -- constant of either of these forms, and X and Y are entities of objects, 201 -- then if Y has a smaller alignment than X, that merits a warning about 202 -- possible bad alignment. The following table collects address clauses of 203 -- this kind. We put these in a table so that they can be checked after the 204 -- back end has completed annotation of the alignments of objects, since we 205 -- can catch more cases that way. 206 207 type Address_Clause_Check_Record is record 208 N : Node_Id; 209 -- The address clause 210 211 X : Entity_Id; 212 -- The entity of the object overlaying Y 213 214 Y : Entity_Id; 215 -- The entity of the object being overlaid 216 217 Off : Boolean; 218 -- Whether the address is offset within Y 219 end record; 220 221 package Address_Clause_Checks is new Table.Table ( 222 Table_Component_Type => Address_Clause_Check_Record, 223 Table_Index_Type => Int, 224 Table_Low_Bound => 1, 225 Table_Initial => 20, 226 Table_Increment => 200, 227 Table_Name => "Address_Clause_Checks"); 228 229 ----------------------------------------- 230 -- Adjust_Record_For_Reverse_Bit_Order -- 231 ----------------------------------------- 232 233 procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is 234 Comp : Node_Id; 235 CC : Node_Id; 236 237 begin 238 -- Processing depends on version of Ada 239 240 -- For Ada 95, we just renumber bits within a storage unit. We do the 241 -- same for Ada 83 mode, since we recognize the Bit_Order attribute in 242 -- Ada 83, and are free to add this extension. 243 244 if Ada_Version < Ada_2005 then 245 Comp := First_Component_Or_Discriminant (R); 246 while Present (Comp) loop 247 CC := Component_Clause (Comp); 248 249 -- If component clause is present, then deal with the non-default 250 -- bit order case for Ada 95 mode. 251 252 -- We only do this processing for the base type, and in fact that 253 -- is important, since otherwise if there are record subtypes, we 254 -- could reverse the bits once for each subtype, which is wrong. 255 256 if Present (CC) and then Ekind (R) = E_Record_Type then 257 declare 258 CFB : constant Uint := Component_Bit_Offset (Comp); 259 CSZ : constant Uint := Esize (Comp); 260 CLC : constant Node_Id := Component_Clause (Comp); 261 Pos : constant Node_Id := Position (CLC); 262 FB : constant Node_Id := First_Bit (CLC); 263 264 Storage_Unit_Offset : constant Uint := 265 CFB / System_Storage_Unit; 266 267 Start_Bit : constant Uint := 268 CFB mod System_Storage_Unit; 269 270 begin 271 -- Cases where field goes over storage unit boundary 272 273 if Start_Bit + CSZ > System_Storage_Unit then 274 275 -- Allow multi-byte field but generate warning 276 277 if Start_Bit mod System_Storage_Unit = 0 278 and then CSZ mod System_Storage_Unit = 0 279 then 280 Error_Msg_N 281 ("multi-byte field specified with non-standard" 282 & " Bit_Order??", CLC); 283 284 if Bytes_Big_Endian then 285 Error_Msg_N 286 ("bytes are not reversed " 287 & "(component is big-endian)??", CLC); 288 else 289 Error_Msg_N 290 ("bytes are not reversed " 291 & "(component is little-endian)??", CLC); 292 end if; 293 294 -- Do not allow non-contiguous field 295 296 else 297 Error_Msg_N 298 ("attempt to specify non-contiguous field " 299 & "not permitted", CLC); 300 Error_Msg_N 301 ("\caused by non-standard Bit_Order " 302 & "specified", CLC); 303 Error_Msg_N 304 ("\consider possibility of using " 305 & "Ada 2005 mode here", CLC); 306 end if; 307 308 -- Case where field fits in one storage unit 309 310 else 311 -- Give warning if suspicious component clause 312 313 if Intval (FB) >= System_Storage_Unit 314 and then Warn_On_Reverse_Bit_Order 315 then 316 Error_Msg_N 317 ("Bit_Order clause does not affect " & 318 "byte ordering?V?", Pos); 319 Error_Msg_Uint_1 := 320 Intval (Pos) + Intval (FB) / 321 System_Storage_Unit; 322 Error_Msg_N 323 ("position normalized to ^ before bit " & 324 "order interpreted?V?", Pos); 325 end if; 326 327 -- Here is where we fix up the Component_Bit_Offset value 328 -- to account for the reverse bit order. Some examples of 329 -- what needs to be done are: 330 331 -- First_Bit .. Last_Bit Component_Bit_Offset 332 -- old new old new 333 334 -- 0 .. 0 7 .. 7 0 7 335 -- 0 .. 1 6 .. 7 0 6 336 -- 0 .. 2 5 .. 7 0 5 337 -- 0 .. 7 0 .. 7 0 4 338 339 -- 1 .. 1 6 .. 6 1 6 340 -- 1 .. 4 3 .. 6 1 3 341 -- 4 .. 7 0 .. 3 4 0 342 343 -- The rule is that the first bit is is obtained by 344 -- subtracting the old ending bit from storage_unit - 1. 345 346 Set_Component_Bit_Offset 347 (Comp, 348 (Storage_Unit_Offset * System_Storage_Unit) + 349 (System_Storage_Unit - 1) - 350 (Start_Bit + CSZ - 1)); 351 352 Set_Normalized_First_Bit 353 (Comp, 354 Component_Bit_Offset (Comp) mod 355 System_Storage_Unit); 356 end if; 357 end; 358 end if; 359 360 Next_Component_Or_Discriminant (Comp); 361 end loop; 362 363 -- For Ada 2005, we do machine scalar processing, as fully described In 364 -- AI-133. This involves gathering all components which start at the 365 -- same byte offset and processing them together. Same approach is still 366 -- valid in later versions including Ada 2012. 367 368 else 369 declare 370 Max_Machine_Scalar_Size : constant Uint := 371 UI_From_Int 372 (Standard_Long_Long_Integer_Size); 373 -- We use this as the maximum machine scalar size 374 375 Num_CC : Natural; 376 SSU : constant Uint := UI_From_Int (System_Storage_Unit); 377 378 begin 379 -- This first loop through components does two things. First it 380 -- deals with the case of components with component clauses whose 381 -- length is greater than the maximum machine scalar size (either 382 -- accepting them or rejecting as needed). Second, it counts the 383 -- number of components with component clauses whose length does 384 -- not exceed this maximum for later processing. 385 386 Num_CC := 0; 387 Comp := First_Component_Or_Discriminant (R); 388 while Present (Comp) loop 389 CC := Component_Clause (Comp); 390 391 if Present (CC) then 392 declare 393 Fbit : constant Uint := Static_Integer (First_Bit (CC)); 394 Lbit : constant Uint := Static_Integer (Last_Bit (CC)); 395 396 begin 397 -- Case of component with last bit >= max machine scalar 398 399 if Lbit >= Max_Machine_Scalar_Size then 400 401 -- This is allowed only if first bit is zero, and 402 -- last bit + 1 is a multiple of storage unit size. 403 404 if Fbit = 0 and then (Lbit + 1) mod SSU = 0 then 405 406 -- This is the case to give a warning if enabled 407 408 if Warn_On_Reverse_Bit_Order then 409 Error_Msg_N 410 ("multi-byte field specified with " 411 & " non-standard Bit_Order?V?", CC); 412 413 if Bytes_Big_Endian then 414 Error_Msg_N 415 ("\bytes are not reversed " 416 & "(component is big-endian)?V?", CC); 417 else 418 Error_Msg_N 419 ("\bytes are not reversed " 420 & "(component is little-endian)?V?", CC); 421 end if; 422 end if; 423 424 -- Give error message for RM 13.5.1(10) violation 425 426 else 427 Error_Msg_FE 428 ("machine scalar rules not followed for&", 429 First_Bit (CC), Comp); 430 431 Error_Msg_Uint_1 := Lbit; 432 Error_Msg_Uint_2 := Max_Machine_Scalar_Size; 433 Error_Msg_F 434 ("\last bit (^) exceeds maximum machine " 435 & "scalar size (^)", 436 First_Bit (CC)); 437 438 if (Lbit + 1) mod SSU /= 0 then 439 Error_Msg_Uint_1 := SSU; 440 Error_Msg_F 441 ("\and is not a multiple of Storage_Unit (^) " 442 & "(RM 13.4.1(10))", 443 First_Bit (CC)); 444 445 else 446 Error_Msg_Uint_1 := Fbit; 447 Error_Msg_F 448 ("\and first bit (^) is non-zero " 449 & "(RM 13.4.1(10))", 450 First_Bit (CC)); 451 end if; 452 end if; 453 454 -- OK case of machine scalar related component clause, 455 -- For now, just count them. 456 457 else 458 Num_CC := Num_CC + 1; 459 end if; 460 end; 461 end if; 462 463 Next_Component_Or_Discriminant (Comp); 464 end loop; 465 466 -- We need to sort the component clauses on the basis of the 467 -- Position values in the clause, so we can group clauses with 468 -- the same Position. together to determine the relevant machine 469 -- scalar size. 470 471 Sort_CC : declare 472 Comps : array (0 .. Num_CC) of Entity_Id; 473 -- Array to collect component and discriminant entities. The 474 -- data starts at index 1, the 0'th entry is for the sort 475 -- routine. 476 477 function CP_Lt (Op1, Op2 : Natural) return Boolean; 478 -- Compare routine for Sort 479 480 procedure CP_Move (From : Natural; To : Natural); 481 -- Move routine for Sort 482 483 package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); 484 485 Start : Natural; 486 Stop : Natural; 487 -- Start and stop positions in the component list of the set of 488 -- components with the same starting position (that constitute 489 -- components in a single machine scalar). 490 491 MaxL : Uint; 492 -- Maximum last bit value of any component in this set 493 494 MSS : Uint; 495 -- Corresponding machine scalar size 496 497 ----------- 498 -- CP_Lt -- 499 ----------- 500 501 function CP_Lt (Op1, Op2 : Natural) return Boolean is 502 begin 503 return Position (Component_Clause (Comps (Op1))) < 504 Position (Component_Clause (Comps (Op2))); 505 end CP_Lt; 506 507 ------------- 508 -- CP_Move -- 509 ------------- 510 511 procedure CP_Move (From : Natural; To : Natural) is 512 begin 513 Comps (To) := Comps (From); 514 end CP_Move; 515 516 -- Start of processing for Sort_CC 517 518 begin 519 -- Collect the machine scalar relevant component clauses 520 521 Num_CC := 0; 522 Comp := First_Component_Or_Discriminant (R); 523 while Present (Comp) loop 524 declare 525 CC : constant Node_Id := Component_Clause (Comp); 526 527 begin 528 -- Collect only component clauses whose last bit is less 529 -- than machine scalar size. Any component clause whose 530 -- last bit exceeds this value does not take part in 531 -- machine scalar layout considerations. The test for 532 -- Error_Posted makes sure we exclude component clauses 533 -- for which we already posted an error. 534 535 if Present (CC) 536 and then not Error_Posted (Last_Bit (CC)) 537 and then Static_Integer (Last_Bit (CC)) < 538 Max_Machine_Scalar_Size 539 then 540 Num_CC := Num_CC + 1; 541 Comps (Num_CC) := Comp; 542 end if; 543 end; 544 545 Next_Component_Or_Discriminant (Comp); 546 end loop; 547 548 -- Sort by ascending position number 549 550 Sorting.Sort (Num_CC); 551 552 -- We now have all the components whose size does not exceed 553 -- the max machine scalar value, sorted by starting position. 554 -- In this loop we gather groups of clauses starting at the 555 -- same position, to process them in accordance with AI-133. 556 557 Stop := 0; 558 while Stop < Num_CC loop 559 Start := Stop + 1; 560 Stop := Start; 561 MaxL := 562 Static_Integer 563 (Last_Bit (Component_Clause (Comps (Start)))); 564 while Stop < Num_CC loop 565 if Static_Integer 566 (Position (Component_Clause (Comps (Stop + 1)))) = 567 Static_Integer 568 (Position (Component_Clause (Comps (Stop)))) 569 then 570 Stop := Stop + 1; 571 MaxL := 572 UI_Max 573 (MaxL, 574 Static_Integer 575 (Last_Bit 576 (Component_Clause (Comps (Stop))))); 577 else 578 exit; 579 end if; 580 end loop; 581 582 -- Now we have a group of component clauses from Start to 583 -- Stop whose positions are identical, and MaxL is the 584 -- maximum last bit value of any of these components. 585 586 -- We need to determine the corresponding machine scalar 587 -- size. This loop assumes that machine scalar sizes are 588 -- even, and that each possible machine scalar has twice 589 -- as many bits as the next smaller one. 590 591 MSS := Max_Machine_Scalar_Size; 592 while MSS mod 2 = 0 593 and then (MSS / 2) >= SSU 594 and then (MSS / 2) > MaxL 595 loop 596 MSS := MSS / 2; 597 end loop; 598 599 -- Here is where we fix up the Component_Bit_Offset value 600 -- to account for the reverse bit order. Some examples of 601 -- what needs to be done for the case of a machine scalar 602 -- size of 8 are: 603 604 -- First_Bit .. Last_Bit Component_Bit_Offset 605 -- old new old new 606 607 -- 0 .. 0 7 .. 7 0 7 608 -- 0 .. 1 6 .. 7 0 6 609 -- 0 .. 2 5 .. 7 0 5 610 -- 0 .. 7 0 .. 7 0 4 611 612 -- 1 .. 1 6 .. 6 1 6 613 -- 1 .. 4 3 .. 6 1 3 614 -- 4 .. 7 0 .. 3 4 0 615 616 -- The rule is that the first bit is obtained by subtracting 617 -- the old ending bit from machine scalar size - 1. 618 619 for C in Start .. Stop loop 620 declare 621 Comp : constant Entity_Id := Comps (C); 622 CC : constant Node_Id := Component_Clause (Comp); 623 624 LB : constant Uint := Static_Integer (Last_Bit (CC)); 625 NFB : constant Uint := MSS - Uint_1 - LB; 626 NLB : constant Uint := NFB + Esize (Comp) - 1; 627 Pos : constant Uint := Static_Integer (Position (CC)); 628 629 begin 630 if Warn_On_Reverse_Bit_Order then 631 Error_Msg_Uint_1 := MSS; 632 Error_Msg_N 633 ("info: reverse bit order in machine " & 634 "scalar of length^?V?", First_Bit (CC)); 635 Error_Msg_Uint_1 := NFB; 636 Error_Msg_Uint_2 := NLB; 637 638 if Bytes_Big_Endian then 639 Error_Msg_NE 640 ("\info: big-endian range for " 641 & "component & is ^ .. ^?V?", 642 First_Bit (CC), Comp); 643 else 644 Error_Msg_NE 645 ("\info: little-endian range " 646 & "for component & is ^ .. ^?V?", 647 First_Bit (CC), Comp); 648 end if; 649 end if; 650 651 Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); 652 Set_Normalized_First_Bit (Comp, NFB mod SSU); 653 end; 654 end loop; 655 end loop; 656 end Sort_CC; 657 end; 658 end if; 659 end Adjust_Record_For_Reverse_Bit_Order; 660 661 ------------------------------------- 662 -- Alignment_Check_For_Size_Change -- 663 ------------------------------------- 664 665 procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint) is 666 begin 667 -- If the alignment is known, and not set by a rep clause, and is 668 -- inconsistent with the size being set, then reset it to unknown, 669 -- we assume in this case that the size overrides the inherited 670 -- alignment, and that the alignment must be recomputed. 671 672 if Known_Alignment (Typ) 673 and then not Has_Alignment_Clause (Typ) 674 and then Size mod (Alignment (Typ) * SSU) /= 0 675 then 676 Init_Alignment (Typ); 677 end if; 678 end Alignment_Check_For_Size_Change; 679 680 ------------------------------------- 681 -- Analyze_Aspects_At_Freeze_Point -- 682 ------------------------------------- 683 684 procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id) is 685 ASN : Node_Id; 686 A_Id : Aspect_Id; 687 Ritem : Node_Id; 688 689 procedure Analyze_Aspect_Default_Value (ASN : Node_Id); 690 -- This routine analyzes an Aspect_Default_[Component_]Value denoted by 691 -- the aspect specification node ASN. 692 693 procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id); 694 -- Given an aspect specification node ASN whose expression is an 695 -- optional Boolean, this routines creates the corresponding pragma 696 -- at the freezing point. 697 698 ---------------------------------- 699 -- Analyze_Aspect_Default_Value -- 700 ---------------------------------- 701 702 procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is 703 Ent : constant Entity_Id := Entity (ASN); 704 Expr : constant Node_Id := Expression (ASN); 705 Id : constant Node_Id := Identifier (ASN); 706 707 begin 708 Error_Msg_Name_1 := Chars (Id); 709 710 if not Is_Type (Ent) then 711 Error_Msg_N ("aspect% can only apply to a type", Id); 712 return; 713 714 elsif not Is_First_Subtype (Ent) then 715 Error_Msg_N ("aspect% cannot apply to subtype", Id); 716 return; 717 718 elsif A_Id = Aspect_Default_Value 719 and then not Is_Scalar_Type (Ent) 720 then 721 Error_Msg_N ("aspect% can only be applied to scalar type", Id); 722 return; 723 724 elsif A_Id = Aspect_Default_Component_Value then 725 if not Is_Array_Type (Ent) then 726 Error_Msg_N ("aspect% can only be applied to array type", Id); 727 return; 728 729 elsif not Is_Scalar_Type (Component_Type (Ent)) then 730 Error_Msg_N ("aspect% requires scalar components", Id); 731 return; 732 end if; 733 end if; 734 735 Set_Has_Default_Aspect (Base_Type (Ent)); 736 737 if Is_Scalar_Type (Ent) then 738 Set_Default_Aspect_Value (Ent, Expr); 739 740 -- Place default value of base type as well, because that is 741 -- the semantics of the aspect. It is convenient to link the 742 -- aspect to both the (possibly anonymous) base type and to 743 -- the given first subtype. 744 745 Set_Default_Aspect_Value (Base_Type (Ent), Expr); 746 747 else 748 Set_Default_Aspect_Component_Value (Ent, Expr); 749 end if; 750 end Analyze_Aspect_Default_Value; 751 752 ------------------------------------- 753 -- Make_Pragma_From_Boolean_Aspect -- 754 ------------------------------------- 755 756 procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id) is 757 Ident : constant Node_Id := Identifier (ASN); 758 A_Name : constant Name_Id := Chars (Ident); 759 A_Id : constant Aspect_Id := Get_Aspect_Id (A_Name); 760 Ent : constant Entity_Id := Entity (ASN); 761 Expr : constant Node_Id := Expression (ASN); 762 Loc : constant Source_Ptr := Sloc (ASN); 763 764 Prag : Node_Id; 765 766 procedure Check_False_Aspect_For_Derived_Type; 767 -- This procedure checks for the case of a false aspect for a derived 768 -- type, which improperly tries to cancel an aspect inherited from 769 -- the parent. 770 771 ----------------------------------------- 772 -- Check_False_Aspect_For_Derived_Type -- 773 ----------------------------------------- 774 775 procedure Check_False_Aspect_For_Derived_Type is 776 Par : Node_Id; 777 778 begin 779 -- We are only checking derived types 780 781 if not Is_Derived_Type (E) then 782 return; 783 end if; 784 785 Par := Nearest_Ancestor (E); 786 787 case A_Id is 788 when Aspect_Atomic | Aspect_Shared => 789 if not Is_Atomic (Par) then 790 return; 791 end if; 792 793 when Aspect_Atomic_Components => 794 if not Has_Atomic_Components (Par) then 795 return; 796 end if; 797 798 when Aspect_Discard_Names => 799 if not Discard_Names (Par) then 800 return; 801 end if; 802 803 when Aspect_Pack => 804 if not Is_Packed (Par) then 805 return; 806 end if; 807 808 when Aspect_Unchecked_Union => 809 if not Is_Unchecked_Union (Par) then 810 return; 811 end if; 812 813 when Aspect_Volatile => 814 if not Is_Volatile (Par) then 815 return; 816 end if; 817 818 when Aspect_Volatile_Components => 819 if not Has_Volatile_Components (Par) then 820 return; 821 end if; 822 823 when others => 824 return; 825 end case; 826 827 -- Fall through means we are canceling an inherited aspect 828 829 Error_Msg_Name_1 := A_Name; 830 Error_Msg_NE ("derived type& inherits aspect%, cannot cancel", 831 Expr, 832 E); 833 834 end Check_False_Aspect_For_Derived_Type; 835 836 -- Start of processing for Make_Pragma_From_Boolean_Aspect 837 838 begin 839 if Is_False (Static_Boolean (Expr)) then 840 Check_False_Aspect_For_Derived_Type; 841 842 else 843 Prag := 844 Make_Pragma (Loc, 845 Pragma_Argument_Associations => New_List ( 846 Make_Pragma_Argument_Association (Sloc (Ident), 847 Expression => New_Occurrence_Of (Ent, Sloc (Ident)))), 848 849 Pragma_Identifier => 850 Make_Identifier (Sloc (Ident), Chars (Ident))); 851 852 Set_From_Aspect_Specification (Prag, True); 853 Set_Corresponding_Aspect (Prag, ASN); 854 Set_Aspect_Rep_Item (ASN, Prag); 855 Set_Is_Delayed_Aspect (Prag); 856 Set_Parent (Prag, ASN); 857 end if; 858 end Make_Pragma_From_Boolean_Aspect; 859 860 -- Start of processing for Analyze_Aspects_At_Freeze_Point 861 862 begin 863 -- Must be visible in current scope 864 865 if not Scope_Within_Or_Same (Current_Scope, Scope (E)) then 866 return; 867 end if; 868 869 -- Look for aspect specification entries for this entity 870 871 ASN := First_Rep_Item (E); 872 while Present (ASN) loop 873 if Nkind (ASN) = N_Aspect_Specification 874 and then Entity (ASN) = E 875 and then Is_Delayed_Aspect (ASN) 876 then 877 A_Id := Get_Aspect_Id (Chars (Identifier (ASN))); 878 879 case A_Id is 880 881 -- For aspects whose expression is an optional Boolean, make 882 -- the corresponding pragma at the freezing point. 883 884 when Boolean_Aspects | 885 Library_Unit_Aspects => 886 Make_Pragma_From_Boolean_Aspect (ASN); 887 888 -- Special handling for aspects that don't correspond to 889 -- pragmas/attributes. 890 891 when Aspect_Default_Value | 892 Aspect_Default_Component_Value => 893 Analyze_Aspect_Default_Value (ASN); 894 895 -- Ditto for iterator aspects, because the corresponding 896 -- attributes may not have been analyzed yet. 897 898 when Aspect_Constant_Indexing | 899 Aspect_Variable_Indexing | 900 Aspect_Default_Iterator | 901 Aspect_Iterator_Element => 902 Analyze (Expression (ASN)); 903 904 when others => 905 null; 906 end case; 907 908 Ritem := Aspect_Rep_Item (ASN); 909 910 if Present (Ritem) then 911 Analyze (Ritem); 912 end if; 913 end if; 914 915 Next_Rep_Item (ASN); 916 end loop; 917 end Analyze_Aspects_At_Freeze_Point; 918 919 ----------------------------------- 920 -- Analyze_Aspect_Specifications -- 921 ----------------------------------- 922 923 procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is 924 Aspect : Node_Id; 925 Aitem : Node_Id; 926 Ent : Node_Id; 927 928 L : constant List_Id := Aspect_Specifications (N); 929 930 Ins_Node : Node_Id := N; 931 -- Insert pragmas/attribute definition clause after this node when no 932 -- delayed analysis is required. 933 934 -- The general processing involves building an attribute definition 935 -- clause or a pragma node that corresponds to the aspect. Then in order 936 -- to delay the evaluation of this aspect to the freeze point, we attach 937 -- the corresponding pragma/attribute definition clause to the aspect 938 -- specification node, which is then placed in the Rep Item chain. In 939 -- this case we mark the entity by setting the flag Has_Delayed_Aspects 940 -- and we evaluate the rep item at the freeze point. When the aspect 941 -- doesn't have a corresponding pragma/attribute definition clause, then 942 -- its analysis is simply delayed at the freeze point. 943 944 -- Some special cases don't require delay analysis, thus the aspect is 945 -- analyzed right now. 946 947 -- Note that there is a special handling for 948 -- Pre/Post/Test_Case/Contract_Case aspects. In this case, we do not 949 -- have to worry about delay issues, since the pragmas themselves deal 950 -- with delay of visibility for the expression analysis. Thus, we just 951 -- insert the pragma after the node N. 952 953 begin 954 pragma Assert (Present (L)); 955 956 -- Loop through aspects 957 958 Aspect := First (L); 959 Aspect_Loop : while Present (Aspect) loop 960 declare 961 Expr : constant Node_Id := Expression (Aspect); 962 Id : constant Node_Id := Identifier (Aspect); 963 Loc : constant Source_Ptr := Sloc (Aspect); 964 Nam : constant Name_Id := Chars (Id); 965 A_Id : constant Aspect_Id := Get_Aspect_Id (Nam); 966 Anod : Node_Id; 967 968 Delay_Required : Boolean := True; 969 -- Set False if delay is not required 970 971 Eloc : Source_Ptr := No_Location; 972 -- Source location of expression, modified when we split PPC's. It 973 -- is set below when Expr is present. 974 975 procedure Analyze_Aspect_External_Or_Link_Name; 976 -- This routine performs the analysis of the External_Name or 977 -- Link_Name aspects. 978 979 procedure Analyze_Aspect_Implicit_Dereference; 980 -- This routine performs the analysis of the Implicit_Dereference 981 -- aspects. 982 983 ------------------------------------------ 984 -- Analyze_Aspect_External_Or_Link_Name -- 985 ------------------------------------------ 986 987 procedure Analyze_Aspect_External_Or_Link_Name is 988 begin 989 -- Verify that there is an Import/Export aspect defined for the 990 -- entity. The processing of that aspect in turn checks that 991 -- there is a Convention aspect declared. The pragma is 992 -- constructed when processing the Convention aspect. 993 994 declare 995 A : Node_Id; 996 997 begin 998 A := First (L); 999 while Present (A) loop 1000 exit when Chars (Identifier (A)) = Name_Export 1001 or else Chars (Identifier (A)) = Name_Import; 1002 Next (A); 1003 end loop; 1004 1005 if No (A) then 1006 Error_Msg_N 1007 ("Missing Import/Export for Link/External name", 1008 Aspect); 1009 end if; 1010 end; 1011 end Analyze_Aspect_External_Or_Link_Name; 1012 1013 ----------------------------------------- 1014 -- Analyze_Aspect_Implicit_Dereference -- 1015 ----------------------------------------- 1016 1017 procedure Analyze_Aspect_Implicit_Dereference is 1018 begin 1019 if not Is_Type (E) or else not Has_Discriminants (E) then 1020 Error_Msg_N 1021 ("Aspect must apply to a type with discriminants", N); 1022 1023 else 1024 declare 1025 Disc : Entity_Id; 1026 1027 begin 1028 Disc := First_Discriminant (E); 1029 while Present (Disc) loop 1030 if Chars (Expr) = Chars (Disc) 1031 and then Ekind (Etype (Disc)) = 1032 E_Anonymous_Access_Type 1033 then 1034 Set_Has_Implicit_Dereference (E); 1035 Set_Has_Implicit_Dereference (Disc); 1036 return; 1037 end if; 1038 1039 Next_Discriminant (Disc); 1040 end loop; 1041 1042 -- Error if no proper access discriminant. 1043 1044 Error_Msg_NE 1045 ("not an access discriminant of&", Expr, E); 1046 end; 1047 end if; 1048 end Analyze_Aspect_Implicit_Dereference; 1049 1050 begin 1051 -- Skip aspect if already analyzed (not clear if this is needed) 1052 1053 if Analyzed (Aspect) then 1054 goto Continue; 1055 end if; 1056 1057 -- Set the source location of expression, used in the case of 1058 -- a failed precondition/postcondition or invariant. Note that 1059 -- the source location of the expression is not usually the best 1060 -- choice here. For example, it gets located on the last AND 1061 -- keyword in a chain of boolean expressiond AND'ed together. 1062 -- It is best to put the message on the first character of the 1063 -- assertion, which is the effect of the First_Node call here. 1064 1065 if Present (Expr) then 1066 Eloc := Sloc (First_Node (Expr)); 1067 end if; 1068 1069 -- Check restriction No_Implementation_Aspect_Specifications 1070 1071 if Impl_Defined_Aspects (A_Id) then 1072 Check_Restriction 1073 (No_Implementation_Aspect_Specifications, Aspect); 1074 end if; 1075 1076 -- Check restriction No_Specification_Of_Aspect 1077 1078 Check_Restriction_No_Specification_Of_Aspect (Aspect); 1079 1080 -- Analyze this aspect 1081 1082 Set_Analyzed (Aspect); 1083 Set_Entity (Aspect, E); 1084 Ent := New_Occurrence_Of (E, Sloc (Id)); 1085 1086 -- Check for duplicate aspect. Note that the Comes_From_Source 1087 -- test allows duplicate Pre/Post's that we generate internally 1088 -- to escape being flagged here. 1089 1090 if No_Duplicates_Allowed (A_Id) then 1091 Anod := First (L); 1092 while Anod /= Aspect loop 1093 if Same_Aspect 1094 (A_Id, Get_Aspect_Id (Chars (Identifier (Anod)))) 1095 and then Comes_From_Source (Aspect) 1096 then 1097 Error_Msg_Name_1 := Nam; 1098 Error_Msg_Sloc := Sloc (Anod); 1099 1100 -- Case of same aspect specified twice 1101 1102 if Class_Present (Anod) = Class_Present (Aspect) then 1103 if not Class_Present (Anod) then 1104 Error_Msg_NE 1105 ("aspect% for & previously given#", 1106 Id, E); 1107 else 1108 Error_Msg_NE 1109 ("aspect `%''Class` for & previously given#", 1110 Id, E); 1111 end if; 1112 end if; 1113 end if; 1114 1115 Next (Anod); 1116 end loop; 1117 end if; 1118 1119 -- Check some general restrictions on language defined aspects 1120 1121 if not Impl_Defined_Aspects (A_Id) then 1122 Error_Msg_Name_1 := Nam; 1123 1124 -- Not allowed for renaming declarations 1125 1126 if Nkind (N) in N_Renaming_Declaration then 1127 Error_Msg_N 1128 ("aspect % not allowed for renaming declaration", 1129 Aspect); 1130 end if; 1131 1132 -- Not allowed for formal type declarations 1133 1134 if Nkind (N) = N_Formal_Type_Declaration then 1135 Error_Msg_N 1136 ("aspect % not allowed for formal type declaration", 1137 Aspect); 1138 end if; 1139 end if; 1140 1141 -- Copy expression for later processing by the procedures 1142 -- Check_Aspect_At_[Freeze_Point | End_Of_Declarations] 1143 1144 Set_Entity (Id, New_Copy_Tree (Expr)); 1145 1146 -- Processing based on specific aspect 1147 1148 case A_Id is 1149 1150 -- No_Aspect should be impossible 1151 1152 when No_Aspect => 1153 raise Program_Error; 1154 1155 -- Case 1: Aspects corresponding to attribute definition 1156 -- clauses. 1157 1158 when Aspect_Address | 1159 Aspect_Alignment | 1160 Aspect_Bit_Order | 1161 Aspect_Component_Size | 1162 Aspect_Constant_Indexing | 1163 Aspect_Default_Iterator | 1164 Aspect_Dispatching_Domain | 1165 Aspect_External_Tag | 1166 Aspect_Input | 1167 Aspect_Iterator_Element | 1168 Aspect_Machine_Radix | 1169 Aspect_Object_Size | 1170 Aspect_Output | 1171 Aspect_Read | 1172 Aspect_Scalar_Storage_Order | 1173 Aspect_Size | 1174 Aspect_Small | 1175 Aspect_Simple_Storage_Pool | 1176 Aspect_Storage_Pool | 1177 Aspect_Storage_Size | 1178 Aspect_Stream_Size | 1179 Aspect_Value_Size | 1180 Aspect_Variable_Indexing | 1181 Aspect_Write => 1182 1183 -- Indexing aspects apply only to tagged type 1184 1185 if (A_Id = Aspect_Constant_Indexing 1186 or else A_Id = Aspect_Variable_Indexing) 1187 and then not (Is_Type (E) 1188 and then Is_Tagged_Type (E)) 1189 then 1190 Error_Msg_N ("indexing applies to a tagged type", N); 1191 goto Continue; 1192 end if; 1193 1194 -- Construct the attribute definition clause 1195 1196 Aitem := 1197 Make_Attribute_Definition_Clause (Loc, 1198 Name => Ent, 1199 Chars => Chars (Id), 1200 Expression => Relocate_Node (Expr)); 1201 1202 -- Case 2: Aspects cooresponding to pragmas 1203 1204 -- Case 2a: Aspects corresponding to pragmas with two 1205 -- arguments, where the first argument is a local name 1206 -- referring to the entity, and the second argument is the 1207 -- aspect definition expression. 1208 1209 when Aspect_Suppress | 1210 Aspect_Unsuppress => 1211 1212 -- Construct the pragma 1213 1214 Aitem := 1215 Make_Pragma (Loc, 1216 Pragma_Argument_Associations => New_List ( 1217 Make_Pragma_Argument_Association (Loc, 1218 Expression => New_Occurrence_Of (E, Loc)), 1219 1220 Make_Pragma_Argument_Association (Sloc (Expr), 1221 Expression => Relocate_Node (Expr))), 1222 1223 Pragma_Identifier => 1224 Make_Identifier (Sloc (Id), Chars (Id))); 1225 1226 when Aspect_Synchronization => 1227 1228 -- The aspect corresponds to pragma Implemented. 1229 -- Construct the pragma. 1230 1231 Aitem := 1232 Make_Pragma (Loc, 1233 Pragma_Argument_Associations => New_List ( 1234 Make_Pragma_Argument_Association (Loc, 1235 Expression => New_Occurrence_Of (E, Loc)), 1236 1237 Make_Pragma_Argument_Association (Sloc (Expr), 1238 Expression => Relocate_Node (Expr))), 1239 1240 Pragma_Identifier => 1241 Make_Identifier (Sloc (Id), Name_Implemented)); 1242 1243 -- No delay is required since the only values are: By_Entry 1244 -- | By_Protected_Procedure | By_Any | Optional which don't 1245 -- get analyzed anyway. 1246 1247 Delay_Required := False; 1248 1249 when Aspect_Attach_Handler => 1250 Aitem := 1251 Make_Pragma (Loc, 1252 Pragma_Identifier => 1253 Make_Identifier (Sloc (Id), Name_Attach_Handler), 1254 Pragma_Argument_Associations => New_List ( 1255 Make_Pragma_Argument_Association (Sloc (Ent), 1256 Expression => Ent), 1257 Make_Pragma_Argument_Association (Sloc (Expr), 1258 Expression => Relocate_Node (Expr)))); 1259 1260 when Aspect_Dynamic_Predicate | 1261 Aspect_Predicate | 1262 Aspect_Static_Predicate => 1263 1264 -- Construct the pragma (always a pragma Predicate, with 1265 -- flags recording whether it is static/dynamic). 1266 1267 Aitem := 1268 Make_Pragma (Loc, 1269 Pragma_Argument_Associations => New_List ( 1270 Make_Pragma_Argument_Association (Sloc (Ent), 1271 Expression => Ent), 1272 Make_Pragma_Argument_Association (Sloc (Expr), 1273 Expression => Relocate_Node (Expr))), 1274 Class_Present => Class_Present (Aspect), 1275 Pragma_Identifier => 1276 Make_Identifier (Sloc (Id), Name_Predicate)); 1277 1278 -- If the type is private, indicate that its completion 1279 -- has a freeze node, because that is the one that will be 1280 -- visible at freeze time. 1281 1282 Set_Has_Predicates (E); 1283 1284 if Is_Private_Type (E) 1285 and then Present (Full_View (E)) 1286 then 1287 Set_Has_Predicates (Full_View (E)); 1288 Set_Has_Delayed_Aspects (Full_View (E)); 1289 Ensure_Freeze_Node (Full_View (E)); 1290 end if; 1291 1292 -- Case 2b: Aspects corresponding to pragmas with two 1293 -- arguments, where the second argument is a local name 1294 -- referring to the entity, and the first argument is the 1295 -- aspect definition expression. 1296 1297 when Aspect_Convention => 1298 1299 -- The aspect may be part of the specification of an import 1300 -- or export pragma. Scan the aspect list to gather the 1301 -- other components, if any. The name of the generated 1302 -- pragma is one of Convention/Import/Export. 1303 1304 declare 1305 P_Name : Name_Id; 1306 A_Name : Name_Id; 1307 A : Node_Id; 1308 Arg_List : List_Id; 1309 Found : Boolean; 1310 L_Assoc : Node_Id; 1311 E_Assoc : Node_Id; 1312 1313 begin 1314 P_Name := Chars (Id); 1315 Found := False; 1316 Arg_List := New_List; 1317 L_Assoc := Empty; 1318 E_Assoc := Empty; 1319 1320 A := First (L); 1321 while Present (A) loop 1322 A_Name := Chars (Identifier (A)); 1323 1324 if A_Name = Name_Import or else 1325 A_Name = Name_Export 1326 then 1327 if Found then 1328 Error_Msg_N ("conflicting", A); 1329 else 1330 Found := True; 1331 end if; 1332 1333 P_Name := A_Name; 1334 1335 elsif A_Name = Name_Link_Name then 1336 L_Assoc := 1337 Make_Pragma_Argument_Association (Loc, 1338 Chars => A_Name, 1339 Expression => Relocate_Node (Expression (A))); 1340 1341 elsif A_Name = Name_External_Name then 1342 E_Assoc := 1343 Make_Pragma_Argument_Association (Loc, 1344 Chars => A_Name, 1345 Expression => Relocate_Node (Expression (A))); 1346 end if; 1347 1348 Next (A); 1349 end loop; 1350 1351 Arg_List := New_List ( 1352 Make_Pragma_Argument_Association (Sloc (Expr), 1353 Expression => Relocate_Node (Expr)), 1354 Make_Pragma_Argument_Association (Sloc (Ent), 1355 Expression => Ent)); 1356 1357 if Present (L_Assoc) then 1358 Append_To (Arg_List, L_Assoc); 1359 end if; 1360 1361 if Present (E_Assoc) then 1362 Append_To (Arg_List, E_Assoc); 1363 end if; 1364 1365 Aitem := 1366 Make_Pragma (Loc, 1367 Pragma_Argument_Associations => Arg_List, 1368 Pragma_Identifier => 1369 Make_Identifier (Loc, P_Name)); 1370 end; 1371 1372 -- The following three aspects can be specified for a 1373 -- subprogram body, in which case we generate pragmas for them 1374 -- and insert them ahead of local declarations, rather than 1375 -- after the body. 1376 1377 when Aspect_CPU | 1378 Aspect_Interrupt_Priority | 1379 Aspect_Priority => 1380 if Nkind (N) = N_Subprogram_Body then 1381 Aitem := 1382 Make_Pragma (Loc, 1383 Pragma_Argument_Associations => New_List ( 1384 Make_Pragma_Argument_Association (Sloc (Expr), 1385 Expression => Relocate_Node (Expr))), 1386 Pragma_Identifier => 1387 Make_Identifier (Sloc (Id), Chars (Id))); 1388 else 1389 Aitem := 1390 Make_Attribute_Definition_Clause (Loc, 1391 Name => Ent, 1392 Chars => Chars (Id), 1393 Expression => Relocate_Node (Expr)); 1394 end if; 1395 1396 when Aspect_Warnings => 1397 1398 -- Construct the pragma 1399 1400 Aitem := 1401 Make_Pragma (Loc, 1402 Pragma_Argument_Associations => New_List ( 1403 Make_Pragma_Argument_Association (Sloc (Expr), 1404 Expression => Relocate_Node (Expr)), 1405 Make_Pragma_Argument_Association (Loc, 1406 Expression => New_Occurrence_Of (E, Loc))), 1407 Pragma_Identifier => 1408 Make_Identifier (Sloc (Id), Chars (Id)), 1409 Class_Present => Class_Present (Aspect)); 1410 1411 -- We don't have to play the delay game here, since the only 1412 -- values are ON/OFF which don't get analyzed anyway. 1413 1414 Delay_Required := False; 1415 1416 -- Case 2c: Aspects corresponding to pragmas with three 1417 -- arguments. 1418 1419 -- Invariant aspects have a first argument that references the 1420 -- entity, a second argument that is the expression and a third 1421 -- argument that is an appropriate message. 1422 1423 when Aspect_Invariant | 1424 Aspect_Type_Invariant => 1425 1426 -- Analysis of the pragma will verify placement legality: 1427 -- an invariant must apply to a private type, or appear in 1428 -- the private part of a spec and apply to a completion. 1429 1430 -- Construct the pragma 1431 1432 Aitem := 1433 Make_Pragma (Loc, 1434 Pragma_Argument_Associations => New_List ( 1435 Make_Pragma_Argument_Association (Sloc (Ent), 1436 Expression => Ent), 1437 Make_Pragma_Argument_Association (Sloc (Expr), 1438 Expression => Relocate_Node (Expr))), 1439 Class_Present => Class_Present (Aspect), 1440 Pragma_Identifier => 1441 Make_Identifier (Sloc (Id), Name_Invariant)); 1442 1443 -- Add message unless exception messages are suppressed 1444 1445 if not Opt.Exception_Locations_Suppressed then 1446 Append_To (Pragma_Argument_Associations (Aitem), 1447 Make_Pragma_Argument_Association (Eloc, 1448 Chars => Name_Message, 1449 Expression => 1450 Make_String_Literal (Eloc, 1451 Strval => "failed invariant from " 1452 & Build_Location_String (Eloc)))); 1453 end if; 1454 1455 -- For Invariant case, insert immediately after the entity 1456 -- declaration. We do not have to worry about delay issues 1457 -- since the pragma processing takes care of this. 1458 1459 Delay_Required := False; 1460 1461 -- Case 2d : Aspects that correspond to a pragma with one 1462 -- argument. 1463 1464 when Aspect_Abstract_State => 1465 Aitem := 1466 Make_Pragma (Loc, 1467 Pragma_Identifier => 1468 Make_Identifier (Sloc (Id), Name_Abstract_State), 1469 Pragma_Argument_Associations => New_List ( 1470 Make_Pragma_Argument_Association (Loc, 1471 Expression => Relocate_Node (Expr)))); 1472 1473 Delay_Required := False; 1474 1475 -- Aspect Global must be delayed because it can mention names 1476 -- and benefit from the forward visibility rules applicable to 1477 -- aspects of subprograms. 1478 1479 when Aspect_Global => 1480 Aitem := 1481 Make_Pragma (Loc, 1482 Pragma_Identifier => 1483 Make_Identifier (Sloc (Id), Name_Global), 1484 Pragma_Argument_Associations => New_List ( 1485 Make_Pragma_Argument_Association (Loc, 1486 Expression => Relocate_Node (Expr)))); 1487 1488 when Aspect_Relative_Deadline => 1489 Aitem := 1490 Make_Pragma (Loc, 1491 Pragma_Argument_Associations => New_List ( 1492 Make_Pragma_Argument_Association (Loc, 1493 Expression => Relocate_Node (Expr))), 1494 Pragma_Identifier => 1495 Make_Identifier (Sloc (Id), Name_Relative_Deadline)); 1496 1497 -- If the aspect applies to a task, the corresponding pragma 1498 -- must appear within its declarations, not after. 1499 1500 if Nkind (N) = N_Task_Type_Declaration then 1501 declare 1502 Def : Node_Id; 1503 V : List_Id; 1504 1505 begin 1506 if No (Task_Definition (N)) then 1507 Set_Task_Definition (N, 1508 Make_Task_Definition (Loc, 1509 Visible_Declarations => New_List, 1510 End_Label => Empty)); 1511 end if; 1512 1513 Def := Task_Definition (N); 1514 V := Visible_Declarations (Def); 1515 if not Is_Empty_List (V) then 1516 Insert_Before (First (V), Aitem); 1517 1518 else 1519 Set_Visible_Declarations (Def, New_List (Aitem)); 1520 end if; 1521 1522 goto Continue; 1523 end; 1524 end if; 1525 1526 -- Case 3 : Aspects that don't correspond to pragma/attribute 1527 -- definition clause. 1528 1529 -- Case 3a: The aspects listed below don't correspond to 1530 -- pragmas/attributes but do require delayed analysis. 1531 1532 when Aspect_Default_Value | 1533 Aspect_Default_Component_Value => 1534 Aitem := Empty; 1535 1536 -- Case 3b: The aspects listed below don't correspond to 1537 -- pragmas/attributes and don't need delayed analysis. 1538 1539 -- For Implicit_Dereference, External_Name and Link_Name, only 1540 -- the legality checks are done during the analysis, thus no 1541 -- delay is required. 1542 1543 when Aspect_Implicit_Dereference => 1544 Analyze_Aspect_Implicit_Dereference; 1545 goto Continue; 1546 1547 when Aspect_External_Name | 1548 Aspect_Link_Name => 1549 Analyze_Aspect_External_Or_Link_Name; 1550 goto Continue; 1551 1552 when Aspect_Dimension => 1553 Analyze_Aspect_Dimension (N, Id, Expr); 1554 goto Continue; 1555 1556 when Aspect_Dimension_System => 1557 Analyze_Aspect_Dimension_System (N, Id, Expr); 1558 goto Continue; 1559 1560 -- Case 4: Special handling for aspects 1561 -- Pre/Post/Test_Case/Contract_Case whose corresponding pragmas 1562 -- take care of the delay. 1563 1564 -- Aspects Pre/Post generate Precondition/Postcondition pragmas 1565 -- with a first argument that is the expression, and a second 1566 -- argument that is an informative message if the test fails. 1567 -- This is inserted right after the declaration, to get the 1568 -- required pragma placement. The processing for the pragmas 1569 -- takes care of the required delay. 1570 1571 when Pre_Post_Aspects => declare 1572 Pname : Name_Id; 1573 1574 begin 1575 if A_Id = Aspect_Pre or else A_Id = Aspect_Precondition then 1576 Pname := Name_Precondition; 1577 else 1578 Pname := Name_Postcondition; 1579 end if; 1580 1581 -- If the expressions is of the form A and then B, then 1582 -- we generate separate Pre/Post aspects for the separate 1583 -- clauses. Since we allow multiple pragmas, there is no 1584 -- problem in allowing multiple Pre/Post aspects internally. 1585 -- These should be treated in reverse order (B first and 1586 -- A second) since they are later inserted just after N in 1587 -- the order they are treated. This way, the pragma for A 1588 -- ends up preceding the pragma for B, which may have an 1589 -- importance for the error raised (either constraint error 1590 -- or precondition error). 1591 1592 -- We do not do this for Pre'Class, since we have to put 1593 -- these conditions together in a complex OR expression 1594 1595 -- We do not do this in ASIS mode, as ASIS relies on the 1596 -- original node representing the complete expression, when 1597 -- retrieving it through the source aspect table. 1598 1599 if not ASIS_Mode 1600 and then (Pname = Name_Postcondition 1601 or else not Class_Present (Aspect)) 1602 then 1603 while Nkind (Expr) = N_And_Then loop 1604 Insert_After (Aspect, 1605 Make_Aspect_Specification (Sloc (Left_Opnd (Expr)), 1606 Identifier => Identifier (Aspect), 1607 Expression => Relocate_Node (Left_Opnd (Expr)), 1608 Class_Present => Class_Present (Aspect), 1609 Split_PPC => True)); 1610 Rewrite (Expr, Relocate_Node (Right_Opnd (Expr))); 1611 Eloc := Sloc (Expr); 1612 end loop; 1613 end if; 1614 1615 -- Build the precondition/postcondition pragma 1616 1617 Aitem := 1618 Make_Pragma (Loc, 1619 Pragma_Identifier => 1620 Make_Identifier (Sloc (Id), Pname), 1621 Class_Present => Class_Present (Aspect), 1622 Split_PPC => Split_PPC (Aspect), 1623 Pragma_Argument_Associations => New_List ( 1624 Make_Pragma_Argument_Association (Eloc, 1625 Chars => Name_Check, 1626 Expression => Relocate_Node (Expr)))); 1627 1628 -- Add message unless exception messages are suppressed 1629 1630 if not Opt.Exception_Locations_Suppressed then 1631 Append_To (Pragma_Argument_Associations (Aitem), 1632 Make_Pragma_Argument_Association (Eloc, 1633 Chars => Name_Message, 1634 Expression => 1635 Make_String_Literal (Eloc, 1636 Strval => "failed " 1637 & Get_Name_String (Pname) 1638 & " from " 1639 & Build_Location_String (Eloc)))); 1640 end if; 1641 1642 Set_From_Aspect_Specification (Aitem, True); 1643 Set_Corresponding_Aspect (Aitem, Aspect); 1644 Set_Is_Delayed_Aspect (Aspect); 1645 1646 -- For Pre/Post cases, insert immediately after the entity 1647 -- declaration, since that is the required pragma placement. 1648 -- Note that for these aspects, we do not have to worry 1649 -- about delay issues, since the pragmas themselves deal 1650 -- with delay of visibility for the expression analysis. 1651 1652 -- If the entity is a library-level subprogram, the pre/ 1653 -- postconditions must be treated as late pragmas. Note 1654 -- that they must be prepended, not appended, to the list, 1655 -- so that split AND THEN sections are processed in the 1656 -- correct order. 1657 1658 if Nkind (Parent (N)) = N_Compilation_Unit then 1659 declare 1660 Aux : constant Node_Id := Aux_Decls_Node (Parent (N)); 1661 1662 begin 1663 if No (Pragmas_After (Aux)) then 1664 Set_Pragmas_After (Aux, New_List); 1665 end if; 1666 1667 Prepend (Aitem, Pragmas_After (Aux)); 1668 end; 1669 1670 -- If it is a subprogram body, add pragmas to list of 1671 -- declarations in body. 1672 1673 elsif Nkind (N) = N_Subprogram_Body then 1674 if No (Declarations (N)) then 1675 Set_Declarations (N, New_List); 1676 end if; 1677 1678 Append (Aitem, Declarations (N)); 1679 1680 else 1681 Insert_After (N, Aitem); 1682 end if; 1683 1684 goto Continue; 1685 end; 1686 1687 when Aspect_Contract_Case | 1688 Aspect_Test_Case => 1689 1690 declare 1691 Args : List_Id; 1692 Comp_Expr : Node_Id; 1693 Comp_Assn : Node_Id; 1694 New_Expr : Node_Id; 1695 1696 begin 1697 Args := New_List; 1698 1699 if Nkind (Parent (N)) = N_Compilation_Unit then 1700 Error_Msg_Name_1 := Nam; 1701 Error_Msg_N ("incorrect placement of aspect `%`", E); 1702 goto Continue; 1703 end if; 1704 1705 if Nkind (Expr) /= N_Aggregate then 1706 Error_Msg_Name_1 := Nam; 1707 Error_Msg_NE 1708 ("wrong syntax for aspect `%` for &", Id, E); 1709 goto Continue; 1710 end if; 1711 1712 -- Make pragma expressions refer to the original aspect 1713 -- expressions through the Original_Node link. This is 1714 -- used in semantic analysis for ASIS mode, so that the 1715 -- original expression also gets analyzed. 1716 1717 Comp_Expr := First (Expressions (Expr)); 1718 while Present (Comp_Expr) loop 1719 New_Expr := Relocate_Node (Comp_Expr); 1720 Set_Original_Node (New_Expr, Comp_Expr); 1721 Append_To (Args, 1722 Make_Pragma_Argument_Association (Sloc (Comp_Expr), 1723 Expression => New_Expr)); 1724 Next (Comp_Expr); 1725 end loop; 1726 1727 Comp_Assn := First (Component_Associations (Expr)); 1728 while Present (Comp_Assn) loop 1729 if List_Length (Choices (Comp_Assn)) /= 1 1730 or else 1731 Nkind (First (Choices (Comp_Assn))) /= N_Identifier 1732 then 1733 Error_Msg_Name_1 := Nam; 1734 Error_Msg_NE 1735 ("wrong syntax for aspect `%` for &", Id, E); 1736 goto Continue; 1737 end if; 1738 1739 New_Expr := Relocate_Node (Expression (Comp_Assn)); 1740 Set_Original_Node (New_Expr, Expression (Comp_Assn)); 1741 Append_To (Args, 1742 Make_Pragma_Argument_Association (Sloc (Comp_Assn), 1743 Chars => Chars (First (Choices (Comp_Assn))), 1744 Expression => New_Expr)); 1745 Next (Comp_Assn); 1746 end loop; 1747 1748 -- Build the contract-case or test-case pragma 1749 1750 Aitem := 1751 Make_Pragma (Loc, 1752 Pragma_Identifier => 1753 Make_Identifier (Sloc (Id), Nam), 1754 Pragma_Argument_Associations => Args); 1755 1756 Delay_Required := False; 1757 end; 1758 1759 when Aspect_Contract_Cases => Contract_Cases : declare 1760 Case_Guard : Node_Id; 1761 Extra : Node_Id; 1762 Others_Seen : Boolean := False; 1763 Post_Case : Node_Id; 1764 1765 begin 1766 if Nkind (Parent (N)) = N_Compilation_Unit then 1767 Error_Msg_Name_1 := Nam; 1768 Error_Msg_N ("incorrect placement of aspect `%`", E); 1769 goto Continue; 1770 end if; 1771 1772 if Nkind (Expr) /= N_Aggregate then 1773 Error_Msg_Name_1 := Nam; 1774 Error_Msg_NE 1775 ("wrong syntax for aspect `%` for &", Id, E); 1776 goto Continue; 1777 end if; 1778 1779 -- Verify the legality of individual post cases 1780 1781 Post_Case := First (Component_Associations (Expr)); 1782 while Present (Post_Case) loop 1783 if Nkind (Post_Case) /= N_Component_Association then 1784 Error_Msg_N ("wrong syntax in post case", Post_Case); 1785 goto Continue; 1786 end if; 1787 1788 -- Each post case must have exactly one case guard 1789 1790 Case_Guard := First (Choices (Post_Case)); 1791 Extra := Next (Case_Guard); 1792 1793 if Present (Extra) then 1794 Error_Msg_N 1795 ("post case may have only one case guard", Extra); 1796 goto Continue; 1797 end if; 1798 1799 -- Check the placement of "others" (if available) 1800 1801 if Nkind (Case_Guard) = N_Others_Choice then 1802 if Others_Seen then 1803 Error_Msg_Name_1 := Nam; 1804 Error_Msg_N 1805 ("only one others choice allowed in aspect %", 1806 Case_Guard); 1807 goto Continue; 1808 else 1809 Others_Seen := True; 1810 end if; 1811 1812 elsif Others_Seen then 1813 Error_Msg_Name_1 := Nam; 1814 Error_Msg_N 1815 ("others must be the last choice in aspect %", N); 1816 goto Continue; 1817 end if; 1818 1819 Next (Post_Case); 1820 end loop; 1821 1822 -- Transform the aspect into a pragma 1823 1824 Aitem := 1825 Make_Pragma (Loc, 1826 Pragma_Identifier => 1827 Make_Identifier (Loc, Nam), 1828 Pragma_Argument_Associations => New_List ( 1829 Make_Pragma_Argument_Association (Loc, 1830 Expression => Relocate_Node (Expr)))); 1831 1832 Delay_Required := False; 1833 end Contract_Cases; 1834 1835 -- Case 5: Special handling for aspects with an optional 1836 -- boolean argument. 1837 1838 -- In the general case, the corresponding pragma cannot be 1839 -- generated yet because the evaluation of the boolean needs to 1840 -- be delayed til the freeze point. 1841 1842 when Boolean_Aspects | 1843 Library_Unit_Aspects => 1844 1845 Set_Is_Boolean_Aspect (Aspect); 1846 1847 -- Lock_Free aspect only apply to protected objects 1848 1849 if A_Id = Aspect_Lock_Free then 1850 if Ekind (E) /= E_Protected_Type then 1851 Error_Msg_Name_1 := Nam; 1852 Error_Msg_N 1853 ("aspect % only applies to a protected object", 1854 Aspect); 1855 1856 else 1857 -- Set the Uses_Lock_Free flag to True if there is no 1858 -- expression or if the expression is True. ??? The 1859 -- evaluation of this aspect should be delayed to the 1860 -- freeze point. 1861 1862 if No (Expr) 1863 or else Is_True (Static_Boolean (Expr)) 1864 then 1865 Set_Uses_Lock_Free (E); 1866 end if; 1867 1868 Record_Rep_Item (E, Aspect); 1869 end if; 1870 1871 goto Continue; 1872 1873 elsif A_Id = Aspect_Import or else A_Id = Aspect_Export then 1874 1875 -- Verify that there is an aspect Convention that will 1876 -- incorporate the Import/Export aspect, and eventual 1877 -- Link/External names. 1878 1879 declare 1880 A : Node_Id; 1881 1882 begin 1883 A := First (L); 1884 while Present (A) loop 1885 exit when Chars (Identifier (A)) = Name_Convention; 1886 Next (A); 1887 end loop; 1888 1889 if No (A) then 1890 Error_Msg_N 1891 ("missing Convention aspect for Export/Import", 1892 Aspect); 1893 end if; 1894 end; 1895 1896 goto Continue; 1897 end if; 1898 1899 -- This requires special handling in the case of a package 1900 -- declaration, the pragma needs to be inserted in the list 1901 -- of declarations for the associated package. There is no 1902 -- issue of visibility delay for these aspects. 1903 1904 if A_Id in Library_Unit_Aspects 1905 and then Nkind (N) = N_Package_Declaration 1906 and then Nkind (Parent (N)) /= N_Compilation_Unit 1907 then 1908 Error_Msg_N 1909 ("incorrect context for library unit aspect&", Id); 1910 goto Continue; 1911 end if; 1912 1913 -- Special handling when the aspect has no expression. In 1914 -- this case the value is considered to be True. Thus, we 1915 -- simply insert the pragma, no delay is required. 1916 1917 if No (Expr) then 1918 Aitem := 1919 Make_Pragma (Loc, 1920 Pragma_Argument_Associations => New_List ( 1921 Make_Pragma_Argument_Association (Sloc (Ent), 1922 Expression => Ent)), 1923 Pragma_Identifier => 1924 Make_Identifier (Sloc (Id), Chars (Id))); 1925 1926 Delay_Required := False; 1927 1928 -- In general cases, the corresponding pragma/attribute 1929 -- definition clause will be inserted later at the freezing 1930 -- point. 1931 1932 else 1933 Aitem := Empty; 1934 end if; 1935 end case; 1936 1937 -- Attach the corresponding pragma/attribute definition clause to 1938 -- the aspect specification node. 1939 1940 if Present (Aitem) then 1941 Set_From_Aspect_Specification (Aitem, True); 1942 1943 if Nkind (Aitem) = N_Pragma then 1944 Set_Corresponding_Aspect (Aitem, Aspect); 1945 end if; 1946 end if; 1947 1948 -- In the context of a compilation unit, we directly put the 1949 -- pragma in the Pragmas_After list of the 1950 -- N_Compilation_Unit_Aux node (no delay is required here) 1951 -- except for aspects on a subprogram body (see below). 1952 1953 if Nkind (Parent (N)) = N_Compilation_Unit 1954 and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect)) 1955 then 1956 declare 1957 Aux : constant Node_Id := Aux_Decls_Node (Parent (N)); 1958 1959 begin 1960 pragma Assert (Nkind (Aux) = N_Compilation_Unit_Aux); 1961 1962 -- For a Boolean aspect, create the corresponding pragma if 1963 -- no expression or if the value is True. 1964 1965 if Is_Boolean_Aspect (Aspect) and then No (Aitem) then 1966 if Is_True (Static_Boolean (Expr)) then 1967 Aitem := 1968 Make_Pragma (Loc, 1969 Pragma_Argument_Associations => New_List ( 1970 Make_Pragma_Argument_Association (Sloc (Ent), 1971 Expression => Ent)), 1972 Pragma_Identifier => 1973 Make_Identifier (Sloc (Id), Chars (Id))); 1974 1975 Set_From_Aspect_Specification (Aitem, True); 1976 Set_Corresponding_Aspect (Aitem, Aspect); 1977 1978 else 1979 goto Continue; 1980 end if; 1981 end if; 1982 1983 -- If the aspect is on a subprogram body (relevant aspects 1984 -- are Inline and Priority), add the pragma in front of 1985 -- the declarations. 1986 1987 if Nkind (N) = N_Subprogram_Body then 1988 if No (Declarations (N)) then 1989 Set_Declarations (N, New_List); 1990 end if; 1991 1992 Prepend (Aitem, Declarations (N)); 1993 1994 -- Aspect Abstract_State produces implicit declarations for 1995 -- all state abstraction entities it defines. To emulate 1996 -- this behavior, insert the pragma at the start of the 1997 -- visible declarations of the related package. 1998 1999 elsif Nam = Name_Abstract_State 2000 and then Nkind (N) = N_Package_Declaration 2001 then 2002 if No (Visible_Declarations (Specification (N))) then 2003 Set_Visible_Declarations (Specification (N), New_List); 2004 end if; 2005 2006 Prepend (Aitem, Visible_Declarations (Specification (N))); 2007 2008 else 2009 if No (Pragmas_After (Aux)) then 2010 Set_Pragmas_After (Aux, New_List); 2011 end if; 2012 2013 Append (Aitem, Pragmas_After (Aux)); 2014 end if; 2015 2016 goto Continue; 2017 end; 2018 end if; 2019 2020 -- The evaluation of the aspect is delayed to the freezing point. 2021 -- The pragma or attribute clause if there is one is then attached 2022 -- to the aspect specification which is placed in the rep item 2023 -- list. 2024 2025 if Delay_Required then 2026 if Present (Aitem) then 2027 Set_Is_Delayed_Aspect (Aitem); 2028 Set_Aspect_Rep_Item (Aspect, Aitem); 2029 Set_Parent (Aitem, Aspect); 2030 end if; 2031 2032 Set_Is_Delayed_Aspect (Aspect); 2033 2034 -- In the case of Default_Value, link aspect to base type 2035 -- as well, even though it appears on a first subtype. This 2036 -- is mandated by the semantics of the aspect. Verify that 2037 -- this a scalar type, to prevent cascaded errors. 2038 2039 if A_Id = Aspect_Default_Value and then Is_Scalar_Type (E) then 2040 Set_Has_Delayed_Aspects (Base_Type (E)); 2041 Record_Rep_Item (Base_Type (E), Aspect); 2042 end if; 2043 2044 Set_Has_Delayed_Aspects (E); 2045 Record_Rep_Item (E, Aspect); 2046 2047 -- When delay is not required and the context is not a compilation 2048 -- unit, we simply insert the pragma/attribute definition clause 2049 -- in sequence. 2050 2051 else 2052 Insert_After (Ins_Node, Aitem); 2053 Ins_Node := Aitem; 2054 end if; 2055 end; 2056 2057 <<Continue>> 2058 Next (Aspect); 2059 end loop Aspect_Loop; 2060 2061 if Has_Delayed_Aspects (E) then 2062 Ensure_Freeze_Node (E); 2063 end if; 2064 end Analyze_Aspect_Specifications; 2065 2066 ----------------------- 2067 -- Analyze_At_Clause -- 2068 ----------------------- 2069 2070 -- An at clause is replaced by the corresponding Address attribute 2071 -- definition clause that is the preferred approach in Ada 95. 2072 2073 procedure Analyze_At_Clause (N : Node_Id) is 2074 CS : constant Boolean := Comes_From_Source (N); 2075 2076 begin 2077 -- This is an obsolescent feature 2078 2079 Check_Restriction (No_Obsolescent_Features, N); 2080 2081 if Warn_On_Obsolescent_Feature then 2082 Error_Msg_N 2083 ("?j?at clause is an obsolescent feature (RM J.7(2))", N); 2084 Error_Msg_N 2085 ("\?j?use address attribute definition clause instead", N); 2086 end if; 2087 2088 -- Rewrite as address clause 2089 2090 Rewrite (N, 2091 Make_Attribute_Definition_Clause (Sloc (N), 2092 Name => Identifier (N), 2093 Chars => Name_Address, 2094 Expression => Expression (N))); 2095 2096 -- We preserve Comes_From_Source, since logically the clause still comes 2097 -- from the source program even though it is changed in form. 2098 2099 Set_Comes_From_Source (N, CS); 2100 2101 -- Analyze rewritten clause 2102 2103 Analyze_Attribute_Definition_Clause (N); 2104 end Analyze_At_Clause; 2105 2106 ----------------------------------------- 2107 -- Analyze_Attribute_Definition_Clause -- 2108 ----------------------------------------- 2109 2110 procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is 2111 Loc : constant Source_Ptr := Sloc (N); 2112 Nam : constant Node_Id := Name (N); 2113 Attr : constant Name_Id := Chars (N); 2114 Expr : constant Node_Id := Expression (N); 2115 Id : constant Attribute_Id := Get_Attribute_Id (Attr); 2116 2117 Ent : Entity_Id; 2118 -- The entity of Nam after it is analyzed. In the case of an incomplete 2119 -- type, this is the underlying type. 2120 2121 U_Ent : Entity_Id; 2122 -- The underlying entity to which the attribute applies. Generally this 2123 -- is the Underlying_Type of Ent, except in the case where the clause 2124 -- applies to full view of incomplete type or private type in which case 2125 -- U_Ent is just a copy of Ent. 2126 2127 FOnly : Boolean := False; 2128 -- Reset to True for subtype specific attribute (Alignment, Size) 2129 -- and for stream attributes, i.e. those cases where in the call 2130 -- to Rep_Item_Too_Late, FOnly is set True so that only the freezing 2131 -- rules are checked. Note that the case of stream attributes is not 2132 -- clear from the RM, but see AI95-00137. Also, the RM seems to 2133 -- disallow Storage_Size for derived task types, but that is also 2134 -- clearly unintentional. 2135 2136 procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type); 2137 -- Common processing for 'Read, 'Write, 'Input and 'Output attribute 2138 -- definition clauses. 2139 2140 function Duplicate_Clause return Boolean; 2141 -- This routine checks if the aspect for U_Ent being given by attribute 2142 -- definition clause N is for an aspect that has already been specified, 2143 -- and if so gives an error message. If there is a duplicate, True is 2144 -- returned, otherwise if there is no error, False is returned. 2145 2146 procedure Check_Indexing_Functions; 2147 -- Check that the function in Constant_Indexing or Variable_Indexing 2148 -- attribute has the proper type structure. If the name is overloaded, 2149 -- check that some interpretation is legal. 2150 2151 procedure Check_Iterator_Functions; 2152 -- Check that there is a single function in Default_Iterator attribute 2153 -- has the proper type structure. 2154 2155 function Check_Primitive_Function (Subp : Entity_Id) return Boolean; 2156 -- Common legality check for the previous two 2157 2158 ----------------------------------- 2159 -- Analyze_Stream_TSS_Definition -- 2160 ----------------------------------- 2161 2162 procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is 2163 Subp : Entity_Id := Empty; 2164 I : Interp_Index; 2165 It : Interp; 2166 Pnam : Entity_Id; 2167 2168 Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read); 2169 -- True for Read attribute, false for other attributes 2170 2171 function Has_Good_Profile (Subp : Entity_Id) return Boolean; 2172 -- Return true if the entity is a subprogram with an appropriate 2173 -- profile for the attribute being defined. 2174 2175 ---------------------- 2176 -- Has_Good_Profile -- 2177 ---------------------- 2178 2179 function Has_Good_Profile (Subp : Entity_Id) return Boolean is 2180 F : Entity_Id; 2181 Is_Function : constant Boolean := (TSS_Nam = TSS_Stream_Input); 2182 Expected_Ekind : constant array (Boolean) of Entity_Kind := 2183 (False => E_Procedure, True => E_Function); 2184 Typ : Entity_Id; 2185 2186 begin 2187 if Ekind (Subp) /= Expected_Ekind (Is_Function) then 2188 return False; 2189 end if; 2190 2191 F := First_Formal (Subp); 2192 2193 if No (F) 2194 or else Ekind (Etype (F)) /= E_Anonymous_Access_Type 2195 or else Designated_Type (Etype (F)) /= 2196 Class_Wide_Type (RTE (RE_Root_Stream_Type)) 2197 then 2198 return False; 2199 end if; 2200 2201 if not Is_Function then 2202 Next_Formal (F); 2203 2204 declare 2205 Expected_Mode : constant array (Boolean) of Entity_Kind := 2206 (False => E_In_Parameter, 2207 True => E_Out_Parameter); 2208 begin 2209 if Parameter_Mode (F) /= Expected_Mode (Is_Read) then 2210 return False; 2211 end if; 2212 end; 2213 2214 Typ := Etype (F); 2215 2216 else 2217 Typ := Etype (Subp); 2218 end if; 2219 2220 return Base_Type (Typ) = Base_Type (Ent) 2221 and then No (Next_Formal (F)); 2222 end Has_Good_Profile; 2223 2224 -- Start of processing for Analyze_Stream_TSS_Definition 2225 2226 begin 2227 FOnly := True; 2228 2229 if not Is_Type (U_Ent) then 2230 Error_Msg_N ("local name must be a subtype", Nam); 2231 return; 2232 end if; 2233 2234 Pnam := TSS (Base_Type (U_Ent), TSS_Nam); 2235 2236 -- If Pnam is present, it can be either inherited from an ancestor 2237 -- type (in which case it is legal to redefine it for this type), or 2238 -- be a previous definition of the attribute for the same type (in 2239 -- which case it is illegal). 2240 2241 -- In the first case, it will have been analyzed already, and we 2242 -- can check that its profile does not match the expected profile 2243 -- for a stream attribute of U_Ent. In the second case, either Pnam 2244 -- has been analyzed (and has the expected profile), or it has not 2245 -- been analyzed yet (case of a type that has not been frozen yet 2246 -- and for which the stream attribute has been set using Set_TSS). 2247 2248 if Present (Pnam) 2249 and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam)) 2250 then 2251 Error_Msg_Sloc := Sloc (Pnam); 2252 Error_Msg_Name_1 := Attr; 2253 Error_Msg_N ("% attribute already defined #", Nam); 2254 return; 2255 end if; 2256 2257 Analyze (Expr); 2258 2259 if Is_Entity_Name (Expr) then 2260 if not Is_Overloaded (Expr) then 2261 if Has_Good_Profile (Entity (Expr)) then 2262 Subp := Entity (Expr); 2263 end if; 2264 2265 else 2266 Get_First_Interp (Expr, I, It); 2267 while Present (It.Nam) loop 2268 if Has_Good_Profile (It.Nam) then 2269 Subp := It.Nam; 2270 exit; 2271 end if; 2272 2273 Get_Next_Interp (I, It); 2274 end loop; 2275 end if; 2276 end if; 2277 2278 if Present (Subp) then 2279 if Is_Abstract_Subprogram (Subp) then 2280 Error_Msg_N ("stream subprogram must not be abstract", Expr); 2281 return; 2282 end if; 2283 2284 Set_Entity (Expr, Subp); 2285 Set_Etype (Expr, Etype (Subp)); 2286 2287 New_Stream_Subprogram (N, U_Ent, Subp, TSS_Nam); 2288 2289 else 2290 Error_Msg_Name_1 := Attr; 2291 Error_Msg_N ("incorrect expression for% attribute", Expr); 2292 end if; 2293 end Analyze_Stream_TSS_Definition; 2294 2295 ------------------------------ 2296 -- Check_Indexing_Functions -- 2297 ------------------------------ 2298 2299 procedure Check_Indexing_Functions is 2300 Indexing_Found : Boolean; 2301 2302 procedure Check_One_Function (Subp : Entity_Id); 2303 -- Check one possible interpretation. Sets Indexing_Found True if an 2304 -- indexing function is found. 2305 2306 ------------------------ 2307 -- Check_One_Function -- 2308 ------------------------ 2309 2310 procedure Check_One_Function (Subp : Entity_Id) is 2311 Default_Element : constant Node_Id := 2312 Find_Aspect 2313 (Etype (First_Formal (Subp)), 2314 Aspect_Iterator_Element); 2315 2316 begin 2317 if not Check_Primitive_Function (Subp) 2318 and then not Is_Overloaded (Expr) 2319 then 2320 Error_Msg_NE 2321 ("aspect Indexing requires a function that applies to type&", 2322 Subp, Ent); 2323 end if; 2324 2325 -- An indexing function must return either the default element of 2326 -- the container, or a reference type. For variable indexing it 2327 -- must be the latter. 2328 2329 if Present (Default_Element) then 2330 Analyze (Default_Element); 2331 2332 if Is_Entity_Name (Default_Element) 2333 and then Covers (Entity (Default_Element), Etype (Subp)) 2334 then 2335 Indexing_Found := True; 2336 return; 2337 end if; 2338 end if; 2339 2340 -- For variable_indexing the return type must be a reference type 2341 2342 if Attr = Name_Variable_Indexing 2343 and then not Has_Implicit_Dereference (Etype (Subp)) 2344 then 2345 Error_Msg_N 2346 ("function for indexing must return a reference type", Subp); 2347 2348 else 2349 Indexing_Found := True; 2350 end if; 2351 end Check_One_Function; 2352 2353 -- Start of processing for Check_Indexing_Functions 2354 2355 begin 2356 if In_Instance then 2357 return; 2358 end if; 2359 2360 Analyze (Expr); 2361 2362 if not Is_Overloaded (Expr) then 2363 Check_One_Function (Entity (Expr)); 2364 2365 else 2366 declare 2367 I : Interp_Index; 2368 It : Interp; 2369 2370 begin 2371 Indexing_Found := False; 2372 Get_First_Interp (Expr, I, It); 2373 while Present (It.Nam) loop 2374 2375 -- Note that analysis will have added the interpretation 2376 -- that corresponds to the dereference. We only check the 2377 -- subprogram itself. 2378 2379 if Is_Overloadable (It.Nam) then 2380 Check_One_Function (It.Nam); 2381 end if; 2382 2383 Get_Next_Interp (I, It); 2384 end loop; 2385 2386 if not Indexing_Found then 2387 Error_Msg_NE 2388 ("aspect Indexing requires a function that " 2389 & "applies to type&", Expr, Ent); 2390 end if; 2391 end; 2392 end if; 2393 end Check_Indexing_Functions; 2394 2395 ------------------------------ 2396 -- Check_Iterator_Functions -- 2397 ------------------------------ 2398 2399 procedure Check_Iterator_Functions is 2400 Default : Entity_Id; 2401 2402 function Valid_Default_Iterator (Subp : Entity_Id) return Boolean; 2403 -- Check one possible interpretation for validity 2404 2405 ---------------------------- 2406 -- Valid_Default_Iterator -- 2407 ---------------------------- 2408 2409 function Valid_Default_Iterator (Subp : Entity_Id) return Boolean is 2410 Formal : Entity_Id; 2411 2412 begin 2413 if not Check_Primitive_Function (Subp) then 2414 return False; 2415 else 2416 Formal := First_Formal (Subp); 2417 end if; 2418 2419 -- False if any subsequent formal has no default expression 2420 2421 Formal := Next_Formal (Formal); 2422 while Present (Formal) loop 2423 if No (Expression (Parent (Formal))) then 2424 return False; 2425 end if; 2426 2427 Next_Formal (Formal); 2428 end loop; 2429 2430 -- True if all subsequent formals have default expressions 2431 2432 return True; 2433 end Valid_Default_Iterator; 2434 2435 -- Start of processing for Check_Iterator_Functions 2436 2437 begin 2438 Analyze (Expr); 2439 2440 if not Is_Entity_Name (Expr) then 2441 Error_Msg_N ("aspect Iterator must be a function name", Expr); 2442 end if; 2443 2444 if not Is_Overloaded (Expr) then 2445 if not Check_Primitive_Function (Entity (Expr)) then 2446 Error_Msg_NE 2447 ("aspect Indexing requires a function that applies to type&", 2448 Entity (Expr), Ent); 2449 end if; 2450 2451 if not Valid_Default_Iterator (Entity (Expr)) then 2452 Error_Msg_N ("improper function for default iterator", Expr); 2453 end if; 2454 2455 else 2456 Default := Empty; 2457 declare 2458 I : Interp_Index; 2459 It : Interp; 2460 2461 begin 2462 Get_First_Interp (Expr, I, It); 2463 while Present (It.Nam) loop 2464 if not Check_Primitive_Function (It.Nam) 2465 or else not Valid_Default_Iterator (It.Nam) 2466 then 2467 Remove_Interp (I); 2468 2469 elsif Present (Default) then 2470 Error_Msg_N ("default iterator must be unique", Expr); 2471 2472 else 2473 Default := It.Nam; 2474 end if; 2475 2476 Get_Next_Interp (I, It); 2477 end loop; 2478 end; 2479 2480 if Present (Default) then 2481 Set_Entity (Expr, Default); 2482 Set_Is_Overloaded (Expr, False); 2483 end if; 2484 end if; 2485 end Check_Iterator_Functions; 2486 2487 ------------------------------- 2488 -- Check_Primitive_Function -- 2489 ------------------------------- 2490 2491 function Check_Primitive_Function (Subp : Entity_Id) return Boolean is 2492 Ctrl : Entity_Id; 2493 2494 begin 2495 if Ekind (Subp) /= E_Function then 2496 return False; 2497 end if; 2498 2499 if No (First_Formal (Subp)) then 2500 return False; 2501 else 2502 Ctrl := Etype (First_Formal (Subp)); 2503 end if; 2504 2505 if Ctrl = Ent 2506 or else Ctrl = Class_Wide_Type (Ent) 2507 or else 2508 (Ekind (Ctrl) = E_Anonymous_Access_Type 2509 and then 2510 (Designated_Type (Ctrl) = Ent 2511 or else Designated_Type (Ctrl) = Class_Wide_Type (Ent))) 2512 then 2513 null; 2514 2515 else 2516 return False; 2517 end if; 2518 2519 return True; 2520 end Check_Primitive_Function; 2521 2522 ---------------------- 2523 -- Duplicate_Clause -- 2524 ---------------------- 2525 2526 function Duplicate_Clause return Boolean is 2527 A : Node_Id; 2528 2529 begin 2530 -- Nothing to do if this attribute definition clause comes from 2531 -- an aspect specification, since we could not be duplicating an 2532 -- explicit clause, and we dealt with the case of duplicated aspects 2533 -- in Analyze_Aspect_Specifications. 2534 2535 if From_Aspect_Specification (N) then 2536 return False; 2537 end if; 2538 2539 -- Otherwise current clause may duplicate previous clause, or a 2540 -- previously given pragma or aspect specification for the same 2541 -- aspect. 2542 2543 A := Get_Rep_Item (U_Ent, Chars (N), Check_Parents => False); 2544 2545 if Present (A) then 2546 Error_Msg_Name_1 := Chars (N); 2547 Error_Msg_Sloc := Sloc (A); 2548 2549 Error_Msg_NE ("aspect% for & previously given#", N, U_Ent); 2550 return True; 2551 end if; 2552 2553 return False; 2554 end Duplicate_Clause; 2555 2556 -- Start of processing for Analyze_Attribute_Definition_Clause 2557 2558 begin 2559 -- The following code is a defense against recursion. Not clear that 2560 -- this can happen legitimately, but perhaps some error situations 2561 -- can cause it, and we did see this recursion during testing. 2562 2563 if Analyzed (N) then 2564 return; 2565 else 2566 Set_Analyzed (N, True); 2567 end if; 2568 2569 -- Ignore some selected attributes in CodePeer mode since they are not 2570 -- relevant in this context. 2571 2572 if CodePeer_Mode then 2573 case Id is 2574 2575 -- Ignore Component_Size in CodePeer mode, to avoid changing the 2576 -- internal representation of types by implicitly packing them. 2577 2578 when Attribute_Component_Size => 2579 Rewrite (N, Make_Null_Statement (Sloc (N))); 2580 return; 2581 2582 when others => 2583 null; 2584 end case; 2585 end if; 2586 2587 -- Process Ignore_Rep_Clauses option 2588 2589 if Ignore_Rep_Clauses then 2590 case Id is 2591 2592 -- The following should be ignored. They do not affect legality 2593 -- and may be target dependent. The basic idea of -gnatI is to 2594 -- ignore any rep clauses that may be target dependent but do not 2595 -- affect legality (except possibly to be rejected because they 2596 -- are incompatible with the compilation target). 2597 2598 when Attribute_Alignment | 2599 Attribute_Bit_Order | 2600 Attribute_Component_Size | 2601 Attribute_Machine_Radix | 2602 Attribute_Object_Size | 2603 Attribute_Size | 2604 Attribute_Stream_Size | 2605 Attribute_Value_Size => 2606 Rewrite (N, Make_Null_Statement (Sloc (N))); 2607 return; 2608 2609 -- Perhaps 'Small should not be ignored by Ignore_Rep_Clauses ??? 2610 2611 when Attribute_Small => 2612 if Ignore_Rep_Clauses then 2613 Rewrite (N, Make_Null_Statement (Sloc (N))); 2614 return; 2615 end if; 2616 2617 -- The following should not be ignored, because in the first place 2618 -- they are reasonably portable, and should not cause problems in 2619 -- compiling code from another target, and also they do affect 2620 -- legality, e.g. failing to provide a stream attribute for a 2621 -- type may make a program illegal. 2622 2623 when Attribute_External_Tag | 2624 Attribute_Input | 2625 Attribute_Output | 2626 Attribute_Read | 2627 Attribute_Simple_Storage_Pool | 2628 Attribute_Storage_Pool | 2629 Attribute_Storage_Size | 2630 Attribute_Write => 2631 null; 2632 2633 -- Other cases are errors ("attribute& cannot be set with 2634 -- definition clause"), which will be caught below. 2635 2636 when others => 2637 null; 2638 end case; 2639 end if; 2640 2641 Analyze (Nam); 2642 Ent := Entity (Nam); 2643 2644 if Rep_Item_Too_Early (Ent, N) then 2645 return; 2646 end if; 2647 2648 -- Rep clause applies to full view of incomplete type or private type if 2649 -- we have one (if not, this is a premature use of the type). However, 2650 -- certain semantic checks need to be done on the specified entity (i.e. 2651 -- the private view), so we save it in Ent. 2652 2653 if Is_Private_Type (Ent) 2654 and then Is_Derived_Type (Ent) 2655 and then not Is_Tagged_Type (Ent) 2656 and then No (Full_View (Ent)) 2657 then 2658 -- If this is a private type whose completion is a derivation from 2659 -- another private type, there is no full view, and the attribute 2660 -- belongs to the type itself, not its underlying parent. 2661 2662 U_Ent := Ent; 2663 2664 elsif Ekind (Ent) = E_Incomplete_Type then 2665 2666 -- The attribute applies to the full view, set the entity of the 2667 -- attribute definition accordingly. 2668 2669 Ent := Underlying_Type (Ent); 2670 U_Ent := Ent; 2671 Set_Entity (Nam, Ent); 2672 2673 else 2674 U_Ent := Underlying_Type (Ent); 2675 end if; 2676 2677 -- Avoid cascaded error 2678 2679 if Etype (Nam) = Any_Type then 2680 return; 2681 2682 -- Must be declared in current scope or in case of an aspect 2683 -- specification, must be visible in current scope. 2684 2685 elsif Scope (Ent) /= Current_Scope 2686 and then 2687 not (From_Aspect_Specification (N) 2688 and then Scope_Within_Or_Same (Current_Scope, Scope (Ent))) 2689 then 2690 Error_Msg_N ("entity must be declared in this scope", Nam); 2691 return; 2692 2693 -- Must not be a source renaming (we do have some cases where the 2694 -- expander generates a renaming, and those cases are OK, in such 2695 -- cases any attribute applies to the renamed object as well). 2696 2697 elsif Is_Object (Ent) 2698 and then Present (Renamed_Object (Ent)) 2699 then 2700 -- Case of renamed object from source, this is an error 2701 2702 if Comes_From_Source (Renamed_Object (Ent)) then 2703 Get_Name_String (Chars (N)); 2704 Error_Msg_Strlen := Name_Len; 2705 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); 2706 Error_Msg_N 2707 ("~ clause not allowed for a renaming declaration " 2708 & "(RM 13.1(6))", Nam); 2709 return; 2710 2711 -- For the case of a compiler generated renaming, the attribute 2712 -- definition clause applies to the renamed object created by the 2713 -- expander. The easiest general way to handle this is to create a 2714 -- copy of the attribute definition clause for this object. 2715 2716 else 2717 Insert_Action (N, 2718 Make_Attribute_Definition_Clause (Loc, 2719 Name => 2720 New_Occurrence_Of (Entity (Renamed_Object (Ent)), Loc), 2721 Chars => Chars (N), 2722 Expression => Duplicate_Subexpr (Expression (N)))); 2723 end if; 2724 2725 -- If no underlying entity, use entity itself, applies to some 2726 -- previously detected error cases ??? 2727 2728 elsif No (U_Ent) then 2729 U_Ent := Ent; 2730 2731 -- Cannot specify for a subtype (exception Object/Value_Size) 2732 2733 elsif Is_Type (U_Ent) 2734 and then not Is_First_Subtype (U_Ent) 2735 and then Id /= Attribute_Object_Size 2736 and then Id /= Attribute_Value_Size 2737 and then not From_At_Mod (N) 2738 then 2739 Error_Msg_N ("cannot specify attribute for subtype", Nam); 2740 return; 2741 end if; 2742 2743 Set_Entity (N, U_Ent); 2744 2745 -- Switch on particular attribute 2746 2747 case Id is 2748 2749 ------------- 2750 -- Address -- 2751 ------------- 2752 2753 -- Address attribute definition clause 2754 2755 when Attribute_Address => Address : begin 2756 2757 -- A little error check, catch for X'Address use X'Address; 2758 2759 if Nkind (Nam) = N_Identifier 2760 and then Nkind (Expr) = N_Attribute_Reference 2761 and then Attribute_Name (Expr) = Name_Address 2762 and then Nkind (Prefix (Expr)) = N_Identifier 2763 and then Chars (Nam) = Chars (Prefix (Expr)) 2764 then 2765 Error_Msg_NE 2766 ("address for & is self-referencing", Prefix (Expr), Ent); 2767 return; 2768 end if; 2769 2770 -- Not that special case, carry on with analysis of expression 2771 2772 Analyze_And_Resolve (Expr, RTE (RE_Address)); 2773 2774 -- Even when ignoring rep clauses we need to indicate that the 2775 -- entity has an address clause and thus it is legal to declare 2776 -- it imported. 2777 2778 if Ignore_Rep_Clauses then 2779 if Ekind_In (U_Ent, E_Variable, E_Constant) then 2780 Record_Rep_Item (U_Ent, N); 2781 end if; 2782 2783 return; 2784 end if; 2785 2786 if Duplicate_Clause then 2787 null; 2788 2789 -- Case of address clause for subprogram 2790 2791 elsif Is_Subprogram (U_Ent) then 2792 if Has_Homonym (U_Ent) then 2793 Error_Msg_N 2794 ("address clause cannot be given " & 2795 "for overloaded subprogram", 2796 Nam); 2797 return; 2798 end if; 2799 2800 -- For subprograms, all address clauses are permitted, and we 2801 -- mark the subprogram as having a deferred freeze so that Gigi 2802 -- will not elaborate it too soon. 2803 2804 -- Above needs more comments, what is too soon about??? 2805 2806 Set_Has_Delayed_Freeze (U_Ent); 2807 2808 -- Case of address clause for entry 2809 2810 elsif Ekind (U_Ent) = E_Entry then 2811 if Nkind (Parent (N)) = N_Task_Body then 2812 Error_Msg_N 2813 ("entry address must be specified in task spec", Nam); 2814 return; 2815 end if; 2816 2817 -- For entries, we require a constant address 2818 2819 Check_Constant_Address_Clause (Expr, U_Ent); 2820 2821 -- Special checks for task types 2822 2823 if Is_Task_Type (Scope (U_Ent)) 2824 and then Comes_From_Source (Scope (U_Ent)) 2825 then 2826 Error_Msg_N 2827 ("??entry address declared for entry in task type", N); 2828 Error_Msg_N 2829 ("\??only one task can be declared of this type", N); 2830 end if; 2831 2832 -- Entry address clauses are obsolescent 2833 2834 Check_Restriction (No_Obsolescent_Features, N); 2835 2836 if Warn_On_Obsolescent_Feature then 2837 Error_Msg_N 2838 ("?j?attaching interrupt to task entry is an " & 2839 "obsolescent feature (RM J.7.1)", N); 2840 Error_Msg_N 2841 ("\?j?use interrupt procedure instead", N); 2842 end if; 2843 2844 -- Case of an address clause for a controlled object which we 2845 -- consider to be erroneous. 2846 2847 elsif Is_Controlled (Etype (U_Ent)) 2848 or else Has_Controlled_Component (Etype (U_Ent)) 2849 then 2850 Error_Msg_NE 2851 ("??controlled object& must not be overlaid", Nam, U_Ent); 2852 Error_Msg_N 2853 ("\??Program_Error will be raised at run time", Nam); 2854 Insert_Action (Declaration_Node (U_Ent), 2855 Make_Raise_Program_Error (Loc, 2856 Reason => PE_Overlaid_Controlled_Object)); 2857 return; 2858 2859 -- Case of address clause for a (non-controlled) object 2860 2861 elsif 2862 Ekind (U_Ent) = E_Variable 2863 or else 2864 Ekind (U_Ent) = E_Constant 2865 then 2866 declare 2867 Expr : constant Node_Id := Expression (N); 2868 O_Ent : Entity_Id; 2869 Off : Boolean; 2870 2871 begin 2872 -- Exported variables cannot have an address clause, because 2873 -- this cancels the effect of the pragma Export. 2874 2875 if Is_Exported (U_Ent) then 2876 Error_Msg_N 2877 ("cannot export object with address clause", Nam); 2878 return; 2879 end if; 2880 2881 Find_Overlaid_Entity (N, O_Ent, Off); 2882 2883 -- Overlaying controlled objects is erroneous 2884 2885 if Present (O_Ent) 2886 and then (Has_Controlled_Component (Etype (O_Ent)) 2887 or else Is_Controlled (Etype (O_Ent))) 2888 then 2889 Error_Msg_N 2890 ("??cannot overlay with controlled object", Expr); 2891 Error_Msg_N 2892 ("\??Program_Error will be raised at run time", Expr); 2893 Insert_Action (Declaration_Node (U_Ent), 2894 Make_Raise_Program_Error (Loc, 2895 Reason => PE_Overlaid_Controlled_Object)); 2896 return; 2897 2898 elsif Present (O_Ent) 2899 and then Ekind (U_Ent) = E_Constant 2900 and then not Is_Constant_Object (O_Ent) 2901 then 2902 Error_Msg_N ("??constant overlays a variable", Expr); 2903 2904 -- Imported variables can have an address clause, but then 2905 -- the import is pretty meaningless except to suppress 2906 -- initializations, so we do not need such variables to 2907 -- be statically allocated (and in fact it causes trouble 2908 -- if the address clause is a local value). 2909 2910 elsif Is_Imported (U_Ent) then 2911 Set_Is_Statically_Allocated (U_Ent, False); 2912 end if; 2913 2914 -- We mark a possible modification of a variable with an 2915 -- address clause, since it is likely aliasing is occurring. 2916 2917 Note_Possible_Modification (Nam, Sure => False); 2918 2919 -- Here we are checking for explicit overlap of one variable 2920 -- by another, and if we find this then mark the overlapped 2921 -- variable as also being volatile to prevent unwanted 2922 -- optimizations. This is a significant pessimization so 2923 -- avoid it when there is an offset, i.e. when the object 2924 -- is composite; they cannot be optimized easily anyway. 2925 2926 if Present (O_Ent) 2927 and then Is_Object (O_Ent) 2928 and then not Off 2929 2930 -- The following test is an expedient solution to what 2931 -- is really a problem in CodePeer. Suppressing the 2932 -- Set_Treat_As_Volatile call here prevents later 2933 -- generation (in some cases) of trees that CodePeer 2934 -- should, but currently does not, handle correctly. 2935 -- This test should probably be removed when CodePeer 2936 -- is improved, just because we want the tree CodePeer 2937 -- analyzes to match the tree for which we generate code 2938 -- as closely as is practical. ??? 2939 2940 and then not CodePeer_Mode 2941 then 2942 -- ??? O_Ent might not be in current unit 2943 2944 Set_Treat_As_Volatile (O_Ent); 2945 end if; 2946 2947 -- Legality checks on the address clause for initialized 2948 -- objects is deferred until the freeze point, because 2949 -- a subsequent pragma might indicate that the object 2950 -- is imported and thus not initialized. Also, the address 2951 -- clause might involve entities that have yet to be 2952 -- elaborated. 2953 2954 Set_Has_Delayed_Freeze (U_Ent); 2955 2956 -- If an initialization call has been generated for this 2957 -- object, it needs to be deferred to after the freeze node 2958 -- we have just now added, otherwise GIGI will see a 2959 -- reference to the variable (as actual to the IP call) 2960 -- before its definition. 2961 2962 declare 2963 Init_Call : constant Node_Id := 2964 Remove_Init_Call (U_Ent, N); 2965 2966 begin 2967 if Present (Init_Call) then 2968 2969 -- If the init call is an expression with actions with 2970 -- null expression, just extract the actions. 2971 2972 if Nkind (Init_Call) = N_Expression_With_Actions 2973 and then 2974 Nkind (Expression (Init_Call)) = N_Null_Statement 2975 then 2976 Append_Freeze_Actions (U_Ent, Actions (Init_Call)); 2977 2978 -- General case: move Init_Call to freeze actions 2979 2980 else 2981 Append_Freeze_Action (U_Ent, Init_Call); 2982 end if; 2983 end if; 2984 end; 2985 2986 if Is_Exported (U_Ent) then 2987 Error_Msg_N 2988 ("& cannot be exported if an address clause is given", 2989 Nam); 2990 Error_Msg_N 2991 ("\define and export a variable " 2992 & "that holds its address instead", Nam); 2993 end if; 2994 2995 -- Entity has delayed freeze, so we will generate an 2996 -- alignment check at the freeze point unless suppressed. 2997 2998 if not Range_Checks_Suppressed (U_Ent) 2999 and then not Alignment_Checks_Suppressed (U_Ent) 3000 then 3001 Set_Check_Address_Alignment (N); 3002 end if; 3003 3004 -- Kill the size check code, since we are not allocating 3005 -- the variable, it is somewhere else. 3006 3007 Kill_Size_Check_Code (U_Ent); 3008 3009 -- If the address clause is of the form: 3010 3011 -- for Y'Address use X'Address 3012 3013 -- or 3014 3015 -- Const : constant Address := X'Address; 3016 -- ... 3017 -- for Y'Address use Const; 3018 3019 -- then we make an entry in the table for checking the size 3020 -- and alignment of the overlaying variable. We defer this 3021 -- check till after code generation to take full advantage 3022 -- of the annotation done by the back end. This entry is 3023 -- only made if the address clause comes from source. 3024 3025 -- If the entity has a generic type, the check will be 3026 -- performed in the instance if the actual type justifies 3027 -- it, and we do not insert the clause in the table to 3028 -- prevent spurious warnings. 3029 3030 if Address_Clause_Overlay_Warnings 3031 and then Comes_From_Source (N) 3032 and then Present (O_Ent) 3033 and then Is_Object (O_Ent) 3034 then 3035 if not Is_Generic_Type (Etype (U_Ent)) then 3036 Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off)); 3037 end if; 3038 3039 -- If variable overlays a constant view, and we are 3040 -- warning on overlays, then mark the variable as 3041 -- overlaying a constant (we will give warnings later 3042 -- if this variable is assigned). 3043 3044 if Is_Constant_Object (O_Ent) 3045 and then Ekind (U_Ent) = E_Variable 3046 then 3047 Set_Overlays_Constant (U_Ent); 3048 end if; 3049 end if; 3050 end; 3051 3052 -- Not a valid entity for an address clause 3053 3054 else 3055 Error_Msg_N ("address cannot be given for &", Nam); 3056 end if; 3057 end Address; 3058 3059 --------------- 3060 -- Alignment -- 3061 --------------- 3062 3063 -- Alignment attribute definition clause 3064 3065 when Attribute_Alignment => Alignment : declare 3066 Align : constant Uint := Get_Alignment_Value (Expr); 3067 Max_Align : constant Uint := UI_From_Int (Maximum_Alignment); 3068 3069 begin 3070 FOnly := True; 3071 3072 if not Is_Type (U_Ent) 3073 and then Ekind (U_Ent) /= E_Variable 3074 and then Ekind (U_Ent) /= E_Constant 3075 then 3076 Error_Msg_N ("alignment cannot be given for &", Nam); 3077 3078 elsif Duplicate_Clause then 3079 null; 3080 3081 elsif Align /= No_Uint then 3082 Set_Has_Alignment_Clause (U_Ent); 3083 3084 -- Tagged type case, check for attempt to set alignment to a 3085 -- value greater than Max_Align, and reset if so. 3086 3087 if Is_Tagged_Type (U_Ent) and then Align > Max_Align then 3088 Error_Msg_N 3089 ("alignment for & set to Maximum_Aligment??", Nam); 3090 Set_Alignment (U_Ent, Max_Align); 3091 3092 -- All other cases 3093 3094 else 3095 Set_Alignment (U_Ent, Align); 3096 end if; 3097 3098 -- For an array type, U_Ent is the first subtype. In that case, 3099 -- also set the alignment of the anonymous base type so that 3100 -- other subtypes (such as the itypes for aggregates of the 3101 -- type) also receive the expected alignment. 3102 3103 if Is_Array_Type (U_Ent) then 3104 Set_Alignment (Base_Type (U_Ent), Align); 3105 end if; 3106 end if; 3107 end Alignment; 3108 3109 --------------- 3110 -- Bit_Order -- 3111 --------------- 3112 3113 -- Bit_Order attribute definition clause 3114 3115 when Attribute_Bit_Order => Bit_Order : declare 3116 begin 3117 if not Is_Record_Type (U_Ent) then 3118 Error_Msg_N 3119 ("Bit_Order can only be defined for record type", Nam); 3120 3121 elsif Duplicate_Clause then 3122 null; 3123 3124 else 3125 Analyze_And_Resolve (Expr, RTE (RE_Bit_Order)); 3126 3127 if Etype (Expr) = Any_Type then 3128 return; 3129 3130 elsif not Is_Static_Expression (Expr) then 3131 Flag_Non_Static_Expr 3132 ("Bit_Order requires static expression!", Expr); 3133 3134 else 3135 if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then 3136 Set_Reverse_Bit_Order (U_Ent, True); 3137 end if; 3138 end if; 3139 end if; 3140 end Bit_Order; 3141 3142 -------------------- 3143 -- Component_Size -- 3144 -------------------- 3145 3146 -- Component_Size attribute definition clause 3147 3148 when Attribute_Component_Size => Component_Size_Case : declare 3149 Csize : constant Uint := Static_Integer (Expr); 3150 Ctyp : Entity_Id; 3151 Btype : Entity_Id; 3152 Biased : Boolean; 3153 New_Ctyp : Entity_Id; 3154 Decl : Node_Id; 3155 3156 begin 3157 if not Is_Array_Type (U_Ent) then 3158 Error_Msg_N ("component size requires array type", Nam); 3159 return; 3160 end if; 3161 3162 Btype := Base_Type (U_Ent); 3163 Ctyp := Component_Type (Btype); 3164 3165 if Duplicate_Clause then 3166 null; 3167 3168 elsif Rep_Item_Too_Early (Btype, N) then 3169 null; 3170 3171 elsif Csize /= No_Uint then 3172 Check_Size (Expr, Ctyp, Csize, Biased); 3173 3174 -- For the biased case, build a declaration for a subtype that 3175 -- will be used to represent the biased subtype that reflects 3176 -- the biased representation of components. We need the subtype 3177 -- to get proper conversions on referencing elements of the 3178 -- array. Note: component size clauses are ignored in VM mode. 3179 3180 if VM_Target = No_VM then 3181 if Biased then 3182 New_Ctyp := 3183 Make_Defining_Identifier (Loc, 3184 Chars => 3185 New_External_Name (Chars (U_Ent), 'C', 0, 'T')); 3186 3187 Decl := 3188 Make_Subtype_Declaration (Loc, 3189 Defining_Identifier => New_Ctyp, 3190 Subtype_Indication => 3191 New_Occurrence_Of (Component_Type (Btype), Loc)); 3192 3193 Set_Parent (Decl, N); 3194 Analyze (Decl, Suppress => All_Checks); 3195 3196 Set_Has_Delayed_Freeze (New_Ctyp, False); 3197 Set_Esize (New_Ctyp, Csize); 3198 Set_RM_Size (New_Ctyp, Csize); 3199 Init_Alignment (New_Ctyp); 3200 Set_Is_Itype (New_Ctyp, True); 3201 Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); 3202 3203 Set_Component_Type (Btype, New_Ctyp); 3204 Set_Biased (New_Ctyp, N, "component size clause"); 3205 end if; 3206 3207 Set_Component_Size (Btype, Csize); 3208 3209 -- For VM case, we ignore component size clauses 3210 3211 else 3212 -- Give a warning unless we are in GNAT mode, in which case 3213 -- the warning is suppressed since it is not useful. 3214 3215 if not GNAT_Mode then 3216 Error_Msg_N 3217 ("component size ignored in this configuration??", N); 3218 end if; 3219 end if; 3220 3221 -- Deal with warning on overridden size 3222 3223 if Warn_On_Overridden_Size 3224 and then Has_Size_Clause (Ctyp) 3225 and then RM_Size (Ctyp) /= Csize 3226 then 3227 Error_Msg_NE 3228 ("component size overrides size clause for&?S?", N, Ctyp); 3229 end if; 3230 3231 Set_Has_Component_Size_Clause (Btype, True); 3232 Set_Has_Non_Standard_Rep (Btype, True); 3233 end if; 3234 end Component_Size_Case; 3235 3236 ----------------------- 3237 -- Constant_Indexing -- 3238 ----------------------- 3239 3240 when Attribute_Constant_Indexing => 3241 Check_Indexing_Functions; 3242 3243 --------- 3244 -- CPU -- 3245 --------- 3246 3247 when Attribute_CPU => CPU : 3248 begin 3249 -- CPU attribute definition clause not allowed except from aspect 3250 -- specification. 3251 3252 if From_Aspect_Specification (N) then 3253 if not Is_Task_Type (U_Ent) then 3254 Error_Msg_N ("CPU can only be defined for task", Nam); 3255 3256 elsif Duplicate_Clause then 3257 null; 3258 3259 else 3260 -- The expression must be analyzed in the special manner 3261 -- described in "Handling of Default and Per-Object 3262 -- Expressions" in sem.ads. 3263 3264 -- The visibility to the discriminants must be restored 3265 3266 Push_Scope_And_Install_Discriminants (U_Ent); 3267 Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range)); 3268 Uninstall_Discriminants_And_Pop_Scope (U_Ent); 3269 3270 if not Is_Static_Expression (Expr) then 3271 Check_Restriction (Static_Priorities, Expr); 3272 end if; 3273 end if; 3274 3275 else 3276 Error_Msg_N 3277 ("attribute& cannot be set with definition clause", N); 3278 end if; 3279 end CPU; 3280 3281 ---------------------- 3282 -- Default_Iterator -- 3283 ---------------------- 3284 3285 when Attribute_Default_Iterator => Default_Iterator : declare 3286 Func : Entity_Id; 3287 3288 begin 3289 if not Is_Tagged_Type (U_Ent) then 3290 Error_Msg_N 3291 ("aspect Default_Iterator applies to tagged type", Nam); 3292 end if; 3293 3294 Check_Iterator_Functions; 3295 3296 Analyze (Expr); 3297 3298 if not Is_Entity_Name (Expr) 3299 or else Ekind (Entity (Expr)) /= E_Function 3300 then 3301 Error_Msg_N ("aspect Iterator must be a function", Expr); 3302 else 3303 Func := Entity (Expr); 3304 end if; 3305 3306 if No (First_Formal (Func)) 3307 or else Etype (First_Formal (Func)) /= U_Ent 3308 then 3309 Error_Msg_NE 3310 ("Default Iterator must be a primitive of&", Func, U_Ent); 3311 end if; 3312 end Default_Iterator; 3313 3314 ------------------------ 3315 -- Dispatching_Domain -- 3316 ------------------------ 3317 3318 when Attribute_Dispatching_Domain => Dispatching_Domain : 3319 begin 3320 -- Dispatching_Domain attribute definition clause not allowed 3321 -- except from aspect specification. 3322 3323 if From_Aspect_Specification (N) then 3324 if not Is_Task_Type (U_Ent) then 3325 Error_Msg_N ("Dispatching_Domain can only be defined" & 3326 "for task", 3327 Nam); 3328 3329 elsif Duplicate_Clause then 3330 null; 3331 3332 else 3333 -- The expression must be analyzed in the special manner 3334 -- described in "Handling of Default and Per-Object 3335 -- Expressions" in sem.ads. 3336 3337 -- The visibility to the discriminants must be restored 3338 3339 Push_Scope_And_Install_Discriminants (U_Ent); 3340 3341 Preanalyze_Spec_Expression 3342 (Expr, RTE (RE_Dispatching_Domain)); 3343 3344 Uninstall_Discriminants_And_Pop_Scope (U_Ent); 3345 end if; 3346 3347 else 3348 Error_Msg_N 3349 ("attribute& cannot be set with definition clause", N); 3350 end if; 3351 end Dispatching_Domain; 3352 3353 ------------------ 3354 -- External_Tag -- 3355 ------------------ 3356 3357 when Attribute_External_Tag => External_Tag : 3358 begin 3359 if not Is_Tagged_Type (U_Ent) then 3360 Error_Msg_N ("should be a tagged type", Nam); 3361 end if; 3362 3363 if Duplicate_Clause then 3364 null; 3365 3366 else 3367 Analyze_And_Resolve (Expr, Standard_String); 3368 3369 if not Is_Static_Expression (Expr) then 3370 Flag_Non_Static_Expr 3371 ("static string required for tag name!", Nam); 3372 end if; 3373 3374 if VM_Target = No_VM then 3375 Set_Has_External_Tag_Rep_Clause (U_Ent); 3376 else 3377 Error_Msg_Name_1 := Attr; 3378 Error_Msg_N 3379 ("% attribute unsupported in this configuration", Nam); 3380 end if; 3381 3382 if not Is_Library_Level_Entity (U_Ent) then 3383 Error_Msg_NE 3384 ("??non-unique external tag supplied for &", N, U_Ent); 3385 Error_Msg_N 3386 ("\??same external tag applies to all " 3387 & "subprogram calls", N); 3388 Error_Msg_N 3389 ("\??corresponding internal tag cannot be obtained", N); 3390 end if; 3391 end if; 3392 end External_Tag; 3393 3394 -------------------------- 3395 -- Implicit_Dereference -- 3396 -------------------------- 3397 3398 when Attribute_Implicit_Dereference => 3399 3400 -- Legality checks already performed at the point of the type 3401 -- declaration, aspect is not delayed. 3402 3403 null; 3404 3405 ----------- 3406 -- Input -- 3407 ----------- 3408 3409 when Attribute_Input => 3410 Analyze_Stream_TSS_Definition (TSS_Stream_Input); 3411 Set_Has_Specified_Stream_Input (Ent); 3412 3413 ------------------------ 3414 -- Interrupt_Priority -- 3415 ------------------------ 3416 3417 when Attribute_Interrupt_Priority => Interrupt_Priority : 3418 begin 3419 -- Interrupt_Priority attribute definition clause not allowed 3420 -- except from aspect specification. 3421 3422 if From_Aspect_Specification (N) then 3423 if not (Is_Protected_Type (U_Ent) 3424 or else Is_Task_Type (U_Ent)) 3425 then 3426 Error_Msg_N 3427 ("Interrupt_Priority can only be defined for task" & 3428 "and protected object", 3429 Nam); 3430 3431 elsif Duplicate_Clause then 3432 null; 3433 3434 else 3435 -- The expression must be analyzed in the special manner 3436 -- described in "Handling of Default and Per-Object 3437 -- Expressions" in sem.ads. 3438 3439 -- The visibility to the discriminants must be restored 3440 3441 Push_Scope_And_Install_Discriminants (U_Ent); 3442 3443 Preanalyze_Spec_Expression 3444 (Expr, RTE (RE_Interrupt_Priority)); 3445 3446 Uninstall_Discriminants_And_Pop_Scope (U_Ent); 3447 end if; 3448 3449 else 3450 Error_Msg_N 3451 ("attribute& cannot be set with definition clause", N); 3452 end if; 3453 end Interrupt_Priority; 3454 3455 ---------------------- 3456 -- Iterator_Element -- 3457 ---------------------- 3458 3459 when Attribute_Iterator_Element => 3460 Analyze (Expr); 3461 3462 if not Is_Entity_Name (Expr) 3463 or else not Is_Type (Entity (Expr)) 3464 then 3465 Error_Msg_N ("aspect Iterator_Element must be a type", Expr); 3466 end if; 3467 3468 ------------------- 3469 -- Machine_Radix -- 3470 ------------------- 3471 3472 -- Machine radix attribute definition clause 3473 3474 when Attribute_Machine_Radix => Machine_Radix : declare 3475 Radix : constant Uint := Static_Integer (Expr); 3476 3477 begin 3478 if not Is_Decimal_Fixed_Point_Type (U_Ent) then 3479 Error_Msg_N ("decimal fixed-point type expected for &", Nam); 3480 3481 elsif Duplicate_Clause then 3482 null; 3483 3484 elsif Radix /= No_Uint then 3485 Set_Has_Machine_Radix_Clause (U_Ent); 3486 Set_Has_Non_Standard_Rep (Base_Type (U_Ent)); 3487 3488 if Radix = 2 then 3489 null; 3490 elsif Radix = 10 then 3491 Set_Machine_Radix_10 (U_Ent); 3492 else 3493 Error_Msg_N ("machine radix value must be 2 or 10", Expr); 3494 end if; 3495 end if; 3496 end Machine_Radix; 3497 3498 ----------------- 3499 -- Object_Size -- 3500 ----------------- 3501 3502 -- Object_Size attribute definition clause 3503 3504 when Attribute_Object_Size => Object_Size : declare 3505 Size : constant Uint := Static_Integer (Expr); 3506 3507 Biased : Boolean; 3508 pragma Warnings (Off, Biased); 3509 3510 begin 3511 if not Is_Type (U_Ent) then 3512 Error_Msg_N ("Object_Size cannot be given for &", Nam); 3513 3514 elsif Duplicate_Clause then 3515 null; 3516 3517 else 3518 Check_Size (Expr, U_Ent, Size, Biased); 3519 3520 if Size /= 8 3521 and then 3522 Size /= 16 3523 and then 3524 Size /= 32 3525 and then 3526 UI_Mod (Size, 64) /= 0 3527 then 3528 Error_Msg_N 3529 ("Object_Size must be 8, 16, 32, or multiple of 64", 3530 Expr); 3531 end if; 3532 3533 Set_Esize (U_Ent, Size); 3534 Set_Has_Object_Size_Clause (U_Ent); 3535 Alignment_Check_For_Size_Change (U_Ent, Size); 3536 end if; 3537 end Object_Size; 3538 3539 ------------ 3540 -- Output -- 3541 ------------ 3542 3543 when Attribute_Output => 3544 Analyze_Stream_TSS_Definition (TSS_Stream_Output); 3545 Set_Has_Specified_Stream_Output (Ent); 3546 3547 -------------- 3548 -- Priority -- 3549 -------------- 3550 3551 when Attribute_Priority => Priority : 3552 begin 3553 -- Priority attribute definition clause not allowed except from 3554 -- aspect specification. 3555 3556 if From_Aspect_Specification (N) then 3557 if not (Is_Protected_Type (U_Ent) 3558 or else Is_Task_Type (U_Ent) 3559 or else Ekind (U_Ent) = E_Procedure) 3560 then 3561 Error_Msg_N 3562 ("Priority can only be defined for task and protected " & 3563 "object", 3564 Nam); 3565 3566 elsif Duplicate_Clause then 3567 null; 3568 3569 else 3570 -- The expression must be analyzed in the special manner 3571 -- described in "Handling of Default and Per-Object 3572 -- Expressions" in sem.ads. 3573 3574 -- The visibility to the discriminants must be restored 3575 3576 Push_Scope_And_Install_Discriminants (U_Ent); 3577 Preanalyze_Spec_Expression (Expr, Standard_Integer); 3578 Uninstall_Discriminants_And_Pop_Scope (U_Ent); 3579 3580 if not Is_Static_Expression (Expr) then 3581 Check_Restriction (Static_Priorities, Expr); 3582 end if; 3583 end if; 3584 3585 else 3586 Error_Msg_N 3587 ("attribute& cannot be set with definition clause", N); 3588 end if; 3589 end Priority; 3590 3591 ---------- 3592 -- Read -- 3593 ---------- 3594 3595 when Attribute_Read => 3596 Analyze_Stream_TSS_Definition (TSS_Stream_Read); 3597 Set_Has_Specified_Stream_Read (Ent); 3598 3599 -------------------------- 3600 -- Scalar_Storage_Order -- 3601 -------------------------- 3602 3603 -- Scalar_Storage_Order attribute definition clause 3604 3605 when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : declare 3606 begin 3607 if not (Is_Record_Type (U_Ent) or else Is_Array_Type (U_Ent)) then 3608 Error_Msg_N 3609 ("Scalar_Storage_Order can only be defined for " 3610 & "record or array type", Nam); 3611 3612 elsif Duplicate_Clause then 3613 null; 3614 3615 else 3616 Analyze_And_Resolve (Expr, RTE (RE_Bit_Order)); 3617 3618 if Etype (Expr) = Any_Type then 3619 return; 3620 3621 elsif not Is_Static_Expression (Expr) then 3622 Flag_Non_Static_Expr 3623 ("Scalar_Storage_Order requires static expression!", Expr); 3624 3625 elsif (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then 3626 3627 -- Here for the case of a non-default (i.e. non-confirming) 3628 -- Scalar_Storage_Order attribute definition. 3629 3630 if Support_Nondefault_SSO_On_Target then 3631 Set_Reverse_Storage_Order (Base_Type (U_Ent), True); 3632 else 3633 Error_Msg_N 3634 ("non-default Scalar_Storage_Order " 3635 & "not supported on target", Expr); 3636 end if; 3637 end if; 3638 end if; 3639 end Scalar_Storage_Order; 3640 3641 ---------- 3642 -- Size -- 3643 ---------- 3644 3645 -- Size attribute definition clause 3646 3647 when Attribute_Size => Size : declare 3648 Size : constant Uint := Static_Integer (Expr); 3649 Etyp : Entity_Id; 3650 Biased : Boolean; 3651 3652 begin 3653 FOnly := True; 3654 3655 if Duplicate_Clause then 3656 null; 3657 3658 elsif not Is_Type (U_Ent) 3659 and then Ekind (U_Ent) /= E_Variable 3660 and then Ekind (U_Ent) /= E_Constant 3661 then 3662 Error_Msg_N ("size cannot be given for &", Nam); 3663 3664 elsif Is_Array_Type (U_Ent) 3665 and then not Is_Constrained (U_Ent) 3666 then 3667 Error_Msg_N 3668 ("size cannot be given for unconstrained array", Nam); 3669 3670 elsif Size /= No_Uint then 3671 if VM_Target /= No_VM and then not GNAT_Mode then 3672 3673 -- Size clause is not handled properly on VM targets. 3674 -- Display a warning unless we are in GNAT mode, in which 3675 -- case this is useless. 3676 3677 Error_Msg_N 3678 ("size clauses are ignored in this configuration??", N); 3679 end if; 3680 3681 if Is_Type (U_Ent) then 3682 Etyp := U_Ent; 3683 else 3684 Etyp := Etype (U_Ent); 3685 end if; 3686 3687 -- Check size, note that Gigi is in charge of checking that the 3688 -- size of an array or record type is OK. Also we do not check 3689 -- the size in the ordinary fixed-point case, since it is too 3690 -- early to do so (there may be subsequent small clause that 3691 -- affects the size). We can check the size if a small clause 3692 -- has already been given. 3693 3694 if not Is_Ordinary_Fixed_Point_Type (U_Ent) 3695 or else Has_Small_Clause (U_Ent) 3696 then 3697 Check_Size (Expr, Etyp, Size, Biased); 3698 Set_Biased (U_Ent, N, "size clause", Biased); 3699 end if; 3700 3701 -- For types set RM_Size and Esize if possible 3702 3703 if Is_Type (U_Ent) then 3704 Set_RM_Size (U_Ent, Size); 3705 3706 -- For elementary types, increase Object_Size to power of 2, 3707 -- but not less than a storage unit in any case (normally 3708 -- this means it will be byte addressable). 3709 3710 -- For all other types, nothing else to do, we leave Esize 3711 -- (object size) unset, the back end will set it from the 3712 -- size and alignment in an appropriate manner. 3713 3714 -- In both cases, we check whether the alignment must be 3715 -- reset in the wake of the size change. 3716 3717 if Is_Elementary_Type (U_Ent) then 3718 if Size <= System_Storage_Unit then 3719 Init_Esize (U_Ent, System_Storage_Unit); 3720 elsif Size <= 16 then 3721 Init_Esize (U_Ent, 16); 3722 elsif Size <= 32 then 3723 Init_Esize (U_Ent, 32); 3724 else 3725 Set_Esize (U_Ent, (Size + 63) / 64 * 64); 3726 end if; 3727 3728 Alignment_Check_For_Size_Change (U_Ent, Esize (U_Ent)); 3729 else 3730 Alignment_Check_For_Size_Change (U_Ent, Size); 3731 end if; 3732 3733 -- For objects, set Esize only 3734 3735 else 3736 if Is_Elementary_Type (Etyp) then 3737 if Size /= System_Storage_Unit 3738 and then 3739 Size /= System_Storage_Unit * 2 3740 and then 3741 Size /= System_Storage_Unit * 4 3742 and then 3743 Size /= System_Storage_Unit * 8 3744 then 3745 Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); 3746 Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8; 3747 Error_Msg_N 3748 ("size for primitive object must be a power of 2" 3749 & " in the range ^-^", N); 3750 end if; 3751 end if; 3752 3753 Set_Esize (U_Ent, Size); 3754 end if; 3755 3756 Set_Has_Size_Clause (U_Ent); 3757 end if; 3758 end Size; 3759 3760 ----------- 3761 -- Small -- 3762 ----------- 3763 3764 -- Small attribute definition clause 3765 3766 when Attribute_Small => Small : declare 3767 Implicit_Base : constant Entity_Id := Base_Type (U_Ent); 3768 Small : Ureal; 3769 3770 begin 3771 Analyze_And_Resolve (Expr, Any_Real); 3772 3773 if Etype (Expr) = Any_Type then 3774 return; 3775 3776 elsif not Is_Static_Expression (Expr) then 3777 Flag_Non_Static_Expr 3778 ("small requires static expression!", Expr); 3779 return; 3780 3781 else 3782 Small := Expr_Value_R (Expr); 3783 3784 if Small <= Ureal_0 then 3785 Error_Msg_N ("small value must be greater than zero", Expr); 3786 return; 3787 end if; 3788 3789 end if; 3790 3791 if not Is_Ordinary_Fixed_Point_Type (U_Ent) then 3792 Error_Msg_N 3793 ("small requires an ordinary fixed point type", Nam); 3794 3795 elsif Has_Small_Clause (U_Ent) then 3796 Error_Msg_N ("small already given for &", Nam); 3797 3798 elsif Small > Delta_Value (U_Ent) then 3799 Error_Msg_N 3800 ("small value must not be greater than delta value", Nam); 3801 3802 else 3803 Set_Small_Value (U_Ent, Small); 3804 Set_Small_Value (Implicit_Base, Small); 3805 Set_Has_Small_Clause (U_Ent); 3806 Set_Has_Small_Clause (Implicit_Base); 3807 Set_Has_Non_Standard_Rep (Implicit_Base); 3808 end if; 3809 end Small; 3810 3811 ------------------ 3812 -- Storage_Pool -- 3813 ------------------ 3814 3815 -- Storage_Pool attribute definition clause 3816 3817 when Attribute_Storage_Pool | Attribute_Simple_Storage_Pool => declare 3818 Pool : Entity_Id; 3819 T : Entity_Id; 3820 3821 begin 3822 if Ekind (U_Ent) = E_Access_Subprogram_Type then 3823 Error_Msg_N 3824 ("storage pool cannot be given for access-to-subprogram type", 3825 Nam); 3826 return; 3827 3828 elsif not 3829 Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type) 3830 then 3831 Error_Msg_N 3832 ("storage pool can only be given for access types", Nam); 3833 return; 3834 3835 elsif Is_Derived_Type (U_Ent) then 3836 Error_Msg_N 3837 ("storage pool cannot be given for a derived access type", 3838 Nam); 3839 3840 elsif Duplicate_Clause then 3841 return; 3842 3843 elsif Present (Associated_Storage_Pool (U_Ent)) then 3844 Error_Msg_N ("storage pool already given for &", Nam); 3845 return; 3846 end if; 3847 3848 if Id = Attribute_Storage_Pool then 3849 Analyze_And_Resolve 3850 (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); 3851 3852 -- In the Simple_Storage_Pool case, we allow a variable of any 3853 -- simple storage pool type, so we Resolve without imposing an 3854 -- expected type. 3855 3856 else 3857 Analyze_And_Resolve (Expr); 3858 3859 if not Present (Get_Rep_Pragma 3860 (Etype (Expr), Name_Simple_Storage_Pool_Type)) 3861 then 3862 Error_Msg_N 3863 ("expression must be of a simple storage pool type", Expr); 3864 end if; 3865 end if; 3866 3867 if not Denotes_Variable (Expr) then 3868 Error_Msg_N ("storage pool must be a variable", Expr); 3869 return; 3870 end if; 3871 3872 if Nkind (Expr) = N_Type_Conversion then 3873 T := Etype (Expression (Expr)); 3874 else 3875 T := Etype (Expr); 3876 end if; 3877 3878 -- The Stack_Bounded_Pool is used internally for implementing 3879 -- access types with a Storage_Size. Since it only work properly 3880 -- when used on one specific type, we need to check that it is not 3881 -- hijacked improperly: 3882 3883 -- type T is access Integer; 3884 -- for T'Storage_Size use n; 3885 -- type Q is access Float; 3886 -- for Q'Storage_Size use T'Storage_Size; -- incorrect 3887 3888 if RTE_Available (RE_Stack_Bounded_Pool) 3889 and then Base_Type (T) = RTE (RE_Stack_Bounded_Pool) 3890 then 3891 Error_Msg_N ("non-shareable internal Pool", Expr); 3892 return; 3893 end if; 3894 3895 -- If the argument is a name that is not an entity name, then 3896 -- we construct a renaming operation to define an entity of 3897 -- type storage pool. 3898 3899 if not Is_Entity_Name (Expr) 3900 and then Is_Object_Reference (Expr) 3901 then 3902 Pool := Make_Temporary (Loc, 'P', Expr); 3903 3904 declare 3905 Rnode : constant Node_Id := 3906 Make_Object_Renaming_Declaration (Loc, 3907 Defining_Identifier => Pool, 3908 Subtype_Mark => 3909 New_Occurrence_Of (Etype (Expr), Loc), 3910 Name => Expr); 3911 3912 begin 3913 Insert_Before (N, Rnode); 3914 Analyze (Rnode); 3915 Set_Associated_Storage_Pool (U_Ent, Pool); 3916 end; 3917 3918 elsif Is_Entity_Name (Expr) then 3919 Pool := Entity (Expr); 3920 3921 -- If pool is a renamed object, get original one. This can 3922 -- happen with an explicit renaming, and within instances. 3923 3924 while Present (Renamed_Object (Pool)) 3925 and then Is_Entity_Name (Renamed_Object (Pool)) 3926 loop 3927 Pool := Entity (Renamed_Object (Pool)); 3928 end loop; 3929 3930 if Present (Renamed_Object (Pool)) 3931 and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion 3932 and then Is_Entity_Name (Expression (Renamed_Object (Pool))) 3933 then 3934 Pool := Entity (Expression (Renamed_Object (Pool))); 3935 end if; 3936 3937 Set_Associated_Storage_Pool (U_Ent, Pool); 3938 3939 elsif Nkind (Expr) = N_Type_Conversion 3940 and then Is_Entity_Name (Expression (Expr)) 3941 and then Nkind (Original_Node (Expr)) = N_Attribute_Reference 3942 then 3943 Pool := Entity (Expression (Expr)); 3944 Set_Associated_Storage_Pool (U_Ent, Pool); 3945 3946 else 3947 Error_Msg_N ("incorrect reference to a Storage Pool", Expr); 3948 return; 3949 end if; 3950 end; 3951 3952 ------------------ 3953 -- Storage_Size -- 3954 ------------------ 3955 3956 -- Storage_Size attribute definition clause 3957 3958 when Attribute_Storage_Size => Storage_Size : declare 3959 Btype : constant Entity_Id := Base_Type (U_Ent); 3960 3961 begin 3962 if Is_Task_Type (U_Ent) then 3963 Check_Restriction (No_Obsolescent_Features, N); 3964 3965 if Warn_On_Obsolescent_Feature then 3966 Error_Msg_N 3967 ("?j?storage size clause for task is an " & 3968 "obsolescent feature (RM J.9)", N); 3969 Error_Msg_N ("\?j?use Storage_Size pragma instead", N); 3970 end if; 3971 3972 FOnly := True; 3973 end if; 3974 3975 if not Is_Access_Type (U_Ent) 3976 and then Ekind (U_Ent) /= E_Task_Type 3977 then 3978 Error_Msg_N ("storage size cannot be given for &", Nam); 3979 3980 elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then 3981 Error_Msg_N 3982 ("storage size cannot be given for a derived access type", 3983 Nam); 3984 3985 elsif Duplicate_Clause then 3986 null; 3987 3988 else 3989 Analyze_And_Resolve (Expr, Any_Integer); 3990 3991 if Is_Access_Type (U_Ent) then 3992 if Present (Associated_Storage_Pool (U_Ent)) then 3993 Error_Msg_N ("storage pool already given for &", Nam); 3994 return; 3995 end if; 3996 3997 if Is_OK_Static_Expression (Expr) 3998 and then Expr_Value (Expr) = 0 3999 then 4000 Set_No_Pool_Assigned (Btype); 4001 end if; 4002 end if; 4003 4004 Set_Has_Storage_Size_Clause (Btype); 4005 end if; 4006 end Storage_Size; 4007 4008 ----------------- 4009 -- Stream_Size -- 4010 ----------------- 4011 4012 when Attribute_Stream_Size => Stream_Size : declare 4013 Size : constant Uint := Static_Integer (Expr); 4014 4015 begin 4016 if Ada_Version <= Ada_95 then 4017 Check_Restriction (No_Implementation_Attributes, N); 4018 end if; 4019 4020 if Duplicate_Clause then 4021 null; 4022 4023 elsif Is_Elementary_Type (U_Ent) then 4024 if Size /= System_Storage_Unit 4025 and then 4026 Size /= System_Storage_Unit * 2 4027 and then 4028 Size /= System_Storage_Unit * 4 4029 and then 4030 Size /= System_Storage_Unit * 8 4031 then 4032 Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); 4033 Error_Msg_N 4034 ("stream size for elementary type must be a" 4035 & " power of 2 and at least ^", N); 4036 4037 elsif RM_Size (U_Ent) > Size then 4038 Error_Msg_Uint_1 := RM_Size (U_Ent); 4039 Error_Msg_N 4040 ("stream size for elementary type must be a" 4041 & " power of 2 and at least ^", N); 4042 end if; 4043 4044 Set_Has_Stream_Size_Clause (U_Ent); 4045 4046 else 4047 Error_Msg_N ("Stream_Size cannot be given for &", Nam); 4048 end if; 4049 end Stream_Size; 4050 4051 ---------------- 4052 -- Value_Size -- 4053 ---------------- 4054 4055 -- Value_Size attribute definition clause 4056 4057 when Attribute_Value_Size => Value_Size : declare 4058 Size : constant Uint := Static_Integer (Expr); 4059 Biased : Boolean; 4060 4061 begin 4062 if not Is_Type (U_Ent) then 4063 Error_Msg_N ("Value_Size cannot be given for &", Nam); 4064 4065 elsif Duplicate_Clause then 4066 null; 4067 4068 elsif Is_Array_Type (U_Ent) 4069 and then not Is_Constrained (U_Ent) 4070 then 4071 Error_Msg_N 4072 ("Value_Size cannot be given for unconstrained array", Nam); 4073 4074 else 4075 if Is_Elementary_Type (U_Ent) then 4076 Check_Size (Expr, U_Ent, Size, Biased); 4077 Set_Biased (U_Ent, N, "value size clause", Biased); 4078 end if; 4079 4080 Set_RM_Size (U_Ent, Size); 4081 end if; 4082 end Value_Size; 4083 4084 ----------------------- 4085 -- Variable_Indexing -- 4086 ----------------------- 4087 4088 when Attribute_Variable_Indexing => 4089 Check_Indexing_Functions; 4090 4091 ----------- 4092 -- Write -- 4093 ----------- 4094 4095 when Attribute_Write => 4096 Analyze_Stream_TSS_Definition (TSS_Stream_Write); 4097 Set_Has_Specified_Stream_Write (Ent); 4098 4099 -- All other attributes cannot be set 4100 4101 when others => 4102 Error_Msg_N 4103 ("attribute& cannot be set with definition clause", N); 4104 end case; 4105 4106 -- The test for the type being frozen must be performed after any 4107 -- expression the clause has been analyzed since the expression itself 4108 -- might cause freezing that makes the clause illegal. 4109 4110 if Rep_Item_Too_Late (U_Ent, N, FOnly) then 4111 return; 4112 end if; 4113 end Analyze_Attribute_Definition_Clause; 4114 4115 ---------------------------- 4116 -- Analyze_Code_Statement -- 4117 ---------------------------- 4118 4119 procedure Analyze_Code_Statement (N : Node_Id) is 4120 HSS : constant Node_Id := Parent (N); 4121 SBody : constant Node_Id := Parent (HSS); 4122 Subp : constant Entity_Id := Current_Scope; 4123 Stmt : Node_Id; 4124 Decl : Node_Id; 4125 StmtO : Node_Id; 4126 DeclO : Node_Id; 4127 4128 begin 4129 -- Analyze and check we get right type, note that this implements the 4130 -- requirement (RM 13.8(1)) that Machine_Code be with'ed, since that 4131 -- is the only way that Asm_Insn could possibly be visible. 4132 4133 Analyze_And_Resolve (Expression (N)); 4134 4135 if Etype (Expression (N)) = Any_Type then 4136 return; 4137 elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then 4138 Error_Msg_N ("incorrect type for code statement", N); 4139 return; 4140 end if; 4141 4142 Check_Code_Statement (N); 4143 4144 -- Make sure we appear in the handled statement sequence of a 4145 -- subprogram (RM 13.8(3)). 4146 4147 if Nkind (HSS) /= N_Handled_Sequence_Of_Statements 4148 or else Nkind (SBody) /= N_Subprogram_Body 4149 then 4150 Error_Msg_N 4151 ("code statement can only appear in body of subprogram", N); 4152 return; 4153 end if; 4154 4155 -- Do remaining checks (RM 13.8(3)) if not already done 4156 4157 if not Is_Machine_Code_Subprogram (Subp) then 4158 Set_Is_Machine_Code_Subprogram (Subp); 4159 4160 -- No exception handlers allowed 4161 4162 if Present (Exception_Handlers (HSS)) then 4163 Error_Msg_N 4164 ("exception handlers not permitted in machine code subprogram", 4165 First (Exception_Handlers (HSS))); 4166 end if; 4167 4168 -- No declarations other than use clauses and pragmas (we allow 4169 -- certain internally generated declarations as well). 4170 4171 Decl := First (Declarations (SBody)); 4172 while Present (Decl) loop 4173 DeclO := Original_Node (Decl); 4174 if Comes_From_Source (DeclO) 4175 and not Nkind_In (DeclO, N_Pragma, 4176 N_Use_Package_Clause, 4177 N_Use_Type_Clause, 4178 N_Implicit_Label_Declaration) 4179 then 4180 Error_Msg_N 4181 ("this declaration not allowed in machine code subprogram", 4182 DeclO); 4183 end if; 4184 4185 Next (Decl); 4186 end loop; 4187 4188 -- No statements other than code statements, pragmas, and labels. 4189 -- Again we allow certain internally generated statements. 4190 4191 -- In Ada 2012, qualified expressions are names, and the code 4192 -- statement is initially parsed as a procedure call. 4193 4194 Stmt := First (Statements (HSS)); 4195 while Present (Stmt) loop 4196 StmtO := Original_Node (Stmt); 4197 4198 -- A procedure call transformed into a code statement is OK. 4199 4200 if Ada_Version >= Ada_2012 4201 and then Nkind (StmtO) = N_Procedure_Call_Statement 4202 and then Nkind (Name (StmtO)) = N_Qualified_Expression 4203 then 4204 null; 4205 4206 elsif Comes_From_Source (StmtO) 4207 and then not Nkind_In (StmtO, N_Pragma, 4208 N_Label, 4209 N_Code_Statement) 4210 then 4211 Error_Msg_N 4212 ("this statement is not allowed in machine code subprogram", 4213 StmtO); 4214 end if; 4215 4216 Next (Stmt); 4217 end loop; 4218 end if; 4219 end Analyze_Code_Statement; 4220 4221 ----------------------------------------------- 4222 -- Analyze_Enumeration_Representation_Clause -- 4223 ----------------------------------------------- 4224 4225 procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is 4226 Ident : constant Node_Id := Identifier (N); 4227 Aggr : constant Node_Id := Array_Aggregate (N); 4228 Enumtype : Entity_Id; 4229 Elit : Entity_Id; 4230 Expr : Node_Id; 4231 Assoc : Node_Id; 4232 Choice : Node_Id; 4233 Val : Uint; 4234 4235 Err : Boolean := False; 4236 -- Set True to avoid cascade errors and crashes on incorrect source code 4237 4238 Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer)); 4239 Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer)); 4240 -- Allowed range of universal integer (= allowed range of enum lit vals) 4241 4242 Min : Uint; 4243 Max : Uint; 4244 -- Minimum and maximum values of entries 4245 4246 Max_Node : Node_Id; 4247 -- Pointer to node for literal providing max value 4248 4249 begin 4250 if Ignore_Rep_Clauses then 4251 return; 4252 end if; 4253 4254 -- First some basic error checks 4255 4256 Find_Type (Ident); 4257 Enumtype := Entity (Ident); 4258 4259 if Enumtype = Any_Type 4260 or else Rep_Item_Too_Early (Enumtype, N) 4261 then 4262 return; 4263 else 4264 Enumtype := Underlying_Type (Enumtype); 4265 end if; 4266 4267 if not Is_Enumeration_Type (Enumtype) then 4268 Error_Msg_NE 4269 ("enumeration type required, found}", 4270 Ident, First_Subtype (Enumtype)); 4271 return; 4272 end if; 4273 4274 -- Ignore rep clause on generic actual type. This will already have 4275 -- been flagged on the template as an error, and this is the safest 4276 -- way to ensure we don't get a junk cascaded message in the instance. 4277 4278 if Is_Generic_Actual_Type (Enumtype) then 4279 return; 4280 4281 -- Type must be in current scope 4282 4283 elsif Scope (Enumtype) /= Current_Scope then 4284 Error_Msg_N ("type must be declared in this scope", Ident); 4285 return; 4286 4287 -- Type must be a first subtype 4288 4289 elsif not Is_First_Subtype (Enumtype) then 4290 Error_Msg_N ("cannot give enumeration rep clause for subtype", N); 4291 return; 4292 4293 -- Ignore duplicate rep clause 4294 4295 elsif Has_Enumeration_Rep_Clause (Enumtype) then 4296 Error_Msg_N ("duplicate enumeration rep clause ignored", N); 4297 return; 4298 4299 -- Don't allow rep clause for standard [wide_[wide_]]character 4300 4301 elsif Is_Standard_Character_Type (Enumtype) then 4302 Error_Msg_N ("enumeration rep clause not allowed for this type", N); 4303 return; 4304 4305 -- Check that the expression is a proper aggregate (no parentheses) 4306 4307 elsif Paren_Count (Aggr) /= 0 then 4308 Error_Msg 4309 ("extra parentheses surrounding aggregate not allowed", 4310 First_Sloc (Aggr)); 4311 return; 4312 4313 -- All tests passed, so set rep clause in place 4314 4315 else 4316 Set_Has_Enumeration_Rep_Clause (Enumtype); 4317 Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype)); 4318 end if; 4319 4320 -- Now we process the aggregate. Note that we don't use the normal 4321 -- aggregate code for this purpose, because we don't want any of the 4322 -- normal expansion activities, and a number of special semantic 4323 -- rules apply (including the component type being any integer type) 4324 4325 Elit := First_Literal (Enumtype); 4326 4327 -- First the positional entries if any 4328 4329 if Present (Expressions (Aggr)) then 4330 Expr := First (Expressions (Aggr)); 4331 while Present (Expr) loop 4332 if No (Elit) then 4333 Error_Msg_N ("too many entries in aggregate", Expr); 4334 return; 4335 end if; 4336 4337 Val := Static_Integer (Expr); 4338 4339 -- Err signals that we found some incorrect entries processing 4340 -- the list. The final checks for completeness and ordering are 4341 -- skipped in this case. 4342 4343 if Val = No_Uint then 4344 Err := True; 4345 elsif Val < Lo or else Hi < Val then 4346 Error_Msg_N ("value outside permitted range", Expr); 4347 Err := True; 4348 end if; 4349 4350 Set_Enumeration_Rep (Elit, Val); 4351 Set_Enumeration_Rep_Expr (Elit, Expr); 4352 Next (Expr); 4353 Next (Elit); 4354 end loop; 4355 end if; 4356 4357 -- Now process the named entries if present 4358 4359 if Present (Component_Associations (Aggr)) then 4360 Assoc := First (Component_Associations (Aggr)); 4361 while Present (Assoc) loop 4362 Choice := First (Choices (Assoc)); 4363 4364 if Present (Next (Choice)) then 4365 Error_Msg_N 4366 ("multiple choice not allowed here", Next (Choice)); 4367 Err := True; 4368 end if; 4369 4370 if Nkind (Choice) = N_Others_Choice then 4371 Error_Msg_N ("others choice not allowed here", Choice); 4372 Err := True; 4373 4374 elsif Nkind (Choice) = N_Range then 4375 4376 -- ??? should allow zero/one element range here 4377 4378 Error_Msg_N ("range not allowed here", Choice); 4379 Err := True; 4380 4381 else 4382 Analyze_And_Resolve (Choice, Enumtype); 4383 4384 if Error_Posted (Choice) then 4385 Err := True; 4386 end if; 4387 4388 if not Err then 4389 if Is_Entity_Name (Choice) 4390 and then Is_Type (Entity (Choice)) 4391 then 4392 Error_Msg_N ("subtype name not allowed here", Choice); 4393 Err := True; 4394 4395 -- ??? should allow static subtype with zero/one entry 4396 4397 elsif Etype (Choice) = Base_Type (Enumtype) then 4398 if not Is_Static_Expression (Choice) then 4399 Flag_Non_Static_Expr 4400 ("non-static expression used for choice!", Choice); 4401 Err := True; 4402 4403 else 4404 Elit := Expr_Value_E (Choice); 4405 4406 if Present (Enumeration_Rep_Expr (Elit)) then 4407 Error_Msg_Sloc := 4408 Sloc (Enumeration_Rep_Expr (Elit)); 4409 Error_Msg_NE 4410 ("representation for& previously given#", 4411 Choice, Elit); 4412 Err := True; 4413 end if; 4414 4415 Set_Enumeration_Rep_Expr (Elit, Expression (Assoc)); 4416 4417 Expr := Expression (Assoc); 4418 Val := Static_Integer (Expr); 4419 4420 if Val = No_Uint then 4421 Err := True; 4422 4423 elsif Val < Lo or else Hi < Val then 4424 Error_Msg_N ("value outside permitted range", Expr); 4425 Err := True; 4426 end if; 4427 4428 Set_Enumeration_Rep (Elit, Val); 4429 end if; 4430 end if; 4431 end if; 4432 end if; 4433 4434 Next (Assoc); 4435 end loop; 4436 end if; 4437 4438 -- Aggregate is fully processed. Now we check that a full set of 4439 -- representations was given, and that they are in range and in order. 4440 -- These checks are only done if no other errors occurred. 4441 4442 if not Err then 4443 Min := No_Uint; 4444 Max := No_Uint; 4445 4446 Elit := First_Literal (Enumtype); 4447 while Present (Elit) loop 4448 if No (Enumeration_Rep_Expr (Elit)) then 4449 Error_Msg_NE ("missing representation for&!", N, Elit); 4450 4451 else 4452 Val := Enumeration_Rep (Elit); 4453 4454 if Min = No_Uint then 4455 Min := Val; 4456 end if; 4457 4458 if Val /= No_Uint then 4459 if Max /= No_Uint and then Val <= Max then 4460 Error_Msg_NE 4461 ("enumeration value for& not ordered!", 4462 Enumeration_Rep_Expr (Elit), Elit); 4463 end if; 4464 4465 Max_Node := Enumeration_Rep_Expr (Elit); 4466 Max := Val; 4467 end if; 4468 4469 -- If there is at least one literal whose representation is not 4470 -- equal to the Pos value, then note that this enumeration type 4471 -- has a non-standard representation. 4472 4473 if Val /= Enumeration_Pos (Elit) then 4474 Set_Has_Non_Standard_Rep (Base_Type (Enumtype)); 4475 end if; 4476 end if; 4477 4478 Next (Elit); 4479 end loop; 4480 4481 -- Now set proper size information 4482 4483 declare 4484 Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype)); 4485 4486 begin 4487 if Has_Size_Clause (Enumtype) then 4488 4489 -- All OK, if size is OK now 4490 4491 if RM_Size (Enumtype) >= Minsize then 4492 null; 4493 4494 else 4495 -- Try if we can get by with biasing 4496 4497 Minsize := 4498 UI_From_Int (Minimum_Size (Enumtype, Biased => True)); 4499 4500 -- Error message if even biasing does not work 4501 4502 if RM_Size (Enumtype) < Minsize then 4503 Error_Msg_Uint_1 := RM_Size (Enumtype); 4504 Error_Msg_Uint_2 := Max; 4505 Error_Msg_N 4506 ("previously given size (^) is too small " 4507 & "for this value (^)", Max_Node); 4508 4509 -- If biasing worked, indicate that we now have biased rep 4510 4511 else 4512 Set_Biased 4513 (Enumtype, Size_Clause (Enumtype), "size clause"); 4514 end if; 4515 end if; 4516 4517 else 4518 Set_RM_Size (Enumtype, Minsize); 4519 Set_Enum_Esize (Enumtype); 4520 end if; 4521 4522 Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype)); 4523 Set_Esize (Base_Type (Enumtype), Esize (Enumtype)); 4524 Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype)); 4525 end; 4526 end if; 4527 4528 -- We repeat the too late test in case it froze itself! 4529 4530 if Rep_Item_Too_Late (Enumtype, N) then 4531 null; 4532 end if; 4533 end Analyze_Enumeration_Representation_Clause; 4534 4535 ---------------------------- 4536 -- Analyze_Free_Statement -- 4537 ---------------------------- 4538 4539 procedure Analyze_Free_Statement (N : Node_Id) is 4540 begin 4541 Analyze (Expression (N)); 4542 end Analyze_Free_Statement; 4543 4544 --------------------------- 4545 -- Analyze_Freeze_Entity -- 4546 --------------------------- 4547 4548 procedure Analyze_Freeze_Entity (N : Node_Id) is 4549 E : constant Entity_Id := Entity (N); 4550 4551 begin 4552 -- Remember that we are processing a freezing entity. Required to 4553 -- ensure correct decoration of internal entities associated with 4554 -- interfaces (see New_Overloaded_Entity). 4555 4556 Inside_Freezing_Actions := Inside_Freezing_Actions + 1; 4557 4558 -- For tagged types covering interfaces add internal entities that link 4559 -- the primitives of the interfaces with the primitives that cover them. 4560 -- Note: These entities were originally generated only when generating 4561 -- code because their main purpose was to provide support to initialize 4562 -- the secondary dispatch tables. They are now generated also when 4563 -- compiling with no code generation to provide ASIS the relationship 4564 -- between interface primitives and tagged type primitives. They are 4565 -- also used to locate primitives covering interfaces when processing 4566 -- generics (see Derive_Subprograms). 4567 4568 if Ada_Version >= Ada_2005 4569 and then Ekind (E) = E_Record_Type 4570 and then Is_Tagged_Type (E) 4571 and then not Is_Interface (E) 4572 and then Has_Interfaces (E) 4573 then 4574 -- This would be a good common place to call the routine that checks 4575 -- overriding of interface primitives (and thus factorize calls to 4576 -- Check_Abstract_Overriding located at different contexts in the 4577 -- compiler). However, this is not possible because it causes 4578 -- spurious errors in case of late overriding. 4579 4580 Add_Internal_Interface_Entities (E); 4581 end if; 4582 4583 -- Check CPP types 4584 4585 if Ekind (E) = E_Record_Type 4586 and then Is_CPP_Class (E) 4587 and then Is_Tagged_Type (E) 4588 and then Tagged_Type_Expansion 4589 and then Expander_Active 4590 then 4591 if CPP_Num_Prims (E) = 0 then 4592 4593 -- If the CPP type has user defined components then it must import 4594 -- primitives from C++. This is required because if the C++ class 4595 -- has no primitives then the C++ compiler does not added the _tag 4596 -- component to the type. 4597 4598 pragma Assert (Chars (First_Entity (E)) = Name_uTag); 4599 4600 if First_Entity (E) /= Last_Entity (E) then 4601 Error_Msg_N 4602 ("'C'P'P type must import at least one primitive from C++??", 4603 E); 4604 end if; 4605 end if; 4606 4607 -- Check that all its primitives are abstract or imported from C++. 4608 -- Check also availability of the C++ constructor. 4609 4610 declare 4611 Has_Constructors : constant Boolean := Has_CPP_Constructors (E); 4612 Elmt : Elmt_Id; 4613 Error_Reported : Boolean := False; 4614 Prim : Node_Id; 4615 4616 begin 4617 Elmt := First_Elmt (Primitive_Operations (E)); 4618 while Present (Elmt) loop 4619 Prim := Node (Elmt); 4620 4621 if Comes_From_Source (Prim) then 4622 if Is_Abstract_Subprogram (Prim) then 4623 null; 4624 4625 elsif not Is_Imported (Prim) 4626 or else Convention (Prim) /= Convention_CPP 4627 then 4628 Error_Msg_N 4629 ("primitives of 'C'P'P types must be imported from C++ " 4630 & "or abstract??", Prim); 4631 4632 elsif not Has_Constructors 4633 and then not Error_Reported 4634 then 4635 Error_Msg_Name_1 := Chars (E); 4636 Error_Msg_N 4637 ("??'C'P'P constructor required for type %", Prim); 4638 Error_Reported := True; 4639 end if; 4640 end if; 4641 4642 Next_Elmt (Elmt); 4643 end loop; 4644 end; 4645 end if; 4646 4647 -- Check Ada derivation of CPP type 4648 4649 if Expander_Active 4650 and then Tagged_Type_Expansion 4651 and then Ekind (E) = E_Record_Type 4652 and then Etype (E) /= E 4653 and then Is_CPP_Class (Etype (E)) 4654 and then CPP_Num_Prims (Etype (E)) > 0 4655 and then not Is_CPP_Class (E) 4656 and then not Has_CPP_Constructors (Etype (E)) 4657 then 4658 -- If the parent has C++ primitives but it has no constructor then 4659 -- check that all the primitives are overridden in this derivation; 4660 -- otherwise the constructor of the parent is needed to build the 4661 -- dispatch table. 4662 4663 declare 4664 Elmt : Elmt_Id; 4665 Prim : Node_Id; 4666 4667 begin 4668 Elmt := First_Elmt (Primitive_Operations (E)); 4669 while Present (Elmt) loop 4670 Prim := Node (Elmt); 4671 4672 if not Is_Abstract_Subprogram (Prim) 4673 and then No (Interface_Alias (Prim)) 4674 and then Find_Dispatching_Type (Ultimate_Alias (Prim)) /= E 4675 then 4676 Error_Msg_Name_1 := Chars (Etype (E)); 4677 Error_Msg_N 4678 ("'C'P'P constructor required for parent type %", E); 4679 exit; 4680 end if; 4681 4682 Next_Elmt (Elmt); 4683 end loop; 4684 end; 4685 end if; 4686 4687 Inside_Freezing_Actions := Inside_Freezing_Actions - 1; 4688 4689 -- If we have a type with predicates, build predicate function 4690 4691 if Is_Type (E) and then Has_Predicates (E) then 4692 Build_Predicate_Function (E, N); 4693 end if; 4694 4695 -- If type has delayed aspects, this is where we do the preanalysis at 4696 -- the freeze point, as part of the consistent visibility check. Note 4697 -- that this must be done after calling Build_Predicate_Function or 4698 -- Build_Invariant_Procedure since these subprograms fix occurrences of 4699 -- the subtype name in the saved expression so that they will not cause 4700 -- trouble in the preanalysis. 4701 4702 if Has_Delayed_Aspects (E) 4703 and then Scope (E) = Current_Scope 4704 then 4705 -- Retrieve the visibility to the discriminants in order to properly 4706 -- analyze the aspects. 4707 4708 Push_Scope_And_Install_Discriminants (E); 4709 4710 declare 4711 Ritem : Node_Id; 4712 4713 begin 4714 -- Look for aspect specification entries for this entity 4715 4716 Ritem := First_Rep_Item (E); 4717 while Present (Ritem) loop 4718 if Nkind (Ritem) = N_Aspect_Specification 4719 and then Entity (Ritem) = E 4720 and then Is_Delayed_Aspect (Ritem) 4721 then 4722 Check_Aspect_At_Freeze_Point (Ritem); 4723 end if; 4724 4725 Next_Rep_Item (Ritem); 4726 end loop; 4727 end; 4728 4729 Uninstall_Discriminants_And_Pop_Scope (E); 4730 end if; 4731 end Analyze_Freeze_Entity; 4732 4733 ------------------------------------------ 4734 -- Analyze_Record_Representation_Clause -- 4735 ------------------------------------------ 4736 4737 -- Note: we check as much as we can here, but we can't do any checks 4738 -- based on the position values (e.g. overlap checks) until freeze time 4739 -- because especially in Ada 2005 (machine scalar mode), the processing 4740 -- for non-standard bit order can substantially change the positions. 4741 -- See procedure Check_Record_Representation_Clause (called from Freeze) 4742 -- for the remainder of this processing. 4743 4744 procedure Analyze_Record_Representation_Clause (N : Node_Id) is 4745 Ident : constant Node_Id := Identifier (N); 4746 Biased : Boolean; 4747 CC : Node_Id; 4748 Comp : Entity_Id; 4749 Fbit : Uint; 4750 Hbit : Uint := Uint_0; 4751 Lbit : Uint; 4752 Ocomp : Entity_Id; 4753 Posit : Uint; 4754 Rectype : Entity_Id; 4755 Recdef : Node_Id; 4756 4757 function Is_Inherited (Comp : Entity_Id) return Boolean; 4758 -- True if Comp is an inherited component in a record extension 4759 4760 ------------------ 4761 -- Is_Inherited -- 4762 ------------------ 4763 4764 function Is_Inherited (Comp : Entity_Id) return Boolean is 4765 Comp_Base : Entity_Id; 4766 4767 begin 4768 if Ekind (Rectype) = E_Record_Subtype then 4769 Comp_Base := Original_Record_Component (Comp); 4770 else 4771 Comp_Base := Comp; 4772 end if; 4773 4774 return Comp_Base /= Original_Record_Component (Comp_Base); 4775 end Is_Inherited; 4776 4777 -- Local variables 4778 4779 Is_Record_Extension : Boolean; 4780 -- True if Rectype is a record extension 4781 4782 CR_Pragma : Node_Id := Empty; 4783 -- Points to N_Pragma node if Complete_Representation pragma present 4784 4785 -- Start of processing for Analyze_Record_Representation_Clause 4786 4787 begin 4788 if Ignore_Rep_Clauses then 4789 return; 4790 end if; 4791 4792 Find_Type (Ident); 4793 Rectype := Entity (Ident); 4794 4795 if Rectype = Any_Type or else Rep_Item_Too_Early (Rectype, N) then 4796 return; 4797 else 4798 Rectype := Underlying_Type (Rectype); 4799 end if; 4800 4801 -- First some basic error checks 4802 4803 if not Is_Record_Type (Rectype) then 4804 Error_Msg_NE 4805 ("record type required, found}", Ident, First_Subtype (Rectype)); 4806 return; 4807 4808 elsif Scope (Rectype) /= Current_Scope then 4809 Error_Msg_N ("type must be declared in this scope", N); 4810 return; 4811 4812 elsif not Is_First_Subtype (Rectype) then 4813 Error_Msg_N ("cannot give record rep clause for subtype", N); 4814 return; 4815 4816 elsif Has_Record_Rep_Clause (Rectype) then 4817 Error_Msg_N ("duplicate record rep clause ignored", N); 4818 return; 4819 4820 elsif Rep_Item_Too_Late (Rectype, N) then 4821 return; 4822 end if; 4823 4824 -- We know we have a first subtype, now possibly go the the anonymous 4825 -- base type to determine whether Rectype is a record extension. 4826 4827 Recdef := Type_Definition (Declaration_Node (Base_Type (Rectype))); 4828 Is_Record_Extension := 4829 Nkind (Recdef) = N_Derived_Type_Definition 4830 and then Present (Record_Extension_Part (Recdef)); 4831 4832 if Present (Mod_Clause (N)) then 4833 declare 4834 Loc : constant Source_Ptr := Sloc (N); 4835 M : constant Node_Id := Mod_Clause (N); 4836 P : constant List_Id := Pragmas_Before (M); 4837 AtM_Nod : Node_Id; 4838 4839 Mod_Val : Uint; 4840 pragma Warnings (Off, Mod_Val); 4841 4842 begin 4843 Check_Restriction (No_Obsolescent_Features, Mod_Clause (N)); 4844 4845 if Warn_On_Obsolescent_Feature then 4846 Error_Msg_N 4847 ("?j?mod clause is an obsolescent feature (RM J.8)", N); 4848 Error_Msg_N 4849 ("\?j?use alignment attribute definition clause instead", N); 4850 end if; 4851 4852 if Present (P) then 4853 Analyze_List (P); 4854 end if; 4855 4856 -- In ASIS_Mode mode, expansion is disabled, but we must convert 4857 -- the Mod clause into an alignment clause anyway, so that the 4858 -- back-end can compute and back-annotate properly the size and 4859 -- alignment of types that may include this record. 4860 4861 -- This seems dubious, this destroys the source tree in a manner 4862 -- not detectable by ASIS ??? 4863 4864 if Operating_Mode = Check_Semantics and then ASIS_Mode then 4865 AtM_Nod := 4866 Make_Attribute_Definition_Clause (Loc, 4867 Name => New_Reference_To (Base_Type (Rectype), Loc), 4868 Chars => Name_Alignment, 4869 Expression => Relocate_Node (Expression (M))); 4870 4871 Set_From_At_Mod (AtM_Nod); 4872 Insert_After (N, AtM_Nod); 4873 Mod_Val := Get_Alignment_Value (Expression (AtM_Nod)); 4874 Set_Mod_Clause (N, Empty); 4875 4876 else 4877 -- Get the alignment value to perform error checking 4878 4879 Mod_Val := Get_Alignment_Value (Expression (M)); 4880 end if; 4881 end; 4882 end if; 4883 4884 -- For untagged types, clear any existing component clauses for the 4885 -- type. If the type is derived, this is what allows us to override 4886 -- a rep clause for the parent. For type extensions, the representation 4887 -- of the inherited components is inherited, so we want to keep previous 4888 -- component clauses for completeness. 4889 4890 if not Is_Tagged_Type (Rectype) then 4891 Comp := First_Component_Or_Discriminant (Rectype); 4892 while Present (Comp) loop 4893 Set_Component_Clause (Comp, Empty); 4894 Next_Component_Or_Discriminant (Comp); 4895 end loop; 4896 end if; 4897 4898 -- All done if no component clauses 4899 4900 CC := First (Component_Clauses (N)); 4901 4902 if No (CC) then 4903 return; 4904 end if; 4905 4906 -- A representation like this applies to the base type 4907 4908 Set_Has_Record_Rep_Clause (Base_Type (Rectype)); 4909 Set_Has_Non_Standard_Rep (Base_Type (Rectype)); 4910 Set_Has_Specified_Layout (Base_Type (Rectype)); 4911 4912 -- Process the component clauses 4913 4914 while Present (CC) loop 4915 4916 -- Pragma 4917 4918 if Nkind (CC) = N_Pragma then 4919 Analyze (CC); 4920 4921 -- The only pragma of interest is Complete_Representation 4922 4923 if Pragma_Name (CC) = Name_Complete_Representation then 4924 CR_Pragma := CC; 4925 end if; 4926 4927 -- Processing for real component clause 4928 4929 else 4930 Posit := Static_Integer (Position (CC)); 4931 Fbit := Static_Integer (First_Bit (CC)); 4932 Lbit := Static_Integer (Last_Bit (CC)); 4933 4934 if Posit /= No_Uint 4935 and then Fbit /= No_Uint 4936 and then Lbit /= No_Uint 4937 then 4938 if Posit < 0 then 4939 Error_Msg_N 4940 ("position cannot be negative", Position (CC)); 4941 4942 elsif Fbit < 0 then 4943 Error_Msg_N 4944 ("first bit cannot be negative", First_Bit (CC)); 4945 4946 -- The Last_Bit specified in a component clause must not be 4947 -- less than the First_Bit minus one (RM-13.5.1(10)). 4948 4949 elsif Lbit < Fbit - 1 then 4950 Error_Msg_N 4951 ("last bit cannot be less than first bit minus one", 4952 Last_Bit (CC)); 4953 4954 -- Values look OK, so find the corresponding record component 4955 -- Even though the syntax allows an attribute reference for 4956 -- implementation-defined components, GNAT does not allow the 4957 -- tag to get an explicit position. 4958 4959 elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then 4960 if Attribute_Name (Component_Name (CC)) = Name_Tag then 4961 Error_Msg_N ("position of tag cannot be specified", CC); 4962 else 4963 Error_Msg_N ("illegal component name", CC); 4964 end if; 4965 4966 else 4967 Comp := First_Entity (Rectype); 4968 while Present (Comp) loop 4969 exit when Chars (Comp) = Chars (Component_Name (CC)); 4970 Next_Entity (Comp); 4971 end loop; 4972 4973 if No (Comp) then 4974 4975 -- Maybe component of base type that is absent from 4976 -- statically constrained first subtype. 4977 4978 Comp := First_Entity (Base_Type (Rectype)); 4979 while Present (Comp) loop 4980 exit when Chars (Comp) = Chars (Component_Name (CC)); 4981 Next_Entity (Comp); 4982 end loop; 4983 end if; 4984 4985 if No (Comp) then 4986 Error_Msg_N 4987 ("component clause is for non-existent field", CC); 4988 4989 -- Ada 2012 (AI05-0026): Any name that denotes a 4990 -- discriminant of an object of an unchecked union type 4991 -- shall not occur within a record_representation_clause. 4992 4993 -- The general restriction of using record rep clauses on 4994 -- Unchecked_Union types has now been lifted. Since it is 4995 -- possible to introduce a record rep clause which mentions 4996 -- the discriminant of an Unchecked_Union in non-Ada 2012 4997 -- code, this check is applied to all versions of the 4998 -- language. 4999 5000 elsif Ekind (Comp) = E_Discriminant 5001 and then Is_Unchecked_Union (Rectype) 5002 then 5003 Error_Msg_N 5004 ("cannot reference discriminant of unchecked union", 5005 Component_Name (CC)); 5006 5007 elsif Is_Record_Extension and then Is_Inherited (Comp) then 5008 Error_Msg_NE 5009 ("component clause not allowed for inherited " 5010 & "component&", CC, Comp); 5011 5012 elsif Present (Component_Clause (Comp)) then 5013 5014 -- Diagnose duplicate rep clause, or check consistency 5015 -- if this is an inherited component. In a double fault, 5016 -- there may be a duplicate inconsistent clause for an 5017 -- inherited component. 5018 5019 if Scope (Original_Record_Component (Comp)) = Rectype 5020 or else Parent (Component_Clause (Comp)) = N 5021 then 5022 Error_Msg_Sloc := Sloc (Component_Clause (Comp)); 5023 Error_Msg_N ("component clause previously given#", CC); 5024 5025 else 5026 declare 5027 Rep1 : constant Node_Id := Component_Clause (Comp); 5028 begin 5029 if Intval (Position (Rep1)) /= 5030 Intval (Position (CC)) 5031 or else Intval (First_Bit (Rep1)) /= 5032 Intval (First_Bit (CC)) 5033 or else Intval (Last_Bit (Rep1)) /= 5034 Intval (Last_Bit (CC)) 5035 then 5036 Error_Msg_N 5037 ("component clause inconsistent " 5038 & "with representation of ancestor", CC); 5039 5040 elsif Warn_On_Redundant_Constructs then 5041 Error_Msg_N 5042 ("?r?redundant confirming component clause " 5043 & "for component!", CC); 5044 end if; 5045 end; 5046 end if; 5047 5048 -- Normal case where this is the first component clause we 5049 -- have seen for this entity, so set it up properly. 5050 5051 else 5052 -- Make reference for field in record rep clause and set 5053 -- appropriate entity field in the field identifier. 5054 5055 Generate_Reference 5056 (Comp, Component_Name (CC), Set_Ref => False); 5057 Set_Entity (Component_Name (CC), Comp); 5058 5059 -- Update Fbit and Lbit to the actual bit number 5060 5061 Fbit := Fbit + UI_From_Int (SSU) * Posit; 5062 Lbit := Lbit + UI_From_Int (SSU) * Posit; 5063 5064 if Has_Size_Clause (Rectype) 5065 and then RM_Size (Rectype) <= Lbit 5066 then 5067 Error_Msg_N 5068 ("bit number out of range of specified size", 5069 Last_Bit (CC)); 5070 else 5071 Set_Component_Clause (Comp, CC); 5072 Set_Component_Bit_Offset (Comp, Fbit); 5073 Set_Esize (Comp, 1 + (Lbit - Fbit)); 5074 Set_Normalized_First_Bit (Comp, Fbit mod SSU); 5075 Set_Normalized_Position (Comp, Fbit / SSU); 5076 5077 if Warn_On_Overridden_Size 5078 and then Has_Size_Clause (Etype (Comp)) 5079 and then RM_Size (Etype (Comp)) /= Esize (Comp) 5080 then 5081 Error_Msg_NE 5082 ("?S?component size overrides size clause for&", 5083 Component_Name (CC), Etype (Comp)); 5084 end if; 5085 5086 -- This information is also set in the corresponding 5087 -- component of the base type, found by accessing the 5088 -- Original_Record_Component link if it is present. 5089 5090 Ocomp := Original_Record_Component (Comp); 5091 5092 if Hbit < Lbit then 5093 Hbit := Lbit; 5094 end if; 5095 5096 Check_Size 5097 (Component_Name (CC), 5098 Etype (Comp), 5099 Esize (Comp), 5100 Biased); 5101 5102 Set_Biased 5103 (Comp, First_Node (CC), "component clause", Biased); 5104 5105 if Present (Ocomp) then 5106 Set_Component_Clause (Ocomp, CC); 5107 Set_Component_Bit_Offset (Ocomp, Fbit); 5108 Set_Normalized_First_Bit (Ocomp, Fbit mod SSU); 5109 Set_Normalized_Position (Ocomp, Fbit / SSU); 5110 Set_Esize (Ocomp, 1 + (Lbit - Fbit)); 5111 5112 Set_Normalized_Position_Max 5113 (Ocomp, Normalized_Position (Ocomp)); 5114 5115 -- Note: we don't use Set_Biased here, because we 5116 -- already gave a warning above if needed, and we 5117 -- would get a duplicate for the same name here. 5118 5119 Set_Has_Biased_Representation 5120 (Ocomp, Has_Biased_Representation (Comp)); 5121 end if; 5122 5123 if Esize (Comp) < 0 then 5124 Error_Msg_N ("component size is negative", CC); 5125 end if; 5126 end if; 5127 end if; 5128 end if; 5129 end if; 5130 end if; 5131 5132 Next (CC); 5133 end loop; 5134 5135 -- Check missing components if Complete_Representation pragma appeared 5136 5137 if Present (CR_Pragma) then 5138 Comp := First_Component_Or_Discriminant (Rectype); 5139 while Present (Comp) loop 5140 if No (Component_Clause (Comp)) then 5141 Error_Msg_NE 5142 ("missing component clause for &", CR_Pragma, Comp); 5143 end if; 5144 5145 Next_Component_Or_Discriminant (Comp); 5146 end loop; 5147 5148 -- Give missing components warning if required 5149 5150 elsif Warn_On_Unrepped_Components then 5151 declare 5152 Num_Repped_Components : Nat := 0; 5153 Num_Unrepped_Components : Nat := 0; 5154 5155 begin 5156 -- First count number of repped and unrepped components 5157 5158 Comp := First_Component_Or_Discriminant (Rectype); 5159 while Present (Comp) loop 5160 if Present (Component_Clause (Comp)) then 5161 Num_Repped_Components := Num_Repped_Components + 1; 5162 else 5163 Num_Unrepped_Components := Num_Unrepped_Components + 1; 5164 end if; 5165 5166 Next_Component_Or_Discriminant (Comp); 5167 end loop; 5168 5169 -- We are only interested in the case where there is at least one 5170 -- unrepped component, and at least half the components have rep 5171 -- clauses. We figure that if less than half have them, then the 5172 -- partial rep clause is really intentional. If the component 5173 -- type has no underlying type set at this point (as for a generic 5174 -- formal type), we don't know enough to give a warning on the 5175 -- component. 5176 5177 if Num_Unrepped_Components > 0 5178 and then Num_Unrepped_Components < Num_Repped_Components 5179 then 5180 Comp := First_Component_Or_Discriminant (Rectype); 5181 while Present (Comp) loop 5182 if No (Component_Clause (Comp)) 5183 and then Comes_From_Source (Comp) 5184 and then Present (Underlying_Type (Etype (Comp))) 5185 and then (Is_Scalar_Type (Underlying_Type (Etype (Comp))) 5186 or else Size_Known_At_Compile_Time 5187 (Underlying_Type (Etype (Comp)))) 5188 and then not Has_Warnings_Off (Rectype) 5189 then 5190 Error_Msg_Sloc := Sloc (Comp); 5191 Error_Msg_NE 5192 ("?C?no component clause given for & declared #", 5193 N, Comp); 5194 end if; 5195 5196 Next_Component_Or_Discriminant (Comp); 5197 end loop; 5198 end if; 5199 end; 5200 end if; 5201 end Analyze_Record_Representation_Clause; 5202 5203 ------------------------------------------- 5204 -- Build_Invariant_Procedure_Declaration -- 5205 ------------------------------------------- 5206 5207 function Build_Invariant_Procedure_Declaration 5208 (Typ : Entity_Id) return Node_Id 5209 is 5210 Loc : constant Source_Ptr := Sloc (Typ); 5211 Object_Entity : constant Entity_Id := 5212 Make_Defining_Identifier (Loc, New_Internal_Name ('I')); 5213 Spec : Node_Id; 5214 SId : Entity_Id; 5215 5216 begin 5217 Set_Etype (Object_Entity, Typ); 5218 5219 -- Check for duplicate definiations. 5220 5221 if Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)) then 5222 return Empty; 5223 end if; 5224 5225 SId := 5226 Make_Defining_Identifier (Loc, 5227 Chars => New_External_Name (Chars (Typ), "Invariant")); 5228 Set_Has_Invariants (SId); 5229 Set_Has_Invariants (Typ); 5230 Set_Ekind (SId, E_Procedure); 5231 Set_Invariant_Procedure (Typ, SId); 5232 5233 Spec := 5234 Make_Procedure_Specification (Loc, 5235 Defining_Unit_Name => SId, 5236 Parameter_Specifications => New_List ( 5237 Make_Parameter_Specification (Loc, 5238 Defining_Identifier => Object_Entity, 5239 Parameter_Type => New_Occurrence_Of (Typ, Loc)))); 5240 5241 return Make_Subprogram_Declaration (Loc, Specification => Spec); 5242 end Build_Invariant_Procedure_Declaration; 5243 5244 ------------------------------- 5245 -- Build_Invariant_Procedure -- 5246 ------------------------------- 5247 5248 -- The procedure that is constructed here has the form 5249 5250 -- procedure typInvariant (Ixxx : typ) is 5251 -- begin 5252 -- pragma Check (Invariant, exp, "failed invariant from xxx"); 5253 -- pragma Check (Invariant, exp, "failed invariant from xxx"); 5254 -- ... 5255 -- pragma Check (Invariant, exp, "failed inherited invariant from xxx"); 5256 -- ... 5257 -- end typInvariant; 5258 5259 procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is 5260 Loc : constant Source_Ptr := Sloc (Typ); 5261 Stmts : List_Id; 5262 Spec : Node_Id; 5263 SId : Entity_Id; 5264 PDecl : Node_Id; 5265 PBody : Node_Id; 5266 5267 Visible_Decls : constant List_Id := Visible_Declarations (N); 5268 Private_Decls : constant List_Id := Private_Declarations (N); 5269 5270 procedure Add_Invariants (T : Entity_Id; Inherit : Boolean); 5271 -- Appends statements to Stmts for any invariants in the rep item chain 5272 -- of the given type. If Inherit is False, then we only process entries 5273 -- on the chain for the type Typ. If Inherit is True, then we ignore any 5274 -- Invariant aspects, but we process all Invariant'Class aspects, adding 5275 -- "inherited" to the exception message and generating an informational 5276 -- message about the inheritance of an invariant. 5277 5278 Object_Name : Name_Id; 5279 -- Name for argument of invariant procedure 5280 5281 Object_Entity : Node_Id; 5282 -- The entity of the formal for the procedure 5283 5284 -------------------- 5285 -- Add_Invariants -- 5286 -------------------- 5287 5288 procedure Add_Invariants (T : Entity_Id; Inherit : Boolean) is 5289 Ritem : Node_Id; 5290 Arg1 : Node_Id; 5291 Arg2 : Node_Id; 5292 Arg3 : Node_Id; 5293 Exp : Node_Id; 5294 Loc : Source_Ptr; 5295 Assoc : List_Id; 5296 Str : String_Id; 5297 5298 procedure Replace_Type_Reference (N : Node_Id); 5299 -- Replace a single occurrence N of the subtype name with a reference 5300 -- to the formal of the predicate function. N can be an identifier 5301 -- referencing the subtype, or a selected component, representing an 5302 -- appropriately qualified occurrence of the subtype name. 5303 5304 procedure Replace_Type_References is 5305 new Replace_Type_References_Generic (Replace_Type_Reference); 5306 -- Traverse an expression replacing all occurrences of the subtype 5307 -- name with appropriate references to the object that is the formal 5308 -- parameter of the predicate function. Note that we must ensure 5309 -- that the type and entity information is properly set in the 5310 -- replacement node, since we will do a Preanalyze call of this 5311 -- expression without proper visibility of the procedure argument. 5312 5313 ---------------------------- 5314 -- Replace_Type_Reference -- 5315 ---------------------------- 5316 5317 -- Note: See comments in Add_Predicates.Replace_Type_Reference 5318 -- regarding handling of Sloc and Comes_From_Source. 5319 5320 procedure Replace_Type_Reference (N : Node_Id) is 5321 begin 5322 -- Invariant'Class, replace with T'Class (obj) 5323 5324 if Class_Present (Ritem) then 5325 Rewrite (N, 5326 Make_Type_Conversion (Sloc (N), 5327 Subtype_Mark => 5328 Make_Attribute_Reference (Sloc (N), 5329 Prefix => New_Occurrence_Of (T, Sloc (N)), 5330 Attribute_Name => Name_Class), 5331 Expression => Make_Identifier (Sloc (N), Object_Name))); 5332 5333 Set_Entity (Expression (N), Object_Entity); 5334 Set_Etype (Expression (N), Typ); 5335 5336 -- Invariant, replace with obj 5337 5338 else 5339 Rewrite (N, Make_Identifier (Sloc (N), Object_Name)); 5340 Set_Entity (N, Object_Entity); 5341 Set_Etype (N, Typ); 5342 end if; 5343 5344 Set_Comes_From_Source (N, True); 5345 end Replace_Type_Reference; 5346 5347 -- Start of processing for Add_Invariants 5348 5349 begin 5350 Ritem := First_Rep_Item (T); 5351 while Present (Ritem) loop 5352 if Nkind (Ritem) = N_Pragma 5353 and then Pragma_Name (Ritem) = Name_Invariant 5354 then 5355 Arg1 := First (Pragma_Argument_Associations (Ritem)); 5356 Arg2 := Next (Arg1); 5357 Arg3 := Next (Arg2); 5358 5359 Arg1 := Get_Pragma_Arg (Arg1); 5360 Arg2 := Get_Pragma_Arg (Arg2); 5361 5362 -- For Inherit case, ignore Invariant, process only Class case 5363 5364 if Inherit then 5365 if not Class_Present (Ritem) then 5366 goto Continue; 5367 end if; 5368 5369 -- For Inherit false, process only item for right type 5370 5371 else 5372 if Entity (Arg1) /= Typ then 5373 goto Continue; 5374 end if; 5375 end if; 5376 5377 if No (Stmts) then 5378 Stmts := Empty_List; 5379 end if; 5380 5381 Exp := New_Copy_Tree (Arg2); 5382 5383 -- Preserve sloc of original pragma Invariant 5384 5385 Loc := Sloc (Ritem); 5386 5387 -- We need to replace any occurrences of the name of the type 5388 -- with references to the object, converted to type'Class in 5389 -- the case of Invariant'Class aspects. 5390 5391 Replace_Type_References (Exp, Chars (T)); 5392 5393 -- If this invariant comes from an aspect, find the aspect 5394 -- specification, and replace the saved expression because 5395 -- we need the subtype references replaced for the calls to 5396 -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point 5397 -- and Check_Aspect_At_End_Of_Declarations. 5398 5399 if From_Aspect_Specification (Ritem) then 5400 declare 5401 Aitem : Node_Id; 5402 5403 begin 5404 -- Loop to find corresponding aspect, note that this 5405 -- must be present given the pragma is marked delayed. 5406 5407 Aitem := Next_Rep_Item (Ritem); 5408 while Present (Aitem) loop 5409 if Nkind (Aitem) = N_Aspect_Specification 5410 and then Aspect_Rep_Item (Aitem) = Ritem 5411 then 5412 Set_Entity 5413 (Identifier (Aitem), New_Copy_Tree (Exp)); 5414 exit; 5415 end if; 5416 5417 Aitem := Next_Rep_Item (Aitem); 5418 end loop; 5419 end; 5420 end if; 5421 5422 -- Now we need to preanalyze the expression to properly capture 5423 -- the visibility in the visible part. The expression will not 5424 -- be analyzed for real until the body is analyzed, but that is 5425 -- at the end of the private part and has the wrong visibility. 5426 5427 Set_Parent (Exp, N); 5428 Preanalyze_Assert_Expression (Exp, Standard_Boolean); 5429 5430 -- Build first two arguments for Check pragma 5431 5432 Assoc := New_List ( 5433 Make_Pragma_Argument_Association (Loc, 5434 Expression => Make_Identifier (Loc, Name_Invariant)), 5435 Make_Pragma_Argument_Association (Loc, 5436 Expression => Exp)); 5437 5438 -- Add message if present in Invariant pragma 5439 5440 if Present (Arg3) then 5441 Str := Strval (Get_Pragma_Arg (Arg3)); 5442 5443 -- If inherited case, and message starts "failed invariant", 5444 -- change it to be "failed inherited invariant". 5445 5446 if Inherit then 5447 String_To_Name_Buffer (Str); 5448 5449 if Name_Buffer (1 .. 16) = "failed invariant" then 5450 Insert_Str_In_Name_Buffer ("inherited ", 8); 5451 Str := String_From_Name_Buffer; 5452 end if; 5453 end if; 5454 5455 Append_To (Assoc, 5456 Make_Pragma_Argument_Association (Loc, 5457 Expression => Make_String_Literal (Loc, Str))); 5458 end if; 5459 5460 -- Add Check pragma to list of statements 5461 5462 Append_To (Stmts, 5463 Make_Pragma (Loc, 5464 Pragma_Identifier => 5465 Make_Identifier (Loc, Name_Check), 5466 Pragma_Argument_Associations => Assoc)); 5467 5468 -- If Inherited case and option enabled, output info msg. Note 5469 -- that we know this is a case of Invariant'Class. 5470 5471 if Inherit and Opt.List_Inherited_Aspects then 5472 Error_Msg_Sloc := Sloc (Ritem); 5473 Error_Msg_N 5474 ("?L?info: & inherits `Invariant''Class` aspect from #", 5475 Typ); 5476 end if; 5477 end if; 5478 5479 <<Continue>> 5480 Next_Rep_Item (Ritem); 5481 end loop; 5482 end Add_Invariants; 5483 5484 -- Start of processing for Build_Invariant_Procedure 5485 5486 begin 5487 Stmts := No_List; 5488 PDecl := Empty; 5489 PBody := Empty; 5490 SId := Empty; 5491 5492 -- If the aspect specification exists for some view of the type, the 5493 -- declaration for the procedure has been created. 5494 5495 if Has_Invariants (Typ) then 5496 SId := Invariant_Procedure (Typ); 5497 end if; 5498 5499 if Present (SId) then 5500 PDecl := Unit_Declaration_Node (SId); 5501 5502 else 5503 PDecl := Build_Invariant_Procedure_Declaration (Typ); 5504 end if; 5505 5506 -- Recover formal of procedure, for use in the calls to invariant 5507 -- functions (including inherited ones). 5508 5509 Object_Entity := 5510 Defining_Identifier 5511 (First (Parameter_Specifications (Specification (PDecl)))); 5512 Object_Name := Chars (Object_Entity); 5513 5514 -- Add invariants for the current type 5515 5516 Add_Invariants (Typ, Inherit => False); 5517 5518 -- Add invariants for parent types 5519 5520 declare 5521 Current_Typ : Entity_Id; 5522 Parent_Typ : Entity_Id; 5523 5524 begin 5525 Current_Typ := Typ; 5526 loop 5527 Parent_Typ := Etype (Current_Typ); 5528 5529 if Is_Private_Type (Parent_Typ) 5530 and then Present (Full_View (Base_Type (Parent_Typ))) 5531 then 5532 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 5533 end if; 5534 5535 exit when Parent_Typ = Current_Typ; 5536 5537 Current_Typ := Parent_Typ; 5538 Add_Invariants (Current_Typ, Inherit => True); 5539 end loop; 5540 end; 5541 5542 -- Build the procedure if we generated at least one Check pragma 5543 5544 if Stmts /= No_List then 5545 Spec := Copy_Separate_Tree (Specification (PDecl)); 5546 5547 PBody := 5548 Make_Subprogram_Body (Loc, 5549 Specification => Spec, 5550 Declarations => Empty_List, 5551 Handled_Statement_Sequence => 5552 Make_Handled_Sequence_Of_Statements (Loc, 5553 Statements => Stmts)); 5554 5555 -- Insert procedure declaration and spec at the appropriate points. 5556 -- If declaration is already analyzed, it was processed by the 5557 -- generated pragma. 5558 5559 if Present (Private_Decls) then 5560 5561 -- The spec goes at the end of visible declarations, but they have 5562 -- already been analyzed, so we need to explicitly do the analyze. 5563 5564 if not Analyzed (PDecl) then 5565 Append_To (Visible_Decls, PDecl); 5566 Analyze (PDecl); 5567 end if; 5568 5569 -- The body goes at the end of the private declarations, which we 5570 -- have not analyzed yet, so we do not need to perform an explicit 5571 -- analyze call. We skip this if there are no private declarations 5572 -- (this is an error that will be caught elsewhere); 5573 5574 Append_To (Private_Decls, PBody); 5575 5576 -- If the invariant appears on the full view of a type, the 5577 -- analysis of the private part is complete, and we must 5578 -- analyze the new body explicitly. 5579 5580 if In_Private_Part (Current_Scope) then 5581 Analyze (PBody); 5582 end if; 5583 5584 -- If there are no private declarations this may be an error that 5585 -- will be diagnosed elsewhere. However, if this is a non-private 5586 -- type that inherits invariants, it needs no completion and there 5587 -- may be no private part. In this case insert invariant procedure 5588 -- at end of current declarative list, and analyze at once, given 5589 -- that the type is about to be frozen. 5590 5591 elsif not Is_Private_Type (Typ) then 5592 Append_To (Visible_Decls, PDecl); 5593 Append_To (Visible_Decls, PBody); 5594 Analyze (PDecl); 5595 Analyze (PBody); 5596 end if; 5597 end if; 5598 end Build_Invariant_Procedure; 5599 5600 ------------------------------ 5601 -- Build_Predicate_Function -- 5602 ------------------------------ 5603 5604 -- The procedure that is constructed here has the form: 5605 5606 -- function typPredicate (Ixxx : typ) return Boolean is 5607 -- begin 5608 -- return 5609 -- exp1 and then exp2 and then ... 5610 -- and then typ1Predicate (typ1 (Ixxx)) 5611 -- and then typ2Predicate (typ2 (Ixxx)) 5612 -- and then ...; 5613 -- end typPredicate; 5614 5615 -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that 5616 -- this is the point at which these expressions get analyzed, providing the 5617 -- required delay, and typ1, typ2, are entities from which predicates are 5618 -- inherited. Note that we do NOT generate Check pragmas, that's because we 5619 -- use this function even if checks are off, e.g. for membership tests. 5620 5621 procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is 5622 Loc : constant Source_Ptr := Sloc (Typ); 5623 Spec : Node_Id; 5624 SId : Entity_Id; 5625 FDecl : Node_Id; 5626 FBody : Node_Id; 5627 5628 Expr : Node_Id; 5629 -- This is the expression for the return statement in the function. It 5630 -- is build by connecting the component predicates with AND THEN. 5631 5632 procedure Add_Call (T : Entity_Id); 5633 -- Includes a call to the predicate function for type T in Expr if T 5634 -- has predicates and Predicate_Function (T) is non-empty. 5635 5636 procedure Add_Predicates; 5637 -- Appends expressions for any Predicate pragmas in the rep item chain 5638 -- Typ to Expr. Note that we look only at items for this exact entity. 5639 -- Inheritance of predicates for the parent type is done by calling the 5640 -- Predicate_Function of the parent type, using Add_Call above. 5641 5642 Object_Name : constant Name_Id := New_Internal_Name ('I'); 5643 -- Name for argument of Predicate procedure 5644 5645 Object_Entity : constant Entity_Id := 5646 Make_Defining_Identifier (Loc, Object_Name); 5647 -- The entity for the spec entity for the argument 5648 5649 Dynamic_Predicate_Present : Boolean := False; 5650 -- Set True if a dynamic predicate is present, results in the entire 5651 -- predicate being considered dynamic even if it looks static 5652 5653 Static_Predicate_Present : Node_Id := Empty; 5654 -- Set to N_Pragma node for a static predicate if one is encountered. 5655 5656 -------------- 5657 -- Add_Call -- 5658 -------------- 5659 5660 procedure Add_Call (T : Entity_Id) is 5661 Exp : Node_Id; 5662 5663 begin 5664 if Present (T) and then Present (Predicate_Function (T)) then 5665 Set_Has_Predicates (Typ); 5666 5667 -- Build the call to the predicate function of T 5668 5669 Exp := 5670 Make_Predicate_Call 5671 (T, Convert_To (T, Make_Identifier (Loc, Object_Name))); 5672 5673 -- Add call to evolving expression, using AND THEN if needed 5674 5675 if No (Expr) then 5676 Expr := Exp; 5677 else 5678 Expr := 5679 Make_And_Then (Loc, 5680 Left_Opnd => Relocate_Node (Expr), 5681 Right_Opnd => Exp); 5682 end if; 5683 5684 -- Output info message on inheritance if required. Note we do not 5685 -- give this information for generic actual types, since it is 5686 -- unwelcome noise in that case in instantiations. We also 5687 -- generally suppress the message in instantiations, and also 5688 -- if it involves internal names. 5689 5690 if Opt.List_Inherited_Aspects 5691 and then not Is_Generic_Actual_Type (Typ) 5692 and then Instantiation_Depth (Sloc (Typ)) = 0 5693 and then not Is_Internal_Name (Chars (T)) 5694 and then not Is_Internal_Name (Chars (Typ)) 5695 then 5696 Error_Msg_Sloc := Sloc (Predicate_Function (T)); 5697 Error_Msg_Node_2 := T; 5698 Error_Msg_N ("info: & inherits predicate from & #?L?", Typ); 5699 end if; 5700 end if; 5701 end Add_Call; 5702 5703 -------------------- 5704 -- Add_Predicates -- 5705 -------------------- 5706 5707 procedure Add_Predicates is 5708 Ritem : Node_Id; 5709 Arg1 : Node_Id; 5710 Arg2 : Node_Id; 5711 5712 procedure Replace_Type_Reference (N : Node_Id); 5713 -- Replace a single occurrence N of the subtype name with a reference 5714 -- to the formal of the predicate function. N can be an identifier 5715 -- referencing the subtype, or a selected component, representing an 5716 -- appropriately qualified occurrence of the subtype name. 5717 5718 procedure Replace_Type_References is 5719 new Replace_Type_References_Generic (Replace_Type_Reference); 5720 -- Traverse an expression changing every occurrence of an identifier 5721 -- whose name matches the name of the subtype with a reference to 5722 -- the formal parameter of the predicate function. 5723 5724 ---------------------------- 5725 -- Replace_Type_Reference -- 5726 ---------------------------- 5727 5728 procedure Replace_Type_Reference (N : Node_Id) is 5729 begin 5730 Rewrite (N, Make_Identifier (Sloc (N), Object_Name)); 5731 -- Use the Sloc of the usage name, not the defining name 5732 5733 Set_Entity (N, Object_Entity); 5734 Set_Etype (N, Typ); 5735 5736 -- We want to treat the node as if it comes from source, so that 5737 -- ASIS will not ignore it 5738 5739 Set_Comes_From_Source (N, True); 5740 end Replace_Type_Reference; 5741 5742 -- Start of processing for Add_Predicates 5743 5744 begin 5745 Ritem := First_Rep_Item (Typ); 5746 while Present (Ritem) loop 5747 if Nkind (Ritem) = N_Pragma 5748 and then Pragma_Name (Ritem) = Name_Predicate 5749 then 5750 if Present (Corresponding_Aspect (Ritem)) then 5751 case Chars (Identifier (Corresponding_Aspect (Ritem))) is 5752 when Name_Dynamic_Predicate => 5753 Dynamic_Predicate_Present := True; 5754 when Name_Static_Predicate => 5755 Static_Predicate_Present := Ritem; 5756 when others => 5757 null; 5758 end case; 5759 end if; 5760 5761 -- Acquire arguments 5762 5763 Arg1 := First (Pragma_Argument_Associations (Ritem)); 5764 Arg2 := Next (Arg1); 5765 5766 Arg1 := Get_Pragma_Arg (Arg1); 5767 Arg2 := Get_Pragma_Arg (Arg2); 5768 5769 -- See if this predicate pragma is for the current type or for 5770 -- its full view. A predicate on a private completion is placed 5771 -- on the partial view beause this is the visible entity that 5772 -- is frozen. 5773 5774 if Entity (Arg1) = Typ 5775 or else Full_View (Entity (Arg1)) = Typ 5776 then 5777 -- We have a match, this entry is for our subtype 5778 5779 -- We need to replace any occurrences of the name of the 5780 -- type with references to the object. 5781 5782 Replace_Type_References (Arg2, Chars (Typ)); 5783 5784 -- If this predicate comes from an aspect, find the aspect 5785 -- specification, and replace the saved expression because 5786 -- we need the subtype references replaced for the calls to 5787 -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point 5788 -- and Check_Aspect_At_End_Of_Declarations. 5789 5790 if From_Aspect_Specification (Ritem) then 5791 declare 5792 Aitem : Node_Id; 5793 5794 begin 5795 -- Loop to find corresponding aspect, note that this 5796 -- must be present given the pragma is marked delayed. 5797 5798 Aitem := Next_Rep_Item (Ritem); 5799 loop 5800 if Nkind (Aitem) = N_Aspect_Specification 5801 and then Aspect_Rep_Item (Aitem) = Ritem 5802 then 5803 Set_Entity 5804 (Identifier (Aitem), New_Copy_Tree (Arg2)); 5805 exit; 5806 end if; 5807 5808 Aitem := Next_Rep_Item (Aitem); 5809 end loop; 5810 end; 5811 end if; 5812 5813 -- Now we can add the expression 5814 5815 if No (Expr) then 5816 Expr := Relocate_Node (Arg2); 5817 5818 -- There already was a predicate, so add to it 5819 5820 else 5821 Expr := 5822 Make_And_Then (Loc, 5823 Left_Opnd => Relocate_Node (Expr), 5824 Right_Opnd => Relocate_Node (Arg2)); 5825 end if; 5826 end if; 5827 end if; 5828 5829 Next_Rep_Item (Ritem); 5830 end loop; 5831 end Add_Predicates; 5832 5833 -- Start of processing for Build_Predicate_Function 5834 5835 begin 5836 -- Initialize for construction of statement list 5837 5838 Expr := Empty; 5839 5840 -- Return if already built or if type does not have predicates 5841 5842 if not Has_Predicates (Typ) 5843 or else Present (Predicate_Function (Typ)) 5844 then 5845 return; 5846 end if; 5847 5848 -- Add Predicates for the current type 5849 5850 Add_Predicates; 5851 5852 -- Add predicates for ancestor if present 5853 5854 declare 5855 Atyp : constant Entity_Id := Nearest_Ancestor (Typ); 5856 begin 5857 if Present (Atyp) then 5858 Add_Call (Atyp); 5859 end if; 5860 end; 5861 5862 -- If we have predicates, build the function 5863 5864 if Present (Expr) then 5865 5866 -- Build function declaration 5867 5868 SId := 5869 Make_Defining_Identifier (Loc, 5870 Chars => New_External_Name (Chars (Typ), "Predicate")); 5871 Set_Has_Predicates (SId); 5872 Set_Ekind (SId, E_Function); 5873 Set_Predicate_Function (Typ, SId); 5874 5875 -- The predicate function is shared between views of a type. 5876 5877 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 5878 Set_Predicate_Function (Full_View (Typ), SId); 5879 end if; 5880 5881 Spec := 5882 Make_Function_Specification (Loc, 5883 Defining_Unit_Name => SId, 5884 Parameter_Specifications => New_List ( 5885 Make_Parameter_Specification (Loc, 5886 Defining_Identifier => Object_Entity, 5887 Parameter_Type => New_Occurrence_Of (Typ, Loc))), 5888 Result_Definition => 5889 New_Occurrence_Of (Standard_Boolean, Loc)); 5890 5891 FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec); 5892 5893 -- Build function body 5894 5895 SId := 5896 Make_Defining_Identifier (Loc, 5897 Chars => New_External_Name (Chars (Typ), "Predicate")); 5898 5899 Spec := 5900 Make_Function_Specification (Loc, 5901 Defining_Unit_Name => SId, 5902 Parameter_Specifications => New_List ( 5903 Make_Parameter_Specification (Loc, 5904 Defining_Identifier => 5905 Make_Defining_Identifier (Loc, Object_Name), 5906 Parameter_Type => 5907 New_Occurrence_Of (Typ, Loc))), 5908 Result_Definition => 5909 New_Occurrence_Of (Standard_Boolean, Loc)); 5910 5911 FBody := 5912 Make_Subprogram_Body (Loc, 5913 Specification => Spec, 5914 Declarations => Empty_List, 5915 Handled_Statement_Sequence => 5916 Make_Handled_Sequence_Of_Statements (Loc, 5917 Statements => New_List ( 5918 Make_Simple_Return_Statement (Loc, 5919 Expression => Expr)))); 5920 5921 -- Insert declaration before freeze node and body after 5922 5923 Insert_Before_And_Analyze (N, FDecl); 5924 Insert_After_And_Analyze (N, FBody); 5925 5926 -- Deal with static predicate case 5927 5928 if Ekind_In (Typ, E_Enumeration_Subtype, 5929 E_Modular_Integer_Subtype, 5930 E_Signed_Integer_Subtype) 5931 and then Is_Static_Subtype (Typ) 5932 and then not Dynamic_Predicate_Present 5933 then 5934 Build_Static_Predicate (Typ, Expr, Object_Name); 5935 5936 if Present (Static_Predicate_Present) 5937 and No (Static_Predicate (Typ)) 5938 then 5939 Error_Msg_F 5940 ("expression does not have required form for " 5941 & "static predicate", 5942 Next (First (Pragma_Argument_Associations 5943 (Static_Predicate_Present)))); 5944 end if; 5945 end if; 5946 end if; 5947 end Build_Predicate_Function; 5948 5949 ---------------------------- 5950 -- Build_Static_Predicate -- 5951 ---------------------------- 5952 5953 procedure Build_Static_Predicate 5954 (Typ : Entity_Id; 5955 Expr : Node_Id; 5956 Nam : Name_Id) 5957 is 5958 Loc : constant Source_Ptr := Sloc (Expr); 5959 5960 Non_Static : exception; 5961 -- Raised if something non-static is found 5962 5963 Btyp : constant Entity_Id := Base_Type (Typ); 5964 5965 BLo : constant Uint := Expr_Value (Type_Low_Bound (Btyp)); 5966 BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp)); 5967 -- Low bound and high bound value of base type of Typ 5968 5969 TLo : constant Uint := Expr_Value (Type_Low_Bound (Typ)); 5970 THi : constant Uint := Expr_Value (Type_High_Bound (Typ)); 5971 -- Low bound and high bound values of static subtype Typ 5972 5973 type REnt is record 5974 Lo, Hi : Uint; 5975 end record; 5976 -- One entry in a Rlist value, a single REnt (range entry) value 5977 -- denotes one range from Lo to Hi. To represent a single value 5978 -- range Lo = Hi = value. 5979 5980 type RList is array (Nat range <>) of REnt; 5981 -- A list of ranges. The ranges are sorted in increasing order, 5982 -- and are disjoint (there is a gap of at least one value between 5983 -- each range in the table). A value is in the set of ranges in 5984 -- Rlist if it lies within one of these ranges 5985 5986 False_Range : constant RList := 5987 RList'(1 .. 0 => REnt'(No_Uint, No_Uint)); 5988 -- An empty set of ranges represents a range list that can never be 5989 -- satisfied, since there are no ranges in which the value could lie, 5990 -- so it does not lie in any of them. False_Range is a canonical value 5991 -- for this empty set, but general processing should test for an Rlist 5992 -- with length zero (see Is_False predicate), since other null ranges 5993 -- may appear which must be treated as False. 5994 5995 True_Range : constant RList := RList'(1 => REnt'(BLo, BHi)); 5996 -- Range representing True, value must be in the base range 5997 5998 function "and" (Left, Right : RList) return RList; 5999 -- And's together two range lists, returning a range list. This is 6000 -- a set intersection operation. 6001 6002 function "or" (Left, Right : RList) return RList; 6003 -- Or's together two range lists, returning a range list. This is a 6004 -- set union operation. 6005 6006 function "not" (Right : RList) return RList; 6007 -- Returns complement of a given range list, i.e. a range list 6008 -- representing all the values in TLo .. THi that are not in the 6009 -- input operand Right. 6010 6011 function Build_Val (V : Uint) return Node_Id; 6012 -- Return an analyzed N_Identifier node referencing this value, suitable 6013 -- for use as an entry in the Static_Predicate list. This node is typed 6014 -- with the base type. 6015 6016 function Build_Range (Lo, Hi : Uint) return Node_Id; 6017 -- Return an analyzed N_Range node referencing this range, suitable 6018 -- for use as an entry in the Static_Predicate list. This node is typed 6019 -- with the base type. 6020 6021 function Get_RList (Exp : Node_Id) return RList; 6022 -- This is a recursive routine that converts the given expression into 6023 -- a list of ranges, suitable for use in building the static predicate. 6024 6025 function Is_False (R : RList) return Boolean; 6026 pragma Inline (Is_False); 6027 -- Returns True if the given range list is empty, and thus represents 6028 -- a False list of ranges that can never be satisfied. 6029 6030 function Is_True (R : RList) return Boolean; 6031 -- Returns True if R trivially represents the True predicate by having 6032 -- a single range from BLo to BHi. 6033 6034 function Is_Type_Ref (N : Node_Id) return Boolean; 6035 pragma Inline (Is_Type_Ref); 6036 -- Returns if True if N is a reference to the type for the predicate in 6037 -- the expression (i.e. if it is an identifier whose Chars field matches 6038 -- the Nam given in the call). 6039 6040 function Lo_Val (N : Node_Id) return Uint; 6041 -- Given static expression or static range from a Static_Predicate list, 6042 -- gets expression value or low bound of range. 6043 6044 function Hi_Val (N : Node_Id) return Uint; 6045 -- Given static expression or static range from a Static_Predicate list, 6046 -- gets expression value of high bound of range. 6047 6048 function Membership_Entry (N : Node_Id) return RList; 6049 -- Given a single membership entry (range, value, or subtype), returns 6050 -- the corresponding range list. Raises Static_Error if not static. 6051 6052 function Membership_Entries (N : Node_Id) return RList; 6053 -- Given an element on an alternatives list of a membership operation, 6054 -- returns the range list corresponding to this entry and all following 6055 -- entries (i.e. returns the "or" of this list of values). 6056 6057 function Stat_Pred (Typ : Entity_Id) return RList; 6058 -- Given a type, if it has a static predicate, then return the predicate 6059 -- as a range list, otherwise raise Non_Static. 6060 6061 ----------- 6062 -- "and" -- 6063 ----------- 6064 6065 function "and" (Left, Right : RList) return RList is 6066 FEnt : REnt; 6067 -- First range of result 6068 6069 SLeft : Nat := Left'First; 6070 -- Start of rest of left entries 6071 6072 SRight : Nat := Right'First; 6073 -- Start of rest of right entries 6074 6075 begin 6076 -- If either range is True, return the other 6077 6078 if Is_True (Left) then 6079 return Right; 6080 elsif Is_True (Right) then 6081 return Left; 6082 end if; 6083 6084 -- If either range is False, return False 6085 6086 if Is_False (Left) or else Is_False (Right) then 6087 return False_Range; 6088 end if; 6089 6090 -- Loop to remove entries at start that are disjoint, and thus 6091 -- just get discarded from the result entirely. 6092 6093 loop 6094 -- If no operands left in either operand, result is false 6095 6096 if SLeft > Left'Last or else SRight > Right'Last then 6097 return False_Range; 6098 6099 -- Discard first left operand entry if disjoint with right 6100 6101 elsif Left (SLeft).Hi < Right (SRight).Lo then 6102 SLeft := SLeft + 1; 6103 6104 -- Discard first right operand entry if disjoint with left 6105 6106 elsif Right (SRight).Hi < Left (SLeft).Lo then 6107 SRight := SRight + 1; 6108 6109 -- Otherwise we have an overlapping entry 6110 6111 else 6112 exit; 6113 end if; 6114 end loop; 6115 6116 -- Now we have two non-null operands, and first entries overlap. 6117 -- The first entry in the result will be the overlapping part of 6118 -- these two entries. 6119 6120 FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo), 6121 Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi)); 6122 6123 -- Now we can remove the entry that ended at a lower value, since 6124 -- its contribution is entirely contained in Fent. 6125 6126 if Left (SLeft).Hi <= Right (SRight).Hi then 6127 SLeft := SLeft + 1; 6128 else 6129 SRight := SRight + 1; 6130 end if; 6131 6132 -- Compute result by concatenating this first entry with the "and" 6133 -- of the remaining parts of the left and right operands. Note that 6134 -- if either of these is empty, "and" will yield empty, so that we 6135 -- will end up with just Fent, which is what we want in that case. 6136 6137 return 6138 FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last)); 6139 end "and"; 6140 6141 ----------- 6142 -- "not" -- 6143 ----------- 6144 6145 function "not" (Right : RList) return RList is 6146 begin 6147 -- Return True if False range 6148 6149 if Is_False (Right) then 6150 return True_Range; 6151 end if; 6152 6153 -- Return False if True range 6154 6155 if Is_True (Right) then 6156 return False_Range; 6157 end if; 6158 6159 -- Here if not trivial case 6160 6161 declare 6162 Result : RList (1 .. Right'Length + 1); 6163 -- May need one more entry for gap at beginning and end 6164 6165 Count : Nat := 0; 6166 -- Number of entries stored in Result 6167 6168 begin 6169 -- Gap at start 6170 6171 if Right (Right'First).Lo > TLo then 6172 Count := Count + 1; 6173 Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1); 6174 end if; 6175 6176 -- Gaps between ranges 6177 6178 for J in Right'First .. Right'Last - 1 loop 6179 Count := Count + 1; 6180 Result (Count) := 6181 REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1); 6182 end loop; 6183 6184 -- Gap at end 6185 6186 if Right (Right'Last).Hi < THi then 6187 Count := Count + 1; 6188 Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi); 6189 end if; 6190 6191 return Result (1 .. Count); 6192 end; 6193 end "not"; 6194 6195 ---------- 6196 -- "or" -- 6197 ---------- 6198 6199 function "or" (Left, Right : RList) return RList is 6200 FEnt : REnt; 6201 -- First range of result 6202 6203 SLeft : Nat := Left'First; 6204 -- Start of rest of left entries 6205 6206 SRight : Nat := Right'First; 6207 -- Start of rest of right entries 6208 6209 begin 6210 -- If either range is True, return True 6211 6212 if Is_True (Left) or else Is_True (Right) then 6213 return True_Range; 6214 end if; 6215 6216 -- If either range is False (empty), return the other 6217 6218 if Is_False (Left) then 6219 return Right; 6220 elsif Is_False (Right) then 6221 return Left; 6222 end if; 6223 6224 -- Initialize result first entry from left or right operand 6225 -- depending on which starts with the lower range. 6226 6227 if Left (SLeft).Lo < Right (SRight).Lo then 6228 FEnt := Left (SLeft); 6229 SLeft := SLeft + 1; 6230 else 6231 FEnt := Right (SRight); 6232 SRight := SRight + 1; 6233 end if; 6234 6235 -- This loop eats ranges from left and right operands that 6236 -- are contiguous with the first range we are gathering. 6237 6238 loop 6239 -- Eat first entry in left operand if contiguous or 6240 -- overlapped by gathered first operand of result. 6241 6242 if SLeft <= Left'Last 6243 and then Left (SLeft).Lo <= FEnt.Hi + 1 6244 then 6245 FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi); 6246 SLeft := SLeft + 1; 6247 6248 -- Eat first entry in right operand if contiguous or 6249 -- overlapped by gathered right operand of result. 6250 6251 elsif SRight <= Right'Last 6252 and then Right (SRight).Lo <= FEnt.Hi + 1 6253 then 6254 FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi); 6255 SRight := SRight + 1; 6256 6257 -- All done if no more entries to eat! 6258 6259 else 6260 exit; 6261 end if; 6262 end loop; 6263 6264 -- Obtain result as the first entry we just computed, concatenated 6265 -- to the "or" of the remaining results (if one operand is empty, 6266 -- this will just concatenate with the other 6267 6268 return 6269 FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last)); 6270 end "or"; 6271 6272 ----------------- 6273 -- Build_Range -- 6274 ----------------- 6275 6276 function Build_Range (Lo, Hi : Uint) return Node_Id is 6277 Result : Node_Id; 6278 begin 6279 if Lo = Hi then 6280 return Build_Val (Hi); 6281 else 6282 Result := 6283 Make_Range (Loc, 6284 Low_Bound => Build_Val (Lo), 6285 High_Bound => Build_Val (Hi)); 6286 Set_Etype (Result, Btyp); 6287 Set_Analyzed (Result); 6288 return Result; 6289 end if; 6290 end Build_Range; 6291 6292 --------------- 6293 -- Build_Val -- 6294 --------------- 6295 6296 function Build_Val (V : Uint) return Node_Id is 6297 Result : Node_Id; 6298 6299 begin 6300 if Is_Enumeration_Type (Typ) then 6301 Result := Get_Enum_Lit_From_Pos (Typ, V, Loc); 6302 else 6303 Result := Make_Integer_Literal (Loc, V); 6304 end if; 6305 6306 Set_Etype (Result, Btyp); 6307 Set_Is_Static_Expression (Result); 6308 Set_Analyzed (Result); 6309 return Result; 6310 end Build_Val; 6311 6312 --------------- 6313 -- Get_RList -- 6314 --------------- 6315 6316 function Get_RList (Exp : Node_Id) return RList is 6317 Op : Node_Kind; 6318 Val : Uint; 6319 6320 begin 6321 -- Static expression can only be true or false 6322 6323 if Is_OK_Static_Expression (Exp) then 6324 6325 -- For False 6326 6327 if Expr_Value (Exp) = 0 then 6328 return False_Range; 6329 else 6330 return True_Range; 6331 end if; 6332 end if; 6333 6334 -- Otherwise test node type 6335 6336 Op := Nkind (Exp); 6337 6338 case Op is 6339 6340 -- And 6341 6342 when N_Op_And | N_And_Then => 6343 return Get_RList (Left_Opnd (Exp)) 6344 and 6345 Get_RList (Right_Opnd (Exp)); 6346 6347 -- Or 6348 6349 when N_Op_Or | N_Or_Else => 6350 return Get_RList (Left_Opnd (Exp)) 6351 or 6352 Get_RList (Right_Opnd (Exp)); 6353 6354 -- Not 6355 6356 when N_Op_Not => 6357 return not Get_RList (Right_Opnd (Exp)); 6358 6359 -- Comparisons of type with static value 6360 6361 when N_Op_Compare => 6362 6363 -- Type is left operand 6364 6365 if Is_Type_Ref (Left_Opnd (Exp)) 6366 and then Is_OK_Static_Expression (Right_Opnd (Exp)) 6367 then 6368 Val := Expr_Value (Right_Opnd (Exp)); 6369 6370 -- Typ is right operand 6371 6372 elsif Is_Type_Ref (Right_Opnd (Exp)) 6373 and then Is_OK_Static_Expression (Left_Opnd (Exp)) 6374 then 6375 Val := Expr_Value (Left_Opnd (Exp)); 6376 6377 -- Invert sense of comparison 6378 6379 case Op is 6380 when N_Op_Gt => Op := N_Op_Lt; 6381 when N_Op_Lt => Op := N_Op_Gt; 6382 when N_Op_Ge => Op := N_Op_Le; 6383 when N_Op_Le => Op := N_Op_Ge; 6384 when others => null; 6385 end case; 6386 6387 -- Other cases are non-static 6388 6389 else 6390 raise Non_Static; 6391 end if; 6392 6393 -- Construct range according to comparison operation 6394 6395 case Op is 6396 when N_Op_Eq => 6397 return RList'(1 => REnt'(Val, Val)); 6398 6399 when N_Op_Ge => 6400 return RList'(1 => REnt'(Val, BHi)); 6401 6402 when N_Op_Gt => 6403 return RList'(1 => REnt'(Val + 1, BHi)); 6404 6405 when N_Op_Le => 6406 return RList'(1 => REnt'(BLo, Val)); 6407 6408 when N_Op_Lt => 6409 return RList'(1 => REnt'(BLo, Val - 1)); 6410 6411 when N_Op_Ne => 6412 return RList'(REnt'(BLo, Val - 1), 6413 REnt'(Val + 1, BHi)); 6414 6415 when others => 6416 raise Program_Error; 6417 end case; 6418 6419 -- Membership (IN) 6420 6421 when N_In => 6422 if not Is_Type_Ref (Left_Opnd (Exp)) then 6423 raise Non_Static; 6424 end if; 6425 6426 if Present (Right_Opnd (Exp)) then 6427 return Membership_Entry (Right_Opnd (Exp)); 6428 else 6429 return Membership_Entries (First (Alternatives (Exp))); 6430 end if; 6431 6432 -- Negative membership (NOT IN) 6433 6434 when N_Not_In => 6435 if not Is_Type_Ref (Left_Opnd (Exp)) then 6436 raise Non_Static; 6437 end if; 6438 6439 if Present (Right_Opnd (Exp)) then 6440 return not Membership_Entry (Right_Opnd (Exp)); 6441 else 6442 return not Membership_Entries (First (Alternatives (Exp))); 6443 end if; 6444 6445 -- Function call, may be call to static predicate 6446 6447 when N_Function_Call => 6448 if Is_Entity_Name (Name (Exp)) then 6449 declare 6450 Ent : constant Entity_Id := Entity (Name (Exp)); 6451 begin 6452 if Has_Predicates (Ent) then 6453 return Stat_Pred (Etype (First_Formal (Ent))); 6454 end if; 6455 end; 6456 end if; 6457 6458 -- Other function call cases are non-static 6459 6460 raise Non_Static; 6461 6462 -- Qualified expression, dig out the expression 6463 6464 when N_Qualified_Expression => 6465 return Get_RList (Expression (Exp)); 6466 6467 -- Xor operator 6468 6469 when N_Op_Xor => 6470 return (Get_RList (Left_Opnd (Exp)) 6471 and not Get_RList (Right_Opnd (Exp))) 6472 or (Get_RList (Right_Opnd (Exp)) 6473 and not Get_RList (Left_Opnd (Exp))); 6474 6475 -- Any other node type is non-static 6476 6477 when others => 6478 raise Non_Static; 6479 end case; 6480 end Get_RList; 6481 6482 ------------ 6483 -- Hi_Val -- 6484 ------------ 6485 6486 function Hi_Val (N : Node_Id) return Uint is 6487 begin 6488 if Is_Static_Expression (N) then 6489 return Expr_Value (N); 6490 else 6491 pragma Assert (Nkind (N) = N_Range); 6492 return Expr_Value (High_Bound (N)); 6493 end if; 6494 end Hi_Val; 6495 6496 -------------- 6497 -- Is_False -- 6498 -------------- 6499 6500 function Is_False (R : RList) return Boolean is 6501 begin 6502 return R'Length = 0; 6503 end Is_False; 6504 6505 ------------- 6506 -- Is_True -- 6507 ------------- 6508 6509 function Is_True (R : RList) return Boolean is 6510 begin 6511 return R'Length = 1 6512 and then R (R'First).Lo = BLo 6513 and then R (R'First).Hi = BHi; 6514 end Is_True; 6515 6516 ----------------- 6517 -- Is_Type_Ref -- 6518 ----------------- 6519 6520 function Is_Type_Ref (N : Node_Id) return Boolean is 6521 begin 6522 return Nkind (N) = N_Identifier and then Chars (N) = Nam; 6523 end Is_Type_Ref; 6524 6525 ------------ 6526 -- Lo_Val -- 6527 ------------ 6528 6529 function Lo_Val (N : Node_Id) return Uint is 6530 begin 6531 if Is_Static_Expression (N) then 6532 return Expr_Value (N); 6533 else 6534 pragma Assert (Nkind (N) = N_Range); 6535 return Expr_Value (Low_Bound (N)); 6536 end if; 6537 end Lo_Val; 6538 6539 ------------------------ 6540 -- Membership_Entries -- 6541 ------------------------ 6542 6543 function Membership_Entries (N : Node_Id) return RList is 6544 begin 6545 if No (Next (N)) then 6546 return Membership_Entry (N); 6547 else 6548 return Membership_Entry (N) or Membership_Entries (Next (N)); 6549 end if; 6550 end Membership_Entries; 6551 6552 ---------------------- 6553 -- Membership_Entry -- 6554 ---------------------- 6555 6556 function Membership_Entry (N : Node_Id) return RList is 6557 Val : Uint; 6558 SLo : Uint; 6559 SHi : Uint; 6560 6561 begin 6562 -- Range case 6563 6564 if Nkind (N) = N_Range then 6565 if not Is_Static_Expression (Low_Bound (N)) 6566 or else 6567 not Is_Static_Expression (High_Bound (N)) 6568 then 6569 raise Non_Static; 6570 else 6571 SLo := Expr_Value (Low_Bound (N)); 6572 SHi := Expr_Value (High_Bound (N)); 6573 return RList'(1 => REnt'(SLo, SHi)); 6574 end if; 6575 6576 -- Static expression case 6577 6578 elsif Is_Static_Expression (N) then 6579 Val := Expr_Value (N); 6580 return RList'(1 => REnt'(Val, Val)); 6581 6582 -- Identifier (other than static expression) case 6583 6584 else pragma Assert (Nkind (N) = N_Identifier); 6585 6586 -- Type case 6587 6588 if Is_Type (Entity (N)) then 6589 6590 -- If type has predicates, process them 6591 6592 if Has_Predicates (Entity (N)) then 6593 return Stat_Pred (Entity (N)); 6594 6595 -- For static subtype without predicates, get range 6596 6597 elsif Is_Static_Subtype (Entity (N)) then 6598 SLo := Expr_Value (Type_Low_Bound (Entity (N))); 6599 SHi := Expr_Value (Type_High_Bound (Entity (N))); 6600 return RList'(1 => REnt'(SLo, SHi)); 6601 6602 -- Any other type makes us non-static 6603 6604 else 6605 raise Non_Static; 6606 end if; 6607 6608 -- Any other kind of identifier in predicate (e.g. a non-static 6609 -- expression value) means this is not a static predicate. 6610 6611 else 6612 raise Non_Static; 6613 end if; 6614 end if; 6615 end Membership_Entry; 6616 6617 --------------- 6618 -- Stat_Pred -- 6619 --------------- 6620 6621 function Stat_Pred (Typ : Entity_Id) return RList is 6622 begin 6623 -- Not static if type does not have static predicates 6624 6625 if not Has_Predicates (Typ) or else No (Static_Predicate (Typ)) then 6626 raise Non_Static; 6627 end if; 6628 6629 -- Otherwise we convert the predicate list to a range list 6630 6631 declare 6632 Result : RList (1 .. List_Length (Static_Predicate (Typ))); 6633 P : Node_Id; 6634 6635 begin 6636 P := First (Static_Predicate (Typ)); 6637 for J in Result'Range loop 6638 Result (J) := REnt'(Lo_Val (P), Hi_Val (P)); 6639 Next (P); 6640 end loop; 6641 6642 return Result; 6643 end; 6644 end Stat_Pred; 6645 6646 -- Start of processing for Build_Static_Predicate 6647 6648 begin 6649 -- Now analyze the expression to see if it is a static predicate 6650 6651 declare 6652 Ranges : constant RList := Get_RList (Expr); 6653 -- Range list from expression if it is static 6654 6655 Plist : List_Id; 6656 6657 begin 6658 -- Convert range list into a form for the static predicate. In the 6659 -- Ranges array, we just have raw ranges, these must be converted 6660 -- to properly typed and analyzed static expressions or range nodes. 6661 6662 -- Note: here we limit ranges to the ranges of the subtype, so that 6663 -- a predicate is always false for values outside the subtype. That 6664 -- seems fine, such values are invalid anyway, and considering them 6665 -- to fail the predicate seems allowed and friendly, and furthermore 6666 -- simplifies processing for case statements and loops. 6667 6668 Plist := New_List; 6669 6670 for J in Ranges'Range loop 6671 declare 6672 Lo : Uint := Ranges (J).Lo; 6673 Hi : Uint := Ranges (J).Hi; 6674 6675 begin 6676 -- Ignore completely out of range entry 6677 6678 if Hi < TLo or else Lo > THi then 6679 null; 6680 6681 -- Otherwise process entry 6682 6683 else 6684 -- Adjust out of range value to subtype range 6685 6686 if Lo < TLo then 6687 Lo := TLo; 6688 end if; 6689 6690 if Hi > THi then 6691 Hi := THi; 6692 end if; 6693 6694 -- Convert range into required form 6695 6696 if Lo = Hi then 6697 Append_To (Plist, Build_Val (Lo)); 6698 else 6699 Append_To (Plist, Build_Range (Lo, Hi)); 6700 end if; 6701 end if; 6702 end; 6703 end loop; 6704 6705 -- Processing was successful and all entries were static, so now we 6706 -- can store the result as the predicate list. 6707 6708 Set_Static_Predicate (Typ, Plist); 6709 6710 -- The processing for static predicates put the expression into 6711 -- canonical form as a series of ranges. It also eliminated 6712 -- duplicates and collapsed and combined ranges. We might as well 6713 -- replace the alternatives list of the right operand of the 6714 -- membership test with the static predicate list, which will 6715 -- usually be more efficient. 6716 6717 declare 6718 New_Alts : constant List_Id := New_List; 6719 Old_Node : Node_Id; 6720 New_Node : Node_Id; 6721 6722 begin 6723 Old_Node := First (Plist); 6724 while Present (Old_Node) loop 6725 New_Node := New_Copy (Old_Node); 6726 6727 if Nkind (New_Node) = N_Range then 6728 Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node))); 6729 Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node))); 6730 end if; 6731 6732 Append_To (New_Alts, New_Node); 6733 Next (Old_Node); 6734 end loop; 6735 6736 -- If empty list, replace by False 6737 6738 if Is_Empty_List (New_Alts) then 6739 Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc)); 6740 6741 -- Else replace by set membership test 6742 6743 else 6744 Rewrite (Expr, 6745 Make_In (Loc, 6746 Left_Opnd => Make_Identifier (Loc, Nam), 6747 Right_Opnd => Empty, 6748 Alternatives => New_Alts)); 6749 6750 -- Resolve new expression in function context 6751 6752 Install_Formals (Predicate_Function (Typ)); 6753 Push_Scope (Predicate_Function (Typ)); 6754 Analyze_And_Resolve (Expr, Standard_Boolean); 6755 Pop_Scope; 6756 end if; 6757 end; 6758 end; 6759 6760 -- If non-static, return doing nothing 6761 6762 exception 6763 when Non_Static => 6764 return; 6765 end Build_Static_Predicate; 6766 6767 ----------------------------------------- 6768 -- Check_Aspect_At_End_Of_Declarations -- 6769 ----------------------------------------- 6770 6771 procedure Check_Aspect_At_End_Of_Declarations (ASN : Node_Id) is 6772 Ent : constant Entity_Id := Entity (ASN); 6773 Ident : constant Node_Id := Identifier (ASN); 6774 A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident)); 6775 6776 End_Decl_Expr : constant Node_Id := Entity (Ident); 6777 -- Expression to be analyzed at end of declarations 6778 6779 Freeze_Expr : constant Node_Id := Expression (ASN); 6780 -- Expression from call to Check_Aspect_At_Freeze_Point 6781 6782 T : constant Entity_Id := Etype (Freeze_Expr); 6783 -- Type required for preanalyze call 6784 6785 Err : Boolean; 6786 -- Set False if error 6787 6788 -- On entry to this procedure, Entity (Ident) contains a copy of the 6789 -- original expression from the aspect, saved for this purpose, and 6790 -- but Expression (Ident) is a preanalyzed copy of the expression, 6791 -- preanalyzed just after the freeze point. 6792 6793 procedure Check_Overloaded_Name; 6794 -- For aspects whose expression is simply a name, this routine checks if 6795 -- the name is overloaded or not. If so, it verifies there is an 6796 -- interpretation that matches the entity obtained at the freeze point, 6797 -- otherwise the compiler complains. 6798 6799 --------------------------- 6800 -- Check_Overloaded_Name -- 6801 --------------------------- 6802 6803 procedure Check_Overloaded_Name is 6804 begin 6805 if not Is_Overloaded (End_Decl_Expr) then 6806 Err := Entity (End_Decl_Expr) /= Entity (Freeze_Expr); 6807 6808 else 6809 Err := True; 6810 6811 declare 6812 Index : Interp_Index; 6813 It : Interp; 6814 6815 begin 6816 Get_First_Interp (End_Decl_Expr, Index, It); 6817 while Present (It.Typ) loop 6818 if It.Nam = Entity (Freeze_Expr) then 6819 Err := False; 6820 exit; 6821 end if; 6822 6823 Get_Next_Interp (Index, It); 6824 end loop; 6825 end; 6826 end if; 6827 end Check_Overloaded_Name; 6828 6829 -- Start of processing for Check_Aspect_At_End_Of_Declarations 6830 6831 begin 6832 -- Case of aspects Dimension, Dimension_System and Synchronization 6833 6834 if A_Id = Aspect_Synchronization then 6835 return; 6836 6837 -- Case of stream attributes, just have to compare entities. However, 6838 -- the expression is just a name (possibly overloaded), and there may 6839 -- be stream operations declared for unrelated types, so we just need 6840 -- to verify that one of these interpretations is the one available at 6841 -- at the freeze point. 6842 6843 elsif A_Id = Aspect_Input or else 6844 A_Id = Aspect_Output or else 6845 A_Id = Aspect_Read or else 6846 A_Id = Aspect_Write 6847 then 6848 Analyze (End_Decl_Expr); 6849 Check_Overloaded_Name; 6850 6851 elsif A_Id = Aspect_Variable_Indexing or else 6852 A_Id = Aspect_Constant_Indexing or else 6853 A_Id = Aspect_Default_Iterator or else 6854 A_Id = Aspect_Iterator_Element 6855 then 6856 -- Make type unfrozen before analysis, to prevent spurious errors 6857 -- about late attributes. 6858 6859 Set_Is_Frozen (Ent, False); 6860 Analyze (End_Decl_Expr); 6861 Set_Is_Frozen (Ent, True); 6862 6863 -- If the end of declarations comes before any other freeze 6864 -- point, the Freeze_Expr is not analyzed: no check needed. 6865 6866 if Analyzed (Freeze_Expr) and then not In_Instance then 6867 Check_Overloaded_Name; 6868 else 6869 Err := False; 6870 end if; 6871 6872 -- All other cases 6873 6874 else 6875 -- In a generic context the aspect expressions have not been 6876 -- preanalyzed, so do it now. There are no conformance checks 6877 -- to perform in this case. 6878 6879 if No (T) then 6880 Check_Aspect_At_Freeze_Point (ASN); 6881 return; 6882 6883 -- The default values attributes may be defined in the private part, 6884 -- and the analysis of the expression may take place when only the 6885 -- partial view is visible. The expression must be scalar, so use 6886 -- the full view to resolve. 6887 6888 elsif (A_Id = Aspect_Default_Value 6889 or else 6890 A_Id = Aspect_Default_Component_Value) 6891 and then Is_Private_Type (T) 6892 then 6893 Preanalyze_Spec_Expression (End_Decl_Expr, Full_View (T)); 6894 else 6895 Preanalyze_Spec_Expression (End_Decl_Expr, T); 6896 end if; 6897 6898 Err := not Fully_Conformant_Expressions (End_Decl_Expr, Freeze_Expr); 6899 end if; 6900 6901 -- Output error message if error 6902 6903 if Err then 6904 Error_Msg_NE 6905 ("visibility of aspect for& changes after freeze point", 6906 ASN, Ent); 6907 Error_Msg_NE 6908 ("info: & is frozen here, aspects evaluated at this point??", 6909 Freeze_Node (Ent), Ent); 6910 end if; 6911 end Check_Aspect_At_End_Of_Declarations; 6912 6913 ---------------------------------- 6914 -- Check_Aspect_At_Freeze_Point -- 6915 ---------------------------------- 6916 6917 procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id) is 6918 Ident : constant Node_Id := Identifier (ASN); 6919 -- Identifier (use Entity field to save expression) 6920 6921 A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident)); 6922 6923 T : Entity_Id := Empty; 6924 -- Type required for preanalyze call 6925 6926 begin 6927 -- On entry to this procedure, Entity (Ident) contains a copy of the 6928 -- original expression from the aspect, saved for this purpose. 6929 6930 -- On exit from this procedure Entity (Ident) is unchanged, still 6931 -- containing that copy, but Expression (Ident) is a preanalyzed copy 6932 -- of the expression, preanalyzed just after the freeze point. 6933 6934 -- Make a copy of the expression to be preanalyzed 6935 6936 Set_Expression (ASN, New_Copy_Tree (Entity (Ident))); 6937 6938 -- Find type for preanalyze call 6939 6940 case A_Id is 6941 6942 -- No_Aspect should be impossible 6943 6944 when No_Aspect => 6945 raise Program_Error; 6946 6947 -- Aspects taking an optional boolean argument 6948 6949 when Boolean_Aspects | 6950 Library_Unit_Aspects => 6951 T := Standard_Boolean; 6952 6953 -- Aspects corresponding to attribute definition clauses 6954 6955 when Aspect_Address => 6956 T := RTE (RE_Address); 6957 6958 when Aspect_Attach_Handler => 6959 T := RTE (RE_Interrupt_ID); 6960 6961 when Aspect_Bit_Order | Aspect_Scalar_Storage_Order => 6962 T := RTE (RE_Bit_Order); 6963 6964 when Aspect_Convention => 6965 return; 6966 6967 when Aspect_CPU => 6968 T := RTE (RE_CPU_Range); 6969 6970 -- Default_Component_Value is resolved with the component type 6971 6972 when Aspect_Default_Component_Value => 6973 T := Component_Type (Entity (ASN)); 6974 6975 -- Default_Value is resolved with the type entity in question 6976 6977 when Aspect_Default_Value => 6978 T := Entity (ASN); 6979 6980 when Aspect_Dispatching_Domain => 6981 T := RTE (RE_Dispatching_Domain); 6982 6983 when Aspect_External_Tag => 6984 T := Standard_String; 6985 6986 when Aspect_External_Name => 6987 T := Standard_String; 6988 6989 -- Global is a delayed aspect because it may reference names that 6990 -- have not been declared yet. There is no action to be taken with 6991 -- respect to the aspect itself as the reference checking is done on 6992 -- the corresponding pragma. 6993 6994 when Aspect_Global => 6995 return; 6996 6997 when Aspect_Link_Name => 6998 T := Standard_String; 6999 7000 when Aspect_Priority | Aspect_Interrupt_Priority => 7001 T := Standard_Integer; 7002 7003 when Aspect_Relative_Deadline => 7004 T := RTE (RE_Time_Span); 7005 7006 when Aspect_Small => 7007 T := Universal_Real; 7008 7009 -- For a simple storage pool, we have to retrieve the type of the 7010 -- pool object associated with the aspect's corresponding attribute 7011 -- definition clause. 7012 7013 when Aspect_Simple_Storage_Pool => 7014 T := Etype (Expression (Aspect_Rep_Item (ASN))); 7015 7016 when Aspect_Storage_Pool => 7017 T := Class_Wide_Type (RTE (RE_Root_Storage_Pool)); 7018 7019 when Aspect_Alignment | 7020 Aspect_Component_Size | 7021 Aspect_Machine_Radix | 7022 Aspect_Object_Size | 7023 Aspect_Size | 7024 Aspect_Storage_Size | 7025 Aspect_Stream_Size | 7026 Aspect_Value_Size => 7027 T := Any_Integer; 7028 7029 when Aspect_Synchronization => 7030 return; 7031 7032 -- Special case, the expression of these aspects is just an entity 7033 -- that does not need any resolution, so just analyze. 7034 7035 when Aspect_Input | 7036 Aspect_Output | 7037 Aspect_Read | 7038 Aspect_Suppress | 7039 Aspect_Unsuppress | 7040 Aspect_Warnings | 7041 Aspect_Write => 7042 Analyze (Expression (ASN)); 7043 return; 7044 7045 -- Same for Iterator aspects, where the expression is a function 7046 -- name. Legality rules are checked separately. 7047 7048 when Aspect_Constant_Indexing | 7049 Aspect_Default_Iterator | 7050 Aspect_Iterator_Element | 7051 Aspect_Variable_Indexing => 7052 Analyze (Expression (ASN)); 7053 return; 7054 7055 -- Invariant/Predicate take boolean expressions 7056 7057 when Aspect_Dynamic_Predicate | 7058 Aspect_Invariant | 7059 Aspect_Predicate | 7060 Aspect_Static_Predicate | 7061 Aspect_Type_Invariant => 7062 T := Standard_Boolean; 7063 7064 -- Here is the list of aspects that don't require delay analysis 7065 7066 when Aspect_Abstract_State | 7067 Aspect_Contract_Case | 7068 Aspect_Contract_Cases | 7069 Aspect_Dimension | 7070 Aspect_Dimension_System | 7071 Aspect_Implicit_Dereference | 7072 Aspect_Post | 7073 Aspect_Postcondition | 7074 Aspect_Pre | 7075 Aspect_Precondition | 7076 Aspect_Test_Case => 7077 raise Program_Error; 7078 7079 end case; 7080 7081 -- Do the preanalyze call 7082 7083 Preanalyze_Spec_Expression (Expression (ASN), T); 7084 end Check_Aspect_At_Freeze_Point; 7085 7086 ----------------------------------- 7087 -- Check_Constant_Address_Clause -- 7088 ----------------------------------- 7089 7090 procedure Check_Constant_Address_Clause 7091 (Expr : Node_Id; 7092 U_Ent : Entity_Id) 7093 is 7094 procedure Check_At_Constant_Address (Nod : Node_Id); 7095 -- Checks that the given node N represents a name whose 'Address is 7096 -- constant (in the same sense as OK_Constant_Address_Clause, i.e. the 7097 -- address value is the same at the point of declaration of U_Ent and at 7098 -- the time of elaboration of the address clause. 7099 7100 procedure Check_Expr_Constants (Nod : Node_Id); 7101 -- Checks that Nod meets the requirements for a constant address clause 7102 -- in the sense of the enclosing procedure. 7103 7104 procedure Check_List_Constants (Lst : List_Id); 7105 -- Check that all elements of list Lst meet the requirements for a 7106 -- constant address clause in the sense of the enclosing procedure. 7107 7108 ------------------------------- 7109 -- Check_At_Constant_Address -- 7110 ------------------------------- 7111 7112 procedure Check_At_Constant_Address (Nod : Node_Id) is 7113 begin 7114 if Is_Entity_Name (Nod) then 7115 if Present (Address_Clause (Entity ((Nod)))) then 7116 Error_Msg_NE 7117 ("invalid address clause for initialized object &!", 7118 Nod, U_Ent); 7119 Error_Msg_NE 7120 ("address for& cannot" & 7121 " depend on another address clause! (RM 13.1(22))!", 7122 Nod, U_Ent); 7123 7124 elsif In_Same_Source_Unit (Entity (Nod), U_Ent) 7125 and then Sloc (U_Ent) < Sloc (Entity (Nod)) 7126 then 7127 Error_Msg_NE 7128 ("invalid address clause for initialized object &!", 7129 Nod, U_Ent); 7130 Error_Msg_Node_2 := U_Ent; 7131 Error_Msg_NE 7132 ("\& must be defined before & (RM 13.1(22))!", 7133 Nod, Entity (Nod)); 7134 end if; 7135 7136 elsif Nkind (Nod) = N_Selected_Component then 7137 declare 7138 T : constant Entity_Id := Etype (Prefix (Nod)); 7139 7140 begin 7141 if (Is_Record_Type (T) 7142 and then Has_Discriminants (T)) 7143 or else 7144 (Is_Access_Type (T) 7145 and then Is_Record_Type (Designated_Type (T)) 7146 and then Has_Discriminants (Designated_Type (T))) 7147 then 7148 Error_Msg_NE 7149 ("invalid address clause for initialized object &!", 7150 Nod, U_Ent); 7151 Error_Msg_N 7152 ("\address cannot depend on component" & 7153 " of discriminated record (RM 13.1(22))!", 7154 Nod); 7155 else 7156 Check_At_Constant_Address (Prefix (Nod)); 7157 end if; 7158 end; 7159 7160 elsif Nkind (Nod) = N_Indexed_Component then 7161 Check_At_Constant_Address (Prefix (Nod)); 7162 Check_List_Constants (Expressions (Nod)); 7163 7164 else 7165 Check_Expr_Constants (Nod); 7166 end if; 7167 end Check_At_Constant_Address; 7168 7169 -------------------------- 7170 -- Check_Expr_Constants -- 7171 -------------------------- 7172 7173 procedure Check_Expr_Constants (Nod : Node_Id) is 7174 Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent); 7175 Ent : Entity_Id := Empty; 7176 7177 begin 7178 if Nkind (Nod) in N_Has_Etype 7179 and then Etype (Nod) = Any_Type 7180 then 7181 return; 7182 end if; 7183 7184 case Nkind (Nod) is 7185 when N_Empty | N_Error => 7186 return; 7187 7188 when N_Identifier | N_Expanded_Name => 7189 Ent := Entity (Nod); 7190 7191 -- We need to look at the original node if it is different 7192 -- from the node, since we may have rewritten things and 7193 -- substituted an identifier representing the rewrite. 7194 7195 if Original_Node (Nod) /= Nod then 7196 Check_Expr_Constants (Original_Node (Nod)); 7197 7198 -- If the node is an object declaration without initial 7199 -- value, some code has been expanded, and the expression 7200 -- is not constant, even if the constituents might be 7201 -- acceptable, as in A'Address + offset. 7202 7203 if Ekind (Ent) = E_Variable 7204 and then 7205 Nkind (Declaration_Node (Ent)) = N_Object_Declaration 7206 and then 7207 No (Expression (Declaration_Node (Ent))) 7208 then 7209 Error_Msg_NE 7210 ("invalid address clause for initialized object &!", 7211 Nod, U_Ent); 7212 7213 -- If entity is constant, it may be the result of expanding 7214 -- a check. We must verify that its declaration appears 7215 -- before the object in question, else we also reject the 7216 -- address clause. 7217 7218 elsif Ekind (Ent) = E_Constant 7219 and then In_Same_Source_Unit (Ent, U_Ent) 7220 and then Sloc (Ent) > Loc_U_Ent 7221 then 7222 Error_Msg_NE 7223 ("invalid address clause for initialized object &!", 7224 Nod, U_Ent); 7225 end if; 7226 7227 return; 7228 end if; 7229 7230 -- Otherwise look at the identifier and see if it is OK 7231 7232 if Ekind_In (Ent, E_Named_Integer, E_Named_Real) 7233 or else Is_Type (Ent) 7234 then 7235 return; 7236 7237 elsif 7238 Ekind (Ent) = E_Constant 7239 or else 7240 Ekind (Ent) = E_In_Parameter 7241 then 7242 -- This is the case where we must have Ent defined before 7243 -- U_Ent. Clearly if they are in different units this 7244 -- requirement is met since the unit containing Ent is 7245 -- already processed. 7246 7247 if not In_Same_Source_Unit (Ent, U_Ent) then 7248 return; 7249 7250 -- Otherwise location of Ent must be before the location 7251 -- of U_Ent, that's what prior defined means. 7252 7253 elsif Sloc (Ent) < Loc_U_Ent then 7254 return; 7255 7256 else 7257 Error_Msg_NE 7258 ("invalid address clause for initialized object &!", 7259 Nod, U_Ent); 7260 Error_Msg_Node_2 := U_Ent; 7261 Error_Msg_NE 7262 ("\& must be defined before & (RM 13.1(22))!", 7263 Nod, Ent); 7264 end if; 7265 7266 elsif Nkind (Original_Node (Nod)) = N_Function_Call then 7267 Check_Expr_Constants (Original_Node (Nod)); 7268 7269 else 7270 Error_Msg_NE 7271 ("invalid address clause for initialized object &!", 7272 Nod, U_Ent); 7273 7274 if Comes_From_Source (Ent) then 7275 Error_Msg_NE 7276 ("\reference to variable& not allowed" 7277 & " (RM 13.1(22))!", Nod, Ent); 7278 else 7279 Error_Msg_N 7280 ("non-static expression not allowed" 7281 & " (RM 13.1(22))!", Nod); 7282 end if; 7283 end if; 7284 7285 when N_Integer_Literal => 7286 7287 -- If this is a rewritten unchecked conversion, in a system 7288 -- where Address is an integer type, always use the base type 7289 -- for a literal value. This is user-friendly and prevents 7290 -- order-of-elaboration issues with instances of unchecked 7291 -- conversion. 7292 7293 if Nkind (Original_Node (Nod)) = N_Function_Call then 7294 Set_Etype (Nod, Base_Type (Etype (Nod))); 7295 end if; 7296 7297 when N_Real_Literal | 7298 N_String_Literal | 7299 N_Character_Literal => 7300 return; 7301 7302 when N_Range => 7303 Check_Expr_Constants (Low_Bound (Nod)); 7304 Check_Expr_Constants (High_Bound (Nod)); 7305 7306 when N_Explicit_Dereference => 7307 Check_Expr_Constants (Prefix (Nod)); 7308 7309 when N_Indexed_Component => 7310 Check_Expr_Constants (Prefix (Nod)); 7311 Check_List_Constants (Expressions (Nod)); 7312 7313 when N_Slice => 7314 Check_Expr_Constants (Prefix (Nod)); 7315 Check_Expr_Constants (Discrete_Range (Nod)); 7316 7317 when N_Selected_Component => 7318 Check_Expr_Constants (Prefix (Nod)); 7319 7320 when N_Attribute_Reference => 7321 if Attribute_Name (Nod) = Name_Address 7322 or else 7323 Attribute_Name (Nod) = Name_Access 7324 or else 7325 Attribute_Name (Nod) = Name_Unchecked_Access 7326 or else 7327 Attribute_Name (Nod) = Name_Unrestricted_Access 7328 then 7329 Check_At_Constant_Address (Prefix (Nod)); 7330 7331 else 7332 Check_Expr_Constants (Prefix (Nod)); 7333 Check_List_Constants (Expressions (Nod)); 7334 end if; 7335 7336 when N_Aggregate => 7337 Check_List_Constants (Component_Associations (Nod)); 7338 Check_List_Constants (Expressions (Nod)); 7339 7340 when N_Component_Association => 7341 Check_Expr_Constants (Expression (Nod)); 7342 7343 when N_Extension_Aggregate => 7344 Check_Expr_Constants (Ancestor_Part (Nod)); 7345 Check_List_Constants (Component_Associations (Nod)); 7346 Check_List_Constants (Expressions (Nod)); 7347 7348 when N_Null => 7349 return; 7350 7351 when N_Binary_Op | N_Short_Circuit | N_Membership_Test => 7352 Check_Expr_Constants (Left_Opnd (Nod)); 7353 Check_Expr_Constants (Right_Opnd (Nod)); 7354 7355 when N_Unary_Op => 7356 Check_Expr_Constants (Right_Opnd (Nod)); 7357 7358 when N_Type_Conversion | 7359 N_Qualified_Expression | 7360 N_Allocator | 7361 N_Unchecked_Type_Conversion => 7362 Check_Expr_Constants (Expression (Nod)); 7363 7364 when N_Function_Call => 7365 if not Is_Pure (Entity (Name (Nod))) then 7366 Error_Msg_NE 7367 ("invalid address clause for initialized object &!", 7368 Nod, U_Ent); 7369 7370 Error_Msg_NE 7371 ("\function & is not pure (RM 13.1(22))!", 7372 Nod, Entity (Name (Nod))); 7373 7374 else 7375 Check_List_Constants (Parameter_Associations (Nod)); 7376 end if; 7377 7378 when N_Parameter_Association => 7379 Check_Expr_Constants (Explicit_Actual_Parameter (Nod)); 7380 7381 when others => 7382 Error_Msg_NE 7383 ("invalid address clause for initialized object &!", 7384 Nod, U_Ent); 7385 Error_Msg_NE 7386 ("\must be constant defined before& (RM 13.1(22))!", 7387 Nod, U_Ent); 7388 end case; 7389 end Check_Expr_Constants; 7390 7391 -------------------------- 7392 -- Check_List_Constants -- 7393 -------------------------- 7394 7395 procedure Check_List_Constants (Lst : List_Id) is 7396 Nod1 : Node_Id; 7397 7398 begin 7399 if Present (Lst) then 7400 Nod1 := First (Lst); 7401 while Present (Nod1) loop 7402 Check_Expr_Constants (Nod1); 7403 Next (Nod1); 7404 end loop; 7405 end if; 7406 end Check_List_Constants; 7407 7408 -- Start of processing for Check_Constant_Address_Clause 7409 7410 begin 7411 -- If rep_clauses are to be ignored, no need for legality checks. In 7412 -- particular, no need to pester user about rep clauses that violate 7413 -- the rule on constant addresses, given that these clauses will be 7414 -- removed by Freeze before they reach the back end. 7415 7416 if not Ignore_Rep_Clauses then 7417 Check_Expr_Constants (Expr); 7418 end if; 7419 end Check_Constant_Address_Clause; 7420 7421 ---------------------------------------- 7422 -- Check_Record_Representation_Clause -- 7423 ---------------------------------------- 7424 7425 procedure Check_Record_Representation_Clause (N : Node_Id) is 7426 Loc : constant Source_Ptr := Sloc (N); 7427 Ident : constant Node_Id := Identifier (N); 7428 Rectype : Entity_Id; 7429 Fent : Entity_Id; 7430 CC : Node_Id; 7431 Fbit : Uint; 7432 Lbit : Uint; 7433 Hbit : Uint := Uint_0; 7434 Comp : Entity_Id; 7435 Pcomp : Entity_Id; 7436 7437 Max_Bit_So_Far : Uint; 7438 -- Records the maximum bit position so far. If all field positions 7439 -- are monotonically increasing, then we can skip the circuit for 7440 -- checking for overlap, since no overlap is possible. 7441 7442 Tagged_Parent : Entity_Id := Empty; 7443 -- This is set in the case of a derived tagged type for which we have 7444 -- Is_Fully_Repped_Tagged_Type True (indicating that all components are 7445 -- positioned by record representation clauses). In this case we must 7446 -- check for overlap between components of this tagged type, and the 7447 -- components of its parent. Tagged_Parent will point to this parent 7448 -- type. For all other cases Tagged_Parent is left set to Empty. 7449 7450 Parent_Last_Bit : Uint; 7451 -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the 7452 -- last bit position for any field in the parent type. We only need to 7453 -- check overlap for fields starting below this point. 7454 7455 Overlap_Check_Required : Boolean; 7456 -- Used to keep track of whether or not an overlap check is required 7457 7458 Overlap_Detected : Boolean := False; 7459 -- Set True if an overlap is detected 7460 7461 Ccount : Natural := 0; 7462 -- Number of component clauses in record rep clause 7463 7464 procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); 7465 -- Given two entities for record components or discriminants, checks 7466 -- if they have overlapping component clauses and issues errors if so. 7467 7468 procedure Find_Component; 7469 -- Finds component entity corresponding to current component clause (in 7470 -- CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin 7471 -- start/stop bits for the field. If there is no matching component or 7472 -- if the matching component does not have a component clause, then 7473 -- that's an error and Comp is set to Empty, but no error message is 7474 -- issued, since the message was already given. Comp is also set to 7475 -- Empty if the current "component clause" is in fact a pragma. 7476 7477 ----------------------------- 7478 -- Check_Component_Overlap -- 7479 ----------------------------- 7480 7481 procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is 7482 CC1 : constant Node_Id := Component_Clause (C1_Ent); 7483 CC2 : constant Node_Id := Component_Clause (C2_Ent); 7484 7485 begin 7486 if Present (CC1) and then Present (CC2) then 7487 7488 -- Exclude odd case where we have two tag components in the same 7489 -- record, both at location zero. This seems a bit strange, but 7490 -- it seems to happen in some circumstances, perhaps on an error. 7491 7492 if Chars (C1_Ent) = Name_uTag 7493 and then 7494 Chars (C2_Ent) = Name_uTag 7495 then 7496 return; 7497 end if; 7498 7499 -- Here we check if the two fields overlap 7500 7501 declare 7502 S1 : constant Uint := Component_Bit_Offset (C1_Ent); 7503 S2 : constant Uint := Component_Bit_Offset (C2_Ent); 7504 E1 : constant Uint := S1 + Esize (C1_Ent); 7505 E2 : constant Uint := S2 + Esize (C2_Ent); 7506 7507 begin 7508 if E2 <= S1 or else E1 <= S2 then 7509 null; 7510 else 7511 Error_Msg_Node_2 := Component_Name (CC2); 7512 Error_Msg_Sloc := Sloc (Error_Msg_Node_2); 7513 Error_Msg_Node_1 := Component_Name (CC1); 7514 Error_Msg_N 7515 ("component& overlaps & #", Component_Name (CC1)); 7516 Overlap_Detected := True; 7517 end if; 7518 end; 7519 end if; 7520 end Check_Component_Overlap; 7521 7522 -------------------- 7523 -- Find_Component -- 7524 -------------------- 7525 7526 procedure Find_Component is 7527 7528 procedure Search_Component (R : Entity_Id); 7529 -- Search components of R for a match. If found, Comp is set 7530 7531 ---------------------- 7532 -- Search_Component -- 7533 ---------------------- 7534 7535 procedure Search_Component (R : Entity_Id) is 7536 begin 7537 Comp := First_Component_Or_Discriminant (R); 7538 while Present (Comp) loop 7539 7540 -- Ignore error of attribute name for component name (we 7541 -- already gave an error message for this, so no need to 7542 -- complain here) 7543 7544 if Nkind (Component_Name (CC)) = N_Attribute_Reference then 7545 null; 7546 else 7547 exit when Chars (Comp) = Chars (Component_Name (CC)); 7548 end if; 7549 7550 Next_Component_Or_Discriminant (Comp); 7551 end loop; 7552 end Search_Component; 7553 7554 -- Start of processing for Find_Component 7555 7556 begin 7557 -- Return with Comp set to Empty if we have a pragma 7558 7559 if Nkind (CC) = N_Pragma then 7560 Comp := Empty; 7561 return; 7562 end if; 7563 7564 -- Search current record for matching component 7565 7566 Search_Component (Rectype); 7567 7568 -- If not found, maybe component of base type discriminant that is 7569 -- absent from statically constrained first subtype. 7570 7571 if No (Comp) then 7572 Search_Component (Base_Type (Rectype)); 7573 end if; 7574 7575 -- If no component, or the component does not reference the component 7576 -- clause in question, then there was some previous error for which 7577 -- we already gave a message, so just return with Comp Empty. 7578 7579 if No (Comp) or else Component_Clause (Comp) /= CC then 7580 Check_Error_Detected; 7581 Comp := Empty; 7582 7583 -- Normal case where we have a component clause 7584 7585 else 7586 Fbit := Component_Bit_Offset (Comp); 7587 Lbit := Fbit + Esize (Comp) - 1; 7588 end if; 7589 end Find_Component; 7590 7591 -- Start of processing for Check_Record_Representation_Clause 7592 7593 begin 7594 Find_Type (Ident); 7595 Rectype := Entity (Ident); 7596 7597 if Rectype = Any_Type then 7598 return; 7599 else 7600 Rectype := Underlying_Type (Rectype); 7601 end if; 7602 7603 -- See if we have a fully repped derived tagged type 7604 7605 declare 7606 PS : constant Entity_Id := Parent_Subtype (Rectype); 7607 7608 begin 7609 if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then 7610 Tagged_Parent := PS; 7611 7612 -- Find maximum bit of any component of the parent type 7613 7614 Parent_Last_Bit := UI_From_Int (System_Address_Size - 1); 7615 Pcomp := First_Entity (Tagged_Parent); 7616 while Present (Pcomp) loop 7617 if Ekind_In (Pcomp, E_Discriminant, E_Component) then 7618 if Component_Bit_Offset (Pcomp) /= No_Uint 7619 and then Known_Static_Esize (Pcomp) 7620 then 7621 Parent_Last_Bit := 7622 UI_Max 7623 (Parent_Last_Bit, 7624 Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); 7625 end if; 7626 7627 Next_Entity (Pcomp); 7628 end if; 7629 end loop; 7630 end if; 7631 end; 7632 7633 -- All done if no component clauses 7634 7635 CC := First (Component_Clauses (N)); 7636 7637 if No (CC) then 7638 return; 7639 end if; 7640 7641 -- If a tag is present, then create a component clause that places it 7642 -- at the start of the record (otherwise gigi may place it after other 7643 -- fields that have rep clauses). 7644 7645 Fent := First_Entity (Rectype); 7646 7647 if Nkind (Fent) = N_Defining_Identifier 7648 and then Chars (Fent) = Name_uTag 7649 then 7650 Set_Component_Bit_Offset (Fent, Uint_0); 7651 Set_Normalized_Position (Fent, Uint_0); 7652 Set_Normalized_First_Bit (Fent, Uint_0); 7653 Set_Normalized_Position_Max (Fent, Uint_0); 7654 Init_Esize (Fent, System_Address_Size); 7655 7656 Set_Component_Clause (Fent, 7657 Make_Component_Clause (Loc, 7658 Component_Name => Make_Identifier (Loc, Name_uTag), 7659 7660 Position => Make_Integer_Literal (Loc, Uint_0), 7661 First_Bit => Make_Integer_Literal (Loc, Uint_0), 7662 Last_Bit => 7663 Make_Integer_Literal (Loc, 7664 UI_From_Int (System_Address_Size)))); 7665 7666 Ccount := Ccount + 1; 7667 end if; 7668 7669 Max_Bit_So_Far := Uint_Minus_1; 7670 Overlap_Check_Required := False; 7671 7672 -- Process the component clauses 7673 7674 while Present (CC) loop 7675 Find_Component; 7676 7677 if Present (Comp) then 7678 Ccount := Ccount + 1; 7679 7680 -- We need a full overlap check if record positions non-monotonic 7681 7682 if Fbit <= Max_Bit_So_Far then 7683 Overlap_Check_Required := True; 7684 end if; 7685 7686 Max_Bit_So_Far := Lbit; 7687 7688 -- Check bit position out of range of specified size 7689 7690 if Has_Size_Clause (Rectype) 7691 and then RM_Size (Rectype) <= Lbit 7692 then 7693 Error_Msg_N 7694 ("bit number out of range of specified size", 7695 Last_Bit (CC)); 7696 7697 -- Check for overlap with tag component 7698 7699 else 7700 if Is_Tagged_Type (Rectype) 7701 and then Fbit < System_Address_Size 7702 then 7703 Error_Msg_NE 7704 ("component overlaps tag field of&", 7705 Component_Name (CC), Rectype); 7706 Overlap_Detected := True; 7707 end if; 7708 7709 if Hbit < Lbit then 7710 Hbit := Lbit; 7711 end if; 7712 end if; 7713 7714 -- Check parent overlap if component might overlap parent field 7715 7716 if Present (Tagged_Parent) and then Fbit <= Parent_Last_Bit then 7717 Pcomp := First_Component_Or_Discriminant (Tagged_Parent); 7718 while Present (Pcomp) loop 7719 if not Is_Tag (Pcomp) 7720 and then Chars (Pcomp) /= Name_uParent 7721 then 7722 Check_Component_Overlap (Comp, Pcomp); 7723 end if; 7724 7725 Next_Component_Or_Discriminant (Pcomp); 7726 end loop; 7727 end if; 7728 end if; 7729 7730 Next (CC); 7731 end loop; 7732 7733 -- Now that we have processed all the component clauses, check for 7734 -- overlap. We have to leave this till last, since the components can 7735 -- appear in any arbitrary order in the representation clause. 7736 7737 -- We do not need this check if all specified ranges were monotonic, 7738 -- as recorded by Overlap_Check_Required being False at this stage. 7739 7740 -- This first section checks if there are any overlapping entries at 7741 -- all. It does this by sorting all entries and then seeing if there are 7742 -- any overlaps. If there are none, then that is decisive, but if there 7743 -- are overlaps, they may still be OK (they may result from fields in 7744 -- different variants). 7745 7746 if Overlap_Check_Required then 7747 Overlap_Check1 : declare 7748 7749 OC_Fbit : array (0 .. Ccount) of Uint; 7750 -- First-bit values for component clauses, the value is the offset 7751 -- of the first bit of the field from start of record. The zero 7752 -- entry is for use in sorting. 7753 7754 OC_Lbit : array (0 .. Ccount) of Uint; 7755 -- Last-bit values for component clauses, the value is the offset 7756 -- of the last bit of the field from start of record. The zero 7757 -- entry is for use in sorting. 7758 7759 OC_Count : Natural := 0; 7760 -- Count of entries in OC_Fbit and OC_Lbit 7761 7762 function OC_Lt (Op1, Op2 : Natural) return Boolean; 7763 -- Compare routine for Sort 7764 7765 procedure OC_Move (From : Natural; To : Natural); 7766 -- Move routine for Sort 7767 7768 package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); 7769 7770 ----------- 7771 -- OC_Lt -- 7772 ----------- 7773 7774 function OC_Lt (Op1, Op2 : Natural) return Boolean is 7775 begin 7776 return OC_Fbit (Op1) < OC_Fbit (Op2); 7777 end OC_Lt; 7778 7779 ------------- 7780 -- OC_Move -- 7781 ------------- 7782 7783 procedure OC_Move (From : Natural; To : Natural) is 7784 begin 7785 OC_Fbit (To) := OC_Fbit (From); 7786 OC_Lbit (To) := OC_Lbit (From); 7787 end OC_Move; 7788 7789 -- Start of processing for Overlap_Check 7790 7791 begin 7792 CC := First (Component_Clauses (N)); 7793 while Present (CC) loop 7794 7795 -- Exclude component clause already marked in error 7796 7797 if not Error_Posted (CC) then 7798 Find_Component; 7799 7800 if Present (Comp) then 7801 OC_Count := OC_Count + 1; 7802 OC_Fbit (OC_Count) := Fbit; 7803 OC_Lbit (OC_Count) := Lbit; 7804 end if; 7805 end if; 7806 7807 Next (CC); 7808 end loop; 7809 7810 Sorting.Sort (OC_Count); 7811 7812 Overlap_Check_Required := False; 7813 for J in 1 .. OC_Count - 1 loop 7814 if OC_Lbit (J) >= OC_Fbit (J + 1) then 7815 Overlap_Check_Required := True; 7816 exit; 7817 end if; 7818 end loop; 7819 end Overlap_Check1; 7820 end if; 7821 7822 -- If Overlap_Check_Required is still True, then we have to do the full 7823 -- scale overlap check, since we have at least two fields that do 7824 -- overlap, and we need to know if that is OK since they are in 7825 -- different variant, or whether we have a definite problem. 7826 7827 if Overlap_Check_Required then 7828 Overlap_Check2 : declare 7829 C1_Ent, C2_Ent : Entity_Id; 7830 -- Entities of components being checked for overlap 7831 7832 Clist : Node_Id; 7833 -- Component_List node whose Component_Items are being checked 7834 7835 Citem : Node_Id; 7836 -- Component declaration for component being checked 7837 7838 begin 7839 C1_Ent := First_Entity (Base_Type (Rectype)); 7840 7841 -- Loop through all components in record. For each component check 7842 -- for overlap with any of the preceding elements on the component 7843 -- list containing the component and also, if the component is in 7844 -- a variant, check against components outside the case structure. 7845 -- This latter test is repeated recursively up the variant tree. 7846 7847 Main_Component_Loop : while Present (C1_Ent) loop 7848 if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then 7849 goto Continue_Main_Component_Loop; 7850 end if; 7851 7852 -- Skip overlap check if entity has no declaration node. This 7853 -- happens with discriminants in constrained derived types. 7854 -- Possibly we are missing some checks as a result, but that 7855 -- does not seem terribly serious. 7856 7857 if No (Declaration_Node (C1_Ent)) then 7858 goto Continue_Main_Component_Loop; 7859 end if; 7860 7861 Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); 7862 7863 -- Loop through component lists that need checking. Check the 7864 -- current component list and all lists in variants above us. 7865 7866 Component_List_Loop : loop 7867 7868 -- If derived type definition, go to full declaration 7869 -- If at outer level, check discriminants if there are any. 7870 7871 if Nkind (Clist) = N_Derived_Type_Definition then 7872 Clist := Parent (Clist); 7873 end if; 7874 7875 -- Outer level of record definition, check discriminants 7876 7877 if Nkind_In (Clist, N_Full_Type_Declaration, 7878 N_Private_Type_Declaration) 7879 then 7880 if Has_Discriminants (Defining_Identifier (Clist)) then 7881 C2_Ent := 7882 First_Discriminant (Defining_Identifier (Clist)); 7883 while Present (C2_Ent) loop 7884 exit when C1_Ent = C2_Ent; 7885 Check_Component_Overlap (C1_Ent, C2_Ent); 7886 Next_Discriminant (C2_Ent); 7887 end loop; 7888 end if; 7889 7890 -- Record extension case 7891 7892 elsif Nkind (Clist) = N_Derived_Type_Definition then 7893 Clist := Empty; 7894 7895 -- Otherwise check one component list 7896 7897 else 7898 Citem := First (Component_Items (Clist)); 7899 while Present (Citem) loop 7900 if Nkind (Citem) = N_Component_Declaration then 7901 C2_Ent := Defining_Identifier (Citem); 7902 exit when C1_Ent = C2_Ent; 7903 Check_Component_Overlap (C1_Ent, C2_Ent); 7904 end if; 7905 7906 Next (Citem); 7907 end loop; 7908 end if; 7909 7910 -- Check for variants above us (the parent of the Clist can 7911 -- be a variant, in which case its parent is a variant part, 7912 -- and the parent of the variant part is a component list 7913 -- whose components must all be checked against the current 7914 -- component for overlap). 7915 7916 if Nkind (Parent (Clist)) = N_Variant then 7917 Clist := Parent (Parent (Parent (Clist))); 7918 7919 -- Check for possible discriminant part in record, this 7920 -- is treated essentially as another level in the 7921 -- recursion. For this case the parent of the component 7922 -- list is the record definition, and its parent is the 7923 -- full type declaration containing the discriminant 7924 -- specifications. 7925 7926 elsif Nkind (Parent (Clist)) = N_Record_Definition then 7927 Clist := Parent (Parent ((Clist))); 7928 7929 -- If neither of these two cases, we are at the top of 7930 -- the tree. 7931 7932 else 7933 exit Component_List_Loop; 7934 end if; 7935 end loop Component_List_Loop; 7936 7937 <<Continue_Main_Component_Loop>> 7938 Next_Entity (C1_Ent); 7939 7940 end loop Main_Component_Loop; 7941 end Overlap_Check2; 7942 end if; 7943 7944 -- The following circuit deals with warning on record holes (gaps). We 7945 -- skip this check if overlap was detected, since it makes sense for the 7946 -- programmer to fix this illegality before worrying about warnings. 7947 7948 if not Overlap_Detected and Warn_On_Record_Holes then 7949 Record_Hole_Check : declare 7950 Decl : constant Node_Id := Declaration_Node (Base_Type (Rectype)); 7951 -- Full declaration of record type 7952 7953 procedure Check_Component_List 7954 (CL : Node_Id; 7955 Sbit : Uint; 7956 DS : List_Id); 7957 -- Check component list CL for holes. The starting bit should be 7958 -- Sbit. which is zero for the main record component list and set 7959 -- appropriately for recursive calls for variants. DS is set to 7960 -- a list of discriminant specifications to be included in the 7961 -- consideration of components. It is No_List if none to consider. 7962 7963 -------------------------- 7964 -- Check_Component_List -- 7965 -------------------------- 7966 7967 procedure Check_Component_List 7968 (CL : Node_Id; 7969 Sbit : Uint; 7970 DS : List_Id) 7971 is 7972 Compl : Integer; 7973 7974 begin 7975 Compl := Integer (List_Length (Component_Items (CL))); 7976 7977 if DS /= No_List then 7978 Compl := Compl + Integer (List_Length (DS)); 7979 end if; 7980 7981 declare 7982 Comps : array (Natural range 0 .. Compl) of Entity_Id; 7983 -- Gather components (zero entry is for sort routine) 7984 7985 Ncomps : Natural := 0; 7986 -- Number of entries stored in Comps (starting at Comps (1)) 7987 7988 Citem : Node_Id; 7989 -- One component item or discriminant specification 7990 7991 Nbit : Uint; 7992 -- Starting bit for next component 7993 7994 CEnt : Entity_Id; 7995 -- Component entity 7996 7997 Variant : Node_Id; 7998 -- One variant 7999 8000 function Lt (Op1, Op2 : Natural) return Boolean; 8001 -- Compare routine for Sort 8002 8003 procedure Move (From : Natural; To : Natural); 8004 -- Move routine for Sort 8005 8006 package Sorting is new GNAT.Heap_Sort_G (Move, Lt); 8007 8008 -------- 8009 -- Lt -- 8010 -------- 8011 8012 function Lt (Op1, Op2 : Natural) return Boolean is 8013 begin 8014 return Component_Bit_Offset (Comps (Op1)) 8015 < 8016 Component_Bit_Offset (Comps (Op2)); 8017 end Lt; 8018 8019 ---------- 8020 -- Move -- 8021 ---------- 8022 8023 procedure Move (From : Natural; To : Natural) is 8024 begin 8025 Comps (To) := Comps (From); 8026 end Move; 8027 8028 begin 8029 -- Gather discriminants into Comp 8030 8031 if DS /= No_List then 8032 Citem := First (DS); 8033 while Present (Citem) loop 8034 if Nkind (Citem) = N_Discriminant_Specification then 8035 declare 8036 Ent : constant Entity_Id := 8037 Defining_Identifier (Citem); 8038 begin 8039 if Ekind (Ent) = E_Discriminant then 8040 Ncomps := Ncomps + 1; 8041 Comps (Ncomps) := Ent; 8042 end if; 8043 end; 8044 end if; 8045 8046 Next (Citem); 8047 end loop; 8048 end if; 8049 8050 -- Gather component entities into Comp 8051 8052 Citem := First (Component_Items (CL)); 8053 while Present (Citem) loop 8054 if Nkind (Citem) = N_Component_Declaration then 8055 Ncomps := Ncomps + 1; 8056 Comps (Ncomps) := Defining_Identifier (Citem); 8057 end if; 8058 8059 Next (Citem); 8060 end loop; 8061 8062 -- Now sort the component entities based on the first bit. 8063 -- Note we already know there are no overlapping components. 8064 8065 Sorting.Sort (Ncomps); 8066 8067 -- Loop through entries checking for holes 8068 8069 Nbit := Sbit; 8070 for J in 1 .. Ncomps loop 8071 CEnt := Comps (J); 8072 Error_Msg_Uint_1 := Component_Bit_Offset (CEnt) - Nbit; 8073 8074 if Error_Msg_Uint_1 > 0 then 8075 Error_Msg_NE 8076 ("?H?^-bit gap before component&", 8077 Component_Name (Component_Clause (CEnt)), CEnt); 8078 end if; 8079 8080 Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt); 8081 end loop; 8082 8083 -- Process variant parts recursively if present 8084 8085 if Present (Variant_Part (CL)) then 8086 Variant := First (Variants (Variant_Part (CL))); 8087 while Present (Variant) loop 8088 Check_Component_List 8089 (Component_List (Variant), Nbit, No_List); 8090 Next (Variant); 8091 end loop; 8092 end if; 8093 end; 8094 end Check_Component_List; 8095 8096 -- Start of processing for Record_Hole_Check 8097 8098 begin 8099 declare 8100 Sbit : Uint; 8101 8102 begin 8103 if Is_Tagged_Type (Rectype) then 8104 Sbit := UI_From_Int (System_Address_Size); 8105 else 8106 Sbit := Uint_0; 8107 end if; 8108 8109 if Nkind (Decl) = N_Full_Type_Declaration 8110 and then Nkind (Type_Definition (Decl)) = N_Record_Definition 8111 then 8112 Check_Component_List 8113 (Component_List (Type_Definition (Decl)), 8114 Sbit, 8115 Discriminant_Specifications (Decl)); 8116 end if; 8117 end; 8118 end Record_Hole_Check; 8119 end if; 8120 8121 -- For records that have component clauses for all components, and whose 8122 -- size is less than or equal to 32, we need to know the size in the 8123 -- front end to activate possible packed array processing where the 8124 -- component type is a record. 8125 8126 -- At this stage Hbit + 1 represents the first unused bit from all the 8127 -- component clauses processed, so if the component clauses are 8128 -- complete, then this is the length of the record. 8129 8130 -- For records longer than System.Storage_Unit, and for those where not 8131 -- all components have component clauses, the back end determines the 8132 -- length (it may for example be appropriate to round up the size 8133 -- to some convenient boundary, based on alignment considerations, etc). 8134 8135 if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then 8136 8137 -- Nothing to do if at least one component has no component clause 8138 8139 Comp := First_Component_Or_Discriminant (Rectype); 8140 while Present (Comp) loop 8141 exit when No (Component_Clause (Comp)); 8142 Next_Component_Or_Discriminant (Comp); 8143 end loop; 8144 8145 -- If we fall out of loop, all components have component clauses 8146 -- and so we can set the size to the maximum value. 8147 8148 if No (Comp) then 8149 Set_RM_Size (Rectype, Hbit + 1); 8150 end if; 8151 end if; 8152 end Check_Record_Representation_Clause; 8153 8154 ---------------- 8155 -- Check_Size -- 8156 ---------------- 8157 8158 procedure Check_Size 8159 (N : Node_Id; 8160 T : Entity_Id; 8161 Siz : Uint; 8162 Biased : out Boolean) 8163 is 8164 UT : constant Entity_Id := Underlying_Type (T); 8165 M : Uint; 8166 8167 begin 8168 Biased := False; 8169 8170 -- Reject patently improper size values. 8171 8172 if Is_Elementary_Type (T) 8173 and then Siz > UI_From_Int (Int'Last) 8174 then 8175 Error_Msg_N ("Size value too large for elementary type", N); 8176 8177 if Nkind (Original_Node (N)) = N_Op_Expon then 8178 Error_Msg_N 8179 ("\maybe '* was meant, rather than '*'*", Original_Node (N)); 8180 end if; 8181 end if; 8182 8183 -- Dismiss generic types 8184 8185 if Is_Generic_Type (T) 8186 or else 8187 Is_Generic_Type (UT) 8188 or else 8189 Is_Generic_Type (Root_Type (UT)) 8190 then 8191 return; 8192 8193 -- Guard against previous errors 8194 8195 elsif No (UT) or else UT = Any_Type then 8196 Check_Error_Detected; 8197 return; 8198 8199 -- Check case of bit packed array 8200 8201 elsif Is_Array_Type (UT) 8202 and then Known_Static_Component_Size (UT) 8203 and then Is_Bit_Packed_Array (UT) 8204 then 8205 declare 8206 Asiz : Uint; 8207 Indx : Node_Id; 8208 Ityp : Entity_Id; 8209 8210 begin 8211 Asiz := Component_Size (UT); 8212 Indx := First_Index (UT); 8213 loop 8214 Ityp := Etype (Indx); 8215 8216 -- If non-static bound, then we are not in the business of 8217 -- trying to check the length, and indeed an error will be 8218 -- issued elsewhere, since sizes of non-static array types 8219 -- cannot be set implicitly or explicitly. 8220 8221 if not Is_Static_Subtype (Ityp) then 8222 return; 8223 end if; 8224 8225 -- Otherwise accumulate next dimension 8226 8227 Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) - 8228 Expr_Value (Type_Low_Bound (Ityp)) + 8229 Uint_1); 8230 8231 Next_Index (Indx); 8232 exit when No (Indx); 8233 end loop; 8234 8235 if Asiz <= Siz then 8236 return; 8237 8238 else 8239 Error_Msg_Uint_1 := Asiz; 8240 Error_Msg_NE 8241 ("size for& too small, minimum allowed is ^", N, T); 8242 Set_Esize (T, Asiz); 8243 Set_RM_Size (T, Asiz); 8244 end if; 8245 end; 8246 8247 -- All other composite types are ignored 8248 8249 elsif Is_Composite_Type (UT) then 8250 return; 8251 8252 -- For fixed-point types, don't check minimum if type is not frozen, 8253 -- since we don't know all the characteristics of the type that can 8254 -- affect the size (e.g. a specified small) till freeze time. 8255 8256 elsif Is_Fixed_Point_Type (UT) 8257 and then not Is_Frozen (UT) 8258 then 8259 null; 8260 8261 -- Cases for which a minimum check is required 8262 8263 else 8264 -- Ignore if specified size is correct for the type 8265 8266 if Known_Esize (UT) and then Siz = Esize (UT) then 8267 return; 8268 end if; 8269 8270 -- Otherwise get minimum size 8271 8272 M := UI_From_Int (Minimum_Size (UT)); 8273 8274 if Siz < M then 8275 8276 -- Size is less than minimum size, but one possibility remains 8277 -- that we can manage with the new size if we bias the type. 8278 8279 M := UI_From_Int (Minimum_Size (UT, Biased => True)); 8280 8281 if Siz < M then 8282 Error_Msg_Uint_1 := M; 8283 Error_Msg_NE 8284 ("size for& too small, minimum allowed is ^", N, T); 8285 Set_Esize (T, M); 8286 Set_RM_Size (T, M); 8287 else 8288 Biased := True; 8289 end if; 8290 end if; 8291 end if; 8292 end Check_Size; 8293 8294 ------------------------- 8295 -- Get_Alignment_Value -- 8296 ------------------------- 8297 8298 function Get_Alignment_Value (Expr : Node_Id) return Uint is 8299 Align : constant Uint := Static_Integer (Expr); 8300 8301 begin 8302 if Align = No_Uint then 8303 return No_Uint; 8304 8305 elsif Align <= 0 then 8306 Error_Msg_N ("alignment value must be positive", Expr); 8307 return No_Uint; 8308 8309 else 8310 for J in Int range 0 .. 64 loop 8311 declare 8312 M : constant Uint := Uint_2 ** J; 8313 8314 begin 8315 exit when M = Align; 8316 8317 if M > Align then 8318 Error_Msg_N 8319 ("alignment value must be power of 2", Expr); 8320 return No_Uint; 8321 end if; 8322 end; 8323 end loop; 8324 8325 return Align; 8326 end if; 8327 end Get_Alignment_Value; 8328 8329 ------------------------------------- 8330 -- Inherit_Aspects_At_Freeze_Point -- 8331 ------------------------------------- 8332 8333 procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is 8334 function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 8335 (Rep_Item : Node_Id) return Boolean; 8336 -- This routine checks if Rep_Item is either a pragma or an aspect 8337 -- specification node whose correponding pragma (if any) is present in 8338 -- the Rep Item chain of the entity it has been specified to. 8339 8340 -------------------------------------------------- 8341 -- Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item -- 8342 -------------------------------------------------- 8343 8344 function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 8345 (Rep_Item : Node_Id) return Boolean 8346 is 8347 begin 8348 return Nkind (Rep_Item) = N_Pragma 8349 or else Present_In_Rep_Item 8350 (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item)); 8351 end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item; 8352 8353 -- Start of processing for Inherit_Aspects_At_Freeze_Point 8354 8355 begin 8356 -- A representation item is either subtype-specific (Size and Alignment 8357 -- clauses) or type-related (all others). Subtype-specific aspects may 8358 -- differ for different subtypes of the same type (RM 13.1.8). 8359 8360 -- A derived type inherits each type-related representation aspect of 8361 -- its parent type that was directly specified before the declaration of 8362 -- the derived type (RM 13.1.15). 8363 8364 -- A derived subtype inherits each subtype-specific representation 8365 -- aspect of its parent subtype that was directly specified before the 8366 -- declaration of the derived type (RM 13.1.15). 8367 8368 -- The general processing involves inheriting a representation aspect 8369 -- from a parent type whenever the first rep item (aspect specification, 8370 -- attribute definition clause, pragma) corresponding to the given 8371 -- representation aspect in the rep item chain of Typ, if any, isn't 8372 -- directly specified to Typ but to one of its parents. 8373 8374 -- ??? Note that, for now, just a limited number of representation 8375 -- aspects have been inherited here so far. Many of them are 8376 -- still inherited in Sem_Ch3. This will be fixed soon. Here is 8377 -- a non- exhaustive list of aspects that likely also need to 8378 -- be moved to this routine: Alignment, Component_Alignment, 8379 -- Component_Size, Machine_Radix, Object_Size, Pack, Predicates, 8380 -- Preelaborable_Initialization, RM_Size and Small. 8381 8382 if Nkind (Parent (Typ)) = N_Private_Extension_Declaration then 8383 return; 8384 end if; 8385 8386 -- Ada_05/Ada_2005 8387 8388 if not Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005, False) 8389 and then Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005) 8390 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 8391 (Get_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005)) 8392 then 8393 Set_Is_Ada_2005_Only (Typ); 8394 end if; 8395 8396 -- Ada_12/Ada_2012 8397 8398 if not Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012, False) 8399 and then Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012) 8400 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 8401 (Get_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012)) 8402 then 8403 Set_Is_Ada_2012_Only (Typ); 8404 end if; 8405 8406 -- Atomic/Shared 8407 8408 if not Has_Rep_Item (Typ, Name_Atomic, Name_Shared, False) 8409 and then Has_Rep_Pragma (Typ, Name_Atomic, Name_Shared) 8410 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 8411 (Get_Rep_Item (Typ, Name_Atomic, Name_Shared)) 8412 then 8413 Set_Is_Atomic (Typ); 8414 Set_Treat_As_Volatile (Typ); 8415 Set_Is_Volatile (Typ); 8416 end if; 8417 8418 -- Default_Component_Value 8419 8420 if Is_Array_Type (Typ) 8421 and then Has_Rep_Item (Typ, Name_Default_Component_Value, False) 8422 and then Has_Rep_Item (Typ, Name_Default_Component_Value) 8423 then 8424 Set_Default_Aspect_Component_Value (Typ, 8425 Default_Aspect_Component_Value 8426 (Entity (Get_Rep_Item (Typ, Name_Default_Component_Value)))); 8427 end if; 8428 8429 -- Default_Value 8430 8431 if Is_Scalar_Type (Typ) 8432 and then Has_Rep_Item (Typ, Name_Default_Value, False) 8433 and then Has_Rep_Item (Typ, Name_Default_Value) 8434 then 8435 Set_Default_Aspect_Value (Typ, 8436 Default_Aspect_Value 8437 (Entity (Get_Rep_Item (Typ, Name_Default_Value)))); 8438 end if; 8439 8440 -- Discard_Names 8441 8442 if not Has_Rep_Item (Typ, Name_Discard_Names, False) 8443 and then Has_Rep_Item (Typ, Name_Discard_Names) 8444 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 8445 (Get_Rep_Item (Typ, Name_Discard_Names)) 8446 then 8447 Set_Discard_Names (Typ); 8448 end if; 8449 8450 -- Invariants 8451 8452 if not Has_Rep_Item (Typ, Name_Invariant, False) 8453 and then Has_Rep_Item (Typ, Name_Invariant) 8454 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 8455 (Get_Rep_Item (Typ, Name_Invariant)) 8456 then 8457 Set_Has_Invariants (Typ); 8458 8459 if Class_Present (Get_Rep_Item (Typ, Name_Invariant)) then 8460 Set_Has_Inheritable_Invariants (Typ); 8461 end if; 8462 end if; 8463 8464 -- Volatile 8465 8466 if not Has_Rep_Item (Typ, Name_Volatile, False) 8467 and then Has_Rep_Item (Typ, Name_Volatile) 8468 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 8469 (Get_Rep_Item (Typ, Name_Volatile)) 8470 then 8471 Set_Treat_As_Volatile (Typ); 8472 Set_Is_Volatile (Typ); 8473 end if; 8474 8475 -- Inheritance for derived types only 8476 8477 if Is_Derived_Type (Typ) then 8478 declare 8479 Bas_Typ : constant Entity_Id := Base_Type (Typ); 8480 Imp_Bas_Typ : constant Entity_Id := Implementation_Base_Type (Typ); 8481 8482 begin 8483 -- Atomic_Components 8484 8485 if not Has_Rep_Item (Typ, Name_Atomic_Components, False) 8486 and then Has_Rep_Item (Typ, Name_Atomic_Components) 8487 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 8488 (Get_Rep_Item (Typ, Name_Atomic_Components)) 8489 then 8490 Set_Has_Atomic_Components (Imp_Bas_Typ); 8491 end if; 8492 8493 -- Volatile_Components 8494 8495 if not Has_Rep_Item (Typ, Name_Volatile_Components, False) 8496 and then Has_Rep_Item (Typ, Name_Volatile_Components) 8497 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 8498 (Get_Rep_Item (Typ, Name_Volatile_Components)) 8499 then 8500 Set_Has_Volatile_Components (Imp_Bas_Typ); 8501 end if; 8502 8503 -- Finalize_Storage_Only. 8504 8505 if not Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only, False) 8506 and then Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only) 8507 then 8508 Set_Finalize_Storage_Only (Bas_Typ); 8509 end if; 8510 8511 -- Universal_Aliasing 8512 8513 if not Has_Rep_Item (Typ, Name_Universal_Aliasing, False) 8514 and then Has_Rep_Item (Typ, Name_Universal_Aliasing) 8515 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 8516 (Get_Rep_Item (Typ, Name_Universal_Aliasing)) 8517 then 8518 Set_Universal_Aliasing (Imp_Bas_Typ); 8519 end if; 8520 8521 -- Record type specific aspects 8522 8523 if Is_Record_Type (Typ) then 8524 8525 -- Bit_Order 8526 8527 if not Has_Rep_Item (Typ, Name_Bit_Order, False) 8528 and then Has_Rep_Item (Typ, Name_Bit_Order) 8529 then 8530 Set_Reverse_Bit_Order (Bas_Typ, 8531 Reverse_Bit_Order (Entity (Name 8532 (Get_Rep_Item (Typ, Name_Bit_Order))))); 8533 end if; 8534 8535 -- Scalar_Storage_Order 8536 8537 if not Has_Rep_Item (Typ, Name_Scalar_Storage_Order, False) 8538 and then Has_Rep_Item (Typ, Name_Scalar_Storage_Order) 8539 then 8540 Set_Reverse_Storage_Order (Bas_Typ, 8541 Reverse_Storage_Order (Entity (Name 8542 (Get_Rep_Item (Typ, Name_Scalar_Storage_Order))))); 8543 end if; 8544 end if; 8545 end; 8546 end if; 8547 end Inherit_Aspects_At_Freeze_Point; 8548 8549 ---------------- 8550 -- Initialize -- 8551 ---------------- 8552 8553 procedure Initialize is 8554 begin 8555 Address_Clause_Checks.Init; 8556 Independence_Checks.Init; 8557 Unchecked_Conversions.Init; 8558 end Initialize; 8559 8560 ------------------------- 8561 -- Is_Operational_Item -- 8562 ------------------------- 8563 8564 function Is_Operational_Item (N : Node_Id) return Boolean is 8565 begin 8566 if Nkind (N) /= N_Attribute_Definition_Clause then 8567 return False; 8568 8569 else 8570 declare 8571 Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); 8572 begin 8573 return Id = Attribute_Input 8574 or else Id = Attribute_Output 8575 or else Id = Attribute_Read 8576 or else Id = Attribute_Write 8577 or else Id = Attribute_External_Tag; 8578 end; 8579 end if; 8580 end Is_Operational_Item; 8581 8582 ------------------ 8583 -- Minimum_Size -- 8584 ------------------ 8585 8586 function Minimum_Size 8587 (T : Entity_Id; 8588 Biased : Boolean := False) return Nat 8589 is 8590 Lo : Uint := No_Uint; 8591 Hi : Uint := No_Uint; 8592 LoR : Ureal := No_Ureal; 8593 HiR : Ureal := No_Ureal; 8594 LoSet : Boolean := False; 8595 HiSet : Boolean := False; 8596 B : Uint; 8597 S : Nat; 8598 Ancest : Entity_Id; 8599 R_Typ : constant Entity_Id := Root_Type (T); 8600 8601 begin 8602 -- If bad type, return 0 8603 8604 if T = Any_Type then 8605 return 0; 8606 8607 -- For generic types, just return zero. There cannot be any legitimate 8608 -- need to know such a size, but this routine may be called with a 8609 -- generic type as part of normal processing. 8610 8611 elsif Is_Generic_Type (R_Typ) 8612 or else R_Typ = Any_Type 8613 then 8614 return 0; 8615 8616 -- Access types. Normally an access type cannot have a size smaller 8617 -- than the size of System.Address. The exception is on VMS, where 8618 -- we have short and long addresses, and it is possible for an access 8619 -- type to have a short address size (and thus be less than the size 8620 -- of System.Address itself). We simply skip the check for VMS, and 8621 -- leave it to the back end to do the check. 8622 8623 elsif Is_Access_Type (T) then 8624 if OpenVMS_On_Target then 8625 return 0; 8626 else 8627 return System_Address_Size; 8628 end if; 8629 8630 -- Floating-point types 8631 8632 elsif Is_Floating_Point_Type (T) then 8633 return UI_To_Int (Esize (R_Typ)); 8634 8635 -- Discrete types 8636 8637 elsif Is_Discrete_Type (T) then 8638 8639 -- The following loop is looking for the nearest compile time known 8640 -- bounds following the ancestor subtype chain. The idea is to find 8641 -- the most restrictive known bounds information. 8642 8643 Ancest := T; 8644 loop 8645 if Ancest = Any_Type or else Etype (Ancest) = Any_Type then 8646 return 0; 8647 end if; 8648 8649 if not LoSet then 8650 if Compile_Time_Known_Value (Type_Low_Bound (Ancest)) then 8651 Lo := Expr_Rep_Value (Type_Low_Bound (Ancest)); 8652 LoSet := True; 8653 exit when HiSet; 8654 end if; 8655 end if; 8656 8657 if not HiSet then 8658 if Compile_Time_Known_Value (Type_High_Bound (Ancest)) then 8659 Hi := Expr_Rep_Value (Type_High_Bound (Ancest)); 8660 HiSet := True; 8661 exit when LoSet; 8662 end if; 8663 end if; 8664 8665 Ancest := Ancestor_Subtype (Ancest); 8666 8667 if No (Ancest) then 8668 Ancest := Base_Type (T); 8669 8670 if Is_Generic_Type (Ancest) then 8671 return 0; 8672 end if; 8673 end if; 8674 end loop; 8675 8676 -- Fixed-point types. We can't simply use Expr_Value to get the 8677 -- Corresponding_Integer_Value values of the bounds, since these do not 8678 -- get set till the type is frozen, and this routine can be called 8679 -- before the type is frozen. Similarly the test for bounds being static 8680 -- needs to include the case where we have unanalyzed real literals for 8681 -- the same reason. 8682 8683 elsif Is_Fixed_Point_Type (T) then 8684 8685 -- The following loop is looking for the nearest compile time known 8686 -- bounds following the ancestor subtype chain. The idea is to find 8687 -- the most restrictive known bounds information. 8688 8689 Ancest := T; 8690 loop 8691 if Ancest = Any_Type or else Etype (Ancest) = Any_Type then 8692 return 0; 8693 end if; 8694 8695 -- Note: In the following two tests for LoSet and HiSet, it may 8696 -- seem redundant to test for N_Real_Literal here since normally 8697 -- one would assume that the test for the value being known at 8698 -- compile time includes this case. However, there is a glitch. 8699 -- If the real literal comes from folding a non-static expression, 8700 -- then we don't consider any non- static expression to be known 8701 -- at compile time if we are in configurable run time mode (needed 8702 -- in some cases to give a clearer definition of what is and what 8703 -- is not accepted). So the test is indeed needed. Without it, we 8704 -- would set neither Lo_Set nor Hi_Set and get an infinite loop. 8705 8706 if not LoSet then 8707 if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal 8708 or else Compile_Time_Known_Value (Type_Low_Bound (Ancest)) 8709 then 8710 LoR := Expr_Value_R (Type_Low_Bound (Ancest)); 8711 LoSet := True; 8712 exit when HiSet; 8713 end if; 8714 end if; 8715 8716 if not HiSet then 8717 if Nkind (Type_High_Bound (Ancest)) = N_Real_Literal 8718 or else Compile_Time_Known_Value (Type_High_Bound (Ancest)) 8719 then 8720 HiR := Expr_Value_R (Type_High_Bound (Ancest)); 8721 HiSet := True; 8722 exit when LoSet; 8723 end if; 8724 end if; 8725 8726 Ancest := Ancestor_Subtype (Ancest); 8727 8728 if No (Ancest) then 8729 Ancest := Base_Type (T); 8730 8731 if Is_Generic_Type (Ancest) then 8732 return 0; 8733 end if; 8734 end if; 8735 end loop; 8736 8737 Lo := UR_To_Uint (LoR / Small_Value (T)); 8738 Hi := UR_To_Uint (HiR / Small_Value (T)); 8739 8740 -- No other types allowed 8741 8742 else 8743 raise Program_Error; 8744 end if; 8745 8746 -- Fall through with Hi and Lo set. Deal with biased case 8747 8748 if (Biased 8749 and then not Is_Fixed_Point_Type (T) 8750 and then not (Is_Enumeration_Type (T) 8751 and then Has_Non_Standard_Rep (T))) 8752 or else Has_Biased_Representation (T) 8753 then 8754 Hi := Hi - Lo; 8755 Lo := Uint_0; 8756 end if; 8757 8758 -- Signed case. Note that we consider types like range 1 .. -1 to be 8759 -- signed for the purpose of computing the size, since the bounds have 8760 -- to be accommodated in the base type. 8761 8762 if Lo < 0 or else Hi < 0 then 8763 S := 1; 8764 B := Uint_1; 8765 8766 -- S = size, B = 2 ** (size - 1) (can accommodate -B .. +(B - 1)) 8767 -- Note that we accommodate the case where the bounds cross. This 8768 -- can happen either because of the way the bounds are declared 8769 -- or because of the algorithm in Freeze_Fixed_Point_Type. 8770 8771 while Lo < -B 8772 or else Hi < -B 8773 or else Lo >= B 8774 or else Hi >= B 8775 loop 8776 B := Uint_2 ** S; 8777 S := S + 1; 8778 end loop; 8779 8780 -- Unsigned case 8781 8782 else 8783 -- If both bounds are positive, make sure that both are represen- 8784 -- table in the case where the bounds are crossed. This can happen 8785 -- either because of the way the bounds are declared, or because of 8786 -- the algorithm in Freeze_Fixed_Point_Type. 8787 8788 if Lo > Hi then 8789 Hi := Lo; 8790 end if; 8791 8792 -- S = size, (can accommodate 0 .. (2**size - 1)) 8793 8794 S := 0; 8795 while Hi >= Uint_2 ** S loop 8796 S := S + 1; 8797 end loop; 8798 end if; 8799 8800 return S; 8801 end Minimum_Size; 8802 8803 --------------------------- 8804 -- New_Stream_Subprogram -- 8805 --------------------------- 8806 8807 procedure New_Stream_Subprogram 8808 (N : Node_Id; 8809 Ent : Entity_Id; 8810 Subp : Entity_Id; 8811 Nam : TSS_Name_Type) 8812 is 8813 Loc : constant Source_Ptr := Sloc (N); 8814 Sname : constant Name_Id := Make_TSS_Name (Base_Type (Ent), Nam); 8815 Subp_Id : Entity_Id; 8816 Subp_Decl : Node_Id; 8817 F : Entity_Id; 8818 Etyp : Entity_Id; 8819 8820 Defer_Declaration : constant Boolean := 8821 Is_Tagged_Type (Ent) or else Is_Private_Type (Ent); 8822 -- For a tagged type, there is a declaration for each stream attribute 8823 -- at the freeze point, and we must generate only a completion of this 8824 -- declaration. We do the same for private types, because the full view 8825 -- might be tagged. Otherwise we generate a declaration at the point of 8826 -- the attribute definition clause. 8827 8828 function Build_Spec return Node_Id; 8829 -- Used for declaration and renaming declaration, so that this is 8830 -- treated as a renaming_as_body. 8831 8832 ---------------- 8833 -- Build_Spec -- 8834 ---------------- 8835 8836 function Build_Spec return Node_Id is 8837 Out_P : constant Boolean := (Nam = TSS_Stream_Read); 8838 Formals : List_Id; 8839 Spec : Node_Id; 8840 T_Ref : constant Node_Id := New_Reference_To (Etyp, Loc); 8841 8842 begin 8843 Subp_Id := Make_Defining_Identifier (Loc, Sname); 8844 8845 -- S : access Root_Stream_Type'Class 8846 8847 Formals := New_List ( 8848 Make_Parameter_Specification (Loc, 8849 Defining_Identifier => 8850 Make_Defining_Identifier (Loc, Name_S), 8851 Parameter_Type => 8852 Make_Access_Definition (Loc, 8853 Subtype_Mark => 8854 New_Reference_To ( 8855 Designated_Type (Etype (F)), Loc)))); 8856 8857 if Nam = TSS_Stream_Input then 8858 Spec := 8859 Make_Function_Specification (Loc, 8860 Defining_Unit_Name => Subp_Id, 8861 Parameter_Specifications => Formals, 8862 Result_Definition => T_Ref); 8863 else 8864 -- V : [out] T 8865 8866 Append_To (Formals, 8867 Make_Parameter_Specification (Loc, 8868 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 8869 Out_Present => Out_P, 8870 Parameter_Type => T_Ref)); 8871 8872 Spec := 8873 Make_Procedure_Specification (Loc, 8874 Defining_Unit_Name => Subp_Id, 8875 Parameter_Specifications => Formals); 8876 end if; 8877 8878 return Spec; 8879 end Build_Spec; 8880 8881 -- Start of processing for New_Stream_Subprogram 8882 8883 begin 8884 F := First_Formal (Subp); 8885 8886 if Ekind (Subp) = E_Procedure then 8887 Etyp := Etype (Next_Formal (F)); 8888 else 8889 Etyp := Etype (Subp); 8890 end if; 8891 8892 -- Prepare subprogram declaration and insert it as an action on the 8893 -- clause node. The visibility for this entity is used to test for 8894 -- visibility of the attribute definition clause (in the sense of 8895 -- 8.3(23) as amended by AI-195). 8896 8897 if not Defer_Declaration then 8898 Subp_Decl := 8899 Make_Subprogram_Declaration (Loc, 8900 Specification => Build_Spec); 8901 8902 -- For a tagged type, there is always a visible declaration for each 8903 -- stream TSS (it is a predefined primitive operation), and the 8904 -- completion of this declaration occurs at the freeze point, which is 8905 -- not always visible at places where the attribute definition clause is 8906 -- visible. So, we create a dummy entity here for the purpose of 8907 -- tracking the visibility of the attribute definition clause itself. 8908 8909 else 8910 Subp_Id := 8911 Make_Defining_Identifier (Loc, New_External_Name (Sname, 'V')); 8912 Subp_Decl := 8913 Make_Object_Declaration (Loc, 8914 Defining_Identifier => Subp_Id, 8915 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc)); 8916 end if; 8917 8918 Insert_Action (N, Subp_Decl); 8919 Set_Entity (N, Subp_Id); 8920 8921 Subp_Decl := 8922 Make_Subprogram_Renaming_Declaration (Loc, 8923 Specification => Build_Spec, 8924 Name => New_Reference_To (Subp, Loc)); 8925 8926 if Defer_Declaration then 8927 Set_TSS (Base_Type (Ent), Subp_Id); 8928 else 8929 Insert_Action (N, Subp_Decl); 8930 Copy_TSS (Subp_Id, Base_Type (Ent)); 8931 end if; 8932 end New_Stream_Subprogram; 8933 8934 ------------------------ 8935 -- Rep_Item_Too_Early -- 8936 ------------------------ 8937 8938 function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is 8939 begin 8940 -- Cannot apply non-operational rep items to generic types 8941 8942 if Is_Operational_Item (N) then 8943 return False; 8944 8945 elsif Is_Type (T) 8946 and then Is_Generic_Type (Root_Type (T)) 8947 then 8948 Error_Msg_N ("representation item not allowed for generic type", N); 8949 return True; 8950 end if; 8951 8952 -- Otherwise check for incomplete type 8953 8954 if Is_Incomplete_Or_Private_Type (T) 8955 and then No (Underlying_Type (T)) 8956 and then 8957 (Nkind (N) /= N_Pragma 8958 or else Get_Pragma_Id (N) /= Pragma_Import) 8959 then 8960 Error_Msg_N 8961 ("representation item must be after full type declaration", N); 8962 return True; 8963 8964 -- If the type has incomplete components, a representation clause is 8965 -- illegal but stream attributes and Convention pragmas are correct. 8966 8967 elsif Has_Private_Component (T) then 8968 if Nkind (N) = N_Pragma then 8969 return False; 8970 8971 else 8972 Error_Msg_N 8973 ("representation item must appear after type is fully defined", 8974 N); 8975 return True; 8976 end if; 8977 else 8978 return False; 8979 end if; 8980 end Rep_Item_Too_Early; 8981 8982 ----------------------- 8983 -- Rep_Item_Too_Late -- 8984 ----------------------- 8985 8986 function Rep_Item_Too_Late 8987 (T : Entity_Id; 8988 N : Node_Id; 8989 FOnly : Boolean := False) return Boolean 8990 is 8991 S : Entity_Id; 8992 Parent_Type : Entity_Id; 8993 8994 procedure Too_Late; 8995 -- Output the too late message. Note that this is not considered a 8996 -- serious error, since the effect is simply that we ignore the 8997 -- representation clause in this case. 8998 8999 -------------- 9000 -- Too_Late -- 9001 -------------- 9002 9003 procedure Too_Late is 9004 begin 9005 Error_Msg_N ("|representation item appears too late!", N); 9006 end Too_Late; 9007 9008 -- Start of processing for Rep_Item_Too_Late 9009 9010 begin 9011 -- First make sure entity is not frozen (RM 13.1(9)) 9012 9013 if Is_Frozen (T) 9014 9015 -- Exclude imported types, which may be frozen if they appear in a 9016 -- representation clause for a local type. 9017 9018 and then not From_With_Type (T) 9019 9020 -- Exclude generated entitiesa (not coming from source). The common 9021 -- case is when we generate a renaming which prematurely freezes the 9022 -- renamed internal entity, but we still want to be able to set copies 9023 -- of attribute values such as Size/Alignment. 9024 9025 and then Comes_From_Source (T) 9026 then 9027 Too_Late; 9028 S := First_Subtype (T); 9029 9030 if Present (Freeze_Node (S)) then 9031 Error_Msg_NE 9032 ("??no more representation items for }", Freeze_Node (S), S); 9033 end if; 9034 9035 return True; 9036 9037 -- Check for case of non-tagged derived type whose parent either has 9038 -- primitive operations, or is a by reference type (RM 13.1(10)). 9039 9040 elsif Is_Type (T) 9041 and then not FOnly 9042 and then Is_Derived_Type (T) 9043 and then not Is_Tagged_Type (T) 9044 then 9045 Parent_Type := Etype (Base_Type (T)); 9046 9047 if Has_Primitive_Operations (Parent_Type) then 9048 Too_Late; 9049 Error_Msg_NE 9050 ("primitive operations already defined for&!", N, Parent_Type); 9051 return True; 9052 9053 elsif Is_By_Reference_Type (Parent_Type) then 9054 Too_Late; 9055 Error_Msg_NE 9056 ("parent type & is a by reference type!", N, Parent_Type); 9057 return True; 9058 end if; 9059 end if; 9060 9061 -- No error, link item into head of chain of rep items for the entity, 9062 -- but avoid chaining if we have an overloadable entity, and the pragma 9063 -- is one that can apply to multiple overloaded entities. 9064 9065 if Is_Overloadable (T) and then Nkind (N) = N_Pragma then 9066 declare 9067 Pname : constant Name_Id := Pragma_Name (N); 9068 begin 9069 if Pname = Name_Convention or else 9070 Pname = Name_Import or else 9071 Pname = Name_Export or else 9072 Pname = Name_External or else 9073 Pname = Name_Interface 9074 then 9075 return False; 9076 end if; 9077 end; 9078 end if; 9079 9080 Record_Rep_Item (T, N); 9081 return False; 9082 end Rep_Item_Too_Late; 9083 9084 ------------------------------------- 9085 -- Replace_Type_References_Generic -- 9086 ------------------------------------- 9087 9088 procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id) is 9089 9090 function Replace_Node (N : Node_Id) return Traverse_Result; 9091 -- Processes a single node in the traversal procedure below, checking 9092 -- if node N should be replaced, and if so, doing the replacement. 9093 9094 procedure Replace_Type_Refs is new Traverse_Proc (Replace_Node); 9095 -- This instantiation provides the body of Replace_Type_References 9096 9097 ------------------ 9098 -- Replace_Node -- 9099 ------------------ 9100 9101 function Replace_Node (N : Node_Id) return Traverse_Result is 9102 S : Entity_Id; 9103 P : Node_Id; 9104 9105 begin 9106 -- Case of identifier 9107 9108 if Nkind (N) = N_Identifier then 9109 9110 -- If not the type name, all done with this node 9111 9112 if Chars (N) /= TName then 9113 return Skip; 9114 9115 -- Otherwise do the replacement and we are done with this node 9116 9117 else 9118 Replace_Type_Reference (N); 9119 return Skip; 9120 end if; 9121 9122 -- Case of selected component (which is what a qualification 9123 -- looks like in the unanalyzed tree, which is what we have. 9124 9125 elsif Nkind (N) = N_Selected_Component then 9126 9127 -- If selector name is not our type, keeping going (we might 9128 -- still have an occurrence of the type in the prefix). 9129 9130 if Nkind (Selector_Name (N)) /= N_Identifier 9131 or else Chars (Selector_Name (N)) /= TName 9132 then 9133 return OK; 9134 9135 -- Selector name is our type, check qualification 9136 9137 else 9138 -- Loop through scopes and prefixes, doing comparison 9139 9140 S := Current_Scope; 9141 P := Prefix (N); 9142 loop 9143 -- Continue if no more scopes or scope with no name 9144 9145 if No (S) or else Nkind (S) not in N_Has_Chars then 9146 return OK; 9147 end if; 9148 9149 -- Do replace if prefix is an identifier matching the 9150 -- scope that we are currently looking at. 9151 9152 if Nkind (P) = N_Identifier 9153 and then Chars (P) = Chars (S) 9154 then 9155 Replace_Type_Reference (N); 9156 return Skip; 9157 end if; 9158 9159 -- Go check scope above us if prefix is itself of the 9160 -- form of a selected component, whose selector matches 9161 -- the scope we are currently looking at. 9162 9163 if Nkind (P) = N_Selected_Component 9164 and then Nkind (Selector_Name (P)) = N_Identifier 9165 and then Chars (Selector_Name (P)) = Chars (S) 9166 then 9167 S := Scope (S); 9168 P := Prefix (P); 9169 9170 -- For anything else, we don't have a match, so keep on 9171 -- going, there are still some weird cases where we may 9172 -- still have a replacement within the prefix. 9173 9174 else 9175 return OK; 9176 end if; 9177 end loop; 9178 end if; 9179 9180 -- Continue for any other node kind 9181 9182 else 9183 return OK; 9184 end if; 9185 end Replace_Node; 9186 9187 begin 9188 Replace_Type_Refs (N); 9189 end Replace_Type_References_Generic; 9190 9191 ------------------------- 9192 -- Same_Representation -- 9193 ------------------------- 9194 9195 function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is 9196 T1 : constant Entity_Id := Underlying_Type (Typ1); 9197 T2 : constant Entity_Id := Underlying_Type (Typ2); 9198 9199 begin 9200 -- A quick check, if base types are the same, then we definitely have 9201 -- the same representation, because the subtype specific representation 9202 -- attributes (Size and Alignment) do not affect representation from 9203 -- the point of view of this test. 9204 9205 if Base_Type (T1) = Base_Type (T2) then 9206 return True; 9207 9208 elsif Is_Private_Type (Base_Type (T2)) 9209 and then Base_Type (T1) = Full_View (Base_Type (T2)) 9210 then 9211 return True; 9212 end if; 9213 9214 -- Tagged types never have differing representations 9215 9216 if Is_Tagged_Type (T1) then 9217 return True; 9218 end if; 9219 9220 -- Representations are definitely different if conventions differ 9221 9222 if Convention (T1) /= Convention (T2) then 9223 return False; 9224 end if; 9225 9226 -- Representations are different if component alignments differ 9227 9228 if (Is_Record_Type (T1) or else Is_Array_Type (T1)) 9229 and then 9230 (Is_Record_Type (T2) or else Is_Array_Type (T2)) 9231 and then Component_Alignment (T1) /= Component_Alignment (T2) 9232 then 9233 return False; 9234 end if; 9235 9236 -- For arrays, the only real issue is component size. If we know the 9237 -- component size for both arrays, and it is the same, then that's 9238 -- good enough to know we don't have a change of representation. 9239 9240 if Is_Array_Type (T1) then 9241 if Known_Component_Size (T1) 9242 and then Known_Component_Size (T2) 9243 and then Component_Size (T1) = Component_Size (T2) 9244 then 9245 if VM_Target = No_VM then 9246 return True; 9247 9248 -- In VM targets the representation of arrays with aliased 9249 -- components differs from arrays with non-aliased components 9250 9251 else 9252 return Has_Aliased_Components (Base_Type (T1)) 9253 = 9254 Has_Aliased_Components (Base_Type (T2)); 9255 end if; 9256 end if; 9257 end if; 9258 9259 -- Types definitely have same representation if neither has non-standard 9260 -- representation since default representations are always consistent. 9261 -- If only one has non-standard representation, and the other does not, 9262 -- then we consider that they do not have the same representation. They 9263 -- might, but there is no way of telling early enough. 9264 9265 if Has_Non_Standard_Rep (T1) then 9266 if not Has_Non_Standard_Rep (T2) then 9267 return False; 9268 end if; 9269 else 9270 return not Has_Non_Standard_Rep (T2); 9271 end if; 9272 9273 -- Here the two types both have non-standard representation, and we need 9274 -- to determine if they have the same non-standard representation. 9275 9276 -- For arrays, we simply need to test if the component sizes are the 9277 -- same. Pragma Pack is reflected in modified component sizes, so this 9278 -- check also deals with pragma Pack. 9279 9280 if Is_Array_Type (T1) then 9281 return Component_Size (T1) = Component_Size (T2); 9282 9283 -- Tagged types always have the same representation, because it is not 9284 -- possible to specify different representations for common fields. 9285 9286 elsif Is_Tagged_Type (T1) then 9287 return True; 9288 9289 -- Case of record types 9290 9291 elsif Is_Record_Type (T1) then 9292 9293 -- Packed status must conform 9294 9295 if Is_Packed (T1) /= Is_Packed (T2) then 9296 return False; 9297 9298 -- Otherwise we must check components. Typ2 maybe a constrained 9299 -- subtype with fewer components, so we compare the components 9300 -- of the base types. 9301 9302 else 9303 Record_Case : declare 9304 CD1, CD2 : Entity_Id; 9305 9306 function Same_Rep return Boolean; 9307 -- CD1 and CD2 are either components or discriminants. This 9308 -- function tests whether the two have the same representation 9309 9310 -------------- 9311 -- Same_Rep -- 9312 -------------- 9313 9314 function Same_Rep return Boolean is 9315 begin 9316 if No (Component_Clause (CD1)) then 9317 return No (Component_Clause (CD2)); 9318 9319 else 9320 return 9321 Present (Component_Clause (CD2)) 9322 and then 9323 Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2) 9324 and then 9325 Esize (CD1) = Esize (CD2); 9326 end if; 9327 end Same_Rep; 9328 9329 -- Start of processing for Record_Case 9330 9331 begin 9332 if Has_Discriminants (T1) then 9333 9334 -- The number of discriminants may be different if the 9335 -- derived type has fewer (constrained by values). The 9336 -- invisible discriminants retain the representation of 9337 -- the original, so the discrepancy does not per se 9338 -- indicate a different representation. 9339 9340 CD1 := First_Discriminant (T1); 9341 CD2 := First_Discriminant (T2); 9342 while Present (CD1) and then Present (CD2) loop 9343 if not Same_Rep then 9344 return False; 9345 else 9346 Next_Discriminant (CD1); 9347 Next_Discriminant (CD2); 9348 end if; 9349 end loop; 9350 end if; 9351 9352 CD1 := First_Component (Underlying_Type (Base_Type (T1))); 9353 CD2 := First_Component (Underlying_Type (Base_Type (T2))); 9354 while Present (CD1) loop 9355 if not Same_Rep then 9356 return False; 9357 else 9358 Next_Component (CD1); 9359 Next_Component (CD2); 9360 end if; 9361 end loop; 9362 9363 return True; 9364 end Record_Case; 9365 end if; 9366 9367 -- For enumeration types, we must check each literal to see if the 9368 -- representation is the same. Note that we do not permit enumeration 9369 -- representation clauses for Character and Wide_Character, so these 9370 -- cases were already dealt with. 9371 9372 elsif Is_Enumeration_Type (T1) then 9373 Enumeration_Case : declare 9374 L1, L2 : Entity_Id; 9375 9376 begin 9377 L1 := First_Literal (T1); 9378 L2 := First_Literal (T2); 9379 while Present (L1) loop 9380 if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then 9381 return False; 9382 else 9383 Next_Literal (L1); 9384 Next_Literal (L2); 9385 end if; 9386 end loop; 9387 9388 return True; 9389 end Enumeration_Case; 9390 9391 -- Any other types have the same representation for these purposes 9392 9393 else 9394 return True; 9395 end if; 9396 end Same_Representation; 9397 9398 ---------------- 9399 -- Set_Biased -- 9400 ---------------- 9401 9402 procedure Set_Biased 9403 (E : Entity_Id; 9404 N : Node_Id; 9405 Msg : String; 9406 Biased : Boolean := True) 9407 is 9408 begin 9409 if Biased then 9410 Set_Has_Biased_Representation (E); 9411 9412 if Warn_On_Biased_Representation then 9413 Error_Msg_NE 9414 ("?B?" & Msg & " forces biased representation for&", N, E); 9415 end if; 9416 end if; 9417 end Set_Biased; 9418 9419 -------------------- 9420 -- Set_Enum_Esize -- 9421 -------------------- 9422 9423 procedure Set_Enum_Esize (T : Entity_Id) is 9424 Lo : Uint; 9425 Hi : Uint; 9426 Sz : Nat; 9427 9428 begin 9429 Init_Alignment (T); 9430 9431 -- Find the minimum standard size (8,16,32,64) that fits 9432 9433 Lo := Enumeration_Rep (Entity (Type_Low_Bound (T))); 9434 Hi := Enumeration_Rep (Entity (Type_High_Bound (T))); 9435 9436 if Lo < 0 then 9437 if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then 9438 Sz := Standard_Character_Size; -- May be > 8 on some targets 9439 9440 elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then 9441 Sz := 16; 9442 9443 elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then 9444 Sz := 32; 9445 9446 else pragma Assert (Lo >= -Uint_2**63 and then Hi < Uint_2**63); 9447 Sz := 64; 9448 end if; 9449 9450 else 9451 if Hi < Uint_2**08 then 9452 Sz := Standard_Character_Size; -- May be > 8 on some targets 9453 9454 elsif Hi < Uint_2**16 then 9455 Sz := 16; 9456 9457 elsif Hi < Uint_2**32 then 9458 Sz := 32; 9459 9460 else pragma Assert (Hi < Uint_2**63); 9461 Sz := 64; 9462 end if; 9463 end if; 9464 9465 -- That minimum is the proper size unless we have a foreign convention 9466 -- and the size required is 32 or less, in which case we bump the size 9467 -- up to 32. This is required for C and C++ and seems reasonable for 9468 -- all other foreign conventions. 9469 9470 if Has_Foreign_Convention (T) 9471 and then Esize (T) < Standard_Integer_Size 9472 then 9473 Init_Esize (T, Standard_Integer_Size); 9474 else 9475 Init_Esize (T, Sz); 9476 end if; 9477 end Set_Enum_Esize; 9478 9479 ------------------------------ 9480 -- Validate_Address_Clauses -- 9481 ------------------------------ 9482 9483 procedure Validate_Address_Clauses is 9484 begin 9485 for J in Address_Clause_Checks.First .. Address_Clause_Checks.Last loop 9486 declare 9487 ACCR : Address_Clause_Check_Record 9488 renames Address_Clause_Checks.Table (J); 9489 9490 Expr : Node_Id; 9491 9492 X_Alignment : Uint; 9493 Y_Alignment : Uint; 9494 9495 X_Size : Uint; 9496 Y_Size : Uint; 9497 9498 begin 9499 -- Skip processing of this entry if warning already posted 9500 9501 if not Address_Warning_Posted (ACCR.N) then 9502 Expr := Original_Node (Expression (ACCR.N)); 9503 9504 -- Get alignments 9505 9506 X_Alignment := Alignment (ACCR.X); 9507 Y_Alignment := Alignment (ACCR.Y); 9508 9509 -- Similarly obtain sizes 9510 9511 X_Size := Esize (ACCR.X); 9512 Y_Size := Esize (ACCR.Y); 9513 9514 -- Check for large object overlaying smaller one 9515 9516 if Y_Size > Uint_0 9517 and then X_Size > Uint_0 9518 and then X_Size > Y_Size 9519 then 9520 Error_Msg_NE 9521 ("?& overlays smaller object", ACCR.N, ACCR.X); 9522 Error_Msg_N 9523 ("\??program execution may be erroneous", ACCR.N); 9524 Error_Msg_Uint_1 := X_Size; 9525 Error_Msg_NE 9526 ("\??size of & is ^", ACCR.N, ACCR.X); 9527 Error_Msg_Uint_1 := Y_Size; 9528 Error_Msg_NE 9529 ("\??size of & is ^", ACCR.N, ACCR.Y); 9530 9531 -- Check for inadequate alignment, both of the base object 9532 -- and of the offset, if any. 9533 9534 -- Note: we do not check the alignment if we gave a size 9535 -- warning, since it would likely be redundant. 9536 9537 elsif Y_Alignment /= Uint_0 9538 and then (Y_Alignment < X_Alignment 9539 or else (ACCR.Off 9540 and then 9541 Nkind (Expr) = N_Attribute_Reference 9542 and then 9543 Attribute_Name (Expr) = Name_Address 9544 and then 9545 Has_Compatible_Alignment 9546 (ACCR.X, Prefix (Expr)) 9547 /= Known_Compatible)) 9548 then 9549 Error_Msg_NE 9550 ("??specified address for& may be inconsistent " 9551 & "with alignment", ACCR.N, ACCR.X); 9552 Error_Msg_N 9553 ("\??program execution may be erroneous (RM 13.3(27))", 9554 ACCR.N); 9555 Error_Msg_Uint_1 := X_Alignment; 9556 Error_Msg_NE 9557 ("\??alignment of & is ^", ACCR.N, ACCR.X); 9558 Error_Msg_Uint_1 := Y_Alignment; 9559 Error_Msg_NE 9560 ("\??alignment of & is ^", ACCR.N, ACCR.Y); 9561 if Y_Alignment >= X_Alignment then 9562 Error_Msg_N 9563 ("\??but offset is not multiple of alignment", ACCR.N); 9564 end if; 9565 end if; 9566 end if; 9567 end; 9568 end loop; 9569 end Validate_Address_Clauses; 9570 9571 --------------------------- 9572 -- Validate_Independence -- 9573 --------------------------- 9574 9575 procedure Validate_Independence is 9576 SU : constant Uint := UI_From_Int (System_Storage_Unit); 9577 N : Node_Id; 9578 E : Entity_Id; 9579 IC : Boolean; 9580 Comp : Entity_Id; 9581 Addr : Node_Id; 9582 P : Node_Id; 9583 9584 procedure Check_Array_Type (Atyp : Entity_Id); 9585 -- Checks if the array type Atyp has independent components, and 9586 -- if not, outputs an appropriate set of error messages. 9587 9588 procedure No_Independence; 9589 -- Output message that independence cannot be guaranteed 9590 9591 function OK_Component (C : Entity_Id) return Boolean; 9592 -- Checks one component to see if it is independently accessible, and 9593 -- if so yields True, otherwise yields False if independent access 9594 -- cannot be guaranteed. This is a conservative routine, it only 9595 -- returns True if it knows for sure, it returns False if it knows 9596 -- there is a problem, or it cannot be sure there is no problem. 9597 9598 procedure Reason_Bad_Component (C : Entity_Id); 9599 -- Outputs continuation message if a reason can be determined for 9600 -- the component C being bad. 9601 9602 ---------------------- 9603 -- Check_Array_Type -- 9604 ---------------------- 9605 9606 procedure Check_Array_Type (Atyp : Entity_Id) is 9607 Ctyp : constant Entity_Id := Component_Type (Atyp); 9608 9609 begin 9610 -- OK if no alignment clause, no pack, and no component size 9611 9612 if not Has_Component_Size_Clause (Atyp) 9613 and then not Has_Alignment_Clause (Atyp) 9614 and then not Is_Packed (Atyp) 9615 then 9616 return; 9617 end if; 9618 9619 -- Check actual component size 9620 9621 if not Known_Component_Size (Atyp) 9622 or else not (Addressable (Component_Size (Atyp)) 9623 and then Component_Size (Atyp) < 64) 9624 or else Component_Size (Atyp) mod Esize (Ctyp) /= 0 9625 then 9626 No_Independence; 9627 9628 -- Bad component size, check reason 9629 9630 if Has_Component_Size_Clause (Atyp) then 9631 P := Get_Attribute_Definition_Clause 9632 (Atyp, Attribute_Component_Size); 9633 9634 if Present (P) then 9635 Error_Msg_Sloc := Sloc (P); 9636 Error_Msg_N ("\because of Component_Size clause#", N); 9637 return; 9638 end if; 9639 end if; 9640 9641 if Is_Packed (Atyp) then 9642 P := Get_Rep_Pragma (Atyp, Name_Pack); 9643 9644 if Present (P) then 9645 Error_Msg_Sloc := Sloc (P); 9646 Error_Msg_N ("\because of pragma Pack#", N); 9647 return; 9648 end if; 9649 end if; 9650 9651 -- No reason found, just return 9652 9653 return; 9654 end if; 9655 9656 -- Array type is OK independence-wise 9657 9658 return; 9659 end Check_Array_Type; 9660 9661 --------------------- 9662 -- No_Independence -- 9663 --------------------- 9664 9665 procedure No_Independence is 9666 begin 9667 if Pragma_Name (N) = Name_Independent then 9668 Error_Msg_NE 9669 ("independence cannot be guaranteed for&", N, E); 9670 else 9671 Error_Msg_NE 9672 ("independent components cannot be guaranteed for&", N, E); 9673 end if; 9674 end No_Independence; 9675 9676 ------------------ 9677 -- OK_Component -- 9678 ------------------ 9679 9680 function OK_Component (C : Entity_Id) return Boolean is 9681 Rec : constant Entity_Id := Scope (C); 9682 Ctyp : constant Entity_Id := Etype (C); 9683 9684 begin 9685 -- OK if no component clause, no Pack, and no alignment clause 9686 9687 if No (Component_Clause (C)) 9688 and then not Is_Packed (Rec) 9689 and then not Has_Alignment_Clause (Rec) 9690 then 9691 return True; 9692 end if; 9693 9694 -- Here we look at the actual component layout. A component is 9695 -- addressable if its size is a multiple of the Esize of the 9696 -- component type, and its starting position in the record has 9697 -- appropriate alignment, and the record itself has appropriate 9698 -- alignment to guarantee the component alignment. 9699 9700 -- Make sure sizes are static, always assume the worst for any 9701 -- cases where we cannot check static values. 9702 9703 if not (Known_Static_Esize (C) 9704 and then 9705 Known_Static_Esize (Ctyp)) 9706 then 9707 return False; 9708 end if; 9709 9710 -- Size of component must be addressable or greater than 64 bits 9711 -- and a multiple of bytes. 9712 9713 if not Addressable (Esize (C)) and then Esize (C) < Uint_64 then 9714 return False; 9715 end if; 9716 9717 -- Check size is proper multiple 9718 9719 if Esize (C) mod Esize (Ctyp) /= 0 then 9720 return False; 9721 end if; 9722 9723 -- Check alignment of component is OK 9724 9725 if not Known_Component_Bit_Offset (C) 9726 or else Component_Bit_Offset (C) < Uint_0 9727 or else Component_Bit_Offset (C) mod Esize (Ctyp) /= 0 9728 then 9729 return False; 9730 end if; 9731 9732 -- Check alignment of record type is OK 9733 9734 if not Known_Alignment (Rec) 9735 or else (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0 9736 then 9737 return False; 9738 end if; 9739 9740 -- All tests passed, component is addressable 9741 9742 return True; 9743 end OK_Component; 9744 9745 -------------------------- 9746 -- Reason_Bad_Component -- 9747 -------------------------- 9748 9749 procedure Reason_Bad_Component (C : Entity_Id) is 9750 Rec : constant Entity_Id := Scope (C); 9751 Ctyp : constant Entity_Id := Etype (C); 9752 9753 begin 9754 -- If component clause present assume that's the problem 9755 9756 if Present (Component_Clause (C)) then 9757 Error_Msg_Sloc := Sloc (Component_Clause (C)); 9758 Error_Msg_N ("\because of Component_Clause#", N); 9759 return; 9760 end if; 9761 9762 -- If pragma Pack clause present, assume that's the problem 9763 9764 if Is_Packed (Rec) then 9765 P := Get_Rep_Pragma (Rec, Name_Pack); 9766 9767 if Present (P) then 9768 Error_Msg_Sloc := Sloc (P); 9769 Error_Msg_N ("\because of pragma Pack#", N); 9770 return; 9771 end if; 9772 end if; 9773 9774 -- See if record has bad alignment clause 9775 9776 if Has_Alignment_Clause (Rec) 9777 and then Known_Alignment (Rec) 9778 and then (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0 9779 then 9780 P := Get_Attribute_Definition_Clause (Rec, Attribute_Alignment); 9781 9782 if Present (P) then 9783 Error_Msg_Sloc := Sloc (P); 9784 Error_Msg_N ("\because of Alignment clause#", N); 9785 end if; 9786 end if; 9787 9788 -- Couldn't find a reason, so return without a message 9789 9790 return; 9791 end Reason_Bad_Component; 9792 9793 -- Start of processing for Validate_Independence 9794 9795 begin 9796 for J in Independence_Checks.First .. Independence_Checks.Last loop 9797 N := Independence_Checks.Table (J).N; 9798 E := Independence_Checks.Table (J).E; 9799 IC := Pragma_Name (N) = Name_Independent_Components; 9800 9801 -- Deal with component case 9802 9803 if Ekind (E) = E_Discriminant or else Ekind (E) = E_Component then 9804 if not OK_Component (E) then 9805 No_Independence; 9806 Reason_Bad_Component (E); 9807 goto Continue; 9808 end if; 9809 end if; 9810 9811 -- Deal with record with Independent_Components 9812 9813 if IC and then Is_Record_Type (E) then 9814 Comp := First_Component_Or_Discriminant (E); 9815 while Present (Comp) loop 9816 if not OK_Component (Comp) then 9817 No_Independence; 9818 Reason_Bad_Component (Comp); 9819 goto Continue; 9820 end if; 9821 9822 Next_Component_Or_Discriminant (Comp); 9823 end loop; 9824 end if; 9825 9826 -- Deal with address clause case 9827 9828 if Is_Object (E) then 9829 Addr := Address_Clause (E); 9830 9831 if Present (Addr) then 9832 No_Independence; 9833 Error_Msg_Sloc := Sloc (Addr); 9834 Error_Msg_N ("\because of Address clause#", N); 9835 goto Continue; 9836 end if; 9837 end if; 9838 9839 -- Deal with independent components for array type 9840 9841 if IC and then Is_Array_Type (E) then 9842 Check_Array_Type (E); 9843 end if; 9844 9845 -- Deal with independent components for array object 9846 9847 if IC and then Is_Object (E) and then Is_Array_Type (Etype (E)) then 9848 Check_Array_Type (Etype (E)); 9849 end if; 9850 9851 <<Continue>> null; 9852 end loop; 9853 end Validate_Independence; 9854 9855 ----------------------------------- 9856 -- Validate_Unchecked_Conversion -- 9857 ----------------------------------- 9858 9859 procedure Validate_Unchecked_Conversion 9860 (N : Node_Id; 9861 Act_Unit : Entity_Id) 9862 is 9863 Source : Entity_Id; 9864 Target : Entity_Id; 9865 Vnode : Node_Id; 9866 9867 begin 9868 -- Obtain source and target types. Note that we call Ancestor_Subtype 9869 -- here because the processing for generic instantiation always makes 9870 -- subtypes, and we want the original frozen actual types. 9871 9872 -- If we are dealing with private types, then do the check on their 9873 -- fully declared counterparts if the full declarations have been 9874 -- encountered (they don't have to be visible, but they must exist!) 9875 9876 Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit))); 9877 9878 if Is_Private_Type (Source) 9879 and then Present (Underlying_Type (Source)) 9880 then 9881 Source := Underlying_Type (Source); 9882 end if; 9883 9884 Target := Ancestor_Subtype (Etype (Act_Unit)); 9885 9886 -- If either type is generic, the instantiation happens within a generic 9887 -- unit, and there is nothing to check. The proper check will happen 9888 -- when the enclosing generic is instantiated. 9889 9890 if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then 9891 return; 9892 end if; 9893 9894 if Is_Private_Type (Target) 9895 and then Present (Underlying_Type (Target)) 9896 then 9897 Target := Underlying_Type (Target); 9898 end if; 9899 9900 -- Source may be unconstrained array, but not target 9901 9902 if Is_Array_Type (Target) and then not Is_Constrained (Target) then 9903 Error_Msg_N 9904 ("unchecked conversion to unconstrained array not allowed", N); 9905 return; 9906 end if; 9907 9908 -- Warn if conversion between two different convention pointers 9909 9910 if Is_Access_Type (Target) 9911 and then Is_Access_Type (Source) 9912 and then Convention (Target) /= Convention (Source) 9913 and then Warn_On_Unchecked_Conversion 9914 then 9915 -- Give warnings for subprogram pointers only on most targets. The 9916 -- exception is VMS, where data pointers can have different lengths 9917 -- depending on the pointer convention. 9918 9919 if Is_Access_Subprogram_Type (Target) 9920 or else Is_Access_Subprogram_Type (Source) 9921 or else OpenVMS_On_Target 9922 then 9923 Error_Msg_N 9924 ("?z?conversion between pointers with different conventions!", 9925 N); 9926 end if; 9927 end if; 9928 9929 -- Warn if one of the operands is Ada.Calendar.Time. Do not emit a 9930 -- warning when compiling GNAT-related sources. 9931 9932 if Warn_On_Unchecked_Conversion 9933 and then not In_Predefined_Unit (N) 9934 and then RTU_Loaded (Ada_Calendar) 9935 and then 9936 (Chars (Source) = Name_Time 9937 or else 9938 Chars (Target) = Name_Time) 9939 then 9940 -- If Ada.Calendar is loaded and the name of one of the operands is 9941 -- Time, there is a good chance that this is Ada.Calendar.Time. 9942 9943 declare 9944 Calendar_Time : constant Entity_Id := 9945 Full_View (RTE (RO_CA_Time)); 9946 begin 9947 pragma Assert (Present (Calendar_Time)); 9948 9949 if Source = Calendar_Time or else Target = Calendar_Time then 9950 Error_Msg_N 9951 ("?z?representation of 'Time values may change between " & 9952 "'G'N'A'T versions", N); 9953 end if; 9954 end; 9955 end if; 9956 9957 -- Make entry in unchecked conversion table for later processing by 9958 -- Validate_Unchecked_Conversions, which will check sizes and alignments 9959 -- (using values set by the back-end where possible). This is only done 9960 -- if the appropriate warning is active. 9961 9962 if Warn_On_Unchecked_Conversion then 9963 Unchecked_Conversions.Append 9964 (New_Val => UC_Entry'(Eloc => Sloc (N), 9965 Source => Source, 9966 Target => Target)); 9967 9968 -- If both sizes are known statically now, then back end annotation 9969 -- is not required to do a proper check but if either size is not 9970 -- known statically, then we need the annotation. 9971 9972 if Known_Static_RM_Size (Source) 9973 and then 9974 Known_Static_RM_Size (Target) 9975 then 9976 null; 9977 else 9978 Back_Annotate_Rep_Info := True; 9979 end if; 9980 end if; 9981 9982 -- If unchecked conversion to access type, and access type is declared 9983 -- in the same unit as the unchecked conversion, then set the flag 9984 -- No_Strict_Aliasing (no strict aliasing is implicit here) 9985 9986 if Is_Access_Type (Target) and then 9987 In_Same_Source_Unit (Target, N) 9988 then 9989 Set_No_Strict_Aliasing (Implementation_Base_Type (Target)); 9990 end if; 9991 9992 -- Generate N_Validate_Unchecked_Conversion node for back end in case 9993 -- the back end needs to perform special validation checks. 9994 9995 -- Shouldn't this be in Exp_Ch13, since the check only gets done if we 9996 -- have full expansion and the back end is called ??? 9997 9998 Vnode := 9999 Make_Validate_Unchecked_Conversion (Sloc (N)); 10000 Set_Source_Type (Vnode, Source); 10001 Set_Target_Type (Vnode, Target); 10002 10003 -- If the unchecked conversion node is in a list, just insert before it. 10004 -- If not we have some strange case, not worth bothering about. 10005 10006 if Is_List_Member (N) then 10007 Insert_After (N, Vnode); 10008 end if; 10009 end Validate_Unchecked_Conversion; 10010 10011 ------------------------------------ 10012 -- Validate_Unchecked_Conversions -- 10013 ------------------------------------ 10014 10015 procedure Validate_Unchecked_Conversions is 10016 begin 10017 for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop 10018 declare 10019 T : UC_Entry renames Unchecked_Conversions.Table (N); 10020 10021 Eloc : constant Source_Ptr := T.Eloc; 10022 Source : constant Entity_Id := T.Source; 10023 Target : constant Entity_Id := T.Target; 10024 10025 Source_Siz : Uint; 10026 Target_Siz : Uint; 10027 10028 begin 10029 -- This validation check, which warns if we have unequal sizes for 10030 -- unchecked conversion, and thus potentially implementation 10031 -- dependent semantics, is one of the few occasions on which we 10032 -- use the official RM size instead of Esize. See description in 10033 -- Einfo "Handling of Type'Size Values" for details. 10034 10035 if Serious_Errors_Detected = 0 10036 and then Known_Static_RM_Size (Source) 10037 and then Known_Static_RM_Size (Target) 10038 10039 -- Don't do the check if warnings off for either type, note the 10040 -- deliberate use of OR here instead of OR ELSE to get the flag 10041 -- Warnings_Off_Used set for both types if appropriate. 10042 10043 and then not (Has_Warnings_Off (Source) 10044 or 10045 Has_Warnings_Off (Target)) 10046 then 10047 Source_Siz := RM_Size (Source); 10048 Target_Siz := RM_Size (Target); 10049 10050 if Source_Siz /= Target_Siz then 10051 Error_Msg 10052 ("?z?types for unchecked conversion have different sizes!", 10053 Eloc); 10054 10055 if All_Errors_Mode then 10056 Error_Msg_Name_1 := Chars (Source); 10057 Error_Msg_Uint_1 := Source_Siz; 10058 Error_Msg_Name_2 := Chars (Target); 10059 Error_Msg_Uint_2 := Target_Siz; 10060 Error_Msg ("\size of % is ^, size of % is ^?z?", Eloc); 10061 10062 Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz); 10063 10064 if Is_Discrete_Type (Source) 10065 and then 10066 Is_Discrete_Type (Target) 10067 then 10068 if Source_Siz > Target_Siz then 10069 Error_Msg 10070 ("\?z?^ high order bits of source will " 10071 & "be ignored!", Eloc); 10072 10073 elsif Is_Unsigned_Type (Source) then 10074 Error_Msg 10075 ("\?z?source will be extended with ^ high order " 10076 & "zero bits?!", Eloc); 10077 10078 else 10079 Error_Msg 10080 ("\?z?source will be extended with ^ high order " 10081 & "sign bits!", Eloc); 10082 end if; 10083 10084 elsif Source_Siz < Target_Siz then 10085 if Is_Discrete_Type (Target) then 10086 if Bytes_Big_Endian then 10087 Error_Msg 10088 ("\?z?target value will include ^ undefined " 10089 & "low order bits!", Eloc); 10090 else 10091 Error_Msg 10092 ("\?z?target value will include ^ undefined " 10093 & "high order bits!", Eloc); 10094 end if; 10095 10096 else 10097 Error_Msg 10098 ("\?z?^ trailing bits of target value will be " 10099 & "undefined!", Eloc); 10100 end if; 10101 10102 else pragma Assert (Source_Siz > Target_Siz); 10103 Error_Msg 10104 ("\?z?^ trailing bits of source will be ignored!", 10105 Eloc); 10106 end if; 10107 end if; 10108 end if; 10109 end if; 10110 10111 -- If both types are access types, we need to check the alignment. 10112 -- If the alignment of both is specified, we can do it here. 10113 10114 if Serious_Errors_Detected = 0 10115 and then Ekind (Source) in Access_Kind 10116 and then Ekind (Target) in Access_Kind 10117 and then Target_Strict_Alignment 10118 and then Present (Designated_Type (Source)) 10119 and then Present (Designated_Type (Target)) 10120 then 10121 declare 10122 D_Source : constant Entity_Id := Designated_Type (Source); 10123 D_Target : constant Entity_Id := Designated_Type (Target); 10124 10125 begin 10126 if Known_Alignment (D_Source) 10127 and then 10128 Known_Alignment (D_Target) 10129 then 10130 declare 10131 Source_Align : constant Uint := Alignment (D_Source); 10132 Target_Align : constant Uint := Alignment (D_Target); 10133 10134 begin 10135 if Source_Align < Target_Align 10136 and then not Is_Tagged_Type (D_Source) 10137 10138 -- Suppress warning if warnings suppressed on either 10139 -- type or either designated type. Note the use of 10140 -- OR here instead of OR ELSE. That is intentional, 10141 -- we would like to set flag Warnings_Off_Used in 10142 -- all types for which warnings are suppressed. 10143 10144 and then not (Has_Warnings_Off (D_Source) 10145 or 10146 Has_Warnings_Off (D_Target) 10147 or 10148 Has_Warnings_Off (Source) 10149 or 10150 Has_Warnings_Off (Target)) 10151 then 10152 Error_Msg_Uint_1 := Target_Align; 10153 Error_Msg_Uint_2 := Source_Align; 10154 Error_Msg_Node_1 := D_Target; 10155 Error_Msg_Node_2 := D_Source; 10156 Error_Msg 10157 ("?z?alignment of & (^) is stricter than " 10158 & "alignment of & (^)!", Eloc); 10159 Error_Msg 10160 ("\?z?resulting access value may have invalid " 10161 & "alignment!", Eloc); 10162 end if; 10163 end; 10164 end if; 10165 end; 10166 end if; 10167 end; 10168 end loop; 10169 end Validate_Unchecked_Conversions; 10170 10171end Sem_Ch13; 10172