1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Casing
; use Casing
;
28 with Einfo
; use Einfo
;
29 with Errout
; use Errout
;
30 with Debug
; use Debug
;
31 with Fname
; use Fname
;
32 with Fname
.UF
; use Fname
.UF
;
35 with Sinfo
; use Sinfo
;
36 with Sinput
; use Sinput
;
37 with Stand
; use Stand
;
38 with Uname
; use Uname
;
40 package body Restrict
is
42 -------------------------------
43 -- SPARK Restriction Control --
44 -------------------------------
46 -- SPARK HIDE directives allow the effect of the SPARK_05 restriction to be
47 -- turned off for a specified region of code, and the following tables are
48 -- the data structures used to keep track of these regions.
50 -- The table contains pairs of source locations, the first being the start
51 -- location for hidden region, and the second being the end location.
53 -- Note that the start location is included in the hidden region, while
54 -- the end location is excluded from it. (It typically corresponds to the
55 -- next token during scanning.)
57 type SPARK_Hide_Entry
is record
62 package SPARK_Hides
is new Table
.Table
(
63 Table_Component_Type
=> SPARK_Hide_Entry
,
64 Table_Index_Type
=> Natural,
67 Table_Increment
=> 200,
68 Table_Name
=> "SPARK Hides");
70 --------------------------------
71 -- Package Local Declarations --
72 --------------------------------
74 Config_Cunit_Boolean_Restrictions
: Save_Cunit_Boolean_Restrictions
;
75 -- Save compilation unit restrictions set by config pragma files
77 Restricted_Profile_Result
: Boolean := False;
78 -- This switch memoizes the result of Restricted_Profile function calls for
79 -- improved efficiency. Valid only if Restricted_Profile_Cached is True.
80 -- Note: if this switch is ever set True, it is never turned off again.
82 Restricted_Profile_Cached
: Boolean := False;
83 -- This flag is set to True if the Restricted_Profile_Result contains the
84 -- correct cached result of Restricted_Profile calls.
86 No_Specification_Of_Aspects
: array (Aspect_Id
) of Source_Ptr
:=
87 (others => No_Location
);
88 -- Entries in this array are set to point to a previously occuring pragma
89 -- that activates a No_Specification_Of_Aspect check.
91 No_Specification_Of_Aspect_Warning
: array (Aspect_Id
) of Boolean :=
93 -- An entry in this array is set False in reponse to a previous call to
94 -- Set_No_Speficiation_Of_Aspect for pragmas in the main unit that
95 -- specify Warning as False. Once set False, an entry is never reset.
97 No_Specification_Of_Aspect_Set
: Boolean := False;
98 -- Set True if any entry of No_Specifcation_Of_Aspects has been set True.
99 -- Once set True, this is never turned off again.
101 No_Use_Of_Attribute
: array (Attribute_Id
) of Source_Ptr
:=
102 (others => No_Location
);
104 No_Use_Of_Attribute_Warning
: array (Attribute_Id
) of Boolean :=
107 No_Use_Of_Attribute_Set
: Boolean := False;
108 -- Indicates that No_Use_Of_Attribute was set at least once
110 No_Use_Of_Pragma
: array (Pragma_Id
) of Source_Ptr
:=
111 (others => No_Location
);
112 -- Source location of pragma No_Use_Of_Pragma for given pragma, a value
113 -- of System_Location indicates occurrence in system.ads.
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_Entity
(E1
, E2
: Node_Id
) return Boolean;
132 -- Returns True iff E1 and E2 represent the same entity. Used for handling
133 -- of No_Use_Of_Entity => fully_qualified_ENTITY restriction case.
135 function Same_Unit
(U1
, U2
: Node_Id
) return Boolean;
136 -- Returns True iff U1 and U2 represent the same library unit. Used for
137 -- handling of No_Dependence => Unit restriction case.
139 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean;
140 -- N is the node for a possible restriction violation message, but the
141 -- message is to be suppressed if this is an internal file and this file is
142 -- not the main unit. Returns True if message is to be suppressed.
148 function Abort_Allowed
return Boolean is
150 if Restrictions
.Set
(No_Abort_Statements
)
151 and then Restrictions
.Set
(Max_Asynchronous_Select_Nesting
)
152 and then Restrictions
.Value
(Max_Asynchronous_Select_Nesting
) = 0
160 ----------------------------------------
161 -- Add_To_Config_Boolean_Restrictions --
162 ----------------------------------------
164 procedure Add_To_Config_Boolean_Restrictions
(R
: Restriction_Id
) is
166 Config_Cunit_Boolean_Restrictions
(R
) := True;
167 end Add_To_Config_Boolean_Restrictions
;
168 -- Add specified restriction to stored configuration boolean restrictions.
169 -- This is used for handling the special case of No_Elaboration_Code.
171 -------------------------
172 -- Check_Compiler_Unit --
173 -------------------------
175 procedure Check_Compiler_Unit
(Feature
: String; N
: Node_Id
) is
177 if Compiler_Unit
then
178 Error_Msg_N
(Feature
& " not allowed in compiler unit!!??", N
);
180 end Check_Compiler_Unit
;
182 procedure Check_Compiler_Unit
(Feature
: String; Loc
: Source_Ptr
) is
184 if Compiler_Unit
then
185 Error_Msg
(Feature
& " not allowed in compiler unit!!??", Loc
);
187 end Check_Compiler_Unit
;
189 ------------------------------------
190 -- Check_Elaboration_Code_Allowed --
191 ------------------------------------
193 procedure Check_Elaboration_Code_Allowed
(N
: Node_Id
) is
195 Check_Restriction
(No_Elaboration_Code
, N
);
196 end Check_Elaboration_Code_Allowed
;
198 --------------------------------
199 -- Check_No_Implicit_Aliasing --
200 --------------------------------
202 procedure Check_No_Implicit_Aliasing
(Obj
: Node_Id
) is
206 -- If restriction not active, nothing to check
208 if not Restriction_Active
(No_Implicit_Aliasing
) then
212 -- If we have an entity name, check entity
214 if Is_Entity_Name
(Obj
) then
217 -- Restriction applies to entities that are objects
219 if Is_Object
(E
) then
220 if Is_Aliased
(E
) then
223 elsif Present
(Renamed_Object
(E
)) then
224 Check_No_Implicit_Aliasing
(Renamed_Object
(E
));
228 -- If we don't have an object, then it's OK
234 -- For selected component, check selector
236 elsif Nkind
(Obj
) = N_Selected_Component
then
237 Check_No_Implicit_Aliasing
(Selector_Name
(Obj
));
240 -- Indexed component is OK if aliased components
242 elsif Nkind
(Obj
) = N_Indexed_Component
then
243 if Has_Aliased_Components
(Etype
(Prefix
(Obj
)))
245 (Is_Access_Type
(Etype
(Prefix
(Obj
)))
246 and then Has_Aliased_Components
247 (Designated_Type
(Etype
(Prefix
(Obj
)))))
252 -- For type conversion, check converted expression
254 elsif Nkind_In
(Obj
, N_Unchecked_Type_Conversion
, N_Type_Conversion
) then
255 Check_No_Implicit_Aliasing
(Expression
(Obj
));
258 -- Explicit dereference is always OK
260 elsif Nkind
(Obj
) = N_Explicit_Dereference
then
264 -- If we fall through, then we have an aliased view that does not meet
265 -- the rules for being explicitly aliased, so issue restriction msg.
267 Check_Restriction
(No_Implicit_Aliasing
, Obj
);
268 end Check_No_Implicit_Aliasing
;
270 -----------------------------------------
271 -- Check_Implicit_Dynamic_Code_Allowed --
272 -----------------------------------------
274 procedure Check_Implicit_Dynamic_Code_Allowed
(N
: Node_Id
) is
276 Check_Restriction
(No_Implicit_Dynamic_Code
, N
);
277 end Check_Implicit_Dynamic_Code_Allowed
;
279 ----------------------------------
280 -- Check_No_Implicit_Heap_Alloc --
281 ----------------------------------
283 procedure Check_No_Implicit_Heap_Alloc
(N
: Node_Id
) is
285 Check_Restriction
(No_Implicit_Heap_Allocations
, N
);
286 end Check_No_Implicit_Heap_Alloc
;
288 ----------------------------------
289 -- Check_No_Implicit_Task_Alloc --
290 ----------------------------------
292 procedure Check_No_Implicit_Task_Alloc
(N
: Node_Id
) is
294 Check_Restriction
(No_Implicit_Task_Allocations
, N
);
295 end Check_No_Implicit_Task_Alloc
;
297 ---------------------------------------
298 -- Check_No_Implicit_Protected_Alloc --
299 ---------------------------------------
301 procedure Check_No_Implicit_Protected_Alloc
(N
: Node_Id
) is
303 Check_Restriction
(No_Implicit_Protected_Object_Allocations
, N
);
304 end Check_No_Implicit_Protected_Alloc
;
306 -----------------------------------
307 -- Check_Obsolescent_2005_Entity --
308 -----------------------------------
310 procedure Check_Obsolescent_2005_Entity
(E
: Entity_Id
; N
: Node_Id
) is
311 function Chars_Is
(E
: Entity_Id
; S
: String) return Boolean;
312 -- Return True iff Chars (E) matches S (given in lower case)
318 function Chars_Is
(E
: Entity_Id
; S
: String) return Boolean is
319 Nam
: constant Name_Id
:= Chars
(E
);
321 if Length_Of_Name
(Nam
) /= S
'Length then
324 return Get_Name_String
(Nam
) = S
;
328 -- Start of processing for Check_Obsolescent_2005_Entity
331 if Restriction_Check_Required
(No_Obsolescent_Features
)
332 and then Ada_Version
>= Ada_2005
333 and then Chars_Is
(Scope
(E
), "handling")
334 and then Chars_Is
(Scope
(Scope
(E
)), "characters")
335 and then Chars_Is
(Scope
(Scope
(Scope
(E
))), "ada")
336 and then Scope
(Scope
(Scope
(Scope
(E
)))) = Standard_Standard
338 if Chars_Is
(E
, "is_character") or else
339 Chars_Is
(E
, "is_string") or else
340 Chars_Is
(E
, "to_character") or else
341 Chars_Is
(E
, "to_string") or else
342 Chars_Is
(E
, "to_wide_character") or else
343 Chars_Is
(E
, "to_wide_string")
345 Check_Restriction
(No_Obsolescent_Features
, N
);
348 end Check_Obsolescent_2005_Entity
;
350 ---------------------------
351 -- Check_Restricted_Unit --
352 ---------------------------
354 procedure Check_Restricted_Unit
(U
: Unit_Name_Type
; N
: Node_Id
) is
356 if Suppress_Restriction_Message
(N
) then
359 elsif Is_Spec_Name
(U
) then
361 Fnam
: constant File_Name_Type
:=
362 Get_File_Name
(U
, Subunit
=> False);
367 Get_Name_String
(Fnam
);
369 -- Nothing to do if name not at least 5 characters long ending
370 -- in .ads or .adb extension, which we strip.
373 or else (Name_Buffer
(Name_Len
- 3 .. Name_Len
) /= ".ads"
375 Name_Buffer
(Name_Len
- 3 .. Name_Len
) /= ".adb")
380 -- Strip extension and pad to eight characters
382 Name_Len
:= Name_Len
- 4;
383 Add_Str_To_Name_Buffer
((Name_Len
+ 1 .. 8 => ' '));
385 -- If predefined unit, check the list of restricted units
387 if Is_Predefined_File_Name
(Fnam
) then
388 for J
in Unit_Array
'Range loop
390 and then Name_Buffer
(1 .. 8) = Unit_Array
(J
).Filenm
392 Check_Restriction
(Unit_Array
(J
).Res_Id
, N
);
396 -- If not predefined unit, then one special check still
397 -- remains. GNAT.Current_Exception is not allowed if we have
398 -- restriction No_Exception_Propagation active.
401 if Name_Buffer
(1 .. 8) = "g-curexc" then
402 Check_Restriction
(No_Exception_Propagation
, N
);
407 end Check_Restricted_Unit
;
409 -----------------------
410 -- Check_Restriction --
411 -----------------------
413 procedure Check_Restriction
416 V
: Uint
:= Uint_Minus_1
)
418 Msg_Issued
: Boolean;
419 pragma Unreferenced
(Msg_Issued
);
421 Check_Restriction
(Msg_Issued
, R
, N
, V
);
422 end Check_Restriction
;
424 procedure Check_Restriction
425 (Msg_Issued
: out Boolean;
428 V
: Uint
:= Uint_Minus_1
)
431 -- V converted to integer form. If V is greater than Integer'Last,
432 -- it is reset to minus 1 (unknown value).
434 procedure Update_Restrictions
(Info
: in out Restrictions_Info
);
435 -- Update violation information in Info.Violated and Info.Count
437 -------------------------
438 -- Update_Restrictions --
439 -------------------------
441 procedure Update_Restrictions
(Info
: in out Restrictions_Info
) is
443 -- If not violated, set as violated now
445 if not Info
.Violated
(R
) then
446 Info
.Violated
(R
) := True;
448 if R
in All_Parameter_Restrictions
then
450 Info
.Unknown
(R
) := True;
454 Info
.Count
(R
) := VV
;
458 -- Otherwise if violated already and a parameter restriction,
459 -- update count by maximizing or summing depending on restriction.
461 elsif R
in All_Parameter_Restrictions
then
463 -- If new value is unknown, result is unknown
466 Info
.Unknown
(R
) := True;
468 -- If checked by maximization, nothing to do because the
469 -- check is per-object.
471 elsif R
in Checked_Max_Parameter_Restrictions
then
474 -- If checked by adding, do add, checking for overflow
476 elsif R
in Checked_Add_Parameter_Restrictions
then
478 pragma Unsuppress
(Overflow_Check
);
480 Info
.Count
(R
) := Info
.Count
(R
) + VV
;
482 when Constraint_Error
=>
483 Info
.Count
(R
) := Integer'Last;
484 Info
.Unknown
(R
) := True;
487 -- Should not be able to come here, known counts should only
488 -- occur for restrictions that are Checked_max or Checked_Sum.
494 end Update_Restrictions
;
496 -- Start of processing for Check_Restriction
501 -- In CodePeer mode, we do not want to check for any restriction, or set
502 -- additional restrictions other than those already set in gnat1drv.adb
503 -- so that we have consistency between each compilation.
505 -- In GNATprove mode restrictions are checked, except for
506 -- No_Initialize_Scalars, which is implicitly set in gnat1drv.adb.
509 or else (GNATprove_Mode
and then R
= No_Initialize_Scalars
)
514 -- In SPARK 05 mode, issue an error for any use of class-wide, even if
515 -- the No_Dispatch restriction is not set.
517 if R
= No_Dispatch
then
518 Check_SPARK_05_Restriction
("class-wide is not allowed", N
);
521 if UI_Is_In_Int_Range
(V
) then
522 VV
:= Integer (UI_To_Int
(V
));
527 -- Count can only be specified in the checked val parameter case
529 pragma Assert
(VV
< 0 or else R
in Checked_Val_Parameter_Restrictions
);
531 -- Nothing to do if value of zero specified for parameter restriction
537 -- Update current restrictions
539 Update_Restrictions
(Restrictions
);
541 -- If in main extended unit, update main restrictions as well. Note
542 -- that as usual we check for Main_Unit explicitly to deal with the
543 -- case of configuration pragma files.
545 if Current_Sem_Unit
= Main_Unit
546 or else In_Extended_Main_Source_Unit
(N
)
548 Update_Restrictions
(Main_Restrictions
);
551 -- Nothing to do if restriction message suppressed
553 if Suppress_Restriction_Message
(N
) then
556 -- If restriction not set, nothing to do
558 elsif not Restrictions
.Set
(R
) then
561 -- Don't complain about No_Obsolescent_Features in an instance, since we
562 -- will complain on the template, which is much better. Are there other
563 -- cases like this ??? Do we need a more general mechanism ???
565 elsif R
= No_Obsolescent_Features
566 and then Instantiation_Location
(Sloc
(N
)) /= No_Location
570 -- Here if restriction set, check for violation (this is a Boolean
571 -- restriction, or a parameter restriction with a value of zero and an
572 -- unknown count, or a parameter restriction with a known value that
573 -- exceeds the restriction count).
575 elsif R
in All_Boolean_Restrictions
576 or else (Restrictions
.Unknown
(R
)
577 and then Restrictions
.Value
(R
) = 0)
578 or else Restrictions
.Count
(R
) > Restrictions
.Value
(R
)
581 Restriction_Msg
(R
, N
);
584 -- For Max_Entries and the like, do not carry forward the violation
585 -- count because it does not affect later declarations.
587 if R
in Checked_Max_Parameter_Restrictions
then
588 Restrictions
.Count
(R
) := 0;
589 Restrictions
.Violated
(R
) := False;
591 end Check_Restriction
;
593 -------------------------------------
594 -- Check_Restriction_No_Dependence --
595 -------------------------------------
597 procedure Check_Restriction_No_Dependence
(U
: Node_Id
; Err
: Node_Id
) is
601 -- Ignore call if node U is not in the main source unit. This avoids
602 -- cascaded errors, e.g. when Ada.Containers units with other units.
603 -- However, allow Standard_Location here, since this catches some cases
604 -- of constructs that get converted to run-time calls.
606 if not In_Extended_Main_Source_Unit
(U
)
607 and then Sloc
(U
) /= Standard_Location
612 -- Loop through entries in No_Dependence table to check each one in turn
614 for J
in No_Dependences
.First
.. No_Dependences
.Last
loop
615 DU
:= No_Dependences
.Table
(J
).Unit
;
617 if Same_Unit
(U
, DU
) then
618 Error_Msg_Sloc
:= Sloc
(DU
);
619 Error_Msg_Node_1
:= DU
;
621 if No_Dependences
.Table
(J
).Warn
then
623 ("?*?violation of restriction `No_Dependence '='> &`#",
627 ("|violation of restriction `No_Dependence '='> &`#",
634 end Check_Restriction_No_Dependence
;
636 --------------------------------------------------
637 -- Check_Restriction_No_Specification_Of_Aspect --
638 --------------------------------------------------
640 procedure Check_Restriction_No_Specification_Of_Aspect
(N
: Node_Id
) is
645 -- Ignore call if no instances of this restriction set
647 if not No_Specification_Of_Aspect_Set
then
651 -- Ignore call if node N is not in the main source unit, since we only
652 -- give messages for the main unit. This avoids giving messages for
653 -- aspects that are specified in withed units.
655 if not In_Extended_Main_Source_Unit
(N
) then
659 Id
:= Identifier
(N
);
660 A_Id
:= Get_Aspect_Id
(Chars
(Id
));
661 pragma Assert
(A_Id
/= No_Aspect
);
663 Error_Msg_Sloc
:= No_Specification_Of_Aspects
(A_Id
);
665 if Error_Msg_Sloc
/= No_Location
then
666 Error_Msg_Node_1
:= Id
;
667 Error_Msg_Warn
:= No_Specification_Of_Aspect_Warning
(A_Id
);
669 ("<*<violation of restriction `No_Specification_Of_Aspect '='> &`#",
672 end Check_Restriction_No_Specification_Of_Aspect
;
674 -------------------------------------------
675 -- Check_Restriction_No_Use_Of_Attribute --
676 --------------------------------------------
678 procedure Check_Restriction_No_Use_Of_Attribute
(N
: Node_Id
) is
679 Id
: constant Name_Id
:= Chars
(N
);
680 A_Id
: constant Attribute_Id
:= Get_Attribute_Id
(Id
);
683 -- Ignore call if node N is not in the main source unit, since we only
684 -- give messages for the main unit. This avoids giving messages for
685 -- aspects that are specified in withed units.
687 if not In_Extended_Main_Source_Unit
(N
) then
691 -- If nothing set, nothing to check
693 if not No_Use_Of_Attribute_Set
then
697 Error_Msg_Sloc
:= No_Use_Of_Attribute
(A_Id
);
699 if Error_Msg_Sloc
/= No_Location
then
700 Error_Msg_Node_1
:= N
;
701 Error_Msg_Warn
:= No_Use_Of_Attribute_Warning
(A_Id
);
703 ("<*<violation of restriction `No_Use_Of_Attribute '='> &`#", N
);
705 end Check_Restriction_No_Use_Of_Attribute
;
707 ----------------------------------------
708 -- Check_Restriction_No_Use_Of_Entity --
709 ----------------------------------------
711 procedure Check_Restriction_No_Use_Of_Entity
(N
: Node_Id
) is
713 -- Error defence (not clearly necessary, but better safe)
715 if No
(Entity
(N
)) then
719 -- If simple name of entity not flagged with Boolean2 flag, then there
720 -- cannot be a matching entry in the table, so skip the search.
722 if Get_Name_Table_Boolean2
(Chars
(Entity
(N
))) = False then
726 -- Restriction is only recognized within a configuration
727 -- pragma file, or within a unit of the main extended
728 -- program. Note: the test for Main_Unit is needed to
729 -- properly include the case of configuration pragma files.
731 if Current_Sem_Unit
/= Main_Unit
732 and then not In_Extended_Main_Source_Unit
(N
)
737 -- Here we must search the table
739 for J
in No_Use_Of_Entity
.First
.. No_Use_Of_Entity
.Last
loop
741 NE_Ent
: NE_Entry
renames No_Use_Of_Entity
.Table
(J
);
747 Expr
:= NE_Ent
.Entity
;
749 -- Here if at outer level of entity name in reference
751 if Scope
(Ent
) = Standard_Standard
then
752 if Nkind_In
(Expr
, N_Identifier
, N_Operator_Symbol
)
753 and then Chars
(Ent
) = Chars
(Expr
)
755 Error_Msg_Node_1
:= N
;
756 Error_Msg_Warn
:= NE_Ent
.Warn
;
757 Error_Msg_Sloc
:= Sloc
(NE_Ent
.Entity
);
759 ("<*<reference to & violates restriction "
760 & "No_Use_Of_Entity #", N
);
767 -- Here if at outer level of entity name in table
769 elsif Nkind_In
(Expr
, N_Identifier
, N_Operator_Symbol
) then
772 -- Here if neither at the outer level
775 pragma Assert
(Nkind
(Expr
) = N_Selected_Component
);
777 if Chars
(Selector_Name
(Expr
)) /= Chars
(Ent
) then
786 exit when not Is_Internal_Name
(Chars
(Ent
));
789 Expr
:= Prefix
(Expr
);
791 -- Entry did not match
797 end Check_Restriction_No_Use_Of_Entity
;
799 ----------------------------------------
800 -- Check_Restriction_No_Use_Of_Pragma --
801 ----------------------------------------
803 procedure Check_Restriction_No_Use_Of_Pragma
(N
: Node_Id
) is
804 Id
: constant Node_Id
:= Pragma_Identifier
(N
);
805 P_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Chars
(Id
));
808 -- Ignore call if node N is not in the main source unit, since we only
809 -- give messages for the main unit. This avoids giving messages for
810 -- aspects that are specified in withed units.
812 if not In_Extended_Main_Source_Unit
(N
) then
816 -- If nothing set, nothing to check
818 if not No_Use_Of_Pragma_Set
then
822 Error_Msg_Sloc
:= No_Use_Of_Pragma
(P_Id
);
824 if Error_Msg_Sloc
/= No_Location
then
825 Error_Msg_Node_1
:= Id
;
826 Error_Msg_Warn
:= No_Use_Of_Pragma_Warning
(P_Id
);
828 ("<*<violation of restriction `No_Use_Of_Pragma '='> &`#", Id
);
830 end Check_Restriction_No_Use_Of_Pragma
;
832 --------------------------------------
833 -- Check_Wide_Character_Restriction --
834 --------------------------------------
836 procedure Check_Wide_Character_Restriction
(E
: Entity_Id
; N
: Node_Id
) is
838 if Restriction_Check_Required
(No_Wide_Characters
)
839 and then Comes_From_Source
(N
)
842 T
: constant Entity_Id
:= Root_Type
(E
);
844 if T
= Standard_Wide_Character
or else
845 T
= Standard_Wide_String
or else
846 T
= Standard_Wide_Wide_Character
or else
847 T
= Standard_Wide_Wide_String
849 Check_Restriction
(No_Wide_Characters
, N
);
853 end Check_Wide_Character_Restriction
;
855 ----------------------------------------
856 -- Cunit_Boolean_Restrictions_Restore --
857 ----------------------------------------
859 procedure Cunit_Boolean_Restrictions_Restore
860 (R
: Save_Cunit_Boolean_Restrictions
)
863 for J
in Cunit_Boolean_Restrictions
loop
864 Restrictions
.Set
(J
) := R
(J
);
867 -- If No_Elaboration_Code set in configuration restrictions, and we
868 -- in the main extended source, then set it here now. This is part of
869 -- the special processing for No_Elaboration_Code.
871 if In_Extended_Main_Source_Unit
(Cunit_Entity
(Current_Sem_Unit
))
872 and then Config_Cunit_Boolean_Restrictions
(No_Elaboration_Code
)
874 Restrictions
.Set
(No_Elaboration_Code
) := True;
876 end Cunit_Boolean_Restrictions_Restore
;
878 -------------------------------------
879 -- Cunit_Boolean_Restrictions_Save --
880 -------------------------------------
882 function Cunit_Boolean_Restrictions_Save
883 return Save_Cunit_Boolean_Restrictions
885 R
: Save_Cunit_Boolean_Restrictions
;
888 for J
in Cunit_Boolean_Restrictions
loop
889 R
(J
) := Restrictions
.Set
(J
);
893 end Cunit_Boolean_Restrictions_Save
;
895 ------------------------
896 -- Get_Restriction_Id --
897 ------------------------
899 function Get_Restriction_Id
900 (N
: Name_Id
) return Restriction_Id
904 Set_Casing
(All_Upper_Case
);
906 for J
in All_Restrictions
loop
908 S
: constant String := Restriction_Id
'Image (J
);
910 if S
= Name_Buffer
(1 .. Name_Len
) then
916 return Not_A_Restriction_Id
;
917 end Get_Restriction_Id
;
919 --------------------------------
920 -- Is_In_Hidden_Part_In_SPARK --
921 --------------------------------
923 function Is_In_Hidden_Part_In_SPARK
(Loc
: Source_Ptr
) return Boolean is
925 -- Loop through table of hidden ranges
927 for J
in SPARK_Hides
.First
.. SPARK_Hides
.Last
loop
928 if SPARK_Hides
.Table
(J
).Start
<= Loc
929 and then Loc
< SPARK_Hides
.Table
(J
).Stop
936 end Is_In_Hidden_Part_In_SPARK
;
938 -------------------------------
939 -- No_Exception_Handlers_Set --
940 -------------------------------
942 function No_Exception_Handlers_Set
return Boolean is
944 return (No_Run_Time_Mode
or else Configurable_Run_Time_Mode
)
945 and then (Restrictions
.Set
(No_Exception_Handlers
)
947 Restrictions
.Set
(No_Exception_Propagation
));
948 end No_Exception_Handlers_Set
;
950 -------------------------------------
951 -- No_Exception_Propagation_Active --
952 -------------------------------------
954 function No_Exception_Propagation_Active
return Boolean is
956 return (No_Run_Time_Mode
957 or else Configurable_Run_Time_Mode
958 or else Debug_Flag_Dot_G
)
959 and then Restriction_Active
(No_Exception_Propagation
);
960 end No_Exception_Propagation_Active
;
962 --------------------------------
963 -- OK_No_Dependence_Unit_Name --
964 --------------------------------
966 function OK_No_Dependence_Unit_Name
(N
: Node_Id
) return Boolean is
968 if Nkind
(N
) = N_Selected_Component
then
970 OK_No_Dependence_Unit_Name
(Prefix
(N
))
972 OK_No_Dependence_Unit_Name
(Selector_Name
(N
));
974 elsif Nkind
(N
) = N_Identifier
then
978 Error_Msg_N
("wrong form for unit name for No_Dependence", N
);
981 end OK_No_Dependence_Unit_Name
;
983 ------------------------------
984 -- OK_No_Use_Of_Entity_Name --
985 ------------------------------
987 function OK_No_Use_Of_Entity_Name
(N
: Node_Id
) return Boolean is
989 if Nkind
(N
) = N_Selected_Component
then
991 OK_No_Use_Of_Entity_Name
(Prefix
(N
))
993 OK_No_Use_Of_Entity_Name
(Selector_Name
(N
));
995 elsif Nkind_In
(N
, N_Identifier
, N_Operator_Symbol
) then
999 Error_Msg_N
("wrong form for entity name for No_Use_Of_Entity", N
);
1002 end OK_No_Use_Of_Entity_Name
;
1004 ----------------------------------
1005 -- Process_Restriction_Synonyms --
1006 ----------------------------------
1008 -- Note: body of this function must be coordinated with list of renaming
1009 -- declarations in System.Rident.
1011 function Process_Restriction_Synonyms
(N
: Node_Id
) return Name_Id
1013 Old_Name
: constant Name_Id
:= Chars
(N
);
1018 when Name_Boolean_Entry_Barriers
=>
1019 New_Name
:= Name_Simple_Barriers
;
1021 when Name_Max_Entry_Queue_Depth
=>
1022 New_Name
:= Name_Max_Entry_Queue_Length
;
1024 when Name_No_Dynamic_Interrupts
=>
1025 New_Name
:= Name_No_Dynamic_Attachment
;
1027 when Name_No_Requeue
=>
1028 New_Name
:= Name_No_Requeue_Statements
;
1030 when Name_No_Task_Attributes
=>
1031 New_Name
:= Name_No_Task_Attributes_Package
;
1033 -- SPARK is special in that we unconditionally warn
1036 Error_Msg_Name_1
:= Name_SPARK
;
1037 Error_Msg_N
("restriction identifier % is obsolescent??", N
);
1038 Error_Msg_Name_1
:= Name_SPARK_05
;
1039 Error_Msg_N
("|use restriction identifier % instead??", N
);
1040 return Name_SPARK_05
;
1046 -- Output warning if we are warning on obsolescent features for all
1047 -- cases other than SPARK.
1049 if Warn_On_Obsolescent_Feature
then
1050 Error_Msg_Name_1
:= Old_Name
;
1051 Error_Msg_N
("restriction identifier % is obsolescent?j?", N
);
1052 Error_Msg_Name_1
:= New_Name
;
1053 Error_Msg_N
("|use restriction identifier % instead?j?", N
);
1057 end Process_Restriction_Synonyms
;
1059 --------------------------------------
1060 -- Reset_Cunit_Boolean_Restrictions --
1061 --------------------------------------
1063 procedure Reset_Cunit_Boolean_Restrictions
is
1065 for J
in Cunit_Boolean_Restrictions
loop
1066 Restrictions
.Set
(J
) := False;
1068 end Reset_Cunit_Boolean_Restrictions
;
1070 -----------------------------------------------
1071 -- Restore_Config_Cunit_Boolean_Restrictions --
1072 -----------------------------------------------
1074 procedure Restore_Config_Cunit_Boolean_Restrictions
is
1076 Cunit_Boolean_Restrictions_Restore
(Config_Cunit_Boolean_Restrictions
);
1077 end Restore_Config_Cunit_Boolean_Restrictions
;
1079 ------------------------
1080 -- Restricted_Profile --
1081 ------------------------
1083 function Restricted_Profile
return Boolean is
1085 if Restricted_Profile_Cached
then
1086 return Restricted_Profile_Result
;
1089 Restricted_Profile_Result
:= True;
1090 Restricted_Profile_Cached
:= True;
1093 R
: Restriction_Flags
renames Profile_Info
(Restricted
).Set
;
1094 V
: Restriction_Values
renames Profile_Info
(Restricted
).Value
;
1096 for J
in R
'Range loop
1098 and then (Restrictions
.Set
(J
) = False
1099 or else Restriction_Warnings
(J
)
1101 (J
in All_Parameter_Restrictions
1102 and then Restrictions
.Value
(J
) > V
(J
)))
1104 Restricted_Profile_Result
:= False;
1109 return Restricted_Profile_Result
;
1112 end Restricted_Profile
;
1114 ------------------------
1115 -- Restriction_Active --
1116 ------------------------
1118 function Restriction_Active
(R
: All_Restrictions
) return Boolean is
1120 return Restrictions
.Set
(R
) and then not Restriction_Warnings
(R
);
1121 end Restriction_Active
;
1123 --------------------------------
1124 -- Restriction_Check_Required --
1125 --------------------------------
1127 function Restriction_Check_Required
(R
: All_Restrictions
) return Boolean is
1129 return Restrictions
.Set
(R
);
1130 end Restriction_Check_Required
;
1132 ---------------------
1133 -- Restriction_Msg --
1134 ---------------------
1136 procedure Restriction_Msg
(R
: Restriction_Id
; N
: Node_Id
) is
1137 Msg
: String (1 .. 100);
1140 procedure Add_Char
(C
: Character);
1141 -- Append given character to Msg, bumping Len
1143 procedure Add_Str
(S
: String);
1144 -- Append given string to Msg, bumping Len appropriately
1146 procedure Id_Case
(S
: String; Quotes
: Boolean := True);
1147 -- Given a string S, case it according to current identifier casing,
1148 -- except for SPARK_05 (an acronym) which is set all upper case, and
1149 -- store in Error_Msg_String. Then append `~` to the message buffer
1150 -- to output the string unchanged surrounded in quotes. The quotes
1151 -- are suppressed if Quotes = False.
1157 procedure Add_Char
(C
: Character) is
1167 procedure Add_Str
(S
: String) is
1169 Msg
(Len
+ 1 .. Len
+ S
'Length) := S
;
1170 Len
:= Len
+ S
'Length;
1177 procedure Id_Case
(S
: String; Quotes
: Boolean := True) is
1179 Name_Buffer
(1 .. S
'Last) := S
;
1180 Name_Len
:= S
'Length;
1182 if R
= SPARK_05
then
1185 Set_Casing
(Identifier_Casing
(Get_Source_File_Index
(Sloc
(N
))));
1188 Error_Msg_Strlen
:= Name_Len
;
1189 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
1198 -- Start of processing for Restriction_Msg
1201 -- Set warning message if warning
1203 if Restriction_Warnings
(R
) then
1206 -- If real violation (not warning), then mark it as non-serious unless
1207 -- it is a violation of No_Finalization in which case we leave it as a
1208 -- serious message, since otherwise we get crashes during attempts to
1209 -- expand stuff that is not properly formed due to assumptions made
1210 -- about no finalization being present.
1212 elsif R
/= No_Finalization
then
1216 Error_Msg_Sloc
:= Restrictions_Loc
(R
);
1218 -- Set main message, adding implicit if no source location
1220 if Error_Msg_Sloc
> No_Location
1221 or else Error_Msg_Sloc
= System_Location
1223 Add_Str
("violation of restriction ");
1225 Add_Str
("violation of implicit restriction ");
1226 Error_Msg_Sloc
:= No_Location
;
1229 -- Case of parameterized restriction
1231 if R
in All_Parameter_Restrictions
then
1233 Id_Case
(Restriction_Id
'Image (R
), Quotes
=> False);
1235 Error_Msg_Uint_1
:= UI_From_Int
(Int
(Restrictions
.Value
(R
)));
1237 -- Case of boolean restriction
1240 Id_Case
(Restriction_Id
'Image (R
));
1243 -- Case of no secondary profile continuation message
1245 if Restriction_Profile_Name
(R
) = No_Profile
then
1246 if Error_Msg_Sloc
/= No_Location
then
1251 Error_Msg_N
(Msg
(1 .. Len
), N
);
1253 -- Case of secondary profile continuation message present
1257 Error_Msg_N
(Msg
(1 .. Len
), N
);
1262 -- Set as warning if warning case
1264 if Restriction_Warnings
(R
) then
1270 Add_Str
("from profile ");
1271 Id_Case
(Profile_Name
'Image (Restriction_Profile_Name
(R
)));
1273 -- Add location if we have one
1275 if Error_Msg_Sloc
/= No_Location
then
1279 -- Output unconditional message and we are done
1282 Error_Msg_N
(Msg
(1 .. Len
), N
);
1284 end Restriction_Msg
;
1290 function Same_Entity
(E1
, E2
: Node_Id
) return Boolean is
1292 if Nkind_In
(E1
, N_Identifier
, N_Operator_Symbol
)
1294 Nkind_In
(E2
, N_Identifier
, N_Operator_Symbol
)
1296 return Chars
(E1
) = Chars
(E2
);
1298 elsif Nkind_In
(E1
, N_Selected_Component
, N_Expanded_Name
)
1300 Nkind_In
(E2
, N_Selected_Component
, N_Expanded_Name
)
1302 return Same_Unit
(Prefix
(E1
), Prefix
(E2
))
1304 Same_Unit
(Selector_Name
(E1
), Selector_Name
(E2
));
1314 function Same_Unit
(U1
, U2
: Node_Id
) return Boolean is
1316 if Nkind
(U1
) = N_Identifier
and then Nkind
(U2
) = N_Identifier
then
1317 return Chars
(U1
) = Chars
(U2
);
1319 elsif Nkind_In
(U1
, N_Selected_Component
, N_Expanded_Name
)
1321 Nkind_In
(U2
, N_Selected_Component
, N_Expanded_Name
)
1323 return Same_Unit
(Prefix
(U1
), Prefix
(U2
))
1325 Same_Unit
(Selector_Name
(U1
), Selector_Name
(U2
));
1331 --------------------------------------------
1332 -- Save_Config_Cunit_Boolean_Restrictions --
1333 --------------------------------------------
1335 procedure Save_Config_Cunit_Boolean_Restrictions
is
1337 Config_Cunit_Boolean_Restrictions
:= Cunit_Boolean_Restrictions_Save
;
1338 end Save_Config_Cunit_Boolean_Restrictions
;
1340 ------------------------------
1341 -- Set_Hidden_Part_In_SPARK --
1342 ------------------------------
1344 procedure Set_Hidden_Part_In_SPARK
(Loc1
, Loc2
: Source_Ptr
) is
1346 SPARK_Hides
.Increment_Last
;
1347 SPARK_Hides
.Table
(SPARK_Hides
.Last
).Start
:= Loc1
;
1348 SPARK_Hides
.Table
(SPARK_Hides
.Last
).Stop
:= Loc2
;
1349 end Set_Hidden_Part_In_SPARK
;
1351 ------------------------------
1352 -- Set_Profile_Restrictions --
1353 ------------------------------
1355 procedure Set_Profile_Restrictions
1360 R
: Restriction_Flags
renames Profile_Info
(P
).Set
;
1361 V
: Restriction_Values
renames Profile_Info
(P
).Value
;
1364 for J
in R
'Range loop
1367 Already_Restricted
: constant Boolean := Restriction_Active
(J
);
1370 -- Set the restriction
1372 if J
in All_Boolean_Restrictions
then
1373 Set_Restriction
(J
, N
);
1375 Set_Restriction
(J
, N
, V
(J
));
1378 -- Record that this came from a Profile[_Warnings] restriction
1380 Restriction_Profile_Name
(J
) := P
;
1382 -- Set warning flag, except that we do not set the warning
1383 -- flag if the restriction was already active and this is
1384 -- the warning case. That avoids a warning overriding a real
1385 -- restriction, which should never happen.
1387 if not (Warn
and Already_Restricted
) then
1388 Restriction_Warnings
(J
) := Warn
;
1393 end Set_Profile_Restrictions
;
1395 ---------------------
1396 -- Set_Restriction --
1397 ---------------------
1399 -- Case of Boolean restriction
1401 procedure Set_Restriction
1402 (R
: All_Boolean_Restrictions
;
1406 Restrictions
.Set
(R
) := True;
1408 if Restricted_Profile_Cached
and Restricted_Profile_Result
then
1411 Restricted_Profile_Cached
:= False;
1414 -- Set location, but preserve location of system restriction for nice
1415 -- error msg with run time name.
1417 if Restrictions_Loc
(R
) /= System_Location
then
1418 Restrictions_Loc
(R
) := Sloc
(N
);
1421 -- Note restriction came from restriction pragma, not profile
1423 Restriction_Profile_Name
(R
) := No_Profile
;
1425 -- Record the restriction if we are in the main unit, or in the extended
1426 -- main unit. The reason that we test separately for Main_Unit is that
1427 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1428 -- gnat.adc do not appear to be in the extended main source unit (they
1429 -- probably should do ???)
1431 if Current_Sem_Unit
= Main_Unit
1432 or else In_Extended_Main_Source_Unit
(N
)
1434 if not Restriction_Warnings
(R
) then
1435 Main_Restrictions
.Set
(R
) := True;
1438 end Set_Restriction
;
1440 -- Case of parameter restriction
1442 procedure Set_Restriction
1443 (R
: All_Parameter_Restrictions
;
1448 if Restricted_Profile_Cached
and Restricted_Profile_Result
then
1451 Restricted_Profile_Cached
:= False;
1454 if Restrictions
.Set
(R
) then
1455 if V
< Restrictions
.Value
(R
) then
1456 Restrictions
.Value
(R
) := V
;
1457 Restrictions_Loc
(R
) := Sloc
(N
);
1461 Restrictions
.Set
(R
) := True;
1462 Restrictions
.Value
(R
) := V
;
1463 Restrictions_Loc
(R
) := Sloc
(N
);
1466 -- Record the restriction if we are in the main unit, or in the extended
1467 -- main unit. The reason that we test separately for Main_Unit is that
1468 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
1469 -- gnat.adc do not appear to be the extended main source unit (they
1470 -- probably should do ???)
1472 if Current_Sem_Unit
= Main_Unit
1473 or else In_Extended_Main_Source_Unit
(N
)
1475 if Main_Restrictions
.Set
(R
) then
1476 if V
< Main_Restrictions
.Value
(R
) then
1477 Main_Restrictions
.Value
(R
) := V
;
1480 elsif not Restriction_Warnings
(R
) then
1481 Main_Restrictions
.Set
(R
) := True;
1482 Main_Restrictions
.Value
(R
) := V
;
1486 -- Note restriction came from restriction pragma, not profile
1488 Restriction_Profile_Name
(R
) := No_Profile
;
1489 end Set_Restriction
;
1491 -----------------------------------
1492 -- Set_Restriction_No_Dependence --
1493 -----------------------------------
1495 procedure Set_Restriction_No_Dependence
1498 Profile
: Profile_Name
:= No_Profile
)
1501 -- Loop to check for duplicate entry
1503 for J
in No_Dependences
.First
.. No_Dependences
.Last
loop
1505 -- Case of entry already in table
1507 if Same_Unit
(Unit
, No_Dependences
.Table
(J
).Unit
) then
1509 -- Error has precedence over warning
1512 No_Dependences
.Table
(J
).Warn
:= False;
1519 -- Entry is not currently in table
1521 No_Dependences
.Append
((Unit
, Warn
, Profile
));
1522 end Set_Restriction_No_Dependence
;
1524 --------------------------------------
1525 -- Set_Restriction_No_Use_Of_Entity --
1526 --------------------------------------
1528 procedure Set_Restriction_No_Use_Of_Entity
1531 Profile
: Profile_Name
:= No_Profile
)
1536 -- Loop to check for duplicate entry
1538 for J
in No_Use_Of_Entity
.First
.. No_Use_Of_Entity
.Last
loop
1540 -- Case of entry already in table
1542 if Same_Entity
(Entity
, No_Use_Of_Entity
.Table
(J
).Entity
) then
1544 -- Error has precedence over warning
1547 No_Use_Of_Entity
.Table
(J
).Warn
:= False;
1554 -- Entry is not currently in table
1556 No_Use_Of_Entity
.Append
((Entity
, Warn
, Profile
));
1558 -- Now we need to find the direct name and set Boolean2 flag
1560 if Nkind_In
(Entity
, N_Identifier
, N_Operator_Symbol
) then
1564 pragma Assert
(Nkind
(Entity
) = N_Selected_Component
);
1565 Nam
:= Selector_Name
(Entity
);
1566 pragma Assert
(Nkind_In
(Nam
, N_Identifier
, N_Operator_Symbol
));
1569 Set_Name_Table_Boolean2
(Chars
(Nam
), True);
1570 end Set_Restriction_No_Use_Of_Entity
;
1572 ------------------------------------------------
1573 -- Set_Restriction_No_Specification_Of_Aspect --
1574 ------------------------------------------------
1576 procedure Set_Restriction_No_Specification_Of_Aspect
1580 A_Id
: constant Aspect_Id_Exclude_No_Aspect
:= Get_Aspect_Id
(Chars
(N
));
1583 No_Specification_Of_Aspects
(A_Id
) := Sloc
(N
);
1585 if Warning
= False then
1586 No_Specification_Of_Aspect_Warning
(A_Id
) := False;
1589 No_Specification_Of_Aspect_Set
:= True;
1590 end Set_Restriction_No_Specification_Of_Aspect
;
1592 procedure Set_Restriction_No_Specification_Of_Aspect
(A_Id
: Aspect_Id
) is
1594 No_Specification_Of_Aspect_Set
:= True;
1595 No_Specification_Of_Aspects
(A_Id
) := System_Location
;
1596 No_Specification_Of_Aspect_Warning
(A_Id
) := False;
1597 end Set_Restriction_No_Specification_Of_Aspect
;
1599 -----------------------------------------
1600 -- Set_Restriction_No_Use_Of_Attribute --
1601 -----------------------------------------
1603 procedure Set_Restriction_No_Use_Of_Attribute
1607 A_Id
: constant Attribute_Id
:= Get_Attribute_Id
(Chars
(N
));
1610 No_Use_Of_Attribute_Set
:= True;
1611 No_Use_Of_Attribute
(A_Id
) := Sloc
(N
);
1613 if Warning
= False then
1614 No_Use_Of_Attribute_Warning
(A_Id
) := False;
1616 end Set_Restriction_No_Use_Of_Attribute
;
1618 procedure Set_Restriction_No_Use_Of_Attribute
(A_Id
: Attribute_Id
) is
1620 No_Use_Of_Attribute_Set
:= True;
1621 No_Use_Of_Attribute
(A_Id
) := System_Location
;
1622 No_Use_Of_Attribute_Warning
(A_Id
) := False;
1623 end Set_Restriction_No_Use_Of_Attribute
;
1625 --------------------------------------
1626 -- Set_Restriction_No_Use_Of_Pragma --
1627 --------------------------------------
1629 procedure Set_Restriction_No_Use_Of_Pragma
1633 A_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Chars
(N
));
1636 No_Use_Of_Pragma_Set
:= True;
1637 No_Use_Of_Pragma
(A_Id
) := Sloc
(N
);
1639 if Warning
= False then
1640 No_Use_Of_Pragma_Warning
(A_Id
) := False;
1642 end Set_Restriction_No_Use_Of_Pragma
;
1644 procedure Set_Restriction_No_Use_Of_Pragma
(A_Id
: Pragma_Id
) is
1646 No_Use_Of_Pragma_Set
:= True;
1647 No_Use_Of_Pragma
(A_Id
) := System_Location
;
1648 No_Use_Of_Pragma_Warning
(A_Id
) := False;
1649 end Set_Restriction_No_Use_Of_Pragma
;
1651 --------------------------------
1652 -- Check_SPARK_05_Restriction --
1653 --------------------------------
1655 procedure Check_SPARK_05_Restriction
1658 Force
: Boolean := False)
1660 Msg_Issued
: Boolean;
1661 Save_Error_Msg_Sloc
: Source_Ptr
;
1662 Onode
: constant Node_Id
:= Original_Node
(N
);
1665 -- Output message if Force set
1669 -- Or if this node comes from source
1671 or else Comes_From_Source
(N
)
1673 -- Or if this is a range node which rewrites a range attribute and
1674 -- the range attribute comes from source.
1676 or else (Nkind
(N
) = N_Range
1677 and then Nkind
(Onode
) = N_Attribute_Reference
1678 and then Attribute_Name
(Onode
) = Name_Range
1679 and then Comes_From_Source
(Onode
))
1681 -- Or this is an expression that does not come from source, which is
1682 -- a rewriting of an expression that does come from source.
1684 or else (Nkind
(N
) in N_Subexpr
and then Comes_From_Source
(Onode
))
1686 if Restriction_Check_Required
(SPARK_05
)
1687 and then Is_In_Hidden_Part_In_SPARK
(Sloc
(N
))
1692 -- Since the call to Restriction_Msg from Check_Restriction may set
1693 -- Error_Msg_Sloc to the location of the pragma restriction, save and
1694 -- restore the previous value of the global variable around the call.
1696 Save_Error_Msg_Sloc
:= Error_Msg_Sloc
;
1697 Check_Restriction
(Msg_Issued
, SPARK_05
, First_Node
(N
));
1698 Error_Msg_Sloc
:= Save_Error_Msg_Sloc
;
1701 Error_Msg_F
("\\| " & Msg
, N
);
1704 end Check_SPARK_05_Restriction
;
1706 procedure Check_SPARK_05_Restriction
(Msg1
, Msg2
: String; N
: Node_Id
) is
1707 Msg_Issued
: Boolean;
1708 Save_Error_Msg_Sloc
: Source_Ptr
;
1711 pragma Assert
(Msg2
'Length /= 0 and then Msg2
(Msg2
'First) = '\');
1713 if Comes_From_Source
(Original_Node
(N
)) then
1714 if Restriction_Check_Required
(SPARK_05
)
1715 and then Is_In_Hidden_Part_In_SPARK
(Sloc
(N
))
1720 -- Since the call to Restriction_Msg from Check_Restriction may set
1721 -- Error_Msg_Sloc to the location of the pragma restriction, save and
1722 -- restore the previous value of the global variable around the call.
1724 Save_Error_Msg_Sloc
:= Error_Msg_Sloc
;
1725 Check_Restriction
(Msg_Issued
, SPARK_05
, First_Node
(N
));
1726 Error_Msg_Sloc
:= Save_Error_Msg_Sloc
;
1729 Error_Msg_F
("\\| " & Msg1
, N
);
1730 Error_Msg_F
(Msg2
, N
);
1733 end Check_SPARK_05_Restriction
;
1735 ----------------------------------
1736 -- Suppress_Restriction_Message --
1737 ----------------------------------
1739 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean is
1741 -- We only output messages for the extended main source unit
1743 if In_Extended_Main_Source_Unit
(N
) then
1746 -- If loaded by rtsfind, then suppress message
1748 elsif Sloc
(N
) <= No_Location
then
1751 -- Otherwise suppress message if internal file
1754 return Is_Internal_File_Name
(Unit_File_Name
(Get_Source_Unit
(N
)));
1756 end Suppress_Restriction_Message
;
1758 ---------------------
1759 -- Tasking_Allowed --
1760 ---------------------
1762 function Tasking_Allowed
return Boolean is
1764 return not Restrictions
.Set
(No_Tasking
)
1765 and then (not Restrictions
.Set
(Max_Tasks
)
1766 or else Restrictions
.Value
(Max_Tasks
) > 0)
1767 and then not No_Run_Time_Mode
;
1768 end Tasking_Allowed
;