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