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