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 --                            $Revision: 1.37 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Atree;    use Atree;
  30 with Casing;   use Casing;
  31 with Errout;   use Errout;
  32 with Exp_Util; use Exp_Util;
  33 with Fname;    use Fname;
  34 with Fname.UF; use Fname.UF;
  35 with Lib;      use Lib;
  36 with Namet;    use Namet;
  37 with Nmake;    use Nmake;
  38 with Opt;      use Opt;
  39 with Stand;    use Stand;
  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          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          Error_Msg_N
 270            ("this construct not allowed in No_Run_Time mode", Enode);
 271       end if;
 272    end Disallow_In_No_Run_Time_Mode;
 273
 274    ------------------------
 275    -- Get_Restriction_Id --
 276    ------------------------
 277
 278    function Get_Restriction_Id
 279      (N    : Name_Id)
 280       return Restriction_Id
 281    is
 282       J : Restriction_Id;
 283
 284    begin
 285       Get_Name_String (N);
 286       Set_Casing (All_Upper_Case);
 287
 288       J := Restriction_Id'First;
 289       while J /= Not_A_Restriction_Id loop
 290          declare
 291             S : constant String := Restriction_Id'Image (J);
 292
 293          begin
 294             exit when S = Name_Buffer (1 .. Name_Len);
 295          end;
 296
 297          J := Restriction_Id'Succ (J);
 298       end loop;
 299
 300       return J;
 301    end Get_Restriction_Id;
 302
 303    ----------------------------------
 304    -- Get_Restriction_Parameter_Id --
 305    ----------------------------------
 306
 307    function Get_Restriction_Parameter_Id
 308      (N    : Name_Id)
 309       return Restriction_Parameter_Id
 310    is
 311       J : Restriction_Parameter_Id;
 312
 313    begin
 314       Get_Name_String (N);
 315       Set_Casing (All_Upper_Case);
 316
 317       J := Restriction_Parameter_Id'First;
 318       while J /= Not_A_Restriction_Parameter_Id loop
 319          declare
 320             S : constant String := Restriction_Parameter_Id'Image (J);
 321
 322          begin
 323             exit when S = Name_Buffer (1 .. Name_Len);
 324          end;
 325
 326          J := Restriction_Parameter_Id'Succ (J);
 327       end loop;
 328
 329       return J;
 330    end Get_Restriction_Parameter_Id;
 331
 332    -------------------------------
 333    -- No_Exception_Handlers_Set --
 334    -------------------------------
 335
 336    function No_Exception_Handlers_Set return Boolean is
 337    begin
 338       return Restrictions (No_Exception_Handlers);
 339    end No_Exception_Handlers_Set;
 340
 341    ------------------------
 342    -- Restricted_Profile --
 343    ------------------------
 344
 345    --  This implementation must be coordinated with Set_Restricted_Profile
 346
 347    function Restricted_Profile return Boolean is
 348    begin
 349       return     Restrictions (No_Abort_Statements)
 350         and then Restrictions (No_Asynchronous_Control)
 351         and then Restrictions (No_Entry_Queue)
 352         and then Restrictions (No_Task_Hierarchy)
 353         and then Restrictions (No_Task_Allocators)
 354         and then Restrictions (No_Dynamic_Priorities)
 355         and then Restrictions (No_Terminate_Alternatives)
 356         and then Restrictions (No_Dynamic_Interrupts)
 357         and then Restrictions (No_Protected_Type_Allocators)
 358         and then Restrictions (No_Local_Protected_Objects)
 359         and then Restrictions (No_Requeue)
 360         and then Restrictions (No_Task_Attributes)
 361         and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) =  0
 362         and then Restriction_Parameters (Max_Task_Entries)                =  0
 363         and then Restriction_Parameters (Max_Protected_Entries)           <= 1
 364         and then Restriction_Parameters (Max_Select_Alternatives)         =  0;
 365    end Restricted_Profile;
 366
 367    --------------------------
 368    -- Set_No_Run_Time_Mode --
 369    --------------------------
 370
 371    procedure Set_No_Run_Time_Mode is
 372    begin
 373       No_Run_Time := True;
 374       Restrictions (No_Exception_Handlers) := True;
 375    end Set_No_Run_Time_Mode;
 376
 377    -------------------
 378    -- Set_Ravenscar --
 379    -------------------
 380
 381    procedure Set_Ravenscar is
 382    begin
 383       Set_Restricted_Profile;
 384       Restrictions (Boolean_Entry_Barriers)       := True;
 385       Restrictions (No_Select_Statements)         := True;
 386       Restrictions (No_Calendar)                  := True;
 387       Restrictions (Static_Storage_Size)          := True;
 388       Restrictions (No_Entry_Queue)               := True;
 389       Restrictions (No_Relative_Delay)            := True;
 390       Restrictions (No_Task_Termination)          := True;
 391       Restrictions (No_Implicit_Heap_Allocations) := True;
 392    end Set_Ravenscar;
 393
 394    ----------------------------
 395    -- Set_Restricted_Profile --
 396    ----------------------------
 397
 398    --  This must be coordinated with Restricted_Profile
 399
 400    procedure Set_Restricted_Profile is
 401    begin
 402       Restrictions (No_Abort_Statements)          := True;
 403       Restrictions (No_Asynchronous_Control)      := True;
 404       Restrictions (No_Entry_Queue)               := True;
 405       Restrictions (No_Task_Hierarchy)            := True;
 406       Restrictions (No_Task_Allocators)           := True;
 407       Restrictions (No_Dynamic_Priorities)        := True;
 408       Restrictions (No_Terminate_Alternatives)    := True;
 409       Restrictions (No_Dynamic_Interrupts)        := True;
 410       Restrictions (No_Protected_Type_Allocators) := True;
 411       Restrictions (No_Local_Protected_Objects)   := True;
 412       Restrictions (No_Requeue)                   := True;
 413       Restrictions (No_Task_Attributes)           := True;
 414
 415       Restriction_Parameters (Max_Asynchronous_Select_Nesting) :=  Uint_0;
 416       Restriction_Parameters (Max_Task_Entries)                :=  Uint_0;
 417       Restriction_Parameters (Max_Select_Alternatives)         :=  Uint_0;
 418
 419       if Restriction_Parameters (Max_Protected_Entries) /= Uint_0 then
 420          Restriction_Parameters (Max_Protected_Entries) := Uint_1;
 421       end if;
 422    end Set_Restricted_Profile;
 423
 424    ----------------------------------
 425    -- Suppress_Restriction_Message --
 426    ----------------------------------
 427
 428    function Suppress_Restriction_Message (N : Node_Id) return Boolean is
 429    begin
 430       --  If main unit is library unit, then we will output message
 431
 432       if In_Extended_Main_Source_Unit (N) then
 433          return False;
 434
 435       --  If loaded by rtsfind, then suppress message
 436
 437       elsif Sloc (N) <= No_Location then
 438          return True;
 439
 440       --  Otherwise suppress message if internal file
 441
 442       else
 443          return
 444            Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
 445       end if;
 446    end Suppress_Restriction_Message;
 447
 448    ---------------------
 449    -- Tasking_Allowed --
 450    ---------------------
 451
 452    function Tasking_Allowed return Boolean is
 453    begin
 454       return
 455         Restriction_Parameters (Max_Tasks) /= 0;
 456    end Tasking_Allowed;
 457
 458 end Restrict;