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 --                                                                          --
  10 --          Copyright (C) 1992-2002 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Atree;    use Atree;
  29 with Casing;   use Casing;
  30 with Errout;   use Errout;
  31 with Exp_Util; use Exp_Util;
  32 with Fname;    use Fname;
  33 with Fname.UF; use Fname.UF;
  34 with Lib;      use Lib;
  35 with Namet;    use Namet;
  36 with Opt;      use Opt;
  37 with Stand;    use Stand;
  38 with Targparm; use Targparm;
  39 with Tbuild;   use Tbuild;
  40 with Uname;    use Uname;
  41
  42 package body Restrict is
  43
  44    function Suppress_Restriction_Message (N : Node_Id) return Boolean;
  45    --  N is the node for a possible restriction violation message, but
  46    --  the message is to be suppressed if this is an internal file and
  47    --  this file is not the main unit.
  48
  49    -------------------
  50    -- Abort_Allowed --
  51    -------------------
  52
  53    function Abort_Allowed return Boolean is
  54    begin
  55       return
  56         Restrictions (No_Abort_Statements) = False
  57           or else
  58         Restriction_Parameters (Max_Asynchronous_Select_Nesting) /= 0;
  59    end Abort_Allowed;
  60
  61    ------------------------------------
  62    -- Check_Elaboration_Code_Allowed --
  63    ------------------------------------
  64
  65    procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
  66    begin
  67       --  Avoid calling Namet.Unlock/Lock except when there is an error.
  68       --  Even in the error case it is a bit dubious, either gigi needs
  69       --  the table locked or it does not! ???
  70
  71       if Restrictions (No_Elaboration_Code)
  72         and then not Suppress_Restriction_Message (N)
  73       then
  74          Namet.Unlock;
  75          Check_Restriction (No_Elaboration_Code, N);
  76          Namet.Lock;
  77       end if;
  78    end Check_Elaboration_Code_Allowed;
  79
  80    ---------------------------
  81    -- Check_Restricted_Unit --
  82    ---------------------------
  83
  84    procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
  85    begin
  86       if Suppress_Restriction_Message (N) then
  87          return;
  88
  89       elsif Is_Spec_Name (U) then
  90          declare
  91             Fnam : constant File_Name_Type :=
  92                      Get_File_Name (U, Subunit => False);
  93             R_Id : Restriction_Id;
  94
  95          begin
  96             if not Is_Predefined_File_Name (Fnam) then
  97                return;
  98
  99             --  Ada child unit spec, needs checking against list
 100
 101             else
 102                --  Pad name to 8 characters with blanks
 103
 104                Get_Name_String (Fnam);
 105                Name_Len := Name_Len - 4;
 106
 107                while Name_Len < 8 loop
 108                   Name_Len := Name_Len + 1;
 109                   Name_Buffer (Name_Len) := ' ';
 110                end loop;
 111
 112                for J in Unit_Array'Range loop
 113                   if Name_Len = 8
 114                     and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
 115                   then
 116                      R_Id := Unit_Array (J).Res_Id;
 117                      Violations (R_Id) := True;
 118
 119                      if Restrictions (R_Id) then
 120                         declare
 121                            S : constant String := Restriction_Id'Image (R_Id);
 122
 123                         begin
 124                            Error_Msg_Unit_1 := U;
 125
 126                            Error_Msg_N
 127                              ("|dependence on $ not allowed,", N);
 128
 129                            Name_Buffer (1 .. S'Last) := S;
 130                            Name_Len := S'Length;
 131                            Set_Casing (All_Lower_Case);
 132                            Error_Msg_Name_1 := Name_Enter;
 133                            Error_Msg_Sloc := Restrictions_Loc (R_Id);
 134
 135                            Error_Msg_N
 136                              ("\|violates pragma Restriction (%) #", N);
 137                            return;
 138                         end;
 139                      end if;
 140                   end if;
 141                end loop;
 142             end if;
 143          end;
 144       end if;
 145    end Check_Restricted_Unit;
 146
 147    -----------------------
 148    -- Check_Restriction --
 149    -----------------------
 150
 151    --  Case of simple identifier (no parameter)
 152
 153    procedure Check_Restriction (R : Restriction_Id; N : Node_Id) is
 154    begin
 155       Violations (R) := True;
 156
 157       if Restrictions (R)
 158         and then not Suppress_Restriction_Message (N)
 159       then
 160          declare
 161             S : constant String := Restriction_Id'Image (R);
 162
 163          begin
 164             Name_Buffer (1 .. S'Last) := S;
 165             Name_Len := S'Length;
 166             Set_Casing (All_Lower_Case);
 167             Error_Msg_Name_1 := Name_Enter;
 168             Error_Msg_Sloc := Restrictions_Loc (R);
 169             Error_Msg_N ("|violation of restriction %#", N);
 170          end;
 171       end if;
 172    end Check_Restriction;
 173
 174    --  Case where a parameter is present (but no count)
 175
 176    procedure Check_Restriction
 177      (R : Restriction_Parameter_Id;
 178       N : Node_Id)
 179    is
 180    begin
 181       if Restriction_Parameters (R) = Uint_0
 182         and then not Suppress_Restriction_Message (N)
 183       then
 184          declare
 185             Loc : constant Source_Ptr := Sloc (N);
 186             S   : constant String :=
 187                     Restriction_Parameter_Id'Image (R);
 188
 189          begin
 190             Error_Msg_NE
 191               ("& will be raised at run time?!", N, Standard_Storage_Error);
 192             Name_Buffer (1 .. S'Last) := S;
 193             Name_Len := S'Length;
 194             Set_Casing (All_Lower_Case);
 195             Error_Msg_Name_1 := Name_Enter;
 196             Error_Msg_Sloc := Restriction_Parameters_Loc (R);
 197             Error_Msg_N ("violation of restriction %?#!", N);
 198
 199             Insert_Action (N,
 200               Make_Raise_Storage_Error (Loc,
 201                 Reason => SE_Restriction_Violation));
 202          end;
 203       end if;
 204    end Check_Restriction;
 205
 206    --  Case where a parameter is present, with a count
 207
 208    procedure Check_Restriction
 209      (R : Restriction_Parameter_Id;
 210       V : Uint;
 211       N : Node_Id)
 212    is
 213    begin
 214       if Restriction_Parameters (R) /= No_Uint
 215         and then V > Restriction_Parameters (R)
 216         and then not Suppress_Restriction_Message (N)
 217       then
 218          declare
 219             S : constant String := Restriction_Parameter_Id'Image (R);
 220
 221          begin
 222             Name_Buffer (1 .. S'Last) := S;
 223             Name_Len := S'Length;
 224             Set_Casing (All_Lower_Case);
 225             Error_Msg_Name_1 := Name_Enter;
 226             Error_Msg_Sloc := Restriction_Parameters_Loc (R);
 227             Error_Msg_N ("|maximum value exceeded for restriction %#", N);
 228          end;
 229       end if;
 230    end Check_Restriction;
 231
 232    -------------------------------------------
 233    -- Compilation_Unit_Restrictions_Restore --
 234    -------------------------------------------
 235
 236    procedure Compilation_Unit_Restrictions_Restore
 237      (R : Save_Compilation_Unit_Restrictions)
 238    is
 239    begin
 240       for J in Compilation_Unit_Restrictions loop
 241          Restrictions (J) := R (J);
 242       end loop;
 243    end Compilation_Unit_Restrictions_Restore;
 244
 245    ----------------------------------------
 246    -- Compilation_Unit_Restrictions_Save --
 247    ----------------------------------------
 248
 249    function Compilation_Unit_Restrictions_Save
 250      return Save_Compilation_Unit_Restrictions
 251    is
 252       R : Save_Compilation_Unit_Restrictions;
 253
 254    begin
 255       for J in Compilation_Unit_Restrictions loop
 256          R (J) := Restrictions (J);
 257          Restrictions (J) := False;
 258       end loop;
 259
 260       return R;
 261    end Compilation_Unit_Restrictions_Save;
 262
 263    ----------------------------------
 264    -- Disallow_In_No_Run_Time_Mode --
 265    ----------------------------------
 266
 267    procedure Disallow_In_No_Run_Time_Mode (Enode : Node_Id) is
 268    begin
 269       if No_Run_Time then
 270          if High_Integrity_Mode_On_Target then
 271             Error_Msg_N
 272               ("|this construct not allowed in high integrity mode", Enode);
 273          else
 274             Error_Msg_N
 275               ("|this construct not allowed in No_Run_Time mode", Enode);
 276          end if;
 277       end if;
 278    end Disallow_In_No_Run_Time_Mode;
 279
 280    ------------------------
 281    -- Get_Restriction_Id --
 282    ------------------------
 283
 284    function Get_Restriction_Id
 285      (N    : Name_Id)
 286       return Restriction_Id
 287    is
 288       J : Restriction_Id;
 289
 290    begin
 291       Get_Name_String (N);
 292       Set_Casing (All_Upper_Case);
 293
 294       J := Restriction_Id'First;
 295       while J /= Not_A_Restriction_Id loop
 296          declare
 297             S : constant String := Restriction_Id'Image (J);
 298
 299          begin
 300             exit when S = Name_Buffer (1 .. Name_Len);
 301          end;
 302
 303          J := Restriction_Id'Succ (J);
 304       end loop;
 305
 306       return J;
 307    end Get_Restriction_Id;
 308
 309    ----------------------------------
 310    -- Get_Restriction_Parameter_Id --
 311    ----------------------------------
 312
 313    function Get_Restriction_Parameter_Id
 314      (N    : Name_Id)
 315       return Restriction_Parameter_Id
 316    is
 317       J : Restriction_Parameter_Id;
 318
 319    begin
 320       Get_Name_String (N);
 321       Set_Casing (All_Upper_Case);
 322
 323       J := Restriction_Parameter_Id'First;
 324       while J /= Not_A_Restriction_Parameter_Id loop
 325          declare
 326             S : constant String := Restriction_Parameter_Id'Image (J);
 327
 328          begin
 329             exit when S = Name_Buffer (1 .. Name_Len);
 330          end;
 331
 332          J := Restriction_Parameter_Id'Succ (J);
 333       end loop;
 334
 335       return J;
 336    end Get_Restriction_Parameter_Id;
 337
 338    -------------------------------
 339    -- No_Exception_Handlers_Set --
 340    -------------------------------
 341
 342    function No_Exception_Handlers_Set return Boolean is
 343    begin
 344       return Restrictions (No_Exception_Handlers);
 345    end No_Exception_Handlers_Set;
 346
 347    ------------------------
 348    -- Restricted_Profile --
 349    ------------------------
 350
 351    --  This implementation must be coordinated with Set_Restricted_Profile
 352
 353    function Restricted_Profile return Boolean is
 354    begin
 355       return     Restrictions (No_Abort_Statements)
 356         and then Restrictions (No_Asynchronous_Control)
 357         and then Restrictions (No_Entry_Queue)
 358         and then Restrictions (No_Task_Hierarchy)
 359         and then Restrictions (No_Task_Allocators)
 360         and then Restrictions (No_Dynamic_Priorities)
 361         and then Restrictions (No_Terminate_Alternatives)
 362         and then Restrictions (No_Dynamic_Interrupts)
 363         and then Restrictions (No_Protected_Type_Allocators)
 364         and then Restrictions (No_Local_Protected_Objects)
 365         and then Restrictions (No_Requeue)
 366         and then Restrictions (No_Task_Attributes)
 367         and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) =  0
 368         and then Restriction_Parameters (Max_Task_Entries)                =  0
 369         and then Restriction_Parameters (Max_Protected_Entries)           <= 1
 370         and then Restriction_Parameters (Max_Select_Alternatives)         =  0;
 371    end Restricted_Profile;
 372
 373    --------------------------
 374    -- Set_No_Run_Time_Mode --
 375    --------------------------
 376
 377    procedure Set_No_Run_Time_Mode is
 378    begin
 379       No_Run_Time := True;
 380       Restrictions (No_Exception_Handlers) := True;
 381       Restrictions (No_Implicit_Dynamic_Code) := True;
 382       Opt.Global_Discard_Names := True;
 383    end Set_No_Run_Time_Mode;
 384
 385    -------------------
 386    -- Set_Ravenscar --
 387    -------------------
 388
 389    procedure Set_Ravenscar is
 390    begin
 391       Set_Restricted_Profile;
 392       Restrictions (Boolean_Entry_Barriers)       := True;
 393       Restrictions (No_Select_Statements)         := True;
 394       Restrictions (No_Calendar)                  := True;
 395       Restrictions (Static_Storage_Size)          := True;
 396       Restrictions (No_Entry_Queue)               := True;
 397       Restrictions (No_Relative_Delay)            := True;
 398       Restrictions (No_Task_Termination)          := True;
 399       Restrictions (No_Implicit_Heap_Allocations) := True;
 400    end Set_Ravenscar;
 401
 402    ----------------------------
 403    -- Set_Restricted_Profile --
 404    ----------------------------
 405
 406    --  This must be coordinated with Restricted_Profile
 407
 408    procedure Set_Restricted_Profile is
 409    begin
 410       Restrictions (No_Abort_Statements)          := True;
 411       Restrictions (No_Asynchronous_Control)      := True;
 412       Restrictions (No_Entry_Queue)               := True;
 413       Restrictions (No_Task_Hierarchy)            := True;
 414       Restrictions (No_Task_Allocators)           := True;
 415       Restrictions (No_Dynamic_Priorities)        := True;
 416       Restrictions (No_Terminate_Alternatives)    := True;
 417       Restrictions (No_Dynamic_Interrupts)        := True;
 418       Restrictions (No_Protected_Type_Allocators) := True;
 419       Restrictions (No_Local_Protected_Objects)   := True;
 420       Restrictions (No_Requeue)                   := True;
 421       Restrictions (No_Task_Attributes)           := True;
 422
 423       Restriction_Parameters (Max_Asynchronous_Select_Nesting) :=  Uint_0;
 424       Restriction_Parameters (Max_Task_Entries)                :=  Uint_0;
 425       Restriction_Parameters (Max_Select_Alternatives)         :=  Uint_0;
 426
 427       if Restriction_Parameters (Max_Protected_Entries) /= Uint_0 then
 428          Restriction_Parameters (Max_Protected_Entries) := Uint_1;
 429       end if;
 430    end Set_Restricted_Profile;
 431
 432    ----------------------------------
 433    -- Suppress_Restriction_Message --
 434    ----------------------------------
 435
 436    function Suppress_Restriction_Message (N : Node_Id) return Boolean is
 437    begin
 438       --  We only output messages for the extended main source unit
 439
 440       if In_Extended_Main_Source_Unit (N) then
 441          return False;
 442
 443       --  If loaded by rtsfind, then suppress message
 444
 445       elsif Sloc (N) <= No_Location then
 446          return True;
 447
 448       --  Otherwise suppress message if internal file
 449
 450       else
 451          return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
 452       end if;
 453    end Suppress_Restriction_Message;
 454
 455    ---------------------
 456    -- Tasking_Allowed --
 457    ---------------------
 458
 459    function Tasking_Allowed return Boolean is
 460    begin
 461       return Restriction_Parameters (Max_Tasks) /= 0;
 462    end Tasking_Allowed;
 463
 464 end Restrict;