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