-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Casing; use Casing;
+with Einfo; use Einfo;
with Errout; use Errout;
-with Exp_Util; use Exp_Util;
+with Debug; use Debug;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Lib; use Lib;
-with Namet; use Namet;
-with Nmake; use Nmake;
with Opt; use Opt;
+with Sinfo; use Sinfo;
+with Sinput; use Sinput;
+with Snames; use Snames;
with Stand; use Stand;
-with Targparm; use Targparm;
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. Valid only if Restricted_Profile_Cached is True.
+ -- Note: if this switch is ever set True, it is never 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.
+
+ No_Specification_Of_Aspects : array (Aspect_Id) of Source_Ptr :=
+ (others => No_Location);
+ -- Entries in this array are set to point to a previously occuring pragma
+ -- that activates a No_Specification_Of_Aspect check.
+
+ No_Specification_Of_Aspect_Warning : array (Aspect_Id) of Boolean :=
+ (others => True);
+ -- An entry in this array is set False in reponse to a previous call to
+ -- Set_No_Speficiation_Of_Aspect for pragmas in the main unit that
+ -- specify Warning as False. Once set False, an entry is never reset.
+
+ No_Specification_Of_Aspect_Set : Boolean := False;
+ -- Set True if any entry of No_Specifcation_Of_Aspects has been set True.
+ -- Once set True, this is never turned off again.
+
+ -----------------------
+ -- 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.
+ -- 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
- return
- Restrictions (No_Abort_Statements) = False
- or else
- Restriction_Parameters (Max_Asynchronous_Select_Nesting) /= 0;
+ 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
- -- 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! ???
+ Check_Restriction (No_Elaboration_Code, N);
+ end Check_Elaboration_Code_Allowed;
+
+ -----------------------------
+ -- Check_SPARK_Restriction --
+ -----------------------------
+
+ procedure Check_SPARK_Restriction
+ (Msg : String;
+ N : Node_Id;
+ Force : Boolean := False)
+ is
+ Msg_Issued : Boolean;
+ Save_Error_Msg_Sloc : Source_Ptr;
+ begin
+ if Force or else Comes_From_Source (Original_Node (N)) then
+
+ if Restriction_Check_Required (SPARK)
+ and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
+ then
+ return;
+ end if;
+
+ -- Since the call to Restriction_Msg from Check_Restriction may set
+ -- Error_Msg_Sloc to the location of the pragma restriction, save and
+ -- restore the previous value of the global variable around the call.
+
+ Save_Error_Msg_Sloc := Error_Msg_Sloc;
+ Check_Restriction (Msg_Issued, SPARK, First_Node (N));
+ Error_Msg_Sloc := Save_Error_Msg_Sloc;
+
+ if Msg_Issued then
+ Error_Msg_F ("\\| " & Msg, N);
+ end if;
+ end if;
+ end Check_SPARK_Restriction;
+
+ procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is
+ Msg_Issued : Boolean;
+ Save_Error_Msg_Sloc : Source_Ptr;
+ begin
+ pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\');
+
+ if Comes_From_Source (Original_Node (N)) then
+
+ if Restriction_Check_Required (SPARK)
+ and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
+ then
+ return;
+ end if;
+
+ -- Since the call to Restriction_Msg from Check_Restriction may set
+ -- Error_Msg_Sloc to the location of the pragma restriction, save and
+ -- restore the previous value of the global variable around the call.
+
+ Save_Error_Msg_Sloc := Error_Msg_Sloc;
+ Check_Restriction (Msg_Issued, SPARK, First_Node (N));
+ Error_Msg_Sloc := Save_Error_Msg_Sloc;
+
+ if Msg_Issued then
+ Error_Msg_F ("\\| " & Msg1, N);
+ Error_Msg_F (Msg2, N);
+ end if;
+ end if;
+ end Check_SPARK_Restriction;
+
+ -----------------------------------------
+ -- 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;
- if Restrictions (No_Elaboration_Code)
- and then not Suppress_Restriction_Message (N)
+ ----------------------------------
+ -- 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_Obsolescent_2005_Entity --
+ -----------------------------------
+
+ procedure Check_Obsolescent_2005_Entity (E : Entity_Id; N : Node_Id) is
+ function Chars_Is (E : Entity_Id; S : String) return Boolean;
+ -- Return True iff Chars (E) matches S (given in lower case)
+
+ function Chars_Is (E : Entity_Id; S : String) return Boolean is
+ Nam : constant Name_Id := Chars (E);
+ begin
+ if Length_Of_Name (Nam) /= S'Length then
+ return False;
+ else
+ return Get_Name_String (Nam) = S;
+ end if;
+ end Chars_Is;
+
+ -- Start of processing for Check_Obsolescent_2005_Entity
+
+ begin
+ if Restriction_Check_Required (No_Obsolescent_Features)
+ and then Ada_Version >= Ada_2005
+ and then Chars_Is (Scope (E), "handling")
+ and then Chars_Is (Scope (Scope (E)), "characters")
+ and then Chars_Is (Scope (Scope (Scope (E))), "ada")
+ and then Scope (Scope (Scope (Scope (E)))) = Standard_Standard
then
- Namet.Unlock;
- Check_Restriction (No_Elaboration_Code, N);
- Namet.Lock;
+ if Chars_Is (E, "is_character") or else
+ Chars_Is (E, "is_string") or else
+ Chars_Is (E, "to_character") or else
+ Chars_Is (E, "to_string") or else
+ Chars_Is (E, "to_wide_character") or else
+ Chars_Is (E, "to_wide_string")
+ then
+ Check_Restriction (No_Obsolescent_Features, N);
+ end if;
end if;
- end Check_Elaboration_Code_Allowed;
+ end Check_Obsolescent_2005_Entity;
---------------------------
-- Check_Restricted_Unit --
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;
+ -- Get file name
- -- Ada child unit spec, needs checking against list
+ Get_Name_String (Fnam);
- else
- -- Pad name to 8 characters with blanks
+ -- 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;
- Get_Name_String (Fnam);
- Name_Len := Name_Len - 4;
+ -- Strip extension and pad to eight characters
- while Name_Len < 8 loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := ' ';
- end loop;
+ 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
- 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;
+ 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;
-- Check_Restriction --
-----------------------
- -- Case of simple identifier (no parameter)
+ procedure Check_Restriction
+ (R : Restriction_Id;
+ N : Node_Id;
+ V : Uint := Uint_Minus_1)
+ is
+ Msg_Issued : Boolean;
+ pragma Unreferenced (Msg_Issued);
+ begin
+ Check_Restriction (Msg_Issued, R, N, V);
+ end Check_Restriction;
+
+ procedure Check_Restriction
+ (Msg_Issued : out Boolean;
+ 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
- procedure Check_Restriction (R : Restriction_Id; N : Node_Id) is
begin
- Violations (R) := True;
+ Msg_Issued := False;
- if Restrictions (R)
- and then not Suppress_Restriction_Message (N)
+ -- In CodePeer and Alfa mode, we do not want to check for any
+ -- restriction, or set additional restrictions other than those already
+ -- set in gnat1drv.adb so that we have consistency between each
+ -- compilation.
+
+ if CodePeer_Mode or Alfa_Mode then
+ return;
+ end if;
+
+ -- In SPARK mode, issue an error for any use of class-wide, even if the
+ -- No_Dispatch restriction is not set.
+
+ if R = No_Dispatch then
+ Check_SPARK_Restriction ("class-wide is not allowed", N);
+ end if;
+
+ 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
- declare
- S : constant String := Restriction_Id'Image (R);
+ Update_Restrictions (Main_Restrictions);
+ end if;
- 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 := Restrictions_Loc (R);
- Error_Msg_N ("violation of restriction %#", N);
- end;
+ -- 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
+ Msg_Issued := True;
+ Restriction_Msg (R, N);
end if;
end Check_Restriction;
- -- Case where a parameter is present (but no count)
+ -------------------------------------
+ -- Check_Restriction_No_Dependence --
+ -------------------------------------
+
+ procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id) is
+ DU : Node_Id;
- 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
- Loc : constant Source_Ptr := Sloc (N);
- S : constant String :=
- Restriction_Parameter_Id'Image (R);
+ -- 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.
- begin
- Error_Msg_NE
- ("& will be raised at run time?!", N, Standard_Storage_Error);
- 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 ("violation of restriction %?#!", N);
-
- Insert_Action (N,
- Make_Raise_Storage_Error (Loc));
- end;
+ if not In_Extended_Main_Source_Unit (U) then
+ return;
end if;
- end Check_Restriction;
- -- Case where a parameter is present, with a count
+ -- Loop through entries in No_Dependence table to check each one in turn
- procedure Check_Restriction
- (R : Restriction_Parameter_Id;
- V : Uint;
- N : Node_Id)
- is
+ for J in No_Dependences.First .. No_Dependences.Last loop
+ DU := No_Dependences.Table (J).Unit;
+
+ if Same_Unit (U, DU) then
+ Error_Msg_Sloc := Sloc (DU);
+ Error_Msg_Node_1 := DU;
+
+ if No_Dependences.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;
+
+ --------------------------------------------------
+ -- Check_Restriction_No_Specification_Of_Aspect --
+ --------------------------------------------------
+
+ procedure Check_Restriction_No_Specification_Of_Aspect (N : Node_Id) is
+ A_Id : Aspect_Id;
+ Id : Node_Id;
+
+ begin
+ -- Ignore call if no instances of this restriction set
+
+ if not No_Specification_Of_Aspect_Set then
+ return;
+ end if;
+
+ -- Ignore call if node N is not in the main source unit, since we only
+ -- give messages for . This avoids giving messages for aspects that are
+ -- specified in withed units.
+
+ if not In_Extended_Main_Source_Unit (N) then
+ return;
+ end if;
+
+ Id := Identifier (N);
+ A_Id := Get_Aspect_Id (Chars (Id));
+ pragma Assert (A_Id /= No_Aspect);
+
+ Error_Msg_Sloc := No_Specification_Of_Aspects (A_Id);
+
+ if Error_Msg_Sloc /= No_Location then
+ Error_Msg_Node_1 := Id;
+ Error_Msg_Warn := No_Specification_Of_Aspect_Warning (A_Id);
+ Error_Msg_N
+ ("<violation of restriction `No_Specification_Of_Aspect '='> &`#",
+ Id);
+ end if;
+ end Check_Restriction_No_Specification_Of_Aspect;
+
+ --------------------------------------
+ -- Check_Wide_Character_Restriction --
+ --------------------------------------
+
+ procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is
begin
- if Restriction_Parameters (R) /= No_Uint
- and then V > Restriction_Parameters (R)
- and then not Suppress_Restriction_Message (N)
+ if Restriction_Check_Required (No_Wide_Characters)
+ and then Comes_From_Source (N)
then
declare
- S : constant String := Restriction_Parameter_Id'Image (R);
-
+ T : constant Entity_Id := Root_Type (E);
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);
+ if T = Standard_Wide_Character or else
+ T = Standard_Wide_String or else
+ T = Standard_Wide_Wide_Character or else
+ T = Standard_Wide_Wide_String
+ then
+ Check_Restriction (No_Wide_Characters, N);
+ end if;
end;
end if;
- end Check_Restriction;
+ end Check_Wide_Character_Restriction;
- -------------------------------------------
- -- Compilation_Unit_Restrictions_Restore --
- -------------------------------------------
+ ----------------------------------------
+ -- Cunit_Boolean_Restrictions_Restore --
+ ----------------------------------------
- procedure Compilation_Unit_Restrictions_Restore
- (R : Save_Compilation_Unit_Restrictions)
+ procedure Cunit_Boolean_Restrictions_Restore
+ (R : Save_Cunit_Boolean_Restrictions)
is
begin
- for J in Compilation_Unit_Restrictions loop
- Restrictions (J) := R (J);
+ for J in Cunit_Boolean_Restrictions loop
+ Restrictions.Set (J) := R (J);
end loop;
- end Compilation_Unit_Restrictions_Restore;
+ end Cunit_Boolean_Restrictions_Restore;
- ----------------------------------------
- -- Compilation_Unit_Restrictions_Save --
- ----------------------------------------
+ -------------------------------------
+ -- Cunit_Boolean_Restrictions_Save --
+ -------------------------------------
- function Compilation_Unit_Restrictions_Save
- return Save_Compilation_Unit_Restrictions
+ function Cunit_Boolean_Restrictions_Save
+ return Save_Cunit_Boolean_Restrictions
is
- R : Save_Compilation_Unit_Restrictions;
+ R : Save_Cunit_Boolean_Restrictions;
begin
- for J in Compilation_Unit_Restrictions loop
- R (J) := Restrictions (J);
- Restrictions (J) := False;
+ for J in Cunit_Boolean_Restrictions loop
+ R (J) := Restrictions.Set (J);
+ Restrictions.Set (J) := False;
end loop;
return R;
- end Compilation_Unit_Restrictions_Save;
-
- ----------------------------------
- -- Disallow_In_No_Run_Time_Mode --
- ----------------------------------
-
- procedure Disallow_In_No_Run_Time_Mode (Enode : Node_Id) is
- begin
- if No_Run_Time then
- if High_Integrity_Mode_On_Target then
- Error_Msg_N
- ("this construct not allowed in high integrity mode", Enode);
- else
- Error_Msg_N
- ("this construct not allowed in No_Run_Time mode", Enode);
- end if;
- end if;
- end Disallow_In_No_Run_Time_Mode;
+ end Cunit_Boolean_Restrictions_Save;
------------------------
-- Get_Restriction_Id --
------------------------
function Get_Restriction_Id
- (N : Name_Id)
- return 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
+ for J in All_Restrictions loop
declare
S : constant String := Restriction_Id'Image (J);
-
begin
- exit when S = Name_Buffer (1 .. Name_Len);
+ if S = Name_Buffer (1 .. Name_Len) then
+ return J;
+ end if;
end;
-
- J := Restriction_Id'Succ (J);
end loop;
- return J;
+ return Not_A_Restriction_Id;
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;
+ --------------------------------
+ -- Is_In_Hidden_Part_In_SPARK --
+ --------------------------------
+ function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean is
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;
+ -- Loop through table of hidden ranges
- J := Restriction_Parameter_Id'Succ (J);
+ for J in SPARK_Hides.First .. SPARK_Hides.Last loop
+ if SPARK_Hides.Table (J).Start <= Loc
+ and then Loc < SPARK_Hides.Table (J).Stop
+ then
+ return True;
+ end if;
end loop;
- return J;
- end Get_Restriction_Parameter_Id;
+ return False;
+ end Is_In_Hidden_Part_In_SPARK;
-------------------------------
-- No_Exception_Handlers_Set --
function No_Exception_Handlers_Set return Boolean is
begin
- return Restrictions (No_Exception_Handlers);
+ 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 --
------------------------
- -- 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;
+ 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;
- --------------------------
- -- Set_No_Run_Time_Mode --
- --------------------------
+ ------------------------
+ -- Restriction_Active --
+ ------------------------
- procedure Set_No_Run_Time_Mode is
+ function Restriction_Active (R : All_Restrictions) return Boolean is
begin
- No_Run_Time := True;
- Restrictions (No_Exception_Handlers) := True;
- Opt.Global_Discard_Names := True;
- end Set_No_Run_Time_Mode;
+ return Restrictions.Set (R) and then not Restriction_Warnings (R);
+ end Restriction_Active;
- -------------------
- -- Set_Ravenscar --
- -------------------
+ --------------------------------
+ -- Restriction_Check_Required --
+ --------------------------------
+
+ function Restriction_Check_Required (R : All_Restrictions) return Boolean is
+ begin
+ return Restrictions.Set (R);
+ end Restriction_Check_Required;
+
+ ---------------------
+ -- 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,
+ -- except for SPARK (an acronym) which is set all upper case, 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;
+
+ if R = SPARK then
+ Set_All_Upper_Case;
+ else
+ Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
+ end if;
+
+ 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 parameterized 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_Hidden_Part_In_SPARK --
+ ------------------------------
+
+ procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr) is
+ begin
+ SPARK_Hides.Increment_Last;
+ SPARK_Hides.Table (SPARK_Hides.Last).Start := Loc1;
+ SPARK_Hides.Table (SPARK_Hides.Last).Stop := Loc2;
+ end Set_Hidden_Part_In_SPARK;
+
+ ------------------------------
+ -- 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_Dependences.First .. No_Dependences.Last loop
+
+ -- Case of entry already in table
+
+ if Same_Unit (Unit, No_Dependences.Table (J).Unit) then
+
+ -- Error has precedence over warning
+
+ if not Warn then
+ No_Dependences.Table (J).Warn := False;
+ end if;
+
+ return;
+ end if;
+ end loop;
+
+ -- Entry is not currently in table
+
+ No_Dependences.Append ((Unit, Warn, Profile));
+ end Set_Restriction_No_Dependence;
+
+ ------------------------------------------------
+ -- Set_Restriction_No_Specification_Of_Aspect --
+ ------------------------------------------------
+
+ procedure Set_Restriction_No_Specification_Of_Aspect
+ (N : Node_Id;
+ Warning : Boolean)
+ is
+ A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (N));
+ pragma Assert (A_Id /= No_Aspect);
+
+ begin
+ No_Specification_Of_Aspects (A_Id) := Sloc (N);
+
+ if Warning = False then
+ No_Specification_Of_Aspect_Warning (A_Id) := False;
+ end if;
- procedure Set_Ravenscar is
- begin
- Set_Restricted_Profile;
- Restrictions (Boolean_Entry_Barriers) := True;
- Restrictions (No_Select_Statements) := True;
- Restrictions (No_Calendar) := True;
- Restrictions (Static_Storage_Size) := True;
- Restrictions (No_Entry_Queue) := True;
- Restrictions (No_Relative_Delay) := True;
- Restrictions (No_Task_Termination) := True;
- Restrictions (No_Implicit_Heap_Allocations) := True;
- end Set_Ravenscar;
-
- ----------------------------
- -- Set_Restricted_Profile --
- ----------------------------
-
- -- This must be coordinated with Restricted_Profile
-
- procedure Set_Restricted_Profile is
- 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;
-
- 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;
+ No_Specification_Of_Aspect_Set := True;
+ end Set_Restriction_No_Specification_Of_Aspect;
----------------------------------
-- Suppress_Restriction_Message --
function Suppress_Restriction_Message (N : Node_Id) return Boolean is
begin
- -- If main unit is library unit, then we will output message
+ -- We only output messages for the extended main source unit
if In_Extended_Main_Source_Unit (N) then
return False;
-- Otherwise suppress message if internal file
else
- return
- Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (N)));
+ 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
- Restriction_Parameters (Max_Tasks) /= 0;
+ 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;
OSDN Git Service
