1 |
281 |
jeremybenn |
------------------------------------------------------------------------------
|
2 |
|
|
-- --
|
3 |
|
|
-- GNAT COMPILER COMPONENTS --
|
4 |
|
|
-- --
|
5 |
|
|
-- S E M _ T Y P E --
|
6 |
|
|
-- --
|
7 |
|
|
-- B o d y --
|
8 |
|
|
-- --
|
9 |
|
|
-- Copyright (C) 1992-2009, 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 Alloc;
|
28 |
|
|
with Debug; use Debug;
|
29 |
|
|
with Einfo; use Einfo;
|
30 |
|
|
with Elists; use Elists;
|
31 |
|
|
with Nlists; use Nlists;
|
32 |
|
|
with Errout; use Errout;
|
33 |
|
|
with Lib; use Lib;
|
34 |
|
|
with Namet; use Namet;
|
35 |
|
|
with Opt; use Opt;
|
36 |
|
|
with Output; use Output;
|
37 |
|
|
with Sem; use Sem;
|
38 |
|
|
with Sem_Aux; use Sem_Aux;
|
39 |
|
|
with Sem_Ch6; use Sem_Ch6;
|
40 |
|
|
with Sem_Ch8; use Sem_Ch8;
|
41 |
|
|
with Sem_Ch12; use Sem_Ch12;
|
42 |
|
|
with Sem_Disp; use Sem_Disp;
|
43 |
|
|
with Sem_Dist; use Sem_Dist;
|
44 |
|
|
with Sem_Util; use Sem_Util;
|
45 |
|
|
with Stand; use Stand;
|
46 |
|
|
with Sinfo; use Sinfo;
|
47 |
|
|
with Snames; use Snames;
|
48 |
|
|
with Table;
|
49 |
|
|
with Uintp; use Uintp;
|
50 |
|
|
|
51 |
|
|
package body Sem_Type is
|
52 |
|
|
|
53 |
|
|
---------------------
|
54 |
|
|
-- Data Structures --
|
55 |
|
|
---------------------
|
56 |
|
|
|
57 |
|
|
-- The following data structures establish a mapping between nodes and
|
58 |
|
|
-- their interpretations. An overloaded node has an entry in Interp_Map,
|
59 |
|
|
-- which in turn contains a pointer into the All_Interp array. The
|
60 |
|
|
-- interpretations of a given node are contiguous in All_Interp. Each set
|
61 |
|
|
-- of interpretations is terminated with the marker No_Interp. In order to
|
62 |
|
|
-- speed up the retrieval of the interpretations of an overloaded node, the
|
63 |
|
|
-- Interp_Map table is accessed by means of a simple hashing scheme, and
|
64 |
|
|
-- the entries in Interp_Map are chained. The heads of clash lists are
|
65 |
|
|
-- stored in array Headers.
|
66 |
|
|
|
67 |
|
|
-- Headers Interp_Map All_Interp
|
68 |
|
|
|
69 |
|
|
-- _ +-----+ +--------+
|
70 |
|
|
-- |_| |_____| --->|interp1 |
|
71 |
|
|
-- |_|---------->|node | | |interp2 |
|
72 |
|
|
-- |_| |index|---------| |nointerp|
|
73 |
|
|
-- |_| |next | | |
|
74 |
|
|
-- |-----| | |
|
75 |
|
|
-- +-----+ +--------+
|
76 |
|
|
|
77 |
|
|
-- This scheme does not currently reclaim interpretations. In principle,
|
78 |
|
|
-- after a unit is compiled, all overloadings have been resolved, and the
|
79 |
|
|
-- candidate interpretations should be deleted. This should be easier
|
80 |
|
|
-- now than with the previous scheme???
|
81 |
|
|
|
82 |
|
|
package All_Interp is new Table.Table (
|
83 |
|
|
Table_Component_Type => Interp,
|
84 |
|
|
Table_Index_Type => Int,
|
85 |
|
|
Table_Low_Bound => 0,
|
86 |
|
|
Table_Initial => Alloc.All_Interp_Initial,
|
87 |
|
|
Table_Increment => Alloc.All_Interp_Increment,
|
88 |
|
|
Table_Name => "All_Interp");
|
89 |
|
|
|
90 |
|
|
type Interp_Ref is record
|
91 |
|
|
Node : Node_Id;
|
92 |
|
|
Index : Interp_Index;
|
93 |
|
|
Next : Int;
|
94 |
|
|
end record;
|
95 |
|
|
|
96 |
|
|
Header_Size : constant Int := 2 ** 12;
|
97 |
|
|
No_Entry : constant Int := -1;
|
98 |
|
|
Headers : array (0 .. Header_Size) of Int := (others => No_Entry);
|
99 |
|
|
|
100 |
|
|
package Interp_Map is new Table.Table (
|
101 |
|
|
Table_Component_Type => Interp_Ref,
|
102 |
|
|
Table_Index_Type => Int,
|
103 |
|
|
Table_Low_Bound => 0,
|
104 |
|
|
Table_Initial => Alloc.Interp_Map_Initial,
|
105 |
|
|
Table_Increment => Alloc.Interp_Map_Increment,
|
106 |
|
|
Table_Name => "Interp_Map");
|
107 |
|
|
|
108 |
|
|
function Hash (N : Node_Id) return Int;
|
109 |
|
|
-- A trivial hashing function for nodes, used to insert an overloaded
|
110 |
|
|
-- node into the Interp_Map table.
|
111 |
|
|
|
112 |
|
|
-------------------------------------
|
113 |
|
|
-- Handling of Overload Resolution --
|
114 |
|
|
-------------------------------------
|
115 |
|
|
|
116 |
|
|
-- Overload resolution uses two passes over the syntax tree of a complete
|
117 |
|
|
-- context. In the first, bottom-up pass, the types of actuals in calls
|
118 |
|
|
-- are used to resolve possibly overloaded subprogram and operator names.
|
119 |
|
|
-- In the second top-down pass, the type of the context (for example the
|
120 |
|
|
-- condition in a while statement) is used to resolve a possibly ambiguous
|
121 |
|
|
-- call, and the unique subprogram name in turn imposes a specific context
|
122 |
|
|
-- on each of its actuals.
|
123 |
|
|
|
124 |
|
|
-- Most expressions are in fact unambiguous, and the bottom-up pass is
|
125 |
|
|
-- sufficient to resolve most everything. To simplify the common case,
|
126 |
|
|
-- names and expressions carry a flag Is_Overloaded to indicate whether
|
127 |
|
|
-- they have more than one interpretation. If the flag is off, then each
|
128 |
|
|
-- name has already a unique meaning and type, and the bottom-up pass is
|
129 |
|
|
-- sufficient (and much simpler).
|
130 |
|
|
|
131 |
|
|
--------------------------
|
132 |
|
|
-- Operator Overloading --
|
133 |
|
|
--------------------------
|
134 |
|
|
|
135 |
|
|
-- The visibility of operators is handled differently from that of other
|
136 |
|
|
-- entities. We do not introduce explicit versions of primitive operators
|
137 |
|
|
-- for each type definition. As a result, there is only one entity
|
138 |
|
|
-- corresponding to predefined addition on all numeric types, etc. The
|
139 |
|
|
-- back-end resolves predefined operators according to their type. The
|
140 |
|
|
-- visibility of primitive operations then reduces to the visibility of the
|
141 |
|
|
-- resulting type: (a + b) is a legal interpretation of some primitive
|
142 |
|
|
-- operator + if the type of the result (which must also be the type of a
|
143 |
|
|
-- and b) is directly visible (either immediately visible or use-visible).
|
144 |
|
|
|
145 |
|
|
-- User-defined operators are treated like other functions, but the
|
146 |
|
|
-- visibility of these user-defined operations must be special-cased
|
147 |
|
|
-- to determine whether they hide or are hidden by predefined operators.
|
148 |
|
|
-- The form P."+" (x, y) requires additional handling.
|
149 |
|
|
|
150 |
|
|
-- Concatenation is treated more conventionally: for every one-dimensional
|
151 |
|
|
-- array type we introduce a explicit concatenation operator. This is
|
152 |
|
|
-- necessary to handle the case of (element & element => array) which
|
153 |
|
|
-- cannot be handled conveniently if there is no explicit instance of
|
154 |
|
|
-- resulting type of the operation.
|
155 |
|
|
|
156 |
|
|
-----------------------
|
157 |
|
|
-- Local Subprograms --
|
158 |
|
|
-----------------------
|
159 |
|
|
|
160 |
|
|
procedure All_Overloads;
|
161 |
|
|
pragma Warnings (Off, All_Overloads);
|
162 |
|
|
-- Debugging procedure: list full contents of Overloads table
|
163 |
|
|
|
164 |
|
|
function Binary_Op_Interp_Has_Abstract_Op
|
165 |
|
|
(N : Node_Id;
|
166 |
|
|
E : Entity_Id) return Entity_Id;
|
167 |
|
|
-- Given the node and entity of a binary operator, determine whether the
|
168 |
|
|
-- actuals of E contain an abstract interpretation with regards to the
|
169 |
|
|
-- types of their corresponding formals. Return the abstract operation or
|
170 |
|
|
-- Empty.
|
171 |
|
|
|
172 |
|
|
function Function_Interp_Has_Abstract_Op
|
173 |
|
|
(N : Node_Id;
|
174 |
|
|
E : Entity_Id) return Entity_Id;
|
175 |
|
|
-- Given the node and entity of a function call, determine whether the
|
176 |
|
|
-- actuals of E contain an abstract interpretation with regards to the
|
177 |
|
|
-- types of their corresponding formals. Return the abstract operation or
|
178 |
|
|
-- Empty.
|
179 |
|
|
|
180 |
|
|
function Has_Abstract_Op
|
181 |
|
|
(N : Node_Id;
|
182 |
|
|
Typ : Entity_Id) return Entity_Id;
|
183 |
|
|
-- Subsidiary routine to Binary_Op_Interp_Has_Abstract_Op and Function_
|
184 |
|
|
-- Interp_Has_Abstract_Op. Determine whether an overloaded node has an
|
185 |
|
|
-- abstract interpretation which yields type Typ.
|
186 |
|
|
|
187 |
|
|
procedure New_Interps (N : Node_Id);
|
188 |
|
|
-- Initialize collection of interpretations for the given node, which is
|
189 |
|
|
-- either an overloaded entity, or an operation whose arguments have
|
190 |
|
|
-- multiple interpretations. Interpretations can be added to only one
|
191 |
|
|
-- node at a time.
|
192 |
|
|
|
193 |
|
|
function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id;
|
194 |
|
|
-- If Typ_1 and Typ_2 are compatible, return the one that is not universal
|
195 |
|
|
-- or is not a "class" type (any_character, etc).
|
196 |
|
|
|
197 |
|
|
--------------------
|
198 |
|
|
-- Add_One_Interp --
|
199 |
|
|
--------------------
|
200 |
|
|
|
201 |
|
|
procedure Add_One_Interp
|
202 |
|
|
(N : Node_Id;
|
203 |
|
|
E : Entity_Id;
|
204 |
|
|
T : Entity_Id;
|
205 |
|
|
Opnd_Type : Entity_Id := Empty)
|
206 |
|
|
is
|
207 |
|
|
Vis_Type : Entity_Id;
|
208 |
|
|
|
209 |
|
|
procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id);
|
210 |
|
|
-- Add one interpretation to an overloaded node. Add a new entry if
|
211 |
|
|
-- not hidden by previous one, and remove previous one if hidden by
|
212 |
|
|
-- new one.
|
213 |
|
|
|
214 |
|
|
function Is_Universal_Operation (Op : Entity_Id) return Boolean;
|
215 |
|
|
-- True if the entity is a predefined operator and the operands have
|
216 |
|
|
-- a universal Interpretation.
|
217 |
|
|
|
218 |
|
|
---------------
|
219 |
|
|
-- Add_Entry --
|
220 |
|
|
---------------
|
221 |
|
|
|
222 |
|
|
procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is
|
223 |
|
|
Abstr_Op : Entity_Id := Empty;
|
224 |
|
|
I : Interp_Index;
|
225 |
|
|
It : Interp;
|
226 |
|
|
|
227 |
|
|
-- Start of processing for Add_Entry
|
228 |
|
|
|
229 |
|
|
begin
|
230 |
|
|
-- Find out whether the new entry references interpretations that
|
231 |
|
|
-- are abstract or disabled by abstract operators.
|
232 |
|
|
|
233 |
|
|
if Ada_Version >= Ada_05 then
|
234 |
|
|
if Nkind (N) in N_Binary_Op then
|
235 |
|
|
Abstr_Op := Binary_Op_Interp_Has_Abstract_Op (N, Name);
|
236 |
|
|
elsif Nkind (N) = N_Function_Call then
|
237 |
|
|
Abstr_Op := Function_Interp_Has_Abstract_Op (N, Name);
|
238 |
|
|
end if;
|
239 |
|
|
end if;
|
240 |
|
|
|
241 |
|
|
Get_First_Interp (N, I, It);
|
242 |
|
|
while Present (It.Nam) loop
|
243 |
|
|
|
244 |
|
|
-- A user-defined subprogram hides another declared at an outer
|
245 |
|
|
-- level, or one that is use-visible. So return if previous
|
246 |
|
|
-- definition hides new one (which is either in an outer
|
247 |
|
|
-- scope, or use-visible). Note that for functions use-visible
|
248 |
|
|
-- is the same as potentially use-visible. If new one hides
|
249 |
|
|
-- previous one, replace entry in table of interpretations.
|
250 |
|
|
-- If this is a universal operation, retain the operator in case
|
251 |
|
|
-- preference rule applies.
|
252 |
|
|
|
253 |
|
|
if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure)
|
254 |
|
|
and then Ekind (Name) = Ekind (It.Nam))
|
255 |
|
|
or else (Ekind (Name) = E_Operator
|
256 |
|
|
and then Ekind (It.Nam) = E_Function))
|
257 |
|
|
|
258 |
|
|
and then Is_Immediately_Visible (It.Nam)
|
259 |
|
|
and then Type_Conformant (Name, It.Nam)
|
260 |
|
|
and then Base_Type (It.Typ) = Base_Type (T)
|
261 |
|
|
then
|
262 |
|
|
if Is_Universal_Operation (Name) then
|
263 |
|
|
exit;
|
264 |
|
|
|
265 |
|
|
-- If node is an operator symbol, we have no actuals with
|
266 |
|
|
-- which to check hiding, and this is done in full in the
|
267 |
|
|
-- caller (Analyze_Subprogram_Renaming) so we include the
|
268 |
|
|
-- predefined operator in any case.
|
269 |
|
|
|
270 |
|
|
elsif Nkind (N) = N_Operator_Symbol
|
271 |
|
|
or else (Nkind (N) = N_Expanded_Name
|
272 |
|
|
and then
|
273 |
|
|
Nkind (Selector_Name (N)) = N_Operator_Symbol)
|
274 |
|
|
then
|
275 |
|
|
exit;
|
276 |
|
|
|
277 |
|
|
elsif not In_Open_Scopes (Scope (Name))
|
278 |
|
|
or else Scope_Depth (Scope (Name)) <=
|
279 |
|
|
Scope_Depth (Scope (It.Nam))
|
280 |
|
|
then
|
281 |
|
|
-- If ambiguity within instance, and entity is not an
|
282 |
|
|
-- implicit operation, save for later disambiguation.
|
283 |
|
|
|
284 |
|
|
if Scope (Name) = Scope (It.Nam)
|
285 |
|
|
and then not Is_Inherited_Operation (Name)
|
286 |
|
|
and then In_Instance
|
287 |
|
|
then
|
288 |
|
|
exit;
|
289 |
|
|
else
|
290 |
|
|
return;
|
291 |
|
|
end if;
|
292 |
|
|
|
293 |
|
|
else
|
294 |
|
|
All_Interp.Table (I).Nam := Name;
|
295 |
|
|
return;
|
296 |
|
|
end if;
|
297 |
|
|
|
298 |
|
|
-- Avoid making duplicate entries in overloads
|
299 |
|
|
|
300 |
|
|
elsif Name = It.Nam
|
301 |
|
|
and then Base_Type (It.Typ) = Base_Type (T)
|
302 |
|
|
then
|
303 |
|
|
return;
|
304 |
|
|
|
305 |
|
|
-- Otherwise keep going
|
306 |
|
|
|
307 |
|
|
else
|
308 |
|
|
Get_Next_Interp (I, It);
|
309 |
|
|
end if;
|
310 |
|
|
|
311 |
|
|
end loop;
|
312 |
|
|
|
313 |
|
|
All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op);
|
314 |
|
|
All_Interp.Append (No_Interp);
|
315 |
|
|
end Add_Entry;
|
316 |
|
|
|
317 |
|
|
----------------------------
|
318 |
|
|
-- Is_Universal_Operation --
|
319 |
|
|
----------------------------
|
320 |
|
|
|
321 |
|
|
function Is_Universal_Operation (Op : Entity_Id) return Boolean is
|
322 |
|
|
Arg : Node_Id;
|
323 |
|
|
|
324 |
|
|
begin
|
325 |
|
|
if Ekind (Op) /= E_Operator then
|
326 |
|
|
return False;
|
327 |
|
|
|
328 |
|
|
elsif Nkind (N) in N_Binary_Op then
|
329 |
|
|
return Present (Universal_Interpretation (Left_Opnd (N)))
|
330 |
|
|
and then Present (Universal_Interpretation (Right_Opnd (N)));
|
331 |
|
|
|
332 |
|
|
elsif Nkind (N) in N_Unary_Op then
|
333 |
|
|
return Present (Universal_Interpretation (Right_Opnd (N)));
|
334 |
|
|
|
335 |
|
|
elsif Nkind (N) = N_Function_Call then
|
336 |
|
|
Arg := First_Actual (N);
|
337 |
|
|
while Present (Arg) loop
|
338 |
|
|
if No (Universal_Interpretation (Arg)) then
|
339 |
|
|
return False;
|
340 |
|
|
end if;
|
341 |
|
|
|
342 |
|
|
Next_Actual (Arg);
|
343 |
|
|
end loop;
|
344 |
|
|
|
345 |
|
|
return True;
|
346 |
|
|
|
347 |
|
|
else
|
348 |
|
|
return False;
|
349 |
|
|
end if;
|
350 |
|
|
end Is_Universal_Operation;
|
351 |
|
|
|
352 |
|
|
-- Start of processing for Add_One_Interp
|
353 |
|
|
|
354 |
|
|
begin
|
355 |
|
|
-- If the interpretation is a predefined operator, verify that the
|
356 |
|
|
-- result type is visible, or that the entity has already been
|
357 |
|
|
-- resolved (case of an instantiation node that refers to a predefined
|
358 |
|
|
-- operation, or an internally generated operator node, or an operator
|
359 |
|
|
-- given as an expanded name). If the operator is a comparison or
|
360 |
|
|
-- equality, it is the type of the operand that matters to determine
|
361 |
|
|
-- whether the operator is visible. In an instance, the check is not
|
362 |
|
|
-- performed, given that the operator was visible in the generic.
|
363 |
|
|
|
364 |
|
|
if Ekind (E) = E_Operator then
|
365 |
|
|
|
366 |
|
|
if Present (Opnd_Type) then
|
367 |
|
|
Vis_Type := Opnd_Type;
|
368 |
|
|
else
|
369 |
|
|
Vis_Type := Base_Type (T);
|
370 |
|
|
end if;
|
371 |
|
|
|
372 |
|
|
if In_Open_Scopes (Scope (Vis_Type))
|
373 |
|
|
or else Is_Potentially_Use_Visible (Vis_Type)
|
374 |
|
|
or else In_Use (Vis_Type)
|
375 |
|
|
or else (In_Use (Scope (Vis_Type))
|
376 |
|
|
and then not Is_Hidden (Vis_Type))
|
377 |
|
|
or else Nkind (N) = N_Expanded_Name
|
378 |
|
|
or else (Nkind (N) in N_Op and then E = Entity (N))
|
379 |
|
|
or else In_Instance
|
380 |
|
|
or else Ekind (Vis_Type) = E_Anonymous_Access_Type
|
381 |
|
|
then
|
382 |
|
|
null;
|
383 |
|
|
|
384 |
|
|
-- If the node is given in functional notation and the prefix
|
385 |
|
|
-- is an expanded name, then the operator is visible if the
|
386 |
|
|
-- prefix is the scope of the result type as well. If the
|
387 |
|
|
-- operator is (implicitly) defined in an extension of system,
|
388 |
|
|
-- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
|
389 |
|
|
|
390 |
|
|
elsif Nkind (N) = N_Function_Call
|
391 |
|
|
and then Nkind (Name (N)) = N_Expanded_Name
|
392 |
|
|
and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))
|
393 |
|
|
or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
|
394 |
|
|
or else Scope (Vis_Type) = System_Aux_Id)
|
395 |
|
|
then
|
396 |
|
|
null;
|
397 |
|
|
|
398 |
|
|
-- Save type for subsequent error message, in case no other
|
399 |
|
|
-- interpretation is found.
|
400 |
|
|
|
401 |
|
|
else
|
402 |
|
|
Candidate_Type := Vis_Type;
|
403 |
|
|
return;
|
404 |
|
|
end if;
|
405 |
|
|
|
406 |
|
|
-- In an instance, an abstract non-dispatching operation cannot be a
|
407 |
|
|
-- candidate interpretation, because it could not have been one in the
|
408 |
|
|
-- generic (it may be a spurious overloading in the instance).
|
409 |
|
|
|
410 |
|
|
elsif In_Instance
|
411 |
|
|
and then Is_Overloadable (E)
|
412 |
|
|
and then Is_Abstract_Subprogram (E)
|
413 |
|
|
and then not Is_Dispatching_Operation (E)
|
414 |
|
|
then
|
415 |
|
|
return;
|
416 |
|
|
|
417 |
|
|
-- An inherited interface operation that is implemented by some derived
|
418 |
|
|
-- type does not participate in overload resolution, only the
|
419 |
|
|
-- implementation operation does.
|
420 |
|
|
|
421 |
|
|
elsif Is_Hidden (E)
|
422 |
|
|
and then Is_Subprogram (E)
|
423 |
|
|
and then Present (Interface_Alias (E))
|
424 |
|
|
then
|
425 |
|
|
-- Ada 2005 (AI-251): If this primitive operation corresponds with
|
426 |
|
|
-- an immediate ancestor interface there is no need to add it to the
|
427 |
|
|
-- list of interpretations. The corresponding aliased primitive is
|
428 |
|
|
-- also in this list of primitive operations and will be used instead
|
429 |
|
|
-- because otherwise we have a dummy ambiguity between the two
|
430 |
|
|
-- subprograms which are in fact the same.
|
431 |
|
|
|
432 |
|
|
if not Is_Ancestor
|
433 |
|
|
(Find_Dispatching_Type (Interface_Alias (E)),
|
434 |
|
|
Find_Dispatching_Type (E))
|
435 |
|
|
then
|
436 |
|
|
Add_One_Interp (N, Interface_Alias (E), T);
|
437 |
|
|
end if;
|
438 |
|
|
|
439 |
|
|
return;
|
440 |
|
|
|
441 |
|
|
-- Calling stubs for an RACW operation never participate in resolution,
|
442 |
|
|
-- they are executed only through dispatching calls.
|
443 |
|
|
|
444 |
|
|
elsif Is_RACW_Stub_Type_Operation (E) then
|
445 |
|
|
return;
|
446 |
|
|
end if;
|
447 |
|
|
|
448 |
|
|
-- If this is the first interpretation of N, N has type Any_Type.
|
449 |
|
|
-- In that case place the new type on the node. If one interpretation
|
450 |
|
|
-- already exists, indicate that the node is overloaded, and store
|
451 |
|
|
-- both the previous and the new interpretation in All_Interp. If
|
452 |
|
|
-- this is a later interpretation, just add it to the set.
|
453 |
|
|
|
454 |
|
|
if Etype (N) = Any_Type then
|
455 |
|
|
if Is_Type (E) then
|
456 |
|
|
Set_Etype (N, T);
|
457 |
|
|
|
458 |
|
|
else
|
459 |
|
|
-- Record both the operator or subprogram name, and its type
|
460 |
|
|
|
461 |
|
|
if Nkind (N) in N_Op or else Is_Entity_Name (N) then
|
462 |
|
|
Set_Entity (N, E);
|
463 |
|
|
end if;
|
464 |
|
|
|
465 |
|
|
Set_Etype (N, T);
|
466 |
|
|
end if;
|
467 |
|
|
|
468 |
|
|
-- Either there is no current interpretation in the table for any
|
469 |
|
|
-- node or the interpretation that is present is for a different
|
470 |
|
|
-- node. In both cases add a new interpretation to the table.
|
471 |
|
|
|
472 |
|
|
elsif Interp_Map.Last < 0
|
473 |
|
|
or else
|
474 |
|
|
(Interp_Map.Table (Interp_Map.Last).Node /= N
|
475 |
|
|
and then not Is_Overloaded (N))
|
476 |
|
|
then
|
477 |
|
|
New_Interps (N);
|
478 |
|
|
|
479 |
|
|
if (Nkind (N) in N_Op or else Is_Entity_Name (N))
|
480 |
|
|
and then Present (Entity (N))
|
481 |
|
|
then
|
482 |
|
|
Add_Entry (Entity (N), Etype (N));
|
483 |
|
|
|
484 |
|
|
elsif (Nkind (N) = N_Function_Call
|
485 |
|
|
or else Nkind (N) = N_Procedure_Call_Statement)
|
486 |
|
|
and then (Nkind (Name (N)) = N_Operator_Symbol
|
487 |
|
|
or else Is_Entity_Name (Name (N)))
|
488 |
|
|
then
|
489 |
|
|
Add_Entry (Entity (Name (N)), Etype (N));
|
490 |
|
|
|
491 |
|
|
-- If this is an indirect call there will be no name associated
|
492 |
|
|
-- with the previous entry. To make diagnostics clearer, save
|
493 |
|
|
-- Subprogram_Type of first interpretation, so that the error will
|
494 |
|
|
-- point to the anonymous access to subprogram, not to the result
|
495 |
|
|
-- type of the call itself.
|
496 |
|
|
|
497 |
|
|
elsif (Nkind (N)) = N_Function_Call
|
498 |
|
|
and then Nkind (Name (N)) = N_Explicit_Dereference
|
499 |
|
|
and then Is_Overloaded (Name (N))
|
500 |
|
|
then
|
501 |
|
|
declare
|
502 |
|
|
It : Interp;
|
503 |
|
|
|
504 |
|
|
Itn : Interp_Index;
|
505 |
|
|
pragma Warnings (Off, Itn);
|
506 |
|
|
|
507 |
|
|
begin
|
508 |
|
|
Get_First_Interp (Name (N), Itn, It);
|
509 |
|
|
Add_Entry (It.Nam, Etype (N));
|
510 |
|
|
end;
|
511 |
|
|
|
512 |
|
|
else
|
513 |
|
|
-- Overloaded prefix in indexed or selected component, or call
|
514 |
|
|
-- whose name is an expression or another call.
|
515 |
|
|
|
516 |
|
|
Add_Entry (Etype (N), Etype (N));
|
517 |
|
|
end if;
|
518 |
|
|
|
519 |
|
|
Add_Entry (E, T);
|
520 |
|
|
|
521 |
|
|
else
|
522 |
|
|
Add_Entry (E, T);
|
523 |
|
|
end if;
|
524 |
|
|
end Add_One_Interp;
|
525 |
|
|
|
526 |
|
|
-------------------
|
527 |
|
|
-- All_Overloads --
|
528 |
|
|
-------------------
|
529 |
|
|
|
530 |
|
|
procedure All_Overloads is
|
531 |
|
|
begin
|
532 |
|
|
for J in All_Interp.First .. All_Interp.Last loop
|
533 |
|
|
|
534 |
|
|
if Present (All_Interp.Table (J).Nam) then
|
535 |
|
|
Write_Entity_Info (All_Interp.Table (J). Nam, " ");
|
536 |
|
|
else
|
537 |
|
|
Write_Str ("No Interp");
|
538 |
|
|
Write_Eol;
|
539 |
|
|
end if;
|
540 |
|
|
|
541 |
|
|
Write_Str ("=================");
|
542 |
|
|
Write_Eol;
|
543 |
|
|
end loop;
|
544 |
|
|
end All_Overloads;
|
545 |
|
|
|
546 |
|
|
--------------------------------------
|
547 |
|
|
-- Binary_Op_Interp_Has_Abstract_Op --
|
548 |
|
|
--------------------------------------
|
549 |
|
|
|
550 |
|
|
function Binary_Op_Interp_Has_Abstract_Op
|
551 |
|
|
(N : Node_Id;
|
552 |
|
|
E : Entity_Id) return Entity_Id
|
553 |
|
|
is
|
554 |
|
|
Abstr_Op : Entity_Id;
|
555 |
|
|
E_Left : constant Node_Id := First_Formal (E);
|
556 |
|
|
E_Right : constant Node_Id := Next_Formal (E_Left);
|
557 |
|
|
|
558 |
|
|
begin
|
559 |
|
|
Abstr_Op := Has_Abstract_Op (Left_Opnd (N), Etype (E_Left));
|
560 |
|
|
if Present (Abstr_Op) then
|
561 |
|
|
return Abstr_Op;
|
562 |
|
|
end if;
|
563 |
|
|
|
564 |
|
|
return Has_Abstract_Op (Right_Opnd (N), Etype (E_Right));
|
565 |
|
|
end Binary_Op_Interp_Has_Abstract_Op;
|
566 |
|
|
|
567 |
|
|
---------------------
|
568 |
|
|
-- Collect_Interps --
|
569 |
|
|
---------------------
|
570 |
|
|
|
571 |
|
|
procedure Collect_Interps (N : Node_Id) is
|
572 |
|
|
Ent : constant Entity_Id := Entity (N);
|
573 |
|
|
H : Entity_Id;
|
574 |
|
|
First_Interp : Interp_Index;
|
575 |
|
|
|
576 |
|
|
begin
|
577 |
|
|
New_Interps (N);
|
578 |
|
|
|
579 |
|
|
-- Unconditionally add the entity that was initially matched
|
580 |
|
|
|
581 |
|
|
First_Interp := All_Interp.Last;
|
582 |
|
|
Add_One_Interp (N, Ent, Etype (N));
|
583 |
|
|
|
584 |
|
|
-- For expanded name, pick up all additional entities from the
|
585 |
|
|
-- same scope, since these are obviously also visible. Note that
|
586 |
|
|
-- these are not necessarily contiguous on the homonym chain.
|
587 |
|
|
|
588 |
|
|
if Nkind (N) = N_Expanded_Name then
|
589 |
|
|
H := Homonym (Ent);
|
590 |
|
|
while Present (H) loop
|
591 |
|
|
if Scope (H) = Scope (Entity (N)) then
|
592 |
|
|
Add_One_Interp (N, H, Etype (H));
|
593 |
|
|
end if;
|
594 |
|
|
|
595 |
|
|
H := Homonym (H);
|
596 |
|
|
end loop;
|
597 |
|
|
|
598 |
|
|
-- Case of direct name
|
599 |
|
|
|
600 |
|
|
else
|
601 |
|
|
-- First, search the homonym chain for directly visible entities
|
602 |
|
|
|
603 |
|
|
H := Current_Entity (Ent);
|
604 |
|
|
while Present (H) loop
|
605 |
|
|
exit when (not Is_Overloadable (H))
|
606 |
|
|
and then Is_Immediately_Visible (H);
|
607 |
|
|
|
608 |
|
|
if Is_Immediately_Visible (H)
|
609 |
|
|
and then H /= Ent
|
610 |
|
|
then
|
611 |
|
|
-- Only add interpretation if not hidden by an inner
|
612 |
|
|
-- immediately visible one.
|
613 |
|
|
|
614 |
|
|
for J in First_Interp .. All_Interp.Last - 1 loop
|
615 |
|
|
|
616 |
|
|
-- Current homograph is not hidden. Add to overloads
|
617 |
|
|
|
618 |
|
|
if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
|
619 |
|
|
exit;
|
620 |
|
|
|
621 |
|
|
-- Homograph is hidden, unless it is a predefined operator
|
622 |
|
|
|
623 |
|
|
elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
|
624 |
|
|
|
625 |
|
|
-- A homograph in the same scope can occur within an
|
626 |
|
|
-- instantiation, the resulting ambiguity has to be
|
627 |
|
|
-- resolved later.
|
628 |
|
|
|
629 |
|
|
if Scope (H) = Scope (Ent)
|
630 |
|
|
and then In_Instance
|
631 |
|
|
and then not Is_Inherited_Operation (H)
|
632 |
|
|
then
|
633 |
|
|
All_Interp.Table (All_Interp.Last) :=
|
634 |
|
|
(H, Etype (H), Empty);
|
635 |
|
|
All_Interp.Append (No_Interp);
|
636 |
|
|
goto Next_Homograph;
|
637 |
|
|
|
638 |
|
|
elsif Scope (H) /= Standard_Standard then
|
639 |
|
|
goto Next_Homograph;
|
640 |
|
|
end if;
|
641 |
|
|
end if;
|
642 |
|
|
end loop;
|
643 |
|
|
|
644 |
|
|
-- On exit, we know that current homograph is not hidden
|
645 |
|
|
|
646 |
|
|
Add_One_Interp (N, H, Etype (H));
|
647 |
|
|
|
648 |
|
|
if Debug_Flag_E then
|
649 |
|
|
Write_Str ("Add overloaded interpretation ");
|
650 |
|
|
Write_Int (Int (H));
|
651 |
|
|
Write_Eol;
|
652 |
|
|
end if;
|
653 |
|
|
end if;
|
654 |
|
|
|
655 |
|
|
<<Next_Homograph>>
|
656 |
|
|
H := Homonym (H);
|
657 |
|
|
end loop;
|
658 |
|
|
|
659 |
|
|
-- Scan list of homographs for use-visible entities only
|
660 |
|
|
|
661 |
|
|
H := Current_Entity (Ent);
|
662 |
|
|
|
663 |
|
|
while Present (H) loop
|
664 |
|
|
if Is_Potentially_Use_Visible (H)
|
665 |
|
|
and then H /= Ent
|
666 |
|
|
and then Is_Overloadable (H)
|
667 |
|
|
then
|
668 |
|
|
for J in First_Interp .. All_Interp.Last - 1 loop
|
669 |
|
|
|
670 |
|
|
if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
|
671 |
|
|
exit;
|
672 |
|
|
|
673 |
|
|
elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
|
674 |
|
|
goto Next_Use_Homograph;
|
675 |
|
|
end if;
|
676 |
|
|
end loop;
|
677 |
|
|
|
678 |
|
|
Add_One_Interp (N, H, Etype (H));
|
679 |
|
|
end if;
|
680 |
|
|
|
681 |
|
|
<<Next_Use_Homograph>>
|
682 |
|
|
H := Homonym (H);
|
683 |
|
|
end loop;
|
684 |
|
|
end if;
|
685 |
|
|
|
686 |
|
|
if All_Interp.Last = First_Interp + 1 then
|
687 |
|
|
|
688 |
|
|
-- The final interpretation is in fact not overloaded. Note that the
|
689 |
|
|
-- unique legal interpretation may or may not be the original one,
|
690 |
|
|
-- so we need to update N's entity and etype now, because once N
|
691 |
|
|
-- is marked as not overloaded it is also expected to carry the
|
692 |
|
|
-- proper interpretation.
|
693 |
|
|
|
694 |
|
|
Set_Is_Overloaded (N, False);
|
695 |
|
|
Set_Entity (N, All_Interp.Table (First_Interp).Nam);
|
696 |
|
|
Set_Etype (N, All_Interp.Table (First_Interp).Typ);
|
697 |
|
|
end if;
|
698 |
|
|
end Collect_Interps;
|
699 |
|
|
|
700 |
|
|
------------
|
701 |
|
|
-- Covers --
|
702 |
|
|
------------
|
703 |
|
|
|
704 |
|
|
function Covers (T1, T2 : Entity_Id) return Boolean is
|
705 |
|
|
|
706 |
|
|
BT1 : Entity_Id;
|
707 |
|
|
BT2 : Entity_Id;
|
708 |
|
|
|
709 |
|
|
function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean;
|
710 |
|
|
-- In an instance the proper view may not always be correct for
|
711 |
|
|
-- private types, but private and full view are compatible. This
|
712 |
|
|
-- removes spurious errors from nested instantiations that involve,
|
713 |
|
|
-- among other things, types derived from private types.
|
714 |
|
|
|
715 |
|
|
----------------------
|
716 |
|
|
-- Full_View_Covers --
|
717 |
|
|
----------------------
|
718 |
|
|
|
719 |
|
|
function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is
|
720 |
|
|
begin
|
721 |
|
|
return
|
722 |
|
|
Is_Private_Type (Typ1)
|
723 |
|
|
and then
|
724 |
|
|
((Present (Full_View (Typ1))
|
725 |
|
|
and then Covers (Full_View (Typ1), Typ2))
|
726 |
|
|
or else Base_Type (Typ1) = Typ2
|
727 |
|
|
or else Base_Type (Typ2) = Typ1);
|
728 |
|
|
end Full_View_Covers;
|
729 |
|
|
|
730 |
|
|
-- Start of processing for Covers
|
731 |
|
|
|
732 |
|
|
begin
|
733 |
|
|
-- If either operand missing, then this is an error, but ignore it (and
|
734 |
|
|
-- pretend we have a cover) if errors already detected, since this may
|
735 |
|
|
-- simply mean we have malformed trees or a semantic error upstream.
|
736 |
|
|
|
737 |
|
|
if No (T1) or else No (T2) then
|
738 |
|
|
if Total_Errors_Detected /= 0 then
|
739 |
|
|
return True;
|
740 |
|
|
else
|
741 |
|
|
raise Program_Error;
|
742 |
|
|
end if;
|
743 |
|
|
|
744 |
|
|
else
|
745 |
|
|
BT1 := Base_Type (T1);
|
746 |
|
|
BT2 := Base_Type (T2);
|
747 |
|
|
|
748 |
|
|
-- Handle underlying view of records with unknown discriminants
|
749 |
|
|
-- using the original entity that motivated the construction of
|
750 |
|
|
-- this underlying record view (see Build_Derived_Private_Type).
|
751 |
|
|
|
752 |
|
|
if Is_Underlying_Record_View (BT1) then
|
753 |
|
|
BT1 := Underlying_Record_View (BT1);
|
754 |
|
|
end if;
|
755 |
|
|
|
756 |
|
|
if Is_Underlying_Record_View (BT2) then
|
757 |
|
|
BT2 := Underlying_Record_View (BT2);
|
758 |
|
|
end if;
|
759 |
|
|
end if;
|
760 |
|
|
|
761 |
|
|
-- Simplest case: same types are compatible, and types that have the
|
762 |
|
|
-- same base type and are not generic actuals are compatible. Generic
|
763 |
|
|
-- actuals belong to their class but are not compatible with other
|
764 |
|
|
-- types of their class, and in particular with other generic actuals.
|
765 |
|
|
-- They are however compatible with their own subtypes, and itypes
|
766 |
|
|
-- with the same base are compatible as well. Similarly, constrained
|
767 |
|
|
-- subtypes obtained from expressions of an unconstrained nominal type
|
768 |
|
|
-- are compatible with the base type (may lead to spurious ambiguities
|
769 |
|
|
-- in obscure cases ???)
|
770 |
|
|
|
771 |
|
|
-- Generic actuals require special treatment to avoid spurious ambi-
|
772 |
|
|
-- guities in an instance, when two formal types are instantiated with
|
773 |
|
|
-- the same actual, so that different subprograms end up with the same
|
774 |
|
|
-- signature in the instance.
|
775 |
|
|
|
776 |
|
|
if T1 = T2 then
|
777 |
|
|
return True;
|
778 |
|
|
|
779 |
|
|
elsif BT1 = BT2
|
780 |
|
|
or else BT1 = T2
|
781 |
|
|
or else BT2 = T1
|
782 |
|
|
then
|
783 |
|
|
if not Is_Generic_Actual_Type (T1) then
|
784 |
|
|
return True;
|
785 |
|
|
else
|
786 |
|
|
return (not Is_Generic_Actual_Type (T2)
|
787 |
|
|
or else Is_Itype (T1)
|
788 |
|
|
or else Is_Itype (T2)
|
789 |
|
|
or else Is_Constr_Subt_For_U_Nominal (T1)
|
790 |
|
|
or else Is_Constr_Subt_For_U_Nominal (T2)
|
791 |
|
|
or else Scope (T1) /= Scope (T2));
|
792 |
|
|
end if;
|
793 |
|
|
|
794 |
|
|
-- Literals are compatible with types in a given "class"
|
795 |
|
|
|
796 |
|
|
elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
|
797 |
|
|
or else (T2 = Universal_Real and then Is_Real_Type (T1))
|
798 |
|
|
or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
|
799 |
|
|
or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
|
800 |
|
|
or else (T2 = Any_String and then Is_String_Type (T1))
|
801 |
|
|
or else (T2 = Any_Character and then Is_Character_Type (T1))
|
802 |
|
|
or else (T2 = Any_Access and then Is_Access_Type (T1))
|
803 |
|
|
then
|
804 |
|
|
return True;
|
805 |
|
|
|
806 |
|
|
-- The context may be class wide, and a class-wide type is
|
807 |
|
|
-- compatible with any member of the class.
|
808 |
|
|
|
809 |
|
|
elsif Is_Class_Wide_Type (T1)
|
810 |
|
|
and then Is_Ancestor (Root_Type (T1), T2)
|
811 |
|
|
then
|
812 |
|
|
return True;
|
813 |
|
|
|
814 |
|
|
elsif Is_Class_Wide_Type (T1)
|
815 |
|
|
and then Is_Class_Wide_Type (T2)
|
816 |
|
|
and then Base_Type (Etype (T1)) = Base_Type (Etype (T2))
|
817 |
|
|
then
|
818 |
|
|
return True;
|
819 |
|
|
|
820 |
|
|
-- Ada 2005 (AI-345): A class-wide abstract interface type covers a
|
821 |
|
|
-- task_type or protected_type that implements the interface.
|
822 |
|
|
|
823 |
|
|
elsif Ada_Version >= Ada_05
|
824 |
|
|
and then Is_Class_Wide_Type (T1)
|
825 |
|
|
and then Is_Interface (Etype (T1))
|
826 |
|
|
and then Is_Concurrent_Type (T2)
|
827 |
|
|
and then Interface_Present_In_Ancestor
|
828 |
|
|
(Typ => Base_Type (T2),
|
829 |
|
|
Iface => Etype (T1))
|
830 |
|
|
then
|
831 |
|
|
return True;
|
832 |
|
|
|
833 |
|
|
-- Ada 2005 (AI-251): A class-wide abstract interface type T1 covers an
|
834 |
|
|
-- object T2 implementing T1
|
835 |
|
|
|
836 |
|
|
elsif Ada_Version >= Ada_05
|
837 |
|
|
and then Is_Class_Wide_Type (T1)
|
838 |
|
|
and then Is_Interface (Etype (T1))
|
839 |
|
|
and then Is_Tagged_Type (T2)
|
840 |
|
|
then
|
841 |
|
|
if Interface_Present_In_Ancestor (Typ => T2,
|
842 |
|
|
Iface => Etype (T1))
|
843 |
|
|
then
|
844 |
|
|
return True;
|
845 |
|
|
end if;
|
846 |
|
|
|
847 |
|
|
declare
|
848 |
|
|
E : Entity_Id;
|
849 |
|
|
Elmt : Elmt_Id;
|
850 |
|
|
|
851 |
|
|
begin
|
852 |
|
|
if Is_Concurrent_Type (BT2) then
|
853 |
|
|
E := Corresponding_Record_Type (BT2);
|
854 |
|
|
else
|
855 |
|
|
E := BT2;
|
856 |
|
|
end if;
|
857 |
|
|
|
858 |
|
|
-- Ada 2005 (AI-251): A class-wide abstract interface type T1
|
859 |
|
|
-- covers an object T2 that implements a direct derivation of T1.
|
860 |
|
|
-- Note: test for presence of E is defense against previous error.
|
861 |
|
|
|
862 |
|
|
if Present (E)
|
863 |
|
|
and then Present (Interfaces (E))
|
864 |
|
|
then
|
865 |
|
|
Elmt := First_Elmt (Interfaces (E));
|
866 |
|
|
while Present (Elmt) loop
|
867 |
|
|
if Is_Ancestor (Etype (T1), Node (Elmt)) then
|
868 |
|
|
return True;
|
869 |
|
|
end if;
|
870 |
|
|
|
871 |
|
|
Next_Elmt (Elmt);
|
872 |
|
|
end loop;
|
873 |
|
|
end if;
|
874 |
|
|
|
875 |
|
|
-- We should also check the case in which T1 is an ancestor of
|
876 |
|
|
-- some implemented interface???
|
877 |
|
|
|
878 |
|
|
return False;
|
879 |
|
|
end;
|
880 |
|
|
|
881 |
|
|
-- In a dispatching call the actual may be class-wide
|
882 |
|
|
|
883 |
|
|
elsif Is_Class_Wide_Type (T2)
|
884 |
|
|
and then Base_Type (Root_Type (T2)) = Base_Type (T1)
|
885 |
|
|
then
|
886 |
|
|
return True;
|
887 |
|
|
|
888 |
|
|
-- Some contexts require a class of types rather than a specific type.
|
889 |
|
|
-- For example, conditions require any boolean type, fixed point
|
890 |
|
|
-- attributes require some real type, etc. The built-in types Any_XXX
|
891 |
|
|
-- represent these classes.
|
892 |
|
|
|
893 |
|
|
elsif (T1 = Any_Integer and then Is_Integer_Type (T2))
|
894 |
|
|
or else (T1 = Any_Boolean and then Is_Boolean_Type (T2))
|
895 |
|
|
or else (T1 = Any_Real and then Is_Real_Type (T2))
|
896 |
|
|
or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
|
897 |
|
|
or else (T1 = Any_Discrete and then Is_Discrete_Type (T2))
|
898 |
|
|
then
|
899 |
|
|
return True;
|
900 |
|
|
|
901 |
|
|
-- An aggregate is compatible with an array or record type
|
902 |
|
|
|
903 |
|
|
elsif T2 = Any_Composite
|
904 |
|
|
and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
|
905 |
|
|
then
|
906 |
|
|
return True;
|
907 |
|
|
|
908 |
|
|
-- If the expected type is an anonymous access, the designated type must
|
909 |
|
|
-- cover that of the expression. Use the base type for this check: even
|
910 |
|
|
-- though access subtypes are rare in sources, they are generated for
|
911 |
|
|
-- actuals in instantiations.
|
912 |
|
|
|
913 |
|
|
elsif Ekind (BT1) = E_Anonymous_Access_Type
|
914 |
|
|
and then Is_Access_Type (T2)
|
915 |
|
|
and then Covers (Designated_Type (T1), Designated_Type (T2))
|
916 |
|
|
then
|
917 |
|
|
return True;
|
918 |
|
|
|
919 |
|
|
-- An Access_To_Subprogram is compatible with itself, or with an
|
920 |
|
|
-- anonymous type created for an attribute reference Access.
|
921 |
|
|
|
922 |
|
|
elsif (Ekind (BT1) = E_Access_Subprogram_Type
|
923 |
|
|
or else
|
924 |
|
|
Ekind (BT1) = E_Access_Protected_Subprogram_Type)
|
925 |
|
|
and then Is_Access_Type (T2)
|
926 |
|
|
and then (not Comes_From_Source (T1)
|
927 |
|
|
or else not Comes_From_Source (T2))
|
928 |
|
|
and then (Is_Overloadable (Designated_Type (T2))
|
929 |
|
|
or else
|
930 |
|
|
Ekind (Designated_Type (T2)) = E_Subprogram_Type)
|
931 |
|
|
and then
|
932 |
|
|
Type_Conformant (Designated_Type (T1), Designated_Type (T2))
|
933 |
|
|
and then
|
934 |
|
|
Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
|
935 |
|
|
then
|
936 |
|
|
return True;
|
937 |
|
|
|
938 |
|
|
-- Ada 2005 (AI-254): An Anonymous_Access_To_Subprogram is compatible
|
939 |
|
|
-- with itself, or with an anonymous type created for an attribute
|
940 |
|
|
-- reference Access.
|
941 |
|
|
|
942 |
|
|
elsif (Ekind (BT1) = E_Anonymous_Access_Subprogram_Type
|
943 |
|
|
or else
|
944 |
|
|
Ekind (BT1)
|
945 |
|
|
= E_Anonymous_Access_Protected_Subprogram_Type)
|
946 |
|
|
and then Is_Access_Type (T2)
|
947 |
|
|
and then (not Comes_From_Source (T1)
|
948 |
|
|
or else not Comes_From_Source (T2))
|
949 |
|
|
and then (Is_Overloadable (Designated_Type (T2))
|
950 |
|
|
or else
|
951 |
|
|
Ekind (Designated_Type (T2)) = E_Subprogram_Type)
|
952 |
|
|
and then
|
953 |
|
|
Type_Conformant (Designated_Type (T1), Designated_Type (T2))
|
954 |
|
|
and then
|
955 |
|
|
Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
|
956 |
|
|
then
|
957 |
|
|
return True;
|
958 |
|
|
|
959 |
|
|
-- The context can be a remote access type, and the expression the
|
960 |
|
|
-- corresponding source type declared in a categorized package, or
|
961 |
|
|
-- vice versa.
|
962 |
|
|
|
963 |
|
|
elsif Is_Record_Type (T1)
|
964 |
|
|
and then (Is_Remote_Call_Interface (T1)
|
965 |
|
|
or else Is_Remote_Types (T1))
|
966 |
|
|
and then Present (Corresponding_Remote_Type (T1))
|
967 |
|
|
then
|
968 |
|
|
return Covers (Corresponding_Remote_Type (T1), T2);
|
969 |
|
|
|
970 |
|
|
-- and conversely.
|
971 |
|
|
|
972 |
|
|
elsif Is_Record_Type (T2)
|
973 |
|
|
and then (Is_Remote_Call_Interface (T2)
|
974 |
|
|
or else Is_Remote_Types (T2))
|
975 |
|
|
and then Present (Corresponding_Remote_Type (T2))
|
976 |
|
|
then
|
977 |
|
|
return Covers (Corresponding_Remote_Type (T2), T1);
|
978 |
|
|
|
979 |
|
|
-- Synchronized types are represented at run time by their corresponding
|
980 |
|
|
-- record type. During expansion one is replaced with the other, but
|
981 |
|
|
-- they are compatible views of the same type.
|
982 |
|
|
|
983 |
|
|
elsif Is_Record_Type (T1)
|
984 |
|
|
and then Is_Concurrent_Type (T2)
|
985 |
|
|
and then Present (Corresponding_Record_Type (T2))
|
986 |
|
|
then
|
987 |
|
|
return Covers (T1, Corresponding_Record_Type (T2));
|
988 |
|
|
|
989 |
|
|
elsif Is_Concurrent_Type (T1)
|
990 |
|
|
and then Present (Corresponding_Record_Type (T1))
|
991 |
|
|
and then Is_Record_Type (T2)
|
992 |
|
|
then
|
993 |
|
|
return Covers (Corresponding_Record_Type (T1), T2);
|
994 |
|
|
|
995 |
|
|
-- During analysis, an attribute reference 'Access has a special type
|
996 |
|
|
-- kind: Access_Attribute_Type, to be replaced eventually with the type
|
997 |
|
|
-- imposed by context.
|
998 |
|
|
|
999 |
|
|
elsif Ekind (T2) = E_Access_Attribute_Type
|
1000 |
|
|
and then (Ekind (BT1) = E_General_Access_Type
|
1001 |
|
|
or else
|
1002 |
|
|
Ekind (BT1) = E_Access_Type)
|
1003 |
|
|
and then Covers (Designated_Type (T1), Designated_Type (T2))
|
1004 |
|
|
then
|
1005 |
|
|
-- If the target type is a RACW type while the source is an access
|
1006 |
|
|
-- attribute type, we are building a RACW that may be exported.
|
1007 |
|
|
|
1008 |
|
|
if Is_Remote_Access_To_Class_Wide_Type (BT1) then
|
1009 |
|
|
Set_Has_RACW (Current_Sem_Unit);
|
1010 |
|
|
end if;
|
1011 |
|
|
|
1012 |
|
|
return True;
|
1013 |
|
|
|
1014 |
|
|
-- Ditto for allocators, which eventually resolve to the context type
|
1015 |
|
|
|
1016 |
|
|
elsif Ekind (T2) = E_Allocator_Type
|
1017 |
|
|
and then Is_Access_Type (T1)
|
1018 |
|
|
then
|
1019 |
|
|
return Covers (Designated_Type (T1), Designated_Type (T2))
|
1020 |
|
|
or else
|
1021 |
|
|
(From_With_Type (Designated_Type (T1))
|
1022 |
|
|
and then Covers (Designated_Type (T2), Designated_Type (T1)));
|
1023 |
|
|
|
1024 |
|
|
-- A boolean operation on integer literals is compatible with modular
|
1025 |
|
|
-- context.
|
1026 |
|
|
|
1027 |
|
|
elsif T2 = Any_Modular
|
1028 |
|
|
and then Is_Modular_Integer_Type (T1)
|
1029 |
|
|
then
|
1030 |
|
|
return True;
|
1031 |
|
|
|
1032 |
|
|
-- The actual type may be the result of a previous error
|
1033 |
|
|
|
1034 |
|
|
elsif Base_Type (T2) = Any_Type then
|
1035 |
|
|
return True;
|
1036 |
|
|
|
1037 |
|
|
-- A packed array type covers its corresponding non-packed type. This is
|
1038 |
|
|
-- not legitimate Ada, but allows the omission of a number of otherwise
|
1039 |
|
|
-- useless unchecked conversions, and since this can only arise in
|
1040 |
|
|
-- (known correct) expanded code, no harm is done.
|
1041 |
|
|
|
1042 |
|
|
elsif Is_Array_Type (T2)
|
1043 |
|
|
and then Is_Packed (T2)
|
1044 |
|
|
and then T1 = Packed_Array_Type (T2)
|
1045 |
|
|
then
|
1046 |
|
|
return True;
|
1047 |
|
|
|
1048 |
|
|
-- Similarly an array type covers its corresponding packed array type
|
1049 |
|
|
|
1050 |
|
|
elsif Is_Array_Type (T1)
|
1051 |
|
|
and then Is_Packed (T1)
|
1052 |
|
|
and then T2 = Packed_Array_Type (T1)
|
1053 |
|
|
then
|
1054 |
|
|
return True;
|
1055 |
|
|
|
1056 |
|
|
-- In instances, or with types exported from instantiations, check
|
1057 |
|
|
-- whether a partial and a full view match. Verify that types are
|
1058 |
|
|
-- legal, to prevent cascaded errors.
|
1059 |
|
|
|
1060 |
|
|
elsif In_Instance
|
1061 |
|
|
and then
|
1062 |
|
|
(Full_View_Covers (T1, T2)
|
1063 |
|
|
or else Full_View_Covers (T2, T1))
|
1064 |
|
|
then
|
1065 |
|
|
return True;
|
1066 |
|
|
|
1067 |
|
|
elsif Is_Type (T2)
|
1068 |
|
|
and then Is_Generic_Actual_Type (T2)
|
1069 |
|
|
and then Full_View_Covers (T1, T2)
|
1070 |
|
|
then
|
1071 |
|
|
return True;
|
1072 |
|
|
|
1073 |
|
|
elsif Is_Type (T1)
|
1074 |
|
|
and then Is_Generic_Actual_Type (T1)
|
1075 |
|
|
and then Full_View_Covers (T2, T1)
|
1076 |
|
|
then
|
1077 |
|
|
return True;
|
1078 |
|
|
|
1079 |
|
|
-- In the expansion of inlined bodies, types are compatible if they
|
1080 |
|
|
-- are structurally equivalent.
|
1081 |
|
|
|
1082 |
|
|
elsif In_Inlined_Body
|
1083 |
|
|
and then (Underlying_Type (T1) = Underlying_Type (T2)
|
1084 |
|
|
or else (Is_Access_Type (T1)
|
1085 |
|
|
and then Is_Access_Type (T2)
|
1086 |
|
|
and then
|
1087 |
|
|
Designated_Type (T1) = Designated_Type (T2))
|
1088 |
|
|
or else (T1 = Any_Access
|
1089 |
|
|
and then Is_Access_Type (Underlying_Type (T2)))
|
1090 |
|
|
or else (T2 = Any_Composite
|
1091 |
|
|
and then
|
1092 |
|
|
Is_Composite_Type (Underlying_Type (T1))))
|
1093 |
|
|
then
|
1094 |
|
|
return True;
|
1095 |
|
|
|
1096 |
|
|
-- Ada 2005 (AI-50217): Additional branches to make the shadow entity
|
1097 |
|
|
-- obtained through a limited_with compatible with its real entity.
|
1098 |
|
|
|
1099 |
|
|
elsif From_With_Type (T1) then
|
1100 |
|
|
|
1101 |
|
|
-- If the expected type is the non-limited view of a type, the
|
1102 |
|
|
-- expression may have the limited view. If that one in turn is
|
1103 |
|
|
-- incomplete, get full view if available.
|
1104 |
|
|
|
1105 |
|
|
if Is_Incomplete_Type (T1) then
|
1106 |
|
|
return Covers (Get_Full_View (Non_Limited_View (T1)), T2);
|
1107 |
|
|
|
1108 |
|
|
elsif Ekind (T1) = E_Class_Wide_Type then
|
1109 |
|
|
return
|
1110 |
|
|
Covers (Class_Wide_Type (Non_Limited_View (Etype (T1))), T2);
|
1111 |
|
|
else
|
1112 |
|
|
return False;
|
1113 |
|
|
end if;
|
1114 |
|
|
|
1115 |
|
|
elsif From_With_Type (T2) then
|
1116 |
|
|
|
1117 |
|
|
-- If units in the context have Limited_With clauses on each other,
|
1118 |
|
|
-- either type might have a limited view. Checks performed elsewhere
|
1119 |
|
|
-- verify that the context type is the nonlimited view.
|
1120 |
|
|
|
1121 |
|
|
if Is_Incomplete_Type (T2) then
|
1122 |
|
|
return Covers (T1, Get_Full_View (Non_Limited_View (T2)));
|
1123 |
|
|
|
1124 |
|
|
elsif Ekind (T2) = E_Class_Wide_Type then
|
1125 |
|
|
return
|
1126 |
|
|
Present (Non_Limited_View (Etype (T2)))
|
1127 |
|
|
and then
|
1128 |
|
|
Covers (T1, Class_Wide_Type (Non_Limited_View (Etype (T2))));
|
1129 |
|
|
else
|
1130 |
|
|
return False;
|
1131 |
|
|
end if;
|
1132 |
|
|
|
1133 |
|
|
-- Ada 2005 (AI-412): Coverage for regular incomplete subtypes
|
1134 |
|
|
|
1135 |
|
|
elsif Ekind (T1) = E_Incomplete_Subtype then
|
1136 |
|
|
return Covers (Full_View (Etype (T1)), T2);
|
1137 |
|
|
|
1138 |
|
|
elsif Ekind (T2) = E_Incomplete_Subtype then
|
1139 |
|
|
return Covers (T1, Full_View (Etype (T2)));
|
1140 |
|
|
|
1141 |
|
|
-- Ada 2005 (AI-423): Coverage of formal anonymous access types
|
1142 |
|
|
-- and actual anonymous access types in the context of generic
|
1143 |
|
|
-- instantiations. We have the following situation:
|
1144 |
|
|
|
1145 |
|
|
-- generic
|
1146 |
|
|
-- type Formal is private;
|
1147 |
|
|
-- Formal_Obj : access Formal; -- T1
|
1148 |
|
|
-- package G is ...
|
1149 |
|
|
|
1150 |
|
|
-- package P is
|
1151 |
|
|
-- type Actual is ...
|
1152 |
|
|
-- Actual_Obj : access Actual; -- T2
|
1153 |
|
|
-- package Instance is new G (Formal => Actual,
|
1154 |
|
|
-- Formal_Obj => Actual_Obj);
|
1155 |
|
|
|
1156 |
|
|
elsif Ada_Version >= Ada_05
|
1157 |
|
|
and then Ekind (T1) = E_Anonymous_Access_Type
|
1158 |
|
|
and then Ekind (T2) = E_Anonymous_Access_Type
|
1159 |
|
|
and then Is_Generic_Type (Directly_Designated_Type (T1))
|
1160 |
|
|
and then Get_Instance_Of (Directly_Designated_Type (T1)) =
|
1161 |
|
|
Directly_Designated_Type (T2)
|
1162 |
|
|
then
|
1163 |
|
|
return True;
|
1164 |
|
|
|
1165 |
|
|
-- Otherwise, types are not compatible!
|
1166 |
|
|
|
1167 |
|
|
else
|
1168 |
|
|
return False;
|
1169 |
|
|
end if;
|
1170 |
|
|
end Covers;
|
1171 |
|
|
|
1172 |
|
|
------------------
|
1173 |
|
|
-- Disambiguate --
|
1174 |
|
|
------------------
|
1175 |
|
|
|
1176 |
|
|
function Disambiguate
|
1177 |
|
|
(N : Node_Id;
|
1178 |
|
|
I1, I2 : Interp_Index;
|
1179 |
|
|
Typ : Entity_Id) return Interp
|
1180 |
|
|
is
|
1181 |
|
|
I : Interp_Index;
|
1182 |
|
|
It : Interp;
|
1183 |
|
|
It1, It2 : Interp;
|
1184 |
|
|
Nam1, Nam2 : Entity_Id;
|
1185 |
|
|
Predef_Subp : Entity_Id;
|
1186 |
|
|
User_Subp : Entity_Id;
|
1187 |
|
|
|
1188 |
|
|
function Inherited_From_Actual (S : Entity_Id) return Boolean;
|
1189 |
|
|
-- Determine whether one of the candidates is an operation inherited by
|
1190 |
|
|
-- a type that is derived from an actual in an instantiation.
|
1191 |
|
|
|
1192 |
|
|
function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
|
1193 |
|
|
-- Determine whether a subprogram is an actual in an enclosing instance.
|
1194 |
|
|
-- An overloading between such a subprogram and one declared outside the
|
1195 |
|
|
-- instance is resolved in favor of the first, because it resolved in
|
1196 |
|
|
-- the generic.
|
1197 |
|
|
|
1198 |
|
|
function Matches (Actual, Formal : Node_Id) return Boolean;
|
1199 |
|
|
-- Look for exact type match in an instance, to remove spurious
|
1200 |
|
|
-- ambiguities when two formal types have the same actual.
|
1201 |
|
|
|
1202 |
|
|
function Standard_Operator return Boolean;
|
1203 |
|
|
-- Check whether subprogram is predefined operator declared in Standard.
|
1204 |
|
|
-- It may given by an operator name, or by an expanded name whose prefix
|
1205 |
|
|
-- is Standard.
|
1206 |
|
|
|
1207 |
|
|
function Remove_Conversions return Interp;
|
1208 |
|
|
-- Last chance for pathological cases involving comparisons on literals,
|
1209 |
|
|
-- and user overloadings of the same operator. Such pathologies have
|
1210 |
|
|
-- been removed from the ACVC, but still appear in two DEC tests, with
|
1211 |
|
|
-- the following notable quote from Ben Brosgol:
|
1212 |
|
|
--
|
1213 |
|
|
-- [Note: I disclaim all credit/responsibility/blame for coming up with
|
1214 |
|
|
-- this example; Robert Dewar brought it to our attention, since it is
|
1215 |
|
|
-- apparently found in the ACVC 1.5. I did not attempt to find the
|
1216 |
|
|
-- reason in the Reference Manual that makes the example legal, since I
|
1217 |
|
|
-- was too nauseated by it to want to pursue it further.]
|
1218 |
|
|
--
|
1219 |
|
|
-- Accordingly, this is not a fully recursive solution, but it handles
|
1220 |
|
|
-- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
|
1221 |
|
|
-- pathology in the other direction with calls whose multiple overloaded
|
1222 |
|
|
-- actuals make them truly unresolvable.
|
1223 |
|
|
|
1224 |
|
|
-- The new rules concerning abstract operations create additional need
|
1225 |
|
|
-- for special handling of expressions with universal operands, see
|
1226 |
|
|
-- comments to Has_Abstract_Interpretation below.
|
1227 |
|
|
|
1228 |
|
|
---------------------------
|
1229 |
|
|
-- Inherited_From_Actual --
|
1230 |
|
|
---------------------------
|
1231 |
|
|
|
1232 |
|
|
function Inherited_From_Actual (S : Entity_Id) return Boolean is
|
1233 |
|
|
Par : constant Node_Id := Parent (S);
|
1234 |
|
|
begin
|
1235 |
|
|
if Nkind (Par) /= N_Full_Type_Declaration
|
1236 |
|
|
or else Nkind (Type_Definition (Par)) /= N_Derived_Type_Definition
|
1237 |
|
|
then
|
1238 |
|
|
return False;
|
1239 |
|
|
else
|
1240 |
|
|
return Is_Entity_Name (Subtype_Indication (Type_Definition (Par)))
|
1241 |
|
|
and then
|
1242 |
|
|
Is_Generic_Actual_Type (
|
1243 |
|
|
Entity (Subtype_Indication (Type_Definition (Par))));
|
1244 |
|
|
end if;
|
1245 |
|
|
end Inherited_From_Actual;
|
1246 |
|
|
|
1247 |
|
|
--------------------------
|
1248 |
|
|
-- Is_Actual_Subprogram --
|
1249 |
|
|
--------------------------
|
1250 |
|
|
|
1251 |
|
|
function Is_Actual_Subprogram (S : Entity_Id) return Boolean is
|
1252 |
|
|
begin
|
1253 |
|
|
return In_Open_Scopes (Scope (S))
|
1254 |
|
|
and then
|
1255 |
|
|
(Is_Generic_Instance (Scope (S))
|
1256 |
|
|
or else Is_Wrapper_Package (Scope (S)));
|
1257 |
|
|
end Is_Actual_Subprogram;
|
1258 |
|
|
|
1259 |
|
|
-------------
|
1260 |
|
|
-- Matches --
|
1261 |
|
|
-------------
|
1262 |
|
|
|
1263 |
|
|
function Matches (Actual, Formal : Node_Id) return Boolean is
|
1264 |
|
|
T1 : constant Entity_Id := Etype (Actual);
|
1265 |
|
|
T2 : constant Entity_Id := Etype (Formal);
|
1266 |
|
|
begin
|
1267 |
|
|
return T1 = T2
|
1268 |
|
|
or else
|
1269 |
|
|
(Is_Numeric_Type (T2)
|
1270 |
|
|
and then (T1 = Universal_Real or else T1 = Universal_Integer));
|
1271 |
|
|
end Matches;
|
1272 |
|
|
|
1273 |
|
|
------------------------
|
1274 |
|
|
-- Remove_Conversions --
|
1275 |
|
|
------------------------
|
1276 |
|
|
|
1277 |
|
|
function Remove_Conversions return Interp is
|
1278 |
|
|
I : Interp_Index;
|
1279 |
|
|
It : Interp;
|
1280 |
|
|
It1 : Interp;
|
1281 |
|
|
F1 : Entity_Id;
|
1282 |
|
|
Act1 : Node_Id;
|
1283 |
|
|
Act2 : Node_Id;
|
1284 |
|
|
|
1285 |
|
|
function Has_Abstract_Interpretation (N : Node_Id) return Boolean;
|
1286 |
|
|
-- If an operation has universal operands the universal operation
|
1287 |
|
|
-- is present among its interpretations. If there is an abstract
|
1288 |
|
|
-- interpretation for the operator, with a numeric result, this
|
1289 |
|
|
-- interpretation was already removed in sem_ch4, but the universal
|
1290 |
|
|
-- one is still visible. We must rescan the list of operators and
|
1291 |
|
|
-- remove the universal interpretation to resolve the ambiguity.
|
1292 |
|
|
|
1293 |
|
|
---------------------------------
|
1294 |
|
|
-- Has_Abstract_Interpretation --
|
1295 |
|
|
---------------------------------
|
1296 |
|
|
|
1297 |
|
|
function Has_Abstract_Interpretation (N : Node_Id) return Boolean is
|
1298 |
|
|
E : Entity_Id;
|
1299 |
|
|
|
1300 |
|
|
begin
|
1301 |
|
|
if Nkind (N) not in N_Op
|
1302 |
|
|
or else Ada_Version < Ada_05
|
1303 |
|
|
or else not Is_Overloaded (N)
|
1304 |
|
|
or else No (Universal_Interpretation (N))
|
1305 |
|
|
then
|
1306 |
|
|
return False;
|
1307 |
|
|
|
1308 |
|
|
else
|
1309 |
|
|
E := Get_Name_Entity_Id (Chars (N));
|
1310 |
|
|
while Present (E) loop
|
1311 |
|
|
if Is_Overloadable (E)
|
1312 |
|
|
and then Is_Abstract_Subprogram (E)
|
1313 |
|
|
and then Is_Numeric_Type (Etype (E))
|
1314 |
|
|
then
|
1315 |
|
|
return True;
|
1316 |
|
|
else
|
1317 |
|
|
E := Homonym (E);
|
1318 |
|
|
end if;
|
1319 |
|
|
end loop;
|
1320 |
|
|
|
1321 |
|
|
-- Finally, if an operand of the binary operator is itself
|
1322 |
|
|
-- an operator, recurse to see whether its own abstract
|
1323 |
|
|
-- interpretation is responsible for the spurious ambiguity.
|
1324 |
|
|
|
1325 |
|
|
if Nkind (N) in N_Binary_Op then
|
1326 |
|
|
return Has_Abstract_Interpretation (Left_Opnd (N))
|
1327 |
|
|
or else Has_Abstract_Interpretation (Right_Opnd (N));
|
1328 |
|
|
|
1329 |
|
|
elsif Nkind (N) in N_Unary_Op then
|
1330 |
|
|
return Has_Abstract_Interpretation (Right_Opnd (N));
|
1331 |
|
|
|
1332 |
|
|
else
|
1333 |
|
|
return False;
|
1334 |
|
|
end if;
|
1335 |
|
|
end if;
|
1336 |
|
|
end Has_Abstract_Interpretation;
|
1337 |
|
|
|
1338 |
|
|
-- Start of processing for Remove_Conversions
|
1339 |
|
|
|
1340 |
|
|
begin
|
1341 |
|
|
It1 := No_Interp;
|
1342 |
|
|
|
1343 |
|
|
Get_First_Interp (N, I, It);
|
1344 |
|
|
while Present (It.Typ) loop
|
1345 |
|
|
if not Is_Overloadable (It.Nam) then
|
1346 |
|
|
return No_Interp;
|
1347 |
|
|
end if;
|
1348 |
|
|
|
1349 |
|
|
F1 := First_Formal (It.Nam);
|
1350 |
|
|
|
1351 |
|
|
if No (F1) then
|
1352 |
|
|
return It1;
|
1353 |
|
|
|
1354 |
|
|
else
|
1355 |
|
|
if Nkind (N) = N_Function_Call
|
1356 |
|
|
or else Nkind (N) = N_Procedure_Call_Statement
|
1357 |
|
|
then
|
1358 |
|
|
Act1 := First_Actual (N);
|
1359 |
|
|
|
1360 |
|
|
if Present (Act1) then
|
1361 |
|
|
Act2 := Next_Actual (Act1);
|
1362 |
|
|
else
|
1363 |
|
|
Act2 := Empty;
|
1364 |
|
|
end if;
|
1365 |
|
|
|
1366 |
|
|
elsif Nkind (N) in N_Unary_Op then
|
1367 |
|
|
Act1 := Right_Opnd (N);
|
1368 |
|
|
Act2 := Empty;
|
1369 |
|
|
|
1370 |
|
|
elsif Nkind (N) in N_Binary_Op then
|
1371 |
|
|
Act1 := Left_Opnd (N);
|
1372 |
|
|
Act2 := Right_Opnd (N);
|
1373 |
|
|
|
1374 |
|
|
-- Use type of second formal, so as to include
|
1375 |
|
|
-- exponentiation, where the exponent may be
|
1376 |
|
|
-- ambiguous and the result non-universal.
|
1377 |
|
|
|
1378 |
|
|
Next_Formal (F1);
|
1379 |
|
|
|
1380 |
|
|
else
|
1381 |
|
|
return It1;
|
1382 |
|
|
end if;
|
1383 |
|
|
|
1384 |
|
|
if Nkind (Act1) in N_Op
|
1385 |
|
|
and then Is_Overloaded (Act1)
|
1386 |
|
|
and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
|
1387 |
|
|
or else Nkind (Right_Opnd (Act1)) = N_Real_Literal)
|
1388 |
|
|
and then Has_Compatible_Type (Act1, Standard_Boolean)
|
1389 |
|
|
and then Etype (F1) = Standard_Boolean
|
1390 |
|
|
then
|
1391 |
|
|
-- If the two candidates are the original ones, the
|
1392 |
|
|
-- ambiguity is real. Otherwise keep the original, further
|
1393 |
|
|
-- calls to Disambiguate will take care of others in the
|
1394 |
|
|
-- list of candidates.
|
1395 |
|
|
|
1396 |
|
|
if It1 /= No_Interp then
|
1397 |
|
|
if It = Disambiguate.It1
|
1398 |
|
|
or else It = Disambiguate.It2
|
1399 |
|
|
then
|
1400 |
|
|
if It1 = Disambiguate.It1
|
1401 |
|
|
or else It1 = Disambiguate.It2
|
1402 |
|
|
then
|
1403 |
|
|
return No_Interp;
|
1404 |
|
|
else
|
1405 |
|
|
It1 := It;
|
1406 |
|
|
end if;
|
1407 |
|
|
end if;
|
1408 |
|
|
|
1409 |
|
|
elsif Present (Act2)
|
1410 |
|
|
and then Nkind (Act2) in N_Op
|
1411 |
|
|
and then Is_Overloaded (Act2)
|
1412 |
|
|
and then Nkind_In (Right_Opnd (Act2), N_Integer_Literal,
|
1413 |
|
|
N_Real_Literal)
|
1414 |
|
|
and then Has_Compatible_Type (Act2, Standard_Boolean)
|
1415 |
|
|
then
|
1416 |
|
|
-- The preference rule on the first actual is not
|
1417 |
|
|
-- sufficient to disambiguate.
|
1418 |
|
|
|
1419 |
|
|
goto Next_Interp;
|
1420 |
|
|
|
1421 |
|
|
else
|
1422 |
|
|
It1 := It;
|
1423 |
|
|
end if;
|
1424 |
|
|
|
1425 |
|
|
elsif Is_Numeric_Type (Etype (F1))
|
1426 |
|
|
and then Has_Abstract_Interpretation (Act1)
|
1427 |
|
|
then
|
1428 |
|
|
-- Current interpretation is not the right one because it
|
1429 |
|
|
-- expects a numeric operand. Examine all the other ones.
|
1430 |
|
|
|
1431 |
|
|
declare
|
1432 |
|
|
I : Interp_Index;
|
1433 |
|
|
It : Interp;
|
1434 |
|
|
|
1435 |
|
|
begin
|
1436 |
|
|
Get_First_Interp (N, I, It);
|
1437 |
|
|
while Present (It.Typ) loop
|
1438 |
|
|
if
|
1439 |
|
|
not Is_Numeric_Type (Etype (First_Formal (It.Nam)))
|
1440 |
|
|
then
|
1441 |
|
|
if No (Act2)
|
1442 |
|
|
or else not Has_Abstract_Interpretation (Act2)
|
1443 |
|
|
or else not
|
1444 |
|
|
Is_Numeric_Type
|
1445 |
|
|
(Etype (Next_Formal (First_Formal (It.Nam))))
|
1446 |
|
|
then
|
1447 |
|
|
return It;
|
1448 |
|
|
end if;
|
1449 |
|
|
end if;
|
1450 |
|
|
|
1451 |
|
|
Get_Next_Interp (I, It);
|
1452 |
|
|
end loop;
|
1453 |
|
|
|
1454 |
|
|
return No_Interp;
|
1455 |
|
|
end;
|
1456 |
|
|
end if;
|
1457 |
|
|
end if;
|
1458 |
|
|
|
1459 |
|
|
<<Next_Interp>>
|
1460 |
|
|
Get_Next_Interp (I, It);
|
1461 |
|
|
end loop;
|
1462 |
|
|
|
1463 |
|
|
-- After some error, a formal may have Any_Type and yield a spurious
|
1464 |
|
|
-- match. To avoid cascaded errors if possible, check for such a
|
1465 |
|
|
-- formal in either candidate.
|
1466 |
|
|
|
1467 |
|
|
if Serious_Errors_Detected > 0 then
|
1468 |
|
|
declare
|
1469 |
|
|
Formal : Entity_Id;
|
1470 |
|
|
|
1471 |
|
|
begin
|
1472 |
|
|
Formal := First_Formal (Nam1);
|
1473 |
|
|
while Present (Formal) loop
|
1474 |
|
|
if Etype (Formal) = Any_Type then
|
1475 |
|
|
return Disambiguate.It2;
|
1476 |
|
|
end if;
|
1477 |
|
|
|
1478 |
|
|
Next_Formal (Formal);
|
1479 |
|
|
end loop;
|
1480 |
|
|
|
1481 |
|
|
Formal := First_Formal (Nam2);
|
1482 |
|
|
while Present (Formal) loop
|
1483 |
|
|
if Etype (Formal) = Any_Type then
|
1484 |
|
|
return Disambiguate.It1;
|
1485 |
|
|
end if;
|
1486 |
|
|
|
1487 |
|
|
Next_Formal (Formal);
|
1488 |
|
|
end loop;
|
1489 |
|
|
end;
|
1490 |
|
|
end if;
|
1491 |
|
|
|
1492 |
|
|
return It1;
|
1493 |
|
|
end Remove_Conversions;
|
1494 |
|
|
|
1495 |
|
|
-----------------------
|
1496 |
|
|
-- Standard_Operator --
|
1497 |
|
|
-----------------------
|
1498 |
|
|
|
1499 |
|
|
function Standard_Operator return Boolean is
|
1500 |
|
|
Nam : Node_Id;
|
1501 |
|
|
|
1502 |
|
|
begin
|
1503 |
|
|
if Nkind (N) in N_Op then
|
1504 |
|
|
return True;
|
1505 |
|
|
|
1506 |
|
|
elsif Nkind (N) = N_Function_Call then
|
1507 |
|
|
Nam := Name (N);
|
1508 |
|
|
|
1509 |
|
|
if Nkind (Nam) /= N_Expanded_Name then
|
1510 |
|
|
return True;
|
1511 |
|
|
else
|
1512 |
|
|
return Entity (Prefix (Nam)) = Standard_Standard;
|
1513 |
|
|
end if;
|
1514 |
|
|
else
|
1515 |
|
|
return False;
|
1516 |
|
|
end if;
|
1517 |
|
|
end Standard_Operator;
|
1518 |
|
|
|
1519 |
|
|
-- Start of processing for Disambiguate
|
1520 |
|
|
|
1521 |
|
|
begin
|
1522 |
|
|
-- Recover the two legal interpretations
|
1523 |
|
|
|
1524 |
|
|
Get_First_Interp (N, I, It);
|
1525 |
|
|
while I /= I1 loop
|
1526 |
|
|
Get_Next_Interp (I, It);
|
1527 |
|
|
end loop;
|
1528 |
|
|
|
1529 |
|
|
It1 := It;
|
1530 |
|
|
Nam1 := It.Nam;
|
1531 |
|
|
while I /= I2 loop
|
1532 |
|
|
Get_Next_Interp (I, It);
|
1533 |
|
|
end loop;
|
1534 |
|
|
|
1535 |
|
|
It2 := It;
|
1536 |
|
|
Nam2 := It.Nam;
|
1537 |
|
|
|
1538 |
|
|
if Ada_Version < Ada_05 then
|
1539 |
|
|
|
1540 |
|
|
-- Check whether one of the entities is an Ada 2005 entity and we are
|
1541 |
|
|
-- operating in an earlier mode, in which case we discard the Ada
|
1542 |
|
|
-- 2005 entity, so that we get proper Ada 95 overload resolution.
|
1543 |
|
|
|
1544 |
|
|
if Is_Ada_2005_Only (Nam1) then
|
1545 |
|
|
return It2;
|
1546 |
|
|
elsif Is_Ada_2005_Only (Nam2) then
|
1547 |
|
|
return It1;
|
1548 |
|
|
end if;
|
1549 |
|
|
end if;
|
1550 |
|
|
|
1551 |
|
|
-- Check for overloaded CIL convention stuff because the CIL libraries
|
1552 |
|
|
-- do sick things like Console.Write_Line where it matches two different
|
1553 |
|
|
-- overloads, so just pick the first ???
|
1554 |
|
|
|
1555 |
|
|
if Convention (Nam1) = Convention_CIL
|
1556 |
|
|
and then Convention (Nam2) = Convention_CIL
|
1557 |
|
|
and then Ekind (Nam1) = Ekind (Nam2)
|
1558 |
|
|
and then (Ekind (Nam1) = E_Procedure
|
1559 |
|
|
or else Ekind (Nam1) = E_Function)
|
1560 |
|
|
then
|
1561 |
|
|
return It2;
|
1562 |
|
|
end if;
|
1563 |
|
|
|
1564 |
|
|
-- If the context is universal, the predefined operator is preferred.
|
1565 |
|
|
-- This includes bounds in numeric type declarations, and expressions
|
1566 |
|
|
-- in type conversions. If no interpretation yields a universal type,
|
1567 |
|
|
-- then we must check whether the user-defined entity hides the prede-
|
1568 |
|
|
-- fined one.
|
1569 |
|
|
|
1570 |
|
|
if Chars (Nam1) in Any_Operator_Name
|
1571 |
|
|
and then Standard_Operator
|
1572 |
|
|
then
|
1573 |
|
|
if Typ = Universal_Integer
|
1574 |
|
|
or else Typ = Universal_Real
|
1575 |
|
|
or else Typ = Any_Integer
|
1576 |
|
|
or else Typ = Any_Discrete
|
1577 |
|
|
or else Typ = Any_Real
|
1578 |
|
|
or else Typ = Any_Type
|
1579 |
|
|
then
|
1580 |
|
|
-- Find an interpretation that yields the universal type, or else
|
1581 |
|
|
-- a predefined operator that yields a predefined numeric type.
|
1582 |
|
|
|
1583 |
|
|
declare
|
1584 |
|
|
Candidate : Interp := No_Interp;
|
1585 |
|
|
|
1586 |
|
|
begin
|
1587 |
|
|
Get_First_Interp (N, I, It);
|
1588 |
|
|
while Present (It.Typ) loop
|
1589 |
|
|
if (Covers (Typ, It.Typ)
|
1590 |
|
|
or else Typ = Any_Type)
|
1591 |
|
|
and then
|
1592 |
|
|
(It.Typ = Universal_Integer
|
1593 |
|
|
or else It.Typ = Universal_Real)
|
1594 |
|
|
then
|
1595 |
|
|
return It;
|
1596 |
|
|
|
1597 |
|
|
elsif Covers (Typ, It.Typ)
|
1598 |
|
|
and then Scope (It.Typ) = Standard_Standard
|
1599 |
|
|
and then Scope (It.Nam) = Standard_Standard
|
1600 |
|
|
and then Is_Numeric_Type (It.Typ)
|
1601 |
|
|
then
|
1602 |
|
|
Candidate := It;
|
1603 |
|
|
end if;
|
1604 |
|
|
|
1605 |
|
|
Get_Next_Interp (I, It);
|
1606 |
|
|
end loop;
|
1607 |
|
|
|
1608 |
|
|
if Candidate /= No_Interp then
|
1609 |
|
|
return Candidate;
|
1610 |
|
|
end if;
|
1611 |
|
|
end;
|
1612 |
|
|
|
1613 |
|
|
elsif Chars (Nam1) /= Name_Op_Not
|
1614 |
|
|
and then (Typ = Standard_Boolean or else Typ = Any_Boolean)
|
1615 |
|
|
then
|
1616 |
|
|
-- Equality or comparison operation. Choose predefined operator if
|
1617 |
|
|
-- arguments are universal. The node may be an operator, name, or
|
1618 |
|
|
-- a function call, so unpack arguments accordingly.
|
1619 |
|
|
|
1620 |
|
|
declare
|
1621 |
|
|
Arg1, Arg2 : Node_Id;
|
1622 |
|
|
|
1623 |
|
|
begin
|
1624 |
|
|
if Nkind (N) in N_Op then
|
1625 |
|
|
Arg1 := Left_Opnd (N);
|
1626 |
|
|
Arg2 := Right_Opnd (N);
|
1627 |
|
|
|
1628 |
|
|
elsif Is_Entity_Name (N)
|
1629 |
|
|
or else Nkind (N) = N_Operator_Symbol
|
1630 |
|
|
then
|
1631 |
|
|
Arg1 := First_Entity (Entity (N));
|
1632 |
|
|
Arg2 := Next_Entity (Arg1);
|
1633 |
|
|
|
1634 |
|
|
else
|
1635 |
|
|
Arg1 := First_Actual (N);
|
1636 |
|
|
Arg2 := Next_Actual (Arg1);
|
1637 |
|
|
end if;
|
1638 |
|
|
|
1639 |
|
|
if Present (Arg2)
|
1640 |
|
|
and then Present (Universal_Interpretation (Arg1))
|
1641 |
|
|
and then Universal_Interpretation (Arg2) =
|
1642 |
|
|
Universal_Interpretation (Arg1)
|
1643 |
|
|
then
|
1644 |
|
|
Get_First_Interp (N, I, It);
|
1645 |
|
|
while Scope (It.Nam) /= Standard_Standard loop
|
1646 |
|
|
Get_Next_Interp (I, It);
|
1647 |
|
|
end loop;
|
1648 |
|
|
|
1649 |
|
|
return It;
|
1650 |
|
|
end if;
|
1651 |
|
|
end;
|
1652 |
|
|
end if;
|
1653 |
|
|
end if;
|
1654 |
|
|
|
1655 |
|
|
-- If no universal interpretation, check whether user-defined operator
|
1656 |
|
|
-- hides predefined one, as well as other special cases. If the node
|
1657 |
|
|
-- is a range, then one or both bounds are ambiguous. Each will have
|
1658 |
|
|
-- to be disambiguated w.r.t. the context type. The type of the range
|
1659 |
|
|
-- itself is imposed by the context, so we can return either legal
|
1660 |
|
|
-- interpretation.
|
1661 |
|
|
|
1662 |
|
|
if Ekind (Nam1) = E_Operator then
|
1663 |
|
|
Predef_Subp := Nam1;
|
1664 |
|
|
User_Subp := Nam2;
|
1665 |
|
|
|
1666 |
|
|
elsif Ekind (Nam2) = E_Operator then
|
1667 |
|
|
Predef_Subp := Nam2;
|
1668 |
|
|
User_Subp := Nam1;
|
1669 |
|
|
|
1670 |
|
|
elsif Nkind (N) = N_Range then
|
1671 |
|
|
return It1;
|
1672 |
|
|
|
1673 |
|
|
-- Implement AI05-105: A renaming declaration with an access
|
1674 |
|
|
-- definition must resolve to an anonymous access type. This
|
1675 |
|
|
-- is a resolution rule and can be used to disambiguate.
|
1676 |
|
|
|
1677 |
|
|
elsif Nkind (Parent (N)) = N_Object_Renaming_Declaration
|
1678 |
|
|
and then Present (Access_Definition (Parent (N)))
|
1679 |
|
|
then
|
1680 |
|
|
if Ekind (It1.Typ) = E_Anonymous_Access_Type
|
1681 |
|
|
or else
|
1682 |
|
|
Ekind (It1.Typ) = E_Anonymous_Access_Subprogram_Type
|
1683 |
|
|
then
|
1684 |
|
|
if Ekind (It2.Typ) = Ekind (It1.Typ) then
|
1685 |
|
|
|
1686 |
|
|
-- True ambiguity
|
1687 |
|
|
|
1688 |
|
|
return No_Interp;
|
1689 |
|
|
|
1690 |
|
|
else
|
1691 |
|
|
return It1;
|
1692 |
|
|
end if;
|
1693 |
|
|
|
1694 |
|
|
elsif Ekind (It2.Typ) = E_Anonymous_Access_Type
|
1695 |
|
|
or else
|
1696 |
|
|
Ekind (It2.Typ) = E_Anonymous_Access_Subprogram_Type
|
1697 |
|
|
then
|
1698 |
|
|
return It2;
|
1699 |
|
|
|
1700 |
|
|
-- No legal interpretation
|
1701 |
|
|
|
1702 |
|
|
else
|
1703 |
|
|
return No_Interp;
|
1704 |
|
|
end if;
|
1705 |
|
|
|
1706 |
|
|
-- If two user defined-subprograms are visible, it is a true ambiguity,
|
1707 |
|
|
-- unless one of them is an entry and the context is a conditional or
|
1708 |
|
|
-- timed entry call, or unless we are within an instance and this is
|
1709 |
|
|
-- results from two formals types with the same actual.
|
1710 |
|
|
|
1711 |
|
|
else
|
1712 |
|
|
if Nkind (N) = N_Procedure_Call_Statement
|
1713 |
|
|
and then Nkind (Parent (N)) = N_Entry_Call_Alternative
|
1714 |
|
|
and then N = Entry_Call_Statement (Parent (N))
|
1715 |
|
|
then
|
1716 |
|
|
if Ekind (Nam2) = E_Entry then
|
1717 |
|
|
return It2;
|
1718 |
|
|
elsif Ekind (Nam1) = E_Entry then
|
1719 |
|
|
return It1;
|
1720 |
|
|
else
|
1721 |
|
|
return No_Interp;
|
1722 |
|
|
end if;
|
1723 |
|
|
|
1724 |
|
|
-- If the ambiguity occurs within an instance, it is due to several
|
1725 |
|
|
-- formal types with the same actual. Look for an exact match between
|
1726 |
|
|
-- the types of the formals of the overloadable entities, and the
|
1727 |
|
|
-- actuals in the call, to recover the unambiguous match in the
|
1728 |
|
|
-- original generic.
|
1729 |
|
|
|
1730 |
|
|
-- The ambiguity can also be due to an overloading between a formal
|
1731 |
|
|
-- subprogram and a subprogram declared outside the generic. If the
|
1732 |
|
|
-- node is overloaded, it did not resolve to the global entity in
|
1733 |
|
|
-- the generic, and we choose the formal subprogram.
|
1734 |
|
|
|
1735 |
|
|
-- Finally, the ambiguity can be between an explicit subprogram and
|
1736 |
|
|
-- one inherited (with different defaults) from an actual. In this
|
1737 |
|
|
-- case the resolution was to the explicit declaration in the
|
1738 |
|
|
-- generic, and remains so in the instance.
|
1739 |
|
|
|
1740 |
|
|
elsif In_Instance
|
1741 |
|
|
and then not In_Generic_Actual (N)
|
1742 |
|
|
then
|
1743 |
|
|
if Nkind (N) = N_Function_Call
|
1744 |
|
|
or else Nkind (N) = N_Procedure_Call_Statement
|
1745 |
|
|
then
|
1746 |
|
|
declare
|
1747 |
|
|
Actual : Node_Id;
|
1748 |
|
|
Formal : Entity_Id;
|
1749 |
|
|
Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1);
|
1750 |
|
|
Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2);
|
1751 |
|
|
|
1752 |
|
|
begin
|
1753 |
|
|
if Is_Act1 and then not Is_Act2 then
|
1754 |
|
|
return It1;
|
1755 |
|
|
|
1756 |
|
|
elsif Is_Act2 and then not Is_Act1 then
|
1757 |
|
|
return It2;
|
1758 |
|
|
|
1759 |
|
|
elsif Inherited_From_Actual (Nam1)
|
1760 |
|
|
and then Comes_From_Source (Nam2)
|
1761 |
|
|
then
|
1762 |
|
|
return It2;
|
1763 |
|
|
|
1764 |
|
|
elsif Inherited_From_Actual (Nam2)
|
1765 |
|
|
and then Comes_From_Source (Nam1)
|
1766 |
|
|
then
|
1767 |
|
|
return It1;
|
1768 |
|
|
end if;
|
1769 |
|
|
|
1770 |
|
|
Actual := First_Actual (N);
|
1771 |
|
|
Formal := First_Formal (Nam1);
|
1772 |
|
|
while Present (Actual) loop
|
1773 |
|
|
if Etype (Actual) /= Etype (Formal) then
|
1774 |
|
|
return It2;
|
1775 |
|
|
end if;
|
1776 |
|
|
|
1777 |
|
|
Next_Actual (Actual);
|
1778 |
|
|
Next_Formal (Formal);
|
1779 |
|
|
end loop;
|
1780 |
|
|
|
1781 |
|
|
return It1;
|
1782 |
|
|
end;
|
1783 |
|
|
|
1784 |
|
|
elsif Nkind (N) in N_Binary_Op then
|
1785 |
|
|
if Matches (Left_Opnd (N), First_Formal (Nam1))
|
1786 |
|
|
and then
|
1787 |
|
|
Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
|
1788 |
|
|
then
|
1789 |
|
|
return It1;
|
1790 |
|
|
else
|
1791 |
|
|
return It2;
|
1792 |
|
|
end if;
|
1793 |
|
|
|
1794 |
|
|
elsif Nkind (N) in N_Unary_Op then
|
1795 |
|
|
if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
|
1796 |
|
|
return It1;
|
1797 |
|
|
else
|
1798 |
|
|
return It2;
|
1799 |
|
|
end if;
|
1800 |
|
|
|
1801 |
|
|
else
|
1802 |
|
|
return Remove_Conversions;
|
1803 |
|
|
end if;
|
1804 |
|
|
else
|
1805 |
|
|
return Remove_Conversions;
|
1806 |
|
|
end if;
|
1807 |
|
|
end if;
|
1808 |
|
|
|
1809 |
|
|
-- An implicit concatenation operator on a string type cannot be
|
1810 |
|
|
-- disambiguated from the predefined concatenation. This can only
|
1811 |
|
|
-- happen with concatenation of string literals.
|
1812 |
|
|
|
1813 |
|
|
if Chars (User_Subp) = Name_Op_Concat
|
1814 |
|
|
and then Ekind (User_Subp) = E_Operator
|
1815 |
|
|
and then Is_String_Type (Etype (First_Formal (User_Subp)))
|
1816 |
|
|
then
|
1817 |
|
|
return No_Interp;
|
1818 |
|
|
|
1819 |
|
|
-- If the user-defined operator is in an open scope, or in the scope
|
1820 |
|
|
-- of the resulting type, or given by an expanded name that names its
|
1821 |
|
|
-- scope, it hides the predefined operator for the type. Exponentiation
|
1822 |
|
|
-- has to be special-cased because the implicit operator does not have
|
1823 |
|
|
-- a symmetric signature, and may not be hidden by the explicit one.
|
1824 |
|
|
|
1825 |
|
|
elsif (Nkind (N) = N_Function_Call
|
1826 |
|
|
and then Nkind (Name (N)) = N_Expanded_Name
|
1827 |
|
|
and then (Chars (Predef_Subp) /= Name_Op_Expon
|
1828 |
|
|
or else Hides_Op (User_Subp, Predef_Subp))
|
1829 |
|
|
and then Scope (User_Subp) = Entity (Prefix (Name (N))))
|
1830 |
|
|
or else Hides_Op (User_Subp, Predef_Subp)
|
1831 |
|
|
then
|
1832 |
|
|
if It1.Nam = User_Subp then
|
1833 |
|
|
return It1;
|
1834 |
|
|
else
|
1835 |
|
|
return It2;
|
1836 |
|
|
end if;
|
1837 |
|
|
|
1838 |
|
|
-- Otherwise, the predefined operator has precedence, or if the user-
|
1839 |
|
|
-- defined operation is directly visible we have a true ambiguity. If
|
1840 |
|
|
-- this is a fixed-point multiplication and division in Ada83 mode,
|
1841 |
|
|
-- exclude the universal_fixed operator, which often causes ambiguities
|
1842 |
|
|
-- in legacy code.
|
1843 |
|
|
|
1844 |
|
|
else
|
1845 |
|
|
if (In_Open_Scopes (Scope (User_Subp))
|
1846 |
|
|
or else Is_Potentially_Use_Visible (User_Subp))
|
1847 |
|
|
and then not In_Instance
|
1848 |
|
|
then
|
1849 |
|
|
if Is_Fixed_Point_Type (Typ)
|
1850 |
|
|
and then (Chars (Nam1) = Name_Op_Multiply
|
1851 |
|
|
or else Chars (Nam1) = Name_Op_Divide)
|
1852 |
|
|
and then Ada_Version = Ada_83
|
1853 |
|
|
then
|
1854 |
|
|
if It2.Nam = Predef_Subp then
|
1855 |
|
|
return It1;
|
1856 |
|
|
else
|
1857 |
|
|
return It2;
|
1858 |
|
|
end if;
|
1859 |
|
|
|
1860 |
|
|
-- Ada 2005, AI-420: preference rule for "=" on Universal_Access
|
1861 |
|
|
-- states that the operator defined in Standard is not available
|
1862 |
|
|
-- if there is a user-defined equality with the proper signature,
|
1863 |
|
|
-- declared in the same declarative list as the type. The node
|
1864 |
|
|
-- may be an operator or a function call.
|
1865 |
|
|
|
1866 |
|
|
elsif (Chars (Nam1) = Name_Op_Eq
|
1867 |
|
|
or else
|
1868 |
|
|
Chars (Nam1) = Name_Op_Ne)
|
1869 |
|
|
and then Ada_Version >= Ada_05
|
1870 |
|
|
and then Etype (User_Subp) = Standard_Boolean
|
1871 |
|
|
then
|
1872 |
|
|
declare
|
1873 |
|
|
Opnd : Node_Id;
|
1874 |
|
|
begin
|
1875 |
|
|
if Nkind (N) = N_Function_Call then
|
1876 |
|
|
Opnd := First_Actual (N);
|
1877 |
|
|
else
|
1878 |
|
|
Opnd := Left_Opnd (N);
|
1879 |
|
|
end if;
|
1880 |
|
|
|
1881 |
|
|
if Ekind (Etype (Opnd)) = E_Anonymous_Access_Type
|
1882 |
|
|
and then
|
1883 |
|
|
List_Containing (Parent (Designated_Type (Etype (Opnd))))
|
1884 |
|
|
= List_Containing (Unit_Declaration_Node (User_Subp))
|
1885 |
|
|
then
|
1886 |
|
|
if It2.Nam = Predef_Subp then
|
1887 |
|
|
return It1;
|
1888 |
|
|
else
|
1889 |
|
|
return It2;
|
1890 |
|
|
end if;
|
1891 |
|
|
else
|
1892 |
|
|
return Remove_Conversions;
|
1893 |
|
|
end if;
|
1894 |
|
|
end;
|
1895 |
|
|
|
1896 |
|
|
else
|
1897 |
|
|
return No_Interp;
|
1898 |
|
|
end if;
|
1899 |
|
|
|
1900 |
|
|
elsif It1.Nam = Predef_Subp then
|
1901 |
|
|
return It1;
|
1902 |
|
|
|
1903 |
|
|
else
|
1904 |
|
|
return It2;
|
1905 |
|
|
end if;
|
1906 |
|
|
end if;
|
1907 |
|
|
end Disambiguate;
|
1908 |
|
|
|
1909 |
|
|
---------------------
|
1910 |
|
|
-- End_Interp_List --
|
1911 |
|
|
---------------------
|
1912 |
|
|
|
1913 |
|
|
procedure End_Interp_List is
|
1914 |
|
|
begin
|
1915 |
|
|
All_Interp.Table (All_Interp.Last) := No_Interp;
|
1916 |
|
|
All_Interp.Increment_Last;
|
1917 |
|
|
end End_Interp_List;
|
1918 |
|
|
|
1919 |
|
|
-------------------------
|
1920 |
|
|
-- Entity_Matches_Spec --
|
1921 |
|
|
-------------------------
|
1922 |
|
|
|
1923 |
|
|
function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
|
1924 |
|
|
begin
|
1925 |
|
|
-- Simple case: same entity kinds, type conformance is required. A
|
1926 |
|
|
-- parameterless function can also rename a literal.
|
1927 |
|
|
|
1928 |
|
|
if Ekind (Old_S) = Ekind (New_S)
|
1929 |
|
|
or else (Ekind (New_S) = E_Function
|
1930 |
|
|
and then Ekind (Old_S) = E_Enumeration_Literal)
|
1931 |
|
|
then
|
1932 |
|
|
return Type_Conformant (New_S, Old_S);
|
1933 |
|
|
|
1934 |
|
|
elsif Ekind (New_S) = E_Function
|
1935 |
|
|
and then Ekind (Old_S) = E_Operator
|
1936 |
|
|
then
|
1937 |
|
|
return Operator_Matches_Spec (Old_S, New_S);
|
1938 |
|
|
|
1939 |
|
|
elsif Ekind (New_S) = E_Procedure
|
1940 |
|
|
and then Is_Entry (Old_S)
|
1941 |
|
|
then
|
1942 |
|
|
return Type_Conformant (New_S, Old_S);
|
1943 |
|
|
|
1944 |
|
|
else
|
1945 |
|
|
return False;
|
1946 |
|
|
end if;
|
1947 |
|
|
end Entity_Matches_Spec;
|
1948 |
|
|
|
1949 |
|
|
----------------------
|
1950 |
|
|
-- Find_Unique_Type --
|
1951 |
|
|
----------------------
|
1952 |
|
|
|
1953 |
|
|
function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
|
1954 |
|
|
T : constant Entity_Id := Etype (L);
|
1955 |
|
|
I : Interp_Index;
|
1956 |
|
|
It : Interp;
|
1957 |
|
|
TR : Entity_Id := Any_Type;
|
1958 |
|
|
|
1959 |
|
|
begin
|
1960 |
|
|
if Is_Overloaded (R) then
|
1961 |
|
|
Get_First_Interp (R, I, It);
|
1962 |
|
|
while Present (It.Typ) loop
|
1963 |
|
|
if Covers (T, It.Typ) or else Covers (It.Typ, T) then
|
1964 |
|
|
|
1965 |
|
|
-- If several interpretations are possible and L is universal,
|
1966 |
|
|
-- apply preference rule.
|
1967 |
|
|
|
1968 |
|
|
if TR /= Any_Type then
|
1969 |
|
|
|
1970 |
|
|
if (T = Universal_Integer or else T = Universal_Real)
|
1971 |
|
|
and then It.Typ = T
|
1972 |
|
|
then
|
1973 |
|
|
TR := It.Typ;
|
1974 |
|
|
end if;
|
1975 |
|
|
|
1976 |
|
|
else
|
1977 |
|
|
TR := It.Typ;
|
1978 |
|
|
end if;
|
1979 |
|
|
end if;
|
1980 |
|
|
|
1981 |
|
|
Get_Next_Interp (I, It);
|
1982 |
|
|
end loop;
|
1983 |
|
|
|
1984 |
|
|
Set_Etype (R, TR);
|
1985 |
|
|
|
1986 |
|
|
-- In the non-overloaded case, the Etype of R is already set correctly
|
1987 |
|
|
|
1988 |
|
|
else
|
1989 |
|
|
null;
|
1990 |
|
|
end if;
|
1991 |
|
|
|
1992 |
|
|
-- If one of the operands is Universal_Fixed, the type of the other
|
1993 |
|
|
-- operand provides the context.
|
1994 |
|
|
|
1995 |
|
|
if Etype (R) = Universal_Fixed then
|
1996 |
|
|
return T;
|
1997 |
|
|
|
1998 |
|
|
elsif T = Universal_Fixed then
|
1999 |
|
|
return Etype (R);
|
2000 |
|
|
|
2001 |
|
|
-- Ada 2005 (AI-230): Support the following operators:
|
2002 |
|
|
|
2003 |
|
|
-- function "=" (L, R : universal_access) return Boolean;
|
2004 |
|
|
-- function "/=" (L, R : universal_access) return Boolean;
|
2005 |
|
|
|
2006 |
|
|
-- Pool specific access types (E_Access_Type) are not covered by these
|
2007 |
|
|
-- operators because of the legality rule of 4.5.2(9.2): "The operands
|
2008 |
|
|
-- of the equality operators for universal_access shall be convertible
|
2009 |
|
|
-- to one another (see 4.6)". For example, considering the type decla-
|
2010 |
|
|
-- ration "type P is access Integer" and an anonymous access to Integer,
|
2011 |
|
|
-- P is convertible to "access Integer" by 4.6 (24.11-24.15), but there
|
2012 |
|
|
-- is no rule in 4.6 that allows "access Integer" to be converted to P.
|
2013 |
|
|
|
2014 |
|
|
elsif Ada_Version >= Ada_05
|
2015 |
|
|
and then
|
2016 |
|
|
(Ekind (Etype (L)) = E_Anonymous_Access_Type
|
2017 |
|
|
or else
|
2018 |
|
|
Ekind (Etype (L)) = E_Anonymous_Access_Subprogram_Type)
|
2019 |
|
|
and then Is_Access_Type (Etype (R))
|
2020 |
|
|
and then Ekind (Etype (R)) /= E_Access_Type
|
2021 |
|
|
then
|
2022 |
|
|
return Etype (L);
|
2023 |
|
|
|
2024 |
|
|
elsif Ada_Version >= Ada_05
|
2025 |
|
|
and then
|
2026 |
|
|
(Ekind (Etype (R)) = E_Anonymous_Access_Type
|
2027 |
|
|
or else Ekind (Etype (R)) = E_Anonymous_Access_Subprogram_Type)
|
2028 |
|
|
and then Is_Access_Type (Etype (L))
|
2029 |
|
|
and then Ekind (Etype (L)) /= E_Access_Type
|
2030 |
|
|
then
|
2031 |
|
|
return Etype (R);
|
2032 |
|
|
|
2033 |
|
|
else
|
2034 |
|
|
return Specific_Type (T, Etype (R));
|
2035 |
|
|
end if;
|
2036 |
|
|
end Find_Unique_Type;
|
2037 |
|
|
|
2038 |
|
|
-------------------------------------
|
2039 |
|
|
-- Function_Interp_Has_Abstract_Op --
|
2040 |
|
|
-------------------------------------
|
2041 |
|
|
|
2042 |
|
|
function Function_Interp_Has_Abstract_Op
|
2043 |
|
|
(N : Node_Id;
|
2044 |
|
|
E : Entity_Id) return Entity_Id
|
2045 |
|
|
is
|
2046 |
|
|
Abstr_Op : Entity_Id;
|
2047 |
|
|
Act : Node_Id;
|
2048 |
|
|
Act_Parm : Node_Id;
|
2049 |
|
|
Form_Parm : Node_Id;
|
2050 |
|
|
|
2051 |
|
|
begin
|
2052 |
|
|
-- Why is check on E needed below ???
|
2053 |
|
|
-- In any case this para needs comments ???
|
2054 |
|
|
|
2055 |
|
|
if Is_Overloaded (N) and then Is_Overloadable (E) then
|
2056 |
|
|
Act_Parm := First_Actual (N);
|
2057 |
|
|
Form_Parm := First_Formal (E);
|
2058 |
|
|
while Present (Act_Parm)
|
2059 |
|
|
and then Present (Form_Parm)
|
2060 |
|
|
loop
|
2061 |
|
|
Act := Act_Parm;
|
2062 |
|
|
|
2063 |
|
|
if Nkind (Act) = N_Parameter_Association then
|
2064 |
|
|
Act := Explicit_Actual_Parameter (Act);
|
2065 |
|
|
end if;
|
2066 |
|
|
|
2067 |
|
|
Abstr_Op := Has_Abstract_Op (Act, Etype (Form_Parm));
|
2068 |
|
|
|
2069 |
|
|
if Present (Abstr_Op) then
|
2070 |
|
|
return Abstr_Op;
|
2071 |
|
|
end if;
|
2072 |
|
|
|
2073 |
|
|
Next_Actual (Act_Parm);
|
2074 |
|
|
Next_Formal (Form_Parm);
|
2075 |
|
|
end loop;
|
2076 |
|
|
end if;
|
2077 |
|
|
|
2078 |
|
|
return Empty;
|
2079 |
|
|
end Function_Interp_Has_Abstract_Op;
|
2080 |
|
|
|
2081 |
|
|
----------------------
|
2082 |
|
|
-- Get_First_Interp --
|
2083 |
|
|
----------------------
|
2084 |
|
|
|
2085 |
|
|
procedure Get_First_Interp
|
2086 |
|
|
(N : Node_Id;
|
2087 |
|
|
I : out Interp_Index;
|
2088 |
|
|
It : out Interp)
|
2089 |
|
|
is
|
2090 |
|
|
Int_Ind : Interp_Index;
|
2091 |
|
|
Map_Ptr : Int;
|
2092 |
|
|
O_N : Node_Id;
|
2093 |
|
|
|
2094 |
|
|
begin
|
2095 |
|
|
-- If a selected component is overloaded because the selector has
|
2096 |
|
|
-- multiple interpretations, the node is a call to a protected
|
2097 |
|
|
-- operation or an indirect call. Retrieve the interpretation from
|
2098 |
|
|
-- the selector name. The selected component may be overloaded as well
|
2099 |
|
|
-- if the prefix is overloaded. That case is unchanged.
|
2100 |
|
|
|
2101 |
|
|
if Nkind (N) = N_Selected_Component
|
2102 |
|
|
and then Is_Overloaded (Selector_Name (N))
|
2103 |
|
|
then
|
2104 |
|
|
O_N := Selector_Name (N);
|
2105 |
|
|
else
|
2106 |
|
|
O_N := N;
|
2107 |
|
|
end if;
|
2108 |
|
|
|
2109 |
|
|
Map_Ptr := Headers (Hash (O_N));
|
2110 |
|
|
while Map_Ptr /= No_Entry loop
|
2111 |
|
|
if Interp_Map.Table (Map_Ptr).Node = O_N then
|
2112 |
|
|
Int_Ind := Interp_Map.Table (Map_Ptr).Index;
|
2113 |
|
|
It := All_Interp.Table (Int_Ind);
|
2114 |
|
|
I := Int_Ind;
|
2115 |
|
|
return;
|
2116 |
|
|
else
|
2117 |
|
|
Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
|
2118 |
|
|
end if;
|
2119 |
|
|
end loop;
|
2120 |
|
|
|
2121 |
|
|
-- Procedure should never be called if the node has no interpretations
|
2122 |
|
|
|
2123 |
|
|
raise Program_Error;
|
2124 |
|
|
end Get_First_Interp;
|
2125 |
|
|
|
2126 |
|
|
---------------------
|
2127 |
|
|
-- Get_Next_Interp --
|
2128 |
|
|
---------------------
|
2129 |
|
|
|
2130 |
|
|
procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
|
2131 |
|
|
begin
|
2132 |
|
|
I := I + 1;
|
2133 |
|
|
It := All_Interp.Table (I);
|
2134 |
|
|
end Get_Next_Interp;
|
2135 |
|
|
|
2136 |
|
|
-------------------------
|
2137 |
|
|
-- Has_Compatible_Type --
|
2138 |
|
|
-------------------------
|
2139 |
|
|
|
2140 |
|
|
function Has_Compatible_Type
|
2141 |
|
|
(N : Node_Id;
|
2142 |
|
|
Typ : Entity_Id) return Boolean
|
2143 |
|
|
is
|
2144 |
|
|
I : Interp_Index;
|
2145 |
|
|
It : Interp;
|
2146 |
|
|
|
2147 |
|
|
begin
|
2148 |
|
|
if N = Error then
|
2149 |
|
|
return False;
|
2150 |
|
|
end if;
|
2151 |
|
|
|
2152 |
|
|
if Nkind (N) = N_Subtype_Indication
|
2153 |
|
|
or else not Is_Overloaded (N)
|
2154 |
|
|
then
|
2155 |
|
|
return
|
2156 |
|
|
Covers (Typ, Etype (N))
|
2157 |
|
|
|
2158 |
|
|
-- Ada 2005 (AI-345): The context may be a synchronized interface.
|
2159 |
|
|
-- If the type is already frozen use the corresponding_record
|
2160 |
|
|
-- to check whether it is a proper descendant.
|
2161 |
|
|
|
2162 |
|
|
or else
|
2163 |
|
|
(Is_Record_Type (Typ)
|
2164 |
|
|
and then Is_Concurrent_Type (Etype (N))
|
2165 |
|
|
and then Present (Corresponding_Record_Type (Etype (N)))
|
2166 |
|
|
and then Covers (Typ, Corresponding_Record_Type (Etype (N))))
|
2167 |
|
|
|
2168 |
|
|
or else
|
2169 |
|
|
(Is_Concurrent_Type (Typ)
|
2170 |
|
|
and then Is_Record_Type (Etype (N))
|
2171 |
|
|
and then Present (Corresponding_Record_Type (Typ))
|
2172 |
|
|
and then Covers (Corresponding_Record_Type (Typ), Etype (N)))
|
2173 |
|
|
|
2174 |
|
|
or else
|
2175 |
|
|
(not Is_Tagged_Type (Typ)
|
2176 |
|
|
and then Ekind (Typ) /= E_Anonymous_Access_Type
|
2177 |
|
|
and then Covers (Etype (N), Typ));
|
2178 |
|
|
|
2179 |
|
|
else
|
2180 |
|
|
Get_First_Interp (N, I, It);
|
2181 |
|
|
while Present (It.Typ) loop
|
2182 |
|
|
if (Covers (Typ, It.Typ)
|
2183 |
|
|
and then
|
2184 |
|
|
(Scope (It.Nam) /= Standard_Standard
|
2185 |
|
|
or else not Is_Invisible_Operator (N, Base_Type (Typ))))
|
2186 |
|
|
|
2187 |
|
|
-- Ada 2005 (AI-345)
|
2188 |
|
|
|
2189 |
|
|
or else
|
2190 |
|
|
(Is_Concurrent_Type (It.Typ)
|
2191 |
|
|
and then Present (Corresponding_Record_Type
|
2192 |
|
|
(Etype (It.Typ)))
|
2193 |
|
|
and then Covers (Typ, Corresponding_Record_Type
|
2194 |
|
|
(Etype (It.Typ))))
|
2195 |
|
|
|
2196 |
|
|
or else (not Is_Tagged_Type (Typ)
|
2197 |
|
|
and then Ekind (Typ) /= E_Anonymous_Access_Type
|
2198 |
|
|
and then Covers (It.Typ, Typ))
|
2199 |
|
|
then
|
2200 |
|
|
return True;
|
2201 |
|
|
end if;
|
2202 |
|
|
|
2203 |
|
|
Get_Next_Interp (I, It);
|
2204 |
|
|
end loop;
|
2205 |
|
|
|
2206 |
|
|
return False;
|
2207 |
|
|
end if;
|
2208 |
|
|
end Has_Compatible_Type;
|
2209 |
|
|
|
2210 |
|
|
---------------------
|
2211 |
|
|
-- Has_Abstract_Op --
|
2212 |
|
|
---------------------
|
2213 |
|
|
|
2214 |
|
|
function Has_Abstract_Op
|
2215 |
|
|
(N : Node_Id;
|
2216 |
|
|
Typ : Entity_Id) return Entity_Id
|
2217 |
|
|
is
|
2218 |
|
|
I : Interp_Index;
|
2219 |
|
|
It : Interp;
|
2220 |
|
|
|
2221 |
|
|
begin
|
2222 |
|
|
if Is_Overloaded (N) then
|
2223 |
|
|
Get_First_Interp (N, I, It);
|
2224 |
|
|
while Present (It.Nam) loop
|
2225 |
|
|
if Present (It.Abstract_Op)
|
2226 |
|
|
and then Etype (It.Abstract_Op) = Typ
|
2227 |
|
|
then
|
2228 |
|
|
return It.Abstract_Op;
|
2229 |
|
|
end if;
|
2230 |
|
|
|
2231 |
|
|
Get_Next_Interp (I, It);
|
2232 |
|
|
end loop;
|
2233 |
|
|
end if;
|
2234 |
|
|
|
2235 |
|
|
return Empty;
|
2236 |
|
|
end Has_Abstract_Op;
|
2237 |
|
|
|
2238 |
|
|
----------
|
2239 |
|
|
-- Hash --
|
2240 |
|
|
----------
|
2241 |
|
|
|
2242 |
|
|
function Hash (N : Node_Id) return Int is
|
2243 |
|
|
begin
|
2244 |
|
|
-- Nodes have a size that is power of two, so to select significant
|
2245 |
|
|
-- bits only we remove the low-order bits.
|
2246 |
|
|
|
2247 |
|
|
return ((Int (N) / 2 ** 5) mod Header_Size);
|
2248 |
|
|
end Hash;
|
2249 |
|
|
|
2250 |
|
|
--------------
|
2251 |
|
|
-- Hides_Op --
|
2252 |
|
|
--------------
|
2253 |
|
|
|
2254 |
|
|
function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
|
2255 |
|
|
Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
|
2256 |
|
|
begin
|
2257 |
|
|
return Operator_Matches_Spec (Op, F)
|
2258 |
|
|
and then (In_Open_Scopes (Scope (F))
|
2259 |
|
|
or else Scope (F) = Scope (Btyp)
|
2260 |
|
|
or else (not In_Open_Scopes (Scope (Btyp))
|
2261 |
|
|
and then not In_Use (Btyp)
|
2262 |
|
|
and then not In_Use (Scope (Btyp))));
|
2263 |
|
|
end Hides_Op;
|
2264 |
|
|
|
2265 |
|
|
------------------------
|
2266 |
|
|
-- Init_Interp_Tables --
|
2267 |
|
|
------------------------
|
2268 |
|
|
|
2269 |
|
|
procedure Init_Interp_Tables is
|
2270 |
|
|
begin
|
2271 |
|
|
All_Interp.Init;
|
2272 |
|
|
Interp_Map.Init;
|
2273 |
|
|
Headers := (others => No_Entry);
|
2274 |
|
|
end Init_Interp_Tables;
|
2275 |
|
|
|
2276 |
|
|
-----------------------------------
|
2277 |
|
|
-- Interface_Present_In_Ancestor --
|
2278 |
|
|
-----------------------------------
|
2279 |
|
|
|
2280 |
|
|
function Interface_Present_In_Ancestor
|
2281 |
|
|
(Typ : Entity_Id;
|
2282 |
|
|
Iface : Entity_Id) return Boolean
|
2283 |
|
|
is
|
2284 |
|
|
Target_Typ : Entity_Id;
|
2285 |
|
|
Iface_Typ : Entity_Id;
|
2286 |
|
|
|
2287 |
|
|
function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean;
|
2288 |
|
|
-- Returns True if Typ or some ancestor of Typ implements Iface
|
2289 |
|
|
|
2290 |
|
|
-------------------------------
|
2291 |
|
|
-- Iface_Present_In_Ancestor --
|
2292 |
|
|
-------------------------------
|
2293 |
|
|
|
2294 |
|
|
function Iface_Present_In_Ancestor (Typ : Entity_Id) return Boolean is
|
2295 |
|
|
E : Entity_Id;
|
2296 |
|
|
AI : Entity_Id;
|
2297 |
|
|
Elmt : Elmt_Id;
|
2298 |
|
|
|
2299 |
|
|
begin
|
2300 |
|
|
if Typ = Iface_Typ then
|
2301 |
|
|
return True;
|
2302 |
|
|
end if;
|
2303 |
|
|
|
2304 |
|
|
-- Handle private types
|
2305 |
|
|
|
2306 |
|
|
if Present (Full_View (Typ))
|
2307 |
|
|
and then not Is_Concurrent_Type (Full_View (Typ))
|
2308 |
|
|
then
|
2309 |
|
|
E := Full_View (Typ);
|
2310 |
|
|
else
|
2311 |
|
|
E := Typ;
|
2312 |
|
|
end if;
|
2313 |
|
|
|
2314 |
|
|
loop
|
2315 |
|
|
if Present (Interfaces (E))
|
2316 |
|
|
and then Present (Interfaces (E))
|
2317 |
|
|
and then not Is_Empty_Elmt_List (Interfaces (E))
|
2318 |
|
|
then
|
2319 |
|
|
Elmt := First_Elmt (Interfaces (E));
|
2320 |
|
|
while Present (Elmt) loop
|
2321 |
|
|
AI := Node (Elmt);
|
2322 |
|
|
|
2323 |
|
|
if AI = Iface_Typ or else Is_Ancestor (Iface_Typ, AI) then
|
2324 |
|
|
return True;
|
2325 |
|
|
end if;
|
2326 |
|
|
|
2327 |
|
|
Next_Elmt (Elmt);
|
2328 |
|
|
end loop;
|
2329 |
|
|
end if;
|
2330 |
|
|
|
2331 |
|
|
exit when Etype (E) = E
|
2332 |
|
|
|
2333 |
|
|
-- Handle private types
|
2334 |
|
|
|
2335 |
|
|
or else (Present (Full_View (Etype (E)))
|
2336 |
|
|
and then Full_View (Etype (E)) = E);
|
2337 |
|
|
|
2338 |
|
|
-- Check if the current type is a direct derivation of the
|
2339 |
|
|
-- interface
|
2340 |
|
|
|
2341 |
|
|
if Etype (E) = Iface_Typ then
|
2342 |
|
|
return True;
|
2343 |
|
|
end if;
|
2344 |
|
|
|
2345 |
|
|
-- Climb to the immediate ancestor handling private types
|
2346 |
|
|
|
2347 |
|
|
if Present (Full_View (Etype (E))) then
|
2348 |
|
|
E := Full_View (Etype (E));
|
2349 |
|
|
else
|
2350 |
|
|
E := Etype (E);
|
2351 |
|
|
end if;
|
2352 |
|
|
end loop;
|
2353 |
|
|
|
2354 |
|
|
return False;
|
2355 |
|
|
end Iface_Present_In_Ancestor;
|
2356 |
|
|
|
2357 |
|
|
-- Start of processing for Interface_Present_In_Ancestor
|
2358 |
|
|
|
2359 |
|
|
begin
|
2360 |
|
|
-- Iface might be a class-wide subtype, so we have to apply Base_Type
|
2361 |
|
|
|
2362 |
|
|
if Is_Class_Wide_Type (Iface) then
|
2363 |
|
|
Iface_Typ := Etype (Base_Type (Iface));
|
2364 |
|
|
else
|
2365 |
|
|
Iface_Typ := Iface;
|
2366 |
|
|
end if;
|
2367 |
|
|
|
2368 |
|
|
-- Handle subtypes
|
2369 |
|
|
|
2370 |
|
|
Iface_Typ := Base_Type (Iface_Typ);
|
2371 |
|
|
|
2372 |
|
|
if Is_Access_Type (Typ) then
|
2373 |
|
|
Target_Typ := Etype (Directly_Designated_Type (Typ));
|
2374 |
|
|
else
|
2375 |
|
|
Target_Typ := Typ;
|
2376 |
|
|
end if;
|
2377 |
|
|
|
2378 |
|
|
if Is_Concurrent_Record_Type (Target_Typ) then
|
2379 |
|
|
Target_Typ := Corresponding_Concurrent_Type (Target_Typ);
|
2380 |
|
|
end if;
|
2381 |
|
|
|
2382 |
|
|
Target_Typ := Base_Type (Target_Typ);
|
2383 |
|
|
|
2384 |
|
|
-- In case of concurrent types we can't use the Corresponding Record_Typ
|
2385 |
|
|
-- to look for the interface because it is built by the expander (and
|
2386 |
|
|
-- hence it is not always available). For this reason we traverse the
|
2387 |
|
|
-- list of interfaces (available in the parent of the concurrent type)
|
2388 |
|
|
|
2389 |
|
|
if Is_Concurrent_Type (Target_Typ) then
|
2390 |
|
|
if Present (Interface_List (Parent (Target_Typ))) then
|
2391 |
|
|
declare
|
2392 |
|
|
AI : Node_Id;
|
2393 |
|
|
|
2394 |
|
|
begin
|
2395 |
|
|
AI := First (Interface_List (Parent (Target_Typ)));
|
2396 |
|
|
while Present (AI) loop
|
2397 |
|
|
if Etype (AI) = Iface_Typ then
|
2398 |
|
|
return True;
|
2399 |
|
|
|
2400 |
|
|
elsif Present (Interfaces (Etype (AI)))
|
2401 |
|
|
and then Iface_Present_In_Ancestor (Etype (AI))
|
2402 |
|
|
then
|
2403 |
|
|
return True;
|
2404 |
|
|
end if;
|
2405 |
|
|
|
2406 |
|
|
Next (AI);
|
2407 |
|
|
end loop;
|
2408 |
|
|
end;
|
2409 |
|
|
end if;
|
2410 |
|
|
|
2411 |
|
|
return False;
|
2412 |
|
|
end if;
|
2413 |
|
|
|
2414 |
|
|
if Is_Class_Wide_Type (Target_Typ) then
|
2415 |
|
|
Target_Typ := Etype (Target_Typ);
|
2416 |
|
|
end if;
|
2417 |
|
|
|
2418 |
|
|
if Ekind (Target_Typ) = E_Incomplete_Type then
|
2419 |
|
|
pragma Assert (Present (Non_Limited_View (Target_Typ)));
|
2420 |
|
|
Target_Typ := Non_Limited_View (Target_Typ);
|
2421 |
|
|
|
2422 |
|
|
-- Protect the frontend against previously detected errors
|
2423 |
|
|
|
2424 |
|
|
if Ekind (Target_Typ) = E_Incomplete_Type then
|
2425 |
|
|
return False;
|
2426 |
|
|
end if;
|
2427 |
|
|
end if;
|
2428 |
|
|
|
2429 |
|
|
return Iface_Present_In_Ancestor (Target_Typ);
|
2430 |
|
|
end Interface_Present_In_Ancestor;
|
2431 |
|
|
|
2432 |
|
|
---------------------
|
2433 |
|
|
-- Intersect_Types --
|
2434 |
|
|
---------------------
|
2435 |
|
|
|
2436 |
|
|
function Intersect_Types (L, R : Node_Id) return Entity_Id is
|
2437 |
|
|
Index : Interp_Index;
|
2438 |
|
|
It : Interp;
|
2439 |
|
|
Typ : Entity_Id;
|
2440 |
|
|
|
2441 |
|
|
function Check_Right_Argument (T : Entity_Id) return Entity_Id;
|
2442 |
|
|
-- Find interpretation of right arg that has type compatible with T
|
2443 |
|
|
|
2444 |
|
|
--------------------------
|
2445 |
|
|
-- Check_Right_Argument --
|
2446 |
|
|
--------------------------
|
2447 |
|
|
|
2448 |
|
|
function Check_Right_Argument (T : Entity_Id) return Entity_Id is
|
2449 |
|
|
Index : Interp_Index;
|
2450 |
|
|
It : Interp;
|
2451 |
|
|
T2 : Entity_Id;
|
2452 |
|
|
|
2453 |
|
|
begin
|
2454 |
|
|
if not Is_Overloaded (R) then
|
2455 |
|
|
return Specific_Type (T, Etype (R));
|
2456 |
|
|
|
2457 |
|
|
else
|
2458 |
|
|
Get_First_Interp (R, Index, It);
|
2459 |
|
|
loop
|
2460 |
|
|
T2 := Specific_Type (T, It.Typ);
|
2461 |
|
|
|
2462 |
|
|
if T2 /= Any_Type then
|
2463 |
|
|
return T2;
|
2464 |
|
|
end if;
|
2465 |
|
|
|
2466 |
|
|
Get_Next_Interp (Index, It);
|
2467 |
|
|
exit when No (It.Typ);
|
2468 |
|
|
end loop;
|
2469 |
|
|
|
2470 |
|
|
return Any_Type;
|
2471 |
|
|
end if;
|
2472 |
|
|
end Check_Right_Argument;
|
2473 |
|
|
|
2474 |
|
|
-- Start of processing for Intersect_Types
|
2475 |
|
|
|
2476 |
|
|
begin
|
2477 |
|
|
if Etype (L) = Any_Type or else Etype (R) = Any_Type then
|
2478 |
|
|
return Any_Type;
|
2479 |
|
|
end if;
|
2480 |
|
|
|
2481 |
|
|
if not Is_Overloaded (L) then
|
2482 |
|
|
Typ := Check_Right_Argument (Etype (L));
|
2483 |
|
|
|
2484 |
|
|
else
|
2485 |
|
|
Typ := Any_Type;
|
2486 |
|
|
Get_First_Interp (L, Index, It);
|
2487 |
|
|
while Present (It.Typ) loop
|
2488 |
|
|
Typ := Check_Right_Argument (It.Typ);
|
2489 |
|
|
exit when Typ /= Any_Type;
|
2490 |
|
|
Get_Next_Interp (Index, It);
|
2491 |
|
|
end loop;
|
2492 |
|
|
|
2493 |
|
|
end if;
|
2494 |
|
|
|
2495 |
|
|
-- If Typ is Any_Type, it means no compatible pair of types was found
|
2496 |
|
|
|
2497 |
|
|
if Typ = Any_Type then
|
2498 |
|
|
if Nkind (Parent (L)) in N_Op then
|
2499 |
|
|
Error_Msg_N ("incompatible types for operator", Parent (L));
|
2500 |
|
|
|
2501 |
|
|
elsif Nkind (Parent (L)) = N_Range then
|
2502 |
|
|
Error_Msg_N ("incompatible types given in constraint", Parent (L));
|
2503 |
|
|
|
2504 |
|
|
-- Ada 2005 (AI-251): Complete the error notification
|
2505 |
|
|
|
2506 |
|
|
elsif Is_Class_Wide_Type (Etype (R))
|
2507 |
|
|
and then Is_Interface (Etype (Class_Wide_Type (Etype (R))))
|
2508 |
|
|
then
|
2509 |
|
|
Error_Msg_NE ("(Ada 2005) does not implement interface }",
|
2510 |
|
|
L, Etype (Class_Wide_Type (Etype (R))));
|
2511 |
|
|
|
2512 |
|
|
else
|
2513 |
|
|
Error_Msg_N ("incompatible types", Parent (L));
|
2514 |
|
|
end if;
|
2515 |
|
|
end if;
|
2516 |
|
|
|
2517 |
|
|
return Typ;
|
2518 |
|
|
end Intersect_Types;
|
2519 |
|
|
|
2520 |
|
|
-----------------------
|
2521 |
|
|
-- In_Generic_Actual --
|
2522 |
|
|
-----------------------
|
2523 |
|
|
|
2524 |
|
|
function In_Generic_Actual (Exp : Node_Id) return Boolean is
|
2525 |
|
|
Par : constant Node_Id := Parent (Exp);
|
2526 |
|
|
|
2527 |
|
|
begin
|
2528 |
|
|
if No (Par) then
|
2529 |
|
|
return False;
|
2530 |
|
|
|
2531 |
|
|
elsif Nkind (Par) in N_Declaration then
|
2532 |
|
|
if Nkind (Par) = N_Object_Declaration then
|
2533 |
|
|
return Present (Corresponding_Generic_Association (Par));
|
2534 |
|
|
else
|
2535 |
|
|
return False;
|
2536 |
|
|
end if;
|
2537 |
|
|
|
2538 |
|
|
elsif Nkind (Par) = N_Object_Renaming_Declaration then
|
2539 |
|
|
return Present (Corresponding_Generic_Association (Par));
|
2540 |
|
|
|
2541 |
|
|
elsif Nkind (Par) in N_Statement_Other_Than_Procedure_Call then
|
2542 |
|
|
return False;
|
2543 |
|
|
|
2544 |
|
|
else
|
2545 |
|
|
return In_Generic_Actual (Parent (Par));
|
2546 |
|
|
end if;
|
2547 |
|
|
end In_Generic_Actual;
|
2548 |
|
|
|
2549 |
|
|
-----------------
|
2550 |
|
|
-- Is_Ancestor --
|
2551 |
|
|
-----------------
|
2552 |
|
|
|
2553 |
|
|
function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
|
2554 |
|
|
BT1 : Entity_Id;
|
2555 |
|
|
BT2 : Entity_Id;
|
2556 |
|
|
Par : Entity_Id;
|
2557 |
|
|
|
2558 |
|
|
begin
|
2559 |
|
|
BT1 := Base_Type (T1);
|
2560 |
|
|
BT2 := Base_Type (T2);
|
2561 |
|
|
|
2562 |
|
|
-- Handle underlying view of records with unknown discriminants
|
2563 |
|
|
-- using the original entity that motivated the construction of
|
2564 |
|
|
-- this underlying record view (see Build_Derived_Private_Type).
|
2565 |
|
|
|
2566 |
|
|
if Is_Underlying_Record_View (BT1) then
|
2567 |
|
|
BT1 := Underlying_Record_View (BT1);
|
2568 |
|
|
end if;
|
2569 |
|
|
|
2570 |
|
|
if Is_Underlying_Record_View (BT2) then
|
2571 |
|
|
BT2 := Underlying_Record_View (BT2);
|
2572 |
|
|
end if;
|
2573 |
|
|
|
2574 |
|
|
if BT1 = BT2 then
|
2575 |
|
|
return True;
|
2576 |
|
|
|
2577 |
|
|
elsif Is_Private_Type (T1)
|
2578 |
|
|
and then Present (Full_View (T1))
|
2579 |
|
|
and then BT2 = Base_Type (Full_View (T1))
|
2580 |
|
|
then
|
2581 |
|
|
return True;
|
2582 |
|
|
|
2583 |
|
|
else
|
2584 |
|
|
Par := Etype (BT2);
|
2585 |
|
|
|
2586 |
|
|
loop
|
2587 |
|
|
-- If there was a error on the type declaration, do not recurse
|
2588 |
|
|
|
2589 |
|
|
if Error_Posted (Par) then
|
2590 |
|
|
return False;
|
2591 |
|
|
|
2592 |
|
|
elsif BT1 = Base_Type (Par)
|
2593 |
|
|
or else (Is_Private_Type (T1)
|
2594 |
|
|
and then Present (Full_View (T1))
|
2595 |
|
|
and then Base_Type (Par) = Base_Type (Full_View (T1)))
|
2596 |
|
|
then
|
2597 |
|
|
return True;
|
2598 |
|
|
|
2599 |
|
|
elsif Is_Private_Type (Par)
|
2600 |
|
|
and then Present (Full_View (Par))
|
2601 |
|
|
and then Full_View (Par) = BT1
|
2602 |
|
|
then
|
2603 |
|
|
return True;
|
2604 |
|
|
|
2605 |
|
|
elsif Etype (Par) /= Par then
|
2606 |
|
|
Par := Etype (Par);
|
2607 |
|
|
else
|
2608 |
|
|
return False;
|
2609 |
|
|
end if;
|
2610 |
|
|
end loop;
|
2611 |
|
|
end if;
|
2612 |
|
|
end Is_Ancestor;
|
2613 |
|
|
|
2614 |
|
|
---------------------------
|
2615 |
|
|
-- Is_Invisible_Operator --
|
2616 |
|
|
---------------------------
|
2617 |
|
|
|
2618 |
|
|
function Is_Invisible_Operator
|
2619 |
|
|
(N : Node_Id;
|
2620 |
|
|
T : Entity_Id) return Boolean
|
2621 |
|
|
is
|
2622 |
|
|
Orig_Node : constant Node_Id := Original_Node (N);
|
2623 |
|
|
|
2624 |
|
|
begin
|
2625 |
|
|
if Nkind (N) not in N_Op then
|
2626 |
|
|
return False;
|
2627 |
|
|
|
2628 |
|
|
elsif not Comes_From_Source (N) then
|
2629 |
|
|
return False;
|
2630 |
|
|
|
2631 |
|
|
elsif No (Universal_Interpretation (Right_Opnd (N))) then
|
2632 |
|
|
return False;
|
2633 |
|
|
|
2634 |
|
|
elsif Nkind (N) in N_Binary_Op
|
2635 |
|
|
and then No (Universal_Interpretation (Left_Opnd (N)))
|
2636 |
|
|
then
|
2637 |
|
|
return False;
|
2638 |
|
|
|
2639 |
|
|
else
|
2640 |
|
|
return Is_Numeric_Type (T)
|
2641 |
|
|
and then not In_Open_Scopes (Scope (T))
|
2642 |
|
|
and then not Is_Potentially_Use_Visible (T)
|
2643 |
|
|
and then not In_Use (T)
|
2644 |
|
|
and then not In_Use (Scope (T))
|
2645 |
|
|
and then
|
2646 |
|
|
(Nkind (Orig_Node) /= N_Function_Call
|
2647 |
|
|
or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
|
2648 |
|
|
or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
|
2649 |
|
|
and then not In_Instance;
|
2650 |
|
|
end if;
|
2651 |
|
|
end Is_Invisible_Operator;
|
2652 |
|
|
|
2653 |
|
|
-------------------
|
2654 |
|
|
-- Is_Subtype_Of --
|
2655 |
|
|
-------------------
|
2656 |
|
|
|
2657 |
|
|
function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
|
2658 |
|
|
S : Entity_Id;
|
2659 |
|
|
|
2660 |
|
|
begin
|
2661 |
|
|
S := Ancestor_Subtype (T1);
|
2662 |
|
|
while Present (S) loop
|
2663 |
|
|
if S = T2 then
|
2664 |
|
|
return True;
|
2665 |
|
|
else
|
2666 |
|
|
S := Ancestor_Subtype (S);
|
2667 |
|
|
end if;
|
2668 |
|
|
end loop;
|
2669 |
|
|
|
2670 |
|
|
return False;
|
2671 |
|
|
end Is_Subtype_Of;
|
2672 |
|
|
|
2673 |
|
|
------------------
|
2674 |
|
|
-- List_Interps --
|
2675 |
|
|
------------------
|
2676 |
|
|
|
2677 |
|
|
procedure List_Interps (Nam : Node_Id; Err : Node_Id) is
|
2678 |
|
|
Index : Interp_Index;
|
2679 |
|
|
It : Interp;
|
2680 |
|
|
|
2681 |
|
|
begin
|
2682 |
|
|
Get_First_Interp (Nam, Index, It);
|
2683 |
|
|
while Present (It.Nam) loop
|
2684 |
|
|
if Scope (It.Nam) = Standard_Standard
|
2685 |
|
|
and then Scope (It.Typ) /= Standard_Standard
|
2686 |
|
|
then
|
2687 |
|
|
Error_Msg_Sloc := Sloc (Parent (It.Typ));
|
2688 |
|
|
Error_Msg_NE ("\\& (inherited) declared#!", Err, It.Nam);
|
2689 |
|
|
|
2690 |
|
|
else
|
2691 |
|
|
Error_Msg_Sloc := Sloc (It.Nam);
|
2692 |
|
|
Error_Msg_NE ("\\& declared#!", Err, It.Nam);
|
2693 |
|
|
end if;
|
2694 |
|
|
|
2695 |
|
|
Get_Next_Interp (Index, It);
|
2696 |
|
|
end loop;
|
2697 |
|
|
end List_Interps;
|
2698 |
|
|
|
2699 |
|
|
-----------------
|
2700 |
|
|
-- New_Interps --
|
2701 |
|
|
-----------------
|
2702 |
|
|
|
2703 |
|
|
procedure New_Interps (N : Node_Id) is
|
2704 |
|
|
Map_Ptr : Int;
|
2705 |
|
|
|
2706 |
|
|
begin
|
2707 |
|
|
All_Interp.Append (No_Interp);
|
2708 |
|
|
|
2709 |
|
|
Map_Ptr := Headers (Hash (N));
|
2710 |
|
|
|
2711 |
|
|
if Map_Ptr = No_Entry then
|
2712 |
|
|
|
2713 |
|
|
-- Place new node at end of table
|
2714 |
|
|
|
2715 |
|
|
Interp_Map.Increment_Last;
|
2716 |
|
|
Headers (Hash (N)) := Interp_Map.Last;
|
2717 |
|
|
|
2718 |
|
|
else
|
2719 |
|
|
-- Place node at end of chain, or locate its previous entry
|
2720 |
|
|
|
2721 |
|
|
loop
|
2722 |
|
|
if Interp_Map.Table (Map_Ptr).Node = N then
|
2723 |
|
|
|
2724 |
|
|
-- Node is already in the table, and is being rewritten.
|
2725 |
|
|
-- Start a new interp section, retain hash link.
|
2726 |
|
|
|
2727 |
|
|
Interp_Map.Table (Map_Ptr).Node := N;
|
2728 |
|
|
Interp_Map.Table (Map_Ptr).Index := All_Interp.Last;
|
2729 |
|
|
Set_Is_Overloaded (N, True);
|
2730 |
|
|
return;
|
2731 |
|
|
|
2732 |
|
|
else
|
2733 |
|
|
exit when Interp_Map.Table (Map_Ptr).Next = No_Entry;
|
2734 |
|
|
Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
|
2735 |
|
|
end if;
|
2736 |
|
|
end loop;
|
2737 |
|
|
|
2738 |
|
|
-- Chain the new node
|
2739 |
|
|
|
2740 |
|
|
Interp_Map.Increment_Last;
|
2741 |
|
|
Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last;
|
2742 |
|
|
end if;
|
2743 |
|
|
|
2744 |
|
|
Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry);
|
2745 |
|
|
Set_Is_Overloaded (N, True);
|
2746 |
|
|
end New_Interps;
|
2747 |
|
|
|
2748 |
|
|
---------------------------
|
2749 |
|
|
-- Operator_Matches_Spec --
|
2750 |
|
|
---------------------------
|
2751 |
|
|
|
2752 |
|
|
function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
|
2753 |
|
|
Op_Name : constant Name_Id := Chars (Op);
|
2754 |
|
|
T : constant Entity_Id := Etype (New_S);
|
2755 |
|
|
New_F : Entity_Id;
|
2756 |
|
|
Old_F : Entity_Id;
|
2757 |
|
|
Num : Int;
|
2758 |
|
|
T1 : Entity_Id;
|
2759 |
|
|
T2 : Entity_Id;
|
2760 |
|
|
|
2761 |
|
|
begin
|
2762 |
|
|
-- To verify that a predefined operator matches a given signature,
|
2763 |
|
|
-- do a case analysis of the operator classes. Function can have one
|
2764 |
|
|
-- or two formals and must have the proper result type.
|
2765 |
|
|
|
2766 |
|
|
New_F := First_Formal (New_S);
|
2767 |
|
|
Old_F := First_Formal (Op);
|
2768 |
|
|
Num := 0;
|
2769 |
|
|
while Present (New_F) and then Present (Old_F) loop
|
2770 |
|
|
Num := Num + 1;
|
2771 |
|
|
Next_Formal (New_F);
|
2772 |
|
|
Next_Formal (Old_F);
|
2773 |
|
|
end loop;
|
2774 |
|
|
|
2775 |
|
|
-- Definite mismatch if different number of parameters
|
2776 |
|
|
|
2777 |
|
|
if Present (Old_F) or else Present (New_F) then
|
2778 |
|
|
return False;
|
2779 |
|
|
|
2780 |
|
|
-- Unary operators
|
2781 |
|
|
|
2782 |
|
|
elsif Num = 1 then
|
2783 |
|
|
T1 := Etype (First_Formal (New_S));
|
2784 |
|
|
|
2785 |
|
|
if Op_Name = Name_Op_Subtract
|
2786 |
|
|
or else Op_Name = Name_Op_Add
|
2787 |
|
|
or else Op_Name = Name_Op_Abs
|
2788 |
|
|
then
|
2789 |
|
|
return Base_Type (T1) = Base_Type (T)
|
2790 |
|
|
and then Is_Numeric_Type (T);
|
2791 |
|
|
|
2792 |
|
|
elsif Op_Name = Name_Op_Not then
|
2793 |
|
|
return Base_Type (T1) = Base_Type (T)
|
2794 |
|
|
and then Valid_Boolean_Arg (Base_Type (T));
|
2795 |
|
|
|
2796 |
|
|
else
|
2797 |
|
|
return False;
|
2798 |
|
|
end if;
|
2799 |
|
|
|
2800 |
|
|
-- Binary operators
|
2801 |
|
|
|
2802 |
|
|
else
|
2803 |
|
|
T1 := Etype (First_Formal (New_S));
|
2804 |
|
|
T2 := Etype (Next_Formal (First_Formal (New_S)));
|
2805 |
|
|
|
2806 |
|
|
if Op_Name = Name_Op_And or else Op_Name = Name_Op_Or
|
2807 |
|
|
or else Op_Name = Name_Op_Xor
|
2808 |
|
|
then
|
2809 |
|
|
return Base_Type (T1) = Base_Type (T2)
|
2810 |
|
|
and then Base_Type (T1) = Base_Type (T)
|
2811 |
|
|
and then Valid_Boolean_Arg (Base_Type (T));
|
2812 |
|
|
|
2813 |
|
|
elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then
|
2814 |
|
|
return Base_Type (T1) = Base_Type (T2)
|
2815 |
|
|
and then not Is_Limited_Type (T1)
|
2816 |
|
|
and then Is_Boolean_Type (T);
|
2817 |
|
|
|
2818 |
|
|
elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le
|
2819 |
|
|
or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge
|
2820 |
|
|
then
|
2821 |
|
|
return Base_Type (T1) = Base_Type (T2)
|
2822 |
|
|
and then Valid_Comparison_Arg (T1)
|
2823 |
|
|
and then Is_Boolean_Type (T);
|
2824 |
|
|
|
2825 |
|
|
elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
|
2826 |
|
|
return Base_Type (T1) = Base_Type (T2)
|
2827 |
|
|
and then Base_Type (T1) = Base_Type (T)
|
2828 |
|
|
and then Is_Numeric_Type (T);
|
2829 |
|
|
|
2830 |
|
|
-- For division and multiplication, a user-defined function does not
|
2831 |
|
|
-- match the predefined universal_fixed operation, except in Ada 83.
|
2832 |
|
|
|
2833 |
|
|
elsif Op_Name = Name_Op_Divide then
|
2834 |
|
|
return (Base_Type (T1) = Base_Type (T2)
|
2835 |
|
|
and then Base_Type (T1) = Base_Type (T)
|
2836 |
|
|
and then Is_Numeric_Type (T)
|
2837 |
|
|
and then (not Is_Fixed_Point_Type (T)
|
2838 |
|
|
or else Ada_Version = Ada_83))
|
2839 |
|
|
|
2840 |
|
|
-- Mixed_Mode operations on fixed-point types
|
2841 |
|
|
|
2842 |
|
|
or else (Base_Type (T1) = Base_Type (T)
|
2843 |
|
|
and then Base_Type (T2) = Base_Type (Standard_Integer)
|
2844 |
|
|
and then Is_Fixed_Point_Type (T))
|
2845 |
|
|
|
2846 |
|
|
-- A user defined operator can also match (and hide) a mixed
|
2847 |
|
|
-- operation on universal literals.
|
2848 |
|
|
|
2849 |
|
|
or else (Is_Integer_Type (T2)
|
2850 |
|
|
and then Is_Floating_Point_Type (T1)
|
2851 |
|
|
and then Base_Type (T1) = Base_Type (T));
|
2852 |
|
|
|
2853 |
|
|
elsif Op_Name = Name_Op_Multiply then
|
2854 |
|
|
return (Base_Type (T1) = Base_Type (T2)
|
2855 |
|
|
and then Base_Type (T1) = Base_Type (T)
|
2856 |
|
|
and then Is_Numeric_Type (T)
|
2857 |
|
|
and then (not Is_Fixed_Point_Type (T)
|
2858 |
|
|
or else Ada_Version = Ada_83))
|
2859 |
|
|
|
2860 |
|
|
-- Mixed_Mode operations on fixed-point types
|
2861 |
|
|
|
2862 |
|
|
or else (Base_Type (T1) = Base_Type (T)
|
2863 |
|
|
and then Base_Type (T2) = Base_Type (Standard_Integer)
|
2864 |
|
|
and then Is_Fixed_Point_Type (T))
|
2865 |
|
|
|
2866 |
|
|
or else (Base_Type (T2) = Base_Type (T)
|
2867 |
|
|
and then Base_Type (T1) = Base_Type (Standard_Integer)
|
2868 |
|
|
and then Is_Fixed_Point_Type (T))
|
2869 |
|
|
|
2870 |
|
|
or else (Is_Integer_Type (T2)
|
2871 |
|
|
and then Is_Floating_Point_Type (T1)
|
2872 |
|
|
and then Base_Type (T1) = Base_Type (T))
|
2873 |
|
|
|
2874 |
|
|
or else (Is_Integer_Type (T1)
|
2875 |
|
|
and then Is_Floating_Point_Type (T2)
|
2876 |
|
|
and then Base_Type (T2) = Base_Type (T));
|
2877 |
|
|
|
2878 |
|
|
elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
|
2879 |
|
|
return Base_Type (T1) = Base_Type (T2)
|
2880 |
|
|
and then Base_Type (T1) = Base_Type (T)
|
2881 |
|
|
and then Is_Integer_Type (T);
|
2882 |
|
|
|
2883 |
|
|
elsif Op_Name = Name_Op_Expon then
|
2884 |
|
|
return Base_Type (T1) = Base_Type (T)
|
2885 |
|
|
and then Is_Numeric_Type (T)
|
2886 |
|
|
and then Base_Type (T2) = Base_Type (Standard_Integer);
|
2887 |
|
|
|
2888 |
|
|
elsif Op_Name = Name_Op_Concat then
|
2889 |
|
|
return Is_Array_Type (T)
|
2890 |
|
|
and then (Base_Type (T) = Base_Type (Etype (Op)))
|
2891 |
|
|
and then (Base_Type (T1) = Base_Type (T)
|
2892 |
|
|
or else
|
2893 |
|
|
Base_Type (T1) = Base_Type (Component_Type (T)))
|
2894 |
|
|
and then (Base_Type (T2) = Base_Type (T)
|
2895 |
|
|
or else
|
2896 |
|
|
Base_Type (T2) = Base_Type (Component_Type (T)));
|
2897 |
|
|
|
2898 |
|
|
else
|
2899 |
|
|
return False;
|
2900 |
|
|
end if;
|
2901 |
|
|
end if;
|
2902 |
|
|
end Operator_Matches_Spec;
|
2903 |
|
|
|
2904 |
|
|
-------------------
|
2905 |
|
|
-- Remove_Interp --
|
2906 |
|
|
-------------------
|
2907 |
|
|
|
2908 |
|
|
procedure Remove_Interp (I : in out Interp_Index) is
|
2909 |
|
|
II : Interp_Index;
|
2910 |
|
|
|
2911 |
|
|
begin
|
2912 |
|
|
-- Find end of interp list and copy downward to erase the discarded one
|
2913 |
|
|
|
2914 |
|
|
II := I + 1;
|
2915 |
|
|
while Present (All_Interp.Table (II).Typ) loop
|
2916 |
|
|
II := II + 1;
|
2917 |
|
|
end loop;
|
2918 |
|
|
|
2919 |
|
|
for J in I + 1 .. II loop
|
2920 |
|
|
All_Interp.Table (J - 1) := All_Interp.Table (J);
|
2921 |
|
|
end loop;
|
2922 |
|
|
|
2923 |
|
|
-- Back up interp index to insure that iterator will pick up next
|
2924 |
|
|
-- available interpretation.
|
2925 |
|
|
|
2926 |
|
|
I := I - 1;
|
2927 |
|
|
end Remove_Interp;
|
2928 |
|
|
|
2929 |
|
|
------------------
|
2930 |
|
|
-- Save_Interps --
|
2931 |
|
|
------------------
|
2932 |
|
|
|
2933 |
|
|
procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
|
2934 |
|
|
Map_Ptr : Int;
|
2935 |
|
|
O_N : Node_Id := Old_N;
|
2936 |
|
|
|
2937 |
|
|
begin
|
2938 |
|
|
if Is_Overloaded (Old_N) then
|
2939 |
|
|
if Nkind (Old_N) = N_Selected_Component
|
2940 |
|
|
and then Is_Overloaded (Selector_Name (Old_N))
|
2941 |
|
|
then
|
2942 |
|
|
O_N := Selector_Name (Old_N);
|
2943 |
|
|
end if;
|
2944 |
|
|
|
2945 |
|
|
Map_Ptr := Headers (Hash (O_N));
|
2946 |
|
|
|
2947 |
|
|
while Interp_Map.Table (Map_Ptr).Node /= O_N loop
|
2948 |
|
|
Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
|
2949 |
|
|
pragma Assert (Map_Ptr /= No_Entry);
|
2950 |
|
|
end loop;
|
2951 |
|
|
|
2952 |
|
|
New_Interps (New_N);
|
2953 |
|
|
Interp_Map.Table (Interp_Map.Last).Index :=
|
2954 |
|
|
Interp_Map.Table (Map_Ptr).Index;
|
2955 |
|
|
end if;
|
2956 |
|
|
end Save_Interps;
|
2957 |
|
|
|
2958 |
|
|
-------------------
|
2959 |
|
|
-- Specific_Type --
|
2960 |
|
|
-------------------
|
2961 |
|
|
|
2962 |
|
|
function Specific_Type (Typ_1, Typ_2 : Entity_Id) return Entity_Id is
|
2963 |
|
|
T1 : constant Entity_Id := Available_View (Typ_1);
|
2964 |
|
|
T2 : constant Entity_Id := Available_View (Typ_2);
|
2965 |
|
|
B1 : constant Entity_Id := Base_Type (T1);
|
2966 |
|
|
B2 : constant Entity_Id := Base_Type (T2);
|
2967 |
|
|
|
2968 |
|
|
function Is_Remote_Access (T : Entity_Id) return Boolean;
|
2969 |
|
|
-- Check whether T is the equivalent type of a remote access type.
|
2970 |
|
|
-- If distribution is enabled, T is a legal context for Null.
|
2971 |
|
|
|
2972 |
|
|
----------------------
|
2973 |
|
|
-- Is_Remote_Access --
|
2974 |
|
|
----------------------
|
2975 |
|
|
|
2976 |
|
|
function Is_Remote_Access (T : Entity_Id) return Boolean is
|
2977 |
|
|
begin
|
2978 |
|
|
return Is_Record_Type (T)
|
2979 |
|
|
and then (Is_Remote_Call_Interface (T)
|
2980 |
|
|
or else Is_Remote_Types (T))
|
2981 |
|
|
and then Present (Corresponding_Remote_Type (T))
|
2982 |
|
|
and then Is_Access_Type (Corresponding_Remote_Type (T));
|
2983 |
|
|
end Is_Remote_Access;
|
2984 |
|
|
|
2985 |
|
|
-- Start of processing for Specific_Type
|
2986 |
|
|
|
2987 |
|
|
begin
|
2988 |
|
|
if T1 = Any_Type or else T2 = Any_Type then
|
2989 |
|
|
return Any_Type;
|
2990 |
|
|
end if;
|
2991 |
|
|
|
2992 |
|
|
if B1 = B2 then
|
2993 |
|
|
return B1;
|
2994 |
|
|
|
2995 |
|
|
elsif (T1 = Universal_Integer and then Is_Integer_Type (T2))
|
2996 |
|
|
or else (T1 = Universal_Real and then Is_Real_Type (T2))
|
2997 |
|
|
or else (T1 = Universal_Fixed and then Is_Fixed_Point_Type (T2))
|
2998 |
|
|
or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
|
2999 |
|
|
then
|
3000 |
|
|
return B2;
|
3001 |
|
|
|
3002 |
|
|
elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
|
3003 |
|
|
or else (T2 = Universal_Real and then Is_Real_Type (T1))
|
3004 |
|
|
or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
|
3005 |
|
|
or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
|
3006 |
|
|
then
|
3007 |
|
|
return B1;
|
3008 |
|
|
|
3009 |
|
|
elsif T2 = Any_String and then Is_String_Type (T1) then
|
3010 |
|
|
return B1;
|
3011 |
|
|
|
3012 |
|
|
elsif T1 = Any_String and then Is_String_Type (T2) then
|
3013 |
|
|
return B2;
|
3014 |
|
|
|
3015 |
|
|
elsif T2 = Any_Character and then Is_Character_Type (T1) then
|
3016 |
|
|
return B1;
|
3017 |
|
|
|
3018 |
|
|
elsif T1 = Any_Character and then Is_Character_Type (T2) then
|
3019 |
|
|
return B2;
|
3020 |
|
|
|
3021 |
|
|
elsif T1 = Any_Access
|
3022 |
|
|
and then (Is_Access_Type (T2) or else Is_Remote_Access (T2))
|
3023 |
|
|
then
|
3024 |
|
|
return T2;
|
3025 |
|
|
|
3026 |
|
|
elsif T2 = Any_Access
|
3027 |
|
|
and then (Is_Access_Type (T1) or else Is_Remote_Access (T1))
|
3028 |
|
|
then
|
3029 |
|
|
return T1;
|
3030 |
|
|
|
3031 |
|
|
elsif T2 = Any_Composite
|
3032 |
|
|
and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
|
3033 |
|
|
then
|
3034 |
|
|
return T1;
|
3035 |
|
|
|
3036 |
|
|
elsif T1 = Any_Composite
|
3037 |
|
|
and then Ekind (T2) in E_Array_Type .. E_Record_Subtype
|
3038 |
|
|
then
|
3039 |
|
|
return T2;
|
3040 |
|
|
|
3041 |
|
|
elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then
|
3042 |
|
|
return T2;
|
3043 |
|
|
|
3044 |
|
|
elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
|
3045 |
|
|
return T1;
|
3046 |
|
|
|
3047 |
|
|
-- ----------------------------------------------------------
|
3048 |
|
|
-- Special cases for equality operators (all other predefined
|
3049 |
|
|
-- operators can never apply to tagged types)
|
3050 |
|
|
-- ----------------------------------------------------------
|
3051 |
|
|
|
3052 |
|
|
-- Ada 2005 (AI-251): T1 and T2 are class-wide types, and T2 is an
|
3053 |
|
|
-- interface
|
3054 |
|
|
|
3055 |
|
|
elsif Is_Class_Wide_Type (T1)
|
3056 |
|
|
and then Is_Class_Wide_Type (T2)
|
3057 |
|
|
and then Is_Interface (Etype (T2))
|
3058 |
|
|
then
|
3059 |
|
|
return T1;
|
3060 |
|
|
|
3061 |
|
|
-- Ada 2005 (AI-251): T1 is a concrete type that implements the
|
3062 |
|
|
-- class-wide interface T2
|
3063 |
|
|
|
3064 |
|
|
elsif Is_Class_Wide_Type (T2)
|
3065 |
|
|
and then Is_Interface (Etype (T2))
|
3066 |
|
|
and then Interface_Present_In_Ancestor (Typ => T1,
|
3067 |
|
|
Iface => Etype (T2))
|
3068 |
|
|
then
|
3069 |
|
|
return T1;
|
3070 |
|
|
|
3071 |
|
|
elsif Is_Class_Wide_Type (T1)
|
3072 |
|
|
and then Is_Ancestor (Root_Type (T1), T2)
|
3073 |
|
|
then
|
3074 |
|
|
return T1;
|
3075 |
|
|
|
3076 |
|
|
elsif Is_Class_Wide_Type (T2)
|
3077 |
|
|
and then Is_Ancestor (Root_Type (T2), T1)
|
3078 |
|
|
then
|
3079 |
|
|
return T2;
|
3080 |
|
|
|
3081 |
|
|
elsif (Ekind (B1) = E_Access_Subprogram_Type
|
3082 |
|
|
or else
|
3083 |
|
|
Ekind (B1) = E_Access_Protected_Subprogram_Type)
|
3084 |
|
|
and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
|
3085 |
|
|
and then Is_Access_Type (T2)
|
3086 |
|
|
then
|
3087 |
|
|
return T2;
|
3088 |
|
|
|
3089 |
|
|
elsif (Ekind (B2) = E_Access_Subprogram_Type
|
3090 |
|
|
or else
|
3091 |
|
|
Ekind (B2) = E_Access_Protected_Subprogram_Type)
|
3092 |
|
|
and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
|
3093 |
|
|
and then Is_Access_Type (T1)
|
3094 |
|
|
then
|
3095 |
|
|
return T1;
|
3096 |
|
|
|
3097 |
|
|
elsif (Ekind (T1) = E_Allocator_Type
|
3098 |
|
|
or else Ekind (T1) = E_Access_Attribute_Type
|
3099 |
|
|
or else Ekind (T1) = E_Anonymous_Access_Type)
|
3100 |
|
|
and then Is_Access_Type (T2)
|
3101 |
|
|
then
|
3102 |
|
|
return T2;
|
3103 |
|
|
|
3104 |
|
|
elsif (Ekind (T2) = E_Allocator_Type
|
3105 |
|
|
or else Ekind (T2) = E_Access_Attribute_Type
|
3106 |
|
|
or else Ekind (T2) = E_Anonymous_Access_Type)
|
3107 |
|
|
and then Is_Access_Type (T1)
|
3108 |
|
|
then
|
3109 |
|
|
return T1;
|
3110 |
|
|
|
3111 |
|
|
-- If none of the above cases applies, types are not compatible
|
3112 |
|
|
|
3113 |
|
|
else
|
3114 |
|
|
return Any_Type;
|
3115 |
|
|
end if;
|
3116 |
|
|
end Specific_Type;
|
3117 |
|
|
|
3118 |
|
|
---------------------
|
3119 |
|
|
-- Set_Abstract_Op --
|
3120 |
|
|
---------------------
|
3121 |
|
|
|
3122 |
|
|
procedure Set_Abstract_Op (I : Interp_Index; V : Entity_Id) is
|
3123 |
|
|
begin
|
3124 |
|
|
All_Interp.Table (I).Abstract_Op := V;
|
3125 |
|
|
end Set_Abstract_Op;
|
3126 |
|
|
|
3127 |
|
|
-----------------------
|
3128 |
|
|
-- Valid_Boolean_Arg --
|
3129 |
|
|
-----------------------
|
3130 |
|
|
|
3131 |
|
|
-- In addition to booleans and arrays of booleans, we must include
|
3132 |
|
|
-- aggregates as valid boolean arguments, because in the first pass of
|
3133 |
|
|
-- resolution their components are not examined. If it turns out not to be
|
3134 |
|
|
-- an aggregate of booleans, this will be diagnosed in Resolve.
|
3135 |
|
|
-- Any_Composite must be checked for prior to the array type checks because
|
3136 |
|
|
-- Any_Composite does not have any associated indexes.
|
3137 |
|
|
|
3138 |
|
|
function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
|
3139 |
|
|
begin
|
3140 |
|
|
return Is_Boolean_Type (T)
|
3141 |
|
|
or else T = Any_Composite
|
3142 |
|
|
or else (Is_Array_Type (T)
|
3143 |
|
|
and then T /= Any_String
|
3144 |
|
|
and then Number_Dimensions (T) = 1
|
3145 |
|
|
and then Is_Boolean_Type (Component_Type (T))
|
3146 |
|
|
and then (not Is_Private_Composite (T)
|
3147 |
|
|
or else In_Instance)
|
3148 |
|
|
and then (not Is_Limited_Composite (T)
|
3149 |
|
|
or else In_Instance))
|
3150 |
|
|
or else Is_Modular_Integer_Type (T)
|
3151 |
|
|
or else T = Universal_Integer;
|
3152 |
|
|
end Valid_Boolean_Arg;
|
3153 |
|
|
|
3154 |
|
|
--------------------------
|
3155 |
|
|
-- Valid_Comparison_Arg --
|
3156 |
|
|
--------------------------
|
3157 |
|
|
|
3158 |
|
|
function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
|
3159 |
|
|
begin
|
3160 |
|
|
|
3161 |
|
|
if T = Any_Composite then
|
3162 |
|
|
return False;
|
3163 |
|
|
elsif Is_Discrete_Type (T)
|
3164 |
|
|
or else Is_Real_Type (T)
|
3165 |
|
|
then
|
3166 |
|
|
return True;
|
3167 |
|
|
elsif Is_Array_Type (T)
|
3168 |
|
|
and then Number_Dimensions (T) = 1
|
3169 |
|
|
and then Is_Discrete_Type (Component_Type (T))
|
3170 |
|
|
and then (not Is_Private_Composite (T)
|
3171 |
|
|
or else In_Instance)
|
3172 |
|
|
and then (not Is_Limited_Composite (T)
|
3173 |
|
|
or else In_Instance)
|
3174 |
|
|
then
|
3175 |
|
|
return True;
|
3176 |
|
|
elsif Is_String_Type (T) then
|
3177 |
|
|
return True;
|
3178 |
|
|
else
|
3179 |
|
|
return False;
|
3180 |
|
|
end if;
|
3181 |
|
|
end Valid_Comparison_Arg;
|
3182 |
|
|
|
3183 |
|
|
----------------------
|
3184 |
|
|
-- Write_Interp_Ref --
|
3185 |
|
|
----------------------
|
3186 |
|
|
|
3187 |
|
|
procedure Write_Interp_Ref (Map_Ptr : Int) is
|
3188 |
|
|
begin
|
3189 |
|
|
Write_Str (" Node: ");
|
3190 |
|
|
Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
|
3191 |
|
|
Write_Str (" Index: ");
|
3192 |
|
|
Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
|
3193 |
|
|
Write_Str (" Next: ");
|
3194 |
|
|
Write_Int (Int (Interp_Map.Table (Map_Ptr).Next));
|
3195 |
|
|
Write_Eol;
|
3196 |
|
|
end Write_Interp_Ref;
|
3197 |
|
|
|
3198 |
|
|
---------------------
|
3199 |
|
|
-- Write_Overloads --
|
3200 |
|
|
---------------------
|
3201 |
|
|
|
3202 |
|
|
procedure Write_Overloads (N : Node_Id) is
|
3203 |
|
|
I : Interp_Index;
|
3204 |
|
|
It : Interp;
|
3205 |
|
|
Nam : Entity_Id;
|
3206 |
|
|
|
3207 |
|
|
begin
|
3208 |
|
|
if not Is_Overloaded (N) then
|
3209 |
|
|
Write_Str ("Non-overloaded entity ");
|
3210 |
|
|
Write_Eol;
|
3211 |
|
|
Write_Entity_Info (Entity (N), " ");
|
3212 |
|
|
|
3213 |
|
|
else
|
3214 |
|
|
Get_First_Interp (N, I, It);
|
3215 |
|
|
Write_Str ("Overloaded entity ");
|
3216 |
|
|
Write_Eol;
|
3217 |
|
|
Write_Str (" Name Type Abstract Op");
|
3218 |
|
|
Write_Eol;
|
3219 |
|
|
Write_Str ("===============================================");
|
3220 |
|
|
Write_Eol;
|
3221 |
|
|
Nam := It.Nam;
|
3222 |
|
|
|
3223 |
|
|
while Present (Nam) loop
|
3224 |
|
|
Write_Int (Int (Nam));
|
3225 |
|
|
Write_Str (" ");
|
3226 |
|
|
Write_Name (Chars (Nam));
|
3227 |
|
|
Write_Str (" ");
|
3228 |
|
|
Write_Int (Int (It.Typ));
|
3229 |
|
|
Write_Str (" ");
|
3230 |
|
|
Write_Name (Chars (It.Typ));
|
3231 |
|
|
|
3232 |
|
|
if Present (It.Abstract_Op) then
|
3233 |
|
|
Write_Str (" ");
|
3234 |
|
|
Write_Int (Int (It.Abstract_Op));
|
3235 |
|
|
Write_Str (" ");
|
3236 |
|
|
Write_Name (Chars (It.Abstract_Op));
|
3237 |
|
|
end if;
|
3238 |
|
|
|
3239 |
|
|
Write_Eol;
|
3240 |
|
|
Get_Next_Interp (I, It);
|
3241 |
|
|
Nam := It.Nam;
|
3242 |
|
|
end loop;
|
3243 |
|
|
end if;
|
3244 |
|
|
end Write_Overloads;
|
3245 |
|
|
|
3246 |
|
|
end Sem_Type;
|