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