913 lines
28 KiB
Ada
913 lines
28 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- R E S T R I C T --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 1992-2008, 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 3, 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 COPYING3. If not, go to --
|
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
|
-- --
|
|
-- 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 Debug; use Debug;
|
|
with Fname; use Fname;
|
|
with Fname.UF; use Fname.UF;
|
|
with Lib; use Lib;
|
|
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 (R : Restriction_Id; N : Node_Id);
|
|
-- Called if a violation of restriction R at node N is found. This routine
|
|
-- outputs the appropriate message or messages taking care of warning vs
|
|
-- real violation, serious vs non-serious, implicit vs explicit, the second
|
|
-- message giving the profile name if needed, and the location information.
|
|
|
|
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. Returns True if message is to be suppressed.
|
|
|
|
-------------------
|
|
-- 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_Compiler_Unit --
|
|
-------------------------
|
|
|
|
procedure Check_Compiler_Unit (N : Node_Id) is
|
|
begin
|
|
if Is_Compiler_Unit (Get_Source_Unit (N)) then
|
|
Error_Msg_N ("use of construct not allowed in compiler", N);
|
|
end if;
|
|
end Check_Compiler_Unit;
|
|
|
|
------------------------------------
|
|
-- Check_Elaboration_Code_Allowed --
|
|
------------------------------------
|
|
|
|
procedure Check_Elaboration_Code_Allowed (N : Node_Id) is
|
|
begin
|
|
Check_Restriction (No_Elaboration_Code, N);
|
|
end Check_Elaboration_Code_Allowed;
|
|
|
|
-----------------------------------------
|
|
-- Check_Implicit_Dynamic_Code_Allowed --
|
|
-----------------------------------------
|
|
|
|
procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id) is
|
|
begin
|
|
Check_Restriction (No_Implicit_Dynamic_Code, N);
|
|
end Check_Implicit_Dynamic_Code_Allowed;
|
|
|
|
----------------------------------
|
|
-- Check_No_Implicit_Heap_Alloc --
|
|
----------------------------------
|
|
|
|
procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is
|
|
begin
|
|
Check_Restriction (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
|
|
-- Get file name
|
|
|
|
Get_Name_String (Fnam);
|
|
|
|
-- Nothing to do if name not at least 5 characters long ending
|
|
-- in .ads or .adb extension, which we strip.
|
|
|
|
if Name_Len < 5
|
|
or else (Name_Buffer (Name_Len - 3 .. Name_Len) /= ".ads"
|
|
and then
|
|
Name_Buffer (Name_Len - 3 .. Name_Len) /= ".adb")
|
|
then
|
|
return;
|
|
end if;
|
|
|
|
-- Strip extension and pad to eight characters
|
|
|
|
Name_Len := Name_Len - 4;
|
|
Add_Str_To_Name_Buffer ((Name_Len + 1 .. 8 => ' '));
|
|
|
|
-- If predefined unit, check the list of restricted units
|
|
|
|
if Is_Predefined_File_Name (Fnam) then
|
|
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;
|
|
|
|
-- If not predefined unit, then one special check still
|
|
-- remains. GNAT.Current_Exception is not allowed if we have
|
|
-- restriction No_Exception_Propagation active.
|
|
|
|
else
|
|
if Name_Buffer (1 .. 8) = "g-curexc" then
|
|
Check_Restriction (No_Exception_Propagation, N);
|
|
end if;
|
|
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
|
|
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
|
|
Restriction_Msg (R, N);
|
|
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
|
|
-- Ignore call if node U is not in the main source unit. This avoids
|
|
-- cascaded errors, e.g. when Ada.Containers units with other units.
|
|
|
|
if not In_Extended_Main_Source_Unit (U) then
|
|
return;
|
|
end if;
|
|
|
|
-- Loop through entries in No_Dependence table to check each one in turn
|
|
|
|
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 (No_Run_Time_Mode or else Configurable_Run_Time_Mode)
|
|
and then (Restrictions.Set (No_Exception_Handlers)
|
|
or else
|
|
Restrictions.Set (No_Exception_Propagation));
|
|
end No_Exception_Handlers_Set;
|
|
|
|
-------------------------------------
|
|
-- No_Exception_Propagation_Active --
|
|
-------------------------------------
|
|
|
|
function No_Exception_Propagation_Active return Boolean is
|
|
begin
|
|
return (No_Run_Time_Mode
|
|
or else Configurable_Run_Time_Mode
|
|
or else Debug_Flag_Dot_G)
|
|
and then Restriction_Active (No_Exception_Propagation);
|
|
end No_Exception_Propagation_Active;
|
|
|
|
----------------------------------
|
|
-- 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) and then not Restriction_Warnings (R);
|
|
end Restriction_Active;
|
|
|
|
---------------------
|
|
-- Restriction_Msg --
|
|
---------------------
|
|
|
|
procedure Restriction_Msg (R : Restriction_Id; N : Node_Id) is
|
|
Msg : String (1 .. 100);
|
|
Len : Natural := 0;
|
|
|
|
procedure Add_Char (C : Character);
|
|
-- Append given character to Msg, bumping Len
|
|
|
|
procedure Add_Str (S : String);
|
|
-- Append given string to Msg, bumping Len appropriately
|
|
|
|
procedure Id_Case (S : String; Quotes : Boolean := True);
|
|
-- Given a string S, case it according to current identifier casing,
|
|
-- and store in Error_Msg_String. Then append `~` to the message buffer
|
|
-- to output the string unchanged surrounded in quotes. The quotes are
|
|
-- suppressed if Quotes = False.
|
|
|
|
--------------
|
|
-- Add_Char --
|
|
--------------
|
|
|
|
procedure Add_Char (C : Character) is
|
|
begin
|
|
Len := Len + 1;
|
|
Msg (Len) := C;
|
|
end Add_Char;
|
|
|
|
-------------
|
|
-- Add_Str --
|
|
-------------
|
|
|
|
procedure Add_Str (S : String) is
|
|
begin
|
|
Msg (Len + 1 .. Len + S'Length) := S;
|
|
Len := Len + S'Length;
|
|
end Add_Str;
|
|
|
|
-------------
|
|
-- Id_Case --
|
|
-------------
|
|
|
|
procedure Id_Case (S : String; Quotes : Boolean := True) is
|
|
begin
|
|
Name_Buffer (1 .. S'Last) := S;
|
|
Name_Len := S'Length;
|
|
Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
|
|
Error_Msg_Strlen := Name_Len;
|
|
Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
|
|
|
|
if Quotes then
|
|
Add_Str ("`~`");
|
|
else
|
|
Add_Char ('~');
|
|
end if;
|
|
end Id_Case;
|
|
|
|
-- Start of processing for Restriction_Msg
|
|
|
|
begin
|
|
-- Set warning message if warning
|
|
|
|
if Restriction_Warnings (R) then
|
|
Add_Char ('?');
|
|
|
|
-- If real violation (not warning), then mark it as non-serious unless
|
|
-- it is a violation of No_Finalization in which case we leave it as a
|
|
-- serious message, since otherwise we get crashes during attempts to
|
|
-- expand stuff that is not properly formed due to assumptions made
|
|
-- about no finalization being present.
|
|
|
|
elsif R /= No_Finalization then
|
|
Add_Char ('|');
|
|
end if;
|
|
|
|
Error_Msg_Sloc := Restrictions_Loc (R);
|
|
|
|
-- Set main message, adding implicit if no source location
|
|
|
|
if Error_Msg_Sloc > No_Location
|
|
or else Error_Msg_Sloc = System_Location
|
|
then
|
|
Add_Str ("violation of restriction ");
|
|
else
|
|
Add_Str ("violation of implicit restriction ");
|
|
Error_Msg_Sloc := No_Location;
|
|
end if;
|
|
|
|
-- Case of parametrized restriction
|
|
|
|
if R in All_Parameter_Restrictions then
|
|
Add_Char ('`');
|
|
Id_Case (Restriction_Id'Image (R), Quotes => False);
|
|
Add_Str (" = ^`");
|
|
Error_Msg_Uint_1 := UI_From_Int (Int (Restrictions.Value (R)));
|
|
|
|
-- Case of boolean restriction
|
|
|
|
else
|
|
Id_Case (Restriction_Id'Image (R));
|
|
end if;
|
|
|
|
-- Case of no secondary profile continuation message
|
|
|
|
if Restriction_Profile_Name (R) = No_Profile then
|
|
if Error_Msg_Sloc /= No_Location then
|
|
Add_Char ('#');
|
|
end if;
|
|
|
|
Add_Char ('!');
|
|
Error_Msg_N (Msg (1 .. Len), N);
|
|
|
|
-- Case of secondary profile continuation message present
|
|
|
|
else
|
|
Add_Char ('!');
|
|
Error_Msg_N (Msg (1 .. Len), N);
|
|
|
|
Len := 0;
|
|
Add_Char ('\');
|
|
|
|
-- Set as warning if warning case
|
|
|
|
if Restriction_Warnings (R) then
|
|
Add_Char ('?');
|
|
end if;
|
|
|
|
-- Set main message
|
|
|
|
Add_Str ("from profile ");
|
|
Id_Case (Profile_Name'Image (Restriction_Profile_Name (R)));
|
|
|
|
-- Add location if we have one
|
|
|
|
if Error_Msg_Sloc /= No_Location then
|
|
Add_Char ('#');
|
|
end if;
|
|
|
|
-- Output unconditional message and we are done
|
|
|
|
Add_Char ('!');
|
|
Error_Msg_N (Msg (1 .. Len), N);
|
|
end if;
|
|
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
|
|
declare
|
|
Already_Restricted : constant Boolean := Restriction_Active (J);
|
|
|
|
begin
|
|
-- Set the restriction
|
|
|
|
if J in All_Boolean_Restrictions then
|
|
Set_Restriction (J, N);
|
|
else
|
|
Set_Restriction (J, N, V (J));
|
|
end if;
|
|
|
|
-- Record that this came from a Profile[_Warnings] restriction
|
|
|
|
Restriction_Profile_Name (J) := P;
|
|
|
|
-- Set warning flag, except that we do not set the warning
|
|
-- flag if the restriction was already active and this is
|
|
-- the warning case. That avoids a warning overriding a real
|
|
-- restriction, which should never happen.
|
|
|
|
if not (Warn and Already_Restricted) then
|
|
Restriction_Warnings (J) := Warn;
|
|
end if;
|
|
end;
|
|
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
|
|
-- Restriction No_Elaboration_Code must be enforced on a unit by unit
|
|
-- basis. Hence, we avoid setting the restriction when processing an
|
|
-- unit which is not the main one being compiled (or its corresponding
|
|
-- spec). It can happen, for example, when processing an inlined body
|
|
-- (the package containing the inlined subprogram is analyzed,
|
|
-- including its pragma Restrictions).
|
|
|
|
-- This seems like a very nasty kludge??? This is not the only per unit
|
|
-- restriction why is this treated specially ???
|
|
|
|
if R = No_Elaboration_Code
|
|
and then Current_Sem_Unit /= Main_Unit
|
|
and then Cunit (Current_Sem_Unit) /= Library_Unit (Cunit (Main_Unit))
|
|
then
|
|
return;
|
|
end if;
|
|
|
|
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;
|
|
|
|
-- Note restriction came from restriction pragma, not profile
|
|
|
|
Restriction_Profile_Name (R) := No_Profile;
|
|
|
|
-- 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 in 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;
|
|
|
|
-- Note restriction came from restriction pragma, not profile
|
|
|
|
Restriction_Profile_Name (R) := No_Profile;
|
|
end Set_Restriction;
|
|
|
|
-----------------------------------
|
|
-- Set_Restriction_No_Dependence --
|
|
-----------------------------------
|
|
|
|
procedure Set_Restriction_No_Dependence
|
|
(Unit : Node_Id;
|
|
Warn : Boolean;
|
|
Profile : Profile_Name := No_Profile)
|
|
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 not currently in table
|
|
|
|
No_Dependence.Append ((Unit, Warn, Profile));
|
|
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;
|