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