------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- R E S T R I C T -- -- -- -- B o d y -- -- -- -- $Revision$ -- -- -- Copyright (C) 1992-2002 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, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- -- 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). -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Casing; use Casing; with Errout; use Errout; with Exp_Util; use Exp_Util; with Fname; use Fname; with Fname.UF; use Fname.UF; with Lib; use Lib; with Namet; use Namet; with Opt; use Opt; with Stand; use Stand; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uname; use Uname; package body Restrict is 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 return Restrictions (No_Abort_Statements) = False or else Restriction_Parameters (Max_Asynchronous_Select_Nesting) /= 0; 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 (No_Elaboration_Code) and then not Suppress_Restriction_Message (N) then Namet.Unlock; Check_Restriction (No_Elaboration_Code, N); Namet.Lock; end if; end Check_Elaboration_Code_Allowed; --------------------------- -- 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); R_Id : Restriction_Id; begin if not Is_Predefined_File_Name (Fnam) then return; -- Ada child unit 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 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; end if; end loop; end if; end; end if; end Check_Restricted_Unit; ----------------------- -- Check_Restriction -- ----------------------- -- Case of simple identifier (no parameter) procedure Check_Restriction (R : Restriction_Id; N : Node_Id) is begin Violations (R) := True; if Restrictions (R) and then not Suppress_Restriction_Message (N) then declare S : constant String := Restriction_Id'Image (R); 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; end if; end Check_Restriction; -- Case where a parameter is present (but no count) 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); 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, Reason => SE_Restriction_Violation)); end; end if; end Check_Restriction; -- Case where a parameter is present, with a count procedure Check_Restriction (R : Restriction_Parameter_Id; V : Uint; N : Node_Id) is begin if Restriction_Parameters (R) /= No_Uint and then V > Restriction_Parameters (R) and then not Suppress_Restriction_Message (N) then declare S : constant String := Restriction_Parameter_Id'Image (R); 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); end; end if; end Check_Restriction; ------------------------------------------- -- Compilation_Unit_Restrictions_Restore -- ------------------------------------------- procedure Compilation_Unit_Restrictions_Restore (R : Save_Compilation_Unit_Restrictions) is begin for J in Compilation_Unit_Restrictions loop Restrictions (J) := R (J); end loop; end Compilation_Unit_Restrictions_Restore; ---------------------------------------- -- Compilation_Unit_Restrictions_Save -- ---------------------------------------- function Compilation_Unit_Restrictions_Save return Save_Compilation_Unit_Restrictions is R : Save_Compilation_Unit_Restrictions; begin for J in Compilation_Unit_Restrictions loop R (J) := Restrictions (J); Restrictions (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; ------------------------ -- Get_Restriction_Id -- ------------------------ function Get_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 declare S : constant String := Restriction_Id'Image (J); begin exit when S = Name_Buffer (1 .. Name_Len); end; J := Restriction_Id'Succ (J); end loop; return J; 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; 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; J := Restriction_Parameter_Id'Succ (J); end loop; return J; end Get_Restriction_Parameter_Id; ------------------------------- -- No_Exception_Handlers_Set -- ------------------------------- function No_Exception_Handlers_Set return Boolean is begin return Restrictions (No_Exception_Handlers); end No_Exception_Handlers_Set; ------------------------ -- 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; end Restricted_Profile; -------------------------- -- Set_No_Run_Time_Mode -- -------------------------- procedure Set_No_Run_Time_Mode is begin No_Run_Time := True; Restrictions (No_Exception_Handlers) := True; Restrictions (No_Implicit_Dynamic_Code) := True; Opt.Global_Discard_Names := True; end Set_No_Run_Time_Mode; ------------------- -- Set_Ravenscar -- ------------------- 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; ---------------------------------- -- 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 Restriction_Parameters (Max_Tasks) /= 0; end Tasking_Allowed; end Restrict;