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-2015, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Casing;   use Casing;
  28 with Einfo;    use Einfo;
  29 with Errout;   use Errout;
  30 with Debug;    use Debug;
  31 with Fname;    use Fname;
  32 with Fname.UF; use Fname.UF;
  33 with Lib;      use Lib;
  34 with Opt;      use Opt;
  35 with Sinfo;    use Sinfo;
  36 with Sinput;   use Sinput;
  37 with Stand;    use Stand;
  38 with Uname;    use Uname;
  39
  40 package body Restrict is
  41
  42    -------------------------------
  43    -- SPARK Restriction Control --
  44    -------------------------------
  45
  46    --  SPARK HIDE directives allow the effect of the SPARK_05 restriction to be
  47    --  turned off for a specified region of code, and the following tables are
  48    --  the data structures used to keep track of these regions.
  49
  50    --  The table contains pairs of source locations, the first being the start
  51    --  location for hidden region, and the second being the end location.
  52
  53    --  Note that the start location is included in the hidden region, while
  54    --  the end location is excluded from it. (It typically corresponds to the
  55    --  next token during scanning.)
  56
  57    type SPARK_Hide_Entry is record
  58       Start : Source_Ptr;
  59       Stop  : Source_Ptr;
  60    end record;
  61
  62    package SPARK_Hides is new Table.Table (
  63      Table_Component_Type => SPARK_Hide_Entry,
  64      Table_Index_Type     => Natural,
  65      Table_Low_Bound      => 1,
  66      Table_Initial        => 100,
  67      Table_Increment      => 200,
  68      Table_Name           => "SPARK Hides");
  69
  70    --------------------------------
  71    -- Package Local Declarations --
  72    --------------------------------
  73
  74    Config_Cunit_Boolean_Restrictions : Save_Cunit_Boolean_Restrictions;
  75    --  Save compilation unit restrictions set by config pragma files
  76
  77    Restricted_Profile_Result : Boolean := False;
  78    --  This switch memoizes the result of Restricted_Profile function calls for
  79    --  improved efficiency. Valid only if Restricted_Profile_Cached is True.
  80    --  Note: if this switch is ever set True, it is never turned off again.
  81
  82    Restricted_Profile_Cached : Boolean := False;
  83    --  This flag is set to True if the Restricted_Profile_Result contains the
  84    --  correct cached result of Restricted_Profile calls.
  85
  86    No_Specification_Of_Aspects : array (Aspect_Id) of Source_Ptr :=
  87                                    (others => No_Location);
  88    --  Entries in this array are set to point to a previously occuring pragma
  89    --  that activates a No_Specification_Of_Aspect check.
  90
  91    No_Specification_Of_Aspect_Warning : array (Aspect_Id) of Boolean :=
  92                                           (others => True);
  93    --  An entry in this array is set False in reponse to a previous call to
  94    --  Set_No_Speficiation_Of_Aspect for pragmas in the main unit that
  95    --  specify Warning as False. Once set False, an entry is never reset.
  96
  97    No_Specification_Of_Aspect_Set : Boolean := False;
  98    --  Set True if any entry of No_Specifcation_Of_Aspects has been set True.
  99    --  Once set True, this is never turned off again.
 100
 101    No_Use_Of_Attribute : array (Attribute_Id) of Source_Ptr :=
 102                            (others => No_Location);
 103
 104    No_Use_Of_Attribute_Warning : array (Attribute_Id) of Boolean :=
 105                                    (others => False);
 106
 107    No_Use_Of_Attribute_Set : Boolean := False;
 108    --  Indicates that No_Use_Of_Attribute was set at least once
 109
 110    No_Use_Of_Pragma : array (Pragma_Id) of Source_Ptr :=
 111                         (others => No_Location);
 112    --  Source location of pragma No_Use_Of_Pragma for given pragma, a value
 113    --  of System_Location indicates occurrence in system.ads.
 114
 115    No_Use_Of_Pragma_Warning : array (Pragma_Id) of Boolean :=
 116                                 (others => False);
 117
 118    No_Use_Of_Pragma_Set : Boolean := False;
 119    --  Indicates that No_Use_Of_Pragma was set at least once
 120
 121    -----------------------
 122    -- Local Subprograms --
 123    -----------------------
 124
 125    procedure Restriction_Msg (R : Restriction_Id; N : Node_Id);
 126    --  Called if a violation of restriction R at node N is found. This routine
 127    --  outputs the appropriate message or messages taking care of warning vs
 128    --  real violation, serious vs non-serious, implicit vs explicit, the second
 129    --  message giving the profile name if needed, and the location information.
 130
 131    function Same_Entity (E1, E2 : Node_Id) return Boolean;
 132    --  Returns True iff E1 and E2 represent the same entity. Used for handling
 133    --  of No_Use_Of_Entity => fully_qualified_ENTITY restriction case.
 134
 135    function Same_Unit (U1, U2 : Node_Id) return Boolean;
 136    --  Returns True iff U1 and U2 represent the same library unit. Used for
 137    --  handling of No_Dependence => Unit restriction case.
 138
 139    function Suppress_Restriction_Message (N : Node_Id) return Boolean;
 140    --  N is the node for a possible restriction violation message, but the
 141    --  message is to be suppressed if this is an internal file and this file is
 142    --  not the main unit. Returns True if message is to be suppressed.
 143
 144    -------------------
 145    -- Abort_Allowed --
 146    -------------------
 147
 148    function Abort_Allowed return Boolean is
 149    begin
 150       if Restrictions.Set (No_Abort_Statements)
 151         and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
 152         and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0
 153       then
 154          return False;
 155       else
 156          return True;
 157       end if;
 158    end Abort_Allowed;
 159
 160    ----------------------------------------
 161    -- Add_To_Config_Boolean_Restrictions --
 162    ----------------------------------------
 163
 164    procedure Add_To_Config_Boolean_Restrictions (R : Restriction_Id) is
 165    begin
 166       Config_Cunit_Boolean_Restrictions (R) := True;
 167    end Add_To_Config_Boolean_Restrictions;
 168    --  Add specified restriction to stored configuration boolean restrictions.
 169    --  This is used for handling the special case of No_Elaboration_Code.
 170
 171    -------------------------
 172    -- Check_Compiler_Unit --
 173    -------------------------
 174
 175    procedure Check_Compiler_Unit (Feature : String; N : Node_Id) is
 176    begin
 177       if Compiler_Unit then
 178          Error_Msg_N (Feature & " not allowed in compiler unit!!??", N);
 179       end if;
 180    end Check_Compiler_Unit;
 181
 182    procedure Check_Compiler_Unit (Feature : String; Loc : Source_Ptr) is
 183    begin
 184       if Compiler_Unit then
 185          Error_Msg (Feature & " not allowed in compiler unit!!??", Loc);
 186       end if;
 187    end Check_Compiler_Unit;
 188
 189    ------------------------------------
 190    -- Check_Elaboration_Code_Allowed --
 191    ------------------------------------
 192
 193    procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
 194    begin
 195       Check_Restriction (No_Elaboration_Code, N);
 196    end Check_Elaboration_Code_Allowed;
 197
 198    --------------------------------
 199    -- Check_No_Implicit_Aliasing --
 200    --------------------------------
 201
 202    procedure Check_No_Implicit_Aliasing (Obj : Node_Id) is
 203       E : Entity_Id;
 204
 205    begin
 206       --  If restriction not active, nothing to check
 207
 208       if not Restriction_Active (No_Implicit_Aliasing) then
 209          return;
 210       end if;
 211
 212       --  If we have an entity name, check entity
 213
 214       if Is_Entity_Name (Obj) then
 215          E := Entity (Obj);
 216
 217          --  Restriction applies to entities that are objects
 218
 219          if Is_Object (E) then
 220             if Is_Aliased (E) then
 221                return;
 222
 223             elsif Present (Renamed_Object (E)) then
 224                Check_No_Implicit_Aliasing (Renamed_Object (E));
 225                return;
 226             end if;
 227
 228          --  If we don't have an object, then it's OK
 229
 230          else
 231             return;
 232          end if;
 233
 234       --  For selected component, check selector
 235
 236       elsif Nkind (Obj) = N_Selected_Component then
 237          Check_No_Implicit_Aliasing (Selector_Name (Obj));
 238          return;
 239
 240       --  Indexed component is OK if aliased components
 241
 242       elsif Nkind (Obj) = N_Indexed_Component then
 243          if Has_Aliased_Components (Etype (Prefix (Obj)))
 244            or else
 245              (Is_Access_Type (Etype (Prefix (Obj)))
 246                and then Has_Aliased_Components
 247                           (Designated_Type (Etype (Prefix (Obj)))))
 248          then
 249             return;
 250          end if;
 251
 252       --  For type conversion, check converted expression
 253
 254       elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
 255          Check_No_Implicit_Aliasing (Expression (Obj));
 256          return;
 257
 258       --  Explicit dereference is always OK
 259
 260       elsif Nkind (Obj) = N_Explicit_Dereference then
 261          return;
 262       end if;
 263
 264       --  If we fall through, then we have an aliased view that does not meet
 265       --  the rules for being explicitly aliased, so issue restriction msg.
 266
 267       Check_Restriction (No_Implicit_Aliasing, Obj);
 268    end Check_No_Implicit_Aliasing;
 269
 270    -----------------------------------------
 271    -- Check_Implicit_Dynamic_Code_Allowed --
 272    -----------------------------------------
 273
 274    procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id) is
 275    begin
 276       Check_Restriction (No_Implicit_Dynamic_Code, N);
 277    end Check_Implicit_Dynamic_Code_Allowed;
 278
 279    ----------------------------------
 280    -- Check_No_Implicit_Heap_Alloc --
 281    ----------------------------------
 282
 283    procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is
 284    begin
 285       Check_Restriction (No_Implicit_Heap_Allocations, N);
 286    end Check_No_Implicit_Heap_Alloc;
 287
 288    -----------------------------------
 289    -- Check_Obsolescent_2005_Entity --
 290    -----------------------------------
 291
 292    procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id) is
 293       function Chars_Is (E : Entity_Id; S : String) return Boolean;
 294       --  Return True iff Chars (E) matches S (given in lower case)
 295
 296       --------------
 297       -- Chars_Is --
 298       --------------
 299
 300       function Chars_Is (E : Entity_Id; S : String) return Boolean is
 301          Nam : constant Name_Id := Chars (E);
 302       begin
 303          if Length_Of_Name (Nam) /= S'Length then
 304             return False;
 305          else
 306             return Get_Name_String (Nam) = S;
 307          end if;
 308       end Chars_Is;
 309
 310    --  Start of processing for Check_Obsolescent_2005_Entity
 311
 312    begin
 313       if Restriction_Check_Required (No_Obsolescent_Features)
 314         and then Ada_Version >= Ada_2005
 315         and then Chars_Is (Scope (E),                 "handling")
 316         and then Chars_Is (Scope (Scope (E)),         "characters")
 317         and then Chars_Is (Scope (Scope (Scope (E))), "ada")
 318         and then Scope (Scope (Scope (Scope (E)))) = Standard_Standard
 319       then
 320          if Chars_Is (E, "is_character")      or else
 321             Chars_Is (E, "is_string")         or else
 322             Chars_Is (E, "to_character")      or else
 323             Chars_Is (E, "to_string")         or else
 324             Chars_Is (E, "to_wide_character") or else
 325             Chars_Is (E, "to_wide_string")
 326          then
 327             Check_Restriction (No_Obsolescent_Features, N);
 328          end if;
 329       end if;
 330    end Check_Obsolescent_2005_Entity;
 331
 332    ---------------------------
 333    -- Check_Restricted_Unit --
 334    ---------------------------
 335
 336    procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
 337    begin
 338       if Suppress_Restriction_Message (N) then
 339          return;
 340
 341       elsif Is_Spec_Name (U) then
 342          declare
 343             Fnam : constant File_Name_Type :=
 344                      Get_File_Name (U, Subunit => False);
 345
 346          begin
 347             --  Get file name
 348
 349             Get_Name_String (Fnam);
 350
 351             --  Nothing to do if name not at least 5 characters long ending
 352             --  in .ads or .adb extension, which we strip.
 353
 354             if Name_Len < 5
 355               or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads"
 356                          and then
 357                        Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb")
 358             then
 359                return;
 360             end if;
 361
 362             --  Strip extension and pad to eight characters
 363
 364             Name_Len := Name_Len - 4;
 365             Add_Str_To_Name_Buffer ((Name_Len + 1 .. 8 => ' '));
 366
 367             --  If predefined unit, check the list of restricted units
 368
 369             if Is_Predefined_File_Name (Fnam) then
 370                for J in Unit_Array'Range loop
 371                   if Name_Len = 8
 372                     and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
 373                   then
 374                      Check_Restriction (Unit_Array (J).Res_Id, N);
 375                   end if;
 376                end loop;
 377
 378                --  If not predefined unit, then one special check still
 379                --  remains. GNAT.Current_Exception is not allowed if we have
 380                --  restriction No_Exception_Propagation active.
 381
 382             else
 383                if Name_Buffer (1 .. 8) = "g-curexc" then
 384                   Check_Restriction (No_Exception_Propagation, N);
 385                end if;
 386             end if;
 387          end;
 388       end if;
 389    end Check_Restricted_Unit;
 390
 391    -----------------------
 392    -- Check_Restriction --
 393    -----------------------
 394
 395    procedure Check_Restriction
 396      (R : Restriction_Id;
 397       N : Node_Id;
 398       V : Uint := Uint_Minus_1)
 399    is
 400       Msg_Issued : Boolean;
 401       pragma Unreferenced (Msg_Issued);
 402    begin
 403       Check_Restriction (Msg_Issued, R, N, V);
 404    end Check_Restriction;
 405
 406    procedure Check_Restriction
 407      (Msg_Issued : out Boolean;
 408       R          : Restriction_Id;
 409       N          : Node_Id;
 410       V          : Uint := Uint_Minus_1)
 411    is
 412       VV : Integer;
 413       --  V converted to integer form. If V is greater than Integer'Last,
 414       --  it is reset to minus 1 (unknown value).
 415
 416       procedure Update_Restrictions (Info : in out Restrictions_Info);
 417       --  Update violation information in Info.Violated and Info.Count
 418
 419       -------------------------
 420       -- Update_Restrictions --
 421       -------------------------
 422
 423       procedure Update_Restrictions (Info : in out Restrictions_Info) is
 424       begin
 425          --  If not violated, set as violated now
 426
 427          if not Info.Violated (R) then
 428             Info.Violated (R) := True;
 429
 430             if R in All_Parameter_Restrictions then
 431                if VV < 0 then
 432                   Info.Unknown (R) := True;
 433                   Info.Count (R) := 1;
 434
 435                else
 436                   Info.Count (R) := VV;
 437                end if;
 438             end if;
 439
 440          --  Otherwise if violated already and a parameter restriction,
 441          --  update count by maximizing or summing depending on restriction.
 442
 443          elsif R in All_Parameter_Restrictions then
 444
 445             --  If new value is unknown, result is unknown
 446
 447             if VV < 0 then
 448                Info.Unknown (R) := True;
 449
 450             --  If checked by maximization, nothing to do because the
 451             --  check is per-object.
 452
 453             elsif R in Checked_Max_Parameter_Restrictions then
 454                null;
 455
 456             --  If checked by adding, do add, checking for overflow
 457
 458             elsif R in Checked_Add_Parameter_Restrictions then
 459                declare
 460                   pragma Unsuppress (Overflow_Check);
 461                begin
 462                   Info.Count (R) := Info.Count (R) + VV;
 463                exception
 464                   when Constraint_Error =>
 465                      Info.Count (R) := Integer'Last;
 466                      Info.Unknown (R) := True;
 467                end;
 468
 469             --  Should not be able to come here, known counts should only
 470             --  occur for restrictions that are Checked_max or Checked_Sum.
 471
 472             else
 473                raise Program_Error;
 474             end if;
 475          end if;
 476       end Update_Restrictions;
 477
 478    --  Start of processing for Check_Restriction
 479
 480    begin
 481       Msg_Issued := False;
 482
 483       --  In CodePeer and SPARK mode, we do not want to check for any
 484       --  restriction, or set additional restrictions other than those already
 485       --  set in gnat1drv.adb so that we have consistency between each
 486       --  compilation.
 487
 488       --  Just checking, SPARK does not allow restrictions to be set ???
 489
 490       if CodePeer_Mode or GNATprove_Mode then
 491          return;
 492       end if;
 493
 494       --  In SPARK mode, issue an error for any use of class-wide, even if the
 495       --  No_Dispatch restriction is not set.
 496
 497       if R = No_Dispatch then
 498          Check_SPARK_05_Restriction ("class-wide is not allowed", N);
 499       end if;
 500
 501       if UI_Is_In_Int_Range (V) then
 502          VV := Integer (UI_To_Int (V));
 503       else
 504          VV := -1;
 505       end if;
 506
 507       --  Count can only be specified in the checked val parameter case
 508
 509       pragma Assert (VV < 0 or else R in Checked_Val_Parameter_Restrictions);
 510
 511       --  Nothing to do if value of zero specified for parameter restriction
 512
 513       if VV = 0 then
 514          return;
 515       end if;
 516
 517       --  Update current restrictions
 518
 519       Update_Restrictions (Restrictions);
 520
 521       --  If in main extended unit, update main restrictions as well. Note
 522       --  that as usual we check for Main_Unit explicitly to deal with the
 523       --  case of configuration pragma files.
 524
 525       if Current_Sem_Unit = Main_Unit
 526         or else In_Extended_Main_Source_Unit (N)
 527       then
 528          Update_Restrictions (Main_Restrictions);
 529       end if;
 530
 531       --  Nothing to do if restriction message suppressed
 532
 533       if Suppress_Restriction_Message (N) then
 534          null;
 535
 536       --  If restriction not set, nothing to do
 537
 538       elsif not Restrictions.Set (R) then
 539          null;
 540
 541       --  Don't complain about No_Obsolescent_Features in an instance, since we
 542       --  will complain on the template, which is much better. Are there other
 543       --  cases like this ??? Do we need a more general mechanism ???
 544
 545       elsif R = No_Obsolescent_Features
 546         and then Instantiation_Location (Sloc (N)) /= No_Location
 547       then
 548          null;
 549
 550       --  Here if restriction set, check for violation (this is a Boolean
 551       --  restriction, or a parameter restriction with a value of zero and an
 552       --  unknown count, or a parameter restriction with a known value that
 553       --  exceeds the restriction count).
 554
 555       elsif R in All_Boolean_Restrictions
 556         or else (Restrictions.Unknown (R)
 557                    and then Restrictions.Value (R) = 0)
 558         or else Restrictions.Count (R) > Restrictions.Value (R)
 559       then
 560          Msg_Issued := True;
 561          Restriction_Msg (R, N);
 562       end if;
 563
 564       --  For Max_Entries and the like, do not carry forward the violation
 565       --  count because it does not affect later declarations.
 566
 567       if R in Checked_Max_Parameter_Restrictions then
 568          Restrictions.Count (R) := 0;
 569          Restrictions.Violated (R) := False;
 570       end if;
 571    end Check_Restriction;
 572
 573    -------------------------------------
 574    -- Check_Restriction_No_Dependence --
 575    -------------------------------------
 576
 577    procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is
 578       DU : Node_Id;
 579
 580    begin
 581       --  Ignore call if node U is not in the main source unit. This avoids
 582       --  cascaded errors, e.g. when Ada.Containers units with other units.
 583       --  However, allow Standard_Location here, since this catches some cases
 584       --  of constructs that get converted to run-time calls.
 585
 586       if not In_Extended_Main_Source_Unit (U)
 587         and then Sloc (U) /= Standard_Location
 588       then
 589          return;
 590       end if;
 591
 592       --  Loop through entries in No_Dependence table to check each one in turn
 593
 594       for J in No_Dependences.First .. No_Dependences.Last loop
 595          DU := No_Dependences.Table (J).Unit;
 596
 597          if Same_Unit (U, DU) then
 598             Error_Msg_Sloc := Sloc (DU);
 599             Error_Msg_Node_1 := DU;
 600
 601             if No_Dependences.Table (J).Warn then
 602                Error_Msg
 603                  ("?*?violation of restriction `No_Dependence '='> &`#",
 604                   Sloc (Err));
 605             else
 606                Error_Msg
 607                  ("|violation of restriction `No_Dependence '='> &`#",
 608                   Sloc (Err));
 609             end if;
 610
 611             return;
 612          end if;
 613       end loop;
 614    end Check_Restriction_No_Dependence;
 615
 616    --------------------------------------------------
 617    -- Check_Restriction_No_Specification_Of_Aspect --
 618    --------------------------------------------------
 619
 620    procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id) is
 621       A_Id : Aspect_Id;
 622       Id   : Node_Id;
 623
 624    begin
 625       --  Ignore call if no instances of this restriction set
 626
 627       if not No_Specification_Of_Aspect_Set then
 628          return;
 629       end if;
 630
 631       --  Ignore call if node N is not in the main source unit, since we only
 632       --  give messages for the main unit. This avoids giving messages for
 633       --  aspects that are specified in withed units.
 634
 635       if not In_Extended_Main_Source_Unit (N) then
 636          return;
 637       end if;
 638
 639       Id := Identifier (N);
 640       A_Id := Get_Aspect_Id (Chars (Id));
 641       pragma Assert (A_Id /= No_Aspect);
 642
 643       Error_Msg_Sloc := No_Specification_Of_Aspects (A_Id);
 644
 645       if Error_Msg_Sloc /= No_Location then
 646          Error_Msg_Node_1 := Id;
 647          Error_Msg_Warn := No_Specification_Of_Aspect_Warning (A_Id);
 648          Error_Msg_N
 649            ("<*<violation of restriction `No_Specification_Of_Aspect '='> &`#",
 650             Id);
 651       end if;
 652    end Check_Restriction_No_Specification_Of_Aspect;
 653
 654    -------------------------------------------
 655    -- Check_Restriction_No_Use_Of_Attribute --
 656    --------------------------------------------
 657
 658    procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id) is
 659       Id   : constant Name_Id      := Chars (N);
 660       A_Id : constant Attribute_Id := Get_Attribute_Id (Id);
 661
 662    begin
 663       --  Ignore call if node N is not in the main source unit, since we only
 664       --  give messages for the main unit. This avoids giving messages for
 665       --  aspects that are specified in withed units.
 666
 667       if not In_Extended_Main_Source_Unit (N) then
 668          return;
 669       end if;
 670
 671       --  If nothing set, nothing to check
 672
 673       if not No_Use_Of_Attribute_Set then
 674          return;
 675       end if;
 676
 677       Error_Msg_Sloc := No_Use_Of_Attribute (A_Id);
 678
 679       if Error_Msg_Sloc /= No_Location then
 680          Error_Msg_Node_1 := N;
 681          Error_Msg_Warn := No_Use_Of_Attribute_Warning (A_Id);
 682          Error_Msg_N
 683            ("<*<violation of restriction `No_Use_Of_Attribute '='> &`#", N);
 684       end if;
 685    end Check_Restriction_No_Use_Of_Attribute;
 686
 687    ----------------------------------------
 688    -- Check_Restriction_No_Use_Of_Entity --
 689    ----------------------------------------
 690
 691    procedure Check_Restriction_No_Use_Of_Entity (N : Node_Id) is
 692    begin
 693       --  Error defence (not clearly necessary, but better safe)
 694
 695       if No (Entity (N)) then
 696          return;
 697       end if;
 698
 699       --  If simple name of entity not flagged with Boolean2 flag, then there
 700       --  cannot be a matching entry in the table, so skip the search.
 701
 702       if Get_Name_Table_Boolean2 (Chars (Entity (N))) = False then
 703          return;
 704       end if;
 705
 706       --  Restriction is only recognized within a configuration
 707       --  pragma file, or within a unit of the main extended
 708       --  program. Note: the test for Main_Unit is needed to
 709       --  properly include the case of configuration pragma files.
 710
 711       if Current_Sem_Unit /= Main_Unit
 712         and then not In_Extended_Main_Source_Unit (N)
 713       then
 714          return;
 715       end if;
 716
 717       --  Here we must search the table
 718
 719       for J in No_Use_Of_Entity.First .. No_Use_Of_Entity.Last loop
 720          declare
 721             NE_Ent : NE_Entry renames No_Use_Of_Entity.Table (J);
 722             Ent    : Entity_Id;
 723             Expr   : Node_Id;
 724
 725          begin
 726             Ent  := Entity (N);
 727             Expr := NE_Ent.Entity;
 728             loop
 729                --  Here if at outer level of entity name in reference
 730
 731                if Scope (Ent) = Standard_Standard then
 732                   if Nkind_In (Expr, N_Identifier, N_Operator_Symbol)
 733                     and then Chars (Ent) = Chars (Expr)
 734                   then
 735                      Error_Msg_Node_1 := N;
 736                      Error_Msg_Warn := NE_Ent.Warn;
 737                      Error_Msg_Sloc := Sloc (NE_Ent.Entity);
 738                      Error_Msg_N
 739                        ("<*<reference to & violates restriction "
 740                         & "No_Use_Of_Entity #", N);
 741                      return;
 742
 743                   else
 744                      goto Continue;
 745                   end if;
 746
 747                --  Here if at outer level of entity name in table
 748
 749                elsif Nkind_In (Expr, N_Identifier, N_Operator_Symbol) then
 750                   goto Continue;
 751
 752                --  Here if neither at the outer level
 753
 754                else
 755                   pragma Assert (Nkind (Expr) = N_Selected_Component);
 756
 757                   if Chars (Selector_Name (Expr)) /= Chars (Ent) then
 758                      goto Continue;
 759                   end if;
 760                end if;
 761
 762                --  Move up a level
 763
 764                loop
 765                   Ent := Scope (Ent);
 766                   exit when not Is_Internal_Name (Chars (Ent));
 767                end loop;
 768
 769                Expr := Prefix (Expr);
 770
 771                --  Entry did not match
 772
 773                <<Continue>> null;
 774             end loop;
 775          end;
 776       end loop;
 777    end Check_Restriction_No_Use_Of_Entity;
 778
 779    ----------------------------------------
 780    -- Check_Restriction_No_Use_Of_Pragma --
 781    ----------------------------------------
 782
 783    procedure Check_Restriction_No_Use_Of_Pragma (N : Node_Id) is
 784       Id   : constant Node_Id   := Pragma_Identifier (N);
 785       P_Id : constant Pragma_Id := Get_Pragma_Id (Chars (Id));
 786
 787    begin
 788       --  Ignore call if node N is not in the main source unit, since we only
 789       --  give messages for the main unit. This avoids giving messages for
 790       --  aspects that are specified in withed units.
 791
 792       if not In_Extended_Main_Source_Unit (N) then
 793          return;
 794       end if;
 795
 796       --  If nothing set, nothing to check
 797
 798       if not No_Use_Of_Pragma_Set then
 799          return;
 800       end if;
 801
 802       Error_Msg_Sloc := No_Use_Of_Pragma (P_Id);
 803
 804       if Error_Msg_Sloc /= No_Location then
 805          Error_Msg_Node_1 := Id;
 806          Error_Msg_Warn := No_Use_Of_Pragma_Warning (P_Id);
 807          Error_Msg_N
 808            ("<*<violation of restriction `No_Use_Of_Pragma '='> &`#", Id);
 809       end if;
 810    end Check_Restriction_No_Use_Of_Pragma;
 811
 812    --------------------------------------
 813    -- Check_Wide_Character_Restriction --
 814    --------------------------------------
 815
 816    procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is
 817    begin
 818       if Restriction_Check_Required (No_Wide_Characters)
 819         and then Comes_From_Source (N)
 820       then
 821          declare
 822             T : constant Entity_Id := Root_Type (E);
 823          begin
 824             if T = Standard_Wide_Character      or else
 825                T = Standard_Wide_String         or else
 826                T = Standard_Wide_Wide_Character or else
 827                T = Standard_Wide_Wide_String
 828             then
 829                Check_Restriction (No_Wide_Characters, N);
 830             end if;
 831          end;
 832       end if;
 833    end Check_Wide_Character_Restriction;
 834
 835    ----------------------------------------
 836    -- Cunit_Boolean_Restrictions_Restore --
 837    ----------------------------------------
 838
 839    procedure Cunit_Boolean_Restrictions_Restore
 840      (R : Save_Cunit_Boolean_Restrictions)
 841    is
 842    begin
 843       for J in Cunit_Boolean_Restrictions loop
 844          Restrictions.Set (J) := R (J);
 845       end loop;
 846
 847       --  If No_Elaboration_Code set in configuration restrictions, and we
 848       --  in the main extended source, then set it here now. This is part of
 849       --  the special processing for No_Elaboration_Code.
 850
 851       if In_Extended_Main_Source_Unit (Cunit_Entity (Current_Sem_Unit))
 852         and then Config_Cunit_Boolean_Restrictions (No_Elaboration_Code)
 853       then
 854          Restrictions.Set (No_Elaboration_Code) := True;
 855       end if;
 856    end Cunit_Boolean_Restrictions_Restore;
 857
 858    -------------------------------------
 859    -- Cunit_Boolean_Restrictions_Save --
 860    -------------------------------------
 861
 862    function Cunit_Boolean_Restrictions_Save
 863      return Save_Cunit_Boolean_Restrictions
 864    is
 865       R : Save_Cunit_Boolean_Restrictions;
 866
 867    begin
 868       for J in Cunit_Boolean_Restrictions loop
 869          R (J) := Restrictions.Set (J);
 870       end loop;
 871
 872       return R;
 873    end Cunit_Boolean_Restrictions_Save;
 874
 875    ------------------------
 876    -- Get_Restriction_Id --
 877    ------------------------
 878
 879    function Get_Restriction_Id
 880      (N : Name_Id) return Restriction_Id
 881    is
 882    begin
 883       Get_Name_String (N);
 884       Set_Casing (All_Upper_Case);
 885
 886       for J in All_Restrictions loop
 887          declare
 888             S : constant String := Restriction_Id'Image (J);
 889          begin
 890             if S = Name_Buffer (1 .. Name_Len) then
 891                return J;
 892             end if;
 893          end;
 894       end loop;
 895
 896       return Not_A_Restriction_Id;
 897    end Get_Restriction_Id;
 898
 899    --------------------------------
 900    -- Is_In_Hidden_Part_In_SPARK --
 901    --------------------------------
 902
 903    function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean is
 904    begin
 905       --  Loop through table of hidden ranges
 906
 907       for J in SPARK_Hides.First .. SPARK_Hides.Last loop
 908          if SPARK_Hides.Table (J).Start <= Loc
 909            and then Loc < SPARK_Hides.Table (J).Stop
 910          then
 911             return True;
 912          end if;
 913       end loop;
 914
 915       return False;
 916    end Is_In_Hidden_Part_In_SPARK;
 917
 918    -------------------------------
 919    -- No_Exception_Handlers_Set --
 920    -------------------------------
 921
 922    function No_Exception_Handlers_Set return Boolean is
 923    begin
 924       return (No_Run_Time_Mode or else Configurable_Run_Time_Mode)
 925         and then (Restrictions.Set (No_Exception_Handlers)
 926                     or else
 927                   Restrictions.Set (No_Exception_Propagation));
 928    end No_Exception_Handlers_Set;
 929
 930    -------------------------------------
 931    -- No_Exception_Propagation_Active --
 932    -------------------------------------
 933
 934    function No_Exception_Propagation_Active return Boolean is
 935    begin
 936       return (No_Run_Time_Mode
 937                or else Configurable_Run_Time_Mode
 938                or else Debug_Flag_Dot_G)
 939         and then Restriction_Active (No_Exception_Propagation);
 940    end No_Exception_Propagation_Active;
 941
 942    --------------------------------
 943    -- OK_No_Dependence_Unit_Name --
 944    --------------------------------
 945
 946    function OK_No_Dependence_Unit_Name (N : Node_Id) return Boolean is
 947    begin
 948       if Nkind (N) = N_Selected_Component then
 949          return
 950            OK_No_Dependence_Unit_Name (Prefix (N))
 951              and then
 952            OK_No_Dependence_Unit_Name (Selector_Name (N));
 953
 954       elsif Nkind (N) = N_Identifier then
 955          return True;
 956
 957       else
 958          Error_Msg_N ("wrong form for unit name for No_Dependence", N);
 959          return False;
 960       end if;
 961    end OK_No_Dependence_Unit_Name;
 962
 963    ------------------------------
 964    -- OK_No_Use_Of_Entity_Name --
 965    ------------------------------
 966
 967    function OK_No_Use_Of_Entity_Name (N : Node_Id) return Boolean is
 968    begin
 969       if Nkind (N) = N_Selected_Component then
 970          return
 971            OK_No_Use_Of_Entity_Name (Prefix (N))
 972              and then
 973            OK_No_Use_Of_Entity_Name (Selector_Name (N));
 974
 975       elsif Nkind_In (N, N_Identifier, N_Operator_Symbol) then
 976          return True;
 977
 978       else
 979          Error_Msg_N ("wrong form for entity name for No_Use_Of_Entity", N);
 980          return False;
 981       end if;
 982    end OK_No_Use_Of_Entity_Name;
 983
 984    ----------------------------------
 985    -- Process_Restriction_Synonyms --
 986    ----------------------------------
 987
 988    --  Note: body of this function must be coordinated with list of renaming
 989    --  declarations in System.Rident.
 990
 991    function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
 992    is
 993       Old_Name : constant Name_Id := Chars (N);
 994       New_Name : Name_Id;
 995
 996    begin
 997       case Old_Name is
 998          when Name_Boolean_Entry_Barriers =>
 999             New_Name := Name_Simple_Barriers;
