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