gcc/ada/sem_smem.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ S M E M                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --          Copyright (C) 1998-2000, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Atree;  use Atree;
  29 with Einfo;  use Einfo;
  30 with Errout; use Errout;
  31 with Namet;  use Namet;
  32 with Sinfo;  use Sinfo;
  33 with Snames; use Snames;
  34
  35 package body Sem_Smem is
  36
  37    function Contains_Access_Type (T : Entity_Id) return Boolean;
  38    --  This function determines if type T is an access type, or contains
  39    --  a component (array, record, protected type cases) that contains
  40    --  an access type (recursively defined in the appropriate manner).
  41
  42    ----------------------
  43    -- Check_Shared_Var --
  44    ----------------------
  45
  46    procedure Check_Shared_Var
  47      (Id : Entity_Id;
  48       T  : Entity_Id;
  49       N  : Node_Id)
  50    is
  51    begin
  52       --  We cannot tolerate aliased variables, because they might be
  53       --  modified via an aliased pointer, and we could not detect that
  54       --  this was happening (to update the corresponding shared memory
  55       --  file), so we must disallow all use of Aliased
  56
  57       if Aliased_Present (N) then
  58          Error_Msg_N
  59            ("aliased variables " &
  60             "not supported in Shared_Passive partitions",
  61             N);
  62
  63       --  We can't support access types at all, since they are local
  64       --  pointers that cannot in any simple way be transmitted to other
  65       --  partitions.
  66
  67       elsif Is_Access_Type (T) then
  68          Error_Msg_N
  69            ("access type variables " &
  70             "not supported in Shared_Passive partitions",
  71             Id);
  72
  73       --  We cannot tolerate types that contain access types, same reasons
  74
  75       elsif Contains_Access_Type (T) then
  76          Error_Msg_N
  77            ("types containing access components " &
  78             "not supported in Shared_Passive partitions",
  79             Id);
  80
  81       --  Currently we do not support unconstrained record types, since we
  82       --  use 'Write to write out values. This could probably be special
  83       --  cased and handled in the future if necessary.
  84
  85       elsif Is_Record_Type (T)
  86         and then not Is_Constrained (T)
  87       then
  88          Error_Msg_N
  89            ("unconstrained variant records " &
  90             "not supported in Shared_Passive partitions",
  91             Id);
  92       end if;
  93    end Check_Shared_Var;
  94
  95    --------------------------
  96    -- Contains_Access_Type --
  97    --------------------------
  98
  99    function Contains_Access_Type (T : Entity_Id) return Boolean is
 100       C : Entity_Id;
 101
 102    begin
 103       if Is_Access_Type (T) then
 104          return True;
 105
 106       elsif Is_Array_Type (T) then
 107          return Contains_Access_Type (Component_Type (T));
 108
 109       elsif Is_Record_Type (T) then
 110          if Has_Discriminants (T) then
 111             C := First_Discriminant (T);
 112             while Present (C) loop
 113                if Comes_From_Source (C) then
 114                   return True;
 115                else
 116                   C := Next_Discriminant (C);
 117                end if;
 118             end loop;
 119          end if;
 120
 121          C := First_Component (T);
 122          while Present (C) loop
 123
 124             --  For components, ignore internal components other than _Parent
 125
 126             if Comes_From_Source (T)
 127               and then
 128                 (Chars (C) = Name_uParent
 129                   or else
 130                  not Is_Internal_Name (Chars (C)))
 131               and then Contains_Access_Type (Etype (C))
 132             then
 133                return True;
 134             else
 135                C := Next_Component (C);
 136             end if;
 137          end loop;
 138
 139          return False;
 140
 141       elsif Is_Protected_Type (T) then
 142          return Contains_Access_Type (Corresponding_Record_Type (T));
 143
 144       else
 145          return False;
 146       end if;
 147    end Contains_Access_Type;
 148
 149 end Sem_Smem;