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-2019, 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 26with Atree; use Atree; 27with Einfo; use Einfo; 28with Errout; use Errout; 29with Namet; use Namet; 30with Sem_Aux; use Sem_Aux; 31with Sinfo; use Sinfo; 32with Snames; use Snames; 33 34package 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 162end Sem_Smem; 163