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