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