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