blob: f12c1eb1c832df1e9d91a15d10c5529483514cfc [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- R E S T R I C T --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, 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, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, 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 Opt; use Opt;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames;
with Uname; use Uname;
package body Restrict is
Restricted_Profile_Result : Boolean := False;
-- This switch memoizes the result of Restricted_Profile function
-- calls for improved efficiency. Its setting is valid only if
-- Restricted_Profile_Cached is True. Note that if this switch
-- is ever set True, it need never be turned off again.
Restricted_Profile_Cached : Boolean := False;
-- This flag is set to True if the Restricted_Profile_Result
-- contains the correct cached result of Restricted_Profile calls.
-----------------------
-- 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 Same_Unit (U1, U2 : Node_Id) return Boolean;
-- Returns True iff U1 and U2 represent the same library unit. Used for
-- handling of No_Dependence => Unit restriction case.
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.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;
------------------------------------
-- 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.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;
----------------------------------
-- 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);
begin
if not Is_Predefined_File_Name (Fnam) then
return;
-- Predefined 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
Check_Restriction (Unit_Array (J).Res_Id, N);
end if;
end loop;
end if;
end;
end if;
end Check_Restricted_Unit;
-----------------------
-- Check_Restriction --
-----------------------
procedure Check_Restriction
(R : Restriction_Id;
N : Node_Id;
V : Uint := Uint_Minus_1)
is
Rimage : constant String := Restriction_Id'Image (R);
VV : Integer;
-- V converted to integer form. If V is greater than Integer'Last,
-- it is reset to minus 1 (unknown value).
procedure Update_Restrictions (Info : in out Restrictions_Info);
-- Update violation information in Info.Violated and Info.Count
-------------------------
-- Update_Restrictions --
-------------------------
procedure Update_Restrictions (Info : in out Restrictions_Info) is
begin
-- If not violated, set as violated now
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;
-- Otherwise if violated already and a parameter restriction,
-- update count by maximizing or summing depending on restriction.
elsif R in All_Parameter_Restrictions then
-- If new value is unknown, result is unknown
if VV < 0 then
Info.Unknown (R) := True;
-- If checked by maximization, do maximization
elsif R in Checked_Max_Parameter_Restrictions then
Info.Count (R) := Integer'Max (Info.Count (R), VV);
-- If checked by adding, do add, checking for overflow
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;
-- Should not be able to come here, known counts should only
-- occur for restrictions that are Checked_max or Checked_Sum.
else
raise Program_Error;
end if;
end if;
end Update_Restrictions;
-- Start of processing for Check_Restriction
begin
if UI_Is_In_Int_Range (V) then
VV := Integer (UI_To_Int (V));
else
VV := -1;
end if;
-- Count can only be specified in the checked val parameter case
pragma Assert (VV < 0 or else R in Checked_Val_Parameter_Restrictions);
-- Nothing to do if value of zero specified for parameter restriction
if VV = 0 then
return;
end if;
-- Update current restrictions
Update_Restrictions (Restrictions);
-- If in main extended unit, update main restrictions as well
if Current_Sem_Unit = Main_Unit
or else In_Extended_Main_Source_Unit (N)
then
Update_Restrictions (Main_Restrictions);
end if;
-- Nothing to do if restriction message suppressed
if Suppress_Restriction_Message (N) then
null;
-- If restriction not set, nothing to do
elsif not Restrictions.Set (R) then
null;
-- Here if restriction set, check for violation (either this is a
-- Boolean restriction, or a parameter restriction with a value of
-- zero and an unknown count, or a parameter restriction with a
-- known value that exceeds the restriction count).
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 we have a location for the Restrictions pragma, output it
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;
-- Otherwise we have the case of an implicit restriction
-- (e.g. a restriction implicitly set by another pragma)
else
Restriction_Msg
("|violation of implicit restriction %", Rimage, N);
end if;
end if;
end Check_Restriction;
-------------------------------------
-- Check_Restriction_No_Dependence --
-------------------------------------
procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is
DU : Node_Id;
begin
for J in No_Dependence.First .. No_Dependence.Last loop
DU := No_Dependence.Table (J).Unit;
if Same_Unit (U, DU) then
Error_Msg_Sloc := Sloc (DU);
Error_Msg_Node_1 := DU;
if No_Dependence.Table (J).Warn then
Error_Msg
("?violation of restriction `No_Dependence '='> &`#",
Sloc (Err));
else
Error_Msg
("|violation of restriction `No_Dependence '='> &`#",
Sloc (Err));
end if;
return;
end if;
end loop;
end Check_Restriction_No_Dependence;
----------------------------------------
-- Cunit_Boolean_Restrictions_Restore --
----------------------------------------
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;
-------------------------------------
-- Cunit_Boolean_Restrictions_Save --
-------------------------------------
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;
------------------------
-- Get_Restriction_Id --
------------------------
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;
-------------------------------
-- No_Exception_Handlers_Set --
-------------------------------
function No_Exception_Handlers_Set return Boolean is
begin
return Restrictions.Set (No_Exception_Handlers);
end No_Exception_Handlers_Set;
----------------------------------
-- Process_Restriction_Synonyms --
----------------------------------
-- Note: body of this function must be coordinated with list of
-- renaming declarations in System.Rident.
function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
is
Old_Name : constant Name_Id := Chars (N);
New_Name : Name_Id;
begin
case Old_Name is
when Name_Boolean_Entry_Barriers =>
New_Name := Name_Simple_Barriers;
when Name_Max_Entry_Queue_Depth =>
New_Name := Name_Max_Entry_Queue_Length;
when Name_No_Dynamic_Interrupts =>
New_Name := Name_No_Dynamic_Attachment;
when Name_No_Requeue =>
New_Name := Name_No_Requeue_Statements;
when Name_No_Task_Attributes =>
New_Name := Name_No_Task_Attributes_Package;
when others =>
return Old_Name;
end case;
if Warn_On_Obsolescent_Feature then
Error_Msg_Name_1 := Old_Name;
Error_Msg_N ("restriction identifier % is obsolescent?", N);
Error_Msg_Name_1 := New_Name;
Error_Msg_N ("|use restriction identifier % instead", N);
end if;
return New_Name;
end Process_Restriction_Synonyms;
------------------------
-- Restricted_Profile --
------------------------
function Restricted_Profile return Boolean is
begin
if Restricted_Profile_Cached then
return Restricted_Profile_Result;
else
Restricted_Profile_Result := True;
Restricted_Profile_Cached := True;
declare
R : Restriction_Flags renames Profile_Info (Restricted).Set;
V : Restriction_Values renames Profile_Info (Restricted).Value;
begin
for J in R'Range loop
if R (J)
and then (Restrictions.Set (J) = False
or else Restriction_Warnings (J)
or else
(J in All_Parameter_Restrictions
and then Restrictions.Value (J) > V (J)))
then
Restricted_Profile_Result := False;
exit;
end if;
end loop;
return Restricted_Profile_Result;
end;
end if;
end Restricted_Profile;
------------------------
-- Restriction_Active --
------------------------
function Restriction_Active (R : All_Restrictions) return Boolean is
begin
return Restrictions.Set (R);
end Restriction_Active;
---------------------
-- 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;
---------------
-- Same_Unit --
---------------
function Same_Unit (U1, U2 : Node_Id) return Boolean is
begin
if Nkind (U1) = N_Identifier then
return Nkind (U2) = N_Identifier and then Chars (U1) = Chars (U2);
elsif Nkind (U2) = N_Identifier then
return False;
elsif (Nkind (U1) = N_Selected_Component
or else Nkind (U1) = N_Expanded_Name)
and then
(Nkind (U2) = N_Selected_Component
or else Nkind (U2) = N_Expanded_Name)
then
return Same_Unit (Prefix (U1), Prefix (U2))
and then Same_Unit (Selector_Name (U1), Selector_Name (U2));
else
return False;
end if;
end Same_Unit;
------------------------------
-- Set_Profile_Restrictions --
------------------------------
procedure Set_Profile_Restrictions
(P : Profile_Name;
N : Node_Id;
Warn : Boolean)
is
R : Restriction_Flags renames Profile_Info (P).Set;
V : Restriction_Values renames Profile_Info (P).Value;
begin
for J in R'Range loop
if R (J) then
if J in All_Boolean_Restrictions then
Set_Restriction (J, N);
else
Set_Restriction (J, N, V (J));
end if;
Restriction_Warnings (J) := Warn;
end if;
end loop;
end Set_Profile_Restrictions;
---------------------
-- Set_Restriction --
---------------------
-- Case of Boolean restriction
procedure Set_Restriction
(R : All_Boolean_Restrictions;
N : Node_Id)
is
begin
Restrictions.Set (R) := True;
if Restricted_Profile_Cached and Restricted_Profile_Result then
null;
else
Restricted_Profile_Cached := False;
end if;
-- Set location, but preserve location of system
-- restriction for nice error msg with run time name
if Restrictions_Loc (R) /= System_Location then
Restrictions_Loc (R) := Sloc (N);
end if;
-- Record the restriction if we are in the main unit,
-- or in the extended main unit. The reason that we
-- test separately for Main_Unit is that gnat.adc is
-- processed with Current_Sem_Unit = Main_Unit, but
-- nodes in gnat.adc do not appear to be the extended
-- main source unit (they probably should do ???)
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;
-- Case of parameter restriction
procedure Set_Restriction
(R : All_Parameter_Restrictions;
N : Node_Id;
V : Integer)
is
begin
if Restricted_Profile_Cached and Restricted_Profile_Result then
null;
else
Restricted_Profile_Cached := False;
end if;
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;
-- Record the restriction if we are in the main unit,
-- or in the extended main unit. The reason that we
-- test separately for Main_Unit is that gnat.adc is
-- processed with Current_Sem_Unit = Main_Unit, but
-- nodes in gnat.adc do not appear to be the extended
-- main source unit (they probably should do ???)
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;
-----------------------------------
-- Set_Restriction_No_Dependence --
-----------------------------------
procedure Set_Restriction_No_Dependence
(Unit : Node_Id;
Warn : Boolean)
is
begin
-- Loop to check for duplicate entry
for J in No_Dependence.First .. No_Dependence.Last loop
-- Case of entry already in table
if Same_Unit (Unit, No_Dependence.Table (J).Unit) then
-- Error has precedence over warning
if not Warn then
No_Dependence.Table (J).Warn := False;
end if;
return;
end if;
end loop;
-- Entry is in table
No_Dependence.Append ((Unit, Warn));
end Set_Restriction_No_Dependence;
----------------------------------
-- 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 not Restrictions.Set (No_Tasking)
and then (not Restrictions.Set (Max_Tasks)
or else Restrictions.Value (Max_Tasks) > 0);
end Tasking_Allowed;
end Restrict;