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-2008, 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 Sem_Aux; use Sem_Aux;
  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       --  Objects with default-initialized types will be rejected when
  81       --  the initialization code is generated. However we must flag tasks
  82       --  earlier on, to prevent expansion of stream attributes that is
  83       --  bound to fail.
  84
  85       elsif Has_Task (T) then
  86          Error_Msg_N
  87            ("Shared_Passive partitions cannot contain tasks", Id);
  88
  89       --  Currently we do not support unconstrained record types, since we
  90       --  use 'Write to write out values. This could probably be special
  91       --  cased and handled in the future if necessary.
  92
  93       elsif Is_Record_Type (T)
  94         and then not Is_Constrained (T)
  95       then
  96          Error_Msg_N
  97            ("unconstrained variant records " &
  98             "not supported in Shared_Passive partitions",
  99             Id);
 100       end if;
 101    end Check_Shared_Var;
 102
 103    --------------------------
 104    -- Contains_Access_Type --
 105    --------------------------
 106
 107    function Contains_Access_Type (T : Entity_Id) return Boolean is
 108       C : Entity_Id;
 109
 110    begin
 111       if Is_Access_Type (T) then
 112          return True;
 113
 114       elsif Is_Array_Type (T) then
 115          return Contains_Access_Type (Component_Type (T));
 116
 117       elsif Is_Record_Type (T) then
 118          if Has_Discriminants (T) then
 119             C := First_Discriminant (T);
 120             while Present (C) loop
 121                if Comes_From_Source (C) then
 122                   return True;
 123                else
 124                   C := Next_Discriminant (C);
 125                end if;
 126             end loop;
 127          end if;
 128
 129          C := First_Component (T);
 130          while Present (C) loop
 131
 132             --  For components, ignore internal components other than _Parent
 133
 134             if Comes_From_Source (T)
 135               and then
 136                 (Chars (C) = Name_uParent
 137                   or else
 138                  not Is_Internal_Name (Chars (C)))
 139               and then Contains_Access_Type (Etype (C))
 140             then
 141                return True;
 142             else
 143                C := Next_Component (C);
 144             end if;
 145          end loop;
 146
 147          return False;
 148
 149       elsif Is_Protected_Type (T) then
 150          return Contains_Access_Type (Corresponding_Record_Type (T));
 151
 152       else
 153          return False;
 154       end if;
 155    end Contains_Access_Type;
 156
 157 end Sem_Smem;