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);