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