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$
  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 Targparm; use Targparm;
  41 with Uname;    use Uname;
  42
  43 package body Restrict is
  44
  45    function Suppress_Restriction_Message (N : Node_Id) return Boolean;
  46    --  N is the node for a possible restriction violation message, but
  47    --  the message is to be suppressed if this is an internal file and
  48    --  this file is not the main unit.
  49
  50    -------------------
  51    -- Abort_Allowed --
  52    -------------------
  53
  54    function Abort_Allowed return Boolean is
  55    begin
  56       return
  57         Restrictions (No_Abort_Statements) = False
  58           or else
  59         Restriction_Parameters (Max_Asynchronous_Select_Nesting) /= 0;
  60    end Abort_Allowed;
  61
  62    ------------------------------------
  63    -- Check_Elaboration_Code_Allowed --
  64    ------------------------------------
  65
  66    procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
  67    begin
  68       --  Avoid calling Namet.Unlock/Lock except when there is an error.
  69       --  Even in the error case it is a bit dubious, either gigi needs
  70       --  the table locked or it does not! ???
  71
  72       if Restrictions (No_Elaboration_Code)
  73         and then not Suppress_Restriction_Message (N)
  74       then
  75          Namet.Unlock;
  76          Check_Restriction (No_Elaboration_Code, N);
  77          Namet.Lock;
  78       end if;
  79    end Check_Elaboration_Code_Allowed;
  80
  81    ---------------------------
  82    -- Check_Restricted_Unit --
  83    ---------------------------
  84
  85    procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
  86    begin
  87       if Suppress_Restriction_Message (N) then
  88          return;
  89
  90       elsif Is_Spec_Name (U) then
  91          declare
  92             Fnam : constant File_Name_Type :=
  93                      Get_File_Name (U, Subunit => False);
  94             R_Id : Restriction_Id;
  95
  96          begin
  97             if not Is_Predefined_File_Name (Fnam) then
  98                return;
  99
 100             --  Ada child unit spec, needs checking against list
 101
 102             else
 103                --  Pad name to 8 characters with blanks
 104
 105                Get_Name_String (Fnam);
 106                Name_Len := Name_Len - 4;
 107
 108                while Name_Len < 8 loop
 109                   Name_Len := Name_Len + 1;
 110                   Name_Buffer (Name_Len) := ' ';
 111                end loop;
 112
 113                for J in Unit_Array'Range loop
 114                   if Name_Len = 8
 115                     and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
 116                   then
 117                      R_Id := Unit_Array (J).Res_Id;
 118                      Violations (R_Id) := True;
 119
 120                      if Restrictions (R_Id) then
 121                         declare
 122                            S : constant String := Restriction_Id'Image (R_Id);
 123
 124                         begin
 125                            Error_Msg_Unit_1 := U;
 126
 127                            Error_Msg_N
 128                              ("dependence on $ not allowed,", N);
 129
 130                            Name_Buffer (1 .. S'Last) := S;
 131                            Name_Len := S'Length;
 132                            Set_Casing (All_Lower_Case);
 133                            Error_Msg_Name_1 := Name_Enter;
 134                            Error_Msg_Sloc := Restrictions_Loc (R_Id);
 135
 136                            Error_Msg_N
 137                              ("\violates pragma Restriction (%) #", N);
 138                            return;
 139                         end;
 140                      end if;
 141                   end if;
 142                end loop;
 143             end if;
 144          end;
 145       end if;
 146    end Check_Restricted_Unit;
 147
 148    -----------------------
 149    -- Check_Restriction --
 150    -----------------------
 151
 152    --  Case of simple identifier (no parameter)
 153
 154    procedure Check_Restriction (R : Restriction_Id; N : Node_Id) is
 155    begin
 156       Violations (R) := True;
 157
 158       if Restrictions (R)
 159         and then not Suppress_Restriction_Message (N)
 160       then
 161          declare
 162             S : constant String := Restriction_Id'Image (R);
 163
 164          begin
 165             Name_Buffer (1 .. S'Last) := S;
 166             Name_Len := S'Length;
 167             Set_Casing (All_Lower_Case);
 168             Error_Msg_Name_1 := Name_Enter;
 169             Error_Msg_Sloc := Restrictions_Loc (R);
 170             Error_Msg_N ("violation of restriction %#", N);
 171          end;
 172       end if;
 173    end Check_Restriction;
 174
 175    --  Case where a parameter is present (but no count)
 176
 177    procedure Check_Restriction
 178      (R : Restriction_Parameter_Id;
 179       N : Node_Id)
 180    is
 181    begin
 182       if Restriction_Parameters (R) = Uint_0
 183         and then not Suppress_Restriction_Message (N)
 184       then
 185          declare
 186             Loc : constant Source_Ptr := Sloc (N);
 187             S   : constant String :=
 188                     Restriction_Parameter_Id'Image (R);
 189
 190          begin
 191             Error_Msg_NE
 192               ("& will be raised at run time?!", N, Standard_Storage_Error);
 193             Name_Buffer (1 .. S'Last) := S;
 194             Name_Len := S'Length;
 195             Set_Casing (All_Lower_Case);
 196             Error_Msg_Name_1 := Name_Enter;
 197             Error_Msg_Sloc := Restriction_Parameters_Loc (R);
 198             Error_Msg_N ("violation of restriction %?#!", N);
 199
 200             Insert_Action (N,
 201               Make_Raise_Storage_Error (Loc));
 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    end Set_No_Run_Time_Mode;
 382
 383    -------------------
 384    -- Set_Ravenscar --
 385    -------------------
 386
 387    procedure Set_Ravenscar is
 388    begin
 389       Set_Restricted_Profile;
 390       Restrictions (Boolean_Entry_Barriers)       := True;
 391       Restrictions (No_Select_Statements)         := True;
 392       Restrictions (No_Calendar)                  := True;
 393       Restrictions (Static_Storage_Size)          := True;
 394       Restrictions (No_Entry_Queue)               := True;
 395       Restrictions (No_Relative_Delay)            := True;
 396       Restrictions (No_Task_Termination)          := True;
 397       Restrictions (No_Implicit_Heap_Allocations) := True;
 398    end Set_Ravenscar;
 399
 400    ----------------------------
 401    -- Set_Restricted_Profile --
 402    ----------------------------
 403
 404    --  This must be coordinated with Restricted_Profile
 405
 406    procedure Set_Restricted_Profile is
 407    begin
 408       Restrictions (No_Abort_Statements)          := True;
 409       Restrictions (No_Asynchronous_Control)      := True;
 410       Restrictions (No_Entry_Queue)               := True;
 411       Restrictions (No_Task_Hierarchy)            := True;
 412       Restrictions (No_Task_Allocators)           := True;
 413       Restrictions (No_Dynamic_Priorities)        := True;
 414       Restrictions (No_Terminate_Alternatives)    := True;
 415       Restrictions (No_Dynamic_Interrupts)        := True;
 416       Restrictions (No_Protected_Type_Allocators) := True;
 417       Restrictions (No_Local_Protected_Objects)   := True;
 418       Restrictions (No_Requeue)                   := True;
 419       Restrictions (No_Task_Attributes)           := True;
 420
 421       Restriction_Parameters (Max_Asynchronous_Select_Nesting) :=  Uint_0;
 422       Restriction_Parameters (Max_Task_Entries)                :=  Uint_0;
 423       Restriction_Parameters (Max_Select_Alternatives)         :=  Uint_0;
 424
 425       if Restriction_Parameters (Max_Protected_Entries) /= Uint_0 then
 426          Restriction_Parameters (Max_Protected_Entries) := Uint_1;
 427       end if;
 428    end Set_Restricted_Profile;
 429
 430    ----------------------------------
 431    -- Suppress_Restriction_Message --
 432    ----------------------------------
 433
 434    function Suppress_Restriction_Message (N : Node_Id) return Boolean is
 435    begin
 436       --  If main unit is library unit, then we will output message
 437
 438       if In_Extended_Main_Source_Unit (N) then
 439          return False;
 440
 441       --  If loaded by rtsfind, then suppress message
 442
 443       elsif Sloc (N) <= No_Location then
 444          return True;
 445
 446       --  Otherwise suppress message if internal file
 447
 448       else
 449          return
 450            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
 461         Restriction_Parameters (Max_Tasks) /= 0;
 462    end Tasking_Allowed;
 463
 464 end Restrict;