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-2003 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 (No_Abort_Statements)
  63         and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) = 0
  64       then
  65          return False;
  66
  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 (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             R_Id : Restriction_Id;
 114
 115          begin
 116             if not Is_Predefined_File_Name (Fnam) then
 117                return;
 118
 119             --  Ada child unit spec, needs checking against list
 120
 121             else
 122                --  Pad name to 8 characters with blanks
 123
 124                Get_Name_String (Fnam);
 125                Name_Len := Name_Len - 4;
 126
 127                while Name_Len < 8 loop
 128                   Name_Len := Name_Len + 1;
 129                   Name_Buffer (Name_Len) := ' ';
 130                end loop;
 131
 132                for J in Unit_Array'Range loop
 133                   if Name_Len = 8
 134                     and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
 135                   then
 136                      R_Id := Unit_Array (J).Res_Id;
 137                      Violations (R_Id) := True;
 138
 139                      if Restrictions (R_Id) then
 140                         declare
 141                            S : constant String := Restriction_Id'Image (R_Id);
 142
 143                         begin
 144                            Error_Msg_Unit_1 := U;
 145
 146                            Error_Msg_N
 147                              ("|dependence on $ not allowed,", N);
 148
 149                            Name_Buffer (1 .. S'Last) := S;
 150                            Name_Len := S'Length;
 151                            Set_Casing (All_Lower_Case);
 152                            Error_Msg_Name_1 := Name_Enter;
 153                            Error_Msg_Sloc := Restrictions_Loc (R_Id);
 154
 155                            Error_Msg_N
 156                              ("\|violates pragma Restriction (%) #", N);
 157                            return;
 158                         end;
 159                      end if;
 160                   end if;
 161                end loop;
 162             end if;
 163          end;
 164       end if;
 165    end Check_Restricted_Unit;
 166
 167    -----------------------
 168    -- Check_Restriction --
 169    -----------------------
 170
 171    --  Case of simple identifier (no parameter)
 172
 173    procedure Check_Restriction (R : Restriction_Id; N : Node_Id) is
 174       Rimage : constant String := Restriction_Id'Image (R);
 175
 176    begin
 177       Violations (R) := True;
 178
 179       if (Restrictions (R) or Restriction_Warnings (R))
 180         and then not Suppress_Restriction_Message (N)
 181       then
 182          --  Output proper message. If this is just a case of
 183          --  a restriction warning, then we output a warning msg
 184
 185          if not Restrictions (R) then
 186             Restriction_Msg
 187               ("?violation of restriction %", Rimage, N);
 188
 189          --  If this is a real restriction violation, then generate
 190          --  a non-serious message with appropriate location.
 191
 192          else
 193             Error_Msg_Sloc := Restrictions_Loc (R);
 194
 195             --  If we have a location for the Restrictions pragma, output it
 196
 197             if Error_Msg_Sloc > No_Location
 198               or else Error_Msg_Sloc = System_Location
 199             then
 200                Restriction_Msg
 201                  ("|violation of restriction %#", Rimage, N);
 202
 203             --  Otherwise restriction was implicit (e.g. set by another pragma)
 204
 205             else
 206                Restriction_Msg
 207                  ("|violation of implicit restriction %", Rimage, N);
 208             end if;
 209          end if;
 210       end if;
 211    end Check_Restriction;
 212
 213    --  Case where a parameter is present, with a count
 214
 215    procedure Check_Restriction
 216      (R : Restriction_Parameter_Id;
 217       V : Uint;
 218       N : Node_Id)
 219    is
 220    begin
 221       if Restriction_Parameters (R) /= No_Uint
 222         and then V > Restriction_Parameters (R)
 223         and then not Suppress_Restriction_Message (N)
 224       then
 225          declare
 226             S : constant String := Restriction_Parameter_Id'Image (R);
 227          begin
 228             Name_Buffer (1 .. S'Last) := S;
 229             Name_Len := S'Length;
 230             Set_Casing (All_Lower_Case);
 231             Error_Msg_Name_1 := Name_Enter;
 232             Error_Msg_Sloc := Restriction_Parameters_Loc (R);
 233             Error_Msg_N ("|maximum value exceeded for restriction %#", N);
 234          end;
 235       end if;
 236    end Check_Restriction;
 237
 238    --  Case where a parameter is present, no count given
 239
 240    procedure Check_Restriction
 241      (R : Restriction_Parameter_Id;
 242       N : Node_Id)
 243    is
 244    begin
 245       if Restriction_Parameters (R) = Uint_0
 246         and then not Suppress_Restriction_Message (N)
 247       then
 248          declare
 249             S : constant String := Restriction_Parameter_Id'Image (R);
 250          begin
 251             Name_Buffer (1 .. S'Last) := S;
 252             Name_Len := S'Length;
 253             Set_Casing (All_Lower_Case);
 254             Error_Msg_Name_1 := Name_Enter;
 255             Error_Msg_Sloc := Restriction_Parameters_Loc (R);
 256             Error_Msg_N ("|maximum value exceeded for restriction %#", N);
 257          end;
 258       end if;
 259    end Check_Restriction;
 260
 261    -------------------------------------------
 262    -- Compilation_Unit_Restrictions_Restore --
 263    -------------------------------------------
 264
 265    procedure Compilation_Unit_Restrictions_Restore
 266      (R : Save_Compilation_Unit_Restrictions)
 267    is
 268    begin
 269       for J in Compilation_Unit_Restrictions loop
 270          Restrictions (J) := R (J);
 271       end loop;
 272    end Compilation_Unit_Restrictions_Restore;
 273
 274    ----------------------------------------
 275    -- Compilation_Unit_Restrictions_Save --
 276    ----------------------------------------
 277
 278    function Compilation_Unit_Restrictions_Save
 279      return Save_Compilation_Unit_Restrictions
 280    is
 281       R : Save_Compilation_Unit_Restrictions;
 282
 283    begin
 284       for J in Compilation_Unit_Restrictions loop
 285          R (J) := Restrictions (J);
 286          Restrictions (J) := False;
 287       end loop;
 288
 289       return R;
 290    end Compilation_Unit_Restrictions_Save;
 291
 292    ------------------------
 293    -- Get_Restriction_Id --
 294    ------------------------
 295
 296    function Get_Restriction_Id
 297      (N    : Name_Id)
 298       return Restriction_Id
 299    is
 300       J : Restriction_Id;
 301
 302    begin
 303       Get_Name_String (N);
 304       Set_Casing (All_Upper_Case);
 305
 306       J := Restriction_Id'First;
 307       while J /= Not_A_Restriction_Id loop
 308          declare
 309             S : constant String := Restriction_Id'Image (J);
 310
 311          begin
 312             exit when S = Name_Buffer (1 .. Name_Len);
 313          end;
 314
 315          J := Restriction_Id'Succ (J);
 316       end loop;
 317
 318       return J;
 319    end Get_Restriction_Id;
 320
 321    ----------------------------------
 322    -- Get_Restriction_Parameter_Id --
 323    ----------------------------------
 324
 325    function Get_Restriction_Parameter_Id
 326      (N    : Name_Id)
 327       return Restriction_Parameter_Id
 328    is
 329       J : Restriction_Parameter_Id;
 330
 331    begin
 332       Get_Name_String (N);
 333       Set_Casing (All_Upper_Case);
 334
 335       J := Restriction_Parameter_Id'First;
 336       while J /= Not_A_Restriction_Parameter_Id loop
 337          declare
 338             S : constant String := Restriction_Parameter_Id'Image (J);
 339
 340          begin
 341             exit when S = Name_Buffer (1 .. Name_Len);
 342          end;
 343
 344          J := Restriction_Parameter_Id'Succ (J);
 345       end loop;
 346
 347       return J;
 348    end Get_Restriction_Parameter_Id;
 349
 350    -------------------------------
 351    -- No_Exception_Handlers_Set --
 352    -------------------------------
 353
 354    function No_Exception_Handlers_Set return Boolean is
 355    begin
 356       return Restrictions (No_Exception_Handlers);
 357    end No_Exception_Handlers_Set;
 358
 359    ------------------------
 360    -- Restricted_Profile --
 361    ------------------------
 362
 363    --  This implementation must be coordinated with Set_Restricted_Profile
 364
 365    function Restricted_Profile return Boolean is
 366    begin
 367       return     Restrictions (No_Abort_Statements)
 368         and then Restrictions (No_Asynchronous_Control)
 369         and then Restrictions (No_Entry_Queue)
 370         and then Restrictions (No_Task_Hierarchy)
 371         and then Restrictions (No_Task_Allocators)
 372         and then Restrictions (No_Dynamic_Priorities)
 373         and then Restrictions (No_Terminate_Alternatives)
 374         and then Restrictions (No_Dynamic_Interrupts)
 375         and then Restrictions (No_Protected_Type_Allocators)
 376         and then Restrictions (No_Local_Protected_Objects)
 377         and then Restrictions (No_Requeue)
 378         and then Restrictions (No_Task_Attributes)
 379         and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) =  0
 380         and then Restriction_Parameters (Max_Task_Entries)                =  0
 381         and then Restriction_Parameters (Max_Protected_Entries)           <= 1
 382         and then Restriction_Parameters (Max_Select_Alternatives)         =  0;
 383    end Restricted_Profile;
 384
 385    ---------------------
 386    -- Restriction_Msg --
 387    ---------------------
 388
 389    procedure Restriction_Msg (Msg : String; R : String; N : Node_Id) is
 390       B : String (1 .. Msg'Length + 2 * R'Length + 1);
 391       P : Natural := 1;
 392
 393    begin
 394       Name_Buffer (1 .. R'Last) := R;
 395       Name_Len := R'Length;
 396       Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
 397
 398       P := 0;
 399       for J in Msg'Range loop
 400          if Msg (J) = '%' then
 401             P := P + 1;
 402             B (P) := '`';
 403
 404             --  Put characters of image in message, quoting upper case letters
 405
 406             for J in 1 .. Name_Len loop
 407                if Name_Buffer (J) in 'A' .. 'Z' then
 408                   P := P + 1;
 409                   B (P) := ''';
 410                end if;
 411
 412                P := P + 1;
 413                B (P) := Name_Buffer (J);
 414             end loop;
 415
 416             P := P + 1;
 417             B (P) := '`';
 418
 419          else
 420             P := P + 1;
 421             B (P) := Msg (J);
 422          end if;
 423       end loop;
 424
 425       Error_Msg_N (B (1 .. P), N);
 426    end Restriction_Msg;
 427
 428    -------------------
 429    -- Set_Ravenscar --
 430    -------------------
 431
 432    procedure Set_Ravenscar (N : Node_Id) is
 433       Loc : constant Source_Ptr := Sloc (N);
 434
 435    begin
 436       Set_Restricted_Profile (N);
 437       Restrictions (Boolean_Entry_Barriers)       := True;
 438       Restrictions (No_Select_Statements)         := True;
 439       Restrictions (No_Calendar)                  := True;
 440       Restrictions (No_Entry_Queue)               := True;
 441       Restrictions (No_Relative_Delay)            := True;
 442       Restrictions (No_Task_Termination)          := True;
 443       Restrictions (No_Implicit_Heap_Allocations) := True;
 444
 445       Restrictions_Loc (Boolean_Entry_Barriers)       := Loc;
 446       Restrictions_Loc (No_Select_Statements)         := Loc;
 447       Restrictions_Loc (No_Calendar)                  := Loc;
 448       Restrictions_Loc (No_Entry_Queue)               := Loc;
 449       Restrictions_Loc (No_Relative_Delay)            := Loc;
 450       Restrictions_Loc (No_Task_Termination)          := Loc;
 451       Restrictions_Loc (No_Implicit_Heap_Allocations) := Loc;
 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       Loc : constant Source_Ptr := Sloc (N);
 462
 463    begin
 464       Restrictions (No_Abort_Statements)          := True;
 465       Restrictions (No_Asynchronous_Control)      := True;
 466       Restrictions (No_Entry_Queue)               := True;
 467       Restrictions (No_Task_Hierarchy)            := True;
 468       Restrictions (No_Task_Allocators)           := True;
 469       Restrictions (No_Dynamic_Priorities)        := True;
 470       Restrictions (No_Terminate_Alternatives)    := True;
 471       Restrictions (No_Dynamic_Interrupts)        := True;
 472       Restrictions (No_Protected_Type_Allocators) := True;
 473       Restrictions (No_Local_Protected_Objects)   := True;
 474       Restrictions (No_Requeue)                   := True;
 475       Restrictions (No_Task_Attributes)           := True;
 476
 477       Restrictions_Loc (No_Abort_Statements)          := Loc;
 478       Restrictions_Loc (No_Asynchronous_Control)      := Loc;
 479       Restrictions_Loc (No_Entry_Queue)               := Loc;
 480       Restrictions_Loc (No_Task_Hierarchy)            := Loc;
 481       Restrictions_Loc (No_Task_Allocators)           := Loc;
 482       Restrictions_Loc (No_Dynamic_Priorities)        := Loc;
 483       Restrictions_Loc (No_Terminate_Alternatives)    := Loc;
 484       Restrictions_Loc (No_Dynamic_Interrupts)        := Loc;
 485       Restrictions_Loc (No_Protected_Type_Allocators) := Loc;
 486       Restrictions_Loc (No_Local_Protected_Objects)   := Loc;
 487       Restrictions_Loc (No_Requeue)                   := Loc;
 488       Restrictions_Loc (No_Task_Attributes)           := Loc;
 489
 490       Restriction_Parameters (Max_Asynchronous_Select_Nesting) := Uint_0;
 491       Restriction_Parameters (Max_Task_Entries)                := Uint_0;
 492       Restriction_Parameters (Max_Select_Alternatives)         := Uint_0;
 493
 494       if Restriction_Parameters (Max_Protected_Entries) /= Uint_0 then
 495          Restriction_Parameters (Max_Protected_Entries) := Uint_1;
 496       end if;
 497    end Set_Restricted_Profile;
 498
 499    ----------------------------------
 500    -- Suppress_Restriction_Message --
 501    ----------------------------------
 502
 503    function Suppress_Restriction_Message (N : Node_Id) return Boolean is
 504    begin
 505       --  We only output messages for the extended main source unit
 506
 507       if In_Extended_Main_Source_Unit (N) then
 508          return False;
 509
 510       --  If loaded by rtsfind, then suppress message
 511
 512       elsif Sloc (N) <= No_Location then
 513          return True;
 514
 515       --  Otherwise suppress message if internal file
 516
 517       else
 518          return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
 519       end if;
 520    end Suppress_Restriction_Message;
 521
 522    ---------------------
 523    -- Tasking_Allowed --
 524    ---------------------
 525
 526    function Tasking_Allowed return Boolean is
 527    begin
 528       return Restriction_Parameters (Max_Tasks) /= 0
 529         and then not Restrictions (No_Tasking);
 530    end Tasking_Allowed;
 531
 532 end Restrict;