1000
1001          when Name_Max_Entry_Queue_Depth =>
1002             New_Name := Name_Max_Entry_Queue_Length;
1003
1004          when Name_No_Dynamic_Interrupts =>
1005             New_Name := Name_No_Dynamic_Attachment;
1006
1007          when Name_No_Requeue =>
1008             New_Name := Name_No_Requeue_Statements;
1009
1010          when Name_No_Task_Attributes =>
1011             New_Name := Name_No_Task_Attributes_Package;
1012
1013          --  SPARK is special in that we unconditionally warn
1014
1015          when Name_SPARK =>
1016             Error_Msg_Name_1 := Name_SPARK;
1017             Error_Msg_N ("restriction identifier % is obsolescent??", N);
1018             Error_Msg_Name_1 := Name_SPARK_05;
1019             Error_Msg_N ("|use restriction identifier % instead??", N);
1020             return Name_SPARK_05;
1021
1022          when others =>
1023             return Old_Name;
1024       end case;
1025
1026       --  Output warning if we are warning on obsolescent features for all
1027       --  cases other than SPARK.
1028
1029       if Warn_On_Obsolescent_Feature then
1030          Error_Msg_Name_1 := Old_Name;
1031          Error_Msg_N ("restriction identifier % is obsolescent?j?", N);
1032          Error_Msg_Name_1 := New_Name;
1033          Error_Msg_N ("|use restriction identifier % instead?j?", N);
1034       end if;
1035
1036       return New_Name;
1037    end Process_Restriction_Synonyms;
1038
1039    --------------------------------------
1040    -- Reset_Cunit_Boolean_Restrictions --
1041    --------------------------------------
1042
1043    procedure Reset_Cunit_Boolean_Restrictions is
1044    begin
1045       for J in Cunit_Boolean_Restrictions loop
1046          Restrictions.Set (J) := False;
1047       end loop;
1048    end Reset_Cunit_Boolean_Restrictions;
1049
1050    -----------------------------------------------
1051    -- Restore_Config_Cunit_Boolean_Restrictions --
1052    -----------------------------------------------
1053
1054    procedure Restore_Config_Cunit_Boolean_Restrictions is
1055    begin
1056       Cunit_Boolean_Restrictions_Restore (Config_Cunit_Boolean_Restrictions);
1057    end Restore_Config_Cunit_Boolean_Restrictions;
1058
1059    ------------------------
1060    -- Restricted_Profile --
1061    ------------------------
1062
1063    function Restricted_Profile return Boolean is
1064    begin
1065       if Restricted_Profile_Cached then
1066          return Restricted_Profile_Result;
1067
1068       else
1069          Restricted_Profile_Result := True;
1070          Restricted_Profile_Cached := True;
1071
1072          declare
1073             R : Restriction_Flags  renames Profile_Info (Restricted).Set;
1074             V : Restriction_Values renames Profile_Info (Restricted).Value;
1075          begin
1076             for J in R'Range loop
1077                if R (J)
1078                  and then (Restrictions.Set (J) = False
1079                              or else Restriction_Warnings (J)
1080                              or else
1081                                (J in All_Parameter_Restrictions
1082                                   and then Restrictions.Value (J) > V (J)))
1083                then
1084                   Restricted_Profile_Result := False;
1085                   exit;
1086                end if;
1087             end loop;
1088
1089             return Restricted_Profile_Result;
1090          end;
1091       end if;
1092    end Restricted_Profile;
1093
1094    ------------------------
1095    -- Restriction_Active --
1096    ------------------------
1097
1098    function Restriction_Active (R : All_Restrictions) return Boolean is
1099    begin
1100       return Restrictions.Set (R) and then not Restriction_Warnings (R);
1101    end Restriction_Active;
1102
1103    --------------------------------
1104    -- Restriction_Check_Required --
1105    --------------------------------
1106
1107    function Restriction_Check_Required (R : All_Restrictions) return Boolean is
1108    begin
1109       return Restrictions.Set (R);
1110    end Restriction_Check_Required;
1111
1112    ---------------------
1113    -- Restriction_Msg --
1114    ---------------------
1115
1116    procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is
1117       Msg : String (1 .. 100);
1118       Len : Natural := 0;
1119
1120       procedure Add_Char (C : Character);
1121       --  Append given character to Msg, bumping Len
1122
1123       procedure Add_Str (S : String);
1124       --  Append given string to Msg, bumping Len appropriately
1125
1126       procedure Id_Case (S : String; Quotes : Boolean := True);
1127       --  Given a string S, case it according to current identifier casing,
1128       --  except for SPARK_05 (an acronym) which is set all upper case, and
1129       --  store in Error_Msg_String. Then append `~` to the message buffer
1130       --  to output the string unchanged surrounded in quotes. The quotes
1131       --  are suppressed if Quotes = False.
1132
1133       --------------
1134       -- Add_Char --
1135       --------------
1136
1137       procedure Add_Char (C : Character) is
1138       begin
1139          Len := Len + 1;
1140          Msg (Len) := C;
1141       end Add_Char;
1142
1143       -------------
1144       -- Add_Str --
1145       -------------
1146
1147       procedure Add_Str (S : String) is
1148       begin
1149          Msg (Len + 1 .. Len + S'Length) := S;
1150          Len := Len + S'Length;
1151       end Add_Str;
1152
1153       -------------
1154       -- Id_Case --
1155       -------------
1156
1157       procedure Id_Case (S : String; Quotes : Boolean := True) is
1158       begin
1159          Name_Buffer (1 .. S'Last) := S;
1160          Name_Len := S'Length;
1161
1162          if R = SPARK_05 then
1163             Set_All_Upper_Case;
1164          else
1165             Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
1166          end if;
1167
1168          Error_Msg_Strlen := Name_Len;
1169          Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1170
1171          if Quotes then
1172             Add_Str ("`~`");
1173          else
1174             Add_Char ('~');
1175          end if;
1176       end Id_Case;
1177
1178    --  Start of processing for Restriction_Msg
1179
1180    begin
1181       --  Set warning message if warning
1182
1183       if Restriction_Warnings (R) then
1184          Add_Str ("?*?");
1185
1186       --  If real violation (not warning), then mark it as non-serious unless
1187       --  it is a violation of No_Finalization in which case we leave it as a
1188       --  serious message, since otherwise we get crashes during attempts to
1189       --  expand stuff that is not properly formed due to assumptions made
1190       --  about no finalization being present.
1191
1192       elsif R /= No_Finalization then
1193          Add_Char ('|');
1194       end if;
1195
1196       Error_Msg_Sloc := Restrictions_Loc (R);
1197
1198       --  Set main message, adding implicit if no source location
1199
1200       if Error_Msg_Sloc > No_Location
1201         or else Error_Msg_Sloc = System_Location
1202       then
1203          Add_Str ("violation of restriction ");
1204       else
1205          Add_Str ("violation of implicit restriction ");
1206          Error_Msg_Sloc := No_Location;
1207       end if;
1208
1209       --  Case of parameterized restriction
1210
1211       if R in All_Parameter_Restrictions then
1212          Add_Char ('`');
1213          Id_Case (Restriction_Id'Image (R), Quotes => False);
1214          Add_Str (" = ^`");
1215          Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R)));
1216
1217       --  Case of boolean restriction
1218
1219       else
1220          Id_Case (Restriction_Id'Image (R));
1221       end if;
1222
1223       --  Case of no secondary profile continuation message
1224
1225       if Restriction_Profile_Name (R) = No_Profile then
1226          if Error_Msg_Sloc /= No_Location then
1227             Add_Char ('#');
1228          end if;
1229
1230          Add_Char ('!');
1231          Error_Msg_N (Msg (1 .. Len), N);
1232
1233       --  Case of secondary profile continuation message present
1234
1235       else
1236          Add_Char ('!');
1237          Error_Msg_N (Msg (1 .. Len), N);
1238
1239          Len := 0;
1240          Add_Char ('\');
1241
1242          --  Set as warning if warning case
1243
1244          if Restriction_Warnings (R) then
1245             Add_Str ("??");
1246          end if;
1247
1248          --  Set main message
1249
1250          Add_Str ("from profile ");
1251          Id_Case (Profile_Name'Image (Restriction_Profile_Name (R)));
1252
1253          --  Add location if we have one
1254
1255          if Error_Msg_Sloc /= No_Location then
1256             Add_Char ('#');
1257          end if;
1258
1259          --  Output unconditional message and we are done
1260
1261          Add_Char ('!');
1262          Error_Msg_N (Msg (1 .. Len), N);
1263       end if;
1264    end Restriction_Msg;
1265
1266    -----------------
1267    -- Same_Entity --
1268    -----------------
1269
1270    function Same_Entity (E1, E2 : Node_Id) return Boolean is
1271    begin
1272       if Nkind_In (E1, N_Identifier, N_Operator_Symbol)
1273            and then
1274          Nkind_In (E2, N_Identifier, N_Operator_Symbol)
1275       then
1276          return Chars (E1) = Chars (E2);
1277
1278       elsif Nkind_In (E1, N_Selected_Component, N_Expanded_Name)
1279               and then
1280             Nkind_In (E2, N_Selected_Component, N_Expanded_Name)
1281       then
1282          return Same_Unit (Prefix (E1), Prefix (E2))
1283                   and then
1284                 Same_Unit (Selector_Name (E1), Selector_Name (E2));
1285       else
1286          return False;
1287       end if;
1288    end Same_Entity;
1289
1290    ---------------
1291    -- Same_Unit --
1292    ---------------
1293
1294    function Same_Unit (U1, U2 : Node_Id) return Boolean is
1295    begin
1296       if Nkind (U1) = N_Identifier and then Nkind (U2) = N_Identifier then
1297          return Chars (U1) = Chars (U2);
1298
1299       elsif Nkind_In (U1, N_Selected_Component, N_Expanded_Name)
1300               and then
1301             Nkind_In (U2, N_Selected_Component, N_Expanded_Name)
1302       then
1303          return Same_Unit (Prefix (U1), Prefix (U2))
1304                   and then
1305                 Same_Unit (Selector_Name (U1), Selector_Name (U2));
1306       else
1307          return False;
1308       end if;
1309    end Same_Unit;
1310
1311    --------------------------------------------
1312    -- Save_Config_Cunit_Boolean_Restrictions --
1313    --------------------------------------------
1314
1315    procedure Save_Config_Cunit_Boolean_Restrictions is
1316    begin
1317       Config_Cunit_Boolean_Restrictions := Cunit_Boolean_Restrictions_Save;
1318    end Save_Config_Cunit_Boolean_Restrictions;
1319
1320    ------------------------------
1321    -- Set_Hidden_Part_In_SPARK --
1322    ------------------------------
1323
1324    procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr) is
1325    begin
1326       SPARK_Hides.Increment_Last;
1327       SPARK_Hides.Table (SPARK_Hides.Last).Start := Loc1;
1328       SPARK_Hides.Table (SPARK_Hides.Last).Stop  := Loc2;
1329    end Set_Hidden_Part_In_SPARK;
1330
1331    ------------------------------
1332    -- Set_Profile_Restrictions --
1333    ------------------------------
1334
1335    procedure Set_Profile_Restrictions
1336      (P    : Profile_Name;
1337       N    : Node_Id;
1338       Warn : Boolean)
1339    is
1340       R : Restriction_Flags  renames Profile_Info (P).Set;
1341       V : Restriction_Values renames Profile_Info (P).Value;
1342
1343    begin
1344       for J in R'Range loop
1345          if R (J) then
1346             declare
1347                Already_Restricted : constant Boolean := Restriction_Active (J);
1348
1349             begin
1350                --  Set the restriction
1351
1352                if J in All_Boolean_Restrictions then
1353                   Set_Restriction (J, N);
1354                else
1355                   Set_Restriction (J, N, V (J));
1356                end if;
1357
1358                --  Record that this came from a Profile[_Warnings] restriction
1359
1360                Restriction_Profile_Name (J) := P;
1361
1362                --  Set warning flag, except that we do not set the warning
1363                --  flag if the restriction was already active and this is
1364                --  the warning case. That avoids a warning overriding a real
1365                --  restriction, which should never happen.
1366
1367                if not (Warn and Already_Restricted) then
1368                   Restriction_Warnings (J) := Warn;
1369                end if;
1370             end;
1371          end if;
1372       end loop;
1373    end Set_Profile_Restrictions;
1374
1375    ---------------------
1376    -- Set_Restriction --
1377    ---------------------
1378
1379    --  Case of Boolean restriction
1380
1381    procedure Set_Restriction
1382      (R : All_Boolean_Restrictions;
1383       N : Node_Id)
1384    is
1385    begin
1386       Restrictions.Set (R) := True;
1387
1388       if Restricted_Profile_Cached and Restricted_Profile_Result then
1389          null;
1390       else
1391          Restricted_Profile_Cached := False;
1392       end if;
1393
1394       --  Set location, but preserve location of system restriction for nice
1395       --  error msg with run time name.
1396
1397       if Restrictions_Loc (R) /= System_Location then
1398          Restrictions_Loc (R) := Sloc (N);
1399       end if;
1400
1401       --  Note restriction came from restriction pragma, not profile
1402
1403       Restriction_Profile_Name (R) := No_Profile;
1404
1405       --  Record the restriction if we are in the main unit, or in the extended
1406       --  main unit. The reason that we test separately for Main_Unit is that
1407       --  gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1408       --  gnat.adc do not appear to be in the extended main source unit (they
1409       --  probably should do ???)
1410
1411       if Current_Sem_Unit = Main_Unit
1412         or else In_Extended_Main_Source_Unit (N)
1413       then
1414          if not Restriction_Warnings (R) then
1415             Main_Restrictions.Set (R) := True;
1416          end if;
1417       end if;
1418    end Set_Restriction;
1419
1420    --  Case of parameter restriction
1421
1422    procedure Set_Restriction
1423      (R : All_Parameter_Restrictions;
1424       N : Node_Id;
1425       V : Integer)
1426    is
1427    begin
1428       if Restricted_Profile_Cached and Restricted_Profile_Result then
1429          null;
1430       else
1431          Restricted_Profile_Cached := False;
1432       end if;
1433
1434       if Restrictions.Set (R) then
1435          if V < Restrictions.Value (R) then
1436             Restrictions.Value (R) := V;
1437             Restrictions_Loc (R) := Sloc (N);
1438          end if;
1439
1440       else
1441          Restrictions.Set (R) := True;
1442          Restrictions.Value (R) := V;
1443          Restrictions_Loc (R) := Sloc (N);
1444       end if;
1445
1446       --  Record the restriction if we are in the main unit, or in the extended
1447       --  main unit. The reason that we test separately for Main_Unit is that
1448       --  gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1449       --  gnat.adc do not appear to be the extended main source unit (they
1450       --  probably should do ???)
1451
1452       if Current_Sem_Unit = Main_Unit
1453         or else In_Extended_Main_Source_Unit (N)
1454       then
1455          if Main_Restrictions.Set (R) then
1456             if V < Main_Restrictions.Value (R) then
1457                Main_Restrictions.Value (R) := V;
1458             end if;
1459
1460          elsif not Restriction_Warnings (R) then
1461             Main_Restrictions.Set (R) := True;
1462             Main_Restrictions.Value (R) := V;
1463          end if;
1464       end if;
1465
1466       --  Note restriction came from restriction pragma, not profile
1467
1468       Restriction_Profile_Name (R) := No_Profile;
1469    end Set_Restriction;
1470
1471    -----------------------------------
1472    -- Set_Restriction_No_Dependence --
1473    -----------------------------------
1474
1475    procedure Set_Restriction_No_Dependence
1476      (Unit    : Node_Id;
1477       Warn    : Boolean;
1478       Profile : Profile_Name := No_Profile)
1479    is
1480    begin
1481       --  Loop to check for duplicate entry
1482
1483       for J in No_Dependences.First .. No_Dependences.Last loop
1484
1485          --  Case of entry already in table
1486
1487          if Same_Unit (Unit, No_Dependences.Table (J).Unit) then
1488
1489             --  Error has precedence over warning
1490
1491             if not Warn then
1492                No_Dependences.Table (J).Warn := False;
1493             end if;
1494
1495             return;
1496          end if;
1497       end loop;
1498
1499       --  Entry is not currently in table
1500
1501       No_Dependences.Append ((Unit, Warn, Profile));
1502    end Set_Restriction_No_Dependence;
1503
1504    --------------------------------------
1505    -- Set_Restriction_No_Use_Of_Entity --
1506    --------------------------------------
1507
1508    procedure Set_Restriction_No_Use_Of_Entity
1509      (Entity  : Node_Id;
1510       Warn    : Boolean;
1511       Profile : Profile_Name := No_Profile)
1512    is
1513       Nam : Node_Id;
1514
1515    begin
1516       --  Loop to check for duplicate entry
1517
1518       for J in No_Use_Of_Entity.First .. No_Use_Of_Entity.Last loop
1519
1520          --  Case of entry already in table
1521
1522          if Same_Entity (Entity, No_Use_Of_Entity.Table (J).Entity) then
1523
1524             --  Error has precedence over warning
1525
1526             if not Warn then
1527                No_Use_Of_Entity.Table (J).Warn := False;
1528             end if;
1529
1530             return;
1531          end if;
1532       end loop;
1533
1534       --  Entry is not currently in table
1535
1536       No_Use_Of_Entity.Append ((Entity, Warn, Profile));
1537
1538       --  Now we need to find the direct name and set Boolean2 flag
1539
1540       if Nkind_In (Entity, N_Identifier, N_Operator_Symbol) then
1541          Nam := Entity;
1542
1543       else
1544          pragma Assert (Nkind (Entity) = N_Selected_Component);
1545          Nam := Selector_Name (Entity);
1546          pragma Assert (Nkind_In (Nam, N_Identifier, N_Operator_Symbol));
1547       end if;
1548
1549       Set_Name_Table_Boolean2 (Chars (Nam), True);
1550    end Set_Restriction_No_Use_Of_Entity;
1551
1552    ------------------------------------------------
1553    -- Set_Restriction_No_Specification_Of_Aspect --
1554    ------------------------------------------------
1555
1556    procedure Set_Restriction_No_Specification_Of_Aspect
1557      (N       : Node_Id;
1558       Warning : Boolean)
1559    is
1560       A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N));
1561
1562    begin
1563       No_Specification_Of_Aspects (A_Id) := Sloc (N);
1564
1565       if Warning = False then
1566          No_Specification_Of_Aspect_Warning (A_Id) := False;
1567       end if;
1568
1569       No_Specification_Of_Aspect_Set := True;
1570    end Set_Restriction_No_Specification_Of_Aspect;
1571
1572    procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id) is
1573    begin
1574       No_Specification_Of_Aspect_Set := True;
1575       No_Specification_Of_Aspects (A_Id) := System_Location;
1576       No_Specification_Of_Aspect_Warning (A_Id) := False;
1577    end Set_Restriction_No_Specification_Of_Aspect;
1578
1579    -----------------------------------------
1580    -- Set_Restriction_No_Use_Of_Attribute --
1581    -----------------------------------------
1582
1583    procedure Set_Restriction_No_Use_Of_Attribute
1584      (N       : Node_Id;
1585       Warning : Boolean)
1586    is
1587       A_Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
1588
1589    begin
1590       No_Use_Of_Attribute_Set := True;
1591       No_Use_Of_Attribute (A_Id) := Sloc (N);
1592
1593       if Warning = False then
1594          No_Use_Of_Attribute_Warning (A_Id) := False;
1595       end if;
1596    end Set_Restriction_No_Use_Of_Attribute;
1597
1598    procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id) is
1599    begin
1600       No_Use_Of_Attribute_Set := True;
1601       No_Use_Of_Attribute (A_Id) := System_Location;
1602       No_Use_Of_Attribute_Warning (A_Id) := False;
1603    end Set_Restriction_No_Use_Of_Attribute;
1604
1605    --------------------------------------
1606    -- Set_Restriction_No_Use_Of_Pragma --
1607    --------------------------------------
1608
1609    procedure Set_Restriction_No_Use_Of_Pragma
1610      (N       : Node_Id;
1611       Warning : Boolean)
1612    is
1613       A_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N));
1614
1615    begin
1616       No_Use_Of_Pragma_Set := True;
1617       No_Use_Of_Pragma (A_Id) := Sloc (N);
1618
1619       if Warning = False then
1620          No_Use_Of_Pragma_Warning (A_Id) := False;
1621       end if;
1622    end Set_Restriction_No_Use_Of_Pragma;
1623
1624    procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id) is
1625    begin
1626       No_Use_Of_Pragma_Set := True;
1627       No_Use_Of_Pragma (A_Id) := System_Location;
1628       No_Use_Of_Pragma_Warning (A_Id) := False;
1629    end Set_Restriction_No_Use_Of_Pragma;
1630
1631    --------------------------------
1632    -- Check_SPARK_05_Restriction --
1633    --------------------------------
1634
1635    procedure Check_SPARK_05_Restriction
1636      (Msg   : String;
1637       N     : Node_Id;
1638       Force : Boolean := False)
1639    is
1640       Msg_Issued          : Boolean;
1641       Save_Error_Msg_Sloc : Source_Ptr;
1642       Onode               : constant Node_Id := Original_Node (N);
1643
1644    begin
1645       --  Output message if Force set
1646
1647       if Force
1648
1649         --  Or if this node comes from source
1650
1651         or else Comes_From_Source (N)
1652
1653         --  Or if this is a range node which rewrites a range attribute and
1654         --  the range attribute comes from source.
1655
1656         or else (Nkind (N) = N_Range
1657                   and then Nkind (Onode) = N_Attribute_Reference
1658                   and then Attribute_Name (Onode) = Name_Range
1659                   and then Comes_From_Source (Onode))
1660
1661         --  Or this is an expression that does not come from source, which is
1662         --  a rewriting of an expression that does come from source.
1663
1664         or else (Nkind (N) in N_Subexpr and then Comes_From_Source (Onode))
1665       then
1666          if Restriction_Check_Required (SPARK_05)
1667            and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
1668          then
1669             return;
1670          end if;
1671
1672          --  Since the call to Restriction_Msg from Check_Restriction may set
1673          --  Error_Msg_Sloc to the location of the pragma restriction, save and
1674          --  restore the previous value of the global variable around the call.
1675
1676          Save_Error_Msg_Sloc := Error_Msg_Sloc;
1677          Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
1678          Error_Msg_Sloc := Save_Error_Msg_Sloc;
1679
1680          if Msg_Issued then
1681             Error_Msg_F ("\\| " & Msg, N);
1682          end if;
1683       end if;
1684    end Check_SPARK_05_Restriction;
1685
1686    procedure Check_SPARK_05_Restriction (Msg1, Msg2 : String; N : Node_Id) is
1687       Msg_Issued          : Boolean;
1688       Save_Error_Msg_Sloc : Source_Ptr;
1689
1690    begin
1691       pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\');
1692
1693       if Comes_From_Source (Original_Node (N)) then
1694          if Restriction_Check_Required (SPARK_05)
1695            and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
1696          then
1697             return;
1698          end if;
1699
1700          --  Since the call to Restriction_Msg from Check_Restriction may set
1701          --  Error_Msg_Sloc to the location of the pragma restriction, save and
1702          --  restore the previous value of the global variable around the call.
1703
1704          Save_Error_Msg_Sloc := Error_Msg_Sloc;
1705          Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
1706          Error_Msg_Sloc := Save_Error_Msg_Sloc;
1707
1708          if Msg_Issued then
1709             Error_Msg_F ("\\| " & Msg1, N);
1710             Error_Msg_F (Msg2, N);
1711          end if;
1712       end if;
1713    end Check_SPARK_05_Restriction;
1714
1715    ----------------------------------
1716    -- Suppress_Restriction_Message --
1717    ----------------------------------
1718
1719    function Suppress_Restriction_Message (N : Node_Id) return Boolean is
1720    begin
1721       --  We only output messages for the extended main source unit
1722
1723       if In_Extended_Main_Source_Unit (N) then
1724          return False;
1725
1726       --  If loaded by rtsfind, then suppress message
1727
1728       elsif Sloc (N) <= No_Location then
1729          return True;
1730
1731       --  Otherwise suppress message if internal file
1732
1733       else
1734          return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
1735       end if;
1736    end Suppress_Restriction_Message;
1737
1738    ---------------------
1739    -- Tasking_Allowed --
1740    ---------------------
1741
1742    function Tasking_Allowed return Boolean is
1743    begin
1744       return not Restrictions.Set (No_Tasking)
1745         and then (not Restrictions.Set (Max_Tasks)
1746                    or else Restrictions.Value (Max_Tasks) > 0)
1747         and then not No_Run_Time_Mode;
1748    end Tasking_Allowed;
1749
1750 end Restrict;