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-2012, 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       --  Don't complain about No_Obsolescent_Features in an instance, since we
 536       --  will complain on the template, which is much better. Are there other
 537       --  cases like this ??? Do we need a more general mechanism ???
 538
 539       elsif R = No_Obsolescent_Features
 540         and then Instantiation_Location (Sloc (N)) /= No_Location
 541       then
 542          null;
 543
 544       --  Here if restriction set, check for violation (this is a Boolean
 545       --  restriction, or a parameter restriction with a value of zero and an
 546       --  unknown count, or a parameter restriction with a known value that
 547       --  exceeds the restriction count).
 548
 549       elsif R in All_Boolean_Restrictions
 550         or else (Restrictions.Unknown (R)
 551                    and then Restrictions.Value (R) = 0)
 552         or else Restrictions.Count (R) > Restrictions.Value (R)
 553       then
 554          Msg_Issued := True;
 555          Restriction_Msg (R, N);
 556       end if;
 557    end Check_Restriction;
 558
 559    -------------------------------------
 560    -- Check_Restriction_No_Dependence --
 561    -------------------------------------
 562
 563    procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is
 564       DU : Node_Id;
 565
 566    begin
 567       --  Ignore call if node U is not in the main source unit. This avoids
 568       --  cascaded errors, e.g. when Ada.Containers units with other units.
 569
 570       if not In_Extended_Main_Source_Unit (U) then
 571          return;
 572       end if;
 573
 574       --  Loop through entries in No_Dependence table to check each one in turn
 575
 576       for J in No_Dependences.First .. No_Dependences.Last loop
 577          DU := No_Dependences.Table (J).Unit;
 578
 579          if Same_Unit (U, DU) then
 580             Error_Msg_Sloc := Sloc (DU);
 581             Error_Msg_Node_1 := DU;
 582
 583             if No_Dependences.Table (J).Warn then
 584                Error_Msg
 585                  ("?violation of restriction `No_Dependence '='> &`#",
 586                   Sloc (Err));
 587             else
 588                Error_Msg
 589                  ("|violation of restriction `No_Dependence '='> &`#",
 590                   Sloc (Err));
 591             end if;
 592
 593             return;
 594          end if;
 595       end loop;
 596    end Check_Restriction_No_Dependence;
 597
 598    --------------------------------------------------
 599    -- Check_Restriction_No_Specification_Of_Aspect --
 600    --------------------------------------------------
 601
 602    procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id) is
 603       A_Id : Aspect_Id;
 604       Id   : Node_Id;
 605
 606    begin
 607       --  Ignore call if no instances of this restriction set
 608
 609       if not No_Specification_Of_Aspect_Set then
 610          return;
 611       end if;
 612
 613       --  Ignore call if node N is not in the main source unit, since we only
 614       --  give messages for . This avoids giving messages for aspects that are
 615       --  specified in withed units.
 616
 617       if not In_Extended_Main_Source_Unit (N) then
 618          return;
 619       end if;
 620
 621       Id := Identifier (N);
 622       A_Id := Get_Aspect_Id (Chars (Id));
 623       pragma Assert (A_Id /= No_Aspect);
 624
 625       Error_Msg_Sloc := No_Specification_Of_Aspects (A_Id);
 626
 627       if Error_Msg_Sloc /= No_Location then
 628          Error_Msg_Node_1 := Id;
 629          Error_Msg_Warn := No_Specification_Of_Aspect_Warning (A_Id);
 630          Error_Msg_N
 631            ("<violation of restriction `No_Specification_Of_Aspect '='> &`#",
 632             Id);
 633       end if;
 634    end Check_Restriction_No_Specification_Of_Aspect;
 635
 636    --------------------------------------
 637    -- Check_Wide_Character_Restriction --
 638    --------------------------------------
 639
 640    procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is
 641    begin
 642       if Restriction_Check_Required (No_Wide_Characters)
 643         and then Comes_From_Source (N)
 644       then
 645          declare
 646             T : constant Entity_Id := Root_Type (E);
 647          begin
 648             if T = Standard_Wide_Character      or else
 649                T = Standard_Wide_String         or else
 650                T = Standard_Wide_Wide_Character or else
 651                T = Standard_Wide_Wide_String
 652             then
 653                Check_Restriction (No_Wide_Characters, N);
 654             end if;
 655          end;
 656       end if;
 657    end Check_Wide_Character_Restriction;
 658
 659    ----------------------------------------
 660    -- Cunit_Boolean_Restrictions_Restore --
 661    ----------------------------------------
 662
 663    procedure Cunit_Boolean_Restrictions_Restore
 664      (R : Save_Cunit_Boolean_Restrictions)
 665    is
 666    begin
 667       for J in Cunit_Boolean_Restrictions loop
 668          Restrictions.Set (J) := R (J);
 669       end loop;
 670
 671       --  If No_Elaboration_Code set in configuration restrictions, and we
 672       --  in the main extended source, then set it here now. This is part of
 673       --  the special processing for No_Elaboration_Code.
 674
 675       if In_Extended_Main_Source_Unit (Cunit_Entity (Current_Sem_Unit))
 676         and then Config_Cunit_Boolean_Restrictions (No_Elaboration_Code)
 677       then
 678          Restrictions.Set (No_Elaboration_Code) := True;
 679       end if;
 680    end Cunit_Boolean_Restrictions_Restore;
 681
 682    -------------------------------------
 683    -- Cunit_Boolean_Restrictions_Save --
 684    -------------------------------------
 685
 686    function Cunit_Boolean_Restrictions_Save
 687      return Save_Cunit_Boolean_Restrictions
 688    is
 689       R : Save_Cunit_Boolean_Restrictions;
 690
 691    begin
 692       for J in Cunit_Boolean_Restrictions loop
 693          R (J) := Restrictions.Set (J);
 694       end loop;
 695
 696       return R;
 697    end Cunit_Boolean_Restrictions_Save;
 698
 699    ------------------------
 700    -- Get_Restriction_Id --
 701    ------------------------
 702
 703    function Get_Restriction_Id
 704      (N : Name_Id) return Restriction_Id
 705    is
 706    begin
 707       Get_Name_String (N);
 708       Set_Casing (All_Upper_Case);
 709
 710       for J in All_Restrictions loop
 711          declare
 712             S : constant String := Restriction_Id'Image (J);
 713          begin
 714             if S = Name_Buffer (1 .. Name_Len) then
 715                return J;
 716             end if;
 717          end;
 718       end loop;
 719
 720       return Not_A_Restriction_Id;
 721    end Get_Restriction_Id;
 722
 723    --------------------------------
 724    -- Is_In_Hidden_Part_In_SPARK --
 725    --------------------------------
 726
 727    function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean is
 728    begin
 729       --  Loop through table of hidden ranges
 730
 731       for J in SPARK_Hides.First .. SPARK_Hides.Last loop
 732          if SPARK_Hides.Table (J).Start <= Loc
 733            and then Loc < SPARK_Hides.Table (J).Stop
 734          then
 735             return True;
 736          end if;
 737       end loop;
 738
 739       return False;
 740    end Is_In_Hidden_Part_In_SPARK;
 741
 742    -------------------------------
 743    -- No_Exception_Handlers_Set --
 744    -------------------------------
 745
 746    function No_Exception_Handlers_Set return Boolean is
 747    begin
 748       return (No_Run_Time_Mode or else Configurable_Run_Time_Mode)
 749         and then (Restrictions.Set (No_Exception_Handlers)
 750                     or else
 751                   Restrictions.Set (No_Exception_Propagation));
 752    end No_Exception_Handlers_Set;
 753
 754    -------------------------------------
 755    -- No_Exception_Propagation_Active --
 756    -------------------------------------
 757
 758    function No_Exception_Propagation_Active return Boolean is
 759    begin
 760       return (No_Run_Time_Mode
 761                or else Configurable_Run_Time_Mode
 762                or else Debug_Flag_Dot_G)
 763         and then Restriction_Active (No_Exception_Propagation);
 764    end No_Exception_Propagation_Active;
 765
 766    ----------------------------------
 767    -- Process_Restriction_Synonyms --
 768    ----------------------------------
 769
 770    --  Note: body of this function must be coordinated with list of
 771    --  renaming declarations in System.Rident.
 772
 773    function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
 774    is
 775       Old_Name : constant Name_Id := Chars (N);
 776       New_Name : Name_Id;
 777
 778    begin
 779       case Old_Name is
 780          when Name_Boolean_Entry_Barriers =>
 781             New_Name := Name_Simple_Barriers;
 782
 783          when Name_Max_Entry_Queue_Depth =>
 784             New_Name := Name_Max_Entry_Queue_Length;
 785
 786          when Name_No_Dynamic_Interrupts =>
 787             New_Name := Name_No_Dynamic_Attachment;
 788
 789          when Name_No_Requeue =>
 790             New_Name := Name_No_Requeue_Statements;
 791
 792          when Name_No_Task_Attributes =>
 793             New_Name := Name_No_Task_Attributes_Package;
 794
 795          when others =>
 796             return Old_Name;
 797       end case;
 798
 799       if Warn_On_Obsolescent_Feature then
 800          Error_Msg_Name_1 := Old_Name;
 801          Error_Msg_N ("restriction identifier % is obsolescent?", N);
 802          Error_Msg_Name_1 := New_Name;
 803          Error_Msg_N ("|use restriction identifier % instead", N);
 804       end if;
 805
 806       return New_Name;
 807    end Process_Restriction_Synonyms;
 808
 809    --------------------------------------
 810    -- Reset_Cunit_Boolean_Restrictions --
 811    --------------------------------------
 812
 813    procedure Reset_Cunit_Boolean_Restrictions is
 814    begin
 815       for J in Cunit_Boolean_Restrictions loop
 816          Restrictions.Set (J) := False;
 817       end loop;
 818    end Reset_Cunit_Boolean_Restrictions;
 819
 820    -----------------------------------------------
 821    -- Restore_Config_Cunit_Boolean_Restrictions --
 822    -----------------------------------------------
 823
 824    procedure Restore_Config_Cunit_Boolean_Restrictions is
 825    begin
 826       Cunit_Boolean_Restrictions_Restore (Config_Cunit_Boolean_Restrictions);
 827    end Restore_Config_Cunit_Boolean_Restrictions;
 828
 829    ------------------------
 830    -- Restricted_Profile --
 831    ------------------------
 832
 833    function Restricted_Profile return Boolean is
 834    begin
 835       if Restricted_Profile_Cached then
 836          return Restricted_Profile_Result;
 837
 838       else
 839          Restricted_Profile_Result := True;
 840          Restricted_Profile_Cached := True;
 841
 842          declare
 843             R : Restriction_Flags  renames Profile_Info (Restricted).Set;
 844             V : Restriction_Values renames Profile_Info (Restricted).Value;
 845          begin
 846             for J in R'Range loop
 847                if R (J)
 848                  and then (Restrictions.Set (J) = False
 849                              or else Restriction_Warnings (J)
 850                              or else
 851                                (J in All_Parameter_Restrictions
 852                                   and then Restrictions.Value (J) > V (J)))
 853                then
 854                   Restricted_Profile_Result := False;
 855                   exit;
 856                end if;
 857             end loop;
 858
 859             return Restricted_Profile_Result;
 860          end;
 861       end if;
 862    end Restricted_Profile;
 863
 864    ------------------------
 865    -- Restriction_Active --
 866    ------------------------
 867
 868    function Restriction_Active (R : All_Restrictions) return Boolean is
 869    begin
 870       return Restrictions.Set (R) and then not Restriction_Warnings (R);
 871    end Restriction_Active;
 872
 873    --------------------------------
 874    -- Restriction_Check_Required --
 875    --------------------------------
 876
 877    function Restriction_Check_Required (R : All_Restrictions) return Boolean is
 878    begin
 879       return Restrictions.Set (R);
 880    end Restriction_Check_Required;
 881
 882    ---------------------
 883    -- Restriction_Msg --
 884    ---------------------
 885
 886    procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is
 887       Msg : String (1 .. 100);
 888       Len : Natural := 0;
 889
 890       procedure Add_Char (C : Character);
 891       --  Append given character to Msg, bumping Len
 892
 893       procedure Add_Str (S : String);
 894       --  Append given string to Msg, bumping Len appropriately
 895
 896       procedure Id_Case (S : String; Quotes : Boolean := True);
 897       --  Given a string S, case it according to current identifier casing,
 898       --  except for SPARK (an acronym) which is set all upper case, and store
 899       --  in Error_Msg_String. Then append `~` to the message buffer to output
 900       --  the string unchanged surrounded in quotes. The quotes are suppressed
 901       --  if Quotes = False.
 902
 903       --------------
 904       -- Add_Char --
 905       --------------
 906
 907       procedure Add_Char (C : Character) is
 908       begin
 909          Len := Len + 1;
 910          Msg (Len) := C;
 911       end Add_Char;
 912
 913       -------------
 914       -- Add_Str --
 915       -------------
 916
 917       procedure Add_Str (S : String) is
 918       begin
 919          Msg (Len + 1 .. Len + S'Length) := S;
 920          Len := Len + S'Length;
 921       end Add_Str;
 922
 923       -------------
 924       -- Id_Case --
 925       -------------
 926
 927       procedure Id_Case (S : String; Quotes : Boolean := True) is
 928       begin
 929          Name_Buffer (1 .. S'Last) := S;
 930          Name_Len := S'Length;
 931
 932          if R = SPARK then
 933             Set_All_Upper_Case;
 934          else
 935             Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
 936          end if;
 937
 938          Error_Msg_Strlen := Name_Len;
 939          Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
 940
 941          if Quotes then
 942             Add_Str ("`~`");
 943          else
 944             Add_Char ('~');
 945          end if;
 946       end Id_Case;
 947
 948    --  Start of processing for Restriction_Msg
 949
 950    begin
 951       --  Set warning message if warning
 952
 953       if Restriction_Warnings (R) then
 954          Add_Char ('?');
 955
 956       --  If real violation (not warning), then mark it as non-serious unless
 957       --  it is a violation of No_Finalization in which case we leave it as a
 958       --  serious message, since otherwise we get crashes during attempts to
 959       --  expand stuff that is not properly formed due to assumptions made
 960       --  about no finalization being present.
 961
 962       elsif R /= No_Finalization then
 963          Add_Char ('|');
 964       end if;
 965
 966       Error_Msg_Sloc := Restrictions_Loc (R);
 967
 968       --  Set main message, adding implicit if no source location
 969
 970       if Error_Msg_Sloc > No_Location
 971         or else Error_Msg_Sloc = System_Location
 972       then
 973          Add_Str ("violation of restriction ");
 974       else
 975          Add_Str ("violation of implicit restriction ");
 976          Error_Msg_Sloc := No_Location;
 977       end if;
 978
 979       --  Case of parameterized restriction
 980
 981       if R in All_Parameter_Restrictions then
 982          Add_Char ('`');
 983          Id_Case (Restriction_Id'Image (R), Quotes => False);
 984          Add_Str (" = ^`");
 985          Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R)));
 986
 987       --  Case of boolean restriction
 988
 989       else
 990          Id_Case (Restriction_Id'Image (R));
 991       end if;
 992
 993       --  Case of no secondary profile continuation message
 994
 995       if Restriction_Profile_Name (R) = No_Profile then
 996          if Error_Msg_Sloc /= No_Location then
 997             Add_Char ('#');
 998          end if;
 999
1000          Add_Char ('!');
1001          Error_Msg_N (Msg (1 .. Len), N);
1002
1003       --  Case of secondary profile continuation message present
1004
1005       else
1006          Add_Char ('!');
1007          Error_Msg_N (Msg (1 .. Len), N);
1008
1009          Len := 0;
1010          Add_Char ('\');
1011
1012          --  Set as warning if warning case
1013
1014          if Restriction_Warnings (R) then
1015             Add_Char ('?');
1016          end if;
1017
1018          --  Set main message
1019
1020          Add_Str ("from profile ");
1021          Id_Case (Profile_Name'Image (Restriction_Profile_Name (R)));
1022
1023          --  Add location if we have one
1024
1025          if Error_Msg_Sloc /= No_Location then
1026             Add_Char ('#');
1027          end if;
1028
1029          --  Output unconditional message and we are done
1030
1031          Add_Char ('!');
1032          Error_Msg_N (Msg (1 .. Len), N);
1033       end if;
1034    end Restriction_Msg;
1035
1036    ---------------
1037    -- Same_Unit --
1038    ---------------
1039
1040    function Same_Unit (U1, U2 : Node_Id) return Boolean is
1041    begin
1042       if Nkind (U1) = N_Identifier then
1043          return Nkind (U2) = N_Identifier and then Chars (U1) = Chars (U2);
1044
1045       elsif Nkind (U2) = N_Identifier then
1046          return False;
1047
1048       elsif (Nkind (U1) = N_Selected_Component
1049              or else Nkind (U1) = N_Expanded_Name)
1050         and then
1051           (Nkind (U2) = N_Selected_Component
1052            or else Nkind (U2) = N_Expanded_Name)
1053       then
1054          return Same_Unit (Prefix (U1), Prefix (U2))
1055            and then Same_Unit (Selector_Name (U1), Selector_Name (U2));
1056       else
1057          return False;
1058       end if;
1059    end Same_Unit;
1060
1061    --------------------------------------------
1062    -- Save_Config_Cunit_Boolean_Restrictions --
1063    --------------------------------------------
1064
1065    procedure Save_Config_Cunit_Boolean_Restrictions is
1066    begin
1067       Config_Cunit_Boolean_Restrictions := Cunit_Boolean_Restrictions_Save;
1068    end Save_Config_Cunit_Boolean_Restrictions;
1069
1070    ------------------------------
1071    -- Set_Hidden_Part_In_SPARK --
1072    ------------------------------
1073
1074    procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr) is
1075    begin
1076       SPARK_Hides.Increment_Last;
1077       SPARK_Hides.Table (SPARK_Hides.Last).Start := Loc1;
1078       SPARK_Hides.Table (SPARK_Hides.Last).Stop  := Loc2;
1079    end Set_Hidden_Part_In_SPARK;
1080
1081    ------------------------------
1082    -- Set_Profile_Restrictions --
1083    ------------------------------
1084
1085    procedure Set_Profile_Restrictions
1086      (P    : Profile_Name;
1087       N    : Node_Id;
1088       Warn : Boolean)
1089    is
1090       R : Restriction_Flags  renames Profile_Info (P).Set;
1091       V : Restriction_Values renames Profile_Info (P).Value;
1092
1093    begin
1094       for J in R'Range loop
1095          if R (J) then
1096             declare
1097                Already_Restricted : constant Boolean := Restriction_Active (J);
1098
1099             begin
1100                --  Set the restriction
1101
1102                if J in All_Boolean_Restrictions then
1103                   Set_Restriction (J, N);
1104                else
1105                   Set_Restriction (J, N, V (J));
1106                end if;
1107
1108                --  Record that this came from a Profile[_Warnings] restriction
1109
1110                Restriction_Profile_Name (J) := P;
1111
1112                --  Set warning flag, except that we do not set the warning
1113                --  flag if the restriction was already active and this is
1114                --  the warning case. That avoids a warning overriding a real
1115                --  restriction, which should never happen.
1116
1117                if not (Warn and Already_Restricted) then
1118                   Restriction_Warnings (J) := Warn;
1119                end if;
1120             end;
1121          end if;
1122       end loop;
1123    end Set_Profile_Restrictions;
1124
1125    ---------------------
1126    -- Set_Restriction --
1127    ---------------------
1128
1129    --  Case of Boolean restriction
1130
1131    procedure Set_Restriction
1132      (R : All_Boolean_Restrictions;
1133       N : Node_Id)
1134    is
1135    begin
1136       Restrictions.Set (R) := True;
1137
1138       if Restricted_Profile_Cached and Restricted_Profile_Result then
1139          null;
1140       else
1141          Restricted_Profile_Cached := False;
1142       end if;
1143
1144       --  Set location, but preserve location of system restriction for nice
1145       --  error msg with run time name.
1146
1147       if Restrictions_Loc (R) /= System_Location then
1148          Restrictions_Loc (R) := Sloc (N);
1149       end if;
1150
1151       --  Note restriction came from restriction pragma, not profile
1152
1153       Restriction_Profile_Name (R) := No_Profile;
1154
1155       --  Record the restriction if we are in the main unit, or in the extended
1156       --  main unit. The reason that we test separately for Main_Unit is that
1157       --  gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1158       --  gnat.adc do not appear to be in the extended main source unit (they
1159       --  probably should do ???)
1160
1161       if Current_Sem_Unit = Main_Unit
1162         or else In_Extended_Main_Source_Unit (N)
1163       then
1164          if not Restriction_Warnings (R) then
1165             Main_Restrictions.Set (R) := True;
1166          end if;
1167       end if;
1168    end Set_Restriction;
1169
1170    --  Case of parameter restriction
1171
1172    procedure Set_Restriction
1173      (R : All_Parameter_Restrictions;
1174       N : Node_Id;
1175       V : Integer)
1176    is
1177    begin
1178       if Restricted_Profile_Cached and Restricted_Profile_Result then
1179          null;
1180       else
1181          Restricted_Profile_Cached := False;
1182       end if;
1183
1184       if Restrictions.Set (R) then
1185          if V < Restrictions.Value (R) then
1186             Restrictions.Value (R) := V;
1187             Restrictions_Loc (R) := Sloc (N);
1188          end if;
1189
1190       else
1191          Restrictions.Set (R) := True;
1192          Restrictions.Value (R) := V;
1193          Restrictions_Loc (R) := Sloc (N);
1194       end if;
1195
1196       --  Record the restriction if we are in the main unit, or in the extended
1197       --  main unit. The reason that we test separately for Main_Unit is that
1198       --  gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1199       --  gnat.adc do not appear to be the extended main source unit (they
1200       --  probably should do ???)
1201
1202       if Current_Sem_Unit = Main_Unit
1203         or else In_Extended_Main_Source_Unit (N)
1204       then
1205          if Main_Restrictions.Set (R) then
1206             if V < Main_Restrictions.Value (R) then
1207                Main_Restrictions.Value (R) := V;
1208             end if;
1209
1210          elsif not Restriction_Warnings (R) then
1211             Main_Restrictions.Set (R) := True;
1212             Main_Restrictions.Value (R) := V;
1213          end if;
1214       end if;
1215
1216       --  Note restriction came from restriction pragma, not profile
1217
1218       Restriction_Profile_Name (R) := No_Profile;
1219    end Set_Restriction;
1220
1221    -----------------------------------
1222    -- Set_Restriction_No_Dependence --
1223    -----------------------------------
1224
1225    procedure Set_Restriction_No_Dependence
1226      (Unit    : Node_Id;
1227       Warn    : Boolean;
1228       Profile : Profile_Name := No_Profile)
1229    is
1230    begin
1231       --  Loop to check for duplicate entry
1232
1233       for J in No_Dependences.First .. No_Dependences.Last loop
1234
1235          --  Case of entry already in table
1236
1237          if Same_Unit (Unit, No_Dependences.Table (J).Unit) then
1238
1239             --  Error has precedence over warning
1240
1241             if not Warn then
1242                No_Dependences.Table (J).Warn := False;
1243             end if;
1244
1245             return;
1246          end if;
1247       end loop;
1248
1249       --  Entry is not currently in table
1250
1251       No_Dependences.Append ((Unit, Warn, Profile));
1252    end Set_Restriction_No_Dependence;
1253
1254    ------------------------------------------------
1255    -- Set_Restriction_No_Specification_Of_Aspect --
1256    ------------------------------------------------
1257
1258    procedure Set_Restriction_No_Specification_Of_Aspect
1259      (N       : Node_Id;
1260       Warning : Boolean)
1261    is
1262       A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (N));
1263       pragma Assert (A_Id /= No_Aspect);
1264
1265    begin
1266       No_Specification_Of_Aspects (A_Id) := Sloc (N);
1267
1268       if Warning = False then
1269          No_Specification_Of_Aspect_Warning (A_Id) := False;
1270       end if;
1271
1272       No_Specification_Of_Aspect_Set := True;
1273    end Set_Restriction_No_Specification_Of_Aspect;
1274
1275    ----------------------------------
1276    -- Suppress_Restriction_Message --
1277    ----------------------------------
1278
1279    function Suppress_Restriction_Message (N : Node_Id) return Boolean is
1280    begin
1281       --  We only output messages for the extended main source unit
1282
1283       if In_Extended_Main_Source_Unit (N) then
1284          return False;
1285
1286       --  If loaded by rtsfind, then suppress message
1287
1288       elsif Sloc (N) <= No_Location then
1289          return True;
1290
1291       --  Otherwise suppress message if internal file
1292
1293       else
1294          return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
1295       end if;
1296    end Suppress_Restriction_Message;
1297
1298    ---------------------
1299    -- Tasking_Allowed --
1300    ---------------------
1301
1302    function Tasking_Allowed return Boolean is
1303    begin
1304       return not Restrictions.Set (No_Tasking)
1305         and then (not Restrictions.Set (Max_Tasks)
1306                     or else Restrictions.Value (Max_Tasks) > 0);
1307    end Tasking_Allowed;
1308
1309 end Restrict;