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