File : restrict.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- R E S T R I C T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with 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 Profile_Info (Restricted).Set;
1198 V : Restriction_Values renames Profile_Info (Restricted).Value;
1199 begin
1200 for J in R'Range loop
1201 if R (J)
1202 and then (Restrictions.Set (J) = False
1203 or else Restriction_Warnings (J)
1204 or else
1205 (J in All_Parameter_Restrictions
1206 and then Restrictions.Value (J) > V (J)))
1207 then
1208 Restricted_Profile_Result := False;
1209 exit;
1210 end if;
1211 end loop;
1212
1213 return Restricted_Profile_Result;
1214 end;
1215 end if;
1216 end Restricted_Profile;
1217
1218 ------------------------
1219 -- Restriction_Active --
1220 ------------------------
1221
1222 function Restriction_Active (R : All_Restrictions) return Boolean is
1223 begin
1224 return Restrictions.Set (R) and then not Restriction_Warnings (R);
1225 end Restriction_Active;
1226
1227 --------------------------------
1228 -- Restriction_Check_Required --
1229 --------------------------------
1230
1231 function Restriction_Check_Required (R : All_Restrictions) return Boolean is
1232 begin
1233 return Restrictions.Set (R);
1234 end Restriction_Check_Required;
1235
1236 ---------------------
1237 -- Restriction_Msg --
1238 ---------------------
1239
1240 procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is
1241 Msg : String (1 .. 100);
1242 Len : Natural := 0;
1243
1244 procedure Add_Char (C : Character);
1245 -- Append given character to Msg, bumping Len
1246
1247 procedure Add_Str (S : String);
1248 -- Append given string to Msg, bumping Len appropriately
1249
1250 procedure Id_Case (S : String; Quotes : Boolean := True);
1251 -- Given a string S, case it according to current identifier casing,
1252 -- except for SPARK_05 (an acronym) which is set all upper case, and
1253 -- store in Error_Msg_String. Then append `~` to the message buffer
1254 -- to output the string unchanged surrounded in quotes. The quotes
1255 -- are suppressed if Quotes = False.
1256
1257 --------------
1258 -- Add_Char --
1259 --------------
1260
1261 procedure Add_Char (C : Character) is
1262 begin
1263 Len := Len + 1;
1264 Msg (Len) := C;
1265 end Add_Char;
1266
1267 -------------
1268 -- Add_Str --
1269 -------------
1270
1271 procedure Add_Str (S : String) is
1272 begin
1273 Msg (Len + 1 .. Len + S'Length) := S;
1274 Len := Len + S'Length;
1275 end Add_Str;
1276
1277 -------------
1278 -- Id_Case --
1279 -------------
1280
1281 procedure Id_Case (S : String; Quotes : Boolean := True) is
1282 begin
1283 Name_Buffer (1 .. S'Last) := S;
1284 Name_Len := S'Length;
1285
1286 if R = SPARK_05 then
1287 Set_All_Upper_Case;
1288 else
1289 Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
1290 end if;
1291
1292 Error_Msg_Strlen := Name_Len;
1293 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1294
1295 if Quotes then
1296 Add_Str ("`~`");
1297 else
1298 Add_Char ('~');
1299 end if;
1300 end Id_Case;
1301
1302 -- Start of processing for Restriction_Msg
1303
1304 begin
1305 -- Set warning message if warning
1306
1307 if Restriction_Warnings (R) then
1308 Add_Str ("?*?");
1309
1310 -- If real violation (not warning), then mark it as non-serious unless
1311 -- it is a violation of No_Finalization in which case we leave it as a
1312 -- serious message, since otherwise we get crashes during attempts to
1313 -- expand stuff that is not properly formed due to assumptions made
1314 -- about no finalization being present.
1315
1316 elsif R /= No_Finalization then
1317 Add_Char ('|');
1318 end if;
1319
1320 Error_Msg_Sloc := Restrictions_Loc (R);
1321
1322 -- Set main message, adding implicit if no source location
1323
1324 if Error_Msg_Sloc > No_Location
1325 or else Error_Msg_Sloc = System_Location
1326 then
1327 Add_Str ("violation of restriction ");
1328 else
1329 Add_Str ("violation of implicit restriction ");
1330 Error_Msg_Sloc := No_Location;
1331 end if;
1332
1333 -- Case of parameterized restriction
1334
1335 if R in All_Parameter_Restrictions then
1336 Add_Char ('`');
1337 Id_Case (Restriction_Id'Image (R), Quotes => False);
1338 Add_Str (" = ^`");
1339 Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R)));
1340
1341 -- Case of boolean restriction
1342
1343 else
1344 Id_Case (Restriction_Id'Image (R));
1345 end if;
1346
1347 -- Case of no secondary profile continuation message
1348
1349 if Restriction_Profile_Name (R) = No_Profile then
1350 if Error_Msg_Sloc /= No_Location then
1351 Add_Char ('#');
1352 end if;
1353
1354 Add_Char ('!');
1355 Error_Msg_N (Msg (1 .. Len), N);
1356
1357 -- Case of secondary profile continuation message present
1358
1359 else
1360 Add_Char ('!');
1361 Error_Msg_N (Msg (1 .. Len), N);
1362
1363 Len := 0;
1364 Add_Char ('\');
1365
1366 -- Set as warning if warning case
1367
1368 if Restriction_Warnings (R) then
1369 Add_Str ("??");
1370 end if;
1371
1372 -- Set main message
1373
1374 Add_Str ("from profile ");
1375 Id_Case (Profile_Name'Image (Restriction_Profile_Name (R)));
1376
1377 -- Add location if we have one
1378
1379 if Error_Msg_Sloc /= No_Location then
1380 Add_Char ('#');
1381 end if;
1382
1383 -- Output unconditional message and we are done
1384
1385 Add_Char ('!');
1386 Error_Msg_N (Msg (1 .. Len), N);
1387 end if;
1388 end Restriction_Msg;
1389
1390 -----------------
1391 -- Same_Entity --
1392 -----------------
1393
1394 function Same_Entity (E1, E2 : Node_Id) return Boolean is
1395 begin
1396 if Nkind_In (E1, N_Identifier, N_Operator_Symbol)
1397 and then
1398 Nkind_In (E2, N_Identifier, N_Operator_Symbol)
1399 then
1400 return Chars (E1) = Chars (E2);
1401
1402 elsif Nkind_In (E1, N_Selected_Component, N_Expanded_Name)
1403 and then
1404 Nkind_In (E2, N_Selected_Component, N_Expanded_Name)
1405 then
1406 return Same_Unit (Prefix (E1), Prefix (E2))
1407 and then
1408 Same_Unit (Selector_Name (E1), Selector_Name (E2));
1409 else
1410 return False;
1411 end if;
1412 end Same_Entity;
1413
1414 ---------------
1415 -- Same_Unit --
1416 ---------------
1417
1418 function Same_Unit (U1, U2 : Node_Id) return Boolean is
1419 begin
1420 if Nkind (U1) = N_Identifier and then Nkind (U2) = N_Identifier then
1421 return Chars (U1) = Chars (U2);
1422
1423 elsif Nkind_In (U1, N_Selected_Component, N_Expanded_Name)
1424 and then
1425 Nkind_In (U2, N_Selected_Component, N_Expanded_Name)
1426 then
1427 return Same_Unit (Prefix (U1), Prefix (U2))
1428 and then
1429 Same_Unit (Selector_Name (U1), Selector_Name (U2));
1430 else
1431 return False;
1432 end if;
1433 end Same_Unit;
1434
1435 --------------------------------------------
1436 -- Save_Config_Cunit_Boolean_Restrictions --
1437 --------------------------------------------
1438
1439 procedure Save_Config_Cunit_Boolean_Restrictions is
1440 begin
1441 Config_Cunit_Boolean_Restrictions := Cunit_Boolean_Restrictions_Save;
1442 end Save_Config_Cunit_Boolean_Restrictions;
1443
1444 ------------------------------
1445 -- Set_Hidden_Part_In_SPARK --
1446 ------------------------------
1447
1448 procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr) is
1449 begin
1450 SPARK_Hides.Increment_Last;
1451 SPARK_Hides.Table (SPARK_Hides.Last).Start := Loc1;
1452 SPARK_Hides.Table (SPARK_Hides.Last).Stop := Loc2;
1453 end Set_Hidden_Part_In_SPARK;
1454
1455 ------------------------------
1456 -- Set_Profile_Restrictions --
1457 ------------------------------
1458
1459 procedure Set_Profile_Restrictions
1460 (P : Profile_Name;
1461 N : Node_Id;
1462 Warn : Boolean)
1463 is
1464 R : Restriction_Flags renames Profile_Info (P).Set;
1465 V : Restriction_Values renames Profile_Info (P).Value;
1466
1467 begin
1468 for J in R'Range loop
1469 if R (J) then
1470 declare
1471 Already_Restricted : constant Boolean := Restriction_Active (J);
1472
1473 begin
1474 -- Set the restriction
1475
1476 if J in All_Boolean_Restrictions then
1477 Set_Restriction (J, N);
1478 else
1479 Set_Restriction (J, N, V (J));
1480 end if;
1481
1482 -- Record that this came from a Profile[_Warnings] restriction
1483
1484 Restriction_Profile_Name (J) := P;
1485
1486 -- Set warning flag, except that we do not set the warning
1487 -- flag if the restriction was already active and this is
1488 -- the warning case. That avoids a warning overriding a real
1489 -- restriction, which should never happen.
1490
1491 if not (Warn and Already_Restricted) then
1492 Restriction_Warnings (J) := Warn;
1493 end if;
1494 end;
1495 end if;
1496 end loop;
1497 end Set_Profile_Restrictions;
1498
1499 ---------------------
1500 -- Set_Restriction --
1501 ---------------------
1502
1503 -- Case of Boolean restriction
1504
1505 procedure Set_Restriction
1506 (R : All_Boolean_Restrictions;
1507 N : Node_Id)
1508 is
1509 begin
1510 Restrictions.Set (R) := True;
1511
1512 if Restricted_Profile_Cached and Restricted_Profile_Result then
1513 null;
1514 else
1515 Restricted_Profile_Cached := False;
1516 end if;
1517
1518 -- Set location, but preserve location of system restriction for nice
1519 -- error msg with run time name.
1520
1521 if Restrictions_Loc (R) /= System_Location then
1522 Restrictions_Loc (R) := Sloc (N);
1523 end if;
1524
1525 -- Note restriction came from restriction pragma, not profile
1526
1527 Restriction_Profile_Name (R) := No_Profile;
1528
1529 -- Record the restriction if we are in the main unit, or in the extended
1530 -- main unit. The reason that we test separately for Main_Unit is that
1531 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1532 -- gnat.adc do not appear to be in the extended main source unit (they
1533 -- probably should do ???)
1534
1535 if Current_Sem_Unit = Main_Unit
1536 or else In_Extended_Main_Source_Unit (N)
1537 then
1538 if not Restriction_Warnings (R) then
1539 Main_Restrictions.Set (R) := True;
1540 end if;
1541 end if;
1542 end Set_Restriction;
1543
1544 -- Case of parameter restriction
1545
1546 procedure Set_Restriction
1547 (R : All_Parameter_Restrictions;
1548 N : Node_Id;
1549 V : Integer)
1550 is
1551 begin
1552 if Restricted_Profile_Cached and Restricted_Profile_Result then
1553 null;
1554 else
1555 Restricted_Profile_Cached := False;
1556 end if;
1557
1558 if Restrictions.Set (R) then
1559 if V < Restrictions.Value (R) then
1560 Restrictions.Value (R) := V;
1561 Restrictions_Loc (R) := Sloc (N);
1562 end if;
1563
1564 else
1565 Restrictions.Set (R) := True;
1566 Restrictions.Value (R) := V;
1567 Restrictions_Loc (R) := Sloc (N);
1568 end if;
1569
1570 -- Record the restriction if we are in the main unit, or in the extended
1571 -- main unit. The reason that we test separately for Main_Unit is that
1572 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1573 -- gnat.adc do not appear to be the extended main source unit (they
1574 -- probably should do ???)
1575
1576 if Current_Sem_Unit = Main_Unit
1577 or else In_Extended_Main_Source_Unit (N)
1578 then
1579 if Main_Restrictions.Set (R) then
1580 if V < Main_Restrictions.Value (R) then
1581 Main_Restrictions.Value (R) := V;
1582 end if;
1583
1584 elsif not Restriction_Warnings (R) then
1585 Main_Restrictions.Set (R) := True;
1586 Main_Restrictions.Value (R) := V;
1587 end if;
1588 end if;
1589
1590 -- Note restriction came from restriction pragma, not profile
1591
1592 Restriction_Profile_Name (R) := No_Profile;
1593 end Set_Restriction;
1594
1595 -----------------------------------
1596 -- Set_Restriction_No_Dependence --
1597 -----------------------------------
1598
1599 procedure Set_Restriction_No_Dependence
1600 (Unit : Node_Id;
1601 Warn : Boolean;
1602 Profile : Profile_Name := No_Profile)
1603 is
1604 begin
1605 -- Loop to check for duplicate entry
1606
1607 for J in No_Dependences.First .. No_Dependences.Last loop
1608
1609 -- Case of entry already in table
1610
1611 if Same_Unit (Unit, No_Dependences.Table (J).Unit) then
1612
1613 -- Error has precedence over warning
1614
1615 if not Warn then
1616 No_Dependences.Table (J).Warn := False;
1617 end if;
1618
1619 return;
1620 end if;
1621 end loop;
1622
1623 -- Entry is not currently in table
1624
1625 No_Dependences.Append ((Unit, Warn, Profile));
1626 end Set_Restriction_No_Dependence;
1627
1628 --------------------------------------
1629 -- Set_Restriction_No_Use_Of_Entity --
1630 --------------------------------------
1631
1632 procedure Set_Restriction_No_Use_Of_Entity
1633 (Entity : Node_Id;
1634 Warning : Boolean;
1635 Profile : Profile_Name := No_Profile)
1636 is
1637 Nam : Node_Id;
1638
1639 begin
1640 -- Loop to check for duplicate entry
1641
1642 for J in No_Use_Of_Entity.First .. No_Use_Of_Entity.Last loop
1643
1644 -- Case of entry already in table
1645
1646 if Same_Entity (Entity, No_Use_Of_Entity.Table (J).Entity) then
1647
1648 -- Error has precedence over warning
1649
1650 if not Warning then
1651 No_Use_Of_Entity.Table (J).Warn := False;
1652 end if;
1653
1654 return;
1655 end if;
1656 end loop;
1657
1658 -- Entry is not currently in table
1659
1660 No_Use_Of_Entity.Append ((Entity, Warning, Profile));
1661
1662 -- Now we need to find the direct name and set Boolean2 flag
1663
1664 if Nkind_In (Entity, N_Identifier, N_Operator_Symbol) then
1665 Nam := Entity;
1666
1667 else
1668 pragma Assert (Nkind (Entity) = N_Selected_Component);
1669 Nam := Selector_Name (Entity);
1670 pragma Assert (Nkind_In (Nam, N_Identifier, N_Operator_Symbol));
1671 end if;
1672
1673 Set_Name_Table_Boolean2 (Chars (Nam), True);
1674 end Set_Restriction_No_Use_Of_Entity;
1675
1676 ------------------------------------------------
1677 -- Set_Restriction_No_Specification_Of_Aspect --
1678 ------------------------------------------------
1679
1680 procedure Set_Restriction_No_Specification_Of_Aspect
1681 (N : Node_Id;
1682 Warning : Boolean)
1683 is
1684 A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N));
1685
1686 begin
1687 No_Specification_Of_Aspect_Set := True;
1688 No_Specification_Of_Aspects (A_Id) := Sloc (N);
1689 No_Specification_Of_Aspect_Warning (A_Id) := Warning;
1690 end Set_Restriction_No_Specification_Of_Aspect;
1691
1692 procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id) is
1693 begin
1694 No_Specification_Of_Aspect_Set := True;
1695 No_Specification_Of_Aspects (A_Id) := System_Location;
1696 No_Specification_Of_Aspect_Warning (A_Id) := False;
1697 end Set_Restriction_No_Specification_Of_Aspect;
1698
1699 -----------------------------------------
1700 -- Set_Restriction_No_Use_Of_Attribute --
1701 -----------------------------------------
1702
1703 procedure Set_Restriction_No_Use_Of_Attribute
1704 (N : Node_Id;
1705 Warning : Boolean)
1706 is
1707 A_Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
1708
1709 begin
1710 No_Use_Of_Attribute_Set := True;
1711 No_Use_Of_Attribute (A_Id) := Sloc (N);
1712 No_Use_Of_Attribute_Warning (A_Id) := Warning;
1713 end Set_Restriction_No_Use_Of_Attribute;
1714
1715 procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id) is
1716 begin
1717 No_Use_Of_Attribute_Set := True;
1718 No_Use_Of_Attribute (A_Id) := System_Location;
1719 No_Use_Of_Attribute_Warning (A_Id) := False;
1720 end Set_Restriction_No_Use_Of_Attribute;
1721
1722 --------------------------------------
1723 -- Set_Restriction_No_Use_Of_Pragma --
1724 --------------------------------------
1725
1726 procedure Set_Restriction_No_Use_Of_Pragma
1727 (N : Node_Id;
1728 Warning : Boolean)
1729 is
1730 A_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N));
1731
1732 begin
1733 No_Use_Of_Pragma_Set := True;
1734 No_Use_Of_Pragma (A_Id) := Sloc (N);
1735 No_Use_Of_Pragma_Warning (A_Id) := Warning;
1736 end Set_Restriction_No_Use_Of_Pragma;
1737
1738 procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id) is
1739 begin
1740 No_Use_Of_Pragma_Set := True;
1741 No_Use_Of_Pragma (A_Id) := System_Location;
1742 No_Use_Of_Pragma_Warning (A_Id) := False;
1743 end Set_Restriction_No_Use_Of_Pragma;
1744
1745 ----------------------------------
1746 -- Suppress_Restriction_Message --
1747 ----------------------------------
1748
1749 function Suppress_Restriction_Message (N : Node_Id) return Boolean is
1750 begin
1751 -- We only output messages for the extended main source unit
1752
1753 if In_Extended_Main_Source_Unit (N) then
1754 return False;
1755
1756 -- If loaded by rtsfind, then suppress message
1757
1758 elsif Sloc (N) <= No_Location then
1759 return True;
1760
1761 -- Otherwise suppress message if internal file
1762
1763 else
1764 return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
1765 end if;
1766 end Suppress_Restriction_Message;
1767
1768 ---------------------
1769 -- Tasking_Allowed --
1770 ---------------------
1771
1772 function Tasking_Allowed return Boolean is
1773 begin
1774 return not Restrictions.Set (No_Tasking)
1775 and then (not Restrictions.Set (Max_Tasks)
1776 or else Restrictions.Value (Max_Tasks) > 0)
1777 and then not No_Run_Time_Mode;
1778 end Tasking_Allowed;
1779
1780 end Restrict;