1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- L O C A L _ R E S T R I C T --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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
;
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
;
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
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.
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
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.
64 ------------------------
65 -- Active_Restriction --
66 ------------------------
68 function Active_Restriction
69 (L_R
: Local_Restriction
; E
: Entity_Id
:= Current_Scope
) return Node_Id
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?
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.
85 while Present
(Scop
) loop
86 Result
:= Find_Aspect
(Scop
, Aspect_Local_Restrictions
);
88 and then Parse_Aspect_Local_Restrictions
(Result
) (L_R
)
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.
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
)));
105 Scop
:= Find_Enclosing_Scope
(Scop
);
112 end Active_Restriction
;
114 -----------------------------------------------
115 -- Check_For_Corresponding_Local_Restriction --
116 -----------------------------------------------
118 procedure Check_For_Corresponding_Local_Restriction
119 (Violated
: All_Restrictions
; N
: Node_Id
)
121 L_R
: Local_Restriction
;
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.
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
;
136 Check_For_Local_Restriction
(L_R
, N
);
137 end Check_For_Corresponding_Local_Restriction
;
139 ---------------------------------
140 -- Check_For_Local_Restriction --
141 ---------------------------------
143 procedure Check_For_Local_Restriction
144 (L_R
: Local_Restriction
; N
: Node_Id
)
146 L_R_Aspect_Spec
: constant Node_Id
:= Active_Restriction
(L_R
);
148 if Present
(L_R_Aspect_Spec
) then
149 Error_Msg_Sloc
:= Sloc
(L_R_Aspect_Spec
);
151 ("violation of local restriction " & L_R_Image
(L_R
) & "#", N
);
153 end Check_For_Local_Restriction
;
159 procedure Check_Call
(Call
: Node_Id
; Callee
: Entity_Id
:= Empty
) is
160 Restrictions_Enforced_By_Callee
: Local_Restriction_Set
:=
163 Real_Callee
: Entity_Id
;
165 if Present
(Callee
) then
166 Real_Callee
:= Ultimate_Alias
(Callee
);
168 if Is_Intrinsic_Subprogram
(Real_Callee
)
169 or else In_Predefined_Unit
(Real_Callee
)
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).
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;
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.
191 Check_For_Local_Restriction
(L_R
, Call
);
196 -----------------------
197 -- Check_Overriding --
198 -----------------------
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
);
206 -- a minor optimization
207 if Ultimate_Overrider
= Ultimate_Overridden
then
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
))
216 Sloc
(Active_Restriction
(L_R
, Ultimate_Overridden
));
218 ("overriding incompatible with local restriction " &
219 L_R_Image
(L_R
) & "#",
223 end Check_Overriding
;
225 ------------------------------------------
226 -- Check_Actual_Subprogram_For_Instance --
227 ------------------------------------------
229 procedure Check_Actual_Subprogram_For_Instance
230 (Actual_Subp_Name
: Node_Id
; Formal_Subp
: Entity_Id
)
232 Actual_Subp
: Entity_Id
:= Empty
;
234 if Is_Entity_Name
(Actual_Subp_Name
) then
235 Actual_Subp
:= Entity
(Actual_Subp_Name
);
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.
242 if Present
(Active_Restriction
(L_R
, Formal_Subp
))
245 or else No
(Active_Restriction
(L_R
, Actual_Subp
)))
247 Error_Msg_Sloc
:= Sloc
(Active_Restriction
(L_R
, Formal_Subp
));
249 ("actual subprogram incompatible with local restriction " &
250 L_R_Image
(L_R
) & " #",
254 end Check_Actual_Subprogram_For_Instance
;
257 -- Allow package Restrict to call package Local_Restrict without
258 -- pulling the bulk of semantics into the closure of package Restrict.
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.
266 Local_Restrictions
.Local_Restriction_Checking_Hook
:=
267 Check_For_Corresponding_Local_Restriction
'Access;