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