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