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-2007, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Casing;   use Casing;
  29 with Errout;   use Errout;
  30 with Fname;    use Fname;
  31 with Fname.UF; use Fname.UF;
  32 with Lib;      use Lib;
  33 with Opt;      use Opt;
  34 with Sinfo;    use Sinfo;
  35 with Sinput;   use Sinput;
  36 with Snames;   use Snames;
  37 with Uname;    use Uname;
  38
  39 package body Restrict is
  40
  41    Restricted_Profile_Result : Boolean := False;
  42    --  This switch memoizes the result of Restricted_Profile function
  43    --  calls for improved efficiency. Its setting is valid only if
  44    --  Restricted_Profile_Cached is True. Note that if this switch
  45    --  is ever set True, it need never be turned off again.
  46
  47    Restricted_Profile_Cached : Boolean := False;
  48    --  This flag is set to True if the Restricted_Profile_Result
  49    --  contains the correct cached result of Restricted_Profile calls.
  50
  51    -----------------------
  52    -- Local Subprograms --
  53    -----------------------
  54
  55    procedure Restriction_Msg (Msg : String; R : String; N : Node_Id);
  56    --  Output error message at node N with given text, replacing the
  57    --  '%' in the message with the name of the restriction given as R,
  58    --  cased according to the current identifier casing. We do not use
  59    --  the normal insertion mechanism, since this requires an entry
  60    --  in the Names table, and this table will be locked if we are
  61    --  generating a message from gigi.
  62
  63    function Same_Unit (U1, U2 : Node_Id) return Boolean;
  64    --  Returns True iff U1 and U2 represent the same library unit. Used for
  65    --  handling of No_Dependence => Unit restriction case.
  66
  67    function Suppress_Restriction_Message (N : Node_Id) return Boolean;
  68    --  N is the node for a possible restriction violation message, but
  69    --  the message is to be suppressed if this is an internal file and
  70    --  this file is not the main unit.
  71
  72    -------------------
  73    -- Abort_Allowed --
  74    -------------------
  75
  76    function Abort_Allowed return Boolean is
  77    begin
  78       if Restrictions.Set (No_Abort_Statements)
  79         and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
  80         and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0
  81       then
  82          return False;
  83       else
  84          return True;
  85       end if;
  86    end Abort_Allowed;
  87
  88    ------------------------------------
  89    -- Check_Elaboration_Code_Allowed --
  90    ------------------------------------
  91
  92    procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
  93    begin
  94       --  Avoid calling Namet.Unlock/Lock except when there is an error.
  95       --  Even in the error case it is a bit dubious, either gigi needs
  96       --  the table locked or it does not! ???
  97
  98       if Restrictions.Set (No_Elaboration_Code)
  99         and then not Suppress_Restriction_Message (N)
 100       then
 101          Namet.Unlock;
 102          Check_Restriction (Restriction_Id'(No_Elaboration_Code), N);
 103          Namet.Lock;
 104       end if;
 105    end Check_Elaboration_Code_Allowed;
 106
 107    ----------------------------------
 108    -- Check_No_Implicit_Heap_Alloc --
 109    ----------------------------------
 110
 111    procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is
 112    begin
 113       Check_Restriction (Restriction_Id'(No_Implicit_Heap_Allocations), N);
 114    end Check_No_Implicit_Heap_Alloc;
 115
 116    ---------------------------
 117    -- Check_Restricted_Unit --
 118    ---------------------------
 119
 120    procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
 121    begin
 122       if Suppress_Restriction_Message (N) then
 123          return;
 124
 125       elsif Is_Spec_Name (U) then
 126          declare
 127             Fnam : constant File_Name_Type :=
 128                      Get_File_Name (U, Subunit => False);
 129
 130          begin
 131             --  Get file name
 132
 133             Get_Name_String (Fnam);
 134
 135             --  Nothing to do if name not at least 5 characters long ending
 136             --  in .ads or .adb extension, which we strip.
 137
 138             if Name_Len < 5
 139               or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads"
 140                          and then
 141                        Name_Buffer (Name_Len - 4 .. Name_Len) /= ".adb")
 142             then
 143                return;
 144             end if;
 145
 146             --  Strip extension and pad to eight characters
 147
 148             Name_Len := Name_Len - 4;
 149             while Name_Len < 8 loop
 150                Name_Len := Name_Len + 1;
 151                Name_Buffer (Name_Len) := ' ';
 152             end loop;
 153
 154             --  If predefined unit, check the list of restricted units
 155
 156             if Is_Predefined_File_Name (Fnam) then
 157                for J in Unit_Array'Range loop
 158                   if Name_Len = 8
 159                     and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
 160                   then
 161                      Check_Restriction (Unit_Array (J).Res_Id, N);
 162                   end if;
 163                end loop;
 164
 165                --  If not predefied unit, then one special check still remains.
 166                --  GNAT.Current_Exception is not allowed if we have restriction
 167                --  No_Exception_Propagation active.
 168
 169             else
 170                if Name_Buffer (1 .. 8) = "g-curexc" then
 171                   Check_Restriction (No_Exception_Propagation, N);
 172                end if;
 173             end if;
 174          end;
 175       end if;
 176    end Check_Restricted_Unit;
 177
 178    -----------------------
 179    -- Check_Restriction --
 180    -----------------------
 181
 182    procedure Check_Restriction
 183      (R : Restriction_Id;
 184       N : Node_Id;
 185       V : Uint := Uint_Minus_1)
 186    is
 187       Rimage : constant String := Restriction_Id'Image (R);
 188
 189       VV : Integer;
 190       --  V converted to integer form. If V is greater than Integer'Last,
 191       --  it is reset to minus 1 (unknown value).
 192
 193       procedure Update_Restrictions (Info : in out Restrictions_Info);
 194       --  Update violation information in Info.Violated and Info.Count
 195
 196       -------------------------
 197       -- Update_Restrictions --
 198       -------------------------
 199
 200       procedure Update_Restrictions (Info : in out Restrictions_Info) is
 201       begin
 202          --  If not violated, set as violated now
 203
 204          if not Info.Violated (R) then
 205             Info.Violated (R) := True;
 206
 207             if R in All_Parameter_Restrictions then
 208                if VV < 0 then
 209                   Info.Unknown (R) := True;
 210                   Info.Count (R) := 1;
 211                else
 212                   Info.Count (R) := VV;
 213                end if;
 214             end if;
 215
 216          --  Otherwise if violated already and a parameter restriction,
 217          --  update count by maximizing or summing depending on restriction.
 218
 219          elsif R in All_Parameter_Restrictions then
 220
 221             --  If new value is unknown, result is unknown
 222
 223             if VV < 0 then
 224                Info.Unknown (R) := True;
 225
 226             --  If checked by maximization, do maximization
 227
 228             elsif R in Checked_Max_Parameter_Restrictions then
 229                Info.Count (R) := Integer'Max (Info.Count (R), VV);
 230
 231             --  If checked by adding, do add, checking for overflow
 232
 233             elsif R in Checked_Add_Parameter_Restrictions then
 234                declare
 235                   pragma Unsuppress (Overflow_Check);
 236                begin
 237                   Info.Count (R) := Info.Count (R) + VV;
 238                exception
 239                   when Constraint_Error =>
 240                      Info.Count (R) := Integer'Last;
 241                      Info.Unknown (R) := True;
 242                end;
 243
 244             --  Should not be able to come here, known counts should only
 245             --  occur for restrictions that are Checked_max or Checked_Sum.
 246
 247             else
 248                raise Program_Error;
 249             end if;
 250          end if;
 251       end Update_Restrictions;
 252
 253    --  Start of processing for Check_Restriction
 254
 255    begin
 256       if UI_Is_In_Int_Range (V) then
 257          VV := Integer (UI_To_Int (V));
 258       else
 259          VV := -1;
 260       end if;
 261
 262       --  Count can only be specified in the checked val parameter case
 263
 264       pragma Assert (VV < 0 or else R in Checked_Val_Parameter_Restrictions);
 265
 266       --  Nothing to do if value of zero specified for parameter restriction
 267
 268       if VV = 0 then
 269          return;
 270       end if;
 271
 272       --  Update current restrictions
 273
 274       Update_Restrictions (Restrictions);
 275
 276       --  If in main extended unit, update main restrictions as well
 277
 278       if Current_Sem_Unit = Main_Unit
 279         or else In_Extended_Main_Source_Unit (N)
 280       then
 281          Update_Restrictions (Main_Restrictions);
 282       end if;
 283
 284       --  Nothing to do if restriction message suppressed
 285
 286       if Suppress_Restriction_Message (N) then
 287          null;
 288
 289       --  If restriction not set, nothing to do
 290
 291       elsif not Restrictions.Set (R) then
 292          null;
 293
 294       --  Here if restriction set, check for violation (either this is a
 295       --  Boolean restriction, or a parameter restriction with a value of
 296       --  zero and an unknown count, or a parameter restriction with a
 297       --  known value that exceeds the restriction count).
 298
 299       elsif R in All_Boolean_Restrictions
 300         or else (Restrictions.Unknown (R)
 301                    and then Restrictions.Value (R) = 0)
 302         or else Restrictions.Count (R) > Restrictions.Value (R)
 303       then
 304          Error_Msg_Sloc := Restrictions_Loc (R);
 305
 306          --  If we have a location for the Restrictions pragma, output it
 307
 308          if Error_Msg_Sloc > No_Location
 309            or else Error_Msg_Sloc = System_Location
 310          then
 311             if Restriction_Warnings (R) then
 312                Restriction_Msg ("|violation of restriction %#?", Rimage, N);
 313             else
 314                Restriction_Msg ("|violation of restriction %#", Rimage, N);
 315             end if;
 316
 317          --  Otherwise we have the case of an implicit restriction
 318          --  (e.g. a restriction implicitly set by another pragma)
 319
 320          else
 321             Restriction_Msg
 322               ("|violation of implicit restriction %", Rimage, N);
 323          end if;
 324       end if;
 325    end Check_Restriction;
 326
 327    -------------------------------------
 328    -- Check_Restriction_No_Dependence --
 329    -------------------------------------
 330
 331    procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is
 332       DU : Node_Id;
 333
 334    begin
 335       for J in No_Dependence.First .. No_Dependence.Last loop
 336          DU := No_Dependence.Table (J).Unit;
 337
 338          if Same_Unit (U, DU) then
 339             Error_Msg_Sloc := Sloc (DU);
 340             Error_Msg_Node_1 := DU;
 341
 342             if No_Dependence.Table (J).Warn then
 343                Error_Msg
 344                  ("?violation of restriction `No_Dependence '='> &`#",
 345                   Sloc (Err));
 346             else
 347                Error_Msg
 348                  ("|violation of restriction `No_Dependence '='> &`#",
 349                   Sloc (Err));
 350             end if;
 351
 352             return;
 353          end if;
 354       end loop;
 355    end Check_Restriction_No_Dependence;
 356
 357    ----------------------------------------
 358    -- Cunit_Boolean_Restrictions_Restore --
 359    ----------------------------------------
 360
 361    procedure Cunit_Boolean_Restrictions_Restore
 362      (R : Save_Cunit_Boolean_Restrictions)
 363    is
 364    begin
 365       for J in Cunit_Boolean_Restrictions loop
 366          Restrictions.Set (J) := R (J);
 367       end loop;
 368    end Cunit_Boolean_Restrictions_Restore;
 369
 370    -------------------------------------
 371    -- Cunit_Boolean_Restrictions_Save --
 372    -------------------------------------
 373
 374    function Cunit_Boolean_Restrictions_Save
 375      return Save_Cunit_Boolean_Restrictions
 376    is
 377       R : Save_Cunit_Boolean_Restrictions;
 378
 379    begin
 380       for J in Cunit_Boolean_Restrictions loop
 381          R (J) := Restrictions.Set (J);
 382          Restrictions.Set (J) := False;
 383       end loop;
 384
 385       return R;
 386    end Cunit_Boolean_Restrictions_Save;
 387
 388    ------------------------
 389    -- Get_Restriction_Id --
 390    ------------------------
 391
 392    function Get_Restriction_Id
 393      (N : Name_Id) return Restriction_Id
 394    is
 395    begin
 396       Get_Name_String (N);
 397       Set_Casing (All_Upper_Case);
 398
 399       for J in All_Restrictions loop
 400          declare
 401             S : constant String := Restriction_Id'Image (J);
 402          begin
 403             if S = Name_Buffer (1 .. Name_Len) then
 404                return J;
 405             end if;
 406          end;
 407       end loop;
 408
 409       return Not_A_Restriction_Id;
 410    end Get_Restriction_Id;
 411
 412    -------------------------------
 413    -- No_Exception_Handlers_Set --
 414    -------------------------------
 415
 416    function No_Exception_Handlers_Set return Boolean is
 417    begin
 418       return (No_Run_Time_Mode or else Configurable_Run_Time_Mode)
 419         and then (Restrictions.Set (No_Exception_Handlers)
 420                     or else
 421                   Restrictions.Set (No_Exception_Propagation));
 422    end No_Exception_Handlers_Set;
 423
 424    ----------------------------------
 425    -- Process_Restriction_Synonyms --
 426    ----------------------------------
 427
 428    --  Note: body of this function must be coordinated with list of
 429    --  renaming declarations in System.Rident.
 430
 431    function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
 432    is
 433       Old_Name : constant Name_Id := Chars (N);
 434       New_Name : Name_Id;
 435
 436    begin
 437       case Old_Name is
 438          when Name_Boolean_Entry_Barriers =>
 439             New_Name := Name_Simple_Barriers;
 440
 441          when Name_Max_Entry_Queue_Depth =>
 442             New_Name := Name_Max_Entry_Queue_Length;
 443
 444          when Name_No_Dynamic_Interrupts =>
 445             New_Name := Name_No_Dynamic_Attachment;
 446
 447          when Name_No_Requeue =>
 448             New_Name := Name_No_Requeue_Statements;
 449
 450          when Name_No_Task_Attributes =>
 451             New_Name := Name_No_Task_Attributes_Package;
 452
 453          when others =>
 454             return Old_Name;
 455       end case;
 456
 457       if Warn_On_Obsolescent_Feature then
 458          Error_Msg_Name_1 := Old_Name;
 459          Error_Msg_N ("restriction identifier % is obsolescent?", N);
 460          Error_Msg_Name_1 := New_Name;
 461          Error_Msg_N ("|use restriction identifier % instead", N);
 462       end if;
 463
 464       return New_Name;
 465    end Process_Restriction_Synonyms;
 466
 467    ------------------------
 468    -- Restricted_Profile --
 469    ------------------------
 470
 471    function Restricted_Profile return Boolean is
 472    begin
 473       if Restricted_Profile_Cached then
 474          return Restricted_Profile_Result;
 475
 476       else
 477          Restricted_Profile_Result := True;
 478          Restricted_Profile_Cached := True;
 479
 480          declare
 481             R : Restriction_Flags  renames Profile_Info (Restricted).Set;
 482             V : Restriction_Values renames Profile_Info (Restricted).Value;
 483          begin
 484             for J in R'Range loop
 485                if R (J)
 486                  and then (Restrictions.Set (J) = False
 487                              or else Restriction_Warnings (J)
 488                              or else
 489                                (J in All_Parameter_Restrictions
 490                                   and then Restrictions.Value (J) > V (J)))
 491                then
 492                   Restricted_Profile_Result := False;
 493                   exit;
 494                end if;
 495             end loop;
 496
 497             return Restricted_Profile_Result;
 498          end;
 499       end if;
 500    end Restricted_Profile;
 501
 502    ------------------------
 503    -- Restriction_Active --
 504    ------------------------
 505
 506    function Restriction_Active (R : All_Restrictions) return Boolean is
 507    begin
 508       return Restrictions.Set (R) and then not Restriction_Warnings (R);
 509    end Restriction_Active;
 510
 511    ---------------------
 512    -- Restriction_Msg --
 513    ---------------------
 514
 515    procedure Restriction_Msg (Msg : String; R : String; N : Node_Id) is
 516       B : String (1 .. Msg'Length + 2 * R'Length + 1);
 517       P : Natural := 1;
 518
 519    begin
 520       Name_Buffer (1 .. R'Last) := R;
 521       Name_Len := R'Length;
 522       Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
 523
 524       P := 0;
 525       for J in Msg'Range loop
 526          if Msg (J) = '%' then
 527             P := P + 1;
 528             B (P) := '`';
 529
 530             --  Put characters of image in message, quoting upper case letters
 531
 532             for J in 1 .. Name_Len loop
 533                if Name_Buffer (J) in 'A' .. 'Z' then
 534                   P := P + 1;
 535                   B (P) := ''';
 536                end if;
 537
 538                P := P + 1;
 539                B (P) := Name_Buffer (J);
 540             end loop;
 541
 542             P := P + 1;
 543             B (P) := '`';
 544
 545          else
 546             P := P + 1;
 547             B (P) := Msg (J);
 548          end if;
 549       end loop;
 550
 551       Error_Msg_N (B (1 .. P), N);
 552    end Restriction_Msg;
 553
 554    ---------------
 555    -- Same_Unit --
 556    ---------------
 557
 558    function Same_Unit (U1, U2 : Node_Id) return Boolean is
 559    begin
 560       if Nkind (U1) = N_Identifier then
 561          return Nkind (U2) = N_Identifier and then Chars (U1) = Chars (U2);
 562
 563       elsif Nkind (U2) = N_Identifier then
 564          return False;
 565
 566       elsif (Nkind (U1) = N_Selected_Component
 567              or else Nkind (U1) = N_Expanded_Name)
 568         and then
 569           (Nkind (U2) = N_Selected_Component
 570            or else Nkind (U2) = N_Expanded_Name)
 571       then
 572          return Same_Unit (Prefix (U1), Prefix (U2))
 573            and then Same_Unit (Selector_Name (U1), Selector_Name (U2));
 574       else
 575          return False;
 576       end if;
 577    end Same_Unit;
 578
 579    ------------------------------
 580    -- Set_Profile_Restrictions --
 581    ------------------------------
 582
 583    procedure Set_Profile_Restrictions
 584      (P    : Profile_Name;
 585       N    : Node_Id;
 586       Warn : Boolean)
 587    is
 588       R : Restriction_Flags  renames Profile_Info (P).Set;
 589       V : Restriction_Values renames Profile_Info (P).Value;
 590
 591    begin
 592       for J in R'Range loop
 593          if R (J) then
 594             declare
 595                Already_Restricted : constant Boolean := Restriction_Active (J);
 596
 597             begin
 598                --  Set the restriction
 599
 600                if J in All_Boolean_Restrictions then
 601                   Set_Restriction (J, N);
 602                else
 603                   Set_Restriction (J, N, V (J));
 604                end if;
 605
 606                --  Set warning flag, except that we do not set the warning
 607                --  flag if the restriction was already active and this is
 608                --  the warning case. That avoids a warning overriding a real
 609                --  restriction, which should never happen.
 610
 611                if not (Warn and Already_Restricted) then
 612                   Restriction_Warnings (J) := Warn;
 613                end if;
 614             end;
 615          end if;
 616       end loop;
 617    end Set_Profile_Restrictions;
 618
 619    ---------------------
 620    -- Set_Restriction --
 621    ---------------------
 622
 623    --  Case of Boolean restriction
 624
 625    procedure Set_Restriction
 626      (R : All_Boolean_Restrictions;
 627       N : Node_Id)
 628    is
 629    begin
 630       --  Restriction No_Elaboration_Code must be enforced on a unit by unit
 631       --  basis. Hence, we avoid setting the restriction when processing an
 632       --  unit which is not the main one being compiled (or its corresponding
 633       --  spec). It can happen, for example, when processing an inlined body
 634       --  (the package containing the inlined subprogram is analyzed,
 635       --  including its pragma Restrictions).
 636
 637       --  This seems like a very nasty kludge??? This is not the only per unit
 638       --  restriction why is this treated specially ???
 639
 640       if R = No_Elaboration_Code
 641         and then Current_Sem_Unit /= Main_Unit
 642         and then Cunit (Current_Sem_Unit) /= Library_Unit (Cunit (Main_Unit))
 643       then
 644          return;
 645       end if;
 646
 647       Restrictions.Set (R) := True;
 648
 649       if Restricted_Profile_Cached and Restricted_Profile_Result then
 650          null;
 651       else
 652          Restricted_Profile_Cached := False;
 653       end if;
 654
 655       --  Set location, but preserve location of system
 656       --  restriction for nice error msg with run time name
 657
 658       if Restrictions_Loc (R) /= System_Location then
 659          Restrictions_Loc (R) := Sloc (N);
 660       end if;
 661
 662       --  Record the restriction if we are in the main unit, or in the extended
 663       --  main unit. The reason that we test separately for Main_Unit is that
 664       --  gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
 665       --  gnat.adc do not appear to be in the extended main source unit (they
 666       --  probably should do ???)
 667
 668       if Current_Sem_Unit = Main_Unit
 669         or else In_Extended_Main_Source_Unit (N)
 670       then
 671          if not Restriction_Warnings (R) then
 672             Main_Restrictions.Set (R) := True;
 673          end if;
 674       end if;
 675    end Set_Restriction;
 676
 677    --  Case of parameter restriction
 678
 679    procedure Set_Restriction
 680      (R : All_Parameter_Restrictions;
 681       N : Node_Id;
 682       V : Integer)
 683    is
 684    begin
 685       if Restricted_Profile_Cached and Restricted_Profile_Result then
 686          null;
 687       else
 688          Restricted_Profile_Cached := False;
 689       end if;
 690
 691       if Restrictions.Set (R) then
 692          if V < Restrictions.Value (R) then
 693             Restrictions.Value (R) := V;
 694             Restrictions_Loc (R) := Sloc (N);
 695          end if;
 696
 697       else
 698          Restrictions.Set (R) := True;
 699          Restrictions.Value (R) := V;
 700          Restrictions_Loc (R) := Sloc (N);
 701       end if;
 702
 703       --  Record the restriction if we are in the main unit,
 704       --  or in the extended main unit. The reason that we
 705       --  test separately for Main_Unit is that gnat.adc is
 706       --  processed with Current_Sem_Unit = Main_Unit, but
 707       --  nodes in gnat.adc do not appear to be the extended
 708       --  main source unit (they probably should do ???)
 709
 710       if Current_Sem_Unit = Main_Unit
 711         or else In_Extended_Main_Source_Unit (N)
 712       then
 713          if Main_Restrictions.Set (R) then
 714             if V < Main_Restrictions.Value (R) then
 715                Main_Restrictions.Value (R) := V;
 716             end if;
 717
 718          elsif not Restriction_Warnings (R) then
 719             Main_Restrictions.Set (R) := True;
 720             Main_Restrictions.Value (R) := V;
 721          end if;
 722       end if;
 723    end Set_Restriction;
 724
 725    -----------------------------------
 726    -- Set_Restriction_No_Dependence --
 727    -----------------------------------
 728
 729    procedure Set_Restriction_No_Dependence
 730      (Unit : Node_Id;
 731       Warn : Boolean)
 732    is
 733    begin
 734       --  Loop to check for duplicate entry
 735
 736       for J in No_Dependence.First .. No_Dependence.Last loop
 737
 738          --  Case of entry already in table
 739
 740          if Same_Unit (Unit, No_Dependence.Table (J).Unit) then
 741
 742             --  Error has precedence over warning
 743
 744             if not Warn then
 745                No_Dependence.Table (J).Warn := False;
 746             end if;
 747
 748             return;
 749          end if;
 750       end loop;
 751
 752       --  Entry is not currently in table
 753
 754       No_Dependence.Append ((Unit, Warn));
 755    end Set_Restriction_No_Dependence;
 756
 757    ----------------------------------
 758    -- Suppress_Restriction_Message --
 759    ----------------------------------
 760
 761    function Suppress_Restriction_Message (N : Node_Id) return Boolean is
 762    begin
 763       --  We only output messages for the extended main source unit
 764
 765       if In_Extended_Main_Source_Unit (N) then
 766          return False;
 767
 768       --  If loaded by rtsfind, then suppress message
 769
 770       elsif Sloc (N) <= No_Location then
 771          return True;
 772
 773       --  Otherwise suppress message if internal file
 774
 775       else
 776          return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
 777       end if;
 778    end Suppress_Restriction_Message;
 779
 780    ---------------------
 781    -- Tasking_Allowed --
 782    ---------------------
 783
 784    function Tasking_Allowed return Boolean is
 785    begin
 786       return not Restrictions.Set (No_Tasking)
 787         and then (not Restrictions.Set (Max_Tasks)
 788                     or else Restrictions.Value (Max_Tasks) > 0);
 789    end Tasking_Allowed;
 790
 791 end Restrict;