1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2004 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Casing
; use Casing
;
29 with Errout
; use Errout
;
30 with Fname
; use Fname
;
31 with Fname
.UF
; use Fname
.UF
;
33 with Namet
; use Namet
;
35 with Sinfo
; use Sinfo
;
36 with Sinput
; use Sinput
;
37 with Snames
; use Snames
;
38 with Uname
; use Uname
;
40 package body Restrict
is
42 Restricted_Profile_Result
: Boolean := False;
43 -- This switch memoizes the result of Restricted_Profile function
44 -- calls for improved efficiency. Its setting is valid only if
45 -- Restricted_Profile_Cached is True. Note that if this switch
46 -- is ever set True, it need never be turned off again.
48 Restricted_Profile_Cached
: Boolean := False;
49 -- This flag is set to True if the Restricted_Profile_Result
50 -- contains the correct cached result of Restricted_Profile calls.
52 -----------------------
53 -- Local Subprograms --
54 -----------------------
56 procedure Restriction_Msg
(Msg
: String; R
: String; N
: Node_Id
);
57 -- Output error message at node N with given text, replacing the
58 -- '%' in the message with the name of the restriction given as R,
59 -- cased according to the current identifier casing. We do not use
60 -- the normal insertion mechanism, since this requires an entry
61 -- in the Names table, and this table will be locked if we are
62 -- generating a message from gigi.
64 function Same_Unit
(U1
, U2
: Node_Id
) return Boolean;
65 -- Returns True iff U1 and U2 represent the same library unit. Used for
66 -- handling of No_Dependence => Unit restriction case.
68 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean;
69 -- N is the node for a possible restriction violation message, but
70 -- the message is to be suppressed if this is an internal file and
71 -- this file is not the main unit.
77 function Abort_Allowed
return Boolean is
79 if Restrictions
.Set
(No_Abort_Statements
)
80 and then Restrictions
.Set
(Max_Asynchronous_Select_Nesting
)
81 and then Restrictions
.Value
(Max_Asynchronous_Select_Nesting
) = 0
89 ------------------------------------
90 -- Check_Elaboration_Code_Allowed --
91 ------------------------------------
93 procedure Check_Elaboration_Code_Allowed
(N
: Node_Id
) is
95 -- Avoid calling Namet.Unlock/Lock except when there is an error.
96 -- Even in the error case it is a bit dubious, either gigi needs
97 -- the table locked or it does not! ???
99 if Restrictions
.Set
(No_Elaboration_Code
)
100 and then not Suppress_Restriction_Message
(N
)
103 Check_Restriction
(Restriction_Id
'(No_Elaboration_Code), N);
106 end Check_Elaboration_Code_Allowed;
108 ----------------------------------
109 -- Check_No_Implicit_Heap_Alloc --
110 ----------------------------------
112 procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is
114 Check_Restriction (Restriction_Id'(No_Implicit_Heap_Allocations
), N
);
115 end Check_No_Implicit_Heap_Alloc
;
117 ---------------------------
118 -- Check_Restricted_Unit --
119 ---------------------------
121 procedure Check_Restricted_Unit
(U
: Unit_Name_Type
; N
: Node_Id
) is
123 if Suppress_Restriction_Message
(N
) then
126 elsif Is_Spec_Name
(U
) then
128 Fnam
: constant File_Name_Type
:=
129 Get_File_Name
(U
, Subunit
=> False);
132 if not Is_Predefined_File_Name
(Fnam
) then
135 -- Predefined spec, needs checking against list
138 -- Pad name to 8 characters with blanks
140 Get_Name_String
(Fnam
);
141 Name_Len
:= Name_Len
- 4;
143 while Name_Len
< 8 loop
144 Name_Len
:= Name_Len
+ 1;
145 Name_Buffer
(Name_Len
) := ' ';
148 for J
in Unit_Array
'Range loop
150 and then Name_Buffer
(1 .. 8) = Unit_Array
(J
).Filenm
152 Check_Restriction
(Unit_Array
(J
).Res_Id
, N
);
158 end Check_Restricted_Unit
;
160 -----------------------
161 -- Check_Restriction --
162 -----------------------
164 procedure Check_Restriction
167 V
: Uint
:= Uint_Minus_1
)
169 Rimage
: constant String := Restriction_Id
'Image (R
);
172 -- V converted to integer form. If V is greater than Integer'Last,
173 -- it is reset to minus 1 (unknown value).
175 procedure Update_Restrictions
(Info
: in out Restrictions_Info
);
176 -- Update violation information in Info.Violated and Info.Count
178 -------------------------
179 -- Update_Restrictions --
180 -------------------------
182 procedure Update_Restrictions
(Info
: in out Restrictions_Info
) is
184 -- If not violated, set as violated now
186 if not Info
.Violated
(R
) then
187 Info
.Violated
(R
) := True;
189 if R
in All_Parameter_Restrictions
then
191 Info
.Unknown
(R
) := True;
194 Info
.Count
(R
) := VV
;
198 -- Otherwise if violated already and a parameter restriction,
199 -- update count by maximizing or summing depending on restriction.
201 elsif R
in All_Parameter_Restrictions
then
203 -- If new value is unknown, result is unknown
206 Info
.Unknown
(R
) := True;
208 -- If checked by maximization, do maximization
210 elsif R
in Checked_Max_Parameter_Restrictions
then
211 Info
.Count
(R
) := Integer'Max (Info
.Count
(R
), VV
);
213 -- If checked by adding, do add, checking for overflow
215 elsif R
in Checked_Add_Parameter_Restrictions
then
217 pragma Unsuppress
(Overflow_Check
);
219 Info
.Count
(R
) := Info
.Count
(R
) + VV
;
221 when Constraint_Error
=>
222 Info
.Count
(R
) := Integer'Last;
223 Info
.Unknown
(R
) := True;
226 -- Should not be able to come here, known counts should only
227 -- occur for restrictions that are Checked_max or Checked_Sum.
233 end Update_Restrictions
;
235 -- Start of processing for Check_Restriction
238 if UI_Is_In_Int_Range
(V
) then
239 VV
:= Integer (UI_To_Int
(V
));
244 -- Count can only be specified in the checked val parameter case
246 pragma Assert
(VV
< 0 or else R
in Checked_Val_Parameter_Restrictions
);
248 -- Nothing to do if value of zero specified for parameter restriction
254 -- Update current restrictions
256 Update_Restrictions
(Restrictions
);
258 -- If in main extended unit, update main restrictions as well
260 if Current_Sem_Unit
= Main_Unit
261 or else In_Extended_Main_Source_Unit
(N
)
263 Update_Restrictions
(Main_Restrictions
);
266 -- Nothing to do if restriction message suppressed
268 if Suppress_Restriction_Message
(N
) then
271 -- If restriction not set, nothing to do
273 elsif not Restrictions
.Set
(R
) then
276 -- Here if restriction set, check for violation (either this is a
277 -- Boolean restriction, or a parameter restriction with a value of
278 -- zero and an unknown count, or a parameter restriction with a
279 -- known value that exceeds the restriction count).
281 elsif R
in All_Boolean_Restrictions
282 or else (Restrictions
.Unknown
(R
)
283 and then Restrictions
.Value
(R
) = 0)
284 or else Restrictions
.Count
(R
) > Restrictions
.Value
(R
)
286 Error_Msg_Sloc
:= Restrictions_Loc
(R
);
288 -- If we have a location for the Restrictions pragma, output it
290 if Error_Msg_Sloc
> No_Location
291 or else Error_Msg_Sloc
= System_Location
293 if Restriction_Warnings
(R
) then
294 Restriction_Msg
("|violation of restriction %#?", Rimage
, N
);
296 Restriction_Msg
("|violation of restriction %#", Rimage
, N
);
299 -- Otherwise we have the case of an implicit restriction
300 -- (e.g. a restriction implicitly set by another pragma)
304 ("|violation of implicit restriction %", Rimage
, N
);
307 end Check_Restriction
;
309 -------------------------------------
310 -- Check_Restriction_No_Dependence --
311 -------------------------------------
313 procedure Check_Restriction_No_Dependence
(U
: Node_Id
; Err
: Node_Id
) is
317 for J
in No_Dependence
.First
.. No_Dependence
.Last
loop
318 DU
:= No_Dependence
.Table
(J
).Unit
;
320 if Same_Unit
(U
, DU
) then
321 Error_Msg_Sloc
:= Sloc
(DU
);
322 Error_Msg_Node_1
:= DU
;
324 if No_Dependence
.Table
(J
).Warn
then
326 ("?violation of restriction `No_Dependence '='> &`#",
330 ("|violation of restriction `No_Dependence '='> &`#",
337 end Check_Restriction_No_Dependence
;
339 ----------------------------------------
340 -- Cunit_Boolean_Restrictions_Restore --
341 ----------------------------------------
343 procedure Cunit_Boolean_Restrictions_Restore
344 (R
: Save_Cunit_Boolean_Restrictions
)
347 for J
in Cunit_Boolean_Restrictions
loop
348 Restrictions
.Set
(J
) := R
(J
);
350 end Cunit_Boolean_Restrictions_Restore
;
352 -------------------------------------
353 -- Cunit_Boolean_Restrictions_Save --
354 -------------------------------------
356 function Cunit_Boolean_Restrictions_Save
357 return Save_Cunit_Boolean_Restrictions
359 R
: Save_Cunit_Boolean_Restrictions
;
362 for J
in Cunit_Boolean_Restrictions
loop
363 R
(J
) := Restrictions
.Set
(J
);
364 Restrictions
.Set
(J
) := False;
368 end Cunit_Boolean_Restrictions_Save
;
370 ------------------------
371 -- Get_Restriction_Id --
372 ------------------------
374 function Get_Restriction_Id
375 (N
: Name_Id
) return Restriction_Id
379 Set_Casing
(All_Upper_Case
);
381 for J
in All_Restrictions
loop
383 S
: constant String := Restriction_Id
'Image (J
);
385 if S
= Name_Buffer
(1 .. Name_Len
) then
391 return Not_A_Restriction_Id
;
392 end Get_Restriction_Id
;
394 -------------------------------
395 -- No_Exception_Handlers_Set --
396 -------------------------------
398 function No_Exception_Handlers_Set
return Boolean is
400 return Restrictions
.Set
(No_Exception_Handlers
);
401 end No_Exception_Handlers_Set
;
403 ----------------------------------
404 -- Process_Restriction_Synonyms --
405 ----------------------------------
407 -- Note: body of this function must be coordinated with list of
408 -- renaming declarations in System.Rident.
410 function Process_Restriction_Synonyms
(N
: Node_Id
) return Name_Id
412 Old_Name
: constant Name_Id
:= Chars
(N
);
417 when Name_Boolean_Entry_Barriers
=>
418 New_Name
:= Name_Simple_Barriers
;
420 when Name_Max_Entry_Queue_Depth
=>
421 New_Name
:= Name_Max_Entry_Queue_Length
;
423 when Name_No_Dynamic_Interrupts
=>
424 New_Name
:= Name_No_Dynamic_Attachment
;
426 when Name_No_Requeue
=>
427 New_Name
:= Name_No_Requeue_Statements
;
429 when Name_No_Task_Attributes
=>
430 New_Name
:= Name_No_Task_Attributes_Package
;
436 if Warn_On_Obsolescent_Feature
then
437 Error_Msg_Name_1
:= Old_Name
;
438 Error_Msg_N
("restriction identifier % is obsolescent?", N
);
439 Error_Msg_Name_1
:= New_Name
;
440 Error_Msg_N
("|use restriction identifier % instead", N
);
444 end Process_Restriction_Synonyms
;
446 ------------------------
447 -- Restricted_Profile --
448 ------------------------
450 function Restricted_Profile
return Boolean is
452 if Restricted_Profile_Cached
then
453 return Restricted_Profile_Result
;
456 Restricted_Profile_Result
:= True;
457 Restricted_Profile_Cached
:= True;
460 R
: Restriction_Flags
renames Profile_Info
(Restricted
).Set
;
461 V
: Restriction_Values
renames Profile_Info
(Restricted
).Value
;
463 for J
in R
'Range loop
465 and then (Restrictions
.Set
(J
) = False
466 or else Restriction_Warnings
(J
)
468 (J
in All_Parameter_Restrictions
469 and then Restrictions
.Value
(J
) > V
(J
)))
471 Restricted_Profile_Result
:= False;
476 return Restricted_Profile_Result
;
479 end Restricted_Profile
;
481 ------------------------
482 -- Restriction_Active --
483 ------------------------
485 function Restriction_Active
(R
: All_Restrictions
) return Boolean is
487 return Restrictions
.Set
(R
);
488 end Restriction_Active
;
490 ---------------------
491 -- Restriction_Msg --
492 ---------------------
494 procedure Restriction_Msg
(Msg
: String; R
: String; N
: Node_Id
) is
495 B
: String (1 .. Msg
'Length + 2 * R
'Length + 1);
499 Name_Buffer
(1 .. R
'Last) := R
;
500 Name_Len
:= R
'Length;
501 Set_Casing
(Identifier_Casing
(Get_Source_File_Index
(Sloc
(N
))));
504 for J
in Msg
'Range loop
505 if Msg
(J
) = '%' then
509 -- Put characters of image in message, quoting upper case letters
511 for J
in 1 .. Name_Len
loop
512 if Name_Buffer
(J
) in 'A' .. 'Z' then
518 B
(P
) := Name_Buffer
(J
);
530 Error_Msg_N
(B
(1 .. P
), N
);
537 function Same_Unit
(U1
, U2
: Node_Id
) return Boolean is
539 if Nkind
(U1
) = N_Identifier
then
540 return Nkind
(U2
) = N_Identifier
and then Chars
(U1
) = Chars
(U2
);
542 elsif Nkind
(U2
) = N_Identifier
then
545 elsif (Nkind
(U1
) = N_Selected_Component
546 or else Nkind
(U1
) = N_Expanded_Name
)
548 (Nkind
(U2
) = N_Selected_Component
549 or else Nkind
(U2
) = N_Expanded_Name
)
551 return Same_Unit
(Prefix
(U1
), Prefix
(U2
))
552 and then Same_Unit
(Selector_Name
(U1
), Selector_Name
(U2
));
558 ------------------------------
559 -- Set_Profile_Restrictions --
560 ------------------------------
562 procedure Set_Profile_Restrictions
567 R
: Restriction_Flags
renames Profile_Info
(P
).Set
;
568 V
: Restriction_Values
renames Profile_Info
(P
).Value
;
571 for J
in R
'Range loop
573 if J
in All_Boolean_Restrictions
then
574 Set_Restriction
(J
, N
);
576 Set_Restriction
(J
, N
, V
(J
));
579 Restriction_Warnings
(J
) := Warn
;
582 end Set_Profile_Restrictions
;
584 ---------------------
585 -- Set_Restriction --
586 ---------------------
588 -- Case of Boolean restriction
590 procedure Set_Restriction
591 (R
: All_Boolean_Restrictions
;
595 Restrictions
.Set
(R
) := True;
597 if Restricted_Profile_Cached
and Restricted_Profile_Result
then
600 Restricted_Profile_Cached
:= False;
603 -- Set location, but preserve location of system
604 -- restriction for nice error msg with run time name
606 if Restrictions_Loc
(R
) /= System_Location
then
607 Restrictions_Loc
(R
) := Sloc
(N
);
610 -- Record the restriction if we are in the main unit,
611 -- or in the extended main unit. The reason that we
612 -- test separately for Main_Unit is that gnat.adc is
613 -- processed with Current_Sem_Unit = Main_Unit, but
614 -- nodes in gnat.adc do not appear to be the extended
615 -- main source unit (they probably should do ???)
617 if Current_Sem_Unit
= Main_Unit
618 or else In_Extended_Main_Source_Unit
(N
)
620 if not Restriction_Warnings
(R
) then
621 Main_Restrictions
.Set
(R
) := True;
626 -- Case of parameter restriction
628 procedure Set_Restriction
629 (R
: All_Parameter_Restrictions
;
634 if Restricted_Profile_Cached
and Restricted_Profile_Result
then
637 Restricted_Profile_Cached
:= False;
640 if Restrictions
.Set
(R
) then
641 if V
< Restrictions
.Value
(R
) then
642 Restrictions
.Value
(R
) := V
;
643 Restrictions_Loc
(R
) := Sloc
(N
);
647 Restrictions
.Set
(R
) := True;
648 Restrictions
.Value
(R
) := V
;
649 Restrictions_Loc
(R
) := Sloc
(N
);
652 -- Record the restriction if we are in the main unit,
653 -- or in the extended main unit. The reason that we
654 -- test separately for Main_Unit is that gnat.adc is
655 -- processed with Current_Sem_Unit = Main_Unit, but
656 -- nodes in gnat.adc do not appear to be the extended
657 -- main source unit (they probably should do ???)
659 if Current_Sem_Unit
= Main_Unit
660 or else In_Extended_Main_Source_Unit
(N
)
662 if Main_Restrictions
.Set
(R
) then
663 if V
< Main_Restrictions
.Value
(R
) then
664 Main_Restrictions
.Value
(R
) := V
;
667 elsif not Restriction_Warnings
(R
) then
668 Main_Restrictions
.Set
(R
) := True;
669 Main_Restrictions
.Value
(R
) := V
;
674 -----------------------------------
675 -- Set_Restriction_No_Dependence --
676 -----------------------------------
678 procedure Set_Restriction_No_Dependence
683 -- Loop to check for duplicate entry
685 for J
in No_Dependence
.First
.. No_Dependence
.Last
loop
687 -- Case of entry already in table
689 if Same_Unit
(Unit
, No_Dependence
.Table
(J
).Unit
) then
691 -- Error has precedence over warning
694 No_Dependence
.Table
(J
).Warn
:= False;
703 No_Dependence
.Append
((Unit
, Warn
));
704 end Set_Restriction_No_Dependence
;
706 ----------------------------------
707 -- Suppress_Restriction_Message --
708 ----------------------------------
710 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean is
712 -- We only output messages for the extended main source unit
714 if In_Extended_Main_Source_Unit
(N
) then
717 -- If loaded by rtsfind, then suppress message
719 elsif Sloc
(N
) <= No_Location
then
722 -- Otherwise suppress message if internal file
725 return Is_Internal_File_Name
(Unit_File_Name
(Get_Source_Unit
(N
)));
727 end Suppress_Restriction_Message
;
729 ---------------------
730 -- Tasking_Allowed --
731 ---------------------
733 function Tasking_Allowed
return Boolean is
735 return not Restrictions
.Set
(No_Tasking
)
736 and then (not Restrictions
.Set
(Max_Tasks
)
737 or else Restrictions
.Value
(Max_Tasks
) > 0);