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