1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
28 with Atree
; use Atree
;
29 with Casing
; use Casing
;
30 with Errout
; use Errout
;
31 with Exp_Util
; use Exp_Util
;
32 with Fname
; use Fname
;
33 with Fname
.UF
; use Fname
.UF
;
35 with Namet
; use Namet
;
37 with Stand
; use Stand
;
38 with Targparm
; use Targparm
;
39 with Tbuild
; use Tbuild
;
40 with Uname
; use Uname
;
42 package body Restrict
is
44 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean;
45 -- N is the node for a possible restriction violation message, but
46 -- the message is to be suppressed if this is an internal file and
47 -- this file is not the main unit.
53 function Abort_Allowed
return Boolean is
56 Restrictions
(No_Abort_Statements
) = False
58 Restriction_Parameters
(Max_Asynchronous_Select_Nesting
) /= 0;
61 ------------------------------------
62 -- Check_Elaboration_Code_Allowed --
63 ------------------------------------
65 procedure Check_Elaboration_Code_Allowed
(N
: Node_Id
) is
67 -- Avoid calling Namet.Unlock/Lock except when there is an error.
68 -- Even in the error case it is a bit dubious, either gigi needs
69 -- the table locked or it does not! ???
71 if Restrictions
(No_Elaboration_Code
)
72 and then not Suppress_Restriction_Message
(N
)
75 Check_Restriction
(No_Elaboration_Code
, N
);
78 end Check_Elaboration_Code_Allowed
;
80 ---------------------------
81 -- Check_Restricted_Unit --
82 ---------------------------
84 procedure Check_Restricted_Unit
(U
: Unit_Name_Type
; N
: Node_Id
) is
86 if Suppress_Restriction_Message
(N
) then
89 elsif Is_Spec_Name
(U
) then
91 Fnam
: constant File_Name_Type
:=
92 Get_File_Name
(U
, Subunit
=> False);
93 R_Id
: Restriction_Id
;
96 if not Is_Predefined_File_Name
(Fnam
) then
99 -- Ada child unit spec, needs checking against list
102 -- Pad name to 8 characters with blanks
104 Get_Name_String
(Fnam
);
105 Name_Len
:= Name_Len
- 4;
107 while Name_Len
< 8 loop
108 Name_Len
:= Name_Len
+ 1;
109 Name_Buffer
(Name_Len
) := ' ';
112 for J
in Unit_Array
'Range loop
114 and then Name_Buffer
(1 .. 8) = Unit_Array
(J
).Filenm
116 R_Id
:= Unit_Array
(J
).Res_Id
;
117 Violations
(R_Id
) := True;
119 if Restrictions
(R_Id
) then
121 S
: constant String := Restriction_Id
'Image (R_Id
);
124 Error_Msg_Unit_1
:= U
;
127 ("|dependence on $ not allowed,", N
);
129 Name_Buffer
(1 .. S
'Last) := S
;
130 Name_Len
:= S
'Length;
131 Set_Casing
(All_Lower_Case
);
132 Error_Msg_Name_1
:= Name_Enter
;
133 Error_Msg_Sloc
:= Restrictions_Loc
(R_Id
);
136 ("\|violates pragma Restriction (%) #", N
);
145 end Check_Restricted_Unit
;
147 -----------------------
148 -- Check_Restriction --
149 -----------------------
151 -- Case of simple identifier (no parameter)
153 procedure Check_Restriction
(R
: Restriction_Id
; N
: Node_Id
) is
155 Violations
(R
) := True;
158 and then not Suppress_Restriction_Message
(N
)
161 S
: constant String := Restriction_Id
'Image (R
);
164 Name_Buffer
(1 .. S
'Last) := S
;
165 Name_Len
:= S
'Length;
166 Set_Casing
(All_Lower_Case
);
167 Error_Msg_Name_1
:= Name_Enter
;
168 Error_Msg_Sloc
:= Restrictions_Loc
(R
);
169 Error_Msg_N
("|violation of restriction %#", N
);
172 end Check_Restriction
;
174 -- Case where a parameter is present (but no count)
176 procedure Check_Restriction
177 (R
: Restriction_Parameter_Id
;
181 if Restriction_Parameters
(R
) = Uint_0
182 and then not Suppress_Restriction_Message
(N
)
185 Loc
: constant Source_Ptr
:= Sloc
(N
);
186 S
: constant String :=
187 Restriction_Parameter_Id
'Image (R
);
191 ("& will be raised at run time?!", N
, Standard_Storage_Error
);
192 Name_Buffer
(1 .. S
'Last) := S
;
193 Name_Len
:= S
'Length;
194 Set_Casing
(All_Lower_Case
);
195 Error_Msg_Name_1
:= Name_Enter
;
196 Error_Msg_Sloc
:= Restriction_Parameters_Loc
(R
);
197 Error_Msg_N
("violation of restriction %?#!", N
);
200 Make_Raise_Storage_Error
(Loc
,
201 Reason
=> SE_Restriction_Violation
));
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 Restrictions
(No_Implicit_Dynamic_Code
) := True;
382 Opt
.Global_Discard_Names
:= True;
383 end Set_No_Run_Time_Mode
;
389 procedure Set_Ravenscar
is
391 Set_Restricted_Profile
;
392 Restrictions
(Boolean_Entry_Barriers
) := True;
393 Restrictions
(No_Select_Statements
) := True;
394 Restrictions
(No_Calendar
) := True;
395 Restrictions
(Static_Storage_Size
) := True;
396 Restrictions
(No_Entry_Queue
) := True;
397 Restrictions
(No_Relative_Delay
) := True;
398 Restrictions
(No_Task_Termination
) := True;
399 Restrictions
(No_Implicit_Heap_Allocations
) := True;
402 ----------------------------
403 -- Set_Restricted_Profile --
404 ----------------------------
406 -- This must be coordinated with Restricted_Profile
408 procedure Set_Restricted_Profile
is
410 Restrictions
(No_Abort_Statements
) := True;
411 Restrictions
(No_Asynchronous_Control
) := True;
412 Restrictions
(No_Entry_Queue
) := True;
413 Restrictions
(No_Task_Hierarchy
) := True;
414 Restrictions
(No_Task_Allocators
) := True;
415 Restrictions
(No_Dynamic_Priorities
) := True;
416 Restrictions
(No_Terminate_Alternatives
) := True;
417 Restrictions
(No_Dynamic_Interrupts
) := True;
418 Restrictions
(No_Protected_Type_Allocators
) := True;
419 Restrictions
(No_Local_Protected_Objects
) := True;
420 Restrictions
(No_Requeue
) := True;
421 Restrictions
(No_Task_Attributes
) := True;
423 Restriction_Parameters
(Max_Asynchronous_Select_Nesting
) := Uint_0
;
424 Restriction_Parameters
(Max_Task_Entries
) := Uint_0
;
425 Restriction_Parameters
(Max_Select_Alternatives
) := Uint_0
;
427 if Restriction_Parameters
(Max_Protected_Entries
) /= Uint_0
then
428 Restriction_Parameters
(Max_Protected_Entries
) := Uint_1
;
430 end Set_Restricted_Profile
;
432 ----------------------------------
433 -- Suppress_Restriction_Message --
434 ----------------------------------
436 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean is
438 -- We only output messages for the extended main source unit
440 if In_Extended_Main_Source_Unit
(N
) then
443 -- If loaded by rtsfind, then suppress message
445 elsif Sloc
(N
) <= No_Location
then
448 -- Otherwise suppress message if internal file
451 return Is_Internal_File_Name
(Unit_File_Name
(Get_Source_Unit
(N
)));
453 end Suppress_Restriction_Message
;
455 ---------------------
456 -- Tasking_Allowed --
457 ---------------------
459 function Tasking_Allowed
return Boolean is
461 return Restriction_Parameters
(Max_Tasks
) /= 0;