1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
29 with Atree; use Atree;
30 with Casing; use Casing;
31 with Errout; use Errout;
32 with Exp_Util; use Exp_Util;
33 with Fname; use Fname;
34 with Fname.UF; use Fname.UF;
36 with Namet; use Namet;
37 with Nmake; use Nmake;
39 with Stand; use Stand;
40 with Targparm; use Targparm;
41 with Uname; use Uname;
43 package body Restrict is
45 function Suppress_Restriction_Message (N : Node_Id) return Boolean;
46 -- N is the node for a possible restriction violation message, but
47 -- the message is to be suppressed if this is an internal file and
48 -- this file is not the main unit.
54 function Abort_Allowed return Boolean is
57 Restrictions (No_Abort_Statements) = False
59 Restriction_Parameters (Max_Asynchronous_Select_Nesting) /= 0;
62 ------------------------------------
63 -- Check_Elaboration_Code_Allowed --
64 ------------------------------------
66 procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
68 -- Avoid calling Namet.Unlock/Lock except when there is an error.
69 -- Even in the error case it is a bit dubious, either gigi needs
70 -- the table locked or it does not! ???
72 if Restrictions (No_Elaboration_Code)
73 and then not Suppress_Restriction_Message (N)
76 Check_Restriction (No_Elaboration_Code, N);
79 end Check_Elaboration_Code_Allowed;
81 ---------------------------
82 -- Check_Restricted_Unit --
83 ---------------------------
85 procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
87 if Suppress_Restriction_Message (N) then
90 elsif Is_Spec_Name (U) then
92 Fnam : constant File_Name_Type :=
93 Get_File_Name (U, Subunit => False);
94 R_Id : Restriction_Id;
97 if not Is_Predefined_File_Name (Fnam) then
100 -- Ada child unit spec, needs checking against list
103 -- Pad name to 8 characters with blanks
105 Get_Name_String (Fnam);
106 Name_Len := Name_Len - 4;
108 while Name_Len < 8 loop
109 Name_Len := Name_Len + 1;
110 Name_Buffer (Name_Len) := ' ';
113 for J in Unit_Array'Range loop
115 and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
117 R_Id := Unit_Array (J).Res_Id;
118 Violations (R_Id) := True;
120 if Restrictions (R_Id) then
122 S : constant String := Restriction_Id'Image (R_Id);
125 Error_Msg_Unit_1 := U;
128 ("dependence on $ not allowed,", N);
130 Name_Buffer (1 .. S'Last) := S;
131 Name_Len := S'Length;
132 Set_Casing (All_Lower_Case);
133 Error_Msg_Name_1 := Name_Enter;
134 Error_Msg_Sloc := Restrictions_Loc (R_Id);
137 ("\violates pragma Restriction (%) #", N);
146 end Check_Restricted_Unit;
148 -----------------------
149 -- Check_Restriction --
150 -----------------------
152 -- Case of simple identifier (no parameter)
154 procedure Check_Restriction (R : Restriction_Id; N : Node_Id) is
156 Violations (R) := True;
159 and then not Suppress_Restriction_Message (N)
162 S : constant String := Restriction_Id'Image (R);
165 Name_Buffer (1 .. S'Last) := S;
166 Name_Len := S'Length;
167 Set_Casing (All_Lower_Case);
168 Error_Msg_Name_1 := Name_Enter;
169 Error_Msg_Sloc := Restrictions_Loc (R);
170 Error_Msg_N ("violation of restriction %#", N);
173 end Check_Restriction;
175 -- Case where a parameter is present (but no count)
177 procedure Check_Restriction
178 (R : Restriction_Parameter_Id;
182 if Restriction_Parameters (R) = Uint_0
183 and then not Suppress_Restriction_Message (N)
186 Loc : constant Source_Ptr := Sloc (N);
187 S : constant String :=
188 Restriction_Parameter_Id'Image (R);
192 ("& will be raised at run time?!", N, Standard_Storage_Error);
193 Name_Buffer (1 .. S'Last) := S;
194 Name_Len := S'Length;
195 Set_Casing (All_Lower_Case);
196 Error_Msg_Name_1 := Name_Enter;
197 Error_Msg_Sloc := Restriction_Parameters_Loc (R);
198 Error_Msg_N ("violation of restriction %?#!", N);
201 Make_Raise_Storage_Error (Loc));
204 end Check_Restriction;
206 -- Case where a parameter is present, with a count
208 procedure Check_Restriction
209 (R : Restriction_Parameter_Id;
214 if Restriction_Parameters (R) /= No_Uint
215 and then V > Restriction_Parameters (R)
216 and then not Suppress_Restriction_Message (N)
219 S : constant String := Restriction_Parameter_Id'Image (R);
222 Name_Buffer (1 .. S'Last) := S;
223 Name_Len := S'Length;
224 Set_Casing (All_Lower_Case);
225 Error_Msg_Name_1 := Name_Enter;
226 Error_Msg_Sloc := Restriction_Parameters_Loc (R);
227 Error_Msg_N ("maximum value exceeded for restriction %#", N);
230 end Check_Restriction;
232 -------------------------------------------
233 -- Compilation_Unit_Restrictions_Restore --
234 -------------------------------------------
236 procedure Compilation_Unit_Restrictions_Restore
237 (R : Save_Compilation_Unit_Restrictions)
240 for J in Compilation_Unit_Restrictions loop
241 Restrictions (J) := R (J);
243 end Compilation_Unit_Restrictions_Restore;
245 ----------------------------------------
246 -- Compilation_Unit_Restrictions_Save --
247 ----------------------------------------
249 function Compilation_Unit_Restrictions_Save
250 return Save_Compilation_Unit_Restrictions
252 R : Save_Compilation_Unit_Restrictions;
255 for J in Compilation_Unit_Restrictions loop
256 R (J) := Restrictions (J);
257 Restrictions (J) := False;
261 end Compilation_Unit_Restrictions_Save;
263 ----------------------------------
264 -- Disallow_In_No_Run_Time_Mode --
265 ----------------------------------
267 procedure Disallow_In_No_Run_Time_Mode (Enode : Node_Id) is
270 if High_Integrity_Mode_On_Target then
272 ("this construct not allowed in high integrity mode", Enode);
275 ("this construct not allowed in No_Run_Time mode", Enode);
278 end Disallow_In_No_Run_Time_Mode;
280 ------------------------
281 -- Get_Restriction_Id --
282 ------------------------
284 function Get_Restriction_Id
286 return Restriction_Id
292 Set_Casing (All_Upper_Case);
294 J := Restriction_Id'First;
295 while J /= Not_A_Restriction_Id loop
297 S : constant String := Restriction_Id'Image (J);
300 exit when S = Name_Buffer (1 .. Name_Len);
303 J := Restriction_Id'Succ (J);
307 end Get_Restriction_Id;
309 ----------------------------------
310 -- Get_Restriction_Parameter_Id --
311 ----------------------------------
313 function Get_Restriction_Parameter_Id
315 return Restriction_Parameter_Id
317 J : Restriction_Parameter_Id;
321 Set_Casing (All_Upper_Case);
323 J := Restriction_Parameter_Id'First;
324 while J /= Not_A_Restriction_Parameter_Id loop
326 S : constant String := Restriction_Parameter_Id'Image (J);
329 exit when S = Name_Buffer (1 .. Name_Len);
332 J := Restriction_Parameter_Id'Succ (J);
336 end Get_Restriction_Parameter_Id;
338 -------------------------------
339 -- No_Exception_Handlers_Set --
340 -------------------------------
342 function No_Exception_Handlers_Set return Boolean is
344 return Restrictions (No_Exception_Handlers);
345 end No_Exception_Handlers_Set;
347 ------------------------
348 -- Restricted_Profile --
349 ------------------------
351 -- This implementation must be coordinated with Set_Restricted_Profile
353 function Restricted_Profile return Boolean is
355 return Restrictions (No_Abort_Statements)
356 and then Restrictions (No_Asynchronous_Control)
357 and then Restrictions (No_Entry_Queue)
358 and then Restrictions (No_Task_Hierarchy)
359 and then Restrictions (No_Task_Allocators)
360 and then Restrictions (No_Dynamic_Priorities)
361 and then Restrictions (No_Terminate_Alternatives)
362 and then Restrictions (No_Dynamic_Interrupts)
363 and then Restrictions (No_Protected_Type_Allocators)
364 and then Restrictions (No_Local_Protected_Objects)
365 and then Restrictions (No_Requeue)
366 and then Restrictions (No_Task_Attributes)
367 and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) = 0
368 and then Restriction_Parameters (Max_Task_Entries) = 0
369 and then Restriction_Parameters (Max_Protected_Entries) <= 1
370 and then Restriction_Parameters (Max_Select_Alternatives) = 0;
371 end Restricted_Profile;
373 --------------------------
374 -- Set_No_Run_Time_Mode --
375 --------------------------
377 procedure Set_No_Run_Time_Mode is
380 Restrictions (No_Exception_Handlers) := True;
381 end Set_No_Run_Time_Mode;
387 procedure Set_Ravenscar is
389 Set_Restricted_Profile;
390 Restrictions (Boolean_Entry_Barriers) := True;
391 Restrictions (No_Select_Statements) := True;
392 Restrictions (No_Calendar) := True;
393 Restrictions (Static_Storage_Size) := True;
394 Restrictions (No_Entry_Queue) := True;
395 Restrictions (No_Relative_Delay) := True;
396 Restrictions (No_Task_Termination) := True;
397 Restrictions (No_Implicit_Heap_Allocations) := True;
400 ----------------------------
401 -- Set_Restricted_Profile --
402 ----------------------------
404 -- This must be coordinated with Restricted_Profile
406 procedure Set_Restricted_Profile is
408 Restrictions (No_Abort_Statements) := True;
409 Restrictions (No_Asynchronous_Control) := True;
410 Restrictions (No_Entry_Queue) := True;
411 Restrictions (No_Task_Hierarchy) := True;
412 Restrictions (No_Task_Allocators) := True;
413 Restrictions (No_Dynamic_Priorities) := True;
414 Restrictions (No_Terminate_Alternatives) := True;
415 Restrictions (No_Dynamic_Interrupts) := True;
416 Restrictions (No_Protected_Type_Allocators) := True;
417 Restrictions (No_Local_Protected_Objects) := True;
418 Restrictions (No_Requeue) := True;
419 Restrictions (No_Task_Attributes) := True;
421 Restriction_Parameters (Max_Asynchronous_Select_Nesting) := Uint_0;
422 Restriction_Parameters (Max_Task_Entries) := Uint_0;
423 Restriction_Parameters (Max_Select_Alternatives) := Uint_0;
425 if Restriction_Parameters (Max_Protected_Entries) /= Uint_0 then
426 Restriction_Parameters (Max_Protected_Entries) := Uint_1;
428 end Set_Restricted_Profile;
430 ----------------------------------
431 -- Suppress_Restriction_Message --
432 ----------------------------------
434 function Suppress_Restriction_Message (N : Node_Id) return Boolean is
436 -- If main unit is library unit, then we will output message
438 if In_Extended_Main_Source_Unit (N) then
441 -- If loaded by rtsfind, then suppress message
443 elsif Sloc (N) <= No_Location then
446 -- Otherwise suppress message if internal file
450 Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
452 end Suppress_Restriction_Message;
454 ---------------------
455 -- Tasking_Allowed --
456 ---------------------
458 function Tasking_Allowed return Boolean is
461 Restriction_Parameters (Max_Tasks) /= 0;