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