|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S E M _ S M E M --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1998-2018, Free Software Foundation, Inc. --
|
|
111
|
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;
|
