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_05_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          Restrictions.Violated (R) := False;
 566       end if;
 567    end Check_Restriction;
 568
 569    -------------------------------------
 570    -- Check_Restriction_No_Dependence --
 571    -------------------------------------
 572
 573    procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is
 574       DU : Node_Id;
 575
 576    begin
 577       --  Ignore call if node U is not in the main source unit. This avoids
 578       --  cascaded errors, e.g. when Ada.Containers units with other units.
 579       --  However, allow Standard_Location here, since this catches some cases
 580       --  of constructs that get converted to run-time calls.
 581
 582       if not In_Extended_Main_Source_Unit (U)
 583         and then Sloc (U) /= Standard_Location
 584       then
 585          return;
 586       end if;
 587
 588       --  Loop through entries in No_Dependence table to check each one in turn
 589
 590       for J in No_Dependences.First .. No_Dependences.Last loop
 591          DU := No_Dependences.Table (J).Unit;
 592
 593          if Same_Unit (U, DU) then
 594             Error_Msg_Sloc := Sloc (DU);
 595             Error_Msg_Node_1 := DU;
 596
 597             if No_Dependences.Table (J).Warn then
 598                Error_Msg
 599                  ("?*?violation of restriction `No_Dependence '='> &`#",
 600                   Sloc (Err));
 601             else
 602                Error_Msg
 603                  ("|violation of restriction `No_Dependence '='> &`#",
 604                   Sloc (Err));
 605             end if;
 606
 607             return;
 608          end if;
 609       end loop;
 610    end Check_Restriction_No_Dependence;
 611
 612    --------------------------------------------------
 613    -- Check_Restriction_No_Specification_Of_Aspect --
 614    --------------------------------------------------
 615
 616    procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id) is
 617       A_Id : Aspect_Id;
 618       Id   : Node_Id;
 619
 620    begin
 621       --  Ignore call if no instances of this restriction set
 622
 623       if not No_Specification_Of_Aspect_Set then
 624          return;
 625       end if;
 626
 627       --  Ignore call if node N is not in the main source unit, since we only
 628       --  give messages for the main unit. This avoids giving messages for
 629       --  aspects that are specified in withed units.
 630
 631       if not In_Extended_Main_Source_Unit (N) then
 632          return;
 633       end if;
 634
 635       Id := Identifier (N);
 636       A_Id := Get_Aspect_Id (Chars (Id));
 637       pragma Assert (A_Id /= No_Aspect);
 638
 639       Error_Msg_Sloc := No_Specification_Of_Aspects (A_Id);
 640
 641       if Error_Msg_Sloc /= No_Location then
 642          Error_Msg_Node_1 := Id;
 643          Error_Msg_Warn := No_Specification_Of_Aspect_Warning (A_Id);
 644          Error_Msg_N
 645            ("<*<violation of restriction `No_Specification_Of_Aspect '='> &`#",
 646             Id);
 647       end if;
 648    end Check_Restriction_No_Specification_Of_Aspect;
 649
 650    -------------------------------------------
 651    -- Check_Restriction_No_Use_Of_Attribute --
 652    --------------------------------------------
 653
 654    procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id) is
 655       Id   : constant Name_Id      := Chars (N);
 656       A_Id : constant Attribute_Id := Get_Attribute_Id (Id);
 657
 658    begin
 659       --  Ignore call if node N is not in the main source unit, since we only
 660       --  give messages for the main unit. This avoids giving messages for
 661       --  aspects that are specified in withed units.
 662
 663       if not In_Extended_Main_Source_Unit (N) then
 664          return;
 665       end if;
 666
 667       --  If nothing set, nothing to check
 668
 669       if not No_Use_Of_Attribute_Set then
 670          return;
 671       end if;
 672
 673       Error_Msg_Sloc := No_Use_Of_Attribute (A_Id);
 674
 675       if Error_Msg_Sloc /= No_Location then
 676          Error_Msg_Node_1 := N;
 677          Error_Msg_Warn := No_Use_Of_Attribute_Warning (A_Id);
 678          Error_Msg_N
 679            ("<*<violation of restriction `No_Use_Of_Attribute '='> &`#", N);
 680       end if;
 681    end Check_Restriction_No_Use_Of_Attribute;
 682
 683    ----------------------------------------
 684    -- Check_Restriction_No_Use_Of_Pragma --
 685    ----------------------------------------
 686
 687    procedure Check_Restriction_No_Use_Of_Pragma (N : Node_Id) is
 688       Id   : constant Node_Id   := Pragma_Identifier (N);
 689       P_Id : constant Pragma_Id := Get_Pragma_Id (Chars (Id));
 690
 691    begin
 692       --  Ignore call if node N is not in the main source unit, since we only
 693       --  give messages for the main unit. This avoids giving messages for
 694       --  aspects that are specified in withed units.
 695
 696       if not In_Extended_Main_Source_Unit (N) then
 697          return;
 698       end if;
 699
 700       --  If nothing set, nothing to check
 701
 702       if not No_Use_Of_Pragma_Set then
 703          return;
 704       end if;
 705
 706       Error_Msg_Sloc := No_Use_Of_Pragma (P_Id);
 707
 708       if Error_Msg_Sloc /= No_Location then
 709          Error_Msg_Node_1 := Id;
 710          Error_Msg_Warn := No_Use_Of_Pragma_Warning (P_Id);
 711          Error_Msg_N
 712            ("<*<violation of restriction `No_Use_Of_Pragma '='> &`#", Id);
 713       end if;
 714    end Check_Restriction_No_Use_Of_Pragma;
 715
 716    --------------------------------------
 717    -- Check_Wide_Character_Restriction --
 718    --------------------------------------
 719
 720    procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is
 721    begin
 722       if Restriction_Check_Required (No_Wide_Characters)
 723         and then Comes_From_Source (N)
 724       then
 725          declare
 726             T : constant Entity_Id := Root_Type (E);
 727          begin
 728             if T = Standard_Wide_Character      or else
 729                T = Standard_Wide_String         or else
 730                T = Standard_Wide_Wide_Character or else
 731                T = Standard_Wide_Wide_String
 732             then
 733                Check_Restriction (No_Wide_Characters, N);
 734             end if;
 735          end;
 736       end if;
 737    end Check_Wide_Character_Restriction;
 738
 739    ----------------------------------------
 740    -- Cunit_Boolean_Restrictions_Restore --
 741    ----------------------------------------
 742
 743    procedure Cunit_Boolean_Restrictions_Restore
 744      (R : Save_Cunit_Boolean_Restrictions)
 745    is
 746    begin
 747       for J in Cunit_Boolean_Restrictions loop
 748          Restrictions.Set (J) := R (J);
 749       end loop;
 750
 751       --  If No_Elaboration_Code set in configuration restrictions, and we
 752       --  in the main extended source, then set it here now. This is part of
 753       --  the special processing for No_Elaboration_Code.
 754
 755       if In_Extended_Main_Source_Unit (Cunit_Entity (Current_Sem_Unit))
 756         and then Config_Cunit_Boolean_Restrictions (No_Elaboration_Code)
 757       then
 758          Restrictions.Set (No_Elaboration_Code) := True;
 759       end if;
 760    end Cunit_Boolean_Restrictions_Restore;
 761
 762    -------------------------------------
 763    -- Cunit_Boolean_Restrictions_Save --
 764    -------------------------------------
 765
 766    function Cunit_Boolean_Restrictions_Save
 767      return Save_Cunit_Boolean_Restrictions
 768    is
 769       R : Save_Cunit_Boolean_Restrictions;
 770
 771    begin
 772       for J in Cunit_Boolean_Restrictions loop
 773          R (J) := Restrictions.Set (J);
 774       end loop;
 775
 776       return R;
 777    end Cunit_Boolean_Restrictions_Save;
 778
 779    ------------------------
 780    -- Get_Restriction_Id --
 781    ------------------------
 782
 783    function Get_Restriction_Id
 784      (N : Name_Id) return Restriction_Id
 785    is
 786    begin
 787       Get_Name_String (N);
 788       Set_Casing (All_Upper_Case);
 789
 790       for J in All_Restrictions loop
 791          declare
 792             S : constant String := Restriction_Id'Image (J);
 793          begin
 794             if S = Name_Buffer (1 .. Name_Len) then
 795                return J;
 796             end if;
 797          end;
 798       end loop;
 799
 800       return Not_A_Restriction_Id;
 801    end Get_Restriction_Id;
 802
 803    --------------------------------
 804    -- Is_In_Hidden_Part_In_SPARK --
 805    --------------------------------
 806
 807    function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean is
 808    begin
 809       --  Loop through table of hidden ranges
 810
 811       for J in SPARK_Hides.First .. SPARK_Hides.Last loop
 812          if SPARK_Hides.Table (J).Start <= Loc
 813            and then Loc < SPARK_Hides.Table (J).Stop
 814          then
 815             return True;
 816          end if;
 817       end loop;
 818
 819       return False;
 820    end Is_In_Hidden_Part_In_SPARK;
 821
 822    -------------------------------
 823    -- No_Exception_Handlers_Set --
 824    -------------------------------
 825
 826    function No_Exception_Handlers_Set return Boolean is
 827    begin
 828       return (No_Run_Time_Mode or else Configurable_Run_Time_Mode)
 829         and then (Restrictions.Set (No_Exception_Handlers)
 830                     or else
 831                   Restrictions.Set (No_Exception_Propagation));
 832    end No_Exception_Handlers_Set;
 833
 834    -------------------------------------
 835    -- No_Exception_Propagation_Active --
 836    -------------------------------------
 837
 838    function No_Exception_Propagation_Active return Boolean is
 839    begin
 840       return (No_Run_Time_Mode
 841                or else Configurable_Run_Time_Mode
 842                or else Debug_Flag_Dot_G)
 843         and then Restriction_Active (No_Exception_Propagation);
 844    end No_Exception_Propagation_Active;
 845
 846    --------------------------------
 847    -- OK_No_Dependence_Unit_Name --
 848    --------------------------------
 849
 850    function OK_No_Dependence_Unit_Name (N : Node_Id) return Boolean is
 851    begin
 852       if Nkind (N) = N_Selected_Component then
 853          return
 854            OK_No_Dependence_Unit_Name (Prefix (N))
 855              and then
 856            OK_No_Dependence_Unit_Name (Selector_Name (N));
 857
 858       elsif Nkind (N) = N_Identifier then
 859          return True;
 860
 861       else
 862          Error_Msg_N ("wrong form for unit name for No_Dependence", N);
 863          return False;
 864       end if;
 865    end OK_No_Dependence_Unit_Name;
 866
 867    ----------------------------------
 868    -- Process_Restriction_Synonyms --
 869    ----------------------------------
 870
 871    --  Note: body of this function must be coordinated with list of renaming
 872    --  declarations in System.Rident.
 873
 874    function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
 875    is
 876       Old_Name : constant Name_Id := Chars (N);
 877       New_Name : Name_Id;
 878
 879    begin
 880       case Old_Name is
 881          when Name_Boolean_Entry_Barriers =>
 882             New_Name := Name_Simple_Barriers;
 883
 884          when Name_Max_Entry_Queue_Depth =>
 885             New_Name := Name_Max_Entry_Queue_Length;
 886
 887          when Name_No_Dynamic_Interrupts =>
 888             New_Name := Name_No_Dynamic_Attachment;
 889
 890          when Name_No_Requeue =>
 891             New_Name := Name_No_Requeue_Statements;
 892
 893          when Name_No_Task_Attributes =>
 894             New_Name := Name_No_Task_Attributes_Package;
 895
 896          --  SPARK is special in that we unconditionally warn
 897
 898          when Name_SPARK =>
 899             Error_Msg_Name_1 := Name_SPARK;
 900             Error_Msg_N ("restriction identifier % is obsolescent??", N);
 901             Error_Msg_Name_1 := Name_SPARK_05;
 902             Error_Msg_N ("|use restriction identifier % instead??", N);
 903             return Name_SPARK_05;
 904
 905          when others =>
 906             return Old_Name;
 907       end case;
 908
 909       --  Output warning if we are warning on obsolescent features for all
 910       --  cases other than SPARK.
 911
 912       if Warn_On_Obsolescent_Feature then
 913          Error_Msg_Name_1 := Old_Name;
 914          Error_Msg_N ("restriction identifier % is obsolescent?j?", N);
 915          Error_Msg_Name_1 := New_Name;
 916          Error_Msg_N ("|use restriction identifier % instead?j?", N);
 917       end if;
 918
 919       return New_Name;
 920    end Process_Restriction_Synonyms;
 921
 922    --------------------------------------
 923    -- Reset_Cunit_Boolean_Restrictions --
 924    --------------------------------------
 925
 926    procedure Reset_Cunit_Boolean_Restrictions is
 927    begin
 928       for J in Cunit_Boolean_Restrictions loop
 929          Restrictions.Set (J) := False;
 930       end loop;
 931    end Reset_Cunit_Boolean_Restrictions;
 932
 933    -----------------------------------------------
 934    -- Restore_Config_Cunit_Boolean_Restrictions --
 935    -----------------------------------------------
 936
 937    procedure Restore_Config_Cunit_Boolean_Restrictions is
 938    begin
 939       Cunit_Boolean_Restrictions_Restore (Config_Cunit_Boolean_Restrictions);
 940    end Restore_Config_Cunit_Boolean_Restrictions;
 941
 942    ------------------------
 943    -- Restricted_Profile --
 944    ------------------------
 945
 946    function Restricted_Profile return Boolean is
 947    begin
 948       if Restricted_Profile_Cached then
 949          return Restricted_Profile_Result;
 950
 951       else
 952          Restricted_Profile_Result := True;
 953          Restricted_Profile_Cached := True;
 954
 955          declare
 956             R : Restriction_Flags  renames Profile_Info (Restricted).Set;
 957             V : Restriction_Values renames Profile_Info (Restricted).Value;
 958          begin
 959             for J in R'Range loop
 960                if R (J)
 961                  and then (Restrictions.Set (J) = False
 962                              or else Restriction_Warnings (J)
 963                              or else
 964                                (J in All_Parameter_Restrictions
 965                                   and then Restrictions.Value (J) > V (J)))
 966                then
 967                   Restricted_Profile_Result := False;
 968                   exit;
 969                end if;
 970             end loop;
 971
 972             return Restricted_Profile_Result;
 973          end;
 974       end if;
 975    end Restricted_Profile;
 976
 977    ------------------------
 978    -- Restriction_Active --
 979    ------------------------
 980
 981    function Restriction_Active (R : All_Restrictions) return Boolean is
 982    begin
 983       return Restrictions.Set (R) and then not Restriction_Warnings (R);
 984    end Restriction_Active;
 985
 986    --------------------------------
 987    -- Restriction_Check_Required --
 988    --------------------------------
 989
 990    function Restriction_Check_Required (R : All_Restrictions) return Boolean is
 991    begin
 992       return Restrictions.Set (R);
 993    end Restriction_Check_Required;
 994
 995    ---------------------
 996    -- Restriction_Msg --
 997    ---------------------
 998
 999    procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is
