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