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 Debug; use Debug; 29with Einfo; use Einfo; 30with Errout; use Errout; 31with Exp_Ch11; use Exp_Ch11; 32with Exp_Util; use Exp_Util; 33with Expander; use Expander; 34with Namet; use Namet; 35with Nlists; use Nlists; 36with Nmake; use Nmake; 37with Opt; use Opt; 38with Restrict; use Restrict; 39with Rident; use Rident; 40with Rtsfind; use Rtsfind; 41with Sem; use Sem; 42with Sem_Ch8; use Sem_Ch8; 43with Sem_Res; use Sem_Res; 44with Sem_Util; use Sem_Util; 45with Sinfo; use Sinfo; 46with Sinput; use Sinput; 47with Snames; use Snames; 48with Stringt; use Stringt; 49with Stand; use Stand; 50with Targparm; use Targparm; 51with Tbuild; use Tbuild; 52with Uintp; use Uintp; 53 54package body Exp_Prag is 55 56 ----------------------- 57 -- Local Subprograms -- 58 ----------------------- 59 60 function Arg1 (N : Node_Id) return Node_Id; 61 function Arg2 (N : Node_Id) return Node_Id; 62 function Arg3 (N : Node_Id) return Node_Id; 63 -- Obtain specified pragma argument expression 64 65 procedure Expand_Pragma_Abort_Defer (N : Node_Id); 66 procedure Expand_Pragma_Check (N : Node_Id); 67 procedure Expand_Pragma_Common_Object (N : Node_Id); 68 procedure Expand_Pragma_Import_Or_Interface (N : Node_Id); 69 procedure Expand_Pragma_Import_Export_Exception (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 76 ---------- 77 -- Arg1 -- 78 ---------- 79 80 function Arg1 (N : Node_Id) return Node_Id is 81 Arg : constant Node_Id := First (Pragma_Argument_Associations (N)); 82 begin 83 if Present (Arg) 84 and then Nkind (Arg) = N_Pragma_Argument_Association 85 then 86 return Expression (Arg); 87 else 88 return Arg; 89 end if; 90 end Arg1; 91 92 ---------- 93 -- Arg2 -- 94 ---------- 95 96 function Arg2 (N : Node_Id) return Node_Id is 97 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); 98 99 begin 100 if No (Arg1) then 101 return Empty; 102 103 else 104 declare 105 Arg : constant Node_Id := Next (Arg1); 106 begin 107 if Present (Arg) 108 and then Nkind (Arg) = N_Pragma_Argument_Association 109 then 110 return Expression (Arg); 111 else 112 return Arg; 113 end if; 114 end; 115 end if; 116 end Arg2; 117 118 ---------- 119 -- Arg3 -- 120 ---------- 121 122 function Arg3 (N : Node_Id) return Node_Id is 123 Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); 124 125 begin 126 if No (Arg1) then 127 return Empty; 128 129 else 130 declare 131 Arg : Node_Id := Next (Arg1); 132 begin 133 if No (Arg) then 134 return Empty; 135 136 else 137 Next (Arg); 138 139 if Present (Arg) 140 and then Nkind (Arg) = N_Pragma_Argument_Association 141 then 142 return Expression (Arg); 143 else 144 return Arg; 145 end if; 146 end if; 147 end; 148 end if; 149 end Arg3; 150 151 --------------------- 152 -- Expand_N_Pragma -- 153 --------------------- 154 155 procedure Expand_N_Pragma (N : Node_Id) is 156 Pname : constant Name_Id := Pragma_Name (N); 157 158 begin 159 -- Note: we may have a pragma whose Pragma_Identifier field is not a 160 -- recognized pragma, and we must ignore it at this stage. 161 162 if Is_Pragma_Name (Pname) then 163 case Get_Pragma_Id (Pname) is 164 165 -- Pragmas requiring special expander action 166 167 when Pragma_Abort_Defer => 168 Expand_Pragma_Abort_Defer (N); 169 170 when Pragma_Check => 171 Expand_Pragma_Check (N); 172 173 when Pragma_Common_Object => 174 Expand_Pragma_Common_Object (N); 175 176 when Pragma_Export_Exception => 177 Expand_Pragma_Import_Export_Exception (N); 178 179 when Pragma_Import => 180 Expand_Pragma_Import_Or_Interface (N); 181 182 when Pragma_Import_Exception => 183 Expand_Pragma_Import_Export_Exception (N); 184 185 when Pragma_Inspection_Point => 186 Expand_Pragma_Inspection_Point (N); 187 188 when Pragma_Interface => 189 Expand_Pragma_Import_Or_Interface (N); 190 191 when Pragma_Interrupt_Priority => 192 Expand_Pragma_Interrupt_Priority (N); 193 194 when Pragma_Loop_Variant => 195 Expand_Pragma_Loop_Variant (N); 196 197 when Pragma_Psect_Object => 198 Expand_Pragma_Psect_Object (N); 199 200 when Pragma_Relative_Deadline => 201 Expand_Pragma_Relative_Deadline (N); 202 203 -- All other pragmas need no expander action 204 205 when others => null; 206 end case; 207 end if; 208 209 end Expand_N_Pragma; 210 211 ------------------------------- 212 -- Expand_Pragma_Abort_Defer -- 213 ------------------------------- 214 215 -- An Abort_Defer pragma appears as the first statement in a handled 216 -- statement sequence (right after the begin). It defers aborts for 217 -- the entire statement sequence, but not for any declarations or 218 -- handlers (if any) associated with this statement sequence. 219 220 -- The transformation is to transform 221 222 -- pragma Abort_Defer; 223 -- statements; 224 225 -- into 226 227 -- begin 228 -- Abort_Defer.all; 229 -- statements 230 -- exception 231 -- when all others => 232 -- Abort_Undefer.all; 233 -- raise; 234 -- at end 235 -- Abort_Undefer_Direct; 236 -- end; 237 238 procedure Expand_Pragma_Abort_Defer (N : Node_Id) is 239 Loc : constant Source_Ptr := Sloc (N); 240 Stm : Node_Id; 241 Stms : List_Id; 242 HSS : Node_Id; 243 Blk : constant Entity_Id := 244 New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B'); 245 246 begin 247 Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer)); 248 249 loop 250 Stm := Remove_Next (N); 251 exit when No (Stm); 252 Append (Stm, Stms); 253 end loop; 254 255 HSS := 256 Make_Handled_Sequence_Of_Statements (Loc, 257 Statements => Stms, 258 At_End_Proc => 259 New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); 260 261 Rewrite (N, 262 Make_Block_Statement (Loc, 263 Handled_Statement_Sequence => HSS)); 264 265 Set_Scope (Blk, Current_Scope); 266 Set_Etype (Blk, Standard_Void_Type); 267 Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N))); 268 Expand_At_End_Handler (HSS, Blk); 269 Analyze (N); 270 end Expand_Pragma_Abort_Defer; 271 272 -------------------------- 273 -- Expand_Pragma_Check -- 274 -------------------------- 275 276 procedure Expand_Pragma_Check (N : Node_Id) is 277 Loc : constant Source_Ptr := Sloc (N); 278 -- Location of the pragma node. Note: it is important to use this 279 -- location (and not the location of the expression) for the generated 280 -- statements, otherwise the implicit return statement in the body 281 -- of a pre/postcondition subprogram may inherit the source location 282 -- of part of the expression, which causes confusing debug information 283 -- to be generated, which interferes with coverage analysis tools. 284 285 Cond : constant Node_Id := Arg2 (N); 286 Nam : constant Name_Id := Chars (Arg1 (N)); 287 Msg : Node_Id; 288 289 begin 290 -- We already know that this check is enabled, because otherwise the 291 -- semantic pass dealt with rewriting the assertion (see Sem_Prag) 292 293 -- Since this check is enabled, we rewrite the pragma into a 294 -- corresponding if statement, and then analyze the statement 295 296 -- The normal case expansion transforms: 297 298 -- pragma Check (name, condition [,message]); 299 300 -- into 301 302 -- if not condition then 303 -- System.Assertions.Raise_Assert_Failure (Str); 304 -- end if; 305 306 -- where Str is the message if one is present, or the default of 307 -- name failed at file:line if no message is given (the "name failed 308 -- at" is omitted for name = Assertion, since it is redundant, given 309 -- that the name of the exception is Assert_Failure.) 310 311 -- An alternative expansion is used when the No_Exception_Propagation 312 -- restriction is active and there is a local Assert_Failure handler. 313 -- This is not a common combination of circumstances, but it occurs in 314 -- the context of Aunit and the zero footprint profile. In this case we 315 -- generate: 316 317 -- if not condition then 318 -- raise Assert_Failure; 319 -- end if; 320 321 -- This will then be transformed into a goto, and the local handler will 322 -- be able to handle the assert error (which would not be the case if a 323 -- call is made to the Raise_Assert_Failure procedure). 324 325 -- We also generate the direct raise if the Suppress_Exception_Locations 326 -- is active, since we don't want to generate messages in this case. 327 328 -- Note that the reason we do not always generate a direct raise is that 329 -- the form in which the procedure is called allows for more efficient 330 -- breakpointing of assertion errors. 331 332 -- Generate the appropriate if statement. Note that we consider this to 333 -- be an explicit conditional in the source, not an implicit if, so we 334 -- do not call Make_Implicit_If_Statement. 335 336 -- Case where we generate a direct raise 337 338 if ((Debug_Flag_Dot_G 339 or else Restriction_Active (No_Exception_Propagation)) 340 and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N))) 341 or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N))) 342 then 343 Rewrite (N, 344 Make_If_Statement (Loc, 345 Condition => 346 Make_Op_Not (Loc, 347 Right_Opnd => Cond), 348 Then_Statements => New_List ( 349 Make_Raise_Statement (Loc, 350 Name => 351 New_Reference_To (RTE (RE_Assert_Failure), Loc))))); 352 353 -- Case where we call the procedure 354 355 else 356 -- If we have a message given, use it 357 358 if Present (Arg3 (N)) then 359 Msg := Get_Pragma_Arg (Arg3 (N)); 360 361 -- Here we have no string, so prepare one 362 363 else 364 declare 365 Msg_Loc : constant String := 366 Build_Location_String (Sloc (First_Node (Cond))); 367 -- Source location used in the case of a failed assertion: 368 -- point to the failing condition, not Loc. Note that the 369 -- source location of the expression is not usually the best 370 -- choice here. For example, it gets located on the last AND 371 -- keyword in a chain of boolean expressiond AND'ed together. 372 -- It is best to put the message on the first character of the 373 -- condition, which is the effect of the First_Node call here. 374 375 begin 376 Name_Len := 0; 377 378 -- For Assert, we just use the location 379 380 if Nam = Name_Assertion then 381 null; 382 383 -- For predicate, we generate the string "predicate failed 384 -- at yyy". We prefer all lower case for predicate. 385 386 elsif Nam = Name_Predicate then 387 Add_Str_To_Name_Buffer ("predicate failed at "); 388 389 -- For special case of Precondition/Postcondition the string is 390 -- "failed xx from yy" where xx is precondition/postcondition 391 -- in all lower case. The reason for this different wording is 392 -- that the failure is not at the point of occurrence of the 393 -- pragma, unlike the other Check cases. 394 395 elsif Nam = Name_Precondition 396 or else 397 Nam = Name_Postcondition 398 then 399 Get_Name_String (Nam); 400 Insert_Str_In_Name_Buffer ("failed ", 1); 401 Add_Str_To_Name_Buffer (" from "); 402 403 -- For all other checks, the string is "xxx failed at yyy" 404 -- where xxx is the check name with current source file casing. 405 406 else 407 Get_Name_String (Nam); 408 Set_Casing (Identifier_Casing (Current_Source_File)); 409 Add_Str_To_Name_Buffer (" failed at "); 410 end if; 411 412 -- In all cases, add location string 413 414 Add_Str_To_Name_Buffer (Msg_Loc); 415 416 -- Build the message 417 418 Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)); 419 end; 420 end if; 421 422 -- Now rewrite as an if statement 423 424 Rewrite (N, 425 Make_If_Statement (Loc, 426 Condition => 427 Make_Op_Not (Loc, 428 Right_Opnd => Cond), 429 Then_Statements => New_List ( 430 Make_Procedure_Call_Statement (Loc, 431 Name => 432 New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc), 433 Parameter_Associations => New_List (Relocate_Node (Msg)))))); 434 end if; 435 436 Analyze (N); 437 438 -- If new condition is always false, give a warning 439 440 if Warn_On_Assertion_Failure 441 and then Nkind (N) = N_Procedure_Call_Statement 442 and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure) 443 then 444 -- If original condition was a Standard.False, we assume that this is 445 -- indeed intended to raise assert error and no warning is required. 446 447 if Is_Entity_Name (Original_Node (Cond)) 448 and then Entity (Original_Node (Cond)) = Standard_False 449 then 450 return; 451 452 elsif Nam = Name_Assertion then 453 Error_Msg_N ("?A?assertion will fail at run time", N); 454 else 455 456 Error_Msg_N ("?A?check will fail at run time", N); 457 end if; 458 end if; 459 end Expand_Pragma_Check; 460 461 --------------------------------- 462 -- Expand_Pragma_Common_Object -- 463 --------------------------------- 464 465 -- Use a machine attribute to replicate semantic effect in DEC Ada 466 467 -- pragma Machine_Attribute (intern_name, "common_object", extern_name); 468 469 -- For now we do nothing with the size attribute ??? 470 471 -- Note: Psect_Object shares this processing 472 473 procedure Expand_Pragma_Common_Object (N : Node_Id) is 474 Loc : constant Source_Ptr := Sloc (N); 475 476 Internal : constant Node_Id := Arg1 (N); 477 External : constant Node_Id := Arg2 (N); 478 479 Psect : Node_Id; 480 -- Psect value upper cased as string literal 481 482 Iloc : constant Source_Ptr := Sloc (Internal); 483 Eloc : constant Source_Ptr := Sloc (External); 484 Ploc : Source_Ptr; 485 486 begin 487 -- Acquire Psect value and fold to upper case 488 489 if Present (External) then 490 if Nkind (External) = N_String_Literal then 491 String_To_Name_Buffer (Strval (External)); 492 else 493 Get_Name_String (Chars (External)); 494 end if; 495 496 Set_All_Upper_Case; 497 498 Psect := 499 Make_String_Literal (Eloc, 500 Strval => String_From_Name_Buffer); 501 502 else 503 Get_Name_String (Chars (Internal)); 504 Set_All_Upper_Case; 505 Psect := 506 Make_String_Literal (Iloc, 507 Strval => String_From_Name_Buffer); 508 end if; 509 510 Ploc := Sloc (Psect); 511 512 -- Insert the pragma 513 514 Insert_After_And_Analyze (N, 515 Make_Pragma (Loc, 516 Chars => Name_Machine_Attribute, 517 Pragma_Argument_Associations => New_List ( 518 Make_Pragma_Argument_Association (Iloc, 519 Expression => New_Copy_Tree (Internal)), 520 Make_Pragma_Argument_Association (Eloc, 521 Expression => 522 Make_String_Literal (Sloc => Ploc, 523 Strval => "common_object")), 524 Make_Pragma_Argument_Association (Ploc, 525 Expression => New_Copy_Tree (Psect))))); 526 527 end Expand_Pragma_Common_Object; 528 529 --------------------------------------- 530 -- Expand_Pragma_Import_Or_Interface -- 531 --------------------------------------- 532 533 -- When applied to a variable, the default initialization must not be done. 534 -- As it is already done when the pragma is found, we just get rid of the 535 -- call the initialization procedure which followed the object declaration. 536 -- The call is inserted after the declaration, but validity checks may 537 -- also have been inserted and the initialization call does not necessarily 538 -- appear immediately after the object declaration. 539 540 -- We can't use the freezing mechanism for this purpose, since we have to 541 -- elaborate the initialization expression when it is first seen (i.e. this 542 -- elaboration cannot be deferred to the freeze point). 543 544 procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is 545 Def_Id : Entity_Id; 546 Init_Call : Node_Id; 547 548 begin 549 Def_Id := Entity (Arg2 (N)); 550 if Ekind (Def_Id) = E_Variable then 551 552 -- Find and remove generated initialization call for object, if any 553 554 Init_Call := Remove_Init_Call (Def_Id, Rep_Clause => N); 555 556 -- Any default initialization expression should be removed (e.g., 557 -- null defaults for access objects, zero initialization of packed 558 -- bit arrays). Imported objects aren't allowed to have explicit 559 -- initialization, so the expression must have been generated by 560 -- the compiler. 561 562 if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then 563 Set_Expression (Parent (Def_Id), Empty); 564 end if; 565 end if; 566 end Expand_Pragma_Import_Or_Interface; 567 568 ------------------------------------------- 569 -- Expand_Pragma_Import_Export_Exception -- 570 ------------------------------------------- 571 572 -- For a VMS exception fix up the language field with "VMS" 573 -- instead of "Ada" (gigi needs this), create a constant that will be the 574 -- value of the VMS condition code and stuff the Interface_Name field 575 -- with the unexpanded name of the exception (if not already set). 576 -- For a Ada exception, just stuff the Interface_Name field 577 -- with the unexpanded name of the exception (if not already set). 578 579 procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is 580 begin 581 -- This pragma is only effective on OpenVMS systems, it was ignored 582 -- on non-VMS systems, and we need to ignore it here as well. 583 584 if not OpenVMS_On_Target then 585 return; 586 end if; 587 588 declare 589 Id : constant Entity_Id := Entity (Arg1 (N)); 590 Call : constant Node_Id := Register_Exception_Call (Id); 591 Loc : constant Source_Ptr := Sloc (N); 592 593 begin 594 if Present (Call) then 595 declare 596 Excep_Internal : constant Node_Id := Make_Temporary (Loc, 'V'); 597 Export_Pragma : Node_Id; 598 Excep_Alias : Node_Id; 599 Excep_Object : Node_Id; 600 Excep_Image : String_Id; 601 Exdata : List_Id; 602 Lang_Char : Node_Id; 603 Code : Node_Id; 604 605 begin 606 if Present (Interface_Name (Id)) then 607 Excep_Image := Strval (Interface_Name (Id)); 608 else 609 Get_Name_String (Chars (Id)); 610 Set_All_Upper_Case; 611 Excep_Image := String_From_Name_Buffer; 612 end if; 613 614 Exdata := Component_Associations (Expression (Parent (Id))); 615 616 if Is_VMS_Exception (Id) then 617 Lang_Char := Next (First (Exdata)); 618 619 -- Change the one-character language designator to 'V' 620 621 Rewrite (Expression (Lang_Char), 622 Make_Character_Literal (Loc, 623 Chars => Name_uV, 624 Char_Literal_Value => 625 UI_From_Int (Character'Pos ('V')))); 626 Analyze (Expression (Lang_Char)); 627 628 if Exception_Code (Id) /= No_Uint then 629 Code := 630 Make_Integer_Literal (Loc, 631 Intval => Exception_Code (Id)); 632 633 Excep_Object := 634 Make_Object_Declaration (Loc, 635 Defining_Identifier => Excep_Internal, 636 Object_Definition => 637 New_Reference_To (RTE (RE_Exception_Code), Loc)); 638 639 Insert_Action (N, Excep_Object); 640 Analyze (Excep_Object); 641 642 Start_String; 643 Store_String_Int 644 (UI_To_Int (Exception_Code (Id)) / 8 * 8); 645 646 Excep_Alias := 647 Make_Pragma (Loc, 648 Chars => Name_Linker_Alias, 649 Pragma_Argument_Associations => New_List ( 650 Make_Pragma_Argument_Association (Loc, 651 Expression => 652 New_Reference_To (Excep_Internal, Loc)), 653 654 Make_Pragma_Argument_Association (Loc, 655 Expression => 656 Make_String_Literal (Loc, End_String)))); 657 658 Insert_Action (N, Excep_Alias); 659 Analyze (Excep_Alias); 660 661 Export_Pragma := 662 Make_Pragma (Loc, 663 Chars => Name_Export, 664 Pragma_Argument_Associations => New_List ( 665 Make_Pragma_Argument_Association (Loc, 666 Expression => Make_Identifier (Loc, Name_C)), 667 668 Make_Pragma_Argument_Association (Loc, 669 Expression => 670 New_Reference_To (Excep_Internal, Loc)), 671 672 Make_Pragma_Argument_Association (Loc, 673 Expression => 674 Make_String_Literal (Loc, Excep_Image)), 675 676 Make_Pragma_Argument_Association (Loc, 677 Expression => 678 Make_String_Literal (Loc, Excep_Image)))); 679 680 Insert_Action (N, Export_Pragma); 681 Analyze (Export_Pragma); 682 683 else 684 Code := 685 Unchecked_Convert_To (RTE (RE_Exception_Code), 686 Make_Function_Call (Loc, 687 Name => 688 New_Reference_To (RTE (RE_Import_Value), Loc), 689 Parameter_Associations => New_List 690 (Make_String_Literal (Loc, 691 Strval => Excep_Image)))); 692 end if; 693 694 Rewrite (Call, 695 Make_Procedure_Call_Statement (Loc, 696 Name => New_Reference_To 697 (RTE (RE_Register_VMS_Exception), Loc), 698 Parameter_Associations => New_List ( 699 Code, 700 Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr), 701 Make_Attribute_Reference (Loc, 702 Prefix => New_Occurrence_Of (Id, Loc), 703 Attribute_Name => Name_Unrestricted_Access))))); 704 705 Analyze_And_Resolve (Code, RTE (RE_Exception_Code)); 706 Analyze (Call); 707 end if; 708 709 if No (Interface_Name (Id)) then 710 Set_Interface_Name (Id, 711 Make_String_Literal 712 (Sloc => Loc, 713 Strval => Excep_Image)); 714 end if; 715 end; 716 end if; 717 end; 718 end Expand_Pragma_Import_Export_Exception; 719 720 ------------------------------------ 721 -- Expand_Pragma_Inspection_Point -- 722 ------------------------------------ 723 724 -- If no argument is given, then we supply a default argument list that 725 -- includes all objects declared at the source level in all subprograms 726 -- that enclose the inspection point pragma. 727 728 procedure Expand_Pragma_Inspection_Point (N : Node_Id) is 729 Loc : constant Source_Ptr := Sloc (N); 730 A : List_Id; 731 Assoc : Node_Id; 732 S : Entity_Id; 733 E : Entity_Id; 734 735 begin 736 if No (Pragma_Argument_Associations (N)) then 737 A := New_List; 738 S := Current_Scope; 739 740 while S /= Standard_Standard loop 741 E := First_Entity (S); 742 while Present (E) loop 743 if Comes_From_Source (E) 744 and then Is_Object (E) 745 and then not Is_Entry_Formal (E) 746 and then Ekind (E) /= E_Component 747 and then Ekind (E) /= E_Discriminant 748 and then Ekind (E) /= E_Generic_In_Parameter 749 and then Ekind (E) /= E_Generic_In_Out_Parameter 750 then 751 Append_To (A, 752 Make_Pragma_Argument_Association (Loc, 753 Expression => New_Occurrence_Of (E, Loc))); 754 end if; 755 756 Next_Entity (E); 757 end loop; 758 759 S := Scope (S); 760 end loop; 761 762 Set_Pragma_Argument_Associations (N, A); 763 end if; 764 765 -- Expand the arguments of the pragma. Expanding an entity reference 766 -- is a noop, except in a protected operation, where a reference may 767 -- have to be transformed into a reference to the corresponding prival. 768 -- Are there other pragmas that may require this ??? 769 770 Assoc := First (Pragma_Argument_Associations (N)); 771 772 while Present (Assoc) loop 773 Expand (Expression (Assoc)); 774 Next (Assoc); 775 end loop; 776 end Expand_Pragma_Inspection_Point; 777 778 -------------------------------------- 779 -- Expand_Pragma_Interrupt_Priority -- 780 -------------------------------------- 781 782 -- Supply default argument if none exists (System.Interrupt_Priority'Last) 783 784 procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is 785 Loc : constant Source_Ptr := Sloc (N); 786 787 begin 788 if No (Pragma_Argument_Associations (N)) then 789 Set_Pragma_Argument_Associations (N, New_List ( 790 Make_Pragma_Argument_Association (Loc, 791 Expression => 792 Make_Attribute_Reference (Loc, 793 Prefix => 794 New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc), 795 Attribute_Name => Name_Last)))); 796 end if; 797 end Expand_Pragma_Interrupt_Priority; 798 799 -------------------------------- 800 -- Expand_Pragma_Loop_Variant -- 801 -------------------------------- 802 803 -- Pragma Loop_Variant is expanded in the following manner: 804 805 -- Original code 806 807 -- for | while ... loop 808 -- <preceding source statements> 809 -- pragma Loop_Variant 810 -- (Increases => Incr_Expr, 811 -- Decreases => Decr_Expr); 812 -- <succeeding source statements> 813 -- end loop; 814 815 -- Expanded code 816 817 -- Curr_1 : <type of Incr_Expr>; 818 -- Curr_2 : <type of Decr_Expr>; 819 -- Old_1 : <type of Incr_Expr>; 820 -- Old_2 : <type of Decr_Expr>; 821 -- Flag : Boolean := False; 822 823 -- for | while ... loop 824 -- <preceding source statements> 825 826 -- if Flag then 827 -- Old_1 := Curr_1; 828 -- Old_2 := Curr_2; 829 -- end if; 830 831 -- Curr_1 := <Incr_Expr>; 832 -- Curr_2 := <Decr_Expr>; 833 834 -- if Flag then 835 -- if Curr_1 /= Old_1 then 836 -- pragma Assert (Curr_1 > Old_1); 837 -- else 838 -- pragma Assert (Curr_2 < Old_2); 839 -- end if; 840 -- else 841 -- Flag := True; 842 -- end if; 843 844 -- <succeeding source statements> 845 -- end loop; 846 847 procedure Expand_Pragma_Loop_Variant (N : Node_Id) is 848 Loc : constant Source_Ptr := Sloc (N); 849 850 Last_Var : constant Node_Id := Last (Pragma_Argument_Associations (N)); 851 852 Curr_Assign : List_Id := No_List; 853 Flag_Id : Entity_Id := Empty; 854 If_Stmt : Node_Id := Empty; 855 Old_Assign : List_Id := No_List; 856 Loop_Scop : Entity_Id; 857 Loop_Stmt : Node_Id; 858 Variant : Node_Id; 859 860 procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean); 861 -- Process a single increasing / decreasing termination variant. Flag 862 -- Is_Last should be set when processing the last variant. 863 864 --------------------- 865 -- Process_Variant -- 866 --------------------- 867 868 procedure Process_Variant (Variant : Node_Id; Is_Last : Boolean) is 869 function Make_Op 870 (Loc : Source_Ptr; 871 Curr_Val : Node_Id; 872 Old_Val : Node_Id) return Node_Id; 873 -- Generate a comparison between Curr_Val and Old_Val depending on 874 -- the change mode (Increases / Decreases) of the variant. 875 876 ------------- 877 -- Make_Op -- 878 ------------- 879 880 function Make_Op 881 (Loc : Source_Ptr; 882 Curr_Val : Node_Id; 883 Old_Val : Node_Id) return Node_Id 884 is 885 begin 886 if Chars (Variant) = Name_Increases then 887 return Make_Op_Gt (Loc, Curr_Val, Old_Val); 888 else pragma Assert (Chars (Variant) = Name_Decreases); 889 return Make_Op_Lt (Loc, Curr_Val, Old_Val); 890 end if; 891 end Make_Op; 892 893 -- Local variables 894 895 Expr : constant Node_Id := Expression (Variant); 896 Expr_Typ : constant Entity_Id := Etype (Expr); 897 Loc : constant Source_Ptr := Sloc (Expr); 898 Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt); 899 Curr_Id : Entity_Id; 900 Old_Id : Entity_Id; 901 Prag : Node_Id; 902 903 -- Start of processing for Process_Variant 904 905 begin 906 -- All temporaries generated in this routine must be inserted before 907 -- the related loop statement. Ensure that the proper scope is on the 908 -- stack when analyzing the temporaries. Note that we also use the 909 -- Sloc of the related loop. 910 911 Push_Scope (Scope (Loop_Scop)); 912 913 -- Step 1: Create the declaration of the flag which controls the 914 -- behavior of the assertion on the first iteration of the loop. 915 916 if No (Flag_Id) then 917 918 -- Generate: 919 -- Flag : Boolean := False; 920 921 Flag_Id := Make_Temporary (Loop_Loc, 'F'); 922 923 Insert_Action (Loop_Stmt, 924 Make_Object_Declaration (Loop_Loc, 925 Defining_Identifier => Flag_Id, 926 Object_Definition => 927 New_Reference_To (Standard_Boolean, Loop_Loc), 928 Expression => 929 New_Reference_To (Standard_False, Loop_Loc))); 930 931 -- Prevent an unwanted optimization where the Current_Value of 932 -- the flag eliminates the if statement which stores the variant 933 -- values coming from the previous iteration. 934 935 -- Flag : Boolean := False; 936 -- loop 937 -- if Flag then -- condition rewritten to False 938 -- Old_N := Curr_N; -- and if statement eliminated 939 -- end if; 940 -- . . . 941 -- Flag := True; 942 -- end loop; 943 944 Set_Current_Value (Flag_Id, Empty); 945 end if; 946 947 -- Step 2: Create the temporaries which store the old and current 948 -- values of the associated expression. 949 950 -- Generate: 951 -- Curr : <type of Expr>; 952 953 Curr_Id := Make_Temporary (Loc, 'C'); 954 955 Insert_Action (Loop_Stmt, 956 Make_Object_Declaration (Loop_Loc, 957 Defining_Identifier => Curr_Id, 958 Object_Definition => New_Reference_To (Expr_Typ, Loop_Loc))); 959 960 -- Generate: 961 -- Old : <type of Expr>; 962 963 Old_Id := Make_Temporary (Loc, 'P'); 964 965 Insert_Action (Loop_Stmt, 966 Make_Object_Declaration (Loop_Loc, 967 Defining_Identifier => Old_Id, 968 Object_Definition => New_Reference_To (Expr_Typ, Loop_Loc))); 969 970 -- Restore original scope after all temporaries have been analyzed 971 972 Pop_Scope; 973 974 -- Step 3: Store value of the expression from the previous iteration 975 976 if No (Old_Assign) then 977 Old_Assign := New_List; 978 end if; 979 980 -- Generate: 981 -- Old := Curr; 982 983 Append_To (Old_Assign, 984 Make_Assignment_Statement (Loc, 985 Name => New_Reference_To (Old_Id, Loc), 986 Expression => New_Reference_To (Curr_Id, Loc))); 987 988 -- Step 4: Store the current value of the expression 989 990 if No (Curr_Assign) then 991 Curr_Assign := New_List; 992 end if; 993 994 -- Generate: 995 -- Curr := <Expr>; 996 997 Append_To (Curr_Assign, 998 Make_Assignment_Statement (Loc, 999 Name => New_Reference_To (Curr_Id, Loc), 1000 Expression => Relocate_Node (Expr))); 1001 1002 -- Step 5: Create corresponding assertion to verify change of value 1003 1004 -- Generate: 1005 -- pragma Assert (Curr <|> Old); 1006 1007 Prag := 1008 Make_Pragma (Loc, 1009 Chars => Name_Assert, 1010 Pragma_Argument_Associations => New_List ( 1011 Make_Pragma_Argument_Association (Loc, 1012 Expression => 1013 Make_Op (Loc, 1014 Curr_Val => New_Reference_To (Curr_Id, Loc), 1015 Old_Val => New_Reference_To (Old_Id, Loc))))); 1016 1017 -- Generate: 1018 -- if Curr /= Old then 1019 -- <Prag>; 1020 1021 if No (If_Stmt) then 1022 1023 -- When there is just one termination variant, do not compare the 1024 -- old and current value for equality, just check the pragma. 1025 1026 if Is_Last then 1027 If_Stmt := Prag; 1028 else 1029 If_Stmt := 1030 Make_If_Statement (Loc, 1031 Condition => 1032 Make_Op_Ne (Loc, 1033 Left_Opnd => New_Reference_To (Curr_Id, Loc), 1034 Right_Opnd => New_Reference_To (Old_Id, Loc)), 1035 Then_Statements => New_List (Prag)); 1036 end if; 1037 1038 -- Generate: 1039 -- else 1040 -- <Prag>; 1041 -- end if; 1042 1043 elsif Is_Last then 1044 Set_Else_Statements (If_Stmt, New_List (Prag)); 1045 1046 -- Generate: 1047 -- elsif Curr /= Old then 1048 -- <Prag>; 1049 1050 else 1051 if Elsif_Parts (If_Stmt) = No_List then 1052 Set_Elsif_Parts (If_Stmt, New_List); 1053 end if; 1054 1055 Append_To (Elsif_Parts (If_Stmt), 1056 Make_Elsif_Part (Loc, 1057 Condition => 1058 Make_Op_Ne (Loc, 1059 Left_Opnd => New_Reference_To (Curr_Id, Loc), 1060 Right_Opnd => New_Reference_To (Old_Id, Loc)), 1061 Then_Statements => New_List (Prag))); 1062 end if; 1063 end Process_Variant; 1064 1065 -- Start of processing for Expand_Pragma_Loop_Assertion 1066 1067 begin 1068 -- Locate the enclosing loop for which this assertion applies. In the 1069 -- case of Ada 2012 array iteration, we might be dealing with nested 1070 -- loops. Only the outermost loop has an identifier. 1071 1072 Loop_Stmt := N; 1073 while Present (Loop_Stmt) loop 1074 if Nkind (Loop_Stmt) = N_Loop_Statement 1075 and then Present (Identifier (Loop_Stmt)) 1076 then 1077 exit; 1078 end if; 1079 1080 Loop_Stmt := Parent (Loop_Stmt); 1081 end loop; 1082 1083 Loop_Scop := Entity (Identifier (Loop_Stmt)); 1084 1085 -- Create the circuitry which verifies individual variants 1086 1087 Variant := First (Pragma_Argument_Associations (N)); 1088 while Present (Variant) loop 1089 Process_Variant (Variant, Is_Last => Variant = Last_Var); 1090 1091 Next (Variant); 1092 end loop; 1093 1094 -- Construct the segment which stores the old values of all expressions. 1095 -- Generate: 1096 -- if Flag then 1097 -- <Old_Assign> 1098 -- end if; 1099 1100 Insert_Action (N, 1101 Make_If_Statement (Loc, 1102 Condition => New_Reference_To (Flag_Id, Loc), 1103 Then_Statements => Old_Assign)); 1104 1105 -- Update the values of all expressions 1106 1107 Insert_Actions (N, Curr_Assign); 1108 1109 -- Add the assertion circuitry to test all changes in expressions. 1110 -- Generate: 1111 -- if Flag then 1112 -- <If_Stmt> 1113 -- else 1114 -- Flag := True; 1115 -- end if; 1116 1117 Insert_Action (N, 1118 Make_If_Statement (Loc, 1119 Condition => New_Reference_To (Flag_Id, Loc), 1120 Then_Statements => New_List (If_Stmt), 1121 Else_Statements => New_List ( 1122 Make_Assignment_Statement (Loc, 1123 Name => New_Reference_To (Flag_Id, Loc), 1124 Expression => New_Reference_To (Standard_True, Loc))))); 1125 1126 -- Note: the pragma has been completely transformed into a sequence of 1127 -- corresponding declarations and statements. We leave it in the tree 1128 -- for documentation purposes. It will be ignored by the backend. 1129 1130 end Expand_Pragma_Loop_Variant; 1131 1132 -------------------------------- 1133 -- Expand_Pragma_Psect_Object -- 1134 -------------------------------- 1135 1136 -- Convert to Common_Object, and expand the resulting pragma 1137 1138 procedure Expand_Pragma_Psect_Object (N : Node_Id) 1139 renames Expand_Pragma_Common_Object; 1140 1141 ------------------------------------- 1142 -- Expand_Pragma_Relative_Deadline -- 1143 ------------------------------------- 1144 1145 procedure Expand_Pragma_Relative_Deadline (N : Node_Id) is 1146 P : constant Node_Id := Parent (N); 1147 Loc : constant Source_Ptr := Sloc (N); 1148 1149 begin 1150 -- Expand the pragma only in the case of the main subprogram. For tasks 1151 -- the expansion is done in exp_ch9. Generate a call to Set_Deadline 1152 -- at Clock plus the relative deadline specified in the pragma. Time 1153 -- values are translated into Duration to allow for non-private 1154 -- addition operation. 1155 1156 if Nkind (P) = N_Subprogram_Body then 1157 Rewrite 1158 (N, 1159 Make_Procedure_Call_Statement (Loc, 1160 Name => New_Reference_To (RTE (RE_Set_Deadline), Loc), 1161 Parameter_Associations => New_List ( 1162 Unchecked_Convert_To (RTE (RO_RT_Time), 1163 Make_Op_Add (Loc, 1164 Left_Opnd => 1165 Make_Function_Call (Loc, 1166 New_Reference_To (RTE (RO_RT_To_Duration), Loc), 1167 New_List (Make_Function_Call (Loc, 1168 New_Reference_To (RTE (RE_Clock), Loc)))), 1169 Right_Opnd => 1170 Unchecked_Convert_To (Standard_Duration, Arg1 (N))))))); 1171 1172 Analyze (N); 1173 end if; 1174 end Expand_Pragma_Relative_Deadline; 1175 1176end Exp_Prag; 1177