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