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-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Elists; use Elists; 32with Errout; use Errout; 33with Exp_Disp; use Exp_Disp; 34with Exp_Tss; use Exp_Tss; 35with Exp_Util; use Exp_Util; 36with Freeze; use Freeze; 37with Lib; use Lib; 38with Lib.Xref; use Lib.Xref; 39with Namet; use Namet; 40with Nlists; use Nlists; 41with Nmake; use Nmake; 42with Opt; use Opt; 43with Restrict; use Restrict; 44with Rident; use Rident; 45with Rtsfind; use Rtsfind; 46with Sem; use Sem; 47with Sem_Aux; use Sem_Aux; 48with Sem_Case; use Sem_Case; 49with Sem_Ch3; use Sem_Ch3; 50with Sem_Ch6; use Sem_Ch6; 51with Sem_Ch8; use Sem_Ch8; 52with Sem_Dim; use Sem_Dim; 53with Sem_Disp; use Sem_Disp; 54with Sem_Eval; use Sem_Eval; 55with Sem_Prag; use Sem_Prag; 56with Sem_Res; use Sem_Res; 57with Sem_Type; use Sem_Type; 58with Sem_Util; use Sem_Util; 59with Sem_Warn; use Sem_Warn; 60with Sinput; use Sinput; 61with Snames; use Snames; 62with Stand; use Stand; 63with Sinfo; use Sinfo; 64with Stringt; use Stringt; 65with Targparm; use Targparm; 66with Ttypes; use Ttypes; 67with Tbuild; use Tbuild; 68with Urealp; use Urealp; 69with Warnsw; use Warnsw; 70 71with GNAT.Heap_Sort_G; 72 73package body Sem_Ch13 is 74 75 SSU : constant Pos := System_Storage_Unit; 76 -- Convenient short hand for commonly used constant 77 78 ----------------------- 79 -- Local Subprograms -- 80 ----------------------- 81 82 procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint); 83 -- This routine is called after setting one of the sizes of type entity 84 -- Typ to Size. The purpose is to deal with the situation of a derived 85 -- type whose inherited alignment is no longer appropriate for the new 86 -- size value. In this case, we reset the Alignment to unknown. 87 88 procedure Build_Discrete_Static_Predicate 89 (Typ : Entity_Id; 90 Expr : Node_Id; 91 Nam : Name_Id); 92 -- Given a predicated type Typ, where Typ is a discrete static subtype, 93 -- whose predicate expression is Expr, tests if Expr is a static predicate, 94 -- and if so, builds the predicate range list. Nam is the name of the one 95 -- argument to the predicate function. Occurrences of the type name in the 96 -- predicate expression have been replaced by identifier references to this 97 -- name, which is unique, so any identifier with Chars matching Nam must be 98 -- a reference to the type. If the predicate is non-static, this procedure 99 -- returns doing nothing. If the predicate is static, then the predicate 100 -- list is stored in Static_Discrete_Predicate (Typ), and the Expr is 101 -- rewritten as a canonicalized membership operation. 102 103 procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id); 104 -- If Typ has predicates (indicated by Has_Predicates being set for Typ), 105 -- then either there are pragma Predicate entries on the rep chain for the 106 -- type (note that Predicate aspects are converted to pragma Predicate), or 107 -- there are inherited aspects from a parent type, or ancestor subtypes. 108 -- This procedure builds the spec and body for the Predicate function that 109 -- tests these predicates. N is the freeze node for the type. The spec of 110 -- the function is inserted before the freeze node, and the body of the 111 -- function is inserted after the freeze node. If the predicate expression 112 -- has at least one Raise_Expression, then this procedure also builds the 113 -- M version of the predicate function for use in membership tests. 114 115 procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id); 116 -- Called if both Storage_Pool and Storage_Size attribute definition 117 -- clauses (SP and SS) are present for entity Ent. Issue error message. 118 119 procedure Freeze_Entity_Checks (N : Node_Id); 120 -- Called from Analyze_Freeze_Entity and Analyze_Generic_Freeze Entity 121 -- to generate appropriate semantic checks that are delayed until this 122 -- point (they had to be delayed this long for cases of delayed aspects, 123 -- e.g. analysis of statically predicated subtypes in choices, for which 124 -- we have to be sure the subtypes in question are frozen before checking. 125 126 function Get_Alignment_Value (Expr : Node_Id) return Uint; 127 -- Given the expression for an alignment value, returns the corresponding 128 -- Uint value. If the value is inappropriate, then error messages are 129 -- posted as required, and a value of No_Uint is returned. 130 131 function Is_Operational_Item (N : Node_Id) return Boolean; 132 -- A specification for a stream attribute is allowed before the full type 133 -- is declared, as explained in AI-00137 and the corrigendum. Attributes 134 -- that do not specify a representation characteristic are operational 135 -- attributes. 136 137 function Is_Predicate_Static 138 (Expr : Node_Id; 139 Nam : Name_Id) return Boolean; 140 -- Given predicate expression Expr, tests if Expr is predicate-static in 141 -- the sense of the rules in (RM 3.2.4 (15-24)). Occurrences of the type 142 -- name in the predicate expression have been replaced by references to 143 -- an identifier whose Chars field is Nam. This name is unique, so any 144 -- identifier with Chars matching Nam must be a reference to the type. 145 -- Returns True if the expression is predicate-static and False otherwise, 146 -- but is not in the business of setting flags or issuing error messages. 147 -- 148 -- Only scalar types can have static predicates, so False is always 149 -- returned for non-scalar types. 150 -- 151 -- Note: the RM seems to suggest that string types can also have static 152 -- predicates. But that really makes lttle sense as very few useful 153 -- predicates can be constructed for strings. Remember that: 154 -- 155 -- "ABC" < "DEF" 156 -- 157 -- is not a static expression. So even though the clearly faulty RM wording 158 -- allows the following: 159 -- 160 -- subtype S is String with Static_Predicate => S < "DEF" 161 -- 162 -- We can't allow this, otherwise we have predicate-static applying to a 163 -- larger class than static expressions, which was never intended. 164 165 procedure New_Stream_Subprogram 166 (N : Node_Id; 167 Ent : Entity_Id; 168 Subp : Entity_Id; 169 Nam : TSS_Name_Type); 170 -- Create a subprogram renaming of a given stream attribute to the 171 -- designated subprogram and then in the tagged case, provide this as a 172 -- primitive operation, or in the untagged case make an appropriate TSS 173 -- entry. This is more properly an expansion activity than just semantics, 174 -- but the presence of user-defined stream functions for limited types 175 -- is a legality check, which is why this takes place here rather than in 176 -- exp_ch13, where it was previously. Nam indicates the name of the TSS 177 -- function to be generated. 178 -- 179 -- To avoid elaboration anomalies with freeze nodes, for untagged types 180 -- we generate both a subprogram declaration and a subprogram renaming 181 -- declaration, so that the attribute specification is handled as a 182 -- renaming_as_body. For tagged types, the specification is one of the 183 -- primitive specs. 184 185 procedure Resolve_Iterable_Operation 186 (N : Node_Id; 187 Cursor : Entity_Id; 188 Typ : Entity_Id; 189 Nam : Name_Id); 190 -- If the name of a primitive operation for an Iterable aspect is 191 -- overloaded, resolve according to required signature. 192 193 procedure Set_Biased 194 (E : Entity_Id; 195 N : Node_Id; 196 Msg : String; 197 Biased : Boolean := True); 198 -- If Biased is True, sets Has_Biased_Representation flag for E, and 199 -- outputs a warning message at node N if Warn_On_Biased_Representation is 200 -- is True. This warning inserts the string Msg to describe the construct 201 -- causing biasing. 202 203 ---------------------------------------------- 204 -- Table for Validate_Unchecked_Conversions -- 205 ---------------------------------------------- 206 207 -- The following table collects unchecked conversions for validation. 208 -- Entries are made by Validate_Unchecked_Conversion and then the call 209 -- to Validate_Unchecked_Conversions does the actual error checking and 210 -- posting of warnings. The reason for this delayed processing is to take 211 -- advantage of back-annotations of size and alignment values performed by 212 -- the back end. 213 214 -- Note: the reason we store a Source_Ptr value instead of a Node_Id is 215 -- that by the time Validate_Unchecked_Conversions is called, Sprint will 216 -- already have modified all Sloc values if the -gnatD option is set. 217 218 type UC_Entry is record 219 Eloc : Source_Ptr; -- node used for posting warnings 220 Source : Entity_Id; -- source type for unchecked conversion 221 Target : Entity_Id; -- target type for unchecked conversion 222 Act_Unit : Entity_Id; -- actual function instantiated 223 end record; 224 225 package Unchecked_Conversions is new Table.Table ( 226 Table_Component_Type => UC_Entry, 227 Table_Index_Type => Int, 228 Table_Low_Bound => 1, 229 Table_Initial => 50, 230 Table_Increment => 200, 231 Table_Name => "Unchecked_Conversions"); 232 233 ---------------------------------------- 234 -- Table for Validate_Address_Clauses -- 235 ---------------------------------------- 236 237 -- If an address clause has the form 238 239 -- for X'Address use Expr 240 241 -- where Expr is of the form Y'Address or recursively is a reference to a 242 -- constant of either of these forms, and X and Y are entities of objects, 243 -- then if Y has a smaller alignment than X, that merits a warning about 244 -- possible bad alignment. The following table collects address clauses of 245 -- this kind. We put these in a table so that they can be checked after the 246 -- back end has completed annotation of the alignments of objects, since we 247 -- can catch more cases that way. 248 249 type Address_Clause_Check_Record is record 250 N : Node_Id; 251 -- The address clause 252 253 X : Entity_Id; 254 -- The entity of the object overlaying Y 255 256 Y : Entity_Id; 257 -- The entity of the object being overlaid 258 259 Off : Boolean; 260 -- Whether the address is offset within Y 261 end record; 262 263 package Address_Clause_Checks is new Table.Table ( 264 Table_Component_Type => Address_Clause_Check_Record, 265 Table_Index_Type => Int, 266 Table_Low_Bound => 1, 267 Table_Initial => 20, 268 Table_Increment => 200, 269 Table_Name => "Address_Clause_Checks"); 270 271 ----------------------------------------- 272 -- Adjust_Record_For_Reverse_Bit_Order -- 273 ----------------------------------------- 274 275 procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is 276 Comp : Node_Id; 277 CC : Node_Id; 278 279 begin 280 -- Processing depends on version of Ada 281 282 -- For Ada 95, we just renumber bits within a storage unit. We do the 283 -- same for Ada 83 mode, since we recognize the Bit_Order attribute in 284 -- Ada 83, and are free to add this extension. 285 286 if Ada_Version < Ada_2005 then 287 Comp := First_Component_Or_Discriminant (R); 288 while Present (Comp) loop 289 CC := Component_Clause (Comp); 290 291 -- If component clause is present, then deal with the non-default 292 -- bit order case for Ada 95 mode. 293 294 -- We only do this processing for the base type, and in fact that 295 -- is important, since otherwise if there are record subtypes, we 296 -- could reverse the bits once for each subtype, which is wrong. 297 298 if Present (CC) and then Ekind (R) = E_Record_Type then 299 declare 300 CFB : constant Uint := Component_Bit_Offset (Comp); 301 CSZ : constant Uint := Esize (Comp); 302 CLC : constant Node_Id := Component_Clause (Comp); 303 Pos : constant Node_Id := Position (CLC); 304 FB : constant Node_Id := First_Bit (CLC); 305 306 Storage_Unit_Offset : constant Uint := 307 CFB / System_Storage_Unit; 308 309 Start_Bit : constant Uint := 310 CFB mod System_Storage_Unit; 311 312 begin 313 -- Cases where field goes over storage unit boundary 314 315 if Start_Bit + CSZ > System_Storage_Unit then 316 317 -- Allow multi-byte field but generate warning 318 319 if Start_Bit mod System_Storage_Unit = 0 320 and then CSZ mod System_Storage_Unit = 0 321 then 322 Error_Msg_N 323 ("info: multi-byte field specified with " 324 & "non-standard Bit_Order?V?", CLC); 325 326 if Bytes_Big_Endian then 327 Error_Msg_N 328 ("\bytes are not reversed " 329 & "(component is big-endian)?V?", CLC); 330 else 331 Error_Msg_N 332 ("\bytes are not reversed " 333 & "(component is little-endian)?V?", CLC); 334 end if; 335 336 -- Do not allow non-contiguous field 337 338 else 339 Error_Msg_N 340 ("attempt to specify non-contiguous field " 341 & "not permitted", CLC); 342 Error_Msg_N 343 ("\caused by non-standard Bit_Order " 344 & "specified", CLC); 345 Error_Msg_N 346 ("\consider possibility of using " 347 & "Ada 2005 mode here", CLC); 348 end if; 349 350 -- Case where field fits in one storage unit 351 352 else 353 -- Give warning if suspicious component clause 354 355 if Intval (FB) >= System_Storage_Unit 356 and then Warn_On_Reverse_Bit_Order 357 then 358 Error_Msg_N 359 ("info: Bit_Order clause does not affect " & 360 "byte ordering?V?", Pos); 361 Error_Msg_Uint_1 := 362 Intval (Pos) + Intval (FB) / 363 System_Storage_Unit; 364 Error_Msg_N 365 ("info: position normalized to ^ before bit " & 366 "order interpreted?V?", Pos); 367 end if; 368 369 -- Here is where we fix up the Component_Bit_Offset value 370 -- to account for the reverse bit order. Some examples of 371 -- what needs to be done are: 372 373 -- First_Bit .. Last_Bit Component_Bit_Offset 374 -- old new old new 375 376 -- 0 .. 0 7 .. 7 0 7 377 -- 0 .. 1 6 .. 7 0 6 378 -- 0 .. 2 5 .. 7 0 5 379 -- 0 .. 7 0 .. 7 0 4 380 381 -- 1 .. 1 6 .. 6 1 6 382 -- 1 .. 4 3 .. 6 1 3 383 -- 4 .. 7 0 .. 3 4 0 384 385 -- The rule is that the first bit is is obtained by 386 -- subtracting the old ending bit from storage_unit - 1. 387 388 Set_Component_Bit_Offset 389 (Comp, 390 (Storage_Unit_Offset * System_Storage_Unit) + 391 (System_Storage_Unit - 1) - 392 (Start_Bit + CSZ - 1)); 393 394 Set_Normalized_First_Bit 395 (Comp, 396 Component_Bit_Offset (Comp) mod 397 System_Storage_Unit); 398 end if; 399 end; 400 end if; 401 402 Next_Component_Or_Discriminant (Comp); 403 end loop; 404 405 -- For Ada 2005, we do machine scalar processing, as fully described In 406 -- AI-133. This involves gathering all components which start at the 407 -- same byte offset and processing them together. Same approach is still 408 -- valid in later versions including Ada 2012. 409 410 else 411 declare 412 Max_Machine_Scalar_Size : constant Uint := 413 UI_From_Int 414 (Standard_Long_Long_Integer_Size); 415 -- We use this as the maximum machine scalar size 416 417 Num_CC : Natural; 418 SSU : constant Uint := UI_From_Int (System_Storage_Unit); 419 420 begin 421 -- This first loop through components does two things. First it 422 -- deals with the case of components with component clauses whose 423 -- length is greater than the maximum machine scalar size (either 424 -- accepting them or rejecting as needed). Second, it counts the 425 -- number of components with component clauses whose length does 426 -- not exceed this maximum for later processing. 427 428 Num_CC := 0; 429 Comp := First_Component_Or_Discriminant (R); 430 while Present (Comp) loop 431 CC := Component_Clause (Comp); 432 433 if Present (CC) then 434 declare 435 Fbit : constant Uint := Static_Integer (First_Bit (CC)); 436 Lbit : constant Uint := Static_Integer (Last_Bit (CC)); 437 438 begin 439 -- Case of component with last bit >= max machine scalar 440 441 if Lbit >= Max_Machine_Scalar_Size then 442 443 -- This is allowed only if first bit is zero, and 444 -- last bit + 1 is a multiple of storage unit size. 445 446 if Fbit = 0 and then (Lbit + 1) mod SSU = 0 then 447 448 -- This is the case to give a warning if enabled 449 450 if Warn_On_Reverse_Bit_Order then 451 Error_Msg_N 452 ("info: multi-byte field specified with " 453 & " non-standard Bit_Order?V?", CC); 454 455 if Bytes_Big_Endian then 456 Error_Msg_N 457 ("\bytes are not reversed " 458 & "(component is big-endian)?V?", CC); 459 else 460 Error_Msg_N 461 ("\bytes are not reversed " 462 & "(component is little-endian)?V?", CC); 463 end if; 464 end if; 465 466 -- Give error message for RM 13.5.1(10) violation 467 468 else 469 Error_Msg_FE 470 ("machine scalar rules not followed for&", 471 First_Bit (CC), Comp); 472 473 Error_Msg_Uint_1 := Lbit; 474 Error_Msg_Uint_2 := Max_Machine_Scalar_Size; 475 Error_Msg_F 476 ("\last bit (^) exceeds maximum machine " 477 & "scalar size (^)", 478 First_Bit (CC)); 479 480 if (Lbit + 1) mod SSU /= 0 then 481 Error_Msg_Uint_1 := SSU; 482 Error_Msg_F 483 ("\and is not a multiple of Storage_Unit (^) " 484 & "(RM 13.4.1(10))", 485 First_Bit (CC)); 486 487 else 488 Error_Msg_Uint_1 := Fbit; 489 Error_Msg_F 490 ("\and first bit (^) is non-zero " 491 & "(RM 13.4.1(10))", 492 First_Bit (CC)); 493 end if; 494 end if; 495 496 -- OK case of machine scalar related component clause, 497 -- For now, just count them. 498 499 else 500 Num_CC := Num_CC + 1; 501 end if; 502 end; 503 end if; 504 505 Next_Component_Or_Discriminant (Comp); 506 end loop; 507 508 -- We need to sort the component clauses on the basis of the 509 -- Position values in the clause, so we can group clauses with 510 -- the same Position together to determine the relevant machine 511 -- scalar size. 512 513 Sort_CC : declare 514 Comps : array (0 .. Num_CC) of Entity_Id; 515 -- Array to collect component and discriminant entities. The 516 -- data starts at index 1, the 0'th entry is for the sort 517 -- routine. 518 519 function CP_Lt (Op1, Op2 : Natural) return Boolean; 520 -- Compare routine for Sort 521 522 procedure CP_Move (From : Natural; To : Natural); 523 -- Move routine for Sort 524 525 package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt); 526 527 Start : Natural; 528 Stop : Natural; 529 -- Start and stop positions in the component list of the set of 530 -- components with the same starting position (that constitute 531 -- components in a single machine scalar). 532 533 MaxL : Uint; 534 -- Maximum last bit value of any component in this set 535 536 MSS : Uint; 537 -- Corresponding machine scalar size 538 539 ----------- 540 -- CP_Lt -- 541 ----------- 542 543 function CP_Lt (Op1, Op2 : Natural) return Boolean is 544 begin 545 return Position (Component_Clause (Comps (Op1))) < 546 Position (Component_Clause (Comps (Op2))); 547 end CP_Lt; 548 549 ------------- 550 -- CP_Move -- 551 ------------- 552 553 procedure CP_Move (From : Natural; To : Natural) is 554 begin 555 Comps (To) := Comps (From); 556 end CP_Move; 557 558 -- Start of processing for Sort_CC 559 560 begin 561 -- Collect the machine scalar relevant component clauses 562 563 Num_CC := 0; 564 Comp := First_Component_Or_Discriminant (R); 565 while Present (Comp) loop 566 declare 567 CC : constant Node_Id := Component_Clause (Comp); 568 569 begin 570 -- Collect only component clauses whose last bit is less 571 -- than machine scalar size. Any component clause whose 572 -- last bit exceeds this value does not take part in 573 -- machine scalar layout considerations. The test for 574 -- Error_Posted makes sure we exclude component clauses 575 -- for which we already posted an error. 576 577 if Present (CC) 578 and then not Error_Posted (Last_Bit (CC)) 579 and then Static_Integer (Last_Bit (CC)) < 580 Max_Machine_Scalar_Size 581 then 582 Num_CC := Num_CC + 1; 583 Comps (Num_CC) := Comp; 584 end if; 585 end; 586 587 Next_Component_Or_Discriminant (Comp); 588 end loop; 589 590 -- Sort by ascending position number 591 592 Sorting.Sort (Num_CC); 593 594 -- We now have all the components whose size does not exceed 595 -- the max machine scalar value, sorted by starting position. 596 -- In this loop we gather groups of clauses starting at the 597 -- same position, to process them in accordance with AI-133. 598 599 Stop := 0; 600 while Stop < Num_CC loop 601 Start := Stop + 1; 602 Stop := Start; 603 MaxL := 604 Static_Integer 605 (Last_Bit (Component_Clause (Comps (Start)))); 606 while Stop < Num_CC loop 607 if Static_Integer 608 (Position (Component_Clause (Comps (Stop + 1)))) = 609 Static_Integer 610 (Position (Component_Clause (Comps (Stop)))) 611 then 612 Stop := Stop + 1; 613 MaxL := 614 UI_Max 615 (MaxL, 616 Static_Integer 617 (Last_Bit 618 (Component_Clause (Comps (Stop))))); 619 else 620 exit; 621 end if; 622 end loop; 623 624 -- Now we have a group of component clauses from Start to 625 -- Stop whose positions are identical, and MaxL is the 626 -- maximum last bit value of any of these components. 627 628 -- We need to determine the corresponding machine scalar 629 -- size. This loop assumes that machine scalar sizes are 630 -- even, and that each possible machine scalar has twice 631 -- as many bits as the next smaller one. 632 633 MSS := Max_Machine_Scalar_Size; 634 while MSS mod 2 = 0 635 and then (MSS / 2) >= SSU 636 and then (MSS / 2) > MaxL 637 loop 638 MSS := MSS / 2; 639 end loop; 640 641 -- Here is where we fix up the Component_Bit_Offset value 642 -- to account for the reverse bit order. Some examples of 643 -- what needs to be done for the case of a machine scalar 644 -- size of 8 are: 645 646 -- First_Bit .. Last_Bit Component_Bit_Offset 647 -- old new old new 648 649 -- 0 .. 0 7 .. 7 0 7 650 -- 0 .. 1 6 .. 7 0 6 651 -- 0 .. 2 5 .. 7 0 5 652 -- 0 .. 7 0 .. 7 0 4 653 654 -- 1 .. 1 6 .. 6 1 6 655 -- 1 .. 4 3 .. 6 1 3 656 -- 4 .. 7 0 .. 3 4 0 657 658 -- The rule is that the first bit is obtained by subtracting 659 -- the old ending bit from machine scalar size - 1. 660 661 for C in Start .. Stop loop 662 declare 663 Comp : constant Entity_Id := Comps (C); 664 CC : constant Node_Id := Component_Clause (Comp); 665 666 LB : constant Uint := Static_Integer (Last_Bit (CC)); 667 NFB : constant Uint := MSS - Uint_1 - LB; 668 NLB : constant Uint := NFB + Esize (Comp) - 1; 669 Pos : constant Uint := Static_Integer (Position (CC)); 670 671 begin 672 if Warn_On_Reverse_Bit_Order then 673 Error_Msg_Uint_1 := MSS; 674 Error_Msg_N 675 ("info: reverse bit order in machine " & 676 "scalar of length^?V?", First_Bit (CC)); 677 Error_Msg_Uint_1 := NFB; 678 Error_Msg_Uint_2 := NLB; 679 680 if Bytes_Big_Endian then 681 Error_Msg_NE 682 ("\big-endian range for component " 683 & "& is ^ .. ^?V?", First_Bit (CC), Comp); 684 else 685 Error_Msg_NE 686 ("\little-endian range for component" 687 & "& is ^ .. ^?V?", First_Bit (CC), Comp); 688 end if; 689 end if; 690 691 Set_Component_Bit_Offset (Comp, Pos * SSU + NFB); 692 Set_Normalized_First_Bit (Comp, NFB mod SSU); 693 end; 694 end loop; 695 end loop; 696 end Sort_CC; 697 end; 698 end if; 699 end Adjust_Record_For_Reverse_Bit_Order; 700 701 ------------------------------------- 702 -- Alignment_Check_For_Size_Change -- 703 ------------------------------------- 704 705 procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint) is 706 begin 707 -- If the alignment is known, and not set by a rep clause, and is 708 -- inconsistent with the size being set, then reset it to unknown, 709 -- we assume in this case that the size overrides the inherited 710 -- alignment, and that the alignment must be recomputed. 711 712 if Known_Alignment (Typ) 713 and then not Has_Alignment_Clause (Typ) 714 and then Size mod (Alignment (Typ) * SSU) /= 0 715 then 716 Init_Alignment (Typ); 717 end if; 718 end Alignment_Check_For_Size_Change; 719 720 ------------------------------------- 721 -- Analyze_Aspects_At_Freeze_Point -- 722 ------------------------------------- 723 724 procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id) is 725 ASN : Node_Id; 726 A_Id : Aspect_Id; 727 Ritem : Node_Id; 728 729 procedure Analyze_Aspect_Default_Value (ASN : Node_Id); 730 -- This routine analyzes an Aspect_Default_[Component_]Value denoted by 731 -- the aspect specification node ASN. 732 733 procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id); 734 -- As discussed in the spec of Aspects (see Aspect_Delay declaration), 735 -- a derived type can inherit aspects from its parent which have been 736 -- specified at the time of the derivation using an aspect, as in: 737 -- 738 -- type A is range 1 .. 10 739 -- with Size => Not_Defined_Yet; 740 -- .. 741 -- type B is new A; 742 -- .. 743 -- Not_Defined_Yet : constant := 64; 744 -- 745 -- In this example, the Size of A is considered to be specified prior 746 -- to the derivation, and thus inherited, even though the value is not 747 -- known at the time of derivation. To deal with this, we use two entity 748 -- flags. The flag Has_Derived_Rep_Aspects is set in the parent type (A 749 -- here), and then the flag May_Inherit_Delayed_Rep_Aspects is set in 750 -- the derived type (B here). If this flag is set when the derived type 751 -- is frozen, then this procedure is called to ensure proper inheritance 752 -- of all delayed aspects from the parent type. The derived type is E, 753 -- the argument to Analyze_Aspects_At_Freeze_Point. ASN is the first 754 -- aspect specification node in the Rep_Item chain for the parent type. 755 756 procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id); 757 -- Given an aspect specification node ASN whose expression is an 758 -- optional Boolean, this routines creates the corresponding pragma 759 -- at the freezing point. 760 761 ---------------------------------- 762 -- Analyze_Aspect_Default_Value -- 763 ---------------------------------- 764 765 procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is 766 Ent : constant Entity_Id := Entity (ASN); 767 Expr : constant Node_Id := Expression (ASN); 768 Id : constant Node_Id := Identifier (ASN); 769 770 begin 771 Error_Msg_Name_1 := Chars (Id); 772 773 if not Is_Type (Ent) then 774 Error_Msg_N ("aspect% can only apply to a type", Id); 775 return; 776 777 elsif not Is_First_Subtype (Ent) then 778 Error_Msg_N ("aspect% cannot apply to subtype", Id); 779 return; 780 781 elsif A_Id = Aspect_Default_Value 782 and then not Is_Scalar_Type (Ent) 783 then 784 Error_Msg_N ("aspect% can only be applied to scalar type", Id); 785 return; 786 787 elsif A_Id = Aspect_Default_Component_Value then 788 if not Is_Array_Type (Ent) then 789 Error_Msg_N ("aspect% can only be applied to array type", Id); 790 return; 791 792 elsif not Is_Scalar_Type (Component_Type (Ent)) then 793 Error_Msg_N ("aspect% requires scalar components", Id); 794 return; 795 end if; 796 end if; 797 798 Set_Has_Default_Aspect (Base_Type (Ent)); 799 800 if Is_Scalar_Type (Ent) then 801 Set_Default_Aspect_Value (Base_Type (Ent), Expr); 802 else 803 Set_Default_Aspect_Component_Value (Base_Type (Ent), Expr); 804 end if; 805 end Analyze_Aspect_Default_Value; 806 807 --------------------------------- 808 -- Inherit_Delayed_Rep_Aspects -- 809 --------------------------------- 810 811 procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id) is 812 P : constant Entity_Id := Entity (ASN); 813 -- Entithy for parent type 814 815 N : Node_Id; 816 -- Item from Rep_Item chain 817 818 A : Aspect_Id; 819 820 begin 821 -- Loop through delayed aspects for the parent type 822 823 N := ASN; 824 while Present (N) loop 825 if Nkind (N) = N_Aspect_Specification then 826 exit when Entity (N) /= P; 827 828 if Is_Delayed_Aspect (N) then 829 A := Get_Aspect_Id (Chars (Identifier (N))); 830 831 -- Process delayed rep aspect. For Boolean attributes it is 832 -- not possible to cancel an attribute once set (the attempt 833 -- to use an aspect with xxx => False is an error) for a 834 -- derived type. So for those cases, we do not have to check 835 -- if a clause has been given for the derived type, since it 836 -- is harmless to set it again if it is already set. 837 838 case A is 839 840 -- Alignment 841 842 when Aspect_Alignment => 843 if not Has_Alignment_Clause (E) then 844 Set_Alignment (E, Alignment (P)); 845 end if; 846 847 -- Atomic 848 849 when Aspect_Atomic => 850 if Is_Atomic (P) then 851 Set_Is_Atomic (E); 852 end if; 853 854 -- Atomic_Components 855 856 when Aspect_Atomic_Components => 857 if Has_Atomic_Components (P) then 858 Set_Has_Atomic_Components (Base_Type (E)); 859 end if; 860 861 -- Bit_Order 862 863 when Aspect_Bit_Order => 864 if Is_Record_Type (E) 865 and then No (Get_Attribute_Definition_Clause 866 (E, Attribute_Bit_Order)) 867 and then Reverse_Bit_Order (P) 868 then 869 Set_Reverse_Bit_Order (Base_Type (E)); 870 end if; 871 872 -- Component_Size 873 874 when Aspect_Component_Size => 875 if Is_Array_Type (E) 876 and then not Has_Component_Size_Clause (E) 877 then 878 Set_Component_Size 879 (Base_Type (E), Component_Size (P)); 880 end if; 881 882 -- Machine_Radix 883 884 when Aspect_Machine_Radix => 885 if Is_Decimal_Fixed_Point_Type (E) 886 and then not Has_Machine_Radix_Clause (E) 887 then 888 Set_Machine_Radix_10 (E, Machine_Radix_10 (P)); 889 end if; 890 891 -- Object_Size (also Size which also sets Object_Size) 892 893 when Aspect_Object_Size | Aspect_Size => 894 if not Has_Size_Clause (E) 895 and then 896 No (Get_Attribute_Definition_Clause 897 (E, Attribute_Object_Size)) 898 then 899 Set_Esize (E, Esize (P)); 900 end if; 901 902 -- Pack 903 904 when Aspect_Pack => 905 if not Is_Packed (E) then 906 Set_Is_Packed (Base_Type (E)); 907 908 if Is_Bit_Packed_Array (P) then 909 Set_Is_Bit_Packed_Array (Base_Type (E)); 910 Set_Packed_Array_Impl_Type 911 (E, Packed_Array_Impl_Type (P)); 912 end if; 913 end if; 914 915 -- Scalar_Storage_Order 916 917 when Aspect_Scalar_Storage_Order => 918 if (Is_Record_Type (E) or else Is_Array_Type (E)) 919 and then No (Get_Attribute_Definition_Clause 920 (E, Attribute_Scalar_Storage_Order)) 921 and then Reverse_Storage_Order (P) 922 then 923 Set_Reverse_Storage_Order (Base_Type (E)); 924 925 -- Clear default SSO indications, since the aspect 926 -- overrides the default. 927 928 Set_SSO_Set_Low_By_Default (Base_Type (E), False); 929 Set_SSO_Set_High_By_Default (Base_Type (E), False); 930 end if; 931 932 -- Small 933 934 when Aspect_Small => 935 if Is_Fixed_Point_Type (E) 936 and then not Has_Small_Clause (E) 937 then 938 Set_Small_Value (E, Small_Value (P)); 939 end if; 940 941 -- Storage_Size 942 943 when Aspect_Storage_Size => 944 if (Is_Access_Type (E) or else Is_Task_Type (E)) 945 and then not Has_Storage_Size_Clause (E) 946 then 947 Set_Storage_Size_Variable 948 (Base_Type (E), Storage_Size_Variable (P)); 949 end if; 950 951 -- Value_Size 952 953 when Aspect_Value_Size => 954 955 -- Value_Size is never inherited, it is either set by 956 -- default, or it is explicitly set for the derived 957 -- type. So nothing to do here. 958 959 null; 960 961 -- Volatile 962 963 when Aspect_Volatile => 964 if Is_Volatile (P) then 965 Set_Is_Volatile (E); 966 end if; 967 968 -- Volatile_Components 969 970 when Aspect_Volatile_Components => 971 if Has_Volatile_Components (P) then 972 Set_Has_Volatile_Components (Base_Type (E)); 973 end if; 974 975 -- That should be all the Rep Aspects 976 977 when others => 978 pragma Assert (Aspect_Delay (A_Id) /= Rep_Aspect); 979 null; 980 981 end case; 982 end if; 983 end if; 984 985 N := Next_Rep_Item (N); 986 end loop; 987 end Inherit_Delayed_Rep_Aspects; 988 989 ------------------------------------- 990 -- Make_Pragma_From_Boolean_Aspect -- 991 ------------------------------------- 992 993 procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id) is 994 Ident : constant Node_Id := Identifier (ASN); 995 A_Name : constant Name_Id := Chars (Ident); 996 A_Id : constant Aspect_Id := Get_Aspect_Id (A_Name); 997 Ent : constant Entity_Id := Entity (ASN); 998 Expr : constant Node_Id := Expression (ASN); 999 Loc : constant Source_Ptr := Sloc (ASN); 1000 1001 Prag : Node_Id; 1002 1003 procedure Check_False_Aspect_For_Derived_Type; 1004 -- This procedure checks for the case of a false aspect for a derived 1005 -- type, which improperly tries to cancel an aspect inherited from 1006 -- the parent. 1007 1008 ----------------------------------------- 1009 -- Check_False_Aspect_For_Derived_Type -- 1010 ----------------------------------------- 1011 1012 procedure Check_False_Aspect_For_Derived_Type is 1013 Par : Node_Id; 1014 1015 begin 1016 -- We are only checking derived types 1017 1018 if not Is_Derived_Type (E) then 1019 return; 1020 end if; 1021 1022 Par := Nearest_Ancestor (E); 1023 1024 case A_Id is 1025 when Aspect_Atomic | Aspect_Shared => 1026 if not Is_Atomic (Par) then 1027 return; 1028 end if; 1029 1030 when Aspect_Atomic_Components => 1031 if not Has_Atomic_Components (Par) then 1032 return; 1033 end if; 1034 1035 when Aspect_Discard_Names => 1036 if not Discard_Names (Par) then 1037 return; 1038 end if; 1039 1040 when Aspect_Pack => 1041 if not Is_Packed (Par) then 1042 return; 1043 end if; 1044 1045 when Aspect_Unchecked_Union => 1046 if not Is_Unchecked_Union (Par) then 1047 return; 1048 end if; 1049 1050 when Aspect_Volatile => 1051 if not Is_Volatile (Par) then 1052 return; 1053 end if; 1054 1055 when Aspect_Volatile_Components => 1056 if not Has_Volatile_Components (Par) then 1057 return; 1058 end if; 1059 1060 when others => 1061 return; 1062 end case; 1063 1064 -- Fall through means we are canceling an inherited aspect 1065 1066 Error_Msg_Name_1 := A_Name; 1067 Error_Msg_NE 1068 ("derived type& inherits aspect%, cannot cancel", Expr, E); 1069 1070 end Check_False_Aspect_For_Derived_Type; 1071 1072 -- Start of processing for Make_Pragma_From_Boolean_Aspect 1073 1074 begin 1075 -- Note that we know Expr is present, because for a missing Expr 1076 -- argument, we knew it was True and did not need to delay the 1077 -- evaluation to the freeze point. 1078 1079 if Is_False (Static_Boolean (Expr)) then 1080 Check_False_Aspect_For_Derived_Type; 1081 1082 else 1083 Prag := 1084 Make_Pragma (Loc, 1085 Pragma_Argument_Associations => New_List ( 1086 Make_Pragma_Argument_Association (Sloc (Ident), 1087 Expression => New_Occurrence_Of (Ent, Sloc (Ident)))), 1088 1089 Pragma_Identifier => 1090 Make_Identifier (Sloc (Ident), Chars (Ident))); 1091 1092 Set_From_Aspect_Specification (Prag, True); 1093 Set_Corresponding_Aspect (Prag, ASN); 1094 Set_Aspect_Rep_Item (ASN, Prag); 1095 Set_Is_Delayed_Aspect (Prag); 1096 Set_Parent (Prag, ASN); 1097 end if; 1098 end Make_Pragma_From_Boolean_Aspect; 1099 1100 -- Start of processing for Analyze_Aspects_At_Freeze_Point 1101 1102 begin 1103 -- Must be visible in current scope 1104 1105 if not Scope_Within_Or_Same (Current_Scope, Scope (E)) then 1106 return; 1107 end if; 1108 1109 -- Look for aspect specification entries for this entity 1110 1111 ASN := First_Rep_Item (E); 1112 while Present (ASN) loop 1113 if Nkind (ASN) = N_Aspect_Specification then 1114 exit when Entity (ASN) /= E; 1115 1116 if Is_Delayed_Aspect (ASN) then 1117 A_Id := Get_Aspect_Id (ASN); 1118 1119 case A_Id is 1120 1121 -- For aspects whose expression is an optional Boolean, make 1122 -- the corresponding pragma at the freeze point. 1123 1124 when Boolean_Aspects | 1125 Library_Unit_Aspects => 1126 Make_Pragma_From_Boolean_Aspect (ASN); 1127 1128 -- Special handling for aspects that don't correspond to 1129 -- pragmas/attributes. 1130 1131 when Aspect_Default_Value | 1132 Aspect_Default_Component_Value => 1133 Analyze_Aspect_Default_Value (ASN); 1134 1135 -- Ditto for iterator aspects, because the corresponding 1136 -- attributes may not have been analyzed yet. 1137 1138 when Aspect_Constant_Indexing | 1139 Aspect_Variable_Indexing | 1140 Aspect_Default_Iterator | 1141 Aspect_Iterator_Element => 1142 Analyze (Expression (ASN)); 1143 1144 if Etype (Expression (ASN)) = Any_Type then 1145 Error_Msg_NE 1146 ("\aspect must be fully defined before & is frozen", 1147 ASN, E); 1148 end if; 1149 1150 when Aspect_Iterable => 1151 Validate_Iterable_Aspect (E, ASN); 1152 1153 when others => 1154 null; 1155 end case; 1156 1157 Ritem := Aspect_Rep_Item (ASN); 1158 1159 if Present (Ritem) then 1160 Analyze (Ritem); 1161 end if; 1162 end if; 1163 end if; 1164 1165 Next_Rep_Item (ASN); 1166 end loop; 1167 1168 -- This is where we inherit delayed rep aspects from our parent. Note 1169 -- that if we fell out of the above loop with ASN non-empty, it means 1170 -- we hit an aspect for an entity other than E, and it must be the 1171 -- type from which we were derived. 1172 1173 if May_Inherit_Delayed_Rep_Aspects (E) then 1174 Inherit_Delayed_Rep_Aspects (ASN); 1175 end if; 1176 end Analyze_Aspects_At_Freeze_Point; 1177 1178 ----------------------------------- 1179 -- Analyze_Aspect_Specifications -- 1180 ----------------------------------- 1181 1182 procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is 1183 procedure Decorate (Asp : Node_Id; Prag : Node_Id); 1184 -- Establish linkages between an aspect and its corresponding 1185 -- pragma. 1186 1187 procedure Insert_After_SPARK_Mode 1188 (Prag : Node_Id; 1189 Ins_Nod : Node_Id; 1190 Decls : List_Id); 1191 -- Subsidiary to the analysis of aspects Abstract_State, Ghost, 1192 -- Initializes, Initial_Condition and Refined_State. Insert node Prag 1193 -- before node Ins_Nod. If Ins_Nod is for pragma SPARK_Mode, then skip 1194 -- SPARK_Mode. Decls is the associated declarative list where Prag is to 1195 -- reside. 1196 1197 procedure Insert_Pragma (Prag : Node_Id); 1198 -- Subsidiary to the analysis of aspects Attach_Handler, Contract_Cases, 1199 -- Depends, Global, Post, Pre, Refined_Depends and Refined_Global. 1200 -- Insert pragma Prag such that it mimics the placement of a source 1201 -- pragma of the same kind. 1202 -- 1203 -- procedure Proc (Formal : ...) with Global => ...; 1204 -- 1205 -- procedure Proc (Formal : ...); 1206 -- pragma Global (...); 1207 1208 -------------- 1209 -- Decorate -- 1210 -------------- 1211 1212 procedure Decorate (Asp : Node_Id; Prag : Node_Id) is 1213 begin 1214 Set_Aspect_Rep_Item (Asp, Prag); 1215 Set_Corresponding_Aspect (Prag, Asp); 1216 Set_From_Aspect_Specification (Prag); 1217 Set_Parent (Prag, Asp); 1218 end Decorate; 1219 1220 ----------------------------- 1221 -- Insert_After_SPARK_Mode -- 1222 ----------------------------- 1223 1224 procedure Insert_After_SPARK_Mode 1225 (Prag : Node_Id; 1226 Ins_Nod : Node_Id; 1227 Decls : List_Id) 1228 is 1229 Decl : Node_Id := Ins_Nod; 1230 1231 begin 1232 -- Skip SPARK_Mode 1233 1234 if Present (Decl) 1235 and then Nkind (Decl) = N_Pragma 1236 and then Pragma_Name (Decl) = Name_SPARK_Mode 1237 then 1238 Decl := Next (Decl); 1239 end if; 1240 1241 if Present (Decl) then 1242 Insert_Before (Decl, Prag); 1243 1244 -- Aitem acts as the last declaration 1245 1246 else 1247 Append_To (Decls, Prag); 1248 end if; 1249 end Insert_After_SPARK_Mode; 1250 1251 ------------------- 1252 -- Insert_Pragma -- 1253 ------------------- 1254 1255 procedure Insert_Pragma (Prag : Node_Id) is 1256 Aux : Node_Id; 1257 Decl : Node_Id; 1258 1259 begin 1260 if Nkind (N) = N_Subprogram_Body then 1261 if Present (Declarations (N)) then 1262 1263 -- Skip other internally generated pragmas from aspects to find 1264 -- the proper insertion point. As a result the order of pragmas 1265 -- is the same as the order of aspects. 1266 1267 -- As precondition pragmas generated from conjuncts in the 1268 -- precondition aspect are presented in reverse order to 1269 -- Insert_Pragma, insert them in the correct order here by not 1270 -- skipping previously inserted precondition pragmas when the 1271 -- current pragma is a precondition. 1272 1273 Decl := First (Declarations (N)); 1274 while Present (Decl) loop 1275 if Nkind (Decl) = N_Pragma 1276 and then From_Aspect_Specification (Decl) 1277 and then not (Get_Pragma_Id (Decl) = Pragma_Precondition 1278 and then 1279 Get_Pragma_Id (Prag) = Pragma_Precondition) 1280 then 1281 Next (Decl); 1282 else 1283 exit; 1284 end if; 1285 end loop; 1286 1287 if Present (Decl) then 1288 Insert_Before (Decl, Prag); 1289 else 1290 Append (Prag, Declarations (N)); 1291 end if; 1292 else 1293 Set_Declarations (N, New_List (Prag)); 1294 end if; 1295 1296 -- When the context is a library unit, the pragma is added to the 1297 -- Pragmas_After list. 1298 1299 elsif Nkind (Parent (N)) = N_Compilation_Unit then 1300 Aux := Aux_Decls_Node (Parent (N)); 1301 1302 if No (Pragmas_After (Aux)) then 1303 Set_Pragmas_After (Aux, New_List); 1304 end if; 1305 1306 Prepend (Prag, Pragmas_After (Aux)); 1307 1308 -- Default 1309 1310 else 1311 Insert_After (N, Prag); 1312 end if; 1313 end Insert_Pragma; 1314 1315 -- Local variables 1316 1317 Aspect : Node_Id; 1318 Aitem : Node_Id; 1319 Ent : Node_Id; 1320 1321 L : constant List_Id := Aspect_Specifications (N); 1322 1323 Ins_Node : Node_Id := N; 1324 -- Insert pragmas/attribute definition clause after this node when no 1325 -- delayed analysis is required. 1326 1327 -- Start of processing for Analyze_Aspect_Specifications 1328 1329 -- The general processing involves building an attribute definition 1330 -- clause or a pragma node that corresponds to the aspect. Then in order 1331 -- to delay the evaluation of this aspect to the freeze point, we attach 1332 -- the corresponding pragma/attribute definition clause to the aspect 1333 -- specification node, which is then placed in the Rep Item chain. In 1334 -- this case we mark the entity by setting the flag Has_Delayed_Aspects 1335 -- and we evaluate the rep item at the freeze point. When the aspect 1336 -- doesn't have a corresponding pragma/attribute definition clause, then 1337 -- its analysis is simply delayed at the freeze point. 1338 1339 -- Some special cases don't require delay analysis, thus the aspect is 1340 -- analyzed right now. 1341 1342 -- Note that there is a special handling for Pre, Post, Test_Case, 1343 -- Contract_Cases aspects. In these cases, we do not have to worry 1344 -- about delay issues, since the pragmas themselves deal with delay 1345 -- of visibility for the expression analysis. Thus, we just insert 1346 -- the pragma after the node N. 1347 1348 begin 1349 pragma Assert (Present (L)); 1350 1351 -- Loop through aspects 1352 1353 Aspect := First (L); 1354 Aspect_Loop : while Present (Aspect) loop 1355 Analyze_One_Aspect : declare 1356 Expr : constant Node_Id := Expression (Aspect); 1357 Id : constant Node_Id := Identifier (Aspect); 1358 Loc : constant Source_Ptr := Sloc (Aspect); 1359 Nam : constant Name_Id := Chars (Id); 1360 A_Id : constant Aspect_Id := Get_Aspect_Id (Nam); 1361 Anod : Node_Id; 1362 1363 Delay_Required : Boolean; 1364 -- Set False if delay is not required 1365 1366 Eloc : Source_Ptr := No_Location; 1367 -- Source location of expression, modified when we split PPC's. It 1368 -- is set below when Expr is present. 1369 1370 procedure Analyze_Aspect_External_Or_Link_Name; 1371 -- Perform analysis of the External_Name or Link_Name aspects 1372 1373 procedure Analyze_Aspect_Implicit_Dereference; 1374 -- Perform analysis of the Implicit_Dereference aspects 1375 1376 procedure Make_Aitem_Pragma 1377 (Pragma_Argument_Associations : List_Id; 1378 Pragma_Name : Name_Id); 1379 -- This is a wrapper for Make_Pragma used for converting aspects 1380 -- to pragmas. It takes care of Sloc (set from Loc) and building 1381 -- the pragma identifier from the given name. In addition the 1382 -- flags Class_Present and Split_PPC are set from the aspect 1383 -- node, as well as Is_Ignored. This routine also sets the 1384 -- From_Aspect_Specification in the resulting pragma node to 1385 -- True, and sets Corresponding_Aspect to point to the aspect. 1386 -- The resulting pragma is assigned to Aitem. 1387 1388 ------------------------------------------ 1389 -- Analyze_Aspect_External_Or_Link_Name -- 1390 ------------------------------------------ 1391 1392 procedure Analyze_Aspect_External_Or_Link_Name is 1393 begin 1394 -- Verify that there is an Import/Export aspect defined for the 1395 -- entity. The processing of that aspect in turn checks that 1396 -- there is a Convention aspect declared. The pragma is 1397 -- constructed when processing the Convention aspect. 1398 1399 declare 1400 A : Node_Id; 1401 1402 begin 1403 A := First (L); 1404 while Present (A) loop 1405 exit when Nam_In (Chars (Identifier (A)), Name_Export, 1406 Name_Import); 1407 Next (A); 1408 end loop; 1409 1410 if No (A) then 1411 Error_Msg_N 1412 ("missing Import/Export for Link/External name", 1413 Aspect); 1414 end if; 1415 end; 1416 end Analyze_Aspect_External_Or_Link_Name; 1417 1418 ----------------------------------------- 1419 -- Analyze_Aspect_Implicit_Dereference -- 1420 ----------------------------------------- 1421 1422 procedure Analyze_Aspect_Implicit_Dereference is 1423 begin 1424 if not Is_Type (E) or else not Has_Discriminants (E) then 1425 Error_Msg_N 1426 ("aspect must apply to a type with discriminants", N); 1427 1428 else 1429 declare 1430 Disc : Entity_Id; 1431 1432 begin 1433 Disc := First_Discriminant (E); 1434 while Present (Disc) loop 1435 if Chars (Expr) = Chars (Disc) 1436 and then Ekind (Etype (Disc)) = 1437 E_Anonymous_Access_Type 1438 then 1439 Set_Has_Implicit_Dereference (E); 1440 Set_Has_Implicit_Dereference (Disc); 1441 return; 1442 end if; 1443 1444 Next_Discriminant (Disc); 1445 end loop; 1446 1447 -- Error if no proper access discriminant. 1448 1449 Error_Msg_NE 1450 ("not an access discriminant of&", Expr, E); 1451 end; 1452 end if; 1453 end Analyze_Aspect_Implicit_Dereference; 1454 1455 ----------------------- 1456 -- Make_Aitem_Pragma -- 1457 ----------------------- 1458 1459 procedure Make_Aitem_Pragma 1460 (Pragma_Argument_Associations : List_Id; 1461 Pragma_Name : Name_Id) 1462 is 1463 Args : List_Id := Pragma_Argument_Associations; 1464 1465 begin 1466 -- We should never get here if aspect was disabled 1467 1468 pragma Assert (not Is_Disabled (Aspect)); 1469 1470 -- Certain aspects allow for an optional name or expression. Do 1471 -- not generate a pragma with empty argument association list. 1472 1473 if No (Args) or else No (Expression (First (Args))) then 1474 Args := No_List; 1475 end if; 1476 1477 -- Build the pragma 1478 1479 Aitem := 1480 Make_Pragma (Loc, 1481 Pragma_Argument_Associations => Args, 1482 Pragma_Identifier => 1483 Make_Identifier (Sloc (Id), Pragma_Name), 1484 Class_Present => Class_Present (Aspect), 1485 Split_PPC => Split_PPC (Aspect)); 1486 1487 -- Set additional semantic fields 1488 1489 if Is_Ignored (Aspect) then 1490 Set_Is_Ignored (Aitem); 1491 elsif Is_Checked (Aspect) then 1492 Set_Is_Checked (Aitem); 1493 end if; 1494 1495 Set_Corresponding_Aspect (Aitem, Aspect); 1496 Set_From_Aspect_Specification (Aitem, True); 1497 end Make_Aitem_Pragma; 1498 1499 -- Start of processing for Analyze_One_Aspect 1500 1501 begin 1502 -- Skip aspect if already analyzed, to avoid looping in some cases 1503 1504 if Analyzed (Aspect) then 1505 goto Continue; 1506 end if; 1507 1508 -- Skip looking at aspect if it is totally disabled. Just mark it 1509 -- as such for later reference in the tree. This also sets the 1510 -- Is_Ignored and Is_Checked flags appropriately. 1511 1512 Check_Applicable_Policy (Aspect); 1513 1514 if Is_Disabled (Aspect) then 1515 goto Continue; 1516 end if; 1517 1518 -- Set the source location of expression, used in the case of 1519 -- a failed precondition/postcondition or invariant. Note that 1520 -- the source location of the expression is not usually the best 1521 -- choice here. For example, it gets located on the last AND 1522 -- keyword in a chain of boolean expressiond AND'ed together. 1523 -- It is best to put the message on the first character of the 1524 -- assertion, which is the effect of the First_Node call here. 1525 1526 if Present (Expr) then 1527 Eloc := Sloc (First_Node (Expr)); 1528 end if; 1529 1530 -- Check restriction No_Implementation_Aspect_Specifications 1531 1532 if Implementation_Defined_Aspect (A_Id) then 1533 Check_Restriction 1534 (No_Implementation_Aspect_Specifications, Aspect); 1535 end if; 1536 1537 -- Check restriction No_Specification_Of_Aspect 1538 1539 Check_Restriction_No_Specification_Of_Aspect (Aspect); 1540 1541 -- Mark aspect analyzed (actual analysis is delayed till later) 1542 1543 Set_Analyzed (Aspect); 1544 Set_Entity (Aspect, E); 1545 Ent := New_Occurrence_Of (E, Sloc (Id)); 1546 1547 -- Check for duplicate aspect. Note that the Comes_From_Source 1548 -- test allows duplicate Pre/Post's that we generate internally 1549 -- to escape being flagged here. 1550 1551 if No_Duplicates_Allowed (A_Id) then 1552 Anod := First (L); 1553 while Anod /= Aspect loop 1554 if Comes_From_Source (Aspect) 1555 and then Same_Aspect (A_Id, Get_Aspect_Id (Anod)) 1556 then 1557 Error_Msg_Name_1 := Nam; 1558 Error_Msg_Sloc := Sloc (Anod); 1559 1560 -- Case of same aspect specified twice 1561 1562 if Class_Present (Anod) = Class_Present (Aspect) then 1563 if not Class_Present (Anod) then 1564 Error_Msg_NE 1565 ("aspect% for & previously given#", 1566 Id, E); 1567 else 1568 Error_Msg_NE 1569 ("aspect `%''Class` for & previously given#", 1570 Id, E); 1571 end if; 1572 end if; 1573 end if; 1574 1575 Next (Anod); 1576 end loop; 1577 end if; 1578 1579 -- Check some general restrictions on language defined aspects 1580 1581 if not Implementation_Defined_Aspect (A_Id) then 1582 Error_Msg_Name_1 := Nam; 1583 1584 -- Not allowed for renaming declarations 1585 1586 if Nkind (N) in N_Renaming_Declaration then 1587 Error_Msg_N 1588 ("aspect % not allowed for renaming declaration", 1589 Aspect); 1590 end if; 1591 1592 -- Not allowed for formal type declarations 1593 1594 if Nkind (N) = N_Formal_Type_Declaration then 1595 Error_Msg_N 1596 ("aspect % not allowed for formal type declaration", 1597 Aspect); 1598 end if; 1599 end if; 1600 1601 -- Copy expression for later processing by the procedures 1602 -- Check_Aspect_At_[Freeze_Point | End_Of_Declarations] 1603 1604 Set_Entity (Id, New_Copy_Tree (Expr)); 1605 1606 -- Set Delay_Required as appropriate to aspect 1607 1608 case Aspect_Delay (A_Id) is 1609 when Always_Delay => 1610 Delay_Required := True; 1611 1612 when Never_Delay => 1613 Delay_Required := False; 1614 1615 when Rep_Aspect => 1616 1617 -- If expression has the form of an integer literal, then 1618 -- do not delay, since we know the value cannot change. 1619 -- This optimization catches most rep clause cases. 1620 1621 -- For Boolean aspects, don't delay if no expression 1622 1623 if A_Id in Boolean_Aspects and then No (Expr) then 1624 Delay_Required := False; 1625 1626 -- For non-Boolean aspects, don't delay if integer literal 1627 1628 elsif A_Id not in Boolean_Aspects 1629 and then Present (Expr) 1630 and then Nkind (Expr) = N_Integer_Literal 1631 then 1632 Delay_Required := False; 1633 1634 -- All other cases are delayed 1635 1636 else 1637 Delay_Required := True; 1638 Set_Has_Delayed_Rep_Aspects (E); 1639 end if; 1640 end case; 1641 1642 -- Processing based on specific aspect 1643 1644 case A_Id is 1645 when Aspect_Unimplemented => 1646 null; -- ??? temp for now 1647 1648 -- No_Aspect should be impossible 1649 1650 when No_Aspect => 1651 raise Program_Error; 1652 1653 -- Case 1: Aspects corresponding to attribute definition 1654 -- clauses. 1655 1656 when Aspect_Address | 1657 Aspect_Alignment | 1658 Aspect_Bit_Order | 1659 Aspect_Component_Size | 1660 Aspect_Constant_Indexing | 1661 Aspect_Default_Iterator | 1662 Aspect_Dispatching_Domain | 1663 Aspect_External_Tag | 1664 Aspect_Input | 1665 Aspect_Iterable | 1666 Aspect_Iterator_Element | 1667 Aspect_Machine_Radix | 1668 Aspect_Object_Size | 1669 Aspect_Output | 1670 Aspect_Read | 1671 Aspect_Scalar_Storage_Order | 1672 Aspect_Size | 1673 Aspect_Small | 1674 Aspect_Simple_Storage_Pool | 1675 Aspect_Storage_Pool | 1676 Aspect_Stream_Size | 1677 Aspect_Value_Size | 1678 Aspect_Variable_Indexing | 1679 Aspect_Write => 1680 1681 -- Indexing aspects apply only to tagged type 1682 1683 if (A_Id = Aspect_Constant_Indexing 1684 or else 1685 A_Id = Aspect_Variable_Indexing) 1686 and then not (Is_Type (E) 1687 and then Is_Tagged_Type (E)) 1688 then 1689 Error_Msg_N 1690 ("indexing aspect can only apply to a tagged type", 1691 Aspect); 1692 goto Continue; 1693 end if; 1694 1695 -- For the case of aspect Address, we don't consider that we 1696 -- know the entity is never set in the source, since it is 1697 -- is likely aliasing is occurring. 1698 1699 -- Note: one might think that the analysis of the resulting 1700 -- attribute definition clause would take care of that, but 1701 -- that's not the case since it won't be from source. 1702 1703 if A_Id = Aspect_Address then 1704 Set_Never_Set_In_Source (E, False); 1705 end if; 1706 1707 -- Correctness of the profile of a stream operation is 1708 -- verified at the freeze point, but we must detect the 1709 -- illegal specification of this aspect for a subtype now, 1710 -- to prevent malformed rep_item chains. 1711 1712 if A_Id = Aspect_Input or else 1713 A_Id = Aspect_Output or else 1714 A_Id = Aspect_Read or else 1715 A_Id = Aspect_Write 1716 then 1717 if not Is_First_Subtype (E) then 1718 Error_Msg_N 1719 ("local name must be a first subtype", Aspect); 1720 goto Continue; 1721 1722 -- If stream aspect applies to the class-wide type, 1723 -- the generated attribute definition applies to the 1724 -- class-wide type as well. 1725 1726 elsif Class_Present (Aspect) then 1727 Ent := 1728 Make_Attribute_Reference (Loc, 1729 Prefix => Ent, 1730 Attribute_Name => Name_Class); 1731 end if; 1732 end if; 1733 1734 -- Construct the attribute definition clause 1735 1736 Aitem := 1737 Make_Attribute_Definition_Clause (Loc, 1738 Name => Ent, 1739 Chars => Chars (Id), 1740 Expression => Relocate_Node (Expr)); 1741 1742 -- If the address is specified, then we treat the entity as 1743 -- referenced, to avoid spurious warnings. This is analogous 1744 -- to what is done with an attribute definition clause, but 1745 -- here we don't want to generate a reference because this 1746 -- is the point of definition of the entity. 1747 1748 if A_Id = Aspect_Address then 1749 Set_Referenced (E); 1750 end if; 1751 1752 -- Case 2: Aspects corresponding to pragmas 1753 1754 -- Case 2a: Aspects corresponding to pragmas with two 1755 -- arguments, where the first argument is a local name 1756 -- referring to the entity, and the second argument is the 1757 -- aspect definition expression. 1758 1759 -- Linker_Section/Suppress/Unsuppress 1760 1761 when Aspect_Linker_Section | 1762 Aspect_Suppress | 1763 Aspect_Unsuppress => 1764 1765 Make_Aitem_Pragma 1766 (Pragma_Argument_Associations => New_List ( 1767 Make_Pragma_Argument_Association (Loc, 1768 Expression => New_Occurrence_Of (E, Loc)), 1769 Make_Pragma_Argument_Association (Sloc (Expr), 1770 Expression => Relocate_Node (Expr))), 1771 Pragma_Name => Chars (Id)); 1772 1773 -- Synchronization 1774 1775 -- Corresponds to pragma Implemented, construct the pragma 1776 1777 when Aspect_Synchronization => 1778 Make_Aitem_Pragma 1779 (Pragma_Argument_Associations => New_List ( 1780 Make_Pragma_Argument_Association (Loc, 1781 Expression => New_Occurrence_Of (E, Loc)), 1782 Make_Pragma_Argument_Association (Sloc (Expr), 1783 Expression => Relocate_Node (Expr))), 1784 Pragma_Name => Name_Implemented); 1785 1786 -- Attach_Handler 1787 1788 when Aspect_Attach_Handler => 1789 Make_Aitem_Pragma 1790 (Pragma_Argument_Associations => New_List ( 1791 Make_Pragma_Argument_Association (Sloc (Ent), 1792 Expression => Ent), 1793 Make_Pragma_Argument_Association (Sloc (Expr), 1794 Expression => Relocate_Node (Expr))), 1795 Pragma_Name => Name_Attach_Handler); 1796 1797 -- We need to insert this pragma into the tree to get proper 1798 -- processing and to look valid from a placement viewpoint. 1799 1800 Insert_Pragma (Aitem); 1801 goto Continue; 1802 1803 -- Dynamic_Predicate, Predicate, Static_Predicate 1804 1805 when Aspect_Dynamic_Predicate | 1806 Aspect_Predicate | 1807 Aspect_Static_Predicate => 1808 1809 -- These aspects apply only to subtypes 1810 1811 if not Is_Type (E) then 1812 Error_Msg_N 1813 ("predicate can only be specified for a subtype", 1814 Aspect); 1815 goto Continue; 1816 1817 elsif Is_Incomplete_Type (E) then 1818 Error_Msg_N 1819 ("predicate cannot apply to incomplete view", Aspect); 1820 goto Continue; 1821 end if; 1822 1823 -- Construct the pragma (always a pragma Predicate, with 1824 -- flags recording whether it is static/dynamic). We also 1825 -- set flags recording this in the type itself. 1826 1827 Make_Aitem_Pragma 1828 (Pragma_Argument_Associations => New_List ( 1829 Make_Pragma_Argument_Association (Sloc (Ent), 1830 Expression => Ent), 1831 Make_Pragma_Argument_Association (Sloc (Expr), 1832 Expression => Relocate_Node (Expr))), 1833 Pragma_Name => Name_Predicate); 1834 1835 -- Mark type has predicates, and remember what kind of 1836 -- aspect lead to this predicate (we need this to access 1837 -- the right set of check policies later on). 1838 1839 Set_Has_Predicates (E); 1840 1841 if A_Id = Aspect_Dynamic_Predicate then 1842 Set_Has_Dynamic_Predicate_Aspect (E); 1843 elsif A_Id = Aspect_Static_Predicate then 1844 Set_Has_Static_Predicate_Aspect (E); 1845 end if; 1846 1847 -- If the type is private, indicate that its completion 1848 -- has a freeze node, because that is the one that will 1849 -- be visible at freeze time. 1850 1851 if Is_Private_Type (E) and then Present (Full_View (E)) then 1852 Set_Has_Predicates (Full_View (E)); 1853 1854 if A_Id = Aspect_Dynamic_Predicate then 1855 Set_Has_Dynamic_Predicate_Aspect (Full_View (E)); 1856 elsif A_Id = Aspect_Static_Predicate then 1857 Set_Has_Static_Predicate_Aspect (Full_View (E)); 1858 end if; 1859 1860 Set_Has_Delayed_Aspects (Full_View (E)); 1861 Ensure_Freeze_Node (Full_View (E)); 1862 end if; 1863 1864 -- Case 2b: Aspects corresponding to pragmas with two 1865 -- arguments, where the second argument is a local name 1866 -- referring to the entity, and the first argument is the 1867 -- aspect definition expression. 1868 1869 -- Convention 1870 1871 when Aspect_Convention => 1872 1873 -- The aspect may be part of the specification of an import 1874 -- or export pragma. Scan the aspect list to gather the 1875 -- other components, if any. The name of the generated 1876 -- pragma is one of Convention/Import/Export. 1877 1878 declare 1879 Args : constant List_Id := New_List ( 1880 Make_Pragma_Argument_Association (Sloc (Expr), 1881 Expression => Relocate_Node (Expr)), 1882 Make_Pragma_Argument_Association (Sloc (Ent), 1883 Expression => Ent)); 1884 1885 Imp_Exp_Seen : Boolean := False; 1886 -- Flag set when aspect Import or Export has been seen 1887 1888 Imp_Seen : Boolean := False; 1889 -- Flag set when aspect Import has been seen 1890 1891 Asp : Node_Id; 1892 Asp_Nam : Name_Id; 1893 Extern_Arg : Node_Id; 1894 Link_Arg : Node_Id; 1895 Prag_Nam : Name_Id; 1896 1897 begin 1898 Extern_Arg := Empty; 1899 Link_Arg := Empty; 1900 Prag_Nam := Chars (Id); 1901 1902 Asp := First (L); 1903 while Present (Asp) loop 1904 Asp_Nam := Chars (Identifier (Asp)); 1905 1906 -- Aspects Import and Export take precedence over 1907 -- aspect Convention. As a result the generated pragma 1908 -- must carry the proper interfacing aspect's name. 1909 1910 if Nam_In (Asp_Nam, Name_Import, Name_Export) then 1911 if Imp_Exp_Seen then 1912 Error_Msg_N ("conflicting", Asp); 1913 else 1914 Imp_Exp_Seen := True; 1915 1916 if Asp_Nam = Name_Import then 1917 Imp_Seen := True; 1918 end if; 1919 end if; 1920 1921 Prag_Nam := Asp_Nam; 1922 1923 -- Aspect External_Name adds an extra argument to the 1924 -- generated pragma. 1925 1926 elsif Asp_Nam = Name_External_Name then 1927 Extern_Arg := 1928 Make_Pragma_Argument_Association (Loc, 1929 Chars => Asp_Nam, 1930 Expression => Relocate_Node (Expression (Asp))); 1931 1932 -- Aspect Link_Name adds an extra argument to the 1933 -- generated pragma. 1934 1935 elsif Asp_Nam = Name_Link_Name then 1936 Link_Arg := 1937 Make_Pragma_Argument_Association (Loc, 1938 Chars => Asp_Nam, 1939 Expression => Relocate_Node (Expression (Asp))); 1940 end if; 1941 1942 Next (Asp); 1943 end loop; 1944 1945 -- Assemble the full argument list 1946 1947 if Present (Extern_Arg) then 1948 Append_To (Args, Extern_Arg); 1949 end if; 1950 1951 if Present (Link_Arg) then 1952 Append_To (Args, Link_Arg); 1953 end if; 1954 1955 Make_Aitem_Pragma 1956 (Pragma_Argument_Associations => Args, 1957 Pragma_Name => Prag_Nam); 1958 1959 -- Store the generated pragma Import in the related 1960 -- subprogram. 1961 1962 if Imp_Seen and then Is_Subprogram (E) then 1963 Set_Import_Pragma (E, Aitem); 1964 end if; 1965 end; 1966 1967 -- CPU, Interrupt_Priority, Priority 1968 1969 -- These three aspects can be specified for a subprogram spec 1970 -- or body, in which case we analyze the expression and export 1971 -- the value of the aspect. 1972 1973 -- Previously, we generated an equivalent pragma for bodies 1974 -- (note that the specs cannot contain these pragmas). The 1975 -- pragma was inserted ahead of local declarations, rather than 1976 -- after the body. This leads to a certain duplication between 1977 -- the processing performed for the aspect and the pragma, but 1978 -- given the straightforward handling required it is simpler 1979 -- to duplicate than to translate the aspect in the spec into 1980 -- a pragma in the declarative part of the body. 1981 1982 when Aspect_CPU | 1983 Aspect_Interrupt_Priority | 1984 Aspect_Priority => 1985 1986 if Nkind_In (N, N_Subprogram_Body, 1987 N_Subprogram_Declaration) 1988 then 1989 -- Analyze the aspect expression 1990 1991 Analyze_And_Resolve (Expr, Standard_Integer); 1992 1993 -- Interrupt_Priority aspect not allowed for main 1994 -- subprograms. ARM D.1 does not forbid this explicitly, 1995 -- but ARM J.15.11 (6/3) does not permit pragma 1996 -- Interrupt_Priority for subprograms. 1997 1998 if A_Id = Aspect_Interrupt_Priority then 1999 Error_Msg_N 2000 ("Interrupt_Priority aspect cannot apply to " 2001 & "subprogram", Expr); 2002 2003 -- The expression must be static 2004 2005 elsif not Is_OK_Static_Expression (Expr) then 2006 Flag_Non_Static_Expr 2007 ("aspect requires static expression!", Expr); 2008 2009 -- Check whether this is the main subprogram. Issue a 2010 -- warning only if it is obviously not a main program 2011 -- (when it has parameters or when the subprogram is 2012 -- within a package). 2013 2014 elsif Present (Parameter_Specifications 2015 (Specification (N))) 2016 or else not Is_Compilation_Unit (Defining_Entity (N)) 2017 then 2018 -- See ARM D.1 (14/3) and D.16 (12/3) 2019 2020 Error_Msg_N 2021 ("aspect applied to subprogram other than the " 2022 & "main subprogram has no effect??", Expr); 2023 2024 -- Otherwise check in range and export the value 2025 2026 -- For the CPU aspect 2027 2028 elsif A_Id = Aspect_CPU then 2029 if Is_In_Range (Expr, RTE (RE_CPU_Range)) then 2030 2031 -- Value is correct so we export the value to make 2032 -- it available at execution time. 2033 2034 Set_Main_CPU 2035 (Main_Unit, UI_To_Int (Expr_Value (Expr))); 2036 2037 else 2038 Error_Msg_N 2039 ("main subprogram CPU is out of range", Expr); 2040 end if; 2041 2042 -- For the Priority aspect 2043 2044 elsif A_Id = Aspect_Priority then 2045 if Is_In_Range (Expr, RTE (RE_Priority)) then 2046 2047 -- Value is correct so we export the value to make 2048 -- it available at execution time. 2049 2050 Set_Main_Priority 2051 (Main_Unit, UI_To_Int (Expr_Value (Expr))); 2052 2053 -- Ignore pragma if Relaxed_RM_Semantics to support 2054 -- other targets/non GNAT compilers. 2055 2056 elsif not Relaxed_RM_Semantics then 2057 Error_Msg_N 2058 ("main subprogram priority is out of range", 2059 Expr); 2060 end if; 2061 end if; 2062 2063 -- Load an arbitrary entity from System.Tasking.Stages 2064 -- or System.Tasking.Restricted.Stages (depending on 2065 -- the supported profile) to make sure that one of these 2066 -- packages is implicitly with'ed, since we need to have 2067 -- the tasking run time active for the pragma Priority to 2068 -- have any effect. Previously we with'ed the package 2069 -- System.Tasking, but this package does not trigger the 2070 -- required initialization of the run-time library. 2071 2072 declare 2073 Discard : Entity_Id; 2074 begin 2075 if Restricted_Profile then 2076 Discard := RTE (RE_Activate_Restricted_Tasks); 2077 else 2078 Discard := RTE (RE_Activate_Tasks); 2079 end if; 2080 end; 2081 2082 -- Handling for these Aspects in subprograms is complete 2083 2084 goto Continue; 2085 2086 -- For tasks 2087 2088 else 2089 -- Pass the aspect as an attribute 2090 2091 Aitem := 2092 Make_Attribute_Definition_Clause (Loc, 2093 Name => Ent, 2094 Chars => Chars (Id), 2095 Expression => Relocate_Node (Expr)); 2096 end if; 2097 2098 -- Warnings 2099 2100 when Aspect_Warnings => 2101 Make_Aitem_Pragma 2102 (Pragma_Argument_Associations => New_List ( 2103 Make_Pragma_Argument_Association (Sloc (Expr), 2104 Expression => Relocate_Node (Expr)), 2105 Make_Pragma_Argument_Association (Loc, 2106 Expression => New_Occurrence_Of (E, Loc))), 2107 Pragma_Name => Chars (Id)); 2108 2109 -- Case 2c: Aspects corresponding to pragmas with three 2110 -- arguments. 2111 2112 -- Invariant aspects have a first argument that references the 2113 -- entity, a second argument that is the expression and a third 2114 -- argument that is an appropriate message. 2115 2116 -- Invariant, Type_Invariant 2117 2118 when Aspect_Invariant | 2119 Aspect_Type_Invariant => 2120 2121 -- Analysis of the pragma will verify placement legality: 2122 -- an invariant must apply to a private type, or appear in 2123 -- the private part of a spec and apply to a completion. 2124 2125 Make_Aitem_Pragma 2126 (Pragma_Argument_Associations => New_List ( 2127 Make_Pragma_Argument_Association (Sloc (Ent), 2128 Expression => Ent), 2129 Make_Pragma_Argument_Association (Sloc (Expr), 2130 Expression => Relocate_Node (Expr))), 2131 Pragma_Name => Name_Invariant); 2132 2133 -- Add message unless exception messages are suppressed 2134 2135 if not Opt.Exception_Locations_Suppressed then 2136 Append_To (Pragma_Argument_Associations (Aitem), 2137 Make_Pragma_Argument_Association (Eloc, 2138 Chars => Name_Message, 2139 Expression => 2140 Make_String_Literal (Eloc, 2141 Strval => "failed invariant from " 2142 & Build_Location_String (Eloc)))); 2143 end if; 2144 2145 -- For Invariant case, insert immediately after the entity 2146 -- declaration. We do not have to worry about delay issues 2147 -- since the pragma processing takes care of this. 2148 2149 Delay_Required := False; 2150 2151 -- Case 2d : Aspects that correspond to a pragma with one 2152 -- argument. 2153 2154 -- Abstract_State 2155 2156 -- Aspect Abstract_State introduces implicit declarations for 2157 -- all state abstraction entities it defines. To emulate this 2158 -- behavior, insert the pragma at the beginning of the visible 2159 -- declarations of the related package so that it is analyzed 2160 -- immediately. 2161 2162 when Aspect_Abstract_State => Abstract_State : declare 2163 Context : Node_Id := N; 2164 Decl : Node_Id; 2165 Decls : List_Id; 2166 2167 begin 2168 -- When aspect Abstract_State appears on a generic package, 2169 -- it is propageted to the package instance. The context in 2170 -- this case is the instance spec. 2171 2172 if Nkind (Context) = N_Package_Instantiation then 2173 Context := Instance_Spec (Context); 2174 end if; 2175 2176 if Nkind_In (Context, N_Generic_Package_Declaration, 2177 N_Package_Declaration) 2178 then 2179 Make_Aitem_Pragma 2180 (Pragma_Argument_Associations => New_List ( 2181 Make_Pragma_Argument_Association (Loc, 2182 Expression => Relocate_Node (Expr))), 2183 Pragma_Name => Name_Abstract_State); 2184 Decorate (Aspect, Aitem); 2185 2186 Decls := Visible_Declarations (Specification (Context)); 2187 2188 -- In general pragma Abstract_State must be at the top 2189 -- of the existing visible declarations to emulate its 2190 -- source counterpart. The only exception to this is a 2191 -- generic instance in which case the pragma must be 2192 -- inserted after the association renamings. 2193 2194 if Present (Decls) then 2195 Decl := First (Decls); 2196 2197 -- The visible declarations of a generic instance have 2198 -- the following structure: 2199 2200 -- <renamings of generic formals> 2201 -- <renamings of internally-generated spec and body> 2202 -- <first source declaration> 2203 2204 -- The pragma must be inserted before the first source 2205 -- declaration, skip the instance "header". 2206 2207 if Is_Generic_Instance (Defining_Entity (Context)) then 2208 while Present (Decl) 2209 and then not Comes_From_Source (Decl) 2210 loop 2211 Decl := Next (Decl); 2212 end loop; 2213 end if; 2214 2215 -- When aspects Abstract_State, Ghost, 2216 -- Initial_Condition and Initializes are out of order, 2217 -- ensure that pragma SPARK_Mode is always at the top 2218 -- of the declarations to properly enabled/suppress 2219 -- errors. 2220 2221 Insert_After_SPARK_Mode 2222 (Prag => Aitem, 2223 Ins_Nod => Decl, 2224 Decls => Decls); 2225 2226 -- Otherwise the pragma forms a new declarative list 2227 2228 else 2229 Set_Visible_Declarations 2230 (Specification (Context), New_List (Aitem)); 2231 end if; 2232 2233 else 2234 Error_Msg_NE 2235 ("aspect & must apply to a package declaration", 2236 Aspect, Id); 2237 end if; 2238 2239 goto Continue; 2240 end Abstract_State; 2241 2242 -- Aspect Default_Internal_Condition is never delayed because 2243 -- it is equivalent to a source pragma which appears after the 2244 -- related private type. To deal with forward references, the 2245 -- generated pragma is stored in the rep chain of the related 2246 -- private type as types do not carry contracts. The pragma is 2247 -- wrapped inside of a procedure at the freeze point of the 2248 -- private type's full view. 2249 2250 when Aspect_Default_Initial_Condition => 2251 Make_Aitem_Pragma 2252 (Pragma_Argument_Associations => New_List ( 2253 Make_Pragma_Argument_Association (Loc, 2254 Expression => Relocate_Node (Expr))), 2255 Pragma_Name => 2256 Name_Default_Initial_Condition); 2257 2258 Decorate (Aspect, Aitem); 2259 Insert_Pragma (Aitem); 2260 goto Continue; 2261 2262 -- Default_Storage_Pool 2263 2264 when Aspect_Default_Storage_Pool => 2265 Make_Aitem_Pragma 2266 (Pragma_Argument_Associations => New_List ( 2267 Make_Pragma_Argument_Association (Loc, 2268 Expression => Relocate_Node (Expr))), 2269 Pragma_Name => 2270 Name_Default_Storage_Pool); 2271 2272 Decorate (Aspect, Aitem); 2273 Insert_Pragma (Aitem); 2274 goto Continue; 2275 2276 -- Depends 2277 2278 -- Aspect Depends is never delayed because it is equivalent to 2279 -- a source pragma which appears after the related subprogram. 2280 -- To deal with forward references, the generated pragma is 2281 -- stored in the contract of the related subprogram and later 2282 -- analyzed at the end of the declarative region. See routine 2283 -- Analyze_Depends_In_Decl_Part for details. 2284 2285 when Aspect_Depends => 2286 Make_Aitem_Pragma 2287 (Pragma_Argument_Associations => New_List ( 2288 Make_Pragma_Argument_Association (Loc, 2289 Expression => Relocate_Node (Expr))), 2290 Pragma_Name => Name_Depends); 2291 2292 Decorate (Aspect, Aitem); 2293 Insert_Pragma (Aitem); 2294 goto Continue; 2295 2296 -- Aspect Extensions_Visible is never delayed because it is 2297 -- equivalent to a source pragma which appears after the 2298 -- related subprogram. 2299 2300 when Aspect_Extensions_Visible => 2301 Make_Aitem_Pragma 2302 (Pragma_Argument_Associations => New_List ( 2303 Make_Pragma_Argument_Association (Loc, 2304 Expression => Relocate_Node (Expr))), 2305 Pragma_Name => Name_Extensions_Visible); 2306 2307 Decorate (Aspect, Aitem); 2308 Insert_Pragma (Aitem); 2309 goto Continue; 2310 2311 -- Aspect Ghost is never delayed because it is equivalent to a 2312 -- source pragma which appears at the top of [generic] package 2313 -- declarations or after an object, a [generic] subprogram, or 2314 -- a type declaration. 2315 2316 when Aspect_Ghost => Ghost : declare 2317 Decls : List_Id; 2318 2319 begin 2320 Make_Aitem_Pragma 2321 (Pragma_Argument_Associations => New_List ( 2322 Make_Pragma_Argument_Association (Loc, 2323 Expression => Relocate_Node (Expr))), 2324 Pragma_Name => Name_Ghost); 2325 2326 Decorate (Aspect, Aitem); 2327 2328 -- When the aspect applies to a [generic] package, insert 2329 -- the pragma at the top of the visible declarations. This 2330 -- emulates the placement of a source pragma. 2331 2332 if Nkind_In (N, N_Generic_Package_Declaration, 2333 N_Package_Declaration) 2334 then 2335 Decls := Visible_Declarations (Specification (N)); 2336 2337 if No (Decls) then 2338 Decls := New_List; 2339 Set_Visible_Declarations (N, Decls); 2340 end if; 2341 2342 -- When aspects Abstract_State, Ghost, Initial_Condition 2343 -- and Initializes are out of order, ensure that pragma 2344 -- SPARK_Mode is always at the top of the declarations to 2345 -- properly enabled/suppress errors. 2346 2347 Insert_After_SPARK_Mode 2348 (Prag => Aitem, 2349 Ins_Nod => First (Decls), 2350 Decls => Decls); 2351 2352 -- Otherwise the context is an object, [generic] subprogram 2353 -- or type declaration. 2354 2355 else 2356 Insert_Pragma (Aitem); 2357 end if; 2358 2359 goto Continue; 2360 end Ghost; 2361 2362 -- Global 2363 2364 -- Aspect Global is never delayed because it is equivalent to 2365 -- a source pragma which appears after the related subprogram. 2366 -- To deal with forward references, the generated pragma is 2367 -- stored in the contract of the related subprogram and later 2368 -- analyzed at the end of the declarative region. See routine 2369 -- Analyze_Global_In_Decl_Part for details. 2370 2371 when Aspect_Global => 2372 Make_Aitem_Pragma 2373 (Pragma_Argument_Associations => New_List ( 2374 Make_Pragma_Argument_Association (Loc, 2375 Expression => Relocate_Node (Expr))), 2376 Pragma_Name => Name_Global); 2377 2378 Decorate (Aspect, Aitem); 2379 Insert_Pragma (Aitem); 2380 goto Continue; 2381 2382 -- Initial_Condition 2383 2384 -- Aspect Initial_Condition is never delayed because it is 2385 -- equivalent to a source pragma which appears after the 2386 -- related package. To deal with forward references, the 2387 -- generated pragma is stored in the contract of the related 2388 -- package and later analyzed at the end of the declarative 2389 -- region. See routine Analyze_Initial_Condition_In_Decl_Part 2390 -- for details. 2391 2392 when Aspect_Initial_Condition => Initial_Condition : declare 2393 Context : Node_Id := N; 2394 Decls : List_Id; 2395 2396 begin 2397 -- When aspect Initial_Condition appears on a generic 2398 -- package, it is propageted to the package instance. The 2399 -- context in this case is the instance spec. 2400 2401 if Nkind (Context) = N_Package_Instantiation then 2402 Context := Instance_Spec (Context); 2403 end if; 2404 2405 if Nkind_In (Context, N_Generic_Package_Declaration, 2406 N_Package_Declaration) 2407 then 2408 Decls := Visible_Declarations (Specification (Context)); 2409 2410 Make_Aitem_Pragma 2411 (Pragma_Argument_Associations => New_List ( 2412 Make_Pragma_Argument_Association (Loc, 2413 Expression => Relocate_Node (Expr))), 2414 Pragma_Name => 2415 Name_Initial_Condition); 2416 Decorate (Aspect, Aitem); 2417 2418 if No (Decls) then 2419 Decls := New_List; 2420 Set_Visible_Declarations (Context, Decls); 2421 end if; 2422 2423 -- When aspects Abstract_State, Ghost, Initial_Condition 2424 -- and Initializes are out of order, ensure that pragma 2425 -- SPARK_Mode is always at the top of the declarations to 2426 -- properly enabled/suppress errors. 2427 2428 Insert_After_SPARK_Mode 2429 (Prag => Aitem, 2430 Ins_Nod => First (Decls), 2431 Decls => Decls); 2432 2433 else 2434 Error_Msg_NE 2435 ("aspect & must apply to a package declaration", 2436 Aspect, Id); 2437 end if; 2438 2439 goto Continue; 2440 end Initial_Condition; 2441 2442 -- Initializes 2443 2444 -- Aspect Initializes is never delayed because it is equivalent 2445 -- to a source pragma appearing after the related package. To 2446 -- deal with forward references, the generated pragma is stored 2447 -- in the contract of the related package and later analyzed at 2448 -- the end of the declarative region. For details, see routine 2449 -- Analyze_Initializes_In_Decl_Part. 2450 2451 when Aspect_Initializes => Initializes : declare 2452 Context : Node_Id := N; 2453 Decls : List_Id; 2454 2455 begin 2456 -- When aspect Initializes appears on a generic package, 2457 -- it is propageted to the package instance. The context 2458 -- in this case is the instance spec. 2459 2460 if Nkind (Context) = N_Package_Instantiation then 2461 Context := Instance_Spec (Context); 2462 end if; 2463 2464 if Nkind_In (Context, N_Generic_Package_Declaration, 2465 N_Package_Declaration) 2466 then 2467 Decls := Visible_Declarations (Specification (Context)); 2468 2469 Make_Aitem_Pragma 2470 (Pragma_Argument_Associations => New_List ( 2471 Make_Pragma_Argument_Association (Loc, 2472 Expression => Relocate_Node (Expr))), 2473 Pragma_Name => Name_Initializes); 2474 Decorate (Aspect, Aitem); 2475 2476 if No (Decls) then 2477 Decls := New_List; 2478 Set_Visible_Declarations (Context, Decls); 2479 end if; 2480 2481 -- When aspects Abstract_State, Ghost, Initial_Condition 2482 -- and Initializes are out of order, ensure that pragma 2483 -- SPARK_Mode is always at the top of the declarations to 2484 -- properly enabled/suppress errors. 2485 2486 Insert_After_SPARK_Mode 2487 (Prag => Aitem, 2488 Ins_Nod => First (Decls), 2489 Decls => Decls); 2490 2491 else 2492 Error_Msg_NE 2493 ("aspect & must apply to a package declaration", 2494 Aspect, Id); 2495 end if; 2496 2497 goto Continue; 2498 end Initializes; 2499 2500 -- Obsolescent 2501 2502 when Aspect_Obsolescent => declare 2503 Args : List_Id; 2504 2505 begin 2506 if No (Expr) then 2507 Args := No_List; 2508 else 2509 Args := New_List ( 2510 Make_Pragma_Argument_Association (Sloc (Expr), 2511 Expression => Relocate_Node (Expr))); 2512 end if; 2513 2514 Make_Aitem_Pragma 2515 (Pragma_Argument_Associations => Args, 2516 Pragma_Name => Chars (Id)); 2517 end; 2518 2519 -- Part_Of 2520 2521 when Aspect_Part_Of => 2522 if Nkind_In (N, N_Object_Declaration, 2523 N_Package_Instantiation) 2524 then 2525 Make_Aitem_Pragma 2526 (Pragma_Argument_Associations => New_List ( 2527 Make_Pragma_Argument_Association (Loc, 2528 Expression => Relocate_Node (Expr))), 2529 Pragma_Name => Name_Part_Of); 2530 2531 else 2532 Error_Msg_NE 2533 ("aspect & must apply to a variable or package " 2534 & "instantiation", Aspect, Id); 2535 end if; 2536 2537 -- SPARK_Mode 2538 2539 when Aspect_SPARK_Mode => SPARK_Mode : declare 2540 Decls : List_Id; 2541 2542 begin 2543 Make_Aitem_Pragma 2544 (Pragma_Argument_Associations => New_List ( 2545 Make_Pragma_Argument_Association (Loc, 2546 Expression => Relocate_Node (Expr))), 2547 Pragma_Name => Name_SPARK_Mode); 2548 2549 -- When the aspect appears on a package or a subprogram 2550 -- body, insert the generated pragma at the top of the body 2551 -- declarations to emulate the behavior of a source pragma. 2552 2553 if Nkind_In (N, N_Package_Body, N_Subprogram_Body) then 2554 Decorate (Aspect, Aitem); 2555 2556 Decls := Declarations (N); 2557 2558 if No (Decls) then 2559 Decls := New_List; 2560 Set_Declarations (N, Decls); 2561 end if; 2562 2563 Prepend_To (Decls, Aitem); 2564 goto Continue; 2565 2566 -- When the aspect is associated with a [generic] package 2567 -- declaration, insert the generated pragma at the top of 2568 -- the visible declarations to emulate the behavior of a 2569 -- source pragma. 2570 2571 elsif Nkind_In (N, N_Generic_Package_Declaration, 2572 N_Package_Declaration) 2573 then 2574 Decorate (Aspect, Aitem); 2575 2576 Decls := Visible_Declarations (Specification (N)); 2577 2578 if No (Decls) then 2579 Decls := New_List; 2580 Set_Visible_Declarations (Specification (N), Decls); 2581 end if; 2582 2583 Prepend_To (Decls, Aitem); 2584 goto Continue; 2585 end if; 2586 end SPARK_Mode; 2587 2588 -- Refined_Depends 2589 2590 -- Aspect Refined_Depends is never delayed because it is 2591 -- equivalent to a source pragma which appears in the 2592 -- declarations of the related subprogram body. To deal with 2593 -- forward references, the generated pragma is stored in the 2594 -- contract of the related subprogram body and later analyzed 2595 -- at the end of the declarative region. For details, see 2596 -- routine Analyze_Refined_Depends_In_Decl_Part. 2597 2598 when Aspect_Refined_Depends => 2599 Make_Aitem_Pragma 2600 (Pragma_Argument_Associations => New_List ( 2601 Make_Pragma_Argument_Association (Loc, 2602 Expression => Relocate_Node (Expr))), 2603 Pragma_Name => Name_Refined_Depends); 2604 2605 Decorate (Aspect, Aitem); 2606 Insert_Pragma (Aitem); 2607 goto Continue; 2608 2609 -- Refined_Global 2610 2611 -- Aspect Refined_Global is never delayed because it is 2612 -- equivalent to a source pragma which appears in the 2613 -- declarations of the related subprogram body. To deal with 2614 -- forward references, the generated pragma is stored in the 2615 -- contract of the related subprogram body and later analyzed 2616 -- at the end of the declarative region. For details, see 2617 -- routine Analyze_Refined_Global_In_Decl_Part. 2618 2619 when Aspect_Refined_Global => 2620 Make_Aitem_Pragma 2621 (Pragma_Argument_Associations => New_List ( 2622 Make_Pragma_Argument_Association (Loc, 2623 Expression => Relocate_Node (Expr))), 2624 Pragma_Name => Name_Refined_Global); 2625 2626 Decorate (Aspect, Aitem); 2627 Insert_Pragma (Aitem); 2628 goto Continue; 2629 2630 -- Refined_Post 2631 2632 when Aspect_Refined_Post => 2633 Make_Aitem_Pragma 2634 (Pragma_Argument_Associations => New_List ( 2635 Make_Pragma_Argument_Association (Loc, 2636 Expression => Relocate_Node (Expr))), 2637 Pragma_Name => Name_Refined_Post); 2638 2639 -- Refined_State 2640 2641 when Aspect_Refined_State => Refined_State : declare 2642 Decls : List_Id; 2643 2644 begin 2645 -- The corresponding pragma for Refined_State is inserted in 2646 -- the declarations of the related package body. This action 2647 -- synchronizes both the source and from-aspect versions of 2648 -- the pragma. 2649 2650 if Nkind (N) = N_Package_Body then 2651 Decls := Declarations (N); 2652 2653 Make_Aitem_Pragma 2654 (Pragma_Argument_Associations => New_List ( 2655 Make_Pragma_Argument_Association (Loc, 2656 Expression => Relocate_Node (Expr))), 2657 Pragma_Name => Name_Refined_State); 2658 Decorate (Aspect, Aitem); 2659 2660 if No (Decls) then 2661 Decls := New_List; 2662 Set_Declarations (N, Decls); 2663 end if; 2664 2665 -- Pragma Refined_State must be inserted after pragma 2666 -- SPARK_Mode in the tree. This ensures that any error 2667 -- messages dependent on SPARK_Mode will be properly 2668 -- enabled/suppressed. 2669 2670 Insert_After_SPARK_Mode 2671 (Prag => Aitem, 2672 Ins_Nod => First (Decls), 2673 Decls => Decls); 2674 2675 else 2676 Error_Msg_NE 2677 ("aspect & must apply to a package body", Aspect, Id); 2678 end if; 2679 2680 goto Continue; 2681 end Refined_State; 2682 2683 -- Relative_Deadline 2684 2685 when Aspect_Relative_Deadline => 2686 Make_Aitem_Pragma 2687 (Pragma_Argument_Associations => New_List ( 2688 Make_Pragma_Argument_Association (Loc, 2689 Expression => Relocate_Node (Expr))), 2690 Pragma_Name => Name_Relative_Deadline); 2691 2692 -- If the aspect applies to a task, the corresponding pragma 2693 -- must appear within its declarations, not after. 2694 2695 if Nkind (N) = N_Task_Type_Declaration then 2696 declare 2697 Def : Node_Id; 2698 V : List_Id; 2699 2700 begin 2701 if No (Task_Definition (N)) then 2702 Set_Task_Definition (N, 2703 Make_Task_Definition (Loc, 2704 Visible_Declarations => New_List, 2705 End_Label => Empty)); 2706 end if; 2707 2708 Def := Task_Definition (N); 2709 V := Visible_Declarations (Def); 2710 if not Is_Empty_List (V) then 2711 Insert_Before (First (V), Aitem); 2712 2713 else 2714 Set_Visible_Declarations (Def, New_List (Aitem)); 2715 end if; 2716 2717 goto Continue; 2718 end; 2719 end if; 2720 2721 -- Case 2e: Annotate aspect 2722 2723 when Aspect_Annotate => 2724 declare 2725 Args : List_Id; 2726 Pargs : List_Id; 2727 Arg : Node_Id; 2728 2729 begin 2730 -- The argument can be a single identifier 2731 2732 if Nkind (Expr) = N_Identifier then 2733 2734 -- One level of parens is allowed 2735 2736 if Paren_Count (Expr) > 1 then 2737 Error_Msg_F ("extra parentheses ignored", Expr); 2738 end if; 2739 2740 Set_Paren_Count (Expr, 0); 2741 2742 -- Add the single item to the list 2743 2744 Args := New_List (Expr); 2745 2746 -- Otherwise we must have an aggregate 2747 2748 elsif Nkind (Expr) = N_Aggregate then 2749 2750 -- Must be positional 2751 2752 if Present (Component_Associations (Expr)) then 2753 Error_Msg_F 2754 ("purely positional aggregate required", Expr); 2755 goto Continue; 2756 end if; 2757 2758 -- Must not be parenthesized 2759 2760 if Paren_Count (Expr) /= 0 then 2761 Error_Msg_F ("extra parentheses ignored", Expr); 2762 end if; 2763 2764 -- List of arguments is list of aggregate expressions 2765 2766 Args := Expressions (Expr); 2767 2768 -- Anything else is illegal 2769 2770 else 2771 Error_Msg_F ("wrong form for Annotate aspect", Expr); 2772 goto Continue; 2773 end if; 2774 2775 -- Prepare pragma arguments 2776 2777 Pargs := New_List; 2778 Arg := First (Args); 2779 while Present (Arg) loop 2780 Append_To (Pargs, 2781 Make_Pragma_Argument_Association (Sloc (Arg), 2782 Expression => Relocate_Node (Arg))); 2783 Next (Arg); 2784 end loop; 2785 2786 Append_To (Pargs, 2787 Make_Pragma_Argument_Association (Sloc (Ent), 2788 Chars => Name_Entity, 2789 Expression => Ent)); 2790 2791 Make_Aitem_Pragma 2792 (Pragma_Argument_Associations => Pargs, 2793 Pragma_Name => Name_Annotate); 2794 end; 2795 2796 -- Case 3 : Aspects that don't correspond to pragma/attribute 2797 -- definition clause. 2798 2799 -- Case 3a: The aspects listed below don't correspond to 2800 -- pragmas/attributes but do require delayed analysis. 2801 2802 -- Default_Value can only apply to a scalar type 2803 2804 when Aspect_Default_Value => 2805 if not Is_Scalar_Type (E) then 2806 Error_Msg_N 2807 ("aspect Default_Value must apply to a scalar type", N); 2808 end if; 2809 2810 Aitem := Empty; 2811 2812 -- Default_Component_Value can only apply to an array type 2813 -- with scalar components. 2814 2815 when Aspect_Default_Component_Value => 2816 if not (Is_Array_Type (E) 2817 and then Is_Scalar_Type (Component_Type (E))) 2818 then 2819 Error_Msg_N ("aspect Default_Component_Value can only " 2820 & "apply to an array of scalar components", N); 2821 end if; 2822 2823 Aitem := Empty; 2824 2825 -- Case 3b: The aspects listed below don't correspond to 2826 -- pragmas/attributes and don't need delayed analysis. 2827 2828 -- Implicit_Dereference 2829 2830 -- For Implicit_Dereference, External_Name and Link_Name, only 2831 -- the legality checks are done during the analysis, thus no 2832 -- delay is required. 2833 2834 when Aspect_Implicit_Dereference => 2835 Analyze_Aspect_Implicit_Dereference; 2836 goto Continue; 2837 2838 -- External_Name, Link_Name 2839 2840 when Aspect_External_Name | 2841 Aspect_Link_Name => 2842 Analyze_Aspect_External_Or_Link_Name; 2843 goto Continue; 2844 2845 -- Dimension 2846 2847 when Aspect_Dimension => 2848 Analyze_Aspect_Dimension (N, Id, Expr); 2849 goto Continue; 2850 2851 -- Dimension_System 2852 2853 when Aspect_Dimension_System => 2854 Analyze_Aspect_Dimension_System (N, Id, Expr); 2855 goto Continue; 2856 2857 -- Case 4: Aspects requiring special handling 2858 2859 -- Pre/Post/Test_Case/Contract_Cases whose corresponding 2860 -- pragmas take care of the delay. 2861 2862 -- Pre/Post 2863 2864 -- Aspects Pre/Post generate Precondition/Postcondition pragmas 2865 -- with a first argument that is the expression, and a second 2866 -- argument that is an informative message if the test fails. 2867 -- This is inserted right after the declaration, to get the 2868 -- required pragma placement. The processing for the pragmas 2869 -- takes care of the required delay. 2870 2871 when Pre_Post_Aspects => Pre_Post : declare 2872 Pname : Name_Id; 2873 2874 begin 2875 if A_Id = Aspect_Pre or else A_Id = Aspect_Precondition then 2876 Pname := Name_Precondition; 2877 else 2878 Pname := Name_Postcondition; 2879 end if; 2880 2881 -- If the expressions is of the form A and then B, then 2882 -- we generate separate Pre/Post aspects for the separate 2883 -- clauses. Since we allow multiple pragmas, there is no 2884 -- problem in allowing multiple Pre/Post aspects internally. 2885 -- These should be treated in reverse order (B first and 2886 -- A second) since they are later inserted just after N in 2887 -- the order they are treated. This way, the pragma for A 2888 -- ends up preceding the pragma for B, which may have an 2889 -- importance for the error raised (either constraint error 2890 -- or precondition error). 2891 2892 -- We do not do this for Pre'Class, since we have to put 2893 -- these conditions together in a complex OR expression. 2894 2895 -- We do not do this in ASIS mode, as ASIS relies on the 2896 -- original node representing the complete expression, when 2897 -- retrieving it through the source aspect table. 2898 2899 if not ASIS_Mode 2900 and then (Pname = Name_Postcondition 2901 or else not Class_Present (Aspect)) 2902 then 2903 while Nkind (Expr) = N_And_Then loop 2904 Insert_After (Aspect, 2905 Make_Aspect_Specification (Sloc (Left_Opnd (Expr)), 2906 Identifier => Identifier (Aspect), 2907 Expression => Relocate_Node (Left_Opnd (Expr)), 2908 Class_Present => Class_Present (Aspect), 2909 Split_PPC => True)); 2910 Rewrite (Expr, Relocate_Node (Right_Opnd (Expr))); 2911 Eloc := Sloc (Expr); 2912 end loop; 2913 end if; 2914 2915 -- Build the precondition/postcondition pragma 2916 2917 -- Add note about why we do NOT need Copy_Tree here??? 2918 2919 Make_Aitem_Pragma 2920 (Pragma_Argument_Associations => New_List ( 2921 Make_Pragma_Argument_Association (Eloc, 2922 Chars => Name_Check, 2923 Expression => Relocate_Node (Expr))), 2924 Pragma_Name => Pname); 2925 2926 -- Add message unless exception messages are suppressed 2927 2928 if not Opt.Exception_Locations_Suppressed then 2929 Append_To (Pragma_Argument_Associations (Aitem), 2930 Make_Pragma_Argument_Association (Eloc, 2931 Chars => Name_Message, 2932 Expression => 2933 Make_String_Literal (Eloc, 2934 Strval => "failed " 2935 & Get_Name_String (Pname) 2936 & " from " 2937 & Build_Location_String (Eloc)))); 2938 end if; 2939 2940 Set_Is_Delayed_Aspect (Aspect); 2941 2942 -- For Pre/Post cases, insert immediately after the entity 2943 -- declaration, since that is the required pragma placement. 2944 -- Note that for these aspects, we do not have to worry 2945 -- about delay issues, since the pragmas themselves deal 2946 -- with delay of visibility for the expression analysis. 2947 2948 Insert_Pragma (Aitem); 2949 2950 goto Continue; 2951 end Pre_Post; 2952 2953 -- Test_Case 2954 2955 when Aspect_Test_Case => Test_Case : declare 2956 Args : List_Id; 2957 Comp_Expr : Node_Id; 2958 Comp_Assn : Node_Id; 2959 New_Expr : Node_Id; 2960 2961 begin 2962 Args := New_List; 2963 2964 if Nkind (Parent (N)) = N_Compilation_Unit then 2965 Error_Msg_Name_1 := Nam; 2966 Error_Msg_N ("incorrect placement of aspect `%`", E); 2967 goto Continue; 2968 end if; 2969 2970 if Nkind (Expr) /= N_Aggregate then 2971 Error_Msg_Name_1 := Nam; 2972 Error_Msg_NE 2973 ("wrong syntax for aspect `%` for &", Id, E); 2974 goto Continue; 2975 end if; 2976 2977 -- Make pragma expressions refer to the original aspect 2978 -- expressions through the Original_Node link. This is used 2979 -- in semantic analysis for ASIS mode, so that the original 2980 -- expression also gets analyzed. 2981 2982 Comp_Expr := First (Expressions (Expr)); 2983 while Present (Comp_Expr) loop 2984 New_Expr := Relocate_Node (Comp_Expr); 2985 Append_To (Args, 2986 Make_Pragma_Argument_Association (Sloc (Comp_Expr), 2987 Expression => New_Expr)); 2988 Next (Comp_Expr); 2989 end loop; 2990 2991 Comp_Assn := First (Component_Associations (Expr)); 2992 while Present (Comp_Assn) loop 2993 if List_Length (Choices (Comp_Assn)) /= 1 2994 or else 2995 Nkind (First (Choices (Comp_Assn))) /= N_Identifier 2996 then 2997 Error_Msg_Name_1 := Nam; 2998 Error_Msg_NE 2999 ("wrong syntax for aspect `%` for &", Id, E); 3000 goto Continue; 3001 end if; 3002 3003 Append_To (Args, 3004 Make_Pragma_Argument_Association (Sloc (Comp_Assn), 3005 Chars => Chars (First (Choices (Comp_Assn))), 3006 Expression => 3007 Relocate_Node (Expression (Comp_Assn)))); 3008 Next (Comp_Assn); 3009 end loop; 3010 3011 -- Build the test-case pragma 3012 3013 Make_Aitem_Pragma 3014 (Pragma_Argument_Associations => Args, 3015 Pragma_Name => Nam); 3016 end Test_Case; 3017 3018 -- Contract_Cases 3019 3020 when Aspect_Contract_Cases => 3021 Make_Aitem_Pragma 3022 (Pragma_Argument_Associations => New_List ( 3023 Make_Pragma_Argument_Association (Loc, 3024 Expression => Relocate_Node (Expr))), 3025 Pragma_Name => Nam); 3026 3027 Decorate (Aspect, Aitem); 3028 Insert_Pragma (Aitem); 3029 goto Continue; 3030 3031 -- Case 5: Special handling for aspects with an optional 3032 -- boolean argument. 3033 3034 -- In the general case, the corresponding pragma cannot be 3035 -- generated yet because the evaluation of the boolean needs 3036 -- to be delayed till the freeze point. 3037 3038 when Boolean_Aspects | 3039 Library_Unit_Aspects => 3040 3041 Set_Is_Boolean_Aspect (Aspect); 3042 3043 -- Lock_Free aspect only apply to protected objects 3044 3045 if A_Id = Aspect_Lock_Free then 3046 if Ekind (E) /= E_Protected_Type then 3047 Error_Msg_Name_1 := Nam; 3048 Error_Msg_N 3049 ("aspect % only applies to a protected object", 3050 Aspect); 3051 3052 else 3053 -- Set the Uses_Lock_Free flag to True if there is no 3054 -- expression or if the expression is True. The 3055 -- evaluation of this aspect should be delayed to the 3056 -- freeze point (why???) 3057 3058 if No (Expr) 3059 or else Is_True (Static_Boolean (Expr)) 3060 then 3061 Set_Uses_Lock_Free (E); 3062 end if; 3063 3064 Record_Rep_Item (E, Aspect); 3065 end if; 3066 3067 goto Continue; 3068 3069 elsif A_Id = Aspect_Import or else A_Id = Aspect_Export then 3070 3071 -- For the case of aspects Import and Export, we don't 3072 -- consider that we know the entity is never set in the 3073 -- source, since it is is likely modified outside the 3074 -- program. 3075 3076 -- Note: one might think that the analysis of the 3077 -- resulting pragma would take care of that, but 3078 -- that's not the case since it won't be from source. 3079 3080 if Ekind (E) = E_Variable then 3081 Set_Never_Set_In_Source (E, False); 3082 end if; 3083 3084 -- In older versions of Ada the corresponding pragmas 3085 -- specified a Convention. In Ada 2012 the convention is 3086 -- specified as a separate aspect, and it is optional, 3087 -- given that it defaults to Convention_Ada. The code 3088 -- that verifed that there was a matching convention 3089 -- is now obsolete. 3090 3091 -- Resolve the expression of an Import or Export here, 3092 -- and require it to be of type Boolean and static. This 3093 -- is not quite right, because in general this should be 3094 -- delayed, but that seems tricky for these, because 3095 -- normally Boolean aspects are replaced with pragmas at 3096 -- the freeze point (in Make_Pragma_From_Boolean_Aspect), 3097 -- but in the case of these aspects we can't generate 3098 -- a simple pragma with just the entity name. ??? 3099 3100 if not Present (Expr) 3101 or else Is_True (Static_Boolean (Expr)) 3102 then 3103 if A_Id = Aspect_Import then 3104 Set_Is_Imported (E); 3105 3106 -- An imported entity cannot have an explicit 3107 -- initialization. 3108 3109 if Nkind (N) = N_Object_Declaration 3110 and then Present (Expression (N)) 3111 then 3112 Error_Msg_N 3113 ("imported entities cannot be initialized " 3114 & "(RM B.1(24))", Expression (N)); 3115 end if; 3116 3117 elsif A_Id = Aspect_Export then 3118 Set_Is_Exported (E); 3119 end if; 3120 end if; 3121 3122 goto Continue; 3123 end if; 3124 3125 -- Library unit aspects require special handling in the case 3126 -- of a package declaration, the pragma needs to be inserted 3127 -- in the list of declarations for the associated package. 3128 -- There is no issue of visibility delay for these aspects. 3129 3130 if A_Id in Library_Unit_Aspects 3131 and then 3132 Nkind_In (N, N_Package_Declaration, 3133 N_Generic_Package_Declaration) 3134 and then Nkind (Parent (N)) /= N_Compilation_Unit 3135 3136 -- Aspect is legal on a local instantiation of a library- 3137 -- level generic unit. 3138 3139 and then not Is_Generic_Instance (Defining_Entity (N)) 3140 then 3141 Error_Msg_N 3142 ("incorrect context for library unit aspect&", Id); 3143 goto Continue; 3144 end if; 3145 3146 -- External property aspects are Boolean by nature, but 3147 -- their pragmas must contain two arguments, the second 3148 -- being the optional Boolean expression. 3149 3150 if A_Id = Aspect_Async_Readers or else 3151 A_Id = Aspect_Async_Writers or else 3152 A_Id = Aspect_Effective_Reads or else 3153 A_Id = Aspect_Effective_Writes 3154 then 3155 declare 3156 Args : List_Id; 3157 3158 begin 3159 -- The first argument of the external property pragma 3160 -- is the related object. 3161 3162 Args := 3163 New_List ( 3164 Make_Pragma_Argument_Association (Sloc (Ent), 3165 Expression => Ent)); 3166 3167 -- The second argument is the optional Boolean 3168 -- expression which must be propagated even if it 3169 -- evaluates to False as this has special semantic 3170 -- meaning. 3171 3172 if Present (Expr) then 3173 Append_To (Args, 3174 Make_Pragma_Argument_Association (Loc, 3175 Expression => Relocate_Node (Expr))); 3176 end if; 3177 3178 Make_Aitem_Pragma 3179 (Pragma_Argument_Associations => Args, 3180 Pragma_Name => Nam); 3181 end; 3182 3183 -- Cases where we do not delay, includes all cases where the 3184 -- expression is missing other than the above cases. 3185 3186 elsif not Delay_Required or else No (Expr) then 3187 Make_Aitem_Pragma 3188 (Pragma_Argument_Associations => New_List ( 3189 Make_Pragma_Argument_Association (Sloc (Ent), 3190 Expression => Ent)), 3191 Pragma_Name => Chars (Id)); 3192 Delay_Required := False; 3193 3194 -- In general cases, the corresponding pragma/attribute 3195 -- definition clause will be inserted later at the freezing 3196 -- point, and we do not need to build it now. 3197 3198 else 3199 Aitem := Empty; 3200 end if; 3201 3202 -- Storage_Size 3203 3204 -- This is special because for access types we need to generate 3205 -- an attribute definition clause. This also works for single 3206 -- task declarations, but it does not work for task type 3207 -- declarations, because we have the case where the expression 3208 -- references a discriminant of the task type. That can't use 3209 -- an attribute definition clause because we would not have 3210 -- visibility on the discriminant. For that case we must 3211 -- generate a pragma in the task definition. 3212 3213 when Aspect_Storage_Size => 3214 3215 -- Task type case 3216 3217 if Ekind (E) = E_Task_Type then 3218 declare 3219 Decl : constant Node_Id := Declaration_Node (E); 3220 3221 begin 3222 pragma Assert (Nkind (Decl) = N_Task_Type_Declaration); 3223 3224 -- If no task definition, create one 3225 3226 if No (Task_Definition (Decl)) then 3227 Set_Task_Definition (Decl, 3228 Make_Task_Definition (Loc, 3229 Visible_Declarations => Empty_List, 3230 End_Label => Empty)); 3231 end if; 3232 3233 -- Create a pragma and put it at the start of the task 3234 -- definition for the task type declaration. 3235 3236 Make_Aitem_Pragma 3237 (Pragma_Argument_Associations => New_List ( 3238 Make_Pragma_Argument_Association (Loc, 3239 Expression => Relocate_Node (Expr))), 3240 Pragma_Name => Name_Storage_Size); 3241 3242 Prepend 3243 (Aitem, 3244 Visible_Declarations (Task_Definition (Decl))); 3245 goto Continue; 3246 end; 3247 3248 -- All other cases, generate attribute definition 3249 3250 else 3251 Aitem := 3252 Make_Attribute_Definition_Clause (Loc, 3253 Name => Ent, 3254 Chars => Chars (Id), 3255 Expression => Relocate_Node (Expr)); 3256 end if; 3257 end case; 3258 3259 -- Attach the corresponding pragma/attribute definition clause to 3260 -- the aspect specification node. 3261 3262 if Present (Aitem) then 3263 Set_From_Aspect_Specification (Aitem); 3264 end if; 3265 3266 -- In the context of a compilation unit, we directly put the 3267 -- pragma in the Pragmas_After list of the N_Compilation_Unit_Aux 3268 -- node (no delay is required here) except for aspects on a 3269 -- subprogram body (see below) and a generic package, for which we 3270 -- need to introduce the pragma before building the generic copy 3271 -- (see sem_ch12), and for package instantiations, where the 3272 -- library unit pragmas are better handled early. 3273 3274 if Nkind (Parent (N)) = N_Compilation_Unit 3275 and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect)) 3276 then 3277 declare 3278 Aux : constant Node_Id := Aux_Decls_Node (Parent (N)); 3279 3280 begin 3281 pragma Assert (Nkind (Aux) = N_Compilation_Unit_Aux); 3282 3283 -- For a Boolean aspect, create the corresponding pragma if 3284 -- no expression or if the value is True. 3285 3286 if Is_Boolean_Aspect (Aspect) and then No (Aitem) then 3287 if Is_True (Static_Boolean (Expr)) then 3288 Make_Aitem_Pragma 3289 (Pragma_Argument_Associations => New_List ( 3290 Make_Pragma_Argument_Association (Sloc (Ent), 3291 Expression => Ent)), 3292 Pragma_Name => Chars (Id)); 3293 3294 Set_From_Aspect_Specification (Aitem, True); 3295 Set_Corresponding_Aspect (Aitem, Aspect); 3296 3297 else 3298 goto Continue; 3299 end if; 3300 end if; 3301 3302 -- If the aspect is on a subprogram body (relevant aspect 3303 -- is Inline), add the pragma in front of the declarations. 3304 3305 if Nkind (N) = N_Subprogram_Body then 3306 if No (Declarations (N)) then 3307 Set_Declarations (N, New_List); 3308 end if; 3309 3310 Prepend (Aitem, Declarations (N)); 3311 3312 elsif Nkind (N) = N_Generic_Package_Declaration then 3313 if No (Visible_Declarations (Specification (N))) then 3314 Set_Visible_Declarations (Specification (N), New_List); 3315 end if; 3316 3317 Prepend (Aitem, 3318 Visible_Declarations (Specification (N))); 3319 3320 elsif Nkind (N) = N_Package_Instantiation then 3321 declare 3322 Spec : constant Node_Id := 3323 Specification (Instance_Spec (N)); 3324 begin 3325 if No (Visible_Declarations (Spec)) then 3326 Set_Visible_Declarations (Spec, New_List); 3327 end if; 3328 3329 Prepend (Aitem, Visible_Declarations (Spec)); 3330 end; 3331 3332 else 3333 if No (Pragmas_After (Aux)) then 3334 Set_Pragmas_After (Aux, New_List); 3335 end if; 3336 3337 Append (Aitem, Pragmas_After (Aux)); 3338 end if; 3339 3340 goto Continue; 3341 end; 3342 end if; 3343 3344 -- The evaluation of the aspect is delayed to the freezing point. 3345 -- The pragma or attribute clause if there is one is then attached 3346 -- to the aspect specification which is put in the rep item list. 3347 3348 if Delay_Required then 3349 if Present (Aitem) then 3350 Set_Is_Delayed_Aspect (Aitem); 3351 Set_Aspect_Rep_Item (Aspect, Aitem); 3352 Set_Parent (Aitem, Aspect); 3353 end if; 3354 3355 Set_Is_Delayed_Aspect (Aspect); 3356 3357 -- In the case of Default_Value, link the aspect to base type 3358 -- as well, even though it appears on a first subtype. This is 3359 -- mandated by the semantics of the aspect. Do not establish 3360 -- the link when processing the base type itself as this leads 3361 -- to a rep item circularity. Verify that we are dealing with 3362 -- a scalar type to prevent cascaded errors. 3363 3364 if A_Id = Aspect_Default_Value 3365 and then Is_Scalar_Type (E) 3366 and then Base_Type (E) /= E 3367 then 3368 Set_Has_Delayed_Aspects (Base_Type (E)); 3369 Record_Rep_Item (Base_Type (E), Aspect); 3370 end if; 3371 3372 Set_Has_Delayed_Aspects (E); 3373 Record_Rep_Item (E, Aspect); 3374 3375 -- When delay is not required and the context is a package or a 3376 -- subprogram body, insert the pragma in the body declarations. 3377 3378 elsif Nkind_In (N, N_Package_Body, N_Subprogram_Body) then 3379 if No (Declarations (N)) then 3380 Set_Declarations (N, New_List); 3381 end if; 3382 3383 -- The pragma is added before source declarations 3384 3385 Prepend_To (Declarations (N), Aitem); 3386 3387 -- When delay is not required and the context is not a compilation 3388 -- unit, we simply insert the pragma/attribute definition clause 3389 -- in sequence. 3390 3391 else 3392 Insert_After (Ins_Node, Aitem); 3393 Ins_Node := Aitem; 3394 end if; 3395 end Analyze_One_Aspect; 3396 3397 <<Continue>> 3398 Next (Aspect); 3399 end loop Aspect_Loop; 3400 3401 if Has_Delayed_Aspects (E) then 3402 Ensure_Freeze_Node (E); 3403 end if; 3404 end Analyze_Aspect_Specifications; 3405 3406 ----------------------- 3407 -- Analyze_At_Clause -- 3408 ----------------------- 3409 3410 -- An at clause is replaced by the corresponding Address attribute 3411 -- definition clause that is the preferred approach in Ada 95. 3412 3413 procedure Analyze_At_Clause (N : Node_Id) is 3414 CS : constant Boolean := Comes_From_Source (N); 3415 3416 begin 3417 -- This is an obsolescent feature 3418 3419 Check_Restriction (No_Obsolescent_Features, N); 3420 3421 if Warn_On_Obsolescent_Feature then 3422 Error_Msg_N 3423 ("?j?at clause is an obsolescent feature (RM J.7(2))", N); 3424 Error_Msg_N 3425 ("\?j?use address attribute definition clause instead", N); 3426 end if; 3427 3428 -- Rewrite as address clause 3429 3430 Rewrite (N, 3431 Make_Attribute_Definition_Clause (Sloc (N), 3432 Name => Identifier (N), 3433 Chars => Name_Address, 3434 Expression => Expression (N))); 3435 3436 -- We preserve Comes_From_Source, since logically the clause still comes 3437 -- from the source program even though it is changed in form. 3438 3439 Set_Comes_From_Source (N, CS); 3440 3441 -- Analyze rewritten clause 3442 3443 Analyze_Attribute_Definition_Clause (N); 3444 end Analyze_At_Clause; 3445 3446 ----------------------------------------- 3447 -- Analyze_Attribute_Definition_Clause -- 3448 ----------------------------------------- 3449 3450 procedure Analyze_Attribute_Definition_Clause (N : Node_Id) is 3451 Loc : constant Source_Ptr := Sloc (N); 3452 Nam : constant Node_Id := Name (N); 3453 Attr : constant Name_Id := Chars (N); 3454 Expr : constant Node_Id := Expression (N); 3455 Id : constant Attribute_Id := Get_Attribute_Id (Attr); 3456 3457 Ent : Entity_Id; 3458 -- The entity of Nam after it is analyzed. In the case of an incomplete 3459 -- type, this is the underlying type. 3460 3461 U_Ent : Entity_Id; 3462 -- The underlying entity to which the attribute applies. Generally this 3463 -- is the Underlying_Type of Ent, except in the case where the clause 3464 -- applies to full view of incomplete type or private type in which case 3465 -- U_Ent is just a copy of Ent. 3466 3467 FOnly : Boolean := False; 3468 -- Reset to True for subtype specific attribute (Alignment, Size) 3469 -- and for stream attributes, i.e. those cases where in the call to 3470 -- Rep_Item_Too_Late, FOnly is set True so that only the freezing rules 3471 -- are checked. Note that the case of stream attributes is not clear 3472 -- from the RM, but see AI95-00137. Also, the RM seems to disallow 3473 -- Storage_Size for derived task types, but that is also clearly 3474 -- unintentional. 3475 3476 procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type); 3477 -- Common processing for 'Read, 'Write, 'Input and 'Output attribute 3478 -- definition clauses. 3479 3480 function Duplicate_Clause return Boolean; 3481 -- This routine checks if the aspect for U_Ent being given by attribute 3482 -- definition clause N is for an aspect that has already been specified, 3483 -- and if so gives an error message. If there is a duplicate, True is 3484 -- returned, otherwise if there is no error, False is returned. 3485 3486 procedure Check_Indexing_Functions; 3487 -- Check that the function in Constant_Indexing or Variable_Indexing 3488 -- attribute has the proper type structure. If the name is overloaded, 3489 -- check that some interpretation is legal. 3490 3491 procedure Check_Iterator_Functions; 3492 -- Check that there is a single function in Default_Iterator attribute 3493 -- has the proper type structure. 3494 3495 function Check_Primitive_Function (Subp : Entity_Id) return Boolean; 3496 -- Common legality check for the previous two 3497 3498 ----------------------------------- 3499 -- Analyze_Stream_TSS_Definition -- 3500 ----------------------------------- 3501 3502 procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is 3503 Subp : Entity_Id := Empty; 3504 I : Interp_Index; 3505 It : Interp; 3506 Pnam : Entity_Id; 3507 3508 Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read); 3509 -- True for Read attribute, false for other attributes 3510 3511 function Has_Good_Profile (Subp : Entity_Id) return Boolean; 3512 -- Return true if the entity is a subprogram with an appropriate 3513 -- profile for the attribute being defined. 3514 3515 ---------------------- 3516 -- Has_Good_Profile -- 3517 ---------------------- 3518 3519 function Has_Good_Profile (Subp : Entity_Id) return Boolean is 3520 F : Entity_Id; 3521 Is_Function : constant Boolean := (TSS_Nam = TSS_Stream_Input); 3522 Expected_Ekind : constant array (Boolean) of Entity_Kind := 3523 (False => E_Procedure, True => E_Function); 3524 Typ : Entity_Id; 3525 3526 begin 3527 if Ekind (Subp) /= Expected_Ekind (Is_Function) then 3528 return False; 3529 end if; 3530 3531 F := First_Formal (Subp); 3532 3533 if No (F) 3534 or else Ekind (Etype (F)) /= E_Anonymous_Access_Type 3535 or else Designated_Type (Etype (F)) /= 3536 Class_Wide_Type (RTE (RE_Root_Stream_Type)) 3537 then 3538 return False; 3539 end if; 3540 3541 if not Is_Function then 3542 Next_Formal (F); 3543 3544 declare 3545 Expected_Mode : constant array (Boolean) of Entity_Kind := 3546 (False => E_In_Parameter, 3547 True => E_Out_Parameter); 3548 begin 3549 if Parameter_Mode (F) /= Expected_Mode (Is_Read) then 3550 return False; 3551 end if; 3552 end; 3553 3554 Typ := Etype (F); 3555 3556 -- If the attribute specification comes from an aspect 3557 -- specification for a class-wide stream, the parameter must be 3558 -- a class-wide type of the entity to which the aspect applies. 3559 3560 if From_Aspect_Specification (N) 3561 and then Class_Present (Parent (N)) 3562 and then Is_Class_Wide_Type (Typ) 3563 then 3564 Typ := Etype (Typ); 3565 end if; 3566 3567 else 3568 Typ := Etype (Subp); 3569 end if; 3570 3571 -- Verify that the prefix of the attribute and the local name for 3572 -- the type of the formal match, or one is the class-wide of the 3573 -- other, in the case of a class-wide stream operation. 3574 3575 if Base_Type (Typ) = Base_Type (Ent) 3576 or else (Is_Class_Wide_Type (Typ) 3577 and then Typ = Class_Wide_Type (Base_Type (Ent))) 3578 or else (Is_Class_Wide_Type (Ent) 3579 and then Ent = Class_Wide_Type (Base_Type (Typ))) 3580 then 3581 null; 3582 else 3583 return False; 3584 end if; 3585 3586 if Present ((Next_Formal (F))) 3587 then 3588 return False; 3589 3590 elsif not Is_Scalar_Type (Typ) 3591 and then not Is_First_Subtype (Typ) 3592 and then not Is_Class_Wide_Type (Typ) 3593 then 3594 return False; 3595 3596 else 3597 return True; 3598 end if; 3599 end Has_Good_Profile; 3600 3601 -- Start of processing for Analyze_Stream_TSS_Definition 3602 3603 begin 3604 FOnly := True; 3605 3606 if not Is_Type (U_Ent) then 3607 Error_Msg_N ("local name must be a subtype", Nam); 3608 return; 3609 3610 elsif not Is_First_Subtype (U_Ent) then 3611 Error_Msg_N ("local name must be a first subtype", Nam); 3612 return; 3613 end if; 3614 3615 Pnam := TSS (Base_Type (U_Ent), TSS_Nam); 3616 3617 -- If Pnam is present, it can be either inherited from an ancestor 3618 -- type (in which case it is legal to redefine it for this type), or 3619 -- be a previous definition of the attribute for the same type (in 3620 -- which case it is illegal). 3621 3622 -- In the first case, it will have been analyzed already, and we 3623 -- can check that its profile does not match the expected profile 3624 -- for a stream attribute of U_Ent. In the second case, either Pnam 3625 -- has been analyzed (and has the expected profile), or it has not 3626 -- been analyzed yet (case of a type that has not been frozen yet 3627 -- and for which the stream attribute has been set using Set_TSS). 3628 3629 if Present (Pnam) 3630 and then (No (First_Entity (Pnam)) or else Has_Good_Profile (Pnam)) 3631 then 3632 Error_Msg_Sloc := Sloc (Pnam); 3633 Error_Msg_Name_1 := Attr; 3634 Error_Msg_N ("% attribute already defined #", Nam); 3635 return; 3636 end if; 3637 3638 Analyze (Expr); 3639 3640 if Is_Entity_Name (Expr) then 3641 if not Is_Overloaded (Expr) then 3642 if Has_Good_Profile (Entity (Expr)) then 3643 Subp := Entity (Expr); 3644 end if; 3645 3646 else 3647 Get_First_Interp (Expr, I, It); 3648 while Present (It.Nam) loop 3649 if Has_Good_Profile (It.Nam) then 3650 Subp := It.Nam; 3651 exit; 3652 end if; 3653 3654 Get_Next_Interp (I, It); 3655 end loop; 3656 end if; 3657 end if; 3658 3659 if Present (Subp) then 3660 if Is_Abstract_Subprogram (Subp) then 3661 Error_Msg_N ("stream subprogram must not be abstract", Expr); 3662 return; 3663 3664 -- A stream subprogram for an interface type must be a null 3665 -- procedure (RM 13.13.2 (38/3)). 3666 3667 elsif Is_Interface (U_Ent) 3668 and then not Is_Class_Wide_Type (U_Ent) 3669 and then not Inside_A_Generic 3670 and then 3671 (Ekind (Subp) = E_Function 3672 or else 3673 not Null_Present 3674 (Specification 3675 (Unit_Declaration_Node (Ultimate_Alias (Subp))))) 3676 then 3677 Error_Msg_N 3678 ("stream subprogram for interface type " 3679 & "must be null procedure", Expr); 3680 end if; 3681 3682 Set_Entity (Expr, Subp); 3683 Set_Etype (Expr, Etype (Subp)); 3684 3685 New_Stream_Subprogram (N, U_Ent, Subp, TSS_Nam); 3686 3687 else 3688 Error_Msg_Name_1 := Attr; 3689 Error_Msg_N ("incorrect expression for% attribute", Expr); 3690 end if; 3691 end Analyze_Stream_TSS_Definition; 3692 3693 ------------------------------ 3694 -- Check_Indexing_Functions -- 3695 ------------------------------ 3696 3697 procedure Check_Indexing_Functions is 3698 Indexing_Found : Boolean := False; 3699 3700 procedure Check_One_Function (Subp : Entity_Id); 3701 -- Check one possible interpretation. Sets Indexing_Found True if a 3702 -- legal indexing function is found. 3703 3704 procedure Illegal_Indexing (Msg : String); 3705 -- Diagnose illegal indexing function if not overloaded. In the 3706 -- overloaded case indicate that no legal interpretation exists. 3707 3708 ------------------------ 3709 -- Check_One_Function -- 3710 ------------------------ 3711 3712 procedure Check_One_Function (Subp : Entity_Id) is 3713 Default_Element : Node_Id; 3714 Ret_Type : constant Entity_Id := Etype (Subp); 3715 3716 begin 3717 if not Is_Overloadable (Subp) then 3718 Illegal_Indexing ("illegal indexing function for type&"); 3719 return; 3720 3721 elsif Scope (Subp) /= Scope (Ent) then 3722 if Nkind (Expr) = N_Expanded_Name then 3723 3724 -- Indexing function can't be declared elsewhere 3725 3726 Illegal_Indexing 3727 ("indexing function must be declared in scope of type&"); 3728 end if; 3729 3730 return; 3731 3732 elsif No (First_Formal (Subp)) then 3733 Illegal_Indexing 3734 ("Indexing requires a function that applies to type&"); 3735 return; 3736 3737 elsif No (Next_Formal (First_Formal (Subp))) then 3738 Illegal_Indexing 3739 ("indexing function must have at least two parameters"); 3740 return; 3741 3742 elsif Is_Derived_Type (Ent) then 3743 if (Attr = Name_Constant_Indexing 3744 and then Present 3745 (Find_Aspect (Etype (Ent), Aspect_Constant_Indexing))) 3746 or else 3747 (Attr = Name_Variable_Indexing 3748 and then Present 3749 (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing))) 3750 then 3751 if Debug_Flag_Dot_XX then 3752 null; 3753 3754 else 3755 Illegal_Indexing 3756 ("indexing function already inherited " 3757 & "from parent type"); 3758 return; 3759 end if; 3760 end if; 3761 end if; 3762 3763 if not Check_Primitive_Function (Subp) then 3764 Illegal_Indexing 3765 ("Indexing aspect requires a function that applies to type&"); 3766 return; 3767 end if; 3768 3769 -- If partial declaration exists, verify that it is not tagged. 3770 3771 if Ekind (Current_Scope) = E_Package 3772 and then Has_Private_Declaration (Ent) 3773 and then From_Aspect_Specification (N) 3774 and then 3775 List_Containing (Parent (Ent)) = 3776 Private_Declarations 3777 (Specification (Unit_Declaration_Node (Current_Scope))) 3778 and then Nkind (N) = N_Attribute_Definition_Clause 3779 then 3780 declare 3781 Decl : Node_Id; 3782 3783 begin 3784 Decl := 3785 First (Visible_Declarations 3786 (Specification 3787 (Unit_Declaration_Node (Current_Scope)))); 3788 3789 while Present (Decl) loop 3790 if Nkind (Decl) = N_Private_Type_Declaration 3791 and then Ent = Full_View (Defining_Identifier (Decl)) 3792 and then Tagged_Present (Decl) 3793 and then No (Aspect_Specifications (Decl)) 3794 then 3795 Illegal_Indexing 3796 ("Indexing aspect cannot be specified on full view " 3797 & "if partial view is tagged"); 3798 return; 3799 end if; 3800 3801 Next (Decl); 3802 end loop; 3803 end; 3804 end if; 3805 3806 -- An indexing function must return either the default element of 3807 -- the container, or a reference type. For variable indexing it 3808 -- must be the latter. 3809 3810 Default_Element := 3811 Find_Value_Of_Aspect 3812 (Etype (First_Formal (Subp)), Aspect_Iterator_Element); 3813 3814 if Present (Default_Element) then 3815 Analyze (Default_Element); 3816 3817 if Is_Entity_Name (Default_Element) 3818 and then not Covers (Entity (Default_Element), Ret_Type) 3819 and then False 3820 then 3821 Illegal_Indexing 3822 ("wrong return type for indexing function"); 3823 return; 3824 end if; 3825 end if; 3826 3827 -- For variable_indexing the return type must be a reference type 3828 3829 if Attr = Name_Variable_Indexing then 3830 if not Has_Implicit_Dereference (Ret_Type) then 3831 Illegal_Indexing 3832 ("variable indexing must return a reference type"); 3833 return; 3834 3835 elsif Is_Access_Constant 3836 (Etype (First_Discriminant (Ret_Type))) 3837 then 3838 Illegal_Indexing 3839 ("variable indexing must return an access to variable"); 3840 return; 3841 end if; 3842 3843 else 3844 if Has_Implicit_Dereference (Ret_Type) 3845 and then not 3846 Is_Access_Constant (Etype (First_Discriminant (Ret_Type))) 3847 then 3848 Illegal_Indexing 3849 ("constant indexing must return an access to constant"); 3850 return; 3851 3852 elsif Is_Access_Type (Etype (First_Formal (Subp))) 3853 and then not Is_Access_Constant (Etype (First_Formal (Subp))) 3854 then 3855 Illegal_Indexing 3856 ("constant indexing must apply to an access to constant"); 3857 return; 3858 end if; 3859 end if; 3860 3861 -- All checks succeeded. 3862 3863 Indexing_Found := True; 3864 end Check_One_Function; 3865 3866 ----------------------- 3867 -- Illegal_Indexing -- 3868 ----------------------- 3869 3870 procedure Illegal_Indexing (Msg : String) is 3871 begin 3872 Error_Msg_NE (Msg, N, Ent); 3873 end Illegal_Indexing; 3874 3875 -- Start of processing for Check_Indexing_Functions 3876 3877 begin 3878 if In_Instance then 3879 return; 3880 end if; 3881 3882 Analyze (Expr); 3883 3884 if not Is_Overloaded (Expr) then 3885 Check_One_Function (Entity (Expr)); 3886 3887 else 3888 declare 3889 I : Interp_Index; 3890 It : Interp; 3891 3892 begin 3893 Indexing_Found := False; 3894 Get_First_Interp (Expr, I, It); 3895 while Present (It.Nam) loop 3896 3897 -- Note that analysis will have added the interpretation 3898 -- that corresponds to the dereference. We only check the 3899 -- subprogram itself. 3900 3901 if Is_Overloadable (It.Nam) then 3902 Check_One_Function (It.Nam); 3903 end if; 3904 3905 Get_Next_Interp (I, It); 3906 end loop; 3907 end; 3908 end if; 3909 3910 if not Indexing_Found and then not Error_Posted (N) then 3911 Error_Msg_NE 3912 ("aspect Indexing requires a local function that " 3913 & "applies to type&", Expr, Ent); 3914 end if; 3915 end Check_Indexing_Functions; 3916 3917 ------------------------------ 3918 -- Check_Iterator_Functions -- 3919 ------------------------------ 3920 3921 procedure Check_Iterator_Functions is 3922 Default : Entity_Id; 3923 3924 function Valid_Default_Iterator (Subp : Entity_Id) return Boolean; 3925 -- Check one possible interpretation for validity 3926 3927 ---------------------------- 3928 -- Valid_Default_Iterator -- 3929 ---------------------------- 3930 3931 function Valid_Default_Iterator (Subp : Entity_Id) return Boolean is 3932 Formal : Entity_Id; 3933 3934 begin 3935 if not Check_Primitive_Function (Subp) then 3936 return False; 3937 else 3938 Formal := First_Formal (Subp); 3939 end if; 3940 3941 -- False if any subsequent formal has no default expression 3942 3943 Formal := Next_Formal (Formal); 3944 while Present (Formal) loop 3945 if No (Expression (Parent (Formal))) then 3946 return False; 3947 end if; 3948 3949 Next_Formal (Formal); 3950 end loop; 3951 3952 -- True if all subsequent formals have default expressions 3953 3954 return True; 3955 end Valid_Default_Iterator; 3956 3957 -- Start of processing for Check_Iterator_Functions 3958 3959 begin 3960 Analyze (Expr); 3961 3962 if not Is_Entity_Name (Expr) then 3963 Error_Msg_N ("aspect Iterator must be a function name", Expr); 3964 end if; 3965 3966 if not Is_Overloaded (Expr) then 3967 if not Check_Primitive_Function (Entity (Expr)) then 3968 Error_Msg_NE 3969 ("aspect Indexing requires a function that applies to type&", 3970 Entity (Expr), Ent); 3971 end if; 3972 3973 if not Valid_Default_Iterator (Entity (Expr)) then 3974 Error_Msg_N ("improper function for default iterator", Expr); 3975 end if; 3976 3977 else 3978 Default := Empty; 3979 declare 3980 I : Interp_Index; 3981 It : Interp; 3982 3983 begin 3984 Get_First_Interp (Expr, I, It); 3985 while Present (It.Nam) loop 3986 if not Check_Primitive_Function (It.Nam) 3987 or else not Valid_Default_Iterator (It.Nam) 3988 then 3989 Remove_Interp (I); 3990 3991 elsif Present (Default) then 3992 Error_Msg_N ("default iterator must be unique", Expr); 3993 3994 else 3995 Default := It.Nam; 3996 end if; 3997 3998 Get_Next_Interp (I, It); 3999 end loop; 4000 end; 4001 4002 if Present (Default) then 4003 Set_Entity (Expr, Default); 4004 Set_Is_Overloaded (Expr, False); 4005 end if; 4006 end if; 4007 end Check_Iterator_Functions; 4008 4009 ------------------------------- 4010 -- Check_Primitive_Function -- 4011 ------------------------------- 4012 4013 function Check_Primitive_Function (Subp : Entity_Id) return Boolean is 4014 Ctrl : Entity_Id; 4015 4016 begin 4017 if Ekind (Subp) /= E_Function then 4018 return False; 4019 end if; 4020 4021 if No (First_Formal (Subp)) then 4022 return False; 4023 else 4024 Ctrl := Etype (First_Formal (Subp)); 4025 end if; 4026 4027 -- Type of formal may be the class-wide type, an access to such, 4028 -- or an incomplete view. 4029 4030 if Ctrl = Ent 4031 or else Ctrl = Class_Wide_Type (Ent) 4032 or else 4033 (Ekind (Ctrl) = E_Anonymous_Access_Type 4034 and then (Designated_Type (Ctrl) = Ent 4035 or else 4036 Designated_Type (Ctrl) = Class_Wide_Type (Ent))) 4037 or else 4038 (Ekind (Ctrl) = E_Incomplete_Type 4039 and then Full_View (Ctrl) = Ent) 4040 then 4041 null; 4042 else 4043 return False; 4044 end if; 4045 4046 return True; 4047 end Check_Primitive_Function; 4048 4049 ---------------------- 4050 -- Duplicate_Clause -- 4051 ---------------------- 4052 4053 function Duplicate_Clause return Boolean is 4054 A : Node_Id; 4055 4056 begin 4057 -- Nothing to do if this attribute definition clause comes from 4058 -- an aspect specification, since we could not be duplicating an 4059 -- explicit clause, and we dealt with the case of duplicated aspects 4060 -- in Analyze_Aspect_Specifications. 4061 4062 if From_Aspect_Specification (N) then 4063 return False; 4064 end if; 4065 4066 -- Otherwise current clause may duplicate previous clause, or a 4067 -- previously given pragma or aspect specification for the same 4068 -- aspect. 4069 4070 A := Get_Rep_Item (U_Ent, Chars (N), Check_Parents => False); 4071 4072 if Present (A) then 4073 Error_Msg_Name_1 := Chars (N); 4074 Error_Msg_Sloc := Sloc (A); 4075 4076 Error_Msg_NE ("aspect% for & previously given#", N, U_Ent); 4077 return True; 4078 end if; 4079 4080 return False; 4081 end Duplicate_Clause; 4082 4083 -- Start of processing for Analyze_Attribute_Definition_Clause 4084 4085 begin 4086 -- The following code is a defense against recursion. Not clear that 4087 -- this can happen legitimately, but perhaps some error situations can 4088 -- cause it, and we did see this recursion during testing. 4089 4090 if Analyzed (N) then 4091 return; 4092 else 4093 Set_Analyzed (N, True); 4094 end if; 4095 4096 -- Ignore some selected attributes in CodePeer mode since they are not 4097 -- relevant in this context. 4098 4099 if CodePeer_Mode then 4100 case Id is 4101 4102 -- Ignore Component_Size in CodePeer mode, to avoid changing the 4103 -- internal representation of types by implicitly packing them. 4104 4105 when Attribute_Component_Size => 4106 Rewrite (N, Make_Null_Statement (Sloc (N))); 4107 return; 4108 4109 when others => 4110 null; 4111 end case; 4112 end if; 4113 4114 -- Process Ignore_Rep_Clauses option 4115 4116 if Ignore_Rep_Clauses then 4117 case Id is 4118 4119 -- The following should be ignored. They do not affect legality 4120 -- and may be target dependent. The basic idea of -gnatI is to 4121 -- ignore any rep clauses that may be target dependent but do not 4122 -- affect legality (except possibly to be rejected because they 4123 -- are incompatible with the compilation target). 4124 4125 when Attribute_Alignment | 4126 Attribute_Bit_Order | 4127 Attribute_Component_Size | 4128 Attribute_Machine_Radix | 4129 Attribute_Object_Size | 4130 Attribute_Size | 4131 Attribute_Small | 4132 Attribute_Stream_Size | 4133 Attribute_Value_Size => 4134 Kill_Rep_Clause (N); 4135 return; 4136 4137 -- The following should not be ignored, because in the first place 4138 -- they are reasonably portable, and should not cause problems 4139 -- in compiling code from another target, and also they do affect 4140 -- legality, e.g. failing to provide a stream attribute for a type 4141 -- may make a program illegal. 4142 4143 when Attribute_External_Tag | 4144 Attribute_Input | 4145 Attribute_Output | 4146 Attribute_Read | 4147 Attribute_Simple_Storage_Pool | 4148 Attribute_Storage_Pool | 4149 Attribute_Storage_Size | 4150 Attribute_Write => 4151 null; 4152 4153 -- We do not do anything here with address clauses, they will be 4154 -- removed by Freeze later on, but for now, it works better to 4155 -- keep then in the tree. 4156 4157 when Attribute_Address => 4158 null; 4159 4160 -- Other cases are errors ("attribute& cannot be set with 4161 -- definition clause"), which will be caught below. 4162 4163 when others => 4164 null; 4165 end case; 4166 end if; 4167 4168 Analyze (Nam); 4169 Ent := Entity (Nam); 4170 4171 if Rep_Item_Too_Early (Ent, N) then 4172 return; 4173 end if; 4174 4175 -- Rep clause applies to full view of incomplete type or private type if 4176 -- we have one (if not, this is a premature use of the type). However, 4177 -- certain semantic checks need to be done on the specified entity (i.e. 4178 -- the private view), so we save it in Ent. 4179 4180 if Is_Private_Type (Ent) 4181 and then Is_Derived_Type (Ent) 4182 and then not Is_Tagged_Type (Ent) 4183 and then No (Full_View (Ent)) 4184 then 4185 -- If this is a private type whose completion is a derivation from 4186 -- another private type, there is no full view, and the attribute 4187 -- belongs to the type itself, not its underlying parent. 4188 4189 U_Ent := Ent; 4190 4191 elsif Ekind (Ent) = E_Incomplete_Type then 4192 4193 -- The attribute applies to the full view, set the entity of the 4194 -- attribute definition accordingly. 4195 4196 Ent := Underlying_Type (Ent); 4197 U_Ent := Ent; 4198 Set_Entity (Nam, Ent); 4199 4200 else 4201 U_Ent := Underlying_Type (Ent); 4202 end if; 4203 4204 -- Avoid cascaded error 4205 4206 if Etype (Nam) = Any_Type then 4207 return; 4208 4209 -- Must be declared in current scope or in case of an aspect 4210 -- specification, must be visible in current scope. 4211 4212 elsif Scope (Ent) /= Current_Scope 4213 and then 4214 not (From_Aspect_Specification (N) 4215 and then Scope_Within_Or_Same (Current_Scope, Scope (Ent))) 4216 then 4217 Error_Msg_N ("entity must be declared in this scope", Nam); 4218 return; 4219 4220 -- Must not be a source renaming (we do have some cases where the 4221 -- expander generates a renaming, and those cases are OK, in such 4222 -- cases any attribute applies to the renamed object as well). 4223 4224 elsif Is_Object (Ent) 4225 and then Present (Renamed_Object (Ent)) 4226 then 4227 -- Case of renamed object from source, this is an error 4228 4229 if Comes_From_Source (Renamed_Object (Ent)) then 4230 Get_Name_String (Chars (N)); 4231 Error_Msg_Strlen := Name_Len; 4232 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); 4233 Error_Msg_N 4234 ("~ clause not allowed for a renaming declaration " 4235 & "(RM 13.1(6))", Nam); 4236 return; 4237 4238 -- For the case of a compiler generated renaming, the attribute 4239 -- definition clause applies to the renamed object created by the 4240 -- expander. The easiest general way to handle this is to create a 4241 -- copy of the attribute definition clause for this object. 4242 4243 elsif Is_Entity_Name (Renamed_Object (Ent)) then 4244 Insert_Action (N, 4245 Make_Attribute_Definition_Clause (Loc, 4246 Name => 4247 New_Occurrence_Of (Entity (Renamed_Object (Ent)), Loc), 4248 Chars => Chars (N), 4249 Expression => Duplicate_Subexpr (Expression (N)))); 4250 4251 -- If the renamed object is not an entity, it must be a dereference 4252 -- of an unconstrained function call, and we must introduce a new 4253 -- declaration to capture the expression. This is needed in the case 4254 -- of 'Alignment, where the original declaration must be rewritten. 4255 4256 else 4257 pragma Assert 4258 (Nkind (Renamed_Object (Ent)) = N_Explicit_Dereference); 4259 null; 4260 end if; 4261 4262 -- If no underlying entity, use entity itself, applies to some 4263 -- previously detected error cases ??? 4264 4265 elsif No (U_Ent) then 4266 U_Ent := Ent; 4267 4268 -- Cannot specify for a subtype (exception Object/Value_Size) 4269 4270 elsif Is_Type (U_Ent) 4271 and then not Is_First_Subtype (U_Ent) 4272 and then Id /= Attribute_Object_Size 4273 and then Id /= Attribute_Value_Size 4274 and then not From_At_Mod (N) 4275 then 4276 Error_Msg_N ("cannot specify attribute for subtype", Nam); 4277 return; 4278 end if; 4279 4280 Set_Entity (N, U_Ent); 4281 Check_Restriction_No_Use_Of_Attribute (N); 4282 4283 -- Switch on particular attribute 4284 4285 case Id is 4286 4287 ------------- 4288 -- Address -- 4289 ------------- 4290 4291 -- Address attribute definition clause 4292 4293 when Attribute_Address => Address : begin 4294 4295 -- A little error check, catch for X'Address use X'Address; 4296 4297 if Nkind (Nam) = N_Identifier 4298 and then Nkind (Expr) = N_Attribute_Reference 4299 and then Attribute_Name (Expr) = Name_Address 4300 and then Nkind (Prefix (Expr)) = N_Identifier 4301 and then Chars (Nam) = Chars (Prefix (Expr)) 4302 then 4303 Error_Msg_NE 4304 ("address for & is self-referencing", Prefix (Expr), Ent); 4305 return; 4306 end if; 4307 4308 -- Not that special case, carry on with analysis of expression 4309 4310 Analyze_And_Resolve (Expr, RTE (RE_Address)); 4311 4312 -- Even when ignoring rep clauses we need to indicate that the 4313 -- entity has an address clause and thus it is legal to declare 4314 -- it imported. Freeze will get rid of the address clause later. 4315 4316 if Ignore_Rep_Clauses then 4317 if Ekind_In (U_Ent, E_Variable, E_Constant) then 4318 Record_Rep_Item (U_Ent, N); 4319 end if; 4320 4321 return; 4322 end if; 4323 4324 if Duplicate_Clause then 4325 null; 4326 4327 -- Case of address clause for subprogram 4328 4329 elsif Is_Subprogram (U_Ent) then 4330 if Has_Homonym (U_Ent) then 4331 Error_Msg_N 4332 ("address clause cannot be given " & 4333 "for overloaded subprogram", 4334 Nam); 4335 return; 4336 end if; 4337 4338 -- For subprograms, all address clauses are permitted, and we 4339 -- mark the subprogram as having a deferred freeze so that Gigi 4340 -- will not elaborate it too soon. 4341 4342 -- Above needs more comments, what is too soon about??? 4343 4344 Set_Has_Delayed_Freeze (U_Ent); 4345 4346 -- Case of address clause for entry 4347 4348 elsif Ekind (U_Ent) = E_Entry then 4349 if Nkind (Parent (N)) = N_Task_Body then 4350 Error_Msg_N 4351 ("entry address must be specified in task spec", Nam); 4352 return; 4353 end if; 4354 4355 -- For entries, we require a constant address 4356 4357 Check_Constant_Address_Clause (Expr, U_Ent); 4358 4359 -- Special checks for task types 4360 4361 if Is_Task_Type (Scope (U_Ent)) 4362 and then Comes_From_Source (Scope (U_Ent)) 4363 then 4364 Error_Msg_N 4365 ("??entry address declared for entry in task type", N); 4366 Error_Msg_N 4367 ("\??only one task can be declared of this type", N); 4368 end if; 4369 4370 -- Entry address clauses are obsolescent 4371 4372 Check_Restriction (No_Obsolescent_Features, N); 4373 4374 if Warn_On_Obsolescent_Feature then 4375 Error_Msg_N 4376 ("?j?attaching interrupt to task entry is an " & 4377 "obsolescent feature (RM J.7.1)", N); 4378 Error_Msg_N 4379 ("\?j?use interrupt procedure instead", N); 4380 end if; 4381 4382 -- Case of an address clause for a controlled object which we 4383 -- consider to be erroneous. 4384 4385 elsif Is_Controlled (Etype (U_Ent)) 4386 or else Has_Controlled_Component (Etype (U_Ent)) 4387 then 4388 Error_Msg_NE 4389 ("??controlled object& must not be overlaid", Nam, U_Ent); 4390 Error_Msg_N 4391 ("\??Program_Error will be raised at run time", Nam); 4392 Insert_Action (Declaration_Node (U_Ent), 4393 Make_Raise_Program_Error (Loc, 4394 Reason => PE_Overlaid_Controlled_Object)); 4395 return; 4396 4397 -- Case of address clause for a (non-controlled) object 4398 4399 elsif Ekind_In (U_Ent, E_Variable, E_Constant) then 4400 declare 4401 Expr : constant Node_Id := Expression (N); 4402 O_Ent : Entity_Id; 4403 Off : Boolean; 4404 4405 begin 4406 -- Exported variables cannot have an address clause, because 4407 -- this cancels the effect of the pragma Export. 4408 4409 if Is_Exported (U_Ent) then 4410 Error_Msg_N 4411 ("cannot export object with address clause", Nam); 4412 return; 4413 end if; 4414 4415 Find_Overlaid_Entity (N, O_Ent, Off); 4416 4417 -- Overlaying controlled objects is erroneous 4418 4419 if Present (O_Ent) 4420 and then (Has_Controlled_Component (Etype (O_Ent)) 4421 or else Is_Controlled (Etype (O_Ent))) 4422 then 4423 Error_Msg_N 4424 ("??cannot overlay with controlled object", Expr); 4425 Error_Msg_N 4426 ("\??Program_Error will be raised at run time", Expr); 4427 Insert_Action (Declaration_Node (U_Ent), 4428 Make_Raise_Program_Error (Loc, 4429 Reason => PE_Overlaid_Controlled_Object)); 4430 return; 4431 4432 elsif Present (O_Ent) 4433 and then Ekind (U_Ent) = E_Constant 4434 and then not Is_Constant_Object (O_Ent) 4435 then 4436 Error_Msg_N ("??constant overlays a variable", Expr); 4437 4438 -- Imported variables can have an address clause, but then 4439 -- the import is pretty meaningless except to suppress 4440 -- initializations, so we do not need such variables to 4441 -- be statically allocated (and in fact it causes trouble 4442 -- if the address clause is a local value). 4443 4444 elsif Is_Imported (U_Ent) then 4445 Set_Is_Statically_Allocated (U_Ent, False); 4446 end if; 4447 4448 -- We mark a possible modification of a variable with an 4449 -- address clause, since it is likely aliasing is occurring. 4450 4451 Note_Possible_Modification (Nam, Sure => False); 4452 4453 -- Here we are checking for explicit overlap of one variable 4454 -- by another, and if we find this then mark the overlapped 4455 -- variable as also being volatile to prevent unwanted 4456 -- optimizations. This is a significant pessimization so 4457 -- avoid it when there is an offset, i.e. when the object 4458 -- is composite; they cannot be optimized easily anyway. 4459 4460 if Present (O_Ent) 4461 and then Is_Object (O_Ent) 4462 and then not Off 4463 4464 -- The following test is an expedient solution to what 4465 -- is really a problem in CodePeer. Suppressing the 4466 -- Set_Treat_As_Volatile call here prevents later 4467 -- generation (in some cases) of trees that CodePeer 4468 -- should, but currently does not, handle correctly. 4469 -- This test should probably be removed when CodePeer 4470 -- is improved, just because we want the tree CodePeer 4471 -- analyzes to match the tree for which we generate code 4472 -- as closely as is practical. ??? 4473 4474 and then not CodePeer_Mode 4475 then 4476 -- ??? O_Ent might not be in current unit 4477 4478 Set_Treat_As_Volatile (O_Ent); 4479 end if; 4480 4481 -- Legality checks on the address clause for initialized 4482 -- objects is deferred until the freeze point, because 4483 -- a subsequent pragma might indicate that the object 4484 -- is imported and thus not initialized. Also, the address 4485 -- clause might involve entities that have yet to be 4486 -- elaborated. 4487 4488 Set_Has_Delayed_Freeze (U_Ent); 4489 4490 -- If an initialization call has been generated for this 4491 -- object, it needs to be deferred to after the freeze node 4492 -- we have just now added, otherwise GIGI will see a 4493 -- reference to the variable (as actual to the IP call) 4494 -- before its definition. 4495 4496 declare 4497 Init_Call : constant Node_Id := 4498 Remove_Init_Call (U_Ent, N); 4499 4500 begin 4501 if Present (Init_Call) then 4502 Append_Freeze_Action (U_Ent, Init_Call); 4503 4504 -- Reset Initialization_Statements pointer so that 4505 -- if there is a pragma Import further down, it can 4506 -- clear any default initialization. 4507 4508 Set_Initialization_Statements (U_Ent, Init_Call); 4509 end if; 4510 end; 4511 4512 if Is_Exported (U_Ent) then 4513 Error_Msg_N 4514 ("& cannot be exported if an address clause is given", 4515 Nam); 4516 Error_Msg_N 4517 ("\define and export a variable " 4518 & "that holds its address instead", Nam); 4519 end if; 4520 4521 -- Entity has delayed freeze, so we will generate an 4522 -- alignment check at the freeze point unless suppressed. 4523 4524 if not Range_Checks_Suppressed (U_Ent) 4525 and then not Alignment_Checks_Suppressed (U_Ent) 4526 then 4527 Set_Check_Address_Alignment (N); 4528 end if; 4529 4530 -- Kill the size check code, since we are not allocating 4531 -- the variable, it is somewhere else. 4532 4533 Kill_Size_Check_Code (U_Ent); 4534 4535 -- If the address clause is of the form: 4536 4537 -- for Y'Address use X'Address 4538 4539 -- or 4540 4541 -- Const : constant Address := X'Address; 4542 -- ... 4543 -- for Y'Address use Const; 4544 4545 -- then we make an entry in the table for checking the size 4546 -- and alignment of the overlaying variable. We defer this 4547 -- check till after code generation to take full advantage 4548 -- of the annotation done by the back end. 4549 4550 -- If the entity has a generic type, the check will be 4551 -- performed in the instance if the actual type justifies 4552 -- it, and we do not insert the clause in the table to 4553 -- prevent spurious warnings. 4554 4555 -- Note: we used to test Comes_From_Source and only give 4556 -- this warning for source entities, but we have removed 4557 -- this test. It really seems bogus to generate overlays 4558 -- that would trigger this warning in generated code. 4559 -- Furthermore, by removing the test, we handle the 4560 -- aspect case properly. 4561 4562 if Address_Clause_Overlay_Warnings 4563 and then Present (O_Ent) 4564 and then Is_Object (O_Ent) 4565 then 4566 if not Is_Generic_Type (Etype (U_Ent)) then 4567 Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off)); 4568 end if; 4569 4570 -- If variable overlays a constant view, and we are 4571 -- warning on overlays, then mark the variable as 4572 -- overlaying a constant (we will give warnings later 4573 -- if this variable is assigned). 4574 4575 if Is_Constant_Object (O_Ent) 4576 and then Ekind (U_Ent) = E_Variable 4577 then 4578 Set_Overlays_Constant (U_Ent); 4579 end if; 4580 end if; 4581 end; 4582 4583 -- Not a valid entity for an address clause 4584 4585 else 4586 Error_Msg_N ("address cannot be given for &", Nam); 4587 end if; 4588 end Address; 4589 4590 --------------- 4591 -- Alignment -- 4592 --------------- 4593 4594 -- Alignment attribute definition clause 4595 4596 when Attribute_Alignment => Alignment : declare 4597 Align : constant Uint := Get_Alignment_Value (Expr); 4598 Max_Align : constant Uint := UI_From_Int (Maximum_Alignment); 4599 4600 begin 4601 FOnly := True; 4602 4603 if not Is_Type (U_Ent) 4604 and then Ekind (U_Ent) /= E_Variable 4605 and then Ekind (U_Ent) /= E_Constant 4606 then 4607 Error_Msg_N ("alignment cannot be given for &", Nam); 4608 4609 elsif Duplicate_Clause then 4610 null; 4611 4612 elsif Align /= No_Uint then 4613 Set_Has_Alignment_Clause (U_Ent); 4614 4615 -- Tagged type case, check for attempt to set alignment to a 4616 -- value greater than Max_Align, and reset if so. 4617 4618 if Is_Tagged_Type (U_Ent) and then Align > Max_Align then 4619 Error_Msg_N 4620 ("alignment for & set to Maximum_Aligment??", Nam); 4621 Set_Alignment (U_Ent, Max_Align); 4622 4623 -- All other cases 4624 4625 else 4626 Set_Alignment (U_Ent, Align); 4627 end if; 4628 4629 -- For an array type, U_Ent is the first subtype. In that case, 4630 -- also set the alignment of the anonymous base type so that 4631 -- other subtypes (such as the itypes for aggregates of the 4632 -- type) also receive the expected alignment. 4633 4634 if Is_Array_Type (U_Ent) then 4635 Set_Alignment (Base_Type (U_Ent), Align); 4636 end if; 4637 end if; 4638 end Alignment; 4639 4640 --------------- 4641 -- Bit_Order -- 4642 --------------- 4643 4644 -- Bit_Order attribute definition clause 4645 4646 when Attribute_Bit_Order => Bit_Order : declare 4647 begin 4648 if not Is_Record_Type (U_Ent) then 4649 Error_Msg_N 4650 ("Bit_Order can only be defined for record type", Nam); 4651 4652 elsif Duplicate_Clause then 4653 null; 4654 4655 else 4656 Analyze_And_Resolve (Expr, RTE (RE_Bit_Order)); 4657 4658 if Etype (Expr) = Any_Type then 4659 return; 4660 4661 elsif not Is_OK_Static_Expression (Expr) then 4662 Flag_Non_Static_Expr 4663 ("Bit_Order requires static expression!", Expr); 4664 4665 else 4666 if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then 4667 Set_Reverse_Bit_Order (Base_Type (U_Ent), True); 4668 end if; 4669 end if; 4670 end if; 4671 end Bit_Order; 4672 4673 -------------------- 4674 -- Component_Size -- 4675 -------------------- 4676 4677 -- Component_Size attribute definition clause 4678 4679 when Attribute_Component_Size => Component_Size_Case : declare 4680 Csize : constant Uint := Static_Integer (Expr); 4681 Ctyp : Entity_Id; 4682 Btype : Entity_Id; 4683 Biased : Boolean; 4684 New_Ctyp : Entity_Id; 4685 Decl : Node_Id; 4686 4687 begin 4688 if not Is_Array_Type (U_Ent) then 4689 Error_Msg_N ("component size requires array type", Nam); 4690 return; 4691 end if; 4692 4693 Btype := Base_Type (U_Ent); 4694 Ctyp := Component_Type (Btype); 4695 4696 if Duplicate_Clause then 4697 null; 4698 4699 elsif Rep_Item_Too_Early (Btype, N) then 4700 null; 4701 4702 elsif Csize /= No_Uint then 4703 Check_Size (Expr, Ctyp, Csize, Biased); 4704 4705 -- For the biased case, build a declaration for a subtype that 4706 -- will be used to represent the biased subtype that reflects 4707 -- the biased representation of components. We need the subtype 4708 -- to get proper conversions on referencing elements of the 4709 -- array. Note: component size clauses are ignored in VM mode. 4710 4711 if VM_Target = No_VM then 4712 if Biased then 4713 New_Ctyp := 4714 Make_Defining_Identifier (Loc, 4715 Chars => 4716 New_External_Name (Chars (U_Ent), 'C', 0, 'T')); 4717 4718 Decl := 4719 Make_Subtype_Declaration (Loc, 4720 Defining_Identifier => New_Ctyp, 4721 Subtype_Indication => 4722 New_Occurrence_Of (Component_Type (Btype), Loc)); 4723 4724 Set_Parent (Decl, N); 4725 Analyze (Decl, Suppress => All_Checks); 4726 4727 Set_Has_Delayed_Freeze (New_Ctyp, False); 4728 Set_Esize (New_Ctyp, Csize); 4729 Set_RM_Size (New_Ctyp, Csize); 4730 Init_Alignment (New_Ctyp); 4731 Set_Is_Itype (New_Ctyp, True); 4732 Set_Associated_Node_For_Itype (New_Ctyp, U_Ent); 4733 4734 Set_Component_Type (Btype, New_Ctyp); 4735 Set_Biased (New_Ctyp, N, "component size clause"); 4736 end if; 4737 4738 Set_Component_Size (Btype, Csize); 4739 4740 -- For VM case, we ignore component size clauses 4741 4742 else 4743 -- Give a warning unless we are in GNAT mode, in which case 4744 -- the warning is suppressed since it is not useful. 4745 4746 if not GNAT_Mode then 4747 Error_Msg_N 4748 ("component size ignored in this configuration??", N); 4749 end if; 4750 end if; 4751 4752 -- Deal with warning on overridden size 4753 4754 if Warn_On_Overridden_Size 4755 and then Has_Size_Clause (Ctyp) 4756 and then RM_Size (Ctyp) /= Csize 4757 then 4758 Error_Msg_NE 4759 ("component size overrides size clause for&?S?", N, Ctyp); 4760 end if; 4761 4762 Set_Has_Component_Size_Clause (Btype, True); 4763 Set_Has_Non_Standard_Rep (Btype, True); 4764 end if; 4765 end Component_Size_Case; 4766 4767 ----------------------- 4768 -- Constant_Indexing -- 4769 ----------------------- 4770 4771 when Attribute_Constant_Indexing => 4772 Check_Indexing_Functions; 4773 4774 --------- 4775 -- CPU -- 4776 --------- 4777 4778 when Attribute_CPU => CPU : 4779 begin 4780 -- CPU attribute definition clause not allowed except from aspect 4781 -- specification. 4782 4783 if From_Aspect_Specification (N) then 4784 if not Is_Task_Type (U_Ent) then 4785 Error_Msg_N ("CPU can only be defined for task", Nam); 4786 4787 elsif Duplicate_Clause then 4788 null; 4789 4790 else 4791 -- The expression must be analyzed in the special manner 4792 -- described in "Handling of Default and Per-Object 4793 -- Expressions" in sem.ads. 4794 4795 -- The visibility to the discriminants must be restored 4796 4797 Push_Scope_And_Install_Discriminants (U_Ent); 4798 Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range)); 4799 Uninstall_Discriminants_And_Pop_Scope (U_Ent); 4800 4801 if not Is_OK_Static_Expression (Expr) then 4802 Check_Restriction (Static_Priorities, Expr); 4803 end if; 4804 end if; 4805 4806 else 4807 Error_Msg_N 4808 ("attribute& cannot be set with definition clause", N); 4809 end if; 4810 end CPU; 4811 4812 ---------------------- 4813 -- Default_Iterator -- 4814 ---------------------- 4815 4816 when Attribute_Default_Iterator => Default_Iterator : declare 4817 Func : Entity_Id; 4818 Typ : Entity_Id; 4819 4820 begin 4821 if not Is_Tagged_Type (U_Ent) then 4822 Error_Msg_N 4823 ("aspect Default_Iterator applies to tagged type", Nam); 4824 end if; 4825 4826 Check_Iterator_Functions; 4827 4828 Analyze (Expr); 4829 4830 if not Is_Entity_Name (Expr) 4831 or else Ekind (Entity (Expr)) /= E_Function 4832 then 4833 Error_Msg_N ("aspect Iterator must be a function", Expr); 4834 else 4835 Func := Entity (Expr); 4836 end if; 4837 4838 -- The type of the first parameter must be T, T'class, or a 4839 -- corresponding access type (5.5.1 (8/3) 4840 4841 if No (First_Formal (Func)) then 4842 Typ := Empty; 4843 else 4844 Typ := Etype (First_Formal (Func)); 4845 end if; 4846 4847 if Typ = U_Ent 4848 or else Typ = Class_Wide_Type (U_Ent) 4849 or else (Is_Access_Type (Typ) 4850 and then Designated_Type (Typ) = U_Ent) 4851 or else (Is_Access_Type (Typ) 4852 and then Designated_Type (Typ) = 4853 Class_Wide_Type (U_Ent)) 4854 then 4855 null; 4856 4857 else 4858 Error_Msg_NE 4859 ("Default Iterator must be a primitive of&", Func, U_Ent); 4860 end if; 4861 end Default_Iterator; 4862 4863 ------------------------ 4864 -- Dispatching_Domain -- 4865 ------------------------ 4866 4867 when Attribute_Dispatching_Domain => Dispatching_Domain : 4868 begin 4869 -- Dispatching_Domain attribute definition clause not allowed 4870 -- except from aspect specification. 4871 4872 if From_Aspect_Specification (N) then 4873 if not Is_Task_Type (U_Ent) then 4874 Error_Msg_N 4875 ("Dispatching_Domain can only be defined for task", Nam); 4876 4877 elsif Duplicate_Clause then 4878 null; 4879 4880 else 4881 -- The expression must be analyzed in the special manner 4882 -- described in "Handling of Default and Per-Object 4883 -- Expressions" in sem.ads. 4884 4885 -- The visibility to the discriminants must be restored 4886 4887 Push_Scope_And_Install_Discriminants (U_Ent); 4888 4889 Preanalyze_Spec_Expression 4890 (Expr, RTE (RE_Dispatching_Domain)); 4891 4892 Uninstall_Discriminants_And_Pop_Scope (U_Ent); 4893 end if; 4894 4895 else 4896 Error_Msg_N 4897 ("attribute& cannot be set with definition clause", N); 4898 end if; 4899 end Dispatching_Domain; 4900 4901 ------------------ 4902 -- External_Tag -- 4903 ------------------ 4904 4905 when Attribute_External_Tag => External_Tag : 4906 begin 4907 if not Is_Tagged_Type (U_Ent) then 4908 Error_Msg_N ("should be a tagged type", Nam); 4909 end if; 4910 4911 if Duplicate_Clause then 4912 null; 4913 4914 else 4915 Analyze_And_Resolve (Expr, Standard_String); 4916 4917 if not Is_OK_Static_Expression (Expr) then 4918 Flag_Non_Static_Expr 4919 ("static string required for tag name!", Nam); 4920 end if; 4921 4922 if VM_Target /= No_VM then 4923 Error_Msg_Name_1 := Attr; 4924 Error_Msg_N 4925 ("% attribute unsupported in this configuration", Nam); 4926 end if; 4927 4928 if not Is_Library_Level_Entity (U_Ent) then 4929 Error_Msg_NE 4930 ("??non-unique external tag supplied for &", N, U_Ent); 4931 Error_Msg_N 4932 ("\??same external tag applies to all " 4933 & "subprogram calls", N); 4934 Error_Msg_N 4935 ("\??corresponding internal tag cannot be obtained", N); 4936 end if; 4937 end if; 4938 end External_Tag; 4939 4940 -------------------------- 4941 -- Implicit_Dereference -- 4942 -------------------------- 4943 4944 when Attribute_Implicit_Dereference => 4945 4946 -- Legality checks already performed at the point of the type 4947 -- declaration, aspect is not delayed. 4948 4949 null; 4950 4951 ----------- 4952 -- Input -- 4953 ----------- 4954 4955 when Attribute_Input => 4956 Analyze_Stream_TSS_Definition (TSS_Stream_Input); 4957 Set_Has_Specified_Stream_Input (Ent); 4958 4959 ------------------------ 4960 -- Interrupt_Priority -- 4961 ------------------------ 4962 4963 when Attribute_Interrupt_Priority => Interrupt_Priority : 4964 begin 4965 -- Interrupt_Priority attribute definition clause not allowed 4966 -- except from aspect specification. 4967 4968 if From_Aspect_Specification (N) then 4969 if not Is_Concurrent_Type (U_Ent) then 4970 Error_Msg_N 4971 ("Interrupt_Priority can only be defined for task " 4972 & "and protected object", Nam); 4973 4974 elsif Duplicate_Clause then 4975 null; 4976 4977 else 4978 -- The expression must be analyzed in the special manner 4979 -- described in "Handling of Default and Per-Object 4980 -- Expressions" in sem.ads. 4981 4982 -- The visibility to the discriminants must be restored 4983 4984 Push_Scope_And_Install_Discriminants (U_Ent); 4985 4986 Preanalyze_Spec_Expression 4987 (Expr, RTE (RE_Interrupt_Priority)); 4988 4989 Uninstall_Discriminants_And_Pop_Scope (U_Ent); 4990 end if; 4991 4992 else 4993 Error_Msg_N 4994 ("attribute& cannot be set with definition clause", N); 4995 end if; 4996 end Interrupt_Priority; 4997 4998 -------------- 4999 -- Iterable -- 5000 -------------- 5001 5002 when Attribute_Iterable => 5003 Analyze (Expr); 5004 5005 if Nkind (Expr) /= N_Aggregate then 5006 Error_Msg_N ("aspect Iterable must be an aggregate", Expr); 5007 end if; 5008 5009 declare 5010 Assoc : Node_Id; 5011 5012 begin 5013 Assoc := First (Component_Associations (Expr)); 5014 while Present (Assoc) loop 5015 if not Is_Entity_Name (Expression (Assoc)) then 5016 Error_Msg_N ("value must be a function", Assoc); 5017 end if; 5018 5019 Next (Assoc); 5020 end loop; 5021 end; 5022 5023 ---------------------- 5024 -- Iterator_Element -- 5025 ---------------------- 5026 5027 when Attribute_Iterator_Element => 5028 Analyze (Expr); 5029 5030 if not Is_Entity_Name (Expr) 5031 or else not Is_Type (Entity (Expr)) 5032 then 5033 Error_Msg_N ("aspect Iterator_Element must be a type", Expr); 5034 end if; 5035 5036 ------------------- 5037 -- Machine_Radix -- 5038 ------------------- 5039 5040 -- Machine radix attribute definition clause 5041 5042 when Attribute_Machine_Radix => Machine_Radix : declare 5043 Radix : constant Uint := Static_Integer (Expr); 5044 5045 begin 5046 if not Is_Decimal_Fixed_Point_Type (U_Ent) then 5047 Error_Msg_N ("decimal fixed-point type expected for &", Nam); 5048 5049 elsif Duplicate_Clause then 5050 null; 5051 5052 elsif Radix /= No_Uint then 5053 Set_Has_Machine_Radix_Clause (U_Ent); 5054 Set_Has_Non_Standard_Rep (Base_Type (U_Ent)); 5055 5056 if Radix = 2 then 5057 null; 5058 elsif Radix = 10 then 5059 Set_Machine_Radix_10 (U_Ent); 5060 else 5061 Error_Msg_N ("machine radix value must be 2 or 10", Expr); 5062 end if; 5063 end if; 5064 end Machine_Radix; 5065 5066 ----------------- 5067 -- Object_Size -- 5068 ----------------- 5069 5070 -- Object_Size attribute definition clause 5071 5072 when Attribute_Object_Size => Object_Size : declare 5073 Size : constant Uint := Static_Integer (Expr); 5074 5075 Biased : Boolean; 5076 pragma Warnings (Off, Biased); 5077 5078 begin 5079 if not Is_Type (U_Ent) then 5080 Error_Msg_N ("Object_Size cannot be given for &", Nam); 5081 5082 elsif Duplicate_Clause then 5083 null; 5084 5085 else 5086 Check_Size (Expr, U_Ent, Size, Biased); 5087 5088 if Is_Scalar_Type (U_Ent) then 5089 if Size /= 8 and then Size /= 16 and then Size /= 32 5090 and then UI_Mod (Size, 64) /= 0 5091 then 5092 Error_Msg_N 5093 ("Object_Size must be 8, 16, 32, or multiple of 64", 5094 Expr); 5095 end if; 5096 5097 elsif Size mod 8 /= 0 then 5098 Error_Msg_N ("Object_Size must be a multiple of 8", Expr); 5099 end if; 5100 5101 Set_Esize (U_Ent, Size); 5102 Set_Has_Object_Size_Clause (U_Ent); 5103 Alignment_Check_For_Size_Change (U_Ent, Size); 5104 end if; 5105 end Object_Size; 5106 5107 ------------ 5108 -- Output -- 5109 ------------ 5110 5111 when Attribute_Output => 5112 Analyze_Stream_TSS_Definition (TSS_Stream_Output); 5113 Set_Has_Specified_Stream_Output (Ent); 5114 5115 -------------- 5116 -- Priority -- 5117 -------------- 5118 5119 when Attribute_Priority => Priority : 5120 begin 5121 -- Priority attribute definition clause not allowed except from 5122 -- aspect specification. 5123 5124 if From_Aspect_Specification (N) then 5125 if not (Is_Concurrent_Type (U_Ent) 5126 or else Ekind (U_Ent) = E_Procedure) 5127 then 5128 Error_Msg_N 5129 ("Priority can only be defined for task and protected " 5130 & "object", Nam); 5131 5132 elsif Duplicate_Clause then 5133 null; 5134 5135 else 5136 -- The expression must be analyzed in the special manner 5137 -- described in "Handling of Default and Per-Object 5138 -- Expressions" in sem.ads. 5139 5140 -- The visibility to the discriminants must be restored 5141 5142 Push_Scope_And_Install_Discriminants (U_Ent); 5143 Preanalyze_Spec_Expression (Expr, Standard_Integer); 5144 Uninstall_Discriminants_And_Pop_Scope (U_Ent); 5145 5146 if not Is_OK_Static_Expression (Expr) then 5147 Check_Restriction (Static_Priorities, Expr); 5148 end if; 5149 end if; 5150 5151 else 5152 Error_Msg_N 5153 ("attribute& cannot be set with definition clause", N); 5154 end if; 5155 end Priority; 5156 5157 ---------- 5158 -- Read -- 5159 ---------- 5160 5161 when Attribute_Read => 5162 Analyze_Stream_TSS_Definition (TSS_Stream_Read); 5163 Set_Has_Specified_Stream_Read (Ent); 5164 5165 -------------------------- 5166 -- Scalar_Storage_Order -- 5167 -------------------------- 5168 5169 -- Scalar_Storage_Order attribute definition clause 5170 5171 when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : declare 5172 begin 5173 if not (Is_Record_Type (U_Ent) or else Is_Array_Type (U_Ent)) then 5174 Error_Msg_N 5175 ("Scalar_Storage_Order can only be defined for " 5176 & "record or array type", Nam); 5177 5178 elsif Duplicate_Clause then 5179 null; 5180 5181 else 5182 Analyze_And_Resolve (Expr, RTE (RE_Bit_Order)); 5183 5184 if Etype (Expr) = Any_Type then 5185 return; 5186 5187 elsif not Is_OK_Static_Expression (Expr) then 5188 Flag_Non_Static_Expr 5189 ("Scalar_Storage_Order requires static expression!", Expr); 5190 5191 elsif (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then 5192 5193 -- Here for the case of a non-default (i.e. non-confirming) 5194 -- Scalar_Storage_Order attribute definition. 5195 5196 if Support_Nondefault_SSO_On_Target then 5197 Set_Reverse_Storage_Order (Base_Type (U_Ent), True); 5198 else 5199 Error_Msg_N 5200 ("non-default Scalar_Storage_Order " 5201 & "not supported on target", Expr); 5202 end if; 5203 end if; 5204 5205 -- Clear SSO default indications since explicit setting of the 5206 -- order overrides the defaults. 5207 5208 Set_SSO_Set_Low_By_Default (Base_Type (U_Ent), False); 5209 Set_SSO_Set_High_By_Default (Base_Type (U_Ent), False); 5210 end if; 5211 end Scalar_Storage_Order; 5212 5213 ---------- 5214 -- Size -- 5215 ---------- 5216 5217 -- Size attribute definition clause 5218 5219 when Attribute_Size => Size : declare 5220 Size : constant Uint := Static_Integer (Expr); 5221 Etyp : Entity_Id; 5222 Biased : Boolean; 5223 5224 begin 5225 FOnly := True; 5226 5227 if Duplicate_Clause then 5228 null; 5229 5230 elsif not Is_Type (U_Ent) 5231 and then Ekind (U_Ent) /= E_Variable 5232 and then Ekind (U_Ent) /= E_Constant 5233 then 5234 Error_Msg_N ("size cannot be given for &", Nam); 5235 5236 elsif Is_Array_Type (U_Ent) 5237 and then not Is_Constrained (U_Ent) 5238 then 5239 Error_Msg_N 5240 ("size cannot be given for unconstrained array", Nam); 5241 5242 elsif Size /= No_Uint then 5243 if VM_Target /= No_VM and then not GNAT_Mode then 5244 5245 -- Size clause is not handled properly on VM targets. 5246 -- Display a warning unless we are in GNAT mode, in which 5247 -- case this is useless. 5248 5249 Error_Msg_N 5250 ("size clauses are ignored in this configuration??", N); 5251 end if; 5252 5253 if Is_Type (U_Ent) then 5254 Etyp := U_Ent; 5255 else 5256 Etyp := Etype (U_Ent); 5257 end if; 5258 5259 -- Check size, note that Gigi is in charge of checking that the 5260 -- size of an array or record type is OK. Also we do not check 5261 -- the size in the ordinary fixed-point case, since it is too 5262 -- early to do so (there may be subsequent small clause that 5263 -- affects the size). We can check the size if a small clause 5264 -- has already been given. 5265 5266 if not Is_Ordinary_Fixed_Point_Type (U_Ent) 5267 or else Has_Small_Clause (U_Ent) 5268 then 5269 Check_Size (Expr, Etyp, Size, Biased); 5270 Set_Biased (U_Ent, N, "size clause", Biased); 5271 end if; 5272 5273 -- For types set RM_Size and Esize if possible 5274 5275 if Is_Type (U_Ent) then 5276 Set_RM_Size (U_Ent, Size); 5277 5278 -- For elementary types, increase Object_Size to power of 2, 5279 -- but not less than a storage unit in any case (normally 5280 -- this means it will be byte addressable). 5281 5282 -- For all other types, nothing else to do, we leave Esize 5283 -- (object size) unset, the back end will set it from the 5284 -- size and alignment in an appropriate manner. 5285 5286 -- In both cases, we check whether the alignment must be 5287 -- reset in the wake of the size change. 5288 5289 if Is_Elementary_Type (U_Ent) then 5290 if Size <= System_Storage_Unit then 5291 Init_Esize (U_Ent, System_Storage_Unit); 5292 elsif Size <= 16 then 5293 Init_Esize (U_Ent, 16); 5294 elsif Size <= 32 then 5295 Init_Esize (U_Ent, 32); 5296 else 5297 Set_Esize (U_Ent, (Size + 63) / 64 * 64); 5298 end if; 5299 5300 Alignment_Check_For_Size_Change (U_Ent, Esize (U_Ent)); 5301 else 5302 Alignment_Check_For_Size_Change (U_Ent, Size); 5303 end if; 5304 5305 -- For objects, set Esize only 5306 5307 else 5308 if Is_Elementary_Type (Etyp) then 5309 if Size /= System_Storage_Unit 5310 and then 5311 Size /= System_Storage_Unit * 2 5312 and then 5313 Size /= System_Storage_Unit * 4 5314 and then 5315 Size /= System_Storage_Unit * 8 5316 then 5317 Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); 5318 Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8; 5319 Error_Msg_N 5320 ("size for primitive object must be a power of 2" 5321 & " in the range ^-^", N); 5322 end if; 5323 end if; 5324 5325 Set_Esize (U_Ent, Size); 5326 end if; 5327 5328 Set_Has_Size_Clause (U_Ent); 5329 end if; 5330 end Size; 5331 5332 ----------- 5333 -- Small -- 5334 ----------- 5335 5336 -- Small attribute definition clause 5337 5338 when Attribute_Small => Small : declare 5339 Implicit_Base : constant Entity_Id := Base_Type (U_Ent); 5340 Small : Ureal; 5341 5342 begin 5343 Analyze_And_Resolve (Expr, Any_Real); 5344 5345 if Etype (Expr) = Any_Type then 5346 return; 5347 5348 elsif not Is_OK_Static_Expression (Expr) then 5349 Flag_Non_Static_Expr 5350 ("small requires static expression!", Expr); 5351 return; 5352 5353 else 5354 Small := Expr_Value_R (Expr); 5355 5356 if Small <= Ureal_0 then 5357 Error_Msg_N ("small value must be greater than zero", Expr); 5358 return; 5359 end if; 5360 5361 end if; 5362 5363 if not Is_Ordinary_Fixed_Point_Type (U_Ent) then 5364 Error_Msg_N 5365 ("small requires an ordinary fixed point type", Nam); 5366 5367 elsif Has_Small_Clause (U_Ent) then 5368 Error_Msg_N ("small already given for &", Nam); 5369 5370 elsif Small > Delta_Value (U_Ent) then 5371 Error_Msg_N 5372 ("small value must not be greater than delta value", Nam); 5373 5374 else 5375 Set_Small_Value (U_Ent, Small); 5376 Set_Small_Value (Implicit_Base, Small); 5377 Set_Has_Small_Clause (U_Ent); 5378 Set_Has_Small_Clause (Implicit_Base); 5379 Set_Has_Non_Standard_Rep (Implicit_Base); 5380 end if; 5381 end Small; 5382 5383 ------------------ 5384 -- Storage_Pool -- 5385 ------------------ 5386 5387 -- Storage_Pool attribute definition clause 5388 5389 when Attribute_Storage_Pool | Attribute_Simple_Storage_Pool => declare 5390 Pool : Entity_Id; 5391 T : Entity_Id; 5392 5393 begin 5394 if Ekind (U_Ent) = E_Access_Subprogram_Type then 5395 Error_Msg_N 5396 ("storage pool cannot be given for access-to-subprogram type", 5397 Nam); 5398 return; 5399 5400 elsif not 5401 Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type) 5402 then 5403 Error_Msg_N 5404 ("storage pool can only be given for access types", Nam); 5405 return; 5406 5407 elsif Is_Derived_Type (U_Ent) then 5408 Error_Msg_N 5409 ("storage pool cannot be given for a derived access type", 5410 Nam); 5411 5412 elsif Duplicate_Clause then 5413 return; 5414 5415 elsif Present (Associated_Storage_Pool (U_Ent)) then 5416 Error_Msg_N ("storage pool already given for &", Nam); 5417 return; 5418 end if; 5419 5420 -- Check for Storage_Size previously given 5421 5422 declare 5423 SS : constant Node_Id := 5424 Get_Attribute_Definition_Clause 5425 (U_Ent, Attribute_Storage_Size); 5426 begin 5427 if Present (SS) then 5428 Check_Pool_Size_Clash (U_Ent, N, SS); 5429 end if; 5430 end; 5431 5432 -- Storage_Pool case 5433 5434 if Id = Attribute_Storage_Pool then 5435 Analyze_And_Resolve 5436 (Expr, Class_Wide_Type (RTE (RE_Root_Storage_Pool))); 5437 5438 -- In the Simple_Storage_Pool case, we allow a variable of any 5439 -- simple storage pool type, so we Resolve without imposing an 5440 -- expected type. 5441 5442 else 5443 Analyze_And_Resolve (Expr); 5444 5445 if not Present (Get_Rep_Pragma 5446 (Etype (Expr), Name_Simple_Storage_Pool_Type)) 5447 then 5448 Error_Msg_N 5449 ("expression must be of a simple storage pool type", Expr); 5450 end if; 5451 end if; 5452 5453 if not Denotes_Variable (Expr) then 5454 Error_Msg_N ("storage pool must be a variable", Expr); 5455 return; 5456 end if; 5457 5458 if Nkind (Expr) = N_Type_Conversion then 5459 T := Etype (Expression (Expr)); 5460 else 5461 T := Etype (Expr); 5462 end if; 5463 5464 -- The Stack_Bounded_Pool is used internally for implementing 5465 -- access types with a Storage_Size. Since it only work properly 5466 -- when used on one specific type, we need to check that it is not 5467 -- hijacked improperly: 5468 5469 -- type T is access Integer; 5470 -- for T'Storage_Size use n; 5471 -- type Q is access Float; 5472 -- for Q'Storage_Size use T'Storage_Size; -- incorrect 5473 5474 if RTE_Available (RE_Stack_Bounded_Pool) 5475 and then Base_Type (T) = RTE (RE_Stack_Bounded_Pool) 5476 then 5477 Error_Msg_N ("non-shareable internal Pool", Expr); 5478 return; 5479 end if; 5480 5481 -- If the argument is a name that is not an entity name, then 5482 -- we construct a renaming operation to define an entity of 5483 -- type storage pool. 5484 5485 if not Is_Entity_Name (Expr) 5486 and then Is_Object_Reference (Expr) 5487 then 5488 Pool := Make_Temporary (Loc, 'P', Expr); 5489 5490 declare 5491 Rnode : constant Node_Id := 5492 Make_Object_Renaming_Declaration (Loc, 5493 Defining_Identifier => Pool, 5494 Subtype_Mark => 5495 New_Occurrence_Of (Etype (Expr), Loc), 5496 Name => Expr); 5497 5498 begin 5499 -- If the attribute definition clause comes from an aspect 5500 -- clause, then insert the renaming before the associated 5501 -- entity's declaration, since the attribute clause has 5502 -- not yet been appended to the declaration list. 5503 5504 if From_Aspect_Specification (N) then 5505 Insert_Before (Parent (Entity (N)), Rnode); 5506 else 5507 Insert_Before (N, Rnode); 5508 end if; 5509 5510 Analyze (Rnode); 5511 Set_Associated_Storage_Pool (U_Ent, Pool); 5512 end; 5513 5514 elsif Is_Entity_Name (Expr) then 5515 Pool := Entity (Expr); 5516 5517 -- If pool is a renamed object, get original one. This can 5518 -- happen with an explicit renaming, and within instances. 5519 5520 while Present (Renamed_Object (Pool)) 5521 and then Is_Entity_Name (Renamed_Object (Pool)) 5522 loop 5523 Pool := Entity (Renamed_Object (Pool)); 5524 end loop; 5525 5526 if Present (Renamed_Object (Pool)) 5527 and then Nkind (Renamed_Object (Pool)) = N_Type_Conversion 5528 and then Is_Entity_Name (Expression (Renamed_Object (Pool))) 5529 then 5530 Pool := Entity (Expression (Renamed_Object (Pool))); 5531 end if; 5532 5533 Set_Associated_Storage_Pool (U_Ent, Pool); 5534 5535 elsif Nkind (Expr) = N_Type_Conversion 5536 and then Is_Entity_Name (Expression (Expr)) 5537 and then Nkind (Original_Node (Expr)) = N_Attribute_Reference 5538 then 5539 Pool := Entity (Expression (Expr)); 5540 Set_Associated_Storage_Pool (U_Ent, Pool); 5541 5542 else 5543 Error_Msg_N ("incorrect reference to a Storage Pool", Expr); 5544 return; 5545 end if; 5546 end; 5547 5548 ------------------ 5549 -- Storage_Size -- 5550 ------------------ 5551 5552 -- Storage_Size attribute definition clause 5553 5554 when Attribute_Storage_Size => Storage_Size : declare 5555 Btype : constant Entity_Id := Base_Type (U_Ent); 5556 5557 begin 5558 if Is_Task_Type (U_Ent) then 5559 5560 -- Check obsolescent (but never obsolescent if from aspect) 5561 5562 if not From_Aspect_Specification (N) then 5563 Check_Restriction (No_Obsolescent_Features, N); 5564 5565 if Warn_On_Obsolescent_Feature then 5566 Error_Msg_N 5567 ("?j?storage size clause for task is an " & 5568 "obsolescent feature (RM J.9)", N); 5569 Error_Msg_N ("\?j?use Storage_Size pragma instead", N); 5570 end if; 5571 end if; 5572 5573 FOnly := True; 5574 end if; 5575 5576 if not Is_Access_Type (U_Ent) 5577 and then Ekind (U_Ent) /= E_Task_Type 5578 then 5579 Error_Msg_N ("storage size cannot be given for &", Nam); 5580 5581 elsif Is_Access_Type (U_Ent) and Is_Derived_Type (U_Ent) then 5582 Error_Msg_N 5583 ("storage size cannot be given for a derived access type", 5584 Nam); 5585 5586 elsif Duplicate_Clause then 5587 null; 5588 5589 else 5590 Analyze_And_Resolve (Expr, Any_Integer); 5591 5592 if Is_Access_Type (U_Ent) then 5593 5594 -- Check for Storage_Pool previously given 5595 5596 declare 5597 SP : constant Node_Id := 5598 Get_Attribute_Definition_Clause 5599 (U_Ent, Attribute_Storage_Pool); 5600 5601 begin 5602 if Present (SP) then 5603 Check_Pool_Size_Clash (U_Ent, SP, N); 5604 end if; 5605 end; 5606 5607 -- Special case of for x'Storage_Size use 0 5608 5609 if Is_OK_Static_Expression (Expr) 5610 and then Expr_Value (Expr) = 0 5611 then 5612 Set_No_Pool_Assigned (Btype); 5613 end if; 5614 end if; 5615 5616 Set_Has_Storage_Size_Clause (Btype); 5617 end if; 5618 end Storage_Size; 5619 5620 ----------------- 5621 -- Stream_Size -- 5622 ----------------- 5623 5624 when Attribute_Stream_Size => Stream_Size : declare 5625 Size : constant Uint := Static_Integer (Expr); 5626 5627 begin 5628 if Ada_Version <= Ada_95 then 5629 Check_Restriction (No_Implementation_Attributes, N); 5630 end if; 5631 5632 if Duplicate_Clause then 5633 null; 5634 5635 elsif Is_Elementary_Type (U_Ent) then 5636 if Size /= System_Storage_Unit 5637 and then 5638 Size /= System_Storage_Unit * 2 5639 and then 5640 Size /= System_Storage_Unit * 4 5641 and then 5642 Size /= System_Storage_Unit * 8 5643 then 5644 Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit); 5645 Error_Msg_N 5646 ("stream size for elementary type must be a" 5647 & " power of 2 and at least ^", N); 5648 5649 elsif RM_Size (U_Ent) > Size then 5650 Error_Msg_Uint_1 := RM_Size (U_Ent); 5651 Error_Msg_N 5652 ("stream size for elementary type must be a" 5653 & " power of 2 and at least ^", N); 5654 end if; 5655 5656 Set_Has_Stream_Size_Clause (U_Ent); 5657 5658 else 5659 Error_Msg_N ("Stream_Size cannot be given for &", Nam); 5660 end if; 5661 end Stream_Size; 5662 5663 ---------------- 5664 -- Value_Size -- 5665 ---------------- 5666 5667 -- Value_Size attribute definition clause 5668 5669 when Attribute_Value_Size => Value_Size : declare 5670 Size : constant Uint := Static_Integer (Expr); 5671 Biased : Boolean; 5672 5673 begin 5674 if not Is_Type (U_Ent) then 5675 Error_Msg_N ("Value_Size cannot be given for &", Nam); 5676 5677 elsif Duplicate_Clause then 5678 null; 5679 5680 elsif Is_Array_Type (U_Ent) 5681 and then not Is_Constrained (U_Ent) 5682 then 5683 Error_Msg_N 5684 ("Value_Size cannot be given for unconstrained array", Nam); 5685 5686 else 5687 if Is_Elementary_Type (U_Ent) then 5688 Check_Size (Expr, U_Ent, Size, Biased); 5689 Set_Biased (U_Ent, N, "value size clause", Biased); 5690 end if; 5691 5692 Set_RM_Size (U_Ent, Size); 5693 end if; 5694 end Value_Size; 5695 5696 ----------------------- 5697 -- Variable_Indexing -- 5698 ----------------------- 5699 5700 when Attribute_Variable_Indexing => 5701 Check_Indexing_Functions; 5702 5703 ----------- 5704 -- Write -- 5705 ----------- 5706 5707 when Attribute_Write => 5708 Analyze_Stream_TSS_Definition (TSS_Stream_Write); 5709 Set_Has_Specified_Stream_Write (Ent); 5710 5711 -- All other attributes cannot be set 5712 5713 when others => 5714 Error_Msg_N 5715 ("attribute& cannot be set with definition clause", N); 5716 end case; 5717 5718 -- The test for the type being frozen must be performed after any 5719 -- expression the clause has been analyzed since the expression itself 5720 -- might cause freezing that makes the clause illegal. 5721 5722 if Rep_Item_Too_Late (U_Ent, N, FOnly) then 5723 return; 5724 end if; 5725 end Analyze_Attribute_Definition_Clause; 5726 5727 ---------------------------- 5728 -- Analyze_Code_Statement -- 5729 ---------------------------- 5730 5731 procedure Analyze_Code_Statement (N : Node_Id) is 5732 HSS : constant Node_Id := Parent (N); 5733 SBody : constant Node_Id := Parent (HSS); 5734 Subp : constant Entity_Id := Current_Scope; 5735 Stmt : Node_Id; 5736 Decl : Node_Id; 5737 StmtO : Node_Id; 5738 DeclO : Node_Id; 5739 5740 begin 5741 -- Analyze and check we get right type, note that this implements the 5742 -- requirement (RM 13.8(1)) that Machine_Code be with'ed, since that 5743 -- is the only way that Asm_Insn could possibly be visible. 5744 5745 Analyze_And_Resolve (Expression (N)); 5746 5747 if Etype (Expression (N)) = Any_Type then 5748 return; 5749 elsif Etype (Expression (N)) /= RTE (RE_Asm_Insn) then 5750 Error_Msg_N ("incorrect type for code statement", N); 5751 return; 5752 end if; 5753 5754 Check_Code_Statement (N); 5755 5756 -- Make sure we appear in the handled statement sequence of a 5757 -- subprogram (RM 13.8(3)). 5758 5759 if Nkind (HSS) /= N_Handled_Sequence_Of_Statements 5760 or else Nkind (SBody) /= N_Subprogram_Body 5761 then 5762 Error_Msg_N 5763 ("code statement can only appear in body of subprogram", N); 5764 return; 5765 end if; 5766 5767 -- Do remaining checks (RM 13.8(3)) if not already done 5768 5769 if not Is_Machine_Code_Subprogram (Subp) then 5770 Set_Is_Machine_Code_Subprogram (Subp); 5771 5772 -- No exception handlers allowed 5773 5774 if Present (Exception_Handlers (HSS)) then 5775 Error_Msg_N 5776 ("exception handlers not permitted in machine code subprogram", 5777 First (Exception_Handlers (HSS))); 5778 end if; 5779 5780 -- No declarations other than use clauses and pragmas (we allow 5781 -- certain internally generated declarations as well). 5782 5783 Decl := First (Declarations (SBody)); 5784 while Present (Decl) loop 5785 DeclO := Original_Node (Decl); 5786 if Comes_From_Source (DeclO) 5787 and not Nkind_In (DeclO, N_Pragma, 5788 N_Use_Package_Clause, 5789 N_Use_Type_Clause, 5790 N_Implicit_Label_Declaration) 5791 then 5792 Error_Msg_N 5793 ("this declaration not allowed in machine code subprogram", 5794 DeclO); 5795 end if; 5796 5797 Next (Decl); 5798 end loop; 5799 5800 -- No statements other than code statements, pragmas, and labels. 5801 -- Again we allow certain internally generated statements. 5802 5803 -- In Ada 2012, qualified expressions are names, and the code 5804 -- statement is initially parsed as a procedure call. 5805 5806 Stmt := First (Statements (HSS)); 5807 while Present (Stmt) loop 5808 StmtO := Original_Node (Stmt); 5809 5810 -- A procedure call transformed into a code statement is OK. 5811 5812 if Ada_Version >= Ada_2012 5813 and then Nkind (StmtO) = N_Procedure_Call_Statement 5814 and then Nkind (Name (StmtO)) = N_Qualified_Expression 5815 then 5816 null; 5817 5818 elsif Comes_From_Source (StmtO) 5819 and then not Nkind_In (StmtO, N_Pragma, 5820 N_Label, 5821 N_Code_Statement) 5822 then 5823 Error_Msg_N 5824 ("this statement is not allowed in machine code subprogram", 5825 StmtO); 5826 end if; 5827 5828 Next (Stmt); 5829 end loop; 5830 end if; 5831 end Analyze_Code_Statement; 5832 5833 ----------------------------------------------- 5834 -- Analyze_Enumeration_Representation_Clause -- 5835 ----------------------------------------------- 5836 5837 procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is 5838 Ident : constant Node_Id := Identifier (N); 5839 Aggr : constant Node_Id := Array_Aggregate (N); 5840 Enumtype : Entity_Id; 5841 Elit : Entity_Id; 5842 Expr : Node_Id; 5843 Assoc : Node_Id; 5844 Choice : Node_Id; 5845 Val : Uint; 5846 5847 Err : Boolean := False; 5848 -- Set True to avoid cascade errors and crashes on incorrect source code 5849 5850 Lo : constant Uint := Expr_Value (Type_Low_Bound (Universal_Integer)); 5851 Hi : constant Uint := Expr_Value (Type_High_Bound (Universal_Integer)); 5852 -- Allowed range of universal integer (= allowed range of enum lit vals) 5853 5854 Min : Uint; 5855 Max : Uint; 5856 -- Minimum and maximum values of entries 5857 5858 Max_Node : Node_Id; 5859 -- Pointer to node for literal providing max value 5860 5861 begin 5862 if Ignore_Rep_Clauses then 5863 Kill_Rep_Clause (N); 5864 return; 5865 end if; 5866 5867 -- Ignore enumeration rep clauses by default in CodePeer mode, 5868 -- unless -gnatd.I is specified, as a work around for potential false 5869 -- positive messages. 5870 5871 if CodePeer_Mode and not Debug_Flag_Dot_II then 5872 return; 5873 end if; 5874 5875 -- First some basic error checks 5876 5877 Find_Type (Ident); 5878 Enumtype := Entity (Ident); 5879 5880 if Enumtype = Any_Type 5881 or else Rep_Item_Too_Early (Enumtype, N) 5882 then 5883 return; 5884 else 5885 Enumtype := Underlying_Type (Enumtype); 5886 end if; 5887 5888 if not Is_Enumeration_Type (Enumtype) then 5889 Error_Msg_NE 5890 ("enumeration type required, found}", 5891 Ident, First_Subtype (Enumtype)); 5892 return; 5893 end if; 5894 5895 -- Ignore rep clause on generic actual type. This will already have 5896 -- been flagged on the template as an error, and this is the safest 5897 -- way to ensure we don't get a junk cascaded message in the instance. 5898 5899 if Is_Generic_Actual_Type (Enumtype) then 5900 return; 5901 5902 -- Type must be in current scope 5903 5904 elsif Scope (Enumtype) /= Current_Scope then 5905 Error_Msg_N ("type must be declared in this scope", Ident); 5906 return; 5907 5908 -- Type must be a first subtype 5909 5910 elsif not Is_First_Subtype (Enumtype) then 5911 Error_Msg_N ("cannot give enumeration rep clause for subtype", N); 5912 return; 5913 5914 -- Ignore duplicate rep clause 5915 5916 elsif Has_Enumeration_Rep_Clause (Enumtype) then 5917 Error_Msg_N ("duplicate enumeration rep clause ignored", N); 5918 return; 5919 5920 -- Don't allow rep clause for standard [wide_[wide_]]character 5921 5922 elsif Is_Standard_Character_Type (Enumtype) then 5923 Error_Msg_N ("enumeration rep clause not allowed for this type", N); 5924 return; 5925 5926 -- Check that the expression is a proper aggregate (no parentheses) 5927 5928 elsif Paren_Count (Aggr) /= 0 then 5929 Error_Msg 5930 ("extra parentheses surrounding aggregate not allowed", 5931 First_Sloc (Aggr)); 5932 return; 5933 5934 -- All tests passed, so set rep clause in place 5935 5936 else 5937 Set_Has_Enumeration_Rep_Clause (Enumtype); 5938 Set_Has_Enumeration_Rep_Clause (Base_Type (Enumtype)); 5939 end if; 5940 5941 -- Now we process the aggregate. Note that we don't use the normal 5942 -- aggregate code for this purpose, because we don't want any of the 5943 -- normal expansion activities, and a number of special semantic 5944 -- rules apply (including the component type being any integer type) 5945 5946 Elit := First_Literal (Enumtype); 5947 5948 -- First the positional entries if any 5949 5950 if Present (Expressions (Aggr)) then 5951 Expr := First (Expressions (Aggr)); 5952 while Present (Expr) loop 5953 if No (Elit) then 5954 Error_Msg_N ("too many entries in aggregate", Expr); 5955 return; 5956 end if; 5957 5958 Val := Static_Integer (Expr); 5959 5960 -- Err signals that we found some incorrect entries processing 5961 -- the list. The final checks for completeness and ordering are 5962 -- skipped in this case. 5963 5964 if Val = No_Uint then 5965 Err := True; 5966 5967 elsif Val < Lo or else Hi < Val then 5968 Error_Msg_N ("value outside permitted range", Expr); 5969 Err := True; 5970 end if; 5971 5972 Set_Enumeration_Rep (Elit, Val); 5973 Set_Enumeration_Rep_Expr (Elit, Expr); 5974 Next (Expr); 5975 Next (Elit); 5976 end loop; 5977 end if; 5978 5979 -- Now process the named entries if present 5980 5981 if Present (Component_Associations (Aggr)) then 5982 Assoc := First (Component_Associations (Aggr)); 5983 while Present (Assoc) loop 5984 Choice := First (Choices (Assoc)); 5985 5986 if Present (Next (Choice)) then 5987 Error_Msg_N 5988 ("multiple choice not allowed here", Next (Choice)); 5989 Err := True; 5990 end if; 5991 5992 if Nkind (Choice) = N_Others_Choice then 5993 Error_Msg_N ("others choice not allowed here", Choice); 5994 Err := True; 5995 5996 elsif Nkind (Choice) = N_Range then 5997 5998 -- ??? should allow zero/one element range here 5999 6000 Error_Msg_N ("range not allowed here", Choice); 6001 Err := True; 6002 6003 else 6004 Analyze_And_Resolve (Choice, Enumtype); 6005 6006 if Error_Posted (Choice) then 6007 Err := True; 6008 end if; 6009 6010 if not Err then 6011 if Is_Entity_Name (Choice) 6012 and then Is_Type (Entity (Choice)) 6013 then 6014 Error_Msg_N ("subtype name not allowed here", Choice); 6015 Err := True; 6016 6017 -- ??? should allow static subtype with zero/one entry 6018 6019 elsif Etype (Choice) = Base_Type (Enumtype) then 6020 if not Is_OK_Static_Expression (Choice) then 6021 Flag_Non_Static_Expr 6022 ("non-static expression used for choice!", Choice); 6023 Err := True; 6024 6025 else 6026 Elit := Expr_Value_E (Choice); 6027 6028 if Present (Enumeration_Rep_Expr (Elit)) then 6029 Error_Msg_Sloc := 6030 Sloc (Enumeration_Rep_Expr (Elit)); 6031 Error_Msg_NE 6032 ("representation for& previously given#", 6033 Choice, Elit); 6034 Err := True; 6035 end if; 6036 6037 Set_Enumeration_Rep_Expr (Elit, Expression (Assoc)); 6038 6039 Expr := Expression (Assoc); 6040 Val := Static_Integer (Expr); 6041 6042 if Val = No_Uint then 6043 Err := True; 6044 6045 elsif Val < Lo or else Hi < Val then 6046 Error_Msg_N ("value outside permitted range", Expr); 6047 Err := True; 6048 end if; 6049 6050 Set_Enumeration_Rep (Elit, Val); 6051 end if; 6052 end if; 6053 end if; 6054 end if; 6055 6056 Next (Assoc); 6057 end loop; 6058 end if; 6059 6060 -- Aggregate is fully processed. Now we check that a full set of 6061 -- representations was given, and that they are in range and in order. 6062 -- These checks are only done if no other errors occurred. 6063 6064 if not Err then 6065 Min := No_Uint; 6066 Max := No_Uint; 6067 6068 Elit := First_Literal (Enumtype); 6069 while Present (Elit) loop 6070 if No (Enumeration_Rep_Expr (Elit)) then 6071 Error_Msg_NE ("missing representation for&!", N, Elit); 6072 6073 else 6074 Val := Enumeration_Rep (Elit); 6075 6076 if Min = No_Uint then 6077 Min := Val; 6078 end if; 6079 6080 if Val /= No_Uint then 6081 if Max /= No_Uint and then Val <= Max then 6082 Error_Msg_NE 6083 ("enumeration value for& not ordered!", 6084 Enumeration_Rep_Expr (Elit), Elit); 6085 end if; 6086 6087 Max_Node := Enumeration_Rep_Expr (Elit); 6088 Max := Val; 6089 end if; 6090 6091 -- If there is at least one literal whose representation is not 6092 -- equal to the Pos value, then note that this enumeration type 6093 -- has a non-standard representation. 6094 6095 if Val /= Enumeration_Pos (Elit) then 6096 Set_Has_Non_Standard_Rep (Base_Type (Enumtype)); 6097 end if; 6098 end if; 6099 6100 Next (Elit); 6101 end loop; 6102 6103 -- Now set proper size information 6104 6105 declare 6106 Minsize : Uint := UI_From_Int (Minimum_Size (Enumtype)); 6107 6108 begin 6109 if Has_Size_Clause (Enumtype) then 6110 6111 -- All OK, if size is OK now 6112 6113 if RM_Size (Enumtype) >= Minsize then 6114 null; 6115 6116 else 6117 -- Try if we can get by with biasing 6118 6119 Minsize := 6120 UI_From_Int (Minimum_Size (Enumtype, Biased => True)); 6121 6122 -- Error message if even biasing does not work 6123 6124 if RM_Size (Enumtype) < Minsize then 6125 Error_Msg_Uint_1 := RM_Size (Enumtype); 6126 Error_Msg_Uint_2 := Max; 6127 Error_Msg_N 6128 ("previously given size (^) is too small " 6129 & "for this value (^)", Max_Node); 6130 6131 -- If biasing worked, indicate that we now have biased rep 6132 6133 else 6134 Set_Biased 6135 (Enumtype, Size_Clause (Enumtype), "size clause"); 6136 end if; 6137 end if; 6138 6139 else 6140 Set_RM_Size (Enumtype, Minsize); 6141 Set_Enum_Esize (Enumtype); 6142 end if; 6143 6144 Set_RM_Size (Base_Type (Enumtype), RM_Size (Enumtype)); 6145 Set_Esize (Base_Type (Enumtype), Esize (Enumtype)); 6146 Set_Alignment (Base_Type (Enumtype), Alignment (Enumtype)); 6147 end; 6148 end if; 6149 6150 -- We repeat the too late test in case it froze itself 6151 6152 if Rep_Item_Too_Late (Enumtype, N) then 6153 null; 6154 end if; 6155 end Analyze_Enumeration_Representation_Clause; 6156 6157 ---------------------------- 6158 -- Analyze_Free_Statement -- 6159 ---------------------------- 6160 6161 procedure Analyze_Free_Statement (N : Node_Id) is 6162 begin 6163 Analyze (Expression (N)); 6164 end Analyze_Free_Statement; 6165 6166 --------------------------- 6167 -- Analyze_Freeze_Entity -- 6168 --------------------------- 6169 6170 procedure Analyze_Freeze_Entity (N : Node_Id) is 6171 begin 6172 Freeze_Entity_Checks (N); 6173 end Analyze_Freeze_Entity; 6174 6175 ----------------------------------- 6176 -- Analyze_Freeze_Generic_Entity -- 6177 ----------------------------------- 6178 6179 procedure Analyze_Freeze_Generic_Entity (N : Node_Id) is 6180 begin 6181 Freeze_Entity_Checks (N); 6182 end Analyze_Freeze_Generic_Entity; 6183 6184 ------------------------------------------ 6185 -- Analyze_Record_Representation_Clause -- 6186 ------------------------------------------ 6187 6188 -- Note: we check as much as we can here, but we can't do any checks 6189 -- based on the position values (e.g. overlap checks) until freeze time 6190 -- because especially in Ada 2005 (machine scalar mode), the processing 6191 -- for non-standard bit order can substantially change the positions. 6192 -- See procedure Check_Record_Representation_Clause (called from Freeze) 6193 -- for the remainder of this processing. 6194 6195 procedure Analyze_Record_Representation_Clause (N : Node_Id) is 6196 Ident : constant Node_Id := Identifier (N); 6197 Biased : Boolean; 6198 CC : Node_Id; 6199 Comp : Entity_Id; 6200 Fbit : Uint; 6201 Hbit : Uint := Uint_0; 6202 Lbit : Uint; 6203 Ocomp : Entity_Id; 6204 Posit : Uint; 6205 Rectype : Entity_Id; 6206 Recdef : Node_Id; 6207 6208 function Is_Inherited (Comp : Entity_Id) return Boolean; 6209 -- True if Comp is an inherited component in a record extension 6210 6211 ------------------ 6212 -- Is_Inherited -- 6213 ------------------ 6214 6215 function Is_Inherited (Comp : Entity_Id) return Boolean is 6216 Comp_Base : Entity_Id; 6217 6218 begin 6219 if Ekind (Rectype) = E_Record_Subtype then 6220 Comp_Base := Original_Record_Component (Comp); 6221 else 6222 Comp_Base := Comp; 6223 end if; 6224 6225 return Comp_Base /= Original_Record_Component (Comp_Base); 6226 end Is_Inherited; 6227 6228 -- Local variables 6229 6230 Is_Record_Extension : Boolean; 6231 -- True if Rectype is a record extension 6232 6233 CR_Pragma : Node_Id := Empty; 6234 -- Points to N_Pragma node if Complete_Representation pragma present 6235 6236 -- Start of processing for Analyze_Record_Representation_Clause 6237 6238 begin 6239 if Ignore_Rep_Clauses then 6240 Kill_Rep_Clause (N); 6241 return; 6242 end if; 6243 6244 Find_Type (Ident); 6245 Rectype := Entity (Ident); 6246 6247 if Rectype = Any_Type or else Rep_Item_Too_Early (Rectype, N) then 6248 return; 6249 else 6250 Rectype := Underlying_Type (Rectype); 6251 end if; 6252 6253 -- First some basic error checks 6254 6255 if not Is_Record_Type (Rectype) then 6256 Error_Msg_NE 6257 ("record type required, found}", Ident, First_Subtype (Rectype)); 6258 return; 6259 6260 elsif Scope (Rectype) /= Current_Scope then 6261 Error_Msg_N ("type must be declared in this scope", N); 6262 return; 6263 6264 elsif not Is_First_Subtype (Rectype) then 6265 Error_Msg_N ("cannot give record rep clause for subtype", N); 6266 return; 6267 6268 elsif Has_Record_Rep_Clause (Rectype) then 6269 Error_Msg_N ("duplicate record rep clause ignored", N); 6270 return; 6271 6272 elsif Rep_Item_Too_Late (Rectype, N) then 6273 return; 6274 end if; 6275 6276 -- We know we have a first subtype, now possibly go the the anonymous 6277 -- base type to determine whether Rectype is a record extension. 6278 6279 Recdef := Type_Definition (Declaration_Node (Base_Type (Rectype))); 6280 Is_Record_Extension := 6281 Nkind (Recdef) = N_Derived_Type_Definition 6282 and then Present (Record_Extension_Part (Recdef)); 6283 6284 if Present (Mod_Clause (N)) then 6285 declare 6286 Loc : constant Source_Ptr := Sloc (N); 6287 M : constant Node_Id := Mod_Clause (N); 6288 P : constant List_Id := Pragmas_Before (M); 6289 AtM_Nod : Node_Id; 6290 6291 Mod_Val : Uint; 6292 pragma Warnings (Off, Mod_Val); 6293 6294 begin 6295 Check_Restriction (No_Obsolescent_Features, Mod_Clause (N)); 6296 6297 if Warn_On_Obsolescent_Feature then 6298 Error_Msg_N 6299 ("?j?mod clause is an obsolescent feature (RM J.8)", N); 6300 Error_Msg_N 6301 ("\?j?use alignment attribute definition clause instead", N); 6302 end if; 6303 6304 if Present (P) then 6305 Analyze_List (P); 6306 end if; 6307 6308 -- In ASIS_Mode mode, expansion is disabled, but we must convert 6309 -- the Mod clause into an alignment clause anyway, so that the 6310 -- back-end can compute and back-annotate properly the size and 6311 -- alignment of types that may include this record. 6312 6313 -- This seems dubious, this destroys the source tree in a manner 6314 -- not detectable by ASIS ??? 6315 6316 if Operating_Mode = Check_Semantics and then ASIS_Mode then 6317 AtM_Nod := 6318 Make_Attribute_Definition_Clause (Loc, 6319 Name => New_Occurrence_Of (Base_Type (Rectype), Loc), 6320 Chars => Name_Alignment, 6321 Expression => Relocate_Node (Expression (M))); 6322 6323 Set_From_At_Mod (AtM_Nod); 6324 Insert_After (N, AtM_Nod); 6325 Mod_Val := Get_Alignment_Value (Expression (AtM_Nod)); 6326 Set_Mod_Clause (N, Empty); 6327 6328 else 6329 -- Get the alignment value to perform error checking 6330 6331 Mod_Val := Get_Alignment_Value (Expression (M)); 6332 end if; 6333 end; 6334 end if; 6335 6336 -- For untagged types, clear any existing component clauses for the 6337 -- type. If the type is derived, this is what allows us to override 6338 -- a rep clause for the parent. For type extensions, the representation 6339 -- of the inherited components is inherited, so we want to keep previous 6340 -- component clauses for completeness. 6341 6342 if not Is_Tagged_Type (Rectype) then 6343 Comp := First_Component_Or_Discriminant (Rectype); 6344 while Present (Comp) loop 6345 Set_Component_Clause (Comp, Empty); 6346 Next_Component_Or_Discriminant (Comp); 6347 end loop; 6348 end if; 6349 6350 -- All done if no component clauses 6351 6352 CC := First (Component_Clauses (N)); 6353 6354 if No (CC) then 6355 return; 6356 end if; 6357 6358 -- A representation like this applies to the base type 6359 6360 Set_Has_Record_Rep_Clause (Base_Type (Rectype)); 6361 Set_Has_Non_Standard_Rep (Base_Type (Rectype)); 6362 Set_Has_Specified_Layout (Base_Type (Rectype)); 6363 6364 -- Process the component clauses 6365 6366 while Present (CC) loop 6367 6368 -- Pragma 6369 6370 if Nkind (CC) = N_Pragma then 6371 Analyze (CC); 6372 6373 -- The only pragma of interest is Complete_Representation 6374 6375 if Pragma_Name (CC) = Name_Complete_Representation then 6376 CR_Pragma := CC; 6377 end if; 6378 6379 -- Processing for real component clause 6380 6381 else 6382 Posit := Static_Integer (Position (CC)); 6383 Fbit := Static_Integer (First_Bit (CC)); 6384 Lbit := Static_Integer (Last_Bit (CC)); 6385 6386 if Posit /= No_Uint 6387 and then Fbit /= No_Uint 6388 and then Lbit /= No_Uint 6389 then 6390 if Posit < 0 then 6391 Error_Msg_N 6392 ("position cannot be negative", Position (CC)); 6393 6394 elsif Fbit < 0 then 6395 Error_Msg_N 6396 ("first bit cannot be negative", First_Bit (CC)); 6397 6398 -- The Last_Bit specified in a component clause must not be 6399 -- less than the First_Bit minus one (RM-13.5.1(10)). 6400 6401 elsif Lbit < Fbit - 1 then 6402 Error_Msg_N 6403 ("last bit cannot be less than first bit minus one", 6404 Last_Bit (CC)); 6405 6406 -- Values look OK, so find the corresponding record component 6407 -- Even though the syntax allows an attribute reference for 6408 -- implementation-defined components, GNAT does not allow the 6409 -- tag to get an explicit position. 6410 6411 elsif Nkind (Component_Name (CC)) = N_Attribute_Reference then 6412 if Attribute_Name (Component_Name (CC)) = Name_Tag then 6413 Error_Msg_N ("position of tag cannot be specified", CC); 6414 else 6415 Error_Msg_N ("illegal component name", CC); 6416 end if; 6417 6418 else 6419 Comp := First_Entity (Rectype); 6420 while Present (Comp) loop 6421 exit when Chars (Comp) = Chars (Component_Name (CC)); 6422 Next_Entity (Comp); 6423 end loop; 6424 6425 if No (Comp) then 6426 6427 -- Maybe component of base type that is absent from 6428 -- statically constrained first subtype. 6429 6430 Comp := First_Entity (Base_Type (Rectype)); 6431 while Present (Comp) loop 6432 exit when Chars (Comp) = Chars (Component_Name (CC)); 6433 Next_Entity (Comp); 6434 end loop; 6435 end if; 6436 6437 if No (Comp) then 6438 Error_Msg_N 6439 ("component clause is for non-existent field", CC); 6440 6441 -- Ada 2012 (AI05-0026): Any name that denotes a 6442 -- discriminant of an object of an unchecked union type 6443 -- shall not occur within a record_representation_clause. 6444 6445 -- The general restriction of using record rep clauses on 6446 -- Unchecked_Union types has now been lifted. Since it is 6447 -- possible to introduce a record rep clause which mentions 6448 -- the discriminant of an Unchecked_Union in non-Ada 2012 6449 -- code, this check is applied to all versions of the 6450 -- language. 6451 6452 elsif Ekind (Comp) = E_Discriminant 6453 and then Is_Unchecked_Union (Rectype) 6454 then 6455 Error_Msg_N 6456 ("cannot reference discriminant of unchecked union", 6457 Component_Name (CC)); 6458 6459 elsif Is_Record_Extension and then Is_Inherited (Comp) then 6460 Error_Msg_NE 6461 ("component clause not allowed for inherited " 6462 & "component&", CC, Comp); 6463 6464 elsif Present (Component_Clause (Comp)) then 6465 6466 -- Diagnose duplicate rep clause, or check consistency 6467 -- if this is an inherited component. In a double fault, 6468 -- there may be a duplicate inconsistent clause for an 6469 -- inherited component. 6470 6471 if Scope (Original_Record_Component (Comp)) = Rectype 6472 or else Parent (Component_Clause (Comp)) = N 6473 then 6474 Error_Msg_Sloc := Sloc (Component_Clause (Comp)); 6475 Error_Msg_N ("component clause previously given#", CC); 6476 6477 else 6478 declare 6479 Rep1 : constant Node_Id := Component_Clause (Comp); 6480 begin 6481 if Intval (Position (Rep1)) /= 6482 Intval (Position (CC)) 6483 or else Intval (First_Bit (Rep1)) /= 6484 Intval (First_Bit (CC)) 6485 or else Intval (Last_Bit (Rep1)) /= 6486 Intval (Last_Bit (CC)) 6487 then 6488 Error_Msg_N 6489 ("component clause inconsistent " 6490 & "with representation of ancestor", CC); 6491 6492 elsif Warn_On_Redundant_Constructs then 6493 Error_Msg_N 6494 ("?r?redundant confirming component clause " 6495 & "for component!", CC); 6496 end if; 6497 end; 6498 end if; 6499 6500 -- Normal case where this is the first component clause we 6501 -- have seen for this entity, so set it up properly. 6502 6503 else 6504 -- Make reference for field in record rep clause and set 6505 -- appropriate entity field in the field identifier. 6506 6507 Generate_Reference 6508 (Comp, Component_Name (CC), Set_Ref => False); 6509 Set_Entity (Component_Name (CC), Comp); 6510 6511 -- Update Fbit and Lbit to the actual bit number 6512 6513 Fbit := Fbit + UI_From_Int (SSU) * Posit; 6514 Lbit := Lbit + UI_From_Int (SSU) * Posit; 6515 6516 if Has_Size_Clause (Rectype) 6517 and then RM_Size (Rectype) <= Lbit 6518 then 6519 Error_Msg_N 6520 ("bit number out of range of specified size", 6521 Last_Bit (CC)); 6522 else 6523 Set_Component_Clause (Comp, CC); 6524 Set_Component_Bit_Offset (Comp, Fbit); 6525 Set_Esize (Comp, 1 + (Lbit - Fbit)); 6526 Set_Normalized_First_Bit (Comp, Fbit mod SSU); 6527 Set_Normalized_Position (Comp, Fbit / SSU); 6528 6529 if Warn_On_Overridden_Size 6530 and then Has_Size_Clause (Etype (Comp)) 6531 and then RM_Size (Etype (Comp)) /= Esize (Comp) 6532 then 6533 Error_Msg_NE 6534 ("?S?component size overrides size clause for&", 6535 Component_Name (CC), Etype (Comp)); 6536 end if; 6537 6538 -- This information is also set in the corresponding 6539 -- component of the base type, found by accessing the 6540 -- Original_Record_Component link if it is present. 6541 6542 Ocomp := Original_Record_Component (Comp); 6543 6544 if Hbit < Lbit then 6545 Hbit := Lbit; 6546 end if; 6547 6548 Check_Size 6549 (Component_Name (CC), 6550 Etype (Comp), 6551 Esize (Comp), 6552 Biased); 6553 6554 Set_Biased 6555 (Comp, First_Node (CC), "component clause", Biased); 6556 6557 if Present (Ocomp) then 6558 Set_Component_Clause (Ocomp, CC); 6559 Set_Component_Bit_Offset (Ocomp, Fbit); 6560 Set_Normalized_First_Bit (Ocomp, Fbit mod SSU); 6561 Set_Normalized_Position (Ocomp, Fbit / SSU); 6562 Set_Esize (Ocomp, 1 + (Lbit - Fbit)); 6563 6564 Set_Normalized_Position_Max 6565 (Ocomp, Normalized_Position (Ocomp)); 6566 6567 -- Note: we don't use Set_Biased here, because we 6568 -- already gave a warning above if needed, and we 6569 -- would get a duplicate for the same name here. 6570 6571 Set_Has_Biased_Representation 6572 (Ocomp, Has_Biased_Representation (Comp)); 6573 end if; 6574 6575 if Esize (Comp) < 0 then 6576 Error_Msg_N ("component size is negative", CC); 6577 end if; 6578 end if; 6579 end if; 6580 end if; 6581 end if; 6582 end if; 6583 6584 Next (CC); 6585 end loop; 6586 6587 -- Check missing components if Complete_Representation pragma appeared 6588 6589 if Present (CR_Pragma) then 6590 Comp := First_Component_Or_Discriminant (Rectype); 6591 while Present (Comp) loop 6592 if No (Component_Clause (Comp)) then 6593 Error_Msg_NE 6594 ("missing component clause for &", CR_Pragma, Comp); 6595 end if; 6596 6597 Next_Component_Or_Discriminant (Comp); 6598 end loop; 6599 6600 -- Give missing components warning if required 6601 6602 elsif Warn_On_Unrepped_Components then 6603 declare 6604 Num_Repped_Components : Nat := 0; 6605 Num_Unrepped_Components : Nat := 0; 6606 6607 begin 6608 -- First count number of repped and unrepped components 6609 6610 Comp := First_Component_Or_Discriminant (Rectype); 6611 while Present (Comp) loop 6612 if Present (Component_Clause (Comp)) then 6613 Num_Repped_Components := Num_Repped_Components + 1; 6614 else 6615 Num_Unrepped_Components := Num_Unrepped_Components + 1; 6616 end if; 6617 6618 Next_Component_Or_Discriminant (Comp); 6619 end loop; 6620 6621 -- We are only interested in the case where there is at least one 6622 -- unrepped component, and at least half the components have rep 6623 -- clauses. We figure that if less than half have them, then the 6624 -- partial rep clause is really intentional. If the component 6625 -- type has no underlying type set at this point (as for a generic 6626 -- formal type), we don't know enough to give a warning on the 6627 -- component. 6628 6629 if Num_Unrepped_Components > 0 6630 and then Num_Unrepped_Components < Num_Repped_Components 6631 then 6632 Comp := First_Component_Or_Discriminant (Rectype); 6633 while Present (Comp) loop 6634 if No (Component_Clause (Comp)) 6635 and then Comes_From_Source (Comp) 6636 and then Present (Underlying_Type (Etype (Comp))) 6637 and then (Is_Scalar_Type (Underlying_Type (Etype (Comp))) 6638 or else Size_Known_At_Compile_Time 6639 (Underlying_Type (Etype (Comp)))) 6640 and then not Has_Warnings_Off (Rectype) 6641 6642 -- Ignore discriminant in unchecked union, since it is 6643 -- not there, and cannot have a component clause. 6644 6645 and then (not Is_Unchecked_Union (Rectype) 6646 or else Ekind (Comp) /= E_Discriminant) 6647 then 6648 Error_Msg_Sloc := Sloc (Comp); 6649 Error_Msg_NE 6650 ("?C?no component clause given for & declared #", 6651 N, Comp); 6652 end if; 6653 6654 Next_Component_Or_Discriminant (Comp); 6655 end loop; 6656 end if; 6657 end; 6658 end if; 6659 end Analyze_Record_Representation_Clause; 6660 6661 ------------------------------------- 6662 -- Build_Discrete_Static_Predicate -- 6663 ------------------------------------- 6664 6665 procedure Build_Discrete_Static_Predicate 6666 (Typ : Entity_Id; 6667 Expr : Node_Id; 6668 Nam : Name_Id) 6669 is 6670 Loc : constant Source_Ptr := Sloc (Expr); 6671 6672 Non_Static : exception; 6673 -- Raised if something non-static is found 6674 6675 Btyp : constant Entity_Id := Base_Type (Typ); 6676 6677 BLo : constant Uint := Expr_Value (Type_Low_Bound (Btyp)); 6678 BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp)); 6679 -- Low bound and high bound value of base type of Typ 6680 6681 TLo : Uint; 6682 THi : Uint; 6683 -- Bounds for constructing the static predicate. We use the bound of the 6684 -- subtype if it is static, otherwise the corresponding base type bound. 6685 -- Note: a non-static subtype can have a static predicate. 6686 6687 type REnt is record 6688 Lo, Hi : Uint; 6689 end record; 6690 -- One entry in a Rlist value, a single REnt (range entry) value denotes 6691 -- one range from Lo to Hi. To represent a single value range Lo = Hi = 6692 -- value. 6693 6694 type RList is array (Nat range <>) of REnt; 6695 -- A list of ranges. The ranges are sorted in increasing order, and are 6696 -- disjoint (there is a gap of at least one value between each range in 6697 -- the table). A value is in the set of ranges in Rlist if it lies 6698 -- within one of these ranges. 6699 6700 False_Range : constant RList := 6701 RList'(1 .. 0 => REnt'(No_Uint, No_Uint)); 6702 -- An empty set of ranges represents a range list that can never be 6703 -- satisfied, since there are no ranges in which the value could lie, 6704 -- so it does not lie in any of them. False_Range is a canonical value 6705 -- for this empty set, but general processing should test for an Rlist 6706 -- with length zero (see Is_False predicate), since other null ranges 6707 -- may appear which must be treated as False. 6708 6709 True_Range : constant RList := RList'(1 => REnt'(BLo, BHi)); 6710 -- Range representing True, value must be in the base range 6711 6712 function "and" (Left : RList; Right : RList) return RList; 6713 -- And's together two range lists, returning a range list. This is a set 6714 -- intersection operation. 6715 6716 function "or" (Left : RList; Right : RList) return RList; 6717 -- Or's together two range lists, returning a range list. This is a set 6718 -- union operation. 6719 6720 function "not" (Right : RList) return RList; 6721 -- Returns complement of a given range list, i.e. a range list 6722 -- representing all the values in TLo .. THi that are not in the input 6723 -- operand Right. 6724 6725 function Build_Val (V : Uint) return Node_Id; 6726 -- Return an analyzed N_Identifier node referencing this value, suitable 6727 -- for use as an entry in the Static_Discrte_Predicate list. This node 6728 -- is typed with the base type. 6729 6730 function Build_Range (Lo : Uint; Hi : Uint) return Node_Id; 6731 -- Return an analyzed N_Range node referencing this range, suitable for 6732 -- use as an entry in the Static_Discrete_Predicate list. This node is 6733 -- typed with the base type. 6734 6735 function Get_RList (Exp : Node_Id) return RList; 6736 -- This is a recursive routine that converts the given expression into a 6737 -- list of ranges, suitable for use in building the static predicate. 6738 6739 function Is_False (R : RList) return Boolean; 6740 pragma Inline (Is_False); 6741 -- Returns True if the given range list is empty, and thus represents a 6742 -- False list of ranges that can never be satisfied. 6743 6744 function Is_True (R : RList) return Boolean; 6745 -- Returns True if R trivially represents the True predicate by having a 6746 -- single range from BLo to BHi. 6747 6748 function Is_Type_Ref (N : Node_Id) return Boolean; 6749 pragma Inline (Is_Type_Ref); 6750 -- Returns if True if N is a reference to the type for the predicate in 6751 -- the expression (i.e. if it is an identifier whose Chars field matches 6752 -- the Nam given in the call). N must not be parenthesized, if the type 6753 -- name appears in parens, this routine will return False. 6754 6755 function Lo_Val (N : Node_Id) return Uint; 6756 -- Given an entry from a Static_Discrete_Predicate list that is either 6757 -- a static expression or static range, gets either the expression value 6758 -- or the low bound of the range. 6759 6760 function Hi_Val (N : Node_Id) return Uint; 6761 -- Given an entry from a Static_Discrete_Predicate list that is either 6762 -- a static expression or static range, gets either the expression value 6763 -- or the high bound of the range. 6764 6765 function Membership_Entry (N : Node_Id) return RList; 6766 -- Given a single membership entry (range, value, or subtype), returns 6767 -- the corresponding range list. Raises Static_Error if not static. 6768 6769 function Membership_Entries (N : Node_Id) return RList; 6770 -- Given an element on an alternatives list of a membership operation, 6771 -- returns the range list corresponding to this entry and all following 6772 -- entries (i.e. returns the "or" of this list of values). 6773 6774 function Stat_Pred (Typ : Entity_Id) return RList; 6775 -- Given a type, if it has a static predicate, then return the predicate 6776 -- as a range list, otherwise raise Non_Static. 6777 6778 ----------- 6779 -- "and" -- 6780 ----------- 6781 6782 function "and" (Left : RList; Right : RList) return RList is 6783 FEnt : REnt; 6784 -- First range of result 6785 6786 SLeft : Nat := Left'First; 6787 -- Start of rest of left entries 6788 6789 SRight : Nat := Right'First; 6790 -- Start of rest of right entries 6791 6792 begin 6793 -- If either range is True, return the other 6794 6795 if Is_True (Left) then 6796 return Right; 6797 elsif Is_True (Right) then 6798 return Left; 6799 end if; 6800 6801 -- If either range is False, return False 6802 6803 if Is_False (Left) or else Is_False (Right) then 6804 return False_Range; 6805 end if; 6806 6807 -- Loop to remove entries at start that are disjoint, and thus just 6808 -- get discarded from the result entirely. 6809 6810 loop 6811 -- If no operands left in either operand, result is false 6812 6813 if SLeft > Left'Last or else SRight > Right'Last then 6814 return False_Range; 6815 6816 -- Discard first left operand entry if disjoint with right 6817 6818 elsif Left (SLeft).Hi < Right (SRight).Lo then 6819 SLeft := SLeft + 1; 6820 6821 -- Discard first right operand entry if disjoint with left 6822 6823 elsif Right (SRight).Hi < Left (SLeft).Lo then 6824 SRight := SRight + 1; 6825 6826 -- Otherwise we have an overlapping entry 6827 6828 else 6829 exit; 6830 end if; 6831 end loop; 6832 6833 -- Now we have two non-null operands, and first entries overlap. The 6834 -- first entry in the result will be the overlapping part of these 6835 -- two entries. 6836 6837 FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo), 6838 Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi)); 6839 6840 -- Now we can remove the entry that ended at a lower value, since its 6841 -- contribution is entirely contained in Fent. 6842 6843 if Left (SLeft).Hi <= Right (SRight).Hi then 6844 SLeft := SLeft + 1; 6845 else 6846 SRight := SRight + 1; 6847 end if; 6848 6849 -- Compute result by concatenating this first entry with the "and" of 6850 -- the remaining parts of the left and right operands. Note that if 6851 -- either of these is empty, "and" will yield empty, so that we will 6852 -- end up with just Fent, which is what we want in that case. 6853 6854 return 6855 FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last)); 6856 end "and"; 6857 6858 ----------- 6859 -- "not" -- 6860 ----------- 6861 6862 function "not" (Right : RList) return RList is 6863 begin 6864 -- Return True if False range 6865 6866 if Is_False (Right) then 6867 return True_Range; 6868 end if; 6869 6870 -- Return False if True range 6871 6872 if Is_True (Right) then 6873 return False_Range; 6874 end if; 6875 6876 -- Here if not trivial case 6877 6878 declare 6879 Result : RList (1 .. Right'Length + 1); 6880 -- May need one more entry for gap at beginning and end 6881 6882 Count : Nat := 0; 6883 -- Number of entries stored in Result 6884 6885 begin 6886 -- Gap at start 6887 6888 if Right (Right'First).Lo > TLo then 6889 Count := Count + 1; 6890 Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1); 6891 end if; 6892 6893 -- Gaps between ranges 6894 6895 for J in Right'First .. Right'Last - 1 loop 6896 Count := Count + 1; 6897 Result (Count) := REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1); 6898 end loop; 6899 6900 -- Gap at end 6901 6902 if Right (Right'Last).Hi < THi then 6903 Count := Count + 1; 6904 Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi); 6905 end if; 6906 6907 return Result (1 .. Count); 6908 end; 6909 end "not"; 6910 6911 ---------- 6912 -- "or" -- 6913 ---------- 6914 6915 function "or" (Left : RList; Right : RList) return RList is 6916 FEnt : REnt; 6917 -- First range of result 6918 6919 SLeft : Nat := Left'First; 6920 -- Start of rest of left entries 6921 6922 SRight : Nat := Right'First; 6923 -- Start of rest of right entries 6924 6925 begin 6926 -- If either range is True, return True 6927 6928 if Is_True (Left) or else Is_True (Right) then 6929 return True_Range; 6930 end if; 6931 6932 -- If either range is False (empty), return the other 6933 6934 if Is_False (Left) then 6935 return Right; 6936 elsif Is_False (Right) then 6937 return Left; 6938 end if; 6939 6940 -- Initialize result first entry from left or right operand depending 6941 -- on which starts with the lower range. 6942 6943 if Left (SLeft).Lo < Right (SRight).Lo then 6944 FEnt := Left (SLeft); 6945 SLeft := SLeft + 1; 6946 else 6947 FEnt := Right (SRight); 6948 SRight := SRight + 1; 6949 end if; 6950 6951 -- This loop eats ranges from left and right operands that are 6952 -- contiguous with the first range we are gathering. 6953 6954 loop 6955 -- Eat first entry in left operand if contiguous or overlapped by 6956 -- gathered first operand of result. 6957 6958 if SLeft <= Left'Last 6959 and then Left (SLeft).Lo <= FEnt.Hi + 1 6960 then 6961 FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi); 6962 SLeft := SLeft + 1; 6963 6964 -- Eat first entry in right operand if contiguous or overlapped by 6965 -- gathered right operand of result. 6966 6967 elsif SRight <= Right'Last 6968 and then Right (SRight).Lo <= FEnt.Hi + 1 6969 then 6970 FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi); 6971 SRight := SRight + 1; 6972 6973 -- All done if no more entries to eat 6974 6975 else 6976 exit; 6977 end if; 6978 end loop; 6979 6980 -- Obtain result as the first entry we just computed, concatenated 6981 -- to the "or" of the remaining results (if one operand is empty, 6982 -- this will just concatenate with the other 6983 6984 return 6985 FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last)); 6986 end "or"; 6987 6988 ----------------- 6989 -- Build_Range -- 6990 ----------------- 6991 6992 function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is 6993 Result : Node_Id; 6994 begin 6995 Result := 6996 Make_Range (Loc, 6997 Low_Bound => Build_Val (Lo), 6998 High_Bound => Build_Val (Hi)); 6999 Set_Etype (Result, Btyp); 7000 Set_Analyzed (Result); 7001 return Result; 7002 end Build_Range; 7003 7004 --------------- 7005 -- Build_Val -- 7006 --------------- 7007 7008 function Build_Val (V : Uint) return Node_Id is 7009 Result : Node_Id; 7010 7011 begin 7012 if Is_Enumeration_Type (Typ) then 7013 Result := Get_Enum_Lit_From_Pos (Typ, V, Loc); 7014 else 7015 Result := Make_Integer_Literal (Loc, V); 7016 end if; 7017 7018 Set_Etype (Result, Btyp); 7019 Set_Is_Static_Expression (Result); 7020 Set_Analyzed (Result); 7021 return Result; 7022 end Build_Val; 7023 7024 --------------- 7025 -- Get_RList -- 7026 --------------- 7027 7028 function Get_RList (Exp : Node_Id) return RList is 7029 Op : Node_Kind; 7030 Val : Uint; 7031 7032 begin 7033 -- Static expression can only be true or false 7034 7035 if Is_OK_Static_Expression (Exp) then 7036 if Expr_Value (Exp) = 0 then 7037 return False_Range; 7038 else 7039 return True_Range; 7040 end if; 7041 end if; 7042 7043 -- Otherwise test node type 7044 7045 Op := Nkind (Exp); 7046 7047 case Op is 7048 7049 -- And 7050 7051 when N_Op_And | N_And_Then => 7052 return Get_RList (Left_Opnd (Exp)) 7053 and 7054 Get_RList (Right_Opnd (Exp)); 7055 7056 -- Or 7057 7058 when N_Op_Or | N_Or_Else => 7059 return Get_RList (Left_Opnd (Exp)) 7060 or 7061 Get_RList (Right_Opnd (Exp)); 7062 7063 -- Not 7064 7065 when N_Op_Not => 7066 return not Get_RList (Right_Opnd (Exp)); 7067 7068 -- Comparisons of type with static value 7069 7070 when N_Op_Compare => 7071 7072 -- Type is left operand 7073 7074 if Is_Type_Ref (Left_Opnd (Exp)) 7075 and then Is_OK_Static_Expression (Right_Opnd (Exp)) 7076 then 7077 Val := Expr_Value (Right_Opnd (Exp)); 7078 7079 -- Typ is right operand 7080 7081 elsif Is_Type_Ref (Right_Opnd (Exp)) 7082 and then Is_OK_Static_Expression (Left_Opnd (Exp)) 7083 then 7084 Val := Expr_Value (Left_Opnd (Exp)); 7085 7086 -- Invert sense of comparison 7087 7088 case Op is 7089 when N_Op_Gt => Op := N_Op_Lt; 7090 when N_Op_Lt => Op := N_Op_Gt; 7091 when N_Op_Ge => Op := N_Op_Le; 7092 when N_Op_Le => Op := N_Op_Ge; 7093 when others => null; 7094 end case; 7095 7096 -- Other cases are non-static 7097 7098 else 7099 raise Non_Static; 7100 end if; 7101 7102 -- Construct range according to comparison operation 7103 7104 case Op is 7105 when N_Op_Eq => 7106 return RList'(1 => REnt'(Val, Val)); 7107 7108 when N_Op_Ge => 7109 return RList'(1 => REnt'(Val, BHi)); 7110 7111 when N_Op_Gt => 7112 return RList'(1 => REnt'(Val + 1, BHi)); 7113 7114 when N_Op_Le => 7115 return RList'(1 => REnt'(BLo, Val)); 7116 7117 when N_Op_Lt => 7118 return RList'(1 => REnt'(BLo, Val - 1)); 7119 7120 when N_Op_Ne => 7121 return RList'(REnt'(BLo, Val - 1), REnt'(Val + 1, BHi)); 7122 7123 when others => 7124 raise Program_Error; 7125 end case; 7126 7127 -- Membership (IN) 7128 7129 when N_In => 7130 if not Is_Type_Ref (Left_Opnd (Exp)) then 7131 raise Non_Static; 7132 end if; 7133 7134 if Present (Right_Opnd (Exp)) then 7135 return Membership_Entry (Right_Opnd (Exp)); 7136 else 7137 return Membership_Entries (First (Alternatives (Exp))); 7138 end if; 7139 7140 -- Negative membership (NOT IN) 7141 7142 when N_Not_In => 7143 if not Is_Type_Ref (Left_Opnd (Exp)) then 7144 raise Non_Static; 7145 end if; 7146 7147 if Present (Right_Opnd (Exp)) then 7148 return not Membership_Entry (Right_Opnd (Exp)); 7149 else 7150 return not Membership_Entries (First (Alternatives (Exp))); 7151 end if; 7152 7153 -- Function call, may be call to static predicate 7154 7155 when N_Function_Call => 7156 if Is_Entity_Name (Name (Exp)) then 7157 declare 7158 Ent : constant Entity_Id := Entity (Name (Exp)); 7159 begin 7160 if Is_Predicate_Function (Ent) 7161 or else 7162 Is_Predicate_Function_M (Ent) 7163 then 7164 return Stat_Pred (Etype (First_Formal (Ent))); 7165 end if; 7166 end; 7167 end if; 7168 7169 -- Other function call cases are non-static 7170 7171 raise Non_Static; 7172 7173 -- Qualified expression, dig out the expression 7174 7175 when N_Qualified_Expression => 7176 return Get_RList (Expression (Exp)); 7177 7178 when N_Case_Expression => 7179 declare 7180 Alt : Node_Id; 7181 Choices : List_Id; 7182 Dep : Node_Id; 7183 7184 begin 7185 if not Is_Entity_Name (Expression (Expr)) 7186 or else Etype (Expression (Expr)) /= Typ 7187 then 7188 Error_Msg_N 7189 ("expression must denaote subtype", Expression (Expr)); 7190 return False_Range; 7191 end if; 7192 7193 -- Collect discrete choices in all True alternatives 7194 7195 Choices := New_List; 7196 Alt := First (Alternatives (Exp)); 7197 while Present (Alt) loop 7198 Dep := Expression (Alt); 7199 7200 if not Is_OK_Static_Expression (Dep) then 7201 raise Non_Static; 7202 7203 elsif Is_True (Expr_Value (Dep)) then 7204 Append_List_To (Choices, 7205 New_Copy_List (Discrete_Choices (Alt))); 7206 end if; 7207 7208 Next (Alt); 7209 end loop; 7210 7211 return Membership_Entries (First (Choices)); 7212 end; 7213 7214 -- Expression with actions: if no actions, dig out expression 7215 7216 when N_Expression_With_Actions => 7217 if Is_Empty_List (Actions (Exp)) then 7218 return Get_RList (Expression (Exp)); 7219 else 7220 raise Non_Static; 7221 end if; 7222 7223 -- Xor operator 7224 7225 when N_Op_Xor => 7226 return (Get_RList (Left_Opnd (Exp)) 7227 and not Get_RList (Right_Opnd (Exp))) 7228 or (Get_RList (Right_Opnd (Exp)) 7229 and not Get_RList (Left_Opnd (Exp))); 7230 7231 -- Any other node type is non-static 7232 7233 when others => 7234 raise Non_Static; 7235 end case; 7236 end Get_RList; 7237 7238 ------------ 7239 -- Hi_Val -- 7240 ------------ 7241 7242 function Hi_Val (N : Node_Id) return Uint is 7243 begin 7244 if Is_OK_Static_Expression (N) then 7245 return Expr_Value (N); 7246 else 7247 pragma Assert (Nkind (N) = N_Range); 7248 return Expr_Value (High_Bound (N)); 7249 end if; 7250 end Hi_Val; 7251 7252 -------------- 7253 -- Is_False -- 7254 -------------- 7255 7256 function Is_False (R : RList) return Boolean is 7257 begin 7258 return R'Length = 0; 7259 end Is_False; 7260 7261 ------------- 7262 -- Is_True -- 7263 ------------- 7264 7265 function Is_True (R : RList) return Boolean is 7266 begin 7267 return R'Length = 1 7268 and then R (R'First).Lo = BLo 7269 and then R (R'First).Hi = BHi; 7270 end Is_True; 7271 7272 ----------------- 7273 -- Is_Type_Ref -- 7274 ----------------- 7275 7276 function Is_Type_Ref (N : Node_Id) return Boolean is 7277 begin 7278 return Nkind (N) = N_Identifier 7279 and then Chars (N) = Nam 7280 and then Paren_Count (N) = 0; 7281 end Is_Type_Ref; 7282 7283 ------------ 7284 -- Lo_Val -- 7285 ------------ 7286 7287 function Lo_Val (N : Node_Id) return Uint is 7288 begin 7289 if Is_OK_Static_Expression (N) then 7290 return Expr_Value (N); 7291 else 7292 pragma Assert (Nkind (N) = N_Range); 7293 return Expr_Value (Low_Bound (N)); 7294 end if; 7295 end Lo_Val; 7296 7297 ------------------------ 7298 -- Membership_Entries -- 7299 ------------------------ 7300 7301 function Membership_Entries (N : Node_Id) return RList is 7302 begin 7303 if No (Next (N)) then 7304 return Membership_Entry (N); 7305 else 7306 return Membership_Entry (N) or Membership_Entries (Next (N)); 7307 end if; 7308 end Membership_Entries; 7309 7310 ---------------------- 7311 -- Membership_Entry -- 7312 ---------------------- 7313 7314 function Membership_Entry (N : Node_Id) return RList is 7315 Val : Uint; 7316 SLo : Uint; 7317 SHi : Uint; 7318 7319 begin 7320 -- Range case 7321 7322 if Nkind (N) = N_Range then 7323 if not Is_OK_Static_Expression (Low_Bound (N)) 7324 or else 7325 not Is_OK_Static_Expression (High_Bound (N)) 7326 then 7327 raise Non_Static; 7328 else 7329 SLo := Expr_Value (Low_Bound (N)); 7330 SHi := Expr_Value (High_Bound (N)); 7331 return RList'(1 => REnt'(SLo, SHi)); 7332 end if; 7333 7334 -- Static expression case 7335 7336 elsif Is_OK_Static_Expression (N) then 7337 Val := Expr_Value (N); 7338 return RList'(1 => REnt'(Val, Val)); 7339 7340 -- Identifier (other than static expression) case 7341 7342 else pragma Assert (Nkind (N) = N_Identifier); 7343 7344 -- Type case 7345 7346 if Is_Type (Entity (N)) then 7347 7348 -- If type has predicates, process them 7349 7350 if Has_Predicates (Entity (N)) then 7351 return Stat_Pred (Entity (N)); 7352 7353 -- For static subtype without predicates, get range 7354 7355 elsif Is_OK_Static_Subtype (Entity (N)) then 7356 SLo := Expr_Value (Type_Low_Bound (Entity (N))); 7357 SHi := Expr_Value (Type_High_Bound (Entity (N))); 7358 return RList'(1 => REnt'(SLo, SHi)); 7359 7360 -- Any other type makes us non-static 7361 7362 else 7363 raise Non_Static; 7364 end if; 7365 7366 -- Any other kind of identifier in predicate (e.g. a non-static 7367 -- expression value) means this is not a static predicate. 7368 7369 else 7370 raise Non_Static; 7371 end if; 7372 end if; 7373 end Membership_Entry; 7374 7375 --------------- 7376 -- Stat_Pred -- 7377 --------------- 7378 7379 function Stat_Pred (Typ : Entity_Id) return RList is 7380 begin 7381 -- Not static if type does not have static predicates 7382 7383 if not Has_Static_Predicate (Typ) then 7384 raise Non_Static; 7385 end if; 7386 7387 -- Otherwise we convert the predicate list to a range list 7388 7389 declare 7390 Spred : constant List_Id := Static_Discrete_Predicate (Typ); 7391 Result : RList (1 .. List_Length (Spred)); 7392 P : Node_Id; 7393 7394 begin 7395 P := First (Static_Discrete_Predicate (Typ)); 7396 for J in Result'Range loop 7397 Result (J) := REnt'(Lo_Val (P), Hi_Val (P)); 7398 Next (P); 7399 end loop; 7400 7401 return Result; 7402 end; 7403 end Stat_Pred; 7404 7405 -- Start of processing for Build_Discrete_Static_Predicate 7406 7407 begin 7408 -- Establish bounds for the predicate 7409 7410 if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then 7411 TLo := Expr_Value (Type_Low_Bound (Typ)); 7412 else 7413 TLo := BLo; 7414 end if; 7415 7416 if Compile_Time_Known_Value (Type_High_Bound (Typ)) then 7417 THi := Expr_Value (Type_High_Bound (Typ)); 7418 else 7419 THi := BHi; 7420 end if; 7421 7422 -- Analyze the expression to see if it is a static predicate 7423 7424 declare 7425 Ranges : constant RList := Get_RList (Expr); 7426 -- Range list from expression if it is static 7427 7428 Plist : List_Id; 7429 7430 begin 7431 -- Convert range list into a form for the static predicate. In the 7432 -- Ranges array, we just have raw ranges, these must be converted 7433 -- to properly typed and analyzed static expressions or range nodes. 7434 7435 -- Note: here we limit ranges to the ranges of the subtype, so that 7436 -- a predicate is always false for values outside the subtype. That 7437 -- seems fine, such values are invalid anyway, and considering them 7438 -- to fail the predicate seems allowed and friendly, and furthermore 7439 -- simplifies processing for case statements and loops. 7440 7441 Plist := New_List; 7442 7443 for J in Ranges'Range loop 7444 declare 7445 Lo : Uint := Ranges (J).Lo; 7446 Hi : Uint := Ranges (J).Hi; 7447 7448 begin 7449 -- Ignore completely out of range entry 7450 7451 if Hi < TLo or else Lo > THi then 7452 null; 7453 7454 -- Otherwise process entry 7455 7456 else 7457 -- Adjust out of range value to subtype range 7458 7459 if Lo < TLo then 7460 Lo := TLo; 7461 end if; 7462 7463 if Hi > THi then 7464 Hi := THi; 7465 end if; 7466 7467 -- Convert range into required form 7468 7469 Append_To (Plist, Build_Range (Lo, Hi)); 7470 end if; 7471 end; 7472 end loop; 7473 7474 -- Processing was successful and all entries were static, so now we 7475 -- can store the result as the predicate list. 7476 7477 Set_Static_Discrete_Predicate (Typ, Plist); 7478 7479 -- The processing for static predicates put the expression into 7480 -- canonical form as a series of ranges. It also eliminated 7481 -- duplicates and collapsed and combined ranges. We might as well 7482 -- replace the alternatives list of the right operand of the 7483 -- membership test with the static predicate list, which will 7484 -- usually be more efficient. 7485 7486 declare 7487 New_Alts : constant List_Id := New_List; 7488 Old_Node : Node_Id; 7489 New_Node : Node_Id; 7490 7491 begin 7492 Old_Node := First (Plist); 7493 while Present (Old_Node) loop 7494 New_Node := New_Copy (Old_Node); 7495 7496 if Nkind (New_Node) = N_Range then 7497 Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node))); 7498 Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node))); 7499 end if; 7500 7501 Append_To (New_Alts, New_Node); 7502 Next (Old_Node); 7503 end loop; 7504 7505 -- If empty list, replace by False 7506 7507 if Is_Empty_List (New_Alts) then 7508 Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc)); 7509 7510 -- Else replace by set membership test 7511 7512 else 7513 Rewrite (Expr, 7514 Make_In (Loc, 7515 Left_Opnd => Make_Identifier (Loc, Nam), 7516 Right_Opnd => Empty, 7517 Alternatives => New_Alts)); 7518 7519 -- Resolve new expression in function context 7520 7521 Install_Formals (Predicate_Function (Typ)); 7522 Push_Scope (Predicate_Function (Typ)); 7523 Analyze_And_Resolve (Expr, Standard_Boolean); 7524 Pop_Scope; 7525 end if; 7526 end; 7527 end; 7528 7529 -- If non-static, return doing nothing 7530 7531 exception 7532 when Non_Static => 7533 return; 7534 end Build_Discrete_Static_Predicate; 7535 7536 ------------------------------------------- 7537 -- Build_Invariant_Procedure_Declaration -- 7538 ------------------------------------------- 7539 7540 function Build_Invariant_Procedure_Declaration 7541 (Typ : Entity_Id) return Node_Id 7542 is 7543 Loc : constant Source_Ptr := Sloc (Typ); 7544 Object_Entity : constant Entity_Id := 7545 Make_Defining_Identifier (Loc, New_Internal_Name ('I')); 7546 Spec : Node_Id; 7547 SId : Entity_Id; 7548 7549 begin 7550 Set_Etype (Object_Entity, Typ); 7551 7552 -- Check for duplicate definiations. 7553 7554 if Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)) then 7555 return Empty; 7556 end if; 7557 7558 SId := 7559 Make_Defining_Identifier (Loc, 7560 Chars => New_External_Name (Chars (Typ), "Invariant")); 7561 Set_Has_Invariants (Typ); 7562 Set_Ekind (SId, E_Procedure); 7563 Set_Etype (SId, Standard_Void_Type); 7564 Set_Is_Invariant_Procedure (SId); 7565 Set_Invariant_Procedure (Typ, SId); 7566 7567 Spec := 7568 Make_Procedure_Specification (Loc, 7569 Defining_Unit_Name => SId, 7570 Parameter_Specifications => New_List ( 7571 Make_Parameter_Specification (Loc, 7572 Defining_Identifier => Object_Entity, 7573 Parameter_Type => New_Occurrence_Of (Typ, Loc)))); 7574 7575 return Make_Subprogram_Declaration (Loc, Specification => Spec); 7576 end Build_Invariant_Procedure_Declaration; 7577 7578 ------------------------------- 7579 -- Build_Invariant_Procedure -- 7580 ------------------------------- 7581 7582 -- The procedure that is constructed here has the form 7583 7584 -- procedure typInvariant (Ixxx : typ) is 7585 -- begin 7586 -- pragma Check (Invariant, exp, "failed invariant from xxx"); 7587 -- pragma Check (Invariant, exp, "failed invariant from xxx"); 7588 -- ... 7589 -- pragma Check (Invariant, exp, "failed inherited invariant from xxx"); 7590 -- ... 7591 -- end typInvariant; 7592 7593 procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is 7594 Loc : constant Source_Ptr := Sloc (Typ); 7595 Stmts : List_Id; 7596 Spec : Node_Id; 7597 SId : Entity_Id; 7598 PDecl : Node_Id; 7599 PBody : Node_Id; 7600 7601 Nam : Name_Id; 7602 -- Name for Check pragma, usually Invariant, but might be Type_Invariant 7603 -- if we come from a Type_Invariant aspect, we make sure to build the 7604 -- Check pragma with the right name, so that Check_Policy works right. 7605 7606 Visible_Decls : constant List_Id := Visible_Declarations (N); 7607 Private_Decls : constant List_Id := Private_Declarations (N); 7608 7609 procedure Add_Invariants (T : Entity_Id; Inherit : Boolean); 7610 -- Appends statements to Stmts for any invariants in the rep item chain 7611 -- of the given type. If Inherit is False, then we only process entries 7612 -- on the chain for the type Typ. If Inherit is True, then we ignore any 7613 -- Invariant aspects, but we process all Invariant'Class aspects, adding 7614 -- "inherited" to the exception message and generating an informational 7615 -- message about the inheritance of an invariant. 7616 7617 Object_Name : Name_Id; 7618 -- Name for argument of invariant procedure 7619 7620 Object_Entity : Node_Id; 7621 -- The entity of the formal for the procedure 7622 7623 -------------------- 7624 -- Add_Invariants -- 7625 -------------------- 7626 7627 procedure Add_Invariants (T : Entity_Id; Inherit : Boolean) is 7628 Ritem : Node_Id; 7629 Arg1 : Node_Id; 7630 Arg2 : Node_Id; 7631 Arg3 : Node_Id; 7632 Exp : Node_Id; 7633 Loc : Source_Ptr; 7634 Assoc : List_Id; 7635 Str : String_Id; 7636 7637 procedure Replace_Type_Reference (N : Node_Id); 7638 -- Replace a single occurrence N of the subtype name with a reference 7639 -- to the formal of the predicate function. N can be an identifier 7640 -- referencing the subtype, or a selected component, representing an 7641 -- appropriately qualified occurrence of the subtype name. 7642 7643 procedure Replace_Type_References is 7644 new Replace_Type_References_Generic (Replace_Type_Reference); 7645 -- Traverse an expression replacing all occurrences of the subtype 7646 -- name with appropriate references to the object that is the formal 7647 -- parameter of the predicate function. Note that we must ensure 7648 -- that the type and entity information is properly set in the 7649 -- replacement node, since we will do a Preanalyze call of this 7650 -- expression without proper visibility of the procedure argument. 7651 7652 ---------------------------- 7653 -- Replace_Type_Reference -- 7654 ---------------------------- 7655 7656 -- Note: See comments in Add_Predicates.Replace_Type_Reference 7657 -- regarding handling of Sloc and Comes_From_Source. 7658 7659 procedure Replace_Type_Reference (N : Node_Id) is 7660 begin 7661 7662 -- Add semantic information to node to be rewritten, for ASIS 7663 -- navigation needs. 7664 7665 if Nkind (N) = N_Identifier then 7666 Set_Entity (N, T); 7667 Set_Etype (N, T); 7668 7669 elsif Nkind (N) = N_Selected_Component then 7670 Analyze (Prefix (N)); 7671 Set_Entity (Selector_Name (N), T); 7672 Set_Etype (Selector_Name (N), T); 7673 end if; 7674 7675 -- Invariant'Class, replace with T'Class (obj) 7676 -- In ASIS mode, an inherited item is analyzed already, and the 7677 -- replacement has been done, so do not repeat transformation 7678 -- to prevent ill-formed tree. 7679 7680 if Class_Present (Ritem) then 7681 if ASIS_Mode 7682 and then Nkind (Parent (N)) = N_Attribute_Reference 7683 and then Attribute_Name (Parent (N)) = Name_Class 7684 then 7685 null; 7686 7687 else 7688 Rewrite (N, 7689 Make_Type_Conversion (Sloc (N), 7690 Subtype_Mark => 7691 Make_Attribute_Reference (Sloc (N), 7692 Prefix => New_Occurrence_Of (T, Sloc (N)), 7693 Attribute_Name => Name_Class), 7694 Expression => 7695 Make_Identifier (Sloc (N), Object_Name))); 7696 7697 Set_Entity (Expression (N), Object_Entity); 7698 Set_Etype (Expression (N), Typ); 7699 end if; 7700 7701 -- Invariant, replace with obj 7702 7703 else 7704 Rewrite (N, Make_Identifier (Sloc (N), Object_Name)); 7705 Set_Entity (N, Object_Entity); 7706 Set_Etype (N, Typ); 7707 end if; 7708 7709 Set_Comes_From_Source (N, True); 7710 end Replace_Type_Reference; 7711 7712 -- Start of processing for Add_Invariants 7713 7714 begin 7715 Ritem := First_Rep_Item (T); 7716 while Present (Ritem) loop 7717 if Nkind (Ritem) = N_Pragma 7718 and then Pragma_Name (Ritem) = Name_Invariant 7719 then 7720 Arg1 := First (Pragma_Argument_Associations (Ritem)); 7721 Arg2 := Next (Arg1); 7722 Arg3 := Next (Arg2); 7723 7724 Arg1 := Get_Pragma_Arg (Arg1); 7725 Arg2 := Get_Pragma_Arg (Arg2); 7726 7727 -- For Inherit case, ignore Invariant, process only Class case 7728 7729 if Inherit then 7730 if not Class_Present (Ritem) then 7731 goto Continue; 7732 end if; 7733 7734 -- For Inherit false, process only item for right type 7735 7736 else 7737 if Entity (Arg1) /= Typ then 7738 goto Continue; 7739 end if; 7740 end if; 7741 7742 if No (Stmts) then 7743 Stmts := Empty_List; 7744 end if; 7745 7746 Exp := New_Copy_Tree (Arg2); 7747 7748 -- Preserve sloc of original pragma Invariant 7749 7750 Loc := Sloc (Ritem); 7751 7752 -- We need to replace any occurrences of the name of the type 7753 -- with references to the object, converted to type'Class in 7754 -- the case of Invariant'Class aspects. 7755 7756 Replace_Type_References (Exp, T); 7757 7758 -- If this invariant comes from an aspect, find the aspect 7759 -- specification, and replace the saved expression because 7760 -- we need the subtype references replaced for the calls to 7761 -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point 7762 -- and Check_Aspect_At_End_Of_Declarations. 7763 7764 if From_Aspect_Specification (Ritem) then 7765 declare 7766 Aitem : Node_Id; 7767 7768 begin 7769 -- Loop to find corresponding aspect, note that this 7770 -- must be present given the pragma is marked delayed. 7771 7772 -- Note: in practice Next_Rep_Item (Ritem) is Empty so 7773 -- this loop does nothing. Furthermore, why isn't this 7774 -- simply Corresponding_Aspect ??? 7775 7776 Aitem := Next_Rep_Item (Ritem); 7777 while Present (Aitem) loop 7778 if Nkind (Aitem) = N_Aspect_Specification 7779 and then Aspect_Rep_Item (Aitem) = Ritem 7780 then 7781 Set_Entity 7782 (Identifier (Aitem), New_Copy_Tree (Exp)); 7783 exit; 7784 end if; 7785 7786 Aitem := Next_Rep_Item (Aitem); 7787 end loop; 7788 end; 7789 end if; 7790 7791 -- Now we need to preanalyze the expression to properly capture 7792 -- the visibility in the visible part. The expression will not 7793 -- be analyzed for real until the body is analyzed, but that is 7794 -- at the end of the private part and has the wrong visibility. 7795 7796 Set_Parent (Exp, N); 7797 Preanalyze_Assert_Expression (Exp, Any_Boolean); 7798 7799 -- A class-wide invariant may be inherited in a separate unit, 7800 -- where the corresponding expression cannot be resolved by 7801 -- visibility, because it refers to a local function. Propagate 7802 -- semantic information to the original representation item, to 7803 -- be used when an invariant procedure for a derived type is 7804 -- constructed. 7805 7806 -- Unclear how to handle class-wide invariants that are not 7807 -- function calls ??? 7808 7809 if not Inherit 7810 and then Class_Present (Ritem) 7811 and then Nkind (Exp) = N_Function_Call 7812 and then Nkind (Arg2) = N_Indexed_Component 7813 then 7814 Rewrite (Arg2, 7815 Make_Function_Call (Loc, 7816 Name => 7817 New_Occurrence_Of (Entity (Name (Exp)), Loc), 7818 Parameter_Associations => 7819 New_Copy_List (Expressions (Arg2)))); 7820 end if; 7821 7822 -- In ASIS mode, even if assertions are not enabled, we must 7823 -- analyze the original expression in the aspect specification 7824 -- because it is part of the original tree. 7825 7826 if ASIS_Mode and then From_Aspect_Specification (Ritem) then 7827 declare 7828 Inv : constant Node_Id := 7829 Expression (Corresponding_Aspect (Ritem)); 7830 begin 7831 Replace_Type_References (Inv, T); 7832 Preanalyze_Assert_Expression (Inv, Standard_Boolean); 7833 end; 7834 end if; 7835 7836 -- Get name to be used for Check pragma 7837 7838 if not From_Aspect_Specification (Ritem) then 7839 Nam := Name_Invariant; 7840 else 7841 Nam := Chars (Identifier (Corresponding_Aspect (Ritem))); 7842 end if; 7843 7844 -- Build first two arguments for Check pragma 7845 7846 Assoc := 7847 New_List ( 7848 Make_Pragma_Argument_Association (Loc, 7849 Expression => Make_Identifier (Loc, Chars => Nam)), 7850 Make_Pragma_Argument_Association (Loc, 7851 Expression => Exp)); 7852 7853 -- Add message if present in Invariant pragma 7854 7855 if Present (Arg3) then 7856 Str := Strval (Get_Pragma_Arg (Arg3)); 7857 7858 -- If inherited case, and message starts "failed invariant", 7859 -- change it to be "failed inherited invariant". 7860 7861 if Inherit then 7862 String_To_Name_Buffer (Str); 7863 7864 if Name_Buffer (1 .. 16) = "failed invariant" then 7865 Insert_Str_In_Name_Buffer ("inherited ", 8); 7866 Str := String_From_Name_Buffer; 7867 end if; 7868 end if; 7869 7870 Append_To (Assoc, 7871 Make_Pragma_Argument_Association (Loc, 7872 Expression => Make_String_Literal (Loc, Str))); 7873 end if; 7874 7875 -- Add Check pragma to list of statements 7876 7877 Append_To (Stmts, 7878 Make_Pragma (Loc, 7879 Pragma_Identifier => 7880 Make_Identifier (Loc, Name_Check), 7881 Pragma_Argument_Associations => Assoc)); 7882 7883 -- If Inherited case and option enabled, output info msg. Note 7884 -- that we know this is a case of Invariant'Class. 7885 7886 if Inherit and Opt.List_Inherited_Aspects then 7887 Error_Msg_Sloc := Sloc (Ritem); 7888 Error_Msg_N 7889 ("info: & inherits `Invariant''Class` aspect from #?L?", 7890 Typ); 7891 end if; 7892 end if; 7893 7894 <<Continue>> 7895 Next_Rep_Item (Ritem); 7896 end loop; 7897 end Add_Invariants; 7898 7899 -- Start of processing for Build_Invariant_Procedure 7900 7901 begin 7902 Stmts := No_List; 7903 PDecl := Empty; 7904 PBody := Empty; 7905 SId := Empty; 7906 7907 -- If the aspect specification exists for some view of the type, the 7908 -- declaration for the procedure has been created. 7909 7910 if Has_Invariants (Typ) then 7911 SId := Invariant_Procedure (Typ); 7912 end if; 7913 7914 -- If the body is already present, nothing to do. This will occur when 7915 -- the type is already frozen, which is the case when the invariant 7916 -- appears in a private part, and the freezing takes place before the 7917 -- final pass over full declarations. 7918 7919 -- See Exp_Ch3.Insert_Component_Invariant_Checks for details. 7920 7921 if Present (SId) then 7922 PDecl := Unit_Declaration_Node (SId); 7923 7924 if Present (PDecl) 7925 and then Nkind (PDecl) = N_Subprogram_Declaration 7926 and then Present (Corresponding_Body (PDecl)) 7927 then 7928 return; 7929 end if; 7930 7931 else 7932 PDecl := Build_Invariant_Procedure_Declaration (Typ); 7933 end if; 7934 7935 -- Recover formal of procedure, for use in the calls to invariant 7936 -- functions (including inherited ones). 7937 7938 Object_Entity := 7939 Defining_Identifier 7940 (First (Parameter_Specifications (Specification (PDecl)))); 7941 Object_Name := Chars (Object_Entity); 7942 7943 -- Add invariants for the current type 7944 7945 Add_Invariants (Typ, Inherit => False); 7946 7947 -- Add invariants for parent types 7948 7949 declare 7950 Current_Typ : Entity_Id; 7951 Parent_Typ : Entity_Id; 7952 7953 begin 7954 Current_Typ := Typ; 7955 loop 7956 Parent_Typ := Etype (Current_Typ); 7957 7958 if Is_Private_Type (Parent_Typ) 7959 and then Present (Full_View (Base_Type (Parent_Typ))) 7960 then 7961 Parent_Typ := Full_View (Base_Type (Parent_Typ)); 7962 end if; 7963 7964 exit when Parent_Typ = Current_Typ; 7965 7966 Current_Typ := Parent_Typ; 7967 Add_Invariants (Current_Typ, Inherit => True); 7968 end loop; 7969 end; 7970 7971 -- Add invariants of progenitors 7972 7973 if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then 7974 declare 7975 Ifaces_List : Elist_Id; 7976 AI : Elmt_Id; 7977 Iface : Entity_Id; 7978 7979 begin 7980 Collect_Interfaces (Typ, Ifaces_List); 7981 7982 AI := First_Elmt (Ifaces_List); 7983 while Present (AI) loop 7984 Iface := Node (AI); 7985 7986 if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then 7987 Add_Invariants (Iface, Inherit => True); 7988 end if; 7989 7990 Next_Elmt (AI); 7991 end loop; 7992 end; 7993 end if; 7994 7995 -- Build the procedure if we generated at least one Check pragma 7996 7997 if Stmts /= No_List then 7998 Spec := Copy_Separate_Tree (Specification (PDecl)); 7999 8000 PBody := 8001 Make_Subprogram_Body (Loc, 8002 Specification => Spec, 8003 Declarations => Empty_List, 8004 Handled_Statement_Sequence => 8005 Make_Handled_Sequence_Of_Statements (Loc, 8006 Statements => Stmts)); 8007 8008 -- Insert procedure declaration and spec at the appropriate points. 8009 -- If declaration is already analyzed, it was processed by the 8010 -- generated pragma. 8011 8012 if Present (Private_Decls) then 8013 8014 -- The spec goes at the end of visible declarations, but they have 8015 -- already been analyzed, so we need to explicitly do the analyze. 8016 8017 if not Analyzed (PDecl) then 8018 Append_To (Visible_Decls, PDecl); 8019 Analyze (PDecl); 8020 end if; 8021 8022 -- The body goes at the end of the private declarations, which we 8023 -- have not analyzed yet, so we do not need to perform an explicit 8024 -- analyze call. We skip this if there are no private declarations 8025 -- (this is an error that will be caught elsewhere); 8026 8027 Append_To (Private_Decls, PBody); 8028 8029 -- If the invariant appears on the full view of a type, the 8030 -- analysis of the private part is complete, and we must 8031 -- analyze the new body explicitly. 8032 8033 if In_Private_Part (Current_Scope) then 8034 Analyze (PBody); 8035 end if; 8036 8037 -- If there are no private declarations this may be an error that 8038 -- will be diagnosed elsewhere. However, if this is a non-private 8039 -- type that inherits invariants, it needs no completion and there 8040 -- may be no private part. In this case insert invariant procedure 8041 -- at end of current declarative list, and analyze at once, given 8042 -- that the type is about to be frozen. 8043 8044 elsif not Is_Private_Type (Typ) then 8045 Append_To (Visible_Decls, PDecl); 8046 Append_To (Visible_Decls, PBody); 8047 Analyze (PDecl); 8048 Analyze (PBody); 8049 end if; 8050 end if; 8051 end Build_Invariant_Procedure; 8052 8053 ------------------------------- 8054 -- Build_Predicate_Functions -- 8055 ------------------------------- 8056 8057 -- The procedures that are constructed here have the form: 8058 8059 -- function typPredicate (Ixxx : typ) return Boolean is 8060 -- begin 8061 -- return 8062 -- exp1 and then exp2 and then ... 8063 -- and then typ1Predicate (typ1 (Ixxx)) 8064 -- and then typ2Predicate (typ2 (Ixxx)) 8065 -- and then ...; 8066 -- end typPredicate; 8067 8068 -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that 8069 -- this is the point at which these expressions get analyzed, providing the 8070 -- required delay, and typ1, typ2, are entities from which predicates are 8071 -- inherited. Note that we do NOT generate Check pragmas, that's because we 8072 -- use this function even if checks are off, e.g. for membership tests. 8073 8074 -- If the expression has at least one Raise_Expression, then we also build 8075 -- the typPredicateM version of the function, in which any occurrence of a 8076 -- Raise_Expression is converted to "return False". 8077 8078 procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is 8079 Loc : constant Source_Ptr := Sloc (Typ); 8080 8081 Expr : Node_Id; 8082 -- This is the expression for the result of the function. It is 8083 -- is build by connecting the component predicates with AND THEN. 8084 8085 Expr_M : Node_Id; 8086 -- This is the corresponding return expression for the Predicate_M 8087 -- function. It differs in that raise expressions are marked for 8088 -- special expansion (see Process_REs). 8089 8090 Object_Name : constant Name_Id := New_Internal_Name ('I'); 8091 -- Name for argument of Predicate procedure. Note that we use the same 8092 -- name for both predicate functions. That way the reference within the 8093 -- predicate expression is the same in both functions. 8094 8095 Object_Entity : constant Entity_Id := 8096 Make_Defining_Identifier (Loc, Chars => Object_Name); 8097 -- Entity for argument of Predicate procedure 8098 8099 Object_Entity_M : constant Entity_Id := 8100 Make_Defining_Identifier (Loc, Chars => Object_Name); 8101 -- Entity for argument of Predicate_M procedure 8102 8103 Raise_Expression_Present : Boolean := False; 8104 -- Set True if Expr has at least one Raise_Expression 8105 8106 procedure Add_Call (T : Entity_Id); 8107 -- Includes a call to the predicate function for type T in Expr if T 8108 -- has predicates and Predicate_Function (T) is non-empty. 8109 8110 procedure Add_Predicates; 8111 -- Appends expressions for any Predicate pragmas in the rep item chain 8112 -- Typ to Expr. Note that we look only at items for this exact entity. 8113 -- Inheritance of predicates for the parent type is done by calling the 8114 -- Predicate_Function of the parent type, using Add_Call above. 8115 8116 function Test_RE (N : Node_Id) return Traverse_Result; 8117 -- Used in Test_REs, tests one node for being a raise expression, and if 8118 -- so sets Raise_Expression_Present True. 8119 8120 procedure Test_REs is new Traverse_Proc (Test_RE); 8121 -- Tests to see if Expr contains any raise expressions 8122 8123 function Process_RE (N : Node_Id) return Traverse_Result; 8124 -- Used in Process REs, tests if node N is a raise expression, and if 8125 -- so, marks it to be converted to return False. 8126 8127 procedure Process_REs is new Traverse_Proc (Process_RE); 8128 -- Marks any raise expressions in Expr_M to return False 8129 8130 -------------- 8131 -- Add_Call -- 8132 -------------- 8133 8134 procedure Add_Call (T : Entity_Id) is 8135 Exp : Node_Id; 8136 8137 begin 8138 if Present (T) and then Present (Predicate_Function (T)) then 8139 Set_Has_Predicates (Typ); 8140 8141 -- Build the call to the predicate function of T 8142 8143 Exp := 8144 Make_Predicate_Call 8145 (T, Convert_To (T, Make_Identifier (Loc, Object_Name))); 8146 8147 -- Add call to evolving expression, using AND THEN if needed 8148 8149 if No (Expr) then 8150 Expr := Exp; 8151 8152 else 8153 Expr := 8154 Make_And_Then (Sloc (Expr), 8155 Left_Opnd => Relocate_Node (Expr), 8156 Right_Opnd => Exp); 8157 end if; 8158 8159 -- Output info message on inheritance if required. Note we do not 8160 -- give this information for generic actual types, since it is 8161 -- unwelcome noise in that case in instantiations. We also 8162 -- generally suppress the message in instantiations, and also 8163 -- if it involves internal names. 8164 8165 if Opt.List_Inherited_Aspects 8166 and then not Is_Generic_Actual_Type (Typ) 8167 and then Instantiation_Depth (Sloc (Typ)) = 0 8168 and then not Is_Internal_Name (Chars (T)) 8169 and then not Is_Internal_Name (Chars (Typ)) 8170 then 8171 Error_Msg_Sloc := Sloc (Predicate_Function (T)); 8172 Error_Msg_Node_2 := T; 8173 Error_Msg_N ("info: & inherits predicate from & #?L?", Typ); 8174 end if; 8175 end if; 8176 end Add_Call; 8177 8178 -------------------- 8179 -- Add_Predicates -- 8180 -------------------- 8181 8182 procedure Add_Predicates is 8183 Ritem : Node_Id; 8184 Arg1 : Node_Id; 8185 Arg2 : Node_Id; 8186 8187 procedure Replace_Type_Reference (N : Node_Id); 8188 -- Replace a single occurrence N of the subtype name with a reference 8189 -- to the formal of the predicate function. N can be an identifier 8190 -- referencing the subtype, or a selected component, representing an 8191 -- appropriately qualified occurrence of the subtype name. 8192 8193 procedure Replace_Type_References is 8194 new Replace_Type_References_Generic (Replace_Type_Reference); 8195 -- Traverse an expression changing every occurrence of an identifier 8196 -- whose name matches the name of the subtype with a reference to 8197 -- the formal parameter of the predicate function. 8198 8199 ---------------------------- 8200 -- Replace_Type_Reference -- 8201 ---------------------------- 8202 8203 procedure Replace_Type_Reference (N : Node_Id) is 8204 begin 8205 Rewrite (N, Make_Identifier (Sloc (N), Object_Name)); 8206 -- Use the Sloc of the usage name, not the defining name 8207 8208 Set_Etype (N, Typ); 8209 Set_Entity (N, Object_Entity); 8210 8211 -- We want to treat the node as if it comes from source, so that 8212 -- ASIS will not ignore it 8213 8214 Set_Comes_From_Source (N, True); 8215 end Replace_Type_Reference; 8216 8217 -- Start of processing for Add_Predicates 8218 8219 begin 8220 Ritem := First_Rep_Item (Typ); 8221 while Present (Ritem) loop 8222 if Nkind (Ritem) = N_Pragma 8223 and then Pragma_Name (Ritem) = Name_Predicate 8224 then 8225 -- Acquire arguments 8226 8227 Arg1 := First (Pragma_Argument_Associations (Ritem)); 8228 Arg2 := Next (Arg1); 8229 8230 Arg1 := Get_Pragma_Arg (Arg1); 8231 Arg2 := Get_Pragma_Arg (Arg2); 8232 8233 -- See if this predicate pragma is for the current type or for 8234 -- its full view. A predicate on a private completion is placed 8235 -- on the partial view beause this is the visible entity that 8236 -- is frozen. 8237 8238 if Entity (Arg1) = Typ 8239 or else Full_View (Entity (Arg1)) = Typ 8240 then 8241 -- We have a match, this entry is for our subtype 8242 8243 -- We need to replace any occurrences of the name of the 8244 -- type with references to the object. 8245 8246 Replace_Type_References (Arg2, Typ); 8247 8248 -- If this predicate comes from an aspect, find the aspect 8249 -- specification, and replace the saved expression because 8250 -- we need the subtype references replaced for the calls to 8251 -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point 8252 -- and Check_Aspect_At_End_Of_Declarations. 8253 8254 if From_Aspect_Specification (Ritem) then 8255 declare 8256 Aitem : Node_Id; 8257 8258 begin 8259 -- Loop to find corresponding aspect, note that this 8260 -- must be present given the pragma is marked delayed. 8261 8262 Aitem := Next_Rep_Item (Ritem); 8263 loop 8264 if Nkind (Aitem) = N_Aspect_Specification 8265 and then Aspect_Rep_Item (Aitem) = Ritem 8266 then 8267 Set_Entity 8268 (Identifier (Aitem), New_Copy_Tree (Arg2)); 8269 exit; 8270 end if; 8271 8272 Aitem := Next_Rep_Item (Aitem); 8273 end loop; 8274 end; 8275 end if; 8276 8277 -- Now we can add the expression 8278 8279 if No (Expr) then 8280 Expr := Relocate_Node (Arg2); 8281 8282 -- There already was a predicate, so add to it 8283 8284 else 8285 Expr := 8286 Make_And_Then (Loc, 8287 Left_Opnd => Relocate_Node (Expr), 8288 Right_Opnd => Relocate_Node (Arg2)); 8289 end if; 8290 end if; 8291 end if; 8292 8293 Next_Rep_Item (Ritem); 8294 end loop; 8295 end Add_Predicates; 8296 8297 ---------------- 8298 -- Process_RE -- 8299 ---------------- 8300 8301 function Process_RE (N : Node_Id) return Traverse_Result is 8302 begin 8303 if Nkind (N) = N_Raise_Expression then 8304 Set_Convert_To_Return_False (N); 8305 return Skip; 8306 else 8307 return OK; 8308 end if; 8309 end Process_RE; 8310 8311 ------------- 8312 -- Test_RE -- 8313 ------------- 8314 8315 function Test_RE (N : Node_Id) return Traverse_Result is 8316 begin 8317 if Nkind (N) = N_Raise_Expression then 8318 Raise_Expression_Present := True; 8319 return Abandon; 8320 else 8321 return OK; 8322 end if; 8323 end Test_RE; 8324 8325 -- Start of processing for Build_Predicate_Functions 8326 8327 begin 8328 -- Return if already built or if type does not have predicates 8329 8330 if not Has_Predicates (Typ) 8331 or else Present (Predicate_Function (Typ)) 8332 then 8333 return; 8334 end if; 8335 8336 -- Prepare to construct predicate expression 8337 8338 Expr := Empty; 8339 8340 -- Add Predicates for the current type 8341 8342 Add_Predicates; 8343 8344 -- Add predicates for ancestor if present 8345 8346 declare 8347 Atyp : constant Entity_Id := Nearest_Ancestor (Typ); 8348 begin 8349 if Present (Atyp) then 8350 Add_Call (Atyp); 8351 end if; 8352 end; 8353 8354 -- Case where predicates are present 8355 8356 if Present (Expr) then 8357 8358 -- Test for raise expression present 8359 8360 Test_REs (Expr); 8361 8362 -- If raise expression is present, capture a copy of Expr for use 8363 -- in building the predicateM function version later on. For this 8364 -- copy we replace references to Object_Entity by Object_Entity_M. 8365 8366 if Raise_Expression_Present then 8367 declare 8368 Map : constant Elist_Id := New_Elmt_List; 8369 New_V : Entity_Id := Empty; 8370 8371 -- The unanalyzed expression will be copied and appear in 8372 -- both functions. Normally expressions do not declare new 8373 -- entities, but quantified expressions do, so we need to 8374 -- create new entities for their bound variables, to prevent 8375 -- multiple definitions in gigi. 8376 8377 function Reset_Loop_Variable (N : Node_Id) 8378 return Traverse_Result; 8379 8380 procedure Collect_Loop_Variables is 8381 new Traverse_Proc (Reset_Loop_Variable); 8382 8383 ------------------------ 8384 -- Reset_Loop_Variable -- 8385 ------------------------ 8386 8387 function Reset_Loop_Variable (N : Node_Id) 8388 return Traverse_Result 8389 is 8390 begin 8391 if Nkind (N) = N_Iterator_Specification then 8392 New_V := Make_Defining_Identifier 8393 (Sloc (N), Chars (Defining_Identifier (N))); 8394 8395 Set_Defining_Identifier (N, New_V); 8396 end if; 8397 8398 return OK; 8399 end Reset_Loop_Variable; 8400 8401 begin 8402 Append_Elmt (Object_Entity, Map); 8403 Append_Elmt (Object_Entity_M, Map); 8404 Expr_M := New_Copy_Tree (Expr, Map => Map); 8405 Collect_Loop_Variables (Expr_M); 8406 end; 8407 end if; 8408 8409 -- Build the main predicate function 8410 8411 declare 8412 SId : constant Entity_Id := 8413 Make_Defining_Identifier (Loc, 8414 Chars => New_External_Name (Chars (Typ), "Predicate")); 8415 -- The entity for the the function spec 8416 8417 SIdB : constant Entity_Id := 8418 Make_Defining_Identifier (Loc, 8419 Chars => New_External_Name (Chars (Typ), "Predicate")); 8420 -- The entity for the function body 8421 8422 Spec : Node_Id; 8423 FDecl : Node_Id; 8424 FBody : Node_Id; 8425 8426 begin 8427 -- Build function declaration 8428 8429 Set_Ekind (SId, E_Function); 8430 Set_Is_Internal (SId); 8431 Set_Is_Predicate_Function (SId); 8432 Set_Predicate_Function (Typ, SId); 8433 8434 -- The predicate function is shared between views of a type 8435 8436 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 8437 Set_Predicate_Function (Full_View (Typ), SId); 8438 end if; 8439 8440 Spec := 8441 Make_Function_Specification (Loc, 8442 Defining_Unit_Name => SId, 8443 Parameter_Specifications => New_List ( 8444 Make_Parameter_Specification (Loc, 8445 Defining_Identifier => Object_Entity, 8446 Parameter_Type => New_Occurrence_Of (Typ, Loc))), 8447 Result_Definition => 8448 New_Occurrence_Of (Standard_Boolean, Loc)); 8449 8450 FDecl := 8451 Make_Subprogram_Declaration (Loc, 8452 Specification => Spec); 8453 8454 -- Build function body 8455 8456 Spec := 8457 Make_Function_Specification (Loc, 8458 Defining_Unit_Name => SIdB, 8459 Parameter_Specifications => New_List ( 8460 Make_Parameter_Specification (Loc, 8461 Defining_Identifier => 8462 Make_Defining_Identifier (Loc, Object_Name), 8463 Parameter_Type => 8464 New_Occurrence_Of (Typ, Loc))), 8465 Result_Definition => 8466 New_Occurrence_Of (Standard_Boolean, Loc)); 8467 8468 FBody := 8469 Make_Subprogram_Body (Loc, 8470 Specification => Spec, 8471 Declarations => Empty_List, 8472 Handled_Statement_Sequence => 8473 Make_Handled_Sequence_Of_Statements (Loc, 8474 Statements => New_List ( 8475 Make_Simple_Return_Statement (Loc, 8476 Expression => Expr)))); 8477 8478 -- Insert declaration before freeze node and body after 8479 8480 Insert_Before_And_Analyze (N, FDecl); 8481 Insert_After_And_Analyze (N, FBody); 8482 end; 8483 8484 -- Test for raise expressions present and if so build M version 8485 8486 if Raise_Expression_Present then 8487 declare 8488 SId : constant Entity_Id := 8489 Make_Defining_Identifier (Loc, 8490 Chars => New_External_Name (Chars (Typ), "PredicateM")); 8491 -- The entity for the the function spec 8492 8493 SIdB : constant Entity_Id := 8494 Make_Defining_Identifier (Loc, 8495 Chars => New_External_Name (Chars (Typ), "PredicateM")); 8496 -- The entity for the function body 8497 8498 Spec : Node_Id; 8499 FDecl : Node_Id; 8500 FBody : Node_Id; 8501 BTemp : Entity_Id; 8502 8503 begin 8504 -- Mark any raise expressions for special expansion 8505 8506 Process_REs (Expr_M); 8507 8508 -- Build function declaration 8509 8510 Set_Ekind (SId, E_Function); 8511 Set_Is_Predicate_Function_M (SId); 8512 Set_Predicate_Function_M (Typ, SId); 8513 8514 -- The predicate function is shared between views of a type 8515 8516 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 8517 Set_Predicate_Function_M (Full_View (Typ), SId); 8518 end if; 8519 8520 Spec := 8521 Make_Function_Specification (Loc, 8522 Defining_Unit_Name => SId, 8523 Parameter_Specifications => New_List ( 8524 Make_Parameter_Specification (Loc, 8525 Defining_Identifier => Object_Entity_M, 8526 Parameter_Type => New_Occurrence_Of (Typ, Loc))), 8527 Result_Definition => 8528 New_Occurrence_Of (Standard_Boolean, Loc)); 8529 8530 FDecl := 8531 Make_Subprogram_Declaration (Loc, 8532 Specification => Spec); 8533 8534 -- Build function body 8535 8536 Spec := 8537 Make_Function_Specification (Loc, 8538 Defining_Unit_Name => SIdB, 8539 Parameter_Specifications => New_List ( 8540 Make_Parameter_Specification (Loc, 8541 Defining_Identifier => 8542 Make_Defining_Identifier (Loc, Object_Name), 8543 Parameter_Type => 8544 New_Occurrence_Of (Typ, Loc))), 8545 Result_Definition => 8546 New_Occurrence_Of (Standard_Boolean, Loc)); 8547 8548 -- Build the body, we declare the boolean expression before 8549 -- doing the return, because we are not really confident of 8550 -- what happens if a return appears within a return. 8551 8552 BTemp := 8553 Make_Defining_Identifier (Loc, 8554 Chars => New_Internal_Name ('B')); 8555 8556 FBody := 8557 Make_Subprogram_Body (Loc, 8558 Specification => Spec, 8559 8560 Declarations => New_List ( 8561 Make_Object_Declaration (Loc, 8562 Defining_Identifier => BTemp, 8563 Constant_Present => True, 8564 Object_Definition => 8565 New_Occurrence_Of (Standard_Boolean, Loc), 8566 Expression => Expr_M)), 8567 8568 Handled_Statement_Sequence => 8569 Make_Handled_Sequence_Of_Statements (Loc, 8570 Statements => New_List ( 8571 Make_Simple_Return_Statement (Loc, 8572 Expression => New_Occurrence_Of (BTemp, Loc))))); 8573 8574 -- Insert declaration before freeze node and body after 8575 8576 Insert_Before_And_Analyze (N, FDecl); 8577 Insert_After_And_Analyze (N, FBody); 8578 end; 8579 end if; 8580 8581 -- See if we have a static predicate. Note that the answer may be 8582 -- yes even if we have an explicit Dynamic_Predicate present. 8583 8584 declare 8585 PS : Boolean; 8586 EN : Node_Id; 8587 8588 begin 8589 if not Is_Scalar_Type (Typ) and then not Is_String_Type (Typ) then 8590 PS := False; 8591 else 8592 PS := Is_Predicate_Static (Expr, Object_Name); 8593 end if; 8594 8595 -- Case where we have a predicate-static aspect 8596 8597 if PS then 8598 8599 -- We don't set Has_Static_Predicate_Aspect, since we can have 8600 -- any of the three cases (Predicate, Dynamic_Predicate, or 8601 -- Static_Predicate) generating a predicate with an expression 8602 -- that is predicate-static. We just indicate that we have a 8603 -- predicate that can be treated as static. 8604 8605 Set_Has_Static_Predicate (Typ); 8606 8607 -- For discrete subtype, build the static predicate list 8608 8609 if Is_Discrete_Type (Typ) then 8610 Build_Discrete_Static_Predicate (Typ, Expr, Object_Name); 8611 8612 -- If we don't get a static predicate list, it means that we 8613 -- have a case where this is not possible, most typically in 8614 -- the case where we inherit a dynamic predicate. We do not 8615 -- consider this an error, we just leave the predicate as 8616 -- dynamic. But if we do succeed in building the list, then 8617 -- we mark the predicate as static. 8618 8619 if No (Static_Discrete_Predicate (Typ)) then 8620 Set_Has_Static_Predicate (Typ, False); 8621 end if; 8622 8623 -- For real or string subtype, save predicate expression 8624 8625 elsif Is_Real_Type (Typ) or else Is_String_Type (Typ) then 8626 Set_Static_Real_Or_String_Predicate (Typ, Expr); 8627 end if; 8628 8629 -- Case of dynamic predicate (expression is not predicate-static) 8630 8631 else 8632 -- Again, we don't set Has_Dynamic_Predicate_Aspect, since that 8633 -- is only set if we have an explicit Dynamic_Predicate aspect 8634 -- given. Here we may simply have a Predicate aspect where the 8635 -- expression happens not to be predicate-static. 8636 8637 -- Emit an error when the predicate is categorized as static 8638 -- but its expression is not predicate-static. 8639 8640 -- First a little fiddling to get a nice location for the 8641 -- message. If the expression is of the form (A and then B), 8642 -- then use the left operand for the Sloc. This avoids getting 8643 -- confused by a call to a higher-level predicate with a less 8644 -- convenient source location. 8645 8646 EN := Expr; 8647 while Nkind (EN) = N_And_Then loop 8648 EN := Left_Opnd (EN); 8649 end loop; 8650 8651 -- Now post appropriate message 8652 8653 if Has_Static_Predicate_Aspect (Typ) then 8654 if Is_Scalar_Type (Typ) or else Is_String_Type (Typ) then 8655 Error_Msg_F 8656 ("expression is not predicate-static (RM 3.2.4(16-22))", 8657 EN); 8658 else 8659 Error_Msg_F 8660 ("static predicate requires scalar or string type", EN); 8661 end if; 8662 end if; 8663 end if; 8664 end; 8665 end if; 8666 end Build_Predicate_Functions; 8667 8668 ----------------------------------------- 8669 -- Check_Aspect_At_End_Of_Declarations -- 8670 ----------------------------------------- 8671 8672 procedure Check_Aspect_At_End_Of_Declarations (ASN : Node_Id) is 8673 Ent : constant Entity_Id := Entity (ASN); 8674 Ident : constant Node_Id := Identifier (ASN); 8675 A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident)); 8676 8677 End_Decl_Expr : constant Node_Id := Entity (Ident); 8678 -- Expression to be analyzed at end of declarations 8679 8680 Freeze_Expr : constant Node_Id := Expression (ASN); 8681 -- Expression from call to Check_Aspect_At_Freeze_Point 8682 8683 T : constant Entity_Id := Etype (Freeze_Expr); 8684 -- Type required for preanalyze call 8685 8686 Err : Boolean; 8687 -- Set False if error 8688 8689 -- On entry to this procedure, Entity (Ident) contains a copy of the 8690 -- original expression from the aspect, saved for this purpose, and 8691 -- but Expression (Ident) is a preanalyzed copy of the expression, 8692 -- preanalyzed just after the freeze point. 8693 8694 procedure Check_Overloaded_Name; 8695 -- For aspects whose expression is simply a name, this routine checks if 8696 -- the name is overloaded or not. If so, it verifies there is an 8697 -- interpretation that matches the entity obtained at the freeze point, 8698 -- otherwise the compiler complains. 8699 8700 --------------------------- 8701 -- Check_Overloaded_Name -- 8702 --------------------------- 8703 8704 procedure Check_Overloaded_Name is 8705 begin 8706 if not Is_Overloaded (End_Decl_Expr) then 8707 Err := not Is_Entity_Name (End_Decl_Expr) 8708 or else Entity (End_Decl_Expr) /= Entity (Freeze_Expr); 8709 8710 else 8711 Err := True; 8712 8713 declare 8714 Index : Interp_Index; 8715 It : Interp; 8716 8717 begin 8718 Get_First_Interp (End_Decl_Expr, Index, It); 8719 while Present (It.Typ) loop 8720 if It.Nam = Entity (Freeze_Expr) then 8721 Err := False; 8722 exit; 8723 end if; 8724 8725 Get_Next_Interp (Index, It); 8726 end loop; 8727 end; 8728 end if; 8729 end Check_Overloaded_Name; 8730 8731 -- Start of processing for Check_Aspect_At_End_Of_Declarations 8732 8733 begin 8734 -- Case of aspects Dimension, Dimension_System and Synchronization 8735 8736 if A_Id = Aspect_Synchronization then 8737 return; 8738 8739 -- Case of stream attributes, just have to compare entities. However, 8740 -- the expression is just a name (possibly overloaded), and there may 8741 -- be stream operations declared for unrelated types, so we just need 8742 -- to verify that one of these interpretations is the one available at 8743 -- at the freeze point. 8744 8745 elsif A_Id = Aspect_Input or else 8746 A_Id = Aspect_Output or else 8747 A_Id = Aspect_Read or else 8748 A_Id = Aspect_Write 8749 then 8750 Analyze (End_Decl_Expr); 8751 Check_Overloaded_Name; 8752 8753 elsif A_Id = Aspect_Variable_Indexing or else 8754 A_Id = Aspect_Constant_Indexing or else 8755 A_Id = Aspect_Default_Iterator or else 8756 A_Id = Aspect_Iterator_Element 8757 then 8758 -- Make type unfrozen before analysis, to prevent spurious errors 8759 -- about late attributes. 8760 8761 Set_Is_Frozen (Ent, False); 8762 Analyze (End_Decl_Expr); 8763 Set_Is_Frozen (Ent, True); 8764 8765 -- If the end of declarations comes before any other freeze 8766 -- point, the Freeze_Expr is not analyzed: no check needed. 8767 8768 if Analyzed (Freeze_Expr) and then not In_Instance then 8769 Check_Overloaded_Name; 8770 else 8771 Err := False; 8772 end if; 8773 8774 -- All other cases 8775 8776 else 8777 -- Indicate that the expression comes from an aspect specification, 8778 -- which is used in subsequent analysis even if expansion is off. 8779 8780 Set_Parent (End_Decl_Expr, ASN); 8781 8782 -- In a generic context the aspect expressions have not been 8783 -- preanalyzed, so do it now. There are no conformance checks 8784 -- to perform in this case. 8785 8786 if No (T) then 8787 Check_Aspect_At_Freeze_Point (ASN); 8788 return; 8789 8790 -- The default values attributes may be defined in the private part, 8791 -- and the analysis of the expression may take place when only the 8792 -- partial view is visible. The expression must be scalar, so use 8793 -- the full view to resolve. 8794 8795 elsif (A_Id = Aspect_Default_Value 8796 or else 8797 A_Id = Aspect_Default_Component_Value) 8798 and then Is_Private_Type (T) 8799 then 8800 Preanalyze_Spec_Expression (End_Decl_Expr, Full_View (T)); 8801 8802 else 8803 Preanalyze_Spec_Expression (End_Decl_Expr, T); 8804 end if; 8805 8806 Err := not Fully_Conformant_Expressions (End_Decl_Expr, Freeze_Expr); 8807 end if; 8808 8809 -- Output error message if error. Force error on aspect specification 8810 -- even if there is an error on the expression itself. 8811 8812 if Err then 8813 Error_Msg_NE 8814 ("!visibility of aspect for& changes after freeze point", 8815 ASN, Ent); 8816 Error_Msg_NE 8817 ("info: & is frozen here, aspects evaluated at this point??", 8818 Freeze_Node (Ent), Ent); 8819 end if; 8820 end Check_Aspect_At_End_Of_Declarations; 8821 8822 ---------------------------------- 8823 -- Check_Aspect_At_Freeze_Point -- 8824 ---------------------------------- 8825 8826 procedure Check_Aspect_At_Freeze_Point (ASN : Node_Id) is 8827 Ident : constant Node_Id := Identifier (ASN); 8828 -- Identifier (use Entity field to save expression) 8829 8830 A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident)); 8831 8832 T : Entity_Id := Empty; 8833 -- Type required for preanalyze call 8834 8835 begin 8836 -- On entry to this procedure, Entity (Ident) contains a copy of the 8837 -- original expression from the aspect, saved for this purpose. 8838 8839 -- On exit from this procedure Entity (Ident) is unchanged, still 8840 -- containing that copy, but Expression (Ident) is a preanalyzed copy 8841 -- of the expression, preanalyzed just after the freeze point. 8842 8843 -- Make a copy of the expression to be preanalyzed 8844 8845 Set_Expression (ASN, New_Copy_Tree (Entity (Ident))); 8846 8847 -- Find type for preanalyze call 8848 8849 case A_Id is 8850 8851 -- No_Aspect should be impossible 8852 8853 when No_Aspect => 8854 raise Program_Error; 8855 8856 -- Aspects taking an optional boolean argument 8857 8858 when Boolean_Aspects | 8859 Library_Unit_Aspects => 8860 8861 T := Standard_Boolean; 8862 8863 -- Aspects corresponding to attribute definition clauses 8864 8865 when Aspect_Address => 8866 T := RTE (RE_Address); 8867 8868 when Aspect_Attach_Handler => 8869 T := RTE (RE_Interrupt_ID); 8870 8871 when Aspect_Bit_Order | Aspect_Scalar_Storage_Order => 8872 T := RTE (RE_Bit_Order); 8873 8874 when Aspect_Convention => 8875 return; 8876 8877 when Aspect_CPU => 8878 T := RTE (RE_CPU_Range); 8879 8880 -- Default_Component_Value is resolved with the component type 8881 8882 when Aspect_Default_Component_Value => 8883 T := Component_Type (Entity (ASN)); 8884 8885 when Aspect_Default_Storage_Pool => 8886 T := Class_Wide_Type (RTE (RE_Root_Storage_Pool)); 8887 8888 -- Default_Value is resolved with the type entity in question 8889 8890 when Aspect_Default_Value => 8891 T := Entity (ASN); 8892 8893 when Aspect_Dispatching_Domain => 8894 T := RTE (RE_Dispatching_Domain); 8895 8896 when Aspect_External_Tag => 8897 T := Standard_String; 8898 8899 when Aspect_External_Name => 8900 T := Standard_String; 8901 8902 when Aspect_Link_Name => 8903 T := Standard_String; 8904 8905 when Aspect_Priority | Aspect_Interrupt_Priority => 8906 T := Standard_Integer; 8907 8908 when Aspect_Relative_Deadline => 8909 T := RTE (RE_Time_Span); 8910 8911 when Aspect_Small => 8912 T := Universal_Real; 8913 8914 -- For a simple storage pool, we have to retrieve the type of the 8915 -- pool object associated with the aspect's corresponding attribute 8916 -- definition clause. 8917 8918 when Aspect_Simple_Storage_Pool => 8919 T := Etype (Expression (Aspect_Rep_Item (ASN))); 8920 8921 when Aspect_Storage_Pool => 8922 T := Class_Wide_Type (RTE (RE_Root_Storage_Pool)); 8923 8924 when Aspect_Alignment | 8925 Aspect_Component_Size | 8926 Aspect_Machine_Radix | 8927 Aspect_Object_Size | 8928 Aspect_Size | 8929 Aspect_Storage_Size | 8930 Aspect_Stream_Size | 8931 Aspect_Value_Size => 8932 T := Any_Integer; 8933 8934 when Aspect_Linker_Section => 8935 T := Standard_String; 8936 8937 when Aspect_Synchronization => 8938 return; 8939 8940 -- Special case, the expression of these aspects is just an entity 8941 -- that does not need any resolution, so just analyze. 8942 8943 when Aspect_Input | 8944 Aspect_Output | 8945 Aspect_Read | 8946 Aspect_Suppress | 8947 Aspect_Unsuppress | 8948 Aspect_Warnings | 8949 Aspect_Write => 8950 Analyze (Expression (ASN)); 8951 return; 8952 8953 -- Same for Iterator aspects, where the expression is a function 8954 -- name. Legality rules are checked separately. 8955 8956 when Aspect_Constant_Indexing | 8957 Aspect_Default_Iterator | 8958 Aspect_Iterator_Element | 8959 Aspect_Variable_Indexing => 8960 Analyze (Expression (ASN)); 8961 return; 8962 8963 -- Ditto for Iterable, legality checks in Validate_Iterable_Aspect. 8964 8965 when Aspect_Iterable => 8966 T := Entity (ASN); 8967 8968 declare 8969 Cursor : constant Entity_Id := Get_Cursor_Type (ASN, T); 8970 Assoc : Node_Id; 8971 Expr : Node_Id; 8972 8973 begin 8974 if Cursor = Any_Type then 8975 return; 8976 end if; 8977 8978 Assoc := First (Component_Associations (Expression (ASN))); 8979 while Present (Assoc) loop 8980 Expr := Expression (Assoc); 8981 Analyze (Expr); 8982 8983 if not Error_Posted (Expr) then 8984 Resolve_Iterable_Operation 8985 (Expr, Cursor, T, Chars (First (Choices (Assoc)))); 8986 end if; 8987 8988 Next (Assoc); 8989 end loop; 8990 end; 8991 8992 return; 8993 8994 -- Invariant/Predicate take boolean expressions 8995 8996 when Aspect_Dynamic_Predicate | 8997 Aspect_Invariant | 8998 Aspect_Predicate | 8999 Aspect_Static_Predicate | 9000 Aspect_Type_Invariant => 9001 T := Standard_Boolean; 9002 9003 -- Here is the list of aspects that don't require delay analysis 9004 9005 when Aspect_Abstract_State | 9006 Aspect_Annotate | 9007 Aspect_Contract_Cases | 9008 Aspect_Default_Initial_Condition | 9009 Aspect_Depends | 9010 Aspect_Dimension | 9011 Aspect_Dimension_System | 9012 Aspect_Extensions_Visible | 9013 Aspect_Ghost | 9014 Aspect_Global | 9015 Aspect_Implicit_Dereference | 9016 Aspect_Initial_Condition | 9017 Aspect_Initializes | 9018 Aspect_Obsolescent | 9019 Aspect_Part_Of | 9020 Aspect_Post | 9021 Aspect_Postcondition | 9022 Aspect_Pre | 9023 Aspect_Precondition | 9024 Aspect_Refined_Depends | 9025 Aspect_Refined_Global | 9026 Aspect_Refined_Post | 9027 Aspect_Refined_State | 9028 Aspect_SPARK_Mode | 9029 Aspect_Test_Case | 9030 Aspect_Unimplemented => 9031 raise Program_Error; 9032 9033 end case; 9034 9035 -- Do the preanalyze call 9036 9037 Preanalyze_Spec_Expression (Expression (ASN), T); 9038 end Check_Aspect_At_Freeze_Point; 9039 9040 ----------------------------------- 9041 -- Check_Constant_Address_Clause -- 9042 ----------------------------------- 9043 9044 procedure Check_Constant_Address_Clause 9045 (Expr : Node_Id; 9046 U_Ent : Entity_Id) 9047 is 9048 procedure Check_At_Constant_Address (Nod : Node_Id); 9049 -- Checks that the given node N represents a name whose 'Address is 9050 -- constant (in the same sense as OK_Constant_Address_Clause, i.e. the 9051 -- address value is the same at the point of declaration of U_Ent and at 9052 -- the time of elaboration of the address clause. 9053 9054 procedure Check_Expr_Constants (Nod : Node_Id); 9055 -- Checks that Nod meets the requirements for a constant address clause 9056 -- in the sense of the enclosing procedure. 9057 9058 procedure Check_List_Constants (Lst : List_Id); 9059 -- Check that all elements of list Lst meet the requirements for a 9060 -- constant address clause in the sense of the enclosing procedure. 9061 9062 ------------------------------- 9063 -- Check_At_Constant_Address -- 9064 ------------------------------- 9065 9066 procedure Check_At_Constant_Address (Nod : Node_Id) is 9067 begin 9068 if Is_Entity_Name (Nod) then 9069 if Present (Address_Clause (Entity ((Nod)))) then 9070 Error_Msg_NE 9071 ("invalid address clause for initialized object &!", 9072 Nod, U_Ent); 9073 Error_Msg_NE 9074 ("address for& cannot" & 9075 " depend on another address clause! (RM 13.1(22))!", 9076 Nod, U_Ent); 9077 9078 elsif In_Same_Source_Unit (Entity (Nod), U_Ent) 9079 and then Sloc (U_Ent) < Sloc (Entity (Nod)) 9080 then 9081 Error_Msg_NE 9082 ("invalid address clause for initialized object &!", 9083 Nod, U_Ent); 9084 Error_Msg_Node_2 := U_Ent; 9085 Error_Msg_NE 9086 ("\& must be defined before & (RM 13.1(22))!", 9087 Nod, Entity (Nod)); 9088 end if; 9089 9090 elsif Nkind (Nod) = N_Selected_Component then 9091 declare 9092 T : constant Entity_Id := Etype (Prefix (Nod)); 9093 9094 begin 9095 if (Is_Record_Type (T) 9096 and then Has_Discriminants (T)) 9097 or else 9098 (Is_Access_Type (T) 9099 and then Is_Record_Type (Designated_Type (T)) 9100 and then Has_Discriminants (Designated_Type (T))) 9101 then 9102 Error_Msg_NE 9103 ("invalid address clause for initialized object &!", 9104 Nod, U_Ent); 9105 Error_Msg_N 9106 ("\address cannot depend on component" & 9107 " of discriminated record (RM 13.1(22))!", 9108 Nod); 9109 else 9110 Check_At_Constant_Address (Prefix (Nod)); 9111 end if; 9112 end; 9113 9114 elsif Nkind (Nod) = N_Indexed_Component then 9115 Check_At_Constant_Address (Prefix (Nod)); 9116 Check_List_Constants (Expressions (Nod)); 9117 9118 else 9119 Check_Expr_Constants (Nod); 9120 end if; 9121 end Check_At_Constant_Address; 9122 9123 -------------------------- 9124 -- Check_Expr_Constants -- 9125 -------------------------- 9126 9127 procedure Check_Expr_Constants (Nod : Node_Id) is 9128 Loc_U_Ent : constant Source_Ptr := Sloc (U_Ent); 9129 Ent : Entity_Id := Empty; 9130 9131 begin 9132 if Nkind (Nod) in N_Has_Etype 9133 and then Etype (Nod) = Any_Type 9134 then 9135 return; 9136 end if; 9137 9138 case Nkind (Nod) is 9139 when N_Empty | N_Error => 9140 return; 9141 9142 when N_Identifier | N_Expanded_Name => 9143 Ent := Entity (Nod); 9144 9145 -- We need to look at the original node if it is different 9146 -- from the node, since we may have rewritten things and 9147 -- substituted an identifier representing the rewrite. 9148 9149 if Original_Node (Nod) /= Nod then 9150 Check_Expr_Constants (Original_Node (Nod)); 9151 9152 -- If the node is an object declaration without initial 9153 -- value, some code has been expanded, and the expression 9154 -- is not constant, even if the constituents might be 9155 -- acceptable, as in A'Address + offset. 9156 9157 if Ekind (Ent) = E_Variable 9158 and then 9159 Nkind (Declaration_Node (Ent)) = N_Object_Declaration 9160 and then 9161 No (Expression (Declaration_Node (Ent))) 9162 then 9163 Error_Msg_NE 9164 ("invalid address clause for initialized object &!", 9165 Nod, U_Ent); 9166 9167 -- If entity is constant, it may be the result of expanding 9168 -- a check. We must verify that its declaration appears 9169 -- before the object in question, else we also reject the 9170 -- address clause. 9171 9172 elsif Ekind (Ent) = E_Constant 9173 and then In_Same_Source_Unit (Ent, U_Ent) 9174 and then Sloc (Ent) > Loc_U_Ent 9175 then 9176 Error_Msg_NE 9177 ("invalid address clause for initialized object &!", 9178 Nod, U_Ent); 9179 end if; 9180 9181 return; 9182 end if; 9183 9184 -- Otherwise look at the identifier and see if it is OK 9185 9186 if Ekind_In (Ent, E_Named_Integer, E_Named_Real) 9187 or else Is_Type (Ent) 9188 then 9189 return; 9190 9191 elsif Ekind_In (Ent, E_Constant, E_In_Parameter) then 9192 9193 -- This is the case where we must have Ent defined before 9194 -- U_Ent. Clearly if they are in different units this 9195 -- requirement is met since the unit containing Ent is 9196 -- already processed. 9197 9198 if not In_Same_Source_Unit (Ent, U_Ent) then 9199 return; 9200 9201 -- Otherwise location of Ent must be before the location 9202 -- of U_Ent, that's what prior defined means. 9203 9204 elsif Sloc (Ent) < Loc_U_Ent then 9205 return; 9206 9207 else 9208 Error_Msg_NE 9209 ("invalid address clause for initialized object &!", 9210 Nod, U_Ent); 9211 Error_Msg_Node_2 := U_Ent; 9212 Error_Msg_NE 9213 ("\& must be defined before & (RM 13.1(22))!", 9214 Nod, Ent); 9215 end if; 9216 9217 elsif Nkind (Original_Node (Nod)) = N_Function_Call then 9218 Check_Expr_Constants (Original_Node (Nod)); 9219 9220 else 9221 Error_Msg_NE 9222 ("invalid address clause for initialized object &!", 9223 Nod, U_Ent); 9224 9225 if Comes_From_Source (Ent) then 9226 Error_Msg_NE 9227 ("\reference to variable& not allowed" 9228 & " (RM 13.1(22))!", Nod, Ent); 9229 else 9230 Error_Msg_N 9231 ("non-static expression not allowed" 9232 & " (RM 13.1(22))!", Nod); 9233 end if; 9234 end if; 9235 9236 when N_Integer_Literal => 9237 9238 -- If this is a rewritten unchecked conversion, in a system 9239 -- where Address is an integer type, always use the base type 9240 -- for a literal value. This is user-friendly and prevents 9241 -- order-of-elaboration issues with instances of unchecked 9242 -- conversion. 9243 9244 if Nkind (Original_Node (Nod)) = N_Function_Call then 9245 Set_Etype (Nod, Base_Type (Etype (Nod))); 9246 end if; 9247 9248 when N_Real_Literal | 9249 N_String_Literal | 9250 N_Character_Literal => 9251 return; 9252 9253 when N_Range => 9254 Check_Expr_Constants (Low_Bound (Nod)); 9255 Check_Expr_Constants (High_Bound (Nod)); 9256 9257 when N_Explicit_Dereference => 9258 Check_Expr_Constants (Prefix (Nod)); 9259 9260 when N_Indexed_Component => 9261 Check_Expr_Constants (Prefix (Nod)); 9262 Check_List_Constants (Expressions (Nod)); 9263 9264 when N_Slice => 9265 Check_Expr_Constants (Prefix (Nod)); 9266 Check_Expr_Constants (Discrete_Range (Nod)); 9267 9268 when N_Selected_Component => 9269 Check_Expr_Constants (Prefix (Nod)); 9270 9271 when N_Attribute_Reference => 9272 if Nam_In (Attribute_Name (Nod), Name_Address, 9273 Name_Access, 9274 Name_Unchecked_Access, 9275 Name_Unrestricted_Access) 9276 then 9277 Check_At_Constant_Address (Prefix (Nod)); 9278 9279 else 9280 Check_Expr_Constants (Prefix (Nod)); 9281 Check_List_Constants (Expressions (Nod)); 9282 end if; 9283 9284 when N_Aggregate => 9285 Check_List_Constants (Component_Associations (Nod)); 9286 Check_List_Constants (Expressions (Nod)); 9287 9288 when N_Component_Association => 9289 Check_Expr_Constants (Expression (Nod)); 9290 9291 when N_Extension_Aggregate => 9292 Check_Expr_Constants (Ancestor_Part (Nod)); 9293 Check_List_Constants (Component_Associations (Nod)); 9294 Check_List_Constants (Expressions (Nod)); 9295 9296 when N_Null => 9297 return; 9298 9299 when N_Binary_Op | N_Short_Circuit | N_Membership_Test => 9300 Check_Expr_Constants (Left_Opnd (Nod)); 9301 Check_Expr_Constants (Right_Opnd (Nod)); 9302 9303 when N_Unary_Op => 9304 Check_Expr_Constants (Right_Opnd (Nod)); 9305 9306 when N_Type_Conversion | 9307 N_Qualified_Expression | 9308 N_Allocator | 9309 N_Unchecked_Type_Conversion => 9310 Check_Expr_Constants (Expression (Nod)); 9311 9312 when N_Function_Call => 9313 if not Is_Pure (Entity (Name (Nod))) then 9314 Error_Msg_NE 9315 ("invalid address clause for initialized object &!", 9316 Nod, U_Ent); 9317 9318 Error_Msg_NE 9319 ("\function & is not pure (RM 13.1(22))!", 9320 Nod, Entity (Name (Nod))); 9321 9322 else 9323 Check_List_Constants (Parameter_Associations (Nod)); 9324 end if; 9325 9326 when N_Parameter_Association => 9327 Check_Expr_Constants (Explicit_Actual_Parameter (Nod)); 9328 9329 when others => 9330 Error_Msg_NE 9331 ("invalid address clause for initialized object &!", 9332 Nod, U_Ent); 9333 Error_Msg_NE 9334 ("\must be constant defined before& (RM 13.1(22))!", 9335 Nod, U_Ent); 9336 end case; 9337 end Check_Expr_Constants; 9338 9339 -------------------------- 9340 -- Check_List_Constants -- 9341 -------------------------- 9342 9343 procedure Check_List_Constants (Lst : List_Id) is 9344 Nod1 : Node_Id; 9345 9346 begin 9347 if Present (Lst) then 9348 Nod1 := First (Lst); 9349 while Present (Nod1) loop 9350 Check_Expr_Constants (Nod1); 9351 Next (Nod1); 9352 end loop; 9353 end if; 9354 end Check_List_Constants; 9355 9356 -- Start of processing for Check_Constant_Address_Clause 9357 9358 begin 9359 -- If rep_clauses are to be ignored, no need for legality checks. In 9360 -- particular, no need to pester user about rep clauses that violate the 9361 -- rule on constant addresses, given that these clauses will be removed 9362 -- by Freeze before they reach the back end. Similarly in CodePeer mode, 9363 -- we want to relax these checks. 9364 9365 if not Ignore_Rep_Clauses and not CodePeer_Mode then 9366 Check_Expr_Constants (Expr); 9367 end if; 9368 end Check_Constant_Address_Clause; 9369 9370 --------------------------- 9371 -- Check_Pool_Size_Clash -- 9372 --------------------------- 9373 9374 procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id) is 9375 Post : Node_Id; 9376 9377 begin 9378 -- We need to find out which one came first. Note that in the case of 9379 -- aspects mixed with pragmas there are cases where the processing order 9380 -- is reversed, which is why we do the check here. 9381 9382 if Sloc (SP) < Sloc (SS) then 9383 Error_Msg_Sloc := Sloc (SP); 9384 Post := SS; 9385 Error_Msg_NE ("Storage_Pool previously given for&#", Post, Ent); 9386 9387 else 9388 Error_Msg_Sloc := Sloc (SS); 9389 Post := SP; 9390 Error_Msg_NE ("Storage_Size previously given for&#", Post, Ent); 9391 end if; 9392 9393 Error_Msg_N 9394 ("\cannot have Storage_Size and Storage_Pool (RM 13.11(3))", Post); 9395 end Check_Pool_Size_Clash; 9396 9397 ---------------------------------------- 9398 -- Check_Record_Representation_Clause -- 9399 ---------------------------------------- 9400 9401 procedure Check_Record_Representation_Clause (N : Node_Id) is 9402 Loc : constant Source_Ptr := Sloc (N); 9403 Ident : constant Node_Id := Identifier (N); 9404 Rectype : Entity_Id; 9405 Fent : Entity_Id; 9406 CC : Node_Id; 9407 Fbit : Uint; 9408 Lbit : Uint; 9409 Hbit : Uint := Uint_0; 9410 Comp : Entity_Id; 9411 Pcomp : Entity_Id; 9412 9413 Max_Bit_So_Far : Uint; 9414 -- Records the maximum bit position so far. If all field positions 9415 -- are monotonically increasing, then we can skip the circuit for 9416 -- checking for overlap, since no overlap is possible. 9417 9418 Tagged_Parent : Entity_Id := Empty; 9419 -- This is set in the case of a derived tagged type for which we have 9420 -- Is_Fully_Repped_Tagged_Type True (indicating that all components are 9421 -- positioned by record representation clauses). In this case we must 9422 -- check for overlap between components of this tagged type, and the 9423 -- components of its parent. Tagged_Parent will point to this parent 9424 -- type. For all other cases Tagged_Parent is left set to Empty. 9425 9426 Parent_Last_Bit : Uint; 9427 -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the 9428 -- last bit position for any field in the parent type. We only need to 9429 -- check overlap for fields starting below this point. 9430 9431 Overlap_Check_Required : Boolean; 9432 -- Used to keep track of whether or not an overlap check is required 9433 9434 Overlap_Detected : Boolean := False; 9435 -- Set True if an overlap is detected 9436 9437 Ccount : Natural := 0; 9438 -- Number of component clauses in record rep clause 9439 9440 procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id); 9441 -- Given two entities for record components or discriminants, checks 9442 -- if they have overlapping component clauses and issues errors if so. 9443 9444 procedure Find_Component; 9445 -- Finds component entity corresponding to current component clause (in 9446 -- CC), and sets Comp to the entity, and Fbit/Lbit to the zero origin 9447 -- start/stop bits for the field. If there is no matching component or 9448 -- if the matching component does not have a component clause, then 9449 -- that's an error and Comp is set to Empty, but no error message is 9450 -- issued, since the message was already given. Comp is also set to 9451 -- Empty if the current "component clause" is in fact a pragma. 9452 9453 ----------------------------- 9454 -- Check_Component_Overlap -- 9455 ----------------------------- 9456 9457 procedure Check_Component_Overlap (C1_Ent, C2_Ent : Entity_Id) is 9458 CC1 : constant Node_Id := Component_Clause (C1_Ent); 9459 CC2 : constant Node_Id := Component_Clause (C2_Ent); 9460 9461 begin 9462 if Present (CC1) and then Present (CC2) then 9463 9464 -- Exclude odd case where we have two tag components in the same 9465 -- record, both at location zero. This seems a bit strange, but 9466 -- it seems to happen in some circumstances, perhaps on an error. 9467 9468 if Nam_In (Chars (C1_Ent), Name_uTag, Name_uTag) then 9469 return; 9470 end if; 9471 9472 -- Here we check if the two fields overlap 9473 9474 declare 9475 S1 : constant Uint := Component_Bit_Offset (C1_Ent); 9476 S2 : constant Uint := Component_Bit_Offset (C2_Ent); 9477 E1 : constant Uint := S1 + Esize (C1_Ent); 9478 E2 : constant Uint := S2 + Esize (C2_Ent); 9479 9480 begin 9481 if E2 <= S1 or else E1 <= S2 then 9482 null; 9483 else 9484 Error_Msg_Node_2 := Component_Name (CC2); 9485 Error_Msg_Sloc := Sloc (Error_Msg_Node_2); 9486 Error_Msg_Node_1 := Component_Name (CC1); 9487 Error_Msg_N 9488 ("component& overlaps & #", Component_Name (CC1)); 9489 Overlap_Detected := True; 9490 end if; 9491 end; 9492 end if; 9493 end Check_Component_Overlap; 9494 9495 -------------------- 9496 -- Find_Component -- 9497 -------------------- 9498 9499 procedure Find_Component is 9500 9501 procedure Search_Component (R : Entity_Id); 9502 -- Search components of R for a match. If found, Comp is set 9503 9504 ---------------------- 9505 -- Search_Component -- 9506 ---------------------- 9507 9508 procedure Search_Component (R : Entity_Id) is 9509 begin 9510 Comp := First_Component_Or_Discriminant (R); 9511 while Present (Comp) loop 9512 9513 -- Ignore error of attribute name for component name (we 9514 -- already gave an error message for this, so no need to 9515 -- complain here) 9516 9517 if Nkind (Component_Name (CC)) = N_Attribute_Reference then 9518 null; 9519 else 9520 exit when Chars (Comp) = Chars (Component_Name (CC)); 9521 end if; 9522 9523 Next_Component_Or_Discriminant (Comp); 9524 end loop; 9525 end Search_Component; 9526 9527 -- Start of processing for Find_Component 9528 9529 begin 9530 -- Return with Comp set to Empty if we have a pragma 9531 9532 if Nkind (CC) = N_Pragma then 9533 Comp := Empty; 9534 return; 9535 end if; 9536 9537 -- Search current record for matching component 9538 9539 Search_Component (Rectype); 9540 9541 -- If not found, maybe component of base type discriminant that is 9542 -- absent from statically constrained first subtype. 9543 9544 if No (Comp) then 9545 Search_Component (Base_Type (Rectype)); 9546 end if; 9547 9548 -- If no component, or the component does not reference the component 9549 -- clause in question, then there was some previous error for which 9550 -- we already gave a message, so just return with Comp Empty. 9551 9552 if No (Comp) or else Component_Clause (Comp) /= CC then 9553 Check_Error_Detected; 9554 Comp := Empty; 9555 9556 -- Normal case where we have a component clause 9557 9558 else 9559 Fbit := Component_Bit_Offset (Comp); 9560 Lbit := Fbit + Esize (Comp) - 1; 9561 end if; 9562 end Find_Component; 9563 9564 -- Start of processing for Check_Record_Representation_Clause 9565 9566 begin 9567 Find_Type (Ident); 9568 Rectype := Entity (Ident); 9569 9570 if Rectype = Any_Type then 9571 return; 9572 else 9573 Rectype := Underlying_Type (Rectype); 9574 end if; 9575 9576 -- See if we have a fully repped derived tagged type 9577 9578 declare 9579 PS : constant Entity_Id := Parent_Subtype (Rectype); 9580 9581 begin 9582 if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then 9583 Tagged_Parent := PS; 9584 9585 -- Find maximum bit of any component of the parent type 9586 9587 Parent_Last_Bit := UI_From_Int (System_Address_Size - 1); 9588 Pcomp := First_Entity (Tagged_Parent); 9589 while Present (Pcomp) loop 9590 if Ekind_In (Pcomp, E_Discriminant, E_Component) then 9591 if Component_Bit_Offset (Pcomp) /= No_Uint 9592 and then Known_Static_Esize (Pcomp) 9593 then 9594 Parent_Last_Bit := 9595 UI_Max 9596 (Parent_Last_Bit, 9597 Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1); 9598 end if; 9599 9600 Next_Entity (Pcomp); 9601 end if; 9602 end loop; 9603 end if; 9604 end; 9605 9606 -- All done if no component clauses 9607 9608 CC := First (Component_Clauses (N)); 9609 9610 if No (CC) then 9611 return; 9612 end if; 9613 9614 -- If a tag is present, then create a component clause that places it 9615 -- at the start of the record (otherwise gigi may place it after other 9616 -- fields that have rep clauses). 9617 9618 Fent := First_Entity (Rectype); 9619 9620 if Nkind (Fent) = N_Defining_Identifier 9621 and then Chars (Fent) = Name_uTag 9622 then 9623 Set_Component_Bit_Offset (Fent, Uint_0); 9624 Set_Normalized_Position (Fent, Uint_0); 9625 Set_Normalized_First_Bit (Fent, Uint_0); 9626 Set_Normalized_Position_Max (Fent, Uint_0); 9627 Init_Esize (Fent, System_Address_Size); 9628 9629 Set_Component_Clause (Fent, 9630 Make_Component_Clause (Loc, 9631 Component_Name => Make_Identifier (Loc, Name_uTag), 9632 9633 Position => Make_Integer_Literal (Loc, Uint_0), 9634 First_Bit => Make_Integer_Literal (Loc, Uint_0), 9635 Last_Bit => 9636 Make_Integer_Literal (Loc, 9637 UI_From_Int (System_Address_Size)))); 9638 9639 Ccount := Ccount + 1; 9640 end if; 9641 9642 Max_Bit_So_Far := Uint_Minus_1; 9643 Overlap_Check_Required := False; 9644 9645 -- Process the component clauses 9646 9647 while Present (CC) loop 9648 Find_Component; 9649 9650 if Present (Comp) then 9651 Ccount := Ccount + 1; 9652 9653 -- We need a full overlap check if record positions non-monotonic 9654 9655 if Fbit <= Max_Bit_So_Far then 9656 Overlap_Check_Required := True; 9657 end if; 9658 9659 Max_Bit_So_Far := Lbit; 9660 9661 -- Check bit position out of range of specified size 9662 9663 if Has_Size_Clause (Rectype) 9664 and then RM_Size (Rectype) <= Lbit 9665 then 9666 Error_Msg_N 9667 ("bit number out of range of specified size", 9668 Last_Bit (CC)); 9669 9670 -- Check for overlap with tag component 9671 9672 else 9673 if Is_Tagged_Type (Rectype) 9674 and then Fbit < System_Address_Size 9675 then 9676 Error_Msg_NE 9677 ("component overlaps tag field of&", 9678 Component_Name (CC), Rectype); 9679 Overlap_Detected := True; 9680 end if; 9681 9682 if Hbit < Lbit then 9683 Hbit := Lbit; 9684 end if; 9685 end if; 9686 9687 -- Check parent overlap if component might overlap parent field 9688 9689 if Present (Tagged_Parent) and then Fbit <= Parent_Last_Bit then 9690 Pcomp := First_Component_Or_Discriminant (Tagged_Parent); 9691 while Present (Pcomp) loop 9692 if not Is_Tag (Pcomp) 9693 and then Chars (Pcomp) /= Name_uParent 9694 then 9695 Check_Component_Overlap (Comp, Pcomp); 9696 end if; 9697 9698 Next_Component_Or_Discriminant (Pcomp); 9699 end loop; 9700 end if; 9701 end if; 9702 9703 Next (CC); 9704 end loop; 9705 9706 -- Now that we have processed all the component clauses, check for 9707 -- overlap. We have to leave this till last, since the components can 9708 -- appear in any arbitrary order in the representation clause. 9709 9710 -- We do not need this check if all specified ranges were monotonic, 9711 -- as recorded by Overlap_Check_Required being False at this stage. 9712 9713 -- This first section checks if there are any overlapping entries at 9714 -- all. It does this by sorting all entries and then seeing if there are 9715 -- any overlaps. If there are none, then that is decisive, but if there 9716 -- are overlaps, they may still be OK (they may result from fields in 9717 -- different variants). 9718 9719 if Overlap_Check_Required then 9720 Overlap_Check1 : declare 9721 9722 OC_Fbit : array (0 .. Ccount) of Uint; 9723 -- First-bit values for component clauses, the value is the offset 9724 -- of the first bit of the field from start of record. The zero 9725 -- entry is for use in sorting. 9726 9727 OC_Lbit : array (0 .. Ccount) of Uint; 9728 -- Last-bit values for component clauses, the value is the offset 9729 -- of the last bit of the field from start of record. The zero 9730 -- entry is for use in sorting. 9731 9732 OC_Count : Natural := 0; 9733 -- Count of entries in OC_Fbit and OC_Lbit 9734 9735 function OC_Lt (Op1, Op2 : Natural) return Boolean; 9736 -- Compare routine for Sort 9737 9738 procedure OC_Move (From : Natural; To : Natural); 9739 -- Move routine for Sort 9740 9741 package Sorting is new GNAT.Heap_Sort_G (OC_Move, OC_Lt); 9742 9743 ----------- 9744 -- OC_Lt -- 9745 ----------- 9746 9747 function OC_Lt (Op1, Op2 : Natural) return Boolean is 9748 begin 9749 return OC_Fbit (Op1) < OC_Fbit (Op2); 9750 end OC_Lt; 9751 9752 ------------- 9753 -- OC_Move -- 9754 ------------- 9755 9756 procedure OC_Move (From : Natural; To : Natural) is 9757 begin 9758 OC_Fbit (To) := OC_Fbit (From); 9759 OC_Lbit (To) := OC_Lbit (From); 9760 end OC_Move; 9761 9762 -- Start of processing for Overlap_Check 9763 9764 begin 9765 CC := First (Component_Clauses (N)); 9766 while Present (CC) loop 9767 9768 -- Exclude component clause already marked in error 9769 9770 if not Error_Posted (CC) then 9771 Find_Component; 9772 9773 if Present (Comp) then 9774 OC_Count := OC_Count + 1; 9775 OC_Fbit (OC_Count) := Fbit; 9776 OC_Lbit (OC_Count) := Lbit; 9777 end if; 9778 end if; 9779 9780 Next (CC); 9781 end loop; 9782 9783 Sorting.Sort (OC_Count); 9784 9785 Overlap_Check_Required := False; 9786 for J in 1 .. OC_Count - 1 loop 9787 if OC_Lbit (J) >= OC_Fbit (J + 1) then 9788 Overlap_Check_Required := True; 9789 exit; 9790 end if; 9791 end loop; 9792 end Overlap_Check1; 9793 end if; 9794 9795 -- If Overlap_Check_Required is still True, then we have to do the full 9796 -- scale overlap check, since we have at least two fields that do 9797 -- overlap, and we need to know if that is OK since they are in 9798 -- different variant, or whether we have a definite problem. 9799 9800 if Overlap_Check_Required then 9801 Overlap_Check2 : declare 9802 C1_Ent, C2_Ent : Entity_Id; 9803 -- Entities of components being checked for overlap 9804 9805 Clist : Node_Id; 9806 -- Component_List node whose Component_Items are being checked 9807 9808 Citem : Node_Id; 9809 -- Component declaration for component being checked 9810 9811 begin 9812 C1_Ent := First_Entity (Base_Type (Rectype)); 9813 9814 -- Loop through all components in record. For each component check 9815 -- for overlap with any of the preceding elements on the component 9816 -- list containing the component and also, if the component is in 9817 -- a variant, check against components outside the case structure. 9818 -- This latter test is repeated recursively up the variant tree. 9819 9820 Main_Component_Loop : while Present (C1_Ent) loop 9821 if not Ekind_In (C1_Ent, E_Component, E_Discriminant) then 9822 goto Continue_Main_Component_Loop; 9823 end if; 9824 9825 -- Skip overlap check if entity has no declaration node. This 9826 -- happens with discriminants in constrained derived types. 9827 -- Possibly we are missing some checks as a result, but that 9828 -- does not seem terribly serious. 9829 9830 if No (Declaration_Node (C1_Ent)) then 9831 goto Continue_Main_Component_Loop; 9832 end if; 9833 9834 Clist := Parent (List_Containing (Declaration_Node (C1_Ent))); 9835 9836 -- Loop through component lists that need checking. Check the 9837 -- current component list and all lists in variants above us. 9838 9839 Component_List_Loop : loop 9840 9841 -- If derived type definition, go to full declaration 9842 -- If at outer level, check discriminants if there are any. 9843 9844 if Nkind (Clist) = N_Derived_Type_Definition then 9845 Clist := Parent (Clist); 9846 end if; 9847 9848 -- Outer level of record definition, check discriminants 9849 9850 if Nkind_In (Clist, N_Full_Type_Declaration, 9851 N_Private_Type_Declaration) 9852 then 9853 if Has_Discriminants (Defining_Identifier (Clist)) then 9854 C2_Ent := 9855 First_Discriminant (Defining_Identifier (Clist)); 9856 while Present (C2_Ent) loop 9857 exit when C1_Ent = C2_Ent; 9858 Check_Component_Overlap (C1_Ent, C2_Ent); 9859 Next_Discriminant (C2_Ent); 9860 end loop; 9861 end if; 9862 9863 -- Record extension case 9864 9865 elsif Nkind (Clist) = N_Derived_Type_Definition then 9866 Clist := Empty; 9867 9868 -- Otherwise check one component list 9869 9870 else 9871 Citem := First (Component_Items (Clist)); 9872 while Present (Citem) loop 9873 if Nkind (Citem) = N_Component_Declaration then 9874 C2_Ent := Defining_Identifier (Citem); 9875 exit when C1_Ent = C2_Ent; 9876 Check_Component_Overlap (C1_Ent, C2_Ent); 9877 end if; 9878 9879 Next (Citem); 9880 end loop; 9881 end if; 9882 9883 -- Check for variants above us (the parent of the Clist can 9884 -- be a variant, in which case its parent is a variant part, 9885 -- and the parent of the variant part is a component list 9886 -- whose components must all be checked against the current 9887 -- component for overlap). 9888 9889 if Nkind (Parent (Clist)) = N_Variant then 9890 Clist := Parent (Parent (Parent (Clist))); 9891 9892 -- Check for possible discriminant part in record, this 9893 -- is treated essentially as another level in the 9894 -- recursion. For this case the parent of the component 9895 -- list is the record definition, and its parent is the 9896 -- full type declaration containing the discriminant 9897 -- specifications. 9898 9899 elsif Nkind (Parent (Clist)) = N_Record_Definition then 9900 Clist := Parent (Parent ((Clist))); 9901 9902 -- If neither of these two cases, we are at the top of 9903 -- the tree. 9904 9905 else 9906 exit Component_List_Loop; 9907 end if; 9908 end loop Component_List_Loop; 9909 9910 <<Continue_Main_Component_Loop>> 9911 Next_Entity (C1_Ent); 9912 9913 end loop Main_Component_Loop; 9914 end Overlap_Check2; 9915 end if; 9916 9917 -- The following circuit deals with warning on record holes (gaps). We 9918 -- skip this check if overlap was detected, since it makes sense for the 9919 -- programmer to fix this illegality before worrying about warnings. 9920 9921 if not Overlap_Detected and Warn_On_Record_Holes then 9922 Record_Hole_Check : declare 9923 Decl : constant Node_Id := Declaration_Node (Base_Type (Rectype)); 9924 -- Full declaration of record type 9925 9926 procedure Check_Component_List 9927 (CL : Node_Id; 9928 Sbit : Uint; 9929 DS : List_Id); 9930 -- Check component list CL for holes. The starting bit should be 9931 -- Sbit. which is zero for the main record component list and set 9932 -- appropriately for recursive calls for variants. DS is set to 9933 -- a list of discriminant specifications to be included in the 9934 -- consideration of components. It is No_List if none to consider. 9935 9936 -------------------------- 9937 -- Check_Component_List -- 9938 -------------------------- 9939 9940 procedure Check_Component_List 9941 (CL : Node_Id; 9942 Sbit : Uint; 9943 DS : List_Id) 9944 is 9945 Compl : Integer; 9946 9947 begin 9948 Compl := Integer (List_Length (Component_Items (CL))); 9949 9950 if DS /= No_List then 9951 Compl := Compl + Integer (List_Length (DS)); 9952 end if; 9953 9954 declare 9955 Comps : array (Natural range 0 .. Compl) of Entity_Id; 9956 -- Gather components (zero entry is for sort routine) 9957 9958 Ncomps : Natural := 0; 9959 -- Number of entries stored in Comps (starting at Comps (1)) 9960 9961 Citem : Node_Id; 9962 -- One component item or discriminant specification 9963 9964 Nbit : Uint; 9965 -- Starting bit for next component 9966 9967 CEnt : Entity_Id; 9968 -- Component entity 9969 9970 Variant : Node_Id; 9971 -- One variant 9972 9973 function Lt (Op1, Op2 : Natural) return Boolean; 9974 -- Compare routine for Sort 9975 9976 procedure Move (From : Natural; To : Natural); 9977 -- Move routine for Sort 9978 9979 package Sorting is new GNAT.Heap_Sort_G (Move, Lt); 9980 9981 -------- 9982 -- Lt -- 9983 -------- 9984 9985 function Lt (Op1, Op2 : Natural) return Boolean is 9986 begin 9987 return Component_Bit_Offset (Comps (Op1)) 9988 < 9989 Component_Bit_Offset (Comps (Op2)); 9990 end Lt; 9991 9992 ---------- 9993 -- Move -- 9994 ---------- 9995 9996 procedure Move (From : Natural; To : Natural) is 9997 begin 9998 Comps (To) := Comps (From); 9999 end Move; 10000 10001 begin 10002 -- Gather discriminants into Comp 10003 10004 if DS /= No_List then 10005 Citem := First (DS); 10006 while Present (Citem) loop 10007 if Nkind (Citem) = N_Discriminant_Specification then 10008 declare 10009 Ent : constant Entity_Id := 10010 Defining_Identifier (Citem); 10011 begin 10012 if Ekind (Ent) = E_Discriminant then 10013 Ncomps := Ncomps + 1; 10014 Comps (Ncomps) := Ent; 10015 end if; 10016 end; 10017 end if; 10018 10019 Next (Citem); 10020 end loop; 10021 end if; 10022 10023 -- Gather component entities into Comp 10024 10025 Citem := First (Component_Items (CL)); 10026 while Present (Citem) loop 10027 if Nkind (Citem) = N_Component_Declaration then 10028 Ncomps := Ncomps + 1; 10029 Comps (Ncomps) := Defining_Identifier (Citem); 10030 end if; 10031 10032 Next (Citem); 10033 end loop; 10034 10035 -- Now sort the component entities based on the first bit. 10036 -- Note we already know there are no overlapping components. 10037 10038 Sorting.Sort (Ncomps); 10039 10040 -- Loop through entries checking for holes 10041 10042 Nbit := Sbit; 10043 for J in 1 .. Ncomps loop 10044 CEnt := Comps (J); 10045 Error_Msg_Uint_1 := Component_Bit_Offset (CEnt) - Nbit; 10046 10047 if Error_Msg_Uint_1 > 0 then 10048 Error_Msg_NE 10049 ("?H?^-bit gap before component&", 10050 Component_Name (Component_Clause (CEnt)), CEnt); 10051 end if; 10052 10053 Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt); 10054 end loop; 10055 10056 -- Process variant parts recursively if present 10057 10058 if Present (Variant_Part (CL)) then 10059 Variant := First (Variants (Variant_Part (CL))); 10060 while Present (Variant) loop 10061 Check_Component_List 10062 (Component_List (Variant), Nbit, No_List); 10063 Next (Variant); 10064 end loop; 10065 end if; 10066 end; 10067 end Check_Component_List; 10068 10069 -- Start of processing for Record_Hole_Check 10070 10071 begin 10072 declare 10073 Sbit : Uint; 10074 10075 begin 10076 if Is_Tagged_Type (Rectype) then 10077 Sbit := UI_From_Int (System_Address_Size); 10078 else 10079 Sbit := Uint_0; 10080 end if; 10081 10082 if Nkind (Decl) = N_Full_Type_Declaration 10083 and then Nkind (Type_Definition (Decl)) = N_Record_Definition 10084 then 10085 Check_Component_List 10086 (Component_List (Type_Definition (Decl)), 10087 Sbit, 10088 Discriminant_Specifications (Decl)); 10089 end if; 10090 end; 10091 end Record_Hole_Check; 10092 end if; 10093 10094 -- For records that have component clauses for all components, and whose 10095 -- size is less than or equal to 32, we need to know the size in the 10096 -- front end to activate possible packed array processing where the 10097 -- component type is a record. 10098 10099 -- At this stage Hbit + 1 represents the first unused bit from all the 10100 -- component clauses processed, so if the component clauses are 10101 -- complete, then this is the length of the record. 10102 10103 -- For records longer than System.Storage_Unit, and for those where not 10104 -- all components have component clauses, the back end determines the 10105 -- length (it may for example be appropriate to round up the size 10106 -- to some convenient boundary, based on alignment considerations, etc). 10107 10108 if Unknown_RM_Size (Rectype) and then Hbit + 1 <= 32 then 10109 10110 -- Nothing to do if at least one component has no component clause 10111 10112 Comp := First_Component_Or_Discriminant (Rectype); 10113 while Present (Comp) loop 10114 exit when No (Component_Clause (Comp)); 10115 Next_Component_Or_Discriminant (Comp); 10116 end loop; 10117 10118 -- If we fall out of loop, all components have component clauses 10119 -- and so we can set the size to the maximum value. 10120 10121 if No (Comp) then 10122 Set_RM_Size (Rectype, Hbit + 1); 10123 end if; 10124 end if; 10125 end Check_Record_Representation_Clause; 10126 10127 ---------------- 10128 -- Check_Size -- 10129 ---------------- 10130 10131 procedure Check_Size 10132 (N : Node_Id; 10133 T : Entity_Id; 10134 Siz : Uint; 10135 Biased : out Boolean) 10136 is 10137 UT : constant Entity_Id := Underlying_Type (T); 10138 M : Uint; 10139 10140 begin 10141 Biased := False; 10142 10143 -- Reject patently improper size values. 10144 10145 if Is_Elementary_Type (T) 10146 and then Siz > UI_From_Int (Int'Last) 10147 then 10148 Error_Msg_N ("Size value too large for elementary type", N); 10149 10150 if Nkind (Original_Node (N)) = N_Op_Expon then 10151 Error_Msg_N 10152 ("\maybe '* was meant, rather than '*'*", Original_Node (N)); 10153 end if; 10154 end if; 10155 10156 -- Dismiss generic types 10157 10158 if Is_Generic_Type (T) 10159 or else 10160 Is_Generic_Type (UT) 10161 or else 10162 Is_Generic_Type (Root_Type (UT)) 10163 then 10164 return; 10165 10166 -- Guard against previous errors 10167 10168 elsif No (UT) or else UT = Any_Type then 10169 Check_Error_Detected; 10170 return; 10171 10172 -- Check case of bit packed array 10173 10174 elsif Is_Array_Type (UT) 10175 and then Known_Static_Component_Size (UT) 10176 and then Is_Bit_Packed_Array (UT) 10177 then 10178 declare 10179 Asiz : Uint; 10180 Indx : Node_Id; 10181 Ityp : Entity_Id; 10182 10183 begin 10184 Asiz := Component_Size (UT); 10185 Indx := First_Index (UT); 10186 loop 10187 Ityp := Etype (Indx); 10188 10189 -- If non-static bound, then we are not in the business of 10190 -- trying to check the length, and indeed an error will be 10191 -- issued elsewhere, since sizes of non-static array types 10192 -- cannot be set implicitly or explicitly. 10193 10194 if not Is_OK_Static_Subtype (Ityp) then 10195 return; 10196 end if; 10197 10198 -- Otherwise accumulate next dimension 10199 10200 Asiz := Asiz * (Expr_Value (Type_High_Bound (Ityp)) - 10201 Expr_Value (Type_Low_Bound (Ityp)) + 10202 Uint_1); 10203 10204 Next_Index (Indx); 10205 exit when No (Indx); 10206 end loop; 10207 10208 if Asiz <= Siz then 10209 return; 10210 10211 else 10212 Error_Msg_Uint_1 := Asiz; 10213 Error_Msg_NE 10214 ("size for& too small, minimum allowed is ^", N, T); 10215 Set_Esize (T, Asiz); 10216 Set_RM_Size (T, Asiz); 10217 end if; 10218 end; 10219 10220 -- All other composite types are ignored 10221 10222 elsif Is_Composite_Type (UT) then 10223 return; 10224 10225 -- For fixed-point types, don't check minimum if type is not frozen, 10226 -- since we don't know all the characteristics of the type that can 10227 -- affect the size (e.g. a specified small) till freeze time. 10228 10229 elsif Is_Fixed_Point_Type (UT) 10230 and then not Is_Frozen (UT) 10231 then 10232 null; 10233 10234 -- Cases for which a minimum check is required 10235 10236 else 10237 -- Ignore if specified size is correct for the type 10238 10239 if Known_Esize (UT) and then Siz = Esize (UT) then 10240 return; 10241 end if; 10242 10243 -- Otherwise get minimum size 10244 10245 M := UI_From_Int (Minimum_Size (UT)); 10246 10247 if Siz < M then 10248 10249 -- Size is less than minimum size, but one possibility remains 10250 -- that we can manage with the new size if we bias the type. 10251 10252 M := UI_From_Int (Minimum_Size (UT, Biased => True)); 10253 10254 if Siz < M then 10255 Error_Msg_Uint_1 := M; 10256 Error_Msg_NE 10257 ("size for& too small, minimum allowed is ^", N, T); 10258 Set_Esize (T, M); 10259 Set_RM_Size (T, M); 10260 else 10261 Biased := True; 10262 end if; 10263 end if; 10264 end if; 10265 end Check_Size; 10266 10267 -------------------------- 10268 -- Freeze_Entity_Checks -- 10269 -------------------------- 10270 10271 procedure Freeze_Entity_Checks (N : Node_Id) is 10272 procedure Hide_Non_Overridden_Subprograms (Typ : Entity_Id); 10273 -- Inspect the primitive operations of type Typ and hide all pairs of 10274 -- implicitly declared non-overridden non-fully conformant homographs 10275 -- (Ada RM 8.3 12.3/2). 10276 10277 ------------------------------------- 10278 -- Hide_Non_Overridden_Subprograms -- 10279 ------------------------------------- 10280 10281 procedure Hide_Non_Overridden_Subprograms (Typ : Entity_Id) is 10282 procedure Hide_Matching_Homographs 10283 (Subp_Id : Entity_Id; 10284 Start_Elmt : Elmt_Id); 10285 -- Inspect a list of primitive operations starting with Start_Elmt 10286 -- and find matching implicitly declared non-overridden non-fully 10287 -- conformant homographs of Subp_Id. If found, all matches along 10288 -- with Subp_Id are hidden from all visibility. 10289 10290 function Is_Non_Overridden_Or_Null_Procedure 10291 (Subp_Id : Entity_Id) return Boolean; 10292 -- Determine whether subprogram Subp_Id is implicitly declared non- 10293 -- overridden subprogram or an implicitly declared null procedure. 10294 10295 ------------------------------ 10296 -- Hide_Matching_Homographs -- 10297 ------------------------------ 10298 10299 procedure Hide_Matching_Homographs 10300 (Subp_Id : Entity_Id; 10301 Start_Elmt : Elmt_Id) 10302 is 10303 Prim : Entity_Id; 10304 Prim_Elmt : Elmt_Id; 10305 10306 begin 10307 Prim_Elmt := Start_Elmt; 10308 while Present (Prim_Elmt) loop 10309 Prim := Node (Prim_Elmt); 10310 10311 -- The current primitive is implicitly declared non-overridden 10312 -- non-fully conformant homograph of Subp_Id. Both subprograms 10313 -- must be hidden from visibility. 10314 10315 if Chars (Prim) = Chars (Subp_Id) 10316 and then Is_Non_Overridden_Or_Null_Procedure (Prim) 10317 and then not Fully_Conformant (Prim, Subp_Id) 10318 then 10319 Set_Is_Hidden_Non_Overridden_Subpgm (Prim); 10320 Set_Is_Immediately_Visible (Prim, False); 10321 Set_Is_Potentially_Use_Visible (Prim, False); 10322 10323 Set_Is_Hidden_Non_Overridden_Subpgm (Subp_Id); 10324 Set_Is_Immediately_Visible (Subp_Id, False); 10325 Set_Is_Potentially_Use_Visible (Subp_Id, False); 10326 end if; 10327 10328 Next_Elmt (Prim_Elmt); 10329 end loop; 10330 end Hide_Matching_Homographs; 10331 10332 ----------------------------------------- 10333 -- Is_Non_Overridden_Or_Null_Procedure -- 10334 ----------------------------------------- 10335 10336 function Is_Non_Overridden_Or_Null_Procedure 10337 (Subp_Id : Entity_Id) return Boolean 10338 is 10339 Alias_Id : Entity_Id; 10340 10341 begin 10342 -- The subprogram is inherited (implicitly declared), it does not 10343 -- override and does not cover a primitive of an interface. 10344 10345 if Ekind_In (Subp_Id, E_Function, E_Procedure) 10346 and then Present (Alias (Subp_Id)) 10347 and then No (Interface_Alias (Subp_Id)) 10348 and then No (Overridden_Operation (Subp_Id)) 10349 then 10350 Alias_Id := Alias (Subp_Id); 10351 10352 if Requires_Overriding (Alias_Id) then 10353 return True; 10354 10355 elsif Nkind (Parent (Alias_Id)) = N_Procedure_Specification 10356 and then Null_Present (Parent (Alias_Id)) 10357 then 10358 return True; 10359 end if; 10360 end if; 10361 10362 return False; 10363 end Is_Non_Overridden_Or_Null_Procedure; 10364 10365 -- Local variables 10366 10367 Prim_Ops : constant Elist_Id := Direct_Primitive_Operations (Typ); 10368 Prim : Entity_Id; 10369 Prim_Elmt : Elmt_Id; 10370 10371 -- Start of processing for Hide_Non_Overridden_Subprograms 10372 10373 begin 10374 -- Inspect the list of primitives looking for non-overridden 10375 -- subprograms. 10376 10377 if Present (Prim_Ops) then 10378 Prim_Elmt := First_Elmt (Prim_Ops); 10379 while Present (Prim_Elmt) loop 10380 Prim := Node (Prim_Elmt); 10381 Next_Elmt (Prim_Elmt); 10382 10383 if Is_Non_Overridden_Or_Null_Procedure (Prim) then 10384 Hide_Matching_Homographs 10385 (Subp_Id => Prim, 10386 Start_Elmt => Prim_Elmt); 10387 end if; 10388 end loop; 10389 end if; 10390 end Hide_Non_Overridden_Subprograms; 10391 10392 --------------------- 10393 -- Local variables -- 10394 --------------------- 10395 10396 E : constant Entity_Id := Entity (N); 10397 10398 Non_Generic_Case : constant Boolean := Nkind (N) = N_Freeze_Entity; 10399 -- True in non-generic case. Some of the processing here is skipped 10400 -- for the generic case since it is not needed. Basically in the 10401 -- generic case, we only need to do stuff that might generate error 10402 -- messages or warnings. 10403 10404 -- Start of processing for Freeze_Entity_Checks 10405 10406 begin 10407 -- Remember that we are processing a freezing entity. Required to 10408 -- ensure correct decoration of internal entities associated with 10409 -- interfaces (see New_Overloaded_Entity). 10410 10411 Inside_Freezing_Actions := Inside_Freezing_Actions + 1; 10412 10413 -- For tagged types covering interfaces add internal entities that link 10414 -- the primitives of the interfaces with the primitives that cover them. 10415 -- Note: These entities were originally generated only when generating 10416 -- code because their main purpose was to provide support to initialize 10417 -- the secondary dispatch tables. They are now generated also when 10418 -- compiling with no code generation to provide ASIS the relationship 10419 -- between interface primitives and tagged type primitives. They are 10420 -- also used to locate primitives covering interfaces when processing 10421 -- generics (see Derive_Subprograms). 10422 10423 -- This is not needed in the generic case 10424 10425 if Ada_Version >= Ada_2005 10426 and then Non_Generic_Case 10427 and then Ekind (E) = E_Record_Type 10428 and then Is_Tagged_Type (E) 10429 and then not Is_Interface (E) 10430 and then Has_Interfaces (E) 10431 then 10432 -- This would be a good common place to call the routine that checks 10433 -- overriding of interface primitives (and thus factorize calls to 10434 -- Check_Abstract_Overriding located at different contexts in the 10435 -- compiler). However, this is not possible because it causes 10436 -- spurious errors in case of late overriding. 10437 10438 Add_Internal_Interface_Entities (E); 10439 end if; 10440 10441 -- After all forms of overriding have been resolved, a tagged type may 10442 -- be left with a set of implicitly declared and possibly erroneous 10443 -- abstract subprograms, null procedures and subprograms that require 10444 -- overriding. If this set contains fully conformat homographs, then one 10445 -- is chosen arbitrarily (already done during resolution), otherwise all 10446 -- remaining non-fully conformant homographs are hidden from visibility 10447 -- (Ada RM 8.3 12.3/2). 10448 10449 if Is_Tagged_Type (E) then 10450 Hide_Non_Overridden_Subprograms (E); 10451 end if; 10452 10453 -- Check CPP types 10454 10455 if Ekind (E) = E_Record_Type 10456 and then Is_CPP_Class (E) 10457 and then Is_Tagged_Type (E) 10458 and then Tagged_Type_Expansion 10459 then 10460 if CPP_Num_Prims (E) = 0 then 10461 10462 -- If the CPP type has user defined components then it must import 10463 -- primitives from C++. This is required because if the C++ class 10464 -- has no primitives then the C++ compiler does not added the _tag 10465 -- component to the type. 10466 10467 if First_Entity (E) /= Last_Entity (E) then 10468 Error_Msg_N 10469 ("'C'P'P type must import at least one primitive from C++??", 10470 E); 10471 end if; 10472 end if; 10473 10474 -- Check that all its primitives are abstract or imported from C++. 10475 -- Check also availability of the C++ constructor. 10476 10477 declare 10478 Has_Constructors : constant Boolean := Has_CPP_Constructors (E); 10479 Elmt : Elmt_Id; 10480 Error_Reported : Boolean := False; 10481 Prim : Node_Id; 10482 10483 begin 10484 Elmt := First_Elmt (Primitive_Operations (E)); 10485 while Present (Elmt) loop 10486 Prim := Node (Elmt); 10487 10488 if Comes_From_Source (Prim) then 10489 if Is_Abstract_Subprogram (Prim) then 10490 null; 10491 10492 elsif not Is_Imported (Prim) 10493 or else Convention (Prim) /= Convention_CPP 10494 then 10495 Error_Msg_N 10496 ("primitives of 'C'P'P types must be imported from C++ " 10497 & "or abstract??", Prim); 10498 10499 elsif not Has_Constructors 10500 and then not Error_Reported 10501 then 10502 Error_Msg_Name_1 := Chars (E); 10503 Error_Msg_N 10504 ("??'C'P'P constructor required for type %", Prim); 10505 Error_Reported := True; 10506 end if; 10507 end if; 10508 10509 Next_Elmt (Elmt); 10510 end loop; 10511 end; 10512 end if; 10513 10514 -- Check Ada derivation of CPP type 10515 10516 if Expander_Active -- why? losing errors in -gnatc mode??? 10517 and then Present (Etype (E)) -- defend against errors 10518 and then Tagged_Type_Expansion 10519 and then Ekind (E) = E_Record_Type 10520 and then Etype (E) /= E 10521 and then Is_CPP_Class (Etype (E)) 10522 and then CPP_Num_Prims (Etype (E)) > 0 10523 and then not Is_CPP_Class (E) 10524 and then not Has_CPP_Constructors (Etype (E)) 10525 then 10526 -- If the parent has C++ primitives but it has no constructor then 10527 -- check that all the primitives are overridden in this derivation; 10528 -- otherwise the constructor of the parent is needed to build the 10529 -- dispatch table. 10530 10531 declare 10532 Elmt : Elmt_Id; 10533 Prim : Node_Id; 10534 10535 begin 10536 Elmt := First_Elmt (Primitive_Operations (E)); 10537 while Present (Elmt) loop 10538 Prim := Node (Elmt); 10539 10540 if not Is_Abstract_Subprogram (Prim) 10541 and then No (Interface_Alias (Prim)) 10542 and then Find_Dispatching_Type (Ultimate_Alias (Prim)) /= E 10543 then 10544 Error_Msg_Name_1 := Chars (Etype (E)); 10545 Error_Msg_N 10546 ("'C'P'P constructor required for parent type %", E); 10547 exit; 10548 end if; 10549 10550 Next_Elmt (Elmt); 10551 end loop; 10552 end; 10553 end if; 10554 10555 Inside_Freezing_Actions := Inside_Freezing_Actions - 1; 10556 10557 -- If we have a type with predicates, build predicate function. This 10558 -- is not needed in the generic case, and is not needed within TSS 10559 -- subprograms and other predefined primitives. 10560 10561 if Non_Generic_Case 10562 and then Is_Type (E) 10563 and then Has_Predicates (E) 10564 and then not Within_Internal_Subprogram 10565 then 10566 Build_Predicate_Functions (E, N); 10567 end if; 10568 10569 -- If type has delayed aspects, this is where we do the preanalysis at 10570 -- the freeze point, as part of the consistent visibility check. Note 10571 -- that this must be done after calling Build_Predicate_Functions or 10572 -- Build_Invariant_Procedure since these subprograms fix occurrences of 10573 -- the subtype name in the saved expression so that they will not cause 10574 -- trouble in the preanalysis. 10575 10576 -- This is also not needed in the generic case 10577 10578 if Non_Generic_Case 10579 and then Has_Delayed_Aspects (E) 10580 and then Scope (E) = Current_Scope 10581 then 10582 -- Retrieve the visibility to the discriminants in order to properly 10583 -- analyze the aspects. 10584 10585 Push_Scope_And_Install_Discriminants (E); 10586 10587 declare 10588 Ritem : Node_Id; 10589 10590 begin 10591 -- Look for aspect specification entries for this entity 10592 10593 Ritem := First_Rep_Item (E); 10594 while Present (Ritem) loop 10595 if Nkind (Ritem) = N_Aspect_Specification 10596 and then Entity (Ritem) = E 10597 and then Is_Delayed_Aspect (Ritem) 10598 then 10599 Check_Aspect_At_Freeze_Point (Ritem); 10600 end if; 10601 10602 Next_Rep_Item (Ritem); 10603 end loop; 10604 end; 10605 10606 Uninstall_Discriminants_And_Pop_Scope (E); 10607 end if; 10608 10609 -- For a record type, deal with variant parts. This has to be delayed 10610 -- to this point, because of the issue of statically predicated 10611 -- subtypes, which we have to ensure are frozen before checking 10612 -- choices, since we need to have the static choice list set. 10613 10614 if Is_Record_Type (E) then 10615 Check_Variant_Part : declare 10616 D : constant Node_Id := Declaration_Node (E); 10617 T : Node_Id; 10618 C : Node_Id; 10619 VP : Node_Id; 10620 10621 Others_Present : Boolean; 10622 pragma Warnings (Off, Others_Present); 10623 -- Indicates others present, not used in this case 10624 10625 procedure Non_Static_Choice_Error (Choice : Node_Id); 10626 -- Error routine invoked by the generic instantiation below when 10627 -- the variant part has a non static choice. 10628 10629 procedure Process_Declarations (Variant : Node_Id); 10630 -- Processes declarations associated with a variant. We analyzed 10631 -- the declarations earlier (in Sem_Ch3.Analyze_Variant_Part), 10632 -- but we still need the recursive call to Check_Choices for any 10633 -- nested variant to get its choices properly processed. This is 10634 -- also where we expand out the choices if expansion is active. 10635 10636 package Variant_Choices_Processing is new 10637 Generic_Check_Choices 10638 (Process_Empty_Choice => No_OP, 10639 Process_Non_Static_Choice => Non_Static_Choice_Error, 10640 Process_Associated_Node => Process_Declarations); 10641 use Variant_Choices_Processing; 10642 10643 ----------------------------- 10644 -- Non_Static_Choice_Error -- 10645 ----------------------------- 10646 10647 procedure Non_Static_Choice_Error (Choice : Node_Id) is 10648 begin 10649 Flag_Non_Static_Expr 10650 ("choice given in variant part is not static!", Choice); 10651 end Non_Static_Choice_Error; 10652 10653 -------------------------- 10654 -- Process_Declarations -- 10655 -------------------------- 10656 10657 procedure Process_Declarations (Variant : Node_Id) is 10658 CL : constant Node_Id := Component_List (Variant); 10659 VP : Node_Id; 10660 10661 begin 10662 -- Check for static predicate present in this variant 10663 10664 if Has_SP_Choice (Variant) then 10665 10666 -- Here we expand. You might expect to find this call in 10667 -- Expand_N_Variant_Part, but that is called when we first 10668 -- see the variant part, and we cannot do this expansion 10669 -- earlier than the freeze point, since for statically 10670 -- predicated subtypes, the predicate is not known till 10671 -- the freeze point. 10672 10673 -- Furthermore, we do this expansion even if the expander 10674 -- is not active, because other semantic processing, e.g. 10675 -- for aggregates, requires the expanded list of choices. 10676 10677 -- If the expander is not active, then we can't just clobber 10678 -- the list since it would invalidate the ASIS -gnatct tree. 10679 -- So we have to rewrite the variant part with a Rewrite 10680 -- call that replaces it with a copy and clobber the copy. 10681 10682 if not Expander_Active then 10683 declare 10684 NewV : constant Node_Id := New_Copy (Variant); 10685 begin 10686 Set_Discrete_Choices 10687 (NewV, New_Copy_List (Discrete_Choices (Variant))); 10688 Rewrite (Variant, NewV); 10689 end; 10690 end if; 10691 10692 Expand_Static_Predicates_In_Choices (Variant); 10693 end if; 10694 10695 -- We don't need to worry about the declarations in the variant 10696 -- (since they were analyzed by Analyze_Choices when we first 10697 -- encountered the variant), but we do need to take care of 10698 -- expansion of any nested variants. 10699 10700 if not Null_Present (CL) then 10701 VP := Variant_Part (CL); 10702 10703 if Present (VP) then 10704 Check_Choices 10705 (VP, Variants (VP), Etype (Name (VP)), Others_Present); 10706 end if; 10707 end if; 10708 end Process_Declarations; 10709 10710 -- Start of processing for Check_Variant_Part 10711 10712 begin 10713 -- Find component list 10714 10715 C := Empty; 10716 10717 if Nkind (D) = N_Full_Type_Declaration then 10718 T := Type_Definition (D); 10719 10720 if Nkind (T) = N_Record_Definition then 10721 C := Component_List (T); 10722 10723 elsif Nkind (T) = N_Derived_Type_Definition 10724 and then Present (Record_Extension_Part (T)) 10725 then 10726 C := Component_List (Record_Extension_Part (T)); 10727 end if; 10728 end if; 10729 10730 -- Case of variant part present 10731 10732 if Present (C) and then Present (Variant_Part (C)) then 10733 VP := Variant_Part (C); 10734 10735 -- Check choices 10736 10737 Check_Choices 10738 (VP, Variants (VP), Etype (Name (VP)), Others_Present); 10739 10740 -- If the last variant does not contain the Others choice, 10741 -- replace it with an N_Others_Choice node since Gigi always 10742 -- wants an Others. Note that we do not bother to call Analyze 10743 -- on the modified variant part, since its only effect would be 10744 -- to compute the Others_Discrete_Choices node laboriously, and 10745 -- of course we already know the list of choices corresponding 10746 -- to the others choice (it's the list we're replacing). 10747 10748 -- We only want to do this if the expander is active, since 10749 -- we do not want to clobber the ASIS tree. 10750 10751 if Expander_Active then 10752 declare 10753 Last_Var : constant Node_Id := 10754 Last_Non_Pragma (Variants (VP)); 10755 10756 Others_Node : Node_Id; 10757 10758 begin 10759 if Nkind (First (Discrete_Choices (Last_Var))) /= 10760 N_Others_Choice 10761 then 10762 Others_Node := Make_Others_Choice (Sloc (Last_Var)); 10763 Set_Others_Discrete_Choices 10764 (Others_Node, Discrete_Choices (Last_Var)); 10765 Set_Discrete_Choices 10766 (Last_Var, New_List (Others_Node)); 10767 end if; 10768 end; 10769 end if; 10770 end if; 10771 end Check_Variant_Part; 10772 end if; 10773 end Freeze_Entity_Checks; 10774 10775 ------------------------- 10776 -- Get_Alignment_Value -- 10777 ------------------------- 10778 10779 function Get_Alignment_Value (Expr : Node_Id) return Uint is 10780 Align : constant Uint := Static_Integer (Expr); 10781 10782 begin 10783 if Align = No_Uint then 10784 return No_Uint; 10785 10786 elsif Align <= 0 then 10787 Error_Msg_N ("alignment value must be positive", Expr); 10788 return No_Uint; 10789 10790 else 10791 for J in Int range 0 .. 64 loop 10792 declare 10793 M : constant Uint := Uint_2 ** J; 10794 10795 begin 10796 exit when M = Align; 10797 10798 if M > Align then 10799 Error_Msg_N 10800 ("alignment value must be power of 2", Expr); 10801 return No_Uint; 10802 end if; 10803 end; 10804 end loop; 10805 10806 return Align; 10807 end if; 10808 end Get_Alignment_Value; 10809 10810 ------------------------------------- 10811 -- Inherit_Aspects_At_Freeze_Point -- 10812 ------------------------------------- 10813 10814 procedure Inherit_Aspects_At_Freeze_Point (Typ : Entity_Id) is 10815 function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 10816 (Rep_Item : Node_Id) return Boolean; 10817 -- This routine checks if Rep_Item is either a pragma or an aspect 10818 -- specification node whose correponding pragma (if any) is present in 10819 -- the Rep Item chain of the entity it has been specified to. 10820 10821 -------------------------------------------------- 10822 -- Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item -- 10823 -------------------------------------------------- 10824 10825 function Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 10826 (Rep_Item : Node_Id) return Boolean 10827 is 10828 begin 10829 return 10830 Nkind (Rep_Item) = N_Pragma 10831 or else Present_In_Rep_Item 10832 (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item)); 10833 end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item; 10834 10835 -- Start of processing for Inherit_Aspects_At_Freeze_Point 10836 10837 begin 10838 -- A representation item is either subtype-specific (Size and Alignment 10839 -- clauses) or type-related (all others). Subtype-specific aspects may 10840 -- differ for different subtypes of the same type (RM 13.1.8). 10841 10842 -- A derived type inherits each type-related representation aspect of 10843 -- its parent type that was directly specified before the declaration of 10844 -- the derived type (RM 13.1.15). 10845 10846 -- A derived subtype inherits each subtype-specific representation 10847 -- aspect of its parent subtype that was directly specified before the 10848 -- declaration of the derived type (RM 13.1.15). 10849 10850 -- The general processing involves inheriting a representation aspect 10851 -- from a parent type whenever the first rep item (aspect specification, 10852 -- attribute definition clause, pragma) corresponding to the given 10853 -- representation aspect in the rep item chain of Typ, if any, isn't 10854 -- directly specified to Typ but to one of its parents. 10855 10856 -- ??? Note that, for now, just a limited number of representation 10857 -- aspects have been inherited here so far. Many of them are 10858 -- still inherited in Sem_Ch3. This will be fixed soon. Here is 10859 -- a non- exhaustive list of aspects that likely also need to 10860 -- be moved to this routine: Alignment, Component_Alignment, 10861 -- Component_Size, Machine_Radix, Object_Size, Pack, Predicates, 10862 -- Preelaborable_Initialization, RM_Size and Small. 10863 10864 -- In addition, Convention must be propagated from base type to subtype, 10865 -- because the subtype may have been declared on an incomplete view. 10866 10867 if Nkind (Parent (Typ)) = N_Private_Extension_Declaration then 10868 return; 10869 end if; 10870 10871 -- Ada_05/Ada_2005 10872 10873 if not Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005, False) 10874 and then Has_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005) 10875 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 10876 (Get_Rep_Item (Typ, Name_Ada_05, Name_Ada_2005)) 10877 then 10878 Set_Is_Ada_2005_Only (Typ); 10879 end if; 10880 10881 -- Ada_12/Ada_2012 10882 10883 if not Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012, False) 10884 and then Has_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012) 10885 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 10886 (Get_Rep_Item (Typ, Name_Ada_12, Name_Ada_2012)) 10887 then 10888 Set_Is_Ada_2012_Only (Typ); 10889 end if; 10890 10891 -- Atomic/Shared 10892 10893 if not Has_Rep_Item (Typ, Name_Atomic, Name_Shared, False) 10894 and then Has_Rep_Pragma (Typ, Name_Atomic, Name_Shared) 10895 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 10896 (Get_Rep_Item (Typ, Name_Atomic, Name_Shared)) 10897 then 10898 Set_Is_Atomic (Typ); 10899 Set_Treat_As_Volatile (Typ); 10900 Set_Is_Volatile (Typ); 10901 end if; 10902 10903 -- Convention 10904 10905 if Is_Record_Type (Typ) 10906 and then Typ /= Base_Type (Typ) and then Is_Frozen (Base_Type (Typ)) 10907 then 10908 Set_Convention (Typ, Convention (Base_Type (Typ))); 10909 end if; 10910 10911 -- Default_Component_Value 10912 10913 if Is_Array_Type (Typ) 10914 and then Is_Base_Type (Typ) 10915 and then Has_Rep_Item (Typ, Name_Default_Component_Value, False) 10916 and then Has_Rep_Item (Typ, Name_Default_Component_Value) 10917 then 10918 Set_Default_Aspect_Component_Value (Typ, 10919 Default_Aspect_Component_Value 10920 (Entity (Get_Rep_Item (Typ, Name_Default_Component_Value)))); 10921 end if; 10922 10923 -- Default_Value 10924 10925 if Is_Scalar_Type (Typ) 10926 and then Is_Base_Type (Typ) 10927 and then Has_Rep_Item (Typ, Name_Default_Value, False) 10928 and then Has_Rep_Item (Typ, Name_Default_Value) 10929 then 10930 Set_Default_Aspect_Value (Typ, 10931 Default_Aspect_Value 10932 (Entity (Get_Rep_Item (Typ, Name_Default_Value)))); 10933 end if; 10934 10935 -- Discard_Names 10936 10937 if not Has_Rep_Item (Typ, Name_Discard_Names, False) 10938 and then Has_Rep_Item (Typ, Name_Discard_Names) 10939 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 10940 (Get_Rep_Item (Typ, Name_Discard_Names)) 10941 then 10942 Set_Discard_Names (Typ); 10943 end if; 10944 10945 -- Invariants 10946 10947 if not Has_Rep_Item (Typ, Name_Invariant, False) 10948 and then Has_Rep_Item (Typ, Name_Invariant) 10949 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 10950 (Get_Rep_Item (Typ, Name_Invariant)) 10951 then 10952 Set_Has_Invariants (Typ); 10953 10954 if Class_Present (Get_Rep_Item (Typ, Name_Invariant)) then 10955 Set_Has_Inheritable_Invariants (Typ); 10956 end if; 10957 10958 -- If we have a subtype with invariants, whose base type does not have 10959 -- invariants, copy these invariants to the base type. This happens for 10960 -- the case of implicit base types created for scalar and array types. 10961 10962 elsif Has_Invariants (Typ) 10963 and then not Has_Invariants (Base_Type (Typ)) 10964 then 10965 Set_Has_Invariants (Base_Type (Typ)); 10966 Set_Invariant_Procedure (Base_Type (Typ), Invariant_Procedure (Typ)); 10967 end if; 10968 10969 -- Volatile 10970 10971 if not Has_Rep_Item (Typ, Name_Volatile, False) 10972 and then Has_Rep_Item (Typ, Name_Volatile) 10973 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 10974 (Get_Rep_Item (Typ, Name_Volatile)) 10975 then 10976 Set_Treat_As_Volatile (Typ); 10977 Set_Is_Volatile (Typ); 10978 end if; 10979 10980 -- Inheritance for derived types only 10981 10982 if Is_Derived_Type (Typ) then 10983 declare 10984 Bas_Typ : constant Entity_Id := Base_Type (Typ); 10985 Imp_Bas_Typ : constant Entity_Id := Implementation_Base_Type (Typ); 10986 10987 begin 10988 -- Atomic_Components 10989 10990 if not Has_Rep_Item (Typ, Name_Atomic_Components, False) 10991 and then Has_Rep_Item (Typ, Name_Atomic_Components) 10992 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 10993 (Get_Rep_Item (Typ, Name_Atomic_Components)) 10994 then 10995 Set_Has_Atomic_Components (Imp_Bas_Typ); 10996 end if; 10997 10998 -- Volatile_Components 10999 11000 if not Has_Rep_Item (Typ, Name_Volatile_Components, False) 11001 and then Has_Rep_Item (Typ, Name_Volatile_Components) 11002 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 11003 (Get_Rep_Item (Typ, Name_Volatile_Components)) 11004 then 11005 Set_Has_Volatile_Components (Imp_Bas_Typ); 11006 end if; 11007 11008 -- Finalize_Storage_Only 11009 11010 if not Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only, False) 11011 and then Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only) 11012 then 11013 Set_Finalize_Storage_Only (Bas_Typ); 11014 end if; 11015 11016 -- Universal_Aliasing 11017 11018 if not Has_Rep_Item (Typ, Name_Universal_Aliasing, False) 11019 and then Has_Rep_Item (Typ, Name_Universal_Aliasing) 11020 and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item 11021 (Get_Rep_Item (Typ, Name_Universal_Aliasing)) 11022 then 11023 Set_Universal_Aliasing (Imp_Bas_Typ); 11024 end if; 11025 11026 -- Bit_Order 11027 11028 if Is_Record_Type (Typ) then 11029 if not Has_Rep_Item (Typ, Name_Bit_Order, False) 11030 and then Has_Rep_Item (Typ, Name_Bit_Order) 11031 then 11032 Set_Reverse_Bit_Order (Bas_Typ, 11033 Reverse_Bit_Order (Entity (Name 11034 (Get_Rep_Item (Typ, Name_Bit_Order))))); 11035 end if; 11036 end if; 11037 11038 -- Scalar_Storage_Order 11039 11040 -- Note: the aspect is specified on a first subtype, but recorded 11041 -- in a flag of the base type! 11042 11043 if (Is_Record_Type (Typ) or else Is_Array_Type (Typ)) 11044 and then Typ = Bas_Typ 11045 then 11046 -- For a type extension, always inherit from parent; otherwise 11047 -- inherit if no default applies. Note: we do not check for 11048 -- an explicit rep item on the parent type when inheriting, 11049 -- because the parent SSO may itself have been set by default. 11050 11051 if not Has_Rep_Item (First_Subtype (Typ), 11052 Name_Scalar_Storage_Order, False) 11053 and then (Is_Tagged_Type (Bas_Typ) 11054 or else not (SSO_Set_Low_By_Default (Bas_Typ) 11055 or else 11056 SSO_Set_High_By_Default (Bas_Typ))) 11057 then 11058 Set_Reverse_Storage_Order (Bas_Typ, 11059 Reverse_Storage_Order 11060 (Implementation_Base_Type (Etype (Bas_Typ)))); 11061 11062 -- Clear default SSO indications, since the inherited aspect 11063 -- which was set explicitly overrides the default. 11064 11065 Set_SSO_Set_Low_By_Default (Bas_Typ, False); 11066 Set_SSO_Set_High_By_Default (Bas_Typ, False); 11067 end if; 11068 end if; 11069 end; 11070 end if; 11071 end Inherit_Aspects_At_Freeze_Point; 11072 11073 ---------------- 11074 -- Initialize -- 11075 ---------------- 11076 11077 procedure Initialize is 11078 begin 11079 Address_Clause_Checks.Init; 11080 Unchecked_Conversions.Init; 11081 11082 if VM_Target /= No_VM or else AAMP_On_Target then 11083 Independence_Checks.Init; 11084 end if; 11085 end Initialize; 11086 11087 --------------------------- 11088 -- Install_Discriminants -- 11089 --------------------------- 11090 11091 procedure Install_Discriminants (E : Entity_Id) is 11092 Disc : Entity_Id; 11093 Prev : Entity_Id; 11094 begin 11095 Disc := First_Discriminant (E); 11096 while Present (Disc) loop 11097 Prev := Current_Entity (Disc); 11098 Set_Current_Entity (Disc); 11099 Set_Is_Immediately_Visible (Disc); 11100 Set_Homonym (Disc, Prev); 11101 Next_Discriminant (Disc); 11102 end loop; 11103 end Install_Discriminants; 11104 11105 ------------------------- 11106 -- Is_Operational_Item -- 11107 ------------------------- 11108 11109 function Is_Operational_Item (N : Node_Id) return Boolean is 11110 begin 11111 if Nkind (N) /= N_Attribute_Definition_Clause then 11112 return False; 11113 11114 else 11115 declare 11116 Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); 11117 begin 11118 return Id = Attribute_Input 11119 or else Id = Attribute_Output 11120 or else Id = Attribute_Read 11121 or else Id = Attribute_Write 11122 or else Id = Attribute_External_Tag; 11123 end; 11124 end if; 11125 end Is_Operational_Item; 11126 11127 ------------------------- 11128 -- Is_Predicate_Static -- 11129 ------------------------- 11130 11131 -- Note: the basic legality of the expression has already been checked, so 11132 -- we don't need to worry about cases or ranges on strings for example. 11133 11134 function Is_Predicate_Static 11135 (Expr : Node_Id; 11136 Nam : Name_Id) return Boolean 11137 is 11138 function All_Static_Case_Alternatives (L : List_Id) return Boolean; 11139 -- Given a list of case expression alternatives, returns True if all 11140 -- the alternatives are static (have all static choices, and a static 11141 -- expression). 11142 11143 function All_Static_Choices (L : List_Id) return Boolean; 11144 -- Returns true if all elements of the list are OK static choices 11145 -- as defined below for Is_Static_Choice. Used for case expression 11146 -- alternatives and for the right operand of a membership test. An 11147 -- others_choice is static if the corresponding expression is static. 11148 -- The staticness of the bounds is checked separately. 11149 11150 function Is_Static_Choice (N : Node_Id) return Boolean; 11151 -- Returns True if N represents a static choice (static subtype, or 11152 -- static subtype indication, or static expression, or static range). 11153 -- 11154 -- Note that this is a bit more inclusive than we actually need 11155 -- (in particular membership tests do not allow the use of subtype 11156 -- indications). But that doesn't matter, we have already checked 11157 -- that the construct is legal to get this far. 11158 11159 function Is_Type_Ref (N : Node_Id) return Boolean; 11160 pragma Inline (Is_Type_Ref); 11161 -- Returns True if N is a reference to the type for the predicate in the 11162 -- expression (i.e. if it is an identifier whose Chars field matches the 11163 -- Nam given in the call). N must not be parenthesized, if the type name 11164 -- appears in parens, this routine will return False. 11165 11166 ---------------------------------- 11167 -- All_Static_Case_Alternatives -- 11168 ---------------------------------- 11169 11170 function All_Static_Case_Alternatives (L : List_Id) return Boolean is 11171 N : Node_Id; 11172 11173 begin 11174 N := First (L); 11175 while Present (N) loop 11176 if not (All_Static_Choices (Discrete_Choices (N)) 11177 and then Is_OK_Static_Expression (Expression (N))) 11178 then 11179 return False; 11180 end if; 11181 11182 Next (N); 11183 end loop; 11184 11185 return True; 11186 end All_Static_Case_Alternatives; 11187 11188 ------------------------ 11189 -- All_Static_Choices -- 11190 ------------------------ 11191 11192 function All_Static_Choices (L : List_Id) return Boolean is 11193 N : Node_Id; 11194 11195 begin 11196 N := First (L); 11197 while Present (N) loop 11198 if not Is_Static_Choice (N) then 11199 return False; 11200 end if; 11201 11202 Next (N); 11203 end loop; 11204 11205 return True; 11206 end All_Static_Choices; 11207 11208 ---------------------- 11209 -- Is_Static_Choice -- 11210 ---------------------- 11211 11212 function Is_Static_Choice (N : Node_Id) return Boolean is 11213 begin 11214 return Nkind (N) = N_Others_Choice 11215 or else Is_OK_Static_Expression (N) 11216 or else (Is_Entity_Name (N) and then Is_Type (Entity (N)) 11217 and then Is_OK_Static_Subtype (Entity (N))) 11218 or else (Nkind (N) = N_Subtype_Indication 11219 and then Is_OK_Static_Subtype (Entity (N))) 11220 or else (Nkind (N) = N_Range and then Is_OK_Static_Range (N)); 11221 end Is_Static_Choice; 11222 11223 ----------------- 11224 -- Is_Type_Ref -- 11225 ----------------- 11226 11227 function Is_Type_Ref (N : Node_Id) return Boolean is 11228 begin 11229 return Nkind (N) = N_Identifier 11230 and then Chars (N) = Nam 11231 and then Paren_Count (N) = 0; 11232 end Is_Type_Ref; 11233 11234 -- Start of processing for Is_Predicate_Static 11235 11236 begin 11237 -- Predicate_Static means one of the following holds. Numbers are the 11238 -- corresponding paragraph numbers in (RM 3.2.4(16-22)). 11239 11240 -- 16: A static expression 11241 11242 if Is_OK_Static_Expression (Expr) then 11243 return True; 11244 11245 -- 17: A membership test whose simple_expression is the current 11246 -- instance, and whose membership_choice_list meets the requirements 11247 -- for a static membership test. 11248 11249 elsif Nkind (Expr) in N_Membership_Test 11250 and then ((Present (Right_Opnd (Expr)) 11251 and then Is_Static_Choice (Right_Opnd (Expr))) 11252 or else 11253 (Present (Alternatives (Expr)) 11254 and then All_Static_Choices (Alternatives (Expr)))) 11255 then 11256 return True; 11257 11258 -- 18. A case_expression whose selecting_expression is the current 11259 -- instance, and whose dependent expressions are static expressions. 11260 11261 elsif Nkind (Expr) = N_Case_Expression 11262 and then Is_Type_Ref (Expression (Expr)) 11263 and then All_Static_Case_Alternatives (Alternatives (Expr)) 11264 then 11265 return True; 11266 11267 -- 19. A call to a predefined equality or ordering operator, where one 11268 -- operand is the current instance, and the other is a static 11269 -- expression. 11270 11271 -- Note: the RM is clearly wrong here in not excluding string types. 11272 -- Without this exclusion, we would allow expressions like X > "ABC" 11273 -- to be considered as predicate-static, which is clearly not intended, 11274 -- since the idea is for predicate-static to be a subset of normal 11275 -- static expressions (and "DEF" > "ABC" is not a static expression). 11276 11277 -- However, we do allow internally generated (not from source) equality 11278 -- and inequality operations to be valid on strings (this helps deal 11279 -- with cases where we transform A in "ABC" to A = "ABC). 11280 11281 elsif Nkind (Expr) in N_Op_Compare 11282 and then ((not Is_String_Type (Etype (Left_Opnd (Expr)))) 11283 or else (Nkind_In (Expr, N_Op_Eq, N_Op_Ne) 11284 and then not Comes_From_Source (Expr))) 11285 and then ((Is_Type_Ref (Left_Opnd (Expr)) 11286 and then Is_OK_Static_Expression (Right_Opnd (Expr))) 11287 or else 11288 (Is_Type_Ref (Right_Opnd (Expr)) 11289 and then Is_OK_Static_Expression (Left_Opnd (Expr)))) 11290 then 11291 return True; 11292 11293 -- 20. A call to a predefined boolean logical operator, where each 11294 -- operand is predicate-static. 11295 11296 elsif (Nkind_In (Expr, N_Op_And, N_Op_Or, N_Op_Xor) 11297 and then Is_Predicate_Static (Left_Opnd (Expr), Nam) 11298 and then Is_Predicate_Static (Right_Opnd (Expr), Nam)) 11299 or else 11300 (Nkind (Expr) = N_Op_Not 11301 and then Is_Predicate_Static (Right_Opnd (Expr), Nam)) 11302 then 11303 return True; 11304 11305 -- 21. A short-circuit control form where both operands are 11306 -- predicate-static. 11307 11308 elsif Nkind (Expr) in N_Short_Circuit 11309 and then Is_Predicate_Static (Left_Opnd (Expr), Nam) 11310 and then Is_Predicate_Static (Right_Opnd (Expr), Nam) 11311 then 11312 return True; 11313 11314 -- 22. A parenthesized predicate-static expression. This does not 11315 -- require any special test, since we just ignore paren levels in 11316 -- all the cases above. 11317 11318 -- One more test that is an implementation artifact caused by the fact 11319 -- that we are analyzing not the original expression, but the generated 11320 -- expression in the body of the predicate function. This can include 11321 -- references to inherited predicates, so that the expression we are 11322 -- processing looks like: 11323 11324 -- expression and then xxPredicate (typ (Inns)) 11325 11326 -- Where the call is to a Predicate function for an inherited predicate. 11327 -- We simply ignore such a call, which could be to either a dynamic or 11328 -- a static predicate. Note that if the parent predicate is dynamic then 11329 -- eventually this type will be marked as dynamic, but you are allowed 11330 -- to specify a static predicate for a subtype which is inheriting a 11331 -- dynamic predicate, so the static predicate validation here ignores 11332 -- the inherited predicate even if it is dynamic. 11333 11334 elsif Nkind (Expr) = N_Function_Call 11335 and then Is_Predicate_Function (Entity (Name (Expr))) 11336 then 11337 return True; 11338 11339 -- That's an exhaustive list of tests, all other cases are not 11340 -- predicate-static, so we return False. 11341 11342 else 11343 return False; 11344 end if; 11345 end Is_Predicate_Static; 11346 11347 --------------------- 11348 -- Kill_Rep_Clause -- 11349 --------------------- 11350 11351 procedure Kill_Rep_Clause (N : Node_Id) is 11352 begin 11353 pragma Assert (Ignore_Rep_Clauses); 11354 11355 -- Note: we use Replace rather than Rewrite, because we don't want 11356 -- ASIS to be able to use Original_Node to dig out the (undecorated) 11357 -- rep clause that is being replaced. 11358 11359 Replace (N, Make_Null_Statement (Sloc (N))); 11360 11361 -- The null statement must be marked as not coming from source. This is 11362 -- so that ASIS ignores it, and also the back end does not expect bogus 11363 -- "from source" null statements in weird places (e.g. in declarative 11364 -- regions where such null statements are not allowed). 11365 11366 Set_Comes_From_Source (N, False); 11367 end Kill_Rep_Clause; 11368 11369 ------------------ 11370 -- Minimum_Size -- 11371 ------------------ 11372 11373 function Minimum_Size 11374 (T : Entity_Id; 11375 Biased : Boolean := False) return Nat 11376 is 11377 Lo : Uint := No_Uint; 11378 Hi : Uint := No_Uint; 11379 LoR : Ureal := No_Ureal; 11380 HiR : Ureal := No_Ureal; 11381 LoSet : Boolean := False; 11382 HiSet : Boolean := False; 11383 B : Uint; 11384 S : Nat; 11385 Ancest : Entity_Id; 11386 R_Typ : constant Entity_Id := Root_Type (T); 11387 11388 begin 11389 -- If bad type, return 0 11390 11391 if T = Any_Type then 11392 return 0; 11393 11394 -- For generic types, just return zero. There cannot be any legitimate 11395 -- need to know such a size, but this routine may be called with a 11396 -- generic type as part of normal processing. 11397 11398 elsif Is_Generic_Type (R_Typ) or else R_Typ = Any_Type then 11399 return 0; 11400 11401 -- Access types (cannot have size smaller than System.Address) 11402 11403 elsif Is_Access_Type (T) then 11404 return System_Address_Size; 11405 11406 -- Floating-point types 11407 11408 elsif Is_Floating_Point_Type (T) then 11409 return UI_To_Int (Esize (R_Typ)); 11410 11411 -- Discrete types 11412 11413 elsif Is_Discrete_Type (T) then 11414 11415 -- The following loop is looking for the nearest compile time known 11416 -- bounds following the ancestor subtype chain. The idea is to find 11417 -- the most restrictive known bounds information. 11418 11419 Ancest := T; 11420 loop 11421 if Ancest = Any_Type or else Etype (Ancest) = Any_Type then 11422 return 0; 11423 end if; 11424 11425 if not LoSet then 11426 if Compile_Time_Known_Value (Type_Low_Bound (Ancest)) then 11427 Lo := Expr_Rep_Value (Type_Low_Bound (Ancest)); 11428 LoSet := True; 11429 exit when HiSet; 11430 end if; 11431 end if; 11432 11433 if not HiSet then 11434 if Compile_Time_Known_Value (Type_High_Bound (Ancest)) then 11435 Hi := Expr_Rep_Value (Type_High_Bound (Ancest)); 11436 HiSet := True; 11437 exit when LoSet; 11438 end if; 11439 end if; 11440 11441 Ancest := Ancestor_Subtype (Ancest); 11442 11443 if No (Ancest) then 11444 Ancest := Base_Type (T); 11445 11446 if Is_Generic_Type (Ancest) then 11447 return 0; 11448 end if; 11449 end if; 11450 end loop; 11451 11452 -- Fixed-point types. We can't simply use Expr_Value to get the 11453 -- Corresponding_Integer_Value values of the bounds, since these do not 11454 -- get set till the type is frozen, and this routine can be called 11455 -- before the type is frozen. Similarly the test for bounds being static 11456 -- needs to include the case where we have unanalyzed real literals for 11457 -- the same reason. 11458 11459 elsif Is_Fixed_Point_Type (T) then 11460 11461 -- The following loop is looking for the nearest compile time known 11462 -- bounds following the ancestor subtype chain. The idea is to find 11463 -- the most restrictive known bounds information. 11464 11465 Ancest := T; 11466 loop 11467 if Ancest = Any_Type or else Etype (Ancest) = Any_Type then 11468 return 0; 11469 end if; 11470 11471 -- Note: In the following two tests for LoSet and HiSet, it may 11472 -- seem redundant to test for N_Real_Literal here since normally 11473 -- one would assume that the test for the value being known at 11474 -- compile time includes this case. However, there is a glitch. 11475 -- If the real literal comes from folding a non-static expression, 11476 -- then we don't consider any non- static expression to be known 11477 -- at compile time if we are in configurable run time mode (needed 11478 -- in some cases to give a clearer definition of what is and what 11479 -- is not accepted). So the test is indeed needed. Without it, we 11480 -- would set neither Lo_Set nor Hi_Set and get an infinite loop. 11481 11482 if not LoSet then 11483 if Nkind (Type_Low_Bound (Ancest)) = N_Real_Literal 11484 or else Compile_Time_Known_Value (Type_Low_Bound (Ancest)) 11485 then 11486 LoR := Expr_Value_R (Type_Low_Bound (Ancest)); 11487 LoSet := True; 11488 exit when HiSet; 11489 end if; 11490 end if; 11491 11492 if not HiSet then 11493 if Nkind (Type_High_Bound (Ancest)) = N_Real_Literal 11494 or else Compile_Time_Known_Value (Type_High_Bound (Ancest)) 11495 then 11496 HiR := Expr_Value_R (Type_High_Bound (Ancest)); 11497 HiSet := True; 11498 exit when LoSet; 11499 end if; 11500 end if; 11501 11502 Ancest := Ancestor_Subtype (Ancest); 11503 11504 if No (Ancest) then 11505 Ancest := Base_Type (T); 11506 11507 if Is_Generic_Type (Ancest) then 11508 return 0; 11509 end if; 11510 end if; 11511 end loop; 11512 11513 Lo := UR_To_Uint (LoR / Small_Value (T)); 11514 Hi := UR_To_Uint (HiR / Small_Value (T)); 11515 11516 -- No other types allowed 11517 11518 else 11519 raise Program_Error; 11520 end if; 11521 11522 -- Fall through with Hi and Lo set. Deal with biased case 11523 11524 if (Biased 11525 and then not Is_Fixed_Point_Type (T) 11526 and then not (Is_Enumeration_Type (T) 11527 and then Has_Non_Standard_Rep (T))) 11528 or else Has_Biased_Representation (T) 11529 then 11530 Hi := Hi - Lo; 11531 Lo := Uint_0; 11532 end if; 11533 11534 -- Signed case. Note that we consider types like range 1 .. -1 to be 11535 -- signed for the purpose of computing the size, since the bounds have 11536 -- to be accommodated in the base type. 11537 11538 if Lo < 0 or else Hi < 0 then 11539 S := 1; 11540 B := Uint_1; 11541 11542 -- S = size, B = 2 ** (size - 1) (can accommodate -B .. +(B - 1)) 11543 -- Note that we accommodate the case where the bounds cross. This 11544 -- can happen either because of the way the bounds are declared 11545 -- or because of the algorithm in Freeze_Fixed_Point_Type. 11546 11547 while Lo < -B 11548 or else Hi < -B 11549 or else Lo >= B 11550 or else Hi >= B 11551 loop 11552 B := Uint_2 ** S; 11553 S := S + 1; 11554 end loop; 11555 11556 -- Unsigned case 11557 11558 else 11559 -- If both bounds are positive, make sure that both are represen- 11560 -- table in the case where the bounds are crossed. This can happen 11561 -- either because of the way the bounds are declared, or because of 11562 -- the algorithm in Freeze_Fixed_Point_Type. 11563 11564 if Lo > Hi then 11565 Hi := Lo; 11566 end if; 11567 11568 -- S = size, (can accommodate 0 .. (2**size - 1)) 11569 11570 S := 0; 11571 while Hi >= Uint_2 ** S loop 11572 S := S + 1; 11573 end loop; 11574 end if; 11575 11576 return S; 11577 end Minimum_Size; 11578 11579 --------------------------- 11580 -- New_Stream_Subprogram -- 11581 --------------------------- 11582 11583 procedure New_Stream_Subprogram 11584 (N : Node_Id; 11585 Ent : Entity_Id; 11586 Subp : Entity_Id; 11587 Nam : TSS_Name_Type) 11588 is 11589 Loc : constant Source_Ptr := Sloc (N); 11590 Sname : constant Name_Id := Make_TSS_Name (Base_Type (Ent), Nam); 11591 Subp_Id : Entity_Id; 11592 Subp_Decl : Node_Id; 11593 F : Entity_Id; 11594 Etyp : Entity_Id; 11595 11596 Defer_Declaration : constant Boolean := 11597 Is_Tagged_Type (Ent) or else Is_Private_Type (Ent); 11598 -- For a tagged type, there is a declaration for each stream attribute 11599 -- at the freeze point, and we must generate only a completion of this 11600 -- declaration. We do the same for private types, because the full view 11601 -- might be tagged. Otherwise we generate a declaration at the point of 11602 -- the attribute definition clause. 11603 11604 function Build_Spec return Node_Id; 11605 -- Used for declaration and renaming declaration, so that this is 11606 -- treated as a renaming_as_body. 11607 11608 ---------------- 11609 -- Build_Spec -- 11610 ---------------- 11611 11612 function Build_Spec return Node_Id is 11613 Out_P : constant Boolean := (Nam = TSS_Stream_Read); 11614 Formals : List_Id; 11615 Spec : Node_Id; 11616 T_Ref : constant Node_Id := New_Occurrence_Of (Etyp, Loc); 11617 11618 begin 11619 Subp_Id := Make_Defining_Identifier (Loc, Sname); 11620 11621 -- S : access Root_Stream_Type'Class 11622 11623 Formals := New_List ( 11624 Make_Parameter_Specification (Loc, 11625 Defining_Identifier => 11626 Make_Defining_Identifier (Loc, Name_S), 11627 Parameter_Type => 11628 Make_Access_Definition (Loc, 11629 Subtype_Mark => 11630 New_Occurrence_Of ( 11631 Designated_Type (Etype (F)), Loc)))); 11632 11633 if Nam = TSS_Stream_Input then 11634 Spec := 11635 Make_Function_Specification (Loc, 11636 Defining_Unit_Name => Subp_Id, 11637 Parameter_Specifications => Formals, 11638 Result_Definition => T_Ref); 11639 else 11640 -- V : [out] T 11641 11642 Append_To (Formals, 11643 Make_Parameter_Specification (Loc, 11644 Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), 11645 Out_Present => Out_P, 11646 Parameter_Type => T_Ref)); 11647 11648 Spec := 11649 Make_Procedure_Specification (Loc, 11650 Defining_Unit_Name => Subp_Id, 11651 Parameter_Specifications => Formals); 11652 end if; 11653 11654 return Spec; 11655 end Build_Spec; 11656 11657 -- Start of processing for New_Stream_Subprogram 11658 11659 begin 11660 F := First_Formal (Subp); 11661 11662 if Ekind (Subp) = E_Procedure then 11663 Etyp := Etype (Next_Formal (F)); 11664 else 11665 Etyp := Etype (Subp); 11666 end if; 11667 11668 -- Prepare subprogram declaration and insert it as an action on the 11669 -- clause node. The visibility for this entity is used to test for 11670 -- visibility of the attribute definition clause (in the sense of 11671 -- 8.3(23) as amended by AI-195). 11672 11673 if not Defer_Declaration then 11674 Subp_Decl := 11675 Make_Subprogram_Declaration (Loc, 11676 Specification => Build_Spec); 11677 11678 -- For a tagged type, there is always a visible declaration for each 11679 -- stream TSS (it is a predefined primitive operation), and the 11680 -- completion of this declaration occurs at the freeze point, which is 11681 -- not always visible at places where the attribute definition clause is 11682 -- visible. So, we create a dummy entity here for the purpose of 11683 -- tracking the visibility of the attribute definition clause itself. 11684 11685 else 11686 Subp_Id := 11687 Make_Defining_Identifier (Loc, New_External_Name (Sname, 'V')); 11688 Subp_Decl := 11689 Make_Object_Declaration (Loc, 11690 Defining_Identifier => Subp_Id, 11691 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc)); 11692 end if; 11693 11694 Insert_Action (N, Subp_Decl); 11695 Set_Entity (N, Subp_Id); 11696 11697 Subp_Decl := 11698 Make_Subprogram_Renaming_Declaration (Loc, 11699 Specification => Build_Spec, 11700 Name => New_Occurrence_Of (Subp, Loc)); 11701 11702 if Defer_Declaration then 11703 Set_TSS (Base_Type (Ent), Subp_Id); 11704 else 11705 Insert_Action (N, Subp_Decl); 11706 Copy_TSS (Subp_Id, Base_Type (Ent)); 11707 end if; 11708 end New_Stream_Subprogram; 11709 11710 ------------------------------------------ 11711 -- Push_Scope_And_Install_Discriminants -- 11712 ------------------------------------------ 11713 11714 procedure Push_Scope_And_Install_Discriminants (E : Entity_Id) is 11715 begin 11716 if Has_Discriminants (E) then 11717 Push_Scope (E); 11718 11719 -- Make discriminants visible for type declarations and protected 11720 -- type declarations, not for subtype declarations (RM 13.1.1 (12/3)) 11721 11722 if Nkind (Parent (E)) /= N_Subtype_Declaration then 11723 Install_Discriminants (E); 11724 end if; 11725 end if; 11726 end Push_Scope_And_Install_Discriminants; 11727 11728 ------------------------ 11729 -- Rep_Item_Too_Early -- 11730 ------------------------ 11731 11732 function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean is 11733 begin 11734 -- Cannot apply non-operational rep items to generic types 11735 11736 if Is_Operational_Item (N) then 11737 return False; 11738 11739 elsif Is_Type (T) 11740 and then Is_Generic_Type (Root_Type (T)) 11741 and then (Nkind (N) /= N_Pragma 11742 or else Get_Pragma_Id (N) /= Pragma_Convention) 11743 then 11744 Error_Msg_N ("representation item not allowed for generic type", N); 11745 return True; 11746 end if; 11747 11748 -- Otherwise check for incomplete type 11749 11750 if Is_Incomplete_Or_Private_Type (T) 11751 and then No (Underlying_Type (T)) 11752 and then 11753 (Nkind (N) /= N_Pragma 11754 or else Get_Pragma_Id (N) /= Pragma_Import) 11755 then 11756 Error_Msg_N 11757 ("representation item must be after full type declaration", N); 11758 return True; 11759 11760 -- If the type has incomplete components, a representation clause is 11761 -- illegal but stream attributes and Convention pragmas are correct. 11762 11763 elsif Has_Private_Component (T) then 11764 if Nkind (N) = N_Pragma then 11765 return False; 11766 11767 else 11768 Error_Msg_N 11769 ("representation item must appear after type is fully defined", 11770 N); 11771 return True; 11772 end if; 11773 else 11774 return False; 11775 end if; 11776 end Rep_Item_Too_Early; 11777 11778 ----------------------- 11779 -- Rep_Item_Too_Late -- 11780 ----------------------- 11781 11782 function Rep_Item_Too_Late 11783 (T : Entity_Id; 11784 N : Node_Id; 11785 FOnly : Boolean := False) return Boolean 11786 is 11787 S : Entity_Id; 11788 Parent_Type : Entity_Id; 11789 11790 procedure No_Type_Rep_Item; 11791 -- Output message indicating that no type-related aspects can be 11792 -- specified due to some property of the parent type. 11793 11794 procedure Too_Late; 11795 -- Output message for an aspect being specified too late 11796 11797 -- Note that neither of the above errors is considered a serious one, 11798 -- since the effect is simply that we ignore the representation clause 11799 -- in these cases. 11800 -- Is this really true? In any case if we make this change we must 11801 -- document the requirement in the spec of Rep_Item_Too_Late that 11802 -- if True is returned, then the rep item must be completely ignored??? 11803 11804 ---------------------- 11805 -- No_Type_Rep_Item -- 11806 ---------------------- 11807 11808 procedure No_Type_Rep_Item is 11809 begin 11810 Error_Msg_N ("|type-related representation item not permitted!", N); 11811 end No_Type_Rep_Item; 11812 11813 -------------- 11814 -- Too_Late -- 11815 -------------- 11816 11817 procedure Too_Late is 11818 begin 11819 -- Other compilers seem more relaxed about rep items appearing too 11820 -- late. Since analysis tools typically don't care about rep items 11821 -- anyway, no reason to be too strict about this. 11822 11823 if not Relaxed_RM_Semantics then 11824 Error_Msg_N ("|representation item appears too late!", N); 11825 end if; 11826 end Too_Late; 11827 11828 -- Start of processing for Rep_Item_Too_Late 11829 11830 begin 11831 -- First make sure entity is not frozen (RM 13.1(9)) 11832 11833 if Is_Frozen (T) 11834 11835 -- Exclude imported types, which may be frozen if they appear in a 11836 -- representation clause for a local type. 11837 11838 and then not From_Limited_With (T) 11839 11840 -- Exclude generated entities (not coming from source). The common 11841 -- case is when we generate a renaming which prematurely freezes the 11842 -- renamed internal entity, but we still want to be able to set copies 11843 -- of attribute values such as Size/Alignment. 11844 11845 and then Comes_From_Source (T) 11846 then 11847 Too_Late; 11848 S := First_Subtype (T); 11849 11850 if Present (Freeze_Node (S)) then 11851 if not Relaxed_RM_Semantics then 11852 Error_Msg_NE 11853 ("??no more representation items for }", Freeze_Node (S), S); 11854 end if; 11855 end if; 11856 11857 return True; 11858 11859 -- Check for case of untagged derived type whose parent either has 11860 -- primitive operations, or is a by reference type (RM 13.1(10)). In 11861 -- this case we do not output a Too_Late message, since there is no 11862 -- earlier point where the rep item could be placed to make it legal. 11863 11864 elsif Is_Type (T) 11865 and then not FOnly 11866 and then Is_Derived_Type (T) 11867 and then not Is_Tagged_Type (T) 11868 then 11869 Parent_Type := Etype (Base_Type (T)); 11870 11871 if Has_Primitive_Operations (Parent_Type) then 11872 No_Type_Rep_Item; 11873 11874 if not Relaxed_RM_Semantics then 11875 Error_Msg_NE 11876 ("\parent type & has primitive operations!", N, Parent_Type); 11877 end if; 11878 11879 return True; 11880 11881 elsif Is_By_Reference_Type (Parent_Type) then 11882 No_Type_Rep_Item; 11883 11884 if not Relaxed_RM_Semantics then 11885 Error_Msg_NE 11886 ("\parent type & is a by reference type!", N, Parent_Type); 11887 end if; 11888 11889 return True; 11890 end if; 11891 end if; 11892 11893 -- No error, but one more warning to consider. The RM (surprisingly) 11894 -- allows this pattern: 11895 11896 -- type S is ... 11897 -- primitive operations for S 11898 -- type R is new S; 11899 -- rep clause for S 11900 11901 -- Meaning that calls on the primitive operations of S for values of 11902 -- type R may require possibly expensive implicit conversion operations. 11903 -- This is not an error, but is worth a warning. 11904 11905 if not Relaxed_RM_Semantics and then Is_Type (T) then 11906 declare 11907 DTL : constant Entity_Id := Derived_Type_Link (Base_Type (T)); 11908 11909 begin 11910 if Present (DTL) 11911 and then Has_Primitive_Operations (Base_Type (T)) 11912 11913 -- For now, do not generate this warning for the case of aspect 11914 -- specification using Ada 2012 syntax, since we get wrong 11915 -- messages we do not understand. The whole business of derived 11916 -- types and rep items seems a bit confused when aspects are 11917 -- used, since the aspects are not evaluated till freeze time. 11918 11919 and then not From_Aspect_Specification (N) 11920 then 11921 Error_Msg_Sloc := Sloc (DTL); 11922 Error_Msg_N 11923 ("representation item for& appears after derived type " 11924 & "declaration#??", N); 11925 Error_Msg_NE 11926 ("\may result in implicit conversions for primitive " 11927 & "operations of&??", N, T); 11928 Error_Msg_NE 11929 ("\to change representations when called with arguments " 11930 & "of type&??", N, DTL); 11931 end if; 11932 end; 11933 end if; 11934 11935 -- No error, link item into head of chain of rep items for the entity, 11936 -- but avoid chaining if we have an overloadable entity, and the pragma 11937 -- is one that can apply to multiple overloaded entities. 11938 11939 if Is_Overloadable (T) and then Nkind (N) = N_Pragma then 11940 declare 11941 Pname : constant Name_Id := Pragma_Name (N); 11942 begin 11943 if Nam_In (Pname, Name_Convention, Name_Import, Name_Export, 11944 Name_External, Name_Interface) 11945 then 11946 return False; 11947 end if; 11948 end; 11949 end if; 11950 11951 Record_Rep_Item (T, N); 11952 return False; 11953 end Rep_Item_Too_Late; 11954 11955 ------------------------------------- 11956 -- Replace_Type_References_Generic -- 11957 ------------------------------------- 11958 11959 procedure Replace_Type_References_Generic (N : Node_Id; T : Entity_Id) is 11960 TName : constant Name_Id := Chars (T); 11961 11962 function Replace_Node (N : Node_Id) return Traverse_Result; 11963 -- Processes a single node in the traversal procedure below, checking 11964 -- if node N should be replaced, and if so, doing the replacement. 11965 11966 procedure Replace_Type_Refs is new Traverse_Proc (Replace_Node); 11967 -- This instantiation provides the body of Replace_Type_References 11968 11969 ------------------ 11970 -- Replace_Node -- 11971 ------------------ 11972 11973 function Replace_Node (N : Node_Id) return Traverse_Result is 11974 S : Entity_Id; 11975 P : Node_Id; 11976 11977 begin 11978 -- Case of identifier 11979 11980 if Nkind (N) = N_Identifier then 11981 11982 -- If not the type name, check whether it is a reference to 11983 -- some other type, which must be frozen before the predicate 11984 -- function is analyzed, i.e. before the freeze node of the 11985 -- type to which the predicate applies. 11986 11987 if Chars (N) /= TName then 11988 if Present (Current_Entity (N)) 11989 and then Is_Type (Current_Entity (N)) 11990 then 11991 Freeze_Before (Freeze_Node (T), Current_Entity (N)); 11992 end if; 11993 11994 return Skip; 11995 11996 -- Otherwise do the replacement and we are done with this node 11997 11998 else 11999 Replace_Type_Reference (N); 12000 return Skip; 12001 end if; 12002 12003 -- Case of selected component (which is what a qualification 12004 -- looks like in the unanalyzed tree, which is what we have. 12005 12006 elsif Nkind (N) = N_Selected_Component then 12007 12008 -- If selector name is not our type, keeping going (we might 12009 -- still have an occurrence of the type in the prefix). 12010 12011 if Nkind (Selector_Name (N)) /= N_Identifier 12012 or else Chars (Selector_Name (N)) /= TName 12013 then 12014 return OK; 12015 12016 -- Selector name is our type, check qualification 12017 12018 else 12019 -- Loop through scopes and prefixes, doing comparison 12020 12021 S := Current_Scope; 12022 P := Prefix (N); 12023 loop 12024 -- Continue if no more scopes or scope with no name 12025 12026 if No (S) or else Nkind (S) not in N_Has_Chars then 12027 return OK; 12028 end if; 12029 12030 -- Do replace if prefix is an identifier matching the 12031 -- scope that we are currently looking at. 12032 12033 if Nkind (P) = N_Identifier 12034 and then Chars (P) = Chars (S) 12035 then 12036 Replace_Type_Reference (N); 12037 return Skip; 12038 end if; 12039 12040 -- Go check scope above us if prefix is itself of the 12041 -- form of a selected component, whose selector matches 12042 -- the scope we are currently looking at. 12043 12044 if Nkind (P) = N_Selected_Component 12045 and then Nkind (Selector_Name (P)) = N_Identifier 12046 and then Chars (Selector_Name (P)) = Chars (S) 12047 then 12048 S := Scope (S); 12049 P := Prefix (P); 12050 12051 -- For anything else, we don't have a match, so keep on 12052 -- going, there are still some weird cases where we may 12053 -- still have a replacement within the prefix. 12054 12055 else 12056 return OK; 12057 end if; 12058 end loop; 12059 end if; 12060 12061 -- Continue for any other node kind 12062 12063 else 12064 return OK; 12065 end if; 12066 end Replace_Node; 12067 12068 begin 12069 Replace_Type_Refs (N); 12070 end Replace_Type_References_Generic; 12071 12072 ------------------------- 12073 -- Same_Representation -- 12074 ------------------------- 12075 12076 function Same_Representation (Typ1, Typ2 : Entity_Id) return Boolean is 12077 T1 : constant Entity_Id := Underlying_Type (Typ1); 12078 T2 : constant Entity_Id := Underlying_Type (Typ2); 12079 12080 begin 12081 -- A quick check, if base types are the same, then we definitely have 12082 -- the same representation, because the subtype specific representation 12083 -- attributes (Size and Alignment) do not affect representation from 12084 -- the point of view of this test. 12085 12086 if Base_Type (T1) = Base_Type (T2) then 12087 return True; 12088 12089 elsif Is_Private_Type (Base_Type (T2)) 12090 and then Base_Type (T1) = Full_View (Base_Type (T2)) 12091 then 12092 return True; 12093 end if; 12094 12095 -- Tagged types never have differing representations 12096 12097 if Is_Tagged_Type (T1) then 12098 return True; 12099 end if; 12100 12101 -- Representations are definitely different if conventions differ 12102 12103 if Convention (T1) /= Convention (T2) then 12104 return False; 12105 end if; 12106 12107 -- Representations are different if component alignments or scalar 12108 -- storage orders differ. 12109 12110 if (Is_Record_Type (T1) or else Is_Array_Type (T1)) 12111 and then 12112 (Is_Record_Type (T2) or else Is_Array_Type (T2)) 12113 and then 12114 (Component_Alignment (T1) /= Component_Alignment (T2) 12115 or else Reverse_Storage_Order (T1) /= Reverse_Storage_Order (T2)) 12116 then 12117 return False; 12118 end if; 12119 12120 -- For arrays, the only real issue is component size. If we know the 12121 -- component size for both arrays, and it is the same, then that's 12122 -- good enough to know we don't have a change of representation. 12123 12124 if Is_Array_Type (T1) then 12125 if Known_Component_Size (T1) 12126 and then Known_Component_Size (T2) 12127 and then Component_Size (T1) = Component_Size (T2) 12128 then 12129 if VM_Target = No_VM then 12130 return True; 12131 12132 -- In VM targets the representation of arrays with aliased 12133 -- components differs from arrays with non-aliased components 12134 12135 else 12136 return Has_Aliased_Components (Base_Type (T1)) 12137 = 12138 Has_Aliased_Components (Base_Type (T2)); 12139 end if; 12140 end if; 12141 end if; 12142 12143 -- Types definitely have same representation if neither has non-standard 12144 -- representation since default representations are always consistent. 12145 -- If only one has non-standard representation, and the other does not, 12146 -- then we consider that they do not have the same representation. They 12147 -- might, but there is no way of telling early enough. 12148 12149 if Has_Non_Standard_Rep (T1) then 12150 if not Has_Non_Standard_Rep (T2) then 12151 return False; 12152 end if; 12153 else 12154 return not Has_Non_Standard_Rep (T2); 12155 end if; 12156 12157 -- Here the two types both have non-standard representation, and we need 12158 -- to determine if they have the same non-standard representation. 12159 12160 -- For arrays, we simply need to test if the component sizes are the 12161 -- same. Pragma Pack is reflected in modified component sizes, so this 12162 -- check also deals with pragma Pack. 12163 12164 if Is_Array_Type (T1) then 12165 return Component_Size (T1) = Component_Size (T2); 12166 12167 -- Tagged types always have the same representation, because it is not 12168 -- possible to specify different representations for common fields. 12169 12170 elsif Is_Tagged_Type (T1) then 12171 return True; 12172 12173 -- Case of record types 12174 12175 elsif Is_Record_Type (T1) then 12176 12177 -- Packed status must conform 12178 12179 if Is_Packed (T1) /= Is_Packed (T2) then 12180 return False; 12181 12182 -- Otherwise we must check components. Typ2 maybe a constrained 12183 -- subtype with fewer components, so we compare the components 12184 -- of the base types. 12185 12186 else 12187 Record_Case : declare 12188 CD1, CD2 : Entity_Id; 12189 12190 function Same_Rep return Boolean; 12191 -- CD1 and CD2 are either components or discriminants. This 12192 -- function tests whether they have the same representation. 12193 12194 -------------- 12195 -- Same_Rep -- 12196 -------------- 12197 12198 function Same_Rep return Boolean is 12199 begin 12200 if No (Component_Clause (CD1)) then 12201 return No (Component_Clause (CD2)); 12202 else 12203 -- Note: at this point, component clauses have been 12204 -- normalized to the default bit order, so that the 12205 -- comparison of Component_Bit_Offsets is meaningful. 12206 12207 return 12208 Present (Component_Clause (CD2)) 12209 and then 12210 Component_Bit_Offset (CD1) = Component_Bit_Offset (CD2) 12211 and then 12212 Esize (CD1) = Esize (CD2); 12213 end if; 12214 end Same_Rep; 12215 12216 -- Start of processing for Record_Case 12217 12218 begin 12219 if Has_Discriminants (T1) then 12220 12221 -- The number of discriminants may be different if the 12222 -- derived type has fewer (constrained by values). The 12223 -- invisible discriminants retain the representation of 12224 -- the original, so the discrepancy does not per se 12225 -- indicate a different representation. 12226 12227 CD1 := First_Discriminant (T1); 12228 CD2 := First_Discriminant (T2); 12229 while Present (CD1) and then Present (CD2) loop 12230 if not Same_Rep then 12231 return False; 12232 else 12233 Next_Discriminant (CD1); 12234 Next_Discriminant (CD2); 12235 end if; 12236 end loop; 12237 end if; 12238 12239 CD1 := First_Component (Underlying_Type (Base_Type (T1))); 12240 CD2 := First_Component (Underlying_Type (Base_Type (T2))); 12241 while Present (CD1) loop 12242 if not Same_Rep then 12243 return False; 12244 else 12245 Next_Component (CD1); 12246 Next_Component (CD2); 12247 end if; 12248 end loop; 12249 12250 return True; 12251 end Record_Case; 12252 end if; 12253 12254 -- For enumeration types, we must check each literal to see if the 12255 -- representation is the same. Note that we do not permit enumeration 12256 -- representation clauses for Character and Wide_Character, so these 12257 -- cases were already dealt with. 12258 12259 elsif Is_Enumeration_Type (T1) then 12260 Enumeration_Case : declare 12261 L1, L2 : Entity_Id; 12262 12263 begin 12264 L1 := First_Literal (T1); 12265 L2 := First_Literal (T2); 12266 while Present (L1) loop 12267 if Enumeration_Rep (L1) /= Enumeration_Rep (L2) then 12268 return False; 12269 else 12270 Next_Literal (L1); 12271 Next_Literal (L2); 12272 end if; 12273 end loop; 12274 12275 return True; 12276 end Enumeration_Case; 12277 12278 -- Any other types have the same representation for these purposes 12279 12280 else 12281 return True; 12282 end if; 12283 end Same_Representation; 12284 12285 -------------------------------- 12286 -- Resolve_Iterable_Operation -- 12287 -------------------------------- 12288 12289 procedure Resolve_Iterable_Operation 12290 (N : Node_Id; 12291 Cursor : Entity_Id; 12292 Typ : Entity_Id; 12293 Nam : Name_Id) 12294 is 12295 Ent : Entity_Id; 12296 F1 : Entity_Id; 12297 F2 : Entity_Id; 12298 12299 begin 12300 if not Is_Overloaded (N) then 12301 if not Is_Entity_Name (N) 12302 or else Ekind (Entity (N)) /= E_Function 12303 or else Scope (Entity (N)) /= Scope (Typ) 12304 or else No (First_Formal (Entity (N))) 12305 or else Etype (First_Formal (Entity (N))) /= Typ 12306 then 12307 Error_Msg_N ("iterable primitive must be local function name " 12308 & "whose first formal is an iterable type", N); 12309 return; 12310 end if; 12311 12312 Ent := Entity (N); 12313 F1 := First_Formal (Ent); 12314 if Nam = Name_First then 12315 12316 -- First (Container) => Cursor 12317 12318 if Etype (Ent) /= Cursor then 12319 Error_Msg_N ("primitive for First must yield a curosr", N); 12320 end if; 12321 12322 elsif Nam = Name_Next then 12323 12324 -- Next (Container, Cursor) => Cursor 12325 12326 F2 := Next_Formal (F1); 12327 12328 if Etype (F2) /= Cursor 12329 or else Etype (Ent) /= Cursor 12330 or else Present (Next_Formal (F2)) 12331 then 12332 Error_Msg_N ("no match for Next iterable primitive", N); 12333 end if; 12334 12335 elsif Nam = Name_Has_Element then 12336 12337 -- Has_Element (Container, Cursor) => Boolean 12338 12339 F2 := Next_Formal (F1); 12340 if Etype (F2) /= Cursor 12341 or else Etype (Ent) /= Standard_Boolean 12342 or else Present (Next_Formal (F2)) 12343 then 12344 Error_Msg_N ("no match for Has_Element iterable primitive", N); 12345 end if; 12346 12347 elsif Nam = Name_Element then 12348 F2 := Next_Formal (F1); 12349 12350 if No (F2) 12351 or else Etype (F2) /= Cursor 12352 or else Present (Next_Formal (F2)) 12353 then 12354 Error_Msg_N ("no match for Element iterable primitive", N); 12355 end if; 12356 null; 12357 12358 else 12359 raise Program_Error; 12360 end if; 12361 12362 else 12363 -- Overloaded case: find subprogram with proper signature. 12364 -- Caller will report error if no match is found. 12365 12366 declare 12367 I : Interp_Index; 12368 It : Interp; 12369 12370 begin 12371 Get_First_Interp (N, I, It); 12372 while Present (It.Typ) loop 12373 if Ekind (It.Nam) = E_Function 12374 and then Scope (It.Nam) = Scope (Typ) 12375 and then Etype (First_Formal (It.Nam)) = Typ 12376 then 12377 F1 := First_Formal (It.Nam); 12378 12379 if Nam = Name_First then 12380 if Etype (It.Nam) = Cursor 12381 and then No (Next_Formal (F1)) 12382 then 12383 Set_Entity (N, It.Nam); 12384 exit; 12385 end if; 12386 12387 elsif Nam = Name_Next then 12388 F2 := Next_Formal (F1); 12389 12390 if Present (F2) 12391 and then No (Next_Formal (F2)) 12392 and then Etype (F2) = Cursor 12393 and then Etype (It.Nam) = Cursor 12394 then 12395 Set_Entity (N, It.Nam); 12396 exit; 12397 end if; 12398 12399 elsif Nam = Name_Has_Element then 12400 F2 := Next_Formal (F1); 12401 12402 if Present (F2) 12403 and then No (Next_Formal (F2)) 12404 and then Etype (F2) = Cursor 12405 and then Etype (It.Nam) = Standard_Boolean 12406 then 12407 Set_Entity (N, It.Nam); 12408 F2 := Next_Formal (F1); 12409 exit; 12410 end if; 12411 12412 elsif Nam = Name_Element then 12413 F2 := Next_Formal (F1); 12414 12415 if Present (F2) 12416 and then No (Next_Formal (F2)) 12417 and then Etype (F2) = Cursor 12418 then 12419 Set_Entity (N, It.Nam); 12420 exit; 12421 end if; 12422 end if; 12423 end if; 12424 12425 Get_Next_Interp (I, It); 12426 end loop; 12427 end; 12428 end if; 12429 end Resolve_Iterable_Operation; 12430 12431 ---------------- 12432 -- Set_Biased -- 12433 ---------------- 12434 12435 procedure Set_Biased 12436 (E : Entity_Id; 12437 N : Node_Id; 12438 Msg : String; 12439 Biased : Boolean := True) 12440 is 12441 begin 12442 if Biased then 12443 Set_Has_Biased_Representation (E); 12444 12445 if Warn_On_Biased_Representation then 12446 Error_Msg_NE 12447 ("?B?" & Msg & " forces biased representation for&", N, E); 12448 end if; 12449 end if; 12450 end Set_Biased; 12451 12452 -------------------- 12453 -- Set_Enum_Esize -- 12454 -------------------- 12455 12456 procedure Set_Enum_Esize (T : Entity_Id) is 12457 Lo : Uint; 12458 Hi : Uint; 12459 Sz : Nat; 12460 12461 begin 12462 Init_Alignment (T); 12463 12464 -- Find the minimum standard size (8,16,32,64) that fits 12465 12466 Lo := Enumeration_Rep (Entity (Type_Low_Bound (T))); 12467 Hi := Enumeration_Rep (Entity (Type_High_Bound (T))); 12468 12469 if Lo < 0 then 12470 if Lo >= -Uint_2**07 and then Hi < Uint_2**07 then 12471 Sz := Standard_Character_Size; -- May be > 8 on some targets 12472 12473 elsif Lo >= -Uint_2**15 and then Hi < Uint_2**15 then 12474 Sz := 16; 12475 12476 elsif Lo >= -Uint_2**31 and then Hi < Uint_2**31 then 12477 Sz := 32; 12478 12479 else pragma Assert (Lo >= -Uint_2**63 and then Hi < Uint_2**63); 12480 Sz := 64; 12481 end if; 12482 12483 else 12484 if Hi < Uint_2**08 then 12485 Sz := Standard_Character_Size; -- May be > 8 on some targets 12486 12487 elsif Hi < Uint_2**16 then 12488 Sz := 16; 12489 12490 elsif Hi < Uint_2**32 then 12491 Sz := 32; 12492 12493 else pragma Assert (Hi < Uint_2**63); 12494 Sz := 64; 12495 end if; 12496 end if; 12497 12498 -- That minimum is the proper size unless we have a foreign convention 12499 -- and the size required is 32 or less, in which case we bump the size 12500 -- up to 32. This is required for C and C++ and seems reasonable for 12501 -- all other foreign conventions. 12502 12503 if Has_Foreign_Convention (T) 12504 and then Esize (T) < Standard_Integer_Size 12505 12506 -- Don't do this if Short_Enums on target 12507 12508 and then not Target_Short_Enums 12509 then 12510 Init_Esize (T, Standard_Integer_Size); 12511 else 12512 Init_Esize (T, Sz); 12513 end if; 12514 end Set_Enum_Esize; 12515 12516 ----------------------------- 12517 -- Uninstall_Discriminants -- 12518 ----------------------------- 12519 12520 procedure Uninstall_Discriminants (E : Entity_Id) is 12521 Disc : Entity_Id; 12522 Prev : Entity_Id; 12523 Outer : Entity_Id; 12524 12525 begin 12526 -- Discriminants have been made visible for type declarations and 12527 -- protected type declarations, not for subtype declarations. 12528 12529 if Nkind (Parent (E)) /= N_Subtype_Declaration then 12530 Disc := First_Discriminant (E); 12531 while Present (Disc) loop 12532 if Disc /= Current_Entity (Disc) then 12533 Prev := Current_Entity (Disc); 12534 while Present (Prev) 12535 and then Present (Homonym (Prev)) 12536 and then Homonym (Prev) /= Disc 12537 loop 12538 Prev := Homonym (Prev); 12539 end loop; 12540 else 12541 Prev := Empty; 12542 end if; 12543 12544 Set_Is_Immediately_Visible (Disc, False); 12545 12546 Outer := Homonym (Disc); 12547 while Present (Outer) and then Scope (Outer) = E loop 12548 Outer := Homonym (Outer); 12549 end loop; 12550 12551 -- Reset homonym link of other entities, but do not modify link 12552 -- between entities in current scope, so that the back-end can 12553 -- have a proper count of local overloadings. 12554 12555 if No (Prev) then 12556 Set_Name_Entity_Id (Chars (Disc), Outer); 12557 12558 elsif Scope (Prev) /= Scope (Disc) then 12559 Set_Homonym (Prev, Outer); 12560 end if; 12561 12562 Next_Discriminant (Disc); 12563 end loop; 12564 end if; 12565 end Uninstall_Discriminants; 12566 12567 ------------------------------------------- 12568 -- Uninstall_Discriminants_And_Pop_Scope -- 12569 ------------------------------------------- 12570 12571 procedure Uninstall_Discriminants_And_Pop_Scope (E : Entity_Id) is 12572 begin 12573 if Has_Discriminants (E) then 12574 Uninstall_Discriminants (E); 12575 Pop_Scope; 12576 end if; 12577 end Uninstall_Discriminants_And_Pop_Scope; 12578 12579 ------------------------------ 12580 -- Validate_Address_Clauses -- 12581 ------------------------------ 12582 12583 procedure Validate_Address_Clauses is 12584 begin 12585 for J in Address_Clause_Checks.First .. Address_Clause_Checks.Last loop 12586 declare 12587 ACCR : Address_Clause_Check_Record 12588 renames Address_Clause_Checks.Table (J); 12589 12590 Expr : Node_Id; 12591 12592 X_Alignment : Uint; 12593 Y_Alignment : Uint; 12594 12595 X_Size : Uint; 12596 Y_Size : Uint; 12597 12598 begin 12599 -- Skip processing of this entry if warning already posted 12600 12601 if not Address_Warning_Posted (ACCR.N) then 12602 Expr := Original_Node (Expression (ACCR.N)); 12603 12604 -- Get alignments 12605 12606 X_Alignment := Alignment (ACCR.X); 12607 Y_Alignment := Alignment (ACCR.Y); 12608 12609 -- Similarly obtain sizes 12610 12611 X_Size := Esize (ACCR.X); 12612 Y_Size := Esize (ACCR.Y); 12613 12614 -- Check for large object overlaying smaller one 12615 12616 if Y_Size > Uint_0 12617 and then X_Size > Uint_0 12618 and then X_Size > Y_Size 12619 then 12620 Error_Msg_NE 12621 ("??& overlays smaller object", ACCR.N, ACCR.X); 12622 Error_Msg_N 12623 ("\??program execution may be erroneous", ACCR.N); 12624 Error_Msg_Uint_1 := X_Size; 12625 Error_Msg_NE 12626 ("\??size of & is ^", ACCR.N, ACCR.X); 12627 Error_Msg_Uint_1 := Y_Size; 12628 Error_Msg_NE 12629 ("\??size of & is ^", ACCR.N, ACCR.Y); 12630 12631 -- Check for inadequate alignment, both of the base object 12632 -- and of the offset, if any. 12633 12634 -- Note: we do not check the alignment if we gave a size 12635 -- warning, since it would likely be redundant. 12636 12637 elsif Y_Alignment /= Uint_0 12638 and then (Y_Alignment < X_Alignment 12639 or else (ACCR.Off 12640 and then 12641 Nkind (Expr) = N_Attribute_Reference 12642 and then 12643 Attribute_Name (Expr) = Name_Address 12644 and then 12645 Has_Compatible_Alignment 12646 (ACCR.X, Prefix (Expr)) 12647 /= Known_Compatible)) 12648 then 12649 Error_Msg_NE 12650 ("??specified address for& may be inconsistent " 12651 & "with alignment", ACCR.N, ACCR.X); 12652 Error_Msg_N 12653 ("\??program execution may be erroneous (RM 13.3(27))", 12654 ACCR.N); 12655 Error_Msg_Uint_1 := X_Alignment; 12656 Error_Msg_NE 12657 ("\??alignment of & is ^", ACCR.N, ACCR.X); 12658 Error_Msg_Uint_1 := Y_Alignment; 12659 Error_Msg_NE 12660 ("\??alignment of & is ^", ACCR.N, ACCR.Y); 12661 if Y_Alignment >= X_Alignment then 12662 Error_Msg_N 12663 ("\??but offset is not multiple of alignment", ACCR.N); 12664 end if; 12665 end if; 12666 end if; 12667 end; 12668 end loop; 12669 end Validate_Address_Clauses; 12670 12671 --------------------------- 12672 -- Validate_Independence -- 12673 --------------------------- 12674 12675 procedure Validate_Independence is 12676 SU : constant Uint := UI_From_Int (System_Storage_Unit); 12677 N : Node_Id; 12678 E : Entity_Id; 12679 IC : Boolean; 12680 Comp : Entity_Id; 12681 Addr : Node_Id; 12682 P : Node_Id; 12683 12684 procedure Check_Array_Type (Atyp : Entity_Id); 12685 -- Checks if the array type Atyp has independent components, and 12686 -- if not, outputs an appropriate set of error messages. 12687 12688 procedure No_Independence; 12689 -- Output message that independence cannot be guaranteed 12690 12691 function OK_Component (C : Entity_Id) return Boolean; 12692 -- Checks one component to see if it is independently accessible, and 12693 -- if so yields True, otherwise yields False if independent access 12694 -- cannot be guaranteed. This is a conservative routine, it only 12695 -- returns True if it knows for sure, it returns False if it knows 12696 -- there is a problem, or it cannot be sure there is no problem. 12697 12698 procedure Reason_Bad_Component (C : Entity_Id); 12699 -- Outputs continuation message if a reason can be determined for 12700 -- the component C being bad. 12701 12702 ---------------------- 12703 -- Check_Array_Type -- 12704 ---------------------- 12705 12706 procedure Check_Array_Type (Atyp : Entity_Id) is 12707 Ctyp : constant Entity_Id := Component_Type (Atyp); 12708 12709 begin 12710 -- OK if no alignment clause, no pack, and no component size 12711 12712 if not Has_Component_Size_Clause (Atyp) 12713 and then not Has_Alignment_Clause (Atyp) 12714 and then not Is_Packed (Atyp) 12715 then 12716 return; 12717 end if; 12718 12719 -- Case of component size is greater than or equal to 64 and the 12720 -- alignment of the array is at least as large as the alignment 12721 -- of the component. We are definitely OK in this situation. 12722 12723 if Known_Component_Size (Atyp) 12724 and then Component_Size (Atyp) >= 64 12725 and then Known_Alignment (Atyp) 12726 and then Known_Alignment (Ctyp) 12727 and then Alignment (Atyp) >= Alignment (Ctyp) 12728 then 12729 return; 12730 end if; 12731 12732 -- Check actual component size 12733 12734 if not Known_Component_Size (Atyp) 12735 or else not (Addressable (Component_Size (Atyp)) 12736 and then Component_Size (Atyp) < 64) 12737 or else Component_Size (Atyp) mod Esize (Ctyp) /= 0 12738 then 12739 No_Independence; 12740 12741 -- Bad component size, check reason 12742 12743 if Has_Component_Size_Clause (Atyp) then 12744 P := Get_Attribute_Definition_Clause 12745 (Atyp, Attribute_Component_Size); 12746 12747 if Present (P) then 12748 Error_Msg_Sloc := Sloc (P); 12749 Error_Msg_N ("\because of Component_Size clause#", N); 12750 return; 12751 end if; 12752 end if; 12753 12754 if Is_Packed (Atyp) then 12755 P := Get_Rep_Pragma (Atyp, Name_Pack); 12756 12757 if Present (P) then 12758 Error_Msg_Sloc := Sloc (P); 12759 Error_Msg_N ("\because of pragma Pack#", N); 12760 return; 12761 end if; 12762 end if; 12763 12764 -- No reason found, just return 12765 12766 return; 12767 end if; 12768 12769 -- Array type is OK independence-wise 12770 12771 return; 12772 end Check_Array_Type; 12773 12774 --------------------- 12775 -- No_Independence -- 12776 --------------------- 12777 12778 procedure No_Independence is 12779 begin 12780 if Pragma_Name (N) = Name_Independent then 12781 Error_Msg_NE ("independence cannot be guaranteed for&", N, E); 12782 else 12783 Error_Msg_NE 12784 ("independent components cannot be guaranteed for&", N, E); 12785 end if; 12786 end No_Independence; 12787 12788 ------------------ 12789 -- OK_Component -- 12790 ------------------ 12791 12792 function OK_Component (C : Entity_Id) return Boolean is 12793 Rec : constant Entity_Id := Scope (C); 12794 Ctyp : constant Entity_Id := Etype (C); 12795 12796 begin 12797 -- OK if no component clause, no Pack, and no alignment clause 12798 12799 if No (Component_Clause (C)) 12800 and then not Is_Packed (Rec) 12801 and then not Has_Alignment_Clause (Rec) 12802 then 12803 return True; 12804 end if; 12805 12806 -- Here we look at the actual component layout. A component is 12807 -- addressable if its size is a multiple of the Esize of the 12808 -- component type, and its starting position in the record has 12809 -- appropriate alignment, and the record itself has appropriate 12810 -- alignment to guarantee the component alignment. 12811 12812 -- Make sure sizes are static, always assume the worst for any 12813 -- cases where we cannot check static values. 12814 12815 if not (Known_Static_Esize (C) 12816 and then 12817 Known_Static_Esize (Ctyp)) 12818 then 12819 return False; 12820 end if; 12821 12822 -- Size of component must be addressable or greater than 64 bits 12823 -- and a multiple of bytes. 12824 12825 if not Addressable (Esize (C)) and then Esize (C) < Uint_64 then 12826 return False; 12827 end if; 12828 12829 -- Check size is proper multiple 12830 12831 if Esize (C) mod Esize (Ctyp) /= 0 then 12832 return False; 12833 end if; 12834 12835 -- Check alignment of component is OK 12836 12837 if not Known_Component_Bit_Offset (C) 12838 or else Component_Bit_Offset (C) < Uint_0 12839 or else Component_Bit_Offset (C) mod Esize (Ctyp) /= 0 12840 then 12841 return False; 12842 end if; 12843 12844 -- Check alignment of record type is OK 12845 12846 if not Known_Alignment (Rec) 12847 or else (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0 12848 then 12849 return False; 12850 end if; 12851 12852 -- All tests passed, component is addressable 12853 12854 return True; 12855 end OK_Component; 12856 12857 -------------------------- 12858 -- Reason_Bad_Component -- 12859 -------------------------- 12860 12861 procedure Reason_Bad_Component (C : Entity_Id) is 12862 Rec : constant Entity_Id := Scope (C); 12863 Ctyp : constant Entity_Id := Etype (C); 12864 12865 begin 12866 -- If component clause present assume that's the problem 12867 12868 if Present (Component_Clause (C)) then 12869 Error_Msg_Sloc := Sloc (Component_Clause (C)); 12870 Error_Msg_N ("\because of Component_Clause#", N); 12871 return; 12872 end if; 12873 12874 -- If pragma Pack clause present, assume that's the problem 12875 12876 if Is_Packed (Rec) then 12877 P := Get_Rep_Pragma (Rec, Name_Pack); 12878 12879 if Present (P) then 12880 Error_Msg_Sloc := Sloc (P); 12881 Error_Msg_N ("\because of pragma Pack#", N); 12882 return; 12883 end if; 12884 end if; 12885 12886 -- See if record has bad alignment clause 12887 12888 if Has_Alignment_Clause (Rec) 12889 and then Known_Alignment (Rec) 12890 and then (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0 12891 then 12892 P := Get_Attribute_Definition_Clause (Rec, Attribute_Alignment); 12893 12894 if Present (P) then 12895 Error_Msg_Sloc := Sloc (P); 12896 Error_Msg_N ("\because of Alignment clause#", N); 12897 end if; 12898 end if; 12899 12900 -- Couldn't find a reason, so return without a message 12901 12902 return; 12903 end Reason_Bad_Component; 12904 12905 -- Start of processing for Validate_Independence 12906 12907 begin 12908 for J in Independence_Checks.First .. Independence_Checks.Last loop 12909 N := Independence_Checks.Table (J).N; 12910 E := Independence_Checks.Table (J).E; 12911 IC := Pragma_Name (N) = Name_Independent_Components; 12912 12913 -- Deal with component case 12914 12915 if Ekind (E) = E_Discriminant or else Ekind (E) = E_Component then 12916 if not OK_Component (E) then 12917 No_Independence; 12918 Reason_Bad_Component (E); 12919 goto Continue; 12920 end if; 12921 end if; 12922 12923 -- Deal with record with Independent_Components 12924 12925 if IC and then Is_Record_Type (E) then 12926 Comp := First_Component_Or_Discriminant (E); 12927 while Present (Comp) loop 12928 if not OK_Component (Comp) then 12929 No_Independence; 12930 Reason_Bad_Component (Comp); 12931 goto Continue; 12932 end if; 12933 12934 Next_Component_Or_Discriminant (Comp); 12935 end loop; 12936 end if; 12937 12938 -- Deal with address clause case 12939 12940 if Is_Object (E) then 12941 Addr := Address_Clause (E); 12942 12943 if Present (Addr) then 12944 No_Independence; 12945 Error_Msg_Sloc := Sloc (Addr); 12946 Error_Msg_N ("\because of Address clause#", N); 12947 goto Continue; 12948 end if; 12949 end if; 12950 12951 -- Deal with independent components for array type 12952 12953 if IC and then Is_Array_Type (E) then 12954 Check_Array_Type (E); 12955 end if; 12956 12957 -- Deal with independent components for array object 12958 12959 if IC and then Is_Object (E) and then Is_Array_Type (Etype (E)) then 12960 Check_Array_Type (Etype (E)); 12961 end if; 12962 12963 <<Continue>> null; 12964 end loop; 12965 end Validate_Independence; 12966 12967 ------------------------------ 12968 -- Validate_Iterable_Aspect -- 12969 ------------------------------ 12970 12971 procedure Validate_Iterable_Aspect (Typ : Entity_Id; ASN : Node_Id) is 12972 Assoc : Node_Id; 12973 Expr : Node_Id; 12974 12975 Prim : Node_Id; 12976 Cursor : constant Entity_Id := Get_Cursor_Type (ASN, Typ); 12977 12978 First_Id : Entity_Id; 12979 Next_Id : Entity_Id; 12980 Has_Element_Id : Entity_Id; 12981 Element_Id : Entity_Id; 12982 12983 begin 12984 -- If previous error aspect is unusable 12985 12986 if Cursor = Any_Type then 12987 return; 12988 end if; 12989 12990 First_Id := Empty; 12991 Next_Id := Empty; 12992 Has_Element_Id := Empty; 12993 Element_Id := Empty; 12994 12995 -- Each expression must resolve to a function with the proper signature 12996 12997 Assoc := First (Component_Associations (Expression (ASN))); 12998 while Present (Assoc) loop 12999 Expr := Expression (Assoc); 13000 Analyze (Expr); 13001 13002 Prim := First (Choices (Assoc)); 13003 13004 if Nkind (Prim) /= N_Identifier or else Present (Next (Prim)) then 13005 Error_Msg_N ("illegal name in association", Prim); 13006 13007 elsif Chars (Prim) = Name_First then 13008 Resolve_Iterable_Operation (Expr, Cursor, Typ, Name_First); 13009 First_Id := Entity (Expr); 13010 13011 elsif Chars (Prim) = Name_Next then 13012 Resolve_Iterable_Operation (Expr, Cursor, Typ, Name_Next); 13013 Next_Id := Entity (Expr); 13014 13015 elsif Chars (Prim) = Name_Has_Element then 13016 Resolve_Iterable_Operation (Expr, Cursor, Typ, Name_Has_Element); 13017 Has_Element_Id := Entity (Expr); 13018 13019 elsif Chars (Prim) = Name_Element then 13020 Resolve_Iterable_Operation (Expr, Cursor, Typ, Name_Element); 13021 Element_Id := Entity (Expr); 13022 13023 else 13024 Error_Msg_N ("invalid name for iterable function", Prim); 13025 end if; 13026 13027 Next (Assoc); 13028 end loop; 13029 13030 if No (First_Id) then 13031 Error_Msg_N ("match for First primitive not found", ASN); 13032 13033 elsif No (Next_Id) then 13034 Error_Msg_N ("match for Next primitive not found", ASN); 13035 13036 elsif No (Has_Element_Id) then 13037 Error_Msg_N ("match for Has_Element primitive not found", ASN); 13038 13039 elsif No (Element_Id) then 13040 null; -- Optional. 13041 end if; 13042 end Validate_Iterable_Aspect; 13043 13044 ----------------------------------- 13045 -- Validate_Unchecked_Conversion -- 13046 ----------------------------------- 13047 13048 procedure Validate_Unchecked_Conversion 13049 (N : Node_Id; 13050 Act_Unit : Entity_Id) 13051 is 13052 Source : Entity_Id; 13053 Target : Entity_Id; 13054 Vnode : Node_Id; 13055 13056 begin 13057 -- Obtain source and target types. Note that we call Ancestor_Subtype 13058 -- here because the processing for generic instantiation always makes 13059 -- subtypes, and we want the original frozen actual types. 13060 13061 -- If we are dealing with private types, then do the check on their 13062 -- fully declared counterparts if the full declarations have been 13063 -- encountered (they don't have to be visible, but they must exist). 13064 13065 Source := Ancestor_Subtype (Etype (First_Formal (Act_Unit))); 13066 13067 if Is_Private_Type (Source) 13068 and then Present (Underlying_Type (Source)) 13069 then 13070 Source := Underlying_Type (Source); 13071 end if; 13072 13073 Target := Ancestor_Subtype (Etype (Act_Unit)); 13074 13075 -- If either type is generic, the instantiation happens within a generic 13076 -- unit, and there is nothing to check. The proper check will happen 13077 -- when the enclosing generic is instantiated. 13078 13079 if Is_Generic_Type (Source) or else Is_Generic_Type (Target) then 13080 return; 13081 end if; 13082 13083 if Is_Private_Type (Target) 13084 and then Present (Underlying_Type (Target)) 13085 then 13086 Target := Underlying_Type (Target); 13087 end if; 13088 13089 -- Source may be unconstrained array, but not target 13090 13091 if Is_Array_Type (Target) and then not Is_Constrained (Target) then 13092 Error_Msg_N 13093 ("unchecked conversion to unconstrained array not allowed", N); 13094 return; 13095 end if; 13096 13097 -- Warn if conversion between two different convention pointers 13098 13099 if Is_Access_Type (Target) 13100 and then Is_Access_Type (Source) 13101 and then Convention (Target) /= Convention (Source) 13102 and then Warn_On_Unchecked_Conversion 13103 then 13104 -- Give warnings for subprogram pointers only on most targets 13105 13106 if Is_Access_Subprogram_Type (Target) 13107 or else Is_Access_Subprogram_Type (Source) 13108 then 13109 Error_Msg_N 13110 ("?z?conversion between pointers with different conventions!", 13111 N); 13112 end if; 13113 end if; 13114 13115 -- Warn if one of the operands is Ada.Calendar.Time. Do not emit a 13116 -- warning when compiling GNAT-related sources. 13117 13118 if Warn_On_Unchecked_Conversion 13119 and then not In_Predefined_Unit (N) 13120 and then RTU_Loaded (Ada_Calendar) 13121 and then (Chars (Source) = Name_Time 13122 or else 13123 Chars (Target) = Name_Time) 13124 then 13125 -- If Ada.Calendar is loaded and the name of one of the operands is 13126 -- Time, there is a good chance that this is Ada.Calendar.Time. 13127 13128 declare 13129 Calendar_Time : constant Entity_Id := Full_View (RTE (RO_CA_Time)); 13130 begin 13131 pragma Assert (Present (Calendar_Time)); 13132 13133 if Source = Calendar_Time or else Target = Calendar_Time then 13134 Error_Msg_N 13135 ("?z?representation of 'Time values may change between " 13136 & "'G'N'A'T versions", N); 13137 end if; 13138 end; 13139 end if; 13140 13141 -- Make entry in unchecked conversion table for later processing by 13142 -- Validate_Unchecked_Conversions, which will check sizes and alignments 13143 -- (using values set by the back-end where possible). This is only done 13144 -- if the appropriate warning is active. 13145 13146 if Warn_On_Unchecked_Conversion then 13147 Unchecked_Conversions.Append 13148 (New_Val => UC_Entry'(Eloc => Sloc (N), 13149 Source => Source, 13150 Target => Target, 13151 Act_Unit => Act_Unit)); 13152 13153 -- If both sizes are known statically now, then back end annotation 13154 -- is not required to do a proper check but if either size is not 13155 -- known statically, then we need the annotation. 13156 13157 if Known_Static_RM_Size (Source) 13158 and then 13159 Known_Static_RM_Size (Target) 13160 then 13161 null; 13162 else 13163 Back_Annotate_Rep_Info := True; 13164 end if; 13165 end if; 13166 13167 -- If unchecked conversion to access type, and access type is declared 13168 -- in the same unit as the unchecked conversion, then set the flag 13169 -- No_Strict_Aliasing (no strict aliasing is implicit here) 13170 13171 if Is_Access_Type (Target) and then 13172 In_Same_Source_Unit (Target, N) 13173 then 13174 Set_No_Strict_Aliasing (Implementation_Base_Type (Target)); 13175 end if; 13176 13177 -- Generate N_Validate_Unchecked_Conversion node for back end in case 13178 -- the back end needs to perform special validation checks. 13179 13180 -- Shouldn't this be in Exp_Ch13, since the check only gets done if we 13181 -- have full expansion and the back end is called ??? 13182 13183 Vnode := 13184 Make_Validate_Unchecked_Conversion (Sloc (N)); 13185 Set_Source_Type (Vnode, Source); 13186 Set_Target_Type (Vnode, Target); 13187 13188 -- If the unchecked conversion node is in a list, just insert before it. 13189 -- If not we have some strange case, not worth bothering about. 13190 13191 if Is_List_Member (N) then 13192 Insert_After (N, Vnode); 13193 end if; 13194 end Validate_Unchecked_Conversion; 13195 13196 ------------------------------------ 13197 -- Validate_Unchecked_Conversions -- 13198 ------------------------------------ 13199 13200 procedure Validate_Unchecked_Conversions is 13201 begin 13202 for N in Unchecked_Conversions.First .. Unchecked_Conversions.Last loop 13203 declare 13204 T : UC_Entry renames Unchecked_Conversions.Table (N); 13205 13206 Eloc : constant Source_Ptr := T.Eloc; 13207 Source : constant Entity_Id := T.Source; 13208 Target : constant Entity_Id := T.Target; 13209 Act_Unit : constant Entity_Id := T.Act_Unit; 13210 13211 Source_Siz : Uint; 13212 Target_Siz : Uint; 13213 13214 begin 13215 -- Skip if function marked as warnings off 13216 13217 if Warnings_Off (Act_Unit) then 13218 goto Continue; 13219 end if; 13220 13221 -- This validation check, which warns if we have unequal sizes for 13222 -- unchecked conversion, and thus potentially implementation 13223 -- dependent semantics, is one of the few occasions on which we 13224 -- use the official RM size instead of Esize. See description in 13225 -- Einfo "Handling of Type'Size Values" for details. 13226 13227 if Serious_Errors_Detected = 0 13228 and then Known_Static_RM_Size (Source) 13229 and then Known_Static_RM_Size (Target) 13230 13231 -- Don't do the check if warnings off for either type, note the 13232 -- deliberate use of OR here instead of OR ELSE to get the flag 13233 -- Warnings_Off_Used set for both types if appropriate. 13234 13235 and then not (Has_Warnings_Off (Source) 13236 or 13237 Has_Warnings_Off (Target)) 13238 then 13239 Source_Siz := RM_Size (Source); 13240 Target_Siz := RM_Size (Target); 13241 13242 if Source_Siz /= Target_Siz then 13243 Error_Msg 13244 ("?z?types for unchecked conversion have different sizes!", 13245 Eloc); 13246 13247 if All_Errors_Mode then 13248 Error_Msg_Name_1 := Chars (Source); 13249 Error_Msg_Uint_1 := Source_Siz; 13250 Error_Msg_Name_2 := Chars (Target); 13251 Error_Msg_Uint_2 := Target_Siz; 13252 Error_Msg ("\size of % is ^, size of % is ^?z?", Eloc); 13253 13254 Error_Msg_Uint_1 := UI_Abs (Source_Siz - Target_Siz); 13255 13256 if Is_Discrete_Type (Source) 13257 and then 13258 Is_Discrete_Type (Target) 13259 then 13260 if Source_Siz > Target_Siz then 13261 Error_Msg 13262 ("\?z?^ high order bits of source will " 13263 & "be ignored!", Eloc); 13264 13265 elsif Is_Unsigned_Type (Source) then 13266 Error_Msg 13267 ("\?z?source will be extended with ^ high order " 13268 & "zero bits!", Eloc); 13269 13270 else 13271 Error_Msg 13272 ("\?z?source will be extended with ^ high order " 13273 & "sign bits!", Eloc); 13274 end if; 13275 13276 elsif Source_Siz < Target_Siz then 13277 if Is_Discrete_Type (Target) then 13278 if Bytes_Big_Endian then 13279 Error_Msg 13280 ("\?z?target value will include ^ undefined " 13281 & "low order bits!", Eloc); 13282 else 13283 Error_Msg 13284 ("\?z?target value will include ^ undefined " 13285 & "high order bits!", Eloc); 13286 end if; 13287 13288 else 13289 Error_Msg 13290 ("\?z?^ trailing bits of target value will be " 13291 & "undefined!", Eloc); 13292 end if; 13293 13294 else pragma Assert (Source_Siz > Target_Siz); 13295 Error_Msg 13296 ("\?z?^ trailing bits of source will be ignored!", 13297 Eloc); 13298 end if; 13299 end if; 13300 end if; 13301 end if; 13302 13303 -- If both types are access types, we need to check the alignment. 13304 -- If the alignment of both is specified, we can do it here. 13305 13306 if Serious_Errors_Detected = 0 13307 and then Is_Access_Type (Source) 13308 and then Is_Access_Type (Target) 13309 and then Target_Strict_Alignment 13310 and then Present (Designated_Type (Source)) 13311 and then Present (Designated_Type (Target)) 13312 then 13313 declare 13314 D_Source : constant Entity_Id := Designated_Type (Source); 13315 D_Target : constant Entity_Id := Designated_Type (Target); 13316 13317 begin 13318 if Known_Alignment (D_Source) 13319 and then 13320 Known_Alignment (D_Target) 13321 then 13322 declare 13323 Source_Align : constant Uint := Alignment (D_Source); 13324 Target_Align : constant Uint := Alignment (D_Target); 13325 13326 begin 13327 if Source_Align < Target_Align 13328 and then not Is_Tagged_Type (D_Source) 13329 13330 -- Suppress warning if warnings suppressed on either 13331 -- type or either designated type. Note the use of 13332 -- OR here instead of OR ELSE. That is intentional, 13333 -- we would like to set flag Warnings_Off_Used in 13334 -- all types for which warnings are suppressed. 13335 13336 and then not (Has_Warnings_Off (D_Source) 13337 or 13338 Has_Warnings_Off (D_Target) 13339 or 13340 Has_Warnings_Off (Source) 13341 or 13342 Has_Warnings_Off (Target)) 13343 then 13344 Error_Msg_Uint_1 := Target_Align; 13345 Error_Msg_Uint_2 := Source_Align; 13346 Error_Msg_Node_1 := D_Target; 13347 Error_Msg_Node_2 := D_Source; 13348 Error_Msg 13349 ("?z?alignment of & (^) is stricter than " 13350 & "alignment of & (^)!", Eloc); 13351 Error_Msg 13352 ("\?z?resulting access value may have invalid " 13353 & "alignment!", Eloc); 13354 end if; 13355 end; 13356 end if; 13357 end; 13358 end if; 13359 end; 13360 13361 <<Continue>> 13362 null; 13363 end loop; 13364 end Validate_Unchecked_Conversions; 13365 13366end Sem_Ch13; 13367