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