1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 Config_Cunit_Boolean_Restrictions : Save_Cunit_Boolean_Restrictions;
45 -- Save compilation unit restrictions set by config pragma files
47 Restricted_Profile_Result : Boolean := False;
48 -- This switch memoizes the result of Restricted_Profile function calls for
49 -- improved efficiency. Valid only if Restricted_Profile_Cached is True.
50 -- Note: if this switch is ever set True, it is never turned off again.
52 Restricted_Profile_Cached : Boolean := False;
53 -- This flag is set to True if the Restricted_Profile_Result contains the
54 -- correct cached result of Restricted_Profile calls.
56 No_Specification_Of_Aspects : array (Aspect_Id) of Source_Ptr :=
57 (others => No_Location);
58 -- Entries in this array are set to point to a previously occuring pragma
59 -- that activates a No_Specification_Of_Aspect check.
61 No_Specification_Of_Aspect_Warning : array (Aspect_Id) of Boolean :=
63 -- An entry in this array is set False in reponse to a previous call to
64 -- Set_No_Speficiation_Of_Aspect for pragmas in the main unit that
65 -- specify Warning as False. Once set False, an entry is never reset.
67 No_Specification_Of_Aspect_Set : Boolean := False;
68 -- Set True if any entry of No_Specifcation_Of_Aspects has been set True.
69 -- Once set True, this is never turned off again.
71 -----------------------
72 -- Local Subprograms --
73 -----------------------
75 procedure Restriction_Msg (R : Restriction_Id; N : Node_Id);
76 -- Called if a violation of restriction R at node N is found. This routine
77 -- outputs the appropriate message or messages taking care of warning vs
78 -- real violation, serious vs non-serious, implicit vs explicit, the second
79 -- message giving the profile name if needed, and the location information.
81 function Same_Unit (U1, U2 : Node_Id) return Boolean;
82 -- Returns True iff U1 and U2 represent the same library unit. Used for
83 -- handling of No_Dependence => Unit restriction case.
85 function Suppress_Restriction_Message (N : Node_Id) return Boolean;
86 -- N is the node for a possible restriction violation message, but the
87 -- message is to be suppressed if this is an internal file and this file is
88 -- not the main unit. Returns True if message is to be suppressed.
94 function Abort_Allowed return Boolean is
96 if Restrictions.Set (No_Abort_Statements)
97 and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
98 and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0
106 ----------------------------------------
107 -- Add_To_Config_Boolean_Restrictions --
108 ----------------------------------------
110 procedure Add_To_Config_Boolean_Restrictions (R : Restriction_Id) is
112 Config_Cunit_Boolean_Restrictions (R) := True;
113 end Add_To_Config_Boolean_Restrictions;
114 -- Add specified restriction to stored configuration boolean restrictions.
115 -- This is used for handling the special case of No_Elaboration_Code.
117 -------------------------
118 -- Check_Compiler_Unit --
119 -------------------------
121 procedure Check_Compiler_Unit (N : Node_Id) is
123 if Is_Compiler_Unit (Get_Source_Unit (N)) then
124 Error_Msg_N ("use of construct not allowed in compiler", N);
126 end Check_Compiler_Unit;
128 ------------------------------------
129 -- Check_Elaboration_Code_Allowed --
130 ------------------------------------
132 procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
134 Check_Restriction (No_Elaboration_Code, N);
135 end Check_Elaboration_Code_Allowed;
137 -----------------------------
138 -- Check_SPARK_Restriction --
139 -----------------------------
141 procedure Check_SPARK_Restriction
144 Force : Boolean := False)
146 Msg_Issued : Boolean;
147 Save_Error_Msg_Sloc : Source_Ptr;
149 if Force or else Comes_From_Source (Original_Node (N)) then
151 if Restriction_Check_Required (SPARK)
152 and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
157 -- Since the call to Restriction_Msg from Check_Restriction may set
158 -- Error_Msg_Sloc to the location of the pragma restriction, save and
159 -- restore the previous value of the global variable around the call.
161 Save_Error_Msg_Sloc := Error_Msg_Sloc;
162 Check_Restriction (Msg_Issued, SPARK, First_Node (N));
163 Error_Msg_Sloc := Save_Error_Msg_Sloc;
166 Error_Msg_F ("\\| " & Msg, N);
169 end Check_SPARK_Restriction;
171 procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is
172 Msg_Issued : Boolean;
173 Save_Error_Msg_Sloc : Source_Ptr;
175 pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\');
177 if Comes_From_Source (Original_Node (N)) then
179 if Restriction_Check_Required (SPARK)
180 and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
185 -- Since the call to Restriction_Msg from Check_Restriction may set
186 -- Error_Msg_Sloc to the location of the pragma restriction, save and
187 -- restore the previous value of the global variable around the call.
189 Save_Error_Msg_Sloc := Error_Msg_Sloc;
190 Check_Restriction (Msg_Issued, SPARK, First_Node (N));
191 Error_Msg_Sloc := Save_Error_Msg_Sloc;
194 Error_Msg_F ("\\| " & Msg1, N);
195 Error_Msg_F (Msg2, N);
198 end Check_SPARK_Restriction;
200 --------------------------------
201 -- Check_No_Implicit_Aliasing --
202 --------------------------------
204 procedure Check_No_Implicit_Aliasing (Obj : Node_Id) is
208 -- If restriction not active, nothing to check
210 if not Restriction_Active (No_Implicit_Aliasing) then
214 -- If we have an entity name, check entity
216 if Is_Entity_Name (Obj) then
219 -- Restriction applies to entities that are objects
221 if Is_Object (E) then
222 if Is_Aliased (E) then
225 elsif Present (Renamed_Object (E)) then
226 Check_No_Implicit_Aliasing (Renamed_Object (E));
230 -- If we don't have an object, then it's OK
236 -- For selected component, check selector
238 elsif Nkind (Obj) = N_Selected_Component then
239 Check_No_Implicit_Aliasing (Selector_Name (Obj));
242 -- Indexed component is OK if aliased components
244 elsif Nkind (Obj) = N_Indexed_Component then
245 if Has_Aliased_Components (Etype (Prefix (Obj)))
247 (Is_Access_Type (Etype (Prefix (Obj)))
248 and then Has_Aliased_Components
249 (Designated_Type (Etype (Prefix (Obj)))))
254 -- For type conversion, check converted expression
256 elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then
257 Check_No_Implicit_Aliasing (Expression (Obj));
260 -- Explicit dereference is always OK
262 elsif Nkind (Obj) = N_Explicit_Dereference then
266 -- If we fall through, then we have an aliased view that does not meet
267 -- the rules for being explicitly aliased, so issue restriction msg.
269 Check_Restriction (No_Implicit_Aliasing, Obj);
270 end Check_No_Implicit_Aliasing;
272 -----------------------------------------
273 -- Check_Implicit_Dynamic_Code_Allowed --
274 -----------------------------------------
276 procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id) is
278 Check_Restriction (No_Implicit_Dynamic_Code, N);
279 end Check_Implicit_Dynamic_Code_Allowed;
281 ----------------------------------
282 -- Check_No_Implicit_Heap_Alloc --
283 ----------------------------------
285 procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is
287 Check_Restriction (No_Implicit_Heap_Allocations, N);
288 end Check_No_Implicit_Heap_Alloc;
290 -----------------------------------
291 -- Check_Obsolescent_2005_Entity --
292 -----------------------------------
294 procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id) is
295 function Chars_Is (E : Entity_Id; S : String) return Boolean;
296 -- Return True iff Chars (E) matches S (given in lower case)
298 function Chars_Is (E : Entity_Id; S : String) return Boolean is
299 Nam : constant Name_Id := Chars (E);
301 if Length_Of_Name (Nam) /= S'Length then
304 return Get_Name_String (Nam) = S;
308 -- Start of processing for Check_Obsolescent_2005_Entity
311 if Restriction_Check_Required (No_Obsolescent_Features)
312 and then Ada_Version >= Ada_2005
313 and then Chars_Is (Scope (E), "handling")
314 and then Chars_Is (Scope (Scope (E)), "characters")
315 and then Chars_Is (Scope (Scope (Scope (E))), "ada")
316 and then Scope (Scope (Scope (Scope (E)))) = Standard_Standard
318 if Chars_Is (E, "is_character") or else
319 Chars_Is (E, "is_string") or else
320 Chars_Is (E, "to_character") or else
321 Chars_Is (E, "to_string") or else
322 Chars_Is (E, "to_wide_character") or else
323 Chars_Is (E, "to_wide_string")
325 Check_Restriction (No_Obsolescent_Features, N);
328 end Check_Obsolescent_2005_Entity;
330 ---------------------------
331 -- Check_Restricted_Unit --
332 ---------------------------
334 procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
336 if Suppress_Restriction_Message (N) then
339 elsif Is_Spec_Name (U) then
341 Fnam : constant File_Name_Type :=
342 Get_File_Name (U, Subunit => False);
347 Get_Name_String (Fnam);
349 -- Nothing to do if name not at least 5 characters long ending
350 -- in .ads or .adb extension, which we strip.
353 or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads"
355 Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb")
360 -- Strip extension and pad to eight characters
362 Name_Len := Name_Len - 4;
363 Add_Str_To_Name_Buffer ((Name_Len + 1 .. 8 => ' '));
365 -- If predefined unit, check the list of restricted units
367 if Is_Predefined_File_Name (Fnam) then
368 for J in Unit_Array'Range loop
370 and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
372 Check_Restriction (Unit_Array (J).Res_Id, N);
376 -- If not predefined unit, then one special check still
377 -- remains. GNAT.Current_Exception is not allowed if we have
378 -- restriction No_Exception_Propagation active.
381 if Name_Buffer (1 .. 8) = "g-curexc" then
382 Check_Restriction (No_Exception_Propagation, N);
387 end Check_Restricted_Unit;
389 -----------------------
390 -- Check_Restriction --
391 -----------------------
393 procedure Check_Restriction
396 V : Uint := Uint_Minus_1)
398 Msg_Issued : Boolean;
399 pragma Unreferenced (Msg_Issued);
401 Check_Restriction (Msg_Issued, R, N, V);
402 end Check_Restriction;
404 procedure Check_Restriction
405 (Msg_Issued : out Boolean;
408 V : Uint := Uint_Minus_1)
411 -- V converted to integer form. If V is greater than Integer'Last,
412 -- it is reset to minus 1 (unknown value).
414 procedure Update_Restrictions (Info : in out Restrictions_Info);
415 -- Update violation information in Info.Violated and Info.Count
417 -------------------------
418 -- Update_Restrictions --
419 -------------------------
421 procedure Update_Restrictions (Info : in out Restrictions_Info) is
423 -- If not violated, set as violated now
425 if not Info.Violated (R) then
426 Info.Violated (R) := True;
428 if R in All_Parameter_Restrictions then
430 Info.Unknown (R) := True;
433 Info.Count (R) := VV;
437 -- Otherwise if violated already and a parameter restriction,
438 -- update count by maximizing or summing depending on restriction.
440 elsif R in All_Parameter_Restrictions then
442 -- If new value is unknown, result is unknown
445 Info.Unknown (R) := True;
447 -- If checked by maximization, do maximization
449 elsif R in Checked_Max_Parameter_Restrictions then
450 Info.Count (R) := Integer'Max (Info.Count (R), VV);
452 -- If checked by adding, do add, checking for overflow
454 elsif R in Checked_Add_Parameter_Restrictions then
456 pragma Unsuppress (Overflow_Check);
458 Info.Count (R) := Info.Count (R) + VV;
460 when Constraint_Error =>
461 Info.Count (R) := Integer'Last;
462 Info.Unknown (R) := True;
465 -- Should not be able to come here, known counts should only
466 -- occur for restrictions that are Checked_max or Checked_Sum.
472 end Update_Restrictions;
474 -- Start of processing for Check_Restriction
479 -- In CodePeer and Alfa mode, we do not want to check for any
480 -- restriction, or set additional restrictions other than those already
481 -- set in gnat1drv.adb so that we have consistency between each
484 if CodePeer_Mode or Alfa_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 (either this is a
545 -- Boolean restriction, or a parameter restriction with a value of
546 -- zero and an unknown count, or a parameter restriction with a
547 -- known value that 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.
570 if not In_Extended_Main_Source_Unit (U) then
574 -- Loop through entries in No_Dependence table to check each one in turn
576 for J in No_Dependences.First .. No_Dependences.Last loop
577 DU := No_Dependences.Table (J).Unit;
579 if Same_Unit (U, DU) then
580 Error_Msg_Sloc := Sloc (DU);
581 Error_Msg_Node_1 := DU;
583 if No_Dependences.Table (J).Warn then
585 ("?violation of restriction `No_Dependence '='> &`#",
589 ("|violation of restriction `No_Dependence '='> &`#",
596 end Check_Restriction_No_Dependence;
598 --------------------------------------------------
599 -- Check_Restriction_No_Specification_Of_Aspect --
600 --------------------------------------------------
602 procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id) is
607 -- Ignore call if no instances of this restriction set
609 if not No_Specification_Of_Aspect_Set then
613 -- Ignore call if node N is not in the main source unit, since we only
614 -- give messages for . This avoids giving messages for aspects that are
615 -- specified in withed units.
617 if not In_Extended_Main_Source_Unit (N) then
621 Id := Identifier (N);
622 A_Id := Get_Aspect_Id (Chars (Id));
623 pragma Assert (A_Id /= No_Aspect);
625 Error_Msg_Sloc := No_Specification_Of_Aspects (A_Id);
627 if Error_Msg_Sloc /= No_Location then
628 Error_Msg_Node_1 := Id;
629 Error_Msg_Warn := No_Specification_Of_Aspect_Warning (A_Id);
631 ("<violation of restriction `No_Specification_Of_Aspect '='> &`#",
634 end Check_Restriction_No_Specification_Of_Aspect;
636 --------------------------------------
637 -- Check_Wide_Character_Restriction --
638 --------------------------------------
640 procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is
642 if Restriction_Check_Required (No_Wide_Characters)
643 and then Comes_From_Source (N)
646 T : constant Entity_Id := Root_Type (E);
648 if T = Standard_Wide_Character or else
649 T = Standard_Wide_String or else
650 T = Standard_Wide_Wide_Character or else
651 T = Standard_Wide_Wide_String
653 Check_Restriction (No_Wide_Characters, N);
657 end Check_Wide_Character_Restriction;
659 ----------------------------------------
660 -- Cunit_Boolean_Restrictions_Restore --
661 ----------------------------------------
663 procedure Cunit_Boolean_Restrictions_Restore
664 (R : Save_Cunit_Boolean_Restrictions)
667 for J in Cunit_Boolean_Restrictions loop
668 Restrictions.Set (J) := R (J);
671 -- If No_Elaboration_Code set in configuration restrictions, and we
672 -- in the main extended source, then set it here now. This is part of
673 -- the special processing for No_Elaboration_Code.
675 if In_Extended_Main_Source_Unit (Cunit_Entity (Current_Sem_Unit))
676 and then Config_Cunit_Boolean_Restrictions (No_Elaboration_Code)
678 Restrictions.Set (No_Elaboration_Code) := True;
680 end Cunit_Boolean_Restrictions_Restore;
682 -------------------------------------
683 -- Cunit_Boolean_Restrictions_Save --
684 -------------------------------------
686 function Cunit_Boolean_Restrictions_Save
687 return Save_Cunit_Boolean_Restrictions
689 R : Save_Cunit_Boolean_Restrictions;
692 for J in Cunit_Boolean_Restrictions loop
693 R (J) := Restrictions.Set (J);
697 end Cunit_Boolean_Restrictions_Save;
699 ------------------------
700 -- Get_Restriction_Id --
701 ------------------------
703 function Get_Restriction_Id
704 (N : Name_Id) return Restriction_Id
708 Set_Casing (All_Upper_Case);
710 for J in All_Restrictions loop
712 S : constant String := Restriction_Id'Image (J);
714 if S = Name_Buffer (1 .. Name_Len) then
720 return Not_A_Restriction_Id;
721 end Get_Restriction_Id;
723 --------------------------------
724 -- Is_In_Hidden_Part_In_SPARK --
725 --------------------------------
727 function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean is
729 -- Loop through table of hidden ranges
731 for J in SPARK_Hides.First .. SPARK_Hides.Last loop
732 if SPARK_Hides.Table (J).Start <= Loc
733 and then Loc < SPARK_Hides.Table (J).Stop
740 end Is_In_Hidden_Part_In_SPARK;
742 -------------------------------
743 -- No_Exception_Handlers_Set --
744 -------------------------------
746 function No_Exception_Handlers_Set return Boolean is
748 return (No_Run_Time_Mode or else Configurable_Run_Time_Mode)
749 and then (Restrictions.Set (No_Exception_Handlers)
751 Restrictions.Set (No_Exception_Propagation));
752 end No_Exception_Handlers_Set;
754 -------------------------------------
755 -- No_Exception_Propagation_Active --
756 -------------------------------------
758 function No_Exception_Propagation_Active return Boolean is
760 return (No_Run_Time_Mode
761 or else Configurable_Run_Time_Mode
762 or else Debug_Flag_Dot_G)
763 and then Restriction_Active (No_Exception_Propagation);
764 end No_Exception_Propagation_Active;
766 ----------------------------------
767 -- Process_Restriction_Synonyms --
768 ----------------------------------
770 -- Note: body of this function must be coordinated with list of
771 -- renaming declarations in System.Rident.
773 function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
775 Old_Name : constant Name_Id := Chars (N);
780 when Name_Boolean_Entry_Barriers =>
781 New_Name := Name_Simple_Barriers;
783 when Name_Max_Entry_Queue_Depth =>
784 New_Name := Name_Max_Entry_Queue_Length;
786 when Name_No_Dynamic_Interrupts =>
787 New_Name := Name_No_Dynamic_Attachment;
789 when Name_No_Requeue =>
790 New_Name := Name_No_Requeue_Statements;
792 when Name_No_Task_Attributes =>
793 New_Name := Name_No_Task_Attributes_Package;
799 if Warn_On_Obsolescent_Feature then
800 Error_Msg_Name_1 := Old_Name;
801 Error_Msg_N ("restriction identifier % is obsolescent?", N);
802 Error_Msg_Name_1 := New_Name;
803 Error_Msg_N ("|use restriction identifier % instead", N);
807 end Process_Restriction_Synonyms;
809 --------------------------------------
810 -- Reset_Cunit_Boolean_Restrictions --
811 --------------------------------------
813 procedure Reset_Cunit_Boolean_Restrictions is
815 for J in Cunit_Boolean_Restrictions loop
816 Restrictions.Set (J) := False;
818 end Reset_Cunit_Boolean_Restrictions;
820 -----------------------------------------------
821 -- Restore_Config_Cunit_Boolean_Restrictions --
822 -----------------------------------------------
824 procedure Restore_Config_Cunit_Boolean_Restrictions is
826 Cunit_Boolean_Restrictions_Restore (Config_Cunit_Boolean_Restrictions);
827 end Restore_Config_Cunit_Boolean_Restrictions;
829 ------------------------
830 -- Restricted_Profile --
831 ------------------------
833 function Restricted_Profile return Boolean is
835 if Restricted_Profile_Cached then
836 return Restricted_Profile_Result;
839 Restricted_Profile_Result := True;
840 Restricted_Profile_Cached := True;
843 R : Restriction_Flags renames Profile_Info (Restricted).Set;
844 V : Restriction_Values renames Profile_Info (Restricted).Value;
846 for J in R'Range loop
848 and then (Restrictions.Set (J) = False
849 or else Restriction_Warnings (J)
851 (J in All_Parameter_Restrictions
852 and then Restrictions.Value (J) > V (J)))
854 Restricted_Profile_Result := False;
859 return Restricted_Profile_Result;
862 end Restricted_Profile;
864 ------------------------
865 -- Restriction_Active --
866 ------------------------
868 function Restriction_Active (R : All_Restrictions) return Boolean is
870 return Restrictions.Set (R) and then not Restriction_Warnings (R);
871 end Restriction_Active;
873 --------------------------------
874 -- Restriction_Check_Required --
875 --------------------------------
877 function Restriction_Check_Required (R : All_Restrictions) return Boolean is
879 return Restrictions.Set (R);
880 end Restriction_Check_Required;
882 ---------------------
883 -- Restriction_Msg --
884 ---------------------
886 procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is
887 Msg : String (1 .. 100);
890 procedure Add_Char (C : Character);
891 -- Append given character to Msg, bumping Len
893 procedure Add_Str (S : String);
894 -- Append given string to Msg, bumping Len appropriately
896 procedure Id_Case (S : String; Quotes : Boolean := True);
897 -- Given a string S, case it according to current identifier casing,
898 -- except for SPARK (an acronym) which is set all upper case, and store
899 -- in Error_Msg_String. Then append `~` to the message buffer to output
900 -- the string unchanged surrounded in quotes. The quotes are suppressed
901 -- if Quotes = False.
907 procedure Add_Char (C : Character) is
917 procedure Add_Str (S : String) is
919 Msg (Len + 1 .. Len + S'Length) := S;
920 Len := Len + S'Length;
927 procedure Id_Case (S : String; Quotes : Boolean := True) is
929 Name_Buffer (1 .. S'Last) := S;
930 Name_Len := S'Length;
935 Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
938 Error_Msg_Strlen := Name_Len;
939 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
948 -- Start of processing for Restriction_Msg
951 -- Set warning message if warning
953 if Restriction_Warnings (R) then
956 -- If real violation (not warning), then mark it as non-serious unless
957 -- it is a violation of No_Finalization in which case we leave it as a
958 -- serious message, since otherwise we get crashes during attempts to
959 -- expand stuff that is not properly formed due to assumptions made
960 -- about no finalization being present.
962 elsif R /= No_Finalization then
966 Error_Msg_Sloc := Restrictions_Loc (R);
968 -- Set main message, adding implicit if no source location
970 if Error_Msg_Sloc > No_Location
971 or else Error_Msg_Sloc = System_Location
973 Add_Str ("violation of restriction ");
975 Add_Str ("violation of implicit restriction ");
976 Error_Msg_Sloc := No_Location;
979 -- Case of parameterized restriction
981 if R in All_Parameter_Restrictions then
983 Id_Case (Restriction_Id'Image (R), Quotes => False);
985 Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R)));
987 -- Case of boolean restriction
990 Id_Case (Restriction_Id'Image (R));
993 -- Case of no secondary profile continuation message
995 if Restriction_Profile_Name (R) = No_Profile then
996 if Error_Msg_Sloc /= No_Location then
1001 Error_Msg_N (Msg (1 .. Len), N);
1003 -- Case of secondary profile continuation message present
1007 Error_Msg_N (Msg (1 .. Len), N);
1012 -- Set as warning if warning case
1014 if Restriction_Warnings (R) then
1020 Add_Str ("from profile ");
1021 Id_Case (Profile_Name'Image (Restriction_Profile_Name (R)));
1023 -- Add location if we have one
1025 if Error_Msg_Sloc /= No_Location then
1029 -- Output unconditional message and we are done
1032 Error_Msg_N (Msg (1 .. Len), N);
1034 end Restriction_Msg;
1040 function Same_Unit (U1, U2 : Node_Id) return Boolean is
1042 if Nkind (U1) = N_Identifier then
1043 return Nkind (U2) = N_Identifier and then Chars (U1) = Chars (U2);
1045 elsif Nkind (U2) = N_Identifier then
1048 elsif (Nkind (U1) = N_Selected_Component
1049 or else Nkind (U1) = N_Expanded_Name)
1051 (Nkind (U2) = N_Selected_Component
1052 or else Nkind (U2) = N_Expanded_Name)
1054 return Same_Unit (Prefix (U1), Prefix (U2))
1055 and then Same_Unit (Selector_Name (U1), Selector_Name (U2));
1061 --------------------------------------------
1062 -- Save_Config_Cunit_Boolean_Restrictions --
1063 --------------------------------------------
1065 procedure Save_Config_Cunit_Boolean_Restrictions is
1067 Config_Cunit_Boolean_Restrictions := Cunit_Boolean_Restrictions_Save;
1068 end Save_Config_Cunit_Boolean_Restrictions;
1070 ------------------------------
1071 -- Set_Hidden_Part_In_SPARK --
1072 ------------------------------
1074 procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr) is
1076 SPARK_Hides.Increment_Last;
1077 SPARK_Hides.Table (SPARK_Hides.Last).Start := Loc1;
1078 SPARK_Hides.Table (SPARK_Hides.Last).Stop := Loc2;
1079 end Set_Hidden_Part_In_SPARK;
1081 ------------------------------
1082 -- Set_Profile_Restrictions --
1083 ------------------------------
1085 procedure Set_Profile_Restrictions
1090 R : Restriction_Flags renames Profile_Info (P).Set;
1091 V : Restriction_Values renames Profile_Info (P).Value;
1094 for J in R'Range loop
1097 Already_Restricted : constant Boolean := Restriction_Active (J);
1100 -- Set the restriction
1102 if J in All_Boolean_Restrictions then
1103 Set_Restriction (J, N);
1105 Set_Restriction (J, N, V (J));
1108 -- Record that this came from a Profile[_Warnings] restriction
1110 Restriction_Profile_Name (J) := P;
1112 -- Set warning flag, except that we do not set the warning
1113 -- flag if the restriction was already active and this is
1114 -- the warning case. That avoids a warning overriding a real
1115 -- restriction, which should never happen.
1117 if not (Warn and Already_Restricted) then
1118 Restriction_Warnings (J) := Warn;
1123 end Set_Profile_Restrictions;
1125 ---------------------
1126 -- Set_Restriction --
1127 ---------------------
1129 -- Case of Boolean restriction
1131 procedure Set_Restriction
1132 (R : All_Boolean_Restrictions;
1136 Restrictions.Set (R) := True;
1138 if Restricted_Profile_Cached and Restricted_Profile_Result then
1141 Restricted_Profile_Cached := False;
1144 -- Set location, but preserve location of system restriction for nice
1145 -- error msg with run time name.
1147 if Restrictions_Loc (R) /= System_Location then
1148 Restrictions_Loc (R) := Sloc (N);
1151 -- Note restriction came from restriction pragma, not profile
1153 Restriction_Profile_Name (R) := No_Profile;
1155 -- Record the restriction if we are in the main unit, or in the extended
1156 -- main unit. The reason that we test separately for Main_Unit is that
1157 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1158 -- gnat.adc do not appear to be in the extended main source unit (they
1159 -- probably should do ???)
1161 if Current_Sem_Unit = Main_Unit
1162 or else In_Extended_Main_Source_Unit (N)
1164 if not Restriction_Warnings (R) then
1165 Main_Restrictions.Set (R) := True;
1168 end Set_Restriction;
1170 -- Case of parameter restriction
1172 procedure Set_Restriction
1173 (R : All_Parameter_Restrictions;
1178 if Restricted_Profile_Cached and Restricted_Profile_Result then
1181 Restricted_Profile_Cached := False;
1184 if Restrictions.Set (R) then
1185 if V < Restrictions.Value (R) then
1186 Restrictions.Value (R) := V;
1187 Restrictions_Loc (R) := Sloc (N);
1191 Restrictions.Set (R) := True;
1192 Restrictions.Value (R) := V;
1193 Restrictions_Loc (R) := Sloc (N);
1196 -- Record the restriction if we are in the main unit, or in the extended
1197 -- main unit. The reason that we test separately for Main_Unit is that
1198 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1199 -- gnat.adc do not appear to be the extended main source unit (they
1200 -- probably should do ???)
1202 if Current_Sem_Unit = Main_Unit
1203 or else In_Extended_Main_Source_Unit (N)
1205 if Main_Restrictions.Set (R) then
1206 if V < Main_Restrictions.Value (R) then
1207 Main_Restrictions.Value (R) := V;
1210 elsif not Restriction_Warnings (R) then
1211 Main_Restrictions.Set (R) := True;
1212 Main_Restrictions.Value (R) := V;
1216 -- Note restriction came from restriction pragma, not profile
1218 Restriction_Profile_Name (R) := No_Profile;
1219 end Set_Restriction;
1221 -----------------------------------
1222 -- Set_Restriction_No_Dependence --
1223 -----------------------------------
1225 procedure Set_Restriction_No_Dependence
1228 Profile : Profile_Name := No_Profile)
1231 -- Loop to check for duplicate entry
1233 for J in No_Dependences.First .. No_Dependences.Last loop
1235 -- Case of entry already in table
1237 if Same_Unit (Unit, No_Dependences.Table (J).Unit) then
1239 -- Error has precedence over warning
1242 No_Dependences.Table (J).Warn := False;
1249 -- Entry is not currently in table
1251 No_Dependences.Append ((Unit, Warn, Profile));
1252 end Set_Restriction_No_Dependence;
1254 ------------------------------------------------
1255 -- Set_Restriction_No_Specification_Of_Aspect --
1256 ------------------------------------------------
1258 procedure Set_Restriction_No_Specification_Of_Aspect
1262 A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (N));
1263 pragma Assert (A_Id /= No_Aspect);
1266 No_Specification_Of_Aspects (A_Id) := Sloc (N);
1268 if Warning = False then
1269 No_Specification_Of_Aspect_Warning (A_Id) := False;
1272 No_Specification_Of_Aspect_Set := True;
1273 end Set_Restriction_No_Specification_Of_Aspect;
1275 ----------------------------------
1276 -- Suppress_Restriction_Message --
1277 ----------------------------------
1279 function Suppress_Restriction_Message (N : Node_Id) return Boolean is
1281 -- We only output messages for the extended main source unit
1283 if In_Extended_Main_Source_Unit (N) then
1286 -- If loaded by rtsfind, then suppress message
1288 elsif Sloc (N) <= No_Location then
1291 -- Otherwise suppress message if internal file
1294 return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
1296 end Suppress_Restriction_Message;
1298 ---------------------
1299 -- Tasking_Allowed --
1300 ---------------------
1302 function Tasking_Allowed return Boolean is
1304 return not Restrictions.Set (No_Tasking)
1305 and then (not Restrictions.Set (Max_Tasks)
1306 or else Restrictions.Value (Max_Tasks) > 0);
1307 end Tasking_Allowed;