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