blob: 2740fc67d22e2d6a12045bbf89cee1d54cdddcb2 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- R E S T R I C T --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Casing; use Casing;
with Errout; use Errout;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Lib; use Lib;
with Namet; use Namet;
with Sinput; use Sinput;
with Uname; use Uname;
package body Restrict is
-----------------------
-- Local Subprograms --
-----------------------
procedure Restriction_Msg (Msg : String; R : String; N : Node_Id);
-- Output error message at node N with given text, replacing the
-- '%' in the message with the name of the restriction given as R,
-- cased according to the current identifier casing. We do not use
-- the normal insertion mechanism, since this requires an entry
-- in the Names table, and this table will be locked if we are
-- generating a message from gigi.
function Suppress_Restriction_Message (N : Node_Id) return Boolean;
-- N is the node for a possible restriction violation message, but
-- the message is to be suppressed if this is an internal file and
-- this file is not the main unit.
-------------------
-- Abort_Allowed --
-------------------
function Abort_Allowed return Boolean is
begin
if Restrictions (No_Abort_Statements)
and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) = 0
then
return False;
else
return True;
end if;
end Abort_Allowed;
------------------------------------
-- Check_Elaboration_Code_Allowed --
------------------------------------
procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
begin
-- Avoid calling Namet.Unlock/Lock except when there is an error.
-- Even in the error case it is a bit dubious, either gigi needs
-- the table locked or it does not! ???
if Restrictions (No_Elaboration_Code)
and then not Suppress_Restriction_Message (N)
then
Namet.Unlock;
Check_Restriction (Restriction_Id'(No_Elaboration_Code), N);
Namet.Lock;
end if;
end Check_Elaboration_Code_Allowed;
----------------------------------
-- Check_No_Implicit_Heap_Alloc --
----------------------------------
procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is
begin
Check_Restriction (Restriction_Id'(No_Implicit_Heap_Allocations), N);
end Check_No_Implicit_Heap_Alloc;
---------------------------
-- Check_Restricted_Unit --
---------------------------
procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id) is
begin
if Suppress_Restriction_Message (N) then
return;
elsif Is_Spec_Name (U) then
declare
Fnam : constant File_Name_Type :=
Get_File_Name (U, Subunit => False);
R_Id : Restriction_Id;
begin
if not Is_Predefined_File_Name (Fnam) then
return;
-- Ada child unit spec, needs checking against list
else
-- Pad name to 8 characters with blanks
Get_Name_String (Fnam);
Name_Len := Name_Len - 4;
while Name_Len < 8 loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := ' ';
end loop;
for J in Unit_Array'Range loop
if Name_Len = 8
and then Name_Buffer (1 .. 8) = Unit_Array (J).Filenm
then
R_Id := Unit_Array (J).Res_Id;
Violations (R_Id) := True;
if Restrictions (R_Id) then
declare
S : constant String := Restriction_Id'Image (R_Id);
begin
Error_Msg_Unit_1 := U;
Error_Msg_N
("|dependence on $ not allowed,", N);
Name_Buffer (1 .. S'Last) := S;
Name_Len := S'Length;
Set_Casing (All_Lower_Case);
Error_Msg_Name_1 := Name_Enter;
Error_Msg_Sloc := Restrictions_Loc (R_Id);
Error_Msg_N
("\|violates pragma Restriction (%) #", N);
return;
end;
end if;
end if;
end loop;
end if;
end;
end if;
end Check_Restricted_Unit;
-----------------------
-- Check_Restriction --
-----------------------
-- Case of simple identifier (no parameter)
procedure Check_Restriction (R : Restriction_Id; N : Node_Id) is
Rimage : constant String := Restriction_Id'Image (R);
begin
Violations (R) := True;
if (Restrictions (R) or Restriction_Warnings (R))
and then not Suppress_Restriction_Message (N)
then
-- Output proper message. If this is just a case of
-- a restriction warning, then we output a warning msg
if not Restrictions (R) then
Restriction_Msg
("?violation of restriction %", Rimage, N);
-- If this is a real restriction violation, then generate
-- a non-serious message with appropriate location.
else
Error_Msg_Sloc := Restrictions_Loc (R);
-- If we have a location for the Restrictions pragma, output it
if Error_Msg_Sloc > No_Location
or else Error_Msg_Sloc = System_Location
then
Restriction_Msg
("|violation of restriction %#", Rimage, N);
-- Otherwise restriction was implicit (e.g. set by another pragma)
else
Restriction_Msg
("|violation of implicit restriction %", Rimage, N);
end if;
end if;
end if;
end Check_Restriction;
-- Case where a parameter is present, with a count
procedure Check_Restriction
(R : Restriction_Parameter_Id;
V : Uint;
N : Node_Id)
is
begin
if Restriction_Parameters (R) /= No_Uint
and then V > Restriction_Parameters (R)
and then not Suppress_Restriction_Message (N)
then
declare
S : constant String := Restriction_Parameter_Id'Image (R);
begin
Name_Buffer (1 .. S'Last) := S;
Name_Len := S'Length;
Set_Casing (All_Lower_Case);
Error_Msg_Name_1 := Name_Enter;
Error_Msg_Sloc := Restriction_Parameters_Loc (R);
Error_Msg_N ("|maximum value exceeded for restriction %#", N);
end;
end if;
end Check_Restriction;
-- Case where a parameter is present, no count given
procedure Check_Restriction
(R : Restriction_Parameter_Id;
N : Node_Id)
is
begin
if Restriction_Parameters (R) = Uint_0
and then not Suppress_Restriction_Message (N)
then
declare
S : constant String := Restriction_Parameter_Id'Image (R);
begin
Name_Buffer (1 .. S'Last) := S;
Name_Len := S'Length;
Set_Casing (All_Lower_Case);
Error_Msg_Name_1 := Name_Enter;
Error_Msg_Sloc := Restriction_Parameters_Loc (R);
Error_Msg_N ("|maximum value exceeded for restriction %#", N);
end;
end if;
end Check_Restriction;
-------------------------------------------
-- Compilation_Unit_Restrictions_Restore --
-------------------------------------------
procedure Compilation_Unit_Restrictions_Restore
(R : Save_Compilation_Unit_Restrictions)
is
begin
for J in Compilation_Unit_Restrictions loop
Restrictions (J) := R (J);
end loop;
end Compilation_Unit_Restrictions_Restore;
----------------------------------------
-- Compilation_Unit_Restrictions_Save --
----------------------------------------
function Compilation_Unit_Restrictions_Save
return Save_Compilation_Unit_Restrictions
is
R : Save_Compilation_Unit_Restrictions;
begin
for J in Compilation_Unit_Restrictions loop
R (J) := Restrictions (J);
Restrictions (J) := False;
end loop;
return R;
end Compilation_Unit_Restrictions_Save;
------------------------
-- Get_Restriction_Id --
------------------------
function Get_Restriction_Id
(N : Name_Id)
return Restriction_Id
is
J : Restriction_Id;
begin
Get_Name_String (N);
Set_Casing (All_Upper_Case);
J := Restriction_Id'First;
while J /= Not_A_Restriction_Id loop
declare
S : constant String := Restriction_Id'Image (J);
begin
exit when S = Name_Buffer (1 .. Name_Len);
end;
J := Restriction_Id'Succ (J);
end loop;
return J;
end Get_Restriction_Id;
----------------------------------
-- Get_Restriction_Parameter_Id --
----------------------------------
function Get_Restriction_Parameter_Id
(N : Name_Id)
return Restriction_Parameter_Id
is
J : Restriction_Parameter_Id;
begin
Get_Name_String (N);
Set_Casing (All_Upper_Case);
J := Restriction_Parameter_Id'First;
while J /= Not_A_Restriction_Parameter_Id loop
declare
S : constant String := Restriction_Parameter_Id'Image (J);
begin
exit when S = Name_Buffer (1 .. Name_Len);
end;
J := Restriction_Parameter_Id'Succ (J);
end loop;
return J;
end Get_Restriction_Parameter_Id;
-------------------------------
-- No_Exception_Handlers_Set --
-------------------------------
function No_Exception_Handlers_Set return Boolean is
begin
return Restrictions (No_Exception_Handlers);
end No_Exception_Handlers_Set;
------------------------
-- Restricted_Profile --
------------------------
-- This implementation must be coordinated with Set_Restricted_Profile
function Restricted_Profile return Boolean is
begin
return Restrictions (No_Abort_Statements)
and then Restrictions (No_Asynchronous_Control)
and then Restrictions (No_Entry_Queue)
and then Restrictions (No_Task_Hierarchy)
and then Restrictions (No_Task_Allocators)
and then Restrictions (No_Dynamic_Priorities)
and then Restrictions (No_Terminate_Alternatives)
and then Restrictions (No_Dynamic_Interrupts)
and then Restrictions (No_Protected_Type_Allocators)
and then Restrictions (No_Local_Protected_Objects)
and then Restrictions (No_Requeue)
and then Restrictions (No_Task_Attributes)
and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) = 0
and then Restriction_Parameters (Max_Task_Entries) = 0
and then Restriction_Parameters (Max_Protected_Entries) <= 1
and then Restriction_Parameters (Max_Select_Alternatives) = 0;
end Restricted_Profile;
---------------------
-- Restriction_Msg --
---------------------
procedure Restriction_Msg (Msg : String; R : String; N : Node_Id) is
B : String (1 .. Msg'Length + 2 * R'Length + 1);
P : Natural := 1;
begin
Name_Buffer (1 .. R'Last) := R;
Name_Len := R'Length;
Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
P := 0;
for J in Msg'Range loop
if Msg (J) = '%' then
P := P + 1;
B (P) := '`';
-- Put characters of image in message, quoting upper case letters
for J in 1 .. Name_Len loop
if Name_Buffer (J) in 'A' .. 'Z' then
P := P + 1;
B (P) := ''';
end if;
P := P + 1;
B (P) := Name_Buffer (J);
end loop;
P := P + 1;
B (P) := '`';
else
P := P + 1;
B (P) := Msg (J);
end if;
end loop;
Error_Msg_N (B (1 .. P), N);
end Restriction_Msg;
-------------------
-- Set_Ravenscar --
-------------------
procedure Set_Ravenscar (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
begin
Set_Restricted_Profile (N);
Restrictions (Boolean_Entry_Barriers) := True;
Restrictions (No_Select_Statements) := True;
Restrictions (No_Calendar) := True;
Restrictions (No_Entry_Queue) := True;
Restrictions (No_Relative_Delay) := True;
Restrictions (No_Task_Termination) := True;
Restrictions (No_Implicit_Heap_Allocations) := True;
Restrictions_Loc (Boolean_Entry_Barriers) := Loc;
Restrictions_Loc (No_Select_Statements) := Loc;
Restrictions_Loc (No_Calendar) := Loc;
Restrictions_Loc (No_Entry_Queue) := Loc;
Restrictions_Loc (No_Relative_Delay) := Loc;
Restrictions_Loc (No_Task_Termination) := Loc;
Restrictions_Loc (No_Implicit_Heap_Allocations) := Loc;
end Set_Ravenscar;
----------------------------
-- Set_Restricted_Profile --
----------------------------
-- This must be coordinated with Restricted_Profile
procedure Set_Restricted_Profile (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
begin
Restrictions (No_Abort_Statements) := True;
Restrictions (No_Asynchronous_Control) := True;
Restrictions (No_Entry_Queue) := True;
Restrictions (No_Task_Hierarchy) := True;
Restrictions (No_Task_Allocators) := True;
Restrictions (No_Dynamic_Priorities) := True;
Restrictions (No_Terminate_Alternatives) := True;
Restrictions (No_Dynamic_Interrupts) := True;
Restrictions (No_Protected_Type_Allocators) := True;
Restrictions (No_Local_Protected_Objects) := True;
Restrictions (No_Requeue) := True;
Restrictions (No_Task_Attributes) := True;
Restrictions_Loc (No_Abort_Statements) := Loc;
Restrictions_Loc (No_Asynchronous_Control) := Loc;
Restrictions_Loc (No_Entry_Queue) := Loc;
Restrictions_Loc (No_Task_Hierarchy) := Loc;
Restrictions_Loc (No_Task_Allocators) := Loc;
Restrictions_Loc (No_Dynamic_Priorities) := Loc;
Restrictions_Loc (No_Terminate_Alternatives) := Loc;
Restrictions_Loc (No_Dynamic_Interrupts) := Loc;
Restrictions_Loc (No_Protected_Type_Allocators) := Loc;
Restrictions_Loc (No_Local_Protected_Objects) := Loc;
Restrictions_Loc (No_Requeue) := Loc;
Restrictions_Loc (No_Task_Attributes) := Loc;
Restriction_Parameters (Max_Asynchronous_Select_Nesting) := Uint_0;
Restriction_Parameters (Max_Task_Entries) := Uint_0;
Restriction_Parameters (Max_Select_Alternatives) := Uint_0;
if Restriction_Parameters (Max_Protected_Entries) /= Uint_0 then
Restriction_Parameters (Max_Protected_Entries) := Uint_1;
end if;
end Set_Restricted_Profile;
----------------------------------
-- Suppress_Restriction_Message --
----------------------------------
function Suppress_Restriction_Message (N : Node_Id) return Boolean is
begin
-- We only output messages for the extended main source unit
if In_Extended_Main_Source_Unit (N) then
return False;
-- If loaded by rtsfind, then suppress message
elsif Sloc (N) <= No_Location then
return True;
-- Otherwise suppress message if internal file
else
return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
end if;
end Suppress_Restriction_Message;
---------------------
-- Tasking_Allowed --
---------------------
function Tasking_Allowed return Boolean is
begin
return Restriction_Parameters (Max_Tasks) /= 0
and then not Restrictions (No_Tasking);
end Tasking_Allowed;
end Restrict;