?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Fix thinko
[official-gcc.git] / gcc / ada / sem_type.adb
blob8666ae706ee40899fe8e4b7a43cff074e034aaed
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-2001 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
26
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Errout; use Errout;
31 with Lib; use Lib;
32 with Opt; use Opt;
33 with Output; use Output;
34 with Sem; use Sem;
35 with Sem_Ch6; use Sem_Ch6;
36 with Sem_Ch8; use Sem_Ch8;
37 with Sem_Util; use Sem_Util;
38 with Stand; use Stand;
39 with Sinfo; use Sinfo;
40 with Snames; use Snames;
41 with Uintp; use Uintp;
42
43 package body Sem_Type is
44
45 -------------------------------------
46 -- Handling of Overload Resolution --
47 -------------------------------------
48
49 -- Overload resolution uses two passes over the syntax tree of a complete
50 -- context. In the first, bottom-up pass, the types of actuals in calls
51 -- are used to resolve possibly overloaded subprogram and operator names.
52 -- In the second top-down pass, the type of the context (for example the
53 -- condition in a while statement) is used to resolve a possibly ambiguous
54 -- call, and the unique subprogram name in turn imposes a specific context
55 -- on each of its actuals.
56
57 -- Most expressions are in fact unambiguous, and the bottom-up pass is
58 -- sufficient to resolve most everything. To simplify the common case,
59 -- names and expressions carry a flag Is_Overloaded to indicate whether
60 -- they have more than one interpretation. If the flag is off, then each
61 -- name has already a unique meaning and type, and the bottom-up pass is
62 -- sufficient (and much simpler).
63
64 --------------------------
65 -- Operator Overloading --
66 --------------------------
67
68 -- The visibility of operators is handled differently from that of
69 -- other entities. We do not introduce explicit versions of primitive
70 -- operators for each type definition. As a result, there is only one
71 -- entity corresponding to predefined addition on all numeric types, etc.
72 -- The back-end resolves predefined operators according to their type.
73 -- The visibility of primitive operations then reduces to the visibility
74 -- of the resulting type: (a + b) is a legal interpretation of some
75 -- primitive operator + if the type of the result (which must also be
76 -- the type of a and b) is directly visible (i.e. either immediately
77 -- visible or use-visible.)
78
79 -- User-defined operators are treated like other functions, but the
80 -- visibility of these user-defined operations must be special-cased
81 -- to determine whether they hide or are hidden by predefined operators.
82 -- The form P."+" (x, y) requires additional handling.
83 --
84 -- Concatenation is treated more conventionally: for every one-dimensional
85 -- array type we introduce a explicit concatenation operator. This is
86 -- necessary to handle the case of (element & element => array) which
87 -- cannot be handled conveniently if there is no explicit instance of
88 -- resulting type of the operation.
89
90 -----------------------
91 -- Local Subprograms --
92 -----------------------
93
94 procedure All_Overloads;
95 pragma Warnings (Off, All_Overloads);
96 -- Debugging procedure: list full contents of Overloads table.
97
98 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id;
99 -- Yields universal_Integer or Universal_Real if this is a candidate.
100
101 function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
102 -- If T1 and T2 are compatible, return the one that is not
103 -- universal or is not a "class" type (any_character, etc).
104
105 --------------------
106 -- Add_One_Interp --
107 --------------------
108
109 procedure Add_One_Interp
110 (N : Node_Id;
111 E : Entity_Id;
112 T : Entity_Id;
113 Opnd_Type : Entity_Id := Empty)
114 is
115 Vis_Type : Entity_Id;
116
117 procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id);
118 -- Add one interpretation to node. Node is already known to be
119 -- overloaded. Add new interpretation if not hidden by previous
120 -- one, and remove previous one if hidden by new one.
121
122 function Is_Universal_Operation (Op : Entity_Id) return Boolean;
123 -- True if the entity is a predefined operator and the operands have
124 -- a universal Interpretation.
125
126 ---------------
127 -- Add_Entry --
128 ---------------
129
130 procedure Add_Entry (Name : Entity_Id; Typ : Entity_Id) is
131 Index : Interp_Index;
132 It : Interp;
133
134 begin
135 Get_First_Interp (N, Index, It);
136
137 while Present (It.Nam) loop
138
139 -- A user-defined subprogram hides another declared at an outer
140 -- level, or one that is use-visible. So return if previous
141 -- definition hides new one (which is either in an outer
142 -- scope, or use-visible). Note that for functions use-visible
143 -- is the same as potentially use-visible. If new one hides
144 -- previous one, replace entry in table of interpretations.
145 -- If this is a universal operation, retain the operator in case
146 -- preference rule applies.
147
148 if (((Ekind (Name) = E_Function or else Ekind (Name) = E_Procedure)
149 and then Ekind (Name) = Ekind (It.Nam))
150 or else (Ekind (Name) = E_Operator
151 and then Ekind (It.Nam) = E_Function))
152
153 and then Is_Immediately_Visible (It.Nam)
154 and then Type_Conformant (Name, It.Nam)
155 and then Base_Type (It.Typ) = Base_Type (T)
156 then
157 if Is_Universal_Operation (Name) then
158 exit;
159
160 -- If node is an operator symbol, we have no actuals with
161 -- which to check hiding, and this is done in full in the
162 -- caller (Analyze_Subprogram_Renaming) so we include the
163 -- predefined operator in any case.
164
165 elsif Nkind (N) = N_Operator_Symbol
166 or else (Nkind (N) = N_Expanded_Name
167 and then
168 Nkind (Selector_Name (N)) = N_Operator_Symbol)
169 then
170 exit;
171
172 elsif not In_Open_Scopes (Scope (Name))
173 or else Scope_Depth (Scope (Name))
174 <= Scope_Depth (Scope (It.Nam))
175 then
176 -- If ambiguity within instance, and entity is not an
177 -- implicit operation, save for later disambiguation.
178
179 if Scope (Name) = Scope (It.Nam)
180 and then not Is_Inherited_Operation (Name)
181 and then In_Instance
182 then
183 exit;
184 else
185 return;
186 end if;
187
188 else
189 All_Interp.Table (Index).Nam := Name;
190 return;
191 end if;
192
193 -- Avoid making duplicate entries in overloads
194
195 elsif Name = It.Nam
196 and then Base_Type (It.Typ) = Base_Type (T)
197 then
198 return;
199
200 -- Otherwise keep going
201
202 else
203 Get_Next_Interp (Index, It);
204 end if;
205
206 end loop;
207
208 -- On exit, enter new interpretation. The context, or a preference
209 -- rule, will resolve the ambiguity on the second pass.
210
211 All_Interp.Table (All_Interp.Last) := (Name, Typ);
212 All_Interp.Increment_Last;
213 All_Interp.Table (All_Interp.Last) := No_Interp;
214
215 end Add_Entry;
216
217 ----------------------------
218 -- Is_Universal_Operation --
219 ----------------------------
220
221 function Is_Universal_Operation (Op : Entity_Id) return Boolean is
222 Arg : Node_Id;
223
224 begin
225 if Ekind (Op) /= E_Operator then
226 return False;
227
228 elsif Nkind (N) in N_Binary_Op then
229 return Present (Universal_Interpretation (Left_Opnd (N)))
230 and then Present (Universal_Interpretation (Right_Opnd (N)));
231
232 elsif Nkind (N) in N_Unary_Op then
233 return Present (Universal_Interpretation (Right_Opnd (N)));
234
235 elsif Nkind (N) = N_Function_Call then
236 Arg := First_Actual (N);
237
238 while Present (Arg) loop
239
240 if No (Universal_Interpretation (Arg)) then
241 return False;
242 end if;
243
244 Next_Actual (Arg);
245 end loop;
246
247 return True;
248
249 else
250 return False;
251 end if;
252 end Is_Universal_Operation;
253
254 -- Start of processing for Add_One_Interp
255
256 begin
257 -- If the interpretation is a predefined operator, verify that the
258 -- result type is visible, or that the entity has already been
259 -- resolved (case of an instantiation node that refers to a predefined
260 -- operation, or an internally generated operator node, or an operator
261 -- given as an expanded name). If the operator is a comparison or
262 -- equality, it is the type of the operand that matters to determine
263 -- whether the operator is visible. In an instance, the check is not
264 -- performed, given that the operator was visible in the generic.
265
266 if Ekind (E) = E_Operator then
267
268 if Present (Opnd_Type) then
269 Vis_Type := Opnd_Type;
270 else
271 Vis_Type := Base_Type (T);
272 end if;
273
274 if In_Open_Scopes (Scope (Vis_Type))
275 or else Is_Potentially_Use_Visible (Vis_Type)
276 or else In_Use (Vis_Type)
277 or else (In_Use (Scope (Vis_Type))
278 and then not Is_Hidden (Vis_Type))
279 or else Nkind (N) = N_Expanded_Name
280 or else (Nkind (N) in N_Op and then E = Entity (N))
281 or else In_Instance
282 then
283 null;
284
285 -- If the node is given in functional notation and the prefix
286 -- is an expanded name, then the operator is visible if the
287 -- prefix is the scope of the result type as well. If the
288 -- operator is (implicitly) defined in an extension of system,
289 -- it is know to be valid (see Defined_In_Scope, sem_ch4.adb).
290
291 elsif Nkind (N) = N_Function_Call
292 and then Nkind (Name (N)) = N_Expanded_Name
293 and then (Entity (Prefix (Name (N))) = Scope (Base_Type (T))
294 or else Entity (Prefix (Name (N))) = Scope (Vis_Type)
295 or else Scope (Vis_Type) = System_Aux_Id)
296 then
297 null;
298
299 -- Save type for subsequent error message, in case no other
300 -- interpretation is found.
301
302 else
303 Candidate_Type := Vis_Type;
304 return;
305 end if;
306
307 -- In an instance, an abstract non-dispatching operation cannot
308 -- be a candidate interpretation, because it could not have been
309 -- one in the generic (it may be a spurious overloading in the
310 -- instance).
311
312 elsif In_Instance
313 and then Is_Abstract (E)
314 and then not Is_Dispatching_Operation (E)
315 then
316 return;
317 end if;
318
319 -- If this is the first interpretation of N, N has type Any_Type.
320 -- In that case place the new type on the node. If one interpretation
321 -- already exists, indicate that the node is overloaded, and store
322 -- both the previous and the new interpretation in All_Interp. If
323 -- this is a later interpretation, just add it to the set.
324
325 if Etype (N) = Any_Type then
326 if Is_Type (E) then
327 Set_Etype (N, T);
328
329 else
330 -- Record both the operator or subprogram name, and its type.
331
332 if Nkind (N) in N_Op or else Is_Entity_Name (N) then
333 Set_Entity (N, E);
334 end if;
335
336 Set_Etype (N, T);
337 end if;
338
339 -- Either there is no current interpretation in the table for any
340 -- node or the interpretation that is present is for a different
341 -- node. In both cases add a new interpretation to the table.
342
343 elsif Interp_Map.Last < 0
344 or else Interp_Map.Table (Interp_Map.Last).Node /= N
345 then
346 New_Interps (N);
347
348 if (Nkind (N) in N_Op or else Is_Entity_Name (N))
349 and then Present (Entity (N))
350 then
351 Add_Entry (Entity (N), Etype (N));
352
353 elsif (Nkind (N) = N_Function_Call
354 or else Nkind (N) = N_Procedure_Call_Statement)
355 and then (Nkind (Name (N)) = N_Operator_Symbol
356 or else Is_Entity_Name (Name (N)))
357 then
358 Add_Entry (Entity (Name (N)), Etype (N));
359
360 else
361 -- Overloaded prefix in indexed or selected component,
362 -- or call whose name is an expression or another call.
363
364 Add_Entry (Etype (N), Etype (N));
365 end if;
366
367 Add_Entry (E, T);
368
369 else
370 Add_Entry (E, T);
371 end if;
372 end Add_One_Interp;
373
374 -------------------
375 -- All_Overloads --
376 -------------------
377
378 procedure All_Overloads is
379 begin
380 for J in All_Interp.First .. All_Interp.Last loop
381
382 if Present (All_Interp.Table (J).Nam) then
383 Write_Entity_Info (All_Interp.Table (J). Nam, " ");
384 else
385 Write_Str ("No Interp");
386 end if;
387
388 Write_Str ("=================");
389 Write_Eol;
390 end loop;
391 end All_Overloads;
392
393 ---------------------
394 -- Collect_Interps --
395 ---------------------
396
397 procedure Collect_Interps (N : Node_Id) is
398 Ent : constant Entity_Id := Entity (N);
399 H : Entity_Id;
400 First_Interp : Interp_Index;
401
402 begin
403 New_Interps (N);
404
405 -- Unconditionally add the entity that was initially matched
406
407 First_Interp := All_Interp.Last;
408 Add_One_Interp (N, Ent, Etype (N));
409
410 -- For expanded name, pick up all additional entities from the
411 -- same scope, since these are obviously also visible. Note that
412 -- these are not necessarily contiguous on the homonym chain.
413
414 if Nkind (N) = N_Expanded_Name then
415 H := Homonym (Ent);
416 while Present (H) loop
417 if Scope (H) = Scope (Entity (N)) then
418 Add_One_Interp (N, H, Etype (H));
419 end if;
420
421 H := Homonym (H);
422 end loop;
423
424 -- Case of direct name
425
426 else
427 -- First, search the homonym chain for directly visible entities
428
429 H := Current_Entity (Ent);
430 while Present (H) loop
431 exit when (not Is_Overloadable (H))
432 and then Is_Immediately_Visible (H);
433
434 if Is_Immediately_Visible (H)
435 and then H /= Ent
436 then
437 -- Only add interpretation if not hidden by an inner
438 -- immediately visible one.
439
440 for J in First_Interp .. All_Interp.Last - 1 loop
441
442 -- Current homograph is not hidden. Add to overloads.
443
444 if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
445 exit;
446
447 -- Homograph is hidden, unless it is a predefined operator.
448
449 elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
450
451 -- A homograph in the same scope can occur within an
452 -- instantiation, the resulting ambiguity has to be
453 -- resolved later.
454
455 if Scope (H) = Scope (Ent)
456 and then In_Instance
457 and then not Is_Inherited_Operation (H)
458 then
459 All_Interp.Table (All_Interp.Last) := (H, Etype (H));
460 All_Interp.Increment_Last;
461 All_Interp.Table (All_Interp.Last) := No_Interp;
462 goto Next_Homograph;
463
464 elsif Scope (H) /= Standard_Standard then
465 goto Next_Homograph;
466 end if;
467 end if;
468 end loop;
469
470 -- On exit, we know that current homograph is not hidden.
471
472 Add_One_Interp (N, H, Etype (H));
473
474 if Debug_Flag_E then
475 Write_Str ("Add overloaded Interpretation ");
476 Write_Int (Int (H));
477 Write_Eol;
478 end if;
479 end if;
480
481 <<Next_Homograph>>
482 H := Homonym (H);
483 end loop;
484
485 -- Scan list of homographs for use-visible entities only.
486
487 H := Current_Entity (Ent);
488
489 while Present (H) loop
490 if Is_Potentially_Use_Visible (H)
491 and then H /= Ent
492 and then Is_Overloadable (H)
493 then
494 for J in First_Interp .. All_Interp.Last - 1 loop
495
496 if not Is_Immediately_Visible (All_Interp.Table (J).Nam) then
497 exit;
498
499 elsif Type_Conformant (H, All_Interp.Table (J).Nam) then
500 goto Next_Use_Homograph;
501 end if;
502 end loop;
503
504 Add_One_Interp (N, H, Etype (H));
505 end if;
506
507 <<Next_Use_Homograph>>
508 H := Homonym (H);
509 end loop;
510 end if;
511
512 if All_Interp.Last = First_Interp + 1 then
513
514 -- The original interpretation is in fact not overloaded.
515
516 Set_Is_Overloaded (N, False);
517 end if;
518 end Collect_Interps;
519
520 ------------
521 -- Covers --
522 ------------
523
524 function Covers (T1, T2 : Entity_Id) return Boolean is
525 begin
526 -- If either operand missing, then this is an error, but ignore
527 -- it (and pretend we have a cover) if errors already detected,
528 -- since this may simply mean we have malformed trees.
529
530 if No (T1) or else No (T2) then
531 if Total_Errors_Detected /= 0 then
532 return True;
533 else
534 raise Program_Error;
535 end if;
536 end if;
537
538 -- Simplest case: same types are compatible, and types that have the
539 -- same base type and are not generic actuals are compatible. Generic
540 -- actuals belong to their class but are not compatible with other
541 -- types of their class, and in particular with other generic actuals.
542 -- They are however compatible with their own subtypes, and itypes
543 -- with the same base are compatible as well. Similary, constrained
544 -- subtypes obtained from expressions of an unconstrained nominal type
545 -- are compatible with the base type (may lead to spurious ambiguities
546 -- in obscure cases ???)
547
548 -- Generic actuals require special treatment to avoid spurious ambi-
549 -- guities in an instance, when two formal types are instantiated with
550 -- the same actual, so that different subprograms end up with the same
551 -- signature in the instance.
552
553 if T1 = T2 then
554 return True;
555
556 elsif Base_Type (T1) = Base_Type (T2) then
557 if not Is_Generic_Actual_Type (T1) then
558 return True;
559 else
560 return (not Is_Generic_Actual_Type (T2)
561 or else Is_Itype (T1)
562 or else Is_Itype (T2)
563 or else Is_Constr_Subt_For_U_Nominal (T1)
564 or else Is_Constr_Subt_For_U_Nominal (T2)
565 or else Scope (T1) /= Scope (T2));
566 end if;
567
568 -- Literals are compatible with types in a given "class"
569
570 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
571 or else (T2 = Universal_Real and then Is_Real_Type (T1))
572 or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
573 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
574 or else (T2 = Any_String and then Is_String_Type (T1))
575 or else (T2 = Any_Character and then Is_Character_Type (T1))
576 or else (T2 = Any_Access and then Is_Access_Type (T1))
577 then
578 return True;
579
580 -- The context may be class wide.
581
582 elsif Is_Class_Wide_Type (T1)
583 and then Is_Ancestor (Root_Type (T1), T2)
584 then
585 return True;
586
587 elsif Is_Class_Wide_Type (T1)
588 and then Is_Class_Wide_Type (T2)
589 and then Base_Type (Etype (T1)) = Base_Type (Etype (T2))
590 then
591 return True;
592
593 -- In a dispatching call the actual may be class-wide
594
595 elsif Is_Class_Wide_Type (T2)
596 and then Base_Type (Root_Type (T2)) = Base_Type (T1)
597 then
598 return True;
599
600 -- Some contexts require a class of types rather than a specific type
601
602 elsif (T1 = Any_Integer and then Is_Integer_Type (T2))
603 or else (T1 = Any_Boolean and then Is_Boolean_Type (T2))
604 or else (T1 = Any_Real and then Is_Real_Type (T2))
605 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
606 or else (T1 = Any_Discrete and then Is_Discrete_Type (T2))
607 then
608 return True;
609
610 -- An aggregate is compatible with an array or record type
611
612 elsif T2 = Any_Composite
613 and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
614 then
615 return True;
616
617 -- If the expected type is an anonymous access, the designated
618 -- type must cover that of the expression.
619
620 elsif Ekind (T1) = E_Anonymous_Access_Type
621 and then Is_Access_Type (T2)
622 and then Covers (Designated_Type (T1), Designated_Type (T2))
623 then
624 return True;
625
626 -- An Access_To_Subprogram is compatible with itself, or with an
627 -- anonymous type created for an attribute reference Access.
628
629 elsif (Ekind (Base_Type (T1)) = E_Access_Subprogram_Type
630 or else
631 Ekind (Base_Type (T1)) = E_Access_Protected_Subprogram_Type)
632 and then Is_Access_Type (T2)
633 and then (not Comes_From_Source (T1)
634 or else not Comes_From_Source (T2))
635 and then (Is_Overloadable (Designated_Type (T2))
636 or else
637 Ekind (Designated_Type (T2)) = E_Subprogram_Type)
638 and then
639 Type_Conformant (Designated_Type (T1), Designated_Type (T2))
640 and then
641 Mode_Conformant (Designated_Type (T1), Designated_Type (T2))
642 then
643 return True;
644
645 elsif Is_Record_Type (T1)
646 and then (Is_Remote_Call_Interface (T1)
647 or else Is_Remote_Types (T1))
648 and then Present (Corresponding_Remote_Type (T1))
649 then
650 return Covers (Corresponding_Remote_Type (T1), T2);
651
652 elsif Ekind (T2) = E_Access_Attribute_Type
653 and then (Ekind (Base_Type (T1)) = E_General_Access_Type
654 or else Ekind (Base_Type (T1)) = E_Access_Type)
655 and then Covers (Designated_Type (T1), Designated_Type (T2))
656 then
657 -- If the target type is a RACW type while the source is an access
658 -- attribute type, we are building a RACW that may be exported.
659
660 if Is_Remote_Access_To_Class_Wide_Type (Base_Type (T1)) then
661 Set_Has_RACW (Current_Sem_Unit);
662 end if;
663
664 return True;
665
666 elsif Ekind (T2) = E_Allocator_Type
667 and then Is_Access_Type (T1)
668 and then Covers (Designated_Type (T1), Designated_Type (T2))
669 then
670 return True;
671
672 -- A boolean operation on integer literals is compatible with a
673 -- modular context.
674
675 elsif T2 = Any_Modular
676 and then Is_Modular_Integer_Type (T1)
677 then
678 return True;
679
680 -- The actual type may be the result of a previous error
681
682 elsif Base_Type (T2) = Any_Type then
683 return True;
684
685 -- A packed array type covers its corresponding non-packed type.
686 -- This is not legitimate Ada, but allows the omission of a number
687 -- of otherwise useless unchecked conversions, and since this can
688 -- only arise in (known correct) expanded code, no harm is done
689
690 elsif Is_Array_Type (T2)
691 and then Is_Packed (T2)
692 and then T1 = Packed_Array_Type (T2)
693 then
694 return True;
695
696 -- Similarly an array type covers its corresponding packed array type
697
698 elsif Is_Array_Type (T1)
699 and then Is_Packed (T1)
700 and then T2 = Packed_Array_Type (T1)
701 then
702 return True;
703
704 -- In an instance the proper view may not always be correct for
705 -- private types, but private and full view are compatible. This
706 -- removes spurious errors from nested instantiations that involve,
707 -- among other things, types derived from privated types.
708
709 elsif In_Instance
710 and then Is_Private_Type (T1)
711 and then ((Present (Full_View (T1))
712 and then Covers (Full_View (T1), T2))
713 or else Base_Type (T1) = T2
714 or else Base_Type (T2) = T1)
715 then
716 return True;
717
718 -- In the expansion of inlined bodies, types are compatible if they
719 -- are structurally equivalent.
720
721 elsif In_Inlined_Body
722 and then (Underlying_Type (T1) = Underlying_Type (T2)
723 or else (Is_Access_Type (T1)
724 and then Is_Access_Type (T2)
725 and then
726 Designated_Type (T1) = Designated_Type (T2))
727 or else (T1 = Any_Access
728 and then Is_Access_Type (Underlying_Type (T2))))
729 then
730 return True;
731
732 -- Otherwise it doesn't cover!
733
734 else
735 return False;
736 end if;
737 end Covers;
738
739 ------------------
740 -- Disambiguate --
741 ------------------
742
743 function Disambiguate
744 (N : Node_Id;
745 I1, I2 : Interp_Index;
746 Typ : Entity_Id)
747 return Interp
748 is
749 I : Interp_Index;
750 It : Interp;
751 It1, It2 : Interp;
752 Nam1, Nam2 : Entity_Id;
753 Predef_Subp : Entity_Id;
754 User_Subp : Entity_Id;
755
756 function Matches (Actual, Formal : Node_Id) return Boolean;
757 -- Look for exact type match in an instance, to remove spurious
758 -- ambiguities when two formal types have the same actual.
759
760 function Standard_Operator return Boolean;
761
762 function Remove_Conversions return Interp;
763 -- Last chance for pathological cases involving comparisons on
764 -- literals, and user overloadings of the same operator. Such
765 -- pathologies have been removed from the ACVC, but still appear in
766 -- two DEC tests, with the following notable quote from Ben Brosgol:
767 --
768 -- [Note: I disclaim all credit/responsibility/blame for coming up with
769 -- this example; Robert Dewar brought it to our attention, since it
770 -- is apparently found in the ACVC 1.5. I did not attempt to find
771 -- the reason in the Reference Manual that makes the example legal,
772 -- since I was too nauseated by it to want to pursue it further.]
773 --
774 -- Accordingly, this is not a fully recursive solution, but it handles
775 -- DEC tests c460vsa, c460vsb. It also handles ai00136a, which pushes
776 -- pathology in the other direction with calls whose multiple overloaded
777 -- actuals make them truly unresolvable.
778
779 -------------
780 -- Matches --
781 -------------
782
783 function Matches (Actual, Formal : Node_Id) return Boolean is
784 T1 : constant Entity_Id := Etype (Actual);
785 T2 : constant Entity_Id := Etype (Formal);
786
787 begin
788 return T1 = T2
789 or else
790 (Is_Numeric_Type (T2)
791 and then
792 (T1 = Universal_Real or else T1 = Universal_Integer));
793 end Matches;
794
795 ------------------------
796 -- Remove_Conversions --
797 ------------------------
798
799 function Remove_Conversions return Interp is
800 I : Interp_Index;
801 It : Interp;
802 It1 : Interp;
803 F1 : Entity_Id;
804 Act1 : Node_Id;
805 Act2 : Node_Id;
806
807 begin
808 It1 := No_Interp;
809 Get_First_Interp (N, I, It);
810
811 while Present (It.Typ) loop
812
813 if not Is_Overloadable (It.Nam) then
814 return No_Interp;
815 end if;
816
817 F1 := First_Formal (It.Nam);
818
819 if No (F1) then
820 return It1;
821
822 else
823 if Nkind (N) = N_Function_Call
824 or else Nkind (N) = N_Procedure_Call_Statement
825 then
826 Act1 := First_Actual (N);
827
828 if Present (Act1) then
829 Act2 := Next_Actual (Act1);
830 else
831 Act2 := Empty;
832 end if;
833
834 elsif Nkind (N) in N_Unary_Op then
835 Act1 := Right_Opnd (N);
836 Act2 := Empty;
837
838 elsif Nkind (N) in N_Binary_Op then
839 Act1 := Left_Opnd (N);
840 Act2 := Right_Opnd (N);
841
842 else
843 return It1;
844 end if;
845
846 if Nkind (Act1) in N_Op
847 and then Is_Overloaded (Act1)
848 and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
849 or else Nkind (Right_Opnd (Act1)) = N_Real_Literal)
850 and then Has_Compatible_Type (Act1, Standard_Boolean)
851 and then Etype (F1) = Standard_Boolean
852 then
853
854 if It1 /= No_Interp then
855 return No_Interp;
856
857 elsif Present (Act2)
858 and then Nkind (Act2) in N_Op
859 and then Is_Overloaded (Act2)
860 and then (Nkind (Right_Opnd (Act1)) = N_Integer_Literal
861 or else
862 Nkind (Right_Opnd (Act1)) = N_Real_Literal)
863 and then Has_Compatible_Type (Act2, Standard_Boolean)
864 then
865 -- The preference rule on the first actual is not
866 -- sufficient to disambiguate.
867
868 goto Next_Interp;
869
870 else
871 It1 := It;
872 end if;
873 end if;
874 end if;
875
876 <<Next_Interp>>
877 Get_Next_Interp (I, It);
878 end loop;
879
880 if Serious_Errors_Detected > 0 then
881
882 -- After some error, a formal may have Any_Type and yield
883 -- a spurious match. To avoid cascaded errors if possible,
884 -- check for such a formal in either candidate.
885
886 declare
887 Formal : Entity_Id;
888
889 begin
890 Formal := First_Formal (Nam1);
891 while Present (Formal) loop
892 if Etype (Formal) = Any_Type then
893 return Disambiguate.It2;
894 end if;
895
896 Next_Formal (Formal);
897 end loop;
898
899 Formal := First_Formal (Nam2);
900 while Present (Formal) loop
901 if Etype (Formal) = Any_Type then
902 return Disambiguate.It1;
903 end if;
904
905 Next_Formal (Formal);
906 end loop;
907 end;
908 end if;
909
910 return It1;
911 end Remove_Conversions;
912
913 -----------------------
914 -- Standard_Operator --
915 -----------------------
916
917 function Standard_Operator return Boolean is
918 Nam : Node_Id;
919
920 begin
921 if Nkind (N) in N_Op then
922 return True;
923
924 elsif Nkind (N) = N_Function_Call then
925 Nam := Name (N);
926
927 if Nkind (Nam) /= N_Expanded_Name then
928 return True;
929 else
930 return Entity (Prefix (Nam)) = Standard_Standard;
931 end if;
932 else
933 return False;
934 end if;
935 end Standard_Operator;
936
937 -- Start of processing for Disambiguate
938
939 begin
940 -- Recover the two legal interpretations.
941
942 Get_First_Interp (N, I, It);
943
944 while I /= I1 loop
945 Get_Next_Interp (I, It);
946 end loop;
947
948 It1 := It;
949 Nam1 := It.Nam;
950
951 while I /= I2 loop
952 Get_Next_Interp (I, It);
953 end loop;
954
955 It2 := It;
956 Nam2 := It.Nam;
957
958 -- If the context is universal, the predefined operator is preferred.
959 -- This includes bounds in numeric type declarations, and expressions
960 -- in type conversions. If no interpretation yields a universal type,
961 -- then we must check whether the user-defined entity hides the prede-
962 -- fined one.
963
964 if Chars (Nam1) in Any_Operator_Name
965 and then Standard_Operator
966 then
967 if Typ = Universal_Integer
968 or else Typ = Universal_Real
969 or else Typ = Any_Integer
970 or else Typ = Any_Discrete
971 or else Typ = Any_Real
972 or else Typ = Any_Type
973 then
974 -- Find an interpretation that yields the universal type, or else
975 -- a predefined operator that yields a predefined numeric type.
976
977 declare
978 Candidate : Interp := No_Interp;
979 begin
980 Get_First_Interp (N, I, It);
981
982 while Present (It.Typ) loop
983 if (Covers (Typ, It.Typ)
984 or else Typ = Any_Type)
985 and then
986 (It.Typ = Universal_Integer
987 or else It.Typ = Universal_Real)
988 then
989 return It;
990
991 elsif Covers (Typ, It.Typ)
992 and then Scope (It.Typ) = Standard_Standard
993 and then Scope (It.Nam) = Standard_Standard
994 and then Is_Numeric_Type (It.Typ)
995 then
996 Candidate := It;
997 end if;
998
999 Get_Next_Interp (I, It);
1000 end loop;
1001
1002 if Candidate /= No_Interp then
1003 return Candidate;
1004 end if;
1005 end;
1006
1007 elsif Chars (Nam1) /= Name_Op_Not
1008 and then (Typ = Standard_Boolean
1009 or else Typ = Any_Boolean)
1010 then
1011 -- Equality or comparison operation. Choose predefined operator
1012 -- if arguments are universal. The node may be an operator, a
1013 -- name, or a function call, so unpack arguments accordingly.
1014
1015 declare
1016 Arg1, Arg2 : Node_Id;
1017
1018 begin
1019 if Nkind (N) in N_Op then
1020 Arg1 := Left_Opnd (N);
1021 Arg2 := Right_Opnd (N);
1022
1023 elsif Is_Entity_Name (N)
1024 or else Nkind (N) = N_Operator_Symbol
1025 then
1026 Arg1 := First_Entity (Entity (N));
1027 Arg2 := Next_Entity (Arg1);
1028
1029 else
1030 Arg1 := First_Actual (N);
1031 Arg2 := Next_Actual (Arg1);
1032 end if;
1033
1034 if Present (Arg2)
1035 and then Present (Universal_Interpretation (Arg1))
1036 and then Universal_Interpretation (Arg2) =
1037 Universal_Interpretation (Arg1)
1038 then
1039 Get_First_Interp (N, I, It);
1040
1041 while Scope (It.Nam) /= Standard_Standard loop
1042 Get_Next_Interp (I, It);
1043 end loop;
1044
1045 return It;
1046 end if;
1047 end;
1048 end if;
1049 end if;
1050
1051 -- If no universal interpretation, check whether user-defined operator
1052 -- hides predefined one, as well as other special cases. If the node
1053 -- is a range, then one or both bounds are ambiguous. Each will have
1054 -- to be disambiguated w.r.t. the context type. The type of the range
1055 -- itself is imposed by the context, so we can return either legal
1056 -- interpretation.
1057
1058 if Ekind (Nam1) = E_Operator then
1059 Predef_Subp := Nam1;
1060 User_Subp := Nam2;
1061
1062 elsif Ekind (Nam2) = E_Operator then
1063 Predef_Subp := Nam2;
1064 User_Subp := Nam1;
1065
1066 elsif Nkind (N) = N_Range then
1067 return It1;
1068
1069 -- If two user defined-subprograms are visible, it is a true ambiguity,
1070 -- unless one of them is an entry and the context is a conditional or
1071 -- timed entry call, or unless we are within an instance and this is
1072 -- results from two formals types with the same actual.
1073
1074 else
1075 if Nkind (N) = N_Procedure_Call_Statement
1076 and then Nkind (Parent (N)) = N_Entry_Call_Alternative
1077 and then N = Entry_Call_Statement (Parent (N))
1078 then
1079 if Ekind (Nam2) = E_Entry then
1080 return It2;
1081 elsif Ekind (Nam1) = E_Entry then
1082 return It1;
1083 else
1084 return No_Interp;
1085 end if;
1086
1087 -- If the ambiguity occurs within an instance, it is due to several
1088 -- formal types with the same actual. Look for an exact match
1089 -- between the types of the formals of the overloadable entities,
1090 -- and the actuals in the call, to recover the unambiguous match
1091 -- in the original generic.
1092
1093 elsif In_Instance then
1094 if (Nkind (N) = N_Function_Call
1095 or else Nkind (N) = N_Procedure_Call_Statement)
1096 then
1097 declare
1098 Actual : Node_Id;
1099 Formal : Entity_Id;
1100
1101 begin
1102 Actual := First_Actual (N);
1103 Formal := First_Formal (Nam1);
1104 while Present (Actual) loop
1105 if Etype (Actual) /= Etype (Formal) then
1106 return It2;
1107 end if;
1108
1109 Next_Actual (Actual);
1110 Next_Formal (Formal);
1111 end loop;
1112
1113 return It1;
1114 end;
1115
1116 elsif Nkind (N) in N_Binary_Op then
1117
1118 if Matches (Left_Opnd (N), First_Formal (Nam1))
1119 and then
1120 Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
1121 then
1122 return It1;
1123 else
1124 return It2;
1125 end if;
1126
1127 elsif Nkind (N) in N_Unary_Op then
1128
1129 if Etype (Right_Opnd (N)) = Etype (First_Formal (Nam1)) then
1130 return It1;
1131 else
1132 return It2;
1133 end if;
1134
1135 else
1136 return Remove_Conversions;
1137 end if;
1138 else
1139 return Remove_Conversions;
1140 end if;
1141 end if;
1142
1143 -- an implicit concatenation operator on a string type cannot be
1144 -- disambiguated from the predefined concatenation. This can only
1145 -- happen with concatenation of string literals.
1146
1147 if Chars (User_Subp) = Name_Op_Concat
1148 and then Ekind (User_Subp) = E_Operator
1149 and then Is_String_Type (Etype (First_Formal (User_Subp)))
1150 then
1151 return No_Interp;
1152
1153 -- If the user-defined operator is in an open scope, or in the scope
1154 -- of the resulting type, or given by an expanded name that names its
1155 -- scope, it hides the predefined operator for the type. Exponentiation
1156 -- has to be special-cased because the implicit operator does not have
1157 -- a symmetric signature, and may not be hidden by the explicit one.
1158
1159 elsif (Nkind (N) = N_Function_Call
1160 and then Nkind (Name (N)) = N_Expanded_Name
1161 and then (Chars (Predef_Subp) /= Name_Op_Expon
1162 or else Hides_Op (User_Subp, Predef_Subp))
1163 and then Scope (User_Subp) = Entity (Prefix (Name (N))))
1164 or else Hides_Op (User_Subp, Predef_Subp)
1165 then
1166 if It1.Nam = User_Subp then
1167 return It1;
1168 else
1169 return It2;
1170 end if;
1171
1172 -- Otherwise, the predefined operator has precedence, or if the
1173 -- user-defined operation is directly visible we have a true ambiguity.
1174 -- If this is a fixed-point multiplication and division in Ada83 mode,
1175 -- exclude the universal_fixed operator, which often causes ambiguities
1176 -- in legacy code.
1177
1178 else
1179 if (In_Open_Scopes (Scope (User_Subp))
1180 or else Is_Potentially_Use_Visible (User_Subp))
1181 and then not In_Instance
1182 then
1183 if Is_Fixed_Point_Type (Typ)
1184 and then (Chars (Nam1) = Name_Op_Multiply
1185 or else Chars (Nam1) = Name_Op_Divide)
1186 and then Ada_83
1187 then
1188 if It2.Nam = Predef_Subp then
1189 return It1;
1190
1191 else
1192 return It2;
1193 end if;
1194 else
1195 return No_Interp;
1196 end if;
1197
1198 elsif It1.Nam = Predef_Subp then
1199 return It1;
1200
1201 else
1202 return It2;
1203 end if;
1204 end if;
1205
1206 end Disambiguate;
1207
1208 ---------------------
1209 -- End_Interp_List --
1210 ---------------------
1211
1212 procedure End_Interp_List is
1213 begin
1214 All_Interp.Table (All_Interp.Last) := No_Interp;
1215 All_Interp.Increment_Last;
1216 end End_Interp_List;
1217
1218 -------------------------
1219 -- Entity_Matches_Spec --
1220 -------------------------
1221
1222 function Entity_Matches_Spec (Old_S, New_S : Entity_Id) return Boolean is
1223 begin
1224 -- Simple case: same entity kinds, type conformance is required.
1225 -- A parameterless function can also rename a literal.
1226
1227 if Ekind (Old_S) = Ekind (New_S)
1228 or else (Ekind (New_S) = E_Function
1229 and then Ekind (Old_S) = E_Enumeration_Literal)
1230 then
1231 return Type_Conformant (New_S, Old_S);
1232
1233 elsif Ekind (New_S) = E_Function
1234 and then Ekind (Old_S) = E_Operator
1235 then
1236 return Operator_Matches_Spec (Old_S, New_S);
1237
1238 elsif Ekind (New_S) = E_Procedure
1239 and then Is_Entry (Old_S)
1240 then
1241 return Type_Conformant (New_S, Old_S);
1242
1243 else
1244 return False;
1245 end if;
1246 end Entity_Matches_Spec;
1247
1248 ----------------------
1249 -- Find_Unique_Type --
1250 ----------------------
1251
1252 function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
1253 I : Interp_Index;
1254 It : Interp;
1255 T : Entity_Id := Etype (L);
1256 TR : Entity_Id := Any_Type;
1257
1258 begin
1259 if Is_Overloaded (R) then
1260 Get_First_Interp (R, I, It);
1261
1262 while Present (It.Typ) loop
1263 if Covers (T, It.Typ) or else Covers (It.Typ, T) then
1264
1265 -- If several interpretations are possible and L is universal,
1266 -- apply preference rule.
1267
1268 if TR /= Any_Type then
1269
1270 if (T = Universal_Integer or else T = Universal_Real)
1271 and then It.Typ = T
1272 then
1273 TR := It.Typ;
1274 end if;
1275
1276 else
1277 TR := It.Typ;
1278 end if;
1279 end if;
1280
1281 Get_Next_Interp (I, It);
1282 end loop;
1283
1284 Set_Etype (R, TR);
1285
1286 -- In the non-overloaded case, the Etype of R is already set
1287 -- correctly.
1288
1289 else
1290 null;
1291 end if;
1292
1293 -- If one of the operands is Universal_Fixed, the type of the
1294 -- other operand provides the context.
1295
1296 if Etype (R) = Universal_Fixed then
1297 return T;
1298
1299 elsif T = Universal_Fixed then
1300 return Etype (R);
1301
1302 else
1303 return Specific_Type (T, Etype (R));
1304 end if;
1305
1306 end Find_Unique_Type;
1307
1308 ----------------------
1309 -- Get_First_Interp --
1310 ----------------------
1311
1312 procedure Get_First_Interp
1313 (N : Node_Id;
1314 I : out Interp_Index;
1315 It : out Interp)
1316 is
1317 Int_Ind : Interp_Index;
1318 O_N : Node_Id;
1319
1320 begin
1321 -- If a selected component is overloaded because the selector has
1322 -- multiple interpretations, the node is a call to a protected
1323 -- operation or an indirect call. Retrieve the interpretation from
1324 -- the selector name. The selected component may be overloaded as well
1325 -- if the prefix is overloaded. That case is unchanged.
1326
1327 if Nkind (N) = N_Selected_Component
1328 and then Is_Overloaded (Selector_Name (N))
1329 then
1330 O_N := Selector_Name (N);
1331 else
1332 O_N := N;
1333 end if;
1334
1335 for Index in 0 .. Interp_Map.Last loop
1336 if Interp_Map.Table (Index).Node = O_N then
1337 Int_Ind := Interp_Map.Table (Index).Index;
1338 It := All_Interp.Table (Int_Ind);
1339 I := Int_Ind;
1340 return;
1341 end if;
1342 end loop;
1343
1344 -- Procedure should never be called if the node has no interpretations
1345
1346 raise Program_Error;
1347 end Get_First_Interp;
1348
1349 ----------------------
1350 -- Get_Next_Interp --
1351 ----------------------
1352
1353 procedure Get_Next_Interp (I : in out Interp_Index; It : out Interp) is
1354 begin
1355 I := I + 1;
1356 It := All_Interp.Table (I);
1357 end Get_Next_Interp;
1358
1359 -------------------------
1360 -- Has_Compatible_Type --
1361 -------------------------
1362
1363 function Has_Compatible_Type
1364 (N : Node_Id;
1365 Typ : Entity_Id)
1366 return Boolean
1367 is
1368 I : Interp_Index;
1369 It : Interp;
1370
1371 begin
1372 if N = Error then
1373 return False;
1374 end if;
1375
1376 if Nkind (N) = N_Subtype_Indication
1377 or else not Is_Overloaded (N)
1378 then
1379 return Covers (Typ, Etype (N))
1380 or else (not Is_Tagged_Type (Typ)
1381 and then Ekind (Typ) /= E_Anonymous_Access_Type
1382 and then Covers (Etype (N), Typ));
1383
1384 else
1385 Get_First_Interp (N, I, It);
1386
1387 while Present (It.Typ) loop
1388 if Covers (Typ, It.Typ)
1389 or else (not Is_Tagged_Type (Typ)
1390 and then Ekind (Typ) /= E_Anonymous_Access_Type
1391 and then Covers (It.Typ, Typ))
1392 then
1393 return True;
1394 end if;
1395
1396 Get_Next_Interp (I, It);
1397 end loop;
1398
1399 return False;
1400 end if;
1401 end Has_Compatible_Type;
1402
1403 --------------
1404 -- Hides_Op --
1405 --------------
1406
1407 function Hides_Op (F : Entity_Id; Op : Entity_Id) return Boolean is
1408 Btyp : constant Entity_Id := Base_Type (Etype (First_Formal (F)));
1409
1410 begin
1411 return Operator_Matches_Spec (Op, F)
1412 and then (In_Open_Scopes (Scope (F))
1413 or else Scope (F) = Scope (Btyp)
1414 or else (not In_Open_Scopes (Scope (Btyp))
1415 and then not In_Use (Btyp)
1416 and then not In_Use (Scope (Btyp))));
1417 end Hides_Op;
1418
1419 ------------------------
1420 -- Init_Interp_Tables --
1421 ------------------------
1422
1423 procedure Init_Interp_Tables is
1424 begin
1425 All_Interp.Init;
1426 Interp_Map.Init;
1427 end Init_Interp_Tables;
1428
1429 ---------------------
1430 -- Intersect_Types --
1431 ---------------------
1432
1433 function Intersect_Types (L, R : Node_Id) return Entity_Id is
1434 Index : Interp_Index;
1435 It : Interp;
1436 Typ : Entity_Id;
1437
1438 function Check_Right_Argument (T : Entity_Id) return Entity_Id;
1439 -- Find interpretation of right arg that has type compatible with T
1440
1441 --------------------------
1442 -- Check_Right_Argument --
1443 --------------------------
1444
1445 function Check_Right_Argument (T : Entity_Id) return Entity_Id is
1446 Index : Interp_Index;
1447 It : Interp;
1448 T2 : Entity_Id;
1449
1450 begin
1451 if not Is_Overloaded (R) then
1452 return Specific_Type (T, Etype (R));
1453
1454 else
1455 Get_First_Interp (R, Index, It);
1456
1457 loop
1458 T2 := Specific_Type (T, It.Typ);
1459
1460 if T2 /= Any_Type then
1461 return T2;
1462 end if;
1463
1464 Get_Next_Interp (Index, It);
1465 exit when No (It.Typ);
1466 end loop;
1467
1468 return Any_Type;
1469 end if;
1470 end Check_Right_Argument;
1471
1472 -- Start processing for Intersect_Types
1473
1474 begin
1475 if Etype (L) = Any_Type or else Etype (R) = Any_Type then
1476 return Any_Type;
1477 end if;
1478
1479 if not Is_Overloaded (L) then
1480 Typ := Check_Right_Argument (Etype (L));
1481
1482 else
1483 Typ := Any_Type;
1484 Get_First_Interp (L, Index, It);
1485
1486 while Present (It.Typ) loop
1487 Typ := Check_Right_Argument (It.Typ);
1488 exit when Typ /= Any_Type;
1489 Get_Next_Interp (Index, It);
1490 end loop;
1491
1492 end if;
1493
1494 -- If Typ is Any_Type, it means no compatible pair of types was found
1495
1496 if Typ = Any_Type then
1497
1498 if Nkind (Parent (L)) in N_Op then
1499 Error_Msg_N ("incompatible types for operator", Parent (L));
1500
1501 elsif Nkind (Parent (L)) = N_Range then
1502 Error_Msg_N ("incompatible types given in constraint", Parent (L));
1503
1504 else
1505 Error_Msg_N ("incompatible types", Parent (L));
1506 end if;
1507 end if;
1508
1509 return Typ;
1510 end Intersect_Types;
1511
1512 -----------------
1513 -- Is_Ancestor --
1514 -----------------
1515
1516 function Is_Ancestor (T1, T2 : Entity_Id) return Boolean is
1517 Par : Entity_Id;
1518
1519 begin
1520 if Base_Type (T1) = Base_Type (T2) then
1521 return True;
1522
1523 elsif Is_Private_Type (T1)
1524 and then Present (Full_View (T1))
1525 and then Base_Type (T2) = Base_Type (Full_View (T1))
1526 then
1527 return True;
1528
1529 else
1530 Par := Etype (T2);
1531
1532 loop
1533 if Base_Type (T1) = Base_Type (Par)
1534 or else (Is_Private_Type (T1)
1535 and then Present (Full_View (T1))
1536 and then Base_Type (Par) = Base_Type (Full_View (T1)))
1537 then
1538 return True;
1539
1540 elsif Is_Private_Type (Par)
1541 and then Present (Full_View (Par))
1542 and then Full_View (Par) = Base_Type (T1)
1543 then
1544 return True;
1545
1546 elsif Etype (Par) /= Par then
1547 Par := Etype (Par);
1548 else
1549 return False;
1550 end if;
1551 end loop;
1552 end if;
1553 end Is_Ancestor;
1554
1555 -------------------
1556 -- Is_Subtype_Of --
1557 -------------------
1558
1559 function Is_Subtype_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
1560 S : Entity_Id;
1561
1562 begin
1563 S := Ancestor_Subtype (T1);
1564 while Present (S) loop
1565 if S = T2 then
1566 return True;
1567 else
1568 S := Ancestor_Subtype (S);
1569 end if;
1570 end loop;
1571
1572 return False;
1573 end Is_Subtype_Of;
1574
1575 -----------------
1576 -- New_Interps --
1577 -----------------
1578
1579 procedure New_Interps (N : Node_Id) is
1580 begin
1581 Interp_Map.Increment_Last;
1582 All_Interp.Increment_Last;
1583 Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last);
1584 All_Interp.Table (All_Interp.Last) := No_Interp;
1585 Set_Is_Overloaded (N, True);
1586 end New_Interps;
1587
1588 ---------------------------
1589 -- Operator_Matches_Spec --
1590 ---------------------------
1591
1592 function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
1593 Op_Name : constant Name_Id := Chars (Op);
1594 T : constant Entity_Id := Etype (New_S);
1595 New_F : Entity_Id;
1596 Old_F : Entity_Id;
1597 Num : Int;
1598 T1 : Entity_Id;
1599 T2 : Entity_Id;
1600
1601 begin
1602 -- To verify that a predefined operator matches a given signature,
1603 -- do a case analysis of the operator classes. Function can have one
1604 -- or two formals and must have the proper result type.
1605
1606 New_F := First_Formal (New_S);
1607 Old_F := First_Formal (Op);
1608 Num := 0;
1609
1610 while Present (New_F) and then Present (Old_F) loop
1611 Num := Num + 1;
1612 Next_Formal (New_F);
1613 Next_Formal (Old_F);
1614 end loop;
1615
1616 -- Definite mismatch if different number of parameters
1617
1618 if Present (Old_F) or else Present (New_F) then
1619 return False;
1620
1621 -- Unary operators
1622
1623 elsif Num = 1 then
1624 T1 := Etype (First_Formal (New_S));
1625
1626 if Op_Name = Name_Op_Subtract
1627 or else Op_Name = Name_Op_Add
1628 or else Op_Name = Name_Op_Abs
1629 then
1630 return Base_Type (T1) = Base_Type (T)
1631 and then Is_Numeric_Type (T);
1632
1633 elsif Op_Name = Name_Op_Not then
1634 return Base_Type (T1) = Base_Type (T)
1635 and then Valid_Boolean_Arg (Base_Type (T));
1636
1637 else
1638 return False;
1639 end if;
1640
1641 -- Binary operators
1642
1643 else
1644 T1 := Etype (First_Formal (New_S));
1645 T2 := Etype (Next_Formal (First_Formal (New_S)));
1646
1647 if Op_Name = Name_Op_And or else Op_Name = Name_Op_Or
1648 or else Op_Name = Name_Op_Xor
1649 then
1650 return Base_Type (T1) = Base_Type (T2)
1651 and then Base_Type (T1) = Base_Type (T)
1652 and then Valid_Boolean_Arg (Base_Type (T));
1653
1654 elsif Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne then
1655 return Base_Type (T1) = Base_Type (T2)
1656 and then not Is_Limited_Type (T1)
1657 and then Is_Boolean_Type (T);
1658
1659 elsif Op_Name = Name_Op_Lt or else Op_Name = Name_Op_Le
1660 or else Op_Name = Name_Op_Gt or else Op_Name = Name_Op_Ge
1661 then
1662 return Base_Type (T1) = Base_Type (T2)
1663 and then Valid_Comparison_Arg (T1)
1664 and then Is_Boolean_Type (T);
1665
1666 elsif Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
1667 return Base_Type (T1) = Base_Type (T2)
1668 and then Base_Type (T1) = Base_Type (T)
1669 and then Is_Numeric_Type (T);
1670
1671 -- for division and multiplication, a user-defined function does
1672 -- not match the predefined universal_fixed operation, except in
1673 -- Ada83 mode.
1674
1675 elsif Op_Name = Name_Op_Divide then
1676 return (Base_Type (T1) = Base_Type (T2)
1677 and then Base_Type (T1) = Base_Type (T)
1678 and then Is_Numeric_Type (T)
1679 and then (not Is_Fixed_Point_Type (T)
1680 or else Ada_83))
1681
1682 -- Mixed_Mode operations on fixed-point types.
1683
1684 or else (Base_Type (T1) = Base_Type (T)
1685 and then Base_Type (T2) = Base_Type (Standard_Integer)
1686 and then Is_Fixed_Point_Type (T))
1687
1688 -- A user defined operator can also match (and hide) a mixed
1689 -- operation on universal literals.
1690
1691 or else (Is_Integer_Type (T2)
1692 and then Is_Floating_Point_Type (T1)
1693 and then Base_Type (T1) = Base_Type (T));
1694
1695 elsif Op_Name = Name_Op_Multiply then
1696 return (Base_Type (T1) = Base_Type (T2)
1697 and then Base_Type (T1) = Base_Type (T)
1698 and then Is_Numeric_Type (T)
1699 and then (not Is_Fixed_Point_Type (T)
1700 or else Ada_83))
1701
1702 -- Mixed_Mode operations on fixed-point types.
1703
1704 or else (Base_Type (T1) = Base_Type (T)
1705 and then Base_Type (T2) = Base_Type (Standard_Integer)
1706 and then Is_Fixed_Point_Type (T))
1707
1708 or else (Base_Type (T2) = Base_Type (T)
1709 and then Base_Type (T1) = Base_Type (Standard_Integer)
1710 and then Is_Fixed_Point_Type (T))
1711
1712 or else (Is_Integer_Type (T2)
1713 and then Is_Floating_Point_Type (T1)
1714 and then Base_Type (T1) = Base_Type (T))
1715
1716 or else (Is_Integer_Type (T1)
1717 and then Is_Floating_Point_Type (T2)
1718 and then Base_Type (T2) = Base_Type (T));
1719
1720 elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
1721 return Base_Type (T1) = Base_Type (T2)
1722 and then Base_Type (T1) = Base_Type (T)
1723 and then Is_Integer_Type (T);
1724
1725 elsif Op_Name = Name_Op_Expon then
1726 return Base_Type (T1) = Base_Type (T)
1727 and then Is_Numeric_Type (T)
1728 and then Base_Type (T2) = Base_Type (Standard_Integer);
1729
1730 elsif Op_Name = Name_Op_Concat then
1731 return Is_Array_Type (T)
1732 and then (Base_Type (T) = Base_Type (Etype (Op)))
1733 and then (Base_Type (T1) = Base_Type (T)
1734 or else
1735 Base_Type (T1) = Base_Type (Component_Type (T)))
1736 and then (Base_Type (T2) = Base_Type (T)
1737 or else
1738 Base_Type (T2) = Base_Type (Component_Type (T)));
1739
1740 else
1741 return False;
1742 end if;
1743 end if;
1744 end Operator_Matches_Spec;
1745
1746 -------------------
1747 -- Remove_Interp --
1748 -------------------
1749
1750 procedure Remove_Interp (I : in out Interp_Index) is
1751 II : Interp_Index;
1752
1753 begin
1754 -- Find end of Interp list and copy downward to erase the discarded one
1755
1756 II := I + 1;
1757
1758 while Present (All_Interp.Table (II).Typ) loop
1759 II := II + 1;
1760 end loop;
1761
1762 for J in I + 1 .. II loop
1763 All_Interp.Table (J - 1) := All_Interp.Table (J);
1764 end loop;
1765
1766 -- Back up interp. index to insure that iterator will pick up next
1767 -- available interpretation.
1768
1769 I := I - 1;
1770 end Remove_Interp;
1771
1772 ------------------
1773 -- Save_Interps --
1774 ------------------
1775
1776 procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
1777 begin
1778 if Is_Overloaded (Old_N) then
1779 for Index in 0 .. Interp_Map.Last loop
1780 if Interp_Map.Table (Index).Node = Old_N then
1781 Interp_Map.Table (Index).Node := New_N;
1782 exit;
1783 end if;
1784 end loop;
1785 end if;
1786 end Save_Interps;
1787
1788 -------------------
1789 -- Specific_Type --
1790 -------------------
1791
1792 function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
1793 B1 : constant Entity_Id := Base_Type (T1);
1794 B2 : constant Entity_Id := Base_Type (T2);
1795
1796 function Is_Remote_Access (T : Entity_Id) return Boolean;
1797 -- Check whether T is the equivalent type of a remote access type.
1798 -- If distribution is enabled, T is a legal context for Null.
1799
1800 ----------------------
1801 -- Is_Remote_Access --
1802 ----------------------
1803
1804 function Is_Remote_Access (T : Entity_Id) return Boolean is
1805 begin
1806 return Is_Record_Type (T)
1807 and then (Is_Remote_Call_Interface (T)
1808 or else Is_Remote_Types (T))
1809 and then Present (Corresponding_Remote_Type (T))
1810 and then Is_Access_Type (Corresponding_Remote_Type (T));
1811 end Is_Remote_Access;
1812
1813 -- Start of processing for Specific_Type
1814
1815 begin
1816 if (T1 = Any_Type or else T2 = Any_Type) then
1817 return Any_Type;
1818 end if;
1819
1820 if B1 = B2 then
1821 return B1;
1822
1823 elsif (T1 = Universal_Integer and then Is_Integer_Type (T2))
1824 or else (T1 = Universal_Real and then Is_Real_Type (T2))
1825 or else (T1 = Any_Fixed and then Is_Fixed_Point_Type (T2))
1826 then
1827 return B2;
1828
1829 elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
1830 or else (T2 = Universal_Real and then Is_Real_Type (T1))
1831 or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
1832 then
1833 return B1;
1834
1835 elsif (T2 = Any_String and then Is_String_Type (T1)) then
1836 return B1;
1837
1838 elsif (T1 = Any_String and then Is_String_Type (T2)) then
1839 return B2;
1840
1841 elsif (T2 = Any_Character and then Is_Character_Type (T1)) then
1842 return B1;
1843
1844 elsif (T1 = Any_Character and then Is_Character_Type (T2)) then
1845 return B2;
1846
1847 elsif (T1 = Any_Access
1848 and then (Is_Access_Type (T2) or else Is_Remote_Access (T2)))
1849 then
1850 return T2;
1851
1852 elsif (T2 = Any_Access
1853 and then (Is_Access_Type (T1) or else Is_Remote_Access (T1)))
1854 then
1855 return T1;
1856
1857 elsif (T2 = Any_Composite
1858 and then Ekind (T1) in E_Array_Type .. E_Record_Subtype)
1859 then
1860 return T1;
1861
1862 elsif (T1 = Any_Composite
1863 and then Ekind (T2) in E_Array_Type .. E_Record_Subtype)
1864 then
1865 return T2;
1866
1867 elsif (T1 = Any_Modular and then Is_Modular_Integer_Type (T2)) then
1868 return T2;
1869
1870 elsif (T2 = Any_Modular and then Is_Modular_Integer_Type (T1)) then
1871 return T1;
1872
1873 -- Special cases for equality operators (all other predefined
1874 -- operators can never apply to tagged types)
1875
1876 elsif Is_Class_Wide_Type (T1)
1877 and then Is_Ancestor (Root_Type (T1), T2)
1878 then
1879 return T1;
1880
1881 elsif Is_Class_Wide_Type (T2)
1882 and then Is_Ancestor (Root_Type (T2), T1)
1883 then
1884 return T2;
1885
1886 elsif (Ekind (B1) = E_Access_Subprogram_Type
1887 or else
1888 Ekind (B1) = E_Access_Protected_Subprogram_Type)
1889 and then Ekind (Designated_Type (B1)) /= E_Subprogram_Type
1890 and then Is_Access_Type (T2)
1891 then
1892 return T2;
1893
1894 elsif (Ekind (B2) = E_Access_Subprogram_Type
1895 or else
1896 Ekind (B2) = E_Access_Protected_Subprogram_Type)
1897 and then Ekind (Designated_Type (B2)) /= E_Subprogram_Type
1898 and then Is_Access_Type (T1)
1899 then
1900 return T1;
1901
1902 elsif (Ekind (T1) = E_Allocator_Type
1903 or else Ekind (T1) = E_Access_Attribute_Type
1904 or else Ekind (T1) = E_Anonymous_Access_Type)
1905 and then Is_Access_Type (T2)
1906 then
1907 return T2;
1908
1909 elsif (Ekind (T2) = E_Allocator_Type
1910 or else Ekind (T2) = E_Access_Attribute_Type
1911 or else Ekind (T2) = E_Anonymous_Access_Type)
1912 and then Is_Access_Type (T1)
1913 then
1914 return T1;
1915
1916 -- If none of the above cases applies, types are not compatible.
1917
1918 else
1919 return Any_Type;
1920 end if;
1921 end Specific_Type;
1922
1923 ------------------------------
1924 -- Universal_Interpretation --
1925 ------------------------------
1926
1927 function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
1928 Index : Interp_Index;
1929 It : Interp;
1930
1931 begin
1932 -- The argument may be a formal parameter of an operator or subprogram
1933 -- with multiple interpretations, or else an expression for an actual.
1934
1935 if Nkind (Opnd) = N_Defining_Identifier
1936 or else not Is_Overloaded (Opnd)
1937 then
1938 if Etype (Opnd) = Universal_Integer
1939 or else Etype (Opnd) = Universal_Real
1940 then
1941 return Etype (Opnd);
1942 else
1943 return Empty;
1944 end if;
1945
1946 else
1947 Get_First_Interp (Opnd, Index, It);
1948
1949 while Present (It.Typ) loop
1950
1951 if It.Typ = Universal_Integer
1952 or else It.Typ = Universal_Real
1953 then
1954 return It.Typ;
1955 end if;
1956
1957 Get_Next_Interp (Index, It);
1958 end loop;
1959
1960 return Empty;
1961 end if;
1962 end Universal_Interpretation;
1963
1964 -----------------------
1965 -- Valid_Boolean_Arg --
1966 -----------------------
1967
1968 -- In addition to booleans and arrays of booleans, we must include
1969 -- aggregates as valid boolean arguments, because in the first pass
1970 -- of resolution their components are not examined. If it turns out not
1971 -- to be an aggregate of booleans, this will be diagnosed in Resolve.
1972 -- Any_Composite must be checked for prior to the array type checks
1973 -- because Any_Composite does not have any associated indexes.
1974
1975 function Valid_Boolean_Arg (T : Entity_Id) return Boolean is
1976 begin
1977 return Is_Boolean_Type (T)
1978 or else T = Any_Composite
1979 or else (Is_Array_Type (T)
1980 and then T /= Any_String
1981 and then Number_Dimensions (T) = 1
1982 and then Is_Boolean_Type (Component_Type (T))
1983 and then (not Is_Private_Composite (T)
1984 or else In_Instance)
1985 and then (not Is_Limited_Composite (T)
1986 or else In_Instance))
1987 or else Is_Modular_Integer_Type (T)
1988 or else T = Universal_Integer;
1989 end Valid_Boolean_Arg;
1990
1991 --------------------------
1992 -- Valid_Comparison_Arg --
1993 --------------------------
1994
1995 function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
1996 begin
1997 return Is_Discrete_Type (T)
1998 or else Is_Real_Type (T)
1999 or else (Is_Array_Type (T) and then Number_Dimensions (T) = 1
2000 and then Is_Discrete_Type (Component_Type (T))
2001 and then (not Is_Private_Composite (T)
2002 or else In_Instance)
2003 and then (not Is_Limited_Composite (T)
2004 or else In_Instance))
2005 or else Is_String_Type (T);
2006 end Valid_Comparison_Arg;
2007
2008 ---------------------
2009 -- Write_Overloads --
2010 ---------------------
2011
2012 procedure Write_Overloads (N : Node_Id) is
2013 I : Interp_Index;
2014 It : Interp;
2015 Nam : Entity_Id;
2016
2017 begin
2018 if not Is_Overloaded (N) then
2019 Write_Str ("Non-overloaded entity ");
2020 Write_Eol;
2021 Write_Entity_Info (Entity (N), " ");
2022
2023 else
2024 Get_First_Interp (N, I, It);
2025 Write_Str ("Overloaded entity ");
2026 Write_Eol;
2027 Nam := It.Nam;
2028
2029 while Present (Nam) loop
2030 Write_Entity_Info (Nam, " ");
2031 Write_Str ("=================");
2032 Write_Eol;
2033 Get_Next_Interp (I, It);
2034 Nam := It.Nam;
2035 end loop;
2036 end if;
2037 end Write_Overloads;
2038
2039 end Sem_Type;
Mirror of the offical gcc git repository hosted at gcc.gnu.org