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 if CodePeer_Mode
or SPARK_Mode
then
545 -- In SPARK mode, issue an error for any use of class-wide, even if the
546 -- No_Dispatch restriction is not set.
548 if R
= No_Dispatch
then
549 Check_SPARK_Restriction
("class-wide is not allowed", N
);
552 if UI_Is_In_Int_Range
(V
) then
553 VV
:= Integer (UI_To_Int
(V
));
558 -- Count can only be specified in the checked val parameter case
560 pragma Assert
(VV
< 0 or else R
in Checked_Val_Parameter_Restrictions
);
562 -- Nothing to do if value of zero specified for parameter restriction
568 -- Update current restrictions
570 Update_Restrictions
(Restrictions
);
572 -- If in main extended unit, update main restrictions as well. Note
573 -- that as usual we check for Main_Unit explicitly to deal with the
574 -- case of configuration pragma files.
576 if Current_Sem_Unit
= Main_Unit
577 or else In_Extended_Main_Source_Unit
(N
)
579 Update_Restrictions
(Main_Restrictions
);
582 -- Nothing to do if restriction message suppressed
584 if Suppress_Restriction_Message
(N
) then
587 -- If restriction not set, nothing to do
589 elsif not Restrictions
.Set
(R
) then
592 -- Don't complain about No_Obsolescent_Features in an instance, since we
593 -- will complain on the template, which is much better. Are there other
594 -- cases like this ??? Do we need a more general mechanism ???
596 elsif R
= No_Obsolescent_Features
597 and then Instantiation_Location
(Sloc
(N
)) /= No_Location
601 -- Here if restriction set, check for violation (this is a Boolean
602 -- restriction, or a parameter restriction with a value of zero and an
603 -- unknown count, or a parameter restriction with a known value that
604 -- exceeds the restriction count).
606 elsif R
in All_Boolean_Restrictions
607 or else (Restrictions
.Unknown
(R
)
608 and then Restrictions
.Value
(R
) = 0)
609 or else Restrictions
.Count
(R
) > Restrictions
.Value
(R
)
612 Restriction_Msg
(R
, N
);
614 end Check_Restriction
;
616 -------------------------------------
617 -- Check_Restriction_No_Dependence --
618 -------------------------------------
620 procedure Check_Restriction_No_Dependence
(U
: Node_Id
; Err
: Node_Id
) is
624 -- Ignore call if node U is not in the main source unit. This avoids
625 -- cascaded errors, e.g. when Ada.Containers units with other units.
627 if not In_Extended_Main_Source_Unit
(U
) then
631 -- Loop through entries in No_Dependence table to check each one in turn
633 for J
in No_Dependences
.First
.. No_Dependences
.Last
loop
634 DU
:= No_Dependences
.Table
(J
).Unit
;
636 if Same_Unit
(U
, DU
) then
637 Error_Msg_Sloc
:= Sloc
(DU
);
638 Error_Msg_Node_1
:= DU
;
640 if No_Dependences
.Table
(J
).Warn
then
642 ("??violation of restriction `No_Dependence '='> &`#",
646 ("|violation of restriction `No_Dependence '='> &`#",
653 end Check_Restriction_No_Dependence
;
655 --------------------------------------------------
656 -- Check_Restriction_No_Specification_Of_Aspect --
657 --------------------------------------------------
659 procedure Check_Restriction_No_Specification_Of_Aspect
(N
: Node_Id
) is
664 -- Ignore call if no instances of this restriction set
666 if not No_Specification_Of_Aspect_Set
then
670 -- Ignore call if node N is not in the main source unit, since we only
671 -- give messages for the main unit. This avoids giving messages for
672 -- aspects that are specified in withed units.
674 if not In_Extended_Main_Source_Unit
(N
) then
678 Id
:= Identifier
(N
);
679 A_Id
:= Get_Aspect_Id
(Chars
(Id
));
680 pragma Assert
(A_Id
/= No_Aspect
);
682 Error_Msg_Sloc
:= No_Specification_Of_Aspects
(A_Id
);
684 if Error_Msg_Sloc
/= No_Location
then
685 Error_Msg_Node_1
:= Id
;
686 Error_Msg_Warn
:= No_Specification_Of_Aspect_Warning
(A_Id
);
688 ("<violation of restriction `No_Specification_Of_Aspect '='> &`#",
691 end Check_Restriction_No_Specification_Of_Aspect
;
693 --------------------------------------
694 -- Check_Wide_Character_Restriction --
695 --------------------------------------
697 procedure Check_Wide_Character_Restriction
(E
: Entity_Id
; N
: Node_Id
) is
699 if Restriction_Check_Required
(No_Wide_Characters
)
700 and then Comes_From_Source
(N
)
703 T
: constant Entity_Id
:= Root_Type
(E
);
705 if T
= Standard_Wide_Character
or else
706 T
= Standard_Wide_String
or else
707 T
= Standard_Wide_Wide_Character
or else
708 T
= Standard_Wide_Wide_String
710 Check_Restriction
(No_Wide_Characters
, N
);
714 end Check_Wide_Character_Restriction
;
716 ----------------------------------------
717 -- Cunit_Boolean_Restrictions_Restore --
718 ----------------------------------------
720 procedure Cunit_Boolean_Restrictions_Restore
721 (R
: Save_Cunit_Boolean_Restrictions
)
724 for J
in Cunit_Boolean_Restrictions
loop
725 Restrictions
.Set
(J
) := R
(J
);
728 -- If No_Elaboration_Code set in configuration restrictions, and we
729 -- in the main extended source, then set it here now. This is part of
730 -- the special processing for No_Elaboration_Code.
732 if In_Extended_Main_Source_Unit
(Cunit_Entity
(Current_Sem_Unit
))
733 and then Config_Cunit_Boolean_Restrictions
(No_Elaboration_Code
)
735 Restrictions
.Set
(No_Elaboration_Code
) := True;
737 end Cunit_Boolean_Restrictions_Restore
;
739 -------------------------------------
740 -- Cunit_Boolean_Restrictions_Save --
741 -------------------------------------
743 function Cunit_Boolean_Restrictions_Save
744 return Save_Cunit_Boolean_Restrictions
746 R
: Save_Cunit_Boolean_Restrictions
;
749 for J
in Cunit_Boolean_Restrictions
loop
750 R
(J
) := Restrictions
.Set
(J
);
754 end Cunit_Boolean_Restrictions_Save
;
756 ------------------------
757 -- Get_Restriction_Id --
758 ------------------------
760 function Get_Restriction_Id
761 (N
: Name_Id
) return Restriction_Id
765 Set_Casing
(All_Upper_Case
);
767 for J
in All_Restrictions
loop
769 S
: constant String := Restriction_Id
'Image (J
);
771 if S
= Name_Buffer
(1 .. Name_Len
) then
777 return Not_A_Restriction_Id
;
778 end Get_Restriction_Id
;
780 --------------------------------
781 -- Is_In_Hidden_Part_In_SPARK --
782 --------------------------------
784 function Is_In_Hidden_Part_In_SPARK
(Loc
: Source_Ptr
) return Boolean is
786 -- Loop through table of hidden ranges
788 for J
in SPARK_Hides
.First
.. SPARK_Hides
.Last
loop
789 if SPARK_Hides
.Table
(J
).Start
<= Loc
790 and then Loc
< SPARK_Hides
.Table
(J
).Stop
797 end Is_In_Hidden_Part_In_SPARK
;
799 -------------------------------
800 -- No_Exception_Handlers_Set --
801 -------------------------------
803 function No_Exception_Handlers_Set
return Boolean is
805 return (No_Run_Time_Mode
or else Configurable_Run_Time_Mode
)
806 and then (Restrictions
.Set
(No_Exception_Handlers
)
808 Restrictions
.Set
(No_Exception_Propagation
));
809 end No_Exception_Handlers_Set
;
811 -------------------------------------
812 -- No_Exception_Propagation_Active --
813 -------------------------------------
815 function No_Exception_Propagation_Active
return Boolean is
817 return (No_Run_Time_Mode
818 or else Configurable_Run_Time_Mode
819 or else Debug_Flag_Dot_G
)
820 and then Restriction_Active
(No_Exception_Propagation
);
821 end No_Exception_Propagation_Active
;
823 --------------------------------
824 -- OK_No_Dependence_Unit_Name --
825 --------------------------------
827 function OK_No_Dependence_Unit_Name
(N
: Node_Id
) return Boolean is
829 if Nkind
(N
) = N_Selected_Component
then
831 OK_No_Dependence_Unit_Name
(Prefix
(N
))
833 OK_No_Dependence_Unit_Name
(Selector_Name
(N
));
835 elsif Nkind
(N
) = N_Identifier
then
839 Error_Msg_N
("wrong form for unit name for No_Dependence", N
);
842 end OK_No_Dependence_Unit_Name
;
844 ----------------------------------
845 -- Process_Restriction_Synonyms --
846 ----------------------------------
848 -- Note: body of this function must be coordinated with list of
849 -- renaming declarations in System.Rident.
851 function Process_Restriction_Synonyms
(N
: Node_Id
) return Name_Id
853 Old_Name
: constant Name_Id
:= Chars
(N
);
858 when Name_Boolean_Entry_Barriers
=>
859 New_Name
:= Name_Simple_Barriers
;
861 when Name_Max_Entry_Queue_Depth
=>
862 New_Name
:= Name_Max_Entry_Queue_Length
;
864 when Name_No_Dynamic_Interrupts
=>
865 New_Name
:= Name_No_Dynamic_Attachment
;
867 when Name_No_Requeue
=>
868 New_Name
:= Name_No_Requeue_Statements
;
870 when Name_No_Task_Attributes
=>
871 New_Name
:= Name_No_Task_Attributes_Package
;
873 -- SPARK is special in that we unconditionally warn
876 Error_Msg_Name_1
:= Name_SPARK
;
877 Error_Msg_N
("restriction identifier % is obsolescent??", N
);
878 Error_Msg_Name_1
:= Name_SPARK_05
;
879 Error_Msg_N
("|use restriction identifier % instead??", N
);
880 return Name_SPARK_05
;
886 -- Output warning if we are warning on obsolescent features for all
887 -- cases other than SPARK.
889 if Warn_On_Obsolescent_Feature
then
890 Error_Msg_Name_1
:= Old_Name
;
891 Error_Msg_N
("restriction identifier % is obsolescent?j?", N
);
892 Error_Msg_Name_1
:= New_Name
;
893 Error_Msg_N
("|use restriction identifier % instead?j?", N
);
897 end Process_Restriction_Synonyms
;
899 --------------------------------------
900 -- Reset_Cunit_Boolean_Restrictions --
901 --------------------------------------
903 procedure Reset_Cunit_Boolean_Restrictions
is
905 for J
in Cunit_Boolean_Restrictions
loop
906 Restrictions
.Set
(J
) := False;
908 end Reset_Cunit_Boolean_Restrictions
;
910 -----------------------------------------------
911 -- Restore_Config_Cunit_Boolean_Restrictions --
912 -----------------------------------------------
914 procedure Restore_Config_Cunit_Boolean_Restrictions
is
916 Cunit_Boolean_Restrictions_Restore
(Config_Cunit_Boolean_Restrictions
);
917 end Restore_Config_Cunit_Boolean_Restrictions
;
919 ------------------------
920 -- Restricted_Profile --
921 ------------------------
923 function Restricted_Profile
return Boolean is
925 if Restricted_Profile_Cached
then
926 return Restricted_Profile_Result
;
929 Restricted_Profile_Result
:= True;
930 Restricted_Profile_Cached
:= True;
933 R
: Restriction_Flags
renames Profile_Info
(Restricted
).Set
;
934 V
: Restriction_Values
renames Profile_Info
(Restricted
).Value
;
936 for J
in R
'Range loop
938 and then (Restrictions
.Set
(J
) = False
939 or else Restriction_Warnings
(J
)
941 (J
in All_Parameter_Restrictions
942 and then Restrictions
.Value
(J
) > V
(J
)))
944 Restricted_Profile_Result
:= False;
949 return Restricted_Profile_Result
;
952 end Restricted_Profile
;
954 ------------------------
955 -- Restriction_Active --
956 ------------------------
958 function Restriction_Active
(R
: All_Restrictions
) return Boolean is
960 return Restrictions
.Set
(R
) and then not Restriction_Warnings
(R
);
961 end Restriction_Active
;
963 --------------------------------
964 -- Restriction_Check_Required --
965 --------------------------------
967 function Restriction_Check_Required
(R
: All_Restrictions
) return Boolean is
969 return Restrictions
.Set
(R
);
970 end Restriction_Check_Required
;
972 ---------------------
973 -- Restriction_Msg --
974 ---------------------
976 procedure Restriction_Msg
(R
: Restriction_Id
; N
: Node_Id
) is
977 Msg
: String (1 .. 100);
980 procedure Add_Char
(C
: Character);
981 -- Append given character to Msg, bumping Len
983 procedure Add_Str
(S
: String);
984 -- Append given string to Msg, bumping Len appropriately
986 procedure Id_Case
(S
: String; Quotes
: Boolean := True);
987 -- Given a string S, case it according to current identifier casing,
988 -- except for SPARK_05 (an acronym) which is set all upper case, and
989 -- store in Error_Msg_String. Then append `~` to the message buffer
990 -- to output the string unchanged surrounded in quotes. The quotes
991 -- are suppressed if Quotes = False.
997 procedure Add_Char
(C
: Character) is
1007 procedure Add_Str
(S
: String) is
1009 Msg
(Len
+ 1 .. Len
+ S
'Length) := S
;
1010 Len
:= Len
+ S
'Length;
1017 procedure Id_Case
(S
: String; Quotes
: Boolean := True) is
1019 Name_Buffer
(1 .. S
'Last) := S
;
1020 Name_Len
:= S
'Length;
1022 if R
= SPARK_05
then
1025 Set_Casing
(Identifier_Casing
(Get_Source_File_Index
(Sloc
(N
))));
1028 Error_Msg_Strlen
:= Name_Len
;
1029 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
1038 -- Start of processing for Restriction_Msg
1041 -- Set warning message if warning
1043 if Restriction_Warnings
(R
) then
1046 -- If real violation (not warning), then mark it as non-serious unless
1047 -- it is a violation of No_Finalization in which case we leave it as a
1048 -- serious message, since otherwise we get crashes during attempts to
1049 -- expand stuff that is not properly formed due to assumptions made
1050 -- about no finalization being present.
1052 elsif R
/= No_Finalization
then
1056 Error_Msg_Sloc
:= Restrictions_Loc
(R
);
1058 -- Set main message, adding implicit if no source location
1060 if Error_Msg_Sloc
> No_Location
1061 or else Error_Msg_Sloc
= System_Location
1063 Add_Str
("violation of restriction ");
1065 Add_Str
("violation of implicit restriction ");
1066 Error_Msg_Sloc
:= No_Location
;
1069 -- Case of parameterized restriction
1071 if R
in All_Parameter_Restrictions
then
1073 Id_Case
(Restriction_Id
'Image (R
), Quotes
=> False);
1075 Error_Msg_Uint_1
:= UI_From_Int
(Int
(Restrictions
.Value
(R
)));
1077 -- Case of boolean restriction
1080 Id_Case
(Restriction_Id
'Image (R
));
1083 -- Case of no secondary profile continuation message
1085 if Restriction_Profile_Name
(R
) = No_Profile
then
1086 if Error_Msg_Sloc
/= No_Location
then
1091 Error_Msg_N
(Msg
(1 .. Len
), N
);
1093 -- Case of secondary profile continuation message present
1097 Error_Msg_N
(Msg
(1 .. Len
), N
);
1102 -- Set as warning if warning case
1104 if Restriction_Warnings
(R
) then
1110 Add_Str
("from profile ");
1111 Id_Case
(Profile_Name
'Image (Restriction_Profile_Name
(R
)));
1113 -- Add location if we have one
1115 if Error_Msg_Sloc
/= No_Location
then
1119 -- Output unconditional message and we are done
1122 Error_Msg_N
(Msg
(1 .. Len
), N
);
1124 end Restriction_Msg
;
1130 function Same_Unit
(U1
, U2
: Node_Id
) return Boolean is
1132 if Nkind
(U1
) = N_Identifier
and then Nkind
(U2
) = N_Identifier
then
1133 return Chars
(U1
) = Chars
(U2
);
1135 elsif Nkind_In
(U1
, N_Selected_Component
, N_Expanded_Name
)
1137 Nkind_In
(U2
, N_Selected_Component
, N_Expanded_Name
)
1139 return Same_Unit
(Prefix
(U1
), Prefix
(U2
))
1141 Same_Unit
(Selector_Name
(U1
), Selector_Name
(U2
));
1147 --------------------------------------------
1148 -- Save_Config_Cunit_Boolean_Restrictions --
1149 --------------------------------------------
1151 procedure Save_Config_Cunit_Boolean_Restrictions
is
1153 Config_Cunit_Boolean_Restrictions
:= Cunit_Boolean_Restrictions_Save
;
1154 end Save_Config_Cunit_Boolean_Restrictions
;
1156 ------------------------------
1157 -- Set_Hidden_Part_In_SPARK --
1158 ------------------------------
1160 procedure Set_Hidden_Part_In_SPARK
(Loc1
, Loc2
: Source_Ptr
) is
1162 SPARK_Hides
.Increment_Last
;
1163 SPARK_Hides
.Table
(SPARK_Hides
.Last
).Start
:= Loc1
;
1164 SPARK_Hides
.Table
(SPARK_Hides
.Last
).Stop
:= Loc2
;
1165 end Set_Hidden_Part_In_SPARK
;
1167 ------------------------------
1168 -- Set_Profile_Restrictions --
1169 ------------------------------
1171 procedure Set_Profile_Restrictions
1176 R
: Restriction_Flags
renames Profile_Info
(P
).Set
;
1177 V
: Restriction_Values
renames Profile_Info
(P
).Value
;
1180 for J
in R
'Range loop
1183 Already_Restricted
: constant Boolean := Restriction_Active
(J
);
1186 -- Set the restriction
1188 if J
in All_Boolean_Restrictions
then
1189 Set_Restriction
(J
, N
);
1191 Set_Restriction
(J
, N
, V
(J
));
1194 -- Record that this came from a Profile[_Warnings] restriction
1196 Restriction_Profile_Name
(J
) := P
;
1198 -- Set warning flag, except that we do not set the warning
1199 -- flag if the restriction was already active and this is
1200 -- the warning case. That avoids a warning overriding a real
1201 -- restriction, which should never happen.
1203 if not (Warn
and Already_Restricted
) then
1204 Restriction_Warnings
(J
) := Warn
;
1209 end Set_Profile_Restrictions
;
1211 ---------------------
1212 -- Set_Restriction --
1213 ---------------------
1215 -- Case of Boolean restriction
1217 procedure Set_Restriction
1218 (R
: All_Boolean_Restrictions
;
1222 Restrictions
.Set
(R
) := True;
1224 if Restricted_Profile_Cached
and Restricted_Profile_Result
then
1227 Restricted_Profile_Cached
:= False;
1230 -- Set location, but preserve location of system restriction for nice
1231 -- error msg with run time name.
1233 if Restrictions_Loc
(R
) /= System_Location
then
1234 Restrictions_Loc
(R
) := Sloc
(N
);
1237 -- Note restriction came from restriction pragma, not profile
1239 Restriction_Profile_Name
(R
) := No_Profile
;
1241 -- Record the restriction if we are in the main unit, or in the extended
1242 -- main unit. The reason that we test separately for Main_Unit is that
1243 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1244 -- gnat.adc do not appear to be in the extended main source unit (they
1245 -- probably should do ???)
1247 if Current_Sem_Unit
= Main_Unit
1248 or else In_Extended_Main_Source_Unit
(N
)
1250 if not Restriction_Warnings
(R
) then
1251 Main_Restrictions
.Set
(R
) := True;
1254 end Set_Restriction
;
1256 -- Case of parameter restriction
1258 procedure Set_Restriction
1259 (R
: All_Parameter_Restrictions
;
1264 if Restricted_Profile_Cached
and Restricted_Profile_Result
then
1267 Restricted_Profile_Cached
:= False;
1270 if Restrictions
.Set
(R
) then
1271 if V
< Restrictions
.Value
(R
) then
1272 Restrictions
.Value
(R
) := V
;
1273 Restrictions_Loc
(R
) := Sloc
(N
);
1277 Restrictions
.Set
(R
) := True;
1278 Restrictions
.Value
(R
) := V
;
1279 Restrictions_Loc
(R
) := Sloc
(N
);
1282 -- Record the restriction if we are in the main unit, or in the extended
1283 -- main unit. The reason that we test separately for Main_Unit is that
1284 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1285 -- gnat.adc do not appear to be the extended main source unit (they
1286 -- probably should do ???)
1288 if Current_Sem_Unit
= Main_Unit
1289 or else In_Extended_Main_Source_Unit
(N
)
1291 if Main_Restrictions
.Set
(R
) then
1292 if V
< Main_Restrictions
.Value
(R
) then
1293 Main_Restrictions
.Value
(R
) := V
;
1296 elsif not Restriction_Warnings
(R
) then
1297 Main_Restrictions
.Set
(R
) := True;
1298 Main_Restrictions
.Value
(R
) := V
;
1302 -- Note restriction came from restriction pragma, not profile
1304 Restriction_Profile_Name
(R
) := No_Profile
;
1305 end Set_Restriction
;
1307 -----------------------------------
1308 -- Set_Restriction_No_Dependence --
1309 -----------------------------------
1311 procedure Set_Restriction_No_Dependence
1314 Profile
: Profile_Name
:= No_Profile
)
1317 -- Loop to check for duplicate entry
1319 for J
in No_Dependences
.First
.. No_Dependences
.Last
loop
1321 -- Case of entry already in table
1323 if Same_Unit
(Unit
, No_Dependences
.Table
(J
).Unit
) then
1325 -- Error has precedence over warning
1328 No_Dependences
.Table
(J
).Warn
:= False;
1335 -- Entry is not currently in table
1337 No_Dependences
.Append
((Unit
, Warn
, Profile
));
1338 end Set_Restriction_No_Dependence
;
1340 ------------------------------------------------
1341 -- Set_Restriction_No_Specification_Of_Aspect --
1342 ------------------------------------------------
1344 procedure Set_Restriction_No_Specification_Of_Aspect
1348 A_Id
: constant Aspect_Id_Exclude_No_Aspect
:= Get_Aspect_Id
(Chars
(N
));
1351 No_Specification_Of_Aspects
(A_Id
) := Sloc
(N
);
1353 if Warning
= False then
1354 No_Specification_Of_Aspect_Warning
(A_Id
) := False;
1357 No_Specification_Of_Aspect_Set
:= True;
1358 end Set_Restriction_No_Specification_Of_Aspect
;
1360 -----------------------------------------
1361 -- Set_Restriction_No_Use_Of_Attribute --
1362 -----------------------------------------
1364 procedure Set_Restriction_No_Use_Of_Attribute
1368 A_Id
: constant Attribute_Id
:= Get_Attribute_Id
(Chars
(N
));
1371 No_Use_Of_Attribute_Set
:= True;
1372 No_Use_Of_Attribute
(A_Id
) := Sloc
(N
);
1374 if Warning
= False then
1375 No_Use_Of_Attribute_Warning
(A_Id
) := False;
1377 end Set_Restriction_No_Use_Of_Attribute
;
1379 --------------------------------------
1380 -- Set_Restriction_No_Use_Of_Pragma --
1381 --------------------------------------
1383 procedure Set_Restriction_No_Use_Of_Pragma
1387 A_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Chars
(N
));
1390 No_Use_Of_Pragma_Set
:= True;
1391 No_Use_Of_Pragma
(A_Id
) := Sloc
(N
);
1393 if Warning
= False then
1394 No_Use_Of_Pragma_Warning
(A_Id
) := False;
1396 end Set_Restriction_No_Use_Of_Pragma
;
1398 -----------------------------
1399 -- Check_SPARK_Restriction --
1400 -----------------------------
1402 procedure Check_SPARK_Restriction
1405 Force
: Boolean := False)
1407 Msg_Issued
: Boolean;
1408 Save_Error_Msg_Sloc
: Source_Ptr
;
1409 Onode
: constant Node_Id
:= Original_Node
(N
);
1412 -- Output message if Force set
1416 -- Or if this node comes from source
1418 or else Comes_From_Source
(N
)
1420 -- Or if this is a range node which rewrites a range attribute and
1421 -- the range attribute comes from source.
1423 or else (Nkind
(N
) = N_Range
1424 and then Nkind
(Onode
) = N_Attribute_Reference
1425 and then Attribute_Name
(Onode
) = Name_Range
1426 and then Comes_From_Source
(Onode
))
1428 -- Or this is an expression that does not come from source, which is
1429 -- a rewriting of an expression that does come from source.
1431 or else (Nkind
(N
) in N_Subexpr
and then Comes_From_Source
(Onode
))
1433 if Restriction_Check_Required
(SPARK_05
)
1434 and then Is_In_Hidden_Part_In_SPARK
(Sloc
(N
))
1439 -- Since the call to Restriction_Msg from Check_Restriction may set
1440 -- Error_Msg_Sloc to the location of the pragma restriction, save and
1441 -- restore the previous value of the global variable around the call.
1443 Save_Error_Msg_Sloc
:= Error_Msg_Sloc
;
1444 Check_Restriction
(Msg_Issued
, SPARK_05
, First_Node
(N
));
1445 Error_Msg_Sloc
:= Save_Error_Msg_Sloc
;
1448 Error_Msg_F
("\\| " & Msg
, N
);
1451 end Check_SPARK_Restriction
;
1453 procedure Check_SPARK_Restriction
(Msg1
, Msg2
: String; N
: Node_Id
) is
1454 Msg_Issued
: Boolean;
1455 Save_Error_Msg_Sloc
: Source_Ptr
;
1458 pragma Assert
(Msg2
'Length /= 0 and then Msg2
(Msg2
'First) = '\');
1460 if Comes_From_Source
(Original_Node
(N
)) then
1461 if Restriction_Check_Required
(SPARK_05
)
1462 and then Is_In_Hidden_Part_In_SPARK
(Sloc
(N
))
1467 -- Since the call to Restriction_Msg from Check_Restriction may set
1468 -- Error_Msg_Sloc to the location of the pragma restriction, save and
1469 -- restore the previous value of the global variable around the call.
1471 Save_Error_Msg_Sloc
:= Error_Msg_Sloc
;
1472 Check_Restriction
(Msg_Issued
, SPARK_05
, First_Node
(N
));
1473 Error_Msg_Sloc
:= Save_Error_Msg_Sloc
;
1476 Error_Msg_F
("\\| " & Msg1
, N
);
1477 Error_Msg_F
(Msg2
, N
);
1480 end Check_SPARK_Restriction
;
1482 ----------------------------------
1483 -- Suppress_Restriction_Message --
1484 ----------------------------------
1486 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean is
1488 -- We only output messages for the extended main source unit
1490 if In_Extended_Main_Source_Unit
(N
) then
1493 -- If loaded by rtsfind, then suppress message
1495 elsif Sloc
(N
) <= No_Location
then
1498 -- Otherwise suppress message if internal file
1501 return Is_Internal_File_Name
(Unit_File_Name
(Get_Source_Unit
(N
)));
1503 end Suppress_Restriction_Message
;
1505 ---------------------
1506 -- Tasking_Allowed --
1507 ---------------------
1509 function Tasking_Allowed
return Boolean is
1511 return not Restrictions
.Set
(No_Tasking
)
1512 and then (not Restrictions
.Set
(Max_Tasks
)
1513 or else Restrictions
.Value
(Max_Tasks
) > 0);
1514 end Tasking_Allowed
;