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