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