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-2004 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Casing;   use Casing;
  29 with Errout;   use Errout;
  30 with Fname;    use Fname;
  31 with Fname.UF; use Fname.UF;
  32 with Lib;      use Lib;
  33 with Namet;    use Namet;
  34 with Opt;      use Opt;
  35 with Sinfo;    use Sinfo;
  36 with Sinput;   use Sinput;
  37 with Snames;   use Snames;
  38 with Uname;    use Uname;
  39
  40 package body Restrict is
  41
  42    Restricted_Profile_Result : Boolean := False;
  43    --  This switch memoizes the result of Restricted_Profile function
  44    --  calls for improved efficiency. Its setting is valid only if
  45    --  Restricted_Profile_Cached is True. Note that if this switch
  46    --  is ever set True, it need never be turned off again.
  47
  48    Restricted_Profile_Cached : Boolean := False;
  49    --  This flag is set to True if the Restricted_Profile_Result
  50    --  contains the correct cached result of Restricted_Profile calls.
  51
  52    -----------------------
  53    -- Local Subprograms --
  54    -----------------------
  55
  56    procedure Restriction_Msg (Msg : String; R : String; N : Node_Id);
  57    --  Output error message at node N with given text, replacing the
  58    --  '%' in the message with the name of the restriction given as R,
  59    --  cased according to the current identifier casing. We do not use
  60    --  the normal insertion mechanism, since this requires an entry
  61    --  in the Names table, and this table will be locked if we are
  62    --  generating a message from gigi.
  63
  64    function Suppress_Restriction_Message (N : Node_Id) return Boolean;
  65    --  N is the node for a possible restriction violation message, but
  66    --  the message is to be suppressed if this is an internal file and
  67    --  this file is not the main unit.
  68
  69    -------------------
  70    -- Abort_Allowed --
  71    -------------------
  72
  73    function Abort_Allowed return Boolean is
  74    begin
  75       if Restrictions.Set (No_Abort_Statements)
  76         and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
  77         and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0
  78       then
  79          return False;
  80       else
  81          return True;
  82       end if;
  83    end Abort_Allowed;
  84
  85    ------------------------------------
  86    -- Check_Elaboration_Code_Allowed --
  87    ------------------------------------
  88
  89    procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
  90    begin
  91       --  Avoid calling Namet.Unlock/Lock except when there is an error.
  92       --  Even in the error case it is a bit dubious, either gigi needs
  93       --  the table locked or it does not! ???
  94
  95       if Restrictions.Set (No_Elaboration_Code)
  96         and then not Suppress_Restriction_Message (N)
  97       then
  98          Namet.Unlock;
  99          Check_Restriction (Restriction_Id'(No_Elaboration_Code), N);
 100          Namet.Lock;
 101       end if;
 102    end Check_Elaboration_Code_Allowed;
 103
 104    ----------------------------------
 105    -- Check_No_Implicit_Heap_Alloc --
 106    ----------------------------------
 107
 108    procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is
 109    begin
 110       Check_Restriction (Restriction_Id'(No_Implicit_Heap_Allocations), N);
 111    end Check_No_Implicit_Heap_Alloc;
 112
 113    ---------------------------
 114    -- Check_Restricted_Unit --
 115    ---------------------------
 116
 117    procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
 118    begin
 119       if Suppress_Restriction_Message (N) then
 120          return;
 121
 122       elsif Is_Spec_Name (U) then
 123          declare
 124             Fnam : constant File_Name_Type :=
 125                      Get_File_Name (U, Subunit => False);
 126
 127          begin
 128             if not Is_Predefined_File_Name (Fnam) then
 129                return;
 130
 131             --  Predefined spec, needs checking against list
 132
 133             else
 134                --  Pad name to 8 characters with blanks
 135
 136                Get_Name_String (Fnam);
 137                Name_Len := Name_Len - 4;
 138
 139                while Name_Len < 8 loop
 140                   Name_Len := Name_Len + 1;
 141                   Name_Buffer (Name_Len) := ' ';
 142                end loop;
 143
 144                for J in Unit_Array'Range loop
 145                   if Name_Len = 8
 146                     and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
 147                   then
 148                      Check_Restriction (Unit_Array (J).Res_Id, N);
 149                   end if;
 150                end loop;
 151             end if;
 152          end;
 153       end if;
 154    end Check_Restricted_Unit;
 155
 156    -----------------------
 157    -- Check_Restriction --
 158    -----------------------
 159
 160    procedure Check_Restriction
 161      (R : Restriction_Id;
 162       N : Node_Id;
 163       V : Uint := Uint_Minus_1)
 164    is
 165       Rimage : constant String := Restriction_Id'Image (R);
 166
 167       VV : Integer;
 168       --  V converted to integer form. If V is greater than Integer'Last,
 169       --  it is reset to minus 1 (unknown value).
 170
 171       procedure Update_Restrictions (Info : in out Restrictions_Info);
 172       --  Update violation information in Info.Violated and Info.Count
 173
 174       -------------------------
 175       -- Update_Restrictions --
 176       -------------------------
 177
 178       procedure Update_Restrictions (Info : in out Restrictions_Info) is
 179       begin
 180          --  If not violated, set as violated now
 181
 182          if not Info.Violated (R) then
 183             Info.Violated (R) := True;
 184
 185             if R in All_Parameter_Restrictions then
 186                if VV < 0 then
 187                   Info.Unknown (R) := True;
 188                   Info.Count (R) := 1;
 189                else
 190                   Info.Count (R) := VV;
 191                end if;
 192             end if;
 193
 194          --  Otherwise if violated already and a parameter restriction,
 195          --  update count by maximizing or summing depending on restriction.
 196
 197          elsif R in All_Parameter_Restrictions then
 198
 199             --  If new value is unknown, result is unknown
 200
 201             if VV < 0 then
 202                Info.Unknown (R) := True;
 203
 204             --  If checked by maximization, do maximization
 205
 206             elsif R in Checked_Max_Parameter_Restrictions then
 207                Info.Count (R) := Integer'Max (Info.Count (R), VV);
 208
 209             --  If checked by adding, do add, checking for overflow
 210
 211             elsif R in Checked_Add_Parameter_Restrictions then
 212                declare
 213                   pragma Unsuppress (Overflow_Check);
 214                begin
 215                   Info.Count (R) := Info.Count (R) + VV;
 216                exception
 217                   when Constraint_Error =>
 218                      Info.Count (R) := Integer'Last;
 219                      Info.Unknown (R) := True;
 220                end;
 221
 222             --  Should not be able to come here, known counts should only
 223             --  occur for restrictions that are Checked_max or Checked_Sum.
 224
 225             else
 226                raise Program_Error;
 227             end if;
 228          end if;
 229       end Update_Restrictions;
 230
 231    --  Start of processing for Check_Restriction
 232
 233    begin
 234       if UI_Is_In_Int_Range (V) then
 235          VV := Integer (UI_To_Int (V));
 236       else
 237          VV := -1;
 238       end if;
 239
 240       --  Count can only be specified in the checked val parameter case
 241
 242       pragma Assert (VV < 0 or else R in Checked_Val_Parameter_Restrictions);
 243
 244       --  Nothing to do if value of zero specified for parameter restriction
 245
 246       if VV = 0 then
 247          return;
 248       end if;
 249
 250       --  Update current restrictions
 251
 252       Update_Restrictions (Restrictions);
 253
 254       --  If in main extended unit, update main restrictions as well
 255
 256       if Current_Sem_Unit = Main_Unit
 257         or else In_Extended_Main_Source_Unit (N)
 258       then
 259          Update_Restrictions (Main_Restrictions);
 260       end if;
 261
 262       --  Nothing to do if restriction message suppressed
 263
 264       if Suppress_Restriction_Message (N) then
 265          null;
 266
 267       --  If restriction not set, nothing to do
 268
 269       elsif not Restrictions.Set (R) then
 270          null;
 271
 272       --  Here if restriction set, check for violation (either this is a
 273       --  Boolean restriction, or a parameter restriction with a value of
 274       --  zero and an unknown count, or a parameter restriction with a
 275       --  known value that exceeds the restriction count).
 276
 277       elsif R in All_Boolean_Restrictions
 278         or else (Restrictions.Unknown (R)
 279                    and then Restrictions.Value (R) = 0)
 280         or else Restrictions.Count (R) > Restrictions.Value (R)
 281       then
 282          Error_Msg_Sloc := Restrictions_Loc (R);
 283
 284          --  If we have a location for the Restrictions pragma, output it
 285
 286          if Error_Msg_Sloc > No_Location
 287            or else Error_Msg_Sloc = System_Location
 288          then
 289             if Restriction_Warnings (R) then
 290                Restriction_Msg ("|violation of restriction %#?", Rimage, N);
 291             else
 292                Restriction_Msg ("|violation of restriction %#", Rimage, N);
 293             end if;
 294
 295          --  Otherwise we have the case of an implicit restriction
 296          --  (e.g. a restriction implicitly set by another pragma)
 297
 298          else
 299             Restriction_Msg
 300               ("|violation of implicit restriction %", Rimage, N);
 301          end if;
 302       end if;
 303    end Check_Restriction;
 304
 305    ----------------------------------------
 306    -- Cunit_Boolean_Restrictions_Restore --
 307    ----------------------------------------
 308
 309    procedure Cunit_Boolean_Restrictions_Restore
 310      (R : Save_Cunit_Boolean_Restrictions)
 311    is
 312    begin
 313       for J in Cunit_Boolean_Restrictions loop
 314          Restrictions.Set (J) := R (J);
 315       end loop;
 316    end Cunit_Boolean_Restrictions_Restore;
 317
 318    -------------------------------------
 319    -- Cunit_Boolean_Restrictions_Save --
 320    -------------------------------------
 321
 322    function Cunit_Boolean_Restrictions_Save
 323      return Save_Cunit_Boolean_Restrictions
 324    is
 325       R : Save_Cunit_Boolean_Restrictions;
 326
 327    begin
 328       for J in Cunit_Boolean_Restrictions loop
 329          R (J) := Restrictions.Set (J);
 330          Restrictions.Set (J) := False;
 331       end loop;
 332
 333       return R;
 334    end Cunit_Boolean_Restrictions_Save;
 335
 336    ------------------------
 337    -- Get_Restriction_Id --
 338    ------------------------
 339
 340    function Get_Restriction_Id
 341      (N : Name_Id) return Restriction_Id
 342    is
 343    begin
 344       Get_Name_String (N);
 345       Set_Casing (All_Upper_Case);
 346
 347       for J in All_Restrictions loop
 348          declare
 349             S : constant String := Restriction_Id'Image (J);
 350          begin
 351             if S = Name_Buffer (1 .. Name_Len) then
 352                return J;
 353             end if;
 354          end;
 355       end loop;
 356
 357       return Not_A_Restriction_Id;
 358    end Get_Restriction_Id;
 359
 360    -------------------------------
 361    -- No_Exception_Handlers_Set --
 362    -------------------------------
 363
 364    function No_Exception_Handlers_Set return Boolean is
 365    begin
 366       return Restrictions.Set (No_Exception_Handlers);
 367    end No_Exception_Handlers_Set;
 368
 369    ----------------------------------
 370    -- Process_Restriction_Synonyms --
 371    ----------------------------------
 372
 373    --  Note: body of this function must be coordinated with list of
 374    --  renaming declarations in System.Rident.
 375
 376    function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
 377    is
 378       Old_Name : constant Name_Id := Chars (N);
 379       New_Name : Name_Id;
 380
 381    begin
 382       case Old_Name is
 383          when Name_Boolean_Entry_Barriers =>
 384             New_Name := Name_Simple_Barriers;
 385
 386          when Name_Max_Entry_Queue_Depth =>
 387             New_Name := Name_Max_Entry_Queue_Length;
 388
 389          when Name_No_Dynamic_Interrupts =>
 390             New_Name := Name_No_Dynamic_Attachment;
 391
 392          when Name_No_Requeue =>
 393             New_Name := Name_No_Requeue_Statements;
 394
 395          when Name_No_Task_Attributes =>
 396             New_Name := Name_No_Task_Attributes_Package;
 397
 398          when others =>
 399             return Old_Name;
 400       end case;
 401
 402       if Warn_On_Obsolescent_Feature then
 403          Error_Msg_Name_1 := Old_Name;
 404          Error_Msg_N ("restriction identifier % is obsolescent?", N);
 405          Error_Msg_Name_1 := New_Name;
 406          Error_Msg_N ("|use restriction identifier % instead", N);
 407       end if;
 408
 409       return New_Name;
 410    end Process_Restriction_Synonyms;
 411
 412    ------------------------
 413    -- Restricted_Profile --
 414    ------------------------
 415
 416    function Restricted_Profile return Boolean is
 417    begin
 418       if Restricted_Profile_Cached then
 419          return Restricted_Profile_Result;
 420
 421       else
 422          Restricted_Profile_Result := True;
 423          Restricted_Profile_Cached := True;
 424
 425          declare
 426             R : Restriction_Flags  renames Profile_Info (Restricted).Set;
 427             V : Restriction_Values renames Profile_Info (Restricted).Value;
 428          begin
 429             for J in R'Range loop
 430                if R (J)
 431                  and then (Restrictions.Set (J) = False
 432                              or else Restriction_Warnings (J)
 433                              or else
 434                                (J in All_Parameter_Restrictions
 435                                   and then Restrictions.Value (J) > V (J)))
 436                then
 437                   Restricted_Profile_Result := False;
 438                   exit;
 439                end if;
 440             end loop;
 441
 442             return Restricted_Profile_Result;
 443          end;
 444       end if;
 445    end Restricted_Profile;
 446
 447    ------------------------
 448    -- Restriction_Active --
 449    ------------------------
 450
 451    function Restriction_Active (R : All_Restrictions) return Boolean is
 452    begin
 453       return Restrictions.Set (R);
 454    end Restriction_Active;
 455
 456    ---------------------
 457    -- Restriction_Msg --
 458    ---------------------
 459
 460    procedure Restriction_Msg (Msg : String; R : String; N : Node_Id) is
 461       B : String (1 .. Msg'Length + 2 * R'Length + 1);
 462       P : Natural := 1;
 463
 464    begin
 465       Name_Buffer (1 .. R'Last) := R;
 466       Name_Len := R'Length;
 467       Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
 468
 469       P := 0;
 470       for J in Msg'Range loop
 471          if Msg (J) = '%' then
 472             P := P + 1;
 473             B (P) := '`';
 474
 475             --  Put characters of image in message, quoting upper case letters
 476
 477             for J in 1 .. Name_Len loop
 478                if Name_Buffer (J) in 'A' .. 'Z' then
 479                   P := P + 1;
 480                   B (P) := ''';
 481                end if;
 482
 483                P := P + 1;
 484                B (P) := Name_Buffer (J);
 485             end loop;
 486
 487             P := P + 1;
 488             B (P) := '`';
 489
 490          else
 491             P := P + 1;
 492             B (P) := Msg (J);
 493          end if;
 494       end loop;
 495
 496       Error_Msg_N (B (1 .. P), N);
 497    end Restriction_Msg;
 498
 499    ------------------------------
 500    -- Set_Profile_Restrictions --
 501    ------------------------------
 502
 503    procedure Set_Profile_Restrictions
 504      (P    : Profile_Name;
 505       N    : Node_Id;
 506       Warn : Boolean)
 507    is
 508       R : Restriction_Flags  renames Profile_Info (P).Set;
 509       V : Restriction_Values renames Profile_Info (P).Value;
 510
 511    begin
 512       for J in R'Range loop
 513          if R (J) then
 514             if J in All_Boolean_Restrictions then
 515                Set_Restriction (J, N);
 516             else
 517                Set_Restriction (J, N, V (J));
 518             end if;
 519
 520             Restriction_Warnings (J) := Warn;
 521          end if;
 522       end loop;
 523    end Set_Profile_Restrictions;
 524
 525    ---------------------
 526    -- Set_Restriction --
 527    ---------------------
 528
 529    --  Case of Boolean restriction
 530
 531    procedure Set_Restriction
 532      (R : All_Boolean_Restrictions;
 533       N : Node_Id)
 534    is
 535    begin
 536       Restrictions.Set (R) := True;
 537
 538       if Restricted_Profile_Cached and Restricted_Profile_Result then
 539          null;
 540       else
 541          Restricted_Profile_Cached := False;
 542       end if;
 543
 544       --  Set location, but preserve location of system
 545       --  restriction for nice error msg with run time name
 546
 547       if Restrictions_Loc (R) /= System_Location then
 548          Restrictions_Loc (R) := Sloc (N);
 549       end if;
 550
 551       --  Record the restriction if we are in the main unit,
 552       --  or in the extended main unit. The reason that we
 553       --  test separately for Main_Unit is that gnat.adc is
 554       --  processed with Current_Sem_Unit = Main_Unit, but
 555       --  nodes in gnat.adc do not appear to be the extended
 556       --  main source unit (they probably should do ???)
 557
 558       if Current_Sem_Unit = Main_Unit
 559         or else In_Extended_Main_Source_Unit (N)
 560       then
 561          if not Restriction_Warnings (R) then
 562             Main_Restrictions.Set (R) := True;
 563          end if;
 564       end if;
 565    end Set_Restriction;
 566
 567    --  Case of parameter restriction
 568
 569    procedure Set_Restriction
 570      (R : All_Parameter_Restrictions;
 571       N : Node_Id;
 572       V : Integer)
 573    is
 574    begin
 575       if Restricted_Profile_Cached and Restricted_Profile_Result then
 576          null;
 577       else
 578          Restricted_Profile_Cached := False;
 579       end if;
 580
 581       if Restrictions.Set (R) then
 582          if V < Restrictions.Value (R) then
 583             Restrictions.Value (R) := V;
 584             Restrictions_Loc (R) := Sloc (N);
 585          end if;
 586
 587       else
 588          Restrictions.Set (R) := True;
 589          Restrictions.Value (R) := V;
 590          Restrictions_Loc (R) := Sloc (N);
 591       end if;
 592
 593       --  Record the restriction if we are in the main unit,
 594       --  or in the extended main unit. The reason that we
 595       --  test separately for Main_Unit is that gnat.adc is
 596       --  processed with Current_Sem_Unit = Main_Unit, but
 597       --  nodes in gnat.adc do not appear to be the extended
 598       --  main source unit (they probably should do ???)
 599
 600       if Current_Sem_Unit = Main_Unit
 601         or else In_Extended_Main_Source_Unit (N)
 602       then
 603          if Main_Restrictions.Set (R) then
 604             if V < Main_Restrictions.Value (R) then
 605                Main_Restrictions.Value (R) := V;
 606             end if;
 607
 608          elsif not Restriction_Warnings (R) then
 609             Main_Restrictions.Set (R) := True;
 610             Main_Restrictions.Value (R) := V;
 611          end if;
 612       end if;
 613    end Set_Restriction;
 614
 615    ----------------------------------
 616    -- Suppress_Restriction_Message --
 617    ----------------------------------
 618
 619    function Suppress_Restriction_Message (N : Node_Id) return Boolean is
 620    begin
 621       --  We only output messages for the extended main source unit
 622
 623       if In_Extended_Main_Source_Unit (N) then
 624          return False;
 625
 626       --  If loaded by rtsfind, then suppress message
 627
 628       elsif Sloc (N) <= No_Location then
 629          return True;
 630
 631       --  Otherwise suppress message if internal file
 632
 633       else
 634          return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
 635       end if;
 636    end Suppress_Restriction_Message;
 637
 638    ---------------------
 639    -- Tasking_Allowed --
 640    ---------------------
 641
 642    function Tasking_Allowed return Boolean is
 643    begin
 644       return not Restrictions.Set (No_Tasking)
 645         and then (not Restrictions.Set (Max_Tasks)
 646                     or else Restrictions.Value (Max_Tasks) > 0);
 647    end Tasking_Allowed;
 648
 649 end Restrict;