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