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