| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |