gcc/ada/s-restri.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                  S Y S T E M . R E S T R I C T I O N S                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2004 Free Software Foundation, Inc.            --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the GNU Public License.                                       --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 package body System.Restrictions is
  35    use Rident;
  36
  37    -------------------
  38    -- Abort_Allowed --
  39    -------------------
  40
  41    function Abort_Allowed return Boolean is
  42    begin
  43       return Run_Time_Restrictions.Violated (No_Abort_Statements)
  44                or else
  45              Run_Time_Restrictions.Violated (Max_Asynchronous_Select_Nesting);
  46    end Abort_Allowed;
  47
  48    ---------------------
  49    -- Tasking_Allowed --
  50    ---------------------
  51
  52    function Tasking_Allowed return Boolean is
  53    begin
  54       return Run_Time_Restrictions.Violated (Max_Tasks)
  55                or else
  56              Run_Time_Restrictions.Violated (No_Tasking);
  57    end Tasking_Allowed;
  58
  59 --  Package elaboration code (acquire restrictions)
  60
  61 begin
  62    Acquire_Restrictions : declare
  63
  64       subtype Big_String is String (Positive);
  65       type Big_String_Ptr is access all Big_String;
  66
  67       RString : Big_String_Ptr;
  68       pragma Import (C, RString, "__gl_restrictions");
  69
  70       P : Natural := 1;
  71       --  Pointer to scan string
  72
  73       C : Character;
  74       --  Next character from string
  75
  76       function Get_Char return Character;
  77       --  Get next character from string
  78
  79       function Get_Natural return Natural;
  80       --  Scan out natural value known to be in range, updating P past it
  81
  82       --------------
  83       -- Get_Char --
  84       --------------
  85
  86       function Get_Char return Character is
  87       begin
  88          P := P + 1;
  89          return RString (P - 1);
  90       end Get_Char;
  91
  92       -----------------
  93       -- Get_Natural --
  94       -----------------
  95
  96       function Get_Natural return Natural is
  97          N : Natural := 0;
  98
  99       begin
 100          while RString (P) in '0' .. '9' loop
 101             N := N * 10 + (Character'Pos (Get_Char) - Character'Pos ('0'));
 102          end loop;
 103
 104          return N;
 105       end Get_Natural;
 106
 107    --  Start of processing for Acquire_Restrictions
 108
 109    begin
 110       --  Acquire data corresponding to first R line
 111
 112       for R in All_Boolean_Restrictions loop
 113          C := Get_Char;
 114
 115          if C = 'v' then
 116             Run_Time_Restrictions.Violated (R) := True;
 117
 118          elsif C = 'r' then
 119             Run_Time_Restrictions.Set (R) := True;
 120          end if;
 121       end loop;
 122
 123       --  Acquire data corresponding to second R line
 124
 125       for RP in All_Parameter_Restrictions loop
 126
 127          --  Acquire restrictions pragma information
 128
 129          if Get_Char = 'r' then
 130             Run_Time_Restrictions.Set (RP) := True;
 131             Run_Time_Restrictions.Value (RP) := Get_Natural;
 132          end if;
 133
 134          --  Acquire restrictions violations information
 135
 136          if Get_Char = 'v' then
 137             Run_Time_Restrictions.Violated (RP) := True;
 138             Run_Time_Restrictions.Count (RP) := Get_Natural;
 139
 140             if RString (P) = '+' then
 141                Run_Time_Restrictions.Unknown (RP) := True;
 142                P := P + 1;
 143             end if;
 144          end if;
 145       end loop;
 146    end Acquire_Restrictions;
 147 end System.Restrictions;
 148