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