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-2020, 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 Errout;   use Errout;
  30 with Debug;    use Debug;
  31 with Fname;    use Fname;
  32 with Fname.UF; use Fname.UF;
  33 with Lib;      use Lib;
  34 with Opt;      use Opt;
  35 with Sinfo;    use Sinfo;
  36 with Sinput;   use Sinput;
  37 with Stand;    use Stand;
  38 with Targparm; use Targparm;
  39 with Uname;    use Uname;
  40
  41 package body Restrict is
  42
  43    Global_Restriction_No_Tasking : Boolean := False;
  44    --  Set to True when No_Tasking is set in the run-time package System
  45    --  or in a configuration pragmas file (for example, gnat.adc).
  46
  47    --------------------------------
  48    -- Package Local Declarations --
  49    --------------------------------
  50
  51    Config_Cunit_Boolean_Restrictions : Save_Cunit_Boolean_Restrictions;
  52    --  Save compilation unit restrictions set by config pragma files
  53
  54    Restricted_Profile_Result : Boolean := False;
  55    --  This switch memoizes the result of Restricted_Profile function calls for
  56    --  improved efficiency. Valid only if Restricted_Profile_Cached is True.
  57    --  Note: if this switch is ever set True, it is never turned off again.
  58
  59    Restricted_Profile_Cached : Boolean := False;
  60    --  This flag is set to True if the Restricted_Profile_Result contains the
  61    --  correct cached result of Restricted_Profile calls.
  62
  63    No_Specification_Of_Aspects : array (Aspect_Id) of Source_Ptr :=
  64                                    (others => No_Location);
  65    --  Entries in this array are set to point to a previously occuring pragma
  66    --  that activates a No_Specification_Of_Aspect check.
  67
  68    No_Specification_Of_Aspect_Warning : array (Aspect_Id) of Boolean :=
  69                                           (others => True);
  70    --  An entry in this array is set False in reponse to a previous call to
  71    --  Set_No_Speficiation_Of_Aspect for pragmas in the main unit that
  72    --  specify Warning as False. Once set False, an entry is never reset.
  73
  74    No_Specification_Of_Aspect_Set : Boolean := False;
  75    --  Set True if any entry of No_Specifcation_Of_Aspects has been set True.
  76    --  Once set True, this is never turned off again.
  77
  78    No_Use_Of_Attribute : array (Attribute_Id) of Source_Ptr :=
  79                            (others => No_Location);
  80
  81    No_Use_Of_Attribute_Warning : array (Attribute_Id) of Boolean :=
  82                                    (others => False);
  83
  84    No_Use_Of_Attribute_Set : Boolean := False;
  85    --  Indicates that No_Use_Of_Attribute was set at least once
  86
  87    No_Use_Of_Pragma : array (Pragma_Id) of Source_Ptr :=
  88                         (others => No_Location);
  89    --  Source location of pragma No_Use_Of_Pragma for given pragma, a value
  90    --  of System_Location indicates occurrence in system.ads.
  91
  92    No_Use_Of_Pragma_Warning : array (Pragma_Id) of Boolean :=
  93                                 (others => False);
  94
  95    No_Use_Of_Pragma_Set : Boolean := False;
  96    --  Indicates that No_Use_Of_Pragma was set at least once
  97
  98    -----------------------
  99    -- Local Subprograms --
 100    -----------------------
 101
 102    procedure Restriction_Msg (R : Restriction_Id; N : Node_Id);
 103    --  Called if a violation of restriction R at node N is found. This routine
 104    --  outputs the appropriate message or messages taking care of warning vs
 105    --  real violation, serious vs non-serious, implicit vs explicit, the second
 106    --  message giving the profile name if needed, and the location information.
 107
 108    function Same_Entity (E1, E2 : Node_Id) return Boolean;
 109    --  Returns True iff E1 and E2 represent the same entity. Used for handling
 110    --  of No_Use_Of_Entity => fully_qualified_ENTITY restriction case.
 111
 112    function Same_Unit (U1, U2 : Node_Id) return Boolean;
 113    --  Returns True iff U1 and U2 represent the same library unit. Used for
 114    --  handling of No_Dependence => Unit restriction case.
 115
 116    function Suppress_Restriction_Message (N : Node_Id) return Boolean;
 117    --  N is the node for a possible restriction violation message, but the
 118    --  message is to be suppressed if this is an internal file and this file is
 119    --  not the main unit. Returns True if message is to be suppressed.
 120
 121    -------------------
 122    -- Abort_Allowed --
 123    -------------------
 124
 125    function Abort_Allowed return Boolean is
 126    begin
 127       if Restrictions.Set (No_Abort_Statements)
 128         and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
 129         and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0
 130       then
 131          return False;
 132       else
 133          return True;
 134       end if;
 135    end Abort_Allowed;
 136
 137    ----------------------------------------
 138    -- Add_To_Config_Boolean_Restrictions --
 139    ----------------------------------------
 140
 141    procedure Add_To_Config_Boolean_Restrictions (R : Restriction_Id) is
 142    begin
 143       Config_Cunit_Boolean_Restrictions (R) := True;
 144    end Add_To_Config_Boolean_Restrictions;
 145    --  Add specified restriction to stored configuration boolean restrictions.
 146    --  This is used for handling the special case of No_Elaboration_Code.
 147
 148    -------------------------
 149    -- Check_Compiler_Unit --
 150    -------------------------
 151
 152    procedure Check_Compiler_Unit (Feature : String; N : Node_Id) is
 153    begin
 154       if Compiler_Unit then
 155          Error_Msg_N (Feature & " not allowed in compiler unit!!??", N);
 156       end if;
 157    end Check_Compiler_Unit;
 158
 159    procedure Check_Compiler_Unit (Feature : String; Loc : Source_Ptr) is
 160    begin
 161       if Compiler_Unit then
 162          Error_Msg (Feature & " not allowed in compiler unit!!??", Loc);
 163       end if;
 164    end Check_Compiler_Unit;
 165
 166    ------------------------------------
 167    -- Check_Elaboration_Code_Allowed --
 168    ------------------------------------
 169
 170    procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
 171    begin
 172       Check_Restriction (No_Elaboration_Code, N);
 173    end Check_Elaboration_Code_Allowed;
 174
 175    -----------------------------------------
 176    -- Check_Implicit_Dynamic_Code_Allowed --
 177    -----------------------------------------
 178
 179    procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id) is
 180    begin
 181       Check_Restriction (No_Implicit_Dynamic_Code, N);
 182    end Check_Implicit_Dynamic_Code_Allowed;
 183
 184    --------------------------------
 185    -- Check_No_Implicit_Aliasing --
 186    --------------------------------
 187
 188    procedure Check_No_Implicit_Aliasing (Obj : Node_Id) is
 189       E : Entity_Id;
 190
 191    begin
 192       --  If restriction not active, nothing to check
 193
 194       if not Restriction_Active (No_Implicit_Aliasing) then
 195          return;
 196       end if;
 197
 198       --  If we have an entity name, check entity
 199
 200       if Is_Entity_Name (Obj) then
 201          E := Entity (Obj);
 202
 203          --  Restriction applies to entities that are objects
 204
 205          if Is_Object (E) then
 206             if Is_Aliased (E) then
 207                return;
 208
 209             elsif Present (Renamed_Object (E)) then
 210                Check_No_Implicit_Aliasing (Renamed_Object (E));
 211                return;
 212             end if;
 213
 214          --  If we don't have an object, then it's OK
 215
 216          else
 217             return;
 218          end if;
 219
 220       --  For selected component, check selector
 221
 222       elsif Nkind (Obj) = N_Selected_Component then
 223          Check_No_Implicit_Aliasing (Selector_Name (Obj));
 224          return;
 225
 226       --  Indexed component is OK if aliased components
 227
 228       elsif Nkind (Obj) = N_Indexed_Component then
 229          if Has_Aliased_Components (Etype (Prefix (Obj)))
 230            or else
 231              (Is_Access_Type (Etype (Prefix (Obj)))
 232                and then Has_Aliased_Components
 233                           (Designated_Type (Etype (Prefix (Obj)))))
 234          then
 235             return;
 236          end if;
 237
 238       --  For type conversion, check converted expression
 239
 240       elsif Nkind (Obj) in N_Unchecked_Type_Conversion | N_Type_Conversion then
 241          Check_No_Implicit_Aliasing (Expression (Obj));
 242          return;
 243
 244       --  Explicit dereference is always OK
 245
 246       elsif Nkind (Obj) = N_Explicit_Dereference then
 247          return;
 248       end if;
 249
 250       --  If we fall through, then we have an aliased view that does not meet
 251       --  the rules for being explicitly aliased, so issue restriction msg.
 252
 253       Check_Restriction (No_Implicit_Aliasing, Obj);
 254    end Check_No_Implicit_Aliasing;
 255
 256    ----------------------------------
 257    -- Check_No_Implicit_Heap_Alloc --
 258    ----------------------------------
 259
 260    procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is
 261    begin
 262       Check_Restriction (No_Implicit_Heap_Allocations, N);
 263    end Check_No_Implicit_Heap_Alloc;
 264
 265    ----------------------------------
 266    -- Check_No_Implicit_Task_Alloc --
 267    ----------------------------------
 268
 269    procedure Check_No_Implicit_Task_Alloc (N : Node_Id) is
 270    begin
 271       Check_Restriction (No_Implicit_Task_Allocations, N);
 272    end Check_No_Implicit_Task_Alloc;
 273
 274    ---------------------------------------
 275    -- Check_No_Implicit_Protected_Alloc --
 276    ---------------------------------------
 277
 278    procedure Check_No_Implicit_Protected_Alloc (N : Node_Id) is
 279    begin
 280       Check_Restriction (No_Implicit_Protected_Object_Allocations, N);
 281    end Check_No_Implicit_Protected_Alloc;
 282
 283    -----------------------------------
 284    -- Check_Obsolescent_2005_Entity --
 285    -----------------------------------
 286
 287    procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id) is
 288       function Chars_Is (E : Entity_Id; S : String) return Boolean;
 289       --  Return True iff Chars (E) matches S (given in lower case)
 290
 291       --------------
 292       -- Chars_Is --
 293       --------------
 294
 295       function Chars_Is (E : Entity_Id; S : String) return Boolean is
 296          Nam : constant Name_Id := Chars (E);
 297       begin
 298          if Length_Of_Name (Nam) /= S'Length then
 299             return False;
 300          else
 301             return Get_Name_String (Nam) = S;
 302          end if;
 303       end Chars_Is;
 304
 305    --  Start of processing for Check_Obsolescent_2005_Entity
 306
 307    begin
 308       if Restriction_Check_Required (No_Obsolescent_Features)
 309         and then Ada_Version >= Ada_2005
 310         and then Chars_Is (Scope (E),                 "handling")
 311         and then Chars_Is (Scope (Scope (E)),         "characters")
 312         and then Chars_Is (Scope (Scope (Scope (E))), "ada")
 313         and then Scope (Scope (Scope (Scope (E)))) = Standard_Standard
 314       then
 315          if Chars_Is (E, "is_character")      or else
 316             Chars_Is (E, "is_string")         or else
 317             Chars_Is (E, "to_character")      or else
 318             Chars_Is (E, "to_string")         or else
 319             Chars_Is (E, "to_wide_character") or else
 320             Chars_Is (E, "to_wide_string")
 321          then
 322             Check_Restriction (No_Obsolescent_Features, N);
 323          end if;
 324       end if;
 325    end Check_Obsolescent_2005_Entity;
 326
 327    ---------------------------
 328    -- Check_Restricted_Unit --
 329    ---------------------------
 330
 331    procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
 332    begin
 333       if Suppress_Restriction_Message (N) then
 334          return;
 335
 336       elsif Is_Spec_Name (U) then
 337          declare
 338             Fnam : constant File_Name_Type :=
 339                      Get_File_Name (U, Subunit => False);
 340
 341          begin
 342             --  Get file name
 343
 344             Get_Name_String (Fnam);
 345
 346             --  Nothing to do if name not at least 5 characters long ending
 347             --  in .ads or .adb extension, which we strip.
 348
 349             if Name_Len < 5
 350               or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads"
 351                          and then
 352                        Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb")
 353             then
 354                return;
 355             end if;
 356
 357             --  Strip extension and pad to eight characters
 358
 359             Name_Len := Name_Len - 4;
 360             Add_Str_To_Name_Buffer ((Name_Len + 1 .. 8 => ' '));
 361
 362             --  If predefined unit, check the list of restricted units
 363
 364             if Is_Predefined_File_Name (Fnam) then
 365                for J in Unit_Array'Range loop
 366                   if Name_Len = 8
 367                     and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
 368                   then
 369                      Check_Restriction (Unit_Array (J).Res_Id, N);
 370                   end if;
 371                end loop;
 372
 373                --  If not predefined unit, then one special check still
 374                --  remains. GNAT.Current_Exception is not allowed if we have
 375                --  restriction No_Exception_Propagation active.
 376
 377             else
 378                if Name_Buffer (1 .. 8) = "g-curexc" then
 379                   Check_Restriction (No_Exception_Propagation, N);
 380                end if;
 381             end if;
 382          end;
 383       end if;
 384    end Check_Restricted_Unit;
 385
 386    -----------------------
 387    -- Check_Restriction --
 388    -----------------------
 389
 390    procedure Check_Restriction
 391      (R : Restriction_Id;
 392       N : Node_Id;
 393       V : Uint := Uint_Minus_1)
 394    is
 395       Msg_Issued : Boolean;
 396       pragma Unreferenced (Msg_Issued);
 397    begin
 398       Check_Restriction (Msg_Issued, R, N, V);
 399    end Check_Restriction;
 400
 401    procedure Check_Restriction
 402      (Msg_Issued : out Boolean;
 403       R          : Restriction_Id;
 404       N          : Node_Id;
 405       V          : Uint := Uint_Minus_1)
 406    is
 407       VV : Integer;
 408       --  V converted to integer form. If V is greater than Integer'Last,
 409       --  it is reset to minus 1 (unknown value).
 410
 411       procedure Update_Restrictions (Info : in out Restrictions_Info);
 412       --  Update violation information in Info.Violated and Info.Count
 413
 414       -------------------------
 415       -- Update_Restrictions --
 416       -------------------------
 417
 418       procedure Update_Restrictions (Info : in out Restrictions_Info) is
 419       begin
 420          --  If not violated, set as violated now
 421
 422          if not Info.Violated (R) then
 423             Info.Violated (R) := True;
 424
 425             if R in All_Parameter_Restrictions then
 426                if VV < 0 then
 427                   Info.Unknown (R) := True;
 428                   Info.Count (R) := 1;
 429
 430                else
 431                   Info.Count (R) := VV;
 432                end if;
 433             end if;
 434
 435          --  Otherwise if violated already and a parameter restriction,
 436          --  update count by maximizing or summing depending on restriction.
 437
 438          elsif R in All_Parameter_Restrictions then
 439
 440             --  If new value is unknown, result is unknown
 441
 442             if VV < 0 then
 443                Info.Unknown (R) := True;
 444
 445             --  If checked by maximization, nothing to do because the
 446             --  check is per-object.
 447
 448             elsif R in Checked_Max_Parameter_Restrictions then
 449                null;
 450
 451             --  If checked by adding, do add, checking for overflow
 452
 453             elsif R in Checked_Add_Parameter_Restrictions then
 454                declare
 455                   pragma Unsuppress (Overflow_Check);
 456                begin
 457                   Info.Count (R) := Info.Count (R) + VV;
 458                exception
 459                   when Constraint_Error =>
 460                      Info.Count (R) := Integer'Last;
 461                      Info.Unknown (R) := True;
 462                end;
 463
 464             --  Should not be able to come here, known counts should only
 465             --  occur for restrictions that are Checked_max or Checked_Sum.
 466
 467             else
 468                raise Program_Error;
 469             end if;
 470          end if;
 471       end Update_Restrictions;
 472
 473    --  Start of processing for Check_Restriction
 474
 475    begin
 476       Msg_Issued := False;
 477
 478       --  In CodePeer mode, we do not want to check for any restriction, or set
 479       --  additional restrictions other than those already set in gnat1drv.adb
 480       --  so that we have consistency between each compilation.
 481
 482       --  In GNATprove mode restrictions are checked, except for
 483       --  No_Initialize_Scalars, which is implicitly set in gnat1drv.adb.
 484
 485       if CodePeer_Mode
 486         or else (GNATprove_Mode and then R = No_Initialize_Scalars)
 487       then
 488          return;
 489       end if;
 490
 491       if UI_Is_In_Int_Range (V) then
 492          VV := Integer (UI_To_Int (V));
 493       else
 494          VV := -1;
 495       end if;
 496
 497       --  Count can only be specified in the checked val parameter case
 498
 499       pragma Assert (VV < 0 or else R in Checked_Val_Parameter_Restrictions);
 500
 501       --  Nothing to do if value of zero specified for parameter restriction
 502
 503       if VV = 0 then
 504          return;
 505       end if;
 506
 507       --  Update current restrictions
 508
 509       Update_Restrictions (Restrictions);
 510
 511       --  If in main extended unit, update main restrictions as well. Note
 512       --  that as usual we check for Main_Unit explicitly to deal with the
 513       --  case of configuration pragma files.
 514
 515       if Current_Sem_Unit = Main_Unit
 516         or else In_Extended_Main_Source_Unit (N)
 517       then
 518          Update_Restrictions (Main_Restrictions);
 519       end if;
 520
 521       --  Nothing to do if restriction message suppressed
 522
 523       if Suppress_Restriction_Message (N) then
 524          null;
 525
 526       --  If restriction not set, nothing to do
 527
 528       elsif not Restrictions.Set (R) then
 529          null;
 530
 531       --  Don't complain about No_Obsolescent_Features in an instance, since we
 532       --  will complain on the template, which is much better. Are there other
 533       --  cases like this ??? Do we need a more general mechanism ???
 534
 535       elsif R = No_Obsolescent_Features
 536         and then Instantiation_Location (Sloc (N)) /= No_Location
 537       then
 538          null;
 539
 540       --  Here if restriction set, check for violation (this is a Boolean
 541       --  restriction, or a parameter restriction with a value of zero and an
 542       --  unknown count, or a parameter restriction with a known value that
 543       --  exceeds the restriction count).
 544
 545       elsif R in All_Boolean_Restrictions
 546         or else (Restrictions.Unknown (R)
 547                    and then Restrictions.Value (R) = 0)
 548         or else Restrictions.Count (R) > Restrictions.Value (R)
 549       then
 550          Msg_Issued := True;
 551          Restriction_Msg (R, N);
 552       end if;
 553
 554       --  For Max_Entries and the like, do not carry forward the violation
 555       --  count because it does not affect later declarations.
 556
 557       if R in Checked_Max_Parameter_Restrictions then
 558          Restrictions.Count (R) := 0;
 559          Restrictions.Violated (R) := False;
 560       end if;
 561    end Check_Restriction;
 562
 563    -------------------------------------
 564    -- Check_Restriction_No_Dependence --
 565    -------------------------------------
 566
 567    procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is
 568       DU : Node_Id;
 569
 570    begin
 571       --  Ignore call if node U is not in the main source unit. This avoids
 572       --  cascaded errors, e.g. when Ada.Containers units with other units.
 573       --  However, allow Standard_Location here, since this catches some cases
 574       --  of constructs that get converted to run-time calls.
 575
 576       if not In_Extended_Main_Source_Unit (U)
 577         and then Sloc (U) /= Standard_Location
 578       then
 579          return;
 580       end if;
 581
 582       --  Loop through entries in No_Dependence table to check each one in turn
 583
 584       for J in No_Dependences.First .. No_Dependences.Last loop
 585          DU := No_Dependences.Table (J).Unit;
 586
 587          if Same_Unit (U, DU) then
 588             Error_Msg_Sloc := Sloc (DU);
 589             Error_Msg_Node_1 := DU;
 590
 591             if No_Dependences.Table (J).Warn then
 592                Error_Msg
 593                  ("?*?violation of restriction `No_Dependence '='> &`#",
 594                   Sloc (Err));
 595             else
 596                Error_Msg
 597                  ("|violation of restriction `No_Dependence '='> &`#",
 598                   Sloc (Err));
 599             end if;
 600
 601             return;
 602          end if;
 603       end loop;
 604    end Check_Restriction_No_Dependence;
 605
 606    --------------------------------------------------
 607    -- Check_Restriction_No_Specification_Of_Aspect --
 608    --------------------------------------------------
 609
 610    procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id) is
 611       A_Id : Aspect_Id;
 612       Id   : Node_Id;
 613
 614    begin
 615       --  Ignore call if no instances of this restriction set
 616
 617       if not No_Specification_Of_Aspect_Set then
 618          return;
 619       end if;
 620
 621       --  Ignore call if node N is not in the main source unit, since we only
 622       --  give messages for the main unit. This avoids giving messages for
 623       --  aspects that are specified in withed units.
 624
 625       if not In_Extended_Main_Source_Unit (N) then
 626          return;
 627       end if;
 628
 629       if Nkind (N) = N_Pragma then
 630          Id := Pragma_Identifier (N);
 631       elsif Nkind (N) = N_Attribute_Definition_Clause then
 632          Id := N;
 633       else
 634          Id := Identifier (N);
 635       end if;
 636
 637       A_Id := Get_Aspect_Id (Chars (Id));
 638       pragma Assert (A_Id /= No_Aspect);
 639
 640       Error_Msg_Sloc := No_Specification_Of_Aspects (A_Id);
 641
 642       if Error_Msg_Sloc /= No_Location then
 643          Error_Msg_Node_1 := Id;
 644          Error_Msg_Warn := No_Specification_Of_Aspect_Warning (A_Id);
 645          Error_Msg_N
 646            ("<*<violation of restriction `No_Specification_Of_Aspect '='> &`#",
 647             Id);
 648       end if;
 649    end Check_Restriction_No_Specification_Of_Aspect;
 650
 651    -------------------------------------------
 652    -- Check_Restriction_No_Use_Of_Attribute --
 653    --------------------------------------------
 654
 655    procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id) is
 656       Attr_Id  : Attribute_Id;
 657       Attr_Nam : Name_Id;
 658
 659    begin
 660       --  Nothing to do if the attribute is not in the main source unit, since
 661       --  we only give messages for the main unit. This avoids giving messages
 662       --  for attributes that are specified in withed units.
 663
 664       if not In_Extended_Main_Source_Unit (N) then
 665          return;
 666
 667       --  Nothing to do if not checking No_Use_Of_Attribute
 668
 669       elsif not No_Use_Of_Attribute_Set then
 670          return;
 671
 672       --  Do not consider internally generated attributes because this leads to
 673       --  bizarre errors.
 674
 675       elsif not Comes_From_Source (N) then
 676          return;
 677       end if;
 678
 679       if Nkind (N) = N_Attribute_Definition_Clause then
 680          Attr_Nam := Chars (N);
 681       else
 682          pragma Assert (Nkind (N) = N_Attribute_Reference);
 683          Attr_Nam := Attribute_Name (N);
 684       end if;
 685
 686       Attr_Id        := Get_Attribute_Id (Attr_Nam);
 687       Error_Msg_Sloc := No_Use_Of_Attribute (Attr_Id);
 688
 689       if Error_Msg_Sloc /= No_Location then
 690          Error_Msg_Name_1 := Attr_Nam;
 691          Error_Msg_Warn   := No_Use_Of_Attribute_Warning (Attr_Id);
 692          Error_Msg_N
 693            ("<*<violation of restriction `No_Use_Of_Attribute '='> %` #", N);
 694       end if;
 695    end Check_Restriction_No_Use_Of_Attribute;
 696
 697    ----------------------------------------
 698    -- Check_Restriction_No_Use_Of_Entity --
 699    ----------------------------------------
 700
 701    procedure Check_Restriction_No_Use_Of_Entity (N : Node_Id) is
 702    begin
 703       --  Error defence (not clearly necessary, but better safe)
 704
 705       if No (Entity (N)) then
 706          return;
 707       end if;
 708
 709       --  If simple name of entity not flagged with Boolean2 flag, then there
 710       --  cannot be a matching entry in the table, so skip the search.
 711
 712       if Get_Name_Table_Boolean2 (Chars (Entity (N))) = False then
 713          return;
 714       end if;
 715
 716       --  Restriction is only recognized within a configuration pragma file,
 717       --  or within a unit of the main extended program. Note: the test for
 718       --  Main_Unit is needed to properly include the case of configuration
 719       --  pragma files.
 720
 721       if Current_Sem_Unit /= Main_Unit
 722         and then not In_Extended_Main_Source_Unit (N)
 723       then
 724          return;
 725       end if;
 726
 727       --  Here we must search the table
 728
 729       for J in No_Use_Of_Entity.First .. No_Use_Of_Entity.Last loop
 730          declare
 731             NE_Ent : NE_Entry renames No_Use_Of_Entity.Table (J);
 732             Ent    : Entity_Id;
 733             Expr   : Node_Id;
 734
 735          begin
 736             Ent  := Entity (N);
 737             Expr := NE_Ent.Entity;
 738             loop
 739                --  Here if at outer level of entity name in reference (handle
 740                --  also the direct use of Text_IO in the pragma). For example:
 741                --  pragma Restrictions (No_Use_Of_Entity => Text_IO.Put);
 742
 743                if Scope (Ent) = Standard_Standard
 744                  or else (Nkind (Expr) = N_Identifier
 745                            and then Chars (Ent) = Name_Text_IO
 746                            and then Chars (Scope (Ent)) = Name_Ada
 747                            and then Scope (Scope (Ent)) = Standard_Standard)
 748                then
 749                   if Nkind (Expr) in N_Identifier | N_Operator_Symbol
 750                     and then Chars (Ent) = Chars (Expr)
 751                   then
 752                      Error_Msg_Node_1 := N;
 753                      Error_Msg_Warn := NE_Ent.Warn;
 754                      Error_Msg_Sloc := Sloc (NE_Ent.Entity);
 755                      Error_Msg_N
 756                        ("<*<reference to & violates restriction "
 757                         & "No_Use_Of_Entity #", N);
 758                      return;
 759
 760                   else
 761                      exit;
 762                   end if;
 763
 764                --  Here if at outer level of entity name in table
 765
 766                elsif Nkind (Expr) in N_Identifier | N_Operator_Symbol then
 767                   exit;
 768
 769                --  Here if neither at the outer level
 770
 771                else
 772                   pragma Assert (Nkind (Expr) = N_Selected_Component);
 773                   exit when Chars (Selector_Name (Expr)) /= Chars (Ent);
 774                end if;
 775
 776                --  Move up a level
 777
 778                loop
 779                   Ent := Scope (Ent);
 780                   exit when not Is_Internal_Name (Chars (Ent));
 781                end loop;
 782
 783                Expr := Prefix (Expr);
 784             end loop;
 785          end;
 786       end loop;
 787    end Check_Restriction_No_Use_Of_Entity;
 788
 789    ----------------------------------------
 790    -- Check_Restriction_No_Use_Of_Pragma --
 791    ----------------------------------------
 792
 793    procedure Check_Restriction_No_Use_Of_Pragma (N : Node_Id) is
 794       Id   : constant Node_Id   := Pragma_Identifier (N);
 795       P_Id : constant Pragma_Id := Get_Pragma_Id (Chars (Id));
 796
 797    begin
 798       --  Nothing to do if the pragma is not in the main source unit, since we
 799       --  only give messages for the main unit. This avoids giving messages for
 800       --  pragmas that are specified in withed units.
 801
 802       if not In_Extended_Main_Source_Unit (N) then
 803          return;
 804
 805       --  Nothing to do if not checking No_Use_Of_Pragma
 806
 807       elsif not No_Use_Of_Pragma_Set then
 808          return;
 809
 810       --  Do not consider internally generated pragmas because this leads to
 811       --  bizarre errors.
 812
 813       elsif not Comes_From_Source (N) then
 814          return;
 815       end if;
 816
 817       Error_Msg_Sloc := No_Use_Of_Pragma (P_Id);
 818
 819       if Error_Msg_Sloc /= No_Location then
 820          Error_Msg_Warn := No_Use_Of_Pragma_Warning (P_Id);
 821          Error_Msg_N
 822            ("<*<violation of restriction `No_Use_Of_Pragma '='> &` #", Id);
 823       end if;
 824    end Check_Restriction_No_Use_Of_Pragma;
 825
 826    --------------------------------------
 827    -- Check_Wide_Character_Restriction --
 828    --------------------------------------
 829
 830    procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is
 831    begin
 832       if Restriction_Check_Required (No_Wide_Characters)
 833         and then Comes_From_Source (N)
 834       then
 835          declare
 836             T : constant Entity_Id := Root_Type (E);
 837          begin
 838             if T = Standard_Wide_Character      or else
 839                T = Standard_Wide_String         or else
 840                T = Standard_Wide_Wide_Character or else
 841                T = Standard_Wide_Wide_String
 842             then
 843                Check_Restriction (No_Wide_Characters, N);
 844             end if;
 845          end;
 846       end if;
 847    end Check_Wide_Character_Restriction;
 848
 849    ----------------------------------------
 850    -- Cunit_Boolean_Restrictions_Restore --
 851    ----------------------------------------
 852
 853    procedure Cunit_Boolean_Restrictions_Restore
 854      (R : Save_Cunit_Boolean_Restrictions)
 855    is
 856    begin
 857       for J in Cunit_Boolean_Restrictions loop
 858          Restrictions.Set (J) := R (J);
 859       end loop;
 860
 861       --  If No_Elaboration_Code set in configuration restrictions, and we
 862       --  in the main extended source, then set it here now. This is part of
 863       --  the special processing for No_Elaboration_Code.
 864
 865       if In_Extended_Main_Source_Unit (Cunit_Entity (Current_Sem_Unit))
 866         and then Config_Cunit_Boolean_Restrictions (No_Elaboration_Code)
 867       then
 868          Restrictions.Set (No_Elaboration_Code) := True;
 869       end if;
 870    end Cunit_Boolean_Restrictions_Restore;
 871
 872    -------------------------------------
 873    -- Cunit_Boolean_Restrictions_Save --
 874    -------------------------------------
 875
 876    function Cunit_Boolean_Restrictions_Save
 877      return Save_Cunit_Boolean_Restrictions
 878    is
 879       R : Save_Cunit_Boolean_Restrictions;
 880
 881    begin
 882       for J in Cunit_Boolean_Restrictions loop
 883          R (J) := Restrictions.Set (J);
 884       end loop;
 885
 886       return R;
 887    end Cunit_Boolean_Restrictions_Save;
 888
 889    ------------------------
 890    -- Get_Restriction_Id --
 891    ------------------------
 892
 893    function Get_Restriction_Id
 894      (N : Name_Id) return Restriction_Id
 895    is
 896    begin
 897       Get_Name_String (N);
 898       Set_Casing (All_Upper_Case);
 899
 900       for J in All_Restrictions loop
 901          declare
 902             S : constant String := Restriction_Id'Image (J);
 903          begin
 904             if S = Name_Buffer (1 .. Name_Len) then
 905                return J;
 906             end if;
 907          end;
 908       end loop;
 909
 910       return Not_A_Restriction_Id;
 911    end Get_Restriction_Id;
 912
 913    -----------------------
 914    -- Global_No_Tasking --
 915    -----------------------
 916
 917    function Global_No_Tasking return Boolean is
 918    begin
 919       return Global_Restriction_No_Tasking
 920         or else Targparm.Restrictions_On_Target.Set (No_Tasking);
 921    end Global_No_Tasking;
 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;