gcc/ada/restrict.adb

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