| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- R E S T R I C T -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- $Revision$ |
| -- -- |
| -- Copyright (C) 1992-2001 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 Nmake; use Nmake; |
| with Opt; use Opt; |
| with Stand; use Stand; |
| with Targparm; use Targparm; |
| 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)); |
| 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; |
| 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 |
| -- If main unit is library unit, then we will output message |
| |
| 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; |
