1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with 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;
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;
45 package body Restrict is
47 Global_Restriction_No_Tasking : Boolean := False;
48 -- Set to True when No_Tasking is set in the run-time package System
49 -- or in a configuration pragmas file (for example, gnat.adc).
51 --------------------------------
52 -- Package Local Declarations --
53 --------------------------------
55 Config_Cunit_Boolean_Restrictions : Save_Cunit_Boolean_Restrictions;
56 -- Save compilation unit restrictions set by config pragma files
58 Restricted_Profile_Result : Boolean := False;
59 -- This switch memoizes the result of Restricted_Profile function calls for
60 -- improved efficiency. Valid only if Restricted_Profile_Cached is True.
61 -- Note: if this switch is ever set True, it is never turned off again.
63 Restricted_Profile_Cached : Boolean := False;
64 -- This flag is set to True if the Restricted_Profile_Result contains the
65 -- correct cached result of Restricted_Profile calls.
67 No_Specification_Of_Aspects : array (Aspect_Id) of Source_Ptr :=
68 (others => No_Location);
69 -- Entries in this array are set to point to a previously occuring pragma
70 -- that activates a No_Specification_Of_Aspect check.
72 No_Specification_Of_Aspect_Warning : array (Aspect_Id) of Boolean :=
74 -- An entry in this array is set False in reponse to a previous call to
75 -- Set_No_Speficiation_Of_Aspect for pragmas in the main unit that
76 -- specify Warning as False. Once set False, an entry is never reset.
78 No_Specification_Of_Aspect_Set : Boolean := False;
79 -- Set True if any entry of No_Specifcation_Of_Aspects has been set True.
80 -- Once set True, this is never turned off again.
82 No_Use_Of_Attribute : array (Attribute_Id) of Source_Ptr :=
83 (others => No_Location);
85 No_Use_Of_Attribute_Warning : array (Attribute_Id) of Boolean :=
88 No_Use_Of_Attribute_Set : Boolean := False;
89 -- Indicates that No_Use_Of_Attribute was set at least once
91 No_Use_Of_Pragma : array (Pragma_Id) of Source_Ptr :=
92 (others => No_Location);
93 -- Source location of pragma No_Use_Of_Pragma for given pragma, a value
94 -- of System_Location indicates occurrence in system.ads.
96 No_Use_Of_Pragma_Warning : array (Pragma_Id) of Boolean :=
99 No_Use_Of_Pragma_Set : Boolean := False;
100 -- Indicates that No_Use_Of_Pragma was set at least once
102 -----------------------
103 -- Local Subprograms --
104 -----------------------
106 procedure Restriction_Msg (R : Restriction_Id; N : Node_Id);
107 -- Called if a violation of restriction R at node N is found. This routine
108 -- outputs the appropriate message or messages taking care of warning vs
109 -- real violation, serious vs non-serious, implicit vs explicit, the second
110 -- message giving the profile name if needed, and the location information.
112 function Same_Entity (E1, E2 : Node_Id) return Boolean;
113 -- Returns True iff E1 and E2 represent the same entity. Used for handling
114 -- of No_Use_Of_Entity => fully_qualified_ENTITY restriction case.
116 function Same_Unit (U1, U2 : Node_Id) return Boolean;
117 -- Returns True iff U1 and U2 represent the same library unit. Used for
118 -- handling of No_Dependence => Unit restriction case.
120 function Suppress_Restriction_Message (N : Node_Id) return Boolean;
121 -- N is the node for a possible restriction violation message, but the
122 -- message is to be suppressed if this is an internal file and this file is
123 -- not the main unit. Returns True if message is to be suppressed.
129 function Abort_Allowed return Boolean is
131 if Restrictions.Set (No_Abort_Statements)
132 and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
133 and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0
141 ----------------------------------------
142 -- Add_To_Config_Boolean_Restrictions --
143 ----------------------------------------
145 procedure Add_To_Config_Boolean_Restrictions (R : Restriction_Id) is
147 Config_Cunit_Boolean_Restrictions (R) := True;
148 end Add_To_Config_Boolean_Restrictions;
149 -- Add specified restriction to stored configuration boolean restrictions.
150 -- This is used for handling the special case of No_Elaboration_Code.
152 -------------------------
153 -- Check_Compiler_Unit --
154 -------------------------
156 procedure Check_Compiler_Unit (Feature : String; N : Node_Id) is
158 if Compiler_Unit then
159 Error_Msg_N (Feature & " not allowed in compiler unit!!??", N);
161 end Check_Compiler_Unit;
163 procedure Check_Compiler_Unit (Feature : String; Loc : Source_Ptr) is
165 if Compiler_Unit then
166 Error_Msg (Feature & " not allowed in compiler unit!!??", Loc);
168 end Check_Compiler_Unit;
170 ------------------------------------
171 -- Check_Elaboration_Code_Allowed --
172 ------------------------------------
174 procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
176 Check_Restriction (No_Elaboration_Code, N);
177 end Check_Elaboration_Code_Allowed;
179 -----------------------------------------
180 -- Check_Implicit_Dynamic_Code_Allowed --
181 -----------------------------------------
183 procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id) is
185 Check_Restriction (No_Implicit_Dynamic_Code, N);
186 end Check_Implicit_Dynamic_Code_Allowed;
188 --------------------------------
189 -- Check_No_Implicit_Aliasing --
190 --------------------------------
192 procedure Check_No_Implicit_Aliasing (Obj : Node_Id) is
196 -- If restriction not active, nothing to check
198 if not Restriction_Active (No_Implicit_Aliasing) then
202 -- If we have an entity name, check entity
204 if Is_Entity_Name (Obj) then
207 -- Restriction applies to entities that are objects
209 if Is_Object (E) then
210 if Is_Aliased (E) then
213 elsif Present (Renamed_Object (E)) then
214 Check_No_Implicit_Aliasing (Renamed_Object (E));
218 -- If we don't have an object, then it's OK
224 -- For selected component, check selector
226 elsif Nkind (Obj) = N_Selected_Component then
227 Check_No_Implicit_Aliasing (Selector_Name (Obj));
230 -- Indexed component is OK if aliased components
232 elsif Nkind (Obj) = N_Indexed_Component then
233 if Has_Aliased_Components (Etype (Prefix (Obj)))
235 (Is_Access_Type (Etype (Prefix (Obj)))
236 and then Has_Aliased_Components
237 (Designated_Type (Etype (Prefix (Obj)))))
242 -- For type conversion, check converted expression
244 elsif Nkind (Obj) in N_Unchecked_Type_Conversion | N_Type_Conversion then
245 Check_No_Implicit_Aliasing (Expression (Obj));
248 -- Explicit dereference is always OK
250 elsif Nkind (Obj) = N_Explicit_Dereference then
254 -- If we fall through, then we have an aliased view that does not meet
255 -- the rules for being explicitly aliased, so issue restriction msg.
257 Check_Restriction (No_Implicit_Aliasing, Obj);
258 end Check_No_Implicit_Aliasing;
260 ----------------------------------
261 -- Check_No_Implicit_Heap_Alloc --
262 ----------------------------------
264 procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is
266 Check_Restriction (No_Implicit_Heap_Allocations, N);
267 end Check_No_Implicit_Heap_Alloc;
269 ----------------------------------
270 -- Check_No_Implicit_Task_Alloc --
271 ----------------------------------
273 procedure Check_No_Implicit_Task_Alloc (N : Node_Id) is
275 Check_Restriction (No_Implicit_Task_Allocations, N);
276 end Check_No_Implicit_Task_Alloc;
278 ---------------------------------------
279 -- Check_No_Implicit_Protected_Alloc --
280 ---------------------------------------
282 procedure Check_No_Implicit_Protected_Alloc (N : Node_Id) is
284 Check_Restriction (No_Implicit_Protected_Object_Allocations, N);
285 end Check_No_Implicit_Protected_Alloc;
287 -----------------------------------
288 -- Check_Obsolescent_2005_Entity --
289 -----------------------------------
291 procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id) is
292 function Chars_Is (E : Entity_Id; S : String) return Boolean;
293 -- Return True iff Chars (E) matches S (given in lower case)
299 function Chars_Is (E : Entity_Id; S : String) return Boolean is
300 Nam : constant Name_Id := Chars (E);
302 if Length_Of_Name (Nam) /= S'Length then
305 return Get_Name_String (Nam) = S;
309 -- Start of processing for Check_Obsolescent_2005_Entity
312 if Restriction_Check_Required (No_Obsolescent_Features)
313 and then Ada_Version >= Ada_2005
314 and then Chars_Is (Scope (E), "handling")
315 and then Chars_Is (Scope (Scope (E)), "characters")
316 and then Chars_Is (Scope (Scope (Scope (E))), "ada")
317 and then Scope (Scope (Scope (Scope (E)))) = Standard_Standard
319 if Chars_Is (E, "is_character") or else
320 Chars_Is (E, "is_string") or else
321 Chars_Is (E, "to_character") or else
322 Chars_Is (E, "to_string") or else
323 Chars_Is (E, "to_wide_character") or else
324 Chars_Is (E, "to_wide_string")
326 Check_Restriction (No_Obsolescent_Features, N);
329 end Check_Obsolescent_2005_Entity;
331 ---------------------------
332 -- Check_Restricted_Unit --
333 ---------------------------
335 procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
337 if Suppress_Restriction_Message (N) then
340 elsif Is_Spec_Name (U) then
342 Fnam : constant File_Name_Type :=
343 Get_File_Name (U, Subunit => False);
348 Get_Name_String (Fnam);
350 -- Nothing to do if name not at least 5 characters long ending
351 -- in .ads or .adb extension, which we strip.
354 or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads"
356 Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb")
361 -- Strip extension and pad to eight characters
363 Name_Len := Name_Len - 4;
364 Add_Str_To_Name_Buffer ((Name_Len + 1 .. 8 => ' '));
366 -- If predefined unit, check the list of restricted units
368 if Is_Predefined_File_Name (Fnam) then
369 for J in Unit_Array'Range loop
371 and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
373 Check_Restriction (Unit_Array (J).Res_Id, N);
377 -- If not predefined unit, then one special check still
378 -- remains. GNAT.Current_Exception is not allowed if we have
379 -- restriction No_Exception_Propagation active.
382 if Name_Buffer (1 .. 8) = "g-curexc" then
383 Check_Restriction (No_Exception_Propagation, N);
388 end Check_Restricted_Unit;
390 -----------------------
391 -- Check_Restriction --
392 -----------------------
394 procedure Check_Restriction
397 V : Uint := Uint_Minus_1)
399 Msg_Issued : Boolean;
400 pragma Unreferenced (Msg_Issued);
402 Check_Restriction (Msg_Issued, R, N, V);
403 end Check_Restriction;
405 procedure Check_Restriction
406 (Msg_Issued : out Boolean;
409 V : Uint := Uint_Minus_1)
412 -- V converted to integer form. If V is greater than Integer'Last,
413 -- it is reset to minus 1 (unknown value).
415 procedure Update_Restrictions (Info : in out Restrictions_Info);
416 -- Update violation information in Info.Violated and Info.Count
418 -------------------------
419 -- Update_Restrictions --
420 -------------------------
422 procedure Update_Restrictions (Info : in out Restrictions_Info) is
424 -- If not violated, set as violated now
426 if not Info.Violated (R) then
427 Info.Violated (R) := True;
429 if R in All_Parameter_Restrictions then
431 Info.Unknown (R) := True;
435 Info.Count (R) := VV;
439 -- Otherwise if violated already and a parameter restriction,
440 -- update count by maximizing or summing depending on restriction.
442 elsif R in All_Parameter_Restrictions then
444 -- If new value is unknown, result is unknown
447 Info.Unknown (R) := True;
449 -- If checked by maximization, nothing to do because the
450 -- check is per-object.
452 elsif R in Checked_Max_Parameter_Restrictions then
455 -- If checked by adding, do add, checking for overflow
457 elsif R in Checked_Add_Parameter_Restrictions then
459 pragma Unsuppress (Overflow_Check);
461 Info.Count (R) := Info.Count (R) + VV;
463 when Constraint_Error =>
464 Info.Count (R) := Integer'Last;
465 Info.Unknown (R) := True;
468 -- Should not be able to come here, known counts should only
469 -- occur for restrictions that are Checked_max or Checked_Sum.
475 end Update_Restrictions;
477 -- Start of processing for Check_Restriction
482 -- In CodePeer mode, we do not want to check for any restriction, or set
483 -- additional restrictions other than those already set in gnat1drv.adb
484 -- so that we have consistency between each compilation.
486 -- In GNATprove mode restrictions are checked, except for
487 -- No_Initialize_Scalars, which is implicitly set in gnat1drv.adb.
490 or else (GNATprove_Mode and then R = No_Initialize_Scalars)
495 if UI_Is_In_Int_Range (V) then
496 VV := Integer (UI_To_Int (V));
501 -- Count can only be specified in the checked val parameter case
503 pragma Assert (VV < 0 or else R in Checked_Val_Parameter_Restrictions);
505 -- Nothing to do if value of zero specified for parameter restriction
511 -- Update current restrictions
513 Update_Restrictions (Restrictions);
515 -- If in main extended unit, update main restrictions as well. Note
516 -- that as usual we check for Main_Unit explicitly to deal with the
517 -- case of configuration pragma files.
519 if Current_Sem_Unit = Main_Unit
520 or else In_Extended_Main_Source_Unit (N)
522 Update_Restrictions (Main_Restrictions);
525 -- Nothing to do if restriction message suppressed
527 if Suppress_Restriction_Message (N) then
530 -- If restriction not set, nothing to do
532 elsif not Restrictions.Set (R) then
535 -- Don't complain about No_Obsolescent_Features in an instance, since we
536 -- will complain on the template, which is much better. Are there other
537 -- cases like this ??? Do we need a more general mechanism ???
539 elsif R = No_Obsolescent_Features
540 and then Instantiation_Location (Sloc (N)) /= No_Location
544 -- Here if restriction set, check for violation (this is a Boolean
545 -- restriction, or a parameter restriction with a value of zero and an
546 -- unknown count, or a parameter restriction with a known value that
547 -- exceeds the restriction count).
549 elsif R in All_Boolean_Restrictions
550 or else (Restrictions.Unknown (R)
551 and then Restrictions.Value (R) = 0)
552 or else Restrictions.Count (R) > Restrictions.Value (R)
555 Restriction_Msg (R, N);
558 -- For Max_Entries and the like, do not carry forward the violation
559 -- count because it does not affect later declarations.
561 if R in Checked_Max_Parameter_Restrictions then
562 Restrictions.Count (R) := 0;
563 Restrictions.Violated (R) := False;
565 end Check_Restriction;
567 -------------------------------------
568 -- Check_Restriction_No_Dependence --
569 -------------------------------------
571 procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is
575 -- Ignore call if node U is not in the main source unit. This avoids
576 -- cascaded errors, e.g. when Ada.Containers units with other units.
577 -- However, allow Standard_Location here, since this catches some cases
578 -- of constructs that get converted to run-time calls.
580 if not In_Extended_Main_Source_Unit (U)
581 and then Sloc (U) /= Standard_Location
586 -- Loop through entries in No_Dependence table to check each one in turn
588 for J in No_Dependences.First .. No_Dependences.Last loop
589 DU := No_Dependences.Table (J).Unit;
591 if Same_Unit (U, DU) then
592 Error_Msg_Sloc := Sloc (DU);
593 Error_Msg_Node_1 := DU;
595 if No_Dependences.Table (J).Warn then
597 ("?*?violation of restriction `No_Dependence '='> &`#",
601 ("|violation of restriction `No_Dependence '='> &`#",
608 end Check_Restriction_No_Dependence;
610 --------------------------------------------------
611 -- Check_Restriction_No_Specification_Of_Aspect --
612 --------------------------------------------------
614 procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id) is
619 -- Ignore call if no instances of this restriction set
621 if not No_Specification_Of_Aspect_Set then
625 -- Ignore call if node N is not in the main source unit, since we only
626 -- give messages for the main unit. This avoids giving messages for
627 -- aspects that are specified in withed units.
629 if not In_Extended_Main_Source_Unit (N) then
633 if Nkind (N) = N_Pragma then
634 Id := Pragma_Identifier (N);
635 elsif Nkind (N) = N_Attribute_Definition_Clause then
638 Id := Identifier (N);
641 A_Id := Get_Aspect_Id (Chars (Id));
642 pragma Assert (A_Id /= No_Aspect);
644 Error_Msg_Sloc := No_Specification_Of_Aspects (A_Id);
646 if Error_Msg_Sloc /= No_Location then
647 Error_Msg_Node_1 := Id;
648 Error_Msg_Warn := No_Specification_Of_Aspect_Warning (A_Id);
650 ("<*<violation of restriction `No_Specification_Of_Aspect '='> &`#",
653 end Check_Restriction_No_Specification_Of_Aspect;
655 -------------------------------------------
656 -- Check_Restriction_No_Use_Of_Attribute --
657 --------------------------------------------
659 procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id) is
660 Attr_Id : Attribute_Id;
664 -- Nothing to do if the attribute is not in the main source unit, since
665 -- we only give messages for the main unit. This avoids giving messages
666 -- for attributes that are specified in withed units.
668 if not In_Extended_Main_Source_Unit (N) then
671 -- Nothing to do if not checking No_Use_Of_Attribute
673 elsif not No_Use_Of_Attribute_Set then
676 -- Do not consider internally generated attributes because this leads to
679 elsif not Comes_From_Source (N) then
683 if Nkind (N) = N_Attribute_Definition_Clause then
684 Attr_Nam := Chars (N);
686 pragma Assert (Nkind (N) = N_Attribute_Reference);
687 Attr_Nam := Attribute_Name (N);
690 Attr_Id := Get_Attribute_Id (Attr_Nam);
691 Error_Msg_Sloc := No_Use_Of_Attribute (Attr_Id);
693 if Error_Msg_Sloc /= No_Location then
694 Error_Msg_Name_1 := Attr_Nam;
695 Error_Msg_Warn := No_Use_Of_Attribute_Warning (Attr_Id);
697 ("<*<violation of restriction `No_Use_Of_Attribute '='> %` #", N);
699 end Check_Restriction_No_Use_Of_Attribute;
701 ----------------------------------------
702 -- Check_Restriction_No_Use_Of_Entity --
703 ----------------------------------------
705 procedure Check_Restriction_No_Use_Of_Entity (N : Node_Id) is
707 -- Error defence (not clearly necessary, but better safe)
709 if No (Entity (N)) then
713 -- If simple name of entity not flagged with Boolean2 flag, then there
714 -- cannot be a matching entry in the table, so skip the search.
716 if Get_Name_Table_Boolean2 (Chars (Entity (N))) = False then
720 -- Restriction is only recognized within a configuration pragma file,
721 -- or within a unit of the main extended program. Note: the test for
722 -- Main_Unit is needed to properly include the case of configuration
725 if Current_Sem_Unit /= Main_Unit
726 and then not In_Extended_Main_Source_Unit (N)
731 -- Here we must search the table
733 for J in No_Use_Of_Entity.First .. No_Use_Of_Entity.Last loop
735 NE_Ent : NE_Entry renames No_Use_Of_Entity.Table (J);
741 Expr := NE_Ent.Entity;
743 -- Here if at outer level of entity name in reference (handle
744 -- also the direct use of Text_IO in the pragma). For example:
745 -- pragma Restrictions (No_Use_Of_Entity => Text_IO.Put);
747 if Scope (Ent) = Standard_Standard
748 or else (Nkind (Expr) = N_Identifier
749 and then Chars (Ent) = Name_Text_IO
750 and then Chars (Scope (Ent)) = Name_Ada
751 and then Scope (Scope (Ent)) = Standard_Standard)
753 if Nkind (Expr) in N_Identifier | N_Operator_Symbol
754 and then Chars (Ent) = Chars (Expr)
756 Error_Msg_Node_1 := N;
757 Error_Msg_Warn := NE_Ent.Warn;
758 Error_Msg_Sloc := Sloc (NE_Ent.Entity);
760 ("<*<reference to & violates restriction "
761 & "No_Use_Of_Entity #", N);
768 -- Here if at outer level of entity name in table
770 elsif Nkind (Expr) in N_Identifier | N_Operator_Symbol then
773 -- Here if neither at the outer level
776 pragma Assert (Nkind (Expr) = N_Selected_Component);
777 exit when Chars (Selector_Name (Expr)) /= Chars (Ent);
784 exit when not Is_Internal_Name (Chars (Ent));
787 Expr := Prefix (Expr);
791 end Check_Restriction_No_Use_Of_Entity;
793 ----------------------------------------
794 -- Check_Restriction_No_Use_Of_Pragma --
795 ----------------------------------------
797 procedure Check_Restriction_No_Use_Of_Pragma (N : Node_Id) is
798 Id : constant Node_Id := Pragma_Identifier (N);
799 P_Id : constant Pragma_Id := Get_Pragma_Id (Chars (Id));
802 -- Nothing to do if the pragma is not in the main source unit, since we
803 -- only give messages for the main unit. This avoids giving messages for
804 -- pragmas that are specified in withed units.
806 if not In_Extended_Main_Source_Unit (N) then
809 -- Nothing to do if not checking No_Use_Of_Pragma
811 elsif not No_Use_Of_Pragma_Set then
814 -- Do not consider internally generated pragmas because this leads to
817 elsif not Comes_From_Source (N) then
821 Error_Msg_Sloc := No_Use_Of_Pragma (P_Id);
823 if Error_Msg_Sloc /= No_Location then
824 Error_Msg_Warn := No_Use_Of_Pragma_Warning (P_Id);
826 ("<*<violation of restriction `No_Use_Of_Pragma '='> &` #", Id);
828 end Check_Restriction_No_Use_Of_Pragma;
830 --------------------------------------
831 -- Check_Wide_Character_Restriction --
832 --------------------------------------
834 procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is
836 if Restriction_Check_Required (No_Wide_Characters)
837 and then Comes_From_Source (N)
840 T : constant Entity_Id := Root_Type (E);
842 if T = Standard_Wide_Character or else
843 T = Standard_Wide_String or else
844 T = Standard_Wide_Wide_Character or else
845 T = Standard_Wide_Wide_String
847 Check_Restriction (No_Wide_Characters, N);
851 end Check_Wide_Character_Restriction;
853 ----------------------------------------
854 -- Cunit_Boolean_Restrictions_Restore --
855 ----------------------------------------
857 procedure Cunit_Boolean_Restrictions_Restore
858 (R : Save_Cunit_Boolean_Restrictions)
861 for J in Cunit_Boolean_Restrictions loop
862 Restrictions.Set (J) := R (J);
865 -- If No_Elaboration_Code set in configuration restrictions, and we
866 -- in the main extended source, then set it here now. This is part of
867 -- the special processing for No_Elaboration_Code.
869 if In_Extended_Main_Source_Unit (Cunit_Entity (Current_Sem_Unit))
870 and then Config_Cunit_Boolean_Restrictions (No_Elaboration_Code)
872 Restrictions.Set (No_Elaboration_Code) := True;
874 end Cunit_Boolean_Restrictions_Restore;
876 -------------------------------------
877 -- Cunit_Boolean_Restrictions_Save --
878 -------------------------------------
880 function Cunit_Boolean_Restrictions_Save
881 return Save_Cunit_Boolean_Restrictions
883 R : Save_Cunit_Boolean_Restrictions;
886 for J in Cunit_Boolean_Restrictions loop
887 R (J) := Restrictions.Set (J);
891 end Cunit_Boolean_Restrictions_Save;
893 ------------------------
894 -- Get_Restriction_Id --
895 ------------------------
897 function Get_Restriction_Id
898 (N : Name_Id) return Restriction_Id
902 Set_Casing (All_Upper_Case);
904 for J in All_Restrictions loop
906 S : constant String := Restriction_Id'Image (J);
908 if S = Name_Buffer (1 .. Name_Len) then
914 return Not_A_Restriction_Id;
915 end Get_Restriction_Id;
917 -----------------------
918 -- Global_No_Tasking --
919 -----------------------
921 function Global_No_Tasking return Boolean is
923 return Global_Restriction_No_Tasking
924 or else Targparm.Restrictions_On_Target.Set (No_Tasking);
925 end Global_No_Tasking;
927 -------------------------------
928 -- No_Exception_Handlers_Set --
929 -------------------------------
931 function No_Exception_Handlers_Set return Boolean is
933 return (No_Run_Time_Mode or else Configurable_Run_Time_Mode)
934 and then (Restrictions.Set (No_Exception_Handlers)
936 Restrictions.Set (No_Exception_Propagation));
937 end No_Exception_Handlers_Set;
939 -------------------------------------
940 -- No_Exception_Propagation_Active --
941 -------------------------------------
943 function No_Exception_Propagation_Active return Boolean is
945 return (No_Run_Time_Mode
946 or else Configurable_Run_Time_Mode
947 or else Debug_Flag_Dot_G)
948 and then Restriction_Active (No_Exception_Propagation);
949 end No_Exception_Propagation_Active;
951 --------------------------------
952 -- OK_No_Dependence_Unit_Name --
953 --------------------------------
955 function OK_No_Dependence_Unit_Name (N : Node_Id) return Boolean is
957 if Nkind (N) = N_Selected_Component then
959 OK_No_Dependence_Unit_Name (Prefix (N))
961 OK_No_Dependence_Unit_Name (Selector_Name (N));
963 elsif Nkind (N) = N_Identifier then
967 Error_Msg_N ("wrong form for unit name for No_Dependence", N);
970 end OK_No_Dependence_Unit_Name;
972 ------------------------------
973 -- OK_No_Use_Of_Entity_Name --
974 ------------------------------
976 function OK_No_Use_Of_Entity_Name (N : Node_Id) return Boolean is
978 if Nkind (N) = N_Selected_Component then
980 OK_No_Use_Of_Entity_Name (Prefix (N))
982 OK_No_Use_Of_Entity_Name (Selector_Name (N));
984 elsif Nkind (N) in N_Identifier | N_Operator_Symbol then
988 Error_Msg_N ("wrong form for entity name for No_Use_Of_Entity", N);
991 end OK_No_Use_Of_Entity_Name;
993 ----------------------------------
994 -- Process_Restriction_Synonyms --
995 ----------------------------------
997 -- Note: body of this function must be coordinated with list of renaming
998 -- declarations in System.Rident.
1000 function Process_Restriction_Synonyms (N : Node_Id) return Name_Id is
1001 Old_Name : constant Name_Id := Chars (N);
1006 when Name_Boolean_Entry_Barriers =>
1007 New_Name := Name_Simple_Barriers;
1009 when Name_Max_Entry_Queue_Depth =>
1010 New_Name := Name_Max_Entry_Queue_Length;
1012 when Name_No_Dynamic_Interrupts =>
1013 New_Name := Name_No_Dynamic_Attachment;
1015 when Name_No_Requeue =>
1016 New_Name := Name_No_Requeue_Statements;
1018 when Name_No_Task_Attributes =>
1019 New_Name := Name_No_Task_Attributes_Package;
1025 -- Output warning if we are warning on obsolescent features.
1027 if Warn_On_Obsolescent_Feature then
1028 Error_Msg_Name_1 := Old_Name;
1029 Error_Msg_N ("restriction identifier % is obsolescent?j?", N);
1030 Error_Msg_Name_1 := New_Name;
1031 Error_Msg_N ("|use restriction identifier % instead?j?", N);
1035 end Process_Restriction_Synonyms;
1037 --------------------------------------
1038 -- Reset_Cunit_Boolean_Restrictions --
1039 --------------------------------------
1041 procedure Reset_Cunit_Boolean_Restrictions is
1043 for J in Cunit_Boolean_Restrictions loop
1044 Restrictions.Set (J) := False;
1046 end Reset_Cunit_Boolean_Restrictions;
1048 -----------------------------------------------
1049 -- Restore_Config_Cunit_Boolean_Restrictions --
1050 -----------------------------------------------
1052 procedure Restore_Config_Cunit_Boolean_Restrictions is
1054 Cunit_Boolean_Restrictions_Restore (Config_Cunit_Boolean_Restrictions);
1055 end Restore_Config_Cunit_Boolean_Restrictions;
1057 ------------------------
1058 -- Restricted_Profile --
1059 ------------------------
1061 function Restricted_Profile return Boolean is
1063 if Restricted_Profile_Cached then
1064 return Restricted_Profile_Result;
1067 Restricted_Profile_Result := True;
1068 Restricted_Profile_Cached := True;
1071 R : Restriction_Flags renames
1072 Profile_Info (Restricted_Tasking).Set;
1073 V : Restriction_Values renames
1074 Profile_Info (Restricted_Tasking).Value;
1076 for J in R'Range loop
1078 and then (Restrictions.Set (J) = False
1079 or else Restriction_Warnings (J)
1081 (J in All_Parameter_Restrictions
1082 and then Restrictions.Value (J) > V (J)))
1084 Restricted_Profile_Result := False;
1089 return Restricted_Profile_Result;
1092 end Restricted_Profile;
1094 ------------------------
1095 -- Restriction_Active --
1096 ------------------------
1098 function Restriction_Active (R : All_Restrictions) return Boolean is
1100 return Restrictions.Set (R) and then not Restriction_Warnings (R);
1101 end Restriction_Active;
1103 --------------------------------
1104 -- Restriction_Check_Required --
1105 --------------------------------
1107 function Restriction_Check_Required (R : All_Restrictions) return Boolean is
1109 return Restrictions.Set (R);
1110 end Restriction_Check_Required;
1112 ---------------------
1113 -- Restriction_Msg --
1114 ---------------------
1116 procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is
1117 Msg : String (1 .. 100);
1120 procedure Add_Char (C : Character);
1121 -- Append given character to Msg, bumping Len
1123 procedure Add_Str (S : String);
1124 -- Append given string to Msg, bumping Len appropriately
1126 procedure Id_Case (S : String; Quotes : Boolean := True);
1127 -- Given a string S, case it according to current identifier casing, and
1128 -- store in Error_Msg_String. Then append `~` to the message buffer
1129 -- to output the string unchanged surrounded in quotes. The quotes
1130 -- are suppressed if Quotes = False.
1136 procedure Add_Char (C : Character) is
1146 procedure Add_Str (S : String) is
1148 Msg (Len + 1 .. Len + S'Length) := S;
1149 Len := Len + S'Length;
1156 procedure Id_Case (S : String; Quotes : Boolean := True) is
1158 Name_Buffer (1 .. S'Last) := S;
1159 Name_Len := S'Length;
1160 Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
1161 Error_Msg_Strlen := Name_Len;
1162 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1171 -- Start of processing for Restriction_Msg
1174 -- Set warning message if warning
1176 if Restriction_Warnings (R) then
1179 -- If real violation (not warning), then mark it as non-serious unless
1180 -- it is a violation of No_Finalization in which case we leave it as a
1181 -- serious message, since otherwise we get crashes during attempts to
1182 -- expand stuff that is not properly formed due to assumptions made
1183 -- about no finalization being present.
1185 elsif R /= No_Finalization then
1189 Error_Msg_Sloc := Restrictions_Loc (R);
1191 -- Set main message, adding implicit if no source location
1193 if Error_Msg_Sloc > No_Location
1194 or else Error_Msg_Sloc = System_Location
1196 Add_Str ("violation of restriction ");
1198 Add_Str ("violation of implicit restriction ");
1199 Error_Msg_Sloc := No_Location;
1202 -- Case of parameterized restriction
1204 if R in All_Parameter_Restrictions then
1206 Id_Case (Restriction_Id'Image (R), Quotes => False);
1208 Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R)));
1210 -- Case of boolean restriction
1213 Id_Case (Restriction_Id'Image (R));
1216 -- Case of no secondary profile continuation message
1218 if Restriction_Profile_Name (R) = No_Profile then
1219 if Error_Msg_Sloc /= No_Location then
1224 Error_Msg_N (Msg (1 .. Len), N);
1226 -- Case of secondary profile continuation message present
1230 Error_Msg_N (Msg (1 .. Len), N);
1235 -- Set as warning if warning case
1237 if Restriction_Warnings (R) then
1243 Add_Str ("from profile ");
1244 Id_Case (Profile_Name'Image (Restriction_Profile_Name (R)));
1246 -- Add location if we have one
1248 if Error_Msg_Sloc /= No_Location then
1252 -- Output unconditional message and we are done
1255 Error_Msg_N (Msg (1 .. Len), N);
1257 end Restriction_Msg;
1263 function Same_Entity (E1, E2 : Node_Id) return Boolean is
1265 if Nkind (E1) in N_Identifier | N_Operator_Symbol
1267 Nkind (E2) in N_Identifier | N_Operator_Symbol
1269 return Chars (E1) = Chars (E2);
1271 elsif Nkind (E1) in N_Selected_Component | N_Expanded_Name
1273 Nkind (E2) in N_Selected_Component | N_Expanded_Name
1275 return Same_Unit (Prefix (E1), Prefix (E2))
1277 Same_Unit (Selector_Name (E1), Selector_Name (E2));
1287 function Same_Unit (U1, U2 : Node_Id) return Boolean is
1289 if Nkind (U1) = N_Identifier and then Nkind (U2) = N_Identifier then
1290 return Chars (U1) = Chars (U2);
1292 elsif Nkind (U1) in N_Selected_Component | N_Expanded_Name
1294 Nkind (U2) in N_Selected_Component | N_Expanded_Name
1296 return Same_Unit (Prefix (U1), Prefix (U2))
1298 Same_Unit (Selector_Name (U1), Selector_Name (U2));
1304 --------------------------------------------
1305 -- Save_Config_Cunit_Boolean_Restrictions --
1306 --------------------------------------------
1308 procedure Save_Config_Cunit_Boolean_Restrictions is
1310 Config_Cunit_Boolean_Restrictions := Cunit_Boolean_Restrictions_Save;
1311 end Save_Config_Cunit_Boolean_Restrictions;
1313 ------------------------------
1314 -- Set_Profile_Restrictions --
1315 ------------------------------
1317 procedure Set_Profile_Restrictions
1322 R : Restriction_Flags renames Profile_Info (P).Set;
1323 V : Restriction_Values renames Profile_Info (P).Value;
1326 for J in R'Range loop
1329 Already_Restricted : constant Boolean := Restriction_Active (J);
1332 -- Set the restriction
1334 if J in All_Boolean_Restrictions then
1335 Set_Restriction (J, N);
1337 Set_Restriction (J, N, V (J));
1340 -- Record that this came from a Profile[_Warnings] restriction
1342 Restriction_Profile_Name (J) := P;
1344 -- Set warning flag, except that we do not set the warning
1345 -- flag if the restriction was already active and this is
1346 -- the warning case. That avoids a warning overriding a real
1347 -- restriction, which should never happen.
1349 if not (Warn and Already_Restricted) then
1350 Restriction_Warnings (J) := Warn;
1355 end Set_Profile_Restrictions;
1357 ---------------------
1358 -- Set_Restriction --
1359 ---------------------
1361 procedure Set_Restriction
1362 (R : All_Boolean_Restrictions;
1366 Restrictions.Set (R) := True;
1368 if Restricted_Profile_Cached and Restricted_Profile_Result then
1371 Restricted_Profile_Cached := False;
1374 -- Set location, but preserve location of system restriction for nice
1375 -- error msg with run time name.
1377 if Restrictions_Loc (R) /= System_Location then
1378 Restrictions_Loc (R) := Sloc (N);
1381 -- Note restriction came from restriction pragma, not profile
1383 Restriction_Profile_Name (R) := No_Profile;
1385 -- Record the restriction if we are in the main unit, or in the extended
1386 -- main unit. The reason that we test separately for Main_Unit is that
1387 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1388 -- gnat.adc do not appear to be in the extended main source unit (they
1389 -- probably should do ???)
1391 if Current_Sem_Unit = Main_Unit
1392 or else In_Extended_Main_Source_Unit (N)
1394 if not Restriction_Warnings (R) then
1395 Main_Restrictions.Set (R) := True;
1398 end Set_Restriction;
1400 procedure Set_Restriction
1401 (R : All_Parameter_Restrictions;
1406 if Restricted_Profile_Cached and Restricted_Profile_Result then
1409 Restricted_Profile_Cached := False;
1412 if Restrictions.Set (R) then
1413 if V < Restrictions.Value (R) then
1414 Restrictions.Value (R) := V;
1415 Restrictions_Loc (R) := Sloc (N);
1419 Restrictions.Set (R) := True;
1420 Restrictions.Value (R) := V;
1421 Restrictions_Loc (R) := Sloc (N);
1424 -- Record the restriction if we are in the main unit, or in the extended
1425 -- main unit. The reason that we test separately for Main_Unit is that
1426 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1427 -- gnat.adc do not appear to be the extended main source unit (they
1428 -- probably should do ???)
1430 if Current_Sem_Unit = Main_Unit
1431 or else In_Extended_Main_Source_Unit (N)
1433 if Main_Restrictions.Set (R) then
1434 if V < Main_Restrictions.Value (R) then
1435 Main_Restrictions.Value (R) := V;
1438 elsif not Restriction_Warnings (R) then
1439 Main_Restrictions.Set (R) := True;
1440 Main_Restrictions.Value (R) := V;
1444 -- Note restriction came from restriction pragma, not profile
1446 Restriction_Profile_Name (R) := No_Profile;
1447 end Set_Restriction;
1449 procedure Set_Restriction
1450 (R : All_Restrictions;
1453 V : Integer := Integer'First)
1455 Set : Boolean := True;
1457 if Warn and then Restriction_Active (R) then
1462 if R in All_Boolean_Restrictions then
1463 Set_Restriction (R, N);
1465 Set_Restriction (R, N, V);
1468 Restriction_Warnings (R) := Warn;
1470 end Set_Restriction;
1472 -----------------------------------
1473 -- Set_Restriction_No_Dependence --
1474 -----------------------------------
1476 procedure Set_Restriction_No_Dependence
1479 Profile : Profile_Name := No_Profile)
1482 -- Loop to check for duplicate entry
1484 for J in No_Dependences.First .. No_Dependences.Last loop
1486 -- Case of entry already in table
1488 if Same_Unit (Unit, No_Dependences.Table (J).Unit) then
1490 -- Error has precedence over warning
1493 No_Dependences.Table (J).Warn := False;
1500 -- Entry is not currently in table
1502 No_Dependences.Append ((Unit, Warn, Profile));
1503 end Set_Restriction_No_Dependence;
1505 --------------------------------------
1506 -- Set_Restriction_No_Use_Of_Entity --
1507 --------------------------------------
1509 procedure Set_Restriction_No_Use_Of_Entity
1512 Profile : Profile_Name := No_Profile)
1517 -- Loop to check for duplicate entry
1519 for J in No_Use_Of_Entity.First .. No_Use_Of_Entity.Last loop
1521 -- Case of entry already in table
1523 if Same_Entity (Entity, No_Use_Of_Entity.Table (J).Entity) then
1525 -- Error has precedence over warning
1528 No_Use_Of_Entity.Table (J).Warn := False;
1535 -- Entry is not currently in table
1537 No_Use_Of_Entity.Append ((Entity, Warn, Profile));
1539 -- Now we need to find the direct name and set Boolean2 flag
1541 if Nkind (Entity) in N_Identifier | N_Operator_Symbol then
1545 pragma Assert (Nkind (Entity) = N_Selected_Component);
1546 Nam := Selector_Name (Entity);
1547 pragma Assert (Nkind (Nam) in N_Identifier | N_Operator_Symbol);
1550 Set_Name_Table_Boolean2 (Chars (Nam), True);
1551 end Set_Restriction_No_Use_Of_Entity;
1553 ------------------------------------------------
1554 -- Set_Restriction_No_Specification_Of_Aspect --
1555 ------------------------------------------------
1557 procedure Set_Restriction_No_Specification_Of_Aspect
1561 A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N));
1564 No_Specification_Of_Aspect_Set := True;
1565 No_Specification_Of_Aspects (A_Id) := Sloc (N);
1566 No_Specification_Of_Aspect_Warning (A_Id) := Warn;
1567 end Set_Restriction_No_Specification_Of_Aspect;
1569 procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id) is
1571 No_Specification_Of_Aspect_Set := True;
1572 No_Specification_Of_Aspects (A_Id) := System_Location;
1573 No_Specification_Of_Aspect_Warning (A_Id) := False;
1574 end Set_Restriction_No_Specification_Of_Aspect;
1576 -----------------------------------------
1577 -- Set_Restriction_No_Use_Of_Attribute --
1578 -----------------------------------------
1580 procedure Set_Restriction_No_Use_Of_Attribute
1584 A_Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
1587 No_Use_Of_Attribute_Set := True;
1588 No_Use_Of_Attribute (A_Id) := Sloc (N);
1589 No_Use_Of_Attribute_Warning (A_Id) := Warn;
1590 end Set_Restriction_No_Use_Of_Attribute;
1592 procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id) is
1594 No_Use_Of_Attribute_Set := True;
1595 No_Use_Of_Attribute (A_Id) := System_Location;
1596 No_Use_Of_Attribute_Warning (A_Id) := False;
1597 end Set_Restriction_No_Use_Of_Attribute;
1599 --------------------------------------
1600 -- Set_Restriction_No_Use_Of_Pragma --
1601 --------------------------------------
1603 procedure Set_Restriction_No_Use_Of_Pragma
1607 A_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N));
1610 No_Use_Of_Pragma_Set := True;
1611 No_Use_Of_Pragma (A_Id) := Sloc (N);
1612 No_Use_Of_Pragma_Warning (A_Id) := Warn;
1613 end Set_Restriction_No_Use_Of_Pragma;
1615 procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id) is
1617 No_Use_Of_Pragma_Set := True;
1618 No_Use_Of_Pragma (A_Id) := System_Location;
1619 No_Use_Of_Pragma_Warning (A_Id) := False;
1620 end Set_Restriction_No_Use_Of_Pragma;
1622 ---------------------------
1623 -- Set_Global_No_Tasking --
1624 ---------------------------
1626 procedure Set_Global_No_Tasking is
1628 Global_Restriction_No_Tasking := True;
1629 end Set_Global_No_Tasking;
1631 ----------------------------------
1632 -- Suppress_Restriction_Message --
1633 ----------------------------------
1635 function Suppress_Restriction_Message (N : Node_Id) return Boolean is
1637 -- We only output messages for the extended main source unit
1639 if In_Extended_Main_Source_Unit (N) then
1642 -- If loaded by rtsfind, then suppress message
1644 elsif Sloc (N) <= No_Location then
1647 -- Otherwise suppress message if internal file
1650 return In_Internal_Unit (N);
1652 end Suppress_Restriction_Message;
1654 ---------------------
1655 -- Tasking_Allowed --
1656 ---------------------
1658 function Tasking_Allowed return Boolean is
1660 return not Restrictions.Set (No_Tasking)
1661 and then (not Restrictions.Set (Max_Tasks)
1662 or else Restrictions.Value (Max_Tasks) > 0)
1663 and then not No_Run_Time_Mode;
1664 end Tasking_Allowed;