1000       Msg : String (1 .. 100);
1001       Len : Natural := 0;
1002
1003       procedure Add_Char (C : Character);
1004       --  Append given character to Msg, bumping Len
1005
1006       procedure Add_Str (S : String);
1007       --  Append given string to Msg, bumping Len appropriately
1008
1009       procedure Id_Case (S : String; Quotes : Boolean := True);
1010       --  Given a string S, case it according to current identifier casing,
1011       --  except for SPARK_05 (an acronym) which is set all upper case, and
1012       --  store in Error_Msg_String. Then append `~` to the message buffer
1013       --  to output the string unchanged surrounded in quotes. The quotes
1014       --  are suppressed if Quotes = False.
1015
1016       --------------
1017       -- Add_Char --
1018       --------------
1019
1020       procedure Add_Char (C : Character) is
1021       begin
1022          Len := Len + 1;
1023          Msg (Len) := C;
1024       end Add_Char;
1025
1026       -------------
1027       -- Add_Str --
1028       -------------
1029
1030       procedure Add_Str (S : String) is
1031       begin
1032          Msg (Len + 1 .. Len + S'Length) := S;
1033          Len := Len + S'Length;
1034       end Add_Str;
1035
1036       -------------
1037       -- Id_Case --
1038       -------------
1039
1040       procedure Id_Case (S : String; Quotes : Boolean := True) is
1041       begin
1042          Name_Buffer (1 .. S'Last) := S;
1043          Name_Len := S'Length;
1044
1045          if R = SPARK_05 then
1046             Set_All_Upper_Case;
1047          else
1048             Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
1049          end if;
1050
1051          Error_Msg_Strlen := Name_Len;
1052          Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1053
1054          if Quotes then
1055             Add_Str ("`~`");
1056          else
1057             Add_Char ('~');
1058          end if;
1059       end Id_Case;
1060
1061    --  Start of processing for Restriction_Msg
1062
1063    begin
1064       --  Set warning message if warning
1065
1066       if Restriction_Warnings (R) then
1067          Add_Str ("?*?");
1068
1069       --  If real violation (not warning), then mark it as non-serious unless
1070       --  it is a violation of No_Finalization in which case we leave it as a
1071       --  serious message, since otherwise we get crashes during attempts to
1072       --  expand stuff that is not properly formed due to assumptions made
1073       --  about no finalization being present.
1074
1075       elsif R /= No_Finalization then
1076          Add_Char ('|');
1077       end if;
1078
1079       Error_Msg_Sloc := Restrictions_Loc (R);
1080
1081       --  Set main message, adding implicit if no source location
1082
1083       if Error_Msg_Sloc > No_Location
1084         or else Error_Msg_Sloc = System_Location
1085       then
1086          Add_Str ("violation of restriction ");
1087       else
1088          Add_Str ("violation of implicit restriction ");
1089          Error_Msg_Sloc := No_Location;
1090       end if;
1091
1092       --  Case of parameterized restriction
1093
1094       if R in All_Parameter_Restrictions then
1095          Add_Char ('`');
1096          Id_Case (Restriction_Id'Image (R), Quotes => False);
1097          Add_Str (" = ^`");
1098          Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R)));
1099
1100       --  Case of boolean restriction
1101
1102       else
1103          Id_Case (Restriction_Id'Image (R));
1104       end if;
1105
1106       --  Case of no secondary profile continuation message
1107
1108       if Restriction_Profile_Name (R) = No_Profile then
1109          if Error_Msg_Sloc /= No_Location then
1110             Add_Char ('#');
1111          end if;
1112
1113          Add_Char ('!');
1114          Error_Msg_N (Msg (1 .. Len), N);
1115
1116       --  Case of secondary profile continuation message present
1117
1118       else
1119          Add_Char ('!');
1120          Error_Msg_N (Msg (1 .. Len), N);
1121
1122          Len := 0;
1123          Add_Char ('\');
1124
1125          --  Set as warning if warning case
1126
1127          if Restriction_Warnings (R) then
1128             Add_Str ("??");
1129          end if;
1130
1131          --  Set main message
1132
1133          Add_Str ("from profile ");
1134          Id_Case (Profile_Name'Image (Restriction_Profile_Name (R)));
1135
1136          --  Add location if we have one
1137
1138          if Error_Msg_Sloc /= No_Location then
1139             Add_Char ('#');
1140          end if;
1141
1142          --  Output unconditional message and we are done
1143
1144          Add_Char ('!');
1145          Error_Msg_N (Msg (1 .. Len), N);
1146       end if;
1147    end Restriction_Msg;
1148
1149    ---------------
1150    -- Same_Unit --
1151    ---------------
1152
1153    function Same_Unit (U1, U2 : Node_Id) return Boolean is
1154    begin
1155       if Nkind (U1) = N_Identifier and then Nkind (U2) = N_Identifier then
1156          return Chars (U1) = Chars (U2);
1157
1158       elsif Nkind_In (U1, N_Selected_Component, N_Expanded_Name)
1159               and then
1160             Nkind_In (U2, N_Selected_Component, N_Expanded_Name)
1161       then
1162          return Same_Unit (Prefix (U1), Prefix (U2))
1163                   and then
1164                 Same_Unit (Selector_Name (U1), Selector_Name (U2));
1165       else
1166          return False;
1167       end if;
1168    end Same_Unit;
1169
1170    --------------------------------------------
1171    -- Save_Config_Cunit_Boolean_Restrictions --
1172    --------------------------------------------
1173
1174    procedure Save_Config_Cunit_Boolean_Restrictions is
1175    begin
1176       Config_Cunit_Boolean_Restrictions := Cunit_Boolean_Restrictions_Save;
1177    end Save_Config_Cunit_Boolean_Restrictions;
1178
1179    ------------------------------
1180    -- Set_Hidden_Part_In_SPARK --
1181    ------------------------------
1182
1183    procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr) is
1184    begin
1185       SPARK_Hides.Increment_Last;
1186       SPARK_Hides.Table (SPARK_Hides.Last).Start := Loc1;
1187       SPARK_Hides.Table (SPARK_Hides.Last).Stop  := Loc2;
1188    end Set_Hidden_Part_In_SPARK;
1189
1190    ------------------------------
1191    -- Set_Profile_Restrictions --
1192    ------------------------------
1193
1194    procedure Set_Profile_Restrictions
1195      (P    : Profile_Name;
1196       N    : Node_Id;
1197       Warn : Boolean)
1198    is
1199       R : Restriction_Flags  renames Profile_Info (P).Set;
1200       V : Restriction_Values renames Profile_Info (P).Value;
1201
1202    begin
1203       for J in R'Range loop
1204          if R (J) then
1205             declare
1206                Already_Restricted : constant Boolean := Restriction_Active (J);
1207
1208             begin
1209                --  Set the restriction
1210
1211                if J in All_Boolean_Restrictions then
1212                   Set_Restriction (J, N);
1213                else
1214                   Set_Restriction (J, N, V (J));
1215                end if;
1216
1217                --  Record that this came from a Profile[_Warnings] restriction
1218
1219                Restriction_Profile_Name (J) := P;
1220
1221                --  Set warning flag, except that we do not set the warning
1222                --  flag if the restriction was already active and this is
1223                --  the warning case. That avoids a warning overriding a real
1224                --  restriction, which should never happen.
1225
1226                if not (Warn and Already_Restricted) then
1227                   Restriction_Warnings (J) := Warn;
1228                end if;
1229             end;
1230          end if;
1231       end loop;
1232    end Set_Profile_Restrictions;
1233
1234    ---------------------
1235    -- Set_Restriction --
1236    ---------------------
1237
1238    --  Case of Boolean restriction
1239
1240    procedure Set_Restriction
1241      (R : All_Boolean_Restrictions;
1242       N : Node_Id)
1243    is
1244    begin
1245       Restrictions.Set (R) := True;
1246
1247       if Restricted_Profile_Cached and Restricted_Profile_Result then
1248          null;
1249       else
1250          Restricted_Profile_Cached := False;
1251       end if;
1252
1253       --  Set location, but preserve location of system restriction for nice
1254       --  error msg with run time name.
1255
1256       if Restrictions_Loc (R) /= System_Location then
1257          Restrictions_Loc (R) := Sloc (N);
1258       end if;
1259
1260       --  Note restriction came from restriction pragma, not profile
1261
1262       Restriction_Profile_Name (R) := No_Profile;
1263
1264       --  Record the restriction if we are in the main unit, or in the extended
1265       --  main unit. The reason that we test separately for Main_Unit is that
1266       --  gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1267       --  gnat.adc do not appear to be in the extended main source unit (they
1268       --  probably should do ???)
1269
1270       if Current_Sem_Unit = Main_Unit
1271         or else In_Extended_Main_Source_Unit (N)
1272       then
1273          if not Restriction_Warnings (R) then
1274             Main_Restrictions.Set (R) := True;
1275          end if;
1276       end if;
1277    end Set_Restriction;
1278
1279    --  Case of parameter restriction
1280
1281    procedure Set_Restriction
1282      (R : All_Parameter_Restrictions;
1283       N : Node_Id;
1284       V : Integer)
1285    is
1286    begin
1287       if Restricted_Profile_Cached and Restricted_Profile_Result then
1288          null;
1289       else
1290          Restricted_Profile_Cached := False;
1291       end if;
1292
1293       if Restrictions.Set (R) then
1294          if V < Restrictions.Value (R) then
1295             Restrictions.Value (R) := V;
1296             Restrictions_Loc (R) := Sloc (N);
1297          end if;
1298
1299       else
1300          Restrictions.Set (R) := True;
1301          Restrictions.Value (R) := V;
1302          Restrictions_Loc (R) := Sloc (N);
1303       end if;
1304
1305       --  Record the restriction if we are in the main unit, or in the extended
1306       --  main unit. The reason that we test separately for Main_Unit is that
1307       --  gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1308       --  gnat.adc do not appear to be the extended main source unit (they
1309       --  probably should do ???)
1310
1311       if Current_Sem_Unit = Main_Unit
1312         or else In_Extended_Main_Source_Unit (N)
1313       then
1314          if Main_Restrictions.Set (R) then
1315             if V < Main_Restrictions.Value (R) then
1316                Main_Restrictions.Value (R) := V;
1317             end if;
1318
1319          elsif not Restriction_Warnings (R) then
1320             Main_Restrictions.Set (R) := True;
1321             Main_Restrictions.Value (R) := V;
1322          end if;
1323       end if;
1324
1325       --  Note restriction came from restriction pragma, not profile
1326
1327       Restriction_Profile_Name (R) := No_Profile;
1328    end Set_Restriction;
1329
1330    -----------------------------------
1331    -- Set_Restriction_No_Dependence --
1332    -----------------------------------
1333
1334    procedure Set_Restriction_No_Dependence
1335      (Unit    : Node_Id;
1336       Warn    : Boolean;
1337       Profile : Profile_Name := No_Profile)
1338    is
1339    begin
1340       --  Loop to check for duplicate entry
1341
1342       for J in No_Dependences.First .. No_Dependences.Last loop
1343
1344          --  Case of entry already in table
1345
1346          if Same_Unit (Unit, No_Dependences.Table (J).Unit) then
1347
1348             --  Error has precedence over warning
1349
1350             if not Warn then
1351                No_Dependences.Table (J).Warn := False;
1352             end if;
1353
1354             return;
1355          end if;
1356       end loop;
1357
1358       --  Entry is not currently in table
1359
1360       No_Dependences.Append ((Unit, Warn, Profile));
1361    end Set_Restriction_No_Dependence;
1362
1363    ------------------------------------------------
1364    -- Set_Restriction_No_Specification_Of_Aspect --
1365    ------------------------------------------------
1366
1367    procedure Set_Restriction_No_Specification_Of_Aspect
1368      (N       : Node_Id;
1369       Warning : Boolean)
1370    is
1371       A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N));
1372
1373    begin
1374       No_Specification_Of_Aspects (A_Id) := Sloc (N);
1375
1376       if Warning = False then
1377          No_Specification_Of_Aspect_Warning (A_Id) := False;
1378       end if;
1379
1380       No_Specification_Of_Aspect_Set := True;
1381    end Set_Restriction_No_Specification_Of_Aspect;
1382
1383    -----------------------------------------
1384    -- Set_Restriction_No_Use_Of_Attribute --
1385    -----------------------------------------
1386
1387    procedure Set_Restriction_No_Use_Of_Attribute
1388      (N       : Node_Id;
1389       Warning : Boolean)
1390    is
1391       A_Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
1392
1393    begin
1394       No_Use_Of_Attribute_Set := True;
1395       No_Use_Of_Attribute (A_Id) := Sloc (N);
1396
1397       if Warning = False then
1398          No_Use_Of_Attribute_Warning (A_Id) := False;
1399       end if;
1400    end Set_Restriction_No_Use_Of_Attribute;
1401
1402    --------------------------------------
1403    -- Set_Restriction_No_Use_Of_Pragma --
1404    --------------------------------------
1405
1406    procedure Set_Restriction_No_Use_Of_Pragma
1407      (N       : Node_Id;
1408       Warning : Boolean)
1409    is
1410       A_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N));
1411
1412    begin
1413       No_Use_Of_Pragma_Set := True;
1414       No_Use_Of_Pragma (A_Id) := Sloc (N);
1415
1416       if Warning = False then
1417          No_Use_Of_Pragma_Warning (A_Id) := False;
1418       end if;
1419    end Set_Restriction_No_Use_Of_Pragma;
1420
1421    --------------------------------
1422    -- Check_SPARK_05_Restriction --
1423    --------------------------------
1424
1425    procedure Check_SPARK_05_Restriction
1426      (Msg   : String;
1427       N     : Node_Id;
1428       Force : Boolean := False)
1429    is
1430       Msg_Issued          : Boolean;
1431       Save_Error_Msg_Sloc : Source_Ptr;
1432       Onode               : constant Node_Id := Original_Node (N);
1433
1434    begin
1435       --  Output message if Force set
1436
1437       if Force
1438
1439         --  Or if this node comes from source
1440
1441         or else Comes_From_Source (N)
1442
1443         --  Or if this is a range node which rewrites a range attribute and
1444         --  the range attribute comes from source.
1445
1446         or else (Nkind (N) = N_Range
1447                   and then Nkind (Onode) = N_Attribute_Reference
1448                   and then Attribute_Name (Onode) = Name_Range
1449                   and then Comes_From_Source (Onode))
1450
1451         --  Or this is an expression that does not come from source, which is
1452         --  a rewriting of an expression that does come from source.
1453
1454         or else (Nkind (N) in N_Subexpr and then Comes_From_Source (Onode))
1455       then
1456          if Restriction_Check_Required (SPARK_05)
1457            and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
1458          then
1459             return;
1460          end if;
1461
1462          --  Since the call to Restriction_Msg from Check_Restriction may set
1463          --  Error_Msg_Sloc to the location of the pragma restriction, save and
1464          --  restore the previous value of the global variable around the call.
1465
1466          Save_Error_Msg_Sloc := Error_Msg_Sloc;
1467          Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
1468          Error_Msg_Sloc := Save_Error_Msg_Sloc;
1469
1470          if Msg_Issued then
1471             Error_Msg_F ("\\| " & Msg, N);
1472          end if;
1473       end if;
1474    end Check_SPARK_05_Restriction;
1475
1476    procedure Check_SPARK_05_Restriction (Msg1, Msg2 : String; N : Node_Id) is
1477       Msg_Issued          : Boolean;
1478       Save_Error_Msg_Sloc : Source_Ptr;
1479
1480    begin
1481       pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\');
1482
1483       if Comes_From_Source (Original_Node (N)) then
1484          if Restriction_Check_Required (SPARK_05)
1485            and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
1486          then
1487             return;
1488          end if;
1489
1490          --  Since the call to Restriction_Msg from Check_Restriction may set
1491          --  Error_Msg_Sloc to the location of the pragma restriction, save and
1492          --  restore the previous value of the global variable around the call.
1493
1494          Save_Error_Msg_Sloc := Error_Msg_Sloc;
1495          Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
1496          Error_Msg_Sloc := Save_Error_Msg_Sloc;
1497
1498          if Msg_Issued then
1499             Error_Msg_F ("\\| " & Msg1, N);
1500             Error_Msg_F (Msg2, N);
1501          end if;
1502       end if;
1503    end Check_SPARK_05_Restriction;
1504
1505    ----------------------------------
1506    -- Suppress_Restriction_Message --
1507    ----------------------------------
1508
1509    function Suppress_Restriction_Message (N : Node_Id) return Boolean is
1510    begin
1511       --  We only output messages for the extended main source unit
1512
1513       if In_Extended_Main_Source_Unit (N) then
1514          return False;
1515
1516       --  If loaded by rtsfind, then suppress message
1517
1518       elsif Sloc (N) <= No_Location then
1519          return True;
1520
1521       --  Otherwise suppress message if internal file
1522
1523       else
1524          return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
1525       end if;
1526    end Suppress_Restriction_Message;
1527
1528    ---------------------
1529    -- Tasking_Allowed --
1530    ---------------------
1531
1532    function Tasking_Allowed return Boolean is
1533    begin
1534       return not Restrictions.Set (No_Tasking)
1535         and then (not Restrictions.Set (Max_Tasks)
1536                    or else Restrictions.Value (Max_Tasks) > 0)
1537         and then not No_Run_Time_Mode;
1538    end Tasking_Allowed;
1539
1540 end Restrict;