diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/restrict.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/restrict.adb | 740 |
1 files changed, 0 insertions, 740 deletions
diff --git a/gcc-4.2.1/gcc/ada/restrict.adb b/gcc-4.2.1/gcc/ada/restrict.adb deleted file mode 100644 index f12c1eb1c..000000000 --- a/gcc-4.2.1/gcc/ada/restrict.adb +++ /dev/null @@ -1,740 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |