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