]>
Commit | Line | Data |
---|---|---|
19235870 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- R E S T R I C T -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
cccef051 | 9 | -- Copyright (C) 1992-2023, Free Software Foundation, Inc. -- |
19235870 RK |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
19235870 RK |
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 -- | |
b5c84c3c RD |
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. -- | |
19235870 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
19235870 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
104f58db BD |
26 | with Atree; use Atree; |
27 | with Casing; use Casing; | |
28 | with Einfo; use Einfo; | |
76f9c7f4 | 29 | with Einfo.Entities; use Einfo.Entities; |
104f58db BD |
30 | with Einfo.Utils; use Einfo.Utils; |
31 | with Errout; use Errout; | |
32 | with Debug; use Debug; | |
33 | with Fname; use Fname; | |
34 | with Fname.UF; use Fname.UF; | |
35 | with Lib; use Lib; | |
36 | with Opt; use Opt; | |
37 | with Sinfo; use Sinfo; | |
38 | with Sinfo.Nodes; use Sinfo.Nodes; | |
39 | with Sinfo.Utils; use Sinfo.Utils; | |
40 | with Sinput; use Sinput; | |
41 | with Stand; use Stand; | |
42 | with Targparm; use Targparm; | |
43 | with Uname; use Uname; | |
bc50ac71 | 44 | with Warnsw; use Warnsw; |
19235870 RK |
45 | |
46 | package body Restrict is | |
47 | ||
6480338a AC |
48 | -------------------------------- |
49 | -- Package Local Declarations -- | |
50 | -------------------------------- | |
51 | ||
51fb9b73 RD |
52 | Config_Cunit_Boolean_Restrictions : Save_Cunit_Boolean_Restrictions; |
53 | -- Save compilation unit restrictions set by config pragma files | |
54 | ||
433cefcd EB |
55 | Global_Restriction_No_Tasking : Boolean := False; |
56 | -- Set to True when No_Tasking is set in the run-time package System | |
57 | -- or in a configuration pragmas file (for example, gnat.adc). | |
58 | ||
cc335f43 | 59 | Restricted_Profile_Result : Boolean := False; |
e7fceebc AC |
60 | -- This switch memoizes the result of Restricted_Profile function calls for |
61 | -- improved efficiency. Valid only if Restricted_Profile_Cached is True. | |
62 | -- Note: if this switch is ever set True, it is never turned off again. | |
cc335f43 AC |
63 | |
64 | Restricted_Profile_Cached : Boolean := False; | |
e7fceebc AC |
65 | -- This flag is set to True if the Restricted_Profile_Result contains the |
66 | -- correct cached result of Restricted_Profile calls. | |
67 | ||
68 | No_Specification_Of_Aspects : array (Aspect_Id) of Source_Ptr := | |
69 | (others => No_Location); | |
e027681d | 70 | -- Entries in this array are set to point to a previously occurring pragma |
e7fceebc AC |
71 | -- that activates a No_Specification_Of_Aspect check. |
72 | ||
73 | No_Specification_Of_Aspect_Warning : array (Aspect_Id) of Boolean := | |
74 | (others => True); | |
41a7b948 ES |
75 | -- An entry in this array is set False in response to a previous call to |
76 | -- Set_No_Specification_Of_Aspect for pragmas in the main unit that | |
e7fceebc AC |
77 | -- specify Warning as False. Once set False, an entry is never reset. |
78 | ||
79 | No_Specification_Of_Aspect_Set : Boolean := False; | |
41a7b948 | 80 | -- Set True if any entry of No_Specification_Of_Aspects has been set True. |
e7fceebc | 81 | -- Once set True, this is never turned off again. |
cc335f43 | 82 | |
57f4c288 | 83 | No_Use_Of_Attribute : array (Attribute_Id) of Source_Ptr := |
489c6e19 | 84 | (others => No_Location); |
57f4c288 ES |
85 | |
86 | No_Use_Of_Attribute_Warning : array (Attribute_Id) of Boolean := | |
489c6e19 | 87 | (others => False); |
57f4c288 ES |
88 | |
89 | No_Use_Of_Attribute_Set : Boolean := False; | |
489c6e19 | 90 | -- Indicates that No_Use_Of_Attribute was set at least once |
57f4c288 ES |
91 | |
92 | No_Use_Of_Pragma : array (Pragma_Id) of Source_Ptr := | |
93 | (others => No_Location); | |
596b25f9 | 94 | -- Source location of pragma No_Use_Of_Pragma for given pragma, a value |
b68cf874 | 95 | -- of System_Location indicates occurrence in system.ads. |
57f4c288 ES |
96 | |
97 | No_Use_Of_Pragma_Warning : array (Pragma_Id) of Boolean := | |
489c6e19 | 98 | (others => False); |
57f4c288 ES |
99 | |
100 | No_Use_Of_Pragma_Set : Boolean := False; | |
489c6e19 | 101 | -- Indicates that No_Use_Of_Pragma was set at least once |
57f4c288 | 102 | |
fbf5a39b AC |
103 | ----------------------- |
104 | -- Local Subprograms -- | |
105 | ----------------------- | |
106 | ||
9b7c38af RD |
107 | procedure Restriction_Msg (R : Restriction_Id; N : Node_Id); |
108 | -- Called if a violation of restriction R at node N is found. This routine | |
109 | -- outputs the appropriate message or messages taking care of warning vs | |
110 | -- real violation, serious vs non-serious, implicit vs explicit, the second | |
111 | -- message giving the profile name if needed, and the location information. | |
fbf5a39b | 112 | |
18dae814 RD |
113 | function Same_Entity (E1, E2 : Node_Id) return Boolean; |
114 | -- Returns True iff E1 and E2 represent the same entity. Used for handling | |
115 | -- of No_Use_Of_Entity => fully_qualified_ENTITY restriction case. | |
116 | ||
5f3ab6fb AC |
117 | function Same_Unit (U1, U2 : Node_Id) return Boolean; |
118 | -- Returns True iff U1 and U2 represent the same library unit. Used for | |
119 | -- handling of No_Dependence => Unit restriction case. | |
120 | ||
19235870 | 121 | function Suppress_Restriction_Message (N : Node_Id) return Boolean; |
9b7c38af RD |
122 | -- N is the node for a possible restriction violation message, but the |
123 | -- message is to be suppressed if this is an internal file and this file is | |
124 | -- not the main unit. Returns True if message is to be suppressed. | |
19235870 | 125 | |
433cefcd EB |
126 | procedure Violation_Of_No_Dependence (Unit : Int; N : Node_Id); |
127 | -- Called if a violation of restriction No_Dependence for Unit at node N | |
128 | -- is found. This routine outputs the appropriate message, taking care of | |
129 | -- warning vs real violation. | |
130 | ||
19235870 RK |
131 | ------------------- |
132 | -- Abort_Allowed -- | |
133 | ------------------- | |
134 | ||
135 | function Abort_Allowed return Boolean is | |
136 | begin | |
6e937c1c AC |
137 | if Restrictions.Set (No_Abort_Statements) |
138 | and then Restrictions.Set (Max_Asynchronous_Select_Nesting) | |
139 | and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0 | |
fbf5a39b AC |
140 | then |
141 | return False; | |
fbf5a39b AC |
142 | else |
143 | return True; | |
144 | end if; | |
19235870 RK |
145 | end Abort_Allowed; |
146 | ||
51fb9b73 RD |
147 | ---------------------------------------- |
148 | -- Add_To_Config_Boolean_Restrictions -- | |
149 | ---------------------------------------- | |
150 | ||
151 | procedure Add_To_Config_Boolean_Restrictions (R : Restriction_Id) is | |
152 | begin | |
153 | Config_Cunit_Boolean_Restrictions (R) := True; | |
154 | end Add_To_Config_Boolean_Restrictions; | |
155 | -- Add specified restriction to stored configuration boolean restrictions. | |
156 | -- This is used for handling the special case of No_Elaboration_Code. | |
157 | ||
19235870 RK |
158 | ------------------------------------ |
159 | -- Check_Elaboration_Code_Allowed -- | |
160 | ------------------------------------ | |
161 | ||
162 | procedure Check_Elaboration_Code_Allowed (N : Node_Id) is | |
163 | begin | |
cadf64d1 | 164 | Check_Restriction (No_Elaboration_Code, N); |
19235870 RK |
165 | end Check_Elaboration_Code_Allowed; |
166 | ||
58ba2415 HK |
167 | ----------------------------------------- |
168 | -- Check_Implicit_Dynamic_Code_Allowed -- | |
169 | ----------------------------------------- | |
170 | ||
171 | procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id) is | |
172 | begin | |
173 | Check_Restriction (No_Implicit_Dynamic_Code, N); | |
174 | end Check_Implicit_Dynamic_Code_Allowed; | |
175 | ||
a4901c08 AC |
176 | -------------------------------- |
177 | -- Check_No_Implicit_Aliasing -- | |
178 | -------------------------------- | |
179 | ||
180 | procedure Check_No_Implicit_Aliasing (Obj : Node_Id) is | |
181 | E : Entity_Id; | |
182 | ||
183 | begin | |
184 | -- If restriction not active, nothing to check | |
185 | ||
186 | if not Restriction_Active (No_Implicit_Aliasing) then | |
187 | return; | |
188 | end if; | |
189 | ||
190 | -- If we have an entity name, check entity | |
191 | ||
192 | if Is_Entity_Name (Obj) then | |
193 | E := Entity (Obj); | |
194 | ||
195 | -- Restriction applies to entities that are objects | |
196 | ||
197 | if Is_Object (E) then | |
198 | if Is_Aliased (E) then | |
199 | return; | |
200 | ||
201 | elsif Present (Renamed_Object (E)) then | |
202 | Check_No_Implicit_Aliasing (Renamed_Object (E)); | |
203 | return; | |
204 | end if; | |
205 | ||
206 | -- If we don't have an object, then it's OK | |
207 | ||
208 | else | |
209 | return; | |
210 | end if; | |
211 | ||
212 | -- For selected component, check selector | |
213 | ||
214 | elsif Nkind (Obj) = N_Selected_Component then | |
215 | Check_No_Implicit_Aliasing (Selector_Name (Obj)); | |
216 | return; | |
217 | ||
218 | -- Indexed component is OK if aliased components | |
219 | ||
220 | elsif Nkind (Obj) = N_Indexed_Component then | |
221 | if Has_Aliased_Components (Etype (Prefix (Obj))) | |
222 | or else | |
223 | (Is_Access_Type (Etype (Prefix (Obj))) | |
224 | and then Has_Aliased_Components | |
225 | (Designated_Type (Etype (Prefix (Obj))))) | |
226 | then | |
227 | return; | |
228 | end if; | |
229 | ||
230 | -- For type conversion, check converted expression | |
231 | ||
4a08c95c | 232 | elsif Nkind (Obj) in N_Unchecked_Type_Conversion | N_Type_Conversion then |
a4901c08 AC |
233 | Check_No_Implicit_Aliasing (Expression (Obj)); |
234 | return; | |
235 | ||
236 | -- Explicit dereference is always OK | |
237 | ||
238 | elsif Nkind (Obj) = N_Explicit_Dereference then | |
239 | return; | |
240 | end if; | |
241 | ||
242 | -- If we fall through, then we have an aliased view that does not meet | |
243 | -- the rules for being explicitly aliased, so issue restriction msg. | |
244 | ||
245 | Check_Restriction (No_Implicit_Aliasing, Obj); | |
246 | end Check_No_Implicit_Aliasing; | |
247 | ||
fbf5a39b AC |
248 | ---------------------------------- |
249 | -- Check_No_Implicit_Heap_Alloc -- | |
250 | ---------------------------------- | |
251 | ||
252 | procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is | |
253 | begin | |
b90cfacd | 254 | Check_Restriction (No_Implicit_Heap_Allocations, N); |
fbf5a39b AC |
255 | end Check_No_Implicit_Heap_Alloc; |
256 | ||
c96c518f AC |
257 | ---------------------------------- |
258 | -- Check_No_Implicit_Task_Alloc -- | |
259 | ---------------------------------- | |
260 | ||
261 | procedure Check_No_Implicit_Task_Alloc (N : Node_Id) is | |
262 | begin | |
263 | Check_Restriction (No_Implicit_Task_Allocations, N); | |
264 | end Check_No_Implicit_Task_Alloc; | |
265 | ||
266 | --------------------------------------- | |
267 | -- Check_No_Implicit_Protected_Alloc -- | |
268 | --------------------------------------- | |
269 | ||
270 | procedure Check_No_Implicit_Protected_Alloc (N : Node_Id) is | |
271 | begin | |
272 | Check_Restriction (No_Implicit_Protected_Object_Allocations, N); | |
273 | end Check_No_Implicit_Protected_Alloc; | |
274 | ||
b5c739f9 RD |
275 | ----------------------------------- |
276 | -- Check_Obsolescent_2005_Entity -- | |
277 | ----------------------------------- | |
278 | ||
279 | procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id) is | |
280 | function Chars_Is (E : Entity_Id; S : String) return Boolean; | |
281 | -- Return True iff Chars (E) matches S (given in lower case) | |
282 | ||
489c6e19 AC |
283 | -------------- |
284 | -- Chars_Is -- | |
285 | -------------- | |
286 | ||
b5c739f9 RD |
287 | function Chars_Is (E : Entity_Id; S : String) return Boolean is |
288 | Nam : constant Name_Id := Chars (E); | |
289 | begin | |
290 | if Length_Of_Name (Nam) /= S'Length then | |
291 | return False; | |
292 | else | |
293 | return Get_Name_String (Nam) = S; | |
294 | end if; | |
295 | end Chars_Is; | |
296 | ||
297 | -- Start of processing for Check_Obsolescent_2005_Entity | |
298 | ||
299 | begin | |
7a963087 RD |
300 | if Restriction_Check_Required (No_Obsolescent_Features) |
301 | and then Ada_Version >= Ada_2005 | |
b5c739f9 RD |
302 | and then Chars_Is (Scope (E), "handling") |
303 | and then Chars_Is (Scope (Scope (E)), "characters") | |
304 | and then Chars_Is (Scope (Scope (Scope (E))), "ada") | |
305 | and then Scope (Scope (Scope (Scope (E)))) = Standard_Standard | |
306 | then | |
307 | if Chars_Is (E, "is_character") or else | |
308 | Chars_Is (E, "is_string") or else | |
309 | Chars_Is (E, "to_character") or else | |
310 | Chars_Is (E, "to_string") or else | |
311 | Chars_Is (E, "to_wide_character") or else | |
312 | Chars_Is (E, "to_wide_string") | |
313 | then | |
314 | Check_Restriction (No_Obsolescent_Features, N); | |
315 | end if; | |
316 | end if; | |
317 | end Check_Obsolescent_2005_Entity; | |
318 | ||
19235870 RK |
319 | --------------------------- |
320 | -- Check_Restricted_Unit -- | |
321 | --------------------------- | |
322 | ||
323 | procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is | |
324 | begin | |
325 | if Suppress_Restriction_Message (N) then | |
326 | return; | |
327 | ||
328 | elsif Is_Spec_Name (U) then | |
329 | declare | |
330 | Fnam : constant File_Name_Type := | |
331 | Get_File_Name (U, Subunit => False); | |
19235870 RK |
332 | |
333 | begin | |
baa3441d | 334 | -- Get file name |
19235870 | 335 | |
baa3441d | 336 | Get_Name_String (Fnam); |
19235870 | 337 | |
baa3441d RD |
338 | -- Nothing to do if name not at least 5 characters long ending |
339 | -- in .ads or .adb extension, which we strip. | |
19235870 | 340 | |
baa3441d RD |
341 | if Name_Len < 5 |
342 | or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads" | |
343 | and then | |
9b7c38af | 344 | Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb") |
baa3441d RD |
345 | then |
346 | return; | |
347 | end if; | |
19235870 | 348 | |
baa3441d | 349 | -- Strip extension and pad to eight characters |
19235870 | 350 | |
baa3441d | 351 | Name_Len := Name_Len - 4; |
dae4faf2 | 352 | Add_Str_To_Name_Buffer ((Name_Len + 1 .. 8 => ' ')); |
baa3441d RD |
353 | |
354 | -- If predefined unit, check the list of restricted units | |
355 | ||
356 | if Is_Predefined_File_Name (Fnam) then | |
19235870 RK |
357 | for J in Unit_Array'Range loop |
358 | if Name_Len = 8 | |
359 | and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm | |
360 | then | |
6e937c1c | 361 | Check_Restriction (Unit_Array (J).Res_Id, N); |
19235870 RK |
362 | end if; |
363 | end loop; | |
baa3441d | 364 | |
276e95ca RW |
365 | -- If not predefined unit, then one special check still |
366 | -- remains. GNAT.Current_Exception is not allowed if we have | |
367 | -- restriction No_Exception_Propagation active. | |
baa3441d RD |
368 | |
369 | else | |
370 | if Name_Buffer (1 .. 8) = "g-curexc" then | |
371 | Check_Restriction (No_Exception_Propagation, N); | |
372 | end if; | |
19235870 RK |
373 | end if; |
374 | end; | |
375 | end if; | |
376 | end Check_Restricted_Unit; | |
377 | ||
378 | ----------------------- | |
379 | -- Check_Restriction -- | |
380 | ----------------------- | |
381 | ||
6e937c1c AC |
382 | procedure Check_Restriction |
383 | (R : Restriction_Id; | |
384 | N : Node_Id; | |
385 | V : Uint := Uint_Minus_1) | |
23685ae6 | 386 | is |
29d39651 | 387 | Ignore_Msg_Issued : Boolean; |
23685ae6 | 388 | begin |
29d39651 | 389 | Check_Restriction (Ignore_Msg_Issued, R, N, V); |
23685ae6 AC |
390 | end Check_Restriction; |
391 | ||
392 | procedure Check_Restriction | |
393 | (Msg_Issued : out Boolean; | |
394 | R : Restriction_Id; | |
395 | N : Node_Id; | |
396 | V : Uint := Uint_Minus_1) | |
6e937c1c | 397 | is |
6e937c1c AC |
398 | VV : Integer; |
399 | -- V converted to integer form. If V is greater than Integer'Last, | |
400 | -- it is reset to minus 1 (unknown value). | |
19235870 | 401 | |
6e937c1c AC |
402 | procedure Update_Restrictions (Info : in out Restrictions_Info); |
403 | -- Update violation information in Info.Violated and Info.Count | |
19235870 | 404 | |
6e937c1c AC |
405 | ------------------------- |
406 | -- Update_Restrictions -- | |
407 | ------------------------- | |
fbf5a39b | 408 | |
6e937c1c AC |
409 | procedure Update_Restrictions (Info : in out Restrictions_Info) is |
410 | begin | |
411 | -- If not violated, set as violated now | |
fbf5a39b | 412 | |
6e937c1c AC |
413 | if not Info.Violated (R) then |
414 | Info.Violated (R) := True; | |
415 | ||
416 | if R in All_Parameter_Restrictions then | |
417 | if VV < 0 then | |
418 | Info.Unknown (R) := True; | |
419 | Info.Count (R) := 1; | |
1696d58d | 420 | |
6e937c1c AC |
421 | else |
422 | Info.Count (R) := VV; | |
423 | end if; | |
424 | end if; | |
425 | ||
426 | -- Otherwise if violated already and a parameter restriction, | |
427 | -- update count by maximizing or summing depending on restriction. | |
428 | ||
429 | elsif R in All_Parameter_Restrictions then | |
430 | ||
431 | -- If new value is unknown, result is unknown | |
432 | ||
433 | if VV < 0 then | |
434 | Info.Unknown (R) := True; | |
fbf5a39b | 435 | |
1696d58d ES |
436 | -- If checked by maximization, nothing to do because the |
437 | -- check is per-object. | |
fbf5a39b | 438 | |
6e937c1c | 439 | elsif R in Checked_Max_Parameter_Restrictions then |
1696d58d | 440 | null; |
fbf5a39b | 441 | |
6e937c1c AC |
442 | -- If checked by adding, do add, checking for overflow |
443 | ||
444 | elsif R in Checked_Add_Parameter_Restrictions then | |
445 | declare | |
446 | pragma Unsuppress (Overflow_Check); | |
447 | begin | |
448 | Info.Count (R) := Info.Count (R) + VV; | |
449 | exception | |
450 | when Constraint_Error => | |
451 | Info.Count (R) := Integer'Last; | |
452 | Info.Unknown (R) := True; | |
453 | end; | |
454 | ||
455 | -- Should not be able to come here, known counts should only | |
456 | -- occur for restrictions that are Checked_max or Checked_Sum. | |
fbf5a39b AC |
457 | |
458 | else | |
6e937c1c | 459 | raise Program_Error; |
fbf5a39b AC |
460 | end if; |
461 | end if; | |
6e937c1c | 462 | end Update_Restrictions; |
19235870 | 463 | |
6e937c1c | 464 | -- Start of processing for Check_Restriction |
19235870 | 465 | |
19235870 | 466 | begin |
23685ae6 AC |
467 | Msg_Issued := False; |
468 | ||
6e840989 HK |
469 | -- In CodePeer mode, we do not want to check for any restriction, or set |
470 | -- additional restrictions other than those already set in gnat1drv.adb | |
471 | -- so that we have consistency between each compilation. | |
472 | ||
473 | -- In GNATprove mode restrictions are checked, except for | |
ed37f25a | 474 | -- No_Initialize_Scalars, which is implicitly set in gnat1drv.adb. |
87dc09cb | 475 | |
6e840989 HK |
476 | if CodePeer_Mode |
477 | or else (GNATprove_Mode and then R = No_Initialize_Scalars) | |
478 | then | |
87dc09cb AC |
479 | return; |
480 | end if; | |
481 | ||
6e937c1c AC |
482 | if UI_Is_In_Int_Range (V) then |
483 | VV := Integer (UI_To_Int (V)); | |
484 | else | |
485 | VV := -1; | |
486 | end if; | |
487 | ||
488 | -- Count can only be specified in the checked val parameter case | |
489 | ||
490 | pragma Assert (VV < 0 or else R in Checked_Val_Parameter_Restrictions); | |
491 | ||
492 | -- Nothing to do if value of zero specified for parameter restriction | |
493 | ||
494 | if VV = 0 then | |
495 | return; | |
496 | end if; | |
497 | ||
498 | -- Update current restrictions | |
499 | ||
500 | Update_Restrictions (Restrictions); | |
501 | ||
51fb9b73 RD |
502 | -- If in main extended unit, update main restrictions as well. Note |
503 | -- that as usual we check for Main_Unit explicitly to deal with the | |
504 | -- case of configuration pragma files. | |
6e937c1c AC |
505 | |
506 | if Current_Sem_Unit = Main_Unit | |
507 | or else In_Extended_Main_Source_Unit (N) | |
19235870 | 508 | then |
6e937c1c | 509 | Update_Restrictions (Main_Restrictions); |
19235870 | 510 | end if; |
19235870 | 511 | |
9daee425 SB |
512 | declare |
513 | use Local_Restrictions; | |
514 | begin | |
515 | if Local_Restriction_Checking_Hook /= null then | |
516 | -- A given global restriction (which may or may not be in | |
517 | -- effect) has been violated. Even if the global restriction | |
518 | -- is not in effect, a corresponding local restriction may be | |
519 | -- in effect (in which case the violation needs to be flagged). | |
520 | Local_Restriction_Checking_Hook.all (R, N); | |
521 | end if; | |
522 | end; | |
523 | ||
6e937c1c | 524 | -- Nothing to do if restriction message suppressed |
19235870 | 525 | |
6e937c1c AC |
526 | if Suppress_Restriction_Message (N) then |
527 | null; | |
528 | ||
529 | -- If restriction not set, nothing to do | |
530 | ||
531 | elsif not Restrictions.Set (R) then | |
532 | null; | |
533 | ||
794b9b72 AC |
534 | -- Don't complain about No_Obsolescent_Features in an instance, since we |
535 | -- will complain on the template, which is much better. Are there other | |
536 | -- cases like this ??? Do we need a more general mechanism ??? | |
537 | ||
538 | elsif R = No_Obsolescent_Features | |
539 | and then Instantiation_Location (Sloc (N)) /= No_Location | |
540 | then | |
541 | null; | |
542 | ||
727e7b1a AC |
543 | -- Here if restriction set, check for violation (this is a Boolean |
544 | -- restriction, or a parameter restriction with a value of zero and an | |
545 | -- unknown count, or a parameter restriction with a known value that | |
546 | -- exceeds the restriction count). | |
6e937c1c AC |
547 | |
548 | elsif R in All_Boolean_Restrictions | |
549 | or else (Restrictions.Unknown (R) | |
550 | and then Restrictions.Value (R) = 0) | |
551 | or else Restrictions.Count (R) > Restrictions.Value (R) | |
19235870 | 552 | then |
23685ae6 | 553 | Msg_Issued := True; |
9b7c38af | 554 | Restriction_Msg (R, N); |
19235870 | 555 | end if; |
1696d58d ES |
556 | |
557 | -- For Max_Entries and the like, do not carry forward the violation | |
558 | -- count because it does not affect later declarations. | |
559 | ||
560 | if R in Checked_Max_Parameter_Restrictions then | |
561 | Restrictions.Count (R) := 0; | |
b6621d10 | 562 | Restrictions.Violated (R) := False; |
1696d58d | 563 | end if; |
19235870 RK |
564 | end Check_Restriction; |
565 | ||
5f3ab6fb AC |
566 | ------------------------------------- |
567 | -- Check_Restriction_No_Dependence -- | |
568 | ------------------------------------- | |
569 | ||
570 | procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is | |
5f3ab6fb | 571 | begin |
bf327c92 AC |
572 | -- Ignore call if node U is not in the main source unit. This avoids |
573 | -- cascaded errors, e.g. when Ada.Containers units with other units. | |
3b8056a5 AC |
574 | -- However, allow Standard_Location here, since this catches some cases |
575 | -- of constructs that get converted to run-time calls. | |
bf327c92 | 576 | |
3b8056a5 AC |
577 | if not In_Extended_Main_Source_Unit (U) |
578 | and then Sloc (U) /= Standard_Location | |
579 | then | |
bf327c92 AC |
580 | return; |
581 | end if; | |
582 | ||
583 | -- Loop through entries in No_Dependence table to check each one in turn | |
584 | ||
e7fceebc | 585 | for J in No_Dependences.First .. No_Dependences.Last loop |
433cefcd EB |
586 | if Same_Unit (No_Dependences.Table (J).Unit, U) then |
587 | Violation_Of_No_Dependence (J, Err); | |
588 | return; | |
589 | end if; | |
590 | end loop; | |
591 | end Check_Restriction_No_Dependence; | |
5f3ab6fb | 592 | |
433cefcd EB |
593 | ----------------------------------------------- |
594 | -- Check_Restriction_No_Dependence_On_System -- | |
595 | ----------------------------------------------- | |
5f3ab6fb | 596 | |
433cefcd EB |
597 | procedure Check_Restriction_No_Dependence_On_System |
598 | (U : Name_Id; | |
599 | Err : Node_Id) | |
600 | is | |
601 | pragma Assert (U /= No_Name); | |
602 | ||
603 | begin | |
604 | -- Loop through entries in No_Dependence table to check each one in turn | |
5f3ab6fb | 605 | |
433cefcd EB |
606 | for J in No_Dependences.First .. No_Dependences.Last loop |
607 | if No_Dependences.Table (J).System_Child = U then | |
608 | Violation_Of_No_Dependence (J, Err); | |
5f3ab6fb AC |
609 | return; |
610 | end if; | |
611 | end loop; | |
433cefcd | 612 | end Check_Restriction_No_Dependence_On_System; |
5f3ab6fb | 613 | |
e7fceebc AC |
614 | -------------------------------------------------- |
615 | -- Check_Restriction_No_Specification_Of_Aspect -- | |
616 | -------------------------------------------------- | |
617 | ||
618 | procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id) is | |
619 | A_Id : Aspect_Id; | |
620 | Id : Node_Id; | |
621 | ||
622 | begin | |
623 | -- Ignore call if no instances of this restriction set | |
624 | ||
625 | if not No_Specification_Of_Aspect_Set then | |
626 | return; | |
627 | end if; | |
628 | ||
629 | -- Ignore call if node N is not in the main source unit, since we only | |
c5d00db0 AC |
630 | -- give messages for the main unit. This avoids giving messages for |
631 | -- aspects that are specified in withed units. | |
e7fceebc AC |
632 | |
633 | if not In_Extended_Main_Source_Unit (N) then | |
634 | return; | |
635 | end if; | |
636 | ||
d4175ef4 GL |
637 | if Nkind (N) = N_Pragma then |
638 | Id := Pragma_Identifier (N); | |
639 | elsif Nkind (N) = N_Attribute_Definition_Clause then | |
640 | Id := N; | |
641 | else | |
642 | Id := Identifier (N); | |
643 | end if; | |
644 | ||
e7fceebc AC |
645 | A_Id := Get_Aspect_Id (Chars (Id)); |
646 | pragma Assert (A_Id /= No_Aspect); | |
647 | ||
648 | Error_Msg_Sloc := No_Specification_Of_Aspects (A_Id); | |
649 | ||
650 | if Error_Msg_Sloc /= No_Location then | |
651 | Error_Msg_Node_1 := Id; | |
652 | Error_Msg_Warn := No_Specification_Of_Aspect_Warning (A_Id); | |
653 | Error_Msg_N | |
23e28b42 | 654 | ("<*<violation of restriction `No_Specification_Of_Aspect '='> &`#", |
e7fceebc AC |
655 | Id); |
656 | end if; | |
657 | end Check_Restriction_No_Specification_Of_Aspect; | |
658 | ||
810241a5 AC |
659 | ------------------------------------------- |
660 | -- Check_Restriction_No_Use_Of_Attribute -- | |
661 | -------------------------------------------- | |
662 | ||
663 | procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id) is | |
58ba2415 HK |
664 | Attr_Id : Attribute_Id; |
665 | Attr_Nam : Name_Id; | |
810241a5 AC |
666 | |
667 | begin | |
58ba2415 HK |
668 | -- Nothing to do if the attribute is not in the main source unit, since |
669 | -- we only give messages for the main unit. This avoids giving messages | |
670 | -- for attributes that are specified in withed units. | |
810241a5 AC |
671 | |
672 | if not In_Extended_Main_Source_Unit (N) then | |
673 | return; | |
810241a5 | 674 | |
58ba2415 HK |
675 | -- Nothing to do if not checking No_Use_Of_Attribute |
676 | ||
677 | elsif not No_Use_Of_Attribute_Set then | |
678 | return; | |
679 | ||
680 | -- Do not consider internally generated attributes because this leads to | |
681 | -- bizarre errors. | |
810241a5 | 682 | |
58ba2415 | 683 | elsif not Comes_From_Source (N) then |
810241a5 AC |
684 | return; |
685 | end if; | |
686 | ||
58ba2415 HK |
687 | if Nkind (N) = N_Attribute_Definition_Clause then |
688 | Attr_Nam := Chars (N); | |
689 | else | |
690 | pragma Assert (Nkind (N) = N_Attribute_Reference); | |
691 | Attr_Nam := Attribute_Name (N); | |
692 | end if; | |
693 | ||
694 | Attr_Id := Get_Attribute_Id (Attr_Nam); | |
695 | Error_Msg_Sloc := No_Use_Of_Attribute (Attr_Id); | |
810241a5 AC |
696 | |
697 | if Error_Msg_Sloc /= No_Location then | |
58ba2415 HK |
698 | Error_Msg_Name_1 := Attr_Nam; |
699 | Error_Msg_Warn := No_Use_Of_Attribute_Warning (Attr_Id); | |
810241a5 | 700 | Error_Msg_N |
58ba2415 | 701 | ("<*<violation of restriction `No_Use_Of_Attribute '='> %` #", N); |
810241a5 AC |
702 | end if; |
703 | end Check_Restriction_No_Use_Of_Attribute; | |
704 | ||
18dae814 RD |
705 | ---------------------------------------- |
706 | -- Check_Restriction_No_Use_Of_Entity -- | |
707 | ---------------------------------------- | |
708 | ||
709 | procedure Check_Restriction_No_Use_Of_Entity (N : Node_Id) is | |
710 | begin | |
711 | -- Error defence (not clearly necessary, but better safe) | |
712 | ||
713 | if No (Entity (N)) then | |
714 | return; | |
715 | end if; | |
716 | ||
717 | -- If simple name of entity not flagged with Boolean2 flag, then there | |
718 | -- cannot be a matching entry in the table, so skip the search. | |
719 | ||
720 | if Get_Name_Table_Boolean2 (Chars (Entity (N))) = False then | |
721 | return; | |
722 | end if; | |
723 | ||
58ba2415 HK |
724 | -- Restriction is only recognized within a configuration pragma file, |
725 | -- or within a unit of the main extended program. Note: the test for | |
726 | -- Main_Unit is needed to properly include the case of configuration | |
727 | -- pragma files. | |
18dae814 RD |
728 | |
729 | if Current_Sem_Unit /= Main_Unit | |
730 | and then not In_Extended_Main_Source_Unit (N) | |
731 | then | |
732 | return; | |
733 | end if; | |
734 | ||
735 | -- Here we must search the table | |
736 | ||
737 | for J in No_Use_Of_Entity.First .. No_Use_Of_Entity.Last loop | |
738 | declare | |
739 | NE_Ent : NE_Entry renames No_Use_Of_Entity.Table (J); | |
740 | Ent : Entity_Id; | |
741 | Expr : Node_Id; | |
742 | ||
743 | begin | |
744 | Ent := Entity (N); | |
745 | Expr := NE_Ent.Entity; | |
746 | loop | |
fb757f7d AC |
747 | -- Here if at outer level of entity name in reference (handle |
748 | -- also the direct use of Text_IO in the pragma). For example: | |
749 | -- pragma Restrictions (No_Use_Of_Entity => Text_IO.Put); | |
750 | ||
751 | if Scope (Ent) = Standard_Standard | |
752 | or else (Nkind (Expr) = N_Identifier | |
753 | and then Chars (Ent) = Name_Text_IO | |
754 | and then Chars (Scope (Ent)) = Name_Ada | |
755 | and then Scope (Scope (Ent)) = Standard_Standard) | |
756 | then | |
4a08c95c | 757 | if Nkind (Expr) in N_Identifier | N_Operator_Symbol |
18dae814 RD |
758 | and then Chars (Ent) = Chars (Expr) |
759 | then | |
760 | Error_Msg_Node_1 := N; | |
761 | Error_Msg_Warn := NE_Ent.Warn; | |
762 | Error_Msg_Sloc := Sloc (NE_Ent.Entity); | |
763 | Error_Msg_N | |
764 | ("<*<reference to & violates restriction " | |
765 | & "No_Use_Of_Entity #", N); | |
766 | return; | |
767 | ||
768 | else | |
fb757f7d | 769 | exit; |
18dae814 RD |
770 | end if; |
771 | ||
772 | -- Here if at outer level of entity name in table | |
773 | ||
4a08c95c | 774 | elsif Nkind (Expr) in N_Identifier | N_Operator_Symbol then |
fb757f7d | 775 | exit; |
18dae814 RD |
776 | |
777 | -- Here if neither at the outer level | |
778 | ||
779 | else | |
780 | pragma Assert (Nkind (Expr) = N_Selected_Component); | |
fb757f7d | 781 | exit when Chars (Selector_Name (Expr)) /= Chars (Ent); |
18dae814 RD |
782 | end if; |
783 | ||
784 | -- Move up a level | |
785 | ||
786 | loop | |
787 | Ent := Scope (Ent); | |
788 | exit when not Is_Internal_Name (Chars (Ent)); | |
789 | end loop; | |
790 | ||
791 | Expr := Prefix (Expr); | |
18dae814 RD |
792 | end loop; |
793 | end; | |
794 | end loop; | |
795 | end Check_Restriction_No_Use_Of_Entity; | |
796 | ||
810241a5 AC |
797 | ---------------------------------------- |
798 | -- Check_Restriction_No_Use_Of_Pragma -- | |
799 | ---------------------------------------- | |
800 | ||
801 | procedure Check_Restriction_No_Use_Of_Pragma (N : Node_Id) is | |
802 | Id : constant Node_Id := Pragma_Identifier (N); | |
803 | P_Id : constant Pragma_Id := Get_Pragma_Id (Chars (Id)); | |
804 | ||
805 | begin | |
58ba2415 HK |
806 | -- Nothing to do if the pragma is not in the main source unit, since we |
807 | -- only give messages for the main unit. This avoids giving messages for | |
808 | -- pragmas that are specified in withed units. | |
810241a5 AC |
809 | |
810 | if not In_Extended_Main_Source_Unit (N) then | |
811 | return; | |
810241a5 | 812 | |
58ba2415 HK |
813 | -- Nothing to do if not checking No_Use_Of_Pragma |
814 | ||
815 | elsif not No_Use_Of_Pragma_Set then | |
816 | return; | |
817 | ||
818 | -- Do not consider internally generated pragmas because this leads to | |
819 | -- bizarre errors. | |
810241a5 | 820 | |
58ba2415 | 821 | elsif not Comes_From_Source (N) then |
810241a5 AC |
822 | return; |
823 | end if; | |
824 | ||
825 | Error_Msg_Sloc := No_Use_Of_Pragma (P_Id); | |
826 | ||
827 | if Error_Msg_Sloc /= No_Location then | |
810241a5 AC |
828 | Error_Msg_Warn := No_Use_Of_Pragma_Warning (P_Id); |
829 | Error_Msg_N | |
58ba2415 | 830 | ("<*<violation of restriction `No_Use_Of_Pragma '='> &` #", Id); |
810241a5 AC |
831 | end if; |
832 | end Check_Restriction_No_Use_Of_Pragma; | |
833 | ||
30196a76 RD |
834 | -------------------------------------- |
835 | -- Check_Wide_Character_Restriction -- | |
836 | -------------------------------------- | |
837 | ||
838 | procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is | |
839 | begin | |
7a963087 | 840 | if Restriction_Check_Required (No_Wide_Characters) |
30196a76 RD |
841 | and then Comes_From_Source (N) |
842 | then | |
843 | declare | |
844 | T : constant Entity_Id := Root_Type (E); | |
845 | begin | |
846 | if T = Standard_Wide_Character or else | |
847 | T = Standard_Wide_String or else | |
848 | T = Standard_Wide_Wide_Character or else | |
849 | T = Standard_Wide_Wide_String | |
850 | then | |
851 | Check_Restriction (No_Wide_Characters, N); | |
852 | end if; | |
853 | end; | |
854 | end if; | |
855 | end Check_Wide_Character_Restriction; | |
856 | ||
6e937c1c AC |
857 | ---------------------------------------- |
858 | -- Cunit_Boolean_Restrictions_Restore -- | |
859 | ---------------------------------------- | |
19235870 | 860 | |
6e937c1c AC |
861 | procedure Cunit_Boolean_Restrictions_Restore |
862 | (R : Save_Cunit_Boolean_Restrictions) | |
19235870 RK |
863 | is |
864 | begin | |
6e937c1c AC |
865 | for J in Cunit_Boolean_Restrictions loop |
866 | Restrictions.Set (J) := R (J); | |
19235870 | 867 | end loop; |
51fb9b73 RD |
868 | |
869 | -- If No_Elaboration_Code set in configuration restrictions, and we | |
870 | -- in the main extended source, then set it here now. This is part of | |
871 | -- the special processing for No_Elaboration_Code. | |
872 | ||
873 | if In_Extended_Main_Source_Unit (Cunit_Entity (Current_Sem_Unit)) | |
874 | and then Config_Cunit_Boolean_Restrictions (No_Elaboration_Code) | |
875 | then | |
876 | Restrictions.Set (No_Elaboration_Code) := True; | |
877 | end if; | |
6e937c1c | 878 | end Cunit_Boolean_Restrictions_Restore; |
19235870 | 879 | |
6e937c1c AC |
880 | ------------------------------------- |
881 | -- Cunit_Boolean_Restrictions_Save -- | |
882 | ------------------------------------- | |
19235870 | 883 | |
6e937c1c AC |
884 | function Cunit_Boolean_Restrictions_Save |
885 | return Save_Cunit_Boolean_Restrictions | |
19235870 | 886 | is |
6e937c1c | 887 | R : Save_Cunit_Boolean_Restrictions; |
19235870 RK |
888 | |
889 | begin | |
6e937c1c AC |
890 | for J in Cunit_Boolean_Restrictions loop |
891 | R (J) := Restrictions.Set (J); | |
19235870 RK |
892 | end loop; |
893 | ||
894 | return R; | |
6e937c1c | 895 | end Cunit_Boolean_Restrictions_Save; |
19235870 | 896 | |
19235870 RK |
897 | ------------------------ |
898 | -- Get_Restriction_Id -- | |
899 | ------------------------ | |
900 | ||
901 | function Get_Restriction_Id | |
6e937c1c | 902 | (N : Name_Id) return Restriction_Id |
19235870 | 903 | is |
19235870 RK |
904 | begin |
905 | Get_Name_String (N); | |
906 | Set_Casing (All_Upper_Case); | |
907 | ||
6e937c1c | 908 | for J in All_Restrictions loop |
19235870 RK |
909 | declare |
910 | S : constant String := Restriction_Id'Image (J); | |
19235870 | 911 | begin |
24dde337 SB |
912 | if S = Name_Buffer (1 .. Name_Len) |
913 | -- users cannot name the N_T_H_Implicit restriction | |
914 | and then J /= No_Task_Hierarchy_Implicit | |
915 | then | |
6e937c1c AC |
916 | return J; |
917 | end if; | |
19235870 | 918 | end; |
19235870 RK |
919 | end loop; |
920 | ||
6e937c1c | 921 | return Not_A_Restriction_Id; |
19235870 RK |
922 | end Get_Restriction_Id; |
923 | ||
a7837c08 JM |
924 | ----------------------- |
925 | -- Global_No_Tasking -- | |
926 | ----------------------- | |
927 | ||
928 | function Global_No_Tasking return Boolean is | |
929 | begin | |
dae4f504 JM |
930 | return Global_Restriction_No_Tasking |
931 | or else Targparm.Restrictions_On_Target.Set (No_Tasking); | |
a7837c08 JM |
932 | end Global_No_Tasking; |
933 | ||
bcb8c3bb JS |
934 | --------------------------------------------- |
935 | -- No_Dynamic_Accessibility_Checks_Enabled -- | |
936 | --------------------------------------------- | |
937 | ||
938 | function No_Dynamic_Accessibility_Checks_Enabled | |
939 | (N : Node_Id) return Boolean | |
940 | is | |
941 | pragma Unreferenced (N); | |
942 | -- N is currently unreferenced but present for debugging purposes and | |
943 | -- potential future use. | |
944 | ||
945 | begin | |
946 | return Restrictions.Set (No_Dynamic_Accessibility_Checks); | |
947 | end No_Dynamic_Accessibility_Checks_Enabled; | |
948 | ||
19235870 RK |
949 | ------------------------------- |
950 | -- No_Exception_Handlers_Set -- | |
951 | ------------------------------- | |
952 | ||
953 | function No_Exception_Handlers_Set return Boolean is | |
954 | begin | |
6790c865 AC |
955 | return (No_Run_Time_Mode or else Configurable_Run_Time_Mode) |
956 | and then (Restrictions.Set (No_Exception_Handlers) | |
957 | or else | |
958 | Restrictions.Set (No_Exception_Propagation)); | |
19235870 RK |
959 | end No_Exception_Handlers_Set; |
960 | ||
06eab6a7 RD |
961 | ------------------------------------- |
962 | -- No_Exception_Propagation_Active -- | |
963 | ------------------------------------- | |
964 | ||
965 | function No_Exception_Propagation_Active return Boolean is | |
966 | begin | |
967 | return (No_Run_Time_Mode | |
968 | or else Configurable_Run_Time_Mode | |
969 | or else Debug_Flag_Dot_G) | |
970 | and then Restriction_Active (No_Exception_Propagation); | |
971 | end No_Exception_Propagation_Active; | |
972 | ||
2cbac6c6 AC |
973 | -------------------------------- |
974 | -- OK_No_Dependence_Unit_Name -- | |
975 | -------------------------------- | |
976 | ||
977 | function OK_No_Dependence_Unit_Name (N : Node_Id) return Boolean is | |
978 | begin | |
979 | if Nkind (N) = N_Selected_Component then | |
980 | return | |
981 | OK_No_Dependence_Unit_Name (Prefix (N)) | |
982 | and then | |
983 | OK_No_Dependence_Unit_Name (Selector_Name (N)); | |
984 | ||
985 | elsif Nkind (N) = N_Identifier then | |
986 | return True; | |
987 | ||
988 | else | |
989 | Error_Msg_N ("wrong form for unit name for No_Dependence", N); | |
990 | return False; | |
991 | end if; | |
992 | end OK_No_Dependence_Unit_Name; | |
993 | ||
18dae814 RD |
994 | ------------------------------ |
995 | -- OK_No_Use_Of_Entity_Name -- | |
996 | ------------------------------ | |
997 | ||
998 | function OK_No_Use_Of_Entity_Name (N : Node_Id) return Boolean is | |
999 | begin | |
1000 | if Nkind (N) = N_Selected_Component then | |
1001 | return | |
1002 | OK_No_Use_Of_Entity_Name (Prefix (N)) | |
1003 | and then | |
1004 | OK_No_Use_Of_Entity_Name (Selector_Name (N)); | |
1005 | ||
4a08c95c | 1006 | elsif Nkind (N) in N_Identifier | N_Operator_Symbol then |
18dae814 RD |
1007 | return True; |
1008 | ||
1009 | else | |
1010 | Error_Msg_N ("wrong form for entity name for No_Use_Of_Entity", N); | |
1011 | return False; | |
1012 | end if; | |
1013 | end OK_No_Use_Of_Entity_Name; | |
1014 | ||
b5e792e2 AC |
1015 | ---------------------------------- |
1016 | -- Process_Restriction_Synonyms -- | |
1017 | ---------------------------------- | |
1018 | ||
4887624e AC |
1019 | -- Note: body of this function must be coordinated with list of renaming |
1020 | -- declarations in System.Rident. | |
b5e792e2 | 1021 | |
497a660d | 1022 | function Process_Restriction_Synonyms (N : Node_Id) return Name_Id is |
cc335f43 AC |
1023 | Old_Name : constant Name_Id := Chars (N); |
1024 | New_Name : Name_Id; | |
1025 | ||
b5e792e2 | 1026 | begin |
cc335f43 | 1027 | case Old_Name is |
b5e792e2 | 1028 | when Name_Boolean_Entry_Barriers => |
cc335f43 | 1029 | New_Name := Name_Simple_Barriers; |
b5e792e2 AC |
1030 | |
1031 | when Name_Max_Entry_Queue_Depth => | |
cc335f43 | 1032 | New_Name := Name_Max_Entry_Queue_Length; |
b5e792e2 AC |
1033 | |
1034 | when Name_No_Dynamic_Interrupts => | |
cc335f43 | 1035 | New_Name := Name_No_Dynamic_Attachment; |
b5e792e2 AC |
1036 | |
1037 | when Name_No_Requeue => | |
cc335f43 | 1038 | New_Name := Name_No_Requeue_Statements; |
b5e792e2 AC |
1039 | |
1040 | when Name_No_Task_Attributes => | |
cc335f43 | 1041 | New_Name := Name_No_Task_Attributes_Package; |
b5e792e2 AC |
1042 | |
1043 | when others => | |
cc335f43 | 1044 | return Old_Name; |
b5e792e2 | 1045 | end case; |
cc335f43 | 1046 | |
7907619e | 1047 | -- Output warning if we are warning on obsolescent features. |
aa0dfa7e | 1048 | |
cc335f43 AC |
1049 | if Warn_On_Obsolescent_Feature then |
1050 | Error_Msg_Name_1 := Old_Name; | |
685bc70f | 1051 | Error_Msg_N ("restriction identifier % is obsolescent?j?", N); |
cc335f43 | 1052 | Error_Msg_Name_1 := New_Name; |
685bc70f | 1053 | Error_Msg_N ("|use restriction identifier % instead?j?", N); |
cc335f43 AC |
1054 | end if; |
1055 | ||
1056 | return New_Name; | |
b5e792e2 AC |
1057 | end Process_Restriction_Synonyms; |
1058 | ||
51fb9b73 RD |
1059 | -------------------------------------- |
1060 | -- Reset_Cunit_Boolean_Restrictions -- | |
1061 | -------------------------------------- | |
1062 | ||
1063 | procedure Reset_Cunit_Boolean_Restrictions is | |
1064 | begin | |
1065 | for J in Cunit_Boolean_Restrictions loop | |
1066 | Restrictions.Set (J) := False; | |
1067 | end loop; | |
1068 | end Reset_Cunit_Boolean_Restrictions; | |
1069 | ||
1070 | ----------------------------------------------- | |
1071 | -- Restore_Config_Cunit_Boolean_Restrictions -- | |
1072 | ----------------------------------------------- | |
1073 | ||
1074 | procedure Restore_Config_Cunit_Boolean_Restrictions is | |
1075 | begin | |
1076 | Cunit_Boolean_Restrictions_Restore (Config_Cunit_Boolean_Restrictions); | |
1077 | end Restore_Config_Cunit_Boolean_Restrictions; | |
1078 | ||
19235870 RK |
1079 | ------------------------ |
1080 | -- Restricted_Profile -- | |
1081 | ------------------------ | |
1082 | ||
19235870 RK |
1083 | function Restricted_Profile return Boolean is |
1084 | begin | |
cc335f43 AC |
1085 | if Restricted_Profile_Cached then |
1086 | return Restricted_Profile_Result; | |
1087 | ||
1088 | else | |
1089 | Restricted_Profile_Result := True; | |
1090 | Restricted_Profile_Cached := True; | |
1091 | ||
1092 | declare | |
393525af | 1093 | R : Restriction_Flags renames |
f31dcd99 | 1094 | Profile_Info (Restricted_Tasking).Set; |
393525af | 1095 | V : Restriction_Values renames |
f31dcd99 | 1096 | Profile_Info (Restricted_Tasking).Value; |
cc335f43 AC |
1097 | begin |
1098 | for J in R'Range loop | |
1099 | if R (J) | |
1100 | and then (Restrictions.Set (J) = False | |
f31dcd99 HK |
1101 | or else Restriction_Warnings (J) |
1102 | or else | |
1103 | (J in All_Parameter_Restrictions | |
1104 | and then Restrictions.Value (J) > V (J))) | |
cc335f43 AC |
1105 | then |
1106 | Restricted_Profile_Result := False; | |
1107 | exit; | |
1108 | end if; | |
1109 | end loop; | |
1110 | ||
1111 | return Restricted_Profile_Result; | |
1112 | end; | |
1113 | end if; | |
19235870 RK |
1114 | end Restricted_Profile; |
1115 | ||
6e937c1c AC |
1116 | ------------------------ |
1117 | -- Restriction_Active -- | |
1118 | ------------------------ | |
1119 | ||
1120 | function Restriction_Active (R : All_Restrictions) return Boolean is | |
1121 | begin | |
24dde337 SB |
1122 | if Restrictions.Set (R) and then not Restriction_Warnings (R) then |
1123 | return True; | |
1124 | else | |
1125 | return R = No_Task_Hierarchy | |
1126 | and then Restriction_Active (No_Task_Hierarchy_Implicit); | |
1127 | end if; | |
6e937c1c AC |
1128 | end Restriction_Active; |
1129 | ||
7a963087 RD |
1130 | -------------------------------- |
1131 | -- Restriction_Check_Required -- | |
1132 | -------------------------------- | |
1133 | ||
1134 | function Restriction_Check_Required (R : All_Restrictions) return Boolean is | |
1135 | begin | |
1136 | return Restrictions.Set (R); | |
1137 | end Restriction_Check_Required; | |
1138 | ||
fbf5a39b AC |
1139 | --------------------- |
1140 | -- Restriction_Msg -- | |
1141 | --------------------- | |
1142 | ||
9b7c38af RD |
1143 | procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is |
1144 | Msg : String (1 .. 100); | |
1145 | Len : Natural := 0; | |
19235870 | 1146 | |
9b7c38af RD |
1147 | procedure Add_Char (C : Character); |
1148 | -- Append given character to Msg, bumping Len | |
fbf5a39b | 1149 | |
9b7c38af RD |
1150 | procedure Add_Str (S : String); |
1151 | -- Append given string to Msg, bumping Len appropriately | |
1152 | ||
1153 | procedure Id_Case (S : String; Quotes : Boolean := True); | |
7907619e | 1154 | -- Given a string S, case it according to current identifier casing, and |
aa0dfa7e AC |
1155 | -- store in Error_Msg_String. Then append `~` to the message buffer |
1156 | -- to output the string unchanged surrounded in quotes. The quotes | |
1157 | -- are suppressed if Quotes = False. | |
9b7c38af RD |
1158 | |
1159 | -------------- | |
1160 | -- Add_Char -- | |
1161 | -------------- | |
1162 | ||
1163 | procedure Add_Char (C : Character) is | |
1164 | begin | |
1165 | Len := Len + 1; | |
1166 | Msg (Len) := C; | |
1167 | end Add_Char; | |
1168 | ||
1169 | ------------- | |
1170 | -- Add_Str -- | |
1171 | ------------- | |
fbf5a39b | 1172 | |
9b7c38af RD |
1173 | procedure Add_Str (S : String) is |
1174 | begin | |
1175 | Msg (Len + 1 .. Len + S'Length) := S; | |
1176 | Len := Len + S'Length; | |
1177 | end Add_Str; | |
fbf5a39b | 1178 | |
9b7c38af RD |
1179 | ------------- |
1180 | -- Id_Case -- | |
1181 | ------------- | |
1182 | ||
1183 | procedure Id_Case (S : String; Quotes : Boolean := True) is | |
1184 | begin | |
1185 | Name_Buffer (1 .. S'Last) := S; | |
1186 | Name_Len := S'Length; | |
7907619e | 1187 | Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N)))); |
9b7c38af RD |
1188 | Error_Msg_Strlen := Name_Len; |
1189 | Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); | |
1190 | ||
1191 | if Quotes then | |
1192 | Add_Str ("`~`"); | |
fbf5a39b | 1193 | else |
9b7c38af RD |
1194 | Add_Char ('~'); |
1195 | end if; | |
1196 | end Id_Case; | |
1197 | ||
1198 | -- Start of processing for Restriction_Msg | |
1199 | ||
1200 | begin | |
1201 | -- Set warning message if warning | |
1202 | ||
1203 | if Restriction_Warnings (R) then | |
17cf9038 | 1204 | Add_Str ("?*?"); |
9b7c38af RD |
1205 | |
1206 | -- If real violation (not warning), then mark it as non-serious unless | |
1207 | -- it is a violation of No_Finalization in which case we leave it as a | |
1208 | -- serious message, since otherwise we get crashes during attempts to | |
1209 | -- expand stuff that is not properly formed due to assumptions made | |
1210 | -- about no finalization being present. | |
1211 | ||
1212 | elsif R /= No_Finalization then | |
1213 | Add_Char ('|'); | |
1214 | end if; | |
1215 | ||
1216 | Error_Msg_Sloc := Restrictions_Loc (R); | |
1217 | ||
1218 | -- Set main message, adding implicit if no source location | |
1219 | ||
1220 | if Error_Msg_Sloc > No_Location | |
1221 | or else Error_Msg_Sloc = System_Location | |
1222 | then | |
1223 | Add_Str ("violation of restriction "); | |
1224 | else | |
1225 | Add_Str ("violation of implicit restriction "); | |
1226 | Error_Msg_Sloc := No_Location; | |
1227 | end if; | |
1228 | ||
dcffd515 | 1229 | -- Case of parameterized restriction |
9b7c38af RD |
1230 | |
1231 | if R in All_Parameter_Restrictions then | |
1232 | Add_Char ('`'); | |
1233 | Id_Case (Restriction_Id'Image (R), Quotes => False); | |
1234 | Add_Str (" = ^`"); | |
1235 | Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R))); | |
1236 | ||
1237 | -- Case of boolean restriction | |
1238 | ||
1239 | else | |
1240 | Id_Case (Restriction_Id'Image (R)); | |
1241 | end if; | |
1242 | ||
1243 | -- Case of no secondary profile continuation message | |
1244 | ||
1245 | if Restriction_Profile_Name (R) = No_Profile then | |
1246 | if Error_Msg_Sloc /= No_Location then | |
1247 | Add_Char ('#'); | |
1248 | end if; | |
1249 | ||
1250 | Add_Char ('!'); | |
1251 | Error_Msg_N (Msg (1 .. Len), N); | |
1252 | ||
1253 | -- Case of secondary profile continuation message present | |
1254 | ||
1255 | else | |
1256 | Add_Char ('!'); | |
1257 | Error_Msg_N (Msg (1 .. Len), N); | |
1258 | ||
1259 | Len := 0; | |
1260 | Add_Char ('\'); | |
1261 | ||
1262 | -- Set as warning if warning case | |
1263 | ||
1264 | if Restriction_Warnings (R) then | |
685bc70f | 1265 | Add_Str ("??"); |
fbf5a39b | 1266 | end if; |
fbf5a39b | 1267 | |
9b7c38af RD |
1268 | -- Set main message |
1269 | ||
1270 | Add_Str ("from profile "); | |
1271 | Id_Case (Profile_Name'Image (Restriction_Profile_Name (R))); | |
1272 | ||
1273 | -- Add location if we have one | |
1274 | ||
1275 | if Error_Msg_Sloc /= No_Location then | |
1276 | Add_Char ('#'); | |
1277 | end if; | |
1278 | ||
1279 | -- Output unconditional message and we are done | |
1280 | ||
1281 | Add_Char ('!'); | |
1282 | Error_Msg_N (Msg (1 .. Len), N); | |
1283 | end if; | |
fbf5a39b | 1284 | end Restriction_Msg; |
19235870 | 1285 | |
18dae814 RD |
1286 | ----------------- |
1287 | -- Same_Entity -- | |
1288 | ----------------- | |
1289 | ||
1290 | function Same_Entity (E1, E2 : Node_Id) return Boolean is | |
1291 | begin | |
4a08c95c | 1292 | if Nkind (E1) in N_Identifier | N_Operator_Symbol |
18dae814 | 1293 | and then |
4a08c95c | 1294 | Nkind (E2) in N_Identifier | N_Operator_Symbol |
18dae814 RD |
1295 | then |
1296 | return Chars (E1) = Chars (E2); | |
1297 | ||
4a08c95c | 1298 | elsif Nkind (E1) in N_Selected_Component | N_Expanded_Name |
18dae814 | 1299 | and then |
4a08c95c | 1300 | Nkind (E2) in N_Selected_Component | N_Expanded_Name |
18dae814 RD |
1301 | then |
1302 | return Same_Unit (Prefix (E1), Prefix (E2)) | |
1303 | and then | |
1304 | Same_Unit (Selector_Name (E1), Selector_Name (E2)); | |
1305 | else | |
1306 | return False; | |
1307 | end if; | |
1308 | end Same_Entity; | |
1309 | ||
5f3ab6fb AC |
1310 | --------------- |
1311 | -- Same_Unit -- | |
1312 | --------------- | |
1313 | ||
1314 | function Same_Unit (U1, U2 : Node_Id) return Boolean is | |
1315 | begin | |
d7a3e18c AC |
1316 | if Nkind (U1) = N_Identifier and then Nkind (U2) = N_Identifier then |
1317 | return Chars (U1) = Chars (U2); | |
5f3ab6fb | 1318 | |
4a08c95c | 1319 | elsif Nkind (U1) in N_Selected_Component | N_Expanded_Name |
d7a3e18c | 1320 | and then |
4a08c95c | 1321 | Nkind (U2) in N_Selected_Component | N_Expanded_Name |
5f3ab6fb AC |
1322 | then |
1323 | return Same_Unit (Prefix (U1), Prefix (U2)) | |
d7a3e18c AC |
1324 | and then |
1325 | Same_Unit (Selector_Name (U1), Selector_Name (U2)); | |
5f3ab6fb AC |
1326 | else |
1327 | return False; | |
1328 | end if; | |
1329 | end Same_Unit; | |
1330 | ||
51fb9b73 RD |
1331 | -------------------------------------------- |
1332 | -- Save_Config_Cunit_Boolean_Restrictions -- | |
1333 | -------------------------------------------- | |
1334 | ||
1335 | procedure Save_Config_Cunit_Boolean_Restrictions is | |
1336 | begin | |
1337 | Config_Cunit_Boolean_Restrictions := Cunit_Boolean_Restrictions_Save; | |
1338 | end Save_Config_Cunit_Boolean_Restrictions; | |
1339 | ||
cc335f43 AC |
1340 | ------------------------------ |
1341 | -- Set_Profile_Restrictions -- | |
1342 | ------------------------------ | |
1343 | ||
1344 | procedure Set_Profile_Restrictions | |
1345 | (P : Profile_Name; | |
1346 | N : Node_Id; | |
1347 | Warn : Boolean) | |
1348 | is | |
1349 | R : Restriction_Flags renames Profile_Info (P).Set; | |
1350 | V : Restriction_Values renames Profile_Info (P).Value; | |
19235870 | 1351 | |
6e937c1c | 1352 | begin |
cc335f43 AC |
1353 | for J in R'Range loop |
1354 | if R (J) then | |
de397a3d AC |
1355 | declare |
1356 | Already_Restricted : constant Boolean := Restriction_Active (J); | |
1357 | ||
1358 | begin | |
1359 | -- Set the restriction | |
1360 | ||
1361 | if J in All_Boolean_Restrictions then | |
1362 | Set_Restriction (J, N); | |
1363 | else | |
1364 | Set_Restriction (J, N, V (J)); | |
1365 | end if; | |
1366 | ||
9b7c38af RD |
1367 | -- Record that this came from a Profile[_Warnings] restriction |
1368 | ||
1369 | Restriction_Profile_Name (J) := P; | |
1370 | ||
de397a3d AC |
1371 | -- Set warning flag, except that we do not set the warning |
1372 | -- flag if the restriction was already active and this is | |
1373 | -- the warning case. That avoids a warning overriding a real | |
1374 | -- restriction, which should never happen. | |
cc335f43 | 1375 | |
de397a3d AC |
1376 | if not (Warn and Already_Restricted) then |
1377 | Restriction_Warnings (J) := Warn; | |
1378 | end if; | |
1379 | end; | |
cc335f43 AC |
1380 | end if; |
1381 | end loop; | |
1382 | end Set_Profile_Restrictions; | |
6e937c1c AC |
1383 | |
1384 | --------------------- | |
1385 | -- Set_Restriction -- | |
1386 | --------------------- | |
1387 | ||
6e937c1c AC |
1388 | procedure Set_Restriction |
1389 | (R : All_Boolean_Restrictions; | |
1390 | N : Node_Id) | |
1391 | is | |
19235870 | 1392 | begin |
6e937c1c AC |
1393 | Restrictions.Set (R) := True; |
1394 | ||
cc335f43 AC |
1395 | if Restricted_Profile_Cached and Restricted_Profile_Result then |
1396 | null; | |
1397 | else | |
1398 | Restricted_Profile_Cached := False; | |
1399 | end if; | |
1400 | ||
9b7c38af RD |
1401 | -- Set location, but preserve location of system restriction for nice |
1402 | -- error msg with run time name. | |
6e937c1c AC |
1403 | |
1404 | if Restrictions_Loc (R) /= System_Location then | |
1405 | Restrictions_Loc (R) := Sloc (N); | |
19235870 | 1406 | end if; |
6e937c1c | 1407 | |
9b7c38af RD |
1408 | -- Note restriction came from restriction pragma, not profile |
1409 | ||
1410 | Restriction_Profile_Name (R) := No_Profile; | |
1411 | ||
de397a3d AC |
1412 | -- Record the restriction if we are in the main unit, or in the extended |
1413 | -- main unit. The reason that we test separately for Main_Unit is that | |
1414 | -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in | |
1415 | -- gnat.adc do not appear to be in the extended main source unit (they | |
1416 | -- probably should do ???) | |
6e937c1c AC |
1417 | |
1418 | if Current_Sem_Unit = Main_Unit | |
1419 | or else In_Extended_Main_Source_Unit (N) | |
1420 | then | |
1421 | if not Restriction_Warnings (R) then | |
1422 | Main_Restrictions.Set (R) := True; | |
1423 | end if; | |
1424 | end if; | |
1425 | end Set_Restriction; | |
1426 | ||
6e937c1c AC |
1427 | procedure Set_Restriction |
1428 | (R : All_Parameter_Restrictions; | |
1429 | N : Node_Id; | |
1430 | V : Integer) | |
1431 | is | |
1432 | begin | |
cc335f43 AC |
1433 | if Restricted_Profile_Cached and Restricted_Profile_Result then |
1434 | null; | |
1435 | else | |
1436 | Restricted_Profile_Cached := False; | |
1437 | end if; | |
1438 | ||
6e937c1c AC |
1439 | if Restrictions.Set (R) then |
1440 | if V < Restrictions.Value (R) then | |
1441 | Restrictions.Value (R) := V; | |
1442 | Restrictions_Loc (R) := Sloc (N); | |
1443 | end if; | |
1444 | ||
1445 | else | |
1446 | Restrictions.Set (R) := True; | |
1447 | Restrictions.Value (R) := V; | |
1448 | Restrictions_Loc (R) := Sloc (N); | |
1449 | end if; | |
1450 | ||
9b7c38af RD |
1451 | -- Record the restriction if we are in the main unit, or in the extended |
1452 | -- main unit. The reason that we test separately for Main_Unit is that | |
1453 | -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in | |
1454 | -- gnat.adc do not appear to be the extended main source unit (they | |
1455 | -- probably should do ???) | |
6e937c1c AC |
1456 | |
1457 | if Current_Sem_Unit = Main_Unit | |
1458 | or else In_Extended_Main_Source_Unit (N) | |
1459 | then | |
1460 | if Main_Restrictions.Set (R) then | |
1461 | if V < Main_Restrictions.Value (R) then | |
1462 | Main_Restrictions.Value (R) := V; | |
1463 | end if; | |
1464 | ||
1465 | elsif not Restriction_Warnings (R) then | |
1466 | Main_Restrictions.Set (R) := True; | |
1467 | Main_Restrictions.Value (R) := V; | |
1468 | end if; | |
1469 | end if; | |
9b7c38af RD |
1470 | |
1471 | -- Note restriction came from restriction pragma, not profile | |
1472 | ||
1473 | Restriction_Profile_Name (R) := No_Profile; | |
6e937c1c | 1474 | end Set_Restriction; |
19235870 | 1475 | |
47484baa BD |
1476 | procedure Set_Restriction |
1477 | (R : All_Restrictions; | |
1478 | N : Node_Id; | |
1479 | Warn : Boolean; | |
1480 | V : Integer := Integer'First) | |
1481 | is | |
1482 | Set : Boolean := True; | |
1483 | begin | |
1484 | if Warn and then Restriction_Active (R) then | |
1485 | Set := False; | |
1486 | end if; | |
1487 | ||
1488 | if Set then | |
1489 | if R in All_Boolean_Restrictions then | |
1490 | Set_Restriction (R, N); | |
1491 | else | |
1492 | Set_Restriction (R, N, V); | |
1493 | end if; | |
1494 | ||
1495 | Restriction_Warnings (R) := Warn; | |
1496 | end if; | |
1497 | end Set_Restriction; | |
1498 | ||
5f3ab6fb AC |
1499 | ----------------------------------- |
1500 | -- Set_Restriction_No_Dependence -- | |
1501 | ----------------------------------- | |
1502 | ||
1503 | procedure Set_Restriction_No_Dependence | |
9b7c38af RD |
1504 | (Unit : Node_Id; |
1505 | Warn : Boolean; | |
1506 | Profile : Profile_Name := No_Profile) | |
5f3ab6fb | 1507 | is |
433cefcd EB |
1508 | ND : ND_Entry; |
1509 | ||
5f3ab6fb AC |
1510 | begin |
1511 | -- Loop to check for duplicate entry | |
1512 | ||
e7fceebc | 1513 | for J in No_Dependences.First .. No_Dependences.Last loop |
5f3ab6fb AC |
1514 | |
1515 | -- Case of entry already in table | |
1516 | ||
e7fceebc | 1517 | if Same_Unit (Unit, No_Dependences.Table (J).Unit) then |
5f3ab6fb AC |
1518 | |
1519 | -- Error has precedence over warning | |
1520 | ||
1521 | if not Warn then | |
e7fceebc | 1522 | No_Dependences.Table (J).Warn := False; |
5f3ab6fb AC |
1523 | end if; |
1524 | ||
1525 | return; | |
1526 | end if; | |
1527 | end loop; | |
1528 | ||
de397a3d | 1529 | -- Entry is not currently in table |
5f3ab6fb | 1530 | |
433cefcd EB |
1531 | ND := (Unit, No_Name, Warn, Profile); |
1532 | ||
1533 | -- Check whether this is a child unit of System | |
1534 | ||
1535 | if Nkind (Unit) = N_Selected_Component then | |
1536 | declare | |
1537 | Root : Node_Id := Unit; | |
1538 | ||
1539 | begin | |
1540 | while Nkind (Prefix (Root)) = N_Selected_Component loop | |
1541 | Root := Prefix (Root); | |
1542 | end loop; | |
1543 | ||
1544 | if Chars (Prefix (Root)) = Name_System then | |
1545 | ND.System_Child := Chars (Selector_Name (Root)); | |
1546 | end if; | |
1547 | end; | |
1548 | end if; | |
1549 | ||
1550 | No_Dependences.Append (ND); | |
5f3ab6fb AC |
1551 | end Set_Restriction_No_Dependence; |
1552 | ||
18dae814 RD |
1553 | -------------------------------------- |
1554 | -- Set_Restriction_No_Use_Of_Entity -- | |
1555 | -------------------------------------- | |
1556 | ||
1557 | procedure Set_Restriction_No_Use_Of_Entity | |
1558 | (Entity : Node_Id; | |
47484baa | 1559 | Warn : Boolean; |
18dae814 RD |
1560 | Profile : Profile_Name := No_Profile) |
1561 | is | |
1562 | Nam : Node_Id; | |
1563 | ||
1564 | begin | |
1565 | -- Loop to check for duplicate entry | |
1566 | ||
1567 | for J in No_Use_Of_Entity.First .. No_Use_Of_Entity.Last loop | |
1568 | ||
1569 | -- Case of entry already in table | |
1570 | ||
1571 | if Same_Entity (Entity, No_Use_Of_Entity.Table (J).Entity) then | |
1572 | ||
1573 | -- Error has precedence over warning | |
1574 | ||
47484baa | 1575 | if not Warn then |
18dae814 RD |
1576 | No_Use_Of_Entity.Table (J).Warn := False; |
1577 | end if; | |
1578 | ||
1579 | return; | |
1580 | end if; | |
1581 | end loop; | |
1582 | ||
1583 | -- Entry is not currently in table | |
1584 | ||
47484baa | 1585 | No_Use_Of_Entity.Append ((Entity, Warn, Profile)); |
18dae814 RD |
1586 | |
1587 | -- Now we need to find the direct name and set Boolean2 flag | |
1588 | ||
4a08c95c | 1589 | if Nkind (Entity) in N_Identifier | N_Operator_Symbol then |
18dae814 RD |
1590 | Nam := Entity; |
1591 | ||
1592 | else | |
1593 | pragma Assert (Nkind (Entity) = N_Selected_Component); | |
1594 | Nam := Selector_Name (Entity); | |
4a08c95c | 1595 | pragma Assert (Nkind (Nam) in N_Identifier | N_Operator_Symbol); |
18dae814 RD |
1596 | end if; |
1597 | ||
1598 | Set_Name_Table_Boolean2 (Chars (Nam), True); | |
1599 | end Set_Restriction_No_Use_Of_Entity; | |
1600 | ||
e7fceebc AC |
1601 | ------------------------------------------------ |
1602 | -- Set_Restriction_No_Specification_Of_Aspect -- | |
1603 | ------------------------------------------------ | |
1604 | ||
1605 | procedure Set_Restriction_No_Specification_Of_Aspect | |
47484baa BD |
1606 | (N : Node_Id; |
1607 | Warn : Boolean) | |
e7fceebc | 1608 | is |
f2c992d9 | 1609 | A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N)); |
e7fceebc AC |
1610 | |
1611 | begin | |
e7fceebc | 1612 | No_Specification_Of_Aspect_Set := True; |
58ba2415 | 1613 | No_Specification_Of_Aspects (A_Id) := Sloc (N); |
47484baa | 1614 | No_Specification_Of_Aspect_Warning (A_Id) := Warn; |
e7fceebc AC |
1615 | end Set_Restriction_No_Specification_Of_Aspect; |
1616 | ||
596b25f9 AC |
1617 | procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id) is |
1618 | begin | |
b68cf874 | 1619 | No_Specification_Of_Aspect_Set := True; |
596b25f9 AC |
1620 | No_Specification_Of_Aspects (A_Id) := System_Location; |
1621 | No_Specification_Of_Aspect_Warning (A_Id) := False; | |
596b25f9 AC |
1622 | end Set_Restriction_No_Specification_Of_Aspect; |
1623 | ||
57f4c288 ES |
1624 | ----------------------------------------- |
1625 | -- Set_Restriction_No_Use_Of_Attribute -- | |
1626 | ----------------------------------------- | |
1627 | ||
1628 | procedure Set_Restriction_No_Use_Of_Attribute | |
47484baa BD |
1629 | (N : Node_Id; |
1630 | Warn : Boolean) | |
57f4c288 ES |
1631 | is |
1632 | A_Id : constant Attribute_Id := Get_Attribute_Id (Chars (N)); | |
1633 | ||
1634 | begin | |
1635 | No_Use_Of_Attribute_Set := True; | |
1636 | No_Use_Of_Attribute (A_Id) := Sloc (N); | |
47484baa | 1637 | No_Use_Of_Attribute_Warning (A_Id) := Warn; |
57f4c288 ES |
1638 | end Set_Restriction_No_Use_Of_Attribute; |
1639 | ||
596b25f9 AC |
1640 | procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id) is |
1641 | begin | |
1642 | No_Use_Of_Attribute_Set := True; | |
1643 | No_Use_Of_Attribute (A_Id) := System_Location; | |
1644 | No_Use_Of_Attribute_Warning (A_Id) := False; | |
1645 | end Set_Restriction_No_Use_Of_Attribute; | |
1646 | ||
57f4c288 ES |
1647 | -------------------------------------- |
1648 | -- Set_Restriction_No_Use_Of_Pragma -- | |
1649 | -------------------------------------- | |
1650 | ||
1651 | procedure Set_Restriction_No_Use_Of_Pragma | |
47484baa BD |
1652 | (N : Node_Id; |
1653 | Warn : Boolean) | |
57f4c288 ES |
1654 | is |
1655 | A_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N)); | |
1656 | ||
1657 | begin | |
1658 | No_Use_Of_Pragma_Set := True; | |
1659 | No_Use_Of_Pragma (A_Id) := Sloc (N); | |
47484baa | 1660 | No_Use_Of_Pragma_Warning (A_Id) := Warn; |
57f4c288 ES |
1661 | end Set_Restriction_No_Use_Of_Pragma; |
1662 | ||
596b25f9 AC |
1663 | procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id) is |
1664 | begin | |
1665 | No_Use_Of_Pragma_Set := True; | |
596b25f9 | 1666 | No_Use_Of_Pragma (A_Id) := System_Location; |
b68cf874 | 1667 | No_Use_Of_Pragma_Warning (A_Id) := False; |
596b25f9 | 1668 | end Set_Restriction_No_Use_Of_Pragma; |
2cbac6c6 | 1669 | |
a7837c08 JM |
1670 | --------------------------- |
1671 | -- Set_Global_No_Tasking -- | |
1672 | --------------------------- | |
1673 | ||
1674 | procedure Set_Global_No_Tasking is | |
1675 | begin | |
1676 | Global_Restriction_No_Tasking := True; | |
1677 | end Set_Global_No_Tasking; | |
1678 | ||
19235870 RK |
1679 | ---------------------------------- |
1680 | -- Suppress_Restriction_Message -- | |
1681 | ---------------------------------- | |
1682 | ||
1683 | function Suppress_Restriction_Message (N : Node_Id) return Boolean is | |
1684 | begin | |
07fc65c4 | 1685 | -- We only output messages for the extended main source unit |
19235870 RK |
1686 | |
1687 | if In_Extended_Main_Source_Unit (N) then | |
1688 | return False; | |
1689 | ||
1690 | -- If loaded by rtsfind, then suppress message | |
1691 | ||
1692 | elsif Sloc (N) <= No_Location then | |
1693 | return True; | |
1694 | ||
1695 | -- Otherwise suppress message if internal file | |
1696 | ||
1697 | else | |
8ab31c0c | 1698 | return In_Internal_Unit (N); |
19235870 RK |
1699 | end if; |
1700 | end Suppress_Restriction_Message; | |
1701 | ||
433cefcd EB |
1702 | -------------------------------- |
1703 | -- Violation_Of_No_Dependence -- | |
1704 | -------------------------------- | |
1705 | ||
1706 | procedure Violation_Of_No_Dependence (Unit : Int; N : Node_Id) is | |
1707 | begin | |
1708 | Error_Msg_Node_1 := No_Dependences.Table (Unit).Unit; | |
1709 | Error_Msg_Sloc := Sloc (Error_Msg_Node_1); | |
1710 | ||
1711 | if No_Dependences.Table (Unit).Warn then | |
1712 | Error_Msg | |
1713 | ("?*?violation of restriction `No_Dependence '='> &`#", Sloc (N)); | |
1714 | else | |
1715 | Error_Msg | |
1716 | ("|violation of restriction `No_Dependence '='> &`#", Sloc (N)); | |
1717 | end if; | |
1718 | end Violation_Of_No_Dependence; | |
1719 | ||
19235870 RK |
1720 | --------------------- |
1721 | -- Tasking_Allowed -- | |
1722 | --------------------- | |
1723 | ||
1724 | function Tasking_Allowed return Boolean is | |
1725 | begin | |
6e937c1c AC |
1726 | return not Restrictions.Set (No_Tasking) |
1727 | and then (not Restrictions.Set (Max_Tasks) | |
43c58950 AC |
1728 | or else Restrictions.Value (Max_Tasks) > 0) |
1729 | and then not No_Run_Time_Mode; | |
19235870 RK |
1730 | end Tasking_Allowed; |
1731 | ||
1732 | end Restrict; |