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
(R
: Restriction_Id
; N
: Node_Id
);
56 -- Called if a violation of restriction R at node N is found. This routine
57 -- outputs the appropriate message or messages taking care of warning vs
58 -- real violation, serious vs non-serious, implicit vs explicit, the second
59 -- message giving the profile name if needed, and the location information.
61 function Same_Unit
(U1
, U2
: Node_Id
) return Boolean;
62 -- Returns True iff U1 and U2 represent the same library unit. Used for
63 -- handling of No_Dependence => Unit restriction case.
65 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean;
66 -- N is the node for a possible restriction violation message, but the
67 -- message is to be suppressed if this is an internal file and this file is
68 -- not the main unit. Returns True if message is to be suppressed.
74 function Abort_Allowed
return Boolean is
76 if Restrictions
.Set
(No_Abort_Statements
)
77 and then Restrictions
.Set
(Max_Asynchronous_Select_Nesting
)
78 and then Restrictions
.Value
(Max_Asynchronous_Select_Nesting
) = 0
86 -------------------------
87 -- Check_Compiler_Unit --
88 -------------------------
90 procedure Check_Compiler_Unit
(N
: Node_Id
) is
92 if Is_Compiler_Unit
(Get_Source_Unit
(N
)) then
93 Error_Msg_N
("use of construct not allowed in compiler", N
);
95 end Check_Compiler_Unit
;
97 ------------------------------------
98 -- Check_Elaboration_Code_Allowed --
99 ------------------------------------
101 procedure Check_Elaboration_Code_Allowed
(N
: Node_Id
) is
103 Check_Restriction
(No_Elaboration_Code
, N
);
104 end Check_Elaboration_Code_Allowed
;
106 -----------------------------------------
107 -- Check_Implicit_Dynamic_Code_Allowed --
108 -----------------------------------------
110 procedure Check_Implicit_Dynamic_Code_Allowed
(N
: Node_Id
) is
112 Check_Restriction
(No_Implicit_Dynamic_Code
, N
);
113 end Check_Implicit_Dynamic_Code_Allowed
;
115 ----------------------------------
116 -- Check_No_Implicit_Heap_Alloc --
117 ----------------------------------
119 procedure Check_No_Implicit_Heap_Alloc
(N
: Node_Id
) is
121 Check_Restriction
(No_Implicit_Heap_Allocations
, N
);
122 end Check_No_Implicit_Heap_Alloc
;
124 ---------------------------
125 -- Check_Restricted_Unit --
126 ---------------------------
128 procedure Check_Restricted_Unit
(U
: Unit_Name_Type
; N
: Node_Id
) is
130 if Suppress_Restriction_Message
(N
) then
133 elsif Is_Spec_Name
(U
) then
135 Fnam
: constant File_Name_Type
:=
136 Get_File_Name
(U
, Subunit
=> False);
141 Get_Name_String
(Fnam
);
143 -- Nothing to do if name not at least 5 characters long ending
144 -- in .ads or .adb extension, which we strip.
147 or else (Name_Buffer
(Name_Len
- 3 .. Name_Len
) /= ".ads"
149 Name_Buffer
(Name_Len
- 3 .. Name_Len
) /= ".adb")
154 -- Strip extension and pad to eight characters
156 Name_Len
:= Name_Len
- 4;
157 while Name_Len
< 8 loop
158 Name_Len
:= Name_Len
+ 1;
159 Name_Buffer
(Name_Len
) := ' ';
162 -- If predefined unit, check the list of restricted units
164 if Is_Predefined_File_Name
(Fnam
) then
165 for J
in Unit_Array
'Range loop
167 and then Name_Buffer
(1 .. 8) = Unit_Array
(J
).Filenm
169 Check_Restriction
(Unit_Array
(J
).Res_Id
, N
);
173 -- If not predefined unit, then one special check still
174 -- remains. GNAT.Current_Exception is not allowed if we have
175 -- restriction No_Exception_Propagation active.
178 if Name_Buffer
(1 .. 8) = "g-curexc" then
179 Check_Restriction
(No_Exception_Propagation
, N
);
184 end Check_Restricted_Unit
;
186 -----------------------
187 -- Check_Restriction --
188 -----------------------
190 procedure Check_Restriction
193 V
: Uint
:= Uint_Minus_1
)
196 -- V converted to integer form. If V is greater than Integer'Last,
197 -- it is reset to minus 1 (unknown value).
199 procedure Update_Restrictions
(Info
: in out Restrictions_Info
);
200 -- Update violation information in Info.Violated and Info.Count
202 -------------------------
203 -- Update_Restrictions --
204 -------------------------
206 procedure Update_Restrictions
(Info
: in out Restrictions_Info
) is
208 -- If not violated, set as violated now
210 if not Info
.Violated
(R
) then
211 Info
.Violated
(R
) := True;
213 if R
in All_Parameter_Restrictions
then
215 Info
.Unknown
(R
) := True;
218 Info
.Count
(R
) := VV
;
222 -- Otherwise if violated already and a parameter restriction,
223 -- update count by maximizing or summing depending on restriction.
225 elsif R
in All_Parameter_Restrictions
then
227 -- If new value is unknown, result is unknown
230 Info
.Unknown
(R
) := True;
232 -- If checked by maximization, do maximization
234 elsif R
in Checked_Max_Parameter_Restrictions
then
235 Info
.Count
(R
) := Integer'Max (Info
.Count
(R
), VV
);
237 -- If checked by adding, do add, checking for overflow
239 elsif R
in Checked_Add_Parameter_Restrictions
then
241 pragma Unsuppress
(Overflow_Check
);
243 Info
.Count
(R
) := Info
.Count
(R
) + VV
;
245 when Constraint_Error
=>
246 Info
.Count
(R
) := Integer'Last;
247 Info
.Unknown
(R
) := True;
250 -- Should not be able to come here, known counts should only
251 -- occur for restrictions that are Checked_max or Checked_Sum.
257 end Update_Restrictions
;
259 -- Start of processing for Check_Restriction
262 if UI_Is_In_Int_Range
(V
) then
263 VV
:= Integer (UI_To_Int
(V
));
268 -- Count can only be specified in the checked val parameter case
270 pragma Assert
(VV
< 0 or else R
in Checked_Val_Parameter_Restrictions
);
272 -- Nothing to do if value of zero specified for parameter restriction
278 -- Update current restrictions
280 Update_Restrictions
(Restrictions
);
282 -- If in main extended unit, update main restrictions as well
284 if Current_Sem_Unit
= Main_Unit
285 or else In_Extended_Main_Source_Unit
(N
)
287 Update_Restrictions
(Main_Restrictions
);
290 -- Nothing to do if restriction message suppressed
292 if Suppress_Restriction_Message
(N
) then
295 -- If restriction not set, nothing to do
297 elsif not Restrictions
.Set
(R
) then
300 -- Here if restriction set, check for violation (either this is a
301 -- Boolean restriction, or a parameter restriction with a value of
302 -- zero and an unknown count, or a parameter restriction with a
303 -- known value that exceeds the restriction count).
305 elsif R
in All_Boolean_Restrictions
306 or else (Restrictions
.Unknown
(R
)
307 and then Restrictions
.Value
(R
) = 0)
308 or else Restrictions
.Count
(R
) > Restrictions
.Value
(R
)
310 Restriction_Msg
(R
, N
);
312 end Check_Restriction
;
314 -------------------------------------
315 -- Check_Restriction_No_Dependence --
316 -------------------------------------
318 procedure Check_Restriction_No_Dependence
(U
: Node_Id
; Err
: Node_Id
) is
322 for J
in No_Dependence
.First
.. No_Dependence
.Last
loop
323 DU
:= No_Dependence
.Table
(J
).Unit
;
325 if Same_Unit
(U
, DU
) then
326 Error_Msg_Sloc
:= Sloc
(DU
);
327 Error_Msg_Node_1
:= DU
;
329 if No_Dependence
.Table
(J
).Warn
then
331 ("?violation of restriction `No_Dependence '='> &`#",
335 ("|violation of restriction `No_Dependence '='> &`#",
342 end Check_Restriction_No_Dependence
;
344 ----------------------------------------
345 -- Cunit_Boolean_Restrictions_Restore --
346 ----------------------------------------
348 procedure Cunit_Boolean_Restrictions_Restore
349 (R
: Save_Cunit_Boolean_Restrictions
)
352 for J
in Cunit_Boolean_Restrictions
loop
353 Restrictions
.Set
(J
) := R
(J
);
355 end Cunit_Boolean_Restrictions_Restore
;
357 -------------------------------------
358 -- Cunit_Boolean_Restrictions_Save --
359 -------------------------------------
361 function Cunit_Boolean_Restrictions_Save
362 return Save_Cunit_Boolean_Restrictions
364 R
: Save_Cunit_Boolean_Restrictions
;
367 for J
in Cunit_Boolean_Restrictions
loop
368 R
(J
) := Restrictions
.Set
(J
);
369 Restrictions
.Set
(J
) := False;
373 end Cunit_Boolean_Restrictions_Save
;
375 ------------------------
376 -- Get_Restriction_Id --
377 ------------------------
379 function Get_Restriction_Id
380 (N
: Name_Id
) return Restriction_Id
384 Set_Casing
(All_Upper_Case
);
386 for J
in All_Restrictions
loop
388 S
: constant String := Restriction_Id
'Image (J
);
390 if S
= Name_Buffer
(1 .. Name_Len
) then
396 return Not_A_Restriction_Id
;
397 end Get_Restriction_Id
;
399 -------------------------------
400 -- No_Exception_Handlers_Set --
401 -------------------------------
403 function No_Exception_Handlers_Set
return Boolean is
405 return (No_Run_Time_Mode
or else Configurable_Run_Time_Mode
)
406 and then (Restrictions
.Set
(No_Exception_Handlers
)
408 Restrictions
.Set
(No_Exception_Propagation
));
409 end No_Exception_Handlers_Set
;
411 -------------------------------------
412 -- No_Exception_Propagation_Active --
413 -------------------------------------
415 function No_Exception_Propagation_Active
return Boolean is
417 return (No_Run_Time_Mode
418 or else Configurable_Run_Time_Mode
419 or else Debug_Flag_Dot_G
)
420 and then Restriction_Active
(No_Exception_Propagation
);
421 end No_Exception_Propagation_Active
;
423 ----------------------------------
424 -- Process_Restriction_Synonyms --
425 ----------------------------------
427 -- Note: body of this function must be coordinated with list of
428 -- renaming declarations in System.Rident.
430 function Process_Restriction_Synonyms
(N
: Node_Id
) return Name_Id
432 Old_Name
: constant Name_Id
:= Chars
(N
);
437 when Name_Boolean_Entry_Barriers
=>
438 New_Name
:= Name_Simple_Barriers
;
440 when Name_Max_Entry_Queue_Depth
=>
441 New_Name
:= Name_Max_Entry_Queue_Length
;
443 when Name_No_Dynamic_Interrupts
=>
444 New_Name
:= Name_No_Dynamic_Attachment
;
446 when Name_No_Requeue
=>
447 New_Name
:= Name_No_Requeue_Statements
;
449 when Name_No_Task_Attributes
=>
450 New_Name
:= Name_No_Task_Attributes_Package
;
456 if Warn_On_Obsolescent_Feature
then
457 Error_Msg_Name_1
:= Old_Name
;
458 Error_Msg_N
("restriction identifier % is obsolescent?", N
);
459 Error_Msg_Name_1
:= New_Name
;
460 Error_Msg_N
("|use restriction identifier % instead", N
);
464 end Process_Restriction_Synonyms
;
466 ------------------------
467 -- Restricted_Profile --
468 ------------------------
470 function Restricted_Profile
return Boolean is
472 if Restricted_Profile_Cached
then
473 return Restricted_Profile_Result
;
476 Restricted_Profile_Result
:= True;
477 Restricted_Profile_Cached
:= True;
480 R
: Restriction_Flags
renames Profile_Info
(Restricted
).Set
;
481 V
: Restriction_Values
renames Profile_Info
(Restricted
).Value
;
483 for J
in R
'Range loop
485 and then (Restrictions
.Set
(J
) = False
486 or else Restriction_Warnings
(J
)
488 (J
in All_Parameter_Restrictions
489 and then Restrictions
.Value
(J
) > V
(J
)))
491 Restricted_Profile_Result
:= False;
496 return Restricted_Profile_Result
;
499 end Restricted_Profile
;
501 ------------------------
502 -- Restriction_Active --
503 ------------------------
505 function Restriction_Active
(R
: All_Restrictions
) return Boolean is
507 return Restrictions
.Set
(R
) and then not Restriction_Warnings
(R
);
508 end Restriction_Active
;
510 ---------------------
511 -- Restriction_Msg --
512 ---------------------
514 procedure Restriction_Msg
(R
: Restriction_Id
; N
: Node_Id
) is
515 Msg
: String (1 .. 100);
518 procedure Add_Char
(C
: Character);
519 -- Append given character to Msg, bumping Len
521 procedure Add_Str
(S
: String);
522 -- Append given string to Msg, bumping Len appropriately
524 procedure Id_Case
(S
: String; Quotes
: Boolean := True);
525 -- Given a string S, case it according to current identifier casing,
526 -- and store in Error_Msg_String. Then append `~` to the message buffer
527 -- to output the string unchanged surrounded in quotes. The quotes are
528 -- suppressed if Quotes = False.
534 procedure Add_Char
(C
: Character) is
544 procedure Add_Str
(S
: String) is
546 Msg
(Len
+ 1 .. Len
+ S
'Length) := S
;
547 Len
:= Len
+ S
'Length;
554 procedure Id_Case
(S
: String; Quotes
: Boolean := True) is
556 Name_Buffer
(1 .. S
'Last) := S
;
557 Name_Len
:= S
'Length;
558 Set_Casing
(Identifier_Casing
(Get_Source_File_Index
(Sloc
(N
))));
559 Error_Msg_Strlen
:= Name_Len
;
560 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
569 -- Start of processing for Restriction_Msg
572 -- Set warning message if warning
574 if Restriction_Warnings
(R
) then
577 -- If real violation (not warning), then mark it as non-serious unless
578 -- it is a violation of No_Finalization in which case we leave it as a
579 -- serious message, since otherwise we get crashes during attempts to
580 -- expand stuff that is not properly formed due to assumptions made
581 -- about no finalization being present.
583 elsif R
/= No_Finalization
then
587 Error_Msg_Sloc
:= Restrictions_Loc
(R
);
589 -- Set main message, adding implicit if no source location
591 if Error_Msg_Sloc
> No_Location
592 or else Error_Msg_Sloc
= System_Location
594 Add_Str
("violation of restriction ");
596 Add_Str
("violation of implicit restriction ");
597 Error_Msg_Sloc
:= No_Location
;
600 -- Case of parametrized restriction
602 if R
in All_Parameter_Restrictions
then
604 Id_Case
(Restriction_Id
'Image (R
), Quotes
=> False);
606 Error_Msg_Uint_1
:= UI_From_Int
(Int
(Restrictions
.Value
(R
)));
608 -- Case of boolean restriction
611 Id_Case
(Restriction_Id
'Image (R
));
614 -- Case of no secondary profile continuation message
616 if Restriction_Profile_Name
(R
) = No_Profile
then
617 if Error_Msg_Sloc
/= No_Location
then
622 Error_Msg_N
(Msg
(1 .. Len
), N
);
624 -- Case of secondary profile continuation message present
628 Error_Msg_N
(Msg
(1 .. Len
), N
);
633 -- Set as warning if warning case
635 if Restriction_Warnings
(R
) then
641 Add_Str
("from profile ");
642 Id_Case
(Profile_Name
'Image (Restriction_Profile_Name
(R
)));
644 -- Add location if we have one
646 if Error_Msg_Sloc
/= No_Location
then
650 -- Output unconditional message and we are done
653 Error_Msg_N
(Msg
(1 .. Len
), N
);
661 function Same_Unit
(U1
, U2
: Node_Id
) return Boolean is
663 if Nkind
(U1
) = N_Identifier
then
664 return Nkind
(U2
) = N_Identifier
and then Chars
(U1
) = Chars
(U2
);
666 elsif Nkind
(U2
) = N_Identifier
then
669 elsif (Nkind
(U1
) = N_Selected_Component
670 or else Nkind
(U1
) = N_Expanded_Name
)
672 (Nkind
(U2
) = N_Selected_Component
673 or else Nkind
(U2
) = N_Expanded_Name
)
675 return Same_Unit
(Prefix
(U1
), Prefix
(U2
))
676 and then Same_Unit
(Selector_Name
(U1
), Selector_Name
(U2
));
682 ------------------------------
683 -- Set_Profile_Restrictions --
684 ------------------------------
686 procedure Set_Profile_Restrictions
691 R
: Restriction_Flags
renames Profile_Info
(P
).Set
;
692 V
: Restriction_Values
renames Profile_Info
(P
).Value
;
695 for J
in R
'Range loop
698 Already_Restricted
: constant Boolean := Restriction_Active
(J
);
701 -- Set the restriction
703 if J
in All_Boolean_Restrictions
then
704 Set_Restriction
(J
, N
);
706 Set_Restriction
(J
, N
, V
(J
));
709 -- Record that this came from a Profile[_Warnings] restriction
711 Restriction_Profile_Name
(J
) := P
;
713 -- Set warning flag, except that we do not set the warning
714 -- flag if the restriction was already active and this is
715 -- the warning case. That avoids a warning overriding a real
716 -- restriction, which should never happen.
718 if not (Warn
and Already_Restricted
) then
719 Restriction_Warnings
(J
) := Warn
;
724 end Set_Profile_Restrictions
;
726 ---------------------
727 -- Set_Restriction --
728 ---------------------
730 -- Case of Boolean restriction
732 procedure Set_Restriction
733 (R
: All_Boolean_Restrictions
;
737 -- Restriction No_Elaboration_Code must be enforced on a unit by unit
738 -- basis. Hence, we avoid setting the restriction when processing an
739 -- unit which is not the main one being compiled (or its corresponding
740 -- spec). It can happen, for example, when processing an inlined body
741 -- (the package containing the inlined subprogram is analyzed,
742 -- including its pragma Restrictions).
744 -- This seems like a very nasty kludge??? This is not the only per unit
745 -- restriction why is this treated specially ???
747 if R
= No_Elaboration_Code
748 and then Current_Sem_Unit
/= Main_Unit
749 and then Cunit
(Current_Sem_Unit
) /= Library_Unit
(Cunit
(Main_Unit
))
754 Restrictions
.Set
(R
) := True;
756 if Restricted_Profile_Cached
and Restricted_Profile_Result
then
759 Restricted_Profile_Cached
:= False;
762 -- Set location, but preserve location of system restriction for nice
763 -- error msg with run time name.
765 if Restrictions_Loc
(R
) /= System_Location
then
766 Restrictions_Loc
(R
) := Sloc
(N
);
769 -- Note restriction came from restriction pragma, not profile
771 Restriction_Profile_Name
(R
) := No_Profile
;
773 -- Record the restriction if we are in the main unit, or in the extended
774 -- main unit. The reason that we test separately for Main_Unit is that
775 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
776 -- gnat.adc do not appear to be in the extended main source unit (they
777 -- probably should do ???)
779 if Current_Sem_Unit
= Main_Unit
780 or else In_Extended_Main_Source_Unit
(N
)
782 if not Restriction_Warnings
(R
) then
783 Main_Restrictions
.Set
(R
) := True;
788 -- Case of parameter restriction
790 procedure Set_Restriction
791 (R
: All_Parameter_Restrictions
;
796 if Restricted_Profile_Cached
and Restricted_Profile_Result
then
799 Restricted_Profile_Cached
:= False;
802 if Restrictions
.Set
(R
) then
803 if V
< Restrictions
.Value
(R
) then
804 Restrictions
.Value
(R
) := V
;
805 Restrictions_Loc
(R
) := Sloc
(N
);
809 Restrictions
.Set
(R
) := True;
810 Restrictions
.Value
(R
) := V
;
811 Restrictions_Loc
(R
) := Sloc
(N
);
814 -- Record the restriction if we are in the main unit, or in the extended
815 -- main unit. The reason that we test separately for Main_Unit is that
816 -- gnat.adc is processed with Current_Sem_Unit = Main_Unit, but nodes in
817 -- gnat.adc do not appear to be the extended main source unit (they
818 -- probably should do ???)
820 if Current_Sem_Unit
= Main_Unit
821 or else In_Extended_Main_Source_Unit
(N
)
823 if Main_Restrictions
.Set
(R
) then
824 if V
< Main_Restrictions
.Value
(R
) then
825 Main_Restrictions
.Value
(R
) := V
;
828 elsif not Restriction_Warnings
(R
) then
829 Main_Restrictions
.Set
(R
) := True;
830 Main_Restrictions
.Value
(R
) := V
;
834 -- Note restriction came from restriction pragma, not profile
836 Restriction_Profile_Name
(R
) := No_Profile
;
839 -----------------------------------
840 -- Set_Restriction_No_Dependence --
841 -----------------------------------
843 procedure Set_Restriction_No_Dependence
846 Profile
: Profile_Name
:= No_Profile
)
849 -- Loop to check for duplicate entry
851 for J
in No_Dependence
.First
.. No_Dependence
.Last
loop
853 -- Case of entry already in table
855 if Same_Unit
(Unit
, No_Dependence
.Table
(J
).Unit
) then
857 -- Error has precedence over warning
860 No_Dependence
.Table
(J
).Warn
:= False;
867 -- Entry is not currently in table
869 No_Dependence
.Append
((Unit
, Warn
, Profile
));
870 end Set_Restriction_No_Dependence
;
872 ----------------------------------
873 -- Suppress_Restriction_Message --
874 ----------------------------------
876 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean is
878 -- We only output messages for the extended main source unit
880 if In_Extended_Main_Source_Unit
(N
) then
883 -- If loaded by rtsfind, then suppress message
885 elsif Sloc
(N
) <= No_Location
then
888 -- Otherwise suppress message if internal file
891 return Is_Internal_File_Name
(Unit_File_Name
(Get_Source_Unit
(N
)));
893 end Suppress_Restriction_Message
;
895 ---------------------
896 -- Tasking_Allowed --
897 ---------------------
899 function Tasking_Allowed
return Boolean is
901 return not Restrictions
.Set
(No_Tasking
)
902 and then (not Restrictions
.Set
(Max_Tasks
)
903 or else Restrictions
.Value
(Max_Tasks
) > 0);