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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 Suppress_Restriction_Message
(N
: Node_Id
) return Boolean;
65 -- N is the node for a possible restriction violation message, but
66 -- the message is to be suppressed if this is an internal file and
67 -- this file is not the main unit.
73 function Abort_Allowed
return Boolean is
75 if Restrictions
.Set
(No_Abort_Statements
)
76 and then Restrictions
.Set
(Max_Asynchronous_Select_Nesting
)
77 and then Restrictions
.Value
(Max_Asynchronous_Select_Nesting
) = 0
85 ------------------------------------
86 -- Check_Elaboration_Code_Allowed --
87 ------------------------------------
89 procedure Check_Elaboration_Code_Allowed
(N
: Node_Id
) is
91 -- Avoid calling Namet.Unlock/Lock except when there is an error.
92 -- Even in the error case it is a bit dubious, either gigi needs
93 -- the table locked or it does not! ???
95 if Restrictions
.Set
(No_Elaboration_Code
)
96 and then not Suppress_Restriction_Message
(N
)
99 Check_Restriction
(Restriction_Id
'(No_Elaboration_Code), N);
102 end Check_Elaboration_Code_Allowed;
104 ----------------------------------
105 -- Check_No_Implicit_Heap_Alloc --
106 ----------------------------------
108 procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is
110 Check_Restriction (Restriction_Id'(No_Implicit_Heap_Allocations
), N
);
111 end Check_No_Implicit_Heap_Alloc
;
113 ---------------------------
114 -- Check_Restricted_Unit --
115 ---------------------------
117 procedure Check_Restricted_Unit
(U
: Unit_Name_Type
; N
: Node_Id
) is
119 if Suppress_Restriction_Message
(N
) then
122 elsif Is_Spec_Name
(U
) then
124 Fnam
: constant File_Name_Type
:=
125 Get_File_Name
(U
, Subunit
=> False);
128 if not Is_Predefined_File_Name
(Fnam
) then
131 -- Predefined spec, needs checking against list
134 -- Pad name to 8 characters with blanks
136 Get_Name_String
(Fnam
);
137 Name_Len
:= Name_Len
- 4;
139 while Name_Len
< 8 loop
140 Name_Len
:= Name_Len
+ 1;
141 Name_Buffer
(Name_Len
) := ' ';
144 for J
in Unit_Array
'Range loop
146 and then Name_Buffer
(1 .. 8) = Unit_Array
(J
).Filenm
148 Check_Restriction
(Unit_Array
(J
).Res_Id
, N
);
154 end Check_Restricted_Unit
;
156 -----------------------
157 -- Check_Restriction --
158 -----------------------
160 procedure Check_Restriction
163 V
: Uint
:= Uint_Minus_1
)
165 Rimage
: constant String := Restriction_Id
'Image (R
);
168 -- V converted to integer form. If V is greater than Integer'Last,
169 -- it is reset to minus 1 (unknown value).
171 procedure Update_Restrictions
(Info
: in out Restrictions_Info
);
172 -- Update violation information in Info.Violated and Info.Count
174 -------------------------
175 -- Update_Restrictions --
176 -------------------------
178 procedure Update_Restrictions
(Info
: in out Restrictions_Info
) is
180 -- If not violated, set as violated now
182 if not Info
.Violated
(R
) then
183 Info
.Violated
(R
) := True;
185 if R
in All_Parameter_Restrictions
then
187 Info
.Unknown
(R
) := True;
190 Info
.Count
(R
) := VV
;
194 -- Otherwise if violated already and a parameter restriction,
195 -- update count by maximizing or summing depending on restriction.
197 elsif R
in All_Parameter_Restrictions
then
199 -- If new value is unknown, result is unknown
202 Info
.Unknown
(R
) := True;
204 -- If checked by maximization, do maximization
206 elsif R
in Checked_Max_Parameter_Restrictions
then
207 Info
.Count
(R
) := Integer'Max (Info
.Count
(R
), VV
);
209 -- If checked by adding, do add, checking for overflow
211 elsif R
in Checked_Add_Parameter_Restrictions
then
213 pragma Unsuppress
(Overflow_Check
);
215 Info
.Count
(R
) := Info
.Count
(R
) + VV
;
217 when Constraint_Error
=>
218 Info
.Count
(R
) := Integer'Last;
219 Info
.Unknown
(R
) := True;
222 -- Should not be able to come here, known counts should only
223 -- occur for restrictions that are Checked_max or Checked_Sum.
229 end Update_Restrictions
;
231 -- Start of processing for Check_Restriction
234 if UI_Is_In_Int_Range
(V
) then
235 VV
:= Integer (UI_To_Int
(V
));
240 -- Count can only be specified in the checked val parameter case
242 pragma Assert
(VV
< 0 or else R
in Checked_Val_Parameter_Restrictions
);
244 -- Nothing to do if value of zero specified for parameter restriction
250 -- Update current restrictions
252 Update_Restrictions
(Restrictions
);
254 -- If in main extended unit, update main restrictions as well
256 if Current_Sem_Unit
= Main_Unit
257 or else In_Extended_Main_Source_Unit
(N
)
259 Update_Restrictions
(Main_Restrictions
);
262 -- Nothing to do if restriction message suppressed
264 if Suppress_Restriction_Message
(N
) then
267 -- If restriction not set, nothing to do
269 elsif not Restrictions
.Set
(R
) then
272 -- Here if restriction set, check for violation (either this is a
273 -- Boolean restriction, or a parameter restriction with a value of
274 -- zero and an unknown count, or a parameter restriction with a
275 -- known value that exceeds the restriction count).
277 elsif R
in All_Boolean_Restrictions
278 or else (Restrictions
.Unknown
(R
)
279 and then Restrictions
.Value
(R
) = 0)
280 or else Restrictions
.Count
(R
) > Restrictions
.Value
(R
)
282 Error_Msg_Sloc
:= Restrictions_Loc
(R
);
284 -- If we have a location for the Restrictions pragma, output it
286 if Error_Msg_Sloc
> No_Location
287 or else Error_Msg_Sloc
= System_Location
289 if Restriction_Warnings
(R
) then
290 Restriction_Msg
("|violation of restriction %#?", Rimage
, N
);
292 Restriction_Msg
("|violation of restriction %#", Rimage
, N
);
295 -- Otherwise we have the case of an implicit restriction
296 -- (e.g. a restriction implicitly set by another pragma)
300 ("|violation of implicit restriction %", Rimage
, N
);
303 end Check_Restriction
;
305 ----------------------------------------
306 -- Cunit_Boolean_Restrictions_Restore --
307 ----------------------------------------
309 procedure Cunit_Boolean_Restrictions_Restore
310 (R
: Save_Cunit_Boolean_Restrictions
)
313 for J
in Cunit_Boolean_Restrictions
loop
314 Restrictions
.Set
(J
) := R
(J
);
316 end Cunit_Boolean_Restrictions_Restore
;
318 -------------------------------------
319 -- Cunit_Boolean_Restrictions_Save --
320 -------------------------------------
322 function Cunit_Boolean_Restrictions_Save
323 return Save_Cunit_Boolean_Restrictions
325 R
: Save_Cunit_Boolean_Restrictions
;
328 for J
in Cunit_Boolean_Restrictions
loop
329 R
(J
) := Restrictions
.Set
(J
);
330 Restrictions
.Set
(J
) := False;
334 end Cunit_Boolean_Restrictions_Save
;
336 ------------------------
337 -- Get_Restriction_Id --
338 ------------------------
340 function Get_Restriction_Id
341 (N
: Name_Id
) return Restriction_Id
345 Set_Casing
(All_Upper_Case
);
347 for J
in All_Restrictions
loop
349 S
: constant String := Restriction_Id
'Image (J
);
351 if S
= Name_Buffer
(1 .. Name_Len
) then
357 return Not_A_Restriction_Id
;
358 end Get_Restriction_Id
;
360 -------------------------------
361 -- No_Exception_Handlers_Set --
362 -------------------------------
364 function No_Exception_Handlers_Set
return Boolean is
366 return Restrictions
.Set
(No_Exception_Handlers
);
367 end No_Exception_Handlers_Set
;
369 ----------------------------------
370 -- Process_Restriction_Synonyms --
371 ----------------------------------
373 -- Note: body of this function must be coordinated with list of
374 -- renaming declarations in System.Rident.
376 function Process_Restriction_Synonyms
(N
: Node_Id
) return Name_Id
378 Old_Name
: constant Name_Id
:= Chars
(N
);
383 when Name_Boolean_Entry_Barriers
=>
384 New_Name
:= Name_Simple_Barriers
;
386 when Name_Max_Entry_Queue_Depth
=>
387 New_Name
:= Name_Max_Entry_Queue_Length
;
389 when Name_No_Dynamic_Interrupts
=>
390 New_Name
:= Name_No_Dynamic_Attachment
;
392 when Name_No_Requeue
=>
393 New_Name
:= Name_No_Requeue_Statements
;
395 when Name_No_Task_Attributes
=>
396 New_Name
:= Name_No_Task_Attributes_Package
;
402 if Warn_On_Obsolescent_Feature
then
403 Error_Msg_Name_1
:= Old_Name
;
404 Error_Msg_N
("restriction identifier % is obsolescent?", N
);
405 Error_Msg_Name_1
:= New_Name
;
406 Error_Msg_N
("|use restriction identifier % instead", N
);
410 end Process_Restriction_Synonyms
;
412 ------------------------
413 -- Restricted_Profile --
414 ------------------------
416 function Restricted_Profile
return Boolean is
418 if Restricted_Profile_Cached
then
419 return Restricted_Profile_Result
;
422 Restricted_Profile_Result
:= True;
423 Restricted_Profile_Cached
:= True;
426 R
: Restriction_Flags
renames Profile_Info
(Restricted
).Set
;
427 V
: Restriction_Values
renames Profile_Info
(Restricted
).Value
;
429 for J
in R
'Range loop
431 and then (Restrictions
.Set
(J
) = False
432 or else Restriction_Warnings
(J
)
434 (J
in All_Parameter_Restrictions
435 and then Restrictions
.Value
(J
) > V
(J
)))
437 Restricted_Profile_Result
:= False;
442 return Restricted_Profile_Result
;
445 end Restricted_Profile
;
447 ------------------------
448 -- Restriction_Active --
449 ------------------------
451 function Restriction_Active
(R
: All_Restrictions
) return Boolean is
453 return Restrictions
.Set
(R
);
454 end Restriction_Active
;
456 ---------------------
457 -- Restriction_Msg --
458 ---------------------
460 procedure Restriction_Msg
(Msg
: String; R
: String; N
: Node_Id
) is
461 B
: String (1 .. Msg
'Length + 2 * R
'Length + 1);
465 Name_Buffer
(1 .. R
'Last) := R
;
466 Name_Len
:= R
'Length;
467 Set_Casing
(Identifier_Casing
(Get_Source_File_Index
(Sloc
(N
))));
470 for J
in Msg
'Range loop
471 if Msg
(J
) = '%' then
475 -- Put characters of image in message, quoting upper case letters
477 for J
in 1 .. Name_Len
loop
478 if Name_Buffer
(J
) in 'A' .. 'Z' then
484 B
(P
) := Name_Buffer
(J
);
496 Error_Msg_N
(B
(1 .. P
), N
);
499 ------------------------------
500 -- Set_Profile_Restrictions --
501 ------------------------------
503 procedure Set_Profile_Restrictions
508 R
: Restriction_Flags
renames Profile_Info
(P
).Set
;
509 V
: Restriction_Values
renames Profile_Info
(P
).Value
;
512 for J
in R
'Range loop
514 if J
in All_Boolean_Restrictions
then
515 Set_Restriction
(J
, N
);
517 Set_Restriction
(J
, N
, V
(J
));
520 Restriction_Warnings
(J
) := Warn
;
523 end Set_Profile_Restrictions
;
525 ---------------------
526 -- Set_Restriction --
527 ---------------------
529 -- Case of Boolean restriction
531 procedure Set_Restriction
532 (R
: All_Boolean_Restrictions
;
536 Restrictions
.Set
(R
) := True;
538 if Restricted_Profile_Cached
and Restricted_Profile_Result
then
541 Restricted_Profile_Cached
:= False;
544 -- Set location, but preserve location of system
545 -- restriction for nice error msg with run time name
547 if Restrictions_Loc
(R
) /= System_Location
then
548 Restrictions_Loc
(R
) := Sloc
(N
);
551 -- Record the restriction if we are in the main unit,
552 -- or in the extended main unit. The reason that we
553 -- test separately for Main_Unit is that gnat.adc is
554 -- processed with Current_Sem_Unit = Main_Unit, but
555 -- nodes in gnat.adc do not appear to be the extended
556 -- main source unit (they probably should do ???)
558 if Current_Sem_Unit
= Main_Unit
559 or else In_Extended_Main_Source_Unit
(N
)
561 if not Restriction_Warnings
(R
) then
562 Main_Restrictions
.Set
(R
) := True;
567 -- Case of parameter restriction
569 procedure Set_Restriction
570 (R
: All_Parameter_Restrictions
;
575 if Restricted_Profile_Cached
and Restricted_Profile_Result
then
578 Restricted_Profile_Cached
:= False;
581 if Restrictions
.Set
(R
) then
582 if V
< Restrictions
.Value
(R
) then
583 Restrictions
.Value
(R
) := V
;
584 Restrictions_Loc
(R
) := Sloc
(N
);
588 Restrictions
.Set
(R
) := True;
589 Restrictions
.Value
(R
) := V
;
590 Restrictions_Loc
(R
) := Sloc
(N
);
593 -- Record the restriction if we are in the main unit,
594 -- or in the extended main unit. The reason that we
595 -- test separately for Main_Unit is that gnat.adc is
596 -- processed with Current_Sem_Unit = Main_Unit, but
597 -- nodes in gnat.adc do not appear to be the extended
598 -- main source unit (they probably should do ???)
600 if Current_Sem_Unit
= Main_Unit
601 or else In_Extended_Main_Source_Unit
(N
)
603 if Main_Restrictions
.Set
(R
) then
604 if V
< Main_Restrictions
.Value
(R
) then
605 Main_Restrictions
.Value
(R
) := V
;
608 elsif not Restriction_Warnings
(R
) then
609 Main_Restrictions
.Set
(R
) := True;
610 Main_Restrictions
.Value
(R
) := V
;
615 ----------------------------------
616 -- Suppress_Restriction_Message --
617 ----------------------------------
619 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean is
621 -- We only output messages for the extended main source unit
623 if In_Extended_Main_Source_Unit
(N
) then
626 -- If loaded by rtsfind, then suppress message
628 elsif Sloc
(N
) <= No_Location
then
631 -- Otherwise suppress message if internal file
634 return Is_Internal_File_Name
(Unit_File_Name
(Get_Source_Unit
(N
)));
636 end Suppress_Restriction_Message
;
638 ---------------------
639 -- Tasking_Allowed --
640 ---------------------
642 function Tasking_Allowed
return Boolean is
644 return not Restrictions
.Set
(No_Tasking
)
645 and then (not Restrictions
.Set
(Max_Tasks
)
646 or else Restrictions
.Value
(Max_Tasks
) > 0);