1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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 Errout
; use Errout
;
29 with Debug
; use Debug
;
30 with Fname
; use Fname
;
31 with Fname
.UF
; use Fname
.UF
;
34 with Sinfo
; use Sinfo
;
35 with Sinput
; use Sinput
;
36 with Snames
; use Snames
;
37 with Uname
; use Uname
;
39 package body Restrict
is
41 Restricted_Profile_Result
: Boolean := False;
42 -- This switch memoizes the result of Restricted_Profile function
43 -- calls for improved efficiency. Its setting is valid only if
44 -- Restricted_Profile_Cached is True. Note that if this switch
45 -- is ever set True, it need never be turned off again.
47 Restricted_Profile_Cached
: Boolean := False;
48 -- This flag is set to True if the Restricted_Profile_Result
49 -- contains the correct cached result of Restricted_Profile calls.
51 -----------------------
52 -- Local Subprograms --
53 -----------------------
55 procedure Restriction_Msg
(Msg
: String; R
: String; N
: Node_Id
);
56 -- Output error message at node N with given text, replacing the
57 -- '%' in the message with the name of the restriction given as R,
58 -- cased according to the current identifier casing. We do not use
59 -- the normal insertion mechanism, since this requires an entry
60 -- in the Names table, and this table will be locked if we are
61 -- generating a message from gigi.
63 function Same_Unit
(U1
, U2
: Node_Id
) return Boolean;
64 -- Returns True iff U1 and U2 represent the same library unit. Used for
65 -- handling of No_Dependence => Unit restriction case.
67 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean;
68 -- N is the node for a possible restriction violation message, but
69 -- the message is to be suppressed if this is an internal file and
70 -- this file is not the main unit.
76 function Abort_Allowed
return Boolean is
78 if Restrictions
.Set
(No_Abort_Statements
)
79 and then Restrictions
.Set
(Max_Asynchronous_Select_Nesting
)
80 and then Restrictions
.Value
(Max_Asynchronous_Select_Nesting
) = 0
88 -------------------------
89 -- Check_Compiler_Unit --
90 -------------------------
92 procedure Check_Compiler_Unit
(N
: Node_Id
) is
94 if Is_Compiler_Unit
(Get_Source_Unit
(N
)) then
95 Error_Msg_N
("use of construct not allowed in compiler", N
);
97 end Check_Compiler_Unit
;
99 ------------------------------------
100 -- Check_Elaboration_Code_Allowed --
101 ------------------------------------
103 procedure Check_Elaboration_Code_Allowed
(N
: Node_Id
) is
105 Check_Restriction
(No_Elaboration_Code
, N
);
106 end Check_Elaboration_Code_Allowed
;
108 -----------------------------------------
109 -- Check_Implicit_Dynamic_Code_Allowed --
110 -----------------------------------------
112 procedure Check_Implicit_Dynamic_Code_Allowed
(N
: Node_Id
) is
114 Check_Restriction
(No_Implicit_Dynamic_Code
, N
);
115 end Check_Implicit_Dynamic_Code_Allowed
;
117 ----------------------------------
118 -- Check_No_Implicit_Heap_Alloc --
119 ----------------------------------
121 procedure Check_No_Implicit_Heap_Alloc
(N
: Node_Id
) is
123 Check_Restriction
(No_Implicit_Heap_Allocations
, N
);
124 end Check_No_Implicit_Heap_Alloc
;
126 ---------------------------
127 -- Check_Restricted_Unit --
128 ---------------------------
130 procedure Check_Restricted_Unit
(U
: Unit_Name_Type
; N
: Node_Id
) is
132 if Suppress_Restriction_Message
(N
) then
135 elsif Is_Spec_Name
(U
) then
137 Fnam
: constant File_Name_Type
:=
138 Get_File_Name
(U
, Subunit
=> False);
143 Get_Name_String
(Fnam
);
145 -- Nothing to do if name not at least 5 characters long ending
146 -- in .ads or .adb extension, which we strip.
149 or else (Name_Buffer
(Name_Len
- 3 .. Name_Len
) /= ".ads"
151 Name_Buffer
(Name_Len
- 4 .. Name_Len
) /= ".adb")
156 -- Strip extension and pad to eight characters
158 Name_Len
:= Name_Len
- 4;
159 while Name_Len
< 8 loop
160 Name_Len
:= Name_Len
+ 1;
161 Name_Buffer
(Name_Len
) := ' ';
164 -- If predefined unit, check the list of restricted units
166 if Is_Predefined_File_Name
(Fnam
) then
167 for J
in Unit_Array
'Range loop
169 and then Name_Buffer
(1 .. 8) = Unit_Array
(J
).Filenm
171 Check_Restriction
(Unit_Array
(J
).Res_Id
, N
);
175 -- If not predefined unit, then one special check still
176 -- remains. GNAT.Current_Exception is not allowed if we have
177 -- restriction No_Exception_Propagation active.
180 if Name_Buffer
(1 .. 8) = "g-curexc" then
181 Check_Restriction
(No_Exception_Propagation
, N
);
186 end Check_Restricted_Unit
;
188 -----------------------
189 -- Check_Restriction --
190 -----------------------
192 procedure Check_Restriction
195 V
: Uint
:= Uint_Minus_1
)
197 Rimage
: constant String := Restriction_Id
'Image (R
);
200 -- V converted to integer form. If V is greater than Integer'Last,
201 -- it is reset to minus 1 (unknown value).
203 procedure Update_Restrictions
(Info
: in out Restrictions_Info
);
204 -- Update violation information in Info.Violated and Info.Count
206 -------------------------
207 -- Update_Restrictions --
208 -------------------------
210 procedure Update_Restrictions
(Info
: in out Restrictions_Info
) is
212 -- If not violated, set as violated now
214 if not Info
.Violated
(R
) then
215 Info
.Violated
(R
) := True;
217 if R
in All_Parameter_Restrictions
then
219 Info
.Unknown
(R
) := True;
222 Info
.Count
(R
) := VV
;
226 -- Otherwise if violated already and a parameter restriction,
227 -- update count by maximizing or summing depending on restriction.
229 elsif R
in All_Parameter_Restrictions
then
231 -- If new value is unknown, result is unknown
234 Info
.Unknown
(R
) := True;
236 -- If checked by maximization, do maximization
238 elsif R
in Checked_Max_Parameter_Restrictions
then
239 Info
.Count
(R
) := Integer'Max (Info
.Count
(R
), VV
);
241 -- If checked by adding, do add, checking for overflow
243 elsif R
in Checked_Add_Parameter_Restrictions
then
245 pragma Unsuppress
(Overflow_Check
);
247 Info
.Count
(R
) := Info
.Count
(R
) + VV
;
249 when Constraint_Error
=>
250 Info
.Count
(R
) := Integer'Last;
251 Info
.Unknown
(R
) := True;
254 -- Should not be able to come here, known counts should only
255 -- occur for restrictions that are Checked_max or Checked_Sum.
261 end Update_Restrictions
;
263 -- Start of processing for Check_Restriction
266 if UI_Is_In_Int_Range
(V
) then
267 VV
:= Integer (UI_To_Int
(V
));
272 -- Count can only be specified in the checked val parameter case
274 pragma Assert
(VV
< 0 or else R
in Checked_Val_Parameter_Restrictions
);
276 -- Nothing to do if value of zero specified for parameter restriction
282 -- Update current restrictions
284 Update_Restrictions
(Restrictions
);
286 -- If in main extended unit, update main restrictions as well
288 if Current_Sem_Unit
= Main_Unit
289 or else In_Extended_Main_Source_Unit
(N
)
291 Update_Restrictions
(Main_Restrictions
);
294 -- Nothing to do if restriction message suppressed
296 if Suppress_Restriction_Message
(N
) then
299 -- If restriction not set, nothing to do
301 elsif not Restrictions
.Set
(R
) then
304 -- Here if restriction set, check for violation (either this is a
305 -- Boolean restriction, or a parameter restriction with a value of
306 -- zero and an unknown count, or a parameter restriction with a
307 -- known value that exceeds the restriction count).
309 elsif R
in All_Boolean_Restrictions
310 or else (Restrictions
.Unknown
(R
)
311 and then Restrictions
.Value
(R
) = 0)
312 or else Restrictions
.Count
(R
) > Restrictions
.Value
(R
)
314 Error_Msg_Sloc
:= Restrictions_Loc
(R
);
316 -- If we have a location for the Restrictions pragma, output it
318 if Error_Msg_Sloc
> No_Location
319 or else Error_Msg_Sloc
= System_Location
321 if Restriction_Warnings
(R
) then
322 Restriction_Msg
("|violation of restriction %#?", Rimage
, N
);
324 -- Normally a restriction violation is a non-serious error,
325 -- but we treat violation of No_Finalization as a serious
326 -- error, since we want to turn off expansion in this case,
327 -- expansion just causes too many cascaded errors.
329 if R
= No_Finalization
then
330 Restriction_Msg
("violation of restriction %#", Rimage
, N
);
332 Restriction_Msg
("|violation of restriction %#", Rimage
, N
);
336 -- Otherwise we have the case of an implicit restriction
337 -- (e.g. a restriction implicitly set by another pragma)
341 ("|violation of implicit restriction %", Rimage
, N
);
344 end Check_Restriction
;
346 -------------------------------------
347 -- Check_Restriction_No_Dependence --
348 -------------------------------------
350 procedure Check_Restriction_No_Dependence
(U
: Node_Id
; Err
: Node_Id
) is
354 for J
in No_Dependence
.First
.. No_Dependence
.Last
loop
355 DU
:= No_Dependence
.Table
(J
).Unit
;
357 if Same_Unit
(U
, DU
) then
358 Error_Msg_Sloc
:= Sloc
(DU
);
359 Error_Msg_Node_1
:= DU
;
361 if No_Dependence
.Table
(J
).Warn
then
363 ("?violation of restriction `No_Dependence '='> &`#",
367 ("|violation of restriction `No_Dependence '='> &`#",
374 end Check_Restriction_No_Dependence
;
376 ----------------------------------------
377 -- Cunit_Boolean_Restrictions_Restore --
378 ----------------------------------------
380 procedure Cunit_Boolean_Restrictions_Restore
381 (R
: Save_Cunit_Boolean_Restrictions
)
384 for J
in Cunit_Boolean_Restrictions
loop
385 Restrictions
.Set
(J
) := R
(J
);
387 end Cunit_Boolean_Restrictions_Restore
;
389 -------------------------------------
390 -- Cunit_Boolean_Restrictions_Save --
391 -------------------------------------
393 function Cunit_Boolean_Restrictions_Save
394 return Save_Cunit_Boolean_Restrictions
396 R
: Save_Cunit_Boolean_Restrictions
;
399 for J
in Cunit_Boolean_Restrictions
loop
400 R
(J
) := Restrictions
.Set
(J
);
401 Restrictions
.Set
(J
) := False;
405 end Cunit_Boolean_Restrictions_Save
;
407 ------------------------
408 -- Get_Restriction_Id --
409 ------------------------
411 function Get_Restriction_Id
412 (N
: Name_Id
) return Restriction_Id
416 Set_Casing
(All_Upper_Case
);
418 for J
in All_Restrictions
loop
420 S
: constant String := Restriction_Id
'Image (J
);
422 if S
= Name_Buffer
(1 .. Name_Len
) then
428 return Not_A_Restriction_Id
;
429 end Get_Restriction_Id
;
431 -------------------------------
432 -- No_Exception_Handlers_Set --
433 -------------------------------
435 function No_Exception_Handlers_Set
return Boolean is
437 return (No_Run_Time_Mode
or else Configurable_Run_Time_Mode
)
438 and then (Restrictions
.Set
(No_Exception_Handlers
)
440 Restrictions
.Set
(No_Exception_Propagation
));
441 end No_Exception_Handlers_Set
;
443 -------------------------------------
444 -- No_Exception_Propagation_Active --
445 -------------------------------------
447 function No_Exception_Propagation_Active
return Boolean is
449 return (No_Run_Time_Mode
450 or else Configurable_Run_Time_Mode
451 or else Debug_Flag_Dot_G
)
452 and then Restriction_Active
(No_Exception_Propagation
);
453 end No_Exception_Propagation_Active
;
455 ----------------------------------
456 -- Process_Restriction_Synonyms --
457 ----------------------------------
459 -- Note: body of this function must be coordinated with list of
460 -- renaming declarations in System.Rident.
462 function Process_Restriction_Synonyms
(N
: Node_Id
) return Name_Id
464 Old_Name
: constant Name_Id
:= Chars
(N
);
469 when Name_Boolean_Entry_Barriers
=>
470 New_Name
:= Name_Simple_Barriers
;
472 when Name_Max_Entry_Queue_Depth
=>
473 New_Name
:= Name_Max_Entry_Queue_Length
;
475 when Name_No_Dynamic_Interrupts
=>
476 New_Name
:= Name_No_Dynamic_Attachment
;
478 when Name_No_Requeue
=>
479 New_Name
:= Name_No_Requeue_Statements
;
481 when Name_No_Task_Attributes
=>
482 New_Name
:= Name_No_Task_Attributes_Package
;
488 if Warn_On_Obsolescent_Feature
then
489 Error_Msg_Name_1
:= Old_Name
;
490 Error_Msg_N
("restriction identifier % is obsolescent?", N
);
491 Error_Msg_Name_1
:= New_Name
;
492 Error_Msg_N
("|use restriction identifier % instead", N
);
496 end Process_Restriction_Synonyms
;
498 ------------------------
499 -- Restricted_Profile --
500 ------------------------
502 function Restricted_Profile
return Boolean is
504 if Restricted_Profile_Cached
then
505 return Restricted_Profile_Result
;
508 Restricted_Profile_Result
:= True;
509 Restricted_Profile_Cached
:= True;
512 R
: Restriction_Flags
renames Profile_Info
(Restricted
).Set
;
513 V
: Restriction_Values
renames Profile_Info
(Restricted
).Value
;
515 for J
in R
'Range loop
517 and then (Restrictions
.Set
(J
) = False
518 or else Restriction_Warnings
(J
)
520 (J
in All_Parameter_Restrictions
521 and then Restrictions
.Value
(J
) > V
(J
)))
523 Restricted_Profile_Result
:= False;
528 return Restricted_Profile_Result
;
531 end Restricted_Profile
;
533 ------------------------
534 -- Restriction_Active --
535 ------------------------
537 function Restriction_Active
(R
: All_Restrictions
) return Boolean is
539 return Restrictions
.Set
(R
) and then not Restriction_Warnings
(R
);
540 end Restriction_Active
;
542 ---------------------
543 -- Restriction_Msg --
544 ---------------------
546 procedure Restriction_Msg
(Msg
: String; R
: String; N
: Node_Id
) is
547 B
: String (1 .. Msg
'Length + 2 * R
'Length + 1);
551 Name_Buffer
(1 .. R
'Last) := R
;
552 Name_Len
:= R
'Length;
553 Set_Casing
(Identifier_Casing
(Get_Source_File_Index
(Sloc
(N
))));
556 for J
in Msg
'Range loop
557 if Msg
(J
) = '%' then
561 -- Put characters of image in message, quoting upper case letters
563 for J
in 1 .. Name_Len
loop
564 if Name_Buffer
(J
) in 'A' .. 'Z' then
570 B
(P
) := Name_Buffer
(J
);
582 Error_Msg_N
(B
(1 .. P
), N
);
589 function Same_Unit
(U1
, U2
: Node_Id
) return Boolean is
591 if Nkind
(U1
) = N_Identifier
then
592 return Nkind
(U2
) = N_Identifier
and then Chars
(U1
) = Chars
(U2
);
594 elsif Nkind
(U2
) = N_Identifier
then
597 elsif (Nkind
(U1
) = N_Selected_Component
598 or else Nkind
(U1
) = N_Expanded_Name
)
600 (Nkind
(U2
) = N_Selected_Component
601 or else Nkind
(U2
) = N_Expanded_Name
)
603 return Same_Unit
(Prefix
(U1
), Prefix
(U2
))
604 and then Same_Unit
(Selector_Name
(U1
), Selector_Name
(U2
));
610 ------------------------------
611 -- Set_Profile_Restrictions --
612 ------------------------------
614 procedure Set_Profile_Restrictions
619 R
: Restriction_Flags
renames Profile_Info
(P
).Set
;
620 V
: Restriction_Values
renames Profile_Info
(P
).Value
;
623 for J
in R
'Range loop
626 Already_Restricted
: constant Boolean := Restriction_Active
(J
);
629 -- Set the restriction
631 if J
in All_Boolean_Restrictions
then
632 Set_Restriction
(J
, N
);
634 Set_Restriction
(J
, N
, V
(J
));
637 -- Set warning flag, except that we do not set the warning
638 -- flag if the restriction was already active and this is
639 -- the warning case. That avoids a warning overriding a real
640 -- restriction, which should never happen.
642 if not (Warn
and Already_Restricted
) then
643 Restriction_Warnings
(J
) := Warn
;
648 end Set_Profile_Restrictions
;
650 ---------------------
651 -- Set_Restriction --
652 ---------------------
654 -- Case of Boolean restriction
656 procedure Set_Restriction
657 (R
: All_Boolean_Restrictions
;
661 -- Restriction No_Elaboration_Code must be enforced on a unit by unit
662 -- basis. Hence, we avoid setting the restriction when processing an
663 -- unit which is not the main one being compiled (or its corresponding
664 -- spec). It can happen, for example, when processing an inlined body
665 -- (the package containing the inlined subprogram is analyzed,
666 -- including its pragma Restrictions).
668 -- This seems like a very nasty kludge??? This is not the only per unit
669 -- restriction why is this treated specially ???
671 if R
= No_Elaboration_Code
672 and then Current_Sem_Unit
/= Main_Unit
673 and then Cunit
(Current_Sem_Unit
) /= Library_Unit
(Cunit
(Main_Unit
))
678 Restrictions
.Set
(R
) := True;
680 if Restricted_Profile_Cached
and Restricted_Profile_Result
then
683 Restricted_Profile_Cached
:= False;
686 -- Set location, but preserve location of system
687 -- restriction for nice error msg with run time name
689 if Restrictions_Loc
(R
) /= System_Location
then
690 Restrictions_Loc
(R
) := Sloc
(N
);
693 -- Record the restriction if we are in the main unit, or in the extended
694 -- main unit. The reason that we test separately for Main_Unit is that
695 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
696 -- gnat.adc do not appear to be in the extended main source unit (they
697 -- probably should do ???)
699 if Current_Sem_Unit
= Main_Unit
700 or else In_Extended_Main_Source_Unit
(N
)
702 if not Restriction_Warnings
(R
) then
703 Main_Restrictions
.Set
(R
) := True;
708 -- Case of parameter restriction
710 procedure Set_Restriction
711 (R
: All_Parameter_Restrictions
;
716 if Restricted_Profile_Cached
and Restricted_Profile_Result
then
719 Restricted_Profile_Cached
:= False;
722 if Restrictions
.Set
(R
) then
723 if V
< Restrictions
.Value
(R
) then
724 Restrictions
.Value
(R
) := V
;
725 Restrictions_Loc
(R
) := Sloc
(N
);
729 Restrictions
.Set
(R
) := True;
730 Restrictions
.Value
(R
) := V
;
731 Restrictions_Loc
(R
) := Sloc
(N
);
734 -- Record the restriction if we are in the main unit,
735 -- or in the extended main unit. The reason that we
736 -- test separately for Main_Unit is that gnat.adc is
737 -- processed with Current_Sem_Unit = Main_Unit, but
738 -- nodes in gnat.adc do not appear to be the extended
739 -- main source unit (they probably should do ???)
741 if Current_Sem_Unit
= Main_Unit
742 or else In_Extended_Main_Source_Unit
(N
)
744 if Main_Restrictions
.Set
(R
) then
745 if V
< Main_Restrictions
.Value
(R
) then
746 Main_Restrictions
.Value
(R
) := V
;
749 elsif not Restriction_Warnings
(R
) then
750 Main_Restrictions
.Set
(R
) := True;
751 Main_Restrictions
.Value
(R
) := V
;
756 -----------------------------------
757 -- Set_Restriction_No_Dependence --
758 -----------------------------------
760 procedure Set_Restriction_No_Dependence
765 -- Loop to check for duplicate entry
767 for J
in No_Dependence
.First
.. No_Dependence
.Last
loop
769 -- Case of entry already in table
771 if Same_Unit
(Unit
, No_Dependence
.Table
(J
).Unit
) then
773 -- Error has precedence over warning
776 No_Dependence
.Table
(J
).Warn
:= False;
783 -- Entry is not currently in table
785 No_Dependence
.Append
((Unit
, Warn
));
786 end Set_Restriction_No_Dependence
;
788 ----------------------------------
789 -- Suppress_Restriction_Message --
790 ----------------------------------
792 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean is
794 -- We only output messages for the extended main source unit
796 if In_Extended_Main_Source_Unit
(N
) then
799 -- If loaded by rtsfind, then suppress message
801 elsif Sloc
(N
) <= No_Location
then
804 -- Otherwise suppress message if internal file
807 return Is_Internal_File_Name
(Unit_File_Name
(Get_Source_Unit
(N
)));
809 end Suppress_Restriction_Message
;
811 ---------------------
812 -- Tasking_Allowed --
813 ---------------------
815 function Tasking_Allowed
return Boolean is
817 return not Restrictions
.Set
(No_Tasking
)
818 and then (not Restrictions
.Set
(Max_Tasks
)
819 or else Restrictions
.Value
(Max_Tasks
) > 0);