1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ P R A G -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, 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 Atree; use Atree; 27with Casing; use Casing; 28with Checks; use Checks; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Errout; use Errout; 32with Exp_Ch11; use Exp_Ch11; 33with Exp_Util; use Exp_Util; 34with Expander; use Expander; 35with Inline; use Inline; 36with Lib; use Lib; 37with Namet; use Namet; 38with Nlists; use Nlists; 39with Nmake; use Nmake; 40with Opt; use Opt; 41with Restrict; use Restrict; 42with Rident; use Rident; 43with Rtsfind; use Rtsfind; 44with Sem; use Sem; 45with Sem_Aux; use Sem_Aux; 46with Sem_Ch8; use Sem_Ch8; 47with Sem_Prag; use Sem_Prag; 48with Sem_Util; use Sem_Util; 49with Sinfo; use Sinfo; 50with Sinput; use Sinput; 51with Snames; use Snames; 52with Stringt; use Stringt; 53with Stand; use Stand; 54with Tbuild; use Tbuild; 55with Uintp; use Uintp; 56with Validsw; use Validsw; 57 58package body Exp_Prag is 59 60 ----------------------- 61 -- Local Subprograms -- 62 ----------------------- 63 64 function Arg1 (N : Node_Id) return Node_Id; 65 function Arg2 (N : Node_Id) return Node_Id; 66 function Arg3 (N : Node_Id) return Node_Id; 67 -- Obtain specified pragma argument expression 68 69 procedure Expand_Pragma_Abort_Defer (N : Node_Id); 70 procedure Expand_Pragma_Check (N : Node_Id); 71 procedure Expand_Pragma_Common_Object (N : Node_Id); 72 procedure Expand_Pragma_Import_Or_Interface (N : Node_Id); 73 procedure Expand_Pragma_Inspection_Point (N : Node_Id); 74 procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); 75 procedure Expand_Pragma_Loop_Variant (N : Node_Id); 76 procedure Expand_Pragma_Psect_Object (N : Node_Id); 77 procedure Expand_Pragma_Relative_Deadline (N : Node_Id); 78 procedure Expand_Pragma_Suppress_Initialization (N : Node_Id); 79 80 procedure Undo_Initialization (Def_Id : Entity_Id; N : Node_Id); 81 -- This procedure is used to undo initialization already done for Def_Id, 82 -- which is always an E_Variable, in response to the occurrence of the 83 -- pragma N, a pragma Interface, Import, or Suppress_Initialization. In all 84 -- these cases we want no initialization to occur, but we have already done 85 -- the initialization by the time we see the pragma, so we have to undo it. 86 87 ---------- 88 -- Arg1 -- 89 ---------- 90 91 function Arg1 (N : Node_Id) return Node_Id is 92 Arg : constant Node_Id := First (Pragma_Argument_Associations (N)); 93 begin 94 if Present (Arg) 95 and then Nkind (Arg) = N_Pragma_Argument_Association 96 then 97 return Expression (Arg); 98 else 99 return Arg; 100 end if; 101 end Arg1; 102 103 ---------- 104 -- Arg2 -- 105 ---------- 106 107 function Arg2 (N : Node_Id) return Node_Id is 108 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); 109 110 begin 111 if No (Arg1) then 112 return Empty; 113 114 else 115 declare 116 Arg : constant Node_Id := Next (Arg1); 117 begin 118 if Present (Arg) 119 and then Nkind (Arg) = N_Pragma_Argument_Association 120 then 121 return Expression (Arg); 122 else 123 return Arg; 124 end if; 125 end; 126 end if; 127 end Arg2; 128 129 ---------- 130 -- Arg3 -- 131 ---------- 132 133 function Arg3 (N : Node_Id) return Node_Id is 134 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); 135 136 begin 137 if No (Arg1) then 138 return Empty; 139 140 else 141 declare 142 Arg : Node_Id := Next (Arg1); 143 begin 144 if No (Arg) then 145 return Empty; 146 147 else 148 Next (Arg); 149 150 if Present (Arg) 151 and then Nkind (Arg) = N_Pragma_Argument_Association 152 then 153 return Expression (Arg); 154 else 155 return Arg; 156 end if; 157 end if; 158 end; 159 end if; 160 end Arg3; 161 162 --------------------- 163 -- Expand_N_Pragma -- 164 --------------------- 165 166 procedure Expand_N_Pragma (N : Node_Id) is 167 Pname : constant Name_Id := Pragma_Name (N); 168 Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname); 169 170 begin 171 -- Suppress the expansion of an ignored assertion pragma. Such a pragma 172 -- should not be transformed into a null statment because: 173 -- 174 -- * The pragma may be part of the rep item chain of a type, in which 175 -- case rewriting it will destroy the chain. 176 -- 177 -- * The analysis of the pragma may involve two parts (see routines 178 -- Analyze_xxx_In_Decl_Part). The second part of the analysis will 179 -- not happen if the pragma is rewritten. 180 181 if Assertion_Expression_Pragma (Prag_Id) and then Is_Ignored (N) then 182 return; 183 184 -- Rewrite the pragma into a null statement when it is ignored using 185 -- pragma Ignore_Pragma, or denotes Default_Scalar_Storage_Order and 186 -- compilation switch -gnatI is in effect. 187 188 elsif Should_Ignore_Pragma_Sem (N) 189 or else (Prag_Id = Pragma_Default_Scalar_Storage_Order 190 and then Ignore_Rep_Clauses) 191 then 192 Rewrite (N, Make_Null_Statement (Sloc (N))); 193 return; 194 end if; 195 196 case Prag_Id is 197 198 -- Pragmas requiring special expander action 199 200 when Pragma_Abort_Defer => 201 Expand_Pragma_Abort_Defer (N); 202 203 when Pragma_Check => 204 Expand_Pragma_Check (N); 205 206 when Pragma_Common_Object => 207 Expand_Pragma_Common_Object (N); 208 209 when Pragma_Import => 210 Expand_Pragma_Import_Or_Interface (N); 211 212 when Pragma_Inspection_Point => 213 Expand_Pragma_Inspection_Point (N); 214 215 when Pragma_Interface => 216 Expand_Pragma_Import_Or_Interface (N); 217 218 when Pragma_Interrupt_Priority => 219 Expand_Pragma_Interrupt_Priority (N); 220 221 when Pragma_Loop_Variant => 222 Expand_Pragma_Loop_Variant (N); 223 224 when Pragma_Psect_Object => 225 Expand_Pragma_Psect_Object (N); 226 227 when Pragma_Relative_Deadline => 228 Expand_Pragma_Relative_Deadline (N); 229 230 when Pragma_Suppress_Initialization => 231 Expand_Pragma_Suppress_Initialization (N); 232 233 -- All other pragmas need no expander action (includes 234 -- Unknown_Pragma). 235 236 when others => null; 237 end case; 238 end Expand_N_Pragma; 239 240 ------------------------------- 241 -- Expand_Pragma_Abort_Defer -- 242 ------------------------------- 243 244 -- An Abort_Defer pragma appears as the first statement in a handled 245 -- statement sequence (right after the begin). It defers aborts for 246 -- the entire statement sequence, but not for any declarations or 247 -- handlers (if any) associated with this statement sequence. 248 249 -- The transformation is to transform 250 251 -- pragma Abort_Defer; 252 -- statements; 253 254 -- into 255 256 -- begin 257 -- Abort_Defer.all; 258 -- statements 259 -- exception 260 -- when all others => 261 -- Abort_Undefer.all; 262 -- raise; 263 -- at end 264 -- Abort_Undefer_Direct; 265 -- end; 266 267 procedure Expand_Pragma_Abort_Defer (N : Node_Id) is 268 begin 269 -- Abort_Defer has no useful effect if Abort's are not allowed 270 271 if not Abort_Allowed then 272 return; 273 end if; 274 275 -- Normal case where abort is possible 276 277 declare 278 Loc : constant Source_Ptr := Sloc (N); 279 Stm : Node_Id; 280 Stms : List_Id; 281 HSS : Node_Id; 282 Blk : constant Entity_Id := 283 New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); 284 AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct); 285 286 begin 287 Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer)); 288 loop 289 Stm := Remove_Next (N); 290 exit when No (Stm); 291 Append (Stm, Stms); 292 end loop; 293 294 HSS := 295 Make_Handled_Sequence_Of_Statements (Loc, 296 Statements => Stms, 297 At_End_Proc => New_Occurrence_Of (AUD, Loc)); 298 299 -- Present the Abort_Undefer_Direct function to the backend so that 300 -- it can inline the call to the function. 301 302 Add_Inlined_Body (AUD, N); 303 304 Rewrite (N, 305 Make_Block_Statement (Loc, Handled_Statement_Sequence => HSS)); 306 307 Set_Scope (Blk, Current_Scope); 308 Set_Etype (Blk, Standard_Void_Type); 309 Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); 310 Expand_At_End_Handler (HSS, Blk); 311 Analyze (N); 312 end; 313 end Expand_Pragma_Abort_Defer; 314 315 -------------------------- 316 -- Expand_Pragma_Check -- 317 -------------------------- 318 319 procedure Expand_Pragma_Check (N : Node_Id) is 320 Cond : constant Node_Id := Arg2 (N); 321 Nam : constant Name_Id := Chars (Arg1 (N)); 322 Msg : Node_Id; 323 324 Loc : constant Source_Ptr := Sloc (First_Node (Cond)); 325 -- Source location used in the case of a failed assertion: point to the 326 -- failing condition, not Loc. Note that the source location of the 327 -- expression is not usually the best choice here, because it points to 328 -- the location of the topmost tree node, which may be an operator in 329 -- the middle of the source text of the expression. For example, it gets 330 -- located on the last AND keyword in a chain of boolean expressiond 331 -- AND'ed together. It is best to put the message on the first character 332 -- of the condition, which is the effect of the First_Node call here. 333 -- This source location is used to build the default exception message, 334 -- and also as the sloc of the call to the runtime subprogram raising 335 -- Assert_Failure, so that coverage analysis tools can relate the 336 -- call to the failed check. 337 338 procedure Replace_Discriminals_Of_Protected_Op (Expr : Node_Id); 339 -- Discriminants of the enclosing protected object may be referenced 340 -- in the expression of a precondition of a protected operation. 341 -- In the body of the operation these references must be replaced by 342 -- the discriminal created for them, which are renamings of the 343 -- discriminants of the object that is the target of the operation. 344 -- This replacement is done by visibility when the references appear 345 -- in the subprogram body, but in the case of a condition which appears 346 -- on the specification of the subprogram it has be done separately 347 -- because the condition has been replaced by a Check pragma and 348 -- analyzed earlier, before the creation of the discriminal renaming 349 -- declarations that are added to the subprogram body. 350 351 ------------------------------------------ 352 -- Replace_Discriminals_Of_Protected_Op -- 353 ------------------------------------------ 354 355 procedure Replace_Discriminals_Of_Protected_Op (Expr : Node_Id) is 356 function Find_Corresponding_Discriminal 357 (E : Entity_Id) return Entity_Id; 358 -- Find the local entity that renames a discriminant of the enclosing 359 -- protected type, and has a matching name. 360 361 function Replace_Discr_Ref (N : Node_Id) return Traverse_Result; 362 -- Replace a reference to a discriminant of the original protected 363 -- type by the local renaming declaration of the discriminant of 364 -- the target object. 365 366 ------------------------------------ 367 -- Find_Corresponding_Discriminal -- 368 ------------------------------------ 369 370 function Find_Corresponding_Discriminal 371 (E : Entity_Id) return Entity_Id 372 is 373 R : Entity_Id; 374 375 begin 376 R := First_Entity (Current_Scope); 377 378 while Present (R) loop 379 if Nkind (Parent (R)) = N_Object_Renaming_Declaration 380 and then Present (Discriminal_Link (R)) 381 and then Chars (Discriminal_Link (R)) = Chars (E) 382 then 383 return R; 384 end if; 385 386 Next_Entity (R); 387 end loop; 388 389 return Empty; 390 end Find_Corresponding_Discriminal; 391 392 ----------------------- 393 -- Replace_Discr_Ref -- 394 ----------------------- 395 396 function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is 397 R : Entity_Id; 398 399 begin 400 if Is_Entity_Name (N) 401 and then Present (Discriminal_Link (Entity (N))) 402 then 403 R := Find_Corresponding_Discriminal (Entity (N)); 404 Rewrite (N, New_Occurrence_Of (R, Sloc (N))); 405 end if; 406 407 return OK; 408 end Replace_Discr_Ref; 409 410 procedure Replace_Discriminant_References is 411 new Traverse_Proc (Replace_Discr_Ref); 412 413 -- Start of processing for Replace_Discriminals_Of_Protected_Op 414 415 begin 416 Replace_Discriminant_References (Expr); 417 end Replace_Discriminals_Of_Protected_Op; 418 419 -- Start of processing for Expand_Pragma_Check 420 421 begin 422 -- Nothing to do if pragma is ignored 423 424 if Is_Ignored (N) then 425 return; 426 end if; 427 428 -- Since this check is active, rewrite the pragma into a corresponding 429 -- if statement, and then analyze the statement. 430 431 -- The normal case expansion transforms: 432 433 -- pragma Check (name, condition [,message]); 434 435 -- into 436 437 -- if not condition then 438 -- System.Assertions.Raise_Assert_Failure (Str); 439 -- end if; 440 441 -- where Str is the message if one is present, or the default of 442 -- name failed at file:line if no message is given (the "name failed 443 -- at" is omitted for name = Assertion, since it is redundant, given 444 -- that the name of the exception is Assert_Failure.) 445 446 -- Also, instead of "XXX failed at", we generate slightly 447 -- different messages for some of the contract assertions (see 448 -- code below for details). 449 450 -- An alternative expansion is used when the No_Exception_Propagation 451 -- restriction is active and there is a local Assert_Failure handler. 452 -- This is not a common combination of circumstances, but it occurs in 453 -- the context of Aunit and the zero footprint profile. In this case we 454 -- generate: 455 456 -- if not condition then 457 -- raise Assert_Failure; 458 -- end if; 459 460 -- This will then be transformed into a goto, and the local handler will 461 -- be able to handle the assert error (which would not be the case if a 462 -- call is made to the Raise_Assert_Failure procedure). 463 464 -- We also generate the direct raise if the Suppress_Exception_Locations 465 -- is active, since we don't want to generate messages in this case. 466 467 -- Note that the reason we do not always generate a direct raise is that 468 -- the form in which the procedure is called allows for more efficient 469 -- breakpointing of assertion errors. 470 471 -- Generate the appropriate if statement. Note that we consider this to 472 -- be an explicit conditional in the source, not an implicit if, so we 473 -- do not call Make_Implicit_If_Statement. 474 475 -- Case where we generate a direct raise 476 477 if ((Debug_Flag_Dot_G 478 or else Restriction_Active (No_Exception_Propagation)) 479 and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N))) 480 or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N))) 481 then 482 Rewrite (N, 483 Make_If_Statement (Loc, 484 Condition => Make_Op_Not (Loc, Right_Opnd => Cond), 485 Then_Statements => New_List ( 486 Make_Raise_Statement (Loc, 487 Name => New_Occurrence_Of (RTE (RE_Assert_Failure), Loc))))); 488 489 -- Case where we call the procedure 490 491 else 492 -- If we have a message given, use it 493 494 if Present (Arg3 (N)) then 495 Msg := Get_Pragma_Arg (Arg3 (N)); 496 497 -- Here we have no string, so prepare one 498 499 else 500 declare 501 Loc_Str : constant String := Build_Location_String (Loc); 502 503 begin 504 Name_Len := 0; 505 506 -- For Assert, we just use the location 507 508 if Nam = Name_Assert then 509 null; 510 511 -- For predicate, we generate the string "predicate failed at 512 -- yyy". We prefer all lower case for predicate. 513 514 elsif Nam = Name_Predicate then 515 Add_Str_To_Name_Buffer ("predicate failed at "); 516 517 -- For special case of Precondition/Postcondition the string is 518 -- "failed xx from yy" where xx is precondition/postcondition 519 -- in all lower case. The reason for this different wording is 520 -- that the failure is not at the point of occurrence of the 521 -- pragma, unlike the other Check cases. 522 523 elsif Nam_In (Nam, Name_Precondition, Name_Postcondition) then 524 Get_Name_String (Nam); 525 Insert_Str_In_Name_Buffer ("failed ", 1); 526 Add_Str_To_Name_Buffer (" from "); 527 528 -- For special case of Invariant, the string is "failed 529 -- invariant from yy", to be consistent with the string that is 530 -- generated for the aspect case (the code later on checks for 531 -- this specific string to modify it in some cases, so this is 532 -- functionally important). 533 534 elsif Nam = Name_Invariant then 535 Add_Str_To_Name_Buffer ("failed invariant from "); 536 537 -- For all other checks, the string is "xxx failed at yyy" 538 -- where xxx is the check name with appropriate casing. 539 540 else 541 Get_Name_String (Nam); 542 Set_Casing 543 (Identifier_Casing (Source_Index (Current_Sem_Unit))); 544 Add_Str_To_Name_Buffer (" failed at "); 545 end if; 546 547 -- In all cases, add location string 548 549 Add_Str_To_Name_Buffer (Loc_Str); 550 551 -- Build the message 552 553 Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)); 554 end; 555 end if; 556 557 -- For a precondition, replace references to discriminants of a 558 -- protected type with the local discriminals. 559 560 if Is_Protected_Type (Scope (Current_Scope)) 561 and then Has_Discriminants (Scope (Current_Scope)) 562 and then From_Aspect_Specification (N) 563 then 564 Replace_Discriminals_Of_Protected_Op (Cond); 565 end if; 566 567 -- Now rewrite as an if statement 568 569 Rewrite (N, 570 Make_If_Statement (Loc, 571 Condition => Make_Op_Not (Loc, Right_Opnd => Cond), 572 Then_Statements => New_List ( 573 Make_Procedure_Call_Statement (Loc, 574 Name => 575 New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), 576 Parameter_Associations => New_List (Relocate_Node (Msg)))))); 577 end if; 578 579 Analyze (N); 580 581 -- If new condition is always false, give a warning 582 583 if Warn_On_Assertion_Failure 584 and then Nkind (N) = N_Procedure_Call_Statement 585 and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure) 586 then 587 -- If original condition was a Standard.False, we assume that this is 588 -- indeed intended to raise assert error and no warning is required. 589 590 if Is_Entity_Name (Original_Node (Cond)) 591 and then Entity (Original_Node (Cond)) = Standard_False 592 then 593 null; 594 595 elsif Nam = Name_Assert then 596 Error_Msg_N ("?A?assertion will fail at run time", N); 597 else 598 Error_Msg_N ("?A?check will fail at run time", N); 599 end if; 600 end if; 601 end Expand_Pragma_Check; 602 603 --------------------------------- 604 -- Expand_Pragma_Common_Object -- 605 --------------------------------- 606 607 -- Use a machine attribute to replicate semantic effect in DEC Ada 608 609 -- pragma Machine_Attribute (intern_name, "common_object", extern_name); 610 611 -- For now we do nothing with the size attribute ??? 612 613 -- Note: Psect_Object shares this processing 614 615 procedure Expand_Pragma_Common_Object (N : Node_Id) is 616 Loc : constant Source_Ptr := Sloc (N); 617 618 Internal : constant Node_Id := Arg1 (N); 619 External : constant Node_Id := Arg2 (N); 620 621 Psect : Node_Id; 622 -- Psect value upper cased as string literal 623 624 Iloc : constant Source_Ptr := Sloc (Internal); 625 Eloc : constant Source_Ptr := Sloc (External); 626 Ploc : Source_Ptr; 627 628 begin 629 -- Acquire Psect value and fold to upper case 630 631 if Present (External) then 632 if Nkind (External) = N_String_Literal then 633 String_To_Name_Buffer (Strval (External)); 634 else 635 Get_Name_String (Chars (External)); 636 end if; 637 638 Set_All_Upper_Case; 639 640 Psect := 641 Make_String_Literal (Eloc, Strval => String_From_Name_Buffer); 642 643 else 644 Get_Name_String (Chars (Internal)); 645 Set_All_Upper_Case; 646 Psect := 647 Make_String_Literal (Iloc, Strval => String_From_Name_Buffer); 648 end if; 649 650 Ploc := Sloc (Psect); 651 652 -- Insert the pragma 653 654 Insert_After_And_Analyze (N, 655 Make_Pragma (Loc, 656 Chars => Name_Machine_Attribute, 657 Pragma_Argument_Associations => New_List ( 658 Make_Pragma_Argument_Association (Iloc, 659 Expression => New_Copy_Tree (Internal)), 660 Make_Pragma_Argument_Association (Eloc, 661 Expression => 662 Make_String_Literal (Sloc => Ploc, Strval => "common_object")), 663 Make_Pragma_Argument_Association (Ploc, 664 Expression => New_Copy_Tree (Psect))))); 665 end Expand_Pragma_Common_Object; 666 667 ---------------------------------- 668 -- Expand_Pragma_Contract_Cases -- 669 ---------------------------------- 670 671 -- Pragma Contract_Cases is expanded in the following manner: 672 673 -- subprogram S is 674 -- Count : Natural := 0; 675 -- Flag_1 : Boolean := False; 676 -- . . . 677 -- Flag_N : Boolean := False; 678 -- Flag_N+1 : Boolean := False; -- when "others" present 679 -- Pref_1 : ...; 680 -- . . . 681 -- Pref_M : ...; 682 683 -- <preconditions (if any)> 684 685 -- -- Evaluate all case guards 686 687 -- if Case_Guard_1 then 688 -- Flag_1 := True; 689 -- Count := Count + 1; 690 -- end if; 691 -- . . . 692 -- if Case_Guard_N then 693 -- Flag_N := True; 694 -- Count := Count + 1; 695 -- end if; 696 697 -- -- Emit errors depending on the number of case guards that 698 -- -- evaluated to True. 699 700 -- if Count = 0 then 701 -- raise Assertion_Error with "xxx contract cases incomplete"; 702 -- <or> 703 -- Flag_N+1 := True; -- when "others" present 704 705 -- elsif Count > 1 then 706 -- declare 707 -- Str0 : constant String := 708 -- "contract cases overlap for subprogram ABC"; 709 -- Str1 : constant String := 710 -- (if Flag_1 then 711 -- Str0 & "case guard at xxx evaluates to True" 712 -- else Str0); 713 -- StrN : constant String := 714 -- (if Flag_N then 715 -- StrN-1 & "case guard at xxx evaluates to True" 716 -- else StrN-1); 717 -- begin 718 -- raise Assertion_Error with StrN; 719 -- end; 720 -- end if; 721 722 -- -- Evaluate all attribute 'Old prefixes found in the selected 723 -- -- consequence. 724 725 -- if Flag_1 then 726 -- Pref_1 := <prefix of 'Old found in Consequence_1> 727 -- . . . 728 -- elsif Flag_N then 729 -- Pref_M := <prefix of 'Old found in Consequence_N> 730 -- end if; 731 732 -- procedure _Postconditions is 733 -- begin 734 -- <postconditions (if any)> 735 736 -- if Flag_1 and then not Consequence_1 then 737 -- raise Assertion_Error with "failed contract case at xxx"; 738 -- end if; 739 -- . . . 740 -- if Flag_N[+1] and then not Consequence_N[+1] then 741 -- raise Assertion_Error with "failed contract case at xxx"; 742 -- end if; 743 -- end _Postconditions; 744 -- begin 745 -- . . . 746 -- end S; 747 748 procedure Expand_Pragma_Contract_Cases 749 (CCs : Node_Id; 750 Subp_Id : Entity_Id; 751 Decls : List_Id; 752 Stmts : in out List_Id) 753 is 754 Loc : constant Source_Ptr := Sloc (CCs); 755 756 procedure Case_Guard_Error 757 (Decls : List_Id; 758 Flag : Entity_Id; 759 Error_Loc : Source_Ptr; 760 Msg : in out Entity_Id); 761 -- Given a declarative list Decls, status flag Flag, the location of the 762 -- error and a string Msg, construct the following check: 763 -- Msg : constant String := 764 -- (if Flag then 765 -- Msg & "case guard at Error_Loc evaluates to True" 766 -- else Msg); 767 -- The resulting code is added to Decls 768 769 procedure Consequence_Error 770 (Checks : in out Node_Id; 771 Flag : Entity_Id; 772 Conseq : Node_Id); 773 -- Given an if statement Checks, status flag Flag and a consequence 774 -- Conseq, construct the following check: 775 -- [els]if Flag and then not Conseq then 776 -- raise Assertion_Error 777 -- with "failed contract case at Sloc (Conseq)"; 778 -- [end if;] 779 -- The resulting code is added to Checks 780 781 function Declaration_Of (Id : Entity_Id) return Node_Id; 782 -- Given the entity Id of a boolean flag, generate: 783 -- Id : Boolean := False; 784 785 procedure Expand_Attributes_In_Consequence 786 (Decls : List_Id; 787 Evals : in out Node_Id; 788 Flag : Entity_Id; 789 Conseq : Node_Id); 790 -- Perform specialized expansion of all attribute 'Old references found 791 -- in consequence Conseq such that at runtime only prefixes coming from 792 -- the selected consequence are evaluated. Similarly expand attribute 793 -- 'Result references by replacing them with identifier _result which 794 -- resolves to the sole formal parameter of procedure _Postconditions. 795 -- Any temporaries generated in the process are added to declarations 796 -- Decls. Evals is a complex if statement tasked with the evaluation of 797 -- all prefixes coming from a single selected consequence. Flag is the 798 -- corresponding case guard flag. Conseq is the consequence expression. 799 800 function Increment (Id : Entity_Id) return Node_Id; 801 -- Given the entity Id of a numerical variable, generate: 802 -- Id := Id + 1; 803 804 function Set (Id : Entity_Id) return Node_Id; 805 -- Given the entity Id of a boolean variable, generate: 806 -- Id := True; 807 808 ---------------------- 809 -- Case_Guard_Error -- 810 ---------------------- 811 812 procedure Case_Guard_Error 813 (Decls : List_Id; 814 Flag : Entity_Id; 815 Error_Loc : Source_Ptr; 816 Msg : in out Entity_Id) 817 is 818 New_Line : constant Character := Character'Val (10); 819 New_Msg : constant Entity_Id := Make_Temporary (Loc, 'S'); 820 821 begin 822 Start_String; 823 Store_String_Char (New_Line); 824 Store_String_Chars (" case guard at "); 825 Store_String_Chars (Build_Location_String (Error_Loc)); 826 Store_String_Chars (" evaluates to True"); 827 828 -- Generate: 829 -- New_Msg : constant String := 830 -- (if Flag then 831 -- Msg & "case guard at Error_Loc evaluates to True" 832 -- else Msg); 833 834 Append_To (Decls, 835 Make_Object_Declaration (Loc, 836 Defining_Identifier => New_Msg, 837 Constant_Present => True, 838 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 839 Expression => 840 Make_If_Expression (Loc, 841 Expressions => New_List ( 842 New_Occurrence_Of (Flag, Loc), 843 844 Make_Op_Concat (Loc, 845 Left_Opnd => New_Occurrence_Of (Msg, Loc), 846 Right_Opnd => Make_String_Literal (Loc, End_String)), 847 848 New_Occurrence_Of (Msg, Loc))))); 849 850 Msg := New_Msg; 851 end Case_Guard_Error; 852 853 ----------------------- 854 -- Consequence_Error -- 855 ----------------------- 856 857 procedure Consequence_Error 858 (Checks : in out Node_Id; 859 Flag : Entity_Id; 860 Conseq : Node_Id) 861 is 862 Cond : Node_Id; 863 Error : Node_Id; 864 865 begin 866 -- Generate: 867 -- Flag and then not Conseq 868 869 Cond := 870 Make_And_Then (Loc, 871 Left_Opnd => New_Occurrence_Of (Flag, Loc), 872 Right_Opnd => 873 Make_Op_Not (Loc, 874 Right_Opnd => Relocate_Node (Conseq))); 875 876 -- Generate: 877 -- raise Assertion_Error 878 -- with "failed contract case at Sloc (Conseq)"; 879 880 Start_String; 881 Store_String_Chars ("failed contract case at "); 882 Store_String_Chars (Build_Location_String (Sloc (Conseq))); 883 884 Error := 885 Make_Procedure_Call_Statement (Loc, 886 Name => 887 New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), 888 Parameter_Associations => New_List ( 889 Make_String_Literal (Loc, End_String))); 890 891 if No (Checks) then 892 Checks := 893 Make_Implicit_If_Statement (CCs, 894 Condition => Cond, 895 Then_Statements => New_List (Error)); 896 897 else 898 if No (Elsif_Parts (Checks)) then 899 Set_Elsif_Parts (Checks, New_List); 900 end if; 901 902 Append_To (Elsif_Parts (Checks), 903 Make_Elsif_Part (Loc, 904 Condition => Cond, 905 Then_Statements => New_List (Error))); 906 end if; 907 end Consequence_Error; 908 909 -------------------- 910 -- Declaration_Of -- 911 -------------------- 912 913 function Declaration_Of (Id : Entity_Id) return Node_Id is 914 begin 915 return 916 Make_Object_Declaration (Loc, 917 Defining_Identifier => Id, 918 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 919 Expression => New_Occurrence_Of (Standard_False, Loc)); 920 end Declaration_Of; 921 922 -------------------------------------- 923 -- Expand_Attributes_In_Consequence -- 924 -------------------------------------- 925 926 procedure Expand_Attributes_In_Consequence 927 (Decls : List_Id; 928 Evals : in out Node_Id; 929 Flag : Entity_Id; 930 Conseq : Node_Id) 931 is 932 Eval_Stmts : List_Id := No_List; 933 -- The evaluation sequence expressed as assignment statements of all 934 -- prefixes of attribute 'Old found in the current consequence. 935 936 function Expand_Attributes (N : Node_Id) return Traverse_Result; 937 -- Determine whether an arbitrary node denotes attribute 'Old or 938 -- 'Result and if it does, perform all expansion-related actions. 939 940 ----------------------- 941 -- Expand_Attributes -- 942 ----------------------- 943 944 function Expand_Attributes (N : Node_Id) return Traverse_Result is 945 Decl : Node_Id; 946 Pref : Node_Id; 947 Temp : Entity_Id; 948 949 begin 950 -- Attribute 'Old 951 952 if Nkind (N) = N_Attribute_Reference 953 and then Attribute_Name (N) = Name_Old 954 then 955 Pref := Prefix (N); 956 Temp := Make_Temporary (Loc, 'T', Pref); 957 Set_Etype (Temp, Etype (Pref)); 958 959 -- Generate a temporary to capture the value of the prefix: 960 -- Temp : <Pref type>; 961 962 Decl := 963 Make_Object_Declaration (Loc, 964 Defining_Identifier => Temp, 965 Object_Definition => 966 New_Occurrence_Of (Etype (Pref), Loc)); 967 968 -- Place that temporary at the beginning of declarations, to 969 -- prevent anomalies in the GNATprove flow-analysis pass in 970 -- the precondition procedure that follows. 971 972 Prepend_To (Decls, Decl); 973 974 -- If the type is unconstrained, the prefix provides its 975 -- value and constraint, so add it to declaration. 976 977 if not Is_Constrained (Etype (Pref)) 978 and then Is_Entity_Name (Pref) 979 then 980 Set_Expression (Decl, Pref); 981 Analyze (Decl); 982 983 -- Otherwise add an assignment statement to temporary using 984 -- prefix as RHS. 985 986 else 987 Analyze (Decl); 988 989 if No (Eval_Stmts) then 990 Eval_Stmts := New_List; 991 end if; 992 993 Append_To (Eval_Stmts, 994 Make_Assignment_Statement (Loc, 995 Name => New_Occurrence_Of (Temp, Loc), 996 Expression => Pref)); 997 998 end if; 999 1000 -- Ensure that the prefix is valid 1001 1002 if Validity_Checks_On and then Validity_Check_Operands then 1003 Ensure_Valid (Pref); 1004 end if; 1005 1006 -- Replace the original attribute 'Old by a reference to the 1007 -- generated temporary. 1008 1009 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 1010 1011 -- Attribute 'Result 1012 1013 elsif Is_Attribute_Result (N) then 1014 Rewrite (N, Make_Identifier (Loc, Name_uResult)); 1015 end if; 1016 1017 return OK; 1018 end Expand_Attributes; 1019 1020 procedure Expand_Attributes_In is 1021 new Traverse_Proc (Expand_Attributes); 1022 1023 -- Start of processing for Expand_Attributes_In_Consequence 1024 1025 begin 1026 -- Inspect the consequence and expand any attribute 'Old and 'Result 1027 -- references found within. 1028 1029 Expand_Attributes_In (Conseq); 1030 1031 -- The consequence does not contain any attribute 'Old references 1032 1033 if No (Eval_Stmts) then 1034 return; 1035 end if; 1036 1037 -- Augment the machinery to trigger the evaluation of all prefixes 1038 -- found in the step above. If Eval is empty, then this is the first 1039 -- consequence to yield expansion of 'Old. Generate: 1040 1041 -- if Flag then 1042 -- <evaluation statements> 1043 -- end if; 1044 1045 if No (Evals) then 1046 Evals := 1047 Make_Implicit_If_Statement (CCs, 1048 Condition => New_Occurrence_Of (Flag, Loc), 1049 Then_Statements => Eval_Stmts); 1050 1051 -- Otherwise generate: 1052 -- elsif Flag then 1053 -- <evaluation statements> 1054 -- end if; 1055 1056 else 1057 if No (Elsif_Parts (Evals)) then 1058 Set_Elsif_Parts (Evals, New_List); 1059 end if; 1060 1061 Append_To (Elsif_Parts (Evals), 1062 Make_Elsif_Part (Loc, 1063 Condition => New_Occurrence_Of (Flag, Loc), 1064 Then_Statements => Eval_Stmts)); 1065 end if; 1066 end Expand_Attributes_In_Consequence; 1067 1068 --------------- 1069 -- Increment -- 1070 --------------- 1071 1072 function Increment (Id : Entity_Id) return Node_Id is 1073 begin 1074 return 1075 Make_Assignment_Statement (Loc, 1076 Name => New_Occurrence_Of (Id, Loc), 1077 Expression => 1078 Make_Op_Add (Loc, 1079 Left_Opnd => New_Occurrence_Of (Id, Loc), 1080 Right_Opnd => Make_Integer_Literal (Loc, 1))); 1081 end Increment; 1082 1083 --------- 1084 -- Set -- 1085 --------- 1086 1087 function Set (Id : Entity_Id) return Node_Id is 1088 begin 1089 return 1090 Make_Assignment_Statement (Loc, 1091 Name => New_Occurrence_Of (Id, Loc), 1092 Expression => New_Occurrence_Of (Standard_True, Loc)); 1093 end Set; 1094 1095 -- Local variables 1096 1097 Aggr : constant Node_Id := 1098 Expression (First (Pragma_Argument_Associations (CCs))); 1099 1100 Case_Guard : Node_Id; 1101 CG_Checks : Node_Id; 1102 CG_Stmts : List_Id; 1103 Conseq : Node_Id; 1104 Conseq_Checks : Node_Id := Empty; 1105 Count : Entity_Id; 1106 Count_Decl : Node_Id; 1107 Error_Decls : List_Id := No_List; -- init to avoid warning 1108 Flag : Entity_Id; 1109 Flag_Decl : Node_Id; 1110 If_Stmt : Node_Id; 1111 Msg_Str : Entity_Id := Empty; 1112 Multiple_PCs : Boolean; 1113 Old_Evals : Node_Id := Empty; 1114 Others_Decl : Node_Id; 1115 Others_Flag : Entity_Id := Empty; 1116 Post_Case : Node_Id; 1117 1118 -- Start of processing for Expand_Pragma_Contract_Cases 1119 1120 begin 1121 -- Do nothing if pragma is not enabled. If pragma is disabled, it has 1122 -- already been rewritten as a Null statement. 1123 1124 if Is_Ignored (CCs) then 1125 return; 1126 1127 -- Guard against malformed contract cases 1128 1129 elsif Nkind (Aggr) /= N_Aggregate then 1130 return; 1131 end if; 1132 1133 -- The expansion of contract cases is quite distributed as it produces 1134 -- various statements to evaluate the case guards and consequences. To 1135 -- preserve the original context, set the Is_Assertion_Expr flag. This 1136 -- aids the Ghost legality checks when verifying the placement of a 1137 -- reference to a Ghost entity. 1138 1139 In_Assertion_Expr := In_Assertion_Expr + 1; 1140 1141 Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1; 1142 1143 -- Create the counter which tracks the number of case guards that 1144 -- evaluate to True. 1145 1146 -- Count : Natural := 0; 1147 1148 Count := Make_Temporary (Loc, 'C'); 1149 Count_Decl := 1150 Make_Object_Declaration (Loc, 1151 Defining_Identifier => Count, 1152 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc), 1153 Expression => Make_Integer_Literal (Loc, 0)); 1154 1155 Prepend_To (Decls, Count_Decl); 1156 Analyze (Count_Decl); 1157 1158 -- Create the base error message for multiple overlapping case guards 1159 1160 -- Msg_Str : constant String := 1161 -- "contract cases overlap for subprogram Subp_Id"; 1162 1163 if Multiple_PCs then 1164 Msg_Str := Make_Temporary (Loc, 'S'); 1165 1166 Start_String; 1167 Store_String_Chars ("contract cases overlap for subprogram "); 1168 Store_String_Chars (Get_Name_String (Chars (Subp_Id))); 1169 1170 Error_Decls := New_List ( 1171 Make_Object_Declaration (Loc, 1172 Defining_Identifier => Msg_Str, 1173 Constant_Present => True, 1174 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 1175 Expression => Make_String_Literal (Loc, End_String))); 1176 end if; 1177 1178 -- Process individual post cases 1179 1180 Post_Case := First (Component_Associations (Aggr)); 1181 while Present (Post_Case) loop 1182 Case_Guard := First (Choices (Post_Case)); 1183 Conseq := Expression (Post_Case); 1184 1185 -- The "others" choice requires special processing 1186 1187 if Nkind (Case_Guard) = N_Others_Choice then 1188 Others_Flag := Make_Temporary (Loc, 'F'); 1189 Others_Decl := Declaration_Of (Others_Flag); 1190 1191 Prepend_To (Decls, Others_Decl); 1192 Analyze (Others_Decl); 1193 1194 -- Check possible overlap between a case guard and "others" 1195 1196 if Multiple_PCs and Exception_Extra_Info then 1197 Case_Guard_Error 1198 (Decls => Error_Decls, 1199 Flag => Others_Flag, 1200 Error_Loc => Sloc (Case_Guard), 1201 Msg => Msg_Str); 1202 end if; 1203 1204 -- Inspect the consequence and perform special expansion of any 1205 -- attribute 'Old and 'Result references found within. 1206 1207 Expand_Attributes_In_Consequence 1208 (Decls => Decls, 1209 Evals => Old_Evals, 1210 Flag => Others_Flag, 1211 Conseq => Conseq); 1212 1213 -- Check the corresponding consequence of "others" 1214 1215 Consequence_Error 1216 (Checks => Conseq_Checks, 1217 Flag => Others_Flag, 1218 Conseq => Conseq); 1219 1220 -- Regular post case 1221 1222 else 1223 -- Create the flag which tracks the state of its associated case 1224 -- guard. 1225 1226 Flag := Make_Temporary (Loc, 'F'); 1227 Flag_Decl := Declaration_Of (Flag); 1228 1229 Prepend_To (Decls, Flag_Decl); 1230 Analyze (Flag_Decl); 1231 1232 -- The flag is set when the case guard is evaluated to True 1233 -- if Case_Guard then 1234 -- Flag := True; 1235 -- Count := Count + 1; 1236 -- end if; 1237 1238 If_Stmt := 1239 Make_Implicit_If_Statement (CCs, 1240 Condition => Relocate_Node (Case_Guard), 1241 Then_Statements => New_List ( 1242 Set (Flag), 1243 Increment (Count))); 1244 1245 Append_To (Decls, If_Stmt); 1246 Analyze (If_Stmt); 1247 1248 -- Check whether this case guard overlaps with another one 1249 1250 if Multiple_PCs and Exception_Extra_Info then 1251 Case_Guard_Error 1252 (Decls => Error_Decls, 1253 Flag => Flag, 1254 Error_Loc => Sloc (Case_Guard), 1255 Msg => Msg_Str); 1256 end if; 1257 1258 -- Inspect the consequence and perform special expansion of any 1259 -- attribute 'Old and 'Result references found within. 1260 1261 Expand_Attributes_In_Consequence 1262 (Decls => Decls, 1263 Evals => Old_Evals, 1264 Flag => Flag, 1265 Conseq => Conseq); 1266 1267 -- The corresponding consequence of the case guard which evaluated 1268 -- to True must hold on exit from the subprogram. 1269 1270 Consequence_Error 1271 (Checks => Conseq_Checks, 1272 Flag => Flag, 1273 Conseq => Conseq); 1274 end if; 1275 1276 Next (Post_Case); 1277 end loop; 1278 1279 -- Raise Assertion_Error when none of the case guards evaluate to True. 1280 -- The only exception is when we have "others", in which case there is 1281 -- no error because "others" acts as a default True. 1282 1283 -- Generate: 1284 -- Flag := True; 1285 1286 if Present (Others_Flag) then 1287 CG_Stmts := New_List (Set (Others_Flag)); 1288 1289 -- Generate: 1290 -- raise Assertion_Error with "xxx contract cases incomplete"; 1291 1292 else 1293 Start_String; 1294 Store_String_Chars (Build_Location_String (Loc)); 1295 Store_String_Chars (" contract cases incomplete"); 1296 1297 CG_Stmts := New_List ( 1298 Make_Procedure_Call_Statement (Loc, 1299 Name => 1300 New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), 1301 Parameter_Associations => New_List ( 1302 Make_String_Literal (Loc, End_String)))); 1303 end if; 1304 1305 CG_Checks := 1306 Make_Implicit_If_Statement (CCs, 1307 Condition => 1308 Make_Op_Eq (Loc, 1309 Left_Opnd => New_Occurrence_Of (Count, Loc), 1310 Right_Opnd => Make_Integer_Literal (Loc, 0)), 1311 Then_Statements => CG_Stmts); 1312 1313 -- Detect a possible failure due to several case guards evaluating to 1314 -- True. 1315 1316 -- Generate: 1317 -- elsif Count > 0 then 1318 -- declare 1319 -- <Error_Decls> 1320 -- begin 1321 -- raise Assertion_Error with <Msg_Str>; 1322 -- end if; 1323 1324 if Multiple_PCs then 1325 Set_Elsif_Parts (CG_Checks, New_List ( 1326 Make_Elsif_Part (Loc, 1327 Condition => 1328 Make_Op_Gt (Loc, 1329 Left_Opnd => New_Occurrence_Of (Count, Loc), 1330 Right_Opnd => Make_Integer_Literal (Loc, 1)), 1331 1332 Then_Statements => New_List ( 1333 Make_Block_Statement (Loc, 1334 Declarations => Error_Decls, 1335 Handled_Statement_Sequence => 1336 Make_Handled_Sequence_Of_Statements (Loc, 1337 Statements => New_List ( 1338 Make_Procedure_Call_Statement (Loc, 1339 Name => 1340 New_Occurrence_Of 1341 (RTE (RE_Raise_Assert_Failure), Loc), 1342 Parameter_Associations => New_List ( 1343 New_Occurrence_Of (Msg_Str, Loc)))))))))); 1344 end if; 1345 1346 Append_To (Decls, CG_Checks); 1347 Analyze (CG_Checks); 1348 1349 -- Once all case guards are evaluated and checked, evaluate any prefixes 1350 -- of attribute 'Old founds in the selected consequence. 1351 1352 if Present (Old_Evals) then 1353 Append_To (Decls, Old_Evals); 1354 Analyze (Old_Evals); 1355 end if; 1356 1357 -- Raise Assertion_Error when the corresponding consequence of a case 1358 -- guard that evaluated to True fails. 1359 1360 if No (Stmts) then 1361 Stmts := New_List; 1362 end if; 1363 1364 Append_To (Stmts, Conseq_Checks); 1365 1366 In_Assertion_Expr := In_Assertion_Expr - 1; 1367 end Expand_Pragma_Contract_Cases; 1368 1369 --------------------------------------- 1370 -- Expand_Pragma_Import_Or_Interface -- 1371 --------------------------------------- 1372 1373 procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is 1374 Def_Id : Entity_Id; 1375 1376 begin 1377 -- In Relaxed_RM_Semantics, support old Ada 83 style: 1378 -- pragma Import (Entity, "external name"); 1379 1380 if Relaxed_RM_Semantics 1381 and then List_Length (Pragma_Argument_Associations (N)) = 2 1382 and then Pragma_Name (N) = Name_Import 1383 and then Nkind (Arg2 (N)) = N_String_Literal 1384 then 1385 Def_Id := Entity (Arg1 (N)); 1386 else 1387 Def_Id := Entity (Arg2 (N)); 1388 end if; 1389 1390 -- Variable case (we have to undo any initialization already done) 1391 1392 if Ekind (Def_Id) = E_Variable then 1393 Undo_Initialization (Def_Id, N); 1394 1395 -- Case of exception with convention C++ 1396 1397 elsif Ekind (Def_Id) = E_Exception 1398 and then Convention (Def_Id) = Convention_CPP 1399 then 1400 -- Import a C++ convention 1401 1402 declare 1403 Loc : constant Source_Ptr := Sloc (N); 1404 Rtti_Name : constant Node_Id := Arg3 (N); 1405 Dum : constant Entity_Id := Make_Temporary (Loc, 'D'); 1406 Exdata : List_Id; 1407 Lang_Char : Node_Id; 1408 Foreign_Data : Node_Id; 1409 1410 begin 1411 Exdata := Component_Associations (Expression (Parent (Def_Id))); 1412 1413 Lang_Char := Next (First (Exdata)); 1414 1415 -- Change the one-character language designator to 'C' 1416 1417 Rewrite (Expression (Lang_Char), 1418 Make_Character_Literal (Loc, 1419 Chars => Name_uC, 1420 Char_Literal_Value => UI_From_Int (Character'Pos ('C')))); 1421 Analyze (Expression (Lang_Char)); 1422 1423 -- Change the value of Foreign_Data 1424 1425 Foreign_Data := Next (Next (Next (Next (Lang_Char)))); 1426 1427 Insert_Actions (Def_Id, New_List ( 1428 Make_Object_Declaration (Loc, 1429 Defining_Identifier => Dum, 1430 Object_Definition => 1431 New_Occurrence_Of (Standard_Character, Loc)), 1432 1433 Make_Pragma (Loc, 1434 Chars => Name_Import, 1435 Pragma_Argument_Associations => New_List ( 1436 Make_Pragma_Argument_Association (Loc, 1437 Expression => Make_Identifier (Loc, Name_Ada)), 1438 1439 Make_Pragma_Argument_Association (Loc, 1440 Expression => Make_Identifier (Loc, Chars (Dum))), 1441 1442 Make_Pragma_Argument_Association (Loc, 1443 Chars => Name_External_Name, 1444 Expression => Relocate_Node (Rtti_Name)))))); 1445 1446 Rewrite (Expression (Foreign_Data), 1447 Unchecked_Convert_To (Standard_A_Char, 1448 Make_Attribute_Reference (Loc, 1449 Prefix => Make_Identifier (Loc, Chars (Dum)), 1450 Attribute_Name => Name_Address))); 1451 Analyze (Expression (Foreign_Data)); 1452 end; 1453 1454 -- No special expansion required for any other case 1455 1456 else 1457 null; 1458 end if; 1459 end Expand_Pragma_Import_Or_Interface; 1460 1461 ------------------------------------- 1462 -- Expand_Pragma_Initial_Condition -- 1463 ------------------------------------- 1464 1465 procedure Expand_Pragma_Initial_Condition 1466 (Pack_Id : Entity_Id; 1467 N : Node_Id) 1468 is 1469 procedure Extract_Package_Body_Lists 1470 (Pack_Body : Node_Id; 1471 Body_List : out List_Id; 1472 Call_List : out List_Id; 1473 Spec_List : out List_Id); 1474 -- Obtain the various declarative and statement lists of package body 1475 -- Pack_Body needed to insert the initial condition procedure and the 1476 -- call to it. The lists are as follows: 1477 -- 1478 -- * Body_List - used to insert the initial condition procedure body 1479 -- 1480 -- * Call_List - used to insert the call to the initial condition 1481 -- procedure. 1482 -- 1483 -- * Spec_List - used to insert the initial condition procedure spec 1484 1485 procedure Extract_Package_Declaration_Lists 1486 (Pack_Decl : Node_Id; 1487 Body_List : out List_Id; 1488 Call_List : out List_Id; 1489 Spec_List : out List_Id); 1490 -- Obtain the various declarative lists of package declaration Pack_Decl 1491 -- needed to insert the initial condition procedure and the call to it. 1492 -- The lists are as follows: 1493 -- 1494 -- * Body_List - used to insert the initial condition procedure body 1495 -- 1496 -- * Call_List - used to insert the call to the initial condition 1497 -- procedure. 1498 -- 1499 -- * Spec_List - used to insert the initial condition procedure spec 1500 1501 -------------------------------- 1502 -- Extract_Package_Body_Lists -- 1503 -------------------------------- 1504 1505 procedure Extract_Package_Body_Lists 1506 (Pack_Body : Node_Id; 1507 Body_List : out List_Id; 1508 Call_List : out List_Id; 1509 Spec_List : out List_Id) 1510 is 1511 Pack_Spec : constant Entity_Id := Corresponding_Spec (Pack_Body); 1512 1513 Dummy_1 : List_Id; 1514 Dummy_2 : List_Id; 1515 HSS : Node_Id; 1516 1517 begin 1518 pragma Assert (Present (Pack_Spec)); 1519 1520 -- The different parts of the invariant procedure are inserted as 1521 -- follows: 1522 1523 -- package Pack is package body Pack is 1524 -- <IC spec> <IC body> 1525 -- private begin 1526 -- ... <IC call> 1527 -- end Pack; end Pack; 1528 1529 -- The initial condition procedure spec is inserted in the visible 1530 -- declaration of the corresponding package spec. 1531 1532 Extract_Package_Declaration_Lists 1533 (Pack_Decl => Unit_Declaration_Node (Pack_Spec), 1534 Body_List => Dummy_1, 1535 Call_List => Dummy_2, 1536 Spec_List => Spec_List); 1537 1538 -- The initial condition procedure body is added to the declarations 1539 -- of the package body. 1540 1541 Body_List := Declarations (Pack_Body); 1542 1543 if No (Body_List) then 1544 Body_List := New_List; 1545 Set_Declarations (Pack_Body, Body_List); 1546 end if; 1547 1548 -- The call to the initial condition procedure is inserted in the 1549 -- statements of the package body. 1550 1551 HSS := Handled_Statement_Sequence (Pack_Body); 1552 1553 if No (HSS) then 1554 HSS := 1555 Make_Handled_Sequence_Of_Statements (Sloc (Pack_Body), 1556 Statements => New_List); 1557 Set_Handled_Statement_Sequence (Pack_Body, HSS); 1558 end if; 1559 1560 Call_List := Statements (HSS); 1561 end Extract_Package_Body_Lists; 1562 1563 --------------------------------------- 1564 -- Extract_Package_Declaration_Lists -- 1565 --------------------------------------- 1566 1567 procedure Extract_Package_Declaration_Lists 1568 (Pack_Decl : Node_Id; 1569 Body_List : out List_Id; 1570 Call_List : out List_Id; 1571 Spec_List : out List_Id) 1572 is 1573 Pack_Spec : constant Node_Id := Specification (Pack_Decl); 1574 1575 begin 1576 -- The different parts of the invariant procedure are inserted as 1577 -- follows: 1578 1579 -- package Pack is 1580 -- <IC spec> 1581 -- <IC body> 1582 -- private 1583 -- <IC call> 1584 -- end Pack; 1585 1586 -- The initial condition procedure spec and body are inserted in the 1587 -- visible declarations of the package spec. 1588 1589 Body_List := Visible_Declarations (Pack_Spec); 1590 1591 if No (Body_List) then 1592 Body_List := New_List; 1593 Set_Visible_Declarations (Pack_Spec, Body_List); 1594 end if; 1595 1596 Spec_List := Body_List; 1597 1598 -- The call to the initial procedure is inserted in the private 1599 -- declarations of the package spec. 1600 1601 Call_List := Private_Declarations (Pack_Spec); 1602 1603 if No (Call_List) then 1604 Call_List := New_List; 1605 Set_Private_Declarations (Pack_Spec, Call_List); 1606 end if; 1607 end Extract_Package_Declaration_Lists; 1608 1609 -- Local variables 1610 1611 IC_Prag : constant Node_Id := 1612 Get_Pragma (Pack_Id, Pragma_Initial_Condition); 1613 1614 Body_List : List_Id; 1615 Call : Node_Id; 1616 Call_List : List_Id; 1617 Call_Loc : Source_Ptr; 1618 Expr : Node_Id; 1619 Loc : Source_Ptr; 1620 Proc_Body : Node_Id; 1621 Proc_Body_Id : Entity_Id; 1622 Proc_Decl : Node_Id; 1623 Proc_Id : Entity_Id; 1624 Spec_List : List_Id; 1625 1626 -- Start of processing for Expand_Pragma_Initial_Condition 1627 1628 begin 1629 -- Nothing to do when the package is not subject to an Initial_Condition 1630 -- pragma. 1631 1632 if No (IC_Prag) then 1633 return; 1634 end if; 1635 1636 Expr := Get_Pragma_Arg (First (Pragma_Argument_Associations (IC_Prag))); 1637 Loc := Sloc (IC_Prag); 1638 1639 -- Nothing to do when the pragma is ignored because its semantics are 1640 -- suppressed. 1641 1642 if Is_Ignored (IC_Prag) then 1643 return; 1644 1645 -- Nothing to do when the pragma or its argument are illegal because 1646 -- there is no valid expression to check. 1647 1648 elsif Error_Posted (IC_Prag) or else Error_Posted (Expr) then 1649 return; 1650 end if; 1651 1652 -- Obtain the various lists of the context where the individual pieces 1653 -- of the initial condition procedure are to be inserted. 1654 1655 if Nkind (N) = N_Package_Body then 1656 Extract_Package_Body_Lists 1657 (Pack_Body => N, 1658 Body_List => Body_List, 1659 Call_List => Call_List, 1660 Spec_List => Spec_List); 1661 1662 elsif Nkind (N) = N_Package_Declaration then 1663 Extract_Package_Declaration_Lists 1664 (Pack_Decl => N, 1665 Body_List => Body_List, 1666 Call_List => Call_List, 1667 Spec_List => Spec_List); 1668 1669 -- This routine should not be used on anything other than packages 1670 1671 else 1672 pragma Assert (False); 1673 return; 1674 end if; 1675 1676 Proc_Id := 1677 Make_Defining_Identifier (Loc, 1678 Chars => New_External_Name (Chars (Pack_Id), "Initial_Condition")); 1679 1680 Set_Ekind (Proc_Id, E_Procedure); 1681 Set_Is_Initial_Condition_Procedure (Proc_Id); 1682 1683 -- Generate: 1684 -- procedure <Pack_Id>Initial_Condition; 1685 1686 Proc_Decl := 1687 Make_Subprogram_Declaration (Loc, 1688 Make_Procedure_Specification (Loc, 1689 Defining_Unit_Name => Proc_Id)); 1690 1691 Append_To (Spec_List, Proc_Decl); 1692 1693 -- The initial condition procedure requires debug info when initial 1694 -- condition is subject to Source Coverage Obligations. 1695 1696 if Generate_SCO then 1697 Set_Debug_Info_Needed (Proc_Id); 1698 end if; 1699 1700 -- Generate: 1701 -- procedure <Pack_Id>Initial_Condition is 1702 -- begin 1703 -- pragma Check (Initial_Condition, <Expr>); 1704 -- end <Pack_Id>Initial_Condition; 1705 1706 Proc_Body := 1707 Make_Subprogram_Body (Loc, 1708 Specification => 1709 Copy_Subprogram_Spec (Specification (Proc_Decl)), 1710 Declarations => Empty_List, 1711 Handled_Statement_Sequence => 1712 Make_Handled_Sequence_Of_Statements (Loc, 1713 Statements => New_List ( 1714 Make_Pragma (Loc, 1715 Chars => Name_Check, 1716 Pragma_Argument_Associations => New_List ( 1717 Make_Pragma_Argument_Association (Loc, 1718 Expression => 1719 Make_Identifier (Loc, Name_Initial_Condition)), 1720 Make_Pragma_Argument_Association (Loc, 1721 Expression => New_Copy_Tree (Expr))))))); 1722 1723 Append_To (Body_List, Proc_Body); 1724 1725 -- The initial condition procedure requires debug info when initial 1726 -- condition is subject to Source Coverage Obligations. 1727 1728 Proc_Body_Id := Defining_Entity (Proc_Body); 1729 1730 if Generate_SCO then 1731 Set_Debug_Info_Needed (Proc_Body_Id); 1732 end if; 1733 1734 -- The location of the initial condition procedure call must be as close 1735 -- as possible to the intended semantic location of the check because 1736 -- the ABE mechanism relies heavily on accurate locations. 1737 1738 Call_Loc := End_Keyword_Location (N); 1739 1740 -- Generate: 1741 -- <Pack_Id>Initial_Condition; 1742 1743 Call := 1744 Make_Procedure_Call_Statement (Call_Loc, 1745 Name => New_Occurrence_Of (Proc_Id, Call_Loc)); 1746 1747 Append_To (Call_List, Call); 1748 1749 Analyze (Proc_Decl); 1750 Analyze (Proc_Body); 1751 Analyze (Call); 1752 end Expand_Pragma_Initial_Condition; 1753 1754 ------------------------------------ 1755 -- Expand_Pragma_Inspection_Point -- 1756 ------------------------------------ 1757 1758 -- If no argument is given, then we supply a default argument list that 1759 -- includes all objects declared at the source level in all subprograms 1760 -- that enclose the inspection point pragma. 1761 1762 procedure Expand_Pragma_Inspection_Point (N : Node_Id) is 1763 Loc : constant Source_Ptr := Sloc (N); 1764 A : List_Id; 1765 Assoc : Node_Id; 1766 S : Entity_Id; 1767 E : Entity_Id; 1768 1769 begin 1770 if No (Pragma_Argument_Associations (N)) then 1771 A := New_List; 1772 S := Current_Scope; 1773 1774 while S /= Standard_Standard loop 1775 E := First_Entity (S); 1776 while Present (E) loop 1777 if Comes_From_Source (E) 1778 and then Is_Object (E) 1779 and then not Is_Entry_Formal (E) 1780 and then Ekind (E) /= E_Component 1781 and then Ekind (E) /= E_Discriminant 1782 and then Ekind (E) /= E_Generic_In_Parameter 1783 and then Ekind (E) /= E_Generic_In_Out_Parameter 1784 then 1785 Append_To (A, 1786 Make_Pragma_Argument_Association (Loc, 1787 Expression => New_Occurrence_Of (E, Loc))); 1788 end if; 1789 1790 Next_Entity (E); 1791 end loop; 1792 1793 S := Scope (S); 1794 end loop; 1795 1796 Set_Pragma_Argument_Associations (N, A); 1797 end if; 1798 1799 -- Expand the arguments of the pragma. Expanding an entity reference 1800 -- is a noop, except in a protected operation, where a reference may 1801 -- have to be transformed into a reference to the corresponding prival. 1802 -- Are there other pragmas that may require this ??? 1803 1804 Assoc := First (Pragma_Argument_Associations (N)); 1805 while Present (Assoc) loop 1806 Expand (Expression (Assoc)); 1807 Next (Assoc); 1808 end loop; 1809 end Expand_Pragma_Inspection_Point; 1810 1811 -------------------------------------- 1812 -- Expand_Pragma_Interrupt_Priority -- 1813 -------------------------------------- 1814 1815 -- Supply default argument if none exists (System.Interrupt_Priority'Last) 1816 1817 procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is 1818 Loc : constant Source_Ptr := Sloc (N); 1819 begin 1820 if No (Pragma_Argument_Associations (N)) then 1821 Set_Pragma_Argument_Associations (N, New_List ( 1822 Make_Pragma_Argument_Association (Loc, 1823 Expression => 1824 Make_Attribute_Reference (Loc, 1825 Prefix => 1826 New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc), 1827 Attribute_Name => Name_Last)))); 1828 end if; 1829 end Expand_Pragma_Interrupt_Priority; 1830 1831 -------------------------------- 1832 -- Expand_Pragma_Loop_Variant -- 1833 -------------------------------- 1834 1835 -- Pragma Loop_Variant is expanded in the following manner: 1836 1837 -- Original code 1838 1839 -- for | while ... loop 1840 -- <preceding source statements> 1841 -- pragma Loop_Variant 1842 -- (Increases => Incr_Expr, 1843 -- Decreases => Decr_Expr); 1844 -- <succeeding source statements> 1845 -- end loop; 1846 1847 -- Expanded code 1848 1849 -- Curr_1 : <type of Incr_Expr>; 1850 -- Curr_2 : <type of Decr_Expr>; 1851 -- Old_1 : <type of Incr_Expr>; 1852 -- Old_2 : <type of Decr_Expr>; 1853 -- Flag : Boolean := False; 1854 1855 -- for | while ... loop 1856 -- <preceding source statements> 1857 1858 -- if Flag then 1859 -- Old_1 := Curr_1; 1860 -- Old_2 := Curr_2; 1861 -- end if; 1862 1863 -- Curr_1 := <Incr_Expr>; 1864 -- Curr_2 := <Decr_Expr>; 1865 1866 -- if Flag then 1867 -- if Curr_1 /= Old_1 then 1868 -- pragma Check (Loop_Variant, Curr_1 > Old_1); 1869 -- else 1870 -- pragma Check (Loop_Variant, Curr_2 < Old_2); 1871 -- end if; 1872 -- else 1873 -- Flag := True; 1874 -- end if; 1875 1876 -- <succeeding source statements> 1877 -- end loop; 1878 1879 procedure Expand_Pragma_Loop_Variant (N : Node_Id) is 1880 Loc : constant Source_Ptr := Sloc (N); 1881 Last_Var : constant Node_Id := 1882 Last (Pragma_Argument_Associations (N)); 1883 1884 Curr_Assign : List_Id := No_List; 1885 Flag_Id : Entity_Id := Empty; 1886 If_Stmt : Node_Id := Empty; 1887 Old_Assign : List_Id := No_List; 1888 Loop_Scop : Entity_Id; 1889 Loop_Stmt : Node_Id; 1890 Variant : Node_Id; 1891 1892 procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean); 1893 -- Process a single increasing / decreasing termination variant. Flag 1894 -- Is_Last should be set when processing the last variant. 1895 1896 --------------------- 1897 -- Process_Variant -- 1898 --------------------- 1899 1900 procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean) is 1901 function Make_Op 1902 (Loc : Source_Ptr; 1903 Curr_Val : Node_Id; 1904 Old_Val : Node_Id) return Node_Id; 1905 -- Generate a comparison between Curr_Val and Old_Val depending on 1906 -- the change mode (Increases / Decreases) of the variant. 1907 1908 ------------- 1909 -- Make_Op -- 1910 ------------- 1911 1912 function Make_Op 1913 (Loc : Source_Ptr; 1914 Curr_Val : Node_Id; 1915 Old_Val : Node_Id) return Node_Id 1916 is 1917 begin 1918 if Chars (Variant) = Name_Increases then 1919 return Make_Op_Gt (Loc, Curr_Val, Old_Val); 1920 else pragma Assert (Chars (Variant) = Name_Decreases); 1921 return Make_Op_Lt (Loc, Curr_Val, Old_Val); 1922 end if; 1923 end Make_Op; 1924 1925 -- Local variables 1926 1927 Expr : constant Node_Id := Expression (Variant); 1928 Expr_Typ : constant Entity_Id := Etype (Expr); 1929 Loc : constant Source_Ptr := Sloc (Expr); 1930 Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt); 1931 Curr_Id : Entity_Id; 1932 Old_Id : Entity_Id; 1933 Prag : Node_Id; 1934 1935 -- Start of processing for Process_Variant 1936 1937 begin 1938 -- All temporaries generated in this routine must be inserted before 1939 -- the related loop statement. Ensure that the proper scope is on the 1940 -- stack when analyzing the temporaries. Note that we also use the 1941 -- Sloc of the related loop. 1942 1943 Push_Scope (Scope (Loop_Scop)); 1944 1945 -- Step 1: Create the declaration of the flag which controls the 1946 -- behavior of the assertion on the first iteration of the loop. 1947 1948 if No (Flag_Id) then 1949 1950 -- Generate: 1951 -- Flag : Boolean := False; 1952 1953 Flag_Id := Make_Temporary (Loop_Loc, 'F'); 1954 1955 Insert_Action (Loop_Stmt, 1956 Make_Object_Declaration (Loop_Loc, 1957 Defining_Identifier => Flag_Id, 1958 Object_Definition => 1959 New_Occurrence_Of (Standard_Boolean, Loop_Loc), 1960 Expression => 1961 New_Occurrence_Of (Standard_False, Loop_Loc))); 1962 1963 -- Prevent an unwanted optimization where the Current_Value of 1964 -- the flag eliminates the if statement which stores the variant 1965 -- values coming from the previous iteration. 1966 1967 -- Flag : Boolean := False; 1968 -- loop 1969 -- if Flag then -- condition rewritten to False 1970 -- Old_N := Curr_N; -- and if statement eliminated 1971 -- end if; 1972 -- . . . 1973 -- Flag := True; 1974 -- end loop; 1975 1976 Set_Current_Value (Flag_Id, Empty); 1977 end if; 1978 1979 -- Step 2: Create the temporaries which store the old and current 1980 -- values of the associated expression. 1981 1982 -- Generate: 1983 -- Curr : <type of Expr>; 1984 1985 Curr_Id := Make_Temporary (Loc, 'C'); 1986 1987 Insert_Action (Loop_Stmt, 1988 Make_Object_Declaration (Loop_Loc, 1989 Defining_Identifier => Curr_Id, 1990 Object_Definition => New_Occurrence_Of (Expr_Typ, Loop_Loc))); 1991 1992 -- Generate: 1993 -- Old : <type of Expr>; 1994 1995 Old_Id := Make_Temporary (Loc, 'P'); 1996 1997 Insert_Action (Loop_Stmt, 1998 Make_Object_Declaration (Loop_Loc, 1999 Defining_Identifier => Old_Id, 2000 Object_Definition => New_Occurrence_Of (Expr_Typ, Loop_Loc))); 2001 2002 -- Restore original scope after all temporaries have been analyzed 2003 2004 Pop_Scope; 2005 2006 -- Step 3: Store value of the expression from the previous iteration 2007 2008 if No (Old_Assign) then 2009 Old_Assign := New_List; 2010 end if; 2011 2012 -- Generate: 2013 -- Old := Curr; 2014 2015 Append_To (Old_Assign, 2016 Make_Assignment_Statement (Loc, 2017 Name => New_Occurrence_Of (Old_Id, Loc), 2018 Expression => New_Occurrence_Of (Curr_Id, Loc))); 2019 2020 -- Step 4: Store the current value of the expression 2021 2022 if No (Curr_Assign) then 2023 Curr_Assign := New_List; 2024 end if; 2025 2026 -- Generate: 2027 -- Curr := <Expr>; 2028 2029 Append_To (Curr_Assign, 2030 Make_Assignment_Statement (Loc, 2031 Name => New_Occurrence_Of (Curr_Id, Loc), 2032 Expression => Relocate_Node (Expr))); 2033 2034 -- Step 5: Create corresponding assertion to verify change of value 2035 2036 -- Generate: 2037 -- pragma Check (Loop_Variant, Curr <|> Old); 2038 2039 Prag := 2040 Make_Pragma (Loc, 2041 Chars => Name_Check, 2042 Pragma_Argument_Associations => New_List ( 2043 Make_Pragma_Argument_Association (Loc, 2044 Expression => Make_Identifier (Loc, Name_Loop_Variant)), 2045 Make_Pragma_Argument_Association (Loc, 2046 Expression => 2047 Make_Op (Loc, 2048 Curr_Val => New_Occurrence_Of (Curr_Id, Loc), 2049 Old_Val => New_Occurrence_Of (Old_Id, Loc))))); 2050 2051 -- Generate: 2052 -- if Curr /= Old then 2053 -- <Prag>; 2054 2055 if No (If_Stmt) then 2056 2057 -- When there is just one termination variant, do not compare the 2058 -- old and current value for equality, just check the pragma. 2059 2060 if Is_Last then 2061 If_Stmt := Prag; 2062 else 2063 If_Stmt := 2064 Make_If_Statement (Loc, 2065 Condition => 2066 Make_Op_Ne (Loc, 2067 Left_Opnd => New_Occurrence_Of (Curr_Id, Loc), 2068 Right_Opnd => New_Occurrence_Of (Old_Id, Loc)), 2069 Then_Statements => New_List (Prag)); 2070 end if; 2071 2072 -- Generate: 2073 -- else 2074 -- <Prag>; 2075 -- end if; 2076 2077 elsif Is_Last then 2078 Set_Else_Statements (If_Stmt, New_List (Prag)); 2079 2080 -- Generate: 2081 -- elsif Curr /= Old then 2082 -- <Prag>; 2083 2084 else 2085 if Elsif_Parts (If_Stmt) = No_List then 2086 Set_Elsif_Parts (If_Stmt, New_List); 2087 end if; 2088 2089 Append_To (Elsif_Parts (If_Stmt), 2090 Make_Elsif_Part (Loc, 2091 Condition => 2092 Make_Op_Ne (Loc, 2093 Left_Opnd => New_Occurrence_Of (Curr_Id, Loc), 2094 Right_Opnd => New_Occurrence_Of (Old_Id, Loc)), 2095 Then_Statements => New_List (Prag))); 2096 end if; 2097 end Process_Variant; 2098 2099 -- Start of processing for Expand_Pragma_Loop_Variant 2100 2101 begin 2102 -- If pragma is not enabled, rewrite as Null statement. If pragma is 2103 -- disabled, it has already been rewritten as a Null statement. 2104 2105 if Is_Ignored (N) then 2106 Rewrite (N, Make_Null_Statement (Loc)); 2107 Analyze (N); 2108 return; 2109 end if; 2110 2111 -- The expansion of Loop_Variant is quite distributed as it produces 2112 -- various statements to capture and compare the arguments. To preserve 2113 -- the original context, set the Is_Assertion_Expr flag. This aids the 2114 -- Ghost legality checks when verifying the placement of a reference to 2115 -- a Ghost entity. 2116 2117 In_Assertion_Expr := In_Assertion_Expr + 1; 2118 2119 -- Locate the enclosing loop for which this assertion applies. In the 2120 -- case of Ada 2012 array iteration, we might be dealing with nested 2121 -- loops. Only the outermost loop has an identifier. 2122 2123 Loop_Stmt := N; 2124 while Present (Loop_Stmt) loop 2125 if Nkind (Loop_Stmt) = N_Loop_Statement 2126 and then Present (Identifier (Loop_Stmt)) 2127 then 2128 exit; 2129 end if; 2130 2131 Loop_Stmt := Parent (Loop_Stmt); 2132 end loop; 2133 2134 Loop_Scop := Entity (Identifier (Loop_Stmt)); 2135 2136 -- Create the circuitry which verifies individual variants 2137 2138 Variant := First (Pragma_Argument_Associations (N)); 2139 while Present (Variant) loop 2140 Process_Variant (Variant, Is_Last => Variant = Last_Var); 2141 Next (Variant); 2142 end loop; 2143 2144 -- Construct the segment which stores the old values of all expressions. 2145 -- Generate: 2146 -- if Flag then 2147 -- <Old_Assign> 2148 -- end if; 2149 2150 Insert_Action (N, 2151 Make_If_Statement (Loc, 2152 Condition => New_Occurrence_Of (Flag_Id, Loc), 2153 Then_Statements => Old_Assign)); 2154 2155 -- Update the values of all expressions 2156 2157 Insert_Actions (N, Curr_Assign); 2158 2159 -- Add the assertion circuitry to test all changes in expressions. 2160 -- Generate: 2161 -- if Flag then 2162 -- <If_Stmt> 2163 -- else 2164 -- Flag := True; 2165 -- end if; 2166 2167 Insert_Action (N, 2168 Make_If_Statement (Loc, 2169 Condition => New_Occurrence_Of (Flag_Id, Loc), 2170 Then_Statements => New_List (If_Stmt), 2171 Else_Statements => New_List ( 2172 Make_Assignment_Statement (Loc, 2173 Name => New_Occurrence_Of (Flag_Id, Loc), 2174 Expression => New_Occurrence_Of (Standard_True, Loc))))); 2175 2176 -- Note: the pragma has been completely transformed into a sequence of 2177 -- corresponding declarations and statements. We leave it in the tree 2178 -- for documentation purposes. It will be ignored by the backend. 2179 2180 In_Assertion_Expr := In_Assertion_Expr - 1; 2181 end Expand_Pragma_Loop_Variant; 2182 2183 -------------------------------- 2184 -- Expand_Pragma_Psect_Object -- 2185 -------------------------------- 2186 2187 -- Convert to Common_Object, and expand the resulting pragma 2188 2189 procedure Expand_Pragma_Psect_Object (N : Node_Id) 2190 renames Expand_Pragma_Common_Object; 2191 2192 ------------------------------------- 2193 -- Expand_Pragma_Relative_Deadline -- 2194 ------------------------------------- 2195 2196 procedure Expand_Pragma_Relative_Deadline (N : Node_Id) is 2197 P : constant Node_Id := Parent (N); 2198 Loc : constant Source_Ptr := Sloc (N); 2199 2200 begin 2201 -- Expand the pragma only in the case of the main subprogram. For tasks 2202 -- the expansion is done in exp_ch9. Generate a call to Set_Deadline 2203 -- at Clock plus the relative deadline specified in the pragma. Time 2204 -- values are translated into Duration to allow for non-private 2205 -- addition operation. 2206 2207 if Nkind (P) = N_Subprogram_Body then 2208 Rewrite 2209 (N, 2210 Make_Procedure_Call_Statement (Loc, 2211 Name => New_Occurrence_Of (RTE (RE_Set_Deadline), Loc), 2212 Parameter_Associations => New_List ( 2213 Unchecked_Convert_To (RTE (RO_RT_Time), 2214 Make_Op_Add (Loc, 2215 Left_Opnd => 2216 Make_Function_Call (Loc, 2217 New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc), 2218 New_List 2219 (Make_Function_Call 2220 (Loc, New_Occurrence_Of (RTE (RE_Clock), Loc)))), 2221 Right_Opnd => 2222 Unchecked_Convert_To (Standard_Duration, Arg1 (N))))))); 2223 2224 Analyze (N); 2225 end if; 2226 end Expand_Pragma_Relative_Deadline; 2227 2228 ------------------------------------------- 2229 -- Expand_Pragma_Suppress_Initialization -- 2230 ------------------------------------------- 2231 2232 procedure Expand_Pragma_Suppress_Initialization (N : Node_Id) is 2233 Def_Id : constant Entity_Id := Entity (Arg1 (N)); 2234 2235 begin 2236 -- Variable case (we have to undo any initialization already done) 2237 2238 if Ekind (Def_Id) = E_Variable then 2239 Undo_Initialization (Def_Id, N); 2240 end if; 2241 end Expand_Pragma_Suppress_Initialization; 2242 2243 ------------------------- 2244 -- Undo_Initialization -- 2245 ------------------------- 2246 2247 procedure Undo_Initialization (Def_Id : Entity_Id; N : Node_Id) is 2248 Init_Call : Node_Id; 2249 2250 begin 2251 -- When applied to a variable, the default initialization must not be 2252 -- done. As it is already done when the pragma is found, we just get rid 2253 -- of the call the initialization procedure which followed the object 2254 -- declaration. The call is inserted after the declaration, but validity 2255 -- checks may also have been inserted and thus the initialization call 2256 -- does not necessarily appear immediately after the object declaration. 2257 2258 -- We can't use the freezing mechanism for this purpose, since we have 2259 -- to elaborate the initialization expression when it is first seen (so 2260 -- this elaboration cannot be deferred to the freeze point). 2261 2262 -- Find and remove generated initialization call for object, if any 2263 2264 Init_Call := Remove_Init_Call (Def_Id, Rep_Clause => N); 2265 2266 -- Any default initialization expression should be removed (e.g. 2267 -- null defaults for access objects, zero initialization of packed 2268 -- bit arrays). Imported objects aren't allowed to have explicit 2269 -- initialization, so the expression must have been generated by 2270 -- the compiler. 2271 2272 if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then 2273 Set_Expression (Parent (Def_Id), Empty); 2274 end if; 2275 2276 -- The object may not have any initialization, but in the presence of 2277 -- Initialize_Scalars code is inserted after then declaration, which 2278 -- must now be removed as well. The code carries the same source 2279 -- location as the declaration itself. 2280 2281 if Initialize_Scalars and then Is_Array_Type (Etype (Def_Id)) then 2282 declare 2283 Init : Node_Id; 2284 Nxt : Node_Id; 2285 begin 2286 Init := Next (Parent (Def_Id)); 2287 while not Comes_From_Source (Init) 2288 and then Sloc (Init) = Sloc (Def_Id) 2289 loop 2290 Nxt := Next (Init); 2291 Remove (Init); 2292 Init := Nxt; 2293 end loop; 2294 end; 2295 end if; 2296 end Undo_Initialization; 2297 2298end Exp_Prag; 2299