1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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
(N
: Node_Id
) is
173 if Is_Compiler_Unit
(Get_Source_Unit
(N
)) then
174 Error_Msg_N
("use of construct not allowed in compiler!!??", N
);
176 end Check_Compiler_Unit
;
178 ------------------------------------
179 -- Check_Elaboration_Code_Allowed --
180 ------------------------------------
182 procedure Check_Elaboration_Code_Allowed
(N
: Node_Id
) is
184 Check_Restriction
(No_Elaboration_Code
, N
);
185 end Check_Elaboration_Code_Allowed
;
187 --------------------------------
188 -- Check_No_Implicit_Aliasing --
189 --------------------------------
191 procedure Check_No_Implicit_Aliasing
(Obj
: Node_Id
) is
195 -- If restriction not active, nothing to check
197 if not Restriction_Active
(No_Implicit_Aliasing
) then
201 -- If we have an entity name, check entity
203 if Is_Entity_Name
(Obj
) then
206 -- Restriction applies to entities that are objects
208 if Is_Object
(E
) then
209 if Is_Aliased
(E
) then
212 elsif Present
(Renamed_Object
(E
)) then
213 Check_No_Implicit_Aliasing
(Renamed_Object
(E
));
217 -- If we don't have an object, then it's OK
223 -- For selected component, check selector
225 elsif Nkind
(Obj
) = N_Selected_Component
then
226 Check_No_Implicit_Aliasing
(Selector_Name
(Obj
));
229 -- Indexed component is OK if aliased components
231 elsif Nkind
(Obj
) = N_Indexed_Component
then
232 if Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
234 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
235 and then Has_Aliased_Components
236 (Designated_Type
(Etype
(Prefix
(Obj
)))))
241 -- For type conversion, check converted expression
243 elsif Nkind_In
(Obj
, N_Unchecked_Type_Conversion
, N_Type_Conversion
) then
244 Check_No_Implicit_Aliasing
(Expression
(Obj
));
247 -- Explicit dereference is always OK
249 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
253 -- If we fall through, then we have an aliased view that does not meet
254 -- the rules for being explicitly aliased, so issue restriction msg.
256 Check_Restriction
(No_Implicit_Aliasing
, Obj
);
257 end Check_No_Implicit_Aliasing
;
259 -----------------------------------------
260 -- Check_Implicit_Dynamic_Code_Allowed --
261 -----------------------------------------
263 procedure Check_Implicit_Dynamic_Code_Allowed
(N
: Node_Id
) is
265 Check_Restriction
(No_Implicit_Dynamic_Code
, N
);
266 end Check_Implicit_Dynamic_Code_Allowed
;
268 ----------------------------------
269 -- Check_No_Implicit_Heap_Alloc --
270 ----------------------------------
272 procedure Check_No_Implicit_Heap_Alloc
(N
: Node_Id
) is
274 Check_Restriction
(No_Implicit_Heap_Allocations
, N
);
275 end Check_No_Implicit_Heap_Alloc
;
277 -------------------------------------------
278 -- Check_Restriction_No_Use_Of_Attribute --
279 --------------------------------------------
281 procedure Check_Restriction_No_Use_Of_Attribute
(N
: Node_Id
) is
282 Id
: constant Name_Id
:= Chars
(N
);
283 A_Id
: constant Attribute_Id
:= Get_Attribute_Id
(Id
);
286 -- Ignore call if node N is not in the main source unit, since we only
287 -- give messages for the main unit. This avoids giving messages for
288 -- aspects that are specified in withed units.
290 if not In_Extended_Main_Source_Unit
(N
) then
294 -- If nothing set, nothing to check
296 if not No_Use_Of_Attribute_Set
then
300 Error_Msg_Sloc
:= No_Use_Of_Attribute
(A_Id
);
302 if Error_Msg_Sloc
/= No_Location
then
303 Error_Msg_Node_1
:= N
;
304 Error_Msg_Warn
:= No_Use_Of_Attribute_Warning
(A_Id
);
306 ("<violation of restriction `No_Use_Of_Attribute '='> &`#", N
);
308 end Check_Restriction_No_Use_Of_Attribute
;
310 ----------------------------------------
311 -- Check_Restriction_No_Use_Of_Pragma --
312 ----------------------------------------
314 procedure Check_Restriction_No_Use_Of_Pragma
(N
: Node_Id
) is
315 Id
: constant Node_Id
:= Pragma_Identifier
(N
);
316 P_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Chars
(Id
));
319 -- Ignore call if node N is not in the main source unit, since we only
320 -- give messages for the main unit. This avoids giving messages for
321 -- aspects that are specified in withed units.
323 if not In_Extended_Main_Source_Unit
(N
) then
327 -- If nothing set, nothing to check
329 if not No_Use_Of_Pragma_Set
then
333 Error_Msg_Sloc
:= No_Use_Of_Pragma
(P_Id
);
335 if Error_Msg_Sloc
/= No_Location
then
336 Error_Msg_Node_1
:= Id
;
337 Error_Msg_Warn
:= No_Use_Of_Pragma_Warning
(P_Id
);
339 ("<violation of restriction `No_Use_Of_Pragma '='> &`#", Id
);
341 end Check_Restriction_No_Use_Of_Pragma
;
343 -----------------------------------
344 -- Check_Obsolescent_2005_Entity --
345 -----------------------------------
347 procedure Check_Obsolescent_2005_Entity
(E
: Entity_Id
; N
: Node_Id
) is
348 function Chars_Is
(E
: Entity_Id
; S
: String) return Boolean;
349 -- Return True iff Chars (E) matches S (given in lower case)
355 function Chars_Is
(E
: Entity_Id
; S
: String) return Boolean is
356 Nam
: constant Name_Id
:= Chars
(E
);
358 if Length_Of_Name
(Nam
) /= S
'Length then
361 return Get_Name_String
(Nam
) = S
;
365 -- Start of processing for Check_Obsolescent_2005_Entity
368 if Restriction_Check_Required
(No_Obsolescent_Features
)
369 and then Ada_Version
>= Ada_2005
370 and then Chars_Is
(Scope
(E
), "handling")
371 and then Chars_Is
(Scope
(Scope
(E
)), "characters")
372 and then Chars_Is
(Scope
(Scope
(Scope
(E
))), "ada")
373 and then Scope
(Scope
(Scope
(Scope
(E
)))) = Standard_Standard
375 if Chars_Is
(E
, "is_character") or else
376 Chars_Is
(E
, "is_string") or else
377 Chars_Is
(E
, "to_character") or else
378 Chars_Is
(E
, "to_string") or else
379 Chars_Is
(E
, "to_wide_character") or else
380 Chars_Is
(E
, "to_wide_string")
382 Check_Restriction
(No_Obsolescent_Features
, N
);
385 end Check_Obsolescent_2005_Entity
;
387 ---------------------------
388 -- Check_Restricted_Unit --
389 ---------------------------
391 procedure Check_Restricted_Unit
(U
: Unit_Name_Type
; N
: Node_Id
) is
393 if Suppress_Restriction_Message
(N
) then
396 elsif Is_Spec_Name
(U
) then
398 Fnam
: constant File_Name_Type
:=
399 Get_File_Name
(U
, Subunit
=> False);
404 Get_Name_String
(Fnam
);
406 -- Nothing to do if name not at least 5 characters long ending
407 -- in .ads or .adb extension, which we strip.
410 or else (Name_Buffer
(Name_Len
- 3 .. Name_Len
) /= ".ads"
412 Name_Buffer
(Name_Len
- 3 .. Name_Len
) /= ".adb")
417 -- Strip extension and pad to eight characters
419 Name_Len
:= Name_Len
- 4;
420 Add_Str_To_Name_Buffer
((Name_Len
+ 1 .. 8 => ' '));
422 -- If predefined unit, check the list of restricted units
424 if Is_Predefined_File_Name
(Fnam
) then
425 for J
in Unit_Array
'Range loop
427 and then Name_Buffer
(1 .. 8) = Unit_Array
(J
).Filenm
429 Check_Restriction
(Unit_Array
(J
).Res_Id
, N
);
433 -- If not predefined unit, then one special check still
434 -- remains. GNAT.Current_Exception is not allowed if we have
435 -- restriction No_Exception_Propagation active.
438 if Name_Buffer
(1 .. 8) = "g-curexc" then
439 Check_Restriction
(No_Exception_Propagation
, N
);
444 end Check_Restricted_Unit
;
446 -----------------------
447 -- Check_Restriction --
448 -----------------------
450 procedure Check_Restriction
453 V
: Uint
:= Uint_Minus_1
)
455 Msg_Issued
: Boolean;
456 pragma Unreferenced
(Msg_Issued
);
458 Check_Restriction
(Msg_Issued
, R
, N
, V
);
459 end Check_Restriction
;
461 procedure Check_Restriction
462 (Msg_Issued
: out Boolean;
465 V
: Uint
:= Uint_Minus_1
)
468 -- V converted to integer form. If V is greater than Integer'Last,
469 -- it is reset to minus 1 (unknown value).
471 procedure Update_Restrictions
(Info
: in out Restrictions_Info
);
472 -- Update violation information in Info.Violated and Info.Count
474 -------------------------
475 -- Update_Restrictions --
476 -------------------------
478 procedure Update_Restrictions
(Info
: in out Restrictions_Info
) is
480 -- If not violated, set as violated now
482 if not Info
.Violated
(R
) then
483 Info
.Violated
(R
) := True;
485 if R
in All_Parameter_Restrictions
then
487 Info
.Unknown
(R
) := True;
490 Info
.Count
(R
) := VV
;
494 -- Otherwise if violated already and a parameter restriction,
495 -- update count by maximizing or summing depending on restriction.
497 elsif R
in All_Parameter_Restrictions
then
499 -- If new value is unknown, result is unknown
502 Info
.Unknown
(R
) := True;
504 -- If checked by maximization, do maximization
506 elsif R
in Checked_Max_Parameter_Restrictions
then
507 Info
.Count
(R
) := Integer'Max (Info
.Count
(R
), VV
);
509 -- If checked by adding, do add, checking for overflow
511 elsif R
in Checked_Add_Parameter_Restrictions
then
513 pragma Unsuppress
(Overflow_Check
);
515 Info
.Count
(R
) := Info
.Count
(R
) + VV
;
517 when Constraint_Error
=>
518 Info
.Count
(R
) := Integer'Last;
519 Info
.Unknown
(R
) := True;
522 -- Should not be able to come here, known counts should only
523 -- occur for restrictions that are Checked_max or Checked_Sum.
529 end Update_Restrictions
;
531 -- Start of processing for Check_Restriction
536 -- In CodePeer and SPARK mode, we do not want to check for any
537 -- restriction, or set additional restrictions other than those already
538 -- set in gnat1drv.adb so that we have consistency between each
541 -- Just checking, SPARK does not allow restrictions to be set ???
543 if CodePeer_Mode
or GNATprove_Mode
then
547 -- In SPARK mode, issue an error for any use of class-wide, even if the
548 -- No_Dispatch restriction is not set.
550 if R
= No_Dispatch
then
551 Check_SPARK_Restriction
("class-wide is not allowed", N
);
554 if UI_Is_In_Int_Range
(V
) then
555 VV
:= Integer (UI_To_Int
(V
));
560 -- Count can only be specified in the checked val parameter case
562 pragma Assert
(VV
< 0 or else R
in Checked_Val_Parameter_Restrictions
);
564 -- Nothing to do if value of zero specified for parameter restriction
570 -- Update current restrictions
572 Update_Restrictions
(Restrictions
);
574 -- If in main extended unit, update main restrictions as well. Note
575 -- that as usual we check for Main_Unit explicitly to deal with the
576 -- case of configuration pragma files.
578 if Current_Sem_Unit
= Main_Unit
579 or else In_Extended_Main_Source_Unit
(N
)
581 Update_Restrictions
(Main_Restrictions
);
584 -- Nothing to do if restriction message suppressed
586 if Suppress_Restriction_Message
(N
) then
589 -- If restriction not set, nothing to do
591 elsif not Restrictions
.Set
(R
) then
594 -- Don't complain about No_Obsolescent_Features in an instance, since we
595 -- will complain on the template, which is much better. Are there other
596 -- cases like this ??? Do we need a more general mechanism ???
598 elsif R
= No_Obsolescent_Features
599 and then Instantiation_Location
(Sloc
(N
)) /= No_Location
603 -- Here if restriction set, check for violation (this is a Boolean
604 -- restriction, or a parameter restriction with a value of zero and an
605 -- unknown count, or a parameter restriction with a known value that
606 -- exceeds the restriction count).
608 elsif R
in All_Boolean_Restrictions
609 or else (Restrictions
.Unknown
(R
)
610 and then Restrictions
.Value
(R
) = 0)
611 or else Restrictions
.Count
(R
) > Restrictions
.Value
(R
)
614 Restriction_Msg
(R
, N
);
616 end Check_Restriction
;
618 -------------------------------------
619 -- Check_Restriction_No_Dependence --
620 -------------------------------------
622 procedure Check_Restriction_No_Dependence
(U
: Node_Id
; Err
: Node_Id
) is
626 -- Ignore call if node U is not in the main source unit. This avoids
627 -- cascaded errors, e.g. when Ada.Containers units with other units.
628 -- However, allow Standard_Location here, since this catches some cases
629 -- of constructs that get converted to run-time calls.
631 if not In_Extended_Main_Source_Unit
(U
)
632 and then Sloc
(U
) /= Standard_Location
637 -- Loop through entries in No_Dependence table to check each one in turn
639 for J
in No_Dependences
.First
.. No_Dependences
.Last
loop
640 DU
:= No_Dependences
.Table
(J
).Unit
;
642 if Same_Unit
(U
, DU
) then
643 Error_Msg_Sloc
:= Sloc
(DU
);
644 Error_Msg_Node_1
:= DU
;
646 if No_Dependences
.Table
(J
).Warn
then
648 ("??violation of restriction `No_Dependence '='> &`#",
652 ("|violation of restriction `No_Dependence '='> &`#",
659 end Check_Restriction_No_Dependence
;
661 --------------------------------------------------
662 -- Check_Restriction_No_Specification_Of_Aspect --
663 --------------------------------------------------
665 procedure Check_Restriction_No_Specification_Of_Aspect
(N
: Node_Id
) is
670 -- Ignore call if no instances of this restriction set
672 if not No_Specification_Of_Aspect_Set
then
676 -- Ignore call if node N is not in the main source unit, since we only
677 -- give messages for the main unit. This avoids giving messages for
678 -- aspects that are specified in withed units.
680 if not In_Extended_Main_Source_Unit
(N
) then
684 Id
:= Identifier
(N
);
685 A_Id
:= Get_Aspect_Id
(Chars
(Id
));
686 pragma Assert
(A_Id
/= No_Aspect
);
688 Error_Msg_Sloc
:= No_Specification_Of_Aspects
(A_Id
);
690 if Error_Msg_Sloc
/= No_Location
then
691 Error_Msg_Node_1
:= Id
;
692 Error_Msg_Warn
:= No_Specification_Of_Aspect_Warning
(A_Id
);
694 ("<violation of restriction `No_Specification_Of_Aspect '='> &`#",
697 end Check_Restriction_No_Specification_Of_Aspect
;
699 --------------------------------------
700 -- Check_Wide_Character_Restriction --
701 --------------------------------------
703 procedure Check_Wide_Character_Restriction
(E
: Entity_Id
; N
: Node_Id
) is
705 if Restriction_Check_Required
(No_Wide_Characters
)
706 and then Comes_From_Source
(N
)
709 T
: constant Entity_Id
:= Root_Type
(E
);
711 if T
= Standard_Wide_Character
or else
712 T
= Standard_Wide_String
or else
713 T
= Standard_Wide_Wide_Character
or else
714 T
= Standard_Wide_Wide_String
716 Check_Restriction
(No_Wide_Characters
, N
);
720 end Check_Wide_Character_Restriction
;
722 ----------------------------------------
723 -- Cunit_Boolean_Restrictions_Restore --
724 ----------------------------------------
726 procedure Cunit_Boolean_Restrictions_Restore
727 (R
: Save_Cunit_Boolean_Restrictions
)
730 for J
in Cunit_Boolean_Restrictions
loop
731 Restrictions
.Set
(J
) := R
(J
);
734 -- If No_Elaboration_Code set in configuration restrictions, and we
735 -- in the main extended source, then set it here now. This is part of
736 -- the special processing for No_Elaboration_Code.
738 if In_Extended_Main_Source_Unit
(Cunit_Entity
(Current_Sem_Unit
))
739 and then Config_Cunit_Boolean_Restrictions
(No_Elaboration_Code
)
741 Restrictions
.Set
(No_Elaboration_Code
) := True;
743 end Cunit_Boolean_Restrictions_Restore
;
745 -------------------------------------
746 -- Cunit_Boolean_Restrictions_Save --
747 -------------------------------------
749 function Cunit_Boolean_Restrictions_Save
750 return Save_Cunit_Boolean_Restrictions
752 R
: Save_Cunit_Boolean_Restrictions
;
755 for J
in Cunit_Boolean_Restrictions
loop
756 R
(J
) := Restrictions
.Set
(J
);
760 end Cunit_Boolean_Restrictions_Save
;
762 ------------------------
763 -- Get_Restriction_Id --
764 ------------------------
766 function Get_Restriction_Id
767 (N
: Name_Id
) return Restriction_Id
771 Set_Casing
(All_Upper_Case
);
773 for J
in All_Restrictions
loop
775 S
: constant String := Restriction_Id
'Image (J
);
777 if S
= Name_Buffer
(1 .. Name_Len
) then
783 return Not_A_Restriction_Id
;
784 end Get_Restriction_Id
;
786 --------------------------------
787 -- Is_In_Hidden_Part_In_SPARK --
788 --------------------------------
790 function Is_In_Hidden_Part_In_SPARK
(Loc
: Source_Ptr
) return Boolean is
792 -- Loop through table of hidden ranges
794 for J
in SPARK_Hides
.First
.. SPARK_Hides
.Last
loop
795 if SPARK_Hides
.Table
(J
).Start
<= Loc
796 and then Loc
< SPARK_Hides
.Table
(J
).Stop
803 end Is_In_Hidden_Part_In_SPARK
;
805 -------------------------------
806 -- No_Exception_Handlers_Set --
807 -------------------------------
809 function No_Exception_Handlers_Set
return Boolean is
811 return (No_Run_Time_Mode
or else Configurable_Run_Time_Mode
)
812 and then (Restrictions
.Set
(No_Exception_Handlers
)
814 Restrictions
.Set
(No_Exception_Propagation
));
815 end No_Exception_Handlers_Set
;
817 -------------------------------------
818 -- No_Exception_Propagation_Active --
819 -------------------------------------
821 function No_Exception_Propagation_Active
return Boolean is
823 return (No_Run_Time_Mode
824 or else Configurable_Run_Time_Mode
825 or else Debug_Flag_Dot_G
)
826 and then Restriction_Active
(No_Exception_Propagation
);
827 end No_Exception_Propagation_Active
;
829 --------------------------------
830 -- OK_No_Dependence_Unit_Name --
831 --------------------------------
833 function OK_No_Dependence_Unit_Name
(N
: Node_Id
) return Boolean is
835 if Nkind
(N
) = N_Selected_Component
then
837 OK_No_Dependence_Unit_Name
(Prefix
(N
))
839 OK_No_Dependence_Unit_Name
(Selector_Name
(N
));
841 elsif Nkind
(N
) = N_Identifier
then
845 Error_Msg_N
("wrong form for unit name for No_Dependence", N
);
848 end OK_No_Dependence_Unit_Name
;
850 ----------------------------------
851 -- Process_Restriction_Synonyms --
852 ----------------------------------
854 -- Note: body of this function must be coordinated with list of
855 -- renaming declarations in System.Rident.
857 function Process_Restriction_Synonyms
(N
: Node_Id
) return Name_Id
859 Old_Name
: constant Name_Id
:= Chars
(N
);
864 when Name_Boolean_Entry_Barriers
=>
865 New_Name
:= Name_Simple_Barriers
;
867 when Name_Max_Entry_Queue_Depth
=>
868 New_Name
:= Name_Max_Entry_Queue_Length
;
870 when Name_No_Dynamic_Interrupts
=>
871 New_Name
:= Name_No_Dynamic_Attachment
;
873 when Name_No_Requeue
=>
874 New_Name
:= Name_No_Requeue_Statements
;
876 when Name_No_Task_Attributes
=>
877 New_Name
:= Name_No_Task_Attributes_Package
;
879 -- SPARK is special in that we unconditionally warn
882 Error_Msg_Name_1
:= Name_SPARK
;
883 Error_Msg_N
("restriction identifier % is obsolescent??", N
);
884 Error_Msg_Name_1
:= Name_SPARK_05
;
885 Error_Msg_N
("|use restriction identifier % instead??", N
);
886 return Name_SPARK_05
;
892 -- Output warning if we are warning on obsolescent features for all
893 -- cases other than SPARK.
895 if Warn_On_Obsolescent_Feature
then
896 Error_Msg_Name_1
:= Old_Name
;
897 Error_Msg_N
("restriction identifier % is obsolescent?j?", N
);
898 Error_Msg_Name_1
:= New_Name
;
899 Error_Msg_N
("|use restriction identifier % instead?j?", N
);
903 end Process_Restriction_Synonyms
;
905 --------------------------------------
906 -- Reset_Cunit_Boolean_Restrictions --
907 --------------------------------------
909 procedure Reset_Cunit_Boolean_Restrictions
is
911 for J
in Cunit_Boolean_Restrictions
loop
912 Restrictions
.Set
(J
) := False;
914 end Reset_Cunit_Boolean_Restrictions
;
916 -----------------------------------------------
917 -- Restore_Config_Cunit_Boolean_Restrictions --
918 -----------------------------------------------
920 procedure Restore_Config_Cunit_Boolean_Restrictions
is
922 Cunit_Boolean_Restrictions_Restore
(Config_Cunit_Boolean_Restrictions
);
923 end Restore_Config_Cunit_Boolean_Restrictions
;
925 ------------------------
926 -- Restricted_Profile --
927 ------------------------
929 function Restricted_Profile
return Boolean is
931 if Restricted_Profile_Cached
then
932 return Restricted_Profile_Result
;
935 Restricted_Profile_Result
:= True;
936 Restricted_Profile_Cached
:= True;
939 R
: Restriction_Flags
renames Profile_Info
(Restricted
).Set
;
940 V
: Restriction_Values
renames Profile_Info
(Restricted
).Value
;
942 for J
in R
'Range loop
944 and then (Restrictions
.Set
(J
) = False
945 or else Restriction_Warnings
(J
)
947 (J
in All_Parameter_Restrictions
948 and then Restrictions
.Value
(J
) > V
(J
)))
950 Restricted_Profile_Result
:= False;
955 return Restricted_Profile_Result
;
958 end Restricted_Profile
;
960 ------------------------
961 -- Restriction_Active --
962 ------------------------
964 function Restriction_Active
(R
: All_Restrictions
) return Boolean is
966 return Restrictions
.Set
(R
) and then not Restriction_Warnings
(R
);
967 end Restriction_Active
;
969 --------------------------------
970 -- Restriction_Check_Required --
971 --------------------------------
973 function Restriction_Check_Required
(R
: All_Restrictions
) return Boolean is
975 return Restrictions
.Set
(R
);
976 end Restriction_Check_Required
;
978 ---------------------
979 -- Restriction_Msg --
980 ---------------------
982 procedure Restriction_Msg
(R
: Restriction_Id
; N
: Node_Id
) is
983 Msg
: String (1 .. 100);
986 procedure Add_Char
(C
: Character);
987 -- Append given character to Msg, bumping Len
989 procedure Add_Str
(S
: String);
990 -- Append given string to Msg, bumping Len appropriately
992 procedure Id_Case
(S
: String; Quotes
: Boolean := True);
993 -- Given a string S, case it according to current identifier casing,
994 -- except for SPARK_05 (an acronym) which is set all upper case, and
995 -- store in Error_Msg_String. Then append `~` to the message buffer
996 -- to output the string unchanged surrounded in quotes. The quotes
997 -- are suppressed if Quotes = False.
1003 procedure Add_Char
(C
: Character) is
1013 procedure Add_Str
(S
: String) is
1015 Msg
(Len
+ 1 .. Len
+ S
'Length) := S
;
1016 Len
:= Len
+ S
'Length;
1023 procedure Id_Case
(S
: String; Quotes
: Boolean := True) is
1025 Name_Buffer
(1 .. S
'Last) := S
;
1026 Name_Len
:= S
'Length;
1028 if R
= SPARK_05
then
1031 Set_Casing
(Identifier_Casing
(Get_Source_File_Index
(Sloc
(N
))));
1034 Error_Msg_Strlen
:= Name_Len
;
1035 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
1044 -- Start of processing for Restriction_Msg
1047 -- Set warning message if warning
1049 if Restriction_Warnings
(R
) then
1052 -- If real violation (not warning), then mark it as non-serious unless
1053 -- it is a violation of No_Finalization in which case we leave it as a
1054 -- serious message, since otherwise we get crashes during attempts to
1055 -- expand stuff that is not properly formed due to assumptions made
1056 -- about no finalization being present.
1058 elsif R
/= No_Finalization
then
1062 Error_Msg_Sloc
:= Restrictions_Loc
(R
);
1064 -- Set main message, adding implicit if no source location
1066 if Error_Msg_Sloc
> No_Location
1067 or else Error_Msg_Sloc
= System_Location
1069 Add_Str
("violation of restriction ");
1071 Add_Str
("violation of implicit restriction ");
1072 Error_Msg_Sloc
:= No_Location
;
1075 -- Case of parameterized restriction
1077 if R
in All_Parameter_Restrictions
then
1079 Id_Case
(Restriction_Id
'Image (R
), Quotes
=> False);
1081 Error_Msg_Uint_1
:= UI_From_Int
(Int
(Restrictions
.Value
(R
)));
1083 -- Case of boolean restriction
1086 Id_Case
(Restriction_Id
'Image (R
));
1089 -- Case of no secondary profile continuation message
1091 if Restriction_Profile_Name
(R
) = No_Profile
then
1092 if Error_Msg_Sloc
/= No_Location
then
1097 Error_Msg_N
(Msg
(1 .. Len
), N
);
1099 -- Case of secondary profile continuation message present
1103 Error_Msg_N
(Msg
(1 .. Len
), N
);
1108 -- Set as warning if warning case
1110 if Restriction_Warnings
(R
) then
1116 Add_Str
("from profile ");
1117 Id_Case
(Profile_Name
'Image (Restriction_Profile_Name
(R
)));
1119 -- Add location if we have one
1121 if Error_Msg_Sloc
/= No_Location
then
1125 -- Output unconditional message and we are done
1128 Error_Msg_N
(Msg
(1 .. Len
), N
);
1130 end Restriction_Msg
;
1136 function Same_Unit
(U1
, U2
: Node_Id
) return Boolean is
1138 if Nkind
(U1
) = N_Identifier
and then Nkind
(U2
) = N_Identifier
then
1139 return Chars
(U1
) = Chars
(U2
);
1141 elsif Nkind_In
(U1
, N_Selected_Component
, N_Expanded_Name
)
1143 Nkind_In
(U2
, N_Selected_Component
, N_Expanded_Name
)
1145 return Same_Unit
(Prefix
(U1
), Prefix
(U2
))
1147 Same_Unit
(Selector_Name
(U1
), Selector_Name
(U2
));
1153 --------------------------------------------
1154 -- Save_Config_Cunit_Boolean_Restrictions --
1155 --------------------------------------------
1157 procedure Save_Config_Cunit_Boolean_Restrictions
is
1159 Config_Cunit_Boolean_Restrictions
:= Cunit_Boolean_Restrictions_Save
;
1160 end Save_Config_Cunit_Boolean_Restrictions
;
1162 ------------------------------
1163 -- Set_Hidden_Part_In_SPARK --
1164 ------------------------------
1166 procedure Set_Hidden_Part_In_SPARK
(Loc1
, Loc2
: Source_Ptr
) is
1168 SPARK_Hides
.Increment_Last
;
1169 SPARK_Hides
.Table
(SPARK_Hides
.Last
).Start
:= Loc1
;
1170 SPARK_Hides
.Table
(SPARK_Hides
.Last
).Stop
:= Loc2
;
1171 end Set_Hidden_Part_In_SPARK
;
1173 ------------------------------
1174 -- Set_Profile_Restrictions --
1175 ------------------------------
1177 procedure Set_Profile_Restrictions
1182 R
: Restriction_Flags
renames Profile_Info
(P
).Set
;
1183 V
: Restriction_Values
renames Profile_Info
(P
).Value
;
1186 for J
in R
'Range loop
1189 Already_Restricted
: constant Boolean := Restriction_Active
(J
);
1192 -- Set the restriction
1194 if J
in All_Boolean_Restrictions
then
1195 Set_Restriction
(J
, N
);
1197 Set_Restriction
(J
, N
, V
(J
));
1200 -- Record that this came from a Profile[_Warnings] restriction
1202 Restriction_Profile_Name
(J
) := P
;
1204 -- Set warning flag, except that we do not set the warning
1205 -- flag if the restriction was already active and this is
1206 -- the warning case. That avoids a warning overriding a real
1207 -- restriction, which should never happen.
1209 if not (Warn
and Already_Restricted
) then
1210 Restriction_Warnings
(J
) := Warn
;
1215 end Set_Profile_Restrictions
;
1217 ---------------------
1218 -- Set_Restriction --
1219 ---------------------
1221 -- Case of Boolean restriction
1223 procedure Set_Restriction
1224 (R
: All_Boolean_Restrictions
;
1228 Restrictions
.Set
(R
) := True;
1230 if Restricted_Profile_Cached
and Restricted_Profile_Result
then
1233 Restricted_Profile_Cached
:= False;
1236 -- Set location, but preserve location of system restriction for nice
1237 -- error msg with run time name.
1239 if Restrictions_Loc
(R
) /= System_Location
then
1240 Restrictions_Loc
(R
) := Sloc
(N
);
1243 -- Note restriction came from restriction pragma, not profile
1245 Restriction_Profile_Name
(R
) := No_Profile
;
1247 -- Record the restriction if we are in the main unit, or in the extended
1248 -- main unit. The reason that we test separately for Main_Unit is that
1249 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1250 -- gnat.adc do not appear to be in the extended main source unit (they
1251 -- probably should do ???)
1253 if Current_Sem_Unit
= Main_Unit
1254 or else In_Extended_Main_Source_Unit
(N
)
1256 if not Restriction_Warnings
(R
) then
1257 Main_Restrictions
.Set
(R
) := True;
1260 end Set_Restriction
;
1262 -- Case of parameter restriction
1264 procedure Set_Restriction
1265 (R
: All_Parameter_Restrictions
;
1270 if Restricted_Profile_Cached
and Restricted_Profile_Result
then
1273 Restricted_Profile_Cached
:= False;
1276 if Restrictions
.Set
(R
) then
1277 if V
< Restrictions
.Value
(R
) then
1278 Restrictions
.Value
(R
) := V
;
1279 Restrictions_Loc
(R
) := Sloc
(N
);
1283 Restrictions
.Set
(R
) := True;
1284 Restrictions
.Value
(R
) := V
;
1285 Restrictions_Loc
(R
) := Sloc
(N
);
1288 -- Record the restriction if we are in the main unit, or in the extended
1289 -- main unit. The reason that we test separately for Main_Unit is that
1290 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1291 -- gnat.adc do not appear to be the extended main source unit (they
1292 -- probably should do ???)
1294 if Current_Sem_Unit
= Main_Unit
1295 or else In_Extended_Main_Source_Unit
(N
)
1297 if Main_Restrictions
.Set
(R
) then
1298 if V
< Main_Restrictions
.Value
(R
) then
1299 Main_Restrictions
.Value
(R
) := V
;
1302 elsif not Restriction_Warnings
(R
) then
1303 Main_Restrictions
.Set
(R
) := True;
1304 Main_Restrictions
.Value
(R
) := V
;
1308 -- Note restriction came from restriction pragma, not profile
1310 Restriction_Profile_Name
(R
) := No_Profile
;
1311 end Set_Restriction
;
1313 -----------------------------------
1314 -- Set_Restriction_No_Dependence --
1315 -----------------------------------
1317 procedure Set_Restriction_No_Dependence
1320 Profile
: Profile_Name
:= No_Profile
)
1323 -- Loop to check for duplicate entry
1325 for J
in No_Dependences
.First
.. No_Dependences
.Last
loop
1327 -- Case of entry already in table
1329 if Same_Unit
(Unit
, No_Dependences
.Table
(J
).Unit
) then
1331 -- Error has precedence over warning
1334 No_Dependences
.Table
(J
).Warn
:= False;
1341 -- Entry is not currently in table
1343 No_Dependences
.Append
((Unit
, Warn
, Profile
));
1344 end Set_Restriction_No_Dependence
;
1346 ------------------------------------------------
1347 -- Set_Restriction_No_Specification_Of_Aspect --
1348 ------------------------------------------------
1350 procedure Set_Restriction_No_Specification_Of_Aspect
1354 A_Id
: constant Aspect_Id_Exclude_No_Aspect
:= Get_Aspect_Id
(Chars
(N
));
1357 No_Specification_Of_Aspects
(A_Id
) := Sloc
(N
);
1359 if Warning
= False then
1360 No_Specification_Of_Aspect_Warning
(A_Id
) := False;
1363 No_Specification_Of_Aspect_Set
:= True;
1364 end Set_Restriction_No_Specification_Of_Aspect
;
1366 -----------------------------------------
1367 -- Set_Restriction_No_Use_Of_Attribute --
1368 -----------------------------------------
1370 procedure Set_Restriction_No_Use_Of_Attribute
1374 A_Id
: constant Attribute_Id
:= Get_Attribute_Id
(Chars
(N
));
1377 No_Use_Of_Attribute_Set
:= True;
1378 No_Use_Of_Attribute
(A_Id
) := Sloc
(N
);
1380 if Warning
= False then
1381 No_Use_Of_Attribute_Warning
(A_Id
) := False;
1383 end Set_Restriction_No_Use_Of_Attribute
;
1385 --------------------------------------
1386 -- Set_Restriction_No_Use_Of_Pragma --
1387 --------------------------------------
1389 procedure Set_Restriction_No_Use_Of_Pragma
1393 A_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Chars
(N
));
1396 No_Use_Of_Pragma_Set
:= True;
1397 No_Use_Of_Pragma
(A_Id
) := Sloc
(N
);
1399 if Warning
= False then
1400 No_Use_Of_Pragma_Warning
(A_Id
) := False;
1402 end Set_Restriction_No_Use_Of_Pragma
;
1404 -----------------------------
1405 -- Check_SPARK_Restriction --
1406 -----------------------------
1408 procedure Check_SPARK_Restriction
1411 Force
: Boolean := False)
1413 Msg_Issued
: Boolean;
1414 Save_Error_Msg_Sloc
: Source_Ptr
;
1415 Onode
: constant Node_Id
:= Original_Node
(N
);
1418 -- Output message if Force set
1422 -- Or if this node comes from source
1424 or else Comes_From_Source
(N
)
1426 -- Or if this is a range node which rewrites a range attribute and
1427 -- the range attribute comes from source.
1429 or else (Nkind
(N
) = N_Range
1430 and then Nkind
(Onode
) = N_Attribute_Reference
1431 and then Attribute_Name
(Onode
) = Name_Range
1432 and then Comes_From_Source
(Onode
))
1434 -- Or this is an expression that does not come from source, which is
1435 -- a rewriting of an expression that does come from source.
1437 or else (Nkind
(N
) in N_Subexpr
and then Comes_From_Source
(Onode
))
1439 if Restriction_Check_Required
(SPARK_05
)
1440 and then Is_In_Hidden_Part_In_SPARK
(Sloc
(N
))
1445 -- Since the call to Restriction_Msg from Check_Restriction may set
1446 -- Error_Msg_Sloc to the location of the pragma restriction, save and
1447 -- restore the previous value of the global variable around the call.
1449 Save_Error_Msg_Sloc
:= Error_Msg_Sloc
;
1450 Check_Restriction
(Msg_Issued
, SPARK_05
, First_Node
(N
));
1451 Error_Msg_Sloc
:= Save_Error_Msg_Sloc
;
1454 Error_Msg_F
("\\| " & Msg
, N
);
1457 end Check_SPARK_Restriction
;
1459 procedure Check_SPARK_Restriction
(Msg1
, Msg2
: String; N
: Node_Id
) is
1460 Msg_Issued
: Boolean;
1461 Save_Error_Msg_Sloc
: Source_Ptr
;
1464 pragma Assert
(Msg2
'Length /= 0 and then Msg2
(Msg2
'First) = '\');
1466 if Comes_From_Source
(Original_Node
(N
)) then
1467 if Restriction_Check_Required
(SPARK_05
)
1468 and then Is_In_Hidden_Part_In_SPARK
(Sloc
(N
))
1473 -- Since the call to Restriction_Msg from Check_Restriction may set
1474 -- Error_Msg_Sloc to the location of the pragma restriction, save and
1475 -- restore the previous value of the global variable around the call.
1477 Save_Error_Msg_Sloc
:= Error_Msg_Sloc
;
1478 Check_Restriction
(Msg_Issued
, SPARK_05
, First_Node
(N
));
1479 Error_Msg_Sloc
:= Save_Error_Msg_Sloc
;
1482 Error_Msg_F
("\\| " & Msg1
, N
);
1483 Error_Msg_F
(Msg2
, N
);
1486 end Check_SPARK_Restriction
;
1488 ----------------------------------
1489 -- Suppress_Restriction_Message --
1490 ----------------------------------
1492 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean is
1494 -- We only output messages for the extended main source unit
1496 if In_Extended_Main_Source_Unit
(N
) then
1499 -- If loaded by rtsfind, then suppress message
1501 elsif Sloc
(N
) <= No_Location
then
1504 -- Otherwise suppress message if internal file
1507 return Is_Internal_File_Name
(Unit_File_Name
(Get_Source_Unit
(N
)));
1509 end Suppress_Restriction_Message
;
1511 ---------------------
1512 -- Tasking_Allowed --
1513 ---------------------
1515 function Tasking_Allowed
return Boolean is
1517 return not Restrictions
.Set
(No_Tasking
)
1518 and then (not Restrictions
.Set
(Max_Tasks
)
1519 or else Restrictions
.Value
(Max_Tasks
) > 0);
1520 end Tasking_Allowed
;