gcc/ada/restrict.adb

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