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