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 --          Copyright (C) 1998-2000, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;  use Atree;
  28 with Einfo;  use Einfo;
  29 with Errout; use Errout;
  30 with Namet;  use Namet;
  31 with Sinfo;  use Sinfo;
  32 with Snames; use Snames;
  33
  34 package body Sem_Smem is
  35
  36    function Contains_Access_Type (T : Entity_Id) return Boolean;
  37    --  This function determines if type T is an access type, or contains
  38    --  a component (array, record, protected type cases) that contains
  39    --  an access type (recursively defined in the appropriate manner).
  40
  41    ----------------------
  42    -- Check_Shared_Var --
  43    ----------------------
  44
  45    procedure Check_Shared_Var
  46      (Id : Entity_Id;
  47       T  : Entity_Id;
  48       N  : Node_Id)
  49    is
  50    begin
  51       --  We cannot tolerate aliased variables, because they might be
  52       --  modified via an aliased pointer, and we could not detect that
  53       --  this was happening (to update the corresponding shared memory
  54       --  file), so we must disallow all use of Aliased
  55
  56       if Aliased_Present (N) then
  57          Error_Msg_N
  58            ("aliased variables " &
  59             "not supported in Shared_Passive partitions",
  60             N);
  61
  62       --  We can't support access types at all, since they are local
  63       --  pointers that cannot in any simple way be transmitted to other
  64       --  partitions.
  65
  66       elsif Is_Access_Type (T) then
  67          Error_Msg_N
  68            ("access type variables " &
  69             "not supported in Shared_Passive partitions",
  70             Id);
  71
  72       --  We cannot tolerate types that contain access types, same reasons
  73
  74       elsif Contains_Access_Type (T) then
  75          Error_Msg_N
  76            ("types containing access components " &
  77             "not supported in Shared_Passive partitions",
  78             Id);
  79
  80       --  Currently we do not support unconstrained record types, since we
  81       --  use 'Write to write out values. This could probably be special
  82       --  cased and handled in the future if necessary.
  83
  84       elsif Is_Record_Type (T)
  85         and then not Is_Constrained (T)
  86       then
  87          Error_Msg_N
  88            ("unconstrained variant records " &
  89             "not supported in Shared_Passive partitions",
  90             Id);
  91       end if;
  92    end Check_Shared_Var;
  93
  94    --------------------------
  95    -- Contains_Access_Type --
  96    --------------------------
  97
  98    function Contains_Access_Type (T : Entity_Id) return Boolean is
  99       C : Entity_Id;
 100
 101    begin
 102       if Is_Access_Type (T) then
 103          return True;
 104
 105       elsif Is_Array_Type (T) then
 106          return Contains_Access_Type (Component_Type (T));
 107
 108       elsif Is_Record_Type (T) then
 109          if Has_Discriminants (T) then
 110             C := First_Discriminant (T);
 111             while Present (C) loop
 112                if Comes_From_Source (C) then
 113                   return True;
 114                else
 115                   C := Next_Discriminant (C);
 116                end if;
 117             end loop;
 118          end if;
 119
 120          C := First_Component (T);
 121          while Present (C) loop
 122
 123             --  For components, ignore internal components other than _Parent
 124
 125             if Comes_From_Source (T)
 126               and then
 127                 (Chars (C) = Name_uParent
 128                   or else
 129                  not Is_Internal_Name (Chars (C)))
 130               and then Contains_Access_Type (Etype (C))
 131             then
 132                return True;
 133             else
 134                C := Next_Component (C);
 135             end if;
 136          end loop;
 137
 138          return False;
 139
 140       elsif Is_Protected_Type (T) then
 141          return Contains_Access_Type (Corresponding_Record_Type (T));
 142
 143       else
 144          return False;
 145       end if;
 146    end Contains_Access_Type;
 147
 148 end Sem_Smem;