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