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-2018, 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         and then (Nkind (N) /= N_Object_Declaration
  96                    or else No (Expression (N)))
  97       then
  98          Error_Msg_N
  99            ("unconstrained variant records " &
 100             "not supported in Shared_Passive partitions",
 101             Id);
 102       end if;
 103    end Check_Shared_Var;
 104
 105    --------------------------
 106    -- Contains_Access_Type --
 107    --------------------------
 108
 109    function Contains_Access_Type (T : Entity_Id) return Boolean is
 110       C : Entity_Id;
 111
 112    begin
 113       if Is_Access_Type (T) then
 114          return True;
 115
 116       elsif Is_Array_Type (T) then
 117          return Contains_Access_Type (Component_Type (T));
 118
 119       elsif Is_Record_Type (T) then
 120          if Has_Discriminants (T) then
 121
 122             --  Check for access discriminants.
 123
 124             C := First_Discriminant (T);
 125             while Present (C) loop
 126                if Is_Access_Type (Etype (C)) then
 127                   return True;
 128                else
 129                   C := Next_Discriminant (C);
 130                end if;
 131             end loop;
 132          end if;
 133
 134          C := First_Component (T);
 135          while Present (C) loop
 136
 137             --  For components, ignore internal components other than _Parent
 138
 139             if Comes_From_Source (T)
 140               and then
 141                 (Chars (C) = Name_uParent
 142                   or else
 143                  not Is_Internal_Name (Chars (C)))
 144               and then Contains_Access_Type (Etype (C))
 145             then
 146                return True;
 147             else
 148                C := Next_Component (C);
 149             end if;
 150          end loop;
 151
 152          return False;
 153
 154       elsif Is_Protected_Type (T) then
 155          return Contains_Access_Type (Corresponding_Record_Type (T));
 156
 157       else
 158          return False;
 159       end if;
 160    end Contains_Access_Type;
 161
 162 end Sem_Smem;