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