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