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