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