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 Snames; use Snames;
with Uname; use Uname;
package body Restrict is
procedure Restriction_Msg (Msg : String; R : String; N : Node_Id);
function Suppress_Restriction_Message (N : Node_Id) return Boolean;
function Abort_Allowed return Boolean is
begin
if Restrictions.Set (No_Abort_Statements)
and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0
then
return False;
else
return True;
end if;
end Abort_Allowed;
procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
begin
if Restrictions.Set (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;
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;
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);
begin
if not Is_Predefined_File_Name (Fnam) then
return;
else
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
Check_Restriction (Unit_Array (J).Res_Id, N);
end if;
end loop;
end if;
end;
end if;
end Check_Restricted_Unit;
procedure Check_Restriction
(R : Restriction_Id;
N : Node_Id;
V : Uint := Uint_Minus_1)
is
Rimage : constant String := Restriction_Id'Image (R);
VV : Integer;
procedure Update_Restrictions (Info : in out Restrictions_Info);
procedure Update_Restrictions (Info : in out Restrictions_Info) is
begin
if not Info.Violated (R) then
Info.Violated (R) := True;
if R in All_Parameter_Restrictions then
if VV < 0 then
Info.Unknown (R) := True;
Info.Count (R) := 1;
else
Info.Count (R) := VV;
end if;
end if;
elsif R in All_Parameter_Restrictions then
if VV < 0 then
Info.Unknown (R) := True;
elsif R in Checked_Max_Parameter_Restrictions then
Info.Count (R) := Integer'Max (Info.Count (R), VV);
elsif R in Checked_Add_Parameter_Restrictions then
declare
pragma Unsuppress (Overflow_Check);
begin
Info.Count (R) := Info.Count (R) + VV;
exception
when Constraint_Error =>
Info.Count (R) := Integer'Last;
Info.Unknown (R) := True;
end;
else
raise Program_Error;
end if;
end if;
end Update_Restrictions;
begin
if UI_Is_In_Int_Range (V) then
VV := Integer (UI_To_Int (V));
else
VV := -1;
end if;
pragma Assert (VV < 0 or else R in Checked_Val_Parameter_Restrictions);
if VV = 0 then
return;
end if;
Update_Restrictions (Restrictions);
if Current_Sem_Unit = Main_Unit
or else In_Extended_Main_Source_Unit (N)
then
Update_Restrictions (Main_Restrictions);
end if;
if Suppress_Restriction_Message (N) then
null;
elsif not Restrictions.Set (R) then
null;
elsif R in All_Boolean_Restrictions
or else (Restrictions.Unknown (R)
and then Restrictions.Value (R) = 0)
or else Restrictions.Count (R) > Restrictions.Value (R)
then
Error_Msg_Sloc := Restrictions_Loc (R);
if Error_Msg_Sloc > No_Location
or else Error_Msg_Sloc = System_Location
then
if Restriction_Warnings (R) then
Restriction_Msg ("|violation of restriction %#?", Rimage, N);
else
Restriction_Msg ("|violation of restriction %#", Rimage, N);
end if;
else
Restriction_Msg
("|violation of implicit restriction %", Rimage, N);
end if;
end if;
end Check_Restriction;
procedure Cunit_Boolean_Restrictions_Restore
(R : Save_Cunit_Boolean_Restrictions)
is
begin
for J in Cunit_Boolean_Restrictions loop
Restrictions.Set (J) := R (J);
end loop;
end Cunit_Boolean_Restrictions_Restore;
function Cunit_Boolean_Restrictions_Save
return Save_Cunit_Boolean_Restrictions
is
R : Save_Cunit_Boolean_Restrictions;
begin
for J in Cunit_Boolean_Restrictions loop
R (J) := Restrictions.Set (J);
Restrictions.Set (J) := False;
end loop;
return R;
end Cunit_Boolean_Restrictions_Save;
function Get_Restriction_Id
(N : Name_Id) return Restriction_Id
is
begin
Get_Name_String (N);
Set_Casing (All_Upper_Case);
for J in All_Restrictions loop
declare
S : constant String := Restriction_Id'Image (J);
begin
if S = Name_Buffer (1 .. Name_Len) then
return J;
end if;
end;
end loop;
return Not_A_Restriction_Id;
end Get_Restriction_Id;
function No_Exception_Handlers_Set return Boolean is
begin
return Restrictions.Set (No_Exception_Handlers);
end No_Exception_Handlers_Set;
function Process_Restriction_Synonyms (Id : Name_Id) return Name_Id is
begin
case Id is
when Name_Boolean_Entry_Barriers =>
return Name_Simple_Barriers;
when Name_Max_Entry_Queue_Depth =>
return Name_Max_Entry_Queue_Length;
when Name_No_Dynamic_Interrupts =>
return Name_No_Dynamic_Attachment;
when Name_No_Requeue =>
return Name_No_Requeue_Statements;
when Name_No_Task_Attributes =>
return Name_No_Task_Attributes_Package;
when others =>
return Id;
end case;
end Process_Restriction_Synonyms;
function Restricted_Profile return Boolean is
begin
return Restrictions.Set (No_Abort_Statements)
and then Restrictions.Set (No_Asynchronous_Control)
and then Restrictions.Set (No_Entry_Queue)
and then Restrictions.Set (No_Task_Hierarchy)
and then Restrictions.Set (No_Task_Allocators)
and then Restrictions.Set (No_Dynamic_Priorities)
and then Restrictions.Set (No_Terminate_Alternatives)
and then Restrictions.Set (No_Dynamic_Attachment)
and then Restrictions.Set (No_Protected_Type_Allocators)
and then Restrictions.Set (No_Local_Protected_Objects)
and then Restrictions.Set (No_Requeue_Statements)
and then Restrictions.Set (No_Task_Attributes_Package)
and then Restrictions.Set (Max_Asynchronous_Select_Nesting)
and then Restrictions.Set (Max_Task_Entries)
and then Restrictions.Set (Max_Protected_Entries)
and then Restrictions.Set (Max_Select_Alternatives)
and then Restrictions.Value (Max_Asynchronous_Select_Nesting) = 0
and then Restrictions.Value (Max_Task_Entries) = 0
and then Restrictions.Value (Max_Protected_Entries) <= 1
and then Restrictions.Value (Max_Select_Alternatives) = 0;
end Restricted_Profile;
function Restriction_Active (R : All_Restrictions) return Boolean is
begin
return Restrictions.Set (R);
end Restriction_Active;
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) := '`';
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;
procedure Set_Ravenscar (N : Node_Id) is
begin
Set_Restricted_Profile (N);
Set_Restriction (Simple_Barriers, N);
Set_Restriction (No_Select_Statements, N);
Set_Restriction (No_Calendar, N);
Set_Restriction (No_Entry_Queue, N);
Set_Restriction (No_Relative_Delay, N);
Set_Restriction (No_Task_Termination, N);
Set_Restriction (No_Implicit_Heap_Allocations, N);
end Set_Ravenscar;
procedure Set_Restricted_Profile (N : Node_Id) is
begin
Set_Restriction (No_Abort_Statements, N);
Set_Restriction (No_Asynchronous_Control, N);
Set_Restriction (No_Entry_Queue, N);
Set_Restriction (No_Task_Hierarchy, N);
Set_Restriction (No_Task_Allocators, N);
Set_Restriction (No_Dynamic_Priorities, N);
Set_Restriction (No_Terminate_Alternatives, N);
Set_Restriction (No_Dynamic_Attachment, N);
Set_Restriction (No_Protected_Type_Allocators, N);
Set_Restriction (No_Local_Protected_Objects, N);
Set_Restriction (No_Requeue_Statements, N);
Set_Restriction (No_Task_Attributes_Package, N);
Set_Restriction (Max_Asynchronous_Select_Nesting, N, 0);
Set_Restriction (Max_Task_Entries, N, 0);
Set_Restriction (Max_Select_Alternatives, N, 0);
Set_Restriction (Max_Protected_Entries, N, 1);
end Set_Restricted_Profile;
procedure Set_Restriction
(R : All_Boolean_Restrictions;
N : Node_Id)
is
begin
Restrictions.Set (R) := True;
if Restrictions_Loc (R) /= System_Location then
Restrictions_Loc (R) := Sloc (N);
end if;
if Current_Sem_Unit = Main_Unit
or else In_Extended_Main_Source_Unit (N)
then
if not Restriction_Warnings (R) then
Main_Restrictions.Set (R) := True;
end if;
end if;
end Set_Restriction;
procedure Set_Restriction
(R : All_Parameter_Restrictions;
N : Node_Id;
V : Integer)
is
begin
if Restrictions.Set (R) then
if V < Restrictions.Value (R) then
Restrictions.Value (R) := V;
Restrictions_Loc (R) := Sloc (N);
end if;
else
Restrictions.Set (R) := True;
Restrictions.Value (R) := V;
Restrictions_Loc (R) := Sloc (N);
end if;
if Current_Sem_Unit = Main_Unit
or else In_Extended_Main_Source_Unit (N)
then
if Main_Restrictions.Set (R) then
if V < Main_Restrictions.Value (R) then
Main_Restrictions.Value (R) := V;
end if;
elsif not Restriction_Warnings (R) then
Main_Restrictions.Set (R) := True;
Main_Restrictions.Value (R) := V;
end if;
end if;
end Set_Restriction;
function Suppress_Restriction_Message (N : Node_Id) return Boolean is
begin
if In_Extended_Main_Source_Unit (N) then
return False;
elsif Sloc (N) <= No_Location then
return True;
else
return Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
end if;
end Suppress_Restriction_Message;
function Tasking_Allowed return Boolean is
begin
return not Restrictions.Set (No_Tasking)
and then (not Restrictions.Set (Max_Tasks)
or else Restrictions.Value (Max_Tasks) > 0);
end Tasking_Allowed;
end Restrict;