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