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