diff options
Diffstat (limited to 'gcc-4.7/gcc/ada/restrict.adb')
| -rw-r--r-- | gcc-4.7/gcc/ada/restrict.adb | 1309 |
1 files changed, 0 insertions, 1309 deletions
diff --git a/gcc-4.7/gcc/ada/restrict.adb b/gcc-4.7/gcc/ada/restrict.adb deleted file mode 100644 index ee45e0547..000000000 --- a/gcc-4.7/gcc/ada/restrict.adb +++ /dev/null @@ -1,1309 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- R E S T R I C T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, 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 Aspects; use Aspects; -with Atree; use Atree; -with Casing; use Casing; -with Einfo; use Einfo; -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 Stand; use Stand; -with Uname; use Uname; - -package body Restrict is - - Config_Cunit_Boolean_Restrictions : Save_Cunit_Boolean_Restrictions; - -- Save compilation unit restrictions set by config pragma files - - 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. 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; - - ---------------------------------------- - -- Add_To_Config_Boolean_Restrictions -- - ---------------------------------------- - - procedure Add_To_Config_Boolean_Restrictions (R : Restriction_Id) is - begin - Config_Cunit_Boolean_Restrictions (R) := True; - end Add_To_Config_Boolean_Restrictions; - -- Add specified restriction to stored configuration boolean restrictions. - -- This is used for handling the special case of No_Elaboration_Code. - - ------------------------- - -- 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_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_No_Implicit_Aliasing -- - -------------------------------- - - procedure Check_No_Implicit_Aliasing (Obj : Node_Id) is - E : Entity_Id; - - begin - -- If restriction not active, nothing to check - - if not Restriction_Active (No_Implicit_Aliasing) then - return; - end if; - - -- If we have an entity name, check entity - - if Is_Entity_Name (Obj) then - E := Entity (Obj); - - -- Restriction applies to entities that are objects - - if Is_Object (E) then - if Is_Aliased (E) then - return; - - elsif Present (Renamed_Object (E)) then - Check_No_Implicit_Aliasing (Renamed_Object (E)); - return; - end if; - - -- If we don't have an object, then it's OK - - else - return; - end if; - - -- For selected component, check selector - - elsif Nkind (Obj) = N_Selected_Component then - Check_No_Implicit_Aliasing (Selector_Name (Obj)); - return; - - -- Indexed component is OK if aliased components - - elsif Nkind (Obj) = N_Indexed_Component then - if Has_Aliased_Components (Etype (Prefix (Obj))) - or else - (Is_Access_Type (Etype (Prefix (Obj))) - and then Has_Aliased_Components - (Designated_Type (Etype (Prefix (Obj))))) - then - return; - end if; - - -- For type conversion, check converted expression - - elsif Nkind_In (Obj, N_Unchecked_Type_Conversion, N_Type_Conversion) then - Check_No_Implicit_Aliasing (Expression (Obj)); - return; - - -- Explicit dereference is always OK - - elsif Nkind (Obj) = N_Explicit_Dereference then - return; - end if; - - -- If we fall through, then we have an aliased view that does not meet - -- the rules for being explicitly aliased, so issue restriction msg. - - Check_Restriction (No_Implicit_Aliasing, Obj); - end Check_No_Implicit_Aliasing; - - ----------------------------------------- - -- 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_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 - 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_Obsolescent_2005_Entity; - - --------------------------- - -- 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 - 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 - - begin - Msg_Issued := False; - - -- 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. Note - -- that as usual we check for Main_Unit explicitly to deal with the - -- case of configuration pragma files. - - 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; - - -- Don't complain about No_Obsolescent_Features in an instance, since we - -- will complain on the template, which is much better. Are there other - -- cases like this ??? Do we need a more general mechanism ??? - - elsif R = No_Obsolescent_Features - and then Instantiation_Location (Sloc (N)) /= No_Location - 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; - - ------------------------------------- - -- 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_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_Check_Required (No_Wide_Characters) - and then Comes_From_Source (N) - then - declare - T : constant Entity_Id := Root_Type (E); - begin - 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_Wide_Character_Restriction; - - ---------------------------------------- - -- 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; - - -- If No_Elaboration_Code set in configuration restrictions, and we - -- in the main extended source, then set it here now. This is part of - -- the special processing for No_Elaboration_Code. - - if In_Extended_Main_Source_Unit (Cunit_Entity (Current_Sem_Unit)) - and then Config_Cunit_Boolean_Restrictions (No_Elaboration_Code) - then - Restrictions.Set (No_Elaboration_Code) := True; - end if; - 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); - 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; - - -------------------------------- - -- Is_In_Hidden_Part_In_SPARK -- - -------------------------------- - - function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean is - begin - -- Loop through table of hidden ranges - - 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 False; - end Is_In_Hidden_Part_In_SPARK; - - ------------------------------- - -- 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; - - -------------------------------------- - -- Reset_Cunit_Boolean_Restrictions -- - -------------------------------------- - - procedure Reset_Cunit_Boolean_Restrictions is - begin - for J in Cunit_Boolean_Restrictions loop - Restrictions.Set (J) := False; - end loop; - end Reset_Cunit_Boolean_Restrictions; - - ----------------------------------------------- - -- Restore_Config_Cunit_Boolean_Restrictions -- - ----------------------------------------------- - - procedure Restore_Config_Cunit_Boolean_Restrictions is - begin - Cunit_Boolean_Restrictions_Restore (Config_Cunit_Boolean_Restrictions); - end Restore_Config_Cunit_Boolean_Restrictions; - - ------------------------ - -- 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_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; - - -------------------------------------------- - -- Save_Config_Cunit_Boolean_Restrictions -- - -------------------------------------------- - - procedure Save_Config_Cunit_Boolean_Restrictions is - begin - Config_Cunit_Boolean_Restrictions := Cunit_Boolean_Restrictions_Save; - end Save_Config_Cunit_Boolean_Restrictions; - - ------------------------------ - -- 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 - 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; - - 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 - -- 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; |