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