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