| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- R E S T R I C T -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2003 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. -- |
| -- 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 Sinput; use Sinput; |
| with Uname; use Uname; |
| |
| package body Restrict is |
| |
| ----------------------- |
| -- 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 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 (No_Abort_Statements) |
| and then Restriction_Parameters (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 (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); |
| 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 |
| Rimage : constant String := Restriction_Id'Image (R); |
| |
| begin |
| Violations (R) := True; |
| |
| if (Restrictions (R) or Restriction_Warnings (R)) |
| and then not Suppress_Restriction_Message (N) |
| then |
| -- Output proper message. If this is just a case of |
| -- a restriction warning, then we output a warning msg |
| |
| if not Restrictions (R) then |
| Restriction_Msg |
| ("?violation of restriction %", Rimage, N); |
| |
| -- If this is a real restriction violation, then generate |
| -- a non-serious message with appropriate location. |
| |
| else |
| 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 |
| Restriction_Msg |
| ("|violation of restriction %#", Rimage, N); |
| |
| -- Otherwise restriction was implicit (e.g. set by another pragma) |
| |
| else |
| Restriction_Msg |
| ("|violation of implicit restriction %", Rimage, N); |
| end if; |
| end if; |
| 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; |
| |
| -- Case where a parameter is present, no count given |
| |
| 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 |
| 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; |
| |
| ------------------------ |
| -- 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; |
| |
| --------------------- |
| -- 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; |
| |
| ------------------- |
| -- Set_Ravenscar -- |
| ------------------- |
| |
| procedure Set_Ravenscar (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| begin |
| Set_Restricted_Profile (N); |
| Restrictions (Boolean_Entry_Barriers) := True; |
| Restrictions (No_Select_Statements) := True; |
| Restrictions (No_Calendar) := True; |
| Restrictions (No_Entry_Queue) := True; |
| Restrictions (No_Relative_Delay) := True; |
| Restrictions (No_Task_Termination) := True; |
| Restrictions (No_Implicit_Heap_Allocations) := True; |
| |
| Restrictions_Loc (Boolean_Entry_Barriers) := Loc; |
| Restrictions_Loc (No_Select_Statements) := Loc; |
| Restrictions_Loc (No_Calendar) := Loc; |
| Restrictions_Loc (No_Entry_Queue) := Loc; |
| Restrictions_Loc (No_Relative_Delay) := Loc; |
| Restrictions_Loc (No_Task_Termination) := Loc; |
| Restrictions_Loc (No_Implicit_Heap_Allocations) := Loc; |
| end Set_Ravenscar; |
| |
| ---------------------------- |
| -- Set_Restricted_Profile -- |
| ---------------------------- |
| |
| -- This must be coordinated with Restricted_Profile |
| |
| procedure Set_Restricted_Profile (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| 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; |
| |
| Restrictions_Loc (No_Abort_Statements) := Loc; |
| Restrictions_Loc (No_Asynchronous_Control) := Loc; |
| Restrictions_Loc (No_Entry_Queue) := Loc; |
| Restrictions_Loc (No_Task_Hierarchy) := Loc; |
| Restrictions_Loc (No_Task_Allocators) := Loc; |
| Restrictions_Loc (No_Dynamic_Priorities) := Loc; |
| Restrictions_Loc (No_Terminate_Alternatives) := Loc; |
| Restrictions_Loc (No_Dynamic_Interrupts) := Loc; |
| Restrictions_Loc (No_Protected_Type_Allocators) := Loc; |
| Restrictions_Loc (No_Local_Protected_Objects) := Loc; |
| Restrictions_Loc (No_Requeue) := Loc; |
| Restrictions_Loc (No_Task_Attributes) := Loc; |
| |
| 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 |
| and then not Restrictions (No_Tasking); |
| end Tasking_Allowed; |
| |
| end Restrict; |
