gcc/ada/local_restrict.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                        L O C A L _ R E S T R I C T                       --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2023, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Aspects;        use Aspects;
  27 with Atree;          use Atree;
  28 with Einfo;          use Einfo;
  29 with Einfo.Entities; use Einfo.Entities;
  30 with Einfo.Utils;    use Einfo.Utils;
  31 with Errout;         use Errout;
  32 with Lib;            use Lib;
  33 with Restrict;       use Restrict;
  34 with Rident;         use Rident;
  35 with Sem_Aux;        use Sem_Aux;
  36 with Sem_Ch13;       use Sem_Ch13;
  37 with Sem_Util;       use Sem_Util;
  38 with Sinfo.Nodes;    use Sinfo.Nodes;
  39 with Sinfo.Utils;    use Sinfo.Utils;
  40
  41 package body Local_Restrict is
  42    function L_R_Image (L_R : Local_Restriction) return String is
  43      (case L_R is when No_Secondary_Stack => "No_Secondary_Stack",
  44         when No_Heap_Allocations => "No_Heap_Allocations");
  45    --  Like Local_Restriction'Image, but with casing appropriate for
  46    --  error messages.
  47
  48    function Active_Restriction
  49      (L_R : Local_Restriction; E : Entity_Id := Current_Scope) return Node_Id;
  50    --  Returns the Local_Restrictions aspect specification that is in effect
  51    --  for E and that imposes the given local restriction; returns Empty if
  52    --  no such aspect specification exists.
  53
  54    procedure Check_For_Corresponding_Local_Restriction
  55      (Violated : All_Restrictions; N : Node_Id);
  56    --  Generate error for node N if a violation of the given (non-local)
  57    --  restriction implies a violation of a corresponding local restriction
  58    --  that is in effect.
  59
  60    procedure Check_For_Local_Restriction
  61      (L_R : Local_Restriction; N : Node_Id);
  62    --  Generate error for node N if given restriction is in effect.
  63
  64    ------------------------
  65    -- Active_Restriction --
  66    ------------------------
  67
  68    function Active_Restriction
  69      (L_R : Local_Restriction; E : Entity_Id := Current_Scope) return Node_Id
  70    is
  71       Scop   : Node_Id := E;
  72       Result : Node_Id;
  73    begin
  74       --  If performance of this function becomes a problem then
  75       --  one possible solution would be cache a set of scopes
  76       --  for which it is known that no local restrictions apply.
  77       --  Perhaps with fixed size (maybe 8?) and LRU replacement?
  78       --
  79       --  Or perhaps just a single global Boolean indicating that
  80       --  no Local_Restrictions aspect specification has been seen
  81       --  at any time in any context during the current compilation.
  82       --  If the flag is set, then Active_Restriction returns Empty
  83       --  without any looping.
  84
  85       while Present (Scop) loop
  86          Result := Find_Aspect (Scop, Aspect_Local_Restrictions);
  87          if Present (Result)
  88            and then Parse_Aspect_Local_Restrictions (Result) (L_R)
  89          then
  90             return Result;
  91          end if;
  92
  93          Scop := Enclosing_Declaration (Scop);
  94          if Present (Scop) then
  95             Scop := Parent (Scop);
  96             if Present (Scop) then
  97                --  For a subprogram associated with a type, we don't care
  98                --  where the type was frozen; continue from the type.
  99
 100                if Nkind (Scop) = N_Freeze_Entity then
 101                   Scop := Scope (Entity (Scop));
 102                elsif Nkind (Parent (Scop)) = N_Freeze_Entity then
 103                   Scop := Scope (Entity (Parent (Scop)));
 104                else
 105                   Scop := Find_Enclosing_Scope (Scop);
 106                end if;
 107             end if;
 108          end if;
 109       end loop;
 110
 111       return Empty;
 112    end Active_Restriction;
 113
 114    -----------------------------------------------
 115    -- Check_For_Corresponding_Local_Restriction --
 116    -----------------------------------------------
 117
 118    procedure Check_For_Corresponding_Local_Restriction
 119      (Violated : All_Restrictions; N : Node_Id)
 120    is
 121       L_R : Local_Restriction;
 122    begin
 123       --  Some restrictions map to a corresponding local restriction.
 124       --  In those cases, check whether the local restriction is in effect.
 125       --  This is the point at which the specific semantics of each
 126       --  local restriction is effectively defined.
 127       case Violated is
 128          when No_Secondary_Stack =>
 129             L_R := No_Secondary_Stack;
 130          when No_Allocators | No_Implicit_Heap_Allocations =>
 131             L_R := No_Heap_Allocations;
 132          when others =>
 133             return;
 134       end case;
 135
 136       Check_For_Local_Restriction (L_R, N);
 137    end Check_For_Corresponding_Local_Restriction;
 138
 139    ---------------------------------
 140    -- Check_For_Local_Restriction --
 141    ---------------------------------
 142
 143    procedure Check_For_Local_Restriction
 144      (L_R : Local_Restriction; N : Node_Id)
 145    is
 146       L_R_Aspect_Spec : constant Node_Id := Active_Restriction (L_R);
 147    begin
 148       if Present (L_R_Aspect_Spec) then
 149          Error_Msg_Sloc := Sloc (L_R_Aspect_Spec);
 150          Error_Msg_N
 151            ("violation of local restriction " & L_R_Image (L_R) & "#", N);
 152       end if;
 153    end Check_For_Local_Restriction;
 154
 155    ----------------
 156    -- Check_Call --
 157    ----------------
 158
 159    procedure Check_Call (Call : Node_Id; Callee : Entity_Id := Empty) is
 160       Restrictions_Enforced_By_Callee : Local_Restriction_Set :=
 161         (others => False);
 162
 163       Real_Callee : Entity_Id;
 164    begin
 165       if Present (Callee) then
 166          Real_Callee := Ultimate_Alias (Callee);
 167
 168          if Is_Intrinsic_Subprogram (Real_Callee)
 169            or else In_Predefined_Unit (Real_Callee)
 170          then
 171             --  If an intrinsic or predefined subprogram violates a local
 172             --  restriction then we don't catch it here. For that, we rely
 173             --  on the same mechanism that is used to catch violations of
 174             --  the corresponding global restriction (i.e., the
 175             --  Local_Restriction_Checking_Hook call in Check_Restriction).
 176             return;
 177          end if;
 178
 179          for L_R in Local_Restriction loop
 180             if Present (Active_Restriction (L_R, Real_Callee)) then
 181                Restrictions_Enforced_By_Callee (L_R) := True;
 182             end if;
 183          end loop;
 184       end if;
 185
 186       for L_R in Local_Restriction loop
 187          if not Restrictions_Enforced_By_Callee (L_R) then
 188             --  Complain if caller must enforce L_R and callee
 189             --  does not promise to do that.
 190
 191             Check_For_Local_Restriction (L_R, Call);
 192          end if;
 193       end loop;
 194    end Check_Call;
 195
 196    -----------------------
 197    --  Check_Overriding --
 198    -----------------------
 199
 200    procedure Check_Overriding (Overrider_Op, Overridden_Op : Entity_Id) is
 201       Ultimate_Overrider  : constant Entity_Id :=
 202         Ultimate_Alias (Overrider_Op);
 203       Ultimate_Overridden : constant Entity_Id :=
 204         Ultimate_Alias (Overridden_Op);
 205    begin
 206       --  a minor optimization
 207       if Ultimate_Overrider = Ultimate_Overridden then
 208          return;
 209       end if;
 210
 211       for L_R in Local_Restriction loop
 212          if Present (Active_Restriction (L_R, Ultimate_Overridden))
 213            and then No (Active_Restriction (L_R, Ultimate_Overrider))
 214          then
 215             Error_Msg_Sloc :=
 216               Sloc (Active_Restriction (L_R, Ultimate_Overridden));
 217             Error_Msg_N
 218               ("overriding incompatible with local restriction " &
 219                L_R_Image (L_R) & "#",
 220                Ultimate_Overrider);
 221          end if;
 222       end loop;
 223    end Check_Overriding;
 224
 225    ------------------------------------------
 226    -- Check_Actual_Subprogram_For_Instance --
 227    ------------------------------------------
 228
 229    procedure Check_Actual_Subprogram_For_Instance
 230      (Actual_Subp_Name : Node_Id; Formal_Subp : Entity_Id)
 231    is
 232       Actual_Subp : Entity_Id := Empty;
 233    begin
 234       if Is_Entity_Name (Actual_Subp_Name) then
 235          Actual_Subp := Entity (Actual_Subp_Name);
 236       end if;
 237
 238       for L_R in Local_Restriction loop
 239          --  Complain if some local restriction is in effect for
 240          --  the formal subprogram but not for the actual subprogram.
 241
 242          if Present (Active_Restriction (L_R, Formal_Subp))
 243            and then
 244              (No (Actual_Subp)
 245                or else No (Active_Restriction (L_R, Actual_Subp)))
 246          then
 247             Error_Msg_Sloc := Sloc (Active_Restriction (L_R, Formal_Subp));
 248             Error_Msg_N
 249               ("actual subprogram incompatible with local restriction " &
 250                L_R_Image (L_R) & " #",
 251                Actual_Subp_Name);
 252          end if;
 253       end loop;
 254    end Check_Actual_Subprogram_For_Instance;
 255
 256 begin
 257    --  Allow package Restrict to call package Local_Restrict without
 258    --  pulling the bulk of semantics into the closure of package Restrict.
 259    --
 260    --  For example, if an allocator is encountered, then package
 261    --  Restrict is called to check whether a No_Allocators restriction is
 262    --  in effect. At that point, we also want to check whether a
 263    --  No_Heap_Allocations local restriction is in effect. This
 264    --  registration makes that possible.
 265
 266    Local_Restrictions.Local_Restriction_Checking_Hook :=
 267      Check_For_Corresponding_Local_Restriction'Access;
 268 end Local_Restrict;