File : sem_ch4.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M _ C H 4 --
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 Aspects; use Aspects;
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Exp_Util; use Exp_Util;
33 with Fname; use Fname;
34 with Itypes; use Itypes;
35 with Lib; use Lib;
36 with Lib.Xref; use Lib.Xref;
37 with Namet; use Namet;
38 with Namet.Sp; use Namet.Sp;
39 with Nlists; use Nlists;
40 with Nmake; use Nmake;
41 with Opt; use Opt;
42 with Output; use Output;
43 with Restrict; use Restrict;
44 with Rident; use Rident;
45 with Sem; use Sem;
46 with Sem_Aux; use Sem_Aux;
47 with Sem_Case; use Sem_Case;
48 with Sem_Cat; use Sem_Cat;
49 with Sem_Ch3; use Sem_Ch3;
50 with Sem_Ch6; use Sem_Ch6;
51 with Sem_Ch8; use Sem_Ch8;
52 with Sem_Dim; use Sem_Dim;
53 with Sem_Disp; use Sem_Disp;
54 with Sem_Dist; use Sem_Dist;
55 with Sem_Eval; use Sem_Eval;
56 with Sem_Res; use Sem_Res;
57 with Sem_Type; use Sem_Type;
58 with Sem_Util; use Sem_Util;
59 with Sem_Warn; use Sem_Warn;
60 with Stand; use Stand;
61 with Sinfo; use Sinfo;
62 with Snames; use Snames;
63 with Tbuild; use Tbuild;
64 with Uintp; use Uintp;
65
66 package body Sem_Ch4 is
67
68 -- Tables which speed up the identification of dangerous calls to Ada 2012
69 -- functions with writable actuals (AI05-0144).
70
71 -- The following table enumerates the Ada constructs which may evaluate in
72 -- arbitrary order. It does not cover all the language constructs which can
73 -- be evaluated in arbitrary order but the subset needed for AI05-0144.
74
75 Has_Arbitrary_Evaluation_Order : constant array (Node_Kind) of Boolean :=
76 (N_Aggregate => True,
77 N_Assignment_Statement => True,
78 N_Entry_Call_Statement => True,
79 N_Extension_Aggregate => True,
80 N_Full_Type_Declaration => True,
81 N_Indexed_Component => True,
82 N_Object_Declaration => True,
83 N_Pragma => True,
84 N_Range => True,
85 N_Slice => True,
86 N_Array_Type_Definition => True,
87 N_Membership_Test => True,
88 N_Binary_Op => True,
89 N_Subprogram_Call => True,
90 others => False);
91
92 -- The following table enumerates the nodes on which we stop climbing when
93 -- locating the outermost Ada construct that can be evaluated in arbitrary
94 -- order.
95
96 Stop_Subtree_Climbing : constant array (Node_Kind) of Boolean :=
97 (N_Aggregate => True,
98 N_Assignment_Statement => True,
99 N_Entry_Call_Statement => True,
100 N_Extended_Return_Statement => True,
101 N_Extension_Aggregate => True,
102 N_Full_Type_Declaration => True,
103 N_Object_Declaration => True,
104 N_Object_Renaming_Declaration => True,
105 N_Package_Specification => True,
106 N_Pragma => True,
107 N_Procedure_Call_Statement => True,
108 N_Simple_Return_Statement => True,
109 N_Has_Condition => True,
110 others => False);
111
112 -----------------------
113 -- Local Subprograms --
114 -----------------------
115
116 procedure Analyze_Concatenation_Rest (N : Node_Id);
117 -- Does the "rest" of the work of Analyze_Concatenation, after the left
118 -- operand has been analyzed. See Analyze_Concatenation for details.
119
120 procedure Analyze_Expression (N : Node_Id);
121 -- For expressions that are not names, this is just a call to analyze. If
122 -- the expression is a name, it may be a call to a parameterless function,
123 -- and if so must be converted into an explicit call node and analyzed as
124 -- such. This deproceduring must be done during the first pass of overload
125 -- resolution, because otherwise a procedure call with overloaded actuals
126 -- may fail to resolve.
127
128 procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id);
129 -- Analyze a call of the form "+"(x, y), etc. The prefix of the call is an
130 -- operator name or an expanded name whose selector is an operator name,
131 -- and one possible interpretation is as a predefined operator.
132
133 procedure Analyze_Overloaded_Selected_Component (N : Node_Id);
134 -- If the prefix of a selected_component is overloaded, the proper
135 -- interpretation that yields a record type with the proper selector
136 -- name must be selected.
137
138 procedure Analyze_User_Defined_Binary_Op (N : Node_Id; Op_Id : Entity_Id);
139 -- Procedure to analyze a user defined binary operator, which is resolved
140 -- like a function, but instead of a list of actuals it is presented
141 -- with the left and right operands of an operator node.
142
143 procedure Analyze_User_Defined_Unary_Op (N : Node_Id; Op_Id : Entity_Id);
144 -- Procedure to analyze a user defined unary operator, which is resolved
145 -- like a function, but instead of a list of actuals, it is presented with
146 -- the operand of the operator node.
147
148 procedure Ambiguous_Operands (N : Node_Id);
149 -- For equality, membership, and comparison operators with overloaded
150 -- arguments, list possible interpretations.
151
152 procedure Analyze_One_Call
153 (N : Node_Id;
154 Nam : Entity_Id;
155 Report : Boolean;
156 Success : out Boolean;
157 Skip_First : Boolean := False);
158 -- Check one interpretation of an overloaded subprogram name for
159 -- compatibility with the types of the actuals in a call. If there is a
160 -- single interpretation which does not match, post error if Report is
161 -- set to True.
162 --
163 -- Nam is the entity that provides the formals against which the actuals
164 -- are checked. Nam is either the name of a subprogram, or the internal
165 -- subprogram type constructed for an access_to_subprogram. If the actuals
166 -- are compatible with Nam, then Nam is added to the list of candidate
167 -- interpretations for N, and Success is set to True.
168 --
169 -- The flag Skip_First is used when analyzing a call that was rewritten
170 -- from object notation. In this case the first actual may have to receive
171 -- an explicit dereference, depending on the first formal of the operation
172 -- being called. The caller will have verified that the object is legal
173 -- for the call. If the remaining parameters match, the first parameter
174 -- will rewritten as a dereference if needed, prior to completing analysis.
175
176 procedure Check_Misspelled_Selector
177 (Prefix : Entity_Id;
178 Sel : Node_Id);
179 -- Give possible misspelling message if Sel seems likely to be a mis-
180 -- spelling of one of the selectors of the Prefix. This is called by
181 -- Analyze_Selected_Component after producing an invalid selector error
182 -- message.
183
184 function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean;
185 -- Verify that type T is declared in scope S. Used to find interpretations
186 -- for operators given by expanded names. This is abstracted as a separate
187 -- function to handle extensions to System, where S is System, but T is
188 -- declared in the extension.
189
190 procedure Find_Arithmetic_Types
191 (L, R : Node_Id;
192 Op_Id : Entity_Id;
193 N : Node_Id);
194 -- L and R are the operands of an arithmetic operator. Find consistent
195 -- pairs of interpretations for L and R that have a numeric type consistent
196 -- with the semantics of the operator.
197
198 procedure Find_Comparison_Types
199 (L, R : Node_Id;
200 Op_Id : Entity_Id;
201 N : Node_Id);
202 -- L and R are operands of a comparison operator. Find consistent pairs of
203 -- interpretations for L and R.
204
205 procedure Find_Concatenation_Types
206 (L, R : Node_Id;
207 Op_Id : Entity_Id;
208 N : Node_Id);
209 -- For the four varieties of concatenation
210
211 procedure Find_Equality_Types
212 (L, R : Node_Id;
213 Op_Id : Entity_Id;
214 N : Node_Id);
215 -- Ditto for equality operators
216
217 procedure Find_Boolean_Types
218 (L, R : Node_Id;
219 Op_Id : Entity_Id;
220 N : Node_Id);
221 -- Ditto for binary logical operations
222
223 procedure Find_Negation_Types
224 (R : Node_Id;
225 Op_Id : Entity_Id;
226 N : Node_Id);
227 -- Find consistent interpretation for operand of negation operator
228
229 procedure Find_Non_Universal_Interpretations
230 (N : Node_Id;
231 R : Node_Id;
232 Op_Id : Entity_Id;
233 T1 : Entity_Id);
234 -- For equality and comparison operators, the result is always boolean,
235 -- and the legality of the operation is determined from the visibility
236 -- of the operand types. If one of the operands has a universal interpre-
237 -- tation, the legality check uses some compatible non-universal
238 -- interpretation of the other operand. N can be an operator node, or
239 -- a function call whose name is an operator designator. Any_Access, which
240 -- is the initial type of the literal NULL, is a universal type for the
241 -- purpose of this routine.
242
243 function Find_Primitive_Operation (N : Node_Id) return Boolean;
244 -- Find candidate interpretations for the name Obj.Proc when it appears
245 -- in a subprogram renaming declaration.
246
247 procedure Find_Unary_Types
248 (R : Node_Id;
249 Op_Id : Entity_Id;
250 N : Node_Id);
251 -- Unary arithmetic types: plus, minus, abs
252
253 procedure Check_Arithmetic_Pair
254 (T1, T2 : Entity_Id;
255 Op_Id : Entity_Id;
256 N : Node_Id);
257 -- Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid types
258 -- for left and right operand. Determine whether they constitute a valid
259 -- pair for the given operator, and record the corresponding interpretation
260 -- of the operator node. The node N may be an operator node (the usual
261 -- case) or a function call whose prefix is an operator designator. In
262 -- both cases Op_Id is the operator name itself.
263
264 procedure Diagnose_Call (N : Node_Id; Nam : Node_Id);
265 -- Give detailed information on overloaded call where none of the
266 -- interpretations match. N is the call node, Nam the designator for
267 -- the overloaded entity being called.
268
269 function Junk_Operand (N : Node_Id) return Boolean;
270 -- Test for an operand that is an inappropriate entity (e.g. a package
271 -- name or a label). If so, issue an error message and return True. If
272 -- the operand is not an inappropriate entity kind, return False.
273
274 procedure Operator_Check (N : Node_Id);
275 -- Verify that an operator has received some valid interpretation. If none
276 -- was found, determine whether a use clause would make the operation
277 -- legal. The variable Candidate_Type (defined in Sem_Type) is set for
278 -- every type compatible with the operator, even if the operator for the
279 -- type is not directly visible. The routine uses this type to emit a more
280 -- informative message.
281
282 function Process_Implicit_Dereference_Prefix
283 (E : Entity_Id;
284 P : Node_Id) return Entity_Id;
285 -- Called when P is the prefix of an implicit dereference, denoting an
286 -- object E. The function returns the designated type of the prefix, taking
287 -- into account that the designated type of an anonymous access type may be
288 -- a limited view, when the non-limited view is visible.
289 --
290 -- If in semantics only mode (-gnatc or generic), the function also records
291 -- that the prefix is a reference to E, if any. Normally, such a reference
292 -- is generated only when the implicit dereference is expanded into an
293 -- explicit one, but for consistency we must generate the reference when
294 -- expansion is disabled as well.
295
296 procedure Remove_Abstract_Operations (N : Node_Id);
297 -- Ada 2005: implementation of AI-310. An abstract non-dispatching
298 -- operation is not a candidate interpretation.
299
300 function Try_Container_Indexing
301 (N : Node_Id;
302 Prefix : Node_Id;
303 Exprs : List_Id) return Boolean;
304 -- AI05-0139: Generalized indexing to support iterators over containers
305
306 function Try_Indexed_Call
307 (N : Node_Id;
308 Nam : Entity_Id;
309 Typ : Entity_Id;
310 Skip_First : Boolean) return Boolean;
311 -- If a function has defaults for all its actuals, a call to it may in fact
312 -- be an indexing on the result of the call. Try_Indexed_Call attempts the
313 -- interpretation as an indexing, prior to analysis as a call. If both are
314 -- possible, the node is overloaded with both interpretations (same symbol
315 -- but two different types). If the call is written in prefix form, the
316 -- prefix becomes the first parameter in the call, and only the remaining
317 -- actuals must be checked for the presence of defaults.
318
319 function Try_Indirect_Call
320 (N : Node_Id;
321 Nam : Entity_Id;
322 Typ : Entity_Id) return Boolean;
323 -- Similarly, a function F that needs no actuals can return an access to a
324 -- subprogram, and the call F (X) interpreted as F.all (X). In this case
325 -- the call may be overloaded with both interpretations.
326
327 function Try_Object_Operation
328 (N : Node_Id;
329 CW_Test_Only : Boolean := False) return Boolean;
330 -- Ada 2005 (AI-252): Support the object.operation notation. If node N
331 -- is a call in this notation, it is transformed into a normal subprogram
332 -- call where the prefix is a parameter, and True is returned. If node
333 -- N is not of this form, it is unchanged, and False is returned. If
334 -- CW_Test_Only is true then N is an N_Selected_Component node which
335 -- is part of a call to an entry or procedure of a tagged concurrent
336 -- type and this routine is invoked to search for class-wide subprograms
337 -- conflicting with the target entity.
338
339 procedure wpo (T : Entity_Id);
340 pragma Warnings (Off, wpo);
341 -- Used for debugging: obtain list of primitive operations even if
342 -- type is not frozen and dispatch table is not built yet.
343
344 ------------------------
345 -- Ambiguous_Operands --
346 ------------------------
347
348 procedure Ambiguous_Operands (N : Node_Id) is
349 procedure List_Operand_Interps (Opnd : Node_Id);
350
351 --------------------------
352 -- List_Operand_Interps --
353 --------------------------
354
355 procedure List_Operand_Interps (Opnd : Node_Id) is
356 Nam : Node_Id;
357 Err : Node_Id := N;
358
359 begin
360 if Is_Overloaded (Opnd) then
361 if Nkind (Opnd) in N_Op then
362 Nam := Opnd;
363
364 elsif Nkind (Opnd) = N_Function_Call then
365 Nam := Name (Opnd);
366
367 elsif Ada_Version >= Ada_2012 then
368 declare
369 It : Interp;
370 I : Interp_Index;
371
372 begin
373 Get_First_Interp (Opnd, I, It);
374 while Present (It.Nam) loop
375 if Has_Implicit_Dereference (It.Typ) then
376 Error_Msg_N
377 ("can be interpreted as implicit dereference", Opnd);
378 return;
379 end if;
380
381 Get_Next_Interp (I, It);
382 end loop;
383 end;
384
385 return;
386 end if;
387
388 else
389 return;
390 end if;
391
392 if Opnd = Left_Opnd (N) then
393 Error_Msg_N
394 ("\left operand has the following interpretations", N);
395 else
396 Error_Msg_N
397 ("\right operand has the following interpretations", N);
398 Err := Opnd;
399 end if;
400
401 List_Interps (Nam, Err);
402 end List_Operand_Interps;
403
404 -- Start of processing for Ambiguous_Operands
405
406 begin
407 if Nkind (N) in N_Membership_Test then
408 Error_Msg_N ("ambiguous operands for membership", N);
409
410 elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then
411 Error_Msg_N ("ambiguous operands for equality", N);
412
413 else
414 Error_Msg_N ("ambiguous operands for comparison", N);
415 end if;
416
417 if All_Errors_Mode then
418 List_Operand_Interps (Left_Opnd (N));
419 List_Operand_Interps (Right_Opnd (N));
420 else
421 Error_Msg_N ("\use -gnatf switch for details", N);
422 end if;
423 end Ambiguous_Operands;
424
425 -----------------------
426 -- Analyze_Aggregate --
427 -----------------------
428
429 -- Most of the analysis of Aggregates requires that the type be known,
430 -- and is therefore put off until resolution.
431
432 procedure Analyze_Aggregate (N : Node_Id) is
433 begin
434 if No (Etype (N)) then
435 Set_Etype (N, Any_Composite);
436 end if;
437 end Analyze_Aggregate;
438
439 -----------------------
440 -- Analyze_Allocator --
441 -----------------------
442
443 procedure Analyze_Allocator (N : Node_Id) is
444 Loc : constant Source_Ptr := Sloc (N);
445 Sav_Errs : constant Nat := Serious_Errors_Detected;
446 E : Node_Id := Expression (N);
447 Acc_Type : Entity_Id;
448 Type_Id : Entity_Id;
449 P : Node_Id;
450 C : Node_Id;
451 Onode : Node_Id;
452
453 begin
454 Check_SPARK_05_Restriction ("allocator is not allowed", N);
455
456 -- Deal with allocator restrictions
457
458 -- In accordance with H.4(7), the No_Allocators restriction only applies
459 -- to user-written allocators. The same consideration applies to the
460 -- No_Standard_Allocators_Before_Elaboration restriction.
461
462 if Comes_From_Source (N) then
463 Check_Restriction (No_Allocators, N);
464
465 -- Processing for No_Standard_Allocators_After_Elaboration, loop to
466 -- look at enclosing context, checking task/main subprogram case.
467
468 C := N;
469 P := Parent (C);
470 while Present (P) loop
471
472 -- For the task case we need a handled sequence of statements,
473 -- where the occurrence of the allocator is within the statements
474 -- and the parent is a task body
475
476 if Nkind (P) = N_Handled_Sequence_Of_Statements
477 and then Is_List_Member (C)
478 and then List_Containing (C) = Statements (P)
479 then
480 Onode := Original_Node (Parent (P));
481
482 -- Check for allocator within task body, this is a definite
483 -- violation of No_Allocators_After_Elaboration we can detect
484 -- at compile time.
485
486 if Nkind (Onode) = N_Task_Body then
487 Check_Restriction
488 (No_Standard_Allocators_After_Elaboration, N);
489 exit;
490 end if;
491 end if;
492
493 -- The other case is appearance in a subprogram body. This is
494 -- a violation if this is a library level subprogram with no
495 -- parameters. Note that this is now a static error even if the
496 -- subprogram is not the main program (this is a change, in an
497 -- earlier version only the main program was affected, and the
498 -- check had to be done in the binder.
499
500 if Nkind (P) = N_Subprogram_Body
501 and then Nkind (Parent (P)) = N_Compilation_Unit
502 and then No (Parameter_Specifications (Specification (P)))
503 then
504 Check_Restriction
505 (No_Standard_Allocators_After_Elaboration, N);
506 end if;
507
508 C := P;
509 P := Parent (C);
510 end loop;
511 end if;
512
513 -- Ada 2012 (AI05-0111-3): Analyze the subpool_specification, if
514 -- any. The expected type for the name is any type. A non-overloading
515 -- rule then requires it to be of a type descended from
516 -- System.Storage_Pools.Subpools.Subpool_Handle.
517
518 -- This isn't exactly what the AI says, but it seems to be the right
519 -- rule. The AI should be fixed.???
520
521 declare
522 Subpool : constant Node_Id := Subpool_Handle_Name (N);
523
524 begin
525 if Present (Subpool) then
526 Analyze (Subpool);
527
528 if Is_Overloaded (Subpool) then
529 Error_Msg_N ("ambiguous subpool handle", Subpool);
530 end if;
531
532 -- Check that Etype (Subpool) is descended from Subpool_Handle
533
534 Resolve (Subpool);
535 end if;
536 end;
537
538 -- Analyze the qualified expression or subtype indication
539
540 if Nkind (E) = N_Qualified_Expression then
541 Acc_Type := Create_Itype (E_Allocator_Type, N);
542 Set_Etype (Acc_Type, Acc_Type);
543 Find_Type (Subtype_Mark (E));
544
545 -- Analyze the qualified expression, and apply the name resolution
546 -- rule given in 4.7(3).
547
548 Analyze (E);
549 Type_Id := Etype (E);
550 Set_Directly_Designated_Type (Acc_Type, Type_Id);
551
552 -- A qualified expression requires an exact match of the type,
553 -- class-wide matching is not allowed.
554
555 -- if Is_Class_Wide_Type (Type_Id)
556 -- and then Base_Type
557 -- (Etype (Expression (E))) /= Base_Type (Type_Id)
558 -- then
559 -- Wrong_Type (Expression (E), Type_Id);
560 -- end if;
561
562 -- We don't analyze the qualified expression itself because it's
563 -- part of the allocator. It is fully analyzed and resolved when
564 -- the allocator is resolved with the context type.
565
566 Set_Etype (E, Type_Id);
567
568 -- Case where allocator has a subtype indication
569
570 else
571 declare
572 Def_Id : Entity_Id;
573 Base_Typ : Entity_Id;
574
575 begin
576 -- If the allocator includes a N_Subtype_Indication then a
577 -- constraint is present, otherwise the node is a subtype mark.
578 -- Introduce an explicit subtype declaration into the tree
579 -- defining some anonymous subtype and rewrite the allocator to
580 -- use this subtype rather than the subtype indication.
581
582 -- It is important to introduce the explicit subtype declaration
583 -- so that the bounds of the subtype indication are attached to
584 -- the tree in case the allocator is inside a generic unit.
585
586 -- Finally, if there is no subtype indication and the type is
587 -- a tagged unconstrained type with discriminants, the designated
588 -- object is constrained by their default values, and it is
589 -- simplest to introduce an explicit constraint now. In some cases
590 -- this is done during expansion, but freeze actions are certain
591 -- to be emitted in the proper order if constraint is explicit.
592
593 if Is_Entity_Name (E) and then Expander_Active then
594 Find_Type (E);
595 Type_Id := Entity (E);
596
597 if Is_Tagged_Type (Type_Id)
598 and then Has_Discriminants (Type_Id)
599 and then not Is_Constrained (Type_Id)
600 and then
601 Present
602 (Discriminant_Default_Value
603 (First_Discriminant (Type_Id)))
604 then
605 declare
606 Constr : constant List_Id := New_List;
607 Loc : constant Source_Ptr := Sloc (E);
608 Discr : Entity_Id := First_Discriminant (Type_Id);
609
610 begin
611 if Present (Discriminant_Default_Value (Discr)) then
612 while Present (Discr) loop
613 Append (Discriminant_Default_Value (Discr), Constr);
614 Next_Discriminant (Discr);
615 end loop;
616
617 Rewrite (E,
618 Make_Subtype_Indication (Loc,
619 Subtype_Mark => New_Occurrence_Of (Type_Id, Loc),
620 Constraint =>
621 Make_Index_Or_Discriminant_Constraint (Loc,
622 Constraints => Constr)));
623 end if;
624 end;
625 end if;
626 end if;
627
628 if Nkind (E) = N_Subtype_Indication then
629
630 -- A constraint is only allowed for a composite type in Ada
631 -- 95. In Ada 83, a constraint is also allowed for an
632 -- access-to-composite type, but the constraint is ignored.
633
634 Find_Type (Subtype_Mark (E));
635 Base_Typ := Entity (Subtype_Mark (E));
636
637 if Is_Elementary_Type (Base_Typ) then
638 if not (Ada_Version = Ada_83
639 and then Is_Access_Type (Base_Typ))
640 then
641 Error_Msg_N ("constraint not allowed here", E);
642
643 if Nkind (Constraint (E)) =
644 N_Index_Or_Discriminant_Constraint
645 then
646 Error_Msg_N -- CODEFIX
647 ("\if qualified expression was meant, " &
648 "use apostrophe", Constraint (E));
649 end if;
650 end if;
651
652 -- Get rid of the bogus constraint:
653
654 Rewrite (E, New_Copy_Tree (Subtype_Mark (E)));
655 Analyze_Allocator (N);
656 return;
657 end if;
658
659 if Expander_Active then
660 Def_Id := Make_Temporary (Loc, 'S');
661
662 Insert_Action (E,
663 Make_Subtype_Declaration (Loc,
664 Defining_Identifier => Def_Id,
665 Subtype_Indication => Relocate_Node (E)));
666
667 if Sav_Errs /= Serious_Errors_Detected
668 and then Nkind (Constraint (E)) =
669 N_Index_Or_Discriminant_Constraint
670 then
671 Error_Msg_N -- CODEFIX
672 ("if qualified expression was meant, "
673 & "use apostrophe!", Constraint (E));
674 end if;
675
676 E := New_Occurrence_Of (Def_Id, Loc);
677 Rewrite (Expression (N), E);
678 end if;
679 end if;
680
681 Type_Id := Process_Subtype (E, N);
682 Acc_Type := Create_Itype (E_Allocator_Type, N);
683 Set_Etype (Acc_Type, Acc_Type);
684 Set_Directly_Designated_Type (Acc_Type, Type_Id);
685 Check_Fully_Declared (Type_Id, N);
686
687 -- Ada 2005 (AI-231): If the designated type is itself an access
688 -- type that excludes null, its default initialization will
689 -- be a null object, and we can insert an unconditional raise
690 -- before the allocator.
691
692 -- Ada 2012 (AI-104): A not null indication here is altogether
693 -- illegal.
694
695 if Can_Never_Be_Null (Type_Id) then
696 declare
697 Not_Null_Check : constant Node_Id :=
698 Make_Raise_Constraint_Error (Sloc (E),
699 Reason => CE_Null_Not_Allowed);
700
701 begin
702 if Expander_Active then
703 Insert_Action (N, Not_Null_Check);
704 Analyze (Not_Null_Check);
705
706 elsif Warn_On_Ada_2012_Compatibility then
707 Error_Msg_N
708 ("null value not allowed here in Ada 2012?y?", E);
709 end if;
710 end;
711 end if;
712
713 -- Check for missing initialization. Skip this check if we already
714 -- had errors on analyzing the allocator, since in that case these
715 -- are probably cascaded errors.
716
717 if not Is_Definite_Subtype (Type_Id)
718 and then Serious_Errors_Detected = Sav_Errs
719 then
720 -- The build-in-place machinery may produce an allocator when
721 -- the designated type is indefinite but the underlying type is
722 -- not. In this case the unknown discriminants are meaningless
723 -- and should not trigger error messages. Check the parent node
724 -- because the allocator is marked as coming from source.
725
726 if Present (Underlying_Type (Type_Id))
727 and then Is_Definite_Subtype (Underlying_Type (Type_Id))
728 and then not Comes_From_Source (Parent (N))
729 then
730 null;
731
732 elsif Is_Class_Wide_Type (Type_Id) then
733 Error_Msg_N
734 ("initialization required in class-wide allocation", N);
735
736 else
737 if Ada_Version < Ada_2005
738 and then Is_Limited_Type (Type_Id)
739 then
740 Error_Msg_N ("unconstrained allocation not allowed", N);
741
742 if Is_Array_Type (Type_Id) then
743 Error_Msg_N
744 ("\constraint with array bounds required", N);
745
746 elsif Has_Unknown_Discriminants (Type_Id) then
747 null;
748
749 else pragma Assert (Has_Discriminants (Type_Id));
750 Error_Msg_N
751 ("\constraint with discriminant values required", N);
752 end if;
753
754 -- Limited Ada 2005 and general non-limited case
755
756 else
757 Error_Msg_N
758 ("uninitialized unconstrained allocation not "
759 & "allowed", N);
760
761 if Is_Array_Type (Type_Id) then
762 Error_Msg_N
763 ("\qualified expression or constraint with "
764 & "array bounds required", N);
765
766 elsif Has_Unknown_Discriminants (Type_Id) then
767 Error_Msg_N ("\qualified expression required", N);
768
769 else pragma Assert (Has_Discriminants (Type_Id));
770 Error_Msg_N
771 ("\qualified expression or constraint with "
772 & "discriminant values required", N);
773 end if;
774 end if;
775 end if;
776 end if;
777 end;
778 end if;
779
780 if Is_Abstract_Type (Type_Id) then
781 Error_Msg_N ("cannot allocate abstract object", E);
782 end if;
783
784 if Has_Task (Designated_Type (Acc_Type)) then
785 Check_Restriction (No_Tasking, N);
786 Check_Restriction (Max_Tasks, N);
787 Check_Restriction (No_Task_Allocators, N);
788 end if;
789
790 -- Check restriction against dynamically allocated protected objects
791
792 if Has_Protected (Designated_Type (Acc_Type)) then
793 Check_Restriction (No_Protected_Type_Allocators, N);
794 end if;
795
796 -- AI05-0013-1: No_Nested_Finalization forbids allocators if the access
797 -- type is nested, and the designated type needs finalization. The rule
798 -- is conservative in that class-wide types need finalization.
799
800 if Needs_Finalization (Designated_Type (Acc_Type))
801 and then not Is_Library_Level_Entity (Acc_Type)
802 then
803 Check_Restriction (No_Nested_Finalization, N);
804 end if;
805
806 -- Check that an allocator of a nested access type doesn't create a
807 -- protected object when restriction No_Local_Protected_Objects applies.
808
809 if Has_Protected (Designated_Type (Acc_Type))
810 and then not Is_Library_Level_Entity (Acc_Type)
811 then
812 Check_Restriction (No_Local_Protected_Objects, N);
813 end if;
814
815 -- Likewise for No_Local_Timing_Events
816
817 if Has_Timing_Event (Designated_Type (Acc_Type))
818 and then not Is_Library_Level_Entity (Acc_Type)
819 then
820 Check_Restriction (No_Local_Timing_Events, N);
821 end if;
822
823 -- If the No_Streams restriction is set, check that the type of the
824 -- object is not, and does not contain, any subtype derived from
825 -- Ada.Streams.Root_Stream_Type. Note that we guard the call to
826 -- Has_Stream just for efficiency reasons. There is no point in
827 -- spending time on a Has_Stream check if the restriction is not set.
828
829 if Restriction_Check_Required (No_Streams) then
830 if Has_Stream (Designated_Type (Acc_Type)) then
831 Check_Restriction (No_Streams, N);
832 end if;
833 end if;
834
835 Set_Etype (N, Acc_Type);
836
837 if not Is_Library_Level_Entity (Acc_Type) then
838 Check_Restriction (No_Local_Allocators, N);
839 end if;
840
841 if Serious_Errors_Detected > Sav_Errs then
842 Set_Error_Posted (N);
843 Set_Etype (N, Any_Type);
844 end if;
845 end Analyze_Allocator;
846
847 ---------------------------
848 -- Analyze_Arithmetic_Op --
849 ---------------------------
850
851 procedure Analyze_Arithmetic_Op (N : Node_Id) is
852 L : constant Node_Id := Left_Opnd (N);
853 R : constant Node_Id := Right_Opnd (N);
854 Op_Id : Entity_Id;
855
856 begin
857 Candidate_Type := Empty;
858 Analyze_Expression (L);
859 Analyze_Expression (R);
860
861 -- If the entity is already set, the node is the instantiation of a
862 -- generic node with a non-local reference, or was manufactured by a
863 -- call to Make_Op_xxx. In either case the entity is known to be valid,
864 -- and we do not need to collect interpretations, instead we just get
865 -- the single possible interpretation.
866
867 Op_Id := Entity (N);
868
869 if Present (Op_Id) then
870 if Ekind (Op_Id) = E_Operator then
871
872 if Nkind_In (N, N_Op_Divide, N_Op_Mod, N_Op_Multiply, N_Op_Rem)
873 and then Treat_Fixed_As_Integer (N)
874 then
875 null;
876 else
877 Set_Etype (N, Any_Type);
878 Find_Arithmetic_Types (L, R, Op_Id, N);
879 end if;
880
881 else
882 Set_Etype (N, Any_Type);
883 Add_One_Interp (N, Op_Id, Etype (Op_Id));
884 end if;
885
886 -- Entity is not already set, so we do need to collect interpretations
887
888 else
889 Set_Etype (N, Any_Type);
890
891 Op_Id := Get_Name_Entity_Id (Chars (N));
892 while Present (Op_Id) loop
893 if Ekind (Op_Id) = E_Operator
894 and then Present (Next_Entity (First_Entity (Op_Id)))
895 then
896 Find_Arithmetic_Types (L, R, Op_Id, N);
897
898 -- The following may seem superfluous, because an operator cannot
899 -- be generic, but this ignores the cleverness of the author of
900 -- ACVC bc1013a.
901
902 elsif Is_Overloadable (Op_Id) then
903 Analyze_User_Defined_Binary_Op (N, Op_Id);
904 end if;
905
906 Op_Id := Homonym (Op_Id);
907 end loop;
908 end if;
909
910 Operator_Check (N);
911 Check_Function_Writable_Actuals (N);
912 end Analyze_Arithmetic_Op;
913
914 ------------------
915 -- Analyze_Call --
916 ------------------
917
918 -- Function, procedure, and entry calls are checked here. The Name in
919 -- the call may be overloaded. The actuals have been analyzed and may
920 -- themselves be overloaded. On exit from this procedure, the node N
921 -- may have zero, one or more interpretations. In the first case an
922 -- error message is produced. In the last case, the node is flagged
923 -- as overloaded and the interpretations are collected in All_Interp.
924
925 -- If the name is an Access_To_Subprogram, it cannot be overloaded, but
926 -- the type-checking is similar to that of other calls.
927
928 procedure Analyze_Call (N : Node_Id) is
929 Actuals : constant List_Id := Parameter_Associations (N);
930 Nam : Node_Id;
931 X : Interp_Index;
932 It : Interp;
933 Nam_Ent : Entity_Id;
934 Success : Boolean := False;
935
936 Deref : Boolean := False;
937 -- Flag indicates whether an interpretation of the prefix is a
938 -- parameterless call that returns an access_to_subprogram.
939
940 procedure Check_Mixed_Parameter_And_Named_Associations;
941 -- Check that parameter and named associations are not mixed. This is
942 -- a restriction in SPARK mode.
943
944 procedure Check_Writable_Actuals (N : Node_Id);
945 -- If the call has out or in-out parameters then mark its outermost
946 -- enclosing construct as a node on which the writable actuals check
947 -- must be performed.
948
949 function Name_Denotes_Function return Boolean;
950 -- If the type of the name is an access to subprogram, this may be the
951 -- type of a name, or the return type of the function being called. If
952 -- the name is not an entity then it can denote a protected function.
953 -- Until we distinguish Etype from Return_Type, we must use this routine
954 -- to resolve the meaning of the name in the call.
955
956 procedure No_Interpretation;
957 -- Output error message when no valid interpretation exists
958
959 --------------------------------------------------
960 -- Check_Mixed_Parameter_And_Named_Associations --
961 --------------------------------------------------
962
963 procedure Check_Mixed_Parameter_And_Named_Associations is
964 Actual : Node_Id;
965 Named_Seen : Boolean;
966
967 begin
968 Named_Seen := False;
969
970 Actual := First (Actuals);
971 while Present (Actual) loop
972 case Nkind (Actual) is
973 when N_Parameter_Association =>
974 if Named_Seen then
975 Check_SPARK_05_Restriction
976 ("named association cannot follow positional one",
977 Actual);
978 exit;
979 end if;
980
981 when others =>
982 Named_Seen := True;
983 end case;
984
985 Next (Actual);
986 end loop;
987 end Check_Mixed_Parameter_And_Named_Associations;
988
989 ----------------------------
990 -- Check_Writable_Actuals --
991 ----------------------------
992
993 -- The identification of conflicts in calls to functions with writable
994 -- actuals is performed in the analysis phase of the front end to ensure
995 -- that it reports exactly the same errors compiling with and without
996 -- expansion enabled. It is performed in two stages:
997
998 -- 1) When a call to a function with out-mode parameters is found,
999 -- we climb to the outermost enclosing construct that can be
1000 -- evaluated in arbitrary order and we mark it with the flag
1001 -- Check_Actuals.
1002
1003 -- 2) When the analysis of the marked node is complete, we traverse
1004 -- its decorated subtree searching for conflicts (see function
1005 -- Sem_Util.Check_Function_Writable_Actuals).
1006
1007 -- The unique exception to this general rule is for aggregates, since
1008 -- their analysis is performed by the front end in the resolution
1009 -- phase. For aggregates we do not climb to their enclosing construct:
1010 -- we restrict the analysis to the subexpressions initializing the
1011 -- aggregate components.
1012
1013 -- This implies that the analysis of expressions containing aggregates
1014 -- is not complete, since there may be conflicts on writable actuals
1015 -- involving subexpressions of the enclosing logical or arithmetic
1016 -- expressions. However, we cannot wait and perform the analysis when
1017 -- the whole subtree is resolved, since the subtrees may be transformed,
1018 -- thus adding extra complexity and computation cost to identify and
1019 -- report exactly the same errors compiling with and without expansion
1020 -- enabled.
1021
1022 procedure Check_Writable_Actuals (N : Node_Id) is
1023 begin
1024 if Comes_From_Source (N)
1025 and then Present (Get_Subprogram_Entity (N))
1026 and then Has_Out_Or_In_Out_Parameter (Get_Subprogram_Entity (N))
1027 then
1028 -- For procedures and entries there is no need to climb since
1029 -- we only need to check if the actuals of this call invoke
1030 -- functions whose out-mode parameters overlap.
1031
1032 if Nkind (N) /= N_Function_Call then
1033 Set_Check_Actuals (N);
1034
1035 -- For calls to functions we climb to the outermost enclosing
1036 -- construct where the out-mode actuals of this function may
1037 -- introduce conflicts.
1038
1039 else
1040 declare
1041 Outermost : Node_Id;
1042 P : Node_Id := N;
1043
1044 begin
1045 while Present (P) loop
1046
1047 -- For object declarations we can climb to the node from
1048 -- its object definition branch or from its initializing
1049 -- expression. We prefer to mark the child node as the
1050 -- outermost construct to avoid adding further complexity
1051 -- to the routine that will later take care of
1052 -- performing the writable actuals check.
1053
1054 if Has_Arbitrary_Evaluation_Order (Nkind (P))
1055 and then not Nkind_In (P, N_Assignment_Statement,
1056 N_Object_Declaration)
1057 then
1058 Outermost := P;
1059 end if;
1060
1061 -- Avoid climbing more than needed!
1062
1063 exit when Stop_Subtree_Climbing (Nkind (P))
1064 or else (Nkind (P) = N_Range
1065 and then not
1066 Nkind_In (Parent (P), N_In, N_Not_In));
1067
1068 P := Parent (P);
1069 end loop;
1070
1071 Set_Check_Actuals (Outermost);
1072 end;
1073 end if;
1074 end if;
1075 end Check_Writable_Actuals;
1076
1077 ---------------------------
1078 -- Name_Denotes_Function --
1079 ---------------------------
1080
1081 function Name_Denotes_Function return Boolean is
1082 begin
1083 if Is_Entity_Name (Nam) then
1084 return Ekind (Entity (Nam)) = E_Function;
1085 elsif Nkind (Nam) = N_Selected_Component then
1086 return Ekind (Entity (Selector_Name (Nam))) = E_Function;
1087 else
1088 return False;
1089 end if;
1090 end Name_Denotes_Function;
1091
1092 -----------------------
1093 -- No_Interpretation --
1094 -----------------------
1095
1096 procedure No_Interpretation is
1097 L : constant Boolean := Is_List_Member (N);
1098 K : constant Node_Kind := Nkind (Parent (N));
1099
1100 begin
1101 -- If the node is in a list whose parent is not an expression then it
1102 -- must be an attempted procedure call.
1103
1104 if L and then K not in N_Subexpr then
1105 if Ekind (Entity (Nam)) = E_Generic_Procedure then
1106 Error_Msg_NE
1107 ("must instantiate generic procedure& before call",
1108 Nam, Entity (Nam));
1109 else
1110 Error_Msg_N ("procedure or entry name expected", Nam);
1111 end if;
1112
1113 -- Check for tasking cases where only an entry call will do
1114
1115 elsif not L
1116 and then Nkind_In (K, N_Entry_Call_Alternative,
1117 N_Triggering_Alternative)
1118 then
1119 Error_Msg_N ("entry name expected", Nam);
1120
1121 -- Otherwise give general error message
1122
1123 else
1124 Error_Msg_N ("invalid prefix in call", Nam);
1125 end if;
1126 end No_Interpretation;
1127
1128 -- Start of processing for Analyze_Call
1129
1130 begin
1131 if Restriction_Check_Required (SPARK_05) then
1132 Check_Mixed_Parameter_And_Named_Associations;
1133 end if;
1134
1135 -- Initialize the type of the result of the call to the error type,
1136 -- which will be reset if the type is successfully resolved.
1137
1138 Set_Etype (N, Any_Type);
1139
1140 Nam := Name (N);
1141
1142 if not Is_Overloaded (Nam) then
1143
1144 -- Only one interpretation to check
1145
1146 if Ekind (Etype (Nam)) = E_Subprogram_Type then
1147 Nam_Ent := Etype (Nam);
1148
1149 -- If the prefix is an access_to_subprogram, this may be an indirect
1150 -- call. This is the case if the name in the call is not an entity
1151 -- name, or if it is a function name in the context of a procedure
1152 -- call. In this latter case, we have a call to a parameterless
1153 -- function that returns a pointer_to_procedure which is the entity
1154 -- being called. Finally, F (X) may be a call to a parameterless
1155 -- function that returns a pointer to a function with parameters.
1156 -- Note that if F returns an access-to-subprogram whose designated
1157 -- type is an array, F (X) cannot be interpreted as an indirect call
1158 -- through the result of the call to F.
1159
1160 elsif Is_Access_Type (Etype (Nam))
1161 and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type
1162 and then
1163 (not Name_Denotes_Function
1164 or else Nkind (N) = N_Procedure_Call_Statement
1165 or else
1166 (Nkind (Parent (N)) /= N_Explicit_Dereference
1167 and then Is_Entity_Name (Nam)
1168 and then No (First_Formal (Entity (Nam)))
1169 and then not
1170 Is_Array_Type (Etype (Designated_Type (Etype (Nam))))
1171 and then Present (Actuals)))
1172 then
1173 Nam_Ent := Designated_Type (Etype (Nam));
1174 Insert_Explicit_Dereference (Nam);
1175
1176 -- Selected component case. Simple entry or protected operation,
1177 -- where the entry name is given by the selector name.
1178
1179 elsif Nkind (Nam) = N_Selected_Component then
1180 Nam_Ent := Entity (Selector_Name (Nam));
1181
1182 if not Ekind_In (Nam_Ent, E_Entry,
1183 E_Entry_Family,
1184 E_Function,
1185 E_Procedure)
1186 then
1187 Error_Msg_N ("name in call is not a callable entity", Nam);
1188 Set_Etype (N, Any_Type);
1189 return;
1190 end if;
1191
1192 -- If the name is an Indexed component, it can be a call to a member
1193 -- of an entry family. The prefix must be a selected component whose
1194 -- selector is the entry. Analyze_Procedure_Call normalizes several
1195 -- kinds of call into this form.
1196
1197 elsif Nkind (Nam) = N_Indexed_Component then
1198 if Nkind (Prefix (Nam)) = N_Selected_Component then
1199 Nam_Ent := Entity (Selector_Name (Prefix (Nam)));
1200 else
1201 Error_Msg_N ("name in call is not a callable entity", Nam);
1202 Set_Etype (N, Any_Type);
1203 return;
1204 end if;
1205
1206 elsif not Is_Entity_Name (Nam) then
1207 Error_Msg_N ("name in call is not a callable entity", Nam);
1208 Set_Etype (N, Any_Type);
1209 return;
1210
1211 else
1212 Nam_Ent := Entity (Nam);
1213
1214 -- If not overloadable, this may be a generalized indexing
1215 -- operation with named associations. Rewrite again as an
1216 -- indexed component and analyze as container indexing.
1217
1218 if not Is_Overloadable (Nam_Ent) then
1219 if Present
1220 (Find_Value_Of_Aspect
1221 (Etype (Nam_Ent), Aspect_Constant_Indexing))
1222 then
1223 Replace (N,
1224 Make_Indexed_Component (Sloc (N),
1225 Prefix => Nam,
1226 Expressions => Parameter_Associations (N)));
1227
1228 if Try_Container_Indexing (N, Nam, Expressions (N)) then
1229 return;
1230 else
1231 No_Interpretation;
1232 end if;
1233
1234 else
1235 No_Interpretation;
1236 end if;
1237
1238 return;
1239 end if;
1240 end if;
1241
1242 -- Operations generated for RACW stub types are called only through
1243 -- dispatching, and can never be the static interpretation of a call.
1244
1245 if Is_RACW_Stub_Type_Operation (Nam_Ent) then
1246 No_Interpretation;
1247 return;
1248 end if;
1249
1250 Analyze_One_Call (N, Nam_Ent, True, Success);
1251
1252 -- If this is an indirect call, the return type of the access_to
1253 -- subprogram may be an incomplete type. At the point of the call,
1254 -- use the full type if available, and at the same time update the
1255 -- return type of the access_to_subprogram.
1256
1257 if Success
1258 and then Nkind (Nam) = N_Explicit_Dereference
1259 and then Ekind (Etype (N)) = E_Incomplete_Type
1260 and then Present (Full_View (Etype (N)))
1261 then
1262 Set_Etype (N, Full_View (Etype (N)));
1263 Set_Etype (Nam_Ent, Etype (N));
1264 end if;
1265
1266 -- Overloaded call
1267
1268 else
1269 -- An overloaded selected component must denote overloaded operations
1270 -- of a concurrent type. The interpretations are attached to the
1271 -- simple name of those operations.
1272
1273 if Nkind (Nam) = N_Selected_Component then
1274 Nam := Selector_Name (Nam);
1275 end if;
1276
1277 Get_First_Interp (Nam, X, It);
1278 while Present (It.Nam) loop
1279 Nam_Ent := It.Nam;
1280 Deref := False;
1281
1282 -- Name may be call that returns an access to subprogram, or more
1283 -- generally an overloaded expression one of whose interpretations
1284 -- yields an access to subprogram. If the name is an entity, we do
1285 -- not dereference, because the node is a call that returns the
1286 -- access type: note difference between f(x), where the call may
1287 -- return an access subprogram type, and f(x)(y), where the type
1288 -- returned by the call to f is implicitly dereferenced to analyze
1289 -- the outer call.
1290
1291 if Is_Access_Type (Nam_Ent) then
1292 Nam_Ent := Designated_Type (Nam_Ent);
1293
1294 elsif Is_Access_Type (Etype (Nam_Ent))
1295 and then
1296 (not Is_Entity_Name (Nam)
1297 or else Nkind (N) = N_Procedure_Call_Statement)
1298 and then Ekind (Designated_Type (Etype (Nam_Ent)))
1299 = E_Subprogram_Type
1300 then
1301 Nam_Ent := Designated_Type (Etype (Nam_Ent));
1302
1303 if Is_Entity_Name (Nam) then
1304 Deref := True;
1305 end if;
1306 end if;
1307
1308 -- If the call has been rewritten from a prefixed call, the first
1309 -- parameter has been analyzed, but may need a subsequent
1310 -- dereference, so skip its analysis now.
1311
1312 if N /= Original_Node (N)
1313 and then Nkind (Original_Node (N)) = Nkind (N)
1314 and then Nkind (Name (N)) /= Nkind (Name (Original_Node (N)))
1315 and then Present (Parameter_Associations (N))
1316 and then Present (Etype (First (Parameter_Associations (N))))
1317 then
1318 Analyze_One_Call
1319 (N, Nam_Ent, False, Success, Skip_First => True);
1320 else
1321 Analyze_One_Call (N, Nam_Ent, False, Success);
1322 end if;
1323
1324 -- If the interpretation succeeds, mark the proper type of the
1325 -- prefix (any valid candidate will do). If not, remove the
1326 -- candidate interpretation. This only needs to be done for
1327 -- overloaded protected operations, for other entities disambi-
1328 -- guation is done directly in Resolve.
1329
1330 if Success then
1331 if Deref
1332 and then Nkind (Parent (N)) /= N_Explicit_Dereference
1333 then
1334 Set_Entity (Nam, It.Nam);
1335 Insert_Explicit_Dereference (Nam);
1336 Set_Etype (Nam, Nam_Ent);
1337
1338 else
1339 Set_Etype (Nam, It.Typ);
1340 end if;
1341
1342 elsif Nkind_In (Name (N), N_Selected_Component,
1343 N_Function_Call)
1344 then
1345 Remove_Interp (X);
1346 end if;
1347
1348 Get_Next_Interp (X, It);
1349 end loop;
1350
1351 -- If the name is the result of a function call, it can only be a
1352 -- call to a function returning an access to subprogram. Insert
1353 -- explicit dereference.
1354
1355 if Nkind (Nam) = N_Function_Call then
1356 Insert_Explicit_Dereference (Nam);
1357 end if;
1358
1359 if Etype (N) = Any_Type then
1360
1361 -- None of the interpretations is compatible with the actuals
1362
1363 Diagnose_Call (N, Nam);
1364
1365 -- Special checks for uninstantiated put routines
1366
1367 if Nkind (N) = N_Procedure_Call_Statement
1368 and then Is_Entity_Name (Nam)
1369 and then Chars (Nam) = Name_Put
1370 and then List_Length (Actuals) = 1
1371 then
1372 declare
1373 Arg : constant Node_Id := First (Actuals);
1374 Typ : Entity_Id;
1375
1376 begin
1377 if Nkind (Arg) = N_Parameter_Association then
1378 Typ := Etype (Explicit_Actual_Parameter (Arg));
1379 else
1380 Typ := Etype (Arg);
1381 end if;
1382
1383 if Is_Signed_Integer_Type (Typ) then
1384 Error_Msg_N
1385 ("possible missing instantiation of "
1386 & "'Text_'I'O.'Integer_'I'O!", Nam);
1387
1388 elsif Is_Modular_Integer_Type (Typ) then
1389 Error_Msg_N
1390 ("possible missing instantiation of "
1391 & "'Text_'I'O.'Modular_'I'O!", Nam);
1392
1393 elsif Is_Floating_Point_Type (Typ) then
1394 Error_Msg_N
1395 ("possible missing instantiation of "
1396 & "'Text_'I'O.'Float_'I'O!", Nam);
1397
1398 elsif Is_Ordinary_Fixed_Point_Type (Typ) then
1399 Error_Msg_N
1400 ("possible missing instantiation of "
1401 & "'Text_'I'O.'Fixed_'I'O!", Nam);
1402
1403 elsif Is_Decimal_Fixed_Point_Type (Typ) then
1404 Error_Msg_N
1405 ("possible missing instantiation of "
1406 & "'Text_'I'O.'Decimal_'I'O!", Nam);
1407
1408 elsif Is_Enumeration_Type (Typ) then
1409 Error_Msg_N
1410 ("possible missing instantiation of "
1411 & "'Text_'I'O.'Enumeration_'I'O!", Nam);
1412 end if;
1413 end;
1414 end if;
1415
1416 elsif not Is_Overloaded (N)
1417 and then Is_Entity_Name (Nam)
1418 then
1419 -- Resolution yields a single interpretation. Verify that the
1420 -- reference has capitalization consistent with the declaration.
1421
1422 Set_Entity_With_Checks (Nam, Entity (Nam));
1423 Generate_Reference (Entity (Nam), Nam);
1424
1425 Set_Etype (Nam, Etype (Entity (Nam)));
1426 else
1427 Remove_Abstract_Operations (N);
1428 end if;
1429
1430 End_Interp_List;
1431 end if;
1432
1433 if Ada_Version >= Ada_2012 then
1434
1435 -- Check if the call contains a function with writable actuals
1436
1437 Check_Writable_Actuals (N);
1438
1439 -- If found and the outermost construct that can be evaluated in
1440 -- an arbitrary order is precisely this call, then check all its
1441 -- actuals.
1442
1443 Check_Function_Writable_Actuals (N);
1444 end if;
1445 end Analyze_Call;
1446
1447 -----------------------------
1448 -- Analyze_Case_Expression --
1449 -----------------------------
1450
1451 procedure Analyze_Case_Expression (N : Node_Id) is
1452 procedure Non_Static_Choice_Error (Choice : Node_Id);
1453 -- Error routine invoked by the generic instantiation below when
1454 -- the case expression has a non static choice.
1455
1456 package Case_Choices_Analysis is new
1457 Generic_Analyze_Choices
1458 (Process_Associated_Node => No_OP);
1459 use Case_Choices_Analysis;
1460
1461 package Case_Choices_Checking is new
1462 Generic_Check_Choices
1463 (Process_Empty_Choice => No_OP,
1464 Process_Non_Static_Choice => Non_Static_Choice_Error,
1465 Process_Associated_Node => No_OP);
1466 use Case_Choices_Checking;
1467
1468 -----------------------------
1469 -- Non_Static_Choice_Error --
1470 -----------------------------
1471
1472 procedure Non_Static_Choice_Error (Choice : Node_Id) is
1473 begin
1474 Flag_Non_Static_Expr
1475 ("choice given in case expression is not static!", Choice);
1476 end Non_Static_Choice_Error;
1477
1478 -- Local variables
1479
1480 Expr : constant Node_Id := Expression (N);
1481 Alt : Node_Id;
1482 Exp_Type : Entity_Id;
1483 Exp_Btype : Entity_Id;
1484
1485 FirstX : Node_Id := Empty;
1486 -- First expression in the case for which there is some type information
1487 -- available, i.e. it is not Any_Type, which can happen because of some
1488 -- error, or from the use of e.g. raise Constraint_Error.
1489
1490 Others_Present : Boolean;
1491 -- Indicates if Others was present
1492
1493 Wrong_Alt : Node_Id := Empty;
1494 -- For error reporting
1495
1496 -- Start of processing for Analyze_Case_Expression
1497
1498 begin
1499 if Comes_From_Source (N) then
1500 Check_Compiler_Unit ("case expression", N);
1501 end if;
1502
1503 Analyze_And_Resolve (Expr, Any_Discrete);
1504 Check_Unset_Reference (Expr);
1505 Exp_Type := Etype (Expr);
1506 Exp_Btype := Base_Type (Exp_Type);
1507
1508 Alt := First (Alternatives (N));
1509 while Present (Alt) loop
1510 Analyze (Expression (Alt));
1511
1512 if No (FirstX) and then Etype (Expression (Alt)) /= Any_Type then
1513 FirstX := Expression (Alt);
1514 end if;
1515
1516 Next (Alt);
1517 end loop;
1518
1519 -- Get our initial type from the first expression for which we got some
1520 -- useful type information from the expression.
1521
1522 if not Is_Overloaded (FirstX) then
1523 Set_Etype (N, Etype (FirstX));
1524
1525 else
1526 declare
1527 I : Interp_Index;
1528 It : Interp;
1529
1530 begin
1531 Set_Etype (N, Any_Type);
1532
1533 Get_First_Interp (FirstX, I, It);
1534 while Present (It.Nam) loop
1535
1536 -- For each interpretation of the first expression, we only
1537 -- add the interpretation if every other expression in the
1538 -- case expression alternatives has a compatible type.
1539
1540 Alt := Next (First (Alternatives (N)));
1541 while Present (Alt) loop
1542 exit when not Has_Compatible_Type (Expression (Alt), It.Typ);
1543 Next (Alt);
1544 end loop;
1545
1546 if No (Alt) then
1547 Add_One_Interp (N, It.Typ, It.Typ);
1548 else
1549 Wrong_Alt := Alt;
1550 end if;
1551
1552 Get_Next_Interp (I, It);
1553 end loop;
1554 end;
1555 end if;
1556
1557 Exp_Btype := Base_Type (Exp_Type);
1558
1559 -- The expression must be of a discrete type which must be determinable
1560 -- independently of the context in which the expression occurs, but
1561 -- using the fact that the expression must be of a discrete type.
1562 -- Moreover, the type this expression must not be a character literal
1563 -- (which is always ambiguous).
1564
1565 -- If error already reported by Resolve, nothing more to do
1566
1567 if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then
1568 return;
1569
1570 -- Special casee message for character literal
1571
1572 elsif Exp_Btype = Any_Character then
1573 Error_Msg_N
1574 ("character literal as case expression is ambiguous", Expr);
1575 return;
1576 end if;
1577
1578 if Etype (N) = Any_Type and then Present (Wrong_Alt) then
1579 Error_Msg_N
1580 ("type incompatible with that of previous alternatives",
1581 Expression (Wrong_Alt));
1582 return;
1583 end if;
1584
1585 -- If the case expression is a formal object of mode in out, then
1586 -- treat it as having a nonstatic subtype by forcing use of the base
1587 -- type (which has to get passed to Check_Case_Choices below). Also
1588 -- use base type when the case expression is parenthesized.
1589
1590 if Paren_Count (Expr) > 0
1591 or else (Is_Entity_Name (Expr)
1592 and then Ekind (Entity (Expr)) = E_Generic_In_Out_Parameter)
1593 then
1594 Exp_Type := Exp_Btype;
1595 end if;
1596
1597 -- The case expression alternatives cover the range of a static subtype
1598 -- subject to aspect Static_Predicate. Do not check the choices when the
1599 -- case expression has not been fully analyzed yet because this may lead
1600 -- to bogus errors.
1601
1602 if Is_OK_Static_Subtype (Exp_Type)
1603 and then Has_Static_Predicate_Aspect (Exp_Type)
1604 and then In_Spec_Expression
1605 then
1606 null;
1607
1608 -- Call Analyze_Choices and Check_Choices to do the rest of the work
1609
1610 else
1611 Analyze_Choices (Alternatives (N), Exp_Type);
1612 Check_Choices (N, Alternatives (N), Exp_Type, Others_Present);
1613 end if;
1614
1615 if Exp_Type = Universal_Integer and then not Others_Present then
1616 Error_Msg_N
1617 ("case on universal integer requires OTHERS choice", Expr);
1618 end if;
1619 end Analyze_Case_Expression;
1620
1621 ---------------------------
1622 -- Analyze_Comparison_Op --
1623 ---------------------------
1624
1625 procedure Analyze_Comparison_Op (N : Node_Id) is
1626 L : constant Node_Id := Left_Opnd (N);
1627 R : constant Node_Id := Right_Opnd (N);
1628 Op_Id : Entity_Id := Entity (N);
1629
1630 begin
1631 Set_Etype (N, Any_Type);
1632 Candidate_Type := Empty;
1633
1634 Analyze_Expression (L);
1635 Analyze_Expression (R);
1636
1637 if Present (Op_Id) then
1638 if Ekind (Op_Id) = E_Operator then
1639 Find_Comparison_Types (L, R, Op_Id, N);
1640 else
1641 Add_One_Interp (N, Op_Id, Etype (Op_Id));
1642 end if;
1643
1644 if Is_Overloaded (L) then
1645 Set_Etype (L, Intersect_Types (L, R));
1646 end if;
1647
1648 else
1649 Op_Id := Get_Name_Entity_Id (Chars (N));
1650 while Present (Op_Id) loop
1651 if Ekind (Op_Id) = E_Operator then
1652 Find_Comparison_Types (L, R, Op_Id, N);
1653 else
1654 Analyze_User_Defined_Binary_Op (N, Op_Id);
1655 end if;
1656
1657 Op_Id := Homonym (Op_Id);
1658 end loop;
1659 end if;
1660
1661 Operator_Check (N);
1662 Check_Function_Writable_Actuals (N);
1663 end Analyze_Comparison_Op;
1664
1665 ---------------------------
1666 -- Analyze_Concatenation --
1667 ---------------------------
1668
1669 procedure Analyze_Concatenation (N : Node_Id) is
1670
1671 -- We wish to avoid deep recursion, because concatenations are often
1672 -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left
1673 -- operands nonrecursively until we find something that is not a
1674 -- concatenation (A in this case), or has already been analyzed. We
1675 -- analyze that, and then walk back up the tree following Parent
1676 -- pointers, calling Analyze_Concatenation_Rest to do the rest of the
1677 -- work at each level. The Parent pointers allow us to avoid recursion,
1678 -- and thus avoid running out of memory.
1679
1680 NN : Node_Id := N;
1681 L : Node_Id;
1682
1683 begin
1684 Candidate_Type := Empty;
1685
1686 -- The following code is equivalent to:
1687
1688 -- Set_Etype (N, Any_Type);
1689 -- Analyze_Expression (Left_Opnd (N));
1690 -- Analyze_Concatenation_Rest (N);
1691
1692 -- where the Analyze_Expression call recurses back here if the left
1693 -- operand is a concatenation.
1694
1695 -- Walk down left operands
1696
1697 loop
1698 Set_Etype (NN, Any_Type);
1699 L := Left_Opnd (NN);
1700 exit when Nkind (L) /= N_Op_Concat or else Analyzed (L);
1701 NN := L;
1702 end loop;
1703
1704 -- Now (given the above example) NN is A&B and L is A
1705
1706 -- First analyze L ...
1707
1708 Analyze_Expression (L);
1709
1710 -- ... then walk NN back up until we reach N (where we started), calling
1711 -- Analyze_Concatenation_Rest along the way.
1712
1713 loop
1714 Analyze_Concatenation_Rest (NN);
1715 exit when NN = N;
1716 NN := Parent (NN);
1717 end loop;
1718 end Analyze_Concatenation;
1719
1720 --------------------------------
1721 -- Analyze_Concatenation_Rest --
1722 --------------------------------
1723
1724 -- If the only one-dimensional array type in scope is String,
1725 -- this is the resulting type of the operation. Otherwise there
1726 -- will be a concatenation operation defined for each user-defined
1727 -- one-dimensional array.
1728
1729 procedure Analyze_Concatenation_Rest (N : Node_Id) is
1730 L : constant Node_Id := Left_Opnd (N);
1731 R : constant Node_Id := Right_Opnd (N);
1732 Op_Id : Entity_Id := Entity (N);
1733 LT : Entity_Id;
1734 RT : Entity_Id;
1735
1736 begin
1737 Analyze_Expression (R);
1738
1739 -- If the entity is present, the node appears in an instance, and
1740 -- denotes a predefined concatenation operation. The resulting type is
1741 -- obtained from the arguments when possible. If the arguments are
1742 -- aggregates, the array type and the concatenation type must be
1743 -- visible.
1744
1745 if Present (Op_Id) then
1746 if Ekind (Op_Id) = E_Operator then
1747 LT := Base_Type (Etype (L));
1748 RT := Base_Type (Etype (R));
1749
1750 if Is_Array_Type (LT)
1751 and then (RT = LT or else RT = Base_Type (Component_Type (LT)))
1752 then
1753 Add_One_Interp (N, Op_Id, LT);
1754
1755 elsif Is_Array_Type (RT)
1756 and then LT = Base_Type (Component_Type (RT))
1757 then
1758 Add_One_Interp (N, Op_Id, RT);
1759
1760 -- If one operand is a string type or a user-defined array type,
1761 -- and the other is a literal, result is of the specific type.
1762
1763 elsif
1764 (Root_Type (LT) = Standard_String
1765 or else Scope (LT) /= Standard_Standard)
1766 and then Etype (R) = Any_String
1767 then
1768 Add_One_Interp (N, Op_Id, LT);
1769
1770 elsif
1771 (Root_Type (RT) = Standard_String
1772 or else Scope (RT) /= Standard_Standard)
1773 and then Etype (L) = Any_String
1774 then
1775 Add_One_Interp (N, Op_Id, RT);
1776
1777 elsif not Is_Generic_Type (Etype (Op_Id)) then
1778 Add_One_Interp (N, Op_Id, Etype (Op_Id));
1779
1780 else
1781 -- Type and its operations must be visible
1782
1783 Set_Entity (N, Empty);
1784 Analyze_Concatenation (N);
1785 end if;
1786
1787 else
1788 Add_One_Interp (N, Op_Id, Etype (Op_Id));
1789 end if;
1790
1791 else
1792 Op_Id := Get_Name_Entity_Id (Name_Op_Concat);
1793 while Present (Op_Id) loop
1794 if Ekind (Op_Id) = E_Operator then
1795
1796 -- Do not consider operators declared in dead code, they can
1797 -- not be part of the resolution.
1798
1799 if Is_Eliminated (Op_Id) then
1800 null;
1801 else
1802 Find_Concatenation_Types (L, R, Op_Id, N);
1803 end if;
1804
1805 else
1806 Analyze_User_Defined_Binary_Op (N, Op_Id);
1807 end if;
1808
1809 Op_Id := Homonym (Op_Id);
1810 end loop;
1811 end if;
1812
1813 Operator_Check (N);
1814 end Analyze_Concatenation_Rest;
1815
1816 -------------------------
1817 -- Analyze_Equality_Op --
1818 -------------------------
1819
1820 procedure Analyze_Equality_Op (N : Node_Id) is
1821 Loc : constant Source_Ptr := Sloc (N);
1822 L : constant Node_Id := Left_Opnd (N);
1823 R : constant Node_Id := Right_Opnd (N);
1824 Op_Id : Entity_Id;
1825
1826 begin
1827 Set_Etype (N, Any_Type);
1828 Candidate_Type := Empty;
1829
1830 Analyze_Expression (L);
1831 Analyze_Expression (R);
1832
1833 -- If the entity is set, the node is a generic instance with a non-local
1834 -- reference to the predefined operator or to a user-defined function.
1835 -- It can also be an inequality that is expanded into the negation of a
1836 -- call to a user-defined equality operator.
1837
1838 -- For the predefined case, the result is Boolean, regardless of the
1839 -- type of the operands. The operands may even be limited, if they are
1840 -- generic actuals. If they are overloaded, label the left argument with
1841 -- the common type that must be present, or with the type of the formal
1842 -- of the user-defined function.
1843
1844 if Present (Entity (N)) then
1845 Op_Id := Entity (N);
1846
1847 if Ekind (Op_Id) = E_Operator then
1848 Add_One_Interp (N, Op_Id, Standard_Boolean);
1849 else
1850 Add_One_Interp (N, Op_Id, Etype (Op_Id));
1851 end if;
1852
1853 if Is_Overloaded (L) then
1854 if Ekind (Op_Id) = E_Operator then
1855 Set_Etype (L, Intersect_Types (L, R));
1856 else
1857 Set_Etype (L, Etype (First_Formal (Op_Id)));
1858 end if;
1859 end if;
1860
1861 else
1862 Op_Id := Get_Name_Entity_Id (Chars (N));
1863 while Present (Op_Id) loop
1864 if Ekind (Op_Id) = E_Operator then
1865 Find_Equality_Types (L, R, Op_Id, N);
1866 else
1867 Analyze_User_Defined_Binary_Op (N, Op_Id);
1868 end if;
1869
1870 Op_Id := Homonym (Op_Id);
1871 end loop;
1872 end if;
1873
1874 -- If there was no match, and the operator is inequality, this may be
1875 -- a case where inequality has not been made explicit, as for tagged
1876 -- types. Analyze the node as the negation of an equality operation.
1877 -- This cannot be done earlier, because before analysis we cannot rule
1878 -- out the presence of an explicit inequality.
1879
1880 if Etype (N) = Any_Type
1881 and then Nkind (N) = N_Op_Ne
1882 then
1883 Op_Id := Get_Name_Entity_Id (Name_Op_Eq);
1884 while Present (Op_Id) loop
1885 if Ekind (Op_Id) = E_Operator then
1886 Find_Equality_Types (L, R, Op_Id, N);
1887 else
1888 Analyze_User_Defined_Binary_Op (N, Op_Id);
1889 end if;
1890
1891 Op_Id := Homonym (Op_Id);
1892 end loop;
1893
1894 if Etype (N) /= Any_Type then
1895 Op_Id := Entity (N);
1896
1897 Rewrite (N,
1898 Make_Op_Not (Loc,
1899 Right_Opnd =>
1900 Make_Op_Eq (Loc,
1901 Left_Opnd => Left_Opnd (N),
1902 Right_Opnd => Right_Opnd (N))));
1903
1904 Set_Entity (Right_Opnd (N), Op_Id);
1905 Analyze (N);
1906 end if;
1907 end if;
1908
1909 Operator_Check (N);
1910 Check_Function_Writable_Actuals (N);
1911 end Analyze_Equality_Op;
1912
1913 ----------------------------------
1914 -- Analyze_Explicit_Dereference --
1915 ----------------------------------
1916
1917 procedure Analyze_Explicit_Dereference (N : Node_Id) is
1918 Loc : constant Source_Ptr := Sloc (N);
1919 P : constant Node_Id := Prefix (N);
1920 T : Entity_Id;
1921 I : Interp_Index;
1922 It : Interp;
1923 New_N : Node_Id;
1924
1925 function Is_Function_Type return Boolean;
1926 -- Check whether node may be interpreted as an implicit function call
1927
1928 ----------------------
1929 -- Is_Function_Type --
1930 ----------------------
1931
1932 function Is_Function_Type return Boolean is
1933 I : Interp_Index;
1934 It : Interp;
1935
1936 begin
1937 if not Is_Overloaded (N) then
1938 return Ekind (Base_Type (Etype (N))) = E_Subprogram_Type
1939 and then Etype (Base_Type (Etype (N))) /= Standard_Void_Type;
1940
1941 else
1942 Get_First_Interp (N, I, It);
1943 while Present (It.Nam) loop
1944 if Ekind (Base_Type (It.Typ)) /= E_Subprogram_Type
1945 or else Etype (Base_Type (It.Typ)) = Standard_Void_Type
1946 then
1947 return False;
1948 end if;
1949
1950 Get_Next_Interp (I, It);
1951 end loop;
1952
1953 return True;
1954 end if;
1955 end Is_Function_Type;
1956
1957 -- Start of processing for Analyze_Explicit_Dereference
1958
1959 begin
1960 -- If source node, check SPARK restriction. We guard this with the
1961 -- source node check, because ???
1962
1963 if Comes_From_Source (N) then
1964 Check_SPARK_05_Restriction ("explicit dereference is not allowed", N);
1965 end if;
1966
1967 -- In formal verification mode, keep track of all reads and writes
1968 -- through explicit dereferences.
1969
1970 if GNATprove_Mode then
1971 SPARK_Specific.Generate_Dereference (N);
1972 end if;
1973
1974 Analyze (P);
1975 Set_Etype (N, Any_Type);
1976
1977 -- Test for remote access to subprogram type, and if so return
1978 -- after rewriting the original tree.
1979
1980 if Remote_AST_E_Dereference (P) then
1981 return;
1982 end if;
1983
1984 -- Normal processing for other than remote access to subprogram type
1985
1986 if not Is_Overloaded (P) then
1987 if Is_Access_Type (Etype (P)) then
1988
1989 -- Set the Etype. We need to go through Is_For_Access_Subtypes to
1990 -- avoid other problems caused by the Private_Subtype and it is
1991 -- safe to go to the Base_Type because this is the same as
1992 -- converting the access value to its Base_Type.
1993
1994 declare
1995 DT : Entity_Id := Designated_Type (Etype (P));
1996
1997 begin
1998 if Ekind (DT) = E_Private_Subtype
1999 and then Is_For_Access_Subtype (DT)
2000 then
2001 DT := Base_Type (DT);
2002 end if;
2003
2004 -- An explicit dereference is a legal occurrence of an
2005 -- incomplete type imported through a limited_with clause, if
2006 -- the full view is visible, or if we are within an instance
2007 -- body, where the enclosing body has a regular with_clause
2008 -- on the unit.
2009
2010 if From_Limited_With (DT)
2011 and then not From_Limited_With (Scope (DT))
2012 and then
2013 (Is_Immediately_Visible (Scope (DT))
2014 or else
2015 (Is_Child_Unit (Scope (DT))
2016 and then Is_Visible_Lib_Unit (Scope (DT)))
2017 or else In_Instance_Body)
2018 then
2019 Set_Etype (N, Available_View (DT));
2020
2021 else
2022 Set_Etype (N, DT);
2023 end if;
2024 end;
2025
2026 elsif Etype (P) /= Any_Type then
2027 Error_Msg_N ("prefix of dereference must be an access type", N);
2028 return;
2029 end if;
2030
2031 else
2032 Get_First_Interp (P, I, It);
2033 while Present (It.Nam) loop
2034 T := It.Typ;
2035
2036 if Is_Access_Type (T) then
2037 Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
2038 end if;
2039
2040 Get_Next_Interp (I, It);
2041 end loop;
2042
2043 -- Error if no interpretation of the prefix has an access type
2044
2045 if Etype (N) = Any_Type then
2046 Error_Msg_N
2047 ("access type required in prefix of explicit dereference", P);
2048 Set_Etype (N, Any_Type);
2049 return;
2050 end if;
2051 end if;
2052
2053 if Is_Function_Type
2054 and then Nkind (Parent (N)) /= N_Indexed_Component
2055
2056 and then (Nkind (Parent (N)) /= N_Function_Call
2057 or else N /= Name (Parent (N)))
2058
2059 and then (Nkind (Parent (N)) /= N_Procedure_Call_Statement
2060 or else N /= Name (Parent (N)))
2061
2062 and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
2063 and then (Nkind (Parent (N)) /= N_Attribute_Reference
2064 or else
2065 (Attribute_Name (Parent (N)) /= Name_Address
2066 and then
2067 Attribute_Name (Parent (N)) /= Name_Access))
2068 then
2069 -- Name is a function call with no actuals, in a context that
2070 -- requires deproceduring (including as an actual in an enclosing
2071 -- function or procedure call). There are some pathological cases
2072 -- where the prefix might include functions that return access to
2073 -- subprograms and others that return a regular type. Disambiguation
2074 -- of those has to take place in Resolve.
2075
2076 New_N :=
2077 Make_Function_Call (Loc,
2078 Name => Make_Explicit_Dereference (Loc, P),
2079 Parameter_Associations => New_List);
2080
2081 -- If the prefix is overloaded, remove operations that have formals,
2082 -- we know that this is a parameterless call.
2083
2084 if Is_Overloaded (P) then
2085 Get_First_Interp (P, I, It);
2086 while Present (It.Nam) loop
2087 T := It.Typ;
2088
2089 if No (First_Formal (Base_Type (Designated_Type (T)))) then
2090 Set_Etype (P, T);
2091 else
2092 Remove_Interp (I);
2093 end if;
2094
2095 Get_Next_Interp (I, It);
2096 end loop;
2097 end if;
2098
2099 Rewrite (N, New_N);
2100 Analyze (N);
2101
2102 elsif not Is_Function_Type
2103 and then Is_Overloaded (N)
2104 then
2105 -- The prefix may include access to subprograms and other access
2106 -- types. If the context selects the interpretation that is a
2107 -- function call (not a procedure call) we cannot rewrite the node
2108 -- yet, but we include the result of the call interpretation.
2109
2110 Get_First_Interp (N, I, It);
2111 while Present (It.Nam) loop
2112 if Ekind (Base_Type (It.Typ)) = E_Subprogram_Type
2113 and then Etype (Base_Type (It.Typ)) /= Standard_Void_Type
2114 and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
2115 then
2116 Add_One_Interp (N, Etype (It.Typ), Etype (It.Typ));
2117 end if;
2118
2119 Get_Next_Interp (I, It);
2120 end loop;
2121 end if;
2122
2123 -- A value of remote access-to-class-wide must not be dereferenced
2124 -- (RM E.2.2(16)).
2125
2126 Validate_Remote_Access_To_Class_Wide_Type (N);
2127 end Analyze_Explicit_Dereference;
2128
2129 ------------------------
2130 -- Analyze_Expression --
2131 ------------------------
2132
2133 procedure Analyze_Expression (N : Node_Id) is
2134 begin
2135
2136 -- If the expression is an indexed component that will be rewritten
2137 -- as a container indexing, it has already been analyzed.
2138
2139 if Nkind (N) = N_Indexed_Component
2140 and then Present (Generalized_Indexing (N))
2141 then
2142 null;
2143
2144 else
2145 Analyze (N);
2146 Check_Parameterless_Call (N);
2147 end if;
2148 end Analyze_Expression;
2149
2150 -------------------------------------
2151 -- Analyze_Expression_With_Actions --
2152 -------------------------------------
2153
2154 procedure Analyze_Expression_With_Actions (N : Node_Id) is
2155 A : Node_Id;
2156
2157 begin
2158 A := First (Actions (N));
2159 while Present (A) loop
2160 Analyze (A);
2161 Next (A);
2162 end loop;
2163
2164 Analyze_Expression (Expression (N));
2165 Set_Etype (N, Etype (Expression (N)));
2166 end Analyze_Expression_With_Actions;
2167
2168 ---------------------------
2169 -- Analyze_If_Expression --
2170 ---------------------------
2171
2172 procedure Analyze_If_Expression (N : Node_Id) is
2173 Condition : constant Node_Id := First (Expressions (N));
2174 Then_Expr : constant Node_Id := Next (Condition);
2175 Else_Expr : Node_Id;
2176
2177 begin
2178 -- Defend against error of missing expressions from previous error
2179
2180 if No (Then_Expr) then
2181 Check_Error_Detected;
2182 return;
2183 end if;
2184
2185 if Comes_From_Source (N) then
2186 Check_SPARK_05_Restriction ("if expression is not allowed", N);
2187 end if;
2188
2189 Else_Expr := Next (Then_Expr);
2190
2191 if Comes_From_Source (N) then
2192 Check_Compiler_Unit ("if expression", N);
2193 end if;
2194
2195 -- Analyze and resolve the condition. We need to resolve this now so
2196 -- that it gets folded to True/False if possible, before we analyze
2197 -- the THEN/ELSE branches, because when analyzing these branches, we
2198 -- may call Is_Statically_Unevaluated, which expects the condition of
2199 -- an enclosing IF to have been analyze/resolved/evaluated.
2200
2201 Analyze_Expression (Condition);
2202 Resolve (Condition, Any_Boolean);
2203
2204 -- Analyze THEN expression and (if present) ELSE expression. For those
2205 -- we delay resolution in the normal manner, because of overloading etc.
2206
2207 Analyze_Expression (Then_Expr);
2208
2209 if Present (Else_Expr) then
2210 Analyze_Expression (Else_Expr);
2211 end if;
2212
2213 -- If then expression not overloaded, then that decides the type
2214
2215 if not Is_Overloaded (Then_Expr) then
2216 Set_Etype (N, Etype (Then_Expr));
2217
2218 -- Case where then expression is overloaded
2219
2220 else
2221 declare
2222 I : Interp_Index;
2223 It : Interp;
2224
2225 begin
2226 Set_Etype (N, Any_Type);
2227
2228 -- Loop through interpretations of Then_Expr
2229
2230 Get_First_Interp (Then_Expr, I, It);
2231 while Present (It.Nam) loop
2232
2233 -- Add possible interpretation of Then_Expr if no Else_Expr, or
2234 -- Else_Expr is present and has a compatible type.
2235
2236 if No (Else_Expr)
2237 or else Has_Compatible_Type (Else_Expr, It.Typ)
2238 then
2239 Add_One_Interp (N, It.Typ, It.Typ);
2240 end if;
2241
2242 Get_Next_Interp (I, It);
2243 end loop;
2244
2245 -- If no valid interpretation has been found, then the type of the
2246 -- ELSE expression does not match any interpretation of the THEN
2247 -- expression.
2248
2249 if Etype (N) = Any_Type then
2250 Error_Msg_N
2251 ("type incompatible with that of `THEN` expression",
2252 Else_Expr);
2253 return;
2254 end if;
2255 end;
2256 end if;
2257 end Analyze_If_Expression;
2258
2259 ------------------------------------
2260 -- Analyze_Indexed_Component_Form --
2261 ------------------------------------
2262
2263 procedure Analyze_Indexed_Component_Form (N : Node_Id) is
2264 P : constant Node_Id := Prefix (N);
2265 Exprs : constant List_Id := Expressions (N);
2266 Exp : Node_Id;
2267 P_T : Entity_Id;
2268 E : Node_Id;
2269 U_N : Entity_Id;
2270
2271 procedure Process_Function_Call;
2272 -- Prefix in indexed component form is an overloadable entity, so the
2273 -- node is a function call. Reformat it as such.
2274
2275 procedure Process_Indexed_Component;
2276 -- Prefix in indexed component form is actually an indexed component.
2277 -- This routine processes it, knowing that the prefix is already
2278 -- resolved.
2279
2280 procedure Process_Indexed_Component_Or_Slice;
2281 -- An indexed component with a single index may designate a slice if
2282 -- the index is a subtype mark. This routine disambiguates these two
2283 -- cases by resolving the prefix to see if it is a subtype mark.
2284
2285 procedure Process_Overloaded_Indexed_Component;
2286 -- If the prefix of an indexed component is overloaded, the proper
2287 -- interpretation is selected by the index types and the context.
2288
2289 ---------------------------
2290 -- Process_Function_Call --
2291 ---------------------------
2292
2293 procedure Process_Function_Call is
2294 Loc : constant Source_Ptr := Sloc (N);
2295 Actual : Node_Id;
2296
2297 begin
2298 Change_Node (N, N_Function_Call);
2299 Set_Name (N, P);
2300 Set_Parameter_Associations (N, Exprs);
2301
2302 -- Analyze actuals prior to analyzing the call itself
2303
2304 Actual := First (Parameter_Associations (N));
2305 while Present (Actual) loop
2306 Analyze (Actual);
2307 Check_Parameterless_Call (Actual);
2308
2309 -- Move to next actual. Note that we use Next, not Next_Actual
2310 -- here. The reason for this is a bit subtle. If a function call
2311 -- includes named associations, the parser recognizes the node
2312 -- as a call, and it is analyzed as such. If all associations are
2313 -- positional, the parser builds an indexed_component node, and
2314 -- it is only after analysis of the prefix that the construct
2315 -- is recognized as a call, in which case Process_Function_Call
2316 -- rewrites the node and analyzes the actuals. If the list of
2317 -- actuals is malformed, the parser may leave the node as an
2318 -- indexed component (despite the presence of named associations).
2319 -- The iterator Next_Actual is equivalent to Next if the list is
2320 -- positional, but follows the normalized chain of actuals when
2321 -- named associations are present. In this case normalization has
2322 -- not taken place, and actuals remain unanalyzed, which leads to
2323 -- subsequent crashes or loops if there is an attempt to continue
2324 -- analysis of the program.
2325
2326 -- IF there is a single actual and it is a type name, the node
2327 -- can only be interpreted as a slice of a parameterless call.
2328 -- Rebuild the node as such and analyze.
2329
2330 if No (Next (Actual))
2331 and then Is_Entity_Name (Actual)
2332 and then Is_Type (Entity (Actual))
2333 and then Is_Discrete_Type (Entity (Actual))
2334 then
2335 Replace (N,
2336 Make_Slice (Loc,
2337 Prefix => P,
2338 Discrete_Range =>
2339 New_Occurrence_Of (Entity (Actual), Loc)));
2340 Analyze (N);
2341 return;
2342
2343 else
2344 Next (Actual);
2345 end if;
2346 end loop;
2347
2348 Analyze_Call (N);
2349 end Process_Function_Call;
2350
2351 -------------------------------
2352 -- Process_Indexed_Component --
2353 -------------------------------
2354
2355 procedure Process_Indexed_Component is
2356 Exp : Node_Id;
2357 Array_Type : Entity_Id;
2358 Index : Node_Id;
2359 Pent : Entity_Id := Empty;
2360
2361 begin
2362 Exp := First (Exprs);
2363
2364 if Is_Overloaded (P) then
2365 Process_Overloaded_Indexed_Component;
2366
2367 else
2368 Array_Type := Etype (P);
2369
2370 if Is_Entity_Name (P) then
2371 Pent := Entity (P);
2372 elsif Nkind (P) = N_Selected_Component
2373 and then Is_Entity_Name (Selector_Name (P))
2374 then
2375 Pent := Entity (Selector_Name (P));
2376 end if;
2377
2378 -- Prefix must be appropriate for an array type, taking into
2379 -- account a possible implicit dereference.
2380
2381 if Is_Access_Type (Array_Type) then
2382 Error_Msg_NW
2383 (Warn_On_Dereference, "?d?implicit dereference", N);
2384 Array_Type := Process_Implicit_Dereference_Prefix (Pent, P);
2385 end if;
2386
2387 if Is_Array_Type (Array_Type) then
2388 null;
2389
2390 elsif Present (Pent) and then Ekind (Pent) = E_Entry_Family then
2391 Analyze (Exp);
2392 Set_Etype (N, Any_Type);
2393
2394 if not Has_Compatible_Type
2395 (Exp, Entry_Index_Type (Pent))
2396 then
2397 Error_Msg_N ("invalid index type in entry name", N);
2398
2399 elsif Present (Next (Exp)) then
2400 Error_Msg_N ("too many subscripts in entry reference", N);
2401
2402 else
2403 Set_Etype (N, Etype (P));
2404 end if;
2405
2406 return;
2407
2408 elsif Is_Record_Type (Array_Type)
2409 and then Remote_AST_I_Dereference (P)
2410 then
2411 return;
2412
2413 elsif Try_Container_Indexing (N, P, Exprs) then
2414 return;
2415
2416 elsif Array_Type = Any_Type then
2417 Set_Etype (N, Any_Type);
2418
2419 -- In most cases the analysis of the prefix will have emitted
2420 -- an error already, but if the prefix may be interpreted as a
2421 -- call in prefixed notation, the report is left to the caller.
2422 -- To prevent cascaded errors, report only if no previous ones.
2423
2424 if Serious_Errors_Detected = 0 then
2425 Error_Msg_N ("invalid prefix in indexed component", P);
2426
2427 if Nkind (P) = N_Expanded_Name then
2428 Error_Msg_NE ("\& is not visible", P, Selector_Name (P));
2429 end if;
2430 end if;
2431
2432 return;
2433
2434 -- Here we definitely have a bad indexing
2435
2436 else
2437 if Nkind (Parent (N)) = N_Requeue_Statement
2438 and then Present (Pent) and then Ekind (Pent) = E_Entry
2439 then
2440 Error_Msg_N
2441 ("REQUEUE does not permit parameters", First (Exprs));
2442
2443 elsif Is_Entity_Name (P)
2444 and then Etype (P) = Standard_Void_Type
2445 then
2446 Error_Msg_NE ("incorrect use of &", P, Entity (P));
2447
2448 else
2449 Error_Msg_N ("array type required in indexed component", P);
2450 end if;
2451
2452 Set_Etype (N, Any_Type);
2453 return;
2454 end if;
2455
2456 Index := First_Index (Array_Type);
2457 while Present (Index) and then Present (Exp) loop
2458 if not Has_Compatible_Type (Exp, Etype (Index)) then
2459 Wrong_Type (Exp, Etype (Index));
2460 Set_Etype (N, Any_Type);
2461 return;
2462 end if;
2463
2464 Next_Index (Index);
2465 Next (Exp);
2466 end loop;
2467
2468 Set_Etype (N, Component_Type (Array_Type));
2469 Check_Implicit_Dereference (N, Etype (N));
2470
2471 if Present (Index) then
2472 Error_Msg_N
2473 ("too few subscripts in array reference", First (Exprs));
2474
2475 elsif Present (Exp) then
2476 Error_Msg_N ("too many subscripts in array reference", Exp);
2477 end if;
2478 end if;
2479 end Process_Indexed_Component;
2480
2481 ----------------------------------------
2482 -- Process_Indexed_Component_Or_Slice --
2483 ----------------------------------------
2484
2485 procedure Process_Indexed_Component_Or_Slice is
2486 begin
2487 Exp := First (Exprs);
2488 while Present (Exp) loop
2489 Analyze_Expression (Exp);
2490 Next (Exp);
2491 end loop;
2492
2493 Exp := First (Exprs);
2494
2495 -- If one index is present, and it is a subtype name, then the node
2496 -- denotes a slice (note that the case of an explicit range for a
2497 -- slice was already built as an N_Slice node in the first place,
2498 -- so that case is not handled here).
2499
2500 -- We use a replace rather than a rewrite here because this is one
2501 -- of the cases in which the tree built by the parser is plain wrong.
2502
2503 if No (Next (Exp))
2504 and then Is_Entity_Name (Exp)
2505 and then Is_Type (Entity (Exp))
2506 then
2507 Replace (N,
2508 Make_Slice (Sloc (N),
2509 Prefix => P,
2510 Discrete_Range => New_Copy (Exp)));
2511 Analyze (N);
2512
2513 -- Otherwise (more than one index present, or single index is not
2514 -- a subtype name), then we have the indexed component case.
2515
2516 else
2517 Process_Indexed_Component;
2518 end if;
2519 end Process_Indexed_Component_Or_Slice;
2520
2521 ------------------------------------------
2522 -- Process_Overloaded_Indexed_Component --
2523 ------------------------------------------
2524
2525 procedure Process_Overloaded_Indexed_Component is
2526 Exp : Node_Id;
2527 I : Interp_Index;
2528 It : Interp;
2529 Typ : Entity_Id;
2530 Index : Node_Id;
2531 Found : Boolean;
2532
2533 begin
2534 Set_Etype (N, Any_Type);
2535
2536 Get_First_Interp (P, I, It);
2537 while Present (It.Nam) loop
2538 Typ := It.Typ;
2539
2540 if Is_Access_Type (Typ) then
2541 Typ := Designated_Type (Typ);
2542 Error_Msg_NW
2543 (Warn_On_Dereference, "?d?implicit dereference", N);
2544 end if;
2545
2546 if Is_Array_Type (Typ) then
2547
2548 -- Got a candidate: verify that index types are compatible
2549
2550 Index := First_Index (Typ);
2551 Found := True;
2552 Exp := First (Exprs);
2553 while Present (Index) and then Present (Exp) loop
2554 if Has_Compatible_Type (Exp, Etype (Index)) then
2555 null;
2556 else
2557 Found := False;
2558 Remove_Interp (I);
2559 exit;
2560 end if;
2561
2562 Next_Index (Index);
2563 Next (Exp);
2564 end loop;
2565
2566 if Found and then No (Index) and then No (Exp) then
2567 declare
2568 CT : constant Entity_Id :=
2569 Base_Type (Component_Type (Typ));
2570 begin
2571 Add_One_Interp (N, CT, CT);
2572 Check_Implicit_Dereference (N, CT);
2573 end;
2574 end if;
2575
2576 elsif Try_Container_Indexing (N, P, Exprs) then
2577 return;
2578
2579 end if;
2580
2581 Get_Next_Interp (I, It);
2582 end loop;
2583
2584 if Etype (N) = Any_Type then
2585 Error_Msg_N ("no legal interpretation for indexed component", N);
2586 Set_Is_Overloaded (N, False);
2587 end if;
2588
2589 End_Interp_List;
2590 end Process_Overloaded_Indexed_Component;
2591
2592 -- Start of processing for Analyze_Indexed_Component_Form
2593
2594 begin
2595 -- Get name of array, function or type
2596
2597 Analyze (P);
2598
2599 -- If P is an explicit dereference whose prefix is of a remote access-
2600 -- to-subprogram type, then N has already been rewritten as a subprogram
2601 -- call and analyzed.
2602
2603 if Nkind (N) in N_Subprogram_Call then
2604 return;
2605
2606 -- When the prefix is attribute 'Loop_Entry and the sole expression of
2607 -- the indexed component denotes a loop name, the indexed form is turned
2608 -- into an attribute reference.
2609
2610 elsif Nkind (N) = N_Attribute_Reference
2611 and then Attribute_Name (N) = Name_Loop_Entry
2612 then
2613 return;
2614 end if;
2615
2616 pragma Assert (Nkind (N) = N_Indexed_Component);
2617
2618 P_T := Base_Type (Etype (P));
2619
2620 if Is_Entity_Name (P) and then Present (Entity (P)) then
2621 U_N := Entity (P);
2622
2623 if Is_Type (U_N) then
2624
2625 -- Reformat node as a type conversion
2626
2627 E := Remove_Head (Exprs);
2628
2629 if Present (First (Exprs)) then
2630 Error_Msg_N
2631 ("argument of type conversion must be single expression", N);
2632 end if;
2633
2634 Change_Node (N, N_Type_Conversion);
2635 Set_Subtype_Mark (N, P);
2636 Set_Etype (N, U_N);
2637 Set_Expression (N, E);
2638
2639 -- After changing the node, call for the specific Analysis
2640 -- routine directly, to avoid a double call to the expander.
2641
2642 Analyze_Type_Conversion (N);
2643 return;
2644 end if;
2645
2646 if Is_Overloadable (U_N) then
2647 Process_Function_Call;
2648
2649 elsif Ekind (Etype (P)) = E_Subprogram_Type
2650 or else (Is_Access_Type (Etype (P))
2651 and then
2652 Ekind (Designated_Type (Etype (P))) =
2653 E_Subprogram_Type)
2654 then
2655 -- Call to access_to-subprogram with possible implicit dereference
2656
2657 Process_Function_Call;
2658
2659 elsif Is_Generic_Subprogram (U_N) then
2660
2661 -- A common beginner's (or C++ templates fan) error
2662
2663 Error_Msg_N ("generic subprogram cannot be called", N);
2664 Set_Etype (N, Any_Type);
2665 return;
2666
2667 else
2668 Process_Indexed_Component_Or_Slice;
2669 end if;
2670
2671 -- If not an entity name, prefix is an expression that may denote
2672 -- an array or an access-to-subprogram.
2673
2674 else
2675 if Ekind (P_T) = E_Subprogram_Type
2676 or else (Is_Access_Type (P_T)
2677 and then
2678 Ekind (Designated_Type (P_T)) = E_Subprogram_Type)
2679 then
2680 Process_Function_Call;
2681
2682 elsif Nkind (P) = N_Selected_Component
2683 and then Present (Entity (Selector_Name (P)))
2684 and then Is_Overloadable (Entity (Selector_Name (P)))
2685 then
2686 Process_Function_Call;
2687
2688 -- In ASIS mode within a generic, a prefixed call is analyzed and
2689 -- partially rewritten but the original indexed component has not
2690 -- yet been rewritten as a call. Perform the replacement now.
2691
2692 elsif Nkind (P) = N_Selected_Component
2693 and then Nkind (Parent (P)) = N_Function_Call
2694 and then ASIS_Mode
2695 then
2696 Rewrite (N, Parent (P));
2697 Analyze (N);
2698
2699 else
2700 -- Indexed component, slice, or a call to a member of a family
2701 -- entry, which will be converted to an entry call later.
2702
2703 Process_Indexed_Component_Or_Slice;
2704 end if;
2705 end if;
2706
2707 Analyze_Dimension (N);
2708 end Analyze_Indexed_Component_Form;
2709
2710 ------------------------
2711 -- Analyze_Logical_Op --
2712 ------------------------
2713
2714 procedure Analyze_Logical_Op (N : Node_Id) is
2715 L : constant Node_Id := Left_Opnd (N);
2716 R : constant Node_Id := Right_Opnd (N);
2717 Op_Id : Entity_Id := Entity (N);
2718
2719 begin
2720 Set_Etype (N, Any_Type);
2721 Candidate_Type := Empty;
2722
2723 Analyze_Expression (L);
2724 Analyze_Expression (R);
2725
2726 if Present (Op_Id) then
2727
2728 if Ekind (Op_Id) = E_Operator then
2729 Find_Boolean_Types (L, R, Op_Id, N);
2730 else
2731 Add_One_Interp (N, Op_Id, Etype (Op_Id));
2732 end if;
2733
2734 else
2735 Op_Id := Get_Name_Entity_Id (Chars (N));
2736 while Present (Op_Id) loop
2737 if Ekind (Op_Id) = E_Operator then
2738 Find_Boolean_Types (L, R, Op_Id, N);
2739 else
2740 Analyze_User_Defined_Binary_Op (N, Op_Id);
2741 end if;
2742
2743 Op_Id := Homonym (Op_Id);
2744 end loop;
2745 end if;
2746
2747 Operator_Check (N);
2748 Check_Function_Writable_Actuals (N);
2749 end Analyze_Logical_Op;
2750
2751 ---------------------------
2752 -- Analyze_Membership_Op --
2753 ---------------------------
2754
2755 procedure Analyze_Membership_Op (N : Node_Id) is
2756 Loc : constant Source_Ptr := Sloc (N);
2757 L : constant Node_Id := Left_Opnd (N);
2758 R : constant Node_Id := Right_Opnd (N);
2759
2760 Index : Interp_Index;
2761 It : Interp;
2762 Found : Boolean := False;
2763 I_F : Interp_Index;
2764 T_F : Entity_Id;
2765
2766 procedure Try_One_Interp (T1 : Entity_Id);
2767 -- Routine to try one proposed interpretation. Note that the context
2768 -- of the operation plays no role in resolving the arguments, so that
2769 -- if there is more than one interpretation of the operands that is
2770 -- compatible with a membership test, the operation is ambiguous.
2771
2772 --------------------
2773 -- Try_One_Interp --
2774 --------------------
2775
2776 procedure Try_One_Interp (T1 : Entity_Id) is
2777 begin
2778 if Has_Compatible_Type (R, T1) then
2779 if Found
2780 and then Base_Type (T1) /= Base_Type (T_F)
2781 then
2782 It := Disambiguate (L, I_F, Index, Any_Type);
2783
2784 if It = No_Interp then
2785 Ambiguous_Operands (N);
2786 Set_Etype (L, Any_Type);
2787 return;
2788
2789 else
2790 T_F := It.Typ;
2791 end if;
2792
2793 else
2794 Found := True;
2795 T_F := T1;
2796 I_F := Index;
2797 end if;
2798
2799 Set_Etype (L, T_F);
2800 end if;
2801 end Try_One_Interp;
2802
2803 procedure Analyze_Set_Membership;
2804 -- If a set of alternatives is present, analyze each and find the
2805 -- common type to which they must all resolve.
2806
2807 ----------------------------
2808 -- Analyze_Set_Membership --
2809 ----------------------------
2810
2811 procedure Analyze_Set_Membership is
2812 Alt : Node_Id;
2813 Index : Interp_Index;
2814 It : Interp;
2815 Candidate_Interps : Node_Id;
2816 Common_Type : Entity_Id := Empty;
2817
2818 begin
2819 if Comes_From_Source (N) then
2820 Check_Compiler_Unit ("set membership", N);
2821 end if;
2822
2823 Analyze (L);
2824 Candidate_Interps := L;
2825
2826 if not Is_Overloaded (L) then
2827 Common_Type := Etype (L);
2828
2829 Alt := First (Alternatives (N));
2830 while Present (Alt) loop
2831 Analyze (Alt);
2832
2833 if not Has_Compatible_Type (Alt, Common_Type) then
2834 Wrong_Type (Alt, Common_Type);
2835 end if;
2836
2837 Next (Alt);
2838 end loop;
2839
2840 else
2841 Alt := First (Alternatives (N));
2842 while Present (Alt) loop
2843 Analyze (Alt);
2844 if not Is_Overloaded (Alt) then
2845 Common_Type := Etype (Alt);
2846
2847 else
2848 Get_First_Interp (Alt, Index, It);
2849 while Present (It.Typ) loop
2850 if not
2851 Has_Compatible_Type (Candidate_Interps, It.Typ)
2852 then
2853 Remove_Interp (Index);
2854 end if;
2855
2856 Get_Next_Interp (Index, It);
2857 end loop;
2858
2859 Get_First_Interp (Alt, Index, It);
2860
2861 if No (It.Typ) then
2862 Error_Msg_N ("alternative has no legal type", Alt);
2863 return;
2864 end if;
2865
2866 -- If alternative is not overloaded, we have a unique type
2867 -- for all of them.
2868
2869 Set_Etype (Alt, It.Typ);
2870 Get_Next_Interp (Index, It);
2871
2872 if No (It.Typ) then
2873 Set_Is_Overloaded (Alt, False);
2874 Common_Type := Etype (Alt);
2875 end if;
2876
2877 Candidate_Interps := Alt;
2878 end if;
2879
2880 Next (Alt);
2881 end loop;
2882 end if;
2883
2884 Set_Etype (N, Standard_Boolean);
2885
2886 if Present (Common_Type) then
2887 Set_Etype (L, Common_Type);
2888
2889 -- The left operand may still be overloaded, to be resolved using
2890 -- the Common_Type.
2891
2892 else
2893 Error_Msg_N ("cannot resolve membership operation", N);
2894 end if;
2895 end Analyze_Set_Membership;
2896
2897 -- Start of processing for Analyze_Membership_Op
2898
2899 begin
2900 Analyze_Expression (L);
2901
2902 if No (R) and then Ada_Version >= Ada_2012 then
2903 Analyze_Set_Membership;
2904 Check_Function_Writable_Actuals (N);
2905
2906 return;
2907 end if;
2908
2909 if Nkind (R) = N_Range
2910 or else (Nkind (R) = N_Attribute_Reference
2911 and then Attribute_Name (R) = Name_Range)
2912 then
2913 Analyze (R);
2914
2915 if not Is_Overloaded (L) then
2916 Try_One_Interp (Etype (L));
2917
2918 else
2919 Get_First_Interp (L, Index, It);
2920 while Present (It.Typ) loop
2921 Try_One_Interp (It.Typ);
2922 Get_Next_Interp (Index, It);
2923 end loop;
2924 end if;
2925
2926 -- If not a range, it can be a subtype mark, or else it is a degenerate
2927 -- membership test with a singleton value, i.e. a test for equality,
2928 -- if the types are compatible.
2929
2930 else
2931 Analyze (R);
2932
2933 if Is_Entity_Name (R)
2934 and then Is_Type (Entity (R))
2935 then
2936 Find_Type (R);
2937 Check_Fully_Declared (Entity (R), R);
2938
2939 elsif Ada_Version >= Ada_2012
2940 and then Has_Compatible_Type (R, Etype (L))
2941 then
2942 if Nkind (N) = N_In then
2943 Rewrite (N,
2944 Make_Op_Eq (Loc,
2945 Left_Opnd => L,
2946 Right_Opnd => R));
2947 else
2948 Rewrite (N,
2949 Make_Op_Ne (Loc,
2950 Left_Opnd => L,
2951 Right_Opnd => R));
2952 end if;
2953
2954 Analyze (N);
2955 return;
2956
2957 else
2958 -- In all versions of the language, if we reach this point there
2959 -- is a previous error that will be diagnosed below.
2960
2961 Find_Type (R);
2962 end if;
2963 end if;
2964
2965 -- Compatibility between expression and subtype mark or range is
2966 -- checked during resolution. The result of the operation is Boolean
2967 -- in any case.
2968
2969 Set_Etype (N, Standard_Boolean);
2970
2971 if Comes_From_Source (N)
2972 and then Present (Right_Opnd (N))
2973 and then Is_CPP_Class (Etype (Etype (Right_Opnd (N))))
2974 then
2975 Error_Msg_N ("membership test not applicable to cpp-class types", N);
2976 end if;
2977
2978 Check_Function_Writable_Actuals (N);
2979 end Analyze_Membership_Op;
2980
2981 -----------------
2982 -- Analyze_Mod --
2983 -----------------
2984
2985 procedure Analyze_Mod (N : Node_Id) is
2986 begin
2987 -- A special warning check, if we have an expression of the form:
2988 -- expr mod 2 * literal
2989 -- where literal is 64 or less, then probably what was meant was
2990 -- expr mod 2 ** literal
2991 -- so issue an appropriate warning.
2992
2993 if Warn_On_Suspicious_Modulus_Value
2994 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
2995 and then Intval (Right_Opnd (N)) = Uint_2
2996 and then Nkind (Parent (N)) = N_Op_Multiply
2997 and then Nkind (Right_Opnd (Parent (N))) = N_Integer_Literal
2998 and then Intval (Right_Opnd (Parent (N))) <= Uint_64
2999 then
3000 Error_Msg_N
3001 ("suspicious MOD value, was '*'* intended'??M?", Parent (N));
3002 end if;
3003
3004 -- Remaining processing is same as for other arithmetic operators
3005
3006 Analyze_Arithmetic_Op (N);
3007 end Analyze_Mod;
3008
3009 ----------------------
3010 -- Analyze_Negation --
3011 ----------------------
3012
3013 procedure Analyze_Negation (N : Node_Id) is
3014 R : constant Node_Id := Right_Opnd (N);
3015 Op_Id : Entity_Id := Entity (N);
3016
3017 begin
3018 Set_Etype (N, Any_Type);
3019 Candidate_Type := Empty;
3020
3021 Analyze_Expression (R);
3022
3023 if Present (Op_Id) then
3024 if Ekind (Op_Id) = E_Operator then
3025 Find_Negation_Types (R, Op_Id, N);
3026 else
3027 Add_One_Interp (N, Op_Id, Etype (Op_Id));
3028 end if;
3029
3030 else
3031 Op_Id := Get_Name_Entity_Id (Chars (N));
3032 while Present (Op_Id) loop
3033 if Ekind (Op_Id) = E_Operator then
3034 Find_Negation_Types (R, Op_Id, N);
3035 else
3036 Analyze_User_Defined_Unary_Op (N, Op_Id);
3037 end if;
3038
3039 Op_Id := Homonym (Op_Id);
3040 end loop;
3041 end if;
3042
3043 Operator_Check (N);
3044 end Analyze_Negation;
3045
3046 ------------------
3047 -- Analyze_Null --
3048 ------------------
3049
3050 procedure Analyze_Null (N : Node_Id) is
3051 begin
3052 Check_SPARK_05_Restriction ("null is not allowed", N);
3053
3054 Set_Etype (N, Any_Access);
3055 end Analyze_Null;
3056
3057 ----------------------
3058 -- Analyze_One_Call --
3059 ----------------------
3060
3061 procedure Analyze_One_Call
3062 (N : Node_Id;
3063 Nam : Entity_Id;
3064 Report : Boolean;
3065 Success : out Boolean;
3066 Skip_First : Boolean := False)
3067 is
3068 Actuals : constant List_Id := Parameter_Associations (N);
3069 Prev_T : constant Entity_Id := Etype (N);
3070
3071 Must_Skip : constant Boolean := Skip_First
3072 or else Nkind (Original_Node (N)) = N_Selected_Component
3073 or else
3074 (Nkind (Original_Node (N)) = N_Indexed_Component
3075 and then Nkind (Prefix (Original_Node (N)))
3076 = N_Selected_Component);
3077 -- The first formal must be omitted from the match when trying to find
3078 -- a primitive operation that is a possible interpretation, and also
3079 -- after the call has been rewritten, because the corresponding actual
3080 -- is already known to be compatible, and because this may be an
3081 -- indexing of a call with default parameters.
3082
3083 Formal : Entity_Id;
3084 Actual : Node_Id;
3085 Is_Indexed : Boolean := False;
3086 Is_Indirect : Boolean := False;
3087 Subp_Type : constant Entity_Id := Etype (Nam);
3088 Norm_OK : Boolean;
3089
3090 function Compatible_Types_In_Predicate
3091 (T1 : Entity_Id;
3092 T2 : Entity_Id) return Boolean;
3093 -- For an Ada 2012 predicate or invariant, a call may mention an
3094 -- incomplete type, while resolution of the corresponding predicate
3095 -- function may see the full view, as a consequence of the delayed
3096 -- resolution of the corresponding expressions. This may occur in
3097 -- the body of a predicate function, or in a call to such. Anomalies
3098 -- involving private and full views can also happen. In each case,
3099 -- rewrite node or add conversions to remove spurious type errors.
3100
3101 procedure Indicate_Name_And_Type;
3102 -- If candidate interpretation matches, indicate name and type of result
3103 -- on call node.
3104
3105 function Operator_Hidden_By (Fun : Entity_Id) return Boolean;
3106 -- There may be a user-defined operator that hides the current
3107 -- interpretation. We must check for this independently of the
3108 -- analysis of the call with the user-defined operation, because
3109 -- the parameter names may be wrong and yet the hiding takes place.
3110 -- This fixes a problem with ACATS test B34014O.
3111 --
3112 -- When the type Address is a visible integer type, and the DEC
3113 -- system extension is visible, the predefined operator may be
3114 -- hidden as well, by one of the address operations in auxdec.
3115 -- Finally, The abstract operations on address do not hide the
3116 -- predefined operator (this is the purpose of making them abstract).
3117
3118 -----------------------------------
3119 -- Compatible_Types_In_Predicate --
3120 -----------------------------------
3121
3122 function Compatible_Types_In_Predicate
3123 (T1 : Entity_Id;
3124 T2 : Entity_Id) return Boolean
3125 is
3126 function Common_Type (T : Entity_Id) return Entity_Id;
3127 -- Find non-private full view if any, without going to ancestor type
3128 -- (as opposed to Underlying_Type).
3129
3130 -----------------
3131 -- Common_Type --
3132 -----------------
3133
3134 function Common_Type (T : Entity_Id) return Entity_Id is
3135 begin
3136 if Is_Private_Type (T) and then Present (Full_View (T)) then
3137 return Base_Type (Full_View (T));
3138 else
3139 return Base_Type (T);
3140 end if;
3141 end Common_Type;
3142
3143 -- Start of processing for Compatible_Types_In_Predicate
3144
3145 begin
3146 if (Ekind (Current_Scope) = E_Function
3147 and then Is_Predicate_Function (Current_Scope))
3148 or else
3149 (Ekind (Nam) = E_Function
3150 and then Is_Predicate_Function (Nam))
3151 then
3152 if Is_Incomplete_Type (T1)
3153 and then Present (Full_View (T1))
3154 and then Full_View (T1) = T2
3155 then
3156 Set_Etype (Formal, Etype (Actual));
3157 return True;
3158
3159 elsif Common_Type (T1) = Common_Type (T2) then
3160 Rewrite (Actual, Unchecked_Convert_To (Etype (Formal), Actual));
3161 return True;
3162
3163 else
3164 return False;
3165 end if;
3166
3167 else
3168 return False;
3169 end if;
3170 end Compatible_Types_In_Predicate;
3171
3172 ----------------------------
3173 -- Indicate_Name_And_Type --
3174 ----------------------------
3175
3176 procedure Indicate_Name_And_Type is
3177 begin
3178 Add_One_Interp (N, Nam, Etype (Nam));
3179 Check_Implicit_Dereference (N, Etype (Nam));
3180 Success := True;
3181
3182 -- If the prefix of the call is a name, indicate the entity
3183 -- being called. If it is not a name, it is an expression that
3184 -- denotes an access to subprogram or else an entry or family. In
3185 -- the latter case, the name is a selected component, and the entity
3186 -- being called is noted on the selector.
3187
3188 if not Is_Type (Nam) then
3189 if Is_Entity_Name (Name (N)) then
3190 Set_Entity (Name (N), Nam);
3191 Set_Etype (Name (N), Etype (Nam));
3192
3193 elsif Nkind (Name (N)) = N_Selected_Component then
3194 Set_Entity (Selector_Name (Name (N)), Nam);
3195 end if;
3196 end if;
3197
3198 if Debug_Flag_E and not Report then
3199 Write_Str (" Overloaded call ");
3200 Write_Int (Int (N));
3201 Write_Str (" compatible with ");
3202 Write_Int (Int (Nam));
3203 Write_Eol;
3204 end if;
3205 end Indicate_Name_And_Type;
3206
3207 ------------------------
3208 -- Operator_Hidden_By --
3209 ------------------------
3210
3211 function Operator_Hidden_By (Fun : Entity_Id) return Boolean is
3212 Act1 : constant Node_Id := First_Actual (N);
3213 Act2 : constant Node_Id := Next_Actual (Act1);
3214 Form1 : constant Entity_Id := First_Formal (Fun);
3215 Form2 : constant Entity_Id := Next_Formal (Form1);
3216
3217 begin
3218 if Ekind (Fun) /= E_Function or else Is_Abstract_Subprogram (Fun) then
3219 return False;
3220
3221 elsif not Has_Compatible_Type (Act1, Etype (Form1)) then
3222 return False;
3223
3224 elsif Present (Form2) then
3225 if No (Act2)
3226 or else not Has_Compatible_Type (Act2, Etype (Form2))
3227 then
3228 return False;
3229 end if;
3230
3231 elsif Present (Act2) then
3232 return False;
3233 end if;
3234
3235 -- Now we know that the arity of the operator matches the function,
3236 -- and the function call is a valid interpretation. The function
3237 -- hides the operator if it has the right signature, or if one of
3238 -- its operands is a non-abstract operation on Address when this is
3239 -- a visible integer type.
3240
3241 return Hides_Op (Fun, Nam)
3242 or else Is_Descendant_Of_Address (Etype (Form1))
3243 or else
3244 (Present (Form2)
3245 and then Is_Descendant_Of_Address (Etype (Form2)));
3246 end Operator_Hidden_By;
3247
3248 -- Start of processing for Analyze_One_Call
3249
3250 begin
3251 Success := False;
3252
3253 -- If the subprogram has no formals or if all the formals have defaults,
3254 -- and the return type is an array type, the node may denote an indexing
3255 -- of the result of a parameterless call. In Ada 2005, the subprogram
3256 -- may have one non-defaulted formal, and the call may have been written
3257 -- in prefix notation, so that the rebuilt parameter list has more than
3258 -- one actual.
3259
3260 if not Is_Overloadable (Nam)
3261 and then Ekind (Nam) /= E_Subprogram_Type
3262 and then Ekind (Nam) /= E_Entry_Family
3263 then
3264 return;
3265 end if;
3266
3267 -- An indexing requires at least one actual. The name of the call cannot
3268 -- be an implicit indirect call, so it cannot be a generated explicit
3269 -- dereference.
3270
3271 if not Is_Empty_List (Actuals)
3272 and then
3273 (Needs_No_Actuals (Nam)
3274 or else
3275 (Needs_One_Actual (Nam)
3276 and then Present (Next_Actual (First (Actuals)))))
3277 then
3278 if Is_Array_Type (Subp_Type)
3279 and then
3280 (Nkind (Name (N)) /= N_Explicit_Dereference
3281 or else Comes_From_Source (Name (N)))
3282 then
3283 Is_Indexed := Try_Indexed_Call (N, Nam, Subp_Type, Must_Skip);
3284
3285 elsif Is_Access_Type (Subp_Type)
3286 and then Is_Array_Type (Designated_Type (Subp_Type))
3287 then
3288 Is_Indexed :=
3289 Try_Indexed_Call
3290 (N, Nam, Designated_Type (Subp_Type), Must_Skip);
3291
3292 -- The prefix can also be a parameterless function that returns an
3293 -- access to subprogram, in which case this is an indirect call.
3294 -- If this succeeds, an explicit dereference is added later on,
3295 -- in Analyze_Call or Resolve_Call.
3296
3297 elsif Is_Access_Type (Subp_Type)
3298 and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type
3299 then
3300 Is_Indirect := Try_Indirect_Call (N, Nam, Subp_Type);
3301 end if;
3302
3303 end if;
3304
3305 -- If the call has been transformed into a slice, it is of the form
3306 -- F (Subtype) where F is parameterless. The node has been rewritten in
3307 -- Try_Indexed_Call and there is nothing else to do.
3308
3309 if Is_Indexed
3310 and then Nkind (N) = N_Slice
3311 then
3312 return;
3313 end if;
3314
3315 Normalize_Actuals
3316 (N, Nam, (Report and not Is_Indexed and not Is_Indirect), Norm_OK);
3317
3318 if not Norm_OK then
3319
3320 -- If an indirect call is a possible interpretation, indicate
3321 -- success to the caller. This may be an indexing of an explicit
3322 -- dereference of a call that returns an access type (see above).
3323
3324 if Is_Indirect
3325 or else (Is_Indexed
3326 and then Nkind (Name (N)) = N_Explicit_Dereference
3327 and then Comes_From_Source (Name (N)))
3328 then
3329 Success := True;
3330 return;
3331
3332 -- Mismatch in number or names of parameters
3333
3334 elsif Debug_Flag_E then
3335 Write_Str (" normalization fails in call ");
3336 Write_Int (Int (N));
3337 Write_Str (" with subprogram ");
3338 Write_Int (Int (Nam));
3339 Write_Eol;
3340 end if;
3341
3342 -- If the context expects a function call, discard any interpretation
3343 -- that is a procedure. If the node is not overloaded, leave as is for
3344 -- better error reporting when type mismatch is found.
3345
3346 elsif Nkind (N) = N_Function_Call
3347 and then Is_Overloaded (Name (N))
3348 and then Ekind (Nam) = E_Procedure
3349 then
3350 return;
3351
3352 -- Ditto for function calls in a procedure context
3353
3354 elsif Nkind (N) = N_Procedure_Call_Statement
3355 and then Is_Overloaded (Name (N))
3356 and then Etype (Nam) /= Standard_Void_Type
3357 then
3358 return;
3359
3360 elsif No (Actuals) then
3361
3362 -- If Normalize succeeds, then there are default parameters for
3363 -- all formals.
3364
3365 Indicate_Name_And_Type;
3366
3367 elsif Ekind (Nam) = E_Operator then
3368 if Nkind (N) = N_Procedure_Call_Statement then
3369 return;
3370 end if;
3371
3372 -- This can occur when the prefix of the call is an operator
3373 -- name or an expanded name whose selector is an operator name.
3374
3375 Analyze_Operator_Call (N, Nam);
3376
3377 if Etype (N) /= Prev_T then
3378
3379 -- Check that operator is not hidden by a function interpretation
3380
3381 if Is_Overloaded (Name (N)) then
3382 declare
3383 I : Interp_Index;
3384 It : Interp;
3385
3386 begin
3387 Get_First_Interp (Name (N), I, It);
3388 while Present (It.Nam) loop
3389 if Operator_Hidden_By (It.Nam) then
3390 Set_Etype (N, Prev_T);
3391 return;
3392 end if;
3393
3394 Get_Next_Interp (I, It);
3395 end loop;
3396 end;
3397 end if;
3398
3399 -- If operator matches formals, record its name on the call.
3400 -- If the operator is overloaded, Resolve will select the
3401 -- correct one from the list of interpretations. The call
3402 -- node itself carries the first candidate.
3403
3404 Set_Entity (Name (N), Nam);
3405 Success := True;
3406
3407 elsif Report and then Etype (N) = Any_Type then
3408 Error_Msg_N ("incompatible arguments for operator", N);
3409 end if;
3410
3411 else
3412 -- Normalize_Actuals has chained the named associations in the
3413 -- correct order of the formals.
3414
3415 Actual := First_Actual (N);
3416 Formal := First_Formal (Nam);
3417
3418 -- If we are analyzing a call rewritten from object notation, skip
3419 -- first actual, which may be rewritten later as an explicit
3420 -- dereference.
3421
3422 if Must_Skip then
3423 Next_Actual (Actual);
3424 Next_Formal (Formal);
3425 end if;
3426
3427 while Present (Actual) and then Present (Formal) loop
3428 if Nkind (Parent (Actual)) /= N_Parameter_Association
3429 or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal)
3430 then
3431 -- The actual can be compatible with the formal, but we must
3432 -- also check that the context is not an address type that is
3433 -- visibly an integer type. In this case the use of literals is
3434 -- illegal, except in the body of descendants of system, where
3435 -- arithmetic operations on address are of course used.
3436
3437 if Has_Compatible_Type (Actual, Etype (Formal))
3438 and then
3439 (Etype (Actual) /= Universal_Integer
3440 or else not Is_Descendant_Of_Address (Etype (Formal))
3441 or else
3442 Is_Predefined_File_Name
3443 (Unit_File_Name (Get_Source_Unit (N))))
3444 then
3445 Next_Actual (Actual);
3446 Next_Formal (Formal);
3447
3448 -- In Allow_Integer_Address mode, we allow an actual integer to
3449 -- match a formal address type and vice versa. We only do this
3450 -- if we are certain that an error will otherwise be issued
3451
3452 elsif Address_Integer_Convert_OK
3453 (Etype (Actual), Etype (Formal))
3454 and then (Report and not Is_Indexed and not Is_Indirect)
3455 then
3456 -- Handle this case by introducing an unchecked conversion
3457
3458 Rewrite (Actual,
3459 Unchecked_Convert_To (Etype (Formal),
3460 Relocate_Node (Actual)));
3461 Analyze_And_Resolve (Actual, Etype (Formal));
3462 Next_Actual (Actual);
3463 Next_Formal (Formal);
3464
3465 -- Under relaxed RM semantics silently replace occurrences of
3466 -- null by System.Address_Null. We only do this if we know that
3467 -- an error will otherwise be issued.
3468
3469 elsif Null_To_Null_Address_Convert_OK (Actual, Etype (Formal))
3470 and then (Report and not Is_Indexed and not Is_Indirect)
3471 then
3472 Replace_Null_By_Null_Address (Actual);
3473 Analyze_And_Resolve (Actual, Etype (Formal));
3474 Next_Actual (Actual);
3475 Next_Formal (Formal);
3476
3477 elsif Compatible_Types_In_Predicate
3478 (Etype (Formal), Etype (Actual))
3479 then
3480 Next_Actual (Actual);
3481 Next_Formal (Formal);
3482
3483 else
3484 if Debug_Flag_E then
3485 Write_Str (" type checking fails in call ");
3486 Write_Int (Int (N));
3487 Write_Str (" with formal ");
3488 Write_Int (Int (Formal));
3489 Write_Str (" in subprogram ");
3490 Write_Int (Int (Nam));
3491 Write_Eol;
3492 end if;
3493
3494 -- Comment needed on the following test???
3495
3496 if Report and not Is_Indexed and not Is_Indirect then
3497
3498 -- Ada 2005 (AI-251): Complete the error notification
3499 -- to help new Ada 2005 users.
3500
3501 if Is_Class_Wide_Type (Etype (Formal))
3502 and then Is_Interface (Etype (Etype (Formal)))
3503 and then not Interface_Present_In_Ancestor
3504 (Typ => Etype (Actual),
3505 Iface => Etype (Etype (Formal)))
3506 then
3507 Error_Msg_NE
3508 ("(Ada 2005) does not implement interface }",
3509 Actual, Etype (Etype (Formal)));
3510 end if;
3511
3512 Wrong_Type (Actual, Etype (Formal));
3513
3514 if Nkind (Actual) = N_Op_Eq
3515 and then Nkind (Left_Opnd (Actual)) = N_Identifier
3516 then
3517 Formal := First_Formal (Nam);
3518 while Present (Formal) loop
3519 if Chars (Left_Opnd (Actual)) = Chars (Formal) then
3520 Error_Msg_N -- CODEFIX
3521 ("possible misspelling of `='>`!", Actual);
3522 exit;
3523 end if;
3524
3525 Next_Formal (Formal);
3526 end loop;
3527 end if;
3528
3529 if All_Errors_Mode then
3530 Error_Msg_Sloc := Sloc (Nam);
3531
3532 if Etype (Formal) = Any_Type then
3533 Error_Msg_N
3534 ("there is no legal actual parameter", Actual);
3535 end if;
3536
3537 if Is_Overloadable (Nam)
3538 and then Present (Alias (Nam))
3539 and then not Comes_From_Source (Nam)
3540 then
3541 Error_Msg_NE
3542 ("\\ =='> in call to inherited operation & #!",
3543 Actual, Nam);
3544
3545 elsif Ekind (Nam) = E_Subprogram_Type then
3546 declare
3547 Access_To_Subprogram_Typ :
3548 constant Entity_Id :=
3549 Defining_Identifier
3550 (Associated_Node_For_Itype (Nam));
3551 begin
3552 Error_Msg_NE
3553 ("\\ =='> in call to dereference of &#!",
3554 Actual, Access_To_Subprogram_Typ);
3555 end;
3556
3557 else
3558 Error_Msg_NE
3559 ("\\ =='> in call to &#!", Actual, Nam);
3560
3561 end if;
3562 end if;
3563 end if;
3564
3565 return;
3566 end if;
3567
3568 else
3569 -- Normalize_Actuals has verified that a default value exists
3570 -- for this formal. Current actual names a subsequent formal.
3571
3572 Next_Formal (Formal);
3573 end if;
3574 end loop;
3575
3576 -- On exit, all actuals match
3577
3578 Indicate_Name_And_Type;
3579 end if;
3580 end Analyze_One_Call;
3581
3582 ---------------------------
3583 -- Analyze_Operator_Call --
3584 ---------------------------
3585
3586 procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id) is
3587 Op_Name : constant Name_Id := Chars (Op_Id);
3588 Act1 : constant Node_Id := First_Actual (N);
3589 Act2 : constant Node_Id := Next_Actual (Act1);
3590
3591 begin
3592 -- Binary operator case
3593
3594 if Present (Act2) then
3595
3596 -- If more than two operands, then not binary operator after all
3597
3598 if Present (Next_Actual (Act2)) then
3599 return;
3600 end if;
3601
3602 -- Otherwise action depends on operator
3603
3604 case Op_Name is
3605 when Name_Op_Add |
3606 Name_Op_Subtract |
3607 Name_Op_Multiply |
3608 Name_Op_Divide |
3609 Name_Op_Mod |
3610 Name_Op_Rem |
3611 Name_Op_Expon =>
3612 Find_Arithmetic_Types (Act1, Act2, Op_Id, N);
3613
3614 when Name_Op_And |
3615 Name_Op_Or |
3616 Name_Op_Xor =>
3617 Find_Boolean_Types (Act1, Act2, Op_Id, N);
3618
3619 when Name_Op_Lt |
3620 Name_Op_Le |
3621 Name_Op_Gt |
3622 Name_Op_Ge =>
3623 Find_Comparison_Types (Act1, Act2, Op_Id, N);
3624
3625 when Name_Op_Eq |
3626 Name_Op_Ne =>
3627 Find_Equality_Types (Act1, Act2, Op_Id, N);
3628
3629 when Name_Op_Concat =>
3630 Find_Concatenation_Types (Act1, Act2, Op_Id, N);
3631
3632 -- Is this when others, or should it be an abort???
3633
3634 when others =>
3635 null;
3636 end case;
3637
3638 -- Unary operator case
3639
3640 else
3641 case Op_Name is
3642 when Name_Op_Subtract |
3643 Name_Op_Add |
3644 Name_Op_Abs =>
3645 Find_Unary_Types (Act1, Op_Id, N);
3646
3647 when Name_Op_Not =>
3648 Find_Negation_Types (Act1, Op_Id, N);
3649
3650 -- Is this when others correct, or should it be an abort???
3651
3652 when others =>
3653 null;
3654 end case;
3655 end if;
3656 end Analyze_Operator_Call;
3657
3658 -------------------------------------------
3659 -- Analyze_Overloaded_Selected_Component --
3660 -------------------------------------------
3661
3662 procedure Analyze_Overloaded_Selected_Component (N : Node_Id) is
3663 Nam : constant Node_Id := Prefix (N);
3664 Sel : constant Node_Id := Selector_Name (N);
3665 Comp : Entity_Id;
3666 I : Interp_Index;
3667 It : Interp;
3668 T : Entity_Id;
3669
3670 begin
3671 Set_Etype (Sel, Any_Type);
3672
3673 Get_First_Interp (Nam, I, It);
3674 while Present (It.Typ) loop
3675 if Is_Access_Type (It.Typ) then
3676 T := Designated_Type (It.Typ);
3677 Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N);
3678 else
3679 T := It.Typ;
3680 end if;
3681
3682 -- Locate the component. For a private prefix the selector can denote
3683 -- a discriminant.
3684
3685 if Is_Record_Type (T) or else Is_Private_Type (T) then
3686
3687 -- If the prefix is a class-wide type, the visible components are
3688 -- those of the base type.
3689
3690 if Is_Class_Wide_Type (T) then
3691 T := Etype (T);
3692 end if;
3693
3694 Comp := First_Entity (T);
3695 while Present (Comp) loop
3696 if Chars (Comp) = Chars (Sel)
3697 and then Is_Visible_Component (Comp)
3698 then
3699
3700 -- AI05-105: if the context is an object renaming with
3701 -- an anonymous access type, the expected type of the
3702 -- object must be anonymous. This is a name resolution rule.
3703
3704 if Nkind (Parent (N)) /= N_Object_Renaming_Declaration
3705 or else No (Access_Definition (Parent (N)))
3706 or else Ekind (Etype (Comp)) = E_Anonymous_Access_Type
3707 or else
3708 Ekind (Etype (Comp)) = E_Anonymous_Access_Subprogram_Type
3709 then
3710 Set_Entity (Sel, Comp);
3711 Set_Etype (Sel, Etype (Comp));
3712 Add_One_Interp (N, Etype (Comp), Etype (Comp));
3713 Check_Implicit_Dereference (N, Etype (Comp));
3714
3715 -- This also specifies a candidate to resolve the name.
3716 -- Further overloading will be resolved from context.
3717 -- The selector name itself does not carry overloading
3718 -- information.
3719
3720 Set_Etype (Nam, It.Typ);
3721
3722 else
3723 -- Named access type in the context of a renaming
3724 -- declaration with an access definition. Remove
3725 -- inapplicable candidate.
3726
3727 Remove_Interp (I);
3728 end if;
3729 end if;
3730
3731 Next_Entity (Comp);
3732 end loop;
3733
3734 elsif Is_Concurrent_Type (T) then
3735 Comp := First_Entity (T);
3736 while Present (Comp)
3737 and then Comp /= First_Private_Entity (T)
3738 loop
3739 if Chars (Comp) = Chars (Sel) then
3740 if Is_Overloadable (Comp) then
3741 Add_One_Interp (Sel, Comp, Etype (Comp));
3742 else
3743 Set_Entity_With_Checks (Sel, Comp);
3744 Generate_Reference (Comp, Sel);
3745 end if;
3746
3747 Set_Etype (Sel, Etype (Comp));
3748 Set_Etype (N, Etype (Comp));
3749 Set_Etype (Nam, It.Typ);
3750
3751 -- For access type case, introduce explicit dereference for
3752 -- more uniform treatment of entry calls. Do this only once
3753 -- if several interpretations yield an access type.
3754
3755 if Is_Access_Type (Etype (Nam))
3756 and then Nkind (Nam) /= N_Explicit_Dereference
3757 then
3758 Insert_Explicit_Dereference (Nam);
3759 Error_Msg_NW
3760 (Warn_On_Dereference, "?d?implicit dereference", N);
3761 end if;
3762 end if;
3763
3764 Next_Entity (Comp);
3765 end loop;
3766
3767 Set_Is_Overloaded (N, Is_Overloaded (Sel));
3768 end if;
3769
3770 Get_Next_Interp (I, It);
3771 end loop;
3772
3773 if Etype (N) = Any_Type
3774 and then not Try_Object_Operation (N)
3775 then
3776 Error_Msg_NE ("undefined selector& for overloaded prefix", N, Sel);
3777 Set_Entity (Sel, Any_Id);
3778 Set_Etype (Sel, Any_Type);
3779 end if;
3780 end Analyze_Overloaded_Selected_Component;
3781
3782 ----------------------------------
3783 -- Analyze_Qualified_Expression --
3784 ----------------------------------
3785
3786 procedure Analyze_Qualified_Expression (N : Node_Id) is
3787 Mark : constant Entity_Id := Subtype_Mark (N);
3788 Expr : constant Node_Id := Expression (N);
3789 I : Interp_Index;
3790 It : Interp;
3791 T : Entity_Id;
3792
3793 begin
3794 Analyze_Expression (Expr);
3795
3796 Set_Etype (N, Any_Type);
3797 Find_Type (Mark);
3798 T := Entity (Mark);
3799 Set_Etype (N, T);
3800
3801 if T = Any_Type then
3802 return;
3803 end if;
3804
3805 Check_Fully_Declared (T, N);
3806
3807 -- If expected type is class-wide, check for exact match before
3808 -- expansion, because if the expression is a dispatching call it
3809 -- may be rewritten as explicit dereference with class-wide result.
3810 -- If expression is overloaded, retain only interpretations that
3811 -- will yield exact matches.
3812
3813 if Is_Class_Wide_Type (T) then
3814 if not Is_Overloaded (Expr) then
3815 if Base_Type (Etype (Expr)) /= Base_Type (T) then
3816 if Nkind (Expr) = N_Aggregate then
3817 Error_Msg_N ("type of aggregate cannot be class-wide", Expr);
3818 else
3819 Wrong_Type (Expr, T);
3820 end if;
3821 end if;
3822
3823 else
3824 Get_First_Interp (Expr, I, It);
3825
3826 while Present (It.Nam) loop
3827 if Base_Type (It.Typ) /= Base_Type (T) then
3828 Remove_Interp (I);
3829 end if;
3830
3831 Get_Next_Interp (I, It);
3832 end loop;
3833 end if;
3834 end if;
3835
3836 Set_Etype (N, T);
3837 end Analyze_Qualified_Expression;
3838
3839 -----------------------------------
3840 -- Analyze_Quantified_Expression --
3841 -----------------------------------
3842
3843 procedure Analyze_Quantified_Expression (N : Node_Id) is
3844 function Is_Empty_Range (Typ : Entity_Id) return Boolean;
3845 -- If the iterator is part of a quantified expression, and the range is
3846 -- known to be statically empty, emit a warning and replace expression
3847 -- with its static value. Returns True if the replacement occurs.
3848
3849 function No_Else_Or_Trivial_True (If_Expr : Node_Id) return Boolean;
3850 -- Determine whether if expression If_Expr lacks an else part or if it
3851 -- has one, it evaluates to True.
3852
3853 --------------------
3854 -- Is_Empty_Range --
3855 --------------------
3856
3857 function Is_Empty_Range (Typ : Entity_Id) return Boolean is
3858 Loc : constant Source_Ptr := Sloc (N);
3859
3860 begin
3861 if Is_Array_Type (Typ)
3862 and then Compile_Time_Known_Bounds (Typ)
3863 and then
3864 (Expr_Value (Type_Low_Bound (Etype (First_Index (Typ)))) >
3865 Expr_Value (Type_High_Bound (Etype (First_Index (Typ)))))
3866 then
3867 Preanalyze_And_Resolve (Condition (N), Standard_Boolean);
3868
3869 if All_Present (N) then
3870 Error_Msg_N
3871 ("??quantified expression with ALL "
3872 & "over a null range has value True", N);
3873 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
3874
3875 else
3876 Error_Msg_N
3877 ("??quantified expression with SOME "
3878 & "over a null range has value False", N);
3879 Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
3880 end if;
3881
3882 Analyze (N);
3883 return True;
3884
3885 else
3886 return False;
3887 end if;
3888 end Is_Empty_Range;
3889
3890 -----------------------------
3891 -- No_Else_Or_Trivial_True --
3892 -----------------------------
3893
3894 function No_Else_Or_Trivial_True (If_Expr : Node_Id) return Boolean is
3895 Else_Expr : constant Node_Id :=
3896 Next (Next (First (Expressions (If_Expr))));
3897 begin
3898 return
3899 No (Else_Expr)
3900 or else (Compile_Time_Known_Value (Else_Expr)
3901 and then Is_True (Expr_Value (Else_Expr)));
3902 end No_Else_Or_Trivial_True;
3903
3904 -- Local variables
3905
3906 Cond : constant Node_Id := Condition (N);
3907 Loop_Id : Entity_Id;
3908 QE_Scop : Entity_Id;
3909
3910 -- Start of processing for Analyze_Quantified_Expression
3911
3912 begin
3913 Check_SPARK_05_Restriction ("quantified expression is not allowed", N);
3914
3915 -- Create a scope to emulate the loop-like behavior of the quantified
3916 -- expression. The scope is needed to provide proper visibility of the
3917 -- loop variable.
3918
3919 QE_Scop := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L');
3920 Set_Etype (QE_Scop, Standard_Void_Type);
3921 Set_Scope (QE_Scop, Current_Scope);
3922 Set_Parent (QE_Scop, N);
3923
3924 Push_Scope (QE_Scop);
3925
3926 -- All constituents are preanalyzed and resolved to avoid untimely
3927 -- generation of various temporaries and types. Full analysis and
3928 -- expansion is carried out when the quantified expression is
3929 -- transformed into an expression with actions.
3930
3931 if Present (Iterator_Specification (N)) then
3932 Preanalyze (Iterator_Specification (N));
3933
3934 -- Do not proceed with the analysis when the range of iteration is
3935 -- empty. The appropriate error is issued by Is_Empty_Range.
3936
3937 if Is_Entity_Name (Name (Iterator_Specification (N)))
3938 and then Is_Empty_Range (Etype (Name (Iterator_Specification (N))))
3939 then
3940 return;
3941 end if;
3942
3943 else pragma Assert (Present (Loop_Parameter_Specification (N)));
3944 declare
3945 Loop_Par : constant Node_Id := Loop_Parameter_Specification (N);
3946
3947 begin
3948 Preanalyze (Loop_Par);
3949
3950 if Nkind (Discrete_Subtype_Definition (Loop_Par)) = N_Function_Call
3951 and then Parent (Loop_Par) /= N
3952 then
3953 -- The parser cannot distinguish between a loop specification
3954 -- and an iterator specification. If after pre-analysis the
3955 -- proper form has been recognized, rewrite the expression to
3956 -- reflect the right kind. This is needed for proper ASIS
3957 -- navigation. If expansion is enabled, the transformation is
3958 -- performed when the expression is rewritten as a loop.
3959
3960 Set_Iterator_Specification (N,
3961 New_Copy_Tree (Iterator_Specification (Parent (Loop_Par))));
3962
3963 Set_Defining_Identifier (Iterator_Specification (N),
3964 Relocate_Node (Defining_Identifier (Loop_Par)));
3965 Set_Name (Iterator_Specification (N),
3966 Relocate_Node (Discrete_Subtype_Definition (Loop_Par)));
3967 Set_Comes_From_Source (Iterator_Specification (N),
3968 Comes_From_Source (Loop_Parameter_Specification (N)));
3969 Set_Loop_Parameter_Specification (N, Empty);
3970 end if;
3971 end;
3972 end if;
3973
3974 Preanalyze_And_Resolve (Cond, Standard_Boolean);
3975
3976 End_Scope;
3977 Set_Etype (N, Standard_Boolean);
3978
3979 -- Verify that the loop variable is used within the condition of the
3980 -- quantified expression.
3981
3982 if Present (Iterator_Specification (N)) then
3983 Loop_Id := Defining_Identifier (Iterator_Specification (N));
3984 else
3985 Loop_Id := Defining_Identifier (Loop_Parameter_Specification (N));
3986 end if;
3987
3988 if Warn_On_Suspicious_Contract
3989 and then not Referenced (Loop_Id, Cond)
3990 then
3991 -- Generating C, this check causes spurious warnings on inlined
3992 -- postconditions; we can safely disable it because this check
3993 -- was previously performed when analyzing the internally built
3994 -- postconditions procedure.
3995
3996 if Modify_Tree_For_C and then In_Inlined_Body then
3997 null;
3998 else
3999 Error_Msg_N ("?T?unused variable &", Loop_Id);
4000 end if;
4001 end if;
4002
4003 -- Diagnose a possible misuse of the SOME existential quantifier. When
4004 -- we have a quantified expression of the form:
4005
4006 -- for some X => (if P then Q [else True])
4007
4008 -- any value for X that makes P False results in the if expression being
4009 -- trivially True, and so also results in the quantified expression
4010 -- being trivially True.
4011
4012 if Warn_On_Suspicious_Contract
4013 and then not All_Present (N)
4014 and then Nkind (Cond) = N_If_Expression
4015 and then No_Else_Or_Trivial_True (Cond)
4016 then
4017 Error_Msg_N ("?T?suspicious expression", N);
4018 Error_Msg_N ("\\did you mean (for all X ='> (if P then Q))", N);
4019 Error_Msg_N ("\\or (for some X ='> P and then Q) instead'?", N);
4020 end if;
4021 end Analyze_Quantified_Expression;
4022
4023 -------------------
4024 -- Analyze_Range --
4025 -------------------
4026
4027 procedure Analyze_Range (N : Node_Id) is
4028 L : constant Node_Id := Low_Bound (N);
4029 H : constant Node_Id := High_Bound (N);
4030 I1, I2 : Interp_Index;
4031 It1, It2 : Interp;
4032
4033 procedure Check_Common_Type (T1, T2 : Entity_Id);
4034 -- Verify the compatibility of two types, and choose the
4035 -- non universal one if the other is universal.
4036
4037 procedure Check_High_Bound (T : Entity_Id);
4038 -- Test one interpretation of the low bound against all those
4039 -- of the high bound.
4040
4041 procedure Check_Universal_Expression (N : Node_Id);
4042 -- In Ada 83, reject bounds of a universal range that are not literals
4043 -- or entity names.
4044
4045 -----------------------
4046 -- Check_Common_Type --
4047 -----------------------
4048
4049 procedure Check_Common_Type (T1, T2 : Entity_Id) is
4050 begin
4051 if Covers (T1 => T1, T2 => T2)
4052 or else
4053 Covers (T1 => T2, T2 => T1)
4054 then
4055 if T1 = Universal_Integer
4056 or else T1 = Universal_Real
4057 or else T1 = Any_Character
4058 then
4059 Add_One_Interp (N, Base_Type (T2), Base_Type (T2));
4060
4061 elsif T1 = T2 then
4062 Add_One_Interp (N, T1, T1);
4063
4064 else
4065 Add_One_Interp (N, Base_Type (T1), Base_Type (T1));
4066 end if;
4067 end if;
4068 end Check_Common_Type;
4069
4070 ----------------------
4071 -- Check_High_Bound --
4072 ----------------------
4073
4074 procedure Check_High_Bound (T : Entity_Id) is
4075 begin
4076 if not Is_Overloaded (H) then
4077 Check_Common_Type (T, Etype (H));
4078 else
4079 Get_First_Interp (H, I2, It2);
4080 while Present (It2.Typ) loop
4081 Check_Common_Type (T, It2.Typ);
4082 Get_Next_Interp (I2, It2);
4083 end loop;
4084 end if;
4085 end Check_High_Bound;
4086
4087 -----------------------------
4088 -- Is_Universal_Expression --
4089 -----------------------------
4090
4091 procedure Check_Universal_Expression (N : Node_Id) is
4092 begin
4093 if Etype (N) = Universal_Integer
4094 and then Nkind (N) /= N_Integer_Literal
4095 and then not Is_Entity_Name (N)
4096 and then Nkind (N) /= N_Attribute_Reference
4097 then
4098 Error_Msg_N ("illegal bound in discrete range", N);
4099 end if;
4100 end Check_Universal_Expression;
4101
4102 -- Start of processing for Analyze_Range
4103
4104 begin
4105 Set_Etype (N, Any_Type);
4106 Analyze_Expression (L);
4107 Analyze_Expression (H);
4108
4109 if Etype (L) = Any_Type or else Etype (H) = Any_Type then
4110 return;
4111
4112 else
4113 if not Is_Overloaded (L) then
4114 Check_High_Bound (Etype (L));
4115 else
4116 Get_First_Interp (L, I1, It1);
4117 while Present (It1.Typ) loop
4118 Check_High_Bound (It1.Typ);
4119 Get_Next_Interp (I1, It1);
4120 end loop;
4121 end if;
4122
4123 -- If result is Any_Type, then we did not find a compatible pair
4124
4125 if Etype (N) = Any_Type then
4126 Error_Msg_N ("incompatible types in range ", N);
4127 end if;
4128 end if;
4129
4130 if Ada_Version = Ada_83
4131 and then
4132 (Nkind (Parent (N)) = N_Loop_Parameter_Specification
4133 or else Nkind (Parent (N)) = N_Constrained_Array_Definition)
4134 then
4135 Check_Universal_Expression (L);
4136 Check_Universal_Expression (H);
4137 end if;
4138
4139 Check_Function_Writable_Actuals (N);
4140 end Analyze_Range;
4141
4142 -----------------------
4143 -- Analyze_Reference --
4144 -----------------------
4145
4146 procedure Analyze_Reference (N : Node_Id) is
4147 P : constant Node_Id := Prefix (N);
4148 E : Entity_Id;
4149 T : Entity_Id;
4150 Acc_Type : Entity_Id;
4151
4152 begin
4153 Analyze (P);
4154
4155 -- An interesting error check, if we take the 'Ref of an object for
4156 -- which a pragma Atomic or Volatile has been given, and the type of the
4157 -- object is not Atomic or Volatile, then we are in trouble. The problem
4158 -- is that no trace of the atomic/volatile status will remain for the
4159 -- backend to respect when it deals with the resulting pointer, since
4160 -- the pointer type will not be marked atomic (it is a pointer to the
4161 -- base type of the object).
4162
4163 -- It is not clear if that can ever occur, but in case it does, we will
4164 -- generate an error message. Not clear if this message can ever be
4165 -- generated, and pretty clear that it represents a bug if it is, still
4166 -- seems worth checking, except in CodePeer mode where we do not really
4167 -- care and don't want to bother the user.
4168
4169 T := Etype (P);
4170
4171 if Is_Entity_Name (P)
4172 and then Is_Object_Reference (P)
4173 and then not CodePeer_Mode
4174 then
4175 E := Entity (P);
4176 T := Etype (P);
4177
4178 if (Has_Atomic_Components (E)
4179 and then not Has_Atomic_Components (T))
4180 or else
4181 (Has_Volatile_Components (E)
4182 and then not Has_Volatile_Components (T))
4183 or else (Is_Atomic (E) and then not Is_Atomic (T))
4184 or else (Is_Volatile (E) and then not Is_Volatile (T))
4185 then
4186 Error_Msg_N ("cannot take reference to Atomic/Volatile object", N);
4187 end if;
4188 end if;
4189
4190 -- Carry on with normal processing
4191
4192 Acc_Type := Create_Itype (E_Allocator_Type, N);
4193 Set_Etype (Acc_Type, Acc_Type);
4194 Set_Directly_Designated_Type (Acc_Type, Etype (P));
4195 Set_Etype (N, Acc_Type);
4196 end Analyze_Reference;
4197
4198 --------------------------------
4199 -- Analyze_Selected_Component --
4200 --------------------------------
4201
4202 -- Prefix is a record type or a task or protected type. In the latter case,
4203 -- the selector must denote a visible entry.
4204
4205 procedure Analyze_Selected_Component (N : Node_Id) is
4206 Name : constant Node_Id := Prefix (N);
4207 Sel : constant Node_Id := Selector_Name (N);
4208 Act_Decl : Node_Id;
4209 Comp : Entity_Id;
4210 Has_Candidate : Boolean := False;
4211 In_Scope : Boolean;
4212 Parent_N : Node_Id;
4213 Pent : Entity_Id := Empty;
4214 Prefix_Type : Entity_Id;
4215
4216 Type_To_Use : Entity_Id;
4217 -- In most cases this is the Prefix_Type, but if the Prefix_Type is
4218 -- a class-wide type, we use its root type, whose components are
4219 -- present in the class-wide type.
4220
4221 Is_Single_Concurrent_Object : Boolean;
4222 -- Set True if the prefix is a single task or a single protected object
4223
4224 procedure Find_Component_In_Instance (Rec : Entity_Id);
4225 -- In an instance, a component of a private extension may not be visible
4226 -- while it was visible in the generic. Search candidate scope for a
4227 -- component with the proper identifier. This is only done if all other
4228 -- searches have failed. If a match is found, the Etype of both N and
4229 -- Sel are set from this component, and the entity of Sel is set to
4230 -- reference this component. If no match is found, Entity (Sel) remains
4231 -- unset. For a derived type that is an actual of the instance, the
4232 -- desired component may be found in any ancestor.
4233
4234 function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean;
4235 -- It is known that the parent of N denotes a subprogram call. Comp
4236 -- is an overloadable component of the concurrent type of the prefix.
4237 -- Determine whether all formals of the parent of N and Comp are mode
4238 -- conformant. If the parent node is not analyzed yet it may be an
4239 -- indexed component rather than a function call.
4240
4241 function Has_Dereference (Nod : Node_Id) return Boolean;
4242 -- Check whether prefix includes a dereference at any level.
4243
4244 --------------------------------
4245 -- Find_Component_In_Instance --
4246 --------------------------------
4247
4248 procedure Find_Component_In_Instance (Rec : Entity_Id) is
4249 Comp : Entity_Id;
4250 Typ : Entity_Id;
4251
4252 begin
4253 Typ := Rec;
4254 while Present (Typ) loop
4255 Comp := First_Component (Typ);
4256 while Present (Comp) loop
4257 if Chars (Comp) = Chars (Sel) then
4258 Set_Entity_With_Checks (Sel, Comp);
4259 Set_Etype (Sel, Etype (Comp));
4260 Set_Etype (N, Etype (Comp));
4261 return;
4262 end if;
4263
4264 Next_Component (Comp);
4265 end loop;
4266
4267 -- If not found, the component may be declared in the parent
4268 -- type or its full view, if any.
4269
4270 if Is_Derived_Type (Typ) then
4271 Typ := Etype (Typ);
4272
4273 if Is_Private_Type (Typ) then
4274 Typ := Full_View (Typ);
4275 end if;
4276
4277 else
4278 return;
4279 end if;
4280 end loop;
4281
4282 -- If we fall through, no match, so no changes made
4283
4284 return;
4285 end Find_Component_In_Instance;
4286
4287 ------------------------------
4288 -- Has_Mode_Conformant_Spec --
4289 ------------------------------
4290
4291 function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean is
4292 Comp_Param : Entity_Id;
4293 Param : Node_Id;
4294 Param_Typ : Entity_Id;
4295
4296 begin
4297 Comp_Param := First_Formal (Comp);
4298
4299 if Nkind (Parent (N)) = N_Indexed_Component then
4300 Param := First (Expressions (Parent (N)));
4301 else
4302 Param := First (Parameter_Associations (Parent (N)));
4303 end if;
4304
4305 while Present (Comp_Param)
4306 and then Present (Param)
4307 loop
4308 Param_Typ := Find_Parameter_Type (Param);
4309
4310 if Present (Param_Typ)
4311 and then
4312 not Conforming_Types
4313 (Etype (Comp_Param), Param_Typ, Mode_Conformant)
4314 then
4315 return False;
4316 end if;
4317
4318 Next_Formal (Comp_Param);
4319 Next (Param);
4320 end loop;
4321
4322 -- One of the specs has additional formals; there is no match, unless
4323 -- this may be an indexing of a parameterless call.
4324
4325 -- Note that when expansion is disabled, the corresponding record
4326 -- type of synchronized types is not constructed, so that there is
4327 -- no point is attempting an interpretation as a prefixed call, as
4328 -- this is bound to fail because the primitive operations will not
4329 -- be properly located.
4330
4331 if Present (Comp_Param) or else Present (Param) then
4332 if Needs_No_Actuals (Comp)
4333 and then Is_Array_Type (Etype (Comp))
4334 and then not Expander_Active
4335 then
4336 return True;
4337 else
4338 return False;
4339 end if;
4340 end if;
4341
4342 return True;
4343 end Has_Mode_Conformant_Spec;
4344
4345 ---------------------
4346 -- Has_Dereference --
4347 ---------------------
4348
4349 function Has_Dereference (Nod : Node_Id) return Boolean is
4350 begin
4351 if Nkind (Nod) = N_Explicit_Dereference then
4352 return True;
4353
4354 -- When expansion is disabled an explicit dereference may not have
4355 -- been inserted, but if this is an access type the indirection makes
4356 -- the call safe.
4357
4358 elsif Is_Access_Type (Etype (Nod)) then
4359 return True;
4360
4361 elsif Nkind_In (Nod, N_Indexed_Component, N_Selected_Component) then
4362 return Has_Dereference (Prefix (Nod));
4363
4364 else
4365 return False;
4366 end if;
4367 end Has_Dereference;
4368
4369 -- Start of processing for Analyze_Selected_Component
4370
4371 begin
4372 Set_Etype (N, Any_Type);
4373
4374 if Is_Overloaded (Name) then
4375 Analyze_Overloaded_Selected_Component (N);
4376 return;
4377
4378 elsif Etype (Name) = Any_Type then
4379 Set_Entity (Sel, Any_Id);
4380 Set_Etype (Sel, Any_Type);
4381 return;
4382
4383 else
4384 Prefix_Type := Etype (Name);
4385 end if;
4386
4387 if Is_Access_Type (Prefix_Type) then
4388
4389 -- A RACW object can never be used as prefix of a selected component
4390 -- since that means it is dereferenced without being a controlling
4391 -- operand of a dispatching operation (RM E.2.2(16/1)). Before
4392 -- reporting an error, we must check whether this is actually a
4393 -- dispatching call in prefix form.
4394
4395 if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type)
4396 and then Comes_From_Source (N)
4397 then
4398 if Try_Object_Operation (N) then
4399 return;
4400 else
4401 Error_Msg_N
4402 ("invalid dereference of a remote access-to-class-wide value",
4403 N);
4404 end if;
4405
4406 -- Normal case of selected component applied to access type
4407
4408 else
4409 Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N);
4410
4411 if Is_Entity_Name (Name) then
4412 Pent := Entity (Name);
4413 elsif Nkind (Name) = N_Selected_Component
4414 and then Is_Entity_Name (Selector_Name (Name))
4415 then
4416 Pent := Entity (Selector_Name (Name));
4417 end if;
4418
4419 Prefix_Type := Process_Implicit_Dereference_Prefix (Pent, Name);
4420 end if;
4421
4422 -- If we have an explicit dereference of a remote access-to-class-wide
4423 -- value, then issue an error (see RM-E.2.2(16/1)). However we first
4424 -- have to check for the case of a prefix that is a controlling operand
4425 -- of a prefixed dispatching call, as the dereference is legal in that
4426 -- case. Normally this condition is checked in Validate_Remote_Access_
4427 -- To_Class_Wide_Type, but we have to defer the checking for selected
4428 -- component prefixes because of the prefixed dispatching call case.
4429 -- Note that implicit dereferences are checked for this just above.
4430
4431 elsif Nkind (Name) = N_Explicit_Dereference
4432 and then Is_Remote_Access_To_Class_Wide_Type (Etype (Prefix (Name)))
4433 and then Comes_From_Source (N)
4434 then
4435 if Try_Object_Operation (N) then
4436 return;
4437 else
4438 Error_Msg_N
4439 ("invalid dereference of a remote access-to-class-wide value",
4440 N);
4441 end if;
4442 end if;
4443
4444 -- (Ada 2005): if the prefix is the limited view of a type, and
4445 -- the context already includes the full view, use the full view
4446 -- in what follows, either to retrieve a component of to find
4447 -- a primitive operation. If the prefix is an explicit dereference,
4448 -- set the type of the prefix to reflect this transformation.
4449 -- If the non-limited view is itself an incomplete type, get the
4450 -- full view if available.
4451
4452 if From_Limited_With (Prefix_Type)
4453 and then Has_Non_Limited_View (Prefix_Type)
4454 then
4455 Prefix_Type := Get_Full_View (Non_Limited_View (Prefix_Type));
4456
4457 if Nkind (N) = N_Explicit_Dereference then
4458 Set_Etype (Prefix (N), Prefix_Type);
4459 end if;
4460 end if;
4461
4462 if Ekind (Prefix_Type) = E_Private_Subtype then
4463 Prefix_Type := Base_Type (Prefix_Type);
4464 end if;
4465
4466 Type_To_Use := Prefix_Type;
4467
4468 -- For class-wide types, use the entity list of the root type. This
4469 -- indirection is specially important for private extensions because
4470 -- only the root type get switched (not the class-wide type).
4471
4472 if Is_Class_Wide_Type (Prefix_Type) then
4473 Type_To_Use := Root_Type (Prefix_Type);
4474 end if;
4475
4476 -- If the prefix is a single concurrent object, use its name in error
4477 -- messages, rather than that of its anonymous type.
4478
4479 Is_Single_Concurrent_Object :=
4480 Is_Concurrent_Type (Prefix_Type)
4481 and then Is_Internal_Name (Chars (Prefix_Type))
4482 and then not Is_Derived_Type (Prefix_Type)
4483 and then Is_Entity_Name (Name);
4484
4485 Comp := First_Entity (Type_To_Use);
4486
4487 -- If the selector has an original discriminant, the node appears in
4488 -- an instance. Replace the discriminant with the corresponding one
4489 -- in the current discriminated type. For nested generics, this must
4490 -- be done transitively, so note the new original discriminant.
4491
4492 if Nkind (Sel) = N_Identifier
4493 and then In_Instance
4494 and then Present (Original_Discriminant (Sel))
4495 then
4496 Comp := Find_Corresponding_Discriminant (Sel, Prefix_Type);
4497
4498 -- Mark entity before rewriting, for completeness and because
4499 -- subsequent semantic checks might examine the original node.
4500
4501 Set_Entity (Sel, Comp);
4502 Rewrite (Selector_Name (N), New_Occurrence_Of (Comp, Sloc (N)));
4503 Set_Original_Discriminant (Selector_Name (N), Comp);
4504 Set_Etype (N, Etype (Comp));
4505 Check_Implicit_Dereference (N, Etype (Comp));
4506
4507 if Is_Access_Type (Etype (Name)) then
4508 Insert_Explicit_Dereference (Name);
4509 Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N);
4510 end if;
4511
4512 elsif Is_Record_Type (Prefix_Type) then
4513
4514 -- Find component with given name. In an instance, if the node is
4515 -- known as a prefixed call, do not examine components whose
4516 -- visibility may be accidental.
4517
4518 while Present (Comp) and then not Is_Prefixed_Call (N) loop
4519 if Chars (Comp) = Chars (Sel)
4520 and then Is_Visible_Component (Comp, N)
4521 then
4522 Set_Entity_With_Checks (Sel, Comp);
4523 Set_Etype (Sel, Etype (Comp));
4524
4525 if Ekind (Comp) = E_Discriminant then
4526 if Is_Unchecked_Union (Base_Type (Prefix_Type)) then
4527 Error_Msg_N
4528 ("cannot reference discriminant of unchecked union",
4529 Sel);
4530 end if;
4531
4532 if Is_Generic_Type (Prefix_Type)
4533 or else
4534 Is_Generic_Type (Root_Type (Prefix_Type))
4535 then
4536 Set_Original_Discriminant (Sel, Comp);
4537 end if;
4538 end if;
4539
4540 -- Resolve the prefix early otherwise it is not possible to
4541 -- build the actual subtype of the component: it may need
4542 -- to duplicate this prefix and duplication is only allowed
4543 -- on fully resolved expressions.
4544
4545 Resolve (Name);
4546
4547 -- Ada 2005 (AI-50217): Check wrong use of incomplete types or
4548 -- subtypes in a package specification.
4549 -- Example:
4550
4551 -- limited with Pkg;
4552 -- package Pkg is
4553 -- type Acc_Inc is access Pkg.T;
4554 -- X : Acc_Inc;
4555 -- N : Natural := X.all.Comp; -- ERROR, limited view
4556 -- end Pkg; -- Comp is not visible
4557
4558 if Nkind (Name) = N_Explicit_Dereference
4559 and then From_Limited_With (Etype (Prefix (Name)))
4560 and then not Is_Potentially_Use_Visible (Etype (Name))
4561 and then Nkind (Parent (Cunit_Entity (Current_Sem_Unit))) =
4562 N_Package_Specification
4563 then
4564 Error_Msg_NE
4565 ("premature usage of incomplete}", Prefix (Name),
4566 Etype (Prefix (Name)));
4567 end if;
4568
4569 -- We never need an actual subtype for the case of a selection
4570 -- for a indexed component of a non-packed array, since in
4571 -- this case gigi generates all the checks and can find the
4572 -- necessary bounds information.
4573
4574 -- We also do not need an actual subtype for the case of a
4575 -- first, last, length, or range attribute applied to a
4576 -- non-packed array, since gigi can again get the bounds in
4577 -- these cases (gigi cannot handle the packed case, since it
4578 -- has the bounds of the packed array type, not the original
4579 -- bounds of the type). However, if the prefix is itself a
4580 -- selected component, as in a.b.c (i), gigi may regard a.b.c
4581 -- as a dynamic-sized temporary, so we do generate an actual
4582 -- subtype for this case.
4583
4584 Parent_N := Parent (N);
4585
4586 if not Is_Packed (Etype (Comp))
4587 and then
4588 ((Nkind (Parent_N) = N_Indexed_Component
4589 and then Nkind (Name) /= N_Selected_Component)
4590 or else
4591 (Nkind (Parent_N) = N_Attribute_Reference
4592 and then
4593 Nam_In (Attribute_Name (Parent_N), Name_First,
4594 Name_Last,
4595 Name_Length,
4596 Name_Range)))
4597 then
4598 Set_Etype (N, Etype (Comp));
4599
4600 -- If full analysis is not enabled, we do not generate an
4601 -- actual subtype, because in the absence of expansion
4602 -- reference to a formal of a protected type, for example,
4603 -- will not be properly transformed, and will lead to
4604 -- out-of-scope references in gigi.
4605
4606 -- In all other cases, we currently build an actual subtype.
4607 -- It seems likely that many of these cases can be avoided,
4608 -- but right now, the front end makes direct references to the
4609 -- bounds (e.g. in generating a length check), and if we do
4610 -- not make an actual subtype, we end up getting a direct
4611 -- reference to a discriminant, which will not do.
4612
4613 elsif Full_Analysis then
4614 Act_Decl :=
4615 Build_Actual_Subtype_Of_Component (Etype (Comp), N);
4616 Insert_Action (N, Act_Decl);
4617
4618 if No (Act_Decl) then
4619 Set_Etype (N, Etype (Comp));
4620
4621 else
4622 -- Component type depends on discriminants. Enter the
4623 -- main attributes of the subtype.
4624
4625 declare
4626 Subt : constant Entity_Id :=
4627 Defining_Identifier (Act_Decl);
4628
4629 begin
4630 Set_Etype (Subt, Base_Type (Etype (Comp)));
4631 Set_Ekind (Subt, Ekind (Etype (Comp)));
4632 Set_Etype (N, Subt);
4633 end;
4634 end if;
4635
4636 -- If Full_Analysis not enabled, just set the Etype
4637
4638 else
4639 Set_Etype (N, Etype (Comp));
4640 end if;
4641
4642 Check_Implicit_Dereference (N, Etype (N));
4643 return;
4644 end if;
4645
4646 -- If the prefix is a private extension, check only the visible
4647 -- components of the partial view. This must include the tag,
4648 -- which can appear in expanded code in a tag check.
4649
4650 if Ekind (Type_To_Use) = E_Record_Type_With_Private
4651 and then Chars (Selector_Name (N)) /= Name_uTag
4652 then
4653 exit when Comp = Last_Entity (Type_To_Use);
4654 end if;
4655
4656 Next_Entity (Comp);
4657 end loop;
4658
4659 -- Ada 2005 (AI-252): The selected component can be interpreted as
4660 -- a prefixed view of a subprogram. Depending on the context, this is
4661 -- either a name that can appear in a renaming declaration, or part
4662 -- of an enclosing call given in prefix form.
4663
4664 -- Ada 2005 (AI05-0030): In the case of dispatching requeue, the
4665 -- selected component should resolve to a name.
4666
4667 if Ada_Version >= Ada_2005
4668 and then Is_Tagged_Type (Prefix_Type)
4669 and then not Is_Concurrent_Type (Prefix_Type)
4670 then
4671 if Nkind (Parent (N)) = N_Generic_Association
4672 or else Nkind (Parent (N)) = N_Requeue_Statement
4673 or else Nkind (Parent (N)) = N_Subprogram_Renaming_Declaration
4674 then
4675 if Find_Primitive_Operation (N) then
4676 return;
4677 end if;
4678
4679 elsif Try_Object_Operation (N) then
4680 return;
4681 end if;
4682
4683 -- If the transformation fails, it will be necessary to redo the
4684 -- analysis with all errors enabled, to indicate candidate
4685 -- interpretations and reasons for each failure ???
4686
4687 end if;
4688
4689 elsif Is_Private_Type (Prefix_Type) then
4690
4691 -- Allow access only to discriminants of the type. If the type has
4692 -- no full view, gigi uses the parent type for the components, so we
4693 -- do the same here.
4694
4695 if No (Full_View (Prefix_Type)) then
4696 Type_To_Use := Root_Type (Base_Type (Prefix_Type));
4697 Comp := First_Entity (Type_To_Use);
4698 end if;
4699
4700 while Present (Comp) loop
4701 if Chars (Comp) = Chars (Sel) then
4702 if Ekind (Comp) = E_Discriminant then
4703 Set_Entity_With_Checks (Sel, Comp);
4704 Generate_Reference (Comp, Sel);
4705
4706 Set_Etype (Sel, Etype (Comp));
4707 Set_Etype (N, Etype (Comp));
4708 Check_Implicit_Dereference (N, Etype (N));
4709
4710 if Is_Generic_Type (Prefix_Type)
4711 or else Is_Generic_Type (Root_Type (Prefix_Type))
4712 then
4713 Set_Original_Discriminant (Sel, Comp);
4714 end if;
4715
4716 -- Before declaring an error, check whether this is tagged
4717 -- private type and a call to a primitive operation.
4718
4719 elsif Ada_Version >= Ada_2005
4720 and then Is_Tagged_Type (Prefix_Type)
4721 and then Try_Object_Operation (N)
4722 then
4723 return;
4724
4725 else
4726 Error_Msg_Node_2 := First_Subtype (Prefix_Type);
4727 Error_Msg_NE ("invisible selector& for }", N, Sel);
4728 Set_Entity (Sel, Any_Id);
4729 Set_Etype (N, Any_Type);
4730 end if;
4731
4732 return;
4733 end if;
4734
4735 Next_Entity (Comp);
4736 end loop;
4737
4738 elsif Is_Concurrent_Type (Prefix_Type) then
4739
4740 -- Find visible operation with given name. For a protected type,
4741 -- the possible candidates are discriminants, entries or protected
4742 -- procedures. For a task type, the set can only include entries or
4743 -- discriminants if the task type is not an enclosing scope. If it
4744 -- is an enclosing scope (e.g. in an inner task) then all entities
4745 -- are visible, but the prefix must denote the enclosing scope, i.e.
4746 -- can only be a direct name or an expanded name.
4747
4748 Set_Etype (Sel, Any_Type);
4749 In_Scope := In_Open_Scopes (Prefix_Type);
4750
4751 while Present (Comp) loop
4752 if Chars (Comp) = Chars (Sel) then
4753 if Is_Overloadable (Comp) then
4754 Add_One_Interp (Sel, Comp, Etype (Comp));
4755
4756 -- If the prefix is tagged, the correct interpretation may
4757 -- lie in the primitive or class-wide operations of the
4758 -- type. Perform a simple conformance check to determine
4759 -- whether Try_Object_Operation should be invoked even if
4760 -- a visible entity is found.
4761
4762 if Is_Tagged_Type (Prefix_Type)
4763 and then
4764 Nkind_In (Parent (N), N_Procedure_Call_Statement,
4765 N_Function_Call,
4766 N_Indexed_Component)
4767 and then Has_Mode_Conformant_Spec (Comp)
4768 then
4769 Has_Candidate := True;
4770 end if;
4771
4772 -- Note: a selected component may not denote a component of a
4773 -- protected type (4.1.3(7)).
4774
4775 elsif Ekind_In (Comp, E_Discriminant, E_Entry_Family)
4776 or else (In_Scope
4777 and then not Is_Protected_Type (Prefix_Type)
4778 and then Is_Entity_Name (Name))
4779 then
4780 Set_Entity_With_Checks (Sel, Comp);
4781 Generate_Reference (Comp, Sel);
4782
4783 -- The selector is not overloadable, so we have a candidate
4784 -- interpretation.
4785
4786 Has_Candidate := True;
4787
4788 else
4789 goto Next_Comp;
4790 end if;
4791
4792 Set_Etype (Sel, Etype (Comp));
4793 Set_Etype (N, Etype (Comp));
4794
4795 if Ekind (Comp) = E_Discriminant then
4796 Set_Original_Discriminant (Sel, Comp);
4797 end if;
4798
4799 -- For access type case, introduce explicit dereference for
4800 -- more uniform treatment of entry calls.
4801
4802 if Is_Access_Type (Etype (Name)) then
4803 Insert_Explicit_Dereference (Name);
4804 Error_Msg_NW
4805 (Warn_On_Dereference, "?d?implicit dereference", N);
4806 end if;
4807 end if;
4808
4809 <<Next_Comp>>
4810 Next_Entity (Comp);
4811 exit when not In_Scope
4812 and then
4813 Comp = First_Private_Entity (Base_Type (Prefix_Type));
4814 end loop;
4815
4816 -- If the scope is a current instance, the prefix cannot be an
4817 -- expression of the same type, unless the selector designates a
4818 -- public operation (otherwise that would represent an attempt to
4819 -- reach an internal entity of another synchronized object).
4820 -- This is legal if prefix is an access to such type and there is
4821 -- a dereference, or is a component with a dereferenced prefix.
4822 -- It is also legal if the prefix is a component of a task type,
4823 -- and the selector is one of the task operations.
4824
4825 if In_Scope
4826 and then not Is_Entity_Name (Name)
4827 and then not Has_Dereference (Name)
4828 then
4829 if Is_Task_Type (Prefix_Type)
4830 and then Present (Entity (Sel))
4831 and then Ekind_In (Entity (Sel), E_Entry, E_Entry_Family)
4832 then
4833 null;
4834
4835 else
4836 Error_Msg_NE
4837 ("invalid reference to internal operation of some object of "
4838 & "type &", N, Type_To_Use);
4839 Set_Entity (Sel, Any_Id);
4840 Set_Etype (Sel, Any_Type);
4841 return;
4842 end if;
4843 end if;
4844
4845 -- If there is no visible entity with the given name or none of the
4846 -- visible entities are plausible interpretations, check whether
4847 -- there is some other primitive operation with that name.
4848
4849 if Ada_Version >= Ada_2005 and then Is_Tagged_Type (Prefix_Type) then
4850 if (Etype (N) = Any_Type
4851 or else not Has_Candidate)
4852 and then Try_Object_Operation (N)
4853 then
4854 return;
4855
4856 -- If the context is not syntactically a procedure call, it
4857 -- may be a call to a primitive function declared outside of
4858 -- the synchronized type.
4859
4860 -- If the context is a procedure call, there might still be
4861 -- an overloading between an entry and a primitive procedure
4862 -- declared outside of the synchronized type, called in prefix
4863 -- notation. This is harder to disambiguate because in one case
4864 -- the controlling formal is implicit ???
4865
4866 elsif Nkind (Parent (N)) /= N_Procedure_Call_Statement
4867 and then Nkind (Parent (N)) /= N_Indexed_Component
4868 and then Try_Object_Operation (N)
4869 then
4870 return;
4871 end if;
4872
4873 -- Ada 2012 (AI05-0090-1): If we found a candidate of a call to an
4874 -- entry or procedure of a tagged concurrent type we must check
4875 -- if there are class-wide subprograms covering the primitive. If
4876 -- true then Try_Object_Operation reports the error.
4877
4878 if Has_Candidate
4879 and then Is_Concurrent_Type (Prefix_Type)
4880 and then Nkind (Parent (N)) = N_Procedure_Call_Statement
4881 then
4882 -- Duplicate the call. This is required to avoid problems with
4883 -- the tree transformations performed by Try_Object_Operation.
4884 -- Set properly the parent of the copied call, because it is
4885 -- about to be reanalyzed.
4886
4887 declare
4888 Par : constant Node_Id := New_Copy_Tree (Parent (N));
4889
4890 begin
4891 Set_Parent (Par, Parent (Parent (N)));
4892
4893 if Try_Object_Operation
4894 (Sinfo.Name (Par), CW_Test_Only => True)
4895 then
4896 return;
4897 end if;
4898 end;
4899 end if;
4900 end if;
4901
4902 if Etype (N) = Any_Type and then Is_Protected_Type (Prefix_Type) then
4903
4904 -- Case of a prefix of a protected type: selector might denote
4905 -- an invisible private component.
4906
4907 Comp := First_Private_Entity (Base_Type (Prefix_Type));
4908 while Present (Comp) and then Chars (Comp) /= Chars (Sel) loop
4909 Next_Entity (Comp);
4910 end loop;
4911
4912 if Present (Comp) then
4913 if Is_Single_Concurrent_Object then
4914 Error_Msg_Node_2 := Entity (Name);
4915 Error_Msg_NE ("invisible selector& for &", N, Sel);
4916
4917 else
4918 Error_Msg_Node_2 := First_Subtype (Prefix_Type);
4919 Error_Msg_NE ("invisible selector& for }", N, Sel);
4920 end if;
4921 return;
4922 end if;
4923 end if;
4924
4925 Set_Is_Overloaded (N, Is_Overloaded (Sel));
4926
4927 else
4928 -- Invalid prefix
4929
4930 Error_Msg_NE ("invalid prefix in selected component&", N, Sel);
4931 end if;
4932
4933 -- If N still has no type, the component is not defined in the prefix
4934
4935 if Etype (N) = Any_Type then
4936
4937 if Is_Single_Concurrent_Object then
4938 Error_Msg_Node_2 := Entity (Name);
4939 Error_Msg_NE ("no selector& for&", N, Sel);
4940
4941 Check_Misspelled_Selector (Type_To_Use, Sel);
4942
4943 -- If this is a derived formal type, the parent may have different
4944 -- visibility at this point. Try for an inherited component before
4945 -- reporting an error.
4946
4947 elsif Is_Generic_Type (Prefix_Type)
4948 and then Ekind (Prefix_Type) = E_Record_Type_With_Private
4949 and then Prefix_Type /= Etype (Prefix_Type)
4950 and then Is_Record_Type (Etype (Prefix_Type))
4951 then
4952 Set_Etype (Prefix (N), Etype (Prefix_Type));
4953 Analyze_Selected_Component (N);
4954 return;
4955
4956 -- Similarly, if this is the actual for a formal derived type, or
4957 -- a derived type thereof, the component inherited from the generic
4958 -- parent may not be visible in the actual, but the selected
4959 -- component is legal. Climb up the derivation chain of the generic
4960 -- parent type until we find the proper ancestor type.
4961
4962 elsif In_Instance and then Is_Tagged_Type (Prefix_Type) then
4963 declare
4964 Par : Entity_Id := Prefix_Type;
4965 begin
4966 -- Climb up derivation chain to generic actual subtype
4967
4968 while not Is_Generic_Actual_Type (Par) loop
4969 if Ekind (Par) = E_Record_Type then
4970 Par := Parent_Subtype (Par);
4971 exit when No (Par);
4972 else
4973 exit when Par = Etype (Par);
4974 Par := Etype (Par);
4975 end if;
4976 end loop;
4977
4978 if Present (Par) and then Is_Generic_Actual_Type (Par) then
4979
4980 -- Now look for component in ancestor types
4981
4982 Par := Generic_Parent_Type (Declaration_Node (Par));
4983 loop
4984 Find_Component_In_Instance (Par);
4985 exit when Present (Entity (Sel))
4986 or else Par = Etype (Par);
4987 Par := Etype (Par);
4988 end loop;
4989
4990 -- Another special case: the type is an extension of a private
4991 -- type T, is an actual in an instance, and we are in the body
4992 -- of the instance, so the generic body had a full view of the
4993 -- type declaration for T or of some ancestor that defines the
4994 -- component in question.
4995
4996 elsif Is_Derived_Type (Type_To_Use)
4997 and then Used_As_Generic_Actual (Type_To_Use)
4998 and then In_Instance_Body
4999 then
5000 Find_Component_In_Instance (Parent_Subtype (Type_To_Use));
5001
5002 -- In ASIS mode the generic parent type may be absent. Examine
5003 -- the parent type directly for a component that may have been
5004 -- visible in a parent generic unit.
5005
5006 elsif Is_Derived_Type (Prefix_Type) then
5007 Par := Etype (Prefix_Type);
5008 Find_Component_In_Instance (Par);
5009 end if;
5010 end;
5011
5012 -- The search above must have eventually succeeded, since the
5013 -- selected component was legal in the generic.
5014
5015 if No (Entity (Sel)) then
5016 raise Program_Error;
5017 end if;
5018
5019 return;
5020
5021 -- Component not found, specialize error message when appropriate
5022
5023 else
5024 if Ekind (Prefix_Type) = E_Record_Subtype then
5025
5026 -- Check whether this is a component of the base type which
5027 -- is absent from a statically constrained subtype. This will
5028 -- raise constraint error at run time, but is not a compile-
5029 -- time error. When the selector is illegal for base type as
5030 -- well fall through and generate a compilation error anyway.
5031
5032 Comp := First_Component (Base_Type (Prefix_Type));
5033 while Present (Comp) loop
5034 if Chars (Comp) = Chars (Sel)
5035 and then Is_Visible_Component (Comp)
5036 then
5037 Set_Entity_With_Checks (Sel, Comp);
5038 Generate_Reference (Comp, Sel);
5039 Set_Etype (Sel, Etype (Comp));
5040 Set_Etype (N, Etype (Comp));
5041
5042 -- Emit appropriate message. The node will be replaced
5043 -- by an appropriate raise statement.
5044
5045 -- Note that in SPARK mode, as with all calls to apply a
5046 -- compile time constraint error, this will be made into
5047 -- an error to simplify the processing of the formal
5048 -- verification backend.
5049
5050 Apply_Compile_Time_Constraint_Error
5051 (N, "component not present in }??",
5052 CE_Discriminant_Check_Failed,
5053 Ent => Prefix_Type, Rep => False);
5054
5055 Set_Raises_Constraint_Error (N);
5056 return;
5057 end if;
5058
5059 Next_Component (Comp);
5060 end loop;
5061
5062 end if;
5063
5064 Error_Msg_Node_2 := First_Subtype (Prefix_Type);
5065 Error_Msg_NE ("no selector& for}", N, Sel);
5066
5067 -- Add information in the case of an incomplete prefix
5068
5069 if Is_Incomplete_Type (Type_To_Use) then
5070 declare
5071 Inc : constant Entity_Id := First_Subtype (Type_To_Use);
5072
5073 begin
5074 if From_Limited_With (Scope (Type_To_Use)) then
5075 Error_Msg_NE
5076 ("\limited view of& has no components", N, Inc);
5077
5078 else
5079 Error_Msg_NE
5080 ("\premature usage of incomplete type&", N, Inc);
5081
5082 if Nkind (Parent (Inc)) =
5083 N_Incomplete_Type_Declaration
5084 then
5085 -- Record location of premature use in entity so that
5086 -- a continuation message is generated when the
5087 -- completion is seen.
5088
5089 Set_Premature_Use (Parent (Inc), N);
5090 end if;
5091 end if;
5092 end;
5093 end if;
5094
5095 Check_Misspelled_Selector (Type_To_Use, Sel);
5096 end if;
5097
5098 Set_Entity (Sel, Any_Id);
5099 Set_Etype (Sel, Any_Type);
5100 end if;
5101 end Analyze_Selected_Component;
5102
5103 ---------------------------
5104 -- Analyze_Short_Circuit --
5105 ---------------------------
5106
5107 procedure Analyze_Short_Circuit (N : Node_Id) is
5108 L : constant Node_Id := Left_Opnd (N);
5109 R : constant Node_Id := Right_Opnd (N);
5110 Ind : Interp_Index;
5111 It : Interp;
5112
5113 begin
5114 Analyze_Expression (L);
5115 Analyze_Expression (R);
5116 Set_Etype (N, Any_Type);
5117
5118 if not Is_Overloaded (L) then
5119 if Root_Type (Etype (L)) = Standard_Boolean
5120 and then Has_Compatible_Type (R, Etype (L))
5121 then
5122 Add_One_Interp (N, Etype (L), Etype (L));
5123 end if;
5124
5125 else
5126 Get_First_Interp (L, Ind, It);
5127 while Present (It.Typ) loop
5128 if Root_Type (It.Typ) = Standard_Boolean
5129 and then Has_Compatible_Type (R, It.Typ)
5130 then
5131 Add_One_Interp (N, It.Typ, It.Typ);
5132 end if;
5133
5134 Get_Next_Interp (Ind, It);
5135 end loop;
5136 end if;
5137
5138 -- Here we have failed to find an interpretation. Clearly we know that
5139 -- it is not the case that both operands can have an interpretation of
5140 -- Boolean, but this is by far the most likely intended interpretation.
5141 -- So we simply resolve both operands as Booleans, and at least one of
5142 -- these resolutions will generate an error message, and we do not need
5143 -- to give another error message on the short circuit operation itself.
5144
5145 if Etype (N) = Any_Type then
5146 Resolve (L, Standard_Boolean);
5147 Resolve (R, Standard_Boolean);
5148 Set_Etype (N, Standard_Boolean);
5149 end if;
5150 end Analyze_Short_Circuit;
5151
5152 -------------------
5153 -- Analyze_Slice --
5154 -------------------
5155
5156 procedure Analyze_Slice (N : Node_Id) is
5157 D : constant Node_Id := Discrete_Range (N);
5158 P : constant Node_Id := Prefix (N);
5159 Array_Type : Entity_Id;
5160 Index_Type : Entity_Id;
5161
5162 procedure Analyze_Overloaded_Slice;
5163 -- If the prefix is overloaded, select those interpretations that
5164 -- yield a one-dimensional array type.
5165
5166 ------------------------------
5167 -- Analyze_Overloaded_Slice --
5168 ------------------------------
5169
5170 procedure Analyze_Overloaded_Slice is
5171 I : Interp_Index;
5172 It : Interp;
5173 Typ : Entity_Id;
5174
5175 begin
5176 Set_Etype (N, Any_Type);
5177
5178 Get_First_Interp (P, I, It);
5179 while Present (It.Nam) loop
5180 Typ := It.Typ;
5181
5182 if Is_Access_Type (Typ) then
5183 Typ := Designated_Type (Typ);
5184 Error_Msg_NW
5185 (Warn_On_Dereference, "?d?implicit dereference", N);
5186 end if;
5187
5188 if Is_Array_Type (Typ)
5189 and then Number_Dimensions (Typ) = 1
5190 and then Has_Compatible_Type (D, Etype (First_Index (Typ)))
5191 then
5192 Add_One_Interp (N, Typ, Typ);
5193 end if;
5194
5195 Get_Next_Interp (I, It);
5196 end loop;
5197
5198 if Etype (N) = Any_Type then
5199 Error_Msg_N ("expect array type in prefix of slice", N);
5200 end if;
5201 end Analyze_Overloaded_Slice;
5202
5203 -- Start of processing for Analyze_Slice
5204
5205 begin
5206 if Comes_From_Source (N) then
5207 Check_SPARK_05_Restriction ("slice is not allowed", N);
5208 end if;
5209
5210 Analyze (P);
5211 Analyze (D);
5212
5213 if Is_Overloaded (P) then
5214 Analyze_Overloaded_Slice;
5215
5216 else
5217 Array_Type := Etype (P);
5218 Set_Etype (N, Any_Type);
5219
5220 if Is_Access_Type (Array_Type) then
5221 Array_Type := Designated_Type (Array_Type);
5222 Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N);
5223 end if;
5224
5225 if not Is_Array_Type (Array_Type) then
5226 Wrong_Type (P, Any_Array);
5227
5228 elsif Number_Dimensions (Array_Type) > 1 then
5229 Error_Msg_N
5230 ("type is not one-dimensional array in slice prefix", N);
5231
5232 else
5233 if Ekind (Array_Type) = E_String_Literal_Subtype then
5234 Index_Type := Etype (String_Literal_Low_Bound (Array_Type));
5235 else
5236 Index_Type := Etype (First_Index (Array_Type));
5237 end if;
5238
5239 if not Has_Compatible_Type (D, Index_Type) then
5240 Wrong_Type (D, Index_Type);
5241 else
5242 Set_Etype (N, Array_Type);
5243 end if;
5244 end if;
5245 end if;
5246 end Analyze_Slice;
5247
5248 -----------------------------
5249 -- Analyze_Type_Conversion --
5250 -----------------------------
5251
5252 procedure Analyze_Type_Conversion (N : Node_Id) is
5253 Expr : constant Node_Id := Expression (N);
5254 Typ : Entity_Id;
5255
5256 begin
5257 -- If Conversion_OK is set, then the Etype is already set, and the only
5258 -- processing required is to analyze the expression. This is used to
5259 -- construct certain "illegal" conversions which are not allowed by Ada
5260 -- semantics, but can be handled by Gigi, see Sinfo for further details.
5261
5262 if Conversion_OK (N) then
5263 Analyze (Expr);
5264 return;
5265 end if;
5266
5267 -- Otherwise full type analysis is required, as well as some semantic
5268 -- checks to make sure the argument of the conversion is appropriate.
5269
5270 Find_Type (Subtype_Mark (N));
5271 Typ := Entity (Subtype_Mark (N));
5272 Set_Etype (N, Typ);
5273 Check_Fully_Declared (Typ, N);
5274 Analyze_Expression (Expr);
5275 Validate_Remote_Type_Type_Conversion (N);
5276
5277 -- Only remaining step is validity checks on the argument. These
5278 -- are skipped if the conversion does not come from the source.
5279
5280 if not Comes_From_Source (N) then
5281 return;
5282
5283 -- If there was an error in a generic unit, no need to replicate the
5284 -- error message. Conversely, constant-folding in the generic may
5285 -- transform the argument of a conversion into a string literal, which
5286 -- is legal. Therefore the following tests are not performed in an
5287 -- instance. The same applies to an inlined body.
5288
5289 elsif In_Instance or In_Inlined_Body then
5290 return;
5291
5292 elsif Nkind (Expr) = N_Null then
5293 Error_Msg_N ("argument of conversion cannot be null", N);
5294 Error_Msg_N ("\use qualified expression instead", N);
5295 Set_Etype (N, Any_Type);
5296
5297 elsif Nkind (Expr) = N_Aggregate then
5298 Error_Msg_N ("argument of conversion cannot be aggregate", N);
5299 Error_Msg_N ("\use qualified expression instead", N);
5300
5301 elsif Nkind (Expr) = N_Allocator then
5302 Error_Msg_N ("argument of conversion cannot be an allocator", N);
5303 Error_Msg_N ("\use qualified expression instead", N);
5304
5305 elsif Nkind (Expr) = N_String_Literal then
5306 Error_Msg_N ("argument of conversion cannot be string literal", N);
5307 Error_Msg_N ("\use qualified expression instead", N);
5308
5309 elsif Nkind (Expr) = N_Character_Literal then
5310 if Ada_Version = Ada_83 then
5311 Resolve (Expr, Typ);
5312 else
5313 Error_Msg_N ("argument of conversion cannot be character literal",
5314 N);
5315 Error_Msg_N ("\use qualified expression instead", N);
5316 end if;
5317
5318 elsif Nkind (Expr) = N_Attribute_Reference
5319 and then Nam_In (Attribute_Name (Expr), Name_Access,
5320 Name_Unchecked_Access,
5321 Name_Unrestricted_Access)
5322 then
5323 Error_Msg_N ("argument of conversion cannot be access", N);
5324 Error_Msg_N ("\use qualified expression instead", N);
5325 end if;
5326
5327 -- A formal parameter of a specific tagged type whose related subprogram
5328 -- is subject to pragma Extensions_Visible with value "False" cannot
5329 -- appear in a class-wide conversion (SPARK RM 6.1.7(3)). Do not check
5330 -- internally generated expressions.
5331
5332 if Is_Class_Wide_Type (Typ)
5333 and then Comes_From_Source (Expr)
5334 and then Is_EVF_Expression (Expr)
5335 then
5336 Error_Msg_N
5337 ("formal parameter cannot be converted to class-wide type when "
5338 & "Extensions_Visible is False", Expr);
5339 end if;
5340 end Analyze_Type_Conversion;
5341
5342 ----------------------
5343 -- Analyze_Unary_Op --
5344 ----------------------
5345
5346 procedure Analyze_Unary_Op (N : Node_Id) is
5347 R : constant Node_Id := Right_Opnd (N);
5348 Op_Id : Entity_Id := Entity (N);
5349
5350 begin
5351 Set_Etype (N, Any_Type);
5352 Candidate_Type := Empty;
5353
5354 Analyze_Expression (R);
5355
5356 if Present (Op_Id) then
5357 if Ekind (Op_Id) = E_Operator then
5358 Find_Unary_Types (R, Op_Id, N);
5359 else
5360 Add_One_Interp (N, Op_Id, Etype (Op_Id));
5361 end if;
5362
5363 else
5364 Op_Id := Get_Name_Entity_Id (Chars (N));
5365 while Present (Op_Id) loop
5366 if Ekind (Op_Id) = E_Operator then
5367 if No (Next_Entity (First_Entity (Op_Id))) then
5368 Find_Unary_Types (R, Op_Id, N);
5369 end if;
5370
5371 elsif Is_Overloadable (Op_Id) then
5372 Analyze_User_Defined_Unary_Op (N, Op_Id);
5373 end if;
5374
5375 Op_Id := Homonym (Op_Id);
5376 end loop;
5377 end if;
5378
5379 Operator_Check (N);
5380 end Analyze_Unary_Op;
5381
5382 ----------------------------------
5383 -- Analyze_Unchecked_Expression --
5384 ----------------------------------
5385
5386 procedure Analyze_Unchecked_Expression (N : Node_Id) is
5387 begin
5388 Analyze (Expression (N), Suppress => All_Checks);
5389 Set_Etype (N, Etype (Expression (N)));
5390 Save_Interps (Expression (N), N);
5391 end Analyze_Unchecked_Expression;
5392
5393 ---------------------------------------
5394 -- Analyze_Unchecked_Type_Conversion --
5395 ---------------------------------------
5396
5397 procedure Analyze_Unchecked_Type_Conversion (N : Node_Id) is
5398 begin
5399 Find_Type (Subtype_Mark (N));
5400 Analyze_Expression (Expression (N));
5401 Set_Etype (N, Entity (Subtype_Mark (N)));
5402 end Analyze_Unchecked_Type_Conversion;
5403
5404 ------------------------------------
5405 -- Analyze_User_Defined_Binary_Op --
5406 ------------------------------------
5407
5408 procedure Analyze_User_Defined_Binary_Op
5409 (N : Node_Id;
5410 Op_Id : Entity_Id)
5411 is
5412 begin
5413 -- Only do analysis if the operator Comes_From_Source, since otherwise
5414 -- the operator was generated by the expander, and all such operators
5415 -- always refer to the operators in package Standard.
5416
5417 if Comes_From_Source (N) then
5418 declare
5419 F1 : constant Entity_Id := First_Formal (Op_Id);
5420 F2 : constant Entity_Id := Next_Formal (F1);
5421
5422 begin
5423 -- Verify that Op_Id is a visible binary function. Note that since
5424 -- we know Op_Id is overloaded, potentially use visible means use
5425 -- visible for sure (RM 9.4(11)).
5426
5427 if Ekind (Op_Id) = E_Function
5428 and then Present (F2)
5429 and then (Is_Immediately_Visible (Op_Id)
5430 or else Is_Potentially_Use_Visible (Op_Id))
5431 and then Has_Compatible_Type (Left_Opnd (N), Etype (F1))
5432 and then Has_Compatible_Type (Right_Opnd (N), Etype (F2))
5433 then
5434 Add_One_Interp (N, Op_Id, Etype (Op_Id));
5435
5436 -- If the left operand is overloaded, indicate that the current
5437 -- type is a viable candidate. This is redundant in most cases,
5438 -- but for equality and comparison operators where the context
5439 -- does not impose a type on the operands, setting the proper
5440 -- type is necessary to avoid subsequent ambiguities during
5441 -- resolution, when both user-defined and predefined operators
5442 -- may be candidates.
5443
5444 if Is_Overloaded (Left_Opnd (N)) then
5445 Set_Etype (Left_Opnd (N), Etype (F1));
5446 end if;
5447
5448 if Debug_Flag_E then
5449 Write_Str ("user defined operator ");
5450 Write_Name (Chars (Op_Id));
5451 Write_Str (" on node ");
5452 Write_Int (Int (N));
5453 Write_Eol;
5454 end if;
5455 end if;
5456 end;
5457 end if;
5458 end Analyze_User_Defined_Binary_Op;
5459
5460 -----------------------------------
5461 -- Analyze_User_Defined_Unary_Op --
5462 -----------------------------------
5463
5464 procedure Analyze_User_Defined_Unary_Op
5465 (N : Node_Id;
5466 Op_Id : Entity_Id)
5467 is
5468 begin
5469 -- Only do analysis if the operator Comes_From_Source, since otherwise
5470 -- the operator was generated by the expander, and all such operators
5471 -- always refer to the operators in package Standard.
5472
5473 if Comes_From_Source (N) then
5474 declare
5475 F : constant Entity_Id := First_Formal (Op_Id);
5476
5477 begin
5478 -- Verify that Op_Id is a visible unary function. Note that since
5479 -- we know Op_Id is overloaded, potentially use visible means use
5480 -- visible for sure (RM 9.4(11)).
5481
5482 if Ekind (Op_Id) = E_Function
5483 and then No (Next_Formal (F))
5484 and then (Is_Immediately_Visible (Op_Id)
5485 or else Is_Potentially_Use_Visible (Op_Id))
5486 and then Has_Compatible_Type (Right_Opnd (N), Etype (F))
5487 then
5488 Add_One_Interp (N, Op_Id, Etype (Op_Id));
5489 end if;
5490 end;
5491 end if;
5492 end Analyze_User_Defined_Unary_Op;
5493
5494 ---------------------------
5495 -- Check_Arithmetic_Pair --
5496 ---------------------------
5497
5498 procedure Check_Arithmetic_Pair
5499 (T1, T2 : Entity_Id;
5500 Op_Id : Entity_Id;
5501 N : Node_Id)
5502 is
5503 Op_Name : constant Name_Id := Chars (Op_Id);
5504
5505 function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean;
5506 -- Check whether the fixed-point type Typ has a user-defined operator
5507 -- (multiplication or division) that should hide the corresponding
5508 -- predefined operator. Used to implement Ada 2005 AI-264, to make
5509 -- such operators more visible and therefore useful.
5510 --
5511 -- If the name of the operation is an expanded name with prefix
5512 -- Standard, the predefined universal fixed operator is available,
5513 -- as specified by AI-420 (RM 4.5.5 (19.1/2)).
5514
5515 function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
5516 -- Get specific type (i.e. non-universal type if there is one)
5517
5518 ------------------
5519 -- Has_Fixed_Op --
5520 ------------------
5521
5522 function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean is
5523 Bas : constant Entity_Id := Base_Type (Typ);
5524 Ent : Entity_Id;
5525 F1 : Entity_Id;
5526 F2 : Entity_Id;
5527
5528 begin
5529 -- If the universal_fixed operation is given explicitly the rule
5530 -- concerning primitive operations of the type do not apply.
5531
5532 if Nkind (N) = N_Function_Call
5533 and then Nkind (Name (N)) = N_Expanded_Name
5534 and then Entity (Prefix (Name (N))) = Standard_Standard
5535 then
5536 return False;
5537 end if;
5538
5539 -- The operation is treated as primitive if it is declared in the
5540 -- same scope as the type, and therefore on the same entity chain.
5541
5542 Ent := Next_Entity (Typ);
5543 while Present (Ent) loop
5544 if Chars (Ent) = Chars (Op) then
5545 F1 := First_Formal (Ent);
5546 F2 := Next_Formal (F1);
5547
5548 -- The operation counts as primitive if either operand or
5549 -- result are of the given base type, and both operands are
5550 -- fixed point types.
5551
5552 if (Base_Type (Etype (F1)) = Bas
5553 and then Is_Fixed_Point_Type (Etype (F2)))
5554
5555 or else
5556 (Base_Type (Etype (F2)) = Bas
5557 and then Is_Fixed_Point_Type (Etype (F1)))
5558
5559 or else
5560 (Base_Type (Etype (Ent)) = Bas
5561 and then Is_Fixed_Point_Type (Etype (F1))
5562 and then Is_Fixed_Point_Type (Etype (F2)))
5563 then
5564 return True;
5565 end if;
5566 end if;
5567
5568 Next_Entity (Ent);
5569 end loop;
5570
5571 return False;
5572 end Has_Fixed_Op;
5573
5574 -------------------
5575 -- Specific_Type --
5576 -------------------
5577
5578 function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
5579 begin
5580 if T1 = Universal_Integer or else T1 = Universal_Real then
5581 return Base_Type (T2);
5582 else
5583 return Base_Type (T1);
5584 end if;
5585 end Specific_Type;
5586
5587 -- Start of processing for Check_Arithmetic_Pair
5588
5589 begin
5590 if Nam_In (Op_Name, Name_Op_Add, Name_Op_Subtract) then
5591 if Is_Numeric_Type (T1)
5592 and then Is_Numeric_Type (T2)
5593 and then (Covers (T1 => T1, T2 => T2)
5594 or else
5595 Covers (T1 => T2, T2 => T1))
5596 then
5597 Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
5598 end if;
5599
5600 elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) then
5601 if Is_Fixed_Point_Type (T1)
5602 and then (Is_Fixed_Point_Type (T2) or else T2 = Universal_Real)
5603 then
5604 -- If Treat_Fixed_As_Integer is set then the Etype is already set
5605 -- and no further processing is required (this is the case of an
5606 -- operator constructed by Exp_Fixd for a fixed point operation)
5607 -- Otherwise add one interpretation with universal fixed result
5608 -- If the operator is given in functional notation, it comes
5609 -- from source and Fixed_As_Integer cannot apply.
5610
5611 if (Nkind (N) not in N_Op
5612 or else not Treat_Fixed_As_Integer (N))
5613 and then
5614 (not Has_Fixed_Op (T1, Op_Id)
5615 or else Nkind (Parent (N)) = N_Type_Conversion)
5616 then
5617 Add_One_Interp (N, Op_Id, Universal_Fixed);
5618 end if;
5619
5620 elsif Is_Fixed_Point_Type (T2)
5621 and then (Nkind (N) not in N_Op
5622 or else not Treat_Fixed_As_Integer (N))
5623 and then T1 = Universal_Real
5624 and then
5625 (not Has_Fixed_Op (T1, Op_Id)
5626 or else Nkind (Parent (N)) = N_Type_Conversion)
5627 then
5628 Add_One_Interp (N, Op_Id, Universal_Fixed);
5629
5630 elsif Is_Numeric_Type (T1)
5631 and then Is_Numeric_Type (T2)
5632 and then (Covers (T1 => T1, T2 => T2)
5633 or else
5634 Covers (T1 => T2, T2 => T1))
5635 then
5636 Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
5637
5638 elsif Is_Fixed_Point_Type (T1)
5639 and then (Base_Type (T2) = Base_Type (Standard_Integer)
5640 or else T2 = Universal_Integer)
5641 then
5642 Add_One_Interp (N, Op_Id, T1);
5643
5644 elsif T2 = Universal_Real
5645 and then Base_Type (T1) = Base_Type (Standard_Integer)
5646 and then Op_Name = Name_Op_Multiply
5647 then
5648 Add_One_Interp (N, Op_Id, Any_Fixed);
5649
5650 elsif T1 = Universal_Real
5651 and then Base_Type (T2) = Base_Type (Standard_Integer)
5652 then
5653 Add_One_Interp (N, Op_Id, Any_Fixed);
5654
5655 elsif Is_Fixed_Point_Type (T2)
5656 and then (Base_Type (T1) = Base_Type (Standard_Integer)
5657 or else T1 = Universal_Integer)
5658 and then Op_Name = Name_Op_Multiply
5659 then
5660 Add_One_Interp (N, Op_Id, T2);
5661
5662 elsif T1 = Universal_Real and then T2 = Universal_Integer then
5663 Add_One_Interp (N, Op_Id, T1);
5664
5665 elsif T2 = Universal_Real
5666 and then T1 = Universal_Integer
5667 and then Op_Name = Name_Op_Multiply
5668 then
5669 Add_One_Interp (N, Op_Id, T2);
5670 end if;
5671
5672 elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
5673
5674 -- Note: The fixed-point operands case with Treat_Fixed_As_Integer
5675 -- set does not require any special processing, since the Etype is
5676 -- already set (case of operation constructed by Exp_Fixed).
5677
5678 if Is_Integer_Type (T1)
5679 and then (Covers (T1 => T1, T2 => T2)
5680 or else
5681 Covers (T1 => T2, T2 => T1))
5682 then
5683 Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
5684 end if;
5685
5686 elsif Op_Name = Name_Op_Expon then
5687 if Is_Numeric_Type (T1)
5688 and then not Is_Fixed_Point_Type (T1)
5689 and then (Base_Type (T2) = Base_Type (Standard_Integer)
5690 or else T2 = Universal_Integer)
5691 then
5692 Add_One_Interp (N, Op_Id, Base_Type (T1));
5693 end if;
5694
5695 else pragma Assert (Nkind (N) in N_Op_Shift);
5696
5697 -- If not one of the predefined operators, the node may be one
5698 -- of the intrinsic functions. Its kind is always specific, and
5699 -- we can use it directly, rather than the name of the operation.
5700
5701 if Is_Integer_Type (T1)
5702 and then (Base_Type (T2) = Base_Type (Standard_Integer)
5703 or else T2 = Universal_Integer)
5704 then
5705 Add_One_Interp (N, Op_Id, Base_Type (T1));
5706 end if;
5707 end if;
5708 end Check_Arithmetic_Pair;
5709
5710 -------------------------------
5711 -- Check_Misspelled_Selector --
5712 -------------------------------
5713
5714 procedure Check_Misspelled_Selector
5715 (Prefix : Entity_Id;
5716 Sel : Node_Id)
5717 is
5718 Max_Suggestions : constant := 2;
5719 Nr_Of_Suggestions : Natural := 0;
5720
5721 Suggestion_1 : Entity_Id := Empty;
5722 Suggestion_2 : Entity_Id := Empty;
5723
5724 Comp : Entity_Id;
5725
5726 begin
5727 -- All the components of the prefix of selector Sel are matched against
5728 -- Sel and a count is maintained of possible misspellings. When at
5729 -- the end of the analysis there are one or two (not more) possible
5730 -- misspellings, these misspellings will be suggested as possible
5731 -- correction.
5732
5733 if not (Is_Private_Type (Prefix) or else Is_Record_Type (Prefix)) then
5734
5735 -- Concurrent types should be handled as well ???
5736
5737 return;
5738 end if;
5739
5740 Comp := First_Entity (Prefix);
5741 while Nr_Of_Suggestions <= Max_Suggestions and then Present (Comp) loop
5742 if Is_Visible_Component (Comp) then
5743 if Is_Bad_Spelling_Of (Chars (Comp), Chars (Sel)) then
5744 Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
5745
5746 case Nr_Of_Suggestions is
5747 when 1 => Suggestion_1 := Comp;
5748 when 2 => Suggestion_2 := Comp;
5749 when others => null;
5750 end case;
5751 end if;
5752 end if;
5753
5754 Comp := Next_Entity (Comp);
5755 end loop;
5756
5757 -- Report at most two suggestions
5758
5759 if Nr_Of_Suggestions = 1 then
5760 Error_Msg_NE -- CODEFIX
5761 ("\possible misspelling of&", Sel, Suggestion_1);
5762
5763 elsif Nr_Of_Suggestions = 2 then
5764 Error_Msg_Node_2 := Suggestion_2;
5765 Error_Msg_NE -- CODEFIX
5766 ("\possible misspelling of& or&", Sel, Suggestion_1);
5767 end if;
5768 end Check_Misspelled_Selector;
5769
5770 ----------------------
5771 -- Defined_In_Scope --
5772 ----------------------
5773
5774 function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean
5775 is
5776 S1 : constant Entity_Id := Scope (Base_Type (T));
5777 begin
5778 return S1 = S
5779 or else (S1 = System_Aux_Id and then S = Scope (S1));
5780 end Defined_In_Scope;
5781
5782 -------------------
5783 -- Diagnose_Call --
5784 -------------------
5785
5786 procedure Diagnose_Call (N : Node_Id; Nam : Node_Id) is
5787 Actual : Node_Id;
5788 X : Interp_Index;
5789 It : Interp;
5790 Err_Mode : Boolean;
5791 New_Nam : Node_Id;
5792 Void_Interp_Seen : Boolean := False;
5793
5794 Success : Boolean;
5795 pragma Warnings (Off, Boolean);
5796
5797 begin
5798 if Ada_Version >= Ada_2005 then
5799 Actual := First_Actual (N);
5800 while Present (Actual) loop
5801
5802 -- Ada 2005 (AI-50217): Post an error in case of premature
5803 -- usage of an entity from the limited view.
5804
5805 if not Analyzed (Etype (Actual))
5806 and then From_Limited_With (Etype (Actual))
5807 then
5808 Error_Msg_Qual_Level := 1;
5809 Error_Msg_NE
5810 ("missing with_clause for scope of imported type&",
5811 Actual, Etype (Actual));
5812 Error_Msg_Qual_Level := 0;
5813 end if;
5814
5815 Next_Actual (Actual);
5816 end loop;
5817 end if;
5818
5819 -- Analyze each candidate call again, with full error reporting
5820 -- for each.
5821
5822 Error_Msg_N
5823 ("no candidate interpretations match the actuals:!", Nam);
5824 Err_Mode := All_Errors_Mode;
5825 All_Errors_Mode := True;
5826
5827 -- If this is a call to an operation of a concurrent type,
5828 -- the failed interpretations have been removed from the
5829 -- name. Recover them to provide full diagnostics.
5830
5831 if Nkind (Parent (Nam)) = N_Selected_Component then
5832 Set_Entity (Nam, Empty);
5833 New_Nam := New_Copy_Tree (Parent (Nam));
5834 Set_Is_Overloaded (New_Nam, False);
5835 Set_Is_Overloaded (Selector_Name (New_Nam), False);
5836 Set_Parent (New_Nam, Parent (Parent (Nam)));
5837 Analyze_Selected_Component (New_Nam);
5838 Get_First_Interp (Selector_Name (New_Nam), X, It);
5839 else
5840 Get_First_Interp (Nam, X, It);
5841 end if;
5842
5843 while Present (It.Nam) loop
5844 if Etype (It.Nam) = Standard_Void_Type then
5845 Void_Interp_Seen := True;
5846 end if;
5847
5848 Analyze_One_Call (N, It.Nam, True, Success);
5849 Get_Next_Interp (X, It);
5850 end loop;
5851
5852 if Nkind (N) = N_Function_Call then
5853 Get_First_Interp (Nam, X, It);
5854 while Present (It.Nam) loop
5855 if Ekind_In (It.Nam, E_Function, E_Operator) then
5856 return;
5857 else
5858 Get_Next_Interp (X, It);
5859 end if;
5860 end loop;
5861
5862 -- If all interpretations are procedures, this deserves a
5863 -- more precise message. Ditto if this appears as the prefix
5864 -- of a selected component, which may be a lexical error.
5865
5866 Error_Msg_N
5867 ("\context requires function call, found procedure name", Nam);
5868
5869 if Nkind (Parent (N)) = N_Selected_Component
5870 and then N = Prefix (Parent (N))
5871 then
5872 Error_Msg_N -- CODEFIX
5873 ("\period should probably be semicolon", Parent (N));
5874 end if;
5875
5876 elsif Nkind (N) = N_Procedure_Call_Statement
5877 and then not Void_Interp_Seen
5878 then
5879 Error_Msg_N (
5880 "\function name found in procedure call", Nam);
5881 end if;
5882
5883 All_Errors_Mode := Err_Mode;
5884 end Diagnose_Call;
5885
5886 ---------------------------
5887 -- Find_Arithmetic_Types --
5888 ---------------------------
5889
5890 procedure Find_Arithmetic_Types
5891 (L, R : Node_Id;
5892 Op_Id : Entity_Id;
5893 N : Node_Id)
5894 is
5895 Index1 : Interp_Index;
5896 Index2 : Interp_Index;
5897 It1 : Interp;
5898 It2 : Interp;
5899
5900 procedure Check_Right_Argument (T : Entity_Id);
5901 -- Check right operand of operator
5902
5903 --------------------------
5904 -- Check_Right_Argument --
5905 --------------------------
5906
5907 procedure Check_Right_Argument (T : Entity_Id) is
5908 begin
5909 if not Is_Overloaded (R) then
5910 Check_Arithmetic_Pair (T, Etype (R), Op_Id, N);
5911 else
5912 Get_First_Interp (R, Index2, It2);
5913 while Present (It2.Typ) loop
5914 Check_Arithmetic_Pair (T, It2.Typ, Op_Id, N);
5915 Get_Next_Interp (Index2, It2);
5916 end loop;
5917 end if;
5918 end Check_Right_Argument;
5919
5920 -- Start of processing for Find_Arithmetic_Types
5921
5922 begin
5923 if not Is_Overloaded (L) then
5924 Check_Right_Argument (Etype (L));
5925
5926 else
5927 Get_First_Interp (L, Index1, It1);
5928 while Present (It1.Typ) loop
5929 Check_Right_Argument (It1.Typ);
5930 Get_Next_Interp (Index1, It1);
5931 end loop;
5932 end if;
5933
5934 end Find_Arithmetic_Types;
5935
5936 ------------------------
5937 -- Find_Boolean_Types --
5938 ------------------------
5939
5940 procedure Find_Boolean_Types
5941 (L, R : Node_Id;
5942 Op_Id : Entity_Id;
5943 N : Node_Id)
5944 is
5945 Index : Interp_Index;
5946 It : Interp;
5947
5948 procedure Check_Numeric_Argument (T : Entity_Id);
5949 -- Special case for logical operations one of whose operands is an
5950 -- integer literal. If both are literal the result is any modular type.
5951
5952 ----------------------------
5953 -- Check_Numeric_Argument --
5954 ----------------------------
5955
5956 procedure Check_Numeric_Argument (T : Entity_Id) is
5957 begin
5958 if T = Universal_Integer then
5959 Add_One_Interp (N, Op_Id, Any_Modular);
5960
5961 elsif Is_Modular_Integer_Type (T) then
5962 Add_One_Interp (N, Op_Id, T);
5963 end if;
5964 end Check_Numeric_Argument;
5965
5966 -- Start of processing for Find_Boolean_Types
5967
5968 begin
5969 if not Is_Overloaded (L) then
5970 if Etype (L) = Universal_Integer
5971 or else Etype (L) = Any_Modular
5972 then
5973 if not Is_Overloaded (R) then
5974 Check_Numeric_Argument (Etype (R));
5975
5976 else
5977 Get_First_Interp (R, Index, It);
5978 while Present (It.Typ) loop
5979 Check_Numeric_Argument (It.Typ);
5980 Get_Next_Interp (Index, It);
5981 end loop;
5982 end if;
5983
5984 -- If operands are aggregates, we must assume that they may be
5985 -- boolean arrays, and leave disambiguation for the second pass.
5986 -- If only one is an aggregate, verify that the other one has an
5987 -- interpretation as a boolean array
5988
5989 elsif Nkind (L) = N_Aggregate then
5990 if Nkind (R) = N_Aggregate then
5991 Add_One_Interp (N, Op_Id, Etype (L));
5992
5993 elsif not Is_Overloaded (R) then
5994 if Valid_Boolean_Arg (Etype (R)) then
5995 Add_One_Interp (N, Op_Id, Etype (R));
5996 end if;
5997
5998 else
5999 Get_First_Interp (R, Index, It);
6000 while Present (It.Typ) loop
6001 if Valid_Boolean_Arg (It.Typ) then
6002 Add_One_Interp (N, Op_Id, It.Typ);
6003 end if;
6004
6005 Get_Next_Interp (Index, It);
6006 end loop;
6007 end if;
6008
6009 elsif Valid_Boolean_Arg (Etype (L))
6010 and then Has_Compatible_Type (R, Etype (L))
6011 then
6012 Add_One_Interp (N, Op_Id, Etype (L));
6013 end if;
6014
6015 else
6016 Get_First_Interp (L, Index, It);
6017 while Present (It.Typ) loop
6018 if Valid_Boolean_Arg (It.Typ)
6019 and then Has_Compatible_Type (R, It.Typ)
6020 then
6021 Add_One_Interp (N, Op_Id, It.Typ);
6022 end if;
6023
6024 Get_Next_Interp (Index, It);
6025 end loop;
6026 end if;
6027 end Find_Boolean_Types;
6028
6029 ---------------------------
6030 -- Find_Comparison_Types --
6031 ---------------------------
6032
6033 procedure Find_Comparison_Types
6034 (L, R : Node_Id;
6035 Op_Id : Entity_Id;
6036 N : Node_Id)
6037 is
6038 Index : Interp_Index;
6039 It : Interp;
6040 Found : Boolean := False;
6041 I_F : Interp_Index;
6042 T_F : Entity_Id;
6043 Scop : Entity_Id := Empty;
6044
6045 procedure Try_One_Interp (T1 : Entity_Id);
6046 -- Routine to try one proposed interpretation. Note that the context
6047 -- of the operator plays no role in resolving the arguments, so that
6048 -- if there is more than one interpretation of the operands that is
6049 -- compatible with comparison, the operation is ambiguous.
6050
6051 --------------------
6052 -- Try_One_Interp --
6053 --------------------
6054
6055 procedure Try_One_Interp (T1 : Entity_Id) is
6056 begin
6057
6058 -- If the operator is an expanded name, then the type of the operand
6059 -- must be defined in the corresponding scope. If the type is
6060 -- universal, the context will impose the correct type.
6061
6062 if Present (Scop)
6063 and then not Defined_In_Scope (T1, Scop)
6064 and then T1 /= Universal_Integer
6065 and then T1 /= Universal_Real
6066 and then T1 /= Any_String
6067 and then T1 /= Any_Composite
6068 then
6069 return;
6070 end if;
6071
6072 if Valid_Comparison_Arg (T1) and then Has_Compatible_Type (R, T1) then
6073 if Found and then Base_Type (T1) /= Base_Type (T_F) then
6074 It := Disambiguate (L, I_F, Index, Any_Type);
6075
6076 if It = No_Interp then
6077 Ambiguous_Operands (N);
6078 Set_Etype (L, Any_Type);
6079 return;
6080
6081 else
6082 T_F := It.Typ;
6083 end if;
6084
6085 else
6086 Found := True;
6087 T_F := T1;
6088 I_F := Index;
6089 end if;
6090
6091 Set_Etype (L, T_F);
6092 Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
6093
6094 end if;
6095 end Try_One_Interp;
6096
6097 -- Start of processing for Find_Comparison_Types
6098
6099 begin
6100 -- If left operand is aggregate, the right operand has to
6101 -- provide a usable type for it.
6102
6103 if Nkind (L) = N_Aggregate and then Nkind (R) /= N_Aggregate then
6104 Find_Comparison_Types (L => R, R => L, Op_Id => Op_Id, N => N);
6105 return;
6106 end if;
6107
6108 if Nkind (N) = N_Function_Call
6109 and then Nkind (Name (N)) = N_Expanded_Name
6110 then
6111 Scop := Entity (Prefix (Name (N)));
6112
6113 -- The prefix may be a package renaming, and the subsequent test
6114 -- requires the original package.
6115
6116 if Ekind (Scop) = E_Package
6117 and then Present (Renamed_Entity (Scop))
6118 then
6119 Scop := Renamed_Entity (Scop);
6120 Set_Entity (Prefix (Name (N)), Scop);
6121 end if;
6122 end if;
6123
6124 if not Is_Overloaded (L) then
6125 Try_One_Interp (Etype (L));
6126
6127 else
6128 Get_First_Interp (L, Index, It);
6129 while Present (It.Typ) loop
6130 Try_One_Interp (It.Typ);
6131 Get_Next_Interp (Index, It);
6132 end loop;
6133 end if;
6134 end Find_Comparison_Types;
6135
6136 ----------------------------------------
6137 -- Find_Non_Universal_Interpretations --
6138 ----------------------------------------
6139
6140 procedure Find_Non_Universal_Interpretations
6141 (N : Node_Id;
6142 R : Node_Id;
6143 Op_Id : Entity_Id;
6144 T1 : Entity_Id)
6145 is
6146 Index : Interp_Index;
6147 It : Interp;
6148
6149 begin
6150 if T1 = Universal_Integer or else T1 = Universal_Real
6151
6152 -- If the left operand of an equality operator is null, the visibility
6153 -- of the operator must be determined from the interpretation of the
6154 -- right operand. This processing must be done for Any_Access, which
6155 -- is the internal representation of the type of the literal null.
6156
6157 or else T1 = Any_Access
6158 then
6159 if not Is_Overloaded (R) then
6160 Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (Etype (R)));
6161 else
6162 Get_First_Interp (R, Index, It);
6163 while Present (It.Typ) loop
6164 if Covers (It.Typ, T1) then
6165 Add_One_Interp
6166 (N, Op_Id, Standard_Boolean, Base_Type (It.Typ));
6167 end if;
6168
6169 Get_Next_Interp (Index, It);
6170 end loop;
6171 end if;
6172 else
6173 Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1));
6174 end if;
6175 end Find_Non_Universal_Interpretations;
6176
6177 ------------------------------
6178 -- Find_Concatenation_Types --
6179 ------------------------------
6180
6181 procedure Find_Concatenation_Types
6182 (L, R : Node_Id;
6183 Op_Id : Entity_Id;
6184 N : Node_Id)
6185 is
6186 Op_Type : constant Entity_Id := Etype (Op_Id);
6187
6188 begin
6189 if Is_Array_Type (Op_Type)
6190 and then not Is_Limited_Type (Op_Type)
6191
6192 and then (Has_Compatible_Type (L, Op_Type)
6193 or else
6194 Has_Compatible_Type (L, Component_Type (Op_Type)))
6195
6196 and then (Has_Compatible_Type (R, Op_Type)
6197 or else
6198 Has_Compatible_Type (R, Component_Type (Op_Type)))
6199 then
6200 Add_One_Interp (N, Op_Id, Op_Type);
6201 end if;
6202 end Find_Concatenation_Types;
6203
6204 -------------------------
6205 -- Find_Equality_Types --
6206 -------------------------
6207
6208 procedure Find_Equality_Types
6209 (L, R : Node_Id;
6210 Op_Id : Entity_Id;
6211 N : Node_Id)
6212 is
6213 Index : Interp_Index;
6214 It : Interp;
6215 Found : Boolean := False;
6216 I_F : Interp_Index;
6217 T_F : Entity_Id;
6218 Scop : Entity_Id := Empty;
6219
6220 procedure Try_One_Interp (T1 : Entity_Id);
6221 -- The context of the equality operator plays no role in resolving the
6222 -- arguments, so that if there is more than one interpretation of the
6223 -- operands that is compatible with equality, the construct is ambiguous
6224 -- and an error can be emitted now, after trying to disambiguate, i.e.
6225 -- applying preference rules.
6226
6227 --------------------
6228 -- Try_One_Interp --
6229 --------------------
6230
6231 procedure Try_One_Interp (T1 : Entity_Id) is
6232 Bas : constant Entity_Id := Base_Type (T1);
6233
6234 begin
6235 -- If the operator is an expanded name, then the type of the operand
6236 -- must be defined in the corresponding scope. If the type is
6237 -- universal, the context will impose the correct type. An anonymous
6238 -- type for a 'Access reference is also universal in this sense, as
6239 -- the actual type is obtained from context.
6240
6241 -- In Ada 2005, the equality operator for anonymous access types
6242 -- is declared in Standard, and preference rules apply to it.
6243
6244 if Present (Scop) then
6245 if Defined_In_Scope (T1, Scop)
6246 or else T1 = Universal_Integer
6247 or else T1 = Universal_Real
6248 or else T1 = Any_Access
6249 or else T1 = Any_String
6250 or else T1 = Any_Composite
6251 or else (Ekind (T1) = E_Access_Subprogram_Type
6252 and then not Comes_From_Source (T1))
6253 then
6254 null;
6255
6256 elsif Ekind (T1) = E_Anonymous_Access_Type
6257 and then Scop = Standard_Standard
6258 then
6259 null;
6260
6261 else
6262 -- The scope does not contain an operator for the type
6263
6264 return;
6265 end if;
6266
6267 -- If we have infix notation, the operator must be usable. Within
6268 -- an instance, if the type is already established we know it is
6269 -- correct. If an operand is universal it is compatible with any
6270 -- numeric type.
6271
6272 elsif In_Open_Scopes (Scope (Bas))
6273 or else Is_Potentially_Use_Visible (Bas)
6274 or else In_Use (Bas)
6275 or else (In_Use (Scope (Bas)) and then not Is_Hidden (Bas))
6276
6277 -- In an instance, the type may have been immediately visible.
6278 -- Either the types are compatible, or one operand is universal
6279 -- (numeric or null).
6280
6281 or else (In_Instance
6282 and then
6283 (First_Subtype (T1) = First_Subtype (Etype (R))
6284 or else Nkind (R) = N_Null
6285 or else
6286 (Is_Numeric_Type (T1)
6287 and then Is_Universal_Numeric_Type (Etype (R)))))
6288
6289 -- In Ada 2005, the equality on anonymous access types is declared
6290 -- in Standard, and is always visible.
6291
6292 or else Ekind (T1) = E_Anonymous_Access_Type
6293 then
6294 null;
6295
6296 else
6297 -- Save candidate type for subsequent error message, if any
6298
6299 if not Is_Limited_Type (T1) then
6300 Candidate_Type := T1;
6301 end if;
6302
6303 return;
6304 end if;
6305
6306 -- Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
6307 -- Do not allow anonymous access types in equality operators.
6308
6309 if Ada_Version < Ada_2005
6310 and then Ekind (T1) = E_Anonymous_Access_Type
6311 then
6312 return;
6313 end if;
6314
6315 -- If the right operand has a type compatible with T1, check for an
6316 -- acceptable interpretation, unless T1 is limited (no predefined
6317 -- equality available), or this is use of a "/=" for a tagged type.
6318 -- In the latter case, possible interpretations of equality need
6319 -- to be considered, we don't want the default inequality declared
6320 -- in Standard to be chosen, and the "/=" will be rewritten as a
6321 -- negation of "=" (see the end of Analyze_Equality_Op). This ensures
6322 -- that that rewriting happens during analysis rather than being
6323 -- delayed until expansion (this is needed for ASIS, which only sees
6324 -- the unexpanded tree). Note that if the node is N_Op_Ne, but Op_Id
6325 -- is Name_Op_Eq then we still proceed with the interpretation,
6326 -- because that indicates the potential rewriting case where the
6327 -- interpretation to consider is actually "=" and the node may be
6328 -- about to be rewritten by Analyze_Equality_Op.
6329
6330 if T1 /= Standard_Void_Type
6331 and then Has_Compatible_Type (R, T1)
6332
6333 and then
6334 ((not Is_Limited_Type (T1)
6335 and then not Is_Limited_Composite (T1))
6336
6337 or else
6338 (Is_Array_Type (T1)
6339 and then not Is_Limited_Type (Component_Type (T1))
6340 and then Available_Full_View_Of_Component (T1)))
6341
6342 and then
6343 (Nkind (N) /= N_Op_Ne
6344 or else not Is_Tagged_Type (T1)
6345 or else Chars (Op_Id) = Name_Op_Eq)
6346 then
6347 if Found
6348 and then Base_Type (T1) /= Base_Type (T_F)
6349 then
6350 It := Disambiguate (L, I_F, Index, Any_Type);
6351
6352 if It = No_Interp then
6353 Ambiguous_Operands (N);
6354 Set_Etype (L, Any_Type);
6355 return;
6356
6357 else
6358 T_F := It.Typ;
6359 end if;
6360
6361 else
6362 Found := True;
6363 T_F := T1;
6364 I_F := Index;
6365 end if;
6366
6367 if not Analyzed (L) then
6368 Set_Etype (L, T_F);
6369 end if;
6370
6371 Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
6372
6373 -- Case of operator was not visible, Etype still set to Any_Type
6374
6375 if Etype (N) = Any_Type then
6376 Found := False;
6377 end if;
6378
6379 elsif Scop = Standard_Standard
6380 and then Ekind (T1) = E_Anonymous_Access_Type
6381 then
6382 Found := True;
6383 end if;
6384 end Try_One_Interp;
6385
6386 -- Start of processing for Find_Equality_Types
6387
6388 begin
6389 -- If left operand is aggregate, the right operand has to
6390 -- provide a usable type for it.
6391
6392 if Nkind (L) = N_Aggregate
6393 and then Nkind (R) /= N_Aggregate
6394 then
6395 Find_Equality_Types (L => R, R => L, Op_Id => Op_Id, N => N);
6396 return;
6397 end if;
6398
6399 if Nkind (N) = N_Function_Call
6400 and then Nkind (Name (N)) = N_Expanded_Name
6401 then
6402 Scop := Entity (Prefix (Name (N)));
6403
6404 -- The prefix may be a package renaming, and the subsequent test
6405 -- requires the original package.
6406
6407 if Ekind (Scop) = E_Package
6408 and then Present (Renamed_Entity (Scop))
6409 then
6410 Scop := Renamed_Entity (Scop);
6411 Set_Entity (Prefix (Name (N)), Scop);
6412 end if;
6413 end if;
6414
6415 if not Is_Overloaded (L) then
6416 Try_One_Interp (Etype (L));
6417
6418 else
6419 Get_First_Interp (L, Index, It);
6420 while Present (It.Typ) loop
6421 Try_One_Interp (It.Typ);
6422 Get_Next_Interp (Index, It);
6423 end loop;
6424 end if;
6425 end Find_Equality_Types;
6426
6427 -------------------------
6428 -- Find_Negation_Types --
6429 -------------------------
6430
6431 procedure Find_Negation_Types
6432 (R : Node_Id;
6433 Op_Id : Entity_Id;
6434 N : Node_Id)
6435 is
6436 Index : Interp_Index;
6437 It : Interp;
6438
6439 begin
6440 if not Is_Overloaded (R) then
6441 if Etype (R) = Universal_Integer then
6442 Add_One_Interp (N, Op_Id, Any_Modular);
6443 elsif Valid_Boolean_Arg (Etype (R)) then
6444 Add_One_Interp (N, Op_Id, Etype (R));
6445 end if;
6446
6447 else
6448 Get_First_Interp (R, Index, It);
6449 while Present (It.Typ) loop
6450 if Valid_Boolean_Arg (It.Typ) then
6451 Add_One_Interp (N, Op_Id, It.Typ);
6452 end if;
6453
6454 Get_Next_Interp (Index, It);
6455 end loop;
6456 end if;
6457 end Find_Negation_Types;
6458
6459 ------------------------------
6460 -- Find_Primitive_Operation --
6461 ------------------------------
6462
6463 function Find_Primitive_Operation (N : Node_Id) return Boolean is
6464 Obj : constant Node_Id := Prefix (N);
6465 Op : constant Node_Id := Selector_Name (N);
6466
6467 Prim : Elmt_Id;
6468 Prims : Elist_Id;
6469 Typ : Entity_Id;
6470
6471 begin
6472 Set_Etype (Op, Any_Type);
6473
6474 if Is_Access_Type (Etype (Obj)) then
6475 Typ := Designated_Type (Etype (Obj));
6476 else
6477 Typ := Etype (Obj);
6478 end if;
6479
6480 if Is_Class_Wide_Type (Typ) then
6481 Typ := Root_Type (Typ);
6482 end if;
6483
6484 Prims := Primitive_Operations (Typ);
6485
6486 Prim := First_Elmt (Prims);
6487 while Present (Prim) loop
6488 if Chars (Node (Prim)) = Chars (Op) then
6489 Add_One_Interp (Op, Node (Prim), Etype (Node (Prim)));
6490 Set_Etype (N, Etype (Node (Prim)));
6491 end if;
6492
6493 Next_Elmt (Prim);
6494 end loop;
6495
6496 -- Now look for class-wide operations of the type or any of its
6497 -- ancestors by iterating over the homonyms of the selector.
6498
6499 declare
6500 Cls_Type : constant Entity_Id := Class_Wide_Type (Typ);
6501 Hom : Entity_Id;
6502
6503 begin
6504 Hom := Current_Entity (Op);
6505 while Present (Hom) loop
6506 if (Ekind (Hom) = E_Procedure
6507 or else
6508 Ekind (Hom) = E_Function)
6509 and then Scope (Hom) = Scope (Typ)
6510 and then Present (First_Formal (Hom))
6511 and then
6512 (Base_Type (Etype (First_Formal (Hom))) = Cls_Type
6513 or else
6514 (Is_Access_Type (Etype (First_Formal (Hom)))
6515 and then
6516 Ekind (Etype (First_Formal (Hom))) =
6517 E_Anonymous_Access_Type
6518 and then
6519 Base_Type
6520 (Designated_Type (Etype (First_Formal (Hom)))) =
6521 Cls_Type))
6522 then
6523 Add_One_Interp (Op, Hom, Etype (Hom));
6524 Set_Etype (N, Etype (Hom));
6525 end if;
6526
6527 Hom := Homonym (Hom);
6528 end loop;
6529 end;
6530
6531 return Etype (Op) /= Any_Type;
6532 end Find_Primitive_Operation;
6533
6534 ----------------------
6535 -- Find_Unary_Types --
6536 ----------------------
6537
6538 procedure Find_Unary_Types
6539 (R : Node_Id;
6540 Op_Id : Entity_Id;
6541 N : Node_Id)
6542 is
6543 Index : Interp_Index;
6544 It : Interp;
6545
6546 begin
6547 if not Is_Overloaded (R) then
6548 if Is_Numeric_Type (Etype (R)) then
6549
6550 -- In an instance a generic actual may be a numeric type even if
6551 -- the formal in the generic unit was not. In that case, the
6552 -- predefined operator was not a possible interpretation in the
6553 -- generic, and cannot be one in the instance, unless the operator
6554 -- is an actual of an instance.
6555
6556 if In_Instance
6557 and then
6558 not Is_Numeric_Type (Corresponding_Generic_Type (Etype (R)))
6559 then
6560 null;
6561 else
6562 Add_One_Interp (N, Op_Id, Base_Type (Etype (R)));
6563 end if;
6564 end if;
6565
6566 else
6567 Get_First_Interp (R, Index, It);
6568 while Present (It.Typ) loop
6569 if Is_Numeric_Type (It.Typ) then
6570 if In_Instance
6571 and then
6572 not Is_Numeric_Type
6573 (Corresponding_Generic_Type (Etype (It.Typ)))
6574 then
6575 null;
6576
6577 else
6578 Add_One_Interp (N, Op_Id, Base_Type (It.Typ));
6579 end if;
6580 end if;
6581
6582 Get_Next_Interp (Index, It);
6583 end loop;
6584 end if;
6585 end Find_Unary_Types;
6586
6587 ------------------
6588 -- Junk_Operand --
6589 ------------------
6590
6591 function Junk_Operand (N : Node_Id) return Boolean is
6592 Enode : Node_Id;
6593
6594 begin
6595 if Error_Posted (N) then
6596 return False;
6597 end if;
6598
6599 -- Get entity to be tested
6600
6601 if Is_Entity_Name (N)
6602 and then Present (Entity (N))
6603 then
6604 Enode := N;
6605
6606 -- An odd case, a procedure name gets converted to a very peculiar
6607 -- function call, and here is where we detect this happening.
6608
6609 elsif Nkind (N) = N_Function_Call
6610 and then Is_Entity_Name (Name (N))
6611 and then Present (Entity (Name (N)))
6612 then
6613 Enode := Name (N);
6614
6615 -- Another odd case, there are at least some cases of selected
6616 -- components where the selected component is not marked as having
6617 -- an entity, even though the selector does have an entity
6618
6619 elsif Nkind (N) = N_Selected_Component
6620 and then Present (Entity (Selector_Name (N)))
6621 then
6622 Enode := Selector_Name (N);
6623
6624 else
6625 return False;
6626 end if;
6627
6628 -- Now test the entity we got to see if it is a bad case
6629
6630 case Ekind (Entity (Enode)) is
6631
6632 when E_Package =>
6633 Error_Msg_N
6634 ("package name cannot be used as operand", Enode);
6635
6636 when Generic_Unit_Kind =>
6637 Error_Msg_N
6638 ("generic unit name cannot be used as operand", Enode);
6639
6640 when Type_Kind =>
6641 Error_Msg_N
6642 ("subtype name cannot be used as operand", Enode);
6643
6644 when Entry_Kind =>
6645 Error_Msg_N
6646 ("entry name cannot be used as operand", Enode);
6647
6648 when E_Procedure =>
6649 Error_Msg_N
6650 ("procedure name cannot be used as operand", Enode);
6651
6652 when E_Exception =>
6653 Error_Msg_N
6654 ("exception name cannot be used as operand", Enode);
6655
6656 when E_Block | E_Label | E_Loop =>
6657 Error_Msg_N
6658 ("label name cannot be used as operand", Enode);
6659
6660 when others =>
6661 return False;
6662
6663 end case;
6664
6665 return True;
6666 end Junk_Operand;
6667
6668 --------------------
6669 -- Operator_Check --
6670 --------------------
6671
6672 procedure Operator_Check (N : Node_Id) is
6673 begin
6674 Remove_Abstract_Operations (N);
6675
6676 -- Test for case of no interpretation found for operator
6677
6678 if Etype (N) = Any_Type then
6679 declare
6680 L : Node_Id;
6681 R : Node_Id;
6682 Op_Id : Entity_Id := Empty;
6683
6684 begin
6685 R := Right_Opnd (N);
6686
6687 if Nkind (N) in N_Binary_Op then
6688 L := Left_Opnd (N);
6689 else
6690 L := Empty;
6691 end if;
6692
6693 -- If either operand has no type, then don't complain further,
6694 -- since this simply means that we have a propagated error.
6695
6696 if R = Error
6697 or else Etype (R) = Any_Type
6698 or else (Nkind (N) in N_Binary_Op and then Etype (L) = Any_Type)
6699 then
6700 -- For the rather unusual case where one of the operands is
6701 -- a Raise_Expression, whose initial type is Any_Type, use
6702 -- the type of the other operand.
6703
6704 if Nkind (L) = N_Raise_Expression then
6705 Set_Etype (L, Etype (R));
6706 Set_Etype (N, Etype (R));
6707
6708 elsif Nkind (R) = N_Raise_Expression then
6709 Set_Etype (R, Etype (L));
6710 Set_Etype (N, Etype (L));
6711 end if;
6712
6713 return;
6714
6715 -- We explicitly check for the case of concatenation of component
6716 -- with component to avoid reporting spurious matching array types
6717 -- that might happen to be lurking in distant packages (such as
6718 -- run-time packages). This also prevents inconsistencies in the
6719 -- messages for certain ACVC B tests, which can vary depending on
6720 -- types declared in run-time interfaces. Another improvement when
6721 -- aggregates are present is to look for a well-typed operand.
6722
6723 elsif Present (Candidate_Type)
6724 and then (Nkind (N) /= N_Op_Concat
6725 or else Is_Array_Type (Etype (L))
6726 or else Is_Array_Type (Etype (R)))
6727 then
6728 if Nkind (N) = N_Op_Concat then
6729 if Etype (L) /= Any_Composite
6730 and then Is_Array_Type (Etype (L))
6731 then
6732 Candidate_Type := Etype (L);
6733
6734 elsif Etype (R) /= Any_Composite
6735 and then Is_Array_Type (Etype (R))
6736 then
6737 Candidate_Type := Etype (R);
6738 end if;
6739 end if;
6740
6741 Error_Msg_NE -- CODEFIX
6742 ("operator for} is not directly visible!",
6743 N, First_Subtype (Candidate_Type));
6744
6745 declare
6746 U : constant Node_Id :=
6747 Cunit (Get_Source_Unit (Candidate_Type));
6748 begin
6749 if Unit_Is_Visible (U) then
6750 Error_Msg_N -- CODEFIX
6751 ("use clause would make operation legal!", N);
6752 else
6753 Error_Msg_NE -- CODEFIX
6754 ("add with_clause and use_clause for&!",
6755 N, Defining_Entity (Unit (U)));
6756 end if;
6757 end;
6758 return;
6759
6760 -- If either operand is a junk operand (e.g. package name), then
6761 -- post appropriate error messages, but do not complain further.
6762
6763 -- Note that the use of OR in this test instead of OR ELSE is
6764 -- quite deliberate, we may as well check both operands in the
6765 -- binary operator case.
6766
6767 elsif Junk_Operand (R)
6768 or -- really mean OR here and not OR ELSE, see above
6769 (Nkind (N) in N_Binary_Op and then Junk_Operand (L))
6770 then
6771 return;
6772
6773 -- If we have a logical operator, one of whose operands is
6774 -- Boolean, then we know that the other operand cannot resolve to
6775 -- Boolean (since we got no interpretations), but in that case we
6776 -- pretty much know that the other operand should be Boolean, so
6777 -- resolve it that way (generating an error).
6778
6779 elsif Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor) then
6780 if Etype (L) = Standard_Boolean then
6781 Resolve (R, Standard_Boolean);
6782 return;
6783 elsif Etype (R) = Standard_Boolean then
6784 Resolve (L, Standard_Boolean);
6785 return;
6786 end if;
6787
6788 -- For an arithmetic operator or comparison operator, if one
6789 -- of the operands is numeric, then we know the other operand
6790 -- is not the same numeric type. If it is a non-numeric type,
6791 -- then probably it is intended to match the other operand.
6792
6793 elsif Nkind_In (N, N_Op_Add,
6794 N_Op_Divide,
6795 N_Op_Ge,
6796 N_Op_Gt,
6797 N_Op_Le)
6798 or else
6799 Nkind_In (N, N_Op_Lt,
6800 N_Op_Mod,
6801 N_Op_Multiply,
6802 N_Op_Rem,
6803 N_Op_Subtract)
6804 then
6805 -- If Allow_Integer_Address is active, check whether the
6806 -- operation becomes legal after converting an operand.
6807
6808 if Is_Numeric_Type (Etype (L))
6809 and then not Is_Numeric_Type (Etype (R))
6810 then
6811 if Address_Integer_Convert_OK (Etype (R), Etype (L)) then
6812 Rewrite (R,
6813 Unchecked_Convert_To (Etype (L), Relocate_Node (R)));
6814
6815 if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then
6816 Analyze_Comparison_Op (N);
6817 else
6818 Analyze_Arithmetic_Op (N);
6819 end if;
6820 else
6821 Resolve (R, Etype (L));
6822 end if;
6823
6824 return;
6825
6826 elsif Is_Numeric_Type (Etype (R))
6827 and then not Is_Numeric_Type (Etype (L))
6828 then
6829 if Address_Integer_Convert_OK (Etype (L), Etype (R)) then
6830 Rewrite (L,
6831 Unchecked_Convert_To (Etype (R), Relocate_Node (L)));
6832
6833 if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then
6834 Analyze_Comparison_Op (N);
6835 else
6836 Analyze_Arithmetic_Op (N);
6837 end if;
6838
6839 return;
6840
6841 else
6842 Resolve (L, Etype (R));
6843 end if;
6844
6845 return;
6846
6847 elsif Allow_Integer_Address
6848 and then Is_Descendant_Of_Address (Etype (L))
6849 and then Is_Descendant_Of_Address (Etype (R))
6850 and then not Error_Posted (N)
6851 then
6852 declare
6853 Addr_Type : constant Entity_Id := Etype (L);
6854
6855 begin
6856 Rewrite (L,
6857 Unchecked_Convert_To (
6858 Standard_Integer, Relocate_Node (L)));
6859 Rewrite (R,
6860 Unchecked_Convert_To (
6861 Standard_Integer, Relocate_Node (R)));
6862
6863 if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then
6864 Analyze_Comparison_Op (N);
6865 else
6866 Analyze_Arithmetic_Op (N);
6867 end if;
6868
6869 -- If this is an operand in an enclosing arithmetic
6870 -- operation, Convert the result as an address so that
6871 -- arithmetic folding of address can continue.
6872
6873 if Nkind (Parent (N)) in N_Op then
6874 Rewrite (N,
6875 Unchecked_Convert_To (Addr_Type, Relocate_Node (N)));
6876 end if;
6877
6878 return;
6879 end;
6880
6881 -- Under relaxed RM semantics silently replace occurrences of
6882 -- null by System.Address_Null.
6883
6884 elsif Null_To_Null_Address_Convert_OK (N) then
6885 Replace_Null_By_Null_Address (N);
6886
6887 if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then
6888 Analyze_Comparison_Op (N);
6889 else
6890 Analyze_Arithmetic_Op (N);
6891 end if;
6892
6893 return;
6894 end if;
6895
6896 -- Comparisons on A'Access are common enough to deserve a
6897 -- special message.
6898
6899 elsif Nkind_In (N, N_Op_Eq, N_Op_Ne)
6900 and then Ekind (Etype (L)) = E_Access_Attribute_Type
6901 and then Ekind (Etype (R)) = E_Access_Attribute_Type
6902 then
6903 Error_Msg_N
6904 ("two access attributes cannot be compared directly", N);
6905 Error_Msg_N
6906 ("\use qualified expression for one of the operands",
6907 N);
6908 return;
6909
6910 -- Another one for C programmers
6911
6912 elsif Nkind (N) = N_Op_Concat
6913 and then Valid_Boolean_Arg (Etype (L))
6914 and then Valid_Boolean_Arg (Etype (R))
6915 then
6916 Error_Msg_N ("invalid operands for concatenation", N);
6917 Error_Msg_N -- CODEFIX
6918 ("\maybe AND was meant", N);
6919 return;
6920
6921 -- A special case for comparison of access parameter with null
6922
6923 elsif Nkind (N) = N_Op_Eq
6924 and then Is_Entity_Name (L)
6925 and then Nkind (Parent (Entity (L))) = N_Parameter_Specification
6926 and then Nkind (Parameter_Type (Parent (Entity (L)))) =
6927 N_Access_Definition
6928 and then Nkind (R) = N_Null
6929 then
6930 Error_Msg_N ("access parameter is not allowed to be null", L);
6931 Error_Msg_N ("\(call would raise Constraint_Error)", L);
6932 return;
6933
6934 -- Another special case for exponentiation, where the right
6935 -- operand must be Natural, independently of the base.
6936
6937 elsif Nkind (N) = N_Op_Expon
6938 and then Is_Numeric_Type (Etype (L))
6939 and then not Is_Overloaded (R)
6940 and then
6941 First_Subtype (Base_Type (Etype (R))) /= Standard_Integer
6942 and then Base_Type (Etype (R)) /= Universal_Integer
6943 then
6944 if Ada_Version >= Ada_2012
6945 and then Has_Dimension_System (Etype (L))
6946 then
6947 Error_Msg_NE
6948 ("exponent for dimensioned type must be a rational" &
6949 ", found}", R, Etype (R));
6950 else
6951 Error_Msg_NE
6952 ("exponent must be of type Natural, found}", R, Etype (R));
6953 end if;
6954
6955 return;
6956
6957 elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then
6958 if Address_Integer_Convert_OK (Etype (R), Etype (L)) then
6959 Rewrite (R,
6960 Unchecked_Convert_To (Etype (L), Relocate_Node (R)));
6961 Analyze_Equality_Op (N);
6962 return;
6963
6964 -- Under relaxed RM semantics silently replace occurrences of
6965 -- null by System.Address_Null.
6966
6967 elsif Null_To_Null_Address_Convert_OK (N) then
6968 Replace_Null_By_Null_Address (N);
6969 Analyze_Equality_Op (N);
6970 return;
6971 end if;
6972 end if;
6973
6974 -- If we fall through then just give general message. Note that in
6975 -- the following messages, if the operand is overloaded we choose
6976 -- an arbitrary type to complain about, but that is probably more
6977 -- useful than not giving a type at all.
6978
6979 if Nkind (N) in N_Unary_Op then
6980 Error_Msg_Node_2 := Etype (R);
6981 Error_Msg_N ("operator& not defined for}", N);
6982 return;
6983
6984 else
6985 if Nkind (N) in N_Binary_Op then
6986 if not Is_Overloaded (L)
6987 and then not Is_Overloaded (R)
6988 and then Base_Type (Etype (L)) = Base_Type (Etype (R))
6989 then
6990 Error_Msg_Node_2 := First_Subtype (Etype (R));
6991 Error_Msg_N ("there is no applicable operator& for}", N);
6992
6993 else
6994 -- Another attempt to find a fix: one of the candidate
6995 -- interpretations may not be use-visible. This has
6996 -- already been checked for predefined operators, so
6997 -- we examine only user-defined functions.
6998
6999 Op_Id := Get_Name_Entity_Id (Chars (N));
7000
7001 while Present (Op_Id) loop
7002 if Ekind (Op_Id) /= E_Operator
7003 and then Is_Overloadable (Op_Id)
7004 then
7005 if not Is_Immediately_Visible (Op_Id)
7006 and then not In_Use (Scope (Op_Id))
7007 and then not Is_Abstract_Subprogram (Op_Id)
7008 and then not Is_Hidden (Op_Id)
7009 and then Ekind (Scope (Op_Id)) = E_Package
7010 and then
7011 Has_Compatible_Type
7012 (L, Etype (First_Formal (Op_Id)))
7013 and then Present
7014 (Next_Formal (First_Formal (Op_Id)))
7015 and then
7016 Has_Compatible_Type
7017 (R,
7018 Etype (Next_Formal (First_Formal (Op_Id))))
7019 then
7020 Error_Msg_N
7021 ("No legal interpretation for operator&", N);
7022 Error_Msg_NE
7023 ("\use clause on& would make operation legal",
7024 N, Scope (Op_Id));
7025 exit;
7026 end if;
7027 end if;
7028
7029 Op_Id := Homonym (Op_Id);
7030 end loop;
7031
7032 if No (Op_Id) then
7033 Error_Msg_N ("invalid operand types for operator&", N);
7034
7035 if Nkind (N) /= N_Op_Concat then
7036 Error_Msg_NE ("\left operand has}!", N, Etype (L));
7037 Error_Msg_NE ("\right operand has}!", N, Etype (R));
7038
7039 -- For concatenation operators it is more difficult to
7040 -- determine which is the wrong operand. It is worth
7041 -- flagging explicitly an access type, for those who
7042 -- might think that a dereference happens here.
7043
7044 elsif Is_Access_Type (Etype (L)) then
7045 Error_Msg_N ("\left operand is access type", N);
7046
7047 elsif Is_Access_Type (Etype (R)) then
7048 Error_Msg_N ("\right operand is access type", N);
7049 end if;
7050 end if;
7051 end if;
7052 end if;
7053 end if;
7054 end;
7055 end if;
7056 end Operator_Check;
7057
7058 -----------------------------------------
7059 -- Process_Implicit_Dereference_Prefix --
7060 -----------------------------------------
7061
7062 function Process_Implicit_Dereference_Prefix
7063 (E : Entity_Id;
7064 P : Entity_Id) return Entity_Id
7065 is
7066 Ref : Node_Id;
7067 Typ : constant Entity_Id := Designated_Type (Etype (P));
7068
7069 begin
7070 if Present (E)
7071 and then (Operating_Mode = Check_Semantics or else not Expander_Active)
7072 then
7073 -- We create a dummy reference to E to ensure that the reference is
7074 -- not considered as part of an assignment (an implicit dereference
7075 -- can never assign to its prefix). The Comes_From_Source attribute
7076 -- needs to be propagated for accurate warnings.
7077
7078 Ref := New_Occurrence_Of (E, Sloc (P));
7079 Set_Comes_From_Source (Ref, Comes_From_Source (P));
7080 Generate_Reference (E, Ref);
7081 end if;
7082
7083 -- An implicit dereference is a legal occurrence of an incomplete type
7084 -- imported through a limited_with clause, if the full view is visible.
7085
7086 if From_Limited_With (Typ)
7087 and then not From_Limited_With (Scope (Typ))
7088 and then
7089 (Is_Immediately_Visible (Scope (Typ))
7090 or else
7091 (Is_Child_Unit (Scope (Typ))
7092 and then Is_Visible_Lib_Unit (Scope (Typ))))
7093 then
7094 return Available_View (Typ);
7095 else
7096 return Typ;
7097 end if;
7098 end Process_Implicit_Dereference_Prefix;
7099
7100 --------------------------------
7101 -- Remove_Abstract_Operations --
7102 --------------------------------
7103
7104 procedure Remove_Abstract_Operations (N : Node_Id) is
7105 Abstract_Op : Entity_Id := Empty;
7106 Address_Descendant : Boolean := False;
7107 I : Interp_Index;
7108 It : Interp;
7109
7110 -- AI-310: If overloaded, remove abstract non-dispatching operations. We
7111 -- activate this if either extensions are enabled, or if the abstract
7112 -- operation in question comes from a predefined file. This latter test
7113 -- allows us to use abstract to make operations invisible to users. In
7114 -- particular, if type Address is non-private and abstract subprograms
7115 -- are used to hide its operators, they will be truly hidden.
7116
7117 type Operand_Position is (First_Op, Second_Op);
7118 Univ_Type : constant Entity_Id := Universal_Interpretation (N);
7119
7120 procedure Remove_Address_Interpretations (Op : Operand_Position);
7121 -- Ambiguities may arise when the operands are literal and the address
7122 -- operations in s-auxdec are visible. In that case, remove the
7123 -- interpretation of a literal as Address, to retain the semantics
7124 -- of Address as a private type.
7125
7126 ------------------------------------
7127 -- Remove_Address_Interpretations --
7128 ------------------------------------
7129
7130 procedure Remove_Address_Interpretations (Op : Operand_Position) is
7131 Formal : Entity_Id;
7132
7133 begin
7134 if Is_Overloaded (N) then
7135 Get_First_Interp (N, I, It);
7136 while Present (It.Nam) loop
7137 Formal := First_Entity (It.Nam);
7138
7139 if Op = Second_Op then
7140 Formal := Next_Entity (Formal);
7141 end if;
7142
7143 if Is_Descendant_Of_Address (Etype (Formal)) then
7144 Address_Descendant := True;
7145 Remove_Interp (I);
7146 end if;
7147
7148 Get_Next_Interp (I, It);
7149 end loop;
7150 end if;
7151 end Remove_Address_Interpretations;
7152
7153 -- Start of processing for Remove_Abstract_Operations
7154
7155 begin
7156 if Is_Overloaded (N) then
7157 if Debug_Flag_V then
7158 Write_Str ("Remove_Abstract_Operations: ");
7159 Write_Overloads (N);
7160 end if;
7161
7162 Get_First_Interp (N, I, It);
7163
7164 while Present (It.Nam) loop
7165 if Is_Overloadable (It.Nam)
7166 and then Is_Abstract_Subprogram (It.Nam)
7167 and then not Is_Dispatching_Operation (It.Nam)
7168 then
7169 Abstract_Op := It.Nam;
7170
7171 if Is_Descendant_Of_Address (It.Typ) then
7172 Address_Descendant := True;
7173 Remove_Interp (I);
7174 exit;
7175
7176 -- In Ada 2005, this operation does not participate in overload
7177 -- resolution. If the operation is defined in a predefined
7178 -- unit, it is one of the operations declared abstract in some
7179 -- variants of System, and it must be removed as well.
7180
7181 elsif Ada_Version >= Ada_2005
7182 or else Is_Predefined_File_Name
7183 (Unit_File_Name (Get_Source_Unit (It.Nam)))
7184 then
7185 Remove_Interp (I);
7186 exit;
7187 end if;
7188 end if;
7189
7190 Get_Next_Interp (I, It);
7191 end loop;
7192
7193 if No (Abstract_Op) then
7194
7195 -- If some interpretation yields an integer type, it is still
7196 -- possible that there are address interpretations. Remove them
7197 -- if one operand is a literal, to avoid spurious ambiguities
7198 -- on systems where Address is a visible integer type.
7199
7200 if Is_Overloaded (N)
7201 and then Nkind (N) in N_Op
7202 and then Is_Integer_Type (Etype (N))
7203 then
7204 if Nkind (N) in N_Binary_Op then
7205 if Nkind (Right_Opnd (N)) = N_Integer_Literal then
7206 Remove_Address_Interpretations (Second_Op);
7207
7208 elsif Nkind (Right_Opnd (N)) = N_Integer_Literal then
7209 Remove_Address_Interpretations (First_Op);
7210 end if;
7211 end if;
7212 end if;
7213
7214 elsif Nkind (N) in N_Op then
7215
7216 -- Remove interpretations that treat literals as addresses. This
7217 -- is never appropriate, even when Address is defined as a visible
7218 -- Integer type. The reason is that we would really prefer Address
7219 -- to behave as a private type, even in this case. If Address is a
7220 -- visible integer type, we get lots of overload ambiguities.
7221
7222 if Nkind (N) in N_Binary_Op then
7223 declare
7224 U1 : constant Boolean :=
7225 Present (Universal_Interpretation (Right_Opnd (N)));
7226 U2 : constant Boolean :=
7227 Present (Universal_Interpretation (Left_Opnd (N)));
7228
7229 begin
7230 if U1 then
7231 Remove_Address_Interpretations (Second_Op);
7232 end if;
7233
7234 if U2 then
7235 Remove_Address_Interpretations (First_Op);
7236 end if;
7237
7238 if not (U1 and U2) then
7239
7240 -- Remove corresponding predefined operator, which is
7241 -- always added to the overload set.
7242
7243 Get_First_Interp (N, I, It);
7244 while Present (It.Nam) loop
7245 if Scope (It.Nam) = Standard_Standard
7246 and then Base_Type (It.Typ) =
7247 Base_Type (Etype (Abstract_Op))
7248 then
7249 Remove_Interp (I);
7250 end if;
7251
7252 Get_Next_Interp (I, It);
7253 end loop;
7254
7255 elsif Is_Overloaded (N)
7256 and then Present (Univ_Type)
7257 then
7258 -- If both operands have a universal interpretation,
7259 -- it is still necessary to remove interpretations that
7260 -- yield Address. Any remaining ambiguities will be
7261 -- removed in Disambiguate.
7262
7263 Get_First_Interp (N, I, It);
7264 while Present (It.Nam) loop
7265 if Is_Descendant_Of_Address (It.Typ) then
7266 Remove_Interp (I);
7267
7268 elsif not Is_Type (It.Nam) then
7269 Set_Entity (N, It.Nam);
7270 end if;
7271
7272 Get_Next_Interp (I, It);
7273 end loop;
7274 end if;
7275 end;
7276 end if;
7277
7278 elsif Nkind (N) = N_Function_Call
7279 and then
7280 (Nkind (Name (N)) = N_Operator_Symbol
7281 or else
7282 (Nkind (Name (N)) = N_Expanded_Name
7283 and then
7284 Nkind (Selector_Name (Name (N))) = N_Operator_Symbol))
7285 then
7286
7287 declare
7288 Arg1 : constant Node_Id := First (Parameter_Associations (N));
7289 U1 : constant Boolean :=
7290 Present (Universal_Interpretation (Arg1));
7291 U2 : constant Boolean :=
7292 Present (Next (Arg1)) and then
7293 Present (Universal_Interpretation (Next (Arg1)));
7294
7295 begin
7296 if U1 then
7297 Remove_Address_Interpretations (First_Op);
7298 end if;
7299
7300 if U2 then
7301 Remove_Address_Interpretations (Second_Op);
7302 end if;
7303
7304 if not (U1 and U2) then
7305 Get_First_Interp (N, I, It);
7306 while Present (It.Nam) loop
7307 if Scope (It.Nam) = Standard_Standard
7308 and then It.Typ = Base_Type (Etype (Abstract_Op))
7309 then
7310 Remove_Interp (I);
7311 end if;
7312
7313 Get_Next_Interp (I, It);
7314 end loop;
7315 end if;
7316 end;
7317 end if;
7318
7319 -- If the removal has left no valid interpretations, emit an error
7320 -- message now and label node as illegal.
7321
7322 if Present (Abstract_Op) then
7323 Get_First_Interp (N, I, It);
7324
7325 if No (It.Nam) then
7326
7327 -- Removal of abstract operation left no viable candidate
7328
7329 Set_Etype (N, Any_Type);
7330 Error_Msg_Sloc := Sloc (Abstract_Op);
7331 Error_Msg_NE
7332 ("cannot call abstract operation& declared#", N, Abstract_Op);
7333
7334 -- In Ada 2005, an abstract operation may disable predefined
7335 -- operators. Since the context is not yet known, we mark the
7336 -- predefined operators as potentially hidden. Do not include
7337 -- predefined operators when addresses are involved since this
7338 -- case is handled separately.
7339
7340 elsif Ada_Version >= Ada_2005 and then not Address_Descendant then
7341 while Present (It.Nam) loop
7342 if Is_Numeric_Type (It.Typ)
7343 and then Scope (It.Typ) = Standard_Standard
7344 then
7345 Set_Abstract_Op (I, Abstract_Op);
7346 end if;
7347
7348 Get_Next_Interp (I, It);
7349 end loop;
7350 end if;
7351 end if;
7352
7353 if Debug_Flag_V then
7354 Write_Str ("Remove_Abstract_Operations done: ");
7355 Write_Overloads (N);
7356 end if;
7357 end if;
7358 end Remove_Abstract_Operations;
7359
7360 ----------------------------
7361 -- Try_Container_Indexing --
7362 ----------------------------
7363
7364 function Try_Container_Indexing
7365 (N : Node_Id;
7366 Prefix : Node_Id;
7367 Exprs : List_Id) return Boolean
7368 is
7369 Pref_Typ : constant Entity_Id := Etype (Prefix);
7370
7371 function Constant_Indexing_OK return Boolean;
7372 -- Constant_Indexing is legal if there is no Variable_Indexing defined
7373 -- for the type, or else node not a target of assignment, or an actual
7374 -- for an IN OUT or OUT formal (RM 4.1.6 (11)).
7375
7376 function Find_Indexing_Operations
7377 (T : Entity_Id;
7378 Nam : Name_Id;
7379 Is_Constant : Boolean) return Node_Id;
7380 -- Return a reference to the primitive operation of type T denoted by
7381 -- name Nam. If the operation is overloaded, the reference carries all
7382 -- interpretations. Flag Is_Constant should be set when the context is
7383 -- constant indexing.
7384
7385 --------------------------
7386 -- Constant_Indexing_OK --
7387 --------------------------
7388
7389 function Constant_Indexing_OK return Boolean is
7390 Par : Node_Id;
7391
7392 begin
7393 if No (Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing)) then
7394 return True;
7395
7396 elsif not Is_Variable (Prefix) then
7397 return True;
7398 end if;
7399
7400 Par := N;
7401 while Present (Par) loop
7402 if Nkind (Parent (Par)) = N_Assignment_Statement
7403 and then Par = Name (Parent (Par))
7404 then
7405 return False;
7406
7407 -- The call may be overloaded, in which case we assume that its
7408 -- resolution does not depend on the type of the parameter that
7409 -- includes the indexing operation.
7410
7411 elsif Nkind_In (Parent (Par), N_Function_Call,
7412 N_Procedure_Call_Statement)
7413 and then Is_Entity_Name (Name (Parent (Par)))
7414 then
7415 declare
7416 Actual : Node_Id;
7417 Formal : Entity_Id;
7418 Proc : Entity_Id;
7419
7420 begin
7421 -- We should look for an interpretation with the proper
7422 -- number of formals, and determine whether it is an
7423 -- In_Parameter, but for now we examine the formal that
7424 -- corresponds to the indexing, and assume that variable
7425 -- indexing is required if some interpretation has an
7426 -- assignable formal at that position. Still does not
7427 -- cover the most complex cases ???
7428
7429 if Is_Overloaded (Name (Parent (Par))) then
7430 declare
7431 Proc : constant Node_Id := Name (Parent (Par));
7432 A : Node_Id;
7433 F : Entity_Id;
7434 I : Interp_Index;
7435 It : Interp;
7436
7437 begin
7438 Get_First_Interp (Proc, I, It);
7439 while Present (It.Nam) loop
7440 F := First_Formal (It.Nam);
7441 A := First (Parameter_Associations (Parent (Par)));
7442
7443 while Present (F) and then Present (A) loop
7444 if A = Par then
7445 if Ekind (F) /= E_In_Parameter then
7446 return False;
7447 else
7448 exit; -- interpretation is safe
7449 end if;
7450 end if;
7451
7452 Next_Formal (F);
7453 Next_Actual (A);
7454 end loop;
7455
7456 Get_Next_Interp (I, It);
7457 end loop;
7458 end;
7459
7460 return True;
7461
7462 else
7463 Proc := Entity (Name (Parent (Par)));
7464
7465 -- If this is an indirect call, get formals from
7466 -- designated type.
7467
7468 if Is_Access_Subprogram_Type (Etype (Proc)) then
7469 Proc := Designated_Type (Etype (Proc));
7470 end if;
7471 end if;
7472
7473 Formal := First_Formal (Proc);
7474 Actual := First_Actual (Parent (Par));
7475
7476 -- Find corresponding actual
7477
7478 while Present (Actual) loop
7479 exit when Actual = Par;
7480 Next_Actual (Actual);
7481
7482 if Present (Formal) then
7483 Next_Formal (Formal);
7484
7485 -- Otherwise this is a parameter mismatch, the error is
7486 -- reported elsewhere.
7487
7488 else
7489 return False;
7490 end if;
7491 end loop;
7492
7493 return Ekind (Formal) = E_In_Parameter;
7494 end;
7495
7496 elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then
7497 return False;
7498
7499 -- If the indexed component is a prefix it may be the first actual
7500 -- of a prefixed call. Retrieve the called entity, if any, and
7501 -- check its first formal. Determine if the context is a procedure
7502 -- or function call.
7503
7504 elsif Nkind (Parent (Par)) = N_Selected_Component then
7505 declare
7506 Sel : constant Node_Id := Selector_Name (Parent (Par));
7507 Nam : constant Entity_Id := Current_Entity (Sel);
7508
7509 begin
7510 if Present (Nam) and then Is_Overloadable (Nam) then
7511 if Nkind (Parent (Parent (Par))) =
7512 N_Procedure_Call_Statement
7513 then
7514 return False;
7515
7516 elsif Ekind (Nam) = E_Function
7517 and then Present (First_Formal (Nam))
7518 then
7519 return Ekind (First_Formal (Nam)) = E_In_Parameter;
7520 end if;
7521 end if;
7522 end;
7523
7524 elsif Nkind (Par) in N_Op then
7525 return True;
7526 end if;
7527
7528 Par := Parent (Par);
7529 end loop;
7530
7531 -- In all other cases, constant indexing is legal
7532
7533 return True;
7534 end Constant_Indexing_OK;
7535
7536 ------------------------------
7537 -- Find_Indexing_Operations --
7538 ------------------------------
7539
7540 function Find_Indexing_Operations
7541 (T : Entity_Id;
7542 Nam : Name_Id;
7543 Is_Constant : Boolean) return Node_Id
7544 is
7545 procedure Inspect_Declarations
7546 (Typ : Entity_Id;
7547 Ref : in out Node_Id);
7548 -- Traverse the declarative list where type Typ resides and collect
7549 -- all suitable interpretations in node Ref.
7550
7551 procedure Inspect_Primitives
7552 (Typ : Entity_Id;
7553 Ref : in out Node_Id);
7554 -- Traverse the list of primitive operations of type Typ and collect
7555 -- all suitable interpretations in node Ref.
7556
7557 function Is_OK_Candidate
7558 (Subp_Id : Entity_Id;
7559 Typ : Entity_Id) return Boolean;
7560 -- Determine whether subprogram Subp_Id is a suitable indexing
7561 -- operation for type Typ. To qualify as such, the subprogram must
7562 -- be a function, have at least two parameters, and the type of the
7563 -- first parameter must be either Typ, or Typ'Class, or access [to
7564 -- constant] with designated type Typ or Typ'Class.
7565
7566 procedure Record_Interp (Subp_Id : Entity_Id; Ref : in out Node_Id);
7567 -- Store subprogram Subp_Id as an interpretation in node Ref
7568
7569 --------------------------
7570 -- Inspect_Declarations --
7571 --------------------------
7572
7573 procedure Inspect_Declarations
7574 (Typ : Entity_Id;
7575 Ref : in out Node_Id)
7576 is
7577 Typ_Decl : constant Node_Id := Declaration_Node (Typ);
7578 Decl : Node_Id;
7579 Subp_Id : Entity_Id;
7580
7581 begin
7582 -- Ensure that the routine is not called with itypes, which lack a
7583 -- declarative node.
7584
7585 pragma Assert (Present (Typ_Decl));
7586 pragma Assert (Is_List_Member (Typ_Decl));
7587
7588 Decl := First (List_Containing (Typ_Decl));
7589 while Present (Decl) loop
7590 if Nkind (Decl) = N_Subprogram_Declaration then
7591 Subp_Id := Defining_Entity (Decl);
7592
7593 if Is_OK_Candidate (Subp_Id, Typ) then
7594 Record_Interp (Subp_Id, Ref);
7595 end if;
7596 end if;
7597
7598 Next (Decl);
7599 end loop;
7600 end Inspect_Declarations;
7601
7602 ------------------------
7603 -- Inspect_Primitives --
7604 ------------------------
7605
7606 procedure Inspect_Primitives
7607 (Typ : Entity_Id;
7608 Ref : in out Node_Id)
7609 is
7610 Prim_Elmt : Elmt_Id;
7611 Prim_Id : Entity_Id;
7612
7613 begin
7614 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
7615 while Present (Prim_Elmt) loop
7616 Prim_Id := Node (Prim_Elmt);
7617
7618 if Is_OK_Candidate (Prim_Id, Typ) then
7619 Record_Interp (Prim_Id, Ref);
7620 end if;
7621
7622 Next_Elmt (Prim_Elmt);
7623 end loop;
7624 end Inspect_Primitives;
7625
7626 ---------------------
7627 -- Is_OK_Candidate --
7628 ---------------------
7629
7630 function Is_OK_Candidate
7631 (Subp_Id : Entity_Id;
7632 Typ : Entity_Id) return Boolean
7633 is
7634 Formal : Entity_Id;
7635 Formal_Typ : Entity_Id;
7636 Param_Typ : Node_Id;
7637
7638 begin
7639 -- To classify as a suitable candidate, the subprogram must be a
7640 -- function whose name matches the argument of aspect Constant or
7641 -- Variable_Indexing.
7642
7643 if Ekind (Subp_Id) = E_Function and then Chars (Subp_Id) = Nam then
7644 Formal := First_Formal (Subp_Id);
7645
7646 -- The candidate requires at least two parameters
7647
7648 if Present (Formal) and then Present (Next_Formal (Formal)) then
7649 Formal_Typ := Empty;
7650 Param_Typ := Parameter_Type (Parent (Formal));
7651
7652 -- Use the designated type when the first parameter is of an
7653 -- access type.
7654
7655 if Nkind (Param_Typ) = N_Access_Definition
7656 and then Present (Subtype_Mark (Param_Typ))
7657 then
7658 -- When the context is a constant indexing, the access
7659 -- definition must be access-to-constant. This does not
7660 -- apply to variable indexing.
7661
7662 if not Is_Constant
7663 or else Constant_Present (Param_Typ)
7664 then
7665 Formal_Typ := Etype (Subtype_Mark (Param_Typ));
7666 end if;
7667
7668 -- Otherwise use the parameter type
7669
7670 else
7671 Formal_Typ := Etype (Param_Typ);
7672 end if;
7673
7674 if Present (Formal_Typ) then
7675
7676 -- Use the specific type when the parameter type is
7677 -- class-wide.
7678
7679 if Is_Class_Wide_Type (Formal_Typ) then
7680 Formal_Typ := Etype (Base_Type (Formal_Typ));
7681 end if;
7682
7683 -- Use the full view when the parameter type is private
7684 -- or incomplete.
7685
7686 if Is_Incomplete_Or_Private_Type (Formal_Typ)
7687 and then Present (Full_View (Formal_Typ))
7688 then
7689 Formal_Typ := Full_View (Formal_Typ);
7690 end if;
7691
7692 -- The type of the first parameter must denote the type
7693 -- of the container or acts as its ancestor type.
7694
7695 return
7696 Formal_Typ = Typ
7697 or else Is_Ancestor (Formal_Typ, Typ);
7698 end if;
7699 end if;
7700 end if;
7701
7702 return False;
7703 end Is_OK_Candidate;
7704
7705 -------------------
7706 -- Record_Interp --
7707 -------------------
7708
7709 procedure Record_Interp (Subp_Id : Entity_Id; Ref : in out Node_Id) is
7710 begin
7711 if Present (Ref) then
7712 Add_One_Interp (Ref, Subp_Id, Etype (Subp_Id));
7713
7714 -- Otherwise this is the first interpretation. Create a reference
7715 -- where all remaining interpretations will be collected.
7716
7717 else
7718 Ref := New_Occurrence_Of (Subp_Id, Sloc (T));
7719 end if;
7720 end Record_Interp;
7721
7722 -- Local variables
7723
7724 Ref : Node_Id;
7725 Typ : Entity_Id;
7726
7727 -- Start of processing for Find_Indexing_Operations
7728
7729 begin
7730 Typ := T;
7731
7732 -- Use the specific type when the parameter type is class-wide
7733
7734 if Is_Class_Wide_Type (Typ) then
7735 Typ := Root_Type (Typ);
7736 end if;
7737
7738 Ref := Empty;
7739 Typ := Underlying_Type (Base_Type (Typ));
7740
7741 Inspect_Primitives (Typ, Ref);
7742 Inspect_Declarations (Typ, Ref);
7743
7744 return Ref;
7745 end Find_Indexing_Operations;
7746
7747 -- Local variables
7748
7749 Loc : constant Source_Ptr := Sloc (N);
7750 Assoc : List_Id;
7751 C_Type : Entity_Id;
7752 Func : Entity_Id;
7753 Func_Name : Node_Id;
7754 Indexing : Node_Id;
7755
7756 Is_Constant_Indexing : Boolean := False;
7757 -- This flag reflects the nature of the container indexing. Note that
7758 -- the context may be suited for constant indexing, but the type may
7759 -- lack a Constant_Indexing annotation.
7760
7761 -- Start of processing for Try_Container_Indexing
7762
7763 begin
7764 -- Node may have been analyzed already when testing for a prefixed
7765 -- call, in which case do not redo analysis.
7766
7767 if Present (Generalized_Indexing (N)) then
7768 return True;
7769 end if;
7770
7771 C_Type := Pref_Typ;
7772
7773 -- If indexing a class-wide container, obtain indexing primitive from
7774 -- specific type.
7775
7776 if Is_Class_Wide_Type (C_Type) then
7777 C_Type := Etype (Base_Type (C_Type));
7778 end if;
7779
7780 -- Check whether the type has a specified indexing aspect
7781
7782 Func_Name := Empty;
7783
7784 -- The context is suitable for constant indexing, so obtain the name of
7785 -- the indexing function from aspect Constant_Indexing.
7786
7787 if Constant_Indexing_OK then
7788 Func_Name :=
7789 Find_Value_Of_Aspect (Pref_Typ, Aspect_Constant_Indexing);
7790 end if;
7791
7792 if Present (Func_Name) then
7793 Is_Constant_Indexing := True;
7794
7795 -- Otherwise attempt variable indexing
7796
7797 else
7798 Func_Name :=
7799 Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing);
7800 end if;
7801
7802 -- The type is not subject to either form of indexing, therefore the
7803 -- indexed component does not denote container indexing. If this is a
7804 -- true error, it is diagnosed by the caller.
7805
7806 if No (Func_Name) then
7807
7808 -- The prefix itself may be an indexing of a container. Rewrite it
7809 -- as such and retry.
7810
7811 if Has_Implicit_Dereference (Pref_Typ) then
7812 Build_Explicit_Dereference (Prefix, First_Discriminant (Pref_Typ));
7813 return Try_Container_Indexing (N, Prefix, Exprs);
7814
7815 -- Otherwise this is definitely not container indexing
7816
7817 else
7818 return False;
7819 end if;
7820
7821 -- If the container type is derived from another container type, the
7822 -- value of the inherited aspect is the Reference operation declared
7823 -- for the parent type.
7824
7825 -- However, Reference is also a primitive operation of the type, and the
7826 -- inherited operation has a different signature. We retrieve the right
7827 -- ones (the function may be overloaded) from the list of primitive
7828 -- operations of the derived type.
7829
7830 -- Note that predefined containers are typically all derived from one of
7831 -- the Controlled types. The code below is motivated by containers that
7832 -- are derived from other types with a Reference aspect.
7833
7834 elsif Is_Derived_Type (C_Type)
7835 and then Etype (First_Formal (Entity (Func_Name))) /= Pref_Typ
7836 then
7837 Func_Name :=
7838 Find_Indexing_Operations
7839 (T => C_Type,
7840 Nam => Chars (Func_Name),
7841 Is_Constant => Is_Constant_Indexing);
7842 end if;
7843
7844 Assoc := New_List (Relocate_Node (Prefix));
7845
7846 -- A generalized indexing may have nore than one index expression, so
7847 -- transfer all of them to the argument list to be used in the call.
7848 -- Note that there may be named associations, in which case the node
7849 -- was rewritten earlier as a call, and has been transformed back into
7850 -- an indexed expression to share the following processing.
7851
7852 -- The generalized indexing node is the one on which analysis and
7853 -- resolution take place. Before expansion the original node is replaced
7854 -- with the generalized indexing node, which is a call, possibly with a
7855 -- dereference operation.
7856
7857 if Comes_From_Source (N) then
7858 Check_Compiler_Unit ("generalized indexing", N);
7859 end if;
7860
7861 -- Create argument list for function call that represents generalized
7862 -- indexing. Note that indices (i.e. actuals) may themselves be
7863 -- overloaded.
7864
7865 declare
7866 Arg : Node_Id;
7867 New_Arg : Node_Id;
7868
7869 begin
7870 Arg := First (Exprs);
7871 while Present (Arg) loop
7872 New_Arg := Relocate_Node (Arg);
7873
7874 -- The arguments can be parameter associations, in which case the
7875 -- explicit actual parameter carries the overloadings.
7876
7877 if Nkind (New_Arg) /= N_Parameter_Association then
7878 Save_Interps (Arg, New_Arg);
7879 end if;
7880
7881 Append (New_Arg, Assoc);
7882 Next (Arg);
7883 end loop;
7884 end;
7885
7886 if not Is_Overloaded (Func_Name) then
7887 Func := Entity (Func_Name);
7888 Indexing :=
7889 Make_Function_Call (Loc,
7890 Name => New_Occurrence_Of (Func, Loc),
7891 Parameter_Associations => Assoc);
7892 Set_Parent (Indexing, Parent (N));
7893 Set_Generalized_Indexing (N, Indexing);
7894 Analyze (Indexing);
7895 Set_Etype (N, Etype (Indexing));
7896
7897 -- If the return type of the indexing function is a reference type,
7898 -- add the dereference as a possible interpretation. Note that the
7899 -- indexing aspect may be a function that returns the element type
7900 -- with no intervening implicit dereference, and that the reference
7901 -- discriminant is not the first discriminant.
7902
7903 if Has_Discriminants (Etype (Func)) then
7904 Check_Implicit_Dereference (N, Etype (Func));
7905 end if;
7906
7907 else
7908 -- If there are multiple indexing functions, build a function call
7909 -- and analyze it for each of the possible interpretations.
7910
7911 Indexing :=
7912 Make_Function_Call (Loc,
7913 Name =>
7914 Make_Identifier (Loc, Chars (Func_Name)),
7915 Parameter_Associations => Assoc);
7916
7917 Set_Parent (Indexing, Parent (N));
7918 Set_Generalized_Indexing (N, Indexing);
7919 Set_Etype (N, Any_Type);
7920 Set_Etype (Name (Indexing), Any_Type);
7921
7922 declare
7923 I : Interp_Index;
7924 It : Interp;
7925 Success : Boolean;
7926
7927 begin
7928 Get_First_Interp (Func_Name, I, It);
7929 Set_Etype (Indexing, Any_Type);
7930
7931 -- Analyze eacn candidae function with the given actuals
7932
7933 while Present (It.Nam) loop
7934 Analyze_One_Call (Indexing, It.Nam, False, Success);
7935 Get_Next_Interp (I, It);
7936 end loop;
7937
7938 -- If there are several successful candidates, resolution will
7939 -- be by result. Mark the interpretations of the function name
7940 -- itself.
7941
7942 if Is_Overloaded (Indexing) then
7943 Get_First_Interp (Indexing, I, It);
7944
7945 while Present (It.Nam) loop
7946 Add_One_Interp (Name (Indexing), It.Nam, It.Typ);
7947 Get_Next_Interp (I, It);
7948 end loop;
7949
7950 else
7951 Set_Etype (Name (Indexing), Etype (Indexing));
7952 end if;
7953
7954 -- Now add the candidate interpretations to the indexing node
7955 -- itself, to be replaced later by the function call.
7956
7957 if Is_Overloaded (Name (Indexing)) then
7958 Get_First_Interp (Name (Indexing), I, It);
7959
7960 while Present (It.Nam) loop
7961 Add_One_Interp (N, It.Nam, It.Typ);
7962
7963 -- Add dereference interpretation if the result type has
7964 -- implicit reference discriminants.
7965
7966 if Has_Discriminants (Etype (It.Nam)) then
7967 Check_Implicit_Dereference (N, Etype (It.Nam));
7968 end if;
7969
7970 Get_Next_Interp (I, It);
7971 end loop;
7972
7973 else
7974 Set_Etype (N, Etype (Name (Indexing)));
7975 if Has_Discriminants (Etype (N)) then
7976 Check_Implicit_Dereference (N, Etype (N));
7977 end if;
7978 end if;
7979 end;
7980 end if;
7981
7982 if Etype (Indexing) = Any_Type then
7983 Error_Msg_NE
7984 ("container cannot be indexed with&", N, Etype (First (Exprs)));
7985 Rewrite (N, New_Occurrence_Of (Any_Id, Loc));
7986 end if;
7987
7988 return True;
7989 end Try_Container_Indexing;
7990
7991 -----------------------
7992 -- Try_Indirect_Call --
7993 -----------------------
7994
7995 function Try_Indirect_Call
7996 (N : Node_Id;
7997 Nam : Entity_Id;
7998 Typ : Entity_Id) return Boolean
7999 is
8000 Actual : Node_Id;
8001 Formal : Entity_Id;
8002
8003 Call_OK : Boolean;
8004 pragma Warnings (Off, Call_OK);
8005
8006 begin
8007 Normalize_Actuals (N, Designated_Type (Typ), False, Call_OK);
8008
8009 Actual := First_Actual (N);
8010 Formal := First_Formal (Designated_Type (Typ));
8011 while Present (Actual) and then Present (Formal) loop
8012 if not Has_Compatible_Type (Actual, Etype (Formal)) then
8013 return False;
8014 end if;
8015
8016 Next (Actual);
8017 Next_Formal (Formal);
8018 end loop;
8019
8020 if No (Actual) and then No (Formal) then
8021 Add_One_Interp (N, Nam, Etype (Designated_Type (Typ)));
8022
8023 -- Nam is a candidate interpretation for the name in the call,
8024 -- if it is not an indirect call.
8025
8026 if not Is_Type (Nam)
8027 and then Is_Entity_Name (Name (N))
8028 then
8029 Set_Entity (Name (N), Nam);
8030 end if;
8031
8032 return True;
8033
8034 else
8035 return False;
8036 end if;
8037 end Try_Indirect_Call;
8038
8039 ----------------------
8040 -- Try_Indexed_Call --
8041 ----------------------
8042
8043 function Try_Indexed_Call
8044 (N : Node_Id;
8045 Nam : Entity_Id;
8046 Typ : Entity_Id;
8047 Skip_First : Boolean) return Boolean
8048 is
8049 Loc : constant Source_Ptr := Sloc (N);
8050 Actuals : constant List_Id := Parameter_Associations (N);
8051 Actual : Node_Id;
8052 Index : Entity_Id;
8053
8054 begin
8055 Actual := First (Actuals);
8056
8057 -- If the call was originally written in prefix form, skip the first
8058 -- actual, which is obviously not defaulted.
8059
8060 if Skip_First then
8061 Next (Actual);
8062 end if;
8063
8064 Index := First_Index (Typ);
8065 while Present (Actual) and then Present (Index) loop
8066
8067 -- If the parameter list has a named association, the expression
8068 -- is definitely a call and not an indexed component.
8069
8070 if Nkind (Actual) = N_Parameter_Association then
8071 return False;
8072 end if;
8073
8074 if Is_Entity_Name (Actual)
8075 and then Is_Type (Entity (Actual))
8076 and then No (Next (Actual))
8077 then
8078 -- A single actual that is a type name indicates a slice if the
8079 -- type is discrete, and an error otherwise.
8080
8081 if Is_Discrete_Type (Entity (Actual)) then
8082 Rewrite (N,
8083 Make_Slice (Loc,
8084 Prefix =>
8085 Make_Function_Call (Loc,
8086 Name => Relocate_Node (Name (N))),
8087 Discrete_Range =>
8088 New_Occurrence_Of (Entity (Actual), Sloc (Actual))));
8089
8090 Analyze (N);
8091
8092 else
8093 Error_Msg_N ("invalid use of type in expression", Actual);
8094 Set_Etype (N, Any_Type);
8095 end if;
8096
8097 return True;
8098
8099 elsif not Has_Compatible_Type (Actual, Etype (Index)) then
8100 return False;
8101 end if;
8102
8103 Next (Actual);
8104 Next_Index (Index);
8105 end loop;
8106
8107 if No (Actual) and then No (Index) then
8108 Add_One_Interp (N, Nam, Component_Type (Typ));
8109
8110 -- Nam is a candidate interpretation for the name in the call,
8111 -- if it is not an indirect call.
8112
8113 if not Is_Type (Nam)
8114 and then Is_Entity_Name (Name (N))
8115 then
8116 Set_Entity (Name (N), Nam);
8117 end if;
8118
8119 return True;
8120 else
8121 return False;
8122 end if;
8123 end Try_Indexed_Call;
8124
8125 --------------------------
8126 -- Try_Object_Operation --
8127 --------------------------
8128
8129 function Try_Object_Operation
8130 (N : Node_Id; CW_Test_Only : Boolean := False) return Boolean
8131 is
8132 K : constant Node_Kind := Nkind (Parent (N));
8133 Is_Subprg_Call : constant Boolean := K in N_Subprogram_Call;
8134 Loc : constant Source_Ptr := Sloc (N);
8135 Obj : constant Node_Id := Prefix (N);
8136
8137 Subprog : constant Node_Id :=
8138 Make_Identifier (Sloc (Selector_Name (N)),
8139 Chars => Chars (Selector_Name (N)));
8140 -- Identifier on which possible interpretations will be collected
8141
8142 Report_Error : Boolean := False;
8143 -- If no candidate interpretation matches the context, redo analysis
8144 -- with Report_Error True to provide additional information.
8145
8146 Actual : Node_Id;
8147 Candidate : Entity_Id := Empty;
8148 New_Call_Node : Node_Id := Empty;
8149 Node_To_Replace : Node_Id;
8150 Obj_Type : Entity_Id := Etype (Obj);
8151 Success : Boolean := False;
8152
8153 function Valid_Candidate
8154 (Success : Boolean;
8155 Call : Node_Id;
8156 Subp : Entity_Id) return Entity_Id;
8157 -- If the subprogram is a valid interpretation, record it, and add
8158 -- to the list of interpretations of Subprog. Otherwise return Empty.
8159
8160 procedure Complete_Object_Operation
8161 (Call_Node : Node_Id;
8162 Node_To_Replace : Node_Id);
8163 -- Make Subprog the name of Call_Node, replace Node_To_Replace with
8164 -- Call_Node, insert the object (or its dereference) as the first actual
8165 -- in the call, and complete the analysis of the call.
8166
8167 procedure Report_Ambiguity (Op : Entity_Id);
8168 -- If a prefixed procedure call is ambiguous, indicate whether the
8169 -- call includes an implicit dereference or an implicit 'Access.
8170
8171 procedure Transform_Object_Operation
8172 (Call_Node : out Node_Id;
8173 Node_To_Replace : out Node_Id);
8174 -- Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..)
8175 -- Call_Node is the resulting subprogram call, Node_To_Replace is
8176 -- either N or the parent of N, and Subprog is a reference to the
8177 -- subprogram we are trying to match.
8178
8179 function Try_Class_Wide_Operation
8180 (Call_Node : Node_Id;
8181 Node_To_Replace : Node_Id) return Boolean;
8182 -- Traverse all ancestor types looking for a class-wide subprogram
8183 -- for which the current operation is a valid non-dispatching call.
8184
8185 procedure Try_One_Prefix_Interpretation (T : Entity_Id);
8186 -- If prefix is overloaded, its interpretation may include different
8187 -- tagged types, and we must examine the primitive operations and
8188 -- the class-wide operations of each in order to find candidate
8189 -- interpretations for the call as a whole.
8190
8191 function Try_Primitive_Operation
8192 (Call_Node : Node_Id;
8193 Node_To_Replace : Node_Id) return Boolean;
8194 -- Traverse the list of primitive subprograms looking for a dispatching
8195 -- operation for which the current node is a valid call .
8196
8197 ---------------------
8198 -- Valid_Candidate --
8199 ---------------------
8200
8201 function Valid_Candidate
8202 (Success : Boolean;
8203 Call : Node_Id;
8204 Subp : Entity_Id) return Entity_Id
8205 is
8206 Arr_Type : Entity_Id;
8207 Comp_Type : Entity_Id;
8208
8209 begin
8210 -- If the subprogram is a valid interpretation, record it in global
8211 -- variable Subprog, to collect all possible overloadings.
8212
8213 if Success then
8214 if Subp /= Entity (Subprog) then
8215 Add_One_Interp (Subprog, Subp, Etype (Subp));
8216 end if;
8217 end if;
8218
8219 -- If the call may be an indexed call, retrieve component type of
8220 -- resulting expression, and add possible interpretation.
8221
8222 Arr_Type := Empty;
8223 Comp_Type := Empty;
8224
8225 if Nkind (Call) = N_Function_Call
8226 and then Nkind (Parent (N)) = N_Indexed_Component
8227 and then Needs_One_Actual (Subp)
8228 then
8229 if Is_Array_Type (Etype (Subp)) then
8230 Arr_Type := Etype (Subp);
8231
8232 elsif Is_Access_Type (Etype (Subp))
8233 and then Is_Array_Type (Designated_Type (Etype (Subp)))
8234 then
8235 Arr_Type := Designated_Type (Etype (Subp));
8236 end if;
8237 end if;
8238
8239 if Present (Arr_Type) then
8240
8241 -- Verify that the actuals (excluding the object) match the types
8242 -- of the indexes.
8243
8244 declare
8245 Actual : Node_Id;
8246 Index : Node_Id;
8247
8248 begin
8249 Actual := Next (First_Actual (Call));
8250 Index := First_Index (Arr_Type);
8251 while Present (Actual) and then Present (Index) loop
8252 if not Has_Compatible_Type (Actual, Etype (Index)) then
8253 Arr_Type := Empty;
8254 exit;
8255 end if;
8256
8257 Next_Actual (Actual);
8258 Next_Index (Index);
8259 end loop;
8260
8261 if No (Actual)
8262 and then No (Index)
8263 and then Present (Arr_Type)
8264 then
8265 Comp_Type := Component_Type (Arr_Type);
8266 end if;
8267 end;
8268
8269 if Present (Comp_Type)
8270 and then Etype (Subprog) /= Comp_Type
8271 then
8272 Add_One_Interp (Subprog, Subp, Comp_Type);
8273 end if;
8274 end if;
8275
8276 if Etype (Call) /= Any_Type then
8277 return Subp;
8278 else
8279 return Empty;
8280 end if;
8281 end Valid_Candidate;
8282
8283 -------------------------------
8284 -- Complete_Object_Operation --
8285 -------------------------------
8286
8287 procedure Complete_Object_Operation
8288 (Call_Node : Node_Id;
8289 Node_To_Replace : Node_Id)
8290 is
8291 Control : constant Entity_Id := First_Formal (Entity (Subprog));
8292 Formal_Type : constant Entity_Id := Etype (Control);
8293 First_Actual : Node_Id;
8294
8295 begin
8296 -- Place the name of the operation, with its interpretations,
8297 -- on the rewritten call.
8298
8299 Set_Name (Call_Node, Subprog);
8300
8301 First_Actual := First (Parameter_Associations (Call_Node));
8302
8303 -- For cross-reference purposes, treat the new node as being in the
8304 -- source if the original one is. Set entity and type, even though
8305 -- they may be overwritten during resolution if overloaded.
8306
8307 Set_Comes_From_Source (Subprog, Comes_From_Source (N));
8308 Set_Comes_From_Source (Call_Node, Comes_From_Source (N));
8309
8310 if Nkind (N) = N_Selected_Component
8311 and then not Inside_A_Generic
8312 then
8313 Set_Entity (Selector_Name (N), Entity (Subprog));
8314 Set_Etype (Selector_Name (N), Etype (Entity (Subprog)));
8315 end if;
8316
8317 -- If need be, rewrite first actual as an explicit dereference. If
8318 -- the call is overloaded, the rewriting can only be done once the
8319 -- primitive operation is identified.
8320
8321 if Is_Overloaded (Subprog) then
8322
8323 -- The prefix itself may be overloaded, and its interpretations
8324 -- must be propagated to the new actual in the call.
8325
8326 if Is_Overloaded (Obj) then
8327 Save_Interps (Obj, First_Actual);
8328 end if;
8329
8330 Rewrite (First_Actual, Obj);
8331
8332 elsif not Is_Access_Type (Formal_Type)
8333 and then Is_Access_Type (Etype (Obj))
8334 then
8335 Rewrite (First_Actual,
8336 Make_Explicit_Dereference (Sloc (Obj), Obj));
8337 Analyze (First_Actual);
8338
8339 -- If we need to introduce an explicit dereference, verify that
8340 -- the resulting actual is compatible with the mode of the formal.
8341
8342 if Ekind (First_Formal (Entity (Subprog))) /= E_In_Parameter
8343 and then Is_Access_Constant (Etype (Obj))
8344 then
8345 Error_Msg_NE
8346 ("expect variable in call to&", Prefix (N), Entity (Subprog));
8347 end if;
8348
8349 -- Conversely, if the formal is an access parameter and the object
8350 -- is not, replace the actual with a 'Access reference. Its analysis
8351 -- will check that the object is aliased.
8352
8353 elsif Is_Access_Type (Formal_Type)
8354 and then not Is_Access_Type (Etype (Obj))
8355 then
8356 -- A special case: A.all'access is illegal if A is an access to a
8357 -- constant and the context requires an access to a variable.
8358
8359 if not Is_Access_Constant (Formal_Type) then
8360 if (Nkind (Obj) = N_Explicit_Dereference
8361 and then Is_Access_Constant (Etype (Prefix (Obj))))
8362 or else not Is_Variable (Obj)
8363 then
8364 Error_Msg_NE
8365 ("actual for & must be a variable", Obj, Control);
8366 end if;
8367 end if;
8368
8369 Rewrite (First_Actual,
8370 Make_Attribute_Reference (Loc,
8371 Attribute_Name => Name_Access,
8372 Prefix => Relocate_Node (Obj)));
8373
8374 if not Is_Aliased_View (Obj) then
8375 Error_Msg_NE
8376 ("object in prefixed call to & must be aliased "
8377 & "(RM 4.1.3 (13 1/2))", Prefix (First_Actual), Subprog);
8378 end if;
8379
8380 Analyze (First_Actual);
8381
8382 else
8383 if Is_Overloaded (Obj) then
8384 Save_Interps (Obj, First_Actual);
8385 end if;
8386
8387 Rewrite (First_Actual, Obj);
8388 end if;
8389
8390 -- The operation is obtained from the dispatch table and not by
8391 -- visibility, and may be declared in a unit that is not explicitly
8392 -- referenced in the source, but is nevertheless required in the
8393 -- context of the current unit. Indicate that operation and its scope
8394 -- are referenced, to prevent spurious and misleading warnings. If
8395 -- the operation is overloaded, all primitives are in the same scope
8396 -- and we can use any of them.
8397
8398 Set_Referenced (Entity (Subprog), True);
8399 Set_Referenced (Scope (Entity (Subprog)), True);
8400
8401 Rewrite (Node_To_Replace, Call_Node);
8402
8403 -- Propagate the interpretations collected in subprog to the new
8404 -- function call node, to be resolved from context.
8405
8406 if Is_Overloaded (Subprog) then
8407 Save_Interps (Subprog, Node_To_Replace);
8408
8409 else
8410 -- The type of the subprogram may be a limited view obtained
8411 -- transitively from another unit. If full view is available,
8412 -- use it to analyze call.
8413
8414 declare
8415 T : constant Entity_Id := Etype (Subprog);
8416 begin
8417 if From_Limited_With (T) then
8418 Set_Etype (Entity (Subprog), Available_View (T));
8419 end if;
8420 end;
8421
8422 Analyze (Node_To_Replace);
8423
8424 -- If the operation has been rewritten into a call, which may get
8425 -- subsequently an explicit dereference, preserve the type on the
8426 -- original node (selected component or indexed component) for
8427 -- subsequent legality tests, e.g. Is_Variable. which examines
8428 -- the original node.
8429
8430 if Nkind (Node_To_Replace) = N_Function_Call then
8431 Set_Etype
8432 (Original_Node (Node_To_Replace), Etype (Node_To_Replace));
8433 end if;
8434 end if;
8435 end Complete_Object_Operation;
8436
8437 ----------------------
8438 -- Report_Ambiguity --
8439 ----------------------
8440
8441 procedure Report_Ambiguity (Op : Entity_Id) is
8442 Access_Actual : constant Boolean :=
8443 Is_Access_Type (Etype (Prefix (N)));
8444 Access_Formal : Boolean := False;
8445
8446 begin
8447 Error_Msg_Sloc := Sloc (Op);
8448
8449 if Present (First_Formal (Op)) then
8450 Access_Formal := Is_Access_Type (Etype (First_Formal (Op)));
8451 end if;
8452
8453 if Access_Formal and then not Access_Actual then
8454 if Nkind (Parent (Op)) = N_Full_Type_Declaration then
8455 Error_Msg_N
8456 ("\possible interpretation "
8457 & "(inherited, with implicit 'Access) #", N);
8458 else
8459 Error_Msg_N
8460 ("\possible interpretation (with implicit 'Access) #", N);
8461 end if;
8462
8463 elsif not Access_Formal and then Access_Actual then
8464 if Nkind (Parent (Op)) = N_Full_Type_Declaration then
8465 Error_Msg_N
8466 ("\possible interpretation "
8467 & "(inherited, with implicit dereference) #", N);
8468 else
8469 Error_Msg_N
8470 ("\possible interpretation (with implicit dereference) #", N);
8471 end if;
8472
8473 else
8474 if Nkind (Parent (Op)) = N_Full_Type_Declaration then
8475 Error_Msg_N ("\possible interpretation (inherited)#", N);
8476 else
8477 Error_Msg_N -- CODEFIX
8478 ("\possible interpretation#", N);
8479 end if;
8480 end if;
8481 end Report_Ambiguity;
8482
8483 --------------------------------
8484 -- Transform_Object_Operation --
8485 --------------------------------
8486
8487 procedure Transform_Object_Operation
8488 (Call_Node : out Node_Id;
8489 Node_To_Replace : out Node_Id)
8490 is
8491 Dummy : constant Node_Id := New_Copy (Obj);
8492 -- Placeholder used as a first parameter in the call, replaced
8493 -- eventually by the proper object.
8494
8495 Parent_Node : constant Node_Id := Parent (N);
8496
8497 Actual : Node_Id;
8498 Actuals : List_Id;
8499
8500 begin
8501 -- Common case covering 1) Call to a procedure and 2) Call to a
8502 -- function that has some additional actuals.
8503
8504 if Nkind (Parent_Node) in N_Subprogram_Call
8505
8506 -- N is a selected component node containing the name of the
8507 -- subprogram. If N is not the name of the parent node we must
8508 -- not replace the parent node by the new construct. This case
8509 -- occurs when N is a parameterless call to a subprogram that
8510 -- is an actual parameter of a call to another subprogram. For
8511 -- example:
8512 -- Some_Subprogram (..., Obj.Operation, ...)
8513
8514 and then Name (Parent_Node) = N
8515 then
8516 Node_To_Replace := Parent_Node;
8517
8518 Actuals := Parameter_Associations (Parent_Node);
8519
8520 if Present (Actuals) then
8521 Prepend (Dummy, Actuals);
8522 else
8523 Actuals := New_List (Dummy);
8524 end if;
8525
8526 if Nkind (Parent_Node) = N_Procedure_Call_Statement then
8527 Call_Node :=
8528 Make_Procedure_Call_Statement (Loc,
8529 Name => New_Copy (Subprog),
8530 Parameter_Associations => Actuals);
8531
8532 else
8533 Call_Node :=
8534 Make_Function_Call (Loc,
8535 Name => New_Copy (Subprog),
8536 Parameter_Associations => Actuals);
8537 end if;
8538
8539 -- Before analysis, a function call appears as an indexed component
8540 -- if there are no named associations.
8541
8542 elsif Nkind (Parent_Node) = N_Indexed_Component
8543 and then N = Prefix (Parent_Node)
8544 then
8545 Node_To_Replace := Parent_Node;
8546 Actuals := Expressions (Parent_Node);
8547
8548 Actual := First (Actuals);
8549 while Present (Actual) loop
8550 Analyze (Actual);
8551 Next (Actual);
8552 end loop;
8553
8554 Prepend (Dummy, Actuals);
8555
8556 Call_Node :=
8557 Make_Function_Call (Loc,
8558 Name => New_Copy (Subprog),
8559 Parameter_Associations => Actuals);
8560
8561 -- Parameterless call: Obj.F is rewritten as F (Obj)
8562
8563 else
8564 Node_To_Replace := N;
8565
8566 Call_Node :=
8567 Make_Function_Call (Loc,
8568 Name => New_Copy (Subprog),
8569 Parameter_Associations => New_List (Dummy));
8570 end if;
8571 end Transform_Object_Operation;
8572
8573 ------------------------------
8574 -- Try_Class_Wide_Operation --
8575 ------------------------------
8576
8577 function Try_Class_Wide_Operation
8578 (Call_Node : Node_Id;
8579 Node_To_Replace : Node_Id) return Boolean
8580 is
8581 Anc_Type : Entity_Id;
8582 Matching_Op : Entity_Id := Empty;
8583 Error : Boolean;
8584
8585 procedure Traverse_Homonyms
8586 (Anc_Type : Entity_Id;
8587 Error : out Boolean);
8588 -- Traverse the homonym chain of the subprogram searching for those
8589 -- homonyms whose first formal has the Anc_Type's class-wide type,
8590 -- or an anonymous access type designating the class-wide type. If
8591 -- an ambiguity is detected, then Error is set to True.
8592
8593 procedure Traverse_Interfaces
8594 (Anc_Type : Entity_Id;
8595 Error : out Boolean);
8596 -- Traverse the list of interfaces, if any, associated with Anc_Type
8597 -- and search for acceptable class-wide homonyms associated with each
8598 -- interface. If an ambiguity is detected, then Error is set to True.
8599
8600 -----------------------
8601 -- Traverse_Homonyms --
8602 -----------------------
8603
8604 procedure Traverse_Homonyms
8605 (Anc_Type : Entity_Id;
8606 Error : out Boolean)
8607 is
8608 Cls_Type : Entity_Id;
8609 Hom : Entity_Id;
8610 Hom_Ref : Node_Id;
8611 Success : Boolean;
8612
8613 begin
8614 Error := False;
8615
8616 Cls_Type := Class_Wide_Type (Anc_Type);
8617
8618 Hom := Current_Entity (Subprog);
8619
8620 -- Find a non-hidden operation whose first parameter is of the
8621 -- class-wide type, a subtype thereof, or an anonymous access
8622 -- to same. If in an instance, the operation can be considered
8623 -- even if hidden (it may be hidden because the instantiation
8624 -- is expanded after the containing package has been analyzed).
8625
8626 while Present (Hom) loop
8627 if Ekind_In (Hom, E_Procedure, E_Function)
8628 and then (not Is_Hidden (Hom) or else In_Instance)
8629 and then Scope (Hom) = Scope (Anc_Type)
8630 and then Present (First_Formal (Hom))
8631 and then
8632 (Base_Type (Etype (First_Formal (Hom))) = Cls_Type
8633 or else
8634 (Is_Access_Type (Etype (First_Formal (Hom)))
8635 and then
8636 Ekind (Etype (First_Formal (Hom))) =
8637 E_Anonymous_Access_Type
8638 and then
8639 Base_Type
8640 (Designated_Type (Etype (First_Formal (Hom)))) =
8641 Cls_Type))
8642 then
8643 -- If the context is a procedure call, ignore functions
8644 -- in the name of the call.
8645
8646 if Ekind (Hom) = E_Function
8647 and then Nkind (Parent (N)) = N_Procedure_Call_Statement
8648 and then N = Name (Parent (N))
8649 then
8650 goto Next_Hom;
8651
8652 -- If the context is a function call, ignore procedures
8653 -- in the name of the call.
8654
8655 elsif Ekind (Hom) = E_Procedure
8656 and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
8657 then
8658 goto Next_Hom;
8659 end if;
8660
8661 Set_Etype (Call_Node, Any_Type);
8662 Set_Is_Overloaded (Call_Node, False);
8663 Success := False;
8664
8665 if No (Matching_Op) then
8666 Hom_Ref := New_Occurrence_Of (Hom, Sloc (Subprog));
8667 Set_Etype (Call_Node, Any_Type);
8668 Set_Parent (Call_Node, Parent (Node_To_Replace));
8669
8670 Set_Name (Call_Node, Hom_Ref);
8671
8672 Analyze_One_Call
8673 (N => Call_Node,
8674 Nam => Hom,
8675 Report => Report_Error,
8676 Success => Success,
8677 Skip_First => True);
8678
8679 Matching_Op :=
8680 Valid_Candidate (Success, Call_Node, Hom);
8681
8682 else
8683 Analyze_One_Call
8684 (N => Call_Node,
8685 Nam => Hom,
8686 Report => Report_Error,
8687 Success => Success,
8688 Skip_First => True);
8689
8690 if Present (Valid_Candidate (Success, Call_Node, Hom))
8691 and then Nkind (Call_Node) /= N_Function_Call
8692 then
8693 Error_Msg_NE ("ambiguous call to&", N, Hom);
8694 Report_Ambiguity (Matching_Op);
8695 Report_Ambiguity (Hom);
8696 Error := True;
8697 return;
8698 end if;
8699 end if;
8700 end if;
8701
8702 <<Next_Hom>>
8703 Hom := Homonym (Hom);
8704 end loop;
8705 end Traverse_Homonyms;
8706
8707 -------------------------
8708 -- Traverse_Interfaces --
8709 -------------------------
8710
8711 procedure Traverse_Interfaces
8712 (Anc_Type : Entity_Id;
8713 Error : out Boolean)
8714 is
8715 Intface_List : constant List_Id :=
8716 Abstract_Interface_List (Anc_Type);
8717 Intface : Node_Id;
8718
8719 begin
8720 Error := False;
8721
8722 if Is_Non_Empty_List (Intface_List) then
8723 Intface := First (Intface_List);
8724 while Present (Intface) loop
8725
8726 -- Look for acceptable class-wide homonyms associated with
8727 -- the interface.
8728
8729 Traverse_Homonyms (Etype (Intface), Error);
8730
8731 if Error then
8732 return;
8733 end if;
8734
8735 -- Continue the search by looking at each of the interface's
8736 -- associated interface ancestors.
8737
8738 Traverse_Interfaces (Etype (Intface), Error);
8739
8740 if Error then
8741 return;
8742 end if;
8743
8744 Next (Intface);
8745 end loop;
8746 end if;
8747 end Traverse_Interfaces;
8748
8749 -- Start of processing for Try_Class_Wide_Operation
8750
8751 begin
8752 -- If we are searching only for conflicting class-wide subprograms
8753 -- then initialize directly Matching_Op with the target entity.
8754
8755 if CW_Test_Only then
8756 Matching_Op := Entity (Selector_Name (N));
8757 end if;
8758
8759 -- Loop through ancestor types (including interfaces), traversing
8760 -- the homonym chain of the subprogram, trying out those homonyms
8761 -- whose first formal has the class-wide type of the ancestor, or
8762 -- an anonymous access type designating the class-wide type.
8763
8764 Anc_Type := Obj_Type;
8765 loop
8766 -- Look for a match among homonyms associated with the ancestor
8767
8768 Traverse_Homonyms (Anc_Type, Error);
8769
8770 if Error then
8771 return True;
8772 end if;
8773
8774 -- Continue the search for matches among homonyms associated with
8775 -- any interfaces implemented by the ancestor.
8776
8777 Traverse_Interfaces (Anc_Type, Error);
8778
8779 if Error then
8780 return True;
8781 end if;
8782
8783 exit when Etype (Anc_Type) = Anc_Type;
8784 Anc_Type := Etype (Anc_Type);
8785 end loop;
8786
8787 if Present (Matching_Op) then
8788 Set_Etype (Call_Node, Etype (Matching_Op));
8789 end if;
8790
8791 return Present (Matching_Op);
8792 end Try_Class_Wide_Operation;
8793
8794 -----------------------------------
8795 -- Try_One_Prefix_Interpretation --
8796 -----------------------------------
8797
8798 procedure Try_One_Prefix_Interpretation (T : Entity_Id) is
8799
8800 -- If the interpretation does not have a valid candidate type,
8801 -- preserve current value of Obj_Type for subsequent errors.
8802
8803 Prev_Obj_Type : constant Entity_Id := Obj_Type;
8804
8805 begin
8806 Obj_Type := T;
8807
8808 if Is_Access_Type (Obj_Type) then
8809 Obj_Type := Designated_Type (Obj_Type);
8810 end if;
8811
8812 if Ekind (Obj_Type) = E_Private_Subtype then
8813 Obj_Type := Base_Type (Obj_Type);
8814 end if;
8815
8816 if Is_Class_Wide_Type (Obj_Type) then
8817 Obj_Type := Etype (Class_Wide_Type (Obj_Type));
8818 end if;
8819
8820 -- The type may have be obtained through a limited_with clause,
8821 -- in which case the primitive operations are available on its
8822 -- non-limited view. If still incomplete, retrieve full view.
8823
8824 if Ekind (Obj_Type) = E_Incomplete_Type
8825 and then From_Limited_With (Obj_Type)
8826 and then Has_Non_Limited_View (Obj_Type)
8827 then
8828 Obj_Type := Get_Full_View (Non_Limited_View (Obj_Type));
8829 end if;
8830
8831 -- If the object is not tagged, or the type is still an incomplete
8832 -- type, this is not a prefixed call.
8833
8834 if not Is_Tagged_Type (Obj_Type)
8835 or else Is_Incomplete_Type (Obj_Type)
8836 then
8837
8838 -- Restore previous type if current one is not legal candidate
8839
8840 Obj_Type := Prev_Obj_Type;
8841 return;
8842 end if;
8843
8844 declare
8845 Dup_Call_Node : constant Node_Id := New_Copy (New_Call_Node);
8846 CW_Result : Boolean;
8847 Prim_Result : Boolean;
8848 pragma Unreferenced (CW_Result);
8849
8850 begin
8851 if not CW_Test_Only then
8852 Prim_Result :=
8853 Try_Primitive_Operation
8854 (Call_Node => New_Call_Node,
8855 Node_To_Replace => Node_To_Replace);
8856 end if;
8857
8858 -- Check if there is a class-wide subprogram covering the
8859 -- primitive. This check must be done even if a candidate
8860 -- was found in order to report ambiguous calls.
8861
8862 if not (Prim_Result) then
8863 CW_Result :=
8864 Try_Class_Wide_Operation
8865 (Call_Node => New_Call_Node,
8866 Node_To_Replace => Node_To_Replace);
8867
8868 -- If we found a primitive we search for class-wide subprograms
8869 -- using a duplicate of the call node (done to avoid missing its
8870 -- decoration if there is no ambiguity).
8871
8872 else
8873 CW_Result :=
8874 Try_Class_Wide_Operation
8875 (Call_Node => Dup_Call_Node,
8876 Node_To_Replace => Node_To_Replace);
8877 end if;
8878 end;
8879 end Try_One_Prefix_Interpretation;
8880
8881 -----------------------------
8882 -- Try_Primitive_Operation --
8883 -----------------------------
8884
8885 function Try_Primitive_Operation
8886 (Call_Node : Node_Id;
8887 Node_To_Replace : Node_Id) return Boolean
8888 is
8889 Elmt : Elmt_Id;
8890 Prim_Op : Entity_Id;
8891 Matching_Op : Entity_Id := Empty;
8892 Prim_Op_Ref : Node_Id := Empty;
8893
8894 Corr_Type : Entity_Id := Empty;
8895 -- If the prefix is a synchronized type, the controlling type of
8896 -- the primitive operation is the corresponding record type, else
8897 -- this is the object type itself.
8898
8899 Success : Boolean := False;
8900
8901 function Collect_Generic_Type_Ops (T : Entity_Id) return Elist_Id;
8902 -- For tagged types the candidate interpretations are found in
8903 -- the list of primitive operations of the type and its ancestors.
8904 -- For formal tagged types we have to find the operations declared
8905 -- in the same scope as the type (including in the generic formal
8906 -- part) because the type itself carries no primitive operations,
8907 -- except for formal derived types that inherit the operations of
8908 -- the parent and progenitors.
8909 --
8910 -- If the context is a generic subprogram body, the generic formals
8911 -- are visible by name, but are not in the entity list of the
8912 -- subprogram because that list starts with the subprogram formals.
8913 -- We retrieve the candidate operations from the generic declaration.
8914
8915 function Extended_Primitive_Ops (T : Entity_Id) return Elist_Id;
8916 -- Prefix notation can also be used on operations that are not
8917 -- primitives of the type, but are declared in the same immediate
8918 -- declarative part, which can only mean the corresponding package
8919 -- body (See RM 4.1.3 (9.2/3)). If we are in that body we extend the
8920 -- list of primitives with body operations with the same name that
8921 -- may be candidates, so that Try_Primitive_Operations can examine
8922 -- them if no real primitive is found.
8923
8924 function Is_Private_Overriding (Op : Entity_Id) return Boolean;
8925 -- An operation that overrides an inherited operation in the private
8926 -- part of its package may be hidden, but if the inherited operation
8927 -- is visible a direct call to it will dispatch to the private one,
8928 -- which is therefore a valid candidate.
8929
8930 function Names_Match
8931 (Obj_Type : Entity_Id;
8932 Prim_Op : Entity_Id;
8933 Subprog : Entity_Id) return Boolean;
8934 -- Return True if the names of Prim_Op and Subprog match. If Obj_Type
8935 -- is a protected type then compare also the original name of Prim_Op
8936 -- with the name of Subprog (since the expander may have added a
8937 -- prefix to its original name --see Exp_Ch9.Build_Selected_Name).
8938
8939 function Valid_First_Argument_Of (Op : Entity_Id) return Boolean;
8940 -- Verify that the prefix, dereferenced if need be, is a valid
8941 -- controlling argument in a call to Op. The remaining actuals
8942 -- are checked in the subsequent call to Analyze_One_Call.
8943
8944 ------------------------------
8945 -- Collect_Generic_Type_Ops --
8946 ------------------------------
8947
8948 function Collect_Generic_Type_Ops (T : Entity_Id) return Elist_Id is
8949 Bas : constant Entity_Id := Base_Type (T);
8950 Candidates : constant Elist_Id := New_Elmt_List;
8951 Subp : Entity_Id;
8952 Formal : Entity_Id;
8953
8954 procedure Check_Candidate;
8955 -- The operation is a candidate if its first parameter is a
8956 -- controlling operand of the desired type.
8957
8958 -----------------------
8959 -- Check_Candidate; --
8960 -----------------------
8961
8962 procedure Check_Candidate is
8963 begin
8964 Formal := First_Formal (Subp);
8965
8966 if Present (Formal)
8967 and then Is_Controlling_Formal (Formal)
8968 and then
8969 (Base_Type (Etype (Formal)) = Bas
8970 or else
8971 (Is_Access_Type (Etype (Formal))
8972 and then Designated_Type (Etype (Formal)) = Bas))
8973 then
8974 Append_Elmt (Subp, Candidates);
8975 end if;
8976 end Check_Candidate;
8977
8978 -- Start of processing for Collect_Generic_Type_Ops
8979
8980 begin
8981 if Is_Derived_Type (T) then
8982 return Primitive_Operations (T);
8983
8984 elsif Ekind_In (Scope (T), E_Procedure, E_Function) then
8985
8986 -- Scan the list of generic formals to find subprograms
8987 -- that may have a first controlling formal of the type.
8988
8989 if Nkind (Unit_Declaration_Node (Scope (T))) =
8990 N_Generic_Subprogram_Declaration
8991 then
8992 declare
8993 Decl : Node_Id;
8994
8995 begin
8996 Decl :=
8997 First (Generic_Formal_Declarations
8998 (Unit_Declaration_Node (Scope (T))));
8999 while Present (Decl) loop
9000 if Nkind (Decl) in N_Formal_Subprogram_Declaration then
9001 Subp := Defining_Entity (Decl);
9002 Check_Candidate;
9003 end if;
9004
9005 Next (Decl);
9006 end loop;
9007 end;
9008 end if;
9009 return Candidates;
9010
9011 else
9012 -- Scan the list of entities declared in the same scope as
9013 -- the type. In general this will be an open scope, given that
9014 -- the call we are analyzing can only appear within a generic
9015 -- declaration or body (either the one that declares T, or a
9016 -- child unit).
9017
9018 -- For a subtype representing a generic actual type, go to the
9019 -- base type.
9020
9021 if Is_Generic_Actual_Type (T) then
9022 Subp := First_Entity (Scope (Base_Type (T)));
9023 else
9024 Subp := First_Entity (Scope (T));
9025 end if;
9026
9027 while Present (Subp) loop
9028 if Is_Overloadable (Subp) then
9029 Check_Candidate;
9030 end if;
9031
9032 Next_Entity (Subp);
9033 end loop;
9034
9035 return Candidates;
9036 end if;
9037 end Collect_Generic_Type_Ops;
9038
9039 ----------------------------
9040 -- Extended_Primitive_Ops --
9041 ----------------------------
9042
9043 function Extended_Primitive_Ops (T : Entity_Id) return Elist_Id is
9044 Type_Scope : constant Entity_Id := Scope (T);
9045
9046 Body_Decls : List_Id;
9047 Op_Found : Boolean;
9048 Op : Entity_Id;
9049 Op_List : Elist_Id;
9050
9051 begin
9052 Op_List := Primitive_Operations (T);
9053
9054 if Ekind (Type_Scope) = E_Package
9055 and then In_Package_Body (Type_Scope)
9056 and then In_Open_Scopes (Type_Scope)
9057 then
9058 -- Retrieve list of declarations of package body.
9059
9060 Body_Decls :=
9061 Declarations
9062 (Unit_Declaration_Node
9063 (Corresponding_Body
9064 (Unit_Declaration_Node (Type_Scope))));
9065
9066 Op := Current_Entity (Subprog);
9067 Op_Found := False;
9068 while Present (Op) loop
9069 if Comes_From_Source (Op)
9070 and then Is_Overloadable (Op)
9071
9072 -- Exclude overriding primitive operations of a type
9073 -- extension declared in the package body, to prevent
9074 -- duplicates in extended list.
9075
9076 and then not Is_Primitive (Op)
9077 and then Is_List_Member (Unit_Declaration_Node (Op))
9078 and then List_Containing (Unit_Declaration_Node (Op)) =
9079 Body_Decls
9080 then
9081 if not Op_Found then
9082
9083 -- Copy list of primitives so it is not affected for
9084 -- other uses.
9085
9086 Op_List := New_Copy_Elist (Op_List);
9087 Op_Found := True;
9088 end if;
9089
9090 Append_Elmt (Op, Op_List);
9091 end if;
9092
9093 Op := Homonym (Op);
9094 end loop;
9095 end if;
9096
9097 return Op_List;
9098 end Extended_Primitive_Ops;
9099
9100 ---------------------------
9101 -- Is_Private_Overriding --
9102 ---------------------------
9103
9104 function Is_Private_Overriding (Op : Entity_Id) return Boolean is
9105 Visible_Op : constant Entity_Id := Homonym (Op);
9106
9107 begin
9108 return Present (Visible_Op)
9109 and then Scope (Op) = Scope (Visible_Op)
9110 and then not Comes_From_Source (Visible_Op)
9111 and then Alias (Visible_Op) = Op
9112 and then not Is_Hidden (Visible_Op);
9113 end Is_Private_Overriding;
9114
9115 -----------------
9116 -- Names_Match --
9117 -----------------
9118
9119 function Names_Match
9120 (Obj_Type : Entity_Id;
9121 Prim_Op : Entity_Id;
9122 Subprog : Entity_Id) return Boolean is
9123 begin
9124 -- Common case: exact match
9125
9126 if Chars (Prim_Op) = Chars (Subprog) then
9127 return True;
9128
9129 -- For protected type primitives the expander may have built the
9130 -- name of the dispatching primitive prepending the type name to
9131 -- avoid conflicts with the name of the protected subprogram (see
9132 -- Exp_Ch9.Build_Selected_Name).
9133
9134 elsif Is_Protected_Type (Obj_Type) then
9135 return
9136 Present (Original_Protected_Subprogram (Prim_Op))
9137 and then Chars (Original_Protected_Subprogram (Prim_Op)) =
9138 Chars (Subprog);
9139 end if;
9140
9141 return False;
9142 end Names_Match;
9143
9144 -----------------------------
9145 -- Valid_First_Argument_Of --
9146 -----------------------------
9147
9148 function Valid_First_Argument_Of (Op : Entity_Id) return Boolean is
9149 Typ : Entity_Id := Etype (First_Formal (Op));
9150
9151 begin
9152 if Is_Concurrent_Type (Typ)
9153 and then Present (Corresponding_Record_Type (Typ))
9154 then
9155 Typ := Corresponding_Record_Type (Typ);
9156 end if;
9157
9158 -- Simple case. Object may be a subtype of the tagged type or
9159 -- may be the corresponding record of a synchronized type.
9160
9161 return Obj_Type = Typ
9162 or else Base_Type (Obj_Type) = Typ
9163 or else Corr_Type = Typ
9164
9165 -- Prefix can be dereferenced
9166
9167 or else
9168 (Is_Access_Type (Corr_Type)
9169 and then Designated_Type (Corr_Type) = Typ)
9170
9171 -- Formal is an access parameter, for which the object
9172 -- can provide an access.
9173
9174 or else
9175 (Ekind (Typ) = E_Anonymous_Access_Type
9176 and then
9177 Base_Type (Designated_Type (Typ)) = Base_Type (Corr_Type));
9178 end Valid_First_Argument_Of;
9179
9180 -- Start of processing for Try_Primitive_Operation
9181
9182 begin
9183 -- Look for subprograms in the list of primitive operations. The name
9184 -- must be identical, and the kind of call indicates the expected
9185 -- kind of operation (function or procedure). If the type is a
9186 -- (tagged) synchronized type, the primitive ops are attached to the
9187 -- corresponding record (base) type.
9188
9189 if Is_Concurrent_Type (Obj_Type) then
9190 if Present (Corresponding_Record_Type (Obj_Type)) then
9191 Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
9192 Elmt := First_Elmt (Primitive_Operations (Corr_Type));
9193 else
9194 Corr_Type := Obj_Type;
9195 Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type));
9196 end if;
9197
9198 elsif not Is_Generic_Type (Obj_Type) then
9199 Corr_Type := Obj_Type;
9200 Elmt := First_Elmt (Extended_Primitive_Ops (Obj_Type));
9201
9202 else
9203 Corr_Type := Obj_Type;
9204 Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type));
9205 end if;
9206
9207 while Present (Elmt) loop
9208 Prim_Op := Node (Elmt);
9209
9210 if Names_Match (Obj_Type, Prim_Op, Subprog)
9211 and then Present (First_Formal (Prim_Op))
9212 and then Valid_First_Argument_Of (Prim_Op)
9213 and then
9214 (Nkind (Call_Node) = N_Function_Call)
9215 =
9216 (Ekind (Prim_Op) = E_Function)
9217 then
9218 -- Ada 2005 (AI-251): If this primitive operation corresponds
9219 -- to an immediate ancestor interface there is no need to add
9220 -- it to the list of interpretations; the corresponding aliased
9221 -- primitive is also in this list of primitive operations and
9222 -- will be used instead.
9223
9224 if (Present (Interface_Alias (Prim_Op))
9225 and then Is_Ancestor (Find_Dispatching_Type
9226 (Alias (Prim_Op)), Corr_Type))
9227
9228 -- Do not consider hidden primitives unless the type is in an
9229 -- open scope or we are within an instance, where visibility
9230 -- is known to be correct, or else if this is an overriding
9231 -- operation in the private part for an inherited operation.
9232
9233 or else (Is_Hidden (Prim_Op)
9234 and then not Is_Immediately_Visible (Obj_Type)
9235 and then not In_Instance
9236 and then not Is_Private_Overriding (Prim_Op))
9237 then
9238 goto Continue;
9239 end if;
9240
9241 Set_Etype (Call_Node, Any_Type);
9242 Set_Is_Overloaded (Call_Node, False);
9243
9244 if No (Matching_Op) then
9245 Prim_Op_Ref := New_Occurrence_Of (Prim_Op, Sloc (Subprog));
9246 Candidate := Prim_Op;
9247
9248 Set_Parent (Call_Node, Parent (Node_To_Replace));
9249
9250 Set_Name (Call_Node, Prim_Op_Ref);
9251 Success := False;
9252
9253 Analyze_One_Call
9254 (N => Call_Node,
9255 Nam => Prim_Op,
9256 Report => Report_Error,
9257 Success => Success,
9258 Skip_First => True);
9259
9260 Matching_Op := Valid_Candidate (Success, Call_Node, Prim_Op);
9261
9262 -- More than one interpretation, collect for subsequent
9263 -- disambiguation. If this is a procedure call and there
9264 -- is another match, report ambiguity now.
9265
9266 else
9267 Analyze_One_Call
9268 (N => Call_Node,
9269 Nam => Prim_Op,
9270 Report => Report_Error,
9271 Success => Success,
9272 Skip_First => True);
9273
9274 if Present (Valid_Candidate (Success, Call_Node, Prim_Op))
9275 and then Nkind (Call_Node) /= N_Function_Call
9276 then
9277 Error_Msg_NE ("ambiguous call to&", N, Prim_Op);
9278 Report_Ambiguity (Matching_Op);
9279 Report_Ambiguity (Prim_Op);
9280 return True;
9281 end if;
9282 end if;
9283 end if;
9284
9285 <<Continue>>
9286 Next_Elmt (Elmt);
9287 end loop;
9288
9289 if Present (Matching_Op) then
9290 Set_Etype (Call_Node, Etype (Matching_Op));
9291 end if;
9292
9293 return Present (Matching_Op);
9294 end Try_Primitive_Operation;
9295
9296 -- Start of processing for Try_Object_Operation
9297
9298 begin
9299 Analyze_Expression (Obj);
9300
9301 -- Analyze the actuals if node is known to be a subprogram call
9302
9303 if Is_Subprg_Call and then N = Name (Parent (N)) then
9304 Actual := First (Parameter_Associations (Parent (N)));
9305 while Present (Actual) loop
9306 Analyze_Expression (Actual);
9307 Next (Actual);
9308 end loop;
9309 end if;
9310
9311 -- Build a subprogram call node, using a copy of Obj as its first
9312 -- actual. This is a placeholder, to be replaced by an explicit
9313 -- dereference when needed.
9314
9315 Transform_Object_Operation
9316 (Call_Node => New_Call_Node,
9317 Node_To_Replace => Node_To_Replace);
9318
9319 Set_Etype (New_Call_Node, Any_Type);
9320 Set_Etype (Subprog, Any_Type);
9321 Set_Parent (New_Call_Node, Parent (Node_To_Replace));
9322
9323 if not Is_Overloaded (Obj) then
9324 Try_One_Prefix_Interpretation (Obj_Type);
9325
9326 else
9327 declare
9328 I : Interp_Index;
9329 It : Interp;
9330 begin
9331 Get_First_Interp (Obj, I, It);
9332 while Present (It.Nam) loop
9333 Try_One_Prefix_Interpretation (It.Typ);
9334 Get_Next_Interp (I, It);
9335 end loop;
9336 end;
9337 end if;
9338
9339 if Etype (New_Call_Node) /= Any_Type then
9340
9341 -- No need to complete the tree transformations if we are only
9342 -- searching for conflicting class-wide subprograms
9343
9344 if CW_Test_Only then
9345 return False;
9346 else
9347 Complete_Object_Operation
9348 (Call_Node => New_Call_Node,
9349 Node_To_Replace => Node_To_Replace);
9350 return True;
9351 end if;
9352
9353 elsif Present (Candidate) then
9354
9355 -- The argument list is not type correct. Re-analyze with error
9356 -- reporting enabled, and use one of the possible candidates.
9357 -- In All_Errors_Mode, re-analyze all failed interpretations.
9358
9359 if All_Errors_Mode then
9360 Report_Error := True;
9361 if Try_Primitive_Operation
9362 (Call_Node => New_Call_Node,
9363 Node_To_Replace => Node_To_Replace)
9364
9365 or else
9366 Try_Class_Wide_Operation
9367 (Call_Node => New_Call_Node,
9368 Node_To_Replace => Node_To_Replace)
9369 then
9370 null;
9371 end if;
9372
9373 else
9374 Analyze_One_Call
9375 (N => New_Call_Node,
9376 Nam => Candidate,
9377 Report => True,
9378 Success => Success,
9379 Skip_First => True);
9380 end if;
9381
9382 -- No need for further errors
9383
9384 return True;
9385
9386 else
9387 -- There was no candidate operation, so report it as an error
9388 -- in the caller: Analyze_Selected_Component.
9389
9390 return False;
9391 end if;
9392 end Try_Object_Operation;
9393
9394 ---------
9395 -- wpo --
9396 ---------
9397
9398 procedure wpo (T : Entity_Id) is
9399 Op : Entity_Id;
9400 E : Elmt_Id;
9401
9402 begin
9403 if not Is_Tagged_Type (T) then
9404 return;
9405 end if;
9406
9407 E := First_Elmt (Primitive_Operations (Base_Type (T)));
9408 while Present (E) loop
9409 Op := Node (E);
9410 Write_Int (Int (Op));
9411 Write_Str (" === ");
9412 Write_Name (Chars (Op));
9413 Write_Str (" in ");
9414 Write_Name (Chars (Scope (Op)));
9415 Next_Elmt (E);
9416 Write_Eol;
9417 end loop;
9418 end wpo;
9419
9420 end Sem_Ch4;