1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, 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 Aspects; use Aspects;
27 with Atree; use Atree;
28 with Casing; use Casing;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Debug; use Debug;
32 with Fname; use Fname;
33 with Fname.UF; use Fname.UF;
36 with Sinfo; use Sinfo;
37 with Sinput; use Sinput;
38 with Snames; use Snames;
39 with Stand; use Stand;
40 with Uname; use Uname;
42 package body Restrict is
44 -------------------------------
45 -- SPARK Restriction Control --
46 -------------------------------
48 -- SPARK HIDE directives allow the effect of the SPARK_05 restriction to be
49 -- turned off for a specified region of code, and the following tables are
50 -- the data structures used to keep track of these regions.
52 -- The table contains pairs of source locations, the first being the start
53 -- location for hidden region, and the second being the end location.
55 -- Note that the start location is included in the hidden region, while
56 -- the end location is excluded from it. (It typically corresponds to the
57 -- next token during scanning.)
59 type SPARK_Hide_Entry is record
64 package SPARK_Hides is new Table.Table (
65 Table_Component_Type => SPARK_Hide_Entry,
66 Table_Index_Type => Natural,
69 Table_Increment => 200,
70 Table_Name => "SPARK Hides");
72 --------------------------------
73 -- Package Local Declarations --
74 --------------------------------
76 Config_Cunit_Boolean_Restrictions : Save_Cunit_Boolean_Restrictions;
77 -- Save compilation unit restrictions set by config pragma files
79 Restricted_Profile_Result : Boolean := False;
80 -- This switch memoizes the result of Restricted_Profile function calls for
81 -- improved efficiency. Valid only if Restricted_Profile_Cached is True.
82 -- Note: if this switch is ever set True, it is never turned off again.
84 Restricted_Profile_Cached : Boolean := False;
85 -- This flag is set to True if the Restricted_Profile_Result contains the
86 -- correct cached result of Restricted_Profile calls.
88 No_Specification_Of_Aspects : array (Aspect_Id) of Source_Ptr :=
89 (others => No_Location);
90 -- Entries in this array are set to point to a previously occuring pragma
91 -- that activates a No_Specification_Of_Aspect check.
93 No_Specification_Of_Aspect_Warning : array (Aspect_Id) of Boolean :=
95 -- An entry in this array is set False in reponse to a previous call to
96 -- Set_No_Speficiation_Of_Aspect for pragmas in the main unit that
97 -- specify Warning as False. Once set False, an entry is never reset.
99 No_Specification_Of_Aspect_Set : Boolean := False;
100 -- Set True if any entry of No_Specifcation_Of_Aspects has been set True.
101 -- Once set True, this is never turned off again.
103 No_Use_Of_Attribute : array (Attribute_Id) of Source_Ptr :=
104 (others => No_Location);
106 No_Use_Of_Attribute_Warning : array (Attribute_Id) of Boolean :=
109 No_Use_Of_Attribute_Set : Boolean := False;
110 -- Indicates that No_Use_Of_Attribute was set at least once
112 No_Use_Of_Pragma : array (Pragma_Id) of Source_Ptr :=
113 (others => No_Location);
115 No_Use_Of_Pragma_Warning : array (Pragma_Id) of Boolean :=
118 No_Use_Of_Pragma_Set : Boolean := False;
119 -- Indicates that No_Use_Of_Pragma was set at least once
121 -----------------------
122 -- Local Subprograms --
123 -----------------------
125 procedure Restriction_Msg (R : Restriction_Id; N : Node_Id);
126 -- Called if a violation of restriction R at node N is found. This routine
127 -- outputs the appropriate message or messages taking care of warning vs
128 -- real violation, serious vs non-serious, implicit vs explicit, the second
129 -- message giving the profile name if needed, and the location information.
131 function Same_Unit (U1, U2 : Node_Id) return Boolean;
132 -- Returns True iff U1 and U2 represent the same library unit. Used for
133 -- handling of No_Dependence => Unit restriction case.
135 function Suppress_Restriction_Message (N : Node_Id) return Boolean;
136 -- N is the node for a possible restriction violation message, but the
137 -- message is to be suppressed if this is an internal file and this file is
138 -- not the main unit. Returns True if message is to be suppressed.
144 function Abort_Allowed return Boolean is
146 if Restrictions.Set (No_Abort_Statements)
147 and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
148 and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0
156 ----------------------------------------
157 -- Add_To_Config_Boolean_Restrictions --
158 ----------------------------------------
160 procedure Add_To_Config_Boolean_Restrictions (R : Restriction_Id) is
162 Config_Cunit_Boolean_Restrictions (R) := True;
163 end Add_To_Config_Boolean_Restrictions;
164 -- Add specified restriction to stored configuration boolean restrictions.
165 -- This is used for handling the special case of No_Elaboration_Code.
167 -------------------------
168 -- Check_Compiler_Unit --
169 -------------------------
171 procedure Check_Compiler_Unit (Feature : String; N : Node_Id) is
173 if Compiler_Unit then
174 Error_Msg_N (Feature & " not allowed in compiler unit!!??", N);
176 end Check_Compiler_Unit;
178 procedure Check_Compiler_Unit (Feature : String; Loc : Source_Ptr) is
180 if Compiler_Unit then
181 Error_Msg (Feature & " not allowed in compiler unit!!??", Loc);
183 end Check_Compiler_Unit;
185 ------------------------------------
186 -- Check_Elaboration_Code_Allowed --
187 ------------------------------------
189 procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
191 Check_Restriction (No_Elaboration_Code, N);
192 end Check_Elaboration_Code_Allowed;
194 --------------------------------
195 -- Check_No_Implicit_Aliasing --
196 --------------------------------
198 procedure Check_No_Implicit_Aliasing (Obj : Node_Id) is
202 -- If restriction not active, nothing to check
204 if not Restriction_Active (No_Implicit_Aliasing) then
208 -- If we have an entity name, check entity
210 if Is_Entity_Name (Obj) then
213 -- Restriction applies to entities that are objects
215 if Is_Object (E) then
216 if Is_Aliased (E) then
219 elsif Present (Renamed_Object (E)) then
220 Check_No_Implicit_Aliasing (Renamed_Object (E));
224 -- If we don't have an object, then it's OK
230 -- For selected component, check selector
232 elsif Nkind (Obj) = N_Selected_Component then
233 Check_No_Implicit_Aliasing (Selector_Name (Obj));
236 -- Indexed component is OK if aliased components
238 elsif Nkind (Obj) = N_Indexed_Component then
239 if Has_Aliased_Components (Etype (Prefix (Obj)))
241 (Is_Access_Type (Etype (Prefix (Obj)))
242 and then Has_Aliased_Components
243 (Designated_Type (Etype (Prefix (Obj)))))
248 -- For type conversion, check converted expression
250 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
251 Check_No_Implicit_Aliasing (Expression (Obj));
254 -- Explicit dereference is always OK
256 elsif Nkind (Obj) = N_Explicit_Dereference then
260 -- If we fall through, then we have an aliased view that does not meet
261 -- the rules for being explicitly aliased, so issue restriction msg.
263 Check_Restriction (No_Implicit_Aliasing, Obj);
264 end Check_No_Implicit_Aliasing;
266 -----------------------------------------
267 -- Check_Implicit_Dynamic_Code_Allowed --
268 -----------------------------------------
270 procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id) is
272 Check_Restriction (No_Implicit_Dynamic_Code, N);
273 end Check_Implicit_Dynamic_Code_Allowed;
275 ----------------------------------
276 -- Check_No_Implicit_Heap_Alloc --
277 ----------------------------------
279 procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is
281 Check_Restriction (No_Implicit_Heap_Allocations, N);
282 end Check_No_Implicit_Heap_Alloc;
284 -----------------------------------
285 -- Check_Obsolescent_2005_Entity --
286 -----------------------------------
288 procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id) is
289 function Chars_Is (E : Entity_Id; S : String) return Boolean;
290 -- Return True iff Chars (E) matches S (given in lower case)
296 function Chars_Is (E : Entity_Id; S : String) return Boolean is
297 Nam : constant Name_Id := Chars (E);
299 if Length_Of_Name (Nam) /= S'Length then
302 return Get_Name_String (Nam) = S;
306 -- Start of processing for Check_Obsolescent_2005_Entity
309 if Restriction_Check_Required (No_Obsolescent_Features)
310 and then Ada_Version >= Ada_2005
311 and then Chars_Is (Scope (E), "handling")
312 and then Chars_Is (Scope (Scope (E)), "characters")
313 and then Chars_Is (Scope (Scope (Scope (E))), "ada")
314 and then Scope (Scope (Scope (Scope (E)))) = Standard_Standard
316 if Chars_Is (E, "is_character") or else
317 Chars_Is (E, "is_string") or else
318 Chars_Is (E, "to_character") or else
319 Chars_Is (E, "to_string") or else
320 Chars_Is (E, "to_wide_character") or else
321 Chars_Is (E, "to_wide_string")
323 Check_Restriction (No_Obsolescent_Features, N);
326 end Check_Obsolescent_2005_Entity;
328 ---------------------------
329 -- Check_Restricted_Unit --
330 ---------------------------
332 procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
334 if Suppress_Restriction_Message (N) then
337 elsif Is_Spec_Name (U) then
339 Fnam : constant File_Name_Type :=
340 Get_File_Name (U, Subunit => False);
345 Get_Name_String (Fnam);
347 -- Nothing to do if name not at least 5 characters long ending
348 -- in .ads or .adb extension, which we strip.
351 or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads"
353 Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb")
358 -- Strip extension and pad to eight characters
360 Name_Len := Name_Len - 4;
361 Add_Str_To_Name_Buffer ((Name_Len + 1 .. 8 => ' '));
363 -- If predefined unit, check the list of restricted units
365 if Is_Predefined_File_Name (Fnam) then
366 for J in Unit_Array'Range loop
368 and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
370 Check_Restriction (Unit_Array (J).Res_Id, N);
374 -- If not predefined unit, then one special check still
375 -- remains. GNAT.Current_Exception is not allowed if we have
376 -- restriction No_Exception_Propagation active.
379 if Name_Buffer (1 .. 8) = "g-curexc" then
380 Check_Restriction (No_Exception_Propagation, N);
385 end Check_Restricted_Unit;
387 -----------------------
388 -- Check_Restriction --
389 -----------------------
391 procedure Check_Restriction
394 V : Uint := Uint_Minus_1)
396 Msg_Issued : Boolean;
397 pragma Unreferenced (Msg_Issued);
399 Check_Restriction (Msg_Issued, R, N, V);
400 end Check_Restriction;
402 procedure Check_Restriction
403 (Msg_Issued : out Boolean;
406 V : Uint := Uint_Minus_1)
409 -- V converted to integer form. If V is greater than Integer'Last,
410 -- it is reset to minus 1 (unknown value).
412 procedure Update_Restrictions (Info : in out Restrictions_Info);
413 -- Update violation information in Info.Violated and Info.Count
415 -------------------------
416 -- Update_Restrictions --
417 -------------------------
419 procedure Update_Restrictions (Info : in out Restrictions_Info) is
421 -- If not violated, set as violated now
423 if not Info.Violated (R) then
424 Info.Violated (R) := True;
426 if R in All_Parameter_Restrictions then
428 Info.Unknown (R) := True;
431 Info.Count (R) := VV;
435 -- Otherwise if violated already and a parameter restriction,
436 -- update count by maximizing or summing depending on restriction.
438 elsif R in All_Parameter_Restrictions then
440 -- If new value is unknown, result is unknown
443 Info.Unknown (R) := True;
445 -- If checked by maximization, do maximization
447 elsif R in Checked_Max_Parameter_Restrictions then
448 Info.Count (R) := Integer'Max (Info.Count (R), VV);
450 -- If checked by adding, do add, checking for overflow
452 elsif R in Checked_Add_Parameter_Restrictions then
454 pragma Unsuppress (Overflow_Check);
456 Info.Count (R) := Info.Count (R) + VV;
458 when Constraint_Error =>
459 Info.Count (R) := Integer'Last;
460 Info.Unknown (R) := True;
463 -- Should not be able to come here, known counts should only
464 -- occur for restrictions that are Checked_max or Checked_Sum.
470 end Update_Restrictions;
472 -- Start of processing for Check_Restriction
477 -- In CodePeer and SPARK mode, we do not want to check for any
478 -- restriction, or set additional restrictions other than those already
479 -- set in gnat1drv.adb so that we have consistency between each
482 -- Just checking, SPARK does not allow restrictions to be set ???
484 if CodePeer_Mode or GNATprove_Mode then
488 -- In SPARK mode, issue an error for any use of class-wide, even if the
489 -- No_Dispatch restriction is not set.
491 if R = No_Dispatch then
492 Check_SPARK_Restriction ("class-wide is not allowed", N);
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);
557 end Check_Restriction;
559 -------------------------------------
560 -- Check_Restriction_No_Dependence --
561 -------------------------------------
563 procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is
567 -- Ignore call if node U is not in the main source unit. This avoids
568 -- cascaded errors, e.g. when Ada.Containers units with other units.
569 -- However, allow Standard_Location here, since this catches some cases
570 -- of constructs that get converted to run-time calls.
572 if not In_Extended_Main_Source_Unit (U)
573 and then Sloc (U) /= Standard_Location
578 -- Loop through entries in No_Dependence table to check each one in turn
580 for J in No_Dependences.First .. No_Dependences.Last loop
581 DU := No_Dependences.Table (J).Unit;
583 if Same_Unit (U, DU) then
584 Error_Msg_Sloc := Sloc (DU);
585 Error_Msg_Node_1 := DU;
587 if No_Dependences.Table (J).Warn then
589 ("?*?violation of restriction `No_Dependence '='> &`#",
593 ("|violation of restriction `No_Dependence '='> &`#",
600 end Check_Restriction_No_Dependence;
602 --------------------------------------------------
603 -- Check_Restriction_No_Specification_Of_Aspect --
604 --------------------------------------------------
606 procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id) is
611 -- Ignore call if no instances of this restriction set
613 if not No_Specification_Of_Aspect_Set then
617 -- Ignore call if node N is not in the main source unit, since we only
618 -- give messages for the main unit. This avoids giving messages for
619 -- aspects that are specified in withed units.
621 if not In_Extended_Main_Source_Unit (N) then
625 Id := Identifier (N);
626 A_Id := Get_Aspect_Id (Chars (Id));
627 pragma Assert (A_Id /= No_Aspect);
629 Error_Msg_Sloc := No_Specification_Of_Aspects (A_Id);
631 if Error_Msg_Sloc /= No_Location then
632 Error_Msg_Node_1 := Id;
633 Error_Msg_Warn := No_Specification_Of_Aspect_Warning (A_Id);
635 ("<*<violation of restriction `No_Specification_Of_Aspect '='> &`#",
638 end Check_Restriction_No_Specification_Of_Aspect;
640 -------------------------------------------
641 -- Check_Restriction_No_Use_Of_Attribute --
642 --------------------------------------------
644 procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id) is
645 Id : constant Name_Id := Chars (N);
646 A_Id : constant Attribute_Id := Get_Attribute_Id (Id);
649 -- Ignore call if node N is not in the main source unit, since we only
650 -- give messages for the main unit. This avoids giving messages for
651 -- aspects that are specified in withed units.
653 if not In_Extended_Main_Source_Unit (N) then
657 -- If nothing set, nothing to check
659 if not No_Use_Of_Attribute_Set then
663 Error_Msg_Sloc := No_Use_Of_Attribute (A_Id);
665 if Error_Msg_Sloc /= No_Location then
666 Error_Msg_Node_1 := N;
667 Error_Msg_Warn := No_Use_Of_Attribute_Warning (A_Id);
669 ("<*<violation of restriction `No_Use_Of_Attribute '='> &`#", N);
671 end Check_Restriction_No_Use_Of_Attribute;
673 ----------------------------------------
674 -- Check_Restriction_No_Use_Of_Pragma --
675 ----------------------------------------
677 procedure Check_Restriction_No_Use_Of_Pragma (N : Node_Id) is
678 Id : constant Node_Id := Pragma_Identifier (N);
679 P_Id : constant Pragma_Id := Get_Pragma_Id (Chars (Id));
682 -- Ignore call if node N is not in the main source unit, since we only
683 -- give messages for the main unit. This avoids giving messages for
684 -- aspects that are specified in withed units.
686 if not In_Extended_Main_Source_Unit (N) then
690 -- If nothing set, nothing to check
692 if not No_Use_Of_Pragma_Set then
696 Error_Msg_Sloc := No_Use_Of_Pragma (P_Id);
698 if Error_Msg_Sloc /= No_Location then
699 Error_Msg_Node_1 := Id;
700 Error_Msg_Warn := No_Use_Of_Pragma_Warning (P_Id);
702 ("<*<violation of restriction `No_Use_Of_Pragma '='> &`#", Id);
704 end Check_Restriction_No_Use_Of_Pragma;
706 --------------------------------------
707 -- Check_Wide_Character_Restriction --
708 --------------------------------------
710 procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is
712 if Restriction_Check_Required (No_Wide_Characters)
713 and then Comes_From_Source (N)
716 T : constant Entity_Id := Root_Type (E);
718 if T = Standard_Wide_Character or else
719 T = Standard_Wide_String or else
720 T = Standard_Wide_Wide_Character or else
721 T = Standard_Wide_Wide_String
723 Check_Restriction (No_Wide_Characters, N);
727 end Check_Wide_Character_Restriction;
729 ----------------------------------------
730 -- Cunit_Boolean_Restrictions_Restore --
731 ----------------------------------------
733 procedure Cunit_Boolean_Restrictions_Restore
734 (R : Save_Cunit_Boolean_Restrictions)
737 for J in Cunit_Boolean_Restrictions loop
738 Restrictions.Set (J) := R (J);
741 -- If No_Elaboration_Code set in configuration restrictions, and we
742 -- in the main extended source, then set it here now. This is part of
743 -- the special processing for No_Elaboration_Code.
745 if In_Extended_Main_Source_Unit (Cunit_Entity (Current_Sem_Unit))
746 and then Config_Cunit_Boolean_Restrictions (No_Elaboration_Code)
748 Restrictions.Set (No_Elaboration_Code) := True;
750 end Cunit_Boolean_Restrictions_Restore;
752 -------------------------------------
753 -- Cunit_Boolean_Restrictions_Save --
754 -------------------------------------
756 function Cunit_Boolean_Restrictions_Save
757 return Save_Cunit_Boolean_Restrictions
759 R : Save_Cunit_Boolean_Restrictions;
762 for J in Cunit_Boolean_Restrictions loop
763 R (J) := Restrictions.Set (J);
767 end Cunit_Boolean_Restrictions_Save;
769 ------------------------
770 -- Get_Restriction_Id --
771 ------------------------
773 function Get_Restriction_Id
774 (N : Name_Id) return Restriction_Id
778 Set_Casing (All_Upper_Case);
780 for J in All_Restrictions loop
782 S : constant String := Restriction_Id'Image (J);
784 if S = Name_Buffer (1 .. Name_Len) then
790 return Not_A_Restriction_Id;
791 end Get_Restriction_Id;
793 --------------------------------
794 -- Is_In_Hidden_Part_In_SPARK --
795 --------------------------------
797 function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean is
799 -- Loop through table of hidden ranges
801 for J in SPARK_Hides.First .. SPARK_Hides.Last loop
802 if SPARK_Hides.Table (J).Start <= Loc
803 and then Loc < SPARK_Hides.Table (J).Stop
810 end Is_In_Hidden_Part_In_SPARK;
812 -------------------------------
813 -- No_Exception_Handlers_Set --
814 -------------------------------
816 function No_Exception_Handlers_Set return Boolean is
818 return (No_Run_Time_Mode or else Configurable_Run_Time_Mode)
819 and then (Restrictions.Set (No_Exception_Handlers)
821 Restrictions.Set (No_Exception_Propagation));
822 end No_Exception_Handlers_Set;
824 -------------------------------------
825 -- No_Exception_Propagation_Active --
826 -------------------------------------
828 function No_Exception_Propagation_Active return Boolean is
830 return (No_Run_Time_Mode
831 or else Configurable_Run_Time_Mode
832 or else Debug_Flag_Dot_G)
833 and then Restriction_Active (No_Exception_Propagation);
834 end No_Exception_Propagation_Active;
836 --------------------------------
837 -- OK_No_Dependence_Unit_Name --
838 --------------------------------
840 function OK_No_Dependence_Unit_Name (N : Node_Id) return Boolean is
842 if Nkind (N) = N_Selected_Component then
844 OK_No_Dependence_Unit_Name (Prefix (N))
846 OK_No_Dependence_Unit_Name (Selector_Name (N));
848 elsif Nkind (N) = N_Identifier then
852 Error_Msg_N ("wrong form for unit name for No_Dependence", N);
855 end OK_No_Dependence_Unit_Name;
857 ----------------------------------
858 -- Process_Restriction_Synonyms --
859 ----------------------------------
861 -- Note: body of this function must be coordinated with list of
862 -- renaming declarations in System.Rident.
864 function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
866 Old_Name : constant Name_Id := Chars (N);
871 when Name_Boolean_Entry_Barriers =>
872 New_Name := Name_Simple_Barriers;
874 when Name_Max_Entry_Queue_Depth =>
875 New_Name := Name_Max_Entry_Queue_Length;
877 when Name_No_Dynamic_Interrupts =>
878 New_Name := Name_No_Dynamic_Attachment;
880 when Name_No_Requeue =>
881 New_Name := Name_No_Requeue_Statements;
883 when Name_No_Task_Attributes =>
884 New_Name := Name_No_Task_Attributes_Package;
886 -- No_Elaboration_Code_All is special, no warning needed
888 when Name_No_Elaboration_Code_All =>
889 return Name_No_Elaboration_Code;
891 -- SPARK is special in that we unconditionally warn
894 Error_Msg_Name_1 := Name_SPARK;
895 Error_Msg_N ("restriction identifier % is obsolescent??", N);
896 Error_Msg_Name_1 := Name_SPARK_05;
897 Error_Msg_N ("|use restriction identifier % instead??", N);
898 return Name_SPARK_05;
904 -- Output warning if we are warning on obsolescent features for all
905 -- cases other than SPARK.
907 if Warn_On_Obsolescent_Feature then
908 Error_Msg_Name_1 := Old_Name;
909 Error_Msg_N ("restriction identifier % is obsolescent?j?", N);
910 Error_Msg_Name_1 := New_Name;
911 Error_Msg_N ("|use restriction identifier % instead?j?", N);
915 end Process_Restriction_Synonyms;
917 --------------------------------------
918 -- Reset_Cunit_Boolean_Restrictions --
919 --------------------------------------
921 procedure Reset_Cunit_Boolean_Restrictions is
923 for J in Cunit_Boolean_Restrictions loop
924 Restrictions.Set (J) := False;
926 end Reset_Cunit_Boolean_Restrictions;
928 -----------------------------------------------
929 -- Restore_Config_Cunit_Boolean_Restrictions --
930 -----------------------------------------------
932 procedure Restore_Config_Cunit_Boolean_Restrictions is
934 Cunit_Boolean_Restrictions_Restore (Config_Cunit_Boolean_Restrictions);
935 end Restore_Config_Cunit_Boolean_Restrictions;
937 ------------------------
938 -- Restricted_Profile --
939 ------------------------
941 function Restricted_Profile return Boolean is
943 if Restricted_Profile_Cached then
944 return Restricted_Profile_Result;
947 Restricted_Profile_Result := True;
948 Restricted_Profile_Cached := True;
951 R : Restriction_Flags renames Profile_Info (Restricted).Set;
952 V : Restriction_Values renames Profile_Info (Restricted).Value;
954 for J in R'Range loop
956 and then (Restrictions.Set (J) = False
957 or else Restriction_Warnings (J)
959 (J in All_Parameter_Restrictions
960 and then Restrictions.Value (J) > V (J)))
962 Restricted_Profile_Result := False;
967 return Restricted_Profile_Result;
970 end Restricted_Profile;
972 ------------------------
973 -- Restriction_Active --
974 ------------------------
976 function Restriction_Active (R : All_Restrictions) return Boolean is
978 return Restrictions.Set (R) and then not Restriction_Warnings (R);
979 end Restriction_Active;
981 --------------------------------
982 -- Restriction_Check_Required --
983 --------------------------------
985 function Restriction_Check_Required (R : All_Restrictions) return Boolean is
987 return Restrictions.Set (R);
988 end Restriction_Check_Required;
990 ---------------------
991 -- Restriction_Msg --
992 ---------------------
994 procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is
995 Msg : String (1 .. 100);
998 procedure Add_Char (C : Character);
999 -- Append given character to Msg, bumping Len
1001 procedure Add_Str (S : String);
1002 -- Append given string to Msg, bumping Len appropriately
1004 procedure Id_Case (S : String; Quotes : Boolean := True);
1005 -- Given a string S, case it according to current identifier casing,
1006 -- except for SPARK_05 (an acronym) which is set all upper case, and
1007 -- store in Error_Msg_String. Then append `~` to the message buffer
1008 -- to output the string unchanged surrounded in quotes. The quotes
1009 -- are suppressed if Quotes = False.
1015 procedure Add_Char (C : Character) is
1025 procedure Add_Str (S : String) is
1027 Msg (Len + 1 .. Len + S'Length) := S;
1028 Len := Len + S'Length;
1035 procedure Id_Case (S : String; Quotes : Boolean := True) is
1037 Name_Buffer (1 .. S'Last) := S;
1038 Name_Len := S'Length;
1040 if R = SPARK_05 then
1043 Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
1046 Error_Msg_Strlen := Name_Len;
1047 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
1056 -- Start of processing for Restriction_Msg
1059 -- Set warning message if warning
1061 if Restriction_Warnings (R) then
1064 -- If real violation (not warning), then mark it as non-serious unless
1065 -- it is a violation of No_Finalization in which case we leave it as a
1066 -- serious message, since otherwise we get crashes during attempts to
1067 -- expand stuff that is not properly formed due to assumptions made
1068 -- about no finalization being present.
1070 elsif R /= No_Finalization then
1074 Error_Msg_Sloc := Restrictions_Loc (R);
1076 -- Set main message, adding implicit if no source location
1078 if Error_Msg_Sloc > No_Location
1079 or else Error_Msg_Sloc = System_Location
1081 Add_Str ("violation of restriction ");
1083 Add_Str ("violation of implicit restriction ");
1084 Error_Msg_Sloc := No_Location;
1087 -- Case of parameterized restriction
1089 if R in All_Parameter_Restrictions then
1091 Id_Case (Restriction_Id'Image (R), Quotes => False);
1093 Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R)));
1095 -- Case of boolean restriction
1098 Id_Case (Restriction_Id'Image (R));
1101 -- Case of no secondary profile continuation message
1103 if Restriction_Profile_Name (R) = No_Profile then
1104 if Error_Msg_Sloc /= No_Location then
1109 Error_Msg_N (Msg (1 .. Len), N);
1111 -- Case of secondary profile continuation message present
1115 Error_Msg_N (Msg (1 .. Len), N);
1120 -- Set as warning if warning case
1122 if Restriction_Warnings (R) then
1128 Add_Str ("from profile ");
1129 Id_Case (Profile_Name'Image (Restriction_Profile_Name (R)));
1131 -- Add location if we have one
1133 if Error_Msg_Sloc /= No_Location then
1137 -- Output unconditional message and we are done
1140 Error_Msg_N (Msg (1 .. Len), N);
1142 end Restriction_Msg;
1148 function Same_Unit (U1, U2 : Node_Id) return Boolean is
1150 if Nkind (U1) = N_Identifier and then Nkind (U2) = N_Identifier then
1151 return Chars (U1) = Chars (U2);
1153 elsif Nkind_In (U1, N_Selected_Component, N_Expanded_Name)
1155 Nkind_In (U2, N_Selected_Component, N_Expanded_Name)
1157 return Same_Unit (Prefix (U1), Prefix (U2))
1159 Same_Unit (Selector_Name (U1), Selector_Name (U2));
1165 --------------------------------------------
1166 -- Save_Config_Cunit_Boolean_Restrictions --
1167 --------------------------------------------
1169 procedure Save_Config_Cunit_Boolean_Restrictions is
1171 Config_Cunit_Boolean_Restrictions := Cunit_Boolean_Restrictions_Save;
1172 end Save_Config_Cunit_Boolean_Restrictions;
1174 ------------------------------
1175 -- Set_Hidden_Part_In_SPARK --
1176 ------------------------------
1178 procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr) is
1180 SPARK_Hides.Increment_Last;
1181 SPARK_Hides.Table (SPARK_Hides.Last).Start := Loc1;
1182 SPARK_Hides.Table (SPARK_Hides.Last).Stop := Loc2;
1183 end Set_Hidden_Part_In_SPARK;
1185 ------------------------------
1186 -- Set_Profile_Restrictions --
1187 ------------------------------
1189 procedure Set_Profile_Restrictions
1194 R : Restriction_Flags renames Profile_Info (P).Set;
1195 V : Restriction_Values renames Profile_Info (P).Value;
1198 for J in R'Range loop
1201 Already_Restricted : constant Boolean := Restriction_Active (J);
1204 -- Set the restriction
1206 if J in All_Boolean_Restrictions then
1207 Set_Restriction (J, N);
1209 Set_Restriction (J, N, V (J));
1212 -- Record that this came from a Profile[_Warnings] restriction
1214 Restriction_Profile_Name (J) := P;
1216 -- Set warning flag, except that we do not set the warning
1217 -- flag if the restriction was already active and this is
1218 -- the warning case. That avoids a warning overriding a real
1219 -- restriction, which should never happen.
1221 if not (Warn and Already_Restricted) then
1222 Restriction_Warnings (J) := Warn;
1227 end Set_Profile_Restrictions;
1229 ---------------------
1230 -- Set_Restriction --
1231 ---------------------
1233 -- Case of Boolean restriction
1235 procedure Set_Restriction
1236 (R : All_Boolean_Restrictions;
1240 Restrictions.Set (R) := True;
1242 if Restricted_Profile_Cached and Restricted_Profile_Result then
1245 Restricted_Profile_Cached := False;
1248 -- Set location, but preserve location of system restriction for nice
1249 -- error msg with run time name.
1251 if Restrictions_Loc (R) /= System_Location then
1252 Restrictions_Loc (R) := Sloc (N);
1255 -- Note restriction came from restriction pragma, not profile
1257 Restriction_Profile_Name (R) := No_Profile;
1259 -- Record the restriction if we are in the main unit, or in the extended
1260 -- main unit. The reason that we test separately for Main_Unit is that
1261 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1262 -- gnat.adc do not appear to be in the extended main source unit (they
1263 -- probably should do ???)
1265 if Current_Sem_Unit = Main_Unit
1266 or else In_Extended_Main_Source_Unit (N)
1268 if not Restriction_Warnings (R) then
1269 Main_Restrictions.Set (R) := True;
1272 end Set_Restriction;
1274 -- Case of parameter restriction
1276 procedure Set_Restriction
1277 (R : All_Parameter_Restrictions;
1282 if Restricted_Profile_Cached and Restricted_Profile_Result then
1285 Restricted_Profile_Cached := False;
1288 if Restrictions.Set (R) then
1289 if V < Restrictions.Value (R) then
1290 Restrictions.Value (R) := V;
1291 Restrictions_Loc (R) := Sloc (N);
1295 Restrictions.Set (R) := True;
1296 Restrictions.Value (R) := V;
1297 Restrictions_Loc (R) := Sloc (N);
1300 -- Record the restriction if we are in the main unit, or in the extended
1301 -- main unit. The reason that we test separately for Main_Unit is that
1302 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1303 -- gnat.adc do not appear to be the extended main source unit (they
1304 -- probably should do ???)
1306 if Current_Sem_Unit = Main_Unit
1307 or else In_Extended_Main_Source_Unit (N)
1309 if Main_Restrictions.Set (R) then
1310 if V < Main_Restrictions.Value (R) then
1311 Main_Restrictions.Value (R) := V;
1314 elsif not Restriction_Warnings (R) then
1315 Main_Restrictions.Set (R) := True;
1316 Main_Restrictions.Value (R) := V;
1320 -- Note restriction came from restriction pragma, not profile
1322 Restriction_Profile_Name (R) := No_Profile;
1323 end Set_Restriction;
1325 -----------------------------------
1326 -- Set_Restriction_No_Dependence --
1327 -----------------------------------
1329 procedure Set_Restriction_No_Dependence
1332 Profile : Profile_Name := No_Profile)
1335 -- Loop to check for duplicate entry
1337 for J in No_Dependences.First .. No_Dependences.Last loop
1339 -- Case of entry already in table
1341 if Same_Unit (Unit, No_Dependences.Table (J).Unit) then
1343 -- Error has precedence over warning
1346 No_Dependences.Table (J).Warn := False;
1353 -- Entry is not currently in table
1355 No_Dependences.Append ((Unit, Warn, Profile));
1356 end Set_Restriction_No_Dependence;
1358 ------------------------------------------------
1359 -- Set_Restriction_No_Specification_Of_Aspect --
1360 ------------------------------------------------
1362 procedure Set_Restriction_No_Specification_Of_Aspect
1366 A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N));
1369 No_Specification_Of_Aspects (A_Id) := Sloc (N);
1371 if Warning = False then
1372 No_Specification_Of_Aspect_Warning (A_Id) := False;
1375 No_Specification_Of_Aspect_Set := True;
1376 end Set_Restriction_No_Specification_Of_Aspect;
1378 -----------------------------------------
1379 -- Set_Restriction_No_Use_Of_Attribute --
1380 -----------------------------------------
1382 procedure Set_Restriction_No_Use_Of_Attribute
1386 A_Id : constant Attribute_Id := Get_Attribute_Id (Chars (N));
1389 No_Use_Of_Attribute_Set := True;
1390 No_Use_Of_Attribute (A_Id) := Sloc (N);
1392 if Warning = False then
1393 No_Use_Of_Attribute_Warning (A_Id) := False;
1395 end Set_Restriction_No_Use_Of_Attribute;
1397 --------------------------------------
1398 -- Set_Restriction_No_Use_Of_Pragma --
1399 --------------------------------------
1401 procedure Set_Restriction_No_Use_Of_Pragma
1405 A_Id : constant Pragma_Id := Get_Pragma_Id (Chars (N));
1408 No_Use_Of_Pragma_Set := True;
1409 No_Use_Of_Pragma (A_Id) := Sloc (N);
1411 if Warning = False then
1412 No_Use_Of_Pragma_Warning (A_Id) := False;
1414 end Set_Restriction_No_Use_Of_Pragma;
1416 -----------------------------
1417 -- Check_SPARK_Restriction --
1418 -----------------------------
1420 procedure Check_SPARK_Restriction
1423 Force : Boolean := False)
1425 Msg_Issued : Boolean;
1426 Save_Error_Msg_Sloc : Source_Ptr;
1427 Onode : constant Node_Id := Original_Node (N);
1430 -- Output message if Force set
1434 -- Or if this node comes from source
1436 or else Comes_From_Source (N)
1438 -- Or if this is a range node which rewrites a range attribute and
1439 -- the range attribute comes from source.
1441 or else (Nkind (N) = N_Range
1442 and then Nkind (Onode) = N_Attribute_Reference
1443 and then Attribute_Name (Onode) = Name_Range
1444 and then Comes_From_Source (Onode))
1446 -- Or this is an expression that does not come from source, which is
1447 -- a rewriting of an expression that does come from source.
1449 or else (Nkind (N) in N_Subexpr and then Comes_From_Source (Onode))
1451 if Restriction_Check_Required (SPARK_05)
1452 and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
1457 -- Since the call to Restriction_Msg from Check_Restriction may set
1458 -- Error_Msg_Sloc to the location of the pragma restriction, save and
1459 -- restore the previous value of the global variable around the call.
1461 Save_Error_Msg_Sloc := Error_Msg_Sloc;
1462 Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
1463 Error_Msg_Sloc := Save_Error_Msg_Sloc;
1466 Error_Msg_F ("\\| " & Msg, N);
1469 end Check_SPARK_Restriction;
1471 procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is
1472 Msg_Issued : Boolean;
1473 Save_Error_Msg_Sloc : Source_Ptr;
1476 pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\');
1478 if Comes_From_Source (Original_Node (N)) then
1479 if Restriction_Check_Required (SPARK_05)
1480 and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
1485 -- Since the call to Restriction_Msg from Check_Restriction may set
1486 -- Error_Msg_Sloc to the location of the pragma restriction, save and
1487 -- restore the previous value of the global variable around the call.
1489 Save_Error_Msg_Sloc := Error_Msg_Sloc;
1490 Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
1491 Error_Msg_Sloc := Save_Error_Msg_Sloc;
1494 Error_Msg_F ("\\| " & Msg1, N);
1495 Error_Msg_F (Msg2, N);
1498 end Check_SPARK_Restriction;
1500 ----------------------------------
1501 -- Suppress_Restriction_Message --
1502 ----------------------------------
1504 function Suppress_Restriction_Message (N : Node_Id) return Boolean is
1506 -- We only output messages for the extended main source unit
1508 if In_Extended_Main_Source_Unit (N) then
1511 -- If loaded by rtsfind, then suppress message
1513 elsif Sloc (N) <= No_Location then
1516 -- Otherwise suppress message if internal file
1519 return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
1521 end Suppress_Restriction_Message;
1523 ---------------------
1524 -- Tasking_Allowed --
1525 ---------------------
1527 function Tasking_Allowed return Boolean is
1529 return not Restrictions.Set (No_Tasking)
1530 and then (not Restrictions.Set (Max_Tasks)
1531 or else Restrictions.Value (Max_Tasks) > 0);
1532 end Tasking_Allowed;