1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- R E S T R I C T -- 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 Aspects; use Aspects; 27with Atree; use Atree; 28with Casing; use Casing; 29with Einfo; use Einfo; 30with Errout; use Errout; 31with Debug; use Debug; 32with Fname; use Fname; 33with Fname.UF; use Fname.UF; 34with Lib; use Lib; 35with Opt; use Opt; 36with Sinfo; use Sinfo; 37with Sinput; use Sinput; 38with Snames; use Snames; 39with Stand; use Stand; 40with Uname; use Uname; 41 42package body Restrict is 43 44 ------------------------------- 45 -- SPARK Restriction Control -- 46 ------------------------------- 47 48 -- SPARK HIDE directives allow the effect of the SPARK_05 restriction to be 49 -- turned off for a specified region of code, and the following tables are 50 -- the data structures used to keep track of these regions. 51 52 -- The table contains pairs of source locations, the first being the start 53 -- location for hidden region, and the second being the end location. 54 55 -- Note that the start location is included in the hidden region, while 56 -- the end location is excluded from it. (It typically corresponds to the 57 -- next token during scanning.) 58 59 type SPARK_Hide_Entry is record 60 Start : Source_Ptr; 61 Stop : Source_Ptr; 62 end record; 63 64 package SPARK_Hides is new Table.Table ( 65 Table_Component_Type => SPARK_Hide_Entry, 66 Table_Index_Type => Natural, 67 Table_Low_Bound => 1, 68 Table_Initial => 100, 69 Table_Increment => 200, 70 Table_Name => "SPARK Hides"); 71 72 -------------------------------- 73 -- Package Local Declarations -- 74 -------------------------------- 75 76 Config_Cunit_Boolean_Restrictions : Save_Cunit_Boolean_Restrictions; 77 -- Save compilation unit restrictions set by config pragma files 78 79 Restricted_Profile_Result : Boolean := False; 80 -- This switch memoizes the result of Restricted_Profile function calls for 81 -- improved efficiency. Valid only if Restricted_Profile_Cached is True. 82 -- Note: if this switch is ever set True, it is never turned off again. 83 84 Restricted_Profile_Cached : Boolean := False; 85 -- This flag is set to True if the Restricted_Profile_Result contains the 86 -- correct cached result of Restricted_Profile calls. 87 88 No_Specification_Of_Aspects : array (Aspect_Id) of Source_Ptr := 89 (others => No_Location); 90 -- Entries in this array are set to point to a previously occuring pragma 91 -- that activates a No_Specification_Of_Aspect check. 92 93 No_Specification_Of_Aspect_Warning : array (Aspect_Id) of Boolean := 94 (others => True); 95 -- An entry in this array is set False in reponse to a previous call to 96 -- Set_No_Speficiation_Of_Aspect for pragmas in the main unit that 97 -- specify Warning as False. Once set False, an entry is never reset. 98 99 No_Specification_Of_Aspect_Set : Boolean := False; 100 -- Set True if any entry of No_Specifcation_Of_Aspects has been set True. 101 -- Once set True, this is never turned off again. 102 103 No_Use_Of_Attribute : array (Attribute_Id) of Source_Ptr := 104 (others => No_Location); 105 106 No_Use_Of_Attribute_Warning : array (Attribute_Id) of Boolean := 107 (others => False); 108 109 No_Use_Of_Attribute_Set : Boolean := False; 110 -- Indicates that No_Use_Of_Attribute was set at least once 111 112 No_Use_Of_Pragma : array (Pragma_Id) of Source_Ptr := 113 (others => No_Location); 114 115 No_Use_Of_Pragma_Warning : array (Pragma_Id) of Boolean := 116 (others => False); 117 118 No_Use_Of_Pragma_Set : Boolean := False; 119 -- Indicates that No_Use_Of_Pragma was set at least once 120 121 ----------------------- 122 -- Local Subprograms -- 123 ----------------------- 124 125 procedure Restriction_Msg (R : Restriction_Id; N : Node_Id); 126 -- Called if a violation of restriction R at node N is found. This routine 127 -- outputs the appropriate message or messages taking care of warning vs 128 -- real violation, serious vs non-serious, implicit vs explicit, the second 129 -- message giving the profile name if needed, and the location information. 130 131 function Same_Unit (U1, U2 : Node_Id) return Boolean; 132 -- Returns True iff U1 and U2 represent the same library unit. Used for 133 -- handling of No_Dependence => Unit restriction case. 134 135 function Suppress_Restriction_Message (N : Node_Id) return Boolean; 136 -- N is the node for a possible restriction violation message, but the 137 -- message is to be suppressed if this is an internal file and this file is 138 -- not the main unit. Returns True if message is to be suppressed. 139 140 ------------------- 141 -- Abort_Allowed -- 142 ------------------- 143 144 function Abort_Allowed return Boolean is 145 begin 146 if Restrictions.Set (No_Abort_Statements) 147 and then Restrictions.Set (Max_Asynchronous_Select_Nesting) 148 and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0 149 then 150 return False; 151 else 152 return True; 153 end if; 154 end Abort_Allowed; 155 156 ---------------------------------------- 157 -- Add_To_Config_Boolean_Restrictions -- 158 ---------------------------------------- 159 160 procedure Add_To_Config_Boolean_Restrictions (R : Restriction_Id) is 161 begin 162 Config_Cunit_Boolean_Restrictions (R) := True; 163 end Add_To_Config_Boolean_Restrictions; 164 -- Add specified restriction to stored configuration boolean restrictions. 165 -- This is used for handling the special case of No_Elaboration_Code. 166 167 ------------------------- 168 -- Check_Compiler_Unit -- 169 ------------------------- 170 171 procedure Check_Compiler_Unit (N : Node_Id) is 172 begin 173 if Is_Compiler_Unit (Get_Source_Unit (N)) then 174 Error_Msg_N ("use of construct not allowed in compiler!!??", N); 175 end if; 176 end Check_Compiler_Unit; 177 178 ------------------------------------ 179 -- Check_Elaboration_Code_Allowed -- 180 ------------------------------------ 181 182 procedure Check_Elaboration_Code_Allowed (N : Node_Id) is 183 begin 184 Check_Restriction (No_Elaboration_Code, N); 185 end Check_Elaboration_Code_Allowed; 186 187 -------------------------------- 188 -- Check_No_Implicit_Aliasing -- 189 -------------------------------- 190 191 procedure Check_No_Implicit_Aliasing (Obj : Node_Id) is 192 E : Entity_Id; 193 194 begin 195 -- If restriction not active, nothing to check 196 197 if not Restriction_Active (No_Implicit_Aliasing) then 198 return; 199 end if; 200 201 -- If we have an entity name, check entity 202 203 if Is_Entity_Name (Obj) then 204 E := Entity (Obj); 205 206 -- Restriction applies to entities that are objects 207 208 if Is_Object (E) then 209 if Is_Aliased (E) then 210 return; 211 212 elsif Present (Renamed_Object (E)) then 213 Check_No_Implicit_Aliasing (Renamed_Object (E)); 214 return; 215 end if; 216 217 -- If we don't have an object, then it's OK 218 219 else 220 return; 221 end if; 222 223 -- For selected component, check selector 224 225 elsif Nkind (Obj) = N_Selected_Component then 226 Check_No_Implicit_Aliasing (Selector_Name (Obj)); 227 return; 228 229 -- Indexed component is OK if aliased components 230 231 elsif Nkind (Obj) = N_Indexed_Component then 232 if Has_Aliased_Components (Etype (Prefix (Obj))) 233 or else 234 (Is_Access_Type (Etype (Prefix (Obj))) 235 and then Has_Aliased_Components 236 (Designated_Type (Etype (Prefix (Obj))))) 237 then 238 return; 239 end if; 240 241 -- For type conversion, check converted expression 242 243 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then 244 Check_No_Implicit_Aliasing (Expression (Obj)); 245 return; 246 247 -- Explicit dereference is always OK 248 249 elsif Nkind (Obj) = N_Explicit_Dereference then 250 return; 251 end if; 252 253 -- If we fall through, then we have an aliased view that does not meet 254 -- the rules for being explicitly aliased, so issue restriction msg. 255 256 Check_Restriction (No_Implicit_Aliasing, Obj); 257 end Check_No_Implicit_Aliasing; 258 259 ----------------------------------------- 260 -- Check_Implicit_Dynamic_Code_Allowed -- 261 ----------------------------------------- 262 263 procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id) is 264 begin 265 Check_Restriction (No_Implicit_Dynamic_Code, N); 266 end Check_Implicit_Dynamic_Code_Allowed; 267 268 ---------------------------------- 269 -- Check_No_Implicit_Heap_Alloc -- 270 ---------------------------------- 271 272 procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is 273 begin 274 Check_Restriction (No_Implicit_Heap_Allocations, N); 275 end Check_No_Implicit_Heap_Alloc; 276 277 ------------------------------------------- 278 -- Check_Restriction_No_Use_Of_Attribute -- 279 -------------------------------------------- 280 281 procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id) is 282 Id : constant Name_Id := Chars (N); 283 A_Id : constant Attribute_Id := Get_Attribute_Id (Id); 284 285 begin 286 -- Ignore call if node N is not in the main source unit, since we only 287 -- give messages for the main unit. This avoids giving messages for 288 -- aspects that are specified in withed units. 289 290 if not In_Extended_Main_Source_Unit (N) then 291 return; 292 end if; 293 294 -- If nothing set, nothing to check 295 296 if not No_Use_Of_Attribute_Set then 297 return; 298 end if; 299 300 Error_Msg_Sloc := No_Use_Of_Attribute (A_Id); 301 302 if Error_Msg_Sloc /= No_Location then 303 Error_Msg_Node_1 := N; 304 Error_Msg_Warn := No_Use_Of_Attribute_Warning (A_Id); 305 Error_Msg_N 306 ("<violation of restriction `No_Use_Of_Attribute '='> &`#", N); 307 end if; 308 end Check_Restriction_No_Use_Of_Attribute; 309 310 ---------------------------------------- 311 -- Check_Restriction_No_Use_Of_Pragma -- 312 ---------------------------------------- 313 314 procedure Check_Restriction_No_Use_Of_Pragma (N : Node_Id) is 315 Id : constant Node_Id := Pragma_Identifier (N); 316 P_Id : constant Pragma_Id := Get_Pragma_Id (Chars (Id)); 317 318 begin 319 -- Ignore call if node N is not in the main source unit, since we only 320 -- give messages for the main unit. This avoids giving messages for 321 -- aspects that are specified in withed units. 322 323 if not In_Extended_Main_Source_Unit (N) then 324 return; 325 end if; 326 327 -- If nothing set, nothing to check 328 329 if not No_Use_Of_Pragma_Set then 330 return; 331 end if; 332 333 Error_Msg_Sloc := No_Use_Of_Pragma (P_Id); 334 335 if Error_Msg_Sloc /= No_Location then 336 Error_Msg_Node_1 := Id; 337 Error_Msg_Warn := No_Use_Of_Pragma_Warning (P_Id); 338 Error_Msg_N 339 ("<violation of restriction `No_Use_Of_Pragma '='> &`#", Id); 340 end if; 341 end Check_Restriction_No_Use_Of_Pragma; 342 343 ----------------------------------- 344 -- Check_Obsolescent_2005_Entity -- 345 ----------------------------------- 346 347 procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id) is 348 function Chars_Is (E : Entity_Id; S : String) return Boolean; 349 -- Return True iff Chars (E) matches S (given in lower case) 350 351 -------------- 352 -- Chars_Is -- 353 -------------- 354 355 function Chars_Is (E : Entity_Id; S : String) return Boolean is 356 Nam : constant Name_Id := Chars (E); 357 begin 358 if Length_Of_Name (Nam) /= S'Length then 359 return False; 360 else 361 return Get_Name_String (Nam) = S; 362 end if; 363 end Chars_Is; 364 365 -- Start of processing for Check_Obsolescent_2005_Entity 366 367 begin 368 if Restriction_Check_Required (No_Obsolescent_Features) 369 and then Ada_Version >= Ada_2005 370 and then Chars_Is (Scope (E), "handling") 371 and then Chars_Is (Scope (Scope (E)), "characters") 372 and then Chars_Is (Scope (Scope (Scope (E))), "ada") 373 and then Scope (Scope (Scope (Scope (E)))) = Standard_Standard 374 then 375 if Chars_Is (E, "is_character") or else 376 Chars_Is (E, "is_string") or else 377 Chars_Is (E, "to_character") or else 378 Chars_Is (E, "to_string") or else 379 Chars_Is (E, "to_wide_character") or else 380 Chars_Is (E, "to_wide_string") 381 then 382 Check_Restriction (No_Obsolescent_Features, N); 383 end if; 384 end if; 385 end Check_Obsolescent_2005_Entity; 386 387 --------------------------- 388 -- Check_Restricted_Unit -- 389 --------------------------- 390 391 procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is 392 begin 393 if Suppress_Restriction_Message (N) then 394 return; 395 396 elsif Is_Spec_Name (U) then 397 declare 398 Fnam : constant File_Name_Type := 399 Get_File_Name (U, Subunit => False); 400 401 begin 402 -- Get file name 403 404 Get_Name_String (Fnam); 405 406 -- Nothing to do if name not at least 5 characters long ending 407 -- in .ads or .adb extension, which we strip. 408 409 if Name_Len < 5 410 or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads" 411 and then 412 Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb") 413 then 414 return; 415 end if; 416 417 -- Strip extension and pad to eight characters 418 419 Name_Len := Name_Len - 4; 420 Add_Str_To_Name_Buffer ((Name_Len + 1 .. 8 => ' ')); 421 422 -- If predefined unit, check the list of restricted units 423 424 if Is_Predefined_File_Name (Fnam) then 425 for J in Unit_Array'Range loop 426 if Name_Len = 8 427 and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm 428 then 429 Check_Restriction (Unit_Array (J).Res_Id, N); 430 end if; 431 end loop; 432 433 -- If not predefined unit, then one special check still 434 -- remains. GNAT.Current_Exception is not allowed if we have 435 -- restriction No_Exception_Propagation active. 436 437 else 438 if Name_Buffer (1 .. 8) = "g-curexc" then 439 Check_Restriction (No_Exception_Propagation, N); 440 end if; 441 end if; 442 end; 443 end if; 444 end Check_Restricted_Unit; 445 446 ----------------------- 447 -- Check_Restriction -- 448 ----------------------- 449 450 procedure Check_Restriction 451 (R : Restriction_Id; 452 N : Node_Id; 453 V : Uint := Uint_Minus_1) 454 is 455 Msg_Issued : Boolean; 456 pragma Unreferenced (Msg_Issued); 457 begin 458 Check_Restriction (Msg_Issued, R, N, V); 459 end Check_Restriction; 460 461 procedure Check_Restriction 462 (Msg_Issued : out Boolean; 463 R : Restriction_Id; 464 N : Node_Id; 465 V : Uint := Uint_Minus_1) 466 is 467 VV : Integer; 468 -- V converted to integer form. If V is greater than Integer'Last, 469 -- it is reset to minus 1 (unknown value). 470 471 procedure Update_Restrictions (Info : in out Restrictions_Info); 472 -- Update violation information in Info.Violated and Info.Count 473 474 ------------------------- 475 -- Update_Restrictions -- 476 ------------------------- 477 478 procedure Update_Restrictions (Info : in out Restrictions_Info) is 479 begin 480 -- If not violated, set as violated now 481 482 if not Info.Violated (R) then 483 Info.Violated (R) := True; 484 485 if R in All_Parameter_Restrictions then 486 if VV < 0 then 487 Info.Unknown (R) := True; 488 Info.Count (R) := 1; 489 else 490 Info.Count (R) := VV; 491 end if; 492 end if; 493 494 -- Otherwise if violated already and a parameter restriction, 495 -- update count by maximizing or summing depending on restriction. 496 497 elsif R in All_Parameter_Restrictions then 498 499 -- If new value is unknown, result is unknown 500 501 if VV < 0 then 502 Info.Unknown (R) := True; 503 504 -- If checked by maximization, do maximization 505 506 elsif R in Checked_Max_Parameter_Restrictions then 507 Info.Count (R) := Integer'Max (Info.Count (R), VV); 508 509 -- If checked by adding, do add, checking for overflow 510 511 elsif R in Checked_Add_Parameter_Restrictions then 512 declare 513 pragma Unsuppress (Overflow_Check); 514 begin 515 Info.Count (R) := Info.Count (R) + VV; 516 exception 517 when Constraint_Error => 518 Info.Count (R) := Integer'Last; 519 Info.Unknown (R) := True; 520 end; 521 522 -- Should not be able to come here, known counts should only 523 -- occur for restrictions that are Checked_max or Checked_Sum. 524 525 else 526 raise Program_Error; 527 end if; 528 end if; 529 end Update_Restrictions; 530 531 -- Start of processing for Check_Restriction 532 533 begin 534 Msg_Issued := False; 535 536 -- In CodePeer and SPARK mode, we do not want to check for any 537 -- restriction, or set additional restrictions other than those already 538 -- set in gnat1drv.adb so that we have consistency between each 539 -- compilation. 540 541 -- Just checking, SPARK does not allow restrictions to be set ??? 542 543 if CodePeer_Mode or GNATprove_Mode then 544 return; 545 end if; 546 547 -- In SPARK mode, issue an error for any use of class-wide, even if the 548 -- No_Dispatch restriction is not set. 549 550 if R = No_Dispatch then 551 Check_SPARK_Restriction ("class-wide is not allowed", N); 552 end if; 553 554 if UI_Is_In_Int_Range (V) then 555 VV := Integer (UI_To_Int (V)); 556 else 557 VV := -1; 558 end if; 559 560 -- Count can only be specified in the checked val parameter case 561 562 pragma Assert (VV < 0 or else R in Checked_Val_Parameter_Restrictions); 563 564 -- Nothing to do if value of zero specified for parameter restriction 565 566 if VV = 0 then 567 return; 568 end if; 569 570 -- Update current restrictions 571 572 Update_Restrictions (Restrictions); 573 574 -- If in main extended unit, update main restrictions as well. Note 575 -- that as usual we check for Main_Unit explicitly to deal with the 576 -- case of configuration pragma files. 577 578 if Current_Sem_Unit = Main_Unit 579 or else In_Extended_Main_Source_Unit (N) 580 then 581 Update_Restrictions (Main_Restrictions); 582 end if; 583 584 -- Nothing to do if restriction message suppressed 585 586 if Suppress_Restriction_Message (N) then 587 null; 588 589 -- If restriction not set, nothing to do 590 591 elsif not Restrictions.Set (R) then 592 null; 593 594 -- Don't complain about No_Obsolescent_Features in an instance, since we 595 -- will complain on the template, which is much better. Are there other 596 -- cases like this ??? Do we need a more general mechanism ??? 597 598 elsif R = No_Obsolescent_Features 599 and then Instantiation_Location (Sloc (N)) /= No_Location 600 then 601 null; 602 603 -- Here if restriction set, check for violation (this is a Boolean 604 -- restriction, or a parameter restriction with a value of zero and an 605 -- unknown count, or a parameter restriction with a known value that 606 -- exceeds the restriction count). 607 608 elsif R in All_Boolean_Restrictions 609 or else (Restrictions.Unknown (R) 610 and then Restrictions.Value (R) = 0) 611 or else Restrictions.Count (R) > Restrictions.Value (R) 612 then 613 Msg_Issued := True; 614 Restriction_Msg (R, N); 615 end if; 616 end Check_Restriction; 617 618 ------------------------------------- 619 -- Check_Restriction_No_Dependence -- 620 ------------------------------------- 621 622 procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is 623 DU : Node_Id; 624 625 begin 626 -- Ignore call if node U is not in the main source unit. This avoids 627 -- cascaded errors, e.g. when Ada.Containers units with other units. 628 -- However, allow Standard_Location here, since this catches some cases 629 -- of constructs that get converted to run-time calls. 630 631 if not In_Extended_Main_Source_Unit (U) 632 and then Sloc (U) /= Standard_Location 633 then 634 return; 635 end if; 636 637 -- Loop through entries in No_Dependence table to check each one in turn 638 639 for J in No_Dependences.First .. No_Dependences.Last loop 640 DU := No_Dependences.Table (J).Unit; 641 642 if Same_Unit (U, DU) then 643 Error_Msg_Sloc := Sloc (DU); 644 Error_Msg_Node_1 := DU; 645 646 if No_Dependences.Table (J).Warn then 647 Error_Msg 648 ("??violation of restriction `No_Dependence '='> &`#", 649 Sloc (Err)); 650 else 651 Error_Msg 652 ("|violation of restriction `No_Dependence '='> &`#", 653 Sloc (Err)); 654 end if; 655 656 return; 657 end if; 658 end loop; 659 end Check_Restriction_No_Dependence; 660 661 -------------------------------------------------- 662 -- Check_Restriction_No_Specification_Of_Aspect -- 663 -------------------------------------------------- 664 665 procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id) is 666 A_Id : Aspect_Id; 667 Id : Node_Id; 668 669 begin 670 -- Ignore call if no instances of this restriction set 671 672 if not No_Specification_Of_Aspect_Set then 673 return; 674 end if; 675 676 -- Ignore call if node N is not in the main source unit, since we only 677 -- give messages for the main unit. This avoids giving messages for 678 -- aspects that are specified in withed units. 679 680 if not In_Extended_Main_Source_Unit (N) then 681 return; 682 end if; 683 684 Id := Identifier (N); 685 A_Id := Get_Aspect_Id (Chars (Id)); 686 pragma Assert (A_Id /= No_Aspect); 687 688 Error_Msg_Sloc := No_Specification_Of_Aspects (A_Id); 689 690 if Error_Msg_Sloc /= No_Location then 691 Error_Msg_Node_1 := Id; 692 Error_Msg_Warn := No_Specification_Of_Aspect_Warning (A_Id); 693 Error_Msg_N 694 ("<violation of restriction `No_Specification_Of_Aspect '='> &`#", 695 Id); 696 end if; 697 end Check_Restriction_No_Specification_Of_Aspect; 698 699 -------------------------------------- 700 -- Check_Wide_Character_Restriction -- 701 -------------------------------------- 702 703 procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is 704 begin 705 if Restriction_Check_Required (No_Wide_Characters) 706 and then Comes_From_Source (N) 707 then 708 declare 709 T : constant Entity_Id := Root_Type (E); 710 begin 711 if T = Standard_Wide_Character or else 712 T = Standard_Wide_String or else 713 T = Standard_Wide_Wide_Character or else 714 T = Standard_Wide_Wide_String 715 then 716 Check_Restriction (No_Wide_Characters, N); 717 end if; 718 end; 719 end if; 720 end Check_Wide_Character_Restriction; 721 722 ---------------------------------------- 723 -- Cunit_Boolean_Restrictions_Restore -- 724 ---------------------------------------- 725 726 procedure Cunit_Boolean_Restrictions_Restore 727 (R : Save_Cunit_Boolean_Restrictions) 728 is 729 begin 730 for J in Cunit_Boolean_Restrictions loop 731 Restrictions.Set (J) := R (J); 732 end loop; 733 734 -- If No_Elaboration_Code set in configuration restrictions, and we 735 -- in the main extended source, then set it here now. This is part of 736 -- the special processing for No_Elaboration_Code. 737 738 if In_Extended_Main_Source_Unit (Cunit_Entity (Current_Sem_Unit)) 739 and then Config_Cunit_Boolean_Restrictions (No_Elaboration_Code) 740 then 741 Restrictions.Set (No_Elaboration_Code) := True; 742 end if; 743 end Cunit_Boolean_Restrictions_Restore; 744 745 ------------------------------------- 746 -- Cunit_Boolean_Restrictions_Save -- 747 ------------------------------------- 748 749 function Cunit_Boolean_Restrictions_Save 750 return Save_Cunit_Boolean_Restrictions 751 is 752 R : Save_Cunit_Boolean_Restrictions; 753 754 begin 755 for J in Cunit_Boolean_Restrictions loop 756 R (J) := Restrictions.Set (J); 757 end loop; 758 759 return R; 760 end Cunit_Boolean_Restrictions_Save; 761 762 ------------------------ 763 -- Get_Restriction_Id -- 764 ------------------------ 765 766 function Get_Restriction_Id 767 (N : Name_Id) return Restriction_Id 768 is 769 begin 770 Get_Name_String (N); 771 Set_Casing (All_Upper_Case); 772 773 for J in All_Restrictions loop 774 declare 775 S : constant String := Restriction_Id'Image (J); 776 begin 777 if S = Name_Buffer (1 .. Name_Len) then 778 return J; 779 end if; 780 end; 781 end loop; 782 783 return Not_A_Restriction_Id; 784 end Get_Restriction_Id; 785 786 -------------------------------- 787 -- Is_In_Hidden_Part_In_SPARK -- 788 -------------------------------- 789 790 function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean is 791 begin 792 -- Loop through table of hidden ranges 793 794 for J in SPARK_Hides.First .. SPARK_Hides.Last loop 795 if SPARK_Hides.Table (J).Start <= Loc 796 and then Loc < SPARK_Hides.Table (J).Stop 797 then 798 return True; 799 end if; 800 end loop; 801 802 return False; 803 end Is_In_Hidden_Part_In_SPARK; 804 805 ------------------------------- 806 -- No_Exception_Handlers_Set -- 807 ------------------------------- 808 809 function No_Exception_Handlers_Set return Boolean is 810 begin 811 return (No_Run_Time_Mode or else Configurable_Run_Time_Mode) 812 and then (Restrictions.Set (No_Exception_Handlers) 813 or else 814 Restrictions.Set (No_Exception_Propagation)); 815 end No_Exception_Handlers_Set; 816 817 ------------------------------------- 818 -- No_Exception_Propagation_Active -- 819 ------------------------------------- 820 821 function No_Exception_Propagation_Active return Boolean is 822 begin 823 return (No_Run_Time_Mode 824 or else Configurable_Run_Time_Mode 825 or else Debug_Flag_Dot_G) 826 and then Restriction_Active (No_Exception_Propagation); 827 end No_Exception_Propagation_Active; 828 829 -------------------------------- 830 -- OK_No_Dependence_Unit_Name -- 831 -------------------------------- 832 833 function OK_No_Dependence_Unit_Name (N : Node_Id) return Boolean is 834 begin 835 if Nkind (N) = N_Selected_Component then 836 return 837 OK_No_Dependence_Unit_Name (Prefix (N)) 838 and then 839 OK_No_Dependence_Unit_Name (Selector_Name (N)); 840 841 elsif Nkind (N) = N_Identifier then 842 return True; 843 844 else 845 Error_Msg_N ("wrong form for unit name for No_Dependence", N); 846 return False; 847 end if; 848 end OK_No_Dependence_Unit_Name; 849 850 ---------------------------------- 851 -- Process_Restriction_Synonyms -- 852 ---------------------------------- 853 854 -- Note: body of this function must be coordinated with list of 855 -- renaming declarations in System.Rident. 856 857 function Process_Restriction_Synonyms (N : Node_Id) return Name_Id 858 is 859 Old_Name : constant Name_Id := Chars (N); 860 New_Name : Name_Id; 861 862 begin 863 case Old_Name is 864 when Name_Boolean_Entry_Barriers => 865 New_Name := Name_Simple_Barriers; 866 867 when Name_Max_Entry_Queue_Depth => 868 New_Name := Name_Max_Entry_Queue_Length; 869 870 when Name_No_Dynamic_Interrupts => 871 New_Name := Name_No_Dynamic_Attachment; 872 873 when Name_No_Requeue => 874 New_Name := Name_No_Requeue_Statements; 875 876 when Name_No_Task_Attributes => 877 New_Name := Name_No_Task_Attributes_Package; 878 879 -- SPARK is special in that we unconditionally warn 880 881 when Name_SPARK => 882 Error_Msg_Name_1 := Name_SPARK; 883 Error_Msg_N ("restriction identifier % is obsolescent??", N); 884 Error_Msg_Name_1 := Name_SPARK_05; 885 Error_Msg_N ("|use restriction identifier % instead??", N); 886 return Name_SPARK_05; 887 888 when others => 889 return Old_Name; 890 end case; 891 892 -- Output warning if we are warning on obsolescent features for all 893 -- cases other than SPARK. 894 895 if Warn_On_Obsolescent_Feature then 896 Error_Msg_Name_1 := Old_Name; 897 Error_Msg_N ("restriction identifier % is obsolescent?j?", N); 898 Error_Msg_Name_1 := New_Name; 899 Error_Msg_N ("|use restriction identifier % instead?j?", N); 900 end if; 901 902 return New_Name; 903 end Process_Restriction_Synonyms; 904 905 -------------------------------------- 906 -- Reset_Cunit_Boolean_Restrictions -- 907 -------------------------------------- 908 909 procedure Reset_Cunit_Boolean_Restrictions is 910 begin 911 for J in Cunit_Boolean_Restrictions loop 912 Restrictions.Set (J) := False; 913 end loop; 914 end Reset_Cunit_Boolean_Restrictions; 915 916 ----------------------------------------------- 917 -- Restore_Config_Cunit_Boolean_Restrictions -- 918 ----------------------------------------------- 919 920 procedure Restore_Config_Cunit_Boolean_Restrictions is 921 begin 922 Cunit_Boolean_Restrictions_Restore (Config_Cunit_Boolean_Restrictions); 923 end Restore_Config_Cunit_Boolean_Restrictions; 924 925 ------------------------ 926 -- Restricted_Profile -- 927 ------------------------ 928 929 function Restricted_Profile return Boolean is 930 begin 931 if Restricted_Profile_Cached then 932 return Restricted_Profile_Result; 933 934 else 935 Restricted_Profile_Result := True; 936 Restricted_Profile_Cached := True; 937 938 declare 939 R : Restriction_Flags renames Profile_Info (Restricted).Set; 940 V : Restriction_Values renames Profile_Info (Restricted).Value; 941 begin 942 for J in R'Range loop 943 if R (J) 944 and then (Restrictions.Set (J) = False 945 or else Restriction_Warnings (J) 946 or else 947 (J in All_Parameter_Restrictions 948 and then Restrictions.Value (J) > V (J))) 949 then 950 Restricted_Profile_Result := False; 951 exit; 952 end if; 953 end loop; 954 955 return Restricted_Profile_Result; 956 end; 957 end if; 958 end Restricted_Profile; 959 960 ------------------------ 961 -- Restriction_Active -- 962 ------------------------ 963 964 function Restriction_Active (R : All_Restrictions) return Boolean is 965 begin 966 return Restrictions.Set (R) and then not Restriction_Warnings (R); 967 end Restriction_Active; 968 969 -------------------------------- 970 -- Restriction_Check_Required -- 971 -------------------------------- 972 973 function Restriction_Check_Required (R : All_Restrictions) return Boolean is 974 begin 975 return Restrictions.Set (R); 976 end Restriction_Check_Required; 977 978 --------------------- 979 -- Restriction_Msg -- 980 --------------------- 981 982 procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is 983 Msg : String (1 .. 100); 984 Len : Natural := 0; 985 986 procedure Add_Char (C : Character); 987 -- Append given character to Msg, bumping Len 988 989 procedure Add_Str (S : String); 990 -- Append given string to Msg, bumping Len appropriately 991 992 procedure Id_Case (S : String; Quotes : Boolean := True); 993 -- Given a string S, case it according to current identifier casing, 994 -- except for SPARK_05 (an acronym) which is set all upper case, and 995 -- store in Error_Msg_String. Then append `~` to the message buffer 996 -- to output the string unchanged surrounded in quotes. The quotes 997 -- are suppressed if Quotes = False. 998 999 -------------- 1000 -- Add_Char -- 1001 -------------- 1002 1003 procedure Add_Char (C : Character) is 1004 begin 1005 Len := Len + 1; 1006 Msg (Len) := C; 1007 end Add_Char; 1008 1009 ------------- 1010 -- Add_Str -- 1011 ------------- 1012 1013 procedure Add_Str (S : String) is 1014 begin 1015 Msg (Len + 1 .. Len + S'Length) := S; 1016 Len := Len + S'Length; 1017 end Add_Str; 1018 1019 ------------- 1020 -- Id_Case -- 1021 ------------- 1022 1023 procedure Id_Case (S : String; Quotes : Boolean := True) is 1024 begin 1025 Name_Buffer (1 .. S'Last) := S; 1026 Name_Len := S'Length; 1027 1028 if R = SPARK_05 then 1029 Set_All_Upper_Case; 1030 else 1031 Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N)))); 1032 end if; 1033 1034 Error_Msg_Strlen := Name_Len; 1035 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); 1036 1037 if Quotes then 1038 Add_Str ("`~`"); 1039 else 1040 Add_Char ('~'); 1041 end if; 1042 end Id_Case; 1043 1044 -- Start of processing for Restriction_Msg 1045 1046 begin 1047 -- Set warning message if warning 1048 1049 if Restriction_Warnings (R) then 1050 Add_Str ("??"); 1051 1052 -- If real violation (not warning), then mark it as non-serious unless 1053 -- it is a violation of No_Finalization in which case we leave it as a 1054 -- serious message, since otherwise we get crashes during attempts to 1055 -- expand stuff that is not properly formed due to assumptions made 1056 -- about no finalization being present. 1057 1058 elsif R /= No_Finalization then 1059 Add_Char ('|'); 1060 end if; 1061 1062 Error_Msg_Sloc := Restrictions_Loc (R); 1063 1064 -- Set main message, adding implicit if no source location 1065 1066 if Error_Msg_Sloc > No_Location 1067 or else Error_Msg_Sloc = System_Location 1068 then 1069 Add_Str ("violation of restriction "); 1070 else 1071 Add_Str ("violation of implicit restriction "); 1072 Error_Msg_Sloc := No_Location; 1073 end if; 1074 1075 -- Case of parameterized restriction 1076 1077 if R in All_Parameter_Restrictions then 1078 Add_Char ('`'); 1079 Id_Case (Restriction_Id'Image (R), Quotes => False); 1080 Add_Str (" = ^`"); 1081 Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R))); 1082 1083 -- Case of boolean restriction 1084 1085 else 1086 Id_Case (Restriction_Id'Image (R)); 1087 end if; 1088 1089 -- Case of no secondary profile continuation message 1090 1091 if Restriction_Profile_Name (R) = No_Profile then 1092 if Error_Msg_Sloc /= No_Location then 1093 Add_Char ('#'); 1094 end if; 1095 1096 Add_Char ('!'); 1097 Error_Msg_N (Msg (1 .. Len), N); 1098 1099 -- Case of secondary profile continuation message present 1100 1101 else 1102 Add_Char ('!'); 1103 Error_Msg_N (Msg (1 .. Len), N); 1104 1105 Len := 0; 1106 Add_Char ('\'); 1107 1108 -- Set as warning if warning case 1109 1110 if Restriction_Warnings (R) then 1111 Add_Str ("??"); 1112 end if; 1113 1114 -- Set main message 1115 1116 Add_Str ("from profile "); 1117 Id_Case (Profile_Name'Image (Restriction_Profile_Name (R))); 1118 1119 -- Add location if we have one 1120 1121 if Error_Msg_Sloc /= No_Location then 1122 Add_Char ('#'); 1123 end if; 1124 1125 -- Output unconditional message and we are done 1126 1127 Add_Char ('!'); 1128 Error_Msg_N (Msg (1 .. Len), N); 1129 end if; 1130 end Restriction_Msg; 1131 1132 --------------- 1133 -- Same_Unit -- 1134 --------------- 1135 1136 function Same_Unit (U1, U2 : Node_Id) return Boolean is 1137 begin 1138 if Nkind (U1) = N_Identifier and then Nkind (U2) = N_Identifier then 1139 return Chars (U1) = Chars (U2); 1140 1141 elsif Nkind_In (U1, N_Selected_Component, N_Expanded_Name) 1142 and then 1143 Nkind_In (U2, N_Selected_Component, N_Expanded_Name) 1144 then 1145 return Same_Unit (Prefix (U1), Prefix (U2)) 1146 and then 1147 Same_Unit (Selector_Name (U1), Selector_Name (U2)); 1148 else 1149 return False; 1150 end if; 1151 end Same_Unit; 1152 1153 -------------------------------------------- 1154 -- Save_Config_Cunit_Boolean_Restrictions -- 1155 -------------------------------------------- 1156 1157 procedure Save_Config_Cunit_Boolean_Restrictions is 1158 begin 1159 Config_Cunit_Boolean_Restrictions := Cunit_Boolean_Restrictions_Save; 1160 end Save_Config_Cunit_Boolean_Restrictions; 1161 1162 ------------------------------ 1163 -- Set_Hidden_Part_In_SPARK -- 1164 ------------------------------ 1165 1166 procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr) is 1167 begin 1168 SPARK_Hides.Increment_Last; 1169 SPARK_Hides.Table (SPARK_Hides.Last).Start := Loc1; 1170 SPARK_Hides.Table (SPARK_Hides.Last).Stop := Loc2; 1171 end Set_Hidden_Part_In_SPARK; 1172 1173 ------------------------------ 1174 -- Set_Profile_Restrictions -- 1175 ------------------------------ 1176 1177 procedure Set_Profile_Restrictions 1178 (P : Profile_Name; 1179 N : Node_Id; 1180 Warn : Boolean) 1181 is 1182 R : Restriction_Flags renames Profile_Info (P).Set; 1183 V : Restriction_Values renames Profile_Info (P).Value; 1184 1185 begin 1186 for J in R'Range loop 1187 if R (J) then 1188 declare 1189 Already_Restricted : constant Boolean := Restriction_Active (J); 1190 1191 begin 1192 -- Set the restriction 1193 1194 if J in All_Boolean_Restrictions then 1195 Set_Restriction (J, N); 1196 else 1197 Set_Restriction (J, N, V (J)); 1198 end if; 1199 1200 -- Record that this came from a Profile[_Warnings] restriction 1201 1202 Restriction_Profile_Name (J) := P; 1203 1204 -- Set warning flag, except that we do not set the warning 1205 -- flag if the restriction was already active and this is 1206 -- the warning case. That avoids a warning overriding a real 1207 -- restriction, which should never happen. 1208 1209 if not (Warn and Already_Restricted) then 1210 Restriction_Warnings (J) := Warn; 1211 end if; 1212 end; 1213 end if; 1214 end loop; 1215 end Set_Profile_Restrictions; 1216 1217 --------------------- 1218 -- Set_Restriction -- 1219 --------------------- 1220 1221 -- Case of Boolean restriction 1222 1223 procedure Set_Restriction 1224 (R : All_Boolean_Restrictions; 1225 N : Node_Id) 1226 is 1227 begin 1228 Restrictions.Set (R) := True; 1229 1230 if Restricted_Profile_Cached and Restricted_Profile_Result then 1231 null; 1232 else 1233 Restricted_Profile_Cached := False; 1234 end if; 1235 1236 -- Set location, but preserve location of system restriction for nice 1237 -- error msg with run time name. 1238 1239 if Restrictions_Loc (R) /= System_Location then 1240 Restrictions_Loc (R) := Sloc (N); 1241 end if; 1242 1243 -- Note restriction came from restriction pragma, not profile 1244 1245 Restriction_Profile_Name (R) := No_Profile; 1246 1247 -- Record the restriction if we are in the main unit, or in the extended 1248 -- main unit. The reason that we test separately for Main_Unit is that 1249 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in 1250 -- gnat.adc do not appear to be in the extended main source unit (they 1251 -- probably should do ???) 1252 1253 if Current_Sem_Unit = Main_Unit 1254 or else In_Extended_Main_Source_Unit (N) 1255 then 1256 if not Restriction_Warnings (R) then 1257 Main_Restrictions.Set (R) := True; 1258 end if; 1259 end if; 1260 end Set_Restriction; 1261 1262 -- Case of parameter restriction 1263 1264 procedure Set_Restriction 1265 (R : All_Parameter_Restrictions; 1266 N : Node_Id; 1267 V : Integer) 1268 is 1269 begin 1270 if Restricted_Profile_Cached and Restricted_Profile_Result then 1271 null; 1272 else 1273 Restricted_Profile_Cached := False; 1274 end if; 1275 1276 if Restrictions.Set (R) then 1277 if V < Restrictions.Value (R) then 1278 Restrictions.Value (R) := V; 1279 Restrictions_Loc (R) := Sloc (N); 1280 end if; 1281 1282 else 1283 Restrictions.Set (R) := True; 1284 Restrictions.Value (R) := V; 1285 Restrictions_Loc (R) := Sloc (N); 1286 end if; 1287 1288 -- Record the restriction if we are in the main unit, or in the extended 1289 -- main unit. The reason that we test separately for Main_Unit is that 1290 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in 1291 -- gnat.adc do not appear to be the extended main source unit (they 1292 -- probably should do ???) 1293 1294 if Current_Sem_Unit = Main_Unit 1295 or else In_Extended_Main_Source_Unit (N) 1296 then 1297 if Main_Restrictions.Set (R) then 1298 if V < Main_Restrictions.Value (R) then 1299 Main_Restrictions.Value (R) := V; 1300 end if; 1301 1302 elsif not Restriction_Warnings (R) then 1303 Main_Restrictions.Set (R) := True; 1304 Main_Restrictions.Value (R) := V; 1305 end if; 1306 end if; 1307 1308 -- Note restriction came from restriction pragma, not profile 1309 1310 Restriction_Profile_Name (R) := No_Profile; 1311 end Set_Restriction; 1312 1313 ----------------------------------- 1314 -- Set_Restriction_No_Dependence -- 1315 ----------------------------------- 1316 1317 procedure Set_Restriction_No_Dependence 1318 (Unit : Node_Id; 1319 Warn : Boolean; 1320 Profile : Profile_Name := No_Profile) 1321 is 1322 begin 1323 -- Loop to check for duplicate entry 1324 1325 for J in No_Dependences.First .. No_Dependences.Last loop 1326 1327 -- Case of entry already in table 1328 1329 if Same_Unit (Unit, No_Dependences.Table (J).Unit) then 1330 1331 -- Error has precedence over warning 1332 1333 if not Warn then 1334 No_Dependences.Table (J).Warn := False; 1335 end if; 1336 1337 return; 1338 end if; 1339 end loop; 1340 1341 -- Entry is not currently in table 1342 1343 No_Dependences.Append ((Unit, Warn, Profile)); 1344 end Set_Restriction_No_Dependence; 1345 1346 ------------------------------------------------ 1347 -- Set_Restriction_No_Specification_Of_Aspect -- 1348 ------------------------------------------------ 1349 1350 procedure Set_Restriction_No_Specification_Of_Aspect 1351 (N : Node_Id; 1352 Warning : Boolean) 1353 is 1354 A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N)); 1355 1356 begin 1357 No_Specification_Of_Aspects (A_Id) := Sloc (N); 1358 1359 if Warning = False then 1360 No_Specification_Of_Aspect_Warning (A_Id) := False; 1361 end if; 1362 1363 No_Specification_Of_Aspect_Set := True; 1364 end Set_Restriction_No_Specification_Of_Aspect; 1365 1366 ----------------------------------------- 1367 -- Set_Restriction_No_Use_Of_Attribute -- 1368 ----------------------------------------- 1369 1370 procedure Set_Restriction_No_Use_Of_Attribute 1371 (N : Node_Id; 1372 Warning : Boolean) 1373 is 1374 A_Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); 1375 1376 begin 1377 No_Use_Of_Attribute_Set := True; 1378 No_Use_Of_Attribute (A_Id) := Sloc (N); 1379 1380 if Warning = False then 1381 No_Use_Of_Attribute_Warning (A_Id) := False; 1382 end if; 1383 end Set_Restriction_No_Use_Of_Attribute; 1384 1385 -------------------------------------- 1386 -- Set_Restriction_No_Use_Of_Pragma -- 1387 -------------------------------------- 1388 1389 procedure Set_Restriction_No_Use_Of_Pragma 1390 (N : Node_Id; 1391 Warning : Boolean) 1392 is 1393 A_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N)); 1394 1395 begin 1396 No_Use_Of_Pragma_Set := True; 1397 No_Use_Of_Pragma (A_Id) := Sloc (N); 1398 1399 if Warning = False then 1400 No_Use_Of_Pragma_Warning (A_Id) := False; 1401 end if; 1402 end Set_Restriction_No_Use_Of_Pragma; 1403 1404 ----------------------------- 1405 -- Check_SPARK_Restriction -- 1406 ----------------------------- 1407 1408 procedure Check_SPARK_Restriction 1409 (Msg : String; 1410 N : Node_Id; 1411 Force : Boolean := False) 1412 is 1413 Msg_Issued : Boolean; 1414 Save_Error_Msg_Sloc : Source_Ptr; 1415 Onode : constant Node_Id := Original_Node (N); 1416 1417 begin 1418 -- Output message if Force set 1419 1420 if Force 1421 1422 -- Or if this node comes from source 1423 1424 or else Comes_From_Source (N) 1425 1426 -- Or if this is a range node which rewrites a range attribute and 1427 -- the range attribute comes from source. 1428 1429 or else (Nkind (N) = N_Range 1430 and then Nkind (Onode) = N_Attribute_Reference 1431 and then Attribute_Name (Onode) = Name_Range 1432 and then Comes_From_Source (Onode)) 1433 1434 -- Or this is an expression that does not come from source, which is 1435 -- a rewriting of an expression that does come from source. 1436 1437 or else (Nkind (N) in N_Subexpr and then Comes_From_Source (Onode)) 1438 then 1439 if Restriction_Check_Required (SPARK_05) 1440 and then Is_In_Hidden_Part_In_SPARK (Sloc (N)) 1441 then 1442 return; 1443 end if; 1444 1445 -- Since the call to Restriction_Msg from Check_Restriction may set 1446 -- Error_Msg_Sloc to the location of the pragma restriction, save and 1447 -- restore the previous value of the global variable around the call. 1448 1449 Save_Error_Msg_Sloc := Error_Msg_Sloc; 1450 Check_Restriction (Msg_Issued, SPARK_05, First_Node (N)); 1451 Error_Msg_Sloc := Save_Error_Msg_Sloc; 1452 1453 if Msg_Issued then 1454 Error_Msg_F ("\\| " & Msg, N); 1455 end if; 1456 end if; 1457 end Check_SPARK_Restriction; 1458 1459 procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is 1460 Msg_Issued : Boolean; 1461 Save_Error_Msg_Sloc : Source_Ptr; 1462 1463 begin 1464 pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\'); 1465 1466 if Comes_From_Source (Original_Node (N)) then 1467 if Restriction_Check_Required (SPARK_05) 1468 and then Is_In_Hidden_Part_In_SPARK (Sloc (N)) 1469 then 1470 return; 1471 end if; 1472 1473 -- Since the call to Restriction_Msg from Check_Restriction may set 1474 -- Error_Msg_Sloc to the location of the pragma restriction, save and 1475 -- restore the previous value of the global variable around the call. 1476 1477 Save_Error_Msg_Sloc := Error_Msg_Sloc; 1478 Check_Restriction (Msg_Issued, SPARK_05, First_Node (N)); 1479 Error_Msg_Sloc := Save_Error_Msg_Sloc; 1480 1481 if Msg_Issued then 1482 Error_Msg_F ("\\| " & Msg1, N); 1483 Error_Msg_F (Msg2, N); 1484 end if; 1485 end if; 1486 end Check_SPARK_Restriction; 1487 1488 ---------------------------------- 1489 -- Suppress_Restriction_Message -- 1490 ---------------------------------- 1491 1492 function Suppress_Restriction_Message (N : Node_Id) return Boolean is 1493 begin 1494 -- We only output messages for the extended main source unit 1495 1496 if In_Extended_Main_Source_Unit (N) then 1497 return False; 1498 1499 -- If loaded by rtsfind, then suppress message 1500 1501 elsif Sloc (N) <= No_Location then 1502 return True; 1503 1504 -- Otherwise suppress message if internal file 1505 1506 else 1507 return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N))); 1508 end if; 1509 end Suppress_Restriction_Message; 1510 1511 --------------------- 1512 -- Tasking_Allowed -- 1513 --------------------- 1514 1515 function Tasking_Allowed return Boolean is 1516 begin 1517 return not Restrictions.Set (No_Tasking) 1518 and then (not Restrictions.Set (Max_Tasks) 1519 or else Restrictions.Value (Max_Tasks) > 0); 1520 end Tasking_Allowed; 1521 1522end Restrict; 1523