1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002 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 Exp_Util
; use Exp_Util
;
31 with Fname
; use Fname
;
32 with Fname
.UF
; use Fname
.UF
;
34 with Namet
; use Namet
;
36 with Stand
; use Stand
;
37 with Targparm
; use Targparm
;
38 with Tbuild
; use Tbuild
;
39 with Uname
; use Uname
;
41 package body Restrict
is
43 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean;
44 -- N is the node for a possible restriction violation message, but
45 -- the message is to be suppressed if this is an internal file and
46 -- this file is not the main unit.
52 function Abort_Allowed
return Boolean is
55 Restrictions
(No_Abort_Statements
) = False
57 Restriction_Parameters
(Max_Asynchronous_Select_Nesting
) /= 0;
60 ------------------------------------
61 -- Check_Elaboration_Code_Allowed --
62 ------------------------------------
64 procedure Check_Elaboration_Code_Allowed
(N
: Node_Id
) is
66 -- Avoid calling Namet.Unlock/Lock except when there is an error.
67 -- Even in the error case it is a bit dubious, either gigi needs
68 -- the table locked or it does not! ???
70 if Restrictions
(No_Elaboration_Code
)
71 and then not Suppress_Restriction_Message
(N
)
74 Check_Restriction
(No_Elaboration_Code
, N
);
77 end Check_Elaboration_Code_Allowed
;
79 ---------------------------
80 -- Check_Restricted_Unit --
81 ---------------------------
83 procedure Check_Restricted_Unit
(U
: Unit_Name_Type
; N
: Node_Id
) is
85 if Suppress_Restriction_Message
(N
) then
88 elsif Is_Spec_Name
(U
) then
90 Fnam
: constant File_Name_Type
:=
91 Get_File_Name
(U
, Subunit
=> False);
92 R_Id
: Restriction_Id
;
95 if not Is_Predefined_File_Name
(Fnam
) then
98 -- Ada child unit spec, needs checking against list
101 -- Pad name to 8 characters with blanks
103 Get_Name_String
(Fnam
);
104 Name_Len
:= Name_Len
- 4;
106 while Name_Len
< 8 loop
107 Name_Len
:= Name_Len
+ 1;
108 Name_Buffer
(Name_Len
) := ' ';
111 for J
in Unit_Array
'Range loop
113 and then Name_Buffer
(1 .. 8) = Unit_Array
(J
).Filenm
115 R_Id
:= Unit_Array
(J
).Res_Id
;
116 Violations
(R_Id
) := True;
118 if Restrictions
(R_Id
) then
120 S
: constant String := Restriction_Id
'Image (R_Id
);
123 Error_Msg_Unit_1
:= U
;
126 ("|dependence on $ not allowed,", N
);
128 Name_Buffer
(1 .. S
'Last) := S
;
129 Name_Len
:= S
'Length;
130 Set_Casing
(All_Lower_Case
);
131 Error_Msg_Name_1
:= Name_Enter
;
132 Error_Msg_Sloc
:= Restrictions_Loc
(R_Id
);
135 ("\|violates pragma Restriction (%) #", N
);
144 end Check_Restricted_Unit
;
146 -----------------------
147 -- Check_Restriction --
148 -----------------------
150 -- Case of simple identifier (no parameter)
152 procedure Check_Restriction
(R
: Restriction_Id
; N
: Node_Id
) is
154 Violations
(R
) := True;
157 and then not Suppress_Restriction_Message
(N
)
160 S
: constant String := Restriction_Id
'Image (R
);
163 Name_Buffer
(1 .. S
'Last) := S
;
164 Name_Len
:= S
'Length;
165 Set_Casing
(All_Lower_Case
);
166 Error_Msg_Name_1
:= Name_Enter
;
167 Error_Msg_Sloc
:= Restrictions_Loc
(R
);
168 Error_Msg_N
("|violation of restriction %#", N
);
171 end Check_Restriction
;
173 -- Case where a parameter is present (but no count)
175 procedure Check_Restriction
176 (R
: Restriction_Parameter_Id
;
180 if Restriction_Parameters
(R
) = Uint_0
181 and then not Suppress_Restriction_Message
(N
)
184 Loc
: constant Source_Ptr
:= Sloc
(N
);
185 S
: constant String :=
186 Restriction_Parameter_Id
'Image (R
);
190 ("& will be raised at run time?!", N
, Standard_Storage_Error
);
191 Name_Buffer
(1 .. S
'Last) := S
;
192 Name_Len
:= S
'Length;
193 Set_Casing
(All_Lower_Case
);
194 Error_Msg_Name_1
:= Name_Enter
;
195 Error_Msg_Sloc
:= Restriction_Parameters_Loc
(R
);
196 Error_Msg_N
("violation of restriction %?#!", N
);
199 Make_Raise_Storage_Error
(Loc
,
200 Reason
=> SE_Restriction_Violation
));
203 end Check_Restriction
;
205 -- Case where a parameter is present, with a count
207 procedure Check_Restriction
208 (R
: Restriction_Parameter_Id
;
213 if Restriction_Parameters
(R
) /= No_Uint
214 and then V
> Restriction_Parameters
(R
)
215 and then not Suppress_Restriction_Message
(N
)
218 S
: constant String := Restriction_Parameter_Id
'Image (R
);
221 Name_Buffer
(1 .. S
'Last) := S
;
222 Name_Len
:= S
'Length;
223 Set_Casing
(All_Lower_Case
);
224 Error_Msg_Name_1
:= Name_Enter
;
225 Error_Msg_Sloc
:= Restriction_Parameters_Loc
(R
);
226 Error_Msg_N
("|maximum value exceeded for restriction %#", N
);
229 end Check_Restriction
;
231 -------------------------------------------
232 -- Compilation_Unit_Restrictions_Restore --
233 -------------------------------------------
235 procedure Compilation_Unit_Restrictions_Restore
236 (R
: Save_Compilation_Unit_Restrictions
)
239 for J
in Compilation_Unit_Restrictions
loop
240 Restrictions
(J
) := R
(J
);
242 end Compilation_Unit_Restrictions_Restore
;
244 ----------------------------------------
245 -- Compilation_Unit_Restrictions_Save --
246 ----------------------------------------
248 function Compilation_Unit_Restrictions_Save
249 return Save_Compilation_Unit_Restrictions
251 R
: Save_Compilation_Unit_Restrictions
;
254 for J
in Compilation_Unit_Restrictions
loop
255 R
(J
) := Restrictions
(J
);
256 Restrictions
(J
) := False;
260 end Compilation_Unit_Restrictions_Save
;
262 ----------------------------------
263 -- Disallow_In_No_Run_Time_Mode --
264 ----------------------------------
266 procedure Disallow_In_No_Run_Time_Mode
(Enode
: Node_Id
) is
269 if High_Integrity_Mode_On_Target
then
271 ("|this construct not allowed in high integrity mode", Enode
);
274 ("|this construct not allowed in No_Run_Time mode", Enode
);
277 end Disallow_In_No_Run_Time_Mode
;
279 ------------------------
280 -- Get_Restriction_Id --
281 ------------------------
283 function Get_Restriction_Id
285 return Restriction_Id
291 Set_Casing
(All_Upper_Case
);
293 J
:= Restriction_Id
'First;
294 while J
/= Not_A_Restriction_Id
loop
296 S
: constant String := Restriction_Id
'Image (J
);
299 exit when S
= Name_Buffer
(1 .. Name_Len
);
302 J
:= Restriction_Id
'Succ (J
);
306 end Get_Restriction_Id
;
308 ----------------------------------
309 -- Get_Restriction_Parameter_Id --
310 ----------------------------------
312 function Get_Restriction_Parameter_Id
314 return Restriction_Parameter_Id
316 J
: Restriction_Parameter_Id
;
320 Set_Casing
(All_Upper_Case
);
322 J
:= Restriction_Parameter_Id
'First;
323 while J
/= Not_A_Restriction_Parameter_Id
loop
325 S
: constant String := Restriction_Parameter_Id
'Image (J
);
328 exit when S
= Name_Buffer
(1 .. Name_Len
);
331 J
:= Restriction_Parameter_Id
'Succ (J
);
335 end Get_Restriction_Parameter_Id
;
337 -------------------------------
338 -- No_Exception_Handlers_Set --
339 -------------------------------
341 function No_Exception_Handlers_Set
return Boolean is
343 return Restrictions
(No_Exception_Handlers
);
344 end No_Exception_Handlers_Set
;
346 ------------------------
347 -- Restricted_Profile --
348 ------------------------
350 -- This implementation must be coordinated with Set_Restricted_Profile
352 function Restricted_Profile
return Boolean is
354 return Restrictions
(No_Abort_Statements
)
355 and then Restrictions
(No_Asynchronous_Control
)
356 and then Restrictions
(No_Entry_Queue
)
357 and then Restrictions
(No_Task_Hierarchy
)
358 and then Restrictions
(No_Task_Allocators
)
359 and then Restrictions
(No_Dynamic_Priorities
)
360 and then Restrictions
(No_Terminate_Alternatives
)
361 and then Restrictions
(No_Dynamic_Interrupts
)
362 and then Restrictions
(No_Protected_Type_Allocators
)
363 and then Restrictions
(No_Local_Protected_Objects
)
364 and then Restrictions
(No_Requeue
)
365 and then Restrictions
(No_Task_Attributes
)
366 and then Restriction_Parameters
(Max_Asynchronous_Select_Nesting
) = 0
367 and then Restriction_Parameters
(Max_Task_Entries
) = 0
368 and then Restriction_Parameters
(Max_Protected_Entries
) <= 1
369 and then Restriction_Parameters
(Max_Select_Alternatives
) = 0;
370 end Restricted_Profile
;
372 --------------------------
373 -- Set_No_Run_Time_Mode --
374 --------------------------
376 procedure Set_No_Run_Time_Mode
is
379 Restrictions
(No_Exception_Handlers
) := True;
380 Restrictions
(No_Implicit_Dynamic_Code
) := True;
381 Opt
.Global_Discard_Names
:= True;
382 end Set_No_Run_Time_Mode
;
388 procedure Set_Ravenscar
is
390 Set_Restricted_Profile
;
391 Restrictions
(Boolean_Entry_Barriers
) := True;
392 Restrictions
(No_Select_Statements
) := True;
393 Restrictions
(No_Calendar
) := True;
394 Restrictions
(Static_Storage_Size
) := True;
395 Restrictions
(No_Entry_Queue
) := True;
396 Restrictions
(No_Relative_Delay
) := True;
397 Restrictions
(No_Task_Termination
) := True;
398 Restrictions
(No_Implicit_Heap_Allocations
) := True;
401 ----------------------------
402 -- Set_Restricted_Profile --
403 ----------------------------
405 -- This must be coordinated with Restricted_Profile
407 procedure Set_Restricted_Profile
is
409 Restrictions
(No_Abort_Statements
) := True;
410 Restrictions
(No_Asynchronous_Control
) := True;
411 Restrictions
(No_Entry_Queue
) := True;
412 Restrictions
(No_Task_Hierarchy
) := True;
413 Restrictions
(No_Task_Allocators
) := True;
414 Restrictions
(No_Dynamic_Priorities
) := True;
415 Restrictions
(No_Terminate_Alternatives
) := True;
416 Restrictions
(No_Dynamic_Interrupts
) := True;
417 Restrictions
(No_Protected_Type_Allocators
) := True;
418 Restrictions
(No_Local_Protected_Objects
) := True;
419 Restrictions
(No_Requeue
) := True;
420 Restrictions
(No_Task_Attributes
) := True;
422 Restriction_Parameters
(Max_Asynchronous_Select_Nesting
) := Uint_0
;
423 Restriction_Parameters
(Max_Task_Entries
) := Uint_0
;
424 Restriction_Parameters
(Max_Select_Alternatives
) := Uint_0
;
426 if Restriction_Parameters
(Max_Protected_Entries
) /= Uint_0
then
427 Restriction_Parameters
(Max_Protected_Entries
) := Uint_1
;
429 end Set_Restricted_Profile
;
431 ----------------------------------
432 -- Suppress_Restriction_Message --
433 ----------------------------------
435 function Suppress_Restriction_Message
(N
: Node_Id
) return Boolean is
437 -- We only output messages for the extended main source unit
439 if In_Extended_Main_Source_Unit
(N
) then
442 -- If loaded by rtsfind, then suppress message
444 elsif Sloc
(N
) <= No_Location
then
447 -- Otherwise suppress message if internal file
450 return 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
460 return Restriction_Parameters
(Max_Tasks
) /= 0;