OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [sem_ch4.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                              S E M _ C H 4                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
with Atree;    use Atree;
27
with Debug;    use Debug;
28
with Einfo;    use Einfo;
29
with Elists;   use Elists;
30
with Errout;   use Errout;
31
with Exp_Util; use Exp_Util;
32
with Fname;    use Fname;
33
with Itypes;   use Itypes;
34
with Lib;      use Lib;
35
with Lib.Xref; use Lib.Xref;
36
with Namet;    use Namet;
37
with Namet.Sp; use Namet.Sp;
38
with Nlists;   use Nlists;
39
with Nmake;    use Nmake;
40
with Opt;      use Opt;
41
with Output;   use Output;
42
with Restrict; use Restrict;
43
with Rident;   use Rident;
44
with Sem;      use Sem;
45
with Sem_Aux;  use Sem_Aux;
46
with Sem_Cat;  use Sem_Cat;
47
with Sem_Ch3;  use Sem_Ch3;
48
with Sem_Ch6;  use Sem_Ch6;
49
with Sem_Ch8;  use Sem_Ch8;
50
with Sem_SCIL; use Sem_SCIL;
51
with Sem_Disp; use Sem_Disp;
52
with Sem_Dist; use Sem_Dist;
53
with Sem_Eval; use Sem_Eval;
54
with Sem_Res;  use Sem_Res;
55
with Sem_Util; use Sem_Util;
56
with Sem_Type; use Sem_Type;
57
with Stand;    use Stand;
58
with Sinfo;    use Sinfo;
59
with Snames;   use Snames;
60
with Tbuild;   use Tbuild;
61
 
62
package body Sem_Ch4 is
63
 
64
   -----------------------
65
   -- Local Subprograms --
66
   -----------------------
67
 
68
   procedure Analyze_Concatenation_Rest (N : Node_Id);
69
   --  Does the "rest" of the work of Analyze_Concatenation, after the left
70
   --  operand has been analyzed. See Analyze_Concatenation for details.
71
 
72
   procedure Analyze_Expression (N : Node_Id);
73
   --  For expressions that are not names, this is just a call to analyze.
74
   --  If the expression is a name, it may be a call to a parameterless
75
   --  function, and if so must be converted into an explicit call node
76
   --  and analyzed as such. This deproceduring must be done during the first
77
   --  pass of overload resolution, because otherwise a procedure call with
78
   --  overloaded actuals may fail to resolve.
79
 
80
   procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id);
81
   --  Analyze a call of the form "+"(x, y), etc. The prefix of the call
82
   --  is an operator name or an expanded name whose selector is an operator
83
   --  name, and one possible interpretation is as a predefined operator.
84
 
85
   procedure Analyze_Overloaded_Selected_Component (N : Node_Id);
86
   --  If the prefix of a selected_component is overloaded, the proper
87
   --  interpretation that yields a record type with the proper selector
88
   --  name must be selected.
89
 
90
   procedure Analyze_User_Defined_Binary_Op (N : Node_Id; Op_Id : Entity_Id);
91
   --  Procedure to analyze a user defined binary operator, which is resolved
92
   --  like a function, but instead of a list of actuals it is presented
93
   --  with the left and right operands of an operator node.
94
 
95
   procedure Analyze_User_Defined_Unary_Op (N : Node_Id; Op_Id : Entity_Id);
96
   --  Procedure to analyze a user defined unary operator, which is resolved
97
   --  like a function, but instead of a list of actuals, it is presented with
98
   --  the operand of the operator node.
99
 
100
   procedure Ambiguous_Operands (N : Node_Id);
101
   --  for equality, membership, and comparison operators with overloaded
102
   --  arguments, list possible interpretations.
103
 
104
   procedure Analyze_One_Call
105
      (N          : Node_Id;
106
       Nam        : Entity_Id;
107
       Report     : Boolean;
108
       Success    : out Boolean;
109
       Skip_First : Boolean := False);
110
   --  Check one interpretation of an overloaded subprogram name for
111
   --  compatibility with the types of the actuals in a call. If there is a
112
   --  single interpretation which does not match, post error if Report is
113
   --  set to True.
114
   --
115
   --  Nam is the entity that provides the formals against which the actuals
116
   --  are checked. Nam is either the name of a subprogram, or the internal
117
   --  subprogram type constructed for an access_to_subprogram. If the actuals
118
   --  are compatible with Nam, then Nam is added to the list of candidate
119
   --  interpretations for N, and Success is set to True.
120
   --
121
   --  The flag Skip_First is used when analyzing a call that was rewritten
122
   --  from object notation. In this case the first actual may have to receive
123
   --  an explicit dereference, depending on the first formal of the operation
124
   --  being called. The caller will have verified that the object is legal
125
   --  for the call. If the remaining parameters match, the first parameter
126
   --  will rewritten as a dereference if needed, prior to completing analysis.
127
 
128
   procedure Check_Misspelled_Selector
129
     (Prefix : Entity_Id;
130
      Sel    : Node_Id);
131
   --  Give possible misspelling diagnostic if Sel is likely to be a mis-
132
   --  spelling of one of the selectors of the Prefix. This is called by
133
   --  Analyze_Selected_Component after producing an invalid selector error
134
   --  message.
135
 
136
   function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean;
137
   --  Verify that type T is declared in scope S. Used to find interpretations
138
   --  for operators given by expanded names. This is abstracted as a separate
139
   --  function to handle extensions to System, where S is System, but T is
140
   --  declared in the extension.
141
 
142
   procedure Find_Arithmetic_Types
143
     (L, R  : Node_Id;
144
      Op_Id : Entity_Id;
145
      N     : Node_Id);
146
   --  L and R are the operands of an arithmetic operator. Find
147
   --  consistent pairs of interpretations for L and R that have a
148
   --  numeric type consistent with the semantics of the operator.
149
 
150
   procedure Find_Comparison_Types
151
     (L, R  : Node_Id;
152
      Op_Id : Entity_Id;
153
      N     : Node_Id);
154
   --  L and R are operands of a comparison operator. Find consistent
155
   --  pairs of interpretations for L and R.
156
 
157
   procedure Find_Concatenation_Types
158
     (L, R  : Node_Id;
159
      Op_Id : Entity_Id;
160
      N     : Node_Id);
161
   --  For the four varieties of concatenation
162
 
163
   procedure Find_Equality_Types
164
     (L, R  : Node_Id;
165
      Op_Id : Entity_Id;
166
      N     : Node_Id);
167
   --  Ditto for equality operators
168
 
169
   procedure Find_Boolean_Types
170
     (L, R  : Node_Id;
171
      Op_Id : Entity_Id;
172
      N     : Node_Id);
173
   --  Ditto for binary logical operations
174
 
175
   procedure Find_Negation_Types
176
     (R     : Node_Id;
177
      Op_Id : Entity_Id;
178
      N     : Node_Id);
179
   --  Find consistent interpretation for operand of negation operator
180
 
181
   procedure Find_Non_Universal_Interpretations
182
     (N     : Node_Id;
183
      R     : Node_Id;
184
      Op_Id : Entity_Id;
185
      T1    : Entity_Id);
186
   --  For equality and comparison operators, the result is always boolean,
187
   --  and the legality of the operation is determined from the visibility
188
   --  of the operand types. If one of the operands has a universal interpre-
189
   --  tation,  the legality check uses some compatible non-universal
190
   --  interpretation of the other operand. N can be an operator node, or
191
   --  a function call whose name is an operator designator.
192
 
193
   function Find_Primitive_Operation (N : Node_Id) return Boolean;
194
   --  Find candidate interpretations for the name Obj.Proc when it appears
195
   --  in a subprogram renaming declaration.
196
 
197
   procedure Find_Unary_Types
198
     (R     : Node_Id;
199
      Op_Id : Entity_Id;
200
      N     : Node_Id);
201
   --  Unary arithmetic types: plus, minus, abs
202
 
203
   procedure Check_Arithmetic_Pair
204
     (T1, T2 : Entity_Id;
205
      Op_Id  : Entity_Id;
206
      N      : Node_Id);
207
   --  Subsidiary procedure to Find_Arithmetic_Types. T1 and T2 are valid
208
   --  types for left and right operand. Determine whether they constitute
209
   --  a valid pair for the given operator, and record the corresponding
210
   --  interpretation of the operator node. The node N may be an operator
211
   --  node (the usual case) or a function call whose prefix is an operator
212
   --  designator. In both cases Op_Id is the operator name itself.
213
 
214
   procedure Diagnose_Call (N : Node_Id; Nam : Node_Id);
215
   --  Give detailed information on overloaded call where none of the
216
   --  interpretations match. N is the call node, Nam the designator for
217
   --  the overloaded entity being called.
218
 
219
   function Junk_Operand (N : Node_Id) return Boolean;
220
   --  Test for an operand that is an inappropriate entity (e.g. a package
221
   --  name or a label). If so, issue an error message and return True. If
222
   --  the operand is not an inappropriate entity kind, return False.
223
 
224
   procedure Operator_Check (N : Node_Id);
225
   --  Verify that an operator has received some valid interpretation. If none
226
   --  was found, determine whether a use clause would make the operation
227
   --  legal. The variable Candidate_Type (defined in Sem_Type) is set for
228
   --  every type compatible with the operator, even if the operator for the
229
   --  type is not directly visible. The routine uses this type to emit a more
230
   --  informative message.
231
 
232
   function Process_Implicit_Dereference_Prefix
233
     (E : Entity_Id;
234
      P : Node_Id) return Entity_Id;
235
   --  Called when P is the prefix of an implicit dereference, denoting an
236
   --  object E. The function returns the designated type of the prefix, taking
237
   --  into account that the designated type of an anonymous access type may be
238
   --  a limited view, when the non-limited view is visible.
239
   --  If in semantics only mode (-gnatc or generic), the function also records
240
   --  that the prefix is a reference to E, if any. Normally, such a reference
241
   --  is generated only when the implicit dereference is expanded into an
242
   --  explicit one, but for consistency we must generate the reference when
243
   --  expansion is disabled as well.
244
 
245
   procedure Remove_Abstract_Operations (N : Node_Id);
246
   --  Ada 2005: implementation of AI-310. An abstract non-dispatching
247
   --  operation is not a candidate interpretation.
248
 
249
   function Try_Indexed_Call
250
     (N          : Node_Id;
251
      Nam        : Entity_Id;
252
      Typ        : Entity_Id;
253
      Skip_First : Boolean) return Boolean;
254
   --  If a function has defaults for all its actuals, a call to it may in fact
255
   --  be an indexing on the result of the call. Try_Indexed_Call attempts the
256
   --  interpretation as an indexing, prior to analysis as a call. If both are
257
   --  possible, the node is overloaded with both interpretations (same symbol
258
   --  but two different types). If the call is written in prefix form, the
259
   --  prefix becomes the first parameter in the call, and only the remaining
260
   --  actuals must be checked for the presence of defaults.
261
 
262
   function Try_Indirect_Call
263
     (N   : Node_Id;
264
      Nam : Entity_Id;
265
      Typ : Entity_Id) return Boolean;
266
   --  Similarly, a function F that needs no actuals can return an access to a
267
   --  subprogram, and the call F (X) interpreted as F.all (X). In this case
268
   --  the call may be overloaded with both interpretations.
269
 
270
   function Try_Object_Operation (N : Node_Id) return Boolean;
271
   --  Ada 2005 (AI-252): Support the object.operation notation
272
 
273
   procedure wpo (T : Entity_Id);
274
   pragma Warnings (Off, wpo);
275
   --  Used for debugging: obtain list of primitive operations even if
276
   --  type is not frozen and dispatch table is not built yet.
277
 
278
   ------------------------
279
   -- Ambiguous_Operands --
280
   ------------------------
281
 
282
   procedure Ambiguous_Operands (N : Node_Id) is
283
      procedure List_Operand_Interps (Opnd : Node_Id);
284
 
285
      --------------------------
286
      -- List_Operand_Interps --
287
      --------------------------
288
 
289
      procedure List_Operand_Interps (Opnd : Node_Id) is
290
         Nam   : Node_Id;
291
         Err   : Node_Id := N;
292
 
293
      begin
294
         if Is_Overloaded (Opnd) then
295
            if Nkind (Opnd) in N_Op then
296
               Nam := Opnd;
297
            elsif Nkind (Opnd) = N_Function_Call then
298
               Nam := Name (Opnd);
299
            else
300
               return;
301
            end if;
302
 
303
         else
304
            return;
305
         end if;
306
 
307
         if Opnd = Left_Opnd (N) then
308
            Error_Msg_N
309
              ("\left operand has the following interpretations", N);
310
         else
311
            Error_Msg_N
312
              ("\right operand has the following interpretations", N);
313
            Err := Opnd;
314
         end if;
315
 
316
         List_Interps (Nam, Err);
317
      end List_Operand_Interps;
318
 
319
   --  Start of processing for Ambiguous_Operands
320
 
321
   begin
322
      if Nkind (N) in N_Membership_Test then
323
         Error_Msg_N ("ambiguous operands for membership",  N);
324
 
325
      elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then
326
         Error_Msg_N ("ambiguous operands for equality",  N);
327
 
328
      else
329
         Error_Msg_N ("ambiguous operands for comparison",  N);
330
      end if;
331
 
332
      if All_Errors_Mode then
333
         List_Operand_Interps (Left_Opnd  (N));
334
         List_Operand_Interps (Right_Opnd (N));
335
      else
336
         Error_Msg_N ("\use -gnatf switch for details", N);
337
      end if;
338
   end Ambiguous_Operands;
339
 
340
   -----------------------
341
   -- Analyze_Aggregate --
342
   -----------------------
343
 
344
   --  Most of the analysis of Aggregates requires that the type be known,
345
   --  and is therefore put off until resolution.
346
 
347
   procedure Analyze_Aggregate (N : Node_Id) is
348
   begin
349
      if No (Etype (N)) then
350
         Set_Etype (N, Any_Composite);
351
      end if;
352
   end Analyze_Aggregate;
353
 
354
   -----------------------
355
   -- Analyze_Allocator --
356
   -----------------------
357
 
358
   procedure Analyze_Allocator (N : Node_Id) is
359
      Loc      : constant Source_Ptr := Sloc (N);
360
      Sav_Errs : constant Nat        := Serious_Errors_Detected;
361
      E        : Node_Id             := Expression (N);
362
      Acc_Type : Entity_Id;
363
      Type_Id  : Entity_Id;
364
 
365
   begin
366
      --  In accordance with H.4(7), the No_Allocators restriction only applies
367
      --  to user-written allocators.
368
 
369
      if Comes_From_Source (N) then
370
         Check_Restriction (No_Allocators, N);
371
      end if;
372
 
373
      if Nkind (E) = N_Qualified_Expression then
374
         Acc_Type := Create_Itype (E_Allocator_Type, N);
375
         Set_Etype (Acc_Type, Acc_Type);
376
         Find_Type (Subtype_Mark (E));
377
 
378
         --  Analyze the qualified expression, and apply the name resolution
379
         --  rule given in  4.7 (3).
380
 
381
         Analyze (E);
382
         Type_Id := Etype (E);
383
         Set_Directly_Designated_Type (Acc_Type, Type_Id);
384
 
385
         Resolve (Expression (E), Type_Id);
386
 
387
         if Is_Limited_Type (Type_Id)
388
           and then Comes_From_Source (N)
389
           and then not In_Instance_Body
390
         then
391
            if not OK_For_Limited_Init (Type_Id, Expression (E)) then
392
               Error_Msg_N ("initialization not allowed for limited types", N);
393
               Explain_Limited_Type (Type_Id, N);
394
            end if;
395
         end if;
396
 
397
         --  A qualified expression requires an exact match of the type,
398
         --  class-wide matching is not allowed.
399
 
400
         --  if Is_Class_Wide_Type (Type_Id)
401
         --    and then Base_Type
402
         --       (Etype (Expression (E))) /= Base_Type (Type_Id)
403
         --  then
404
         --     Wrong_Type (Expression (E), Type_Id);
405
         --  end if;
406
 
407
         Check_Non_Static_Context (Expression (E));
408
 
409
         --  We don't analyze the qualified expression itself because it's
410
         --  part of the allocator
411
 
412
         Set_Etype  (E, Type_Id);
413
 
414
      --  Case where allocator has a subtype indication
415
 
416
      else
417
         declare
418
            Def_Id   : Entity_Id;
419
            Base_Typ : Entity_Id;
420
 
421
         begin
422
            --  If the allocator includes a N_Subtype_Indication then a
423
            --  constraint is present, otherwise the node is a subtype mark.
424
            --  Introduce an explicit subtype declaration into the tree
425
            --  defining some anonymous subtype and rewrite the allocator to
426
            --  use this subtype rather than the subtype indication.
427
 
428
            --  It is important to introduce the explicit subtype declaration
429
            --  so that the bounds of the subtype indication are attached to
430
            --  the tree in case the allocator is inside a generic unit.
431
 
432
            if Nkind (E) = N_Subtype_Indication then
433
 
434
               --  A constraint is only allowed for a composite type in Ada
435
               --  95. In Ada 83, a constraint is also allowed for an
436
               --  access-to-composite type, but the constraint is ignored.
437
 
438
               Find_Type (Subtype_Mark (E));
439
               Base_Typ := Entity (Subtype_Mark (E));
440
 
441
               if Is_Elementary_Type (Base_Typ) then
442
                  if not (Ada_Version = Ada_83
443
                           and then Is_Access_Type (Base_Typ))
444
                  then
445
                     Error_Msg_N ("constraint not allowed here", E);
446
 
447
                     if Nkind (Constraint (E)) =
448
                       N_Index_Or_Discriminant_Constraint
449
                     then
450
                        Error_Msg_N -- CODEFIX
451
                          ("\if qualified expression was meant, " &
452
                              "use apostrophe", Constraint (E));
453
                     end if;
454
                  end if;
455
 
456
                  --  Get rid of the bogus constraint:
457
 
458
                  Rewrite (E, New_Copy_Tree (Subtype_Mark (E)));
459
                  Analyze_Allocator (N);
460
                  return;
461
 
462
               --  Ada 2005, AI-363: if the designated type has a constrained
463
               --  partial view, it cannot receive a discriminant constraint,
464
               --  and the allocated object is unconstrained.
465
 
466
               elsif Ada_Version >= Ada_05
467
                 and then Has_Constrained_Partial_View (Base_Typ)
468
               then
469
                  Error_Msg_N
470
                    ("constraint no allowed when type " &
471
                      "has a constrained partial view", Constraint (E));
472
               end if;
473
 
474
               if Expander_Active then
475
                  Def_Id :=
476
                    Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
477
 
478
                  Insert_Action (E,
479
                    Make_Subtype_Declaration (Loc,
480
                      Defining_Identifier => Def_Id,
481
                      Subtype_Indication  => Relocate_Node (E)));
482
 
483
                  if Sav_Errs /= Serious_Errors_Detected
484
                    and then Nkind (Constraint (E)) =
485
                               N_Index_Or_Discriminant_Constraint
486
                  then
487
                     Error_Msg_N -- CODEFIX
488
                       ("if qualified expression was meant, " &
489
                           "use apostrophe!", Constraint (E));
490
                  end if;
491
 
492
                  E := New_Occurrence_Of (Def_Id, Loc);
493
                  Rewrite (Expression (N), E);
494
               end if;
495
            end if;
496
 
497
            Type_Id := Process_Subtype (E, N);
498
            Acc_Type := Create_Itype (E_Allocator_Type, N);
499
            Set_Etype                    (Acc_Type, Acc_Type);
500
            Set_Directly_Designated_Type (Acc_Type, Type_Id);
501
            Check_Fully_Declared (Type_Id, N);
502
 
503
            --  Ada 2005 (AI-231): If the designated type is itself an access
504
            --  type that excludes null, its default initialization will
505
            --  be a null object, and we can insert an unconditional raise
506
            --  before the allocator.
507
 
508
            if Can_Never_Be_Null (Type_Id) then
509
               declare
510
                  Not_Null_Check : constant Node_Id :=
511
                                     Make_Raise_Constraint_Error (Sloc (E),
512
                                       Reason => CE_Null_Not_Allowed);
513
               begin
514
                  if Expander_Active then
515
                     Insert_Action (N, Not_Null_Check);
516
                     Analyze (Not_Null_Check);
517
                  else
518
                     Error_Msg_N ("null value not allowed here?", E);
519
                  end if;
520
               end;
521
            end if;
522
 
523
            --  Check restriction against dynamically allocated protected
524
            --  objects. Note that when limited aggregates are supported,
525
            --  a similar test should be applied to an allocator with a
526
            --  qualified expression ???
527
 
528
            if Is_Protected_Type (Type_Id) then
529
               Check_Restriction (No_Protected_Type_Allocators, N);
530
            end if;
531
 
532
            --  Check for missing initialization. Skip this check if we already
533
            --  had errors on analyzing the allocator, since in that case these
534
            --  are probably cascaded errors.
535
 
536
            if Is_Indefinite_Subtype (Type_Id)
537
              and then Serious_Errors_Detected = Sav_Errs
538
            then
539
               if Is_Class_Wide_Type (Type_Id) then
540
                  Error_Msg_N
541
                    ("initialization required in class-wide allocation", N);
542
               else
543
                  if Ada_Version < Ada_05
544
                    and then Is_Limited_Type (Type_Id)
545
                  then
546
                     Error_Msg_N ("unconstrained allocation not allowed", N);
547
 
548
                     if Is_Array_Type (Type_Id) then
549
                        Error_Msg_N
550
                          ("\constraint with array bounds required", N);
551
 
552
                     elsif Has_Unknown_Discriminants (Type_Id) then
553
                        null;
554
 
555
                     else pragma Assert (Has_Discriminants (Type_Id));
556
                        Error_Msg_N
557
                          ("\constraint with discriminant values required", N);
558
                     end if;
559
 
560
                  --  Limited Ada 2005 and general non-limited case
561
 
562
                  else
563
                     Error_Msg_N
564
                       ("uninitialized unconstrained allocation not allowed",
565
                        N);
566
 
567
                     if Is_Array_Type (Type_Id) then
568
                        Error_Msg_N
569
                          ("\qualified expression or constraint with " &
570
                           "array bounds required", N);
571
 
572
                     elsif Has_Unknown_Discriminants (Type_Id) then
573
                        Error_Msg_N ("\qualified expression required", N);
574
 
575
                     else pragma Assert (Has_Discriminants (Type_Id));
576
                        Error_Msg_N
577
                          ("\qualified expression or constraint with " &
578
                           "discriminant values required", N);
579
                     end if;
580
                  end if;
581
               end if;
582
            end if;
583
         end;
584
      end if;
585
 
586
      if Is_Abstract_Type (Type_Id) then
587
         Error_Msg_N ("cannot allocate abstract object", E);
588
      end if;
589
 
590
      if Has_Task (Designated_Type (Acc_Type)) then
591
         Check_Restriction (No_Tasking, N);
592
         Check_Restriction (Max_Tasks, N);
593
         Check_Restriction (No_Task_Allocators, N);
594
      end if;
595
 
596
      --  If the No_Streams restriction is set, check that the type of the
597
      --  object is not, and does not contain, any subtype derived from
598
      --  Ada.Streams.Root_Stream_Type. Note that we guard the call to
599
      --  Has_Stream just for efficiency reasons. There is no point in
600
      --  spending time on a Has_Stream check if the restriction is not set.
601
 
602
      if Restrictions.Set (No_Streams) then
603
         if Has_Stream (Designated_Type (Acc_Type)) then
604
            Check_Restriction (No_Streams, N);
605
         end if;
606
      end if;
607
 
608
      Set_Etype (N, Acc_Type);
609
 
610
      if not Is_Library_Level_Entity (Acc_Type) then
611
         Check_Restriction (No_Local_Allocators, N);
612
      end if;
613
 
614
      if Serious_Errors_Detected > Sav_Errs then
615
         Set_Error_Posted (N);
616
         Set_Etype (N, Any_Type);
617
      end if;
618
   end Analyze_Allocator;
619
 
620
   ---------------------------
621
   -- Analyze_Arithmetic_Op --
622
   ---------------------------
623
 
624
   procedure Analyze_Arithmetic_Op (N : Node_Id) is
625
      L     : constant Node_Id := Left_Opnd (N);
626
      R     : constant Node_Id := Right_Opnd (N);
627
      Op_Id : Entity_Id;
628
 
629
   begin
630
      Candidate_Type := Empty;
631
      Analyze_Expression (L);
632
      Analyze_Expression (R);
633
 
634
      --  If the entity is already set, the node is the instantiation of a
635
      --  generic node with a non-local reference, or was manufactured by a
636
      --  call to Make_Op_xxx. In either case the entity is known to be valid,
637
      --  and we do not need to collect interpretations, instead we just get
638
      --  the single possible interpretation.
639
 
640
      Op_Id := Entity (N);
641
 
642
      if Present (Op_Id) then
643
         if Ekind (Op_Id) = E_Operator then
644
 
645
            if Nkind_In (N, N_Op_Divide, N_Op_Mod, N_Op_Multiply, N_Op_Rem)
646
              and then Treat_Fixed_As_Integer (N)
647
            then
648
               null;
649
            else
650
               Set_Etype (N, Any_Type);
651
               Find_Arithmetic_Types (L, R, Op_Id, N);
652
            end if;
653
 
654
         else
655
            Set_Etype (N, Any_Type);
656
            Add_One_Interp (N, Op_Id, Etype (Op_Id));
657
         end if;
658
 
659
      --  Entity is not already set, so we do need to collect interpretations
660
 
661
      else
662
         Op_Id := Get_Name_Entity_Id (Chars (N));
663
         Set_Etype (N, Any_Type);
664
 
665
         while Present (Op_Id) loop
666
            if Ekind (Op_Id) = E_Operator
667
              and then Present (Next_Entity (First_Entity (Op_Id)))
668
            then
669
               Find_Arithmetic_Types (L, R, Op_Id, N);
670
 
671
            --  The following may seem superfluous, because an operator cannot
672
            --  be generic, but this ignores the cleverness of the author of
673
            --  ACVC bc1013a.
674
 
675
            elsif Is_Overloadable (Op_Id) then
676
               Analyze_User_Defined_Binary_Op (N, Op_Id);
677
            end if;
678
 
679
            Op_Id := Homonym (Op_Id);
680
         end loop;
681
      end if;
682
 
683
      Operator_Check (N);
684
   end Analyze_Arithmetic_Op;
685
 
686
   ------------------
687
   -- Analyze_Call --
688
   ------------------
689
 
690
   --  Function, procedure, and entry calls are checked here. The Name in
691
   --  the call may be overloaded. The actuals have been analyzed and may
692
   --  themselves be overloaded. On exit from this procedure, the node N
693
   --  may have zero, one or more interpretations. In the first case an
694
   --  error message is produced. In the last case, the node is flagged
695
   --  as overloaded and the interpretations are collected in All_Interp.
696
 
697
   --  If the name is an Access_To_Subprogram, it cannot be overloaded, but
698
   --  the type-checking is similar to that of other calls.
699
 
700
   procedure Analyze_Call (N : Node_Id) is
701
      Actuals : constant List_Id := Parameter_Associations (N);
702
      Nam     : Node_Id;
703
      X       : Interp_Index;
704
      It      : Interp;
705
      Nam_Ent : Entity_Id;
706
      Success : Boolean := False;
707
 
708
      Deref : Boolean := False;
709
      --  Flag indicates whether an interpretation of the prefix is a
710
      --  parameterless call that returns an access_to_subprogram.
711
 
712
      function Name_Denotes_Function return Boolean;
713
      --  If the type of the name is an access to subprogram, this may be the
714
      --  type of a name, or the return type of the function being called. If
715
      --  the name is not an entity then it can denote a protected function.
716
      --  Until we distinguish Etype from Return_Type, we must use this routine
717
      --  to resolve the meaning of the name in the call.
718
 
719
      procedure No_Interpretation;
720
      --  Output error message when no valid interpretation exists
721
 
722
      ---------------------------
723
      -- Name_Denotes_Function --
724
      ---------------------------
725
 
726
      function Name_Denotes_Function return Boolean is
727
      begin
728
         if Is_Entity_Name (Nam) then
729
            return Ekind (Entity (Nam)) = E_Function;
730
 
731
         elsif Nkind (Nam) = N_Selected_Component then
732
            return Ekind (Entity (Selector_Name (Nam))) = E_Function;
733
 
734
         else
735
            return False;
736
         end if;
737
      end Name_Denotes_Function;
738
 
739
      -----------------------
740
      -- No_Interpretation --
741
      -----------------------
742
 
743
      procedure No_Interpretation is
744
         L : constant Boolean   := Is_List_Member (N);
745
         K : constant Node_Kind := Nkind (Parent (N));
746
 
747
      begin
748
         --  If the node is in a list whose parent is not an expression then it
749
         --  must be an attempted procedure call.
750
 
751
         if L and then K not in N_Subexpr then
752
            if Ekind (Entity (Nam)) = E_Generic_Procedure then
753
               Error_Msg_NE
754
                 ("must instantiate generic procedure& before call",
755
                  Nam, Entity (Nam));
756
            else
757
               Error_Msg_N
758
                 ("procedure or entry name expected", Nam);
759
            end if;
760
 
761
         --  Check for tasking cases where only an entry call will do
762
 
763
         elsif not L
764
           and then Nkind_In (K, N_Entry_Call_Alternative,
765
                                 N_Triggering_Alternative)
766
         then
767
            Error_Msg_N ("entry name expected", Nam);
768
 
769
         --  Otherwise give general error message
770
 
771
         else
772
            Error_Msg_N ("invalid prefix in call", Nam);
773
         end if;
774
      end No_Interpretation;
775
 
776
   --  Start of processing for Analyze_Call
777
 
778
   begin
779
      --  Initialize the type of the result of the call to the error type,
780
      --  which will be reset if the type is successfully resolved.
781
 
782
      Set_Etype (N, Any_Type);
783
 
784
      Nam := Name (N);
785
 
786
      if not Is_Overloaded (Nam) then
787
 
788
         --  Only one interpretation to check
789
 
790
         if Ekind (Etype (Nam)) = E_Subprogram_Type then
791
            Nam_Ent := Etype (Nam);
792
 
793
         --  If the prefix is an access_to_subprogram, this may be an indirect
794
         --  call. This is the case if the name in the call is not an entity
795
         --  name, or if it is a function name in the context of a procedure
796
         --  call. In this latter case, we have a call to a parameterless
797
         --  function that returns a pointer_to_procedure which is the entity
798
         --  being called. Finally, F (X) may be a call to a parameterless
799
         --  function that returns a pointer to a function with parameters.
800
 
801
         elsif Is_Access_Type (Etype (Nam))
802
           and then Ekind (Designated_Type (Etype (Nam))) = E_Subprogram_Type
803
           and then
804
             (not Name_Denotes_Function
805
                or else Nkind (N) = N_Procedure_Call_Statement
806
                or else
807
                  (Nkind (Parent (N)) /= N_Explicit_Dereference
808
                     and then Is_Entity_Name (Nam)
809
                     and then No (First_Formal (Entity (Nam)))
810
                     and then Present (Actuals)))
811
         then
812
            Nam_Ent := Designated_Type (Etype (Nam));
813
            Insert_Explicit_Dereference (Nam);
814
 
815
         --  Selected component case. Simple entry or protected operation,
816
         --  where the entry name is given by the selector name.
817
 
818
         elsif Nkind (Nam) = N_Selected_Component then
819
            Nam_Ent := Entity (Selector_Name (Nam));
820
 
821
            if Ekind (Nam_Ent) /= E_Entry
822
              and then Ekind (Nam_Ent) /= E_Entry_Family
823
              and then Ekind (Nam_Ent) /= E_Function
824
              and then Ekind (Nam_Ent) /= E_Procedure
825
            then
826
               Error_Msg_N ("name in call is not a callable entity", Nam);
827
               Set_Etype (N, Any_Type);
828
               return;
829
            end if;
830
 
831
         --  If the name is an Indexed component, it can be a call to a member
832
         --  of an entry family. The prefix must be a selected component whose
833
         --  selector is the entry. Analyze_Procedure_Call normalizes several
834
         --  kinds of call into this form.
835
 
836
         elsif Nkind (Nam) = N_Indexed_Component then
837
            if Nkind (Prefix (Nam)) = N_Selected_Component then
838
               Nam_Ent := Entity (Selector_Name (Prefix (Nam)));
839
            else
840
               Error_Msg_N ("name in call is not a callable entity", Nam);
841
               Set_Etype (N, Any_Type);
842
               return;
843
            end if;
844
 
845
         elsif not Is_Entity_Name (Nam) then
846
            Error_Msg_N ("name in call is not a callable entity", Nam);
847
            Set_Etype (N, Any_Type);
848
            return;
849
 
850
         else
851
            Nam_Ent := Entity (Nam);
852
 
853
            --  If no interpretations, give error message
854
 
855
            if not Is_Overloadable (Nam_Ent) then
856
               No_Interpretation;
857
               return;
858
            end if;
859
         end if;
860
 
861
         --  Operations generated for RACW stub types are called only through
862
         --  dispatching, and can never be the static interpretation of a call.
863
 
864
         if Is_RACW_Stub_Type_Operation (Nam_Ent) then
865
            No_Interpretation;
866
            return;
867
         end if;
868
 
869
         Analyze_One_Call (N, Nam_Ent, True, Success);
870
 
871
         --  If this is an indirect call, the return type of the access_to
872
         --  subprogram may be an incomplete type. At the point of the call,
873
         --  use the full type if available, and at the same time update
874
         --  the return type of the access_to_subprogram.
875
 
876
         if Success
877
           and then Nkind (Nam) = N_Explicit_Dereference
878
           and then Ekind (Etype (N)) = E_Incomplete_Type
879
           and then Present (Full_View (Etype (N)))
880
         then
881
            Set_Etype (N, Full_View (Etype (N)));
882
            Set_Etype (Nam_Ent, Etype (N));
883
         end if;
884
 
885
      else
886
         --  An overloaded selected component must denote overloaded operations
887
         --  of a concurrent type. The interpretations are attached to the
888
         --  simple name of those operations.
889
 
890
         if Nkind (Nam) = N_Selected_Component then
891
            Nam := Selector_Name (Nam);
892
         end if;
893
 
894
         Get_First_Interp (Nam, X, It);
895
 
896
         while Present (It.Nam) loop
897
            Nam_Ent := It.Nam;
898
            Deref   := False;
899
 
900
            --  Name may be call that returns an access to subprogram, or more
901
            --  generally an overloaded expression one of whose interpretations
902
            --  yields an access to subprogram. If the name is an entity, we
903
            --  do not dereference, because the node is a call that returns
904
            --  the access type: note difference between f(x), where the call
905
            --  may return an access subprogram type, and f(x)(y), where the
906
            --  type returned by the call to f is implicitly dereferenced to
907
            --  analyze the outer call.
908
 
909
            if Is_Access_Type (Nam_Ent) then
910
               Nam_Ent := Designated_Type (Nam_Ent);
911
 
912
            elsif Is_Access_Type (Etype (Nam_Ent))
913
              and then
914
                (not Is_Entity_Name (Nam)
915
                   or else Nkind (N) = N_Procedure_Call_Statement)
916
              and then Ekind (Designated_Type (Etype (Nam_Ent)))
917
                                                          = E_Subprogram_Type
918
            then
919
               Nam_Ent := Designated_Type (Etype (Nam_Ent));
920
 
921
               if Is_Entity_Name (Nam) then
922
                  Deref := True;
923
               end if;
924
            end if;
925
 
926
            Analyze_One_Call (N, Nam_Ent, False, Success);
927
 
928
            --  If the interpretation succeeds, mark the proper type of the
929
            --  prefix (any valid candidate will do). If not, remove the
930
            --  candidate interpretation. This only needs to be done for
931
            --  overloaded protected operations, for other entities disambi-
932
            --  guation is done directly in Resolve.
933
 
934
            if Success then
935
               if Deref
936
                 and then Nkind (Parent (N)) /= N_Explicit_Dereference
937
               then
938
                  Set_Entity (Nam, It.Nam);
939
                  Insert_Explicit_Dereference (Nam);
940
                  Set_Etype (Nam, Nam_Ent);
941
 
942
               else
943
                  Set_Etype (Nam, It.Typ);
944
               end if;
945
 
946
            elsif Nkind_In (Name (N), N_Selected_Component,
947
                                      N_Function_Call)
948
            then
949
               Remove_Interp (X);
950
            end if;
951
 
952
            Get_Next_Interp (X, It);
953
         end loop;
954
 
955
         --  If the name is the result of a function call, it can only
956
         --  be a call to a function returning an access to subprogram.
957
         --  Insert explicit dereference.
958
 
959
         if Nkind (Nam) = N_Function_Call then
960
            Insert_Explicit_Dereference (Nam);
961
         end if;
962
 
963
         if Etype (N) = Any_Type then
964
 
965
            --  None of the interpretations is compatible with the actuals
966
 
967
            Diagnose_Call (N, Nam);
968
 
969
            --  Special checks for uninstantiated put routines
970
 
971
            if Nkind (N) = N_Procedure_Call_Statement
972
              and then Is_Entity_Name (Nam)
973
              and then Chars (Nam) = Name_Put
974
              and then List_Length (Actuals) = 1
975
            then
976
               declare
977
                  Arg : constant Node_Id := First (Actuals);
978
                  Typ : Entity_Id;
979
 
980
               begin
981
                  if Nkind (Arg) = N_Parameter_Association then
982
                     Typ := Etype (Explicit_Actual_Parameter (Arg));
983
                  else
984
                     Typ := Etype (Arg);
985
                  end if;
986
 
987
                  if Is_Signed_Integer_Type (Typ) then
988
                     Error_Msg_N
989
                       ("possible missing instantiation of " &
990
                          "'Text_'I'O.'Integer_'I'O!", Nam);
991
 
992
                  elsif Is_Modular_Integer_Type (Typ) then
993
                     Error_Msg_N
994
                       ("possible missing instantiation of " &
995
                          "'Text_'I'O.'Modular_'I'O!", Nam);
996
 
997
                  elsif Is_Floating_Point_Type (Typ) then
998
                     Error_Msg_N
999
                       ("possible missing instantiation of " &
1000
                          "'Text_'I'O.'Float_'I'O!", Nam);
1001
 
1002
                  elsif Is_Ordinary_Fixed_Point_Type (Typ) then
1003
                     Error_Msg_N
1004
                       ("possible missing instantiation of " &
1005
                          "'Text_'I'O.'Fixed_'I'O!", Nam);
1006
 
1007
                  elsif Is_Decimal_Fixed_Point_Type (Typ) then
1008
                     Error_Msg_N
1009
                       ("possible missing instantiation of " &
1010
                          "'Text_'I'O.'Decimal_'I'O!", Nam);
1011
 
1012
                  elsif Is_Enumeration_Type (Typ) then
1013
                     Error_Msg_N
1014
                       ("possible missing instantiation of " &
1015
                          "'Text_'I'O.'Enumeration_'I'O!", Nam);
1016
                  end if;
1017
               end;
1018
            end if;
1019
 
1020
         elsif not Is_Overloaded (N)
1021
           and then Is_Entity_Name (Nam)
1022
         then
1023
            --  Resolution yields a single interpretation. Verify that the
1024
            --  reference has capitalization consistent with the declaration.
1025
 
1026
            Set_Entity_With_Style_Check (Nam, Entity (Nam));
1027
            Generate_Reference (Entity (Nam), Nam);
1028
 
1029
            Set_Etype (Nam, Etype (Entity (Nam)));
1030
         else
1031
            Remove_Abstract_Operations (N);
1032
         end if;
1033
 
1034
         End_Interp_List;
1035
      end if;
1036
   end Analyze_Call;
1037
 
1038
   ---------------------------
1039
   -- Analyze_Comparison_Op --
1040
   ---------------------------
1041
 
1042
   procedure Analyze_Comparison_Op (N : Node_Id) is
1043
      L     : constant Node_Id := Left_Opnd (N);
1044
      R     : constant Node_Id := Right_Opnd (N);
1045
      Op_Id : Entity_Id        := Entity (N);
1046
 
1047
   begin
1048
      Set_Etype (N, Any_Type);
1049
      Candidate_Type := Empty;
1050
 
1051
      Analyze_Expression (L);
1052
      Analyze_Expression (R);
1053
 
1054
      if Present (Op_Id) then
1055
         if Ekind (Op_Id) = E_Operator then
1056
            Find_Comparison_Types (L, R, Op_Id, N);
1057
         else
1058
            Add_One_Interp (N, Op_Id, Etype (Op_Id));
1059
         end if;
1060
 
1061
         if Is_Overloaded (L) then
1062
            Set_Etype (L, Intersect_Types (L, R));
1063
         end if;
1064
 
1065
      else
1066
         Op_Id := Get_Name_Entity_Id (Chars (N));
1067
         while Present (Op_Id) loop
1068
            if Ekind (Op_Id) = E_Operator then
1069
               Find_Comparison_Types (L, R, Op_Id, N);
1070
            else
1071
               Analyze_User_Defined_Binary_Op (N, Op_Id);
1072
            end if;
1073
 
1074
            Op_Id := Homonym (Op_Id);
1075
         end loop;
1076
      end if;
1077
 
1078
      Operator_Check (N);
1079
   end Analyze_Comparison_Op;
1080
 
1081
   ---------------------------
1082
   -- Analyze_Concatenation --
1083
   ---------------------------
1084
 
1085
   procedure Analyze_Concatenation (N : Node_Id) is
1086
 
1087
      --  We wish to avoid deep recursion, because concatenations are often
1088
      --  deeply nested, as in A&B&...&Z. Therefore, we walk down the left
1089
      --  operands nonrecursively until we find something that is not a
1090
      --  concatenation (A in this case), or has already been analyzed. We
1091
      --  analyze that, and then walk back up the tree following Parent
1092
      --  pointers, calling Analyze_Concatenation_Rest to do the rest of the
1093
      --  work at each level. The Parent pointers allow us to avoid recursion,
1094
      --  and thus avoid running out of memory.
1095
 
1096
      NN : Node_Id := N;
1097
      L  : Node_Id;
1098
 
1099
   begin
1100
      Candidate_Type := Empty;
1101
 
1102
      --  The following code is equivalent to:
1103
 
1104
      --    Set_Etype (N, Any_Type);
1105
      --    Analyze_Expression (Left_Opnd (N));
1106
      --    Analyze_Concatenation_Rest (N);
1107
 
1108
      --  where the Analyze_Expression call recurses back here if the left
1109
      --  operand is a concatenation.
1110
 
1111
      --  Walk down left operands
1112
 
1113
      loop
1114
         Set_Etype (NN, Any_Type);
1115
         L := Left_Opnd (NN);
1116
         exit when Nkind (L) /= N_Op_Concat or else Analyzed (L);
1117
         NN := L;
1118
      end loop;
1119
 
1120
      --  Now (given the above example) NN is A&B and L is A
1121
 
1122
      --  First analyze L ...
1123
 
1124
      Analyze_Expression (L);
1125
 
1126
      --  ... then walk NN back up until we reach N (where we started), calling
1127
      --  Analyze_Concatenation_Rest along the way.
1128
 
1129
      loop
1130
         Analyze_Concatenation_Rest (NN);
1131
         exit when NN = N;
1132
         NN := Parent (NN);
1133
      end loop;
1134
   end Analyze_Concatenation;
1135
 
1136
   --------------------------------
1137
   -- Analyze_Concatenation_Rest --
1138
   --------------------------------
1139
 
1140
   --  If the only one-dimensional array type in scope is String,
1141
   --  this is the resulting type of the operation. Otherwise there
1142
   --  will be a concatenation operation defined for each user-defined
1143
   --  one-dimensional array.
1144
 
1145
   procedure Analyze_Concatenation_Rest (N : Node_Id) is
1146
      L     : constant Node_Id := Left_Opnd (N);
1147
      R     : constant Node_Id := Right_Opnd (N);
1148
      Op_Id : Entity_Id        := Entity (N);
1149
      LT    : Entity_Id;
1150
      RT    : Entity_Id;
1151
 
1152
   begin
1153
      Analyze_Expression (R);
1154
 
1155
      --  If the entity is present, the node appears in an instance, and
1156
      --  denotes a predefined concatenation operation. The resulting type is
1157
      --  obtained from the arguments when possible. If the arguments are
1158
      --  aggregates, the array type and the concatenation type must be
1159
      --  visible.
1160
 
1161
      if Present (Op_Id) then
1162
         if Ekind (Op_Id) = E_Operator then
1163
 
1164
            LT := Base_Type (Etype (L));
1165
            RT := Base_Type (Etype (R));
1166
 
1167
            if Is_Array_Type (LT)
1168
              and then (RT = LT or else RT = Base_Type (Component_Type (LT)))
1169
            then
1170
               Add_One_Interp (N, Op_Id, LT);
1171
 
1172
            elsif Is_Array_Type (RT)
1173
              and then LT = Base_Type (Component_Type (RT))
1174
            then
1175
               Add_One_Interp (N, Op_Id, RT);
1176
 
1177
            --  If one operand is a string type or a user-defined array type,
1178
            --  and the other is a literal, result is of the specific type.
1179
 
1180
            elsif
1181
              (Root_Type (LT) = Standard_String
1182
                 or else Scope (LT) /= Standard_Standard)
1183
              and then Etype (R) = Any_String
1184
            then
1185
               Add_One_Interp (N, Op_Id, LT);
1186
 
1187
            elsif
1188
              (Root_Type (RT) = Standard_String
1189
                 or else Scope (RT) /= Standard_Standard)
1190
              and then Etype (L) = Any_String
1191
            then
1192
               Add_One_Interp (N, Op_Id, RT);
1193
 
1194
            elsif not Is_Generic_Type (Etype (Op_Id)) then
1195
               Add_One_Interp (N, Op_Id, Etype (Op_Id));
1196
 
1197
            else
1198
               --  Type and its operations must be visible
1199
 
1200
               Set_Entity (N, Empty);
1201
               Analyze_Concatenation (N);
1202
            end if;
1203
 
1204
         else
1205
            Add_One_Interp (N, Op_Id, Etype (Op_Id));
1206
         end if;
1207
 
1208
      else
1209
         Op_Id := Get_Name_Entity_Id (Name_Op_Concat);
1210
         while Present (Op_Id) loop
1211
            if Ekind (Op_Id) = E_Operator then
1212
 
1213
               --  Do not consider operators declared in dead code, they can
1214
               --  not be part of the resolution.
1215
 
1216
               if Is_Eliminated (Op_Id) then
1217
                  null;
1218
               else
1219
                  Find_Concatenation_Types (L, R, Op_Id, N);
1220
               end if;
1221
 
1222
            else
1223
               Analyze_User_Defined_Binary_Op (N, Op_Id);
1224
            end if;
1225
 
1226
            Op_Id := Homonym (Op_Id);
1227
         end loop;
1228
      end if;
1229
 
1230
      Operator_Check (N);
1231
   end Analyze_Concatenation_Rest;
1232
 
1233
   ------------------------------------
1234
   -- Analyze_Conditional_Expression --
1235
   ------------------------------------
1236
 
1237
   procedure Analyze_Conditional_Expression (N : Node_Id) is
1238
      Condition : constant Node_Id := First (Expressions (N));
1239
      Then_Expr : constant Node_Id := Next (Condition);
1240
      Else_Expr : constant Node_Id := Next (Then_Expr);
1241
 
1242
   begin
1243
      if Comes_From_Source (N) then
1244
         Check_Compiler_Unit (N);
1245
      end if;
1246
 
1247
      Analyze_Expression (Condition);
1248
      Analyze_Expression (Then_Expr);
1249
 
1250
      if Present (Else_Expr) then
1251
         Analyze_Expression (Else_Expr);
1252
      end if;
1253
 
1254
      if not Is_Overloaded (Then_Expr) then
1255
         Set_Etype (N, Etype (Then_Expr));
1256
      else
1257
         declare
1258
            I  : Interp_Index;
1259
            It : Interp;
1260
 
1261
         begin
1262
            Set_Etype (N, Any_Type);
1263
            Get_First_Interp (Then_Expr, I, It);
1264
            while Present (It.Nam) loop
1265
               if Has_Compatible_Type (Else_Expr, It.Typ) then
1266
                  Add_One_Interp (N, It.Typ, It.Typ);
1267
               end if;
1268
 
1269
               Get_Next_Interp (I, It);
1270
            end loop;
1271
         end;
1272
      end if;
1273
   end Analyze_Conditional_Expression;
1274
 
1275
   -------------------------
1276
   -- Analyze_Equality_Op --
1277
   -------------------------
1278
 
1279
   procedure Analyze_Equality_Op (N : Node_Id) is
1280
      Loc   : constant Source_Ptr := Sloc (N);
1281
      L     : constant Node_Id := Left_Opnd (N);
1282
      R     : constant Node_Id := Right_Opnd (N);
1283
      Op_Id : Entity_Id;
1284
 
1285
   begin
1286
      Set_Etype (N, Any_Type);
1287
      Candidate_Type := Empty;
1288
 
1289
      Analyze_Expression (L);
1290
      Analyze_Expression (R);
1291
 
1292
      --  If the entity is set, the node is a generic instance with a non-local
1293
      --  reference to the predefined operator or to a user-defined function.
1294
      --  It can also be an inequality that is expanded into the negation of a
1295
      --  call to a user-defined equality operator.
1296
 
1297
      --  For the predefined case, the result is Boolean, regardless of the
1298
      --  type of the  operands. The operands may even be limited, if they are
1299
      --  generic actuals. If they are overloaded, label the left argument with
1300
      --  the common type that must be present, or with the type of the formal
1301
      --  of the user-defined function.
1302
 
1303
      if Present (Entity (N)) then
1304
         Op_Id := Entity (N);
1305
 
1306
         if Ekind (Op_Id) = E_Operator then
1307
            Add_One_Interp (N, Op_Id, Standard_Boolean);
1308
         else
1309
            Add_One_Interp (N, Op_Id, Etype (Op_Id));
1310
         end if;
1311
 
1312
         if Is_Overloaded (L) then
1313
            if Ekind (Op_Id) = E_Operator then
1314
               Set_Etype (L, Intersect_Types (L, R));
1315
            else
1316
               Set_Etype (L, Etype (First_Formal (Op_Id)));
1317
            end if;
1318
         end if;
1319
 
1320
      else
1321
         Op_Id := Get_Name_Entity_Id (Chars (N));
1322
         while Present (Op_Id) loop
1323
            if Ekind (Op_Id) = E_Operator then
1324
               Find_Equality_Types (L, R, Op_Id, N);
1325
            else
1326
               Analyze_User_Defined_Binary_Op (N, Op_Id);
1327
            end if;
1328
 
1329
            Op_Id := Homonym (Op_Id);
1330
         end loop;
1331
      end if;
1332
 
1333
      --  If there was no match, and the operator is inequality, this may
1334
      --  be a case where inequality has not been made explicit, as for
1335
      --  tagged types. Analyze the node as the negation of an equality
1336
      --  operation. This cannot be done earlier, because before analysis
1337
      --  we cannot rule out the presence of an explicit inequality.
1338
 
1339
      if Etype (N) = Any_Type
1340
        and then Nkind (N) = N_Op_Ne
1341
      then
1342
         Op_Id := Get_Name_Entity_Id (Name_Op_Eq);
1343
         while Present (Op_Id) loop
1344
            if Ekind (Op_Id) = E_Operator then
1345
               Find_Equality_Types (L, R, Op_Id, N);
1346
            else
1347
               Analyze_User_Defined_Binary_Op (N, Op_Id);
1348
            end if;
1349
 
1350
            Op_Id := Homonym (Op_Id);
1351
         end loop;
1352
 
1353
         if Etype (N) /= Any_Type then
1354
            Op_Id := Entity (N);
1355
 
1356
            Rewrite (N,
1357
              Make_Op_Not (Loc,
1358
                Right_Opnd =>
1359
                  Make_Op_Eq (Loc,
1360
                    Left_Opnd  => Left_Opnd (N),
1361
                    Right_Opnd => Right_Opnd (N))));
1362
 
1363
            Set_Entity (Right_Opnd (N), Op_Id);
1364
            Analyze (N);
1365
         end if;
1366
      end if;
1367
 
1368
      Operator_Check (N);
1369
   end Analyze_Equality_Op;
1370
 
1371
   ----------------------------------
1372
   -- Analyze_Explicit_Dereference --
1373
   ----------------------------------
1374
 
1375
   procedure Analyze_Explicit_Dereference (N : Node_Id) is
1376
      Loc   : constant Source_Ptr := Sloc (N);
1377
      P     : constant Node_Id := Prefix (N);
1378
      T     : Entity_Id;
1379
      I     : Interp_Index;
1380
      It    : Interp;
1381
      New_N : Node_Id;
1382
 
1383
      function Is_Function_Type return Boolean;
1384
      --  Check whether node may be interpreted as an implicit function call
1385
 
1386
      ----------------------
1387
      -- Is_Function_Type --
1388
      ----------------------
1389
 
1390
      function Is_Function_Type return Boolean is
1391
         I  : Interp_Index;
1392
         It : Interp;
1393
 
1394
      begin
1395
         if not Is_Overloaded (N) then
1396
            return Ekind (Base_Type (Etype (N))) = E_Subprogram_Type
1397
              and then Etype (Base_Type (Etype (N))) /= Standard_Void_Type;
1398
 
1399
         else
1400
            Get_First_Interp (N, I, It);
1401
            while Present (It.Nam) loop
1402
               if Ekind (Base_Type (It.Typ)) /= E_Subprogram_Type
1403
                 or else Etype (Base_Type (It.Typ)) = Standard_Void_Type
1404
               then
1405
                  return False;
1406
               end if;
1407
 
1408
               Get_Next_Interp (I, It);
1409
            end loop;
1410
 
1411
            return True;
1412
         end if;
1413
      end Is_Function_Type;
1414
 
1415
   --  Start of processing for Analyze_Explicit_Dereference
1416
 
1417
   begin
1418
      Analyze (P);
1419
      Set_Etype (N, Any_Type);
1420
 
1421
      --  Test for remote access to subprogram type, and if so return
1422
      --  after rewriting the original tree.
1423
 
1424
      if Remote_AST_E_Dereference (P) then
1425
         return;
1426
      end if;
1427
 
1428
      --  Normal processing for other than remote access to subprogram type
1429
 
1430
      if not Is_Overloaded (P) then
1431
         if Is_Access_Type (Etype (P)) then
1432
 
1433
            --  Set the Etype. We need to go through Is_For_Access_Subtypes to
1434
            --  avoid other problems caused by the Private_Subtype and it is
1435
            --  safe to go to the Base_Type because this is the same as
1436
            --  converting the access value to its Base_Type.
1437
 
1438
            declare
1439
               DT : Entity_Id := Designated_Type (Etype (P));
1440
 
1441
            begin
1442
               if Ekind (DT) = E_Private_Subtype
1443
                 and then Is_For_Access_Subtype (DT)
1444
               then
1445
                  DT := Base_Type (DT);
1446
               end if;
1447
 
1448
               --  An explicit dereference is a legal occurrence of an
1449
               --  incomplete type imported through a limited_with clause,
1450
               --  if the full view is visible.
1451
 
1452
               if From_With_Type (DT)
1453
                 and then not From_With_Type (Scope (DT))
1454
                 and then
1455
                   (Is_Immediately_Visible (Scope (DT))
1456
                     or else
1457
                       (Is_Child_Unit (Scope (DT))
1458
                          and then Is_Visible_Child_Unit (Scope (DT))))
1459
               then
1460
                  Set_Etype (N, Available_View (DT));
1461
 
1462
               else
1463
                  Set_Etype (N, DT);
1464
               end if;
1465
            end;
1466
 
1467
         elsif Etype (P) /= Any_Type then
1468
            Error_Msg_N ("prefix of dereference must be an access type", N);
1469
            return;
1470
         end if;
1471
 
1472
      else
1473
         Get_First_Interp (P, I, It);
1474
         while Present (It.Nam) loop
1475
            T := It.Typ;
1476
 
1477
            if Is_Access_Type (T) then
1478
               Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
1479
            end if;
1480
 
1481
            Get_Next_Interp (I, It);
1482
         end loop;
1483
 
1484
         --  Error if no interpretation of the prefix has an access type
1485
 
1486
         if Etype (N) = Any_Type then
1487
            Error_Msg_N
1488
              ("access type required in prefix of explicit dereference", P);
1489
            Set_Etype (N, Any_Type);
1490
            return;
1491
         end if;
1492
      end if;
1493
 
1494
      if Is_Function_Type
1495
        and then Nkind (Parent (N)) /= N_Indexed_Component
1496
 
1497
        and then (Nkind (Parent (N)) /= N_Function_Call
1498
                   or else N /= Name (Parent (N)))
1499
 
1500
        and then (Nkind (Parent (N)) /= N_Procedure_Call_Statement
1501
                   or else N /= Name (Parent (N)))
1502
 
1503
        and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
1504
        and then (Nkind (Parent (N)) /= N_Attribute_Reference
1505
                    or else
1506
                      (Attribute_Name (Parent (N)) /= Name_Address
1507
                        and then
1508
                       Attribute_Name (Parent (N)) /= Name_Access))
1509
      then
1510
         --  Name is a function call with no actuals, in a context that
1511
         --  requires deproceduring (including as an actual in an enclosing
1512
         --  function or procedure call). There are some pathological cases
1513
         --  where the prefix might include functions that return access to
1514
         --  subprograms and others that return a regular type. Disambiguation
1515
         --  of those has to take place in Resolve.
1516
 
1517
         New_N :=
1518
           Make_Function_Call (Loc,
1519
           Name => Make_Explicit_Dereference (Loc, P),
1520
           Parameter_Associations => New_List);
1521
 
1522
         --  If the prefix is overloaded, remove operations that have formals,
1523
         --  we know that this is a parameterless call.
1524
 
1525
         if Is_Overloaded (P) then
1526
            Get_First_Interp (P, I, It);
1527
            while Present (It.Nam) loop
1528
               T := It.Typ;
1529
 
1530
               if No (First_Formal (Base_Type (Designated_Type (T)))) then
1531
                  Set_Etype (P, T);
1532
               else
1533
                  Remove_Interp (I);
1534
               end if;
1535
 
1536
               Get_Next_Interp (I, It);
1537
            end loop;
1538
         end if;
1539
 
1540
         Rewrite (N, New_N);
1541
         Analyze (N);
1542
 
1543
      elsif not Is_Function_Type
1544
        and then Is_Overloaded (N)
1545
      then
1546
         --  The prefix may include access to subprograms and other access
1547
         --  types. If the context selects the interpretation that is a
1548
         --  function call (not a procedure call) we cannot rewrite the node
1549
         --  yet, but we include the result of the call interpretation.
1550
 
1551
         Get_First_Interp (N, I, It);
1552
         while Present (It.Nam) loop
1553
            if Ekind (Base_Type (It.Typ)) = E_Subprogram_Type
1554
               and then Etype (Base_Type (It.Typ)) /= Standard_Void_Type
1555
               and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
1556
            then
1557
               Add_One_Interp (N, Etype (It.Typ), Etype (It.Typ));
1558
            end if;
1559
 
1560
            Get_Next_Interp (I, It);
1561
         end loop;
1562
      end if;
1563
 
1564
      --  A value of remote access-to-class-wide must not be dereferenced
1565
      --  (RM E.2.2(16)).
1566
 
1567
      Validate_Remote_Access_To_Class_Wide_Type (N);
1568
   end Analyze_Explicit_Dereference;
1569
 
1570
   ------------------------
1571
   -- Analyze_Expression --
1572
   ------------------------
1573
 
1574
   procedure Analyze_Expression (N : Node_Id) is
1575
   begin
1576
      Analyze (N);
1577
      Check_Parameterless_Call (N);
1578
   end Analyze_Expression;
1579
 
1580
   ------------------------------------
1581
   -- Analyze_Indexed_Component_Form --
1582
   ------------------------------------
1583
 
1584
   procedure Analyze_Indexed_Component_Form (N : Node_Id) is
1585
      P     : constant Node_Id := Prefix (N);
1586
      Exprs : constant List_Id := Expressions (N);
1587
      Exp   : Node_Id;
1588
      P_T   : Entity_Id;
1589
      E     : Node_Id;
1590
      U_N   : Entity_Id;
1591
 
1592
      procedure Process_Function_Call;
1593
      --  Prefix in indexed component form is an overloadable entity,
1594
      --  so the node is a function call. Reformat it as such.
1595
 
1596
      procedure Process_Indexed_Component;
1597
      --  Prefix in indexed component form is actually an indexed component.
1598
      --  This routine processes it, knowing that the prefix is already
1599
      --  resolved.
1600
 
1601
      procedure Process_Indexed_Component_Or_Slice;
1602
      --  An indexed component with a single index may designate a slice if
1603
      --  the index is a subtype mark. This routine disambiguates these two
1604
      --  cases by resolving the prefix to see if it is a subtype mark.
1605
 
1606
      procedure Process_Overloaded_Indexed_Component;
1607
      --  If the prefix of an indexed component is overloaded, the proper
1608
      --  interpretation is selected by the index types and the context.
1609
 
1610
      ---------------------------
1611
      -- Process_Function_Call --
1612
      ---------------------------
1613
 
1614
      procedure Process_Function_Call is
1615
         Actual : Node_Id;
1616
 
1617
      begin
1618
         Change_Node (N, N_Function_Call);
1619
         Set_Name (N, P);
1620
         Set_Parameter_Associations (N, Exprs);
1621
 
1622
         --  Analyze actuals prior to analyzing the call itself
1623
 
1624
         Actual := First (Parameter_Associations (N));
1625
         while Present (Actual) loop
1626
            Analyze (Actual);
1627
            Check_Parameterless_Call (Actual);
1628
 
1629
            --  Move to next actual. Note that we use Next, not Next_Actual
1630
            --  here. The reason for this is a bit subtle. If a function call
1631
            --  includes named associations, the parser recognizes the node as
1632
            --  a call, and it is analyzed as such. If all associations are
1633
            --  positional, the parser builds an indexed_component node, and
1634
            --  it is only after analysis of the prefix that the construct
1635
            --  is recognized as a call, in which case Process_Function_Call
1636
            --  rewrites the node and analyzes the actuals. If the list of
1637
            --  actuals is malformed, the parser may leave the node as an
1638
            --  indexed component (despite the presence of named associations).
1639
            --  The iterator Next_Actual is equivalent to Next if the list is
1640
            --  positional, but follows the normalized chain of actuals when
1641
            --  named associations are present. In this case normalization has
1642
            --  not taken place, and actuals remain unanalyzed, which leads to
1643
            --  subsequent crashes or loops if there is an attempt to continue
1644
            --  analysis of the program.
1645
 
1646
            Next (Actual);
1647
         end loop;
1648
 
1649
         Analyze_Call (N);
1650
      end Process_Function_Call;
1651
 
1652
      -------------------------------
1653
      -- Process_Indexed_Component --
1654
      -------------------------------
1655
 
1656
      procedure Process_Indexed_Component is
1657
         Exp        : Node_Id;
1658
         Array_Type : Entity_Id;
1659
         Index      : Node_Id;
1660
         Pent       : Entity_Id := Empty;
1661
 
1662
      begin
1663
         Exp := First (Exprs);
1664
 
1665
         if Is_Overloaded (P) then
1666
            Process_Overloaded_Indexed_Component;
1667
 
1668
         else
1669
            Array_Type := Etype (P);
1670
 
1671
            if Is_Entity_Name (P) then
1672
               Pent := Entity (P);
1673
            elsif Nkind (P) = N_Selected_Component
1674
              and then Is_Entity_Name (Selector_Name (P))
1675
            then
1676
               Pent := Entity (Selector_Name (P));
1677
            end if;
1678
 
1679
            --  Prefix must be appropriate for an array type, taking into
1680
            --  account a possible implicit dereference.
1681
 
1682
            if Is_Access_Type (Array_Type) then
1683
               Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
1684
               Array_Type := Process_Implicit_Dereference_Prefix (Pent, P);
1685
            end if;
1686
 
1687
            if Is_Array_Type (Array_Type) then
1688
               null;
1689
 
1690
            elsif Present (Pent) and then Ekind (Pent) = E_Entry_Family then
1691
               Analyze (Exp);
1692
               Set_Etype (N, Any_Type);
1693
 
1694
               if not Has_Compatible_Type
1695
                 (Exp, Entry_Index_Type (Pent))
1696
               then
1697
                  Error_Msg_N ("invalid index type in entry name", N);
1698
 
1699
               elsif Present (Next (Exp)) then
1700
                  Error_Msg_N ("too many subscripts in entry reference", N);
1701
 
1702
               else
1703
                  Set_Etype (N,  Etype (P));
1704
               end if;
1705
 
1706
               return;
1707
 
1708
            elsif Is_Record_Type (Array_Type)
1709
              and then Remote_AST_I_Dereference (P)
1710
            then
1711
               return;
1712
 
1713
            elsif Array_Type = Any_Type then
1714
               Set_Etype (N, Any_Type);
1715
 
1716
               --  In most cases the analysis of the prefix will have emitted
1717
               --  an error already, but if the prefix may be interpreted as a
1718
               --  call in prefixed notation, the report is left to the caller.
1719
               --  To prevent cascaded errors, report only if no previous ones.
1720
 
1721
               if Serious_Errors_Detected = 0 then
1722
                  Error_Msg_N ("invalid prefix in indexed component", P);
1723
 
1724
                  if Nkind (P) = N_Expanded_Name then
1725
                     Error_Msg_NE ("\& is not visible", P, Selector_Name (P));
1726
                  end if;
1727
               end if;
1728
 
1729
               return;
1730
 
1731
            --  Here we definitely have a bad indexing
1732
 
1733
            else
1734
               if Nkind (Parent (N)) = N_Requeue_Statement
1735
                 and then Present (Pent) and then Ekind (Pent) = E_Entry
1736
               then
1737
                  Error_Msg_N
1738
                    ("REQUEUE does not permit parameters", First (Exprs));
1739
 
1740
               elsif Is_Entity_Name (P)
1741
                 and then Etype (P) = Standard_Void_Type
1742
               then
1743
                  Error_Msg_NE ("incorrect use of&", P, Entity (P));
1744
 
1745
               else
1746
                  Error_Msg_N ("array type required in indexed component", P);
1747
               end if;
1748
 
1749
               Set_Etype (N, Any_Type);
1750
               return;
1751
            end if;
1752
 
1753
            Index := First_Index (Array_Type);
1754
            while Present (Index) and then Present (Exp) loop
1755
               if not Has_Compatible_Type (Exp, Etype (Index)) then
1756
                  Wrong_Type (Exp, Etype (Index));
1757
                  Set_Etype (N, Any_Type);
1758
                  return;
1759
               end if;
1760
 
1761
               Next_Index (Index);
1762
               Next (Exp);
1763
            end loop;
1764
 
1765
            Set_Etype (N, Component_Type (Array_Type));
1766
 
1767
            if Present (Index) then
1768
               Error_Msg_N
1769
                 ("too few subscripts in array reference", First (Exprs));
1770
 
1771
            elsif Present (Exp) then
1772
               Error_Msg_N ("too many subscripts in array reference", Exp);
1773
            end if;
1774
         end if;
1775
      end Process_Indexed_Component;
1776
 
1777
      ----------------------------------------
1778
      -- Process_Indexed_Component_Or_Slice --
1779
      ----------------------------------------
1780
 
1781
      procedure Process_Indexed_Component_Or_Slice is
1782
      begin
1783
         Exp := First (Exprs);
1784
         while Present (Exp) loop
1785
            Analyze_Expression (Exp);
1786
            Next (Exp);
1787
         end loop;
1788
 
1789
         Exp := First (Exprs);
1790
 
1791
         --  If one index is present, and it is a subtype name, then the
1792
         --  node denotes a slice (note that the case of an explicit range
1793
         --  for a slice was already built as an N_Slice node in the first
1794
         --  place, so that case is not handled here).
1795
 
1796
         --  We use a replace rather than a rewrite here because this is one
1797
         --  of the cases in which the tree built by the parser is plain wrong.
1798
 
1799
         if No (Next (Exp))
1800
           and then Is_Entity_Name (Exp)
1801
           and then Is_Type (Entity (Exp))
1802
         then
1803
            Replace (N,
1804
               Make_Slice (Sloc (N),
1805
                 Prefix => P,
1806
                 Discrete_Range => New_Copy (Exp)));
1807
            Analyze (N);
1808
 
1809
         --  Otherwise (more than one index present, or single index is not
1810
         --  a subtype name), then we have the indexed component case.
1811
 
1812
         else
1813
            Process_Indexed_Component;
1814
         end if;
1815
      end Process_Indexed_Component_Or_Slice;
1816
 
1817
      ------------------------------------------
1818
      -- Process_Overloaded_Indexed_Component --
1819
      ------------------------------------------
1820
 
1821
      procedure Process_Overloaded_Indexed_Component is
1822
         Exp   : Node_Id;
1823
         I     : Interp_Index;
1824
         It    : Interp;
1825
         Typ   : Entity_Id;
1826
         Index : Node_Id;
1827
         Found : Boolean;
1828
 
1829
      begin
1830
         Set_Etype (N, Any_Type);
1831
 
1832
         Get_First_Interp (P, I, It);
1833
         while Present (It.Nam) loop
1834
            Typ := It.Typ;
1835
 
1836
            if Is_Access_Type (Typ) then
1837
               Typ := Designated_Type (Typ);
1838
               Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
1839
            end if;
1840
 
1841
            if Is_Array_Type (Typ) then
1842
 
1843
               --  Got a candidate: verify that index types are compatible
1844
 
1845
               Index := First_Index (Typ);
1846
               Found := True;
1847
               Exp := First (Exprs);
1848
               while Present (Index) and then Present (Exp) loop
1849
                  if Has_Compatible_Type (Exp, Etype (Index)) then
1850
                     null;
1851
                  else
1852
                     Found := False;
1853
                     Remove_Interp (I);
1854
                     exit;
1855
                  end if;
1856
 
1857
                  Next_Index (Index);
1858
                  Next (Exp);
1859
               end loop;
1860
 
1861
               if Found and then No (Index) and then No (Exp) then
1862
                  Add_One_Interp (N,
1863
                     Etype (Component_Type (Typ)),
1864
                     Etype (Component_Type (Typ)));
1865
               end if;
1866
            end if;
1867
 
1868
            Get_Next_Interp (I, It);
1869
         end loop;
1870
 
1871
         if Etype (N) = Any_Type then
1872
            Error_Msg_N ("no legal interpretation for indexed component", N);
1873
            Set_Is_Overloaded (N, False);
1874
         end if;
1875
 
1876
         End_Interp_List;
1877
      end Process_Overloaded_Indexed_Component;
1878
 
1879
   --  Start of processing for Analyze_Indexed_Component_Form
1880
 
1881
   begin
1882
      --  Get name of array, function or type
1883
 
1884
      Analyze (P);
1885
 
1886
      if Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) then
1887
 
1888
         --  If P is an explicit dereference whose prefix is of a
1889
         --  remote access-to-subprogram type, then N has already
1890
         --  been rewritten as a subprogram call and analyzed.
1891
 
1892
         return;
1893
      end if;
1894
 
1895
      pragma Assert (Nkind (N) = N_Indexed_Component);
1896
 
1897
      P_T := Base_Type (Etype (P));
1898
 
1899
      if Is_Entity_Name (P)
1900
        or else Nkind (P) = N_Operator_Symbol
1901
      then
1902
         U_N := Entity (P);
1903
 
1904
         if Is_Type (U_N) then
1905
 
1906
            --  Reformat node as a type conversion
1907
 
1908
            E := Remove_Head (Exprs);
1909
 
1910
            if Present (First (Exprs)) then
1911
               Error_Msg_N
1912
                ("argument of type conversion must be single expression", N);
1913
            end if;
1914
 
1915
            Change_Node (N, N_Type_Conversion);
1916
            Set_Subtype_Mark (N, P);
1917
            Set_Etype (N, U_N);
1918
            Set_Expression (N, E);
1919
 
1920
            --  After changing the node, call for the specific Analysis
1921
            --  routine directly, to avoid a double call to the expander.
1922
 
1923
            Analyze_Type_Conversion (N);
1924
            return;
1925
         end if;
1926
 
1927
         if Is_Overloadable (U_N) then
1928
            Process_Function_Call;
1929
 
1930
         elsif Ekind (Etype (P)) = E_Subprogram_Type
1931
           or else (Is_Access_Type (Etype (P))
1932
                      and then
1933
                    Ekind (Designated_Type (Etype (P))) = E_Subprogram_Type)
1934
         then
1935
            --  Call to access_to-subprogram with possible implicit dereference
1936
 
1937
            Process_Function_Call;
1938
 
1939
         elsif Is_Generic_Subprogram (U_N) then
1940
 
1941
            --  A common beginner's (or C++ templates fan) error
1942
 
1943
            Error_Msg_N ("generic subprogram cannot be called", N);
1944
            Set_Etype (N, Any_Type);
1945
            return;
1946
 
1947
         else
1948
            Process_Indexed_Component_Or_Slice;
1949
         end if;
1950
 
1951
      --  If not an entity name, prefix is an expression that may denote
1952
      --  an array or an access-to-subprogram.
1953
 
1954
      else
1955
         if Ekind (P_T) = E_Subprogram_Type
1956
           or else (Is_Access_Type (P_T)
1957
                     and then
1958
                    Ekind (Designated_Type (P_T)) = E_Subprogram_Type)
1959
         then
1960
            Process_Function_Call;
1961
 
1962
         elsif Nkind (P) = N_Selected_Component
1963
           and then Is_Overloadable (Entity (Selector_Name (P)))
1964
         then
1965
            Process_Function_Call;
1966
 
1967
         else
1968
            --  Indexed component, slice, or a call to a member of a family
1969
            --  entry, which will be converted to an entry call later.
1970
 
1971
            Process_Indexed_Component_Or_Slice;
1972
         end if;
1973
      end if;
1974
   end Analyze_Indexed_Component_Form;
1975
 
1976
   ------------------------
1977
   -- Analyze_Logical_Op --
1978
   ------------------------
1979
 
1980
   procedure Analyze_Logical_Op (N : Node_Id) is
1981
      L     : constant Node_Id := Left_Opnd (N);
1982
      R     : constant Node_Id := Right_Opnd (N);
1983
      Op_Id : Entity_Id := Entity (N);
1984
 
1985
   begin
1986
      Set_Etype (N, Any_Type);
1987
      Candidate_Type := Empty;
1988
 
1989
      Analyze_Expression (L);
1990
      Analyze_Expression (R);
1991
 
1992
      if Present (Op_Id) then
1993
 
1994
         if Ekind (Op_Id) = E_Operator then
1995
            Find_Boolean_Types (L, R, Op_Id, N);
1996
         else
1997
            Add_One_Interp (N, Op_Id, Etype (Op_Id));
1998
         end if;
1999
 
2000
      else
2001
         Op_Id := Get_Name_Entity_Id (Chars (N));
2002
         while Present (Op_Id) loop
2003
            if Ekind (Op_Id) = E_Operator then
2004
               Find_Boolean_Types (L, R, Op_Id, N);
2005
            else
2006
               Analyze_User_Defined_Binary_Op (N, Op_Id);
2007
            end if;
2008
 
2009
            Op_Id := Homonym (Op_Id);
2010
         end loop;
2011
      end if;
2012
 
2013
      Operator_Check (N);
2014
   end Analyze_Logical_Op;
2015
 
2016
   ---------------------------
2017
   -- Analyze_Membership_Op --
2018
   ---------------------------
2019
 
2020
   procedure Analyze_Membership_Op (N : Node_Id) is
2021
      L     : constant Node_Id := Left_Opnd (N);
2022
      R     : constant Node_Id := Right_Opnd (N);
2023
 
2024
      Index : Interp_Index;
2025
      It    : Interp;
2026
      Found : Boolean := False;
2027
      I_F   : Interp_Index;
2028
      T_F   : Entity_Id;
2029
 
2030
      procedure Try_One_Interp (T1 : Entity_Id);
2031
      --  Routine to try one proposed interpretation. Note that the context
2032
      --  of the operation plays no role in resolving the arguments, so that
2033
      --  if there is more than one interpretation of the operands that is
2034
      --  compatible with a membership test, the operation is ambiguous.
2035
 
2036
      --------------------
2037
      -- Try_One_Interp --
2038
      --------------------
2039
 
2040
      procedure Try_One_Interp (T1 : Entity_Id) is
2041
      begin
2042
         if Has_Compatible_Type (R, T1) then
2043
            if Found
2044
              and then Base_Type (T1) /= Base_Type (T_F)
2045
            then
2046
               It := Disambiguate (L, I_F, Index, Any_Type);
2047
 
2048
               if It = No_Interp then
2049
                  Ambiguous_Operands (N);
2050
                  Set_Etype (L, Any_Type);
2051
                  return;
2052
 
2053
               else
2054
                  T_F := It.Typ;
2055
               end if;
2056
 
2057
            else
2058
               Found := True;
2059
               T_F   := T1;
2060
               I_F   := Index;
2061
            end if;
2062
 
2063
            Set_Etype (L, T_F);
2064
         end if;
2065
      end Try_One_Interp;
2066
 
2067
      procedure Analyze_Set_Membership;
2068
      --  If a set of alternatives is present, analyze each and find the
2069
      --  common type to which they must all resolve.
2070
 
2071
      ----------------------------
2072
      -- Analyze_Set_Membership --
2073
      ----------------------------
2074
 
2075
      procedure Analyze_Set_Membership is
2076
         Alt               : Node_Id;
2077
         Index             : Interp_Index;
2078
         It                : Interp;
2079
         Candidate_Interps : Node_Id;
2080
         Common_Type       : Entity_Id := Empty;
2081
 
2082
      begin
2083
         Analyze (L);
2084
         Candidate_Interps := L;
2085
 
2086
         if not Is_Overloaded (L) then
2087
            Common_Type := Etype (L);
2088
 
2089
            Alt := First (Alternatives (N));
2090
            while Present (Alt) loop
2091
               Analyze (Alt);
2092
 
2093
               if not Has_Compatible_Type (Alt, Common_Type) then
2094
                  Wrong_Type (Alt, Common_Type);
2095
               end if;
2096
 
2097
               Next (Alt);
2098
            end loop;
2099
 
2100
         else
2101
            Alt := First (Alternatives (N));
2102
            while Present (Alt) loop
2103
               Analyze (Alt);
2104
               if not Is_Overloaded (Alt) then
2105
                  Common_Type := Etype (Alt);
2106
 
2107
               else
2108
                  Get_First_Interp (Alt, Index, It);
2109
                  while Present (It.Typ) loop
2110
                     if not
2111
                       Has_Compatible_Type (Candidate_Interps, It.Typ)
2112
                     then
2113
                        Remove_Interp (Index);
2114
                     end if;
2115
 
2116
                     Get_Next_Interp (Index, It);
2117
                  end loop;
2118
 
2119
                  Get_First_Interp (Alt, Index, It);
2120
 
2121
                  if No (It.Typ) then
2122
                     Error_Msg_N ("alternative has no legal type", Alt);
2123
                     return;
2124
                  end if;
2125
 
2126
                  --  If alternative is not overloaded, we have a unique type
2127
                  --  for all of them.
2128
 
2129
                  Set_Etype (Alt, It.Typ);
2130
                  Get_Next_Interp (Index, It);
2131
 
2132
                  if No (It.Typ) then
2133
                     Set_Is_Overloaded (Alt, False);
2134
                     Common_Type := Etype (Alt);
2135
                  end if;
2136
 
2137
                  Candidate_Interps := Alt;
2138
               end if;
2139
 
2140
               Next (Alt);
2141
            end loop;
2142
         end if;
2143
 
2144
         Set_Etype (N, Standard_Boolean);
2145
 
2146
         if Present (Common_Type) then
2147
            Set_Etype (L, Common_Type);
2148
            Set_Is_Overloaded (L, False);
2149
 
2150
         else
2151
            Error_Msg_N ("cannot resolve membership operation", N);
2152
         end if;
2153
      end Analyze_Set_Membership;
2154
 
2155
   --  Start of processing for Analyze_Membership_Op
2156
 
2157
   begin
2158
      Analyze_Expression (L);
2159
 
2160
      if No (R)
2161
        and then Extensions_Allowed
2162
      then
2163
         Analyze_Set_Membership;
2164
         return;
2165
      end if;
2166
 
2167
      if Nkind (R) = N_Range
2168
        or else (Nkind (R) = N_Attribute_Reference
2169
                  and then Attribute_Name (R) = Name_Range)
2170
      then
2171
         Analyze (R);
2172
 
2173
         if not Is_Overloaded (L) then
2174
            Try_One_Interp (Etype (L));
2175
 
2176
         else
2177
            Get_First_Interp (L, Index, It);
2178
            while Present (It.Typ) loop
2179
               Try_One_Interp (It.Typ);
2180
               Get_Next_Interp (Index, It);
2181
            end loop;
2182
         end if;
2183
 
2184
      --  If not a range, it can only be a subtype mark, or else there
2185
      --  is a more basic error, to be diagnosed in Find_Type.
2186
 
2187
      else
2188
         Find_Type (R);
2189
 
2190
         if Is_Entity_Name (R) then
2191
            Check_Fully_Declared (Entity (R), R);
2192
         end if;
2193
      end if;
2194
 
2195
      --  Compatibility between expression and subtype mark or range is
2196
      --  checked during resolution. The result of the operation is Boolean
2197
      --  in any case.
2198
 
2199
      Set_Etype (N, Standard_Boolean);
2200
 
2201
      if Comes_From_Source (N)
2202
        and then Present (Right_Opnd (N))
2203
        and then Is_CPP_Class (Etype (Etype (Right_Opnd (N))))
2204
      then
2205
         Error_Msg_N ("membership test not applicable to cpp-class types", N);
2206
      end if;
2207
   end Analyze_Membership_Op;
2208
 
2209
   ----------------------
2210
   -- Analyze_Negation --
2211
   ----------------------
2212
 
2213
   procedure Analyze_Negation (N : Node_Id) is
2214
      R     : constant Node_Id := Right_Opnd (N);
2215
      Op_Id : Entity_Id := Entity (N);
2216
 
2217
   begin
2218
      Set_Etype (N, Any_Type);
2219
      Candidate_Type := Empty;
2220
 
2221
      Analyze_Expression (R);
2222
 
2223
      if Present (Op_Id) then
2224
         if Ekind (Op_Id) = E_Operator then
2225
            Find_Negation_Types (R, Op_Id, N);
2226
         else
2227
            Add_One_Interp (N, Op_Id, Etype (Op_Id));
2228
         end if;
2229
 
2230
      else
2231
         Op_Id := Get_Name_Entity_Id (Chars (N));
2232
         while Present (Op_Id) loop
2233
            if Ekind (Op_Id) = E_Operator then
2234
               Find_Negation_Types (R, Op_Id, N);
2235
            else
2236
               Analyze_User_Defined_Unary_Op (N, Op_Id);
2237
            end if;
2238
 
2239
            Op_Id := Homonym (Op_Id);
2240
         end loop;
2241
      end if;
2242
 
2243
      Operator_Check (N);
2244
   end Analyze_Negation;
2245
 
2246
   ------------------
2247
   -- Analyze_Null --
2248
   ------------------
2249
 
2250
   procedure Analyze_Null (N : Node_Id) is
2251
   begin
2252
      Set_Etype (N, Any_Access);
2253
   end Analyze_Null;
2254
 
2255
   ----------------------
2256
   -- Analyze_One_Call --
2257
   ----------------------
2258
 
2259
   procedure Analyze_One_Call
2260
      (N          : Node_Id;
2261
       Nam        : Entity_Id;
2262
       Report     : Boolean;
2263
       Success    : out Boolean;
2264
       Skip_First : Boolean := False)
2265
   is
2266
      Actuals : constant List_Id   := Parameter_Associations (N);
2267
      Prev_T  : constant Entity_Id := Etype (N);
2268
 
2269
      Must_Skip  : constant Boolean := Skip_First
2270
                     or else Nkind (Original_Node (N)) = N_Selected_Component
2271
                     or else
2272
                       (Nkind (Original_Node (N)) = N_Indexed_Component
2273
                          and then Nkind (Prefix (Original_Node (N)))
2274
                            = N_Selected_Component);
2275
      --  The first formal must be omitted from the match when trying to find
2276
      --  a primitive operation that is a possible interpretation, and also
2277
      --  after the call has been rewritten, because the corresponding actual
2278
      --  is already known to be compatible, and because this may be an
2279
      --  indexing of a call with default parameters.
2280
 
2281
      Formal      : Entity_Id;
2282
      Actual      : Node_Id;
2283
      Is_Indexed  : Boolean := False;
2284
      Is_Indirect : Boolean := False;
2285
      Subp_Type   : constant Entity_Id := Etype (Nam);
2286
      Norm_OK     : Boolean;
2287
 
2288
      function Operator_Hidden_By (Fun : Entity_Id) return Boolean;
2289
      --  There may be a user-defined operator that hides the current
2290
      --  interpretation. We must check for this independently of the
2291
      --  analysis of the call with the user-defined operation, because
2292
      --  the parameter names may be wrong and yet the hiding takes place.
2293
      --  This fixes a problem with ACATS test B34014O.
2294
      --
2295
      --  When the type Address is a visible integer type, and the DEC
2296
      --  system extension is visible, the predefined operator may be
2297
      --  hidden as well, by one of the address operations in auxdec.
2298
      --  Finally, The abstract operations on address do not hide the
2299
      --  predefined operator (this is the purpose of making them abstract).
2300
 
2301
      procedure Indicate_Name_And_Type;
2302
      --  If candidate interpretation matches, indicate name and type of
2303
      --  result on call node.
2304
 
2305
      ----------------------------
2306
      -- Indicate_Name_And_Type --
2307
      ----------------------------
2308
 
2309
      procedure Indicate_Name_And_Type is
2310
      begin
2311
         Add_One_Interp (N, Nam, Etype (Nam));
2312
         Success := True;
2313
 
2314
         --  If the prefix of the call is a name, indicate the entity
2315
         --  being called. If it is not a name,  it is an expression that
2316
         --  denotes an access to subprogram or else an entry or family. In
2317
         --  the latter case, the name is a selected component, and the entity
2318
         --  being called is noted on the selector.
2319
 
2320
         if not Is_Type (Nam) then
2321
            if Is_Entity_Name (Name (N))
2322
              or else Nkind (Name (N)) = N_Operator_Symbol
2323
            then
2324
               Set_Entity (Name (N), Nam);
2325
 
2326
            elsif Nkind (Name (N)) = N_Selected_Component then
2327
               Set_Entity (Selector_Name (Name (N)),  Nam);
2328
            end if;
2329
         end if;
2330
 
2331
         if Debug_Flag_E and not Report then
2332
            Write_Str (" Overloaded call ");
2333
            Write_Int (Int (N));
2334
            Write_Str (" compatible with ");
2335
            Write_Int (Int (Nam));
2336
            Write_Eol;
2337
         end if;
2338
      end Indicate_Name_And_Type;
2339
 
2340
      ------------------------
2341
      -- Operator_Hidden_By --
2342
      ------------------------
2343
 
2344
      function Operator_Hidden_By (Fun : Entity_Id) return Boolean is
2345
         Act1  : constant Node_Id   := First_Actual (N);
2346
         Act2  : constant Node_Id   := Next_Actual (Act1);
2347
         Form1 : constant Entity_Id := First_Formal (Fun);
2348
         Form2 : constant Entity_Id := Next_Formal (Form1);
2349
 
2350
      begin
2351
         if Ekind (Fun) /= E_Function
2352
           or else Is_Abstract_Subprogram (Fun)
2353
         then
2354
            return False;
2355
 
2356
         elsif not Has_Compatible_Type (Act1, Etype (Form1)) then
2357
            return False;
2358
 
2359
         elsif Present (Form2) then
2360
            if
2361
              No (Act2) or else not Has_Compatible_Type (Act2, Etype (Form2))
2362
            then
2363
               return False;
2364
            end if;
2365
 
2366
         elsif Present (Act2) then
2367
            return False;
2368
         end if;
2369
 
2370
         --  Now we know that the arity of the operator matches the function,
2371
         --  and the function call is a valid interpretation. The function
2372
         --  hides the operator if it has the right signature, or if one of
2373
         --  its operands is a non-abstract operation on Address when this is
2374
         --  a visible integer type.
2375
 
2376
         return Hides_Op (Fun, Nam)
2377
           or else Is_Descendent_Of_Address (Etype (Form1))
2378
           or else
2379
             (Present (Form2)
2380
               and then Is_Descendent_Of_Address (Etype (Form2)));
2381
      end Operator_Hidden_By;
2382
 
2383
   --  Start of processing for Analyze_One_Call
2384
 
2385
   begin
2386
      Success := False;
2387
 
2388
      --  If the subprogram has no formals or if all the formals have defaults,
2389
      --  and the return type is an array type, the node may denote an indexing
2390
      --  of the result of a parameterless call. In Ada 2005, the subprogram
2391
      --  may have one non-defaulted formal, and the call may have been written
2392
      --  in prefix notation, so that the rebuilt parameter list has more than
2393
      --  one actual.
2394
 
2395
      if not Is_Overloadable (Nam)
2396
        and then Ekind (Nam) /= E_Subprogram_Type
2397
        and then Ekind (Nam) /= E_Entry_Family
2398
      then
2399
         return;
2400
      end if;
2401
 
2402
      --  An indexing requires at least one actual
2403
 
2404
      if not Is_Empty_List (Actuals)
2405
        and then
2406
          (Needs_No_Actuals (Nam)
2407
            or else
2408
              (Needs_One_Actual (Nam)
2409
                 and then Present (Next_Actual (First (Actuals)))))
2410
      then
2411
         if Is_Array_Type (Subp_Type) then
2412
            Is_Indexed := Try_Indexed_Call (N, Nam, Subp_Type, Must_Skip);
2413
 
2414
         elsif Is_Access_Type (Subp_Type)
2415
           and then Is_Array_Type (Designated_Type (Subp_Type))
2416
         then
2417
            Is_Indexed :=
2418
              Try_Indexed_Call
2419
                (N, Nam, Designated_Type (Subp_Type), Must_Skip);
2420
 
2421
         --  The prefix can also be a parameterless function that returns an
2422
         --  access to subprogram, in which case this is an indirect call.
2423
         --  If this succeeds, an explicit dereference is added later on,
2424
         --  in Analyze_Call or Resolve_Call.
2425
 
2426
         elsif Is_Access_Type (Subp_Type)
2427
           and then Ekind (Designated_Type (Subp_Type)) = E_Subprogram_Type
2428
         then
2429
            Is_Indirect := Try_Indirect_Call (N, Nam, Subp_Type);
2430
         end if;
2431
 
2432
      end if;
2433
 
2434
      --  If the call has been transformed into a slice, it is of the form
2435
      --  F (Subtype) where F is parameterless. The node has been rewritten in
2436
      --  Try_Indexed_Call and there is nothing else to do.
2437
 
2438
      if Is_Indexed
2439
        and then  Nkind (N) = N_Slice
2440
      then
2441
         return;
2442
      end if;
2443
 
2444
      Normalize_Actuals
2445
        (N, Nam, (Report and not Is_Indexed and not Is_Indirect), Norm_OK);
2446
 
2447
      if not Norm_OK then
2448
 
2449
         --  If an indirect call is a possible interpretation, indicate
2450
         --  success to the caller.
2451
 
2452
         if Is_Indirect then
2453
            Success := True;
2454
            return;
2455
 
2456
         --  Mismatch in number or names of parameters
2457
 
2458
         elsif Debug_Flag_E then
2459
            Write_Str (" normalization fails in call ");
2460
            Write_Int (Int (N));
2461
            Write_Str (" with subprogram ");
2462
            Write_Int (Int (Nam));
2463
            Write_Eol;
2464
         end if;
2465
 
2466
      --  If the context expects a function call, discard any interpretation
2467
      --  that is a procedure. If the node is not overloaded, leave as is for
2468
      --  better error reporting when type mismatch is found.
2469
 
2470
      elsif Nkind (N) = N_Function_Call
2471
        and then Is_Overloaded (Name (N))
2472
        and then Ekind (Nam) = E_Procedure
2473
      then
2474
         return;
2475
 
2476
      --  Ditto for function calls in a procedure context
2477
 
2478
      elsif Nkind (N) = N_Procedure_Call_Statement
2479
         and then Is_Overloaded (Name (N))
2480
         and then Etype (Nam) /= Standard_Void_Type
2481
      then
2482
         return;
2483
 
2484
      elsif No (Actuals) then
2485
 
2486
         --  If Normalize succeeds, then there are default parameters for
2487
         --  all formals.
2488
 
2489
         Indicate_Name_And_Type;
2490
 
2491
      elsif Ekind (Nam) = E_Operator then
2492
         if Nkind (N) = N_Procedure_Call_Statement then
2493
            return;
2494
         end if;
2495
 
2496
         --  This can occur when the prefix of the call is an operator
2497
         --  name or an expanded name whose selector is an operator name.
2498
 
2499
         Analyze_Operator_Call (N, Nam);
2500
 
2501
         if Etype (N) /= Prev_T then
2502
 
2503
            --  Check that operator is not hidden by a function interpretation
2504
 
2505
            if Is_Overloaded (Name (N)) then
2506
               declare
2507
                  I  : Interp_Index;
2508
                  It : Interp;
2509
 
2510
               begin
2511
                  Get_First_Interp (Name (N), I, It);
2512
                  while Present (It.Nam) loop
2513
                     if Operator_Hidden_By (It.Nam) then
2514
                        Set_Etype (N, Prev_T);
2515
                        return;
2516
                     end if;
2517
 
2518
                     Get_Next_Interp (I, It);
2519
                  end loop;
2520
               end;
2521
            end if;
2522
 
2523
            --  If operator matches formals, record its name on the call.
2524
            --  If the operator is overloaded, Resolve will select the
2525
            --  correct one from the list of interpretations. The call
2526
            --  node itself carries the first candidate.
2527
 
2528
            Set_Entity (Name (N), Nam);
2529
            Success := True;
2530
 
2531
         elsif Report and then Etype (N) = Any_Type then
2532
            Error_Msg_N ("incompatible arguments for operator", N);
2533
         end if;
2534
 
2535
      else
2536
         --  Normalize_Actuals has chained the named associations in the
2537
         --  correct order of the formals.
2538
 
2539
         Actual := First_Actual (N);
2540
         Formal := First_Formal (Nam);
2541
 
2542
         --  If we are analyzing a call rewritten from object notation,
2543
         --  skip first actual, which may be rewritten later as an
2544
         --  explicit dereference.
2545
 
2546
         if Must_Skip then
2547
            Next_Actual (Actual);
2548
            Next_Formal (Formal);
2549
         end if;
2550
 
2551
         while Present (Actual) and then Present (Formal) loop
2552
            if Nkind (Parent (Actual)) /= N_Parameter_Association
2553
              or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal)
2554
            then
2555
               --  The actual can be compatible with the formal, but we must
2556
               --  also check that the context is not an address type that is
2557
               --  visibly an integer type, as is the case in VMS_64. In this
2558
               --  case the use of literals is illegal, except in the body of
2559
               --  descendents of system, where arithmetic operations on
2560
               --  address are of course used.
2561
 
2562
               if Has_Compatible_Type (Actual, Etype (Formal))
2563
                 and then
2564
                  (Etype (Actual) /= Universal_Integer
2565
                    or else not Is_Descendent_Of_Address (Etype (Formal))
2566
                    or else
2567
                      Is_Predefined_File_Name
2568
                        (Unit_File_Name (Get_Source_Unit (N))))
2569
               then
2570
                  Next_Actual (Actual);
2571
                  Next_Formal (Formal);
2572
 
2573
               else
2574
                  if Debug_Flag_E then
2575
                     Write_Str (" type checking fails in call ");
2576
                     Write_Int (Int (N));
2577
                     Write_Str (" with formal ");
2578
                     Write_Int (Int (Formal));
2579
                     Write_Str (" in subprogram ");
2580
                     Write_Int (Int (Nam));
2581
                     Write_Eol;
2582
                  end if;
2583
 
2584
                  if Report and not Is_Indexed and not Is_Indirect then
2585
 
2586
                     --  Ada 2005 (AI-251): Complete the error notification
2587
                     --  to help new Ada 2005 users.
2588
 
2589
                     if Is_Class_Wide_Type (Etype (Formal))
2590
                       and then Is_Interface (Etype (Etype (Formal)))
2591
                       and then not Interface_Present_In_Ancestor
2592
                                      (Typ   => Etype (Actual),
2593
                                       Iface => Etype (Etype (Formal)))
2594
                     then
2595
                        Error_Msg_NE
2596
                          ("(Ada 2005) does not implement interface }",
2597
                           Actual, Etype (Etype (Formal)));
2598
                     end if;
2599
 
2600
                     Wrong_Type (Actual, Etype (Formal));
2601
 
2602
                     if Nkind (Actual) = N_Op_Eq
2603
                       and then Nkind (Left_Opnd (Actual)) = N_Identifier
2604
                     then
2605
                        Formal := First_Formal (Nam);
2606
                        while Present (Formal) loop
2607
                           if Chars (Left_Opnd (Actual)) = Chars (Formal) then
2608
                              Error_Msg_N -- CODEFIX
2609
                                ("possible misspelling of `='>`!", Actual);
2610
                              exit;
2611
                           end if;
2612
 
2613
                           Next_Formal (Formal);
2614
                        end loop;
2615
                     end if;
2616
 
2617
                     if All_Errors_Mode then
2618
                        Error_Msg_Sloc := Sloc (Nam);
2619
 
2620
                        if Is_Overloadable (Nam)
2621
                          and then Present (Alias (Nam))
2622
                          and then not Comes_From_Source (Nam)
2623
                        then
2624
                           Error_Msg_NE
2625
                             ("\\  =='> in call to inherited operation & #!",
2626
                              Actual, Nam);
2627
 
2628
                        elsif Ekind (Nam) = E_Subprogram_Type then
2629
                           declare
2630
                              Access_To_Subprogram_Typ :
2631
                                constant Entity_Id :=
2632
                                  Defining_Identifier
2633
                                    (Associated_Node_For_Itype (Nam));
2634
                           begin
2635
                              Error_Msg_NE (
2636
                                "\\  =='> in call to dereference of &#!",
2637
                                Actual, Access_To_Subprogram_Typ);
2638
                           end;
2639
 
2640
                        else
2641
                           Error_Msg_NE
2642
                             ("\\  =='> in call to &#!", Actual, Nam);
2643
 
2644
                        end if;
2645
                     end if;
2646
                  end if;
2647
 
2648
                  return;
2649
               end if;
2650
 
2651
            else
2652
               --  Normalize_Actuals has verified that a default value exists
2653
               --  for this formal. Current actual names a subsequent formal.
2654
 
2655
               Next_Formal (Formal);
2656
            end if;
2657
         end loop;
2658
 
2659
         --  On exit, all actuals match
2660
 
2661
         Indicate_Name_And_Type;
2662
      end if;
2663
   end Analyze_One_Call;
2664
 
2665
   ---------------------------
2666
   -- Analyze_Operator_Call --
2667
   ---------------------------
2668
 
2669
   procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id) is
2670
      Op_Name : constant Name_Id := Chars (Op_Id);
2671
      Act1    : constant Node_Id := First_Actual (N);
2672
      Act2    : constant Node_Id := Next_Actual (Act1);
2673
 
2674
   begin
2675
      --  Binary operator case
2676
 
2677
      if Present (Act2) then
2678
 
2679
         --  If more than two operands, then not binary operator after all
2680
 
2681
         if Present (Next_Actual (Act2)) then
2682
            return;
2683
 
2684
         elsif     Op_Name = Name_Op_Add
2685
           or else Op_Name = Name_Op_Subtract
2686
           or else Op_Name = Name_Op_Multiply
2687
           or else Op_Name = Name_Op_Divide
2688
           or else Op_Name = Name_Op_Mod
2689
           or else Op_Name = Name_Op_Rem
2690
           or else Op_Name = Name_Op_Expon
2691
         then
2692
            Find_Arithmetic_Types (Act1, Act2, Op_Id, N);
2693
 
2694
         elsif     Op_Name =  Name_Op_And
2695
           or else Op_Name = Name_Op_Or
2696
           or else Op_Name = Name_Op_Xor
2697
         then
2698
            Find_Boolean_Types (Act1, Act2, Op_Id, N);
2699
 
2700
         elsif     Op_Name = Name_Op_Lt
2701
           or else Op_Name = Name_Op_Le
2702
           or else Op_Name = Name_Op_Gt
2703
           or else Op_Name = Name_Op_Ge
2704
         then
2705
            Find_Comparison_Types (Act1, Act2, Op_Id,  N);
2706
 
2707
         elsif     Op_Name = Name_Op_Eq
2708
           or else Op_Name = Name_Op_Ne
2709
         then
2710
            Find_Equality_Types (Act1, Act2, Op_Id,  N);
2711
 
2712
         elsif     Op_Name = Name_Op_Concat then
2713
            Find_Concatenation_Types (Act1, Act2, Op_Id, N);
2714
 
2715
         --  Is this else null correct, or should it be an abort???
2716
 
2717
         else
2718
            null;
2719
         end if;
2720
 
2721
      --  Unary operator case
2722
 
2723
      else
2724
         if Op_Name = Name_Op_Subtract or else
2725
            Op_Name = Name_Op_Add      or else
2726
            Op_Name = Name_Op_Abs
2727
         then
2728
            Find_Unary_Types (Act1, Op_Id, N);
2729
 
2730
         elsif
2731
            Op_Name = Name_Op_Not
2732
         then
2733
            Find_Negation_Types (Act1, Op_Id, N);
2734
 
2735
         --  Is this else null correct, or should it be an abort???
2736
 
2737
         else
2738
            null;
2739
         end if;
2740
      end if;
2741
   end Analyze_Operator_Call;
2742
 
2743
   -------------------------------------------
2744
   -- Analyze_Overloaded_Selected_Component --
2745
   -------------------------------------------
2746
 
2747
   procedure Analyze_Overloaded_Selected_Component (N : Node_Id) is
2748
      Nam   : constant Node_Id := Prefix (N);
2749
      Sel   : constant Node_Id := Selector_Name (N);
2750
      Comp  : Entity_Id;
2751
      I     : Interp_Index;
2752
      It    : Interp;
2753
      T     : Entity_Id;
2754
 
2755
   begin
2756
      Set_Etype (Sel, Any_Type);
2757
 
2758
      Get_First_Interp (Nam, I, It);
2759
      while Present (It.Typ) loop
2760
         if Is_Access_Type (It.Typ) then
2761
            T := Designated_Type (It.Typ);
2762
            Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
2763
         else
2764
            T := It.Typ;
2765
         end if;
2766
 
2767
         if Is_Record_Type (T) then
2768
 
2769
            --  If the prefix is a class-wide type, the visible components are
2770
            --  those of the base type.
2771
 
2772
            if Is_Class_Wide_Type (T) then
2773
               T := Etype (T);
2774
            end if;
2775
 
2776
            Comp := First_Entity (T);
2777
            while Present (Comp) loop
2778
               if Chars (Comp) = Chars (Sel)
2779
                 and then Is_Visible_Component (Comp)
2780
               then
2781
 
2782
                  --  AI05-105:  if the context is an object renaming with
2783
                  --  an anonymous access type, the expected type of the
2784
                  --  object must be anonymous. This is a name resolution rule.
2785
 
2786
                  if Nkind (Parent (N)) /= N_Object_Renaming_Declaration
2787
                    or else No (Access_Definition (Parent (N)))
2788
                    or else Ekind (Etype (Comp)) = E_Anonymous_Access_Type
2789
                    or else
2790
                      Ekind (Etype (Comp)) = E_Anonymous_Access_Subprogram_Type
2791
                  then
2792
                     Set_Entity (Sel, Comp);
2793
                     Set_Etype (Sel, Etype (Comp));
2794
                     Add_One_Interp (N, Etype (Comp), Etype (Comp));
2795
 
2796
                     --  This also specifies a candidate to resolve the name.
2797
                     --  Further overloading will be resolved from context.
2798
                     --  The selector name itself does not carry overloading
2799
                     --  information.
2800
 
2801
                     Set_Etype (Nam, It.Typ);
2802
 
2803
                  else
2804
                     --  Named access type in the context of a renaming
2805
                     --  declaration with an access definition. Remove
2806
                     --  inapplicable candidate.
2807
 
2808
                     Remove_Interp (I);
2809
                  end if;
2810
               end if;
2811
 
2812
               Next_Entity (Comp);
2813
            end loop;
2814
 
2815
         elsif Is_Concurrent_Type (T) then
2816
            Comp := First_Entity (T);
2817
            while Present (Comp)
2818
              and then Comp /= First_Private_Entity (T)
2819
            loop
2820
               if Chars (Comp) = Chars (Sel) then
2821
                  if Is_Overloadable (Comp) then
2822
                     Add_One_Interp (Sel, Comp, Etype (Comp));
2823
                  else
2824
                     Set_Entity_With_Style_Check (Sel, Comp);
2825
                     Generate_Reference (Comp, Sel);
2826
                  end if;
2827
 
2828
                  Set_Etype (Sel, Etype (Comp));
2829
                  Set_Etype (N,   Etype (Comp));
2830
                  Set_Etype (Nam, It.Typ);
2831
 
2832
                  --  For access type case, introduce explicit dereference for
2833
                  --  more uniform treatment of entry calls. Do this only once
2834
                  --  if several interpretations yield an access type.
2835
 
2836
                  if Is_Access_Type (Etype (Nam))
2837
                    and then Nkind (Nam) /= N_Explicit_Dereference
2838
                  then
2839
                     Insert_Explicit_Dereference (Nam);
2840
                     Error_Msg_NW
2841
                       (Warn_On_Dereference, "?implicit dereference", N);
2842
                  end if;
2843
               end if;
2844
 
2845
               Next_Entity (Comp);
2846
            end loop;
2847
 
2848
            Set_Is_Overloaded (N, Is_Overloaded (Sel));
2849
         end if;
2850
 
2851
         Get_Next_Interp (I, It);
2852
      end loop;
2853
 
2854
      if Etype (N) = Any_Type
2855
        and then not Try_Object_Operation (N)
2856
      then
2857
         Error_Msg_NE ("undefined selector& for overloaded prefix", N, Sel);
2858
         Set_Entity (Sel, Any_Id);
2859
         Set_Etype  (Sel, Any_Type);
2860
      end if;
2861
   end Analyze_Overloaded_Selected_Component;
2862
 
2863
   ----------------------------------
2864
   -- Analyze_Qualified_Expression --
2865
   ----------------------------------
2866
 
2867
   procedure Analyze_Qualified_Expression (N : Node_Id) is
2868
      Mark : constant Entity_Id := Subtype_Mark (N);
2869
      Expr : constant Node_Id   := Expression (N);
2870
      I    : Interp_Index;
2871
      It   : Interp;
2872
      T    : Entity_Id;
2873
 
2874
   begin
2875
      Analyze_Expression (Expr);
2876
 
2877
      Set_Etype (N, Any_Type);
2878
      Find_Type (Mark);
2879
      T := Entity (Mark);
2880
      Set_Etype (N, T);
2881
 
2882
      if T = Any_Type then
2883
         return;
2884
      end if;
2885
 
2886
      Check_Fully_Declared (T, N);
2887
 
2888
      --  If expected type is class-wide, check for exact match before
2889
      --  expansion, because if the expression is a dispatching call it
2890
      --  may be rewritten as explicit dereference with class-wide result.
2891
      --  If expression is overloaded, retain only interpretations that
2892
      --  will yield exact matches.
2893
 
2894
      if Is_Class_Wide_Type (T) then
2895
         if not Is_Overloaded (Expr) then
2896
            if  Base_Type (Etype (Expr)) /= Base_Type (T) then
2897
               if Nkind (Expr) = N_Aggregate then
2898
                  Error_Msg_N ("type of aggregate cannot be class-wide", Expr);
2899
               else
2900
                  Wrong_Type (Expr, T);
2901
               end if;
2902
            end if;
2903
 
2904
         else
2905
            Get_First_Interp (Expr, I, It);
2906
 
2907
            while Present (It.Nam) loop
2908
               if Base_Type (It.Typ) /= Base_Type (T) then
2909
                  Remove_Interp (I);
2910
               end if;
2911
 
2912
               Get_Next_Interp (I, It);
2913
            end loop;
2914
         end if;
2915
      end if;
2916
 
2917
      Set_Etype  (N, T);
2918
   end Analyze_Qualified_Expression;
2919
 
2920
   -------------------
2921
   -- Analyze_Range --
2922
   -------------------
2923
 
2924
   procedure Analyze_Range (N : Node_Id) is
2925
      L        : constant Node_Id := Low_Bound (N);
2926
      H        : constant Node_Id := High_Bound (N);
2927
      I1, I2   : Interp_Index;
2928
      It1, It2 : Interp;
2929
 
2930
      procedure Check_Common_Type (T1, T2 : Entity_Id);
2931
      --  Verify the compatibility of two types,  and choose the
2932
      --  non universal one if the other is universal.
2933
 
2934
      procedure Check_High_Bound (T : Entity_Id);
2935
      --  Test one interpretation of the low bound against all those
2936
      --  of the high bound.
2937
 
2938
      procedure Check_Universal_Expression (N : Node_Id);
2939
      --  In Ada83, reject bounds of a universal range that are not
2940
      --  literals or entity names.
2941
 
2942
      -----------------------
2943
      -- Check_Common_Type --
2944
      -----------------------
2945
 
2946
      procedure Check_Common_Type (T1, T2 : Entity_Id) is
2947
      begin
2948
         if Covers (T1 => T1, T2 => T2)
2949
              or else
2950
            Covers (T1 => T2, T2 => T1)
2951
         then
2952
            if T1 = Universal_Integer
2953
              or else T1 = Universal_Real
2954
              or else T1 = Any_Character
2955
            then
2956
               Add_One_Interp (N, Base_Type (T2), Base_Type (T2));
2957
 
2958
            elsif T1 = T2 then
2959
               Add_One_Interp (N, T1, T1);
2960
 
2961
            else
2962
               Add_One_Interp (N, Base_Type (T1), Base_Type (T1));
2963
            end if;
2964
         end if;
2965
      end Check_Common_Type;
2966
 
2967
      ----------------------
2968
      -- Check_High_Bound --
2969
      ----------------------
2970
 
2971
      procedure Check_High_Bound (T : Entity_Id) is
2972
      begin
2973
         if not Is_Overloaded (H) then
2974
            Check_Common_Type (T, Etype (H));
2975
         else
2976
            Get_First_Interp (H, I2, It2);
2977
            while Present (It2.Typ) loop
2978
               Check_Common_Type (T, It2.Typ);
2979
               Get_Next_Interp (I2, It2);
2980
            end loop;
2981
         end if;
2982
      end Check_High_Bound;
2983
 
2984
      -----------------------------
2985
      -- Is_Universal_Expression --
2986
      -----------------------------
2987
 
2988
      procedure Check_Universal_Expression (N : Node_Id) is
2989
      begin
2990
         if Etype (N) = Universal_Integer
2991
           and then Nkind (N) /= N_Integer_Literal
2992
           and then not Is_Entity_Name (N)
2993
           and then Nkind (N) /= N_Attribute_Reference
2994
         then
2995
            Error_Msg_N ("illegal bound in discrete range", N);
2996
         end if;
2997
      end Check_Universal_Expression;
2998
 
2999
   --  Start of processing for Analyze_Range
3000
 
3001
   begin
3002
      Set_Etype (N, Any_Type);
3003
      Analyze_Expression (L);
3004
      Analyze_Expression (H);
3005
 
3006
      if Etype (L) = Any_Type or else Etype (H) = Any_Type then
3007
         return;
3008
 
3009
      else
3010
         if not Is_Overloaded (L) then
3011
            Check_High_Bound (Etype (L));
3012
         else
3013
            Get_First_Interp (L, I1, It1);
3014
            while Present (It1.Typ) loop
3015
               Check_High_Bound (It1.Typ);
3016
               Get_Next_Interp (I1, It1);
3017
            end loop;
3018
         end if;
3019
 
3020
         --  If result is Any_Type, then we did not find a compatible pair
3021
 
3022
         if Etype (N) = Any_Type then
3023
            Error_Msg_N ("incompatible types in range ", N);
3024
         end if;
3025
      end if;
3026
 
3027
      if Ada_Version = Ada_83
3028
        and then
3029
          (Nkind (Parent (N)) = N_Loop_Parameter_Specification
3030
             or else Nkind (Parent (N)) = N_Constrained_Array_Definition)
3031
      then
3032
         Check_Universal_Expression (L);
3033
         Check_Universal_Expression (H);
3034
      end if;
3035
   end Analyze_Range;
3036
 
3037
   -----------------------
3038
   -- Analyze_Reference --
3039
   -----------------------
3040
 
3041
   procedure Analyze_Reference (N : Node_Id) is
3042
      P        : constant Node_Id := Prefix (N);
3043
      E        : Entity_Id;
3044
      T        : Entity_Id;
3045
      Acc_Type : Entity_Id;
3046
 
3047
   begin
3048
      Analyze (P);
3049
 
3050
      --  An interesting error check, if we take the 'Reference of an object
3051
      --  for which a pragma Atomic or Volatile has been given, and the type
3052
      --  of the object is not Atomic or Volatile, then we are in trouble. The
3053
      --  problem is that no trace of the atomic/volatile status will remain
3054
      --  for the backend to respect when it deals with the resulting pointer,
3055
      --  since the pointer type will not be marked atomic (it is a pointer to
3056
      --  the base type of the object).
3057
 
3058
      --  It is not clear if that can ever occur, but in case it does, we will
3059
      --  generate an error message. Not clear if this message can ever be
3060
      --  generated, and pretty clear that it represents a bug if it is, still
3061
      --  seems worth checking!
3062
 
3063
      T := Etype (P);
3064
 
3065
      if Is_Entity_Name (P)
3066
        and then Is_Object_Reference (P)
3067
      then
3068
         E := Entity (P);
3069
         T := Etype (P);
3070
 
3071
         if (Has_Atomic_Components   (E)
3072
               and then not Has_Atomic_Components   (T))
3073
           or else
3074
            (Has_Volatile_Components (E)
3075
               and then not Has_Volatile_Components (T))
3076
           or else (Is_Atomic   (E) and then not Is_Atomic   (T))
3077
           or else (Is_Volatile (E) and then not Is_Volatile (T))
3078
         then
3079
            Error_Msg_N ("cannot take reference to Atomic/Volatile object", N);
3080
         end if;
3081
      end if;
3082
 
3083
      --  Carry on with normal processing
3084
 
3085
      Acc_Type := Create_Itype (E_Allocator_Type, N);
3086
      Set_Etype (Acc_Type,  Acc_Type);
3087
      Set_Directly_Designated_Type (Acc_Type, Etype (P));
3088
      Set_Etype (N, Acc_Type);
3089
   end Analyze_Reference;
3090
 
3091
   --------------------------------
3092
   -- Analyze_Selected_Component --
3093
   --------------------------------
3094
 
3095
   --  Prefix is a record type or a task or protected type. In the
3096
   --  later case, the selector must denote a visible entry.
3097
 
3098
   procedure Analyze_Selected_Component (N : Node_Id) is
3099
      Name          : constant Node_Id := Prefix (N);
3100
      Sel           : constant Node_Id := Selector_Name (N);
3101
      Act_Decl      : Node_Id;
3102
      Comp          : Entity_Id;
3103
      Has_Candidate : Boolean := False;
3104
      In_Scope      : Boolean;
3105
      Parent_N      : Node_Id;
3106
      Pent          : Entity_Id := Empty;
3107
      Prefix_Type   : Entity_Id;
3108
 
3109
      Type_To_Use : Entity_Id;
3110
      --  In most cases this is the Prefix_Type, but if the Prefix_Type is
3111
      --  a class-wide type, we use its root type, whose components are
3112
      --  present in the class-wide type.
3113
 
3114
      function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean;
3115
      --  It is known that the parent of N denotes a subprogram call. Comp
3116
      --  is an overloadable component of the concurrent type of the prefix.
3117
      --  Determine whether all formals of the parent of N and Comp are mode
3118
      --  conformant. If the parent node is not analyzed yet it may be an
3119
      --  indexed component rather than a function call.
3120
 
3121
      ------------------------------
3122
      -- Has_Mode_Conformant_Spec --
3123
      ------------------------------
3124
 
3125
      function Has_Mode_Conformant_Spec (Comp : Entity_Id) return Boolean is
3126
         Comp_Param : Entity_Id;
3127
         Param      : Node_Id;
3128
         Param_Typ  : Entity_Id;
3129
 
3130
      begin
3131
         Comp_Param := First_Formal (Comp);
3132
 
3133
         if Nkind (Parent (N)) = N_Indexed_Component then
3134
            Param := First (Expressions (Parent (N)));
3135
         else
3136
            Param := First (Parameter_Associations (Parent (N)));
3137
         end if;
3138
 
3139
         while Present (Comp_Param)
3140
           and then Present (Param)
3141
         loop
3142
            Param_Typ := Find_Parameter_Type (Param);
3143
 
3144
            if Present (Param_Typ)
3145
              and then
3146
                not Conforming_Types
3147
                     (Etype (Comp_Param), Param_Typ, Mode_Conformant)
3148
            then
3149
               return False;
3150
            end if;
3151
 
3152
            Next_Formal (Comp_Param);
3153
            Next (Param);
3154
         end loop;
3155
 
3156
         --  One of the specs has additional formals
3157
 
3158
         if Present (Comp_Param) or else Present (Param) then
3159
            return False;
3160
         end if;
3161
 
3162
         return True;
3163
      end Has_Mode_Conformant_Spec;
3164
 
3165
   --  Start of processing for Analyze_Selected_Component
3166
 
3167
   begin
3168
      Set_Etype (N, Any_Type);
3169
 
3170
      if Is_Overloaded (Name) then
3171
         Analyze_Overloaded_Selected_Component (N);
3172
         return;
3173
 
3174
      elsif Etype (Name) = Any_Type then
3175
         Set_Entity (Sel, Any_Id);
3176
         Set_Etype (Sel, Any_Type);
3177
         return;
3178
 
3179
      else
3180
         Prefix_Type := Etype (Name);
3181
      end if;
3182
 
3183
      if Is_Access_Type (Prefix_Type) then
3184
 
3185
         --  A RACW object can never be used as prefix of a selected
3186
         --  component since that means it is dereferenced without
3187
         --  being a controlling operand of a dispatching operation
3188
         --  (RM E.2.2(16/1)). Before reporting an error, we must check
3189
         --  whether this is actually a dispatching call in prefix form.
3190
 
3191
         if Is_Remote_Access_To_Class_Wide_Type (Prefix_Type)
3192
           and then Comes_From_Source (N)
3193
         then
3194
            if Try_Object_Operation (N) then
3195
               return;
3196
            else
3197
               Error_Msg_N
3198
                 ("invalid dereference of a remote access-to-class-wide value",
3199
                  N);
3200
            end if;
3201
 
3202
         --  Normal case of selected component applied to access type
3203
 
3204
         else
3205
            Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
3206
 
3207
            if Is_Entity_Name (Name) then
3208
               Pent := Entity (Name);
3209
            elsif Nkind (Name) = N_Selected_Component
3210
              and then Is_Entity_Name (Selector_Name (Name))
3211
            then
3212
               Pent := Entity (Selector_Name (Name));
3213
            end if;
3214
 
3215
            Prefix_Type := Process_Implicit_Dereference_Prefix (Pent, Name);
3216
         end if;
3217
 
3218
      --  If we have an explicit dereference of a remote access-to-class-wide
3219
      --  value, then issue an error (see RM-E.2.2(16/1)). However we first
3220
      --  have to check for the case of a prefix that is a controlling operand
3221
      --  of a prefixed dispatching call, as the dereference is legal in that
3222
      --  case. Normally this condition is checked in Validate_Remote_Access_
3223
      --  To_Class_Wide_Type, but we have to defer the checking for selected
3224
      --  component prefixes because of the prefixed dispatching call case.
3225
      --  Note that implicit dereferences are checked for this just above.
3226
 
3227
      elsif Nkind (Name) = N_Explicit_Dereference
3228
        and then Is_Remote_Access_To_Class_Wide_Type (Etype (Prefix (Name)))
3229
        and then Comes_From_Source (N)
3230
      then
3231
         if Try_Object_Operation (N) then
3232
            return;
3233
         else
3234
            Error_Msg_N
3235
              ("invalid dereference of a remote access-to-class-wide value",
3236
               N);
3237
         end if;
3238
      end if;
3239
 
3240
      --  (Ada 2005): if the prefix is the limited view of a type, and
3241
      --  the context already includes the full view, use the full view
3242
      --  in what follows, either to retrieve a component of to find
3243
      --  a primitive operation. If the prefix is an explicit dereference,
3244
      --  set the type of the prefix to reflect this transformation.
3245
      --  If the non-limited view is itself an incomplete type, get the
3246
      --  full view if available.
3247
 
3248
      if Is_Incomplete_Type (Prefix_Type)
3249
        and then From_With_Type (Prefix_Type)
3250
        and then Present (Non_Limited_View (Prefix_Type))
3251
      then
3252
         Prefix_Type := Get_Full_View (Non_Limited_View (Prefix_Type));
3253
 
3254
         if Nkind (N) = N_Explicit_Dereference then
3255
            Set_Etype (Prefix (N), Prefix_Type);
3256
         end if;
3257
 
3258
      elsif Ekind (Prefix_Type) = E_Class_Wide_Type
3259
        and then From_With_Type (Prefix_Type)
3260
        and then Present (Non_Limited_View (Etype (Prefix_Type)))
3261
      then
3262
         Prefix_Type :=
3263
           Class_Wide_Type (Non_Limited_View (Etype (Prefix_Type)));
3264
 
3265
         if Nkind (N) = N_Explicit_Dereference then
3266
            Set_Etype (Prefix (N), Prefix_Type);
3267
         end if;
3268
      end if;
3269
 
3270
      if Ekind (Prefix_Type) = E_Private_Subtype then
3271
         Prefix_Type := Base_Type (Prefix_Type);
3272
      end if;
3273
 
3274
      Type_To_Use := Prefix_Type;
3275
 
3276
      --  For class-wide types, use the entity list of the root type. This
3277
      --  indirection is specially important for private extensions because
3278
      --  only the root type get switched (not the class-wide type).
3279
 
3280
      if Is_Class_Wide_Type (Prefix_Type) then
3281
         Type_To_Use := Root_Type (Prefix_Type);
3282
      end if;
3283
 
3284
      Comp := First_Entity (Type_To_Use);
3285
 
3286
      --  If the selector has an original discriminant, the node appears in
3287
      --  an instance. Replace the discriminant with the corresponding one
3288
      --  in the current discriminated type. For nested generics, this must
3289
      --  be done transitively, so note the new original discriminant.
3290
 
3291
      if Nkind (Sel) = N_Identifier
3292
        and then Present (Original_Discriminant (Sel))
3293
      then
3294
         Comp := Find_Corresponding_Discriminant (Sel, Prefix_Type);
3295
 
3296
         --  Mark entity before rewriting, for completeness and because
3297
         --  subsequent semantic checks might examine the original node.
3298
 
3299
         Set_Entity (Sel, Comp);
3300
         Rewrite (Selector_Name (N),
3301
           New_Occurrence_Of (Comp, Sloc (N)));
3302
         Set_Original_Discriminant (Selector_Name (N), Comp);
3303
         Set_Etype (N, Etype (Comp));
3304
 
3305
         if Is_Access_Type (Etype (Name)) then
3306
            Insert_Explicit_Dereference (Name);
3307
            Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
3308
         end if;
3309
 
3310
      elsif Is_Record_Type (Prefix_Type) then
3311
 
3312
         --  Find component with given name
3313
 
3314
         while Present (Comp) loop
3315
            if Chars (Comp) = Chars (Sel)
3316
              and then Is_Visible_Component (Comp)
3317
            then
3318
               Set_Entity_With_Style_Check (Sel, Comp);
3319
               Set_Etype (Sel, Etype (Comp));
3320
 
3321
               if Ekind (Comp) = E_Discriminant then
3322
                  if Is_Unchecked_Union (Base_Type (Prefix_Type)) then
3323
                     Error_Msg_N
3324
                       ("cannot reference discriminant of Unchecked_Union",
3325
                        Sel);
3326
                  end if;
3327
 
3328
                  if Is_Generic_Type (Prefix_Type)
3329
                       or else
3330
                     Is_Generic_Type (Root_Type (Prefix_Type))
3331
                  then
3332
                     Set_Original_Discriminant (Sel, Comp);
3333
                  end if;
3334
               end if;
3335
 
3336
               --  Resolve the prefix early otherwise it is not possible to
3337
               --  build the actual subtype of the component: it may need
3338
               --  to duplicate this prefix and duplication is only allowed
3339
               --  on fully resolved expressions.
3340
 
3341
               Resolve (Name);
3342
 
3343
               --  Ada 2005 (AI-50217): Check wrong use of incomplete types or
3344
               --  subtypes in a package specification.
3345
               --  Example:
3346
 
3347
               --    limited with Pkg;
3348
               --    package Pkg is
3349
               --       type Acc_Inc is access Pkg.T;
3350
               --       X : Acc_Inc;
3351
               --       N : Natural := X.all.Comp;  --  ERROR, limited view
3352
               --    end Pkg;                       --  Comp is not visible
3353
 
3354
               if Nkind (Name) = N_Explicit_Dereference
3355
                 and then From_With_Type (Etype (Prefix (Name)))
3356
                 and then not Is_Potentially_Use_Visible (Etype (Name))
3357
                 and then Nkind (Parent (Cunit_Entity (Current_Sem_Unit))) =
3358
                            N_Package_Specification
3359
               then
3360
                  Error_Msg_NE
3361
                    ("premature usage of incomplete}", Prefix (Name),
3362
                     Etype (Prefix (Name)));
3363
               end if;
3364
 
3365
               --  We never need an actual subtype for the case of a selection
3366
               --  for a indexed component of a non-packed array, since in
3367
               --  this case gigi generates all the checks and can find the
3368
               --  necessary bounds information.
3369
 
3370
               --  We also do not need an actual subtype for the case of
3371
               --  a first, last, length, or range attribute applied to a
3372
               --  non-packed array, since gigi can again get the bounds in
3373
               --  these cases (gigi cannot handle the packed case, since it
3374
               --  has the bounds of the packed array type, not the original
3375
               --  bounds of the type). However, if the prefix is itself a
3376
               --  selected component, as in a.b.c (i), gigi may regard a.b.c
3377
               --  as a dynamic-sized temporary, so we do generate an actual
3378
               --  subtype for this case.
3379
 
3380
               Parent_N := Parent (N);
3381
 
3382
               if not Is_Packed (Etype (Comp))
3383
                 and then
3384
                   ((Nkind (Parent_N) = N_Indexed_Component
3385
                       and then Nkind (Name) /= N_Selected_Component)
3386
                     or else
3387
                      (Nkind (Parent_N) = N_Attribute_Reference
3388
                         and then (Attribute_Name (Parent_N) = Name_First
3389
                                     or else
3390
                                   Attribute_Name (Parent_N) = Name_Last
3391
                                     or else
3392
                                   Attribute_Name (Parent_N) = Name_Length
3393
                                     or else
3394
                                   Attribute_Name (Parent_N) = Name_Range)))
3395
               then
3396
                  Set_Etype (N, Etype (Comp));
3397
 
3398
               --  If full analysis is not enabled, we do not generate an
3399
               --  actual subtype, because in the absence of expansion
3400
               --  reference to a formal of a protected type, for example,
3401
               --  will not be properly transformed, and will lead to
3402
               --  out-of-scope references in gigi.
3403
 
3404
               --  In all other cases, we currently build an actual subtype.
3405
               --  It seems likely that many of these cases can be avoided,
3406
               --  but right now, the front end makes direct references to the
3407
               --  bounds (e.g. in generating a length check), and if we do
3408
               --  not make an actual subtype, we end up getting a direct
3409
               --  reference to a discriminant, which will not do.
3410
 
3411
               elsif Full_Analysis then
3412
                  Act_Decl :=
3413
                    Build_Actual_Subtype_Of_Component (Etype (Comp), N);
3414
                  Insert_Action (N, Act_Decl);
3415
 
3416
                  if No (Act_Decl) then
3417
                     Set_Etype (N, Etype (Comp));
3418
 
3419
                  else
3420
                     --  Component type depends on discriminants. Enter the
3421
                     --  main attributes of the subtype.
3422
 
3423
                     declare
3424
                        Subt : constant Entity_Id :=
3425
                                 Defining_Identifier (Act_Decl);
3426
 
3427
                     begin
3428
                        Set_Etype (Subt, Base_Type (Etype (Comp)));
3429
                        Set_Ekind (Subt, Ekind (Etype (Comp)));
3430
                        Set_Etype (N, Subt);
3431
                     end;
3432
                  end if;
3433
 
3434
               --  If Full_Analysis not enabled, just set the Etype
3435
 
3436
               else
3437
                  Set_Etype (N, Etype (Comp));
3438
               end if;
3439
 
3440
               return;
3441
            end if;
3442
 
3443
            --  If the prefix is a private extension, check only the visible
3444
            --  components of the partial view. This must include the tag,
3445
            --  which can appear in expanded code in a tag check.
3446
 
3447
            if Ekind (Type_To_Use) = E_Record_Type_With_Private
3448
              and then  Chars (Selector_Name (N)) /= Name_uTag
3449
            then
3450
               exit when Comp = Last_Entity (Type_To_Use);
3451
            end if;
3452
 
3453
            Next_Entity (Comp);
3454
         end loop;
3455
 
3456
         --  Ada 2005 (AI-252): The selected component can be interpreted as
3457
         --  a prefixed view of a subprogram. Depending on the context, this is
3458
         --  either a name that can appear in a renaming declaration, or part
3459
         --  of an enclosing call given in prefix form.
3460
 
3461
         --  Ada 2005 (AI05-0030): In the case of dispatching requeue, the
3462
         --  selected component should resolve to a name.
3463
 
3464
         if Ada_Version >= Ada_05
3465
           and then Is_Tagged_Type (Prefix_Type)
3466
           and then not Is_Concurrent_Type (Prefix_Type)
3467
         then
3468
            if Nkind (Parent (N)) = N_Generic_Association
3469
              or else Nkind (Parent (N)) = N_Requeue_Statement
3470
              or else Nkind (Parent (N)) = N_Subprogram_Renaming_Declaration
3471
            then
3472
               if Find_Primitive_Operation (N) then
3473
                  return;
3474
               end if;
3475
 
3476
            elsif Try_Object_Operation (N) then
3477
               return;
3478
            end if;
3479
 
3480
            --  If the transformation fails, it will be necessary to redo the
3481
            --  analysis with all errors enabled, to indicate candidate
3482
            --  interpretations and reasons for each failure ???
3483
 
3484
         end if;
3485
 
3486
      elsif Is_Private_Type (Prefix_Type) then
3487
 
3488
         --  Allow access only to discriminants of the type. If the type has
3489
         --  no full view, gigi uses the parent type for the components, so we
3490
         --  do the same here.
3491
 
3492
         if No (Full_View (Prefix_Type)) then
3493
            Type_To_Use := Root_Type (Base_Type (Prefix_Type));
3494
            Comp := First_Entity (Type_To_Use);
3495
         end if;
3496
 
3497
         while Present (Comp) loop
3498
            if Chars (Comp) = Chars (Sel) then
3499
               if Ekind (Comp) = E_Discriminant then
3500
                  Set_Entity_With_Style_Check (Sel, Comp);
3501
                  Generate_Reference (Comp, Sel);
3502
 
3503
                  Set_Etype (Sel, Etype (Comp));
3504
                  Set_Etype (N,   Etype (Comp));
3505
 
3506
                  if Is_Generic_Type (Prefix_Type)
3507
                    or else Is_Generic_Type (Root_Type (Prefix_Type))
3508
                  then
3509
                     Set_Original_Discriminant (Sel, Comp);
3510
                  end if;
3511
 
3512
               --  Before declaring an error, check whether this is tagged
3513
               --  private type and a call to a primitive operation.
3514
 
3515
               elsif Ada_Version >= Ada_05
3516
                 and then Is_Tagged_Type (Prefix_Type)
3517
                 and then Try_Object_Operation (N)
3518
               then
3519
                  return;
3520
 
3521
               else
3522
                  Error_Msg_NE
3523
                    ("invisible selector for }",
3524
                     N, First_Subtype (Prefix_Type));
3525
                  Set_Entity (Sel, Any_Id);
3526
                  Set_Etype (N, Any_Type);
3527
               end if;
3528
 
3529
               return;
3530
            end if;
3531
 
3532
            Next_Entity (Comp);
3533
         end loop;
3534
 
3535
      elsif Is_Concurrent_Type (Prefix_Type) then
3536
 
3537
         --  Find visible operation with given name. For a protected type,
3538
         --  the possible candidates are discriminants, entries or protected
3539
         --  procedures. For a task type, the set can only include entries or
3540
         --  discriminants if the task type is not an enclosing scope. If it
3541
         --  is an enclosing scope (e.g. in an inner task) then all entities
3542
         --  are visible, but the prefix must denote the enclosing scope, i.e.
3543
         --  can only be a direct name or an expanded name.
3544
 
3545
         Set_Etype (Sel, Any_Type);
3546
         In_Scope := In_Open_Scopes (Prefix_Type);
3547
 
3548
         while Present (Comp) loop
3549
            if Chars (Comp) = Chars (Sel) then
3550
               if Is_Overloadable (Comp) then
3551
                  Add_One_Interp (Sel, Comp, Etype (Comp));
3552
 
3553
                  --  If the prefix is tagged, the correct interpretation may
3554
                  --  lie in the primitive or class-wide operations of the
3555
                  --  type. Perform a simple conformance check to determine
3556
                  --  whether Try_Object_Operation should be invoked even if
3557
                  --  a visible entity is found.
3558
 
3559
                  if Is_Tagged_Type (Prefix_Type)
3560
                    and then
3561
                      Nkind_In (Parent (N), N_Procedure_Call_Statement,
3562
                                            N_Function_Call,
3563
                                            N_Indexed_Component)
3564
                    and then Has_Mode_Conformant_Spec (Comp)
3565
                  then
3566
                     Has_Candidate := True;
3567
                  end if;
3568
 
3569
               elsif Ekind (Comp) = E_Discriminant
3570
                 or else Ekind (Comp) = E_Entry_Family
3571
                 or else (In_Scope
3572
                   and then Is_Entity_Name (Name))
3573
               then
3574
                  Set_Entity_With_Style_Check (Sel, Comp);
3575
                  Generate_Reference (Comp, Sel);
3576
 
3577
               else
3578
                  goto Next_Comp;
3579
               end if;
3580
 
3581
               Set_Etype (Sel, Etype (Comp));
3582
               Set_Etype (N,   Etype (Comp));
3583
 
3584
               if Ekind (Comp) = E_Discriminant then
3585
                  Set_Original_Discriminant (Sel, Comp);
3586
               end if;
3587
 
3588
               --  For access type case, introduce explicit dereference for
3589
               --  more uniform treatment of entry calls.
3590
 
3591
               if Is_Access_Type (Etype (Name)) then
3592
                  Insert_Explicit_Dereference (Name);
3593
                  Error_Msg_NW
3594
                    (Warn_On_Dereference, "?implicit dereference", N);
3595
               end if;
3596
            end if;
3597
 
3598
            <<Next_Comp>>
3599
               Next_Entity (Comp);
3600
               exit when not In_Scope
3601
                 and then
3602
                   Comp = First_Private_Entity (Base_Type (Prefix_Type));
3603
         end loop;
3604
 
3605
         --  If there is no visible entity with the given name or none of the
3606
         --  visible entities are plausible interpretations, check whether
3607
         --  there is some other primitive operation with that name.
3608
 
3609
         if Ada_Version >= Ada_05
3610
           and then Is_Tagged_Type (Prefix_Type)
3611
         then
3612
            if (Etype (N) = Any_Type
3613
                  or else not Has_Candidate)
3614
              and then Try_Object_Operation (N)
3615
            then
3616
               return;
3617
 
3618
            --  If the context is not syntactically a procedure call, it
3619
            --  may be a call to a primitive function declared outside of
3620
            --  the synchronized type.
3621
 
3622
            --  If the context is a procedure call, there might still be
3623
            --  an overloading between an entry and a primitive procedure
3624
            --  declared outside of the synchronized type, called in prefix
3625
            --  notation. This is harder to disambiguate because in one case
3626
            --  the controlling formal is implicit ???
3627
 
3628
            elsif Nkind (Parent (N)) /= N_Procedure_Call_Statement
3629
              and then Nkind (Parent (N)) /= N_Indexed_Component
3630
              and then Try_Object_Operation (N)
3631
            then
3632
               return;
3633
            end if;
3634
         end if;
3635
 
3636
         Set_Is_Overloaded (N, Is_Overloaded (Sel));
3637
 
3638
      else
3639
         --  Invalid prefix
3640
 
3641
         Error_Msg_NE ("invalid prefix in selected component&", N, Sel);
3642
      end if;
3643
 
3644
      --  If N still has no type, the component is not defined in the prefix
3645
 
3646
      if Etype (N) = Any_Type then
3647
 
3648
         --  If the prefix is a single concurrent object, use its name in the
3649
         --  error message, rather than that of its anonymous type.
3650
 
3651
         if Is_Concurrent_Type (Prefix_Type)
3652
           and then Is_Internal_Name (Chars (Prefix_Type))
3653
           and then not Is_Derived_Type (Prefix_Type)
3654
           and then Is_Entity_Name (Name)
3655
         then
3656
 
3657
            Error_Msg_Node_2 := Entity (Name);
3658
            Error_Msg_NE ("no selector& for&", N, Sel);
3659
 
3660
            Check_Misspelled_Selector (Type_To_Use, Sel);
3661
 
3662
         elsif Is_Generic_Type (Prefix_Type)
3663
           and then Ekind (Prefix_Type) = E_Record_Type_With_Private
3664
           and then Prefix_Type /= Etype (Prefix_Type)
3665
           and then Is_Record_Type (Etype (Prefix_Type))
3666
         then
3667
            --  If this is a derived formal type, the parent may have
3668
            --  different visibility at this point. Try for an inherited
3669
            --  component before reporting an error.
3670
 
3671
            Set_Etype (Prefix (N), Etype (Prefix_Type));
3672
            Analyze_Selected_Component (N);
3673
            return;
3674
 
3675
         elsif Ekind (Prefix_Type) = E_Record_Subtype_With_Private
3676
           and then Is_Generic_Actual_Type (Prefix_Type)
3677
           and then Present (Full_View (Prefix_Type))
3678
         then
3679
            --  Similarly, if this the actual for a formal derived type, the
3680
            --  component inherited from the generic parent may not be visible
3681
            --  in the actual, but the selected component is legal.
3682
 
3683
            declare
3684
               Comp : Entity_Id;
3685
 
3686
            begin
3687
               Comp :=
3688
                 First_Component (Generic_Parent_Type (Parent (Prefix_Type)));
3689
               while Present (Comp) loop
3690
                  if Chars (Comp) = Chars (Sel) then
3691
                     Set_Entity_With_Style_Check (Sel, Comp);
3692
                     Set_Etype (Sel, Etype (Comp));
3693
                     Set_Etype (N,   Etype (Comp));
3694
                     return;
3695
                  end if;
3696
 
3697
                  Next_Component (Comp);
3698
               end loop;
3699
 
3700
               pragma Assert (Etype (N) /= Any_Type);
3701
            end;
3702
 
3703
         else
3704
            if Ekind (Prefix_Type) = E_Record_Subtype then
3705
 
3706
               --  Check whether this is a component of the base type
3707
               --  which is absent from a statically constrained subtype.
3708
               --  This will raise constraint error at run-time, but is
3709
               --  not a compile-time error. When the selector is illegal
3710
               --  for base type as well fall through and generate a
3711
               --  compilation error anyway.
3712
 
3713
               Comp := First_Component (Base_Type (Prefix_Type));
3714
               while Present (Comp) loop
3715
                  if Chars (Comp) = Chars (Sel)
3716
                    and then Is_Visible_Component (Comp)
3717
                  then
3718
                     Set_Entity_With_Style_Check (Sel, Comp);
3719
                     Generate_Reference (Comp, Sel);
3720
                     Set_Etype (Sel, Etype (Comp));
3721
                     Set_Etype (N,   Etype (Comp));
3722
 
3723
                     --  Emit appropriate message. Gigi will replace the
3724
                     --  node subsequently with the appropriate Raise.
3725
 
3726
                     Apply_Compile_Time_Constraint_Error
3727
                       (N, "component not present in }?",
3728
                        CE_Discriminant_Check_Failed,
3729
                        Ent => Prefix_Type, Rep => False);
3730
                     Set_Raises_Constraint_Error (N);
3731
                     return;
3732
                  end if;
3733
 
3734
                  Next_Component (Comp);
3735
               end loop;
3736
 
3737
            end if;
3738
 
3739
            Error_Msg_Node_2 := First_Subtype (Prefix_Type);
3740
            Error_Msg_NE ("no selector& for}", N, Sel);
3741
 
3742
            Check_Misspelled_Selector (Type_To_Use, Sel);
3743
         end if;
3744
 
3745
         Set_Entity (Sel, Any_Id);
3746
         Set_Etype (Sel, Any_Type);
3747
      end if;
3748
   end Analyze_Selected_Component;
3749
 
3750
   ---------------------------
3751
   -- Analyze_Short_Circuit --
3752
   ---------------------------
3753
 
3754
   procedure Analyze_Short_Circuit (N : Node_Id) is
3755
      L   : constant Node_Id := Left_Opnd  (N);
3756
      R   : constant Node_Id := Right_Opnd (N);
3757
      Ind : Interp_Index;
3758
      It  : Interp;
3759
 
3760
   begin
3761
      Analyze_Expression (L);
3762
      Analyze_Expression (R);
3763
      Set_Etype (N, Any_Type);
3764
 
3765
      if not Is_Overloaded (L) then
3766
         if Root_Type (Etype (L)) = Standard_Boolean
3767
           and then Has_Compatible_Type (R, Etype (L))
3768
         then
3769
            Add_One_Interp (N, Etype (L), Etype (L));
3770
         end if;
3771
 
3772
      else
3773
         Get_First_Interp (L, Ind, It);
3774
         while Present (It.Typ) loop
3775
            if Root_Type (It.Typ) = Standard_Boolean
3776
              and then Has_Compatible_Type (R, It.Typ)
3777
            then
3778
               Add_One_Interp (N, It.Typ, It.Typ);
3779
            end if;
3780
 
3781
            Get_Next_Interp (Ind, It);
3782
         end loop;
3783
      end if;
3784
 
3785
      --  Here we have failed to find an interpretation. Clearly we know that
3786
      --  it is not the case that both operands can have an interpretation of
3787
      --  Boolean, but this is by far the most likely intended interpretation.
3788
      --  So we simply resolve both operands as Booleans, and at least one of
3789
      --  these resolutions will generate an error message, and we do not need
3790
      --  to give another error message on the short circuit operation itself.
3791
 
3792
      if Etype (N) = Any_Type then
3793
         Resolve (L, Standard_Boolean);
3794
         Resolve (R, Standard_Boolean);
3795
         Set_Etype (N, Standard_Boolean);
3796
      end if;
3797
   end Analyze_Short_Circuit;
3798
 
3799
   -------------------
3800
   -- Analyze_Slice --
3801
   -------------------
3802
 
3803
   procedure Analyze_Slice (N : Node_Id) is
3804
      P          : constant Node_Id := Prefix (N);
3805
      D          : constant Node_Id := Discrete_Range (N);
3806
      Array_Type : Entity_Id;
3807
 
3808
      procedure Analyze_Overloaded_Slice;
3809
      --  If the prefix is overloaded, select those interpretations that
3810
      --  yield a one-dimensional array type.
3811
 
3812
      ------------------------------
3813
      -- Analyze_Overloaded_Slice --
3814
      ------------------------------
3815
 
3816
      procedure Analyze_Overloaded_Slice is
3817
         I   : Interp_Index;
3818
         It  : Interp;
3819
         Typ : Entity_Id;
3820
 
3821
      begin
3822
         Set_Etype (N, Any_Type);
3823
 
3824
         Get_First_Interp (P, I, It);
3825
         while Present (It.Nam) loop
3826
            Typ := It.Typ;
3827
 
3828
            if Is_Access_Type (Typ) then
3829
               Typ := Designated_Type (Typ);
3830
               Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
3831
            end if;
3832
 
3833
            if Is_Array_Type (Typ)
3834
              and then Number_Dimensions (Typ) = 1
3835
              and then Has_Compatible_Type (D, Etype (First_Index (Typ)))
3836
            then
3837
               Add_One_Interp (N, Typ, Typ);
3838
            end if;
3839
 
3840
            Get_Next_Interp (I, It);
3841
         end loop;
3842
 
3843
         if Etype (N) = Any_Type then
3844
            Error_Msg_N ("expect array type in prefix of slice",  N);
3845
         end if;
3846
      end Analyze_Overloaded_Slice;
3847
 
3848
   --  Start of processing for Analyze_Slice
3849
 
3850
   begin
3851
      Analyze (P);
3852
      Analyze (D);
3853
 
3854
      if Is_Overloaded (P) then
3855
         Analyze_Overloaded_Slice;
3856
 
3857
      else
3858
         Array_Type := Etype (P);
3859
         Set_Etype (N, Any_Type);
3860
 
3861
         if Is_Access_Type (Array_Type) then
3862
            Array_Type := Designated_Type (Array_Type);
3863
            Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
3864
         end if;
3865
 
3866
         if not Is_Array_Type (Array_Type) then
3867
            Wrong_Type (P, Any_Array);
3868
 
3869
         elsif Number_Dimensions (Array_Type) > 1 then
3870
            Error_Msg_N
3871
              ("type is not one-dimensional array in slice prefix", N);
3872
 
3873
         elsif not
3874
           Has_Compatible_Type (D, Etype (First_Index (Array_Type)))
3875
         then
3876
            Wrong_Type (D, Etype (First_Index (Array_Type)));
3877
 
3878
         else
3879
            Set_Etype (N, Array_Type);
3880
         end if;
3881
      end if;
3882
   end Analyze_Slice;
3883
 
3884
   -----------------------------
3885
   -- Analyze_Type_Conversion --
3886
   -----------------------------
3887
 
3888
   procedure Analyze_Type_Conversion (N : Node_Id) is
3889
      Expr : constant Node_Id := Expression (N);
3890
      T    : Entity_Id;
3891
 
3892
   begin
3893
      --  Check if the expression is a function call for which we need to
3894
      --  adjust a SCIL dispatching node.
3895
 
3896
      if Generate_SCIL
3897
        and then Nkind (Expr) = N_Function_Call
3898
      then
3899
         Adjust_SCIL_Node (N, Expr);
3900
      end if;
3901
 
3902
      --  If Conversion_OK is set, then the Etype is already set, and the
3903
      --  only processing required is to analyze the expression. This is
3904
      --  used to construct certain "illegal" conversions which are not
3905
      --  allowed by Ada semantics, but can be handled OK by Gigi, see
3906
      --  Sinfo for further details.
3907
 
3908
      if Conversion_OK (N) then
3909
         Analyze (Expr);
3910
         return;
3911
      end if;
3912
 
3913
      --  Otherwise full type analysis is required, as well as some semantic
3914
      --  checks to make sure the argument of the conversion is appropriate.
3915
 
3916
      Find_Type (Subtype_Mark (N));
3917
      T := Entity (Subtype_Mark (N));
3918
      Set_Etype (N, T);
3919
      Check_Fully_Declared (T, N);
3920
      Analyze_Expression (Expr);
3921
      Validate_Remote_Type_Type_Conversion (N);
3922
 
3923
      --  Only remaining step is validity checks on the argument. These
3924
      --  are skipped if the conversion does not come from the source.
3925
 
3926
      if not Comes_From_Source (N) then
3927
         return;
3928
 
3929
      --  If there was an error in a generic unit, no need to replicate the
3930
      --  error message. Conversely, constant-folding in the generic may
3931
      --  transform the argument of a conversion into a string literal, which
3932
      --  is legal. Therefore the following tests are not performed in an
3933
      --  instance.
3934
 
3935
      elsif In_Instance then
3936
         return;
3937
 
3938
      elsif Nkind (Expr) = N_Null then
3939
         Error_Msg_N ("argument of conversion cannot be null", N);
3940
         Error_Msg_N ("\use qualified expression instead", N);
3941
         Set_Etype (N, Any_Type);
3942
 
3943
      elsif Nkind (Expr) = N_Aggregate then
3944
         Error_Msg_N ("argument of conversion cannot be aggregate", N);
3945
         Error_Msg_N ("\use qualified expression instead", N);
3946
 
3947
      elsif Nkind (Expr) = N_Allocator then
3948
         Error_Msg_N ("argument of conversion cannot be an allocator", N);
3949
         Error_Msg_N ("\use qualified expression instead", N);
3950
 
3951
      elsif Nkind (Expr) = N_String_Literal then
3952
         Error_Msg_N ("argument of conversion cannot be string literal", N);
3953
         Error_Msg_N ("\use qualified expression instead", N);
3954
 
3955
      elsif Nkind (Expr) = N_Character_Literal then
3956
         if Ada_Version = Ada_83 then
3957
            Resolve (Expr, T);
3958
         else
3959
            Error_Msg_N ("argument of conversion cannot be character literal",
3960
              N);
3961
            Error_Msg_N ("\use qualified expression instead", N);
3962
         end if;
3963
 
3964
      elsif Nkind (Expr) = N_Attribute_Reference
3965
        and then
3966
          (Attribute_Name (Expr) = Name_Access            or else
3967
           Attribute_Name (Expr) = Name_Unchecked_Access  or else
3968
           Attribute_Name (Expr) = Name_Unrestricted_Access)
3969
      then
3970
         Error_Msg_N ("argument of conversion cannot be access", N);
3971
         Error_Msg_N ("\use qualified expression instead", N);
3972
      end if;
3973
   end Analyze_Type_Conversion;
3974
 
3975
   ----------------------
3976
   -- Analyze_Unary_Op --
3977
   ----------------------
3978
 
3979
   procedure Analyze_Unary_Op (N : Node_Id) is
3980
      R     : constant Node_Id := Right_Opnd (N);
3981
      Op_Id : Entity_Id := Entity (N);
3982
 
3983
   begin
3984
      Set_Etype (N, Any_Type);
3985
      Candidate_Type := Empty;
3986
 
3987
      Analyze_Expression (R);
3988
 
3989
      if Present (Op_Id) then
3990
         if Ekind (Op_Id) = E_Operator then
3991
            Find_Unary_Types (R, Op_Id,  N);
3992
         else
3993
            Add_One_Interp (N, Op_Id, Etype (Op_Id));
3994
         end if;
3995
 
3996
      else
3997
         Op_Id := Get_Name_Entity_Id (Chars (N));
3998
         while Present (Op_Id) loop
3999
            if Ekind (Op_Id) = E_Operator then
4000
               if No (Next_Entity (First_Entity (Op_Id))) then
4001
                  Find_Unary_Types (R, Op_Id,  N);
4002
               end if;
4003
 
4004
            elsif Is_Overloadable (Op_Id) then
4005
               Analyze_User_Defined_Unary_Op (N, Op_Id);
4006
            end if;
4007
 
4008
            Op_Id := Homonym (Op_Id);
4009
         end loop;
4010
      end if;
4011
 
4012
      Operator_Check (N);
4013
   end Analyze_Unary_Op;
4014
 
4015
   ----------------------------------
4016
   -- Analyze_Unchecked_Expression --
4017
   ----------------------------------
4018
 
4019
   procedure Analyze_Unchecked_Expression (N : Node_Id) is
4020
   begin
4021
      Analyze (Expression (N), Suppress => All_Checks);
4022
      Set_Etype (N, Etype (Expression (N)));
4023
      Save_Interps (Expression (N), N);
4024
   end Analyze_Unchecked_Expression;
4025
 
4026
   ---------------------------------------
4027
   -- Analyze_Unchecked_Type_Conversion --
4028
   ---------------------------------------
4029
 
4030
   procedure Analyze_Unchecked_Type_Conversion (N : Node_Id) is
4031
   begin
4032
      Find_Type (Subtype_Mark (N));
4033
      Analyze_Expression (Expression (N));
4034
      Set_Etype (N, Entity (Subtype_Mark (N)));
4035
   end Analyze_Unchecked_Type_Conversion;
4036
 
4037
   ------------------------------------
4038
   -- Analyze_User_Defined_Binary_Op --
4039
   ------------------------------------
4040
 
4041
   procedure Analyze_User_Defined_Binary_Op
4042
     (N     : Node_Id;
4043
      Op_Id : Entity_Id)
4044
   is
4045
   begin
4046
      --  Only do analysis if the operator Comes_From_Source, since otherwise
4047
      --  the operator was generated by the expander, and all such operators
4048
      --  always refer to the operators in package Standard.
4049
 
4050
      if Comes_From_Source (N) then
4051
         declare
4052
            F1 : constant Entity_Id := First_Formal (Op_Id);
4053
            F2 : constant Entity_Id := Next_Formal (F1);
4054
 
4055
         begin
4056
            --  Verify that Op_Id is a visible binary function. Note that since
4057
            --  we know Op_Id is overloaded, potentially use visible means use
4058
            --  visible for sure (RM 9.4(11)).
4059
 
4060
            if Ekind (Op_Id) = E_Function
4061
              and then Present (F2)
4062
              and then (Is_Immediately_Visible (Op_Id)
4063
                         or else Is_Potentially_Use_Visible (Op_Id))
4064
              and then Has_Compatible_Type (Left_Opnd (N), Etype (F1))
4065
              and then Has_Compatible_Type (Right_Opnd (N), Etype (F2))
4066
            then
4067
               Add_One_Interp (N, Op_Id, Etype (Op_Id));
4068
 
4069
               --  If the left operand is overloaded, indicate that the
4070
               --  current type is a viable candidate. This is redundant
4071
               --  in most cases, but for equality and comparison operators
4072
               --  where the context does not impose a type on the operands,
4073
               --  setting the proper type is necessary to avoid subsequent
4074
               --  ambiguities during resolution, when both user-defined and
4075
               --  predefined operators may be candidates.
4076
 
4077
               if Is_Overloaded (Left_Opnd (N)) then
4078
                  Set_Etype (Left_Opnd (N), Etype (F1));
4079
               end if;
4080
 
4081
               if Debug_Flag_E then
4082
                  Write_Str ("user defined operator ");
4083
                  Write_Name (Chars (Op_Id));
4084
                  Write_Str (" on node ");
4085
                  Write_Int (Int (N));
4086
                  Write_Eol;
4087
               end if;
4088
            end if;
4089
         end;
4090
      end if;
4091
   end Analyze_User_Defined_Binary_Op;
4092
 
4093
   -----------------------------------
4094
   -- Analyze_User_Defined_Unary_Op --
4095
   -----------------------------------
4096
 
4097
   procedure Analyze_User_Defined_Unary_Op
4098
     (N     : Node_Id;
4099
      Op_Id : Entity_Id)
4100
   is
4101
   begin
4102
      --  Only do analysis if the operator Comes_From_Source, since otherwise
4103
      --  the operator was generated by the expander, and all such operators
4104
      --  always refer to the operators in package Standard.
4105
 
4106
      if Comes_From_Source (N) then
4107
         declare
4108
            F : constant Entity_Id := First_Formal (Op_Id);
4109
 
4110
         begin
4111
            --  Verify that Op_Id is a visible unary function. Note that since
4112
            --  we know Op_Id is overloaded, potentially use visible means use
4113
            --  visible for sure (RM 9.4(11)).
4114
 
4115
            if Ekind (Op_Id) = E_Function
4116
              and then No (Next_Formal (F))
4117
              and then (Is_Immediately_Visible (Op_Id)
4118
                         or else Is_Potentially_Use_Visible (Op_Id))
4119
              and then Has_Compatible_Type (Right_Opnd (N), Etype (F))
4120
            then
4121
               Add_One_Interp (N, Op_Id, Etype (Op_Id));
4122
            end if;
4123
         end;
4124
      end if;
4125
   end Analyze_User_Defined_Unary_Op;
4126
 
4127
   ---------------------------
4128
   -- Check_Arithmetic_Pair --
4129
   ---------------------------
4130
 
4131
   procedure Check_Arithmetic_Pair
4132
     (T1, T2 : Entity_Id;
4133
      Op_Id  : Entity_Id;
4134
      N      : Node_Id)
4135
   is
4136
      Op_Name : constant Name_Id := Chars (Op_Id);
4137
 
4138
      function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean;
4139
      --  Check whether the fixed-point type Typ has a user-defined operator
4140
      --  (multiplication or division) that should hide the corresponding
4141
      --  predefined operator. Used to implement Ada 2005 AI-264, to make
4142
      --  such operators more visible and therefore useful.
4143
 
4144
      --  If the name of the operation is an expanded name with prefix
4145
      --  Standard, the predefined universal fixed operator is available,
4146
      --  as specified by AI-420 (RM 4.5.5 (19.1/2)).
4147
 
4148
      function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
4149
      --  Get specific type (i.e. non-universal type if there is one)
4150
 
4151
      ------------------
4152
      -- Has_Fixed_Op --
4153
      ------------------
4154
 
4155
      function Has_Fixed_Op (Typ : Entity_Id; Op : Entity_Id) return Boolean is
4156
         Bas : constant Entity_Id := Base_Type (Typ);
4157
         Ent : Entity_Id;
4158
         F1  : Entity_Id;
4159
         F2  : Entity_Id;
4160
 
4161
      begin
4162
         --  If the universal_fixed operation is given explicitly the rule
4163
         --  concerning primitive operations of the type do not apply.
4164
 
4165
         if Nkind (N) = N_Function_Call
4166
           and then Nkind (Name (N)) = N_Expanded_Name
4167
           and then Entity (Prefix (Name (N))) = Standard_Standard
4168
         then
4169
            return False;
4170
         end if;
4171
 
4172
         --  The operation is treated as primitive if it is declared in the
4173
         --  same scope as the type, and therefore on the same entity chain.
4174
 
4175
         Ent := Next_Entity (Typ);
4176
         while Present (Ent) loop
4177
            if Chars (Ent) = Chars (Op) then
4178
               F1 := First_Formal (Ent);
4179
               F2 := Next_Formal (F1);
4180
 
4181
               --  The operation counts as primitive if either operand or
4182
               --  result are of the given base type, and both operands are
4183
               --  fixed point types.
4184
 
4185
               if (Base_Type (Etype (F1)) = Bas
4186
                    and then Is_Fixed_Point_Type (Etype (F2)))
4187
 
4188
                 or else
4189
                   (Base_Type (Etype (F2)) = Bas
4190
                     and then Is_Fixed_Point_Type (Etype (F1)))
4191
 
4192
                 or else
4193
                   (Base_Type (Etype (Ent)) = Bas
4194
                     and then Is_Fixed_Point_Type (Etype (F1))
4195
                     and then Is_Fixed_Point_Type (Etype (F2)))
4196
               then
4197
                  return True;
4198
               end if;
4199
            end if;
4200
 
4201
            Next_Entity (Ent);
4202
         end loop;
4203
 
4204
         return False;
4205
      end Has_Fixed_Op;
4206
 
4207
      -------------------
4208
      -- Specific_Type --
4209
      -------------------
4210
 
4211
      function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
4212
      begin
4213
         if T1 = Universal_Integer or else T1 = Universal_Real then
4214
            return Base_Type (T2);
4215
         else
4216
            return Base_Type (T1);
4217
         end if;
4218
      end Specific_Type;
4219
 
4220
   --  Start of processing for Check_Arithmetic_Pair
4221
 
4222
   begin
4223
      if Op_Name = Name_Op_Add or else Op_Name = Name_Op_Subtract then
4224
 
4225
         if Is_Numeric_Type (T1)
4226
           and then Is_Numeric_Type (T2)
4227
           and then (Covers (T1 => T1, T2 => T2)
4228
                       or else
4229
                     Covers (T1 => T2, T2 => T1))
4230
         then
4231
            Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
4232
         end if;
4233
 
4234
      elsif Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide then
4235
 
4236
         if Is_Fixed_Point_Type (T1)
4237
           and then (Is_Fixed_Point_Type (T2)
4238
                       or else T2 = Universal_Real)
4239
         then
4240
            --  If Treat_Fixed_As_Integer is set then the Etype is already set
4241
            --  and no further processing is required (this is the case of an
4242
            --  operator constructed by Exp_Fixd for a fixed point operation)
4243
            --  Otherwise add one interpretation with universal fixed result
4244
            --  If the operator is given in  functional notation, it comes
4245
            --  from source and Fixed_As_Integer cannot apply.
4246
 
4247
            if (Nkind (N) not in N_Op
4248
                 or else not Treat_Fixed_As_Integer (N))
4249
              and then
4250
                (not Has_Fixed_Op (T1, Op_Id)
4251
                  or else Nkind (Parent (N)) = N_Type_Conversion)
4252
            then
4253
               Add_One_Interp (N, Op_Id, Universal_Fixed);
4254
            end if;
4255
 
4256
         elsif Is_Fixed_Point_Type (T2)
4257
           and then (Nkind (N) not in N_Op
4258
                      or else not Treat_Fixed_As_Integer (N))
4259
           and then T1 = Universal_Real
4260
           and then
4261
             (not Has_Fixed_Op (T1, Op_Id)
4262
               or else Nkind (Parent (N)) = N_Type_Conversion)
4263
         then
4264
            Add_One_Interp (N, Op_Id, Universal_Fixed);
4265
 
4266
         elsif Is_Numeric_Type (T1)
4267
           and then Is_Numeric_Type (T2)
4268
           and then (Covers (T1 => T1, T2 => T2)
4269
                       or else
4270
                     Covers (T1 => T2, T2 => T1))
4271
         then
4272
            Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
4273
 
4274
         elsif Is_Fixed_Point_Type (T1)
4275
           and then (Base_Type (T2) = Base_Type (Standard_Integer)
4276
                       or else T2 = Universal_Integer)
4277
         then
4278
            Add_One_Interp (N, Op_Id, T1);
4279
 
4280
         elsif T2 = Universal_Real
4281
           and then Base_Type (T1) = Base_Type (Standard_Integer)
4282
           and then Op_Name = Name_Op_Multiply
4283
         then
4284
            Add_One_Interp (N, Op_Id, Any_Fixed);
4285
 
4286
         elsif T1 = Universal_Real
4287
           and then Base_Type (T2) = Base_Type (Standard_Integer)
4288
         then
4289
            Add_One_Interp (N, Op_Id, Any_Fixed);
4290
 
4291
         elsif Is_Fixed_Point_Type (T2)
4292
           and then (Base_Type (T1) = Base_Type (Standard_Integer)
4293
                       or else T1 = Universal_Integer)
4294
           and then Op_Name = Name_Op_Multiply
4295
         then
4296
            Add_One_Interp (N, Op_Id, T2);
4297
 
4298
         elsif T1 = Universal_Real and then T2 = Universal_Integer then
4299
            Add_One_Interp (N, Op_Id, T1);
4300
 
4301
         elsif T2 = Universal_Real
4302
           and then T1 = Universal_Integer
4303
           and then Op_Name = Name_Op_Multiply
4304
         then
4305
            Add_One_Interp (N, Op_Id, T2);
4306
         end if;
4307
 
4308
      elsif Op_Name = Name_Op_Mod or else Op_Name = Name_Op_Rem then
4309
 
4310
         --  Note: The fixed-point operands case with Treat_Fixed_As_Integer
4311
         --  set does not require any special processing, since the Etype is
4312
         --  already set (case of operation constructed by Exp_Fixed).
4313
 
4314
         if Is_Integer_Type (T1)
4315
           and then (Covers (T1 => T1, T2 => T2)
4316
                       or else
4317
                     Covers (T1 => T2, T2 => T1))
4318
         then
4319
            Add_One_Interp (N, Op_Id, Specific_Type (T1, T2));
4320
         end if;
4321
 
4322
      elsif Op_Name = Name_Op_Expon then
4323
         if Is_Numeric_Type (T1)
4324
           and then not Is_Fixed_Point_Type (T1)
4325
           and then (Base_Type (T2) = Base_Type (Standard_Integer)
4326
                      or else T2 = Universal_Integer)
4327
         then
4328
            Add_One_Interp (N, Op_Id, Base_Type (T1));
4329
         end if;
4330
 
4331
      else pragma Assert (Nkind (N) in N_Op_Shift);
4332
 
4333
         --  If not one of the predefined operators, the node may be one
4334
         --  of the intrinsic functions. Its kind is always specific, and
4335
         --  we can use it directly, rather than the name of the operation.
4336
 
4337
         if Is_Integer_Type (T1)
4338
           and then (Base_Type (T2) = Base_Type (Standard_Integer)
4339
                      or else T2 = Universal_Integer)
4340
         then
4341
            Add_One_Interp (N, Op_Id, Base_Type (T1));
4342
         end if;
4343
      end if;
4344
   end Check_Arithmetic_Pair;
4345
 
4346
   -------------------------------
4347
   -- Check_Misspelled_Selector --
4348
   -------------------------------
4349
 
4350
   procedure Check_Misspelled_Selector
4351
     (Prefix : Entity_Id;
4352
      Sel    : Node_Id)
4353
   is
4354
      Max_Suggestions   : constant := 2;
4355
      Nr_Of_Suggestions : Natural := 0;
4356
 
4357
      Suggestion_1 : Entity_Id := Empty;
4358
      Suggestion_2 : Entity_Id := Empty;
4359
 
4360
      Comp : Entity_Id;
4361
 
4362
   begin
4363
      --  All the components of the prefix of selector Sel are matched
4364
      --  against  Sel and a count is maintained of possible misspellings.
4365
      --  When at the end of the analysis there are one or two (not more!)
4366
      --  possible misspellings, these misspellings will be suggested as
4367
      --  possible correction.
4368
 
4369
      if not (Is_Private_Type (Prefix) or else Is_Record_Type (Prefix)) then
4370
 
4371
         --  Concurrent types should be handled as well ???
4372
 
4373
         return;
4374
      end if;
4375
 
4376
      Comp  := First_Entity (Prefix);
4377
      while Nr_Of_Suggestions <= Max_Suggestions and then Present (Comp) loop
4378
         if Is_Visible_Component (Comp) then
4379
            if Is_Bad_Spelling_Of (Chars (Comp), Chars (Sel)) then
4380
               Nr_Of_Suggestions := Nr_Of_Suggestions + 1;
4381
 
4382
               case Nr_Of_Suggestions is
4383
                  when 1      => Suggestion_1 := Comp;
4384
                  when 2      => Suggestion_2 := Comp;
4385
                  when others => exit;
4386
               end case;
4387
            end if;
4388
         end if;
4389
 
4390
         Comp := Next_Entity (Comp);
4391
      end loop;
4392
 
4393
      --  Report at most two suggestions
4394
 
4395
      if Nr_Of_Suggestions = 1 then
4396
         Error_Msg_NE -- CODEFIX
4397
           ("\possible misspelling of&", Sel, Suggestion_1);
4398
 
4399
      elsif Nr_Of_Suggestions = 2 then
4400
         Error_Msg_Node_2 := Suggestion_2;
4401
         Error_Msg_NE -- CODEFIX
4402
           ("\possible misspelling of& or&", Sel, Suggestion_1);
4403
      end if;
4404
   end Check_Misspelled_Selector;
4405
 
4406
   ----------------------
4407
   -- Defined_In_Scope --
4408
   ----------------------
4409
 
4410
   function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean
4411
   is
4412
      S1 : constant Entity_Id := Scope (Base_Type (T));
4413
   begin
4414
      return S1 = S
4415
        or else (S1 = System_Aux_Id and then S = Scope (S1));
4416
   end Defined_In_Scope;
4417
 
4418
   -------------------
4419
   -- Diagnose_Call --
4420
   -------------------
4421
 
4422
   procedure Diagnose_Call (N : Node_Id; Nam : Node_Id) is
4423
      Actual           : Node_Id;
4424
      X                : Interp_Index;
4425
      It               : Interp;
4426
      Err_Mode         : Boolean;
4427
      New_Nam          : Node_Id;
4428
      Void_Interp_Seen : Boolean := False;
4429
 
4430
      Success : Boolean;
4431
      pragma Warnings (Off, Boolean);
4432
 
4433
   begin
4434
      if Ada_Version >= Ada_05 then
4435
         Actual := First_Actual (N);
4436
         while Present (Actual) loop
4437
 
4438
            --  Ada 2005 (AI-50217): Post an error in case of premature
4439
            --  usage of an entity from the limited view.
4440
 
4441
            if not Analyzed (Etype (Actual))
4442
             and then From_With_Type (Etype (Actual))
4443
            then
4444
               Error_Msg_Qual_Level := 1;
4445
               Error_Msg_NE
4446
                ("missing with_clause for scope of imported type&",
4447
                  Actual, Etype (Actual));
4448
               Error_Msg_Qual_Level := 0;
4449
            end if;
4450
 
4451
            Next_Actual (Actual);
4452
         end loop;
4453
      end if;
4454
 
4455
      --   Analyze each candidate call again, with full error reporting
4456
      --   for each.
4457
 
4458
      Error_Msg_N
4459
        ("no candidate interpretations match the actuals:!", Nam);
4460
      Err_Mode := All_Errors_Mode;
4461
      All_Errors_Mode := True;
4462
 
4463
      --  If this is a call to an operation of a concurrent type,
4464
      --  the failed interpretations have been removed from the
4465
      --  name. Recover them to provide full diagnostics.
4466
 
4467
      if Nkind (Parent (Nam)) = N_Selected_Component then
4468
         Set_Entity (Nam, Empty);
4469
         New_Nam := New_Copy_Tree (Parent (Nam));
4470
         Set_Is_Overloaded (New_Nam, False);
4471
         Set_Is_Overloaded (Selector_Name (New_Nam), False);
4472
         Set_Parent (New_Nam, Parent (Parent (Nam)));
4473
         Analyze_Selected_Component (New_Nam);
4474
         Get_First_Interp (Selector_Name (New_Nam), X, It);
4475
      else
4476
         Get_First_Interp (Nam, X, It);
4477
      end if;
4478
 
4479
      while Present (It.Nam) loop
4480
         if Etype (It.Nam) = Standard_Void_Type then
4481
            Void_Interp_Seen := True;
4482
         end if;
4483
 
4484
         Analyze_One_Call (N, It.Nam, True, Success);
4485
         Get_Next_Interp (X, It);
4486
      end loop;
4487
 
4488
      if Nkind (N) = N_Function_Call then
4489
         Get_First_Interp (Nam, X, It);
4490
         while Present (It.Nam) loop
4491
            if Ekind (It.Nam) = E_Function
4492
              or else Ekind (It.Nam) = E_Operator
4493
            then
4494
               return;
4495
            else
4496
               Get_Next_Interp (X, It);
4497
            end if;
4498
         end loop;
4499
 
4500
         --  If all interpretations are procedures, this deserves a
4501
         --  more precise message. Ditto if this appears as the prefix
4502
         --  of a selected component, which may be a lexical error.
4503
 
4504
         Error_Msg_N
4505
           ("\context requires function call, found procedure name", Nam);
4506
 
4507
         if Nkind (Parent (N)) = N_Selected_Component
4508
           and then N = Prefix (Parent (N))
4509
         then
4510
            Error_Msg_N -- CODEFIX
4511
              ("\period should probably be semicolon", Parent (N));
4512
         end if;
4513
 
4514
      elsif Nkind (N) = N_Procedure_Call_Statement
4515
        and then not Void_Interp_Seen
4516
      then
4517
         Error_Msg_N (
4518
         "\function name found in procedure call", Nam);
4519
      end if;
4520
 
4521
      All_Errors_Mode := Err_Mode;
4522
   end Diagnose_Call;
4523
 
4524
   ---------------------------
4525
   -- Find_Arithmetic_Types --
4526
   ---------------------------
4527
 
4528
   procedure Find_Arithmetic_Types
4529
     (L, R  : Node_Id;
4530
      Op_Id : Entity_Id;
4531
      N     : Node_Id)
4532
   is
4533
      Index1 : Interp_Index;
4534
      Index2 : Interp_Index;
4535
      It1    : Interp;
4536
      It2    : Interp;
4537
 
4538
      procedure Check_Right_Argument (T : Entity_Id);
4539
      --  Check right operand of operator
4540
 
4541
      --------------------------
4542
      -- Check_Right_Argument --
4543
      --------------------------
4544
 
4545
      procedure Check_Right_Argument (T : Entity_Id) is
4546
      begin
4547
         if not Is_Overloaded (R) then
4548
            Check_Arithmetic_Pair (T, Etype (R), Op_Id,  N);
4549
         else
4550
            Get_First_Interp (R, Index2, It2);
4551
            while Present (It2.Typ) loop
4552
               Check_Arithmetic_Pair (T, It2.Typ, Op_Id, N);
4553
               Get_Next_Interp (Index2, It2);
4554
            end loop;
4555
         end if;
4556
      end Check_Right_Argument;
4557
 
4558
   --  Start of processing for Find_Arithmetic_Types
4559
 
4560
   begin
4561
      if not Is_Overloaded (L) then
4562
         Check_Right_Argument (Etype (L));
4563
 
4564
      else
4565
         Get_First_Interp (L, Index1, It1);
4566
         while Present (It1.Typ) loop
4567
            Check_Right_Argument (It1.Typ);
4568
            Get_Next_Interp (Index1, It1);
4569
         end loop;
4570
      end if;
4571
 
4572
   end Find_Arithmetic_Types;
4573
 
4574
   ------------------------
4575
   -- Find_Boolean_Types --
4576
   ------------------------
4577
 
4578
   procedure Find_Boolean_Types
4579
     (L, R  : Node_Id;
4580
      Op_Id : Entity_Id;
4581
      N     : Node_Id)
4582
   is
4583
      Index : Interp_Index;
4584
      It    : Interp;
4585
 
4586
      procedure Check_Numeric_Argument (T : Entity_Id);
4587
      --  Special case for logical operations one of whose operands is an
4588
      --  integer literal. If both are literal the result is any modular type.
4589
 
4590
      ----------------------------
4591
      -- Check_Numeric_Argument --
4592
      ----------------------------
4593
 
4594
      procedure Check_Numeric_Argument (T : Entity_Id) is
4595
      begin
4596
         if T = Universal_Integer then
4597
            Add_One_Interp (N, Op_Id, Any_Modular);
4598
 
4599
         elsif Is_Modular_Integer_Type (T) then
4600
            Add_One_Interp (N, Op_Id, T);
4601
         end if;
4602
      end Check_Numeric_Argument;
4603
 
4604
   --  Start of processing for Find_Boolean_Types
4605
 
4606
   begin
4607
      if not Is_Overloaded (L) then
4608
         if Etype (L) = Universal_Integer
4609
           or else Etype (L) = Any_Modular
4610
         then
4611
            if not Is_Overloaded (R) then
4612
               Check_Numeric_Argument (Etype (R));
4613
 
4614
            else
4615
               Get_First_Interp (R, Index, It);
4616
               while Present (It.Typ) loop
4617
                  Check_Numeric_Argument (It.Typ);
4618
                  Get_Next_Interp (Index, It);
4619
               end loop;
4620
            end if;
4621
 
4622
         --  If operands are aggregates, we must assume that they may be
4623
         --  boolean arrays, and leave disambiguation for the second pass.
4624
         --  If only one is an aggregate, verify that the other one has an
4625
         --  interpretation as a boolean array
4626
 
4627
         elsif Nkind (L) = N_Aggregate then
4628
            if Nkind (R) = N_Aggregate then
4629
               Add_One_Interp (N, Op_Id, Etype (L));
4630
 
4631
            elsif not Is_Overloaded (R) then
4632
               if Valid_Boolean_Arg (Etype (R)) then
4633
                  Add_One_Interp (N, Op_Id, Etype (R));
4634
               end if;
4635
 
4636
            else
4637
               Get_First_Interp (R, Index, It);
4638
               while Present (It.Typ) loop
4639
                  if Valid_Boolean_Arg (It.Typ) then
4640
                     Add_One_Interp (N, Op_Id, It.Typ);
4641
                  end if;
4642
 
4643
                  Get_Next_Interp (Index, It);
4644
               end loop;
4645
            end if;
4646
 
4647
         elsif Valid_Boolean_Arg (Etype (L))
4648
           and then Has_Compatible_Type (R, Etype (L))
4649
         then
4650
            Add_One_Interp (N, Op_Id, Etype (L));
4651
         end if;
4652
 
4653
      else
4654
         Get_First_Interp (L, Index, It);
4655
         while Present (It.Typ) loop
4656
            if Valid_Boolean_Arg (It.Typ)
4657
              and then Has_Compatible_Type (R, It.Typ)
4658
            then
4659
               Add_One_Interp (N, Op_Id, It.Typ);
4660
            end if;
4661
 
4662
            Get_Next_Interp (Index, It);
4663
         end loop;
4664
      end if;
4665
   end Find_Boolean_Types;
4666
 
4667
   ---------------------------
4668
   -- Find_Comparison_Types --
4669
   ---------------------------
4670
 
4671
   procedure Find_Comparison_Types
4672
     (L, R  : Node_Id;
4673
      Op_Id : Entity_Id;
4674
      N     : Node_Id)
4675
   is
4676
      Index : Interp_Index;
4677
      It    : Interp;
4678
      Found : Boolean := False;
4679
      I_F   : Interp_Index;
4680
      T_F   : Entity_Id;
4681
      Scop  : Entity_Id := Empty;
4682
 
4683
      procedure Try_One_Interp (T1 : Entity_Id);
4684
      --  Routine to try one proposed interpretation. Note that the context
4685
      --  of the operator plays no role in resolving the arguments, so that
4686
      --  if there is more than one interpretation of the operands that is
4687
      --  compatible with comparison, the operation is ambiguous.
4688
 
4689
      --------------------
4690
      -- Try_One_Interp --
4691
      --------------------
4692
 
4693
      procedure Try_One_Interp (T1 : Entity_Id) is
4694
      begin
4695
 
4696
         --  If the operator is an expanded name, then the type of the operand
4697
         --  must be defined in the corresponding scope. If the type is
4698
         --  universal, the context will impose the correct type.
4699
 
4700
         if Present (Scop)
4701
            and then not Defined_In_Scope (T1, Scop)
4702
            and then T1 /= Universal_Integer
4703
            and then T1 /= Universal_Real
4704
            and then T1 /= Any_String
4705
            and then T1 /= Any_Composite
4706
         then
4707
            return;
4708
         end if;
4709
 
4710
         if Valid_Comparison_Arg (T1)
4711
           and then Has_Compatible_Type (R, T1)
4712
         then
4713
            if Found
4714
              and then Base_Type (T1) /= Base_Type (T_F)
4715
            then
4716
               It := Disambiguate (L, I_F, Index, Any_Type);
4717
 
4718
               if It = No_Interp then
4719
                  Ambiguous_Operands (N);
4720
                  Set_Etype (L, Any_Type);
4721
                  return;
4722
 
4723
               else
4724
                  T_F := It.Typ;
4725
               end if;
4726
 
4727
            else
4728
               Found := True;
4729
               T_F   := T1;
4730
               I_F   := Index;
4731
            end if;
4732
 
4733
            Set_Etype (L, T_F);
4734
            Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
4735
 
4736
         end if;
4737
      end Try_One_Interp;
4738
 
4739
   --  Start of processing for Find_Comparison_Types
4740
 
4741
   begin
4742
      --  If left operand is aggregate, the right operand has to
4743
      --  provide a usable type for it.
4744
 
4745
      if Nkind (L) = N_Aggregate
4746
        and then Nkind (R) /= N_Aggregate
4747
      then
4748
         Find_Comparison_Types (L => R, R => L, Op_Id => Op_Id, N => N);
4749
         return;
4750
      end if;
4751
 
4752
      if Nkind (N) = N_Function_Call
4753
         and then Nkind (Name (N)) = N_Expanded_Name
4754
      then
4755
         Scop := Entity (Prefix (Name (N)));
4756
 
4757
         --  The prefix may be a package renaming, and the subsequent test
4758
         --  requires the original package.
4759
 
4760
         if Ekind (Scop) = E_Package
4761
           and then Present (Renamed_Entity (Scop))
4762
         then
4763
            Scop := Renamed_Entity (Scop);
4764
            Set_Entity (Prefix (Name (N)), Scop);
4765
         end if;
4766
      end if;
4767
 
4768
      if not Is_Overloaded (L) then
4769
         Try_One_Interp (Etype (L));
4770
 
4771
      else
4772
         Get_First_Interp (L, Index, It);
4773
         while Present (It.Typ) loop
4774
            Try_One_Interp (It.Typ);
4775
            Get_Next_Interp (Index, It);
4776
         end loop;
4777
      end if;
4778
   end Find_Comparison_Types;
4779
 
4780
   ----------------------------------------
4781
   -- Find_Non_Universal_Interpretations --
4782
   ----------------------------------------
4783
 
4784
   procedure Find_Non_Universal_Interpretations
4785
     (N     : Node_Id;
4786
      R     : Node_Id;
4787
      Op_Id : Entity_Id;
4788
      T1    : Entity_Id)
4789
   is
4790
      Index : Interp_Index;
4791
      It    : Interp;
4792
 
4793
   begin
4794
      if T1 = Universal_Integer
4795
        or else T1 = Universal_Real
4796
      then
4797
         if not Is_Overloaded (R) then
4798
            Add_One_Interp
4799
              (N, Op_Id, Standard_Boolean, Base_Type (Etype (R)));
4800
         else
4801
            Get_First_Interp (R, Index, It);
4802
            while Present (It.Typ) loop
4803
               if Covers (It.Typ, T1) then
4804
                  Add_One_Interp
4805
                    (N, Op_Id, Standard_Boolean, Base_Type (It.Typ));
4806
               end if;
4807
 
4808
               Get_Next_Interp (Index, It);
4809
            end loop;
4810
         end if;
4811
      else
4812
         Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (T1));
4813
      end if;
4814
   end Find_Non_Universal_Interpretations;
4815
 
4816
   ------------------------------
4817
   -- Find_Concatenation_Types --
4818
   ------------------------------
4819
 
4820
   procedure Find_Concatenation_Types
4821
     (L, R  : Node_Id;
4822
      Op_Id : Entity_Id;
4823
      N     : Node_Id)
4824
   is
4825
      Op_Type : constant Entity_Id := Etype (Op_Id);
4826
 
4827
   begin
4828
      if Is_Array_Type (Op_Type)
4829
        and then not Is_Limited_Type (Op_Type)
4830
 
4831
        and then (Has_Compatible_Type (L, Op_Type)
4832
                    or else
4833
                  Has_Compatible_Type (L, Component_Type (Op_Type)))
4834
 
4835
        and then (Has_Compatible_Type (R, Op_Type)
4836
                    or else
4837
                  Has_Compatible_Type (R, Component_Type (Op_Type)))
4838
      then
4839
         Add_One_Interp (N, Op_Id, Op_Type);
4840
      end if;
4841
   end Find_Concatenation_Types;
4842
 
4843
   -------------------------
4844
   -- Find_Equality_Types --
4845
   -------------------------
4846
 
4847
   procedure Find_Equality_Types
4848
     (L, R  : Node_Id;
4849
      Op_Id : Entity_Id;
4850
      N     : Node_Id)
4851
   is
4852
      Index : Interp_Index;
4853
      It    : Interp;
4854
      Found : Boolean := False;
4855
      I_F   : Interp_Index;
4856
      T_F   : Entity_Id;
4857
      Scop  : Entity_Id := Empty;
4858
 
4859
      procedure Try_One_Interp (T1 : Entity_Id);
4860
      --  The context of the equality operator plays no role in resolving the
4861
      --  arguments, so that if there is more than one interpretation of the
4862
      --  operands that is compatible with equality, the construct is ambiguous
4863
      --  and an error can be emitted now, after trying to disambiguate, i.e.
4864
      --  applying preference rules.
4865
 
4866
      --------------------
4867
      -- Try_One_Interp --
4868
      --------------------
4869
 
4870
      procedure Try_One_Interp (T1 : Entity_Id) is
4871
         Bas : constant Entity_Id := Base_Type (T1);
4872
 
4873
      begin
4874
         --  If the operator is an expanded name, then the type of the operand
4875
         --  must be defined in the corresponding scope. If the type is
4876
         --  universal, the context will impose the correct type. An anonymous
4877
         --  type for a 'Access reference is also universal in this sense, as
4878
         --  the actual type is obtained from context.
4879
         --  In Ada 2005, the equality operator for anonymous access types
4880
         --  is declared in Standard, and preference rules apply to it.
4881
 
4882
         if Present (Scop) then
4883
            if Defined_In_Scope (T1, Scop)
4884
              or else T1 = Universal_Integer
4885
              or else T1 = Universal_Real
4886
              or else T1 = Any_Access
4887
              or else T1 = Any_String
4888
              or else T1 = Any_Composite
4889
              or else (Ekind (T1) = E_Access_Subprogram_Type
4890
                        and then not Comes_From_Source (T1))
4891
            then
4892
               null;
4893
 
4894
            elsif Ekind (T1) = E_Anonymous_Access_Type
4895
              and then Scop = Standard_Standard
4896
            then
4897
               null;
4898
 
4899
            else
4900
               --  The scope does not contain an operator for the type
4901
 
4902
               return;
4903
            end if;
4904
 
4905
         --  If we have infix notation, the operator must be usable.
4906
         --  Within an instance, if the type is already established we
4907
         --  know it is correct.
4908
         --  In Ada 2005, the equality on anonymous access types is declared
4909
         --  in Standard, and is always visible.
4910
 
4911
         elsif In_Open_Scopes (Scope (Bas))
4912
           or else Is_Potentially_Use_Visible (Bas)
4913
           or else In_Use (Bas)
4914
           or else (In_Use (Scope (Bas))
4915
                     and then not Is_Hidden (Bas))
4916
           or else (In_Instance
4917
                     and then First_Subtype (T1) = First_Subtype (Etype (R)))
4918
           or else Ekind (T1) = E_Anonymous_Access_Type
4919
         then
4920
            null;
4921
 
4922
         else
4923
            --  Save candidate type for subsquent error message, if any
4924
 
4925
            if not Is_Limited_Type (T1) then
4926
               Candidate_Type := T1;
4927
            end if;
4928
 
4929
            return;
4930
         end if;
4931
 
4932
         --  Ada 2005 (AI-230): Keep restriction imposed by Ada 83 and 95:
4933
         --  Do not allow anonymous access types in equality operators.
4934
 
4935
         if Ada_Version < Ada_05
4936
           and then Ekind (T1) = E_Anonymous_Access_Type
4937
         then
4938
            return;
4939
         end if;
4940
 
4941
         if T1 /= Standard_Void_Type
4942
           and then not Is_Limited_Type (T1)
4943
           and then not Is_Limited_Composite (T1)
4944
           and then Has_Compatible_Type (R, T1)
4945
         then
4946
            if Found
4947
              and then Base_Type (T1) /= Base_Type (T_F)
4948
            then
4949
               It := Disambiguate (L, I_F, Index, Any_Type);
4950
 
4951
               if It = No_Interp then
4952
                  Ambiguous_Operands (N);
4953
                  Set_Etype (L, Any_Type);
4954
                  return;
4955
 
4956
               else
4957
                  T_F := It.Typ;
4958
               end if;
4959
 
4960
            else
4961
               Found := True;
4962
               T_F   := T1;
4963
               I_F   := Index;
4964
            end if;
4965
 
4966
            if not Analyzed (L) then
4967
               Set_Etype (L, T_F);
4968
            end if;
4969
 
4970
            Find_Non_Universal_Interpretations (N, R, Op_Id, T1);
4971
 
4972
            --  Case of operator was not visible, Etype still set to Any_Type
4973
 
4974
            if Etype (N) = Any_Type then
4975
               Found := False;
4976
            end if;
4977
 
4978
         elsif Scop = Standard_Standard
4979
           and then Ekind (T1) = E_Anonymous_Access_Type
4980
         then
4981
            Found := True;
4982
         end if;
4983
      end Try_One_Interp;
4984
 
4985
   --  Start of processing for Find_Equality_Types
4986
 
4987
   begin
4988
      --  If left operand is aggregate, the right operand has to
4989
      --  provide a usable type for it.
4990
 
4991
      if Nkind (L) = N_Aggregate
4992
        and then Nkind (R) /= N_Aggregate
4993
      then
4994
         Find_Equality_Types (L => R, R => L, Op_Id => Op_Id, N => N);
4995
         return;
4996
      end if;
4997
 
4998
      if Nkind (N) = N_Function_Call
4999
         and then Nkind (Name (N)) = N_Expanded_Name
5000
      then
5001
         Scop := Entity (Prefix (Name (N)));
5002
 
5003
         --  The prefix may be a package renaming, and the subsequent test
5004
         --  requires the original package.
5005
 
5006
         if Ekind (Scop) = E_Package
5007
           and then Present (Renamed_Entity (Scop))
5008
         then
5009
            Scop := Renamed_Entity (Scop);
5010
            Set_Entity (Prefix (Name (N)), Scop);
5011
         end if;
5012
      end if;
5013
 
5014
      if not Is_Overloaded (L) then
5015
         Try_One_Interp (Etype (L));
5016
 
5017
      else
5018
         Get_First_Interp (L, Index, It);
5019
         while Present (It.Typ) loop
5020
            Try_One_Interp (It.Typ);
5021
            Get_Next_Interp (Index, It);
5022
         end loop;
5023
      end if;
5024
   end Find_Equality_Types;
5025
 
5026
   -------------------------
5027
   -- Find_Negation_Types --
5028
   -------------------------
5029
 
5030
   procedure Find_Negation_Types
5031
     (R     : Node_Id;
5032
      Op_Id : Entity_Id;
5033
      N     : Node_Id)
5034
   is
5035
      Index : Interp_Index;
5036
      It    : Interp;
5037
 
5038
   begin
5039
      if not Is_Overloaded (R) then
5040
         if Etype (R) = Universal_Integer then
5041
            Add_One_Interp (N, Op_Id, Any_Modular);
5042
         elsif Valid_Boolean_Arg (Etype (R)) then
5043
            Add_One_Interp (N, Op_Id, Etype (R));
5044
         end if;
5045
 
5046
      else
5047
         Get_First_Interp (R, Index, It);
5048
         while Present (It.Typ) loop
5049
            if Valid_Boolean_Arg (It.Typ) then
5050
               Add_One_Interp (N, Op_Id, It.Typ);
5051
            end if;
5052
 
5053
            Get_Next_Interp (Index, It);
5054
         end loop;
5055
      end if;
5056
   end Find_Negation_Types;
5057
 
5058
   ------------------------------
5059
   -- Find_Primitive_Operation --
5060
   ------------------------------
5061
 
5062
   function Find_Primitive_Operation (N : Node_Id) return Boolean is
5063
      Obj : constant Node_Id := Prefix (N);
5064
      Op  : constant Node_Id := Selector_Name (N);
5065
 
5066
      Prim  : Elmt_Id;
5067
      Prims : Elist_Id;
5068
      Typ   : Entity_Id;
5069
 
5070
   begin
5071
      Set_Etype (Op, Any_Type);
5072
 
5073
      if Is_Access_Type (Etype (Obj)) then
5074
         Typ := Designated_Type (Etype (Obj));
5075
      else
5076
         Typ := Etype (Obj);
5077
      end if;
5078
 
5079
      if Is_Class_Wide_Type (Typ) then
5080
         Typ := Root_Type (Typ);
5081
      end if;
5082
 
5083
      Prims := Primitive_Operations (Typ);
5084
 
5085
      Prim := First_Elmt (Prims);
5086
      while Present (Prim) loop
5087
         if Chars (Node (Prim)) = Chars (Op) then
5088
            Add_One_Interp (Op, Node (Prim), Etype (Node (Prim)));
5089
            Set_Etype (N, Etype (Node (Prim)));
5090
         end if;
5091
 
5092
         Next_Elmt (Prim);
5093
      end loop;
5094
 
5095
      --  Now look for class-wide operations of the type or any of its
5096
      --  ancestors by iterating over the homonyms of the selector.
5097
 
5098
      declare
5099
         Cls_Type : constant Entity_Id := Class_Wide_Type (Typ);
5100
         Hom      : Entity_Id;
5101
 
5102
      begin
5103
         Hom := Current_Entity (Op);
5104
         while Present (Hom) loop
5105
            if (Ekind (Hom) = E_Procedure
5106
                  or else
5107
                Ekind (Hom) = E_Function)
5108
              and then Scope (Hom) = Scope (Typ)
5109
              and then Present (First_Formal (Hom))
5110
              and then
5111
                (Base_Type (Etype (First_Formal (Hom))) = Cls_Type
5112
                  or else
5113
                    (Is_Access_Type (Etype (First_Formal (Hom)))
5114
                       and then
5115
                         Ekind (Etype (First_Formal (Hom))) =
5116
                           E_Anonymous_Access_Type
5117
                       and then
5118
                         Base_Type
5119
                           (Designated_Type (Etype (First_Formal (Hom)))) =
5120
                                                                Cls_Type))
5121
            then
5122
               Add_One_Interp (Op, Hom, Etype (Hom));
5123
               Set_Etype (N, Etype (Hom));
5124
            end if;
5125
 
5126
            Hom := Homonym (Hom);
5127
         end loop;
5128
      end;
5129
 
5130
      return Etype (Op) /= Any_Type;
5131
   end Find_Primitive_Operation;
5132
 
5133
   ----------------------
5134
   -- Find_Unary_Types --
5135
   ----------------------
5136
 
5137
   procedure Find_Unary_Types
5138
     (R     : Node_Id;
5139
      Op_Id : Entity_Id;
5140
      N     : Node_Id)
5141
   is
5142
      Index : Interp_Index;
5143
      It    : Interp;
5144
 
5145
   begin
5146
      if not Is_Overloaded (R) then
5147
         if Is_Numeric_Type (Etype (R)) then
5148
            Add_One_Interp (N, Op_Id, Base_Type (Etype (R)));
5149
         end if;
5150
 
5151
      else
5152
         Get_First_Interp (R, Index, It);
5153
         while Present (It.Typ) loop
5154
            if Is_Numeric_Type (It.Typ) then
5155
               Add_One_Interp (N, Op_Id, Base_Type (It.Typ));
5156
            end if;
5157
 
5158
            Get_Next_Interp (Index, It);
5159
         end loop;
5160
      end if;
5161
   end Find_Unary_Types;
5162
 
5163
   ------------------
5164
   -- Junk_Operand --
5165
   ------------------
5166
 
5167
   function Junk_Operand (N : Node_Id) return Boolean is
5168
      Enode : Node_Id;
5169
 
5170
   begin
5171
      if Error_Posted (N) then
5172
         return False;
5173
      end if;
5174
 
5175
      --  Get entity to be tested
5176
 
5177
      if Is_Entity_Name (N)
5178
        and then Present (Entity (N))
5179
      then
5180
         Enode := N;
5181
 
5182
      --  An odd case, a procedure name gets converted to a very peculiar
5183
      --  function call, and here is where we detect this happening.
5184
 
5185
      elsif Nkind (N) = N_Function_Call
5186
        and then Is_Entity_Name (Name (N))
5187
        and then Present (Entity (Name (N)))
5188
      then
5189
         Enode := Name (N);
5190
 
5191
      --  Another odd case, there are at least some cases of selected
5192
      --  components where the selected component is not marked as having
5193
      --  an entity, even though the selector does have an entity
5194
 
5195
      elsif Nkind (N) = N_Selected_Component
5196
        and then Present (Entity (Selector_Name (N)))
5197
      then
5198
         Enode := Selector_Name (N);
5199
 
5200
      else
5201
         return False;
5202
      end if;
5203
 
5204
      --  Now test the entity we got to see if it is a bad case
5205
 
5206
      case Ekind (Entity (Enode)) is
5207
 
5208
         when E_Package =>
5209
            Error_Msg_N
5210
              ("package name cannot be used as operand", Enode);
5211
 
5212
         when Generic_Unit_Kind =>
5213
            Error_Msg_N
5214
              ("generic unit name cannot be used as operand", Enode);
5215
 
5216
         when Type_Kind =>
5217
            Error_Msg_N
5218
              ("subtype name cannot be used as operand", Enode);
5219
 
5220
         when Entry_Kind =>
5221
            Error_Msg_N
5222
              ("entry name cannot be used as operand", Enode);
5223
 
5224
         when E_Procedure =>
5225
            Error_Msg_N
5226
              ("procedure name cannot be used as operand", Enode);
5227
 
5228
         when E_Exception =>
5229
            Error_Msg_N
5230
              ("exception name cannot be used as operand", Enode);
5231
 
5232
         when E_Block | E_Label | E_Loop =>
5233
            Error_Msg_N
5234
              ("label name cannot be used as operand", Enode);
5235
 
5236
         when others =>
5237
            return False;
5238
 
5239
      end case;
5240
 
5241
      return True;
5242
   end Junk_Operand;
5243
 
5244
   --------------------
5245
   -- Operator_Check --
5246
   --------------------
5247
 
5248
   procedure Operator_Check (N : Node_Id) is
5249
   begin
5250
      Remove_Abstract_Operations (N);
5251
 
5252
      --  Test for case of no interpretation found for operator
5253
 
5254
      if Etype (N) = Any_Type then
5255
         declare
5256
            L     : Node_Id;
5257
            R     : Node_Id;
5258
            Op_Id : Entity_Id := Empty;
5259
 
5260
         begin
5261
            R := Right_Opnd (N);
5262
 
5263
            if Nkind (N) in N_Binary_Op then
5264
               L := Left_Opnd (N);
5265
            else
5266
               L := Empty;
5267
            end if;
5268
 
5269
            --  If either operand has no type, then don't complain further,
5270
            --  since this simply means that we have a propagated error.
5271
 
5272
            if R = Error
5273
              or else Etype (R) = Any_Type
5274
              or else (Nkind (N) in N_Binary_Op and then Etype (L) = Any_Type)
5275
            then
5276
               return;
5277
 
5278
            --  We explicitly check for the case of concatenation of component
5279
            --  with component to avoid reporting spurious matching array types
5280
            --  that might happen to be lurking in distant packages (such as
5281
            --  run-time packages). This also prevents inconsistencies in the
5282
            --  messages for certain ACVC B tests, which can vary depending on
5283
            --  types declared in run-time interfaces. Another improvement when
5284
            --  aggregates are present is to look for a well-typed operand.
5285
 
5286
            elsif Present (Candidate_Type)
5287
              and then (Nkind (N) /= N_Op_Concat
5288
                         or else Is_Array_Type (Etype (L))
5289
                         or else Is_Array_Type (Etype (R)))
5290
            then
5291
 
5292
               if Nkind (N) = N_Op_Concat then
5293
                  if Etype (L) /= Any_Composite
5294
                    and then Is_Array_Type (Etype (L))
5295
                  then
5296
                     Candidate_Type := Etype (L);
5297
 
5298
                  elsif Etype (R) /= Any_Composite
5299
                    and then Is_Array_Type (Etype (R))
5300
                  then
5301
                     Candidate_Type := Etype (R);
5302
                  end if;
5303
               end if;
5304
 
5305
               Error_Msg_NE
5306
                 ("operator for} is not directly visible!",
5307
                  N, First_Subtype (Candidate_Type));
5308
               Error_Msg_N ("use clause would make operation legal!",  N);
5309
               return;
5310
 
5311
            --  If either operand is a junk operand (e.g. package name), then
5312
            --  post appropriate error messages, but do not complain further.
5313
 
5314
            --  Note that the use of OR in this test instead of OR ELSE is
5315
            --  quite deliberate, we may as well check both operands in the
5316
            --  binary operator case.
5317
 
5318
            elsif Junk_Operand (R)
5319
              or (Nkind (N) in N_Binary_Op and then Junk_Operand (L))
5320
            then
5321
               return;
5322
 
5323
            --  If we have a logical operator, one of whose operands is
5324
            --  Boolean, then we know that the other operand cannot resolve to
5325
            --  Boolean (since we got no interpretations), but in that case we
5326
            --  pretty much know that the other operand should be Boolean, so
5327
            --  resolve it that way (generating an error)
5328
 
5329
            elsif Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor) then
5330
               if Etype (L) = Standard_Boolean then
5331
                  Resolve (R, Standard_Boolean);
5332
                  return;
5333
               elsif Etype (R) = Standard_Boolean then
5334
                  Resolve (L, Standard_Boolean);
5335
                  return;
5336
               end if;
5337
 
5338
            --  For an arithmetic operator or comparison operator, if one
5339
            --  of the operands is numeric, then we know the other operand
5340
            --  is not the same numeric type. If it is a non-numeric type,
5341
            --  then probably it is intended to match the other operand.
5342
 
5343
            elsif Nkind_In (N, N_Op_Add,
5344
                               N_Op_Divide,
5345
                               N_Op_Ge,
5346
                               N_Op_Gt,
5347
                               N_Op_Le)
5348
              or else
5349
                  Nkind_In (N, N_Op_Lt,
5350
                               N_Op_Mod,
5351
                               N_Op_Multiply,
5352
                               N_Op_Rem,
5353
                               N_Op_Subtract)
5354
            then
5355
               if Is_Numeric_Type (Etype (L))
5356
                 and then not Is_Numeric_Type (Etype (R))
5357
               then
5358
                  Resolve (R, Etype (L));
5359
                  return;
5360
 
5361
               elsif Is_Numeric_Type (Etype (R))
5362
                 and then not Is_Numeric_Type (Etype (L))
5363
               then
5364
                  Resolve (L, Etype (R));
5365
                  return;
5366
               end if;
5367
 
5368
            --  Comparisons on A'Access are common enough to deserve a
5369
            --  special message.
5370
 
5371
            elsif Nkind_In (N, N_Op_Eq, N_Op_Ne)
5372
               and then Ekind (Etype (L)) = E_Access_Attribute_Type
5373
               and then Ekind (Etype (R)) = E_Access_Attribute_Type
5374
            then
5375
               Error_Msg_N
5376
                 ("two access attributes cannot be compared directly", N);
5377
               Error_Msg_N
5378
                 ("\use qualified expression for one of the operands",
5379
                   N);
5380
               return;
5381
 
5382
            --  Another one for C programmers
5383
 
5384
            elsif Nkind (N) = N_Op_Concat
5385
              and then Valid_Boolean_Arg (Etype (L))
5386
              and then Valid_Boolean_Arg (Etype (R))
5387
            then
5388
               Error_Msg_N ("invalid operands for concatenation", N);
5389
               Error_Msg_N -- CODEFIX
5390
                 ("\maybe AND was meant", N);
5391
               return;
5392
 
5393
            --  A special case for comparison of access parameter with null
5394
 
5395
            elsif Nkind (N) = N_Op_Eq
5396
              and then Is_Entity_Name (L)
5397
              and then Nkind (Parent (Entity (L))) = N_Parameter_Specification
5398
              and then Nkind (Parameter_Type (Parent (Entity (L)))) =
5399
                                                  N_Access_Definition
5400
              and then Nkind (R) = N_Null
5401
            then
5402
               Error_Msg_N ("access parameter is not allowed to be null", L);
5403
               Error_Msg_N ("\(call would raise Constraint_Error)", L);
5404
               return;
5405
 
5406
            --  Another special case for exponentiation, where the right
5407
            --  operand must be Natural, independently of the base.
5408
 
5409
            elsif Nkind (N) = N_Op_Expon
5410
              and then Is_Numeric_Type (Etype (L))
5411
              and then not Is_Overloaded (R)
5412
              and then
5413
                First_Subtype (Base_Type (Etype (R))) /= Standard_Integer
5414
              and then Base_Type (Etype (R)) /= Universal_Integer
5415
            then
5416
               Error_Msg_NE
5417
                 ("exponent must be of type Natural, found}", R, Etype (R));
5418
               return;
5419
            end if;
5420
 
5421
            --  If we fall through then just give general message. Note that in
5422
            --  the following messages, if the operand is overloaded we choose
5423
            --  an arbitrary type to complain about, but that is probably more
5424
            --  useful than not giving a type at all.
5425
 
5426
            if Nkind (N) in N_Unary_Op then
5427
               Error_Msg_Node_2 := Etype (R);
5428
               Error_Msg_N ("operator& not defined for}", N);
5429
               return;
5430
 
5431
            else
5432
               if Nkind (N) in N_Binary_Op then
5433
                  if not Is_Overloaded (L)
5434
                    and then not Is_Overloaded (R)
5435
                    and then Base_Type (Etype (L)) = Base_Type (Etype (R))
5436
                  then
5437
                     Error_Msg_Node_2 := First_Subtype (Etype (R));
5438
                     Error_Msg_N ("there is no applicable operator& for}", N);
5439
 
5440
                  else
5441
                     --  Another attempt to find a fix: one of the candidate
5442
                     --  interpretations may not be use-visible. This has
5443
                     --  already been checked for predefined operators, so
5444
                     --  we examine only user-defined functions.
5445
 
5446
                     Op_Id := Get_Name_Entity_Id (Chars (N));
5447
 
5448
                     while Present (Op_Id) loop
5449
                        if Ekind (Op_Id) /= E_Operator
5450
                          and then Is_Overloadable (Op_Id)
5451
                        then
5452
                           if not Is_Immediately_Visible (Op_Id)
5453
                             and then not In_Use (Scope (Op_Id))
5454
                             and then not Is_Abstract_Subprogram (Op_Id)
5455
                             and then not Is_Hidden (Op_Id)
5456
                             and then Ekind (Scope (Op_Id)) = E_Package
5457
                             and then
5458
                               Has_Compatible_Type
5459
                                 (L, Etype (First_Formal (Op_Id)))
5460
                             and then Present
5461
                              (Next_Formal (First_Formal (Op_Id)))
5462
                             and then
5463
                               Has_Compatible_Type
5464
                                 (R,
5465
                                  Etype (Next_Formal (First_Formal (Op_Id))))
5466
                           then
5467
                              Error_Msg_N
5468
                                ("No legal interpretation for operator&", N);
5469
                              Error_Msg_NE
5470
                                ("\use clause on& would make operation legal",
5471
                                   N, Scope (Op_Id));
5472
                              exit;
5473
                           end if;
5474
                        end if;
5475
 
5476
                        Op_Id := Homonym (Op_Id);
5477
                     end loop;
5478
 
5479
                     if No (Op_Id) then
5480
                        Error_Msg_N ("invalid operand types for operator&", N);
5481
 
5482
                        if Nkind (N) /= N_Op_Concat then
5483
                           Error_Msg_NE ("\left operand has}!",  N, Etype (L));
5484
                           Error_Msg_NE ("\right operand has}!", N, Etype (R));
5485
                        end if;
5486
                     end if;
5487
                  end if;
5488
               end if;
5489
            end if;
5490
         end;
5491
      end if;
5492
   end Operator_Check;
5493
 
5494
   -----------------------------------------
5495
   -- Process_Implicit_Dereference_Prefix --
5496
   -----------------------------------------
5497
 
5498
   function Process_Implicit_Dereference_Prefix
5499
     (E : Entity_Id;
5500
      P : Entity_Id) return Entity_Id
5501
   is
5502
      Ref : Node_Id;
5503
      Typ : constant Entity_Id := Designated_Type (Etype (P));
5504
 
5505
   begin
5506
      if Present (E)
5507
        and then (Operating_Mode = Check_Semantics or else not Expander_Active)
5508
      then
5509
         --  We create a dummy reference to E to ensure that the reference
5510
         --  is not considered as part of an assignment (an implicit
5511
         --  dereference can never assign to its prefix). The Comes_From_Source
5512
         --  attribute needs to be propagated for accurate warnings.
5513
 
5514
         Ref := New_Reference_To (E, Sloc (P));
5515
         Set_Comes_From_Source (Ref, Comes_From_Source (P));
5516
         Generate_Reference (E, Ref);
5517
      end if;
5518
 
5519
      --  An implicit dereference is a legal occurrence of an
5520
      --  incomplete type imported through a limited_with clause,
5521
      --  if the full view is visible.
5522
 
5523
      if From_With_Type (Typ)
5524
        and then not From_With_Type (Scope (Typ))
5525
        and then
5526
          (Is_Immediately_Visible (Scope (Typ))
5527
            or else
5528
              (Is_Child_Unit (Scope (Typ))
5529
                 and then Is_Visible_Child_Unit (Scope (Typ))))
5530
      then
5531
         return Available_View (Typ);
5532
      else
5533
         return Typ;
5534
      end if;
5535
 
5536
   end Process_Implicit_Dereference_Prefix;
5537
 
5538
   --------------------------------
5539
   -- Remove_Abstract_Operations --
5540
   --------------------------------
5541
 
5542
   procedure Remove_Abstract_Operations (N : Node_Id) is
5543
      Abstract_Op    : Entity_Id := Empty;
5544
      Address_Kludge : Boolean := False;
5545
      I              : Interp_Index;
5546
      It             : Interp;
5547
 
5548
      --  AI-310: If overloaded, remove abstract non-dispatching operations. We
5549
      --  activate this if either extensions are enabled, or if the abstract
5550
      --  operation in question comes from a predefined file. This latter test
5551
      --  allows us to use abstract to make operations invisible to users. In
5552
      --  particular, if type Address is non-private and abstract subprograms
5553
      --  are used to hide its operators, they will be truly hidden.
5554
 
5555
      type Operand_Position is (First_Op, Second_Op);
5556
      Univ_Type : constant Entity_Id := Universal_Interpretation (N);
5557
 
5558
      procedure Remove_Address_Interpretations (Op : Operand_Position);
5559
      --  Ambiguities may arise when the operands are literal and the address
5560
      --  operations in s-auxdec are visible. In that case, remove the
5561
      --  interpretation of a literal as Address, to retain the semantics of
5562
      --  Address as a private type.
5563
 
5564
      ------------------------------------
5565
      -- Remove_Address_Interpretations --
5566
      ------------------------------------
5567
 
5568
      procedure Remove_Address_Interpretations (Op : Operand_Position) is
5569
         Formal : Entity_Id;
5570
 
5571
      begin
5572
         if Is_Overloaded (N) then
5573
            Get_First_Interp (N, I, It);
5574
            while Present (It.Nam) loop
5575
               Formal := First_Entity (It.Nam);
5576
 
5577
               if Op = Second_Op then
5578
                  Formal := Next_Entity (Formal);
5579
               end if;
5580
 
5581
               if Is_Descendent_Of_Address (Etype (Formal)) then
5582
                  Address_Kludge := True;
5583
                  Remove_Interp (I);
5584
               end if;
5585
 
5586
               Get_Next_Interp (I, It);
5587
            end loop;
5588
         end if;
5589
      end Remove_Address_Interpretations;
5590
 
5591
   --  Start of processing for Remove_Abstract_Operations
5592
 
5593
   begin
5594
      if Is_Overloaded (N) then
5595
         Get_First_Interp (N, I, It);
5596
 
5597
         while Present (It.Nam) loop
5598
            if Is_Overloadable (It.Nam)
5599
              and then Is_Abstract_Subprogram (It.Nam)
5600
              and then not Is_Dispatching_Operation (It.Nam)
5601
            then
5602
               Abstract_Op := It.Nam;
5603
 
5604
               if Is_Descendent_Of_Address (It.Typ) then
5605
                  Address_Kludge := True;
5606
                  Remove_Interp (I);
5607
                  exit;
5608
 
5609
               --  In Ada 2005, this operation does not participate in Overload
5610
               --  resolution. If the operation is defined in a predefined
5611
               --  unit, it is one of the operations declared abstract in some
5612
               --  variants of System, and it must be removed as well.
5613
 
5614
               elsif Ada_Version >= Ada_05
5615
                 or else Is_Predefined_File_Name
5616
                           (Unit_File_Name (Get_Source_Unit (It.Nam)))
5617
               then
5618
                  Remove_Interp (I);
5619
                  exit;
5620
               end if;
5621
            end if;
5622
 
5623
            Get_Next_Interp (I, It);
5624
         end loop;
5625
 
5626
         if No (Abstract_Op) then
5627
 
5628
            --  If some interpretation yields an integer type, it is still
5629
            --  possible that there are address interpretations. Remove them
5630
            --  if one operand is a literal, to avoid spurious ambiguities
5631
            --  on systems where Address is a visible integer type.
5632
 
5633
            if Is_Overloaded (N)
5634
              and then Nkind (N) in N_Op
5635
              and then Is_Integer_Type (Etype (N))
5636
            then
5637
               if Nkind (N) in N_Binary_Op then
5638
                  if Nkind (Right_Opnd (N)) = N_Integer_Literal then
5639
                     Remove_Address_Interpretations (Second_Op);
5640
 
5641
                  elsif Nkind (Right_Opnd (N)) = N_Integer_Literal then
5642
                     Remove_Address_Interpretations (First_Op);
5643
                  end if;
5644
               end if;
5645
            end if;
5646
 
5647
         elsif Nkind (N) in N_Op then
5648
 
5649
            --  Remove interpretations that treat literals as addresses. This
5650
            --  is never appropriate, even when Address is defined as a visible
5651
            --  Integer type. The reason is that we would really prefer Address
5652
            --  to behave as a private type, even in this case, which is there
5653
            --  only to accommodate oddities of VMS address sizes. If Address
5654
            --  is a visible integer type, we get lots of overload ambiguities.
5655
 
5656
            if Nkind (N) in N_Binary_Op then
5657
               declare
5658
                  U1 : constant Boolean :=
5659
                     Present (Universal_Interpretation (Right_Opnd (N)));
5660
                  U2 : constant Boolean :=
5661
                     Present (Universal_Interpretation (Left_Opnd (N)));
5662
 
5663
               begin
5664
                  if U1 then
5665
                     Remove_Address_Interpretations (Second_Op);
5666
                  end if;
5667
 
5668
                  if U2 then
5669
                     Remove_Address_Interpretations (First_Op);
5670
                  end if;
5671
 
5672
                  if not (U1 and U2) then
5673
 
5674
                     --  Remove corresponding predefined operator, which is
5675
                     --  always added to the overload set.
5676
 
5677
                     Get_First_Interp (N, I, It);
5678
                     while Present (It.Nam) loop
5679
                        if Scope (It.Nam) = Standard_Standard
5680
                          and then Base_Type (It.Typ) =
5681
                                   Base_Type (Etype (Abstract_Op))
5682
                        then
5683
                           Remove_Interp (I);
5684
                        end if;
5685
 
5686
                        Get_Next_Interp (I, It);
5687
                     end loop;
5688
 
5689
                  elsif Is_Overloaded (N)
5690
                    and then Present (Univ_Type)
5691
                  then
5692
                     --  If both operands have a universal interpretation,
5693
                     --  it is still necessary to remove interpretations that
5694
                     --  yield Address. Any remaining ambiguities will be
5695
                     --  removed in Disambiguate.
5696
 
5697
                     Get_First_Interp (N, I, It);
5698
                     while Present (It.Nam) loop
5699
                        if Is_Descendent_Of_Address (It.Typ) then
5700
                           Remove_Interp (I);
5701
 
5702
                        elsif not Is_Type (It.Nam) then
5703
                           Set_Entity (N, It.Nam);
5704
                        end if;
5705
 
5706
                        Get_Next_Interp (I, It);
5707
                     end loop;
5708
                  end if;
5709
               end;
5710
            end if;
5711
 
5712
         elsif Nkind (N) = N_Function_Call
5713
           and then
5714
             (Nkind (Name (N)) = N_Operator_Symbol
5715
                or else
5716
                  (Nkind (Name (N)) = N_Expanded_Name
5717
                     and then
5718
                       Nkind (Selector_Name (Name (N))) = N_Operator_Symbol))
5719
         then
5720
 
5721
            declare
5722
               Arg1 : constant Node_Id := First (Parameter_Associations (N));
5723
               U1   : constant Boolean :=
5724
                        Present (Universal_Interpretation (Arg1));
5725
               U2   : constant Boolean :=
5726
                        Present (Next (Arg1)) and then
5727
                        Present (Universal_Interpretation (Next (Arg1)));
5728
 
5729
            begin
5730
               if U1 then
5731
                  Remove_Address_Interpretations (First_Op);
5732
               end if;
5733
 
5734
               if U2 then
5735
                  Remove_Address_Interpretations (Second_Op);
5736
               end if;
5737
 
5738
               if not (U1 and U2) then
5739
                  Get_First_Interp (N, I, It);
5740
                  while Present (It.Nam) loop
5741
                     if Scope (It.Nam) = Standard_Standard
5742
                       and then It.Typ = Base_Type (Etype (Abstract_Op))
5743
                     then
5744
                        Remove_Interp (I);
5745
                     end if;
5746
 
5747
                     Get_Next_Interp (I, It);
5748
                  end loop;
5749
               end if;
5750
            end;
5751
         end if;
5752
 
5753
         --  If the removal has left no valid interpretations, emit an error
5754
         --  message now and label node as illegal.
5755
 
5756
         if Present (Abstract_Op) then
5757
            Get_First_Interp (N, I, It);
5758
 
5759
            if No (It.Nam) then
5760
 
5761
               --  Removal of abstract operation left no viable candidate
5762
 
5763
               Set_Etype (N, Any_Type);
5764
               Error_Msg_Sloc := Sloc (Abstract_Op);
5765
               Error_Msg_NE
5766
                 ("cannot call abstract operation& declared#", N, Abstract_Op);
5767
 
5768
            --  In Ada 2005, an abstract operation may disable predefined
5769
            --  operators. Since the context is not yet known, we mark the
5770
            --  predefined operators as potentially hidden. Do not include
5771
            --  predefined operators when addresses are involved since this
5772
            --  case is handled separately.
5773
 
5774
            elsif Ada_Version >= Ada_05
5775
              and then not Address_Kludge
5776
            then
5777
               while Present (It.Nam) loop
5778
                  if Is_Numeric_Type (It.Typ)
5779
                    and then Scope (It.Typ) = Standard_Standard
5780
                  then
5781
                     Set_Abstract_Op (I, Abstract_Op);
5782
                  end if;
5783
 
5784
                  Get_Next_Interp (I, It);
5785
               end loop;
5786
            end if;
5787
         end if;
5788
      end if;
5789
   end Remove_Abstract_Operations;
5790
 
5791
   -----------------------
5792
   -- Try_Indirect_Call --
5793
   -----------------------
5794
 
5795
   function Try_Indirect_Call
5796
     (N   : Node_Id;
5797
      Nam : Entity_Id;
5798
      Typ : Entity_Id) return Boolean
5799
   is
5800
      Actual : Node_Id;
5801
      Formal : Entity_Id;
5802
 
5803
      Call_OK : Boolean;
5804
      pragma Warnings (Off, Call_OK);
5805
 
5806
   begin
5807
      Normalize_Actuals (N, Designated_Type (Typ), False, Call_OK);
5808
 
5809
      Actual := First_Actual (N);
5810
      Formal := First_Formal (Designated_Type (Typ));
5811
      while Present (Actual) and then Present (Formal) loop
5812
         if not Has_Compatible_Type (Actual, Etype (Formal)) then
5813
            return False;
5814
         end if;
5815
 
5816
         Next (Actual);
5817
         Next_Formal (Formal);
5818
      end loop;
5819
 
5820
      if No (Actual) and then No (Formal) then
5821
         Add_One_Interp (N, Nam, Etype (Designated_Type (Typ)));
5822
 
5823
         --  Nam is a candidate interpretation for the name in the call,
5824
         --  if it is not an indirect call.
5825
 
5826
         if not Is_Type (Nam)
5827
            and then Is_Entity_Name (Name (N))
5828
         then
5829
            Set_Entity (Name (N), Nam);
5830
         end if;
5831
 
5832
         return True;
5833
      else
5834
         return False;
5835
      end if;
5836
   end Try_Indirect_Call;
5837
 
5838
   ----------------------
5839
   -- Try_Indexed_Call --
5840
   ----------------------
5841
 
5842
   function Try_Indexed_Call
5843
     (N          : Node_Id;
5844
      Nam        : Entity_Id;
5845
      Typ        : Entity_Id;
5846
      Skip_First : Boolean) return Boolean
5847
   is
5848
      Loc     : constant Source_Ptr := Sloc (N);
5849
      Actuals : constant List_Id    := Parameter_Associations (N);
5850
      Actual  : Node_Id;
5851
      Index   : Entity_Id;
5852
 
5853
   begin
5854
      Actual := First (Actuals);
5855
 
5856
      --  If the call was originally written in prefix form, skip the first
5857
      --  actual, which is obviously not defaulted.
5858
 
5859
      if Skip_First then
5860
         Next (Actual);
5861
      end if;
5862
 
5863
      Index := First_Index (Typ);
5864
      while Present (Actual) and then Present (Index) loop
5865
 
5866
         --  If the parameter list has a named association, the expression
5867
         --  is definitely a call and not an indexed component.
5868
 
5869
         if Nkind (Actual) = N_Parameter_Association then
5870
            return False;
5871
         end if;
5872
 
5873
         if Is_Entity_Name (Actual)
5874
           and then Is_Type (Entity (Actual))
5875
           and then No (Next (Actual))
5876
         then
5877
            Rewrite (N,
5878
              Make_Slice (Loc,
5879
                Prefix => Make_Function_Call (Loc,
5880
                  Name => Relocate_Node (Name (N))),
5881
                Discrete_Range =>
5882
                  New_Occurrence_Of (Entity (Actual), Sloc (Actual))));
5883
 
5884
            Analyze (N);
5885
            return True;
5886
 
5887
         elsif not Has_Compatible_Type (Actual, Etype (Index)) then
5888
            return False;
5889
         end if;
5890
 
5891
         Next (Actual);
5892
         Next_Index (Index);
5893
      end loop;
5894
 
5895
      if No (Actual) and then No (Index) then
5896
         Add_One_Interp (N, Nam, Component_Type (Typ));
5897
 
5898
         --  Nam is a candidate interpretation for the name in the call,
5899
         --  if it is not an indirect call.
5900
 
5901
         if not Is_Type (Nam)
5902
            and then Is_Entity_Name (Name (N))
5903
         then
5904
            Set_Entity (Name (N), Nam);
5905
         end if;
5906
 
5907
         return True;
5908
      else
5909
         return False;
5910
      end if;
5911
   end Try_Indexed_Call;
5912
 
5913
   --------------------------
5914
   -- Try_Object_Operation --
5915
   --------------------------
5916
 
5917
   function Try_Object_Operation (N : Node_Id) return Boolean is
5918
      K              : constant Node_Kind  := Nkind (Parent (N));
5919
      Is_Subprg_Call : constant Boolean    := Nkind_In
5920
                                               (K, N_Procedure_Call_Statement,
5921
                                                   N_Function_Call);
5922
      Loc            : constant Source_Ptr := Sloc (N);
5923
      Obj            : constant Node_Id    := Prefix (N);
5924
      Subprog        : constant Node_Id    :=
5925
                         Make_Identifier (Sloc (Selector_Name (N)),
5926
                           Chars => Chars (Selector_Name (N)));
5927
      --  Identifier on which possible interpretations will be collected
5928
 
5929
      Report_Error : Boolean := False;
5930
      --  If no candidate interpretation matches the context, redo the
5931
      --  analysis with error enabled to provide additional information.
5932
 
5933
      Actual          : Node_Id;
5934
      Candidate       : Entity_Id := Empty;
5935
      New_Call_Node   : Node_Id := Empty;
5936
      Node_To_Replace : Node_Id;
5937
      Obj_Type        : Entity_Id := Etype (Obj);
5938
      Success         : Boolean := False;
5939
 
5940
      function Valid_Candidate
5941
        (Success : Boolean;
5942
         Call    : Node_Id;
5943
         Subp    : Entity_Id) return Entity_Id;
5944
      --  If the subprogram is a valid interpretation, record it, and add
5945
      --  to the list of interpretations of Subprog.
5946
 
5947
      procedure Complete_Object_Operation
5948
        (Call_Node       : Node_Id;
5949
         Node_To_Replace : Node_Id);
5950
      --  Make Subprog the name of Call_Node, replace Node_To_Replace with
5951
      --  Call_Node, insert the object (or its dereference) as the first actual
5952
      --  in the call, and complete the analysis of the call.
5953
 
5954
      procedure Report_Ambiguity (Op : Entity_Id);
5955
      --  If a prefixed procedure call is ambiguous, indicate whether the
5956
      --  call includes an implicit dereference or an implicit 'Access.
5957
 
5958
      procedure Transform_Object_Operation
5959
        (Call_Node       : out Node_Id;
5960
         Node_To_Replace : out Node_Id);
5961
      --  Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..)
5962
      --  Call_Node is the resulting subprogram call, Node_To_Replace is
5963
      --  either N or the parent of N, and Subprog is a reference to the
5964
      --  subprogram we are trying to match.
5965
 
5966
      function Try_Class_Wide_Operation
5967
        (Call_Node       : Node_Id;
5968
         Node_To_Replace : Node_Id) return Boolean;
5969
      --  Traverse all ancestor types looking for a class-wide subprogram
5970
      --  for which the current operation is a valid non-dispatching call.
5971
 
5972
      procedure Try_One_Prefix_Interpretation (T : Entity_Id);
5973
      --  If prefix is overloaded, its interpretation may include different
5974
      --  tagged types, and we must examine the primitive operations and
5975
      --  the class-wide operations of each in order to find candidate
5976
      --  interpretations for the call as a whole.
5977
 
5978
      function Try_Primitive_Operation
5979
        (Call_Node       : Node_Id;
5980
         Node_To_Replace : Node_Id) return Boolean;
5981
      --  Traverse the list of primitive subprograms looking for a dispatching
5982
      --  operation for which the current node is a valid call .
5983
 
5984
      ---------------------
5985
      -- Valid_Candidate --
5986
      ---------------------
5987
 
5988
      function Valid_Candidate
5989
        (Success : Boolean;
5990
         Call    : Node_Id;
5991
         Subp    : Entity_Id) return Entity_Id
5992
      is
5993
         Arr_Type  : Entity_Id;
5994
         Comp_Type : Entity_Id;
5995
 
5996
      begin
5997
         --  If the subprogram is a valid interpretation, record it in global
5998
         --  variable Subprog, to collect all possible overloadings.
5999
 
6000
         if Success then
6001
            if Subp /= Entity (Subprog) then
6002
               Add_One_Interp (Subprog, Subp, Etype (Subp));
6003
            end if;
6004
         end if;
6005
 
6006
         --  If the call may be an indexed call, retrieve component type of
6007
         --  resulting expression, and add possible interpretation.
6008
 
6009
         Arr_Type  := Empty;
6010
         Comp_Type := Empty;
6011
 
6012
         if Nkind (Call) = N_Function_Call
6013
           and then Nkind (Parent (N)) = N_Indexed_Component
6014
           and then Needs_One_Actual (Subp)
6015
         then
6016
            if Is_Array_Type (Etype (Subp)) then
6017
               Arr_Type := Etype (Subp);
6018
 
6019
            elsif Is_Access_Type (Etype (Subp))
6020
              and then Is_Array_Type (Designated_Type (Etype (Subp)))
6021
            then
6022
               Arr_Type := Designated_Type (Etype (Subp));
6023
            end if;
6024
         end if;
6025
 
6026
         if Present (Arr_Type) then
6027
 
6028
            --  Verify that the actuals (excluding the object)
6029
            --  match the types of the indices.
6030
 
6031
            declare
6032
               Actual : Node_Id;
6033
               Index  : Node_Id;
6034
 
6035
            begin
6036
               Actual := Next (First_Actual (Call));
6037
               Index  := First_Index (Arr_Type);
6038
               while Present (Actual) and then Present (Index) loop
6039
                  if not Has_Compatible_Type (Actual, Etype (Index)) then
6040
                     Arr_Type := Empty;
6041
                     exit;
6042
                  end if;
6043
 
6044
                  Next_Actual (Actual);
6045
                  Next_Index  (Index);
6046
               end loop;
6047
 
6048
               if No (Actual)
6049
                  and then No (Index)
6050
                  and then Present (Arr_Type)
6051
               then
6052
                  Comp_Type := Component_Type (Arr_Type);
6053
               end if;
6054
            end;
6055
 
6056
            if Present (Comp_Type)
6057
              and then Etype (Subprog) /= Comp_Type
6058
            then
6059
               Add_One_Interp (Subprog, Subp, Comp_Type);
6060
            end if;
6061
         end if;
6062
 
6063
         if Etype (Call) /= Any_Type then
6064
            return Subp;
6065
         else
6066
            return Empty;
6067
         end if;
6068
      end Valid_Candidate;
6069
 
6070
      -------------------------------
6071
      -- Complete_Object_Operation --
6072
      -------------------------------
6073
 
6074
      procedure Complete_Object_Operation
6075
        (Call_Node       : Node_Id;
6076
         Node_To_Replace : Node_Id)
6077
      is
6078
         Control      : constant Entity_Id := First_Formal (Entity (Subprog));
6079
         Formal_Type  : constant Entity_Id := Etype (Control);
6080
         First_Actual : Node_Id;
6081
 
6082
      begin
6083
         --  Place the name of the operation, with its interpretations,
6084
         --  on the rewritten call.
6085
 
6086
         Set_Name (Call_Node, Subprog);
6087
 
6088
         First_Actual := First (Parameter_Associations (Call_Node));
6089
 
6090
         --  For cross-reference purposes, treat the new node as being in
6091
         --  the source if the original one is.
6092
 
6093
         Set_Comes_From_Source (Subprog, Comes_From_Source (N));
6094
         Set_Comes_From_Source (Call_Node, Comes_From_Source (N));
6095
 
6096
         if Nkind (N) = N_Selected_Component
6097
           and then not Inside_A_Generic
6098
         then
6099
            Set_Entity (Selector_Name (N), Entity (Subprog));
6100
         end if;
6101
 
6102
         --  If need be, rewrite first actual as an explicit dereference
6103
         --  If the call is overloaded, the rewriting can only be done
6104
         --  once the primitive operation is identified.
6105
 
6106
         if Is_Overloaded (Subprog) then
6107
 
6108
            --  The prefix itself may be overloaded, and its interpretations
6109
            --  must be propagated to the new actual in the call.
6110
 
6111
            if Is_Overloaded (Obj) then
6112
               Save_Interps (Obj, First_Actual);
6113
            end if;
6114
 
6115
            Rewrite (First_Actual, Obj);
6116
 
6117
         elsif not Is_Access_Type (Formal_Type)
6118
           and then Is_Access_Type (Etype (Obj))
6119
         then
6120
            Rewrite (First_Actual,
6121
              Make_Explicit_Dereference (Sloc (Obj), Obj));
6122
            Analyze (First_Actual);
6123
 
6124
            --  If we need to introduce an explicit dereference, verify that
6125
            --  the resulting actual is compatible with the mode of the formal.
6126
 
6127
            if Ekind (First_Formal (Entity (Subprog))) /= E_In_Parameter
6128
              and then Is_Access_Constant (Etype (Obj))
6129
            then
6130
               Error_Msg_NE
6131
                 ("expect variable in call to&", Prefix (N), Entity (Subprog));
6132
            end if;
6133
 
6134
         --  Conversely, if the formal is an access parameter and the object
6135
         --  is not, replace the actual with a 'Access reference. Its analysis
6136
         --  will check that the object is aliased.
6137
 
6138
         elsif Is_Access_Type (Formal_Type)
6139
           and then not Is_Access_Type (Etype (Obj))
6140
         then
6141
            --  A special case: A.all'access is illegal if A is an access to a
6142
            --  constant and the context requires an access to a variable.
6143
 
6144
            if not Is_Access_Constant (Formal_Type) then
6145
               if (Nkind (Obj) = N_Explicit_Dereference
6146
                    and then Is_Access_Constant (Etype (Prefix (Obj))))
6147
                 or else not Is_Variable (Obj)
6148
               then
6149
                  Error_Msg_NE
6150
                    ("actual for& must be a variable", Obj, Control);
6151
               end if;
6152
            end if;
6153
 
6154
            Rewrite (First_Actual,
6155
              Make_Attribute_Reference (Loc,
6156
                Attribute_Name => Name_Access,
6157
                Prefix => Relocate_Node (Obj)));
6158
 
6159
            if not Is_Aliased_View (Obj) then
6160
               Error_Msg_NE
6161
                 ("object in prefixed call to& must be aliased"
6162
                      & " (RM-2005 4.3.1 (13))",
6163
                 Prefix (First_Actual), Subprog);
6164
            end if;
6165
 
6166
            Analyze (First_Actual);
6167
 
6168
         else
6169
            if Is_Overloaded (Obj) then
6170
               Save_Interps (Obj, First_Actual);
6171
            end if;
6172
 
6173
            Rewrite (First_Actual, Obj);
6174
         end if;
6175
 
6176
         Rewrite (Node_To_Replace, Call_Node);
6177
 
6178
         --  Propagate the interpretations collected in subprog to the new
6179
         --  function call node, to be resolved from context.
6180
 
6181
         if Is_Overloaded (Subprog) then
6182
            Save_Interps (Subprog, Node_To_Replace);
6183
         else
6184
            Analyze (Node_To_Replace);
6185
         end if;
6186
      end Complete_Object_Operation;
6187
 
6188
      ----------------------
6189
      -- Report_Ambiguity --
6190
      ----------------------
6191
 
6192
      procedure Report_Ambiguity (Op : Entity_Id) is
6193
         Access_Formal : constant Boolean :=
6194
                           Is_Access_Type (Etype (First_Formal (Op)));
6195
         Access_Actual : constant Boolean :=
6196
                           Is_Access_Type (Etype (Prefix (N)));
6197
 
6198
      begin
6199
         Error_Msg_Sloc := Sloc (Op);
6200
 
6201
         if Access_Formal and then not Access_Actual then
6202
            if Nkind (Parent (Op)) = N_Full_Type_Declaration then
6203
               Error_Msg_N
6204
                 ("\possible interpretation"
6205
                   & " (inherited, with implicit 'Access) #", N);
6206
            else
6207
               Error_Msg_N
6208
                 ("\possible interpretation (with implicit 'Access) #", N);
6209
            end if;
6210
 
6211
         elsif not Access_Formal and then Access_Actual then
6212
            if Nkind (Parent (Op)) = N_Full_Type_Declaration then
6213
               Error_Msg_N
6214
                 ("\possible interpretation"
6215
                   & " ( inherited, with implicit dereference) #", N);
6216
            else
6217
               Error_Msg_N
6218
                 ("\possible interpretation (with implicit dereference) #", N);
6219
            end if;
6220
 
6221
         else
6222
            if Nkind (Parent (Op)) = N_Full_Type_Declaration then
6223
               Error_Msg_N ("\possible interpretation (inherited)#", N);
6224
            else
6225
               Error_Msg_N -- CODEFIX
6226
                 ("\possible interpretation#", N);
6227
            end if;
6228
         end if;
6229
      end Report_Ambiguity;
6230
 
6231
      --------------------------------
6232
      -- Transform_Object_Operation --
6233
      --------------------------------
6234
 
6235
      procedure Transform_Object_Operation
6236
        (Call_Node       : out Node_Id;
6237
         Node_To_Replace : out Node_Id)
6238
      is
6239
         Dummy : constant Node_Id := New_Copy (Obj);
6240
         --  Placeholder used as a first parameter in the call, replaced
6241
         --  eventually by the proper object.
6242
 
6243
         Parent_Node : constant Node_Id := Parent (N);
6244
 
6245
         Actual  : Node_Id;
6246
         Actuals : List_Id;
6247
 
6248
      begin
6249
         --  Common case covering 1) Call to a procedure and 2) Call to a
6250
         --  function that has some additional actuals.
6251
 
6252
         if Nkind_In (Parent_Node, N_Function_Call,
6253
                                   N_Procedure_Call_Statement)
6254
 
6255
            --  N is a selected component node containing the name of the
6256
            --  subprogram. If N is not the name of the parent node we must
6257
            --  not replace the parent node by the new construct. This case
6258
            --  occurs when N is a parameterless call to a subprogram that
6259
            --  is an actual parameter of a call to another subprogram. For
6260
            --  example:
6261
            --            Some_Subprogram (..., Obj.Operation, ...)
6262
 
6263
            and then Name (Parent_Node) = N
6264
         then
6265
            Node_To_Replace := Parent_Node;
6266
 
6267
            Actuals := Parameter_Associations (Parent_Node);
6268
 
6269
            if Present (Actuals) then
6270
               Prepend (Dummy, Actuals);
6271
            else
6272
               Actuals := New_List (Dummy);
6273
            end if;
6274
 
6275
            if Nkind (Parent_Node) = N_Procedure_Call_Statement then
6276
               Call_Node :=
6277
                 Make_Procedure_Call_Statement (Loc,
6278
                   Name => New_Copy (Subprog),
6279
                   Parameter_Associations => Actuals);
6280
 
6281
            else
6282
               Call_Node :=
6283
                 Make_Function_Call (Loc,
6284
                   Name => New_Copy (Subprog),
6285
                   Parameter_Associations => Actuals);
6286
 
6287
            end if;
6288
 
6289
         --  Before analysis, a function call appears as an indexed component
6290
         --  if there are no named associations.
6291
 
6292
         elsif Nkind (Parent_Node) =  N_Indexed_Component
6293
           and then N = Prefix (Parent_Node)
6294
         then
6295
            Node_To_Replace := Parent_Node;
6296
 
6297
            Actuals := Expressions (Parent_Node);
6298
 
6299
            Actual := First (Actuals);
6300
            while Present (Actual) loop
6301
               Analyze (Actual);
6302
               Next (Actual);
6303
            end loop;
6304
 
6305
            Prepend (Dummy, Actuals);
6306
 
6307
            Call_Node :=
6308
               Make_Function_Call (Loc,
6309
                 Name => New_Copy (Subprog),
6310
                 Parameter_Associations => Actuals);
6311
 
6312
         --  Parameterless call: Obj.F is rewritten as F (Obj)
6313
 
6314
         else
6315
            Node_To_Replace := N;
6316
 
6317
            Call_Node :=
6318
               Make_Function_Call (Loc,
6319
                 Name => New_Copy (Subprog),
6320
                 Parameter_Associations => New_List (Dummy));
6321
         end if;
6322
      end Transform_Object_Operation;
6323
 
6324
      ------------------------------
6325
      -- Try_Class_Wide_Operation --
6326
      ------------------------------
6327
 
6328
      function Try_Class_Wide_Operation
6329
        (Call_Node       : Node_Id;
6330
         Node_To_Replace : Node_Id) return Boolean
6331
      is
6332
         Anc_Type    : Entity_Id;
6333
         Matching_Op : Entity_Id := Empty;
6334
         Error       : Boolean;
6335
 
6336
         procedure Traverse_Homonyms
6337
           (Anc_Type : Entity_Id;
6338
            Error    : out Boolean);
6339
         --  Traverse the homonym chain of the subprogram searching for those
6340
         --  homonyms whose first formal has the Anc_Type's class-wide type,
6341
         --  or an anonymous access type designating the class-wide type. If
6342
         --  an ambiguity is detected, then Error is set to True.
6343
 
6344
         procedure Traverse_Interfaces
6345
           (Anc_Type : Entity_Id;
6346
            Error    : out Boolean);
6347
         --  Traverse the list of interfaces, if any, associated with Anc_Type
6348
         --  and search for acceptable class-wide homonyms associated with each
6349
         --  interface. If an ambiguity is detected, then Error is set to True.
6350
 
6351
         -----------------------
6352
         -- Traverse_Homonyms --
6353
         -----------------------
6354
 
6355
         procedure Traverse_Homonyms
6356
           (Anc_Type : Entity_Id;
6357
            Error    : out Boolean)
6358
         is
6359
            Cls_Type    : Entity_Id;
6360
            Hom         : Entity_Id;
6361
            Hom_Ref     : Node_Id;
6362
            Success     : Boolean;
6363
 
6364
         begin
6365
            Error := False;
6366
 
6367
            Cls_Type := Class_Wide_Type (Anc_Type);
6368
 
6369
            Hom := Current_Entity (Subprog);
6370
 
6371
            --  Find operation whose first parameter is of the class-wide
6372
            --  type, a subtype thereof, or an anonymous access to same.
6373
 
6374
            while Present (Hom) loop
6375
               if (Ekind (Hom) = E_Procedure
6376
                     or else
6377
                   Ekind (Hom) = E_Function)
6378
                 and then Scope (Hom) = Scope (Anc_Type)
6379
                 and then Present (First_Formal (Hom))
6380
                 and then
6381
                   (Base_Type (Etype (First_Formal (Hom))) = Cls_Type
6382
                     or else
6383
                       (Is_Access_Type (Etype (First_Formal (Hom)))
6384
                          and then
6385
                            Ekind (Etype (First_Formal (Hom))) =
6386
                              E_Anonymous_Access_Type
6387
                          and then
6388
                            Base_Type
6389
                              (Designated_Type (Etype (First_Formal (Hom)))) =
6390
                                                                   Cls_Type))
6391
               then
6392
                  Set_Etype (Call_Node, Any_Type);
6393
                  Set_Is_Overloaded (Call_Node, False);
6394
                  Success := False;
6395
 
6396
                  if No (Matching_Op) then
6397
                     Hom_Ref := New_Reference_To (Hom, Sloc (Subprog));
6398
                     Set_Etype (Call_Node, Any_Type);
6399
                     Set_Parent (Call_Node, Parent (Node_To_Replace));
6400
 
6401
                     Set_Name (Call_Node, Hom_Ref);
6402
 
6403
                     Analyze_One_Call
6404
                       (N          => Call_Node,
6405
                        Nam        => Hom,
6406
                        Report     => Report_Error,
6407
                        Success    => Success,
6408
                        Skip_First => True);
6409
 
6410
                     Matching_Op :=
6411
                       Valid_Candidate (Success, Call_Node, Hom);
6412
 
6413
                  else
6414
                     Analyze_One_Call
6415
                       (N          => Call_Node,
6416
                        Nam        => Hom,
6417
                        Report     => Report_Error,
6418
                        Success    => Success,
6419
                        Skip_First => True);
6420
 
6421
                     if Present (Valid_Candidate (Success, Call_Node, Hom))
6422
                       and then Nkind (Call_Node) /= N_Function_Call
6423
                     then
6424
                        Error_Msg_NE ("ambiguous call to&", N, Hom);
6425
                        Report_Ambiguity (Matching_Op);
6426
                        Report_Ambiguity (Hom);
6427
                        Error := True;
6428
                        return;
6429
                     end if;
6430
                  end if;
6431
               end if;
6432
 
6433
               Hom := Homonym (Hom);
6434
            end loop;
6435
         end Traverse_Homonyms;
6436
 
6437
         -------------------------
6438
         -- Traverse_Interfaces --
6439
         -------------------------
6440
 
6441
         procedure Traverse_Interfaces
6442
           (Anc_Type : Entity_Id;
6443
            Error    : out Boolean)
6444
         is
6445
            Intface_List : constant List_Id :=
6446
                             Abstract_Interface_List (Anc_Type);
6447
            Intface      : Node_Id;
6448
 
6449
         begin
6450
            Error := False;
6451
 
6452
            if Is_Non_Empty_List (Intface_List) then
6453
               Intface := First (Intface_List);
6454
               while Present (Intface) loop
6455
 
6456
                  --  Look for acceptable class-wide homonyms associated with
6457
                  --  the interface.
6458
 
6459
                  Traverse_Homonyms (Etype (Intface), Error);
6460
 
6461
                  if Error then
6462
                     return;
6463
                  end if;
6464
 
6465
                  --  Continue the search by looking at each of the interface's
6466
                  --  associated interface ancestors.
6467
 
6468
                  Traverse_Interfaces (Etype (Intface), Error);
6469
 
6470
                  if Error then
6471
                     return;
6472
                  end if;
6473
 
6474
                  Next (Intface);
6475
               end loop;
6476
            end if;
6477
         end Traverse_Interfaces;
6478
 
6479
      --  Start of processing for Try_Class_Wide_Operation
6480
 
6481
      begin
6482
         --  Loop through ancestor types (including interfaces), traversing
6483
         --  the homonym chain of the subprogram, trying out those homonyms
6484
         --  whose first formal has the class-wide type of the ancestor, or
6485
         --  an anonymous access type designating the class-wide type.
6486
 
6487
         Anc_Type := Obj_Type;
6488
         loop
6489
            --  Look for a match among homonyms associated with the ancestor
6490
 
6491
            Traverse_Homonyms (Anc_Type, Error);
6492
 
6493
            if Error then
6494
               return True;
6495
            end if;
6496
 
6497
            --  Continue the search for matches among homonyms associated with
6498
            --  any interfaces implemented by the ancestor.
6499
 
6500
            Traverse_Interfaces (Anc_Type, Error);
6501
 
6502
            if Error then
6503
               return True;
6504
            end if;
6505
 
6506
            exit when Etype (Anc_Type) = Anc_Type;
6507
            Anc_Type := Etype (Anc_Type);
6508
         end loop;
6509
 
6510
         if Present (Matching_Op) then
6511
            Set_Etype (Call_Node, Etype (Matching_Op));
6512
         end if;
6513
 
6514
         return Present (Matching_Op);
6515
      end Try_Class_Wide_Operation;
6516
 
6517
      -----------------------------------
6518
      -- Try_One_Prefix_Interpretation --
6519
      -----------------------------------
6520
 
6521
      procedure Try_One_Prefix_Interpretation (T : Entity_Id) is
6522
      begin
6523
         Obj_Type := T;
6524
 
6525
         if Is_Access_Type (Obj_Type) then
6526
            Obj_Type := Designated_Type (Obj_Type);
6527
         end if;
6528
 
6529
         if Ekind (Obj_Type) = E_Private_Subtype then
6530
            Obj_Type := Base_Type (Obj_Type);
6531
         end if;
6532
 
6533
         if Is_Class_Wide_Type (Obj_Type) then
6534
            Obj_Type := Etype (Class_Wide_Type (Obj_Type));
6535
         end if;
6536
 
6537
         --  The type may have be obtained through a limited_with clause,
6538
         --  in which case the primitive operations are available on its
6539
         --  non-limited view. If still incomplete, retrieve full view.
6540
 
6541
         if Ekind (Obj_Type) = E_Incomplete_Type
6542
           and then From_With_Type (Obj_Type)
6543
         then
6544
            Obj_Type := Get_Full_View (Non_Limited_View (Obj_Type));
6545
         end if;
6546
 
6547
         --  If the object is not tagged, or the type is still an incomplete
6548
         --  type, this is not a prefixed call.
6549
 
6550
         if not Is_Tagged_Type (Obj_Type)
6551
           or else Is_Incomplete_Type (Obj_Type)
6552
         then
6553
            return;
6554
         end if;
6555
 
6556
         if Try_Primitive_Operation
6557
              (Call_Node       => New_Call_Node,
6558
               Node_To_Replace => Node_To_Replace)
6559
           or else
6560
             Try_Class_Wide_Operation
6561
               (Call_Node       => New_Call_Node,
6562
                Node_To_Replace => Node_To_Replace)
6563
         then
6564
            null;
6565
         end if;
6566
      end Try_One_Prefix_Interpretation;
6567
 
6568
      -----------------------------
6569
      -- Try_Primitive_Operation --
6570
      -----------------------------
6571
 
6572
      function Try_Primitive_Operation
6573
        (Call_Node       : Node_Id;
6574
         Node_To_Replace : Node_Id) return Boolean
6575
      is
6576
         Elmt        : Elmt_Id;
6577
         Prim_Op     : Entity_Id;
6578
         Matching_Op : Entity_Id := Empty;
6579
         Prim_Op_Ref : Node_Id   := Empty;
6580
 
6581
         Corr_Type   : Entity_Id := Empty;
6582
         --  If the prefix is a synchronized type, the controlling type of
6583
         --  the primitive operation is the corresponding record type, else
6584
         --  this is the object type itself.
6585
 
6586
         Success     : Boolean   := False;
6587
 
6588
         function Collect_Generic_Type_Ops (T : Entity_Id) return Elist_Id;
6589
         --  For tagged types the candidate interpretations are found in
6590
         --  the list of primitive operations of the type and its ancestors.
6591
         --  For formal tagged types we have to find the operations declared
6592
         --  in the same scope as the type (including in the generic formal
6593
         --  part) because the type itself carries no primitive operations,
6594
         --  except for formal derived types that inherit the operations of
6595
         --  the parent and progenitors.
6596
         --  If the context is a generic subprogram body, the generic formals
6597
         --  are visible by name, but are not in the entity list of the
6598
         --  subprogram because that list starts with the subprogram formals.
6599
         --  We retrieve the candidate operations from the generic declaration.
6600
 
6601
         function Is_Private_Overriding (Op : Entity_Id) return Boolean;
6602
         --  An operation that overrides an inherited operation in the private
6603
         --  part of its package may be hidden, but if the inherited operation
6604
         --  is visible a direct call to it will dispatch to the private one,
6605
         --  which is therefore a valid candidate.
6606
 
6607
         function Valid_First_Argument_Of (Op : Entity_Id) return Boolean;
6608
         --  Verify that the prefix, dereferenced if need be, is a valid
6609
         --  controlling argument in a call to Op. The remaining actuals
6610
         --  are checked in the subsequent call to Analyze_One_Call.
6611
 
6612
         ------------------------------
6613
         -- Collect_Generic_Type_Ops --
6614
         ------------------------------
6615
 
6616
         function Collect_Generic_Type_Ops (T : Entity_Id) return Elist_Id is
6617
            Bas        : constant Entity_Id := Base_Type (T);
6618
            Candidates : constant Elist_Id := New_Elmt_List;
6619
            Subp       : Entity_Id;
6620
            Formal     : Entity_Id;
6621
 
6622
            procedure Check_Candidate;
6623
            --  The operation is a candidate if its first parameter is a
6624
            --  controlling operand of the desired type.
6625
 
6626
            -----------------------
6627
            --  Check_Candidate; --
6628
            -----------------------
6629
 
6630
            procedure Check_Candidate is
6631
            begin
6632
               Formal := First_Formal (Subp);
6633
 
6634
               if Present (Formal)
6635
                 and then Is_Controlling_Formal (Formal)
6636
                 and then
6637
                   (Base_Type (Etype (Formal)) = Bas
6638
                     or else
6639
                       (Is_Access_Type (Etype (Formal))
6640
                         and then Designated_Type (Etype (Formal)) = Bas))
6641
               then
6642
                  Append_Elmt (Subp, Candidates);
6643
               end if;
6644
            end Check_Candidate;
6645
 
6646
         --  Start of processing for Collect_Generic_Type_Ops
6647
 
6648
         begin
6649
            if Is_Derived_Type (T) then
6650
               return Primitive_Operations (T);
6651
 
6652
            elsif Ekind (Scope (T)) = E_Procedure
6653
              or else Ekind (Scope (T)) = E_Function
6654
            then
6655
               --  Scan the list of generic formals to find subprograms
6656
               --  that may have a first controlling formal of the type.
6657
 
6658
               declare
6659
                  Decl : Node_Id;
6660
 
6661
               begin
6662
                  Decl :=
6663
                    First (Generic_Formal_Declarations
6664
                            (Unit_Declaration_Node (Scope (T))));
6665
                  while Present (Decl) loop
6666
                     if Nkind (Decl) in N_Formal_Subprogram_Declaration then
6667
                        Subp := Defining_Entity (Decl);
6668
                        Check_Candidate;
6669
                     end if;
6670
 
6671
                     Next (Decl);
6672
                  end loop;
6673
               end;
6674
 
6675
               return Candidates;
6676
 
6677
            else
6678
               --  Scan the list of entities declared in the same scope as
6679
               --  the type. In general this will be an open scope, given that
6680
               --  the call we are analyzing can only appear within a generic
6681
               --  declaration or body (either the one that declares T, or a
6682
               --  child unit).
6683
 
6684
               Subp := First_Entity (Scope (T));
6685
               while Present (Subp) loop
6686
                  if Is_Overloadable (Subp) then
6687
                     Check_Candidate;
6688
                  end if;
6689
 
6690
                  Next_Entity (Subp);
6691
               end loop;
6692
 
6693
               return Candidates;
6694
            end if;
6695
         end Collect_Generic_Type_Ops;
6696
 
6697
         ---------------------------
6698
         -- Is_Private_Overriding --
6699
         ---------------------------
6700
 
6701
         function Is_Private_Overriding (Op : Entity_Id) return Boolean is
6702
            Visible_Op : constant Entity_Id := Homonym (Op);
6703
 
6704
         begin
6705
            return Present (Visible_Op)
6706
              and then Scope (Op) = Scope (Visible_Op)
6707
              and then not Comes_From_Source (Visible_Op)
6708
              and then Alias (Visible_Op) = Op
6709
              and then not Is_Hidden (Visible_Op);
6710
         end Is_Private_Overriding;
6711
 
6712
         -----------------------------
6713
         -- Valid_First_Argument_Of --
6714
         -----------------------------
6715
 
6716
         function Valid_First_Argument_Of (Op : Entity_Id) return Boolean is
6717
            Typ : Entity_Id := Etype (First_Formal (Op));
6718
 
6719
         begin
6720
            if Is_Concurrent_Type (Typ)
6721
              and then Present (Corresponding_Record_Type (Typ))
6722
            then
6723
               Typ := Corresponding_Record_Type (Typ);
6724
            end if;
6725
 
6726
            --  Simple case. Object may be a subtype of the tagged type or
6727
            --  may be the corresponding record of a synchronized type.
6728
 
6729
            return Obj_Type = Typ
6730
              or else Base_Type (Obj_Type) = Typ
6731
              or else Corr_Type = Typ
6732
 
6733
               --  Prefix can be dereferenced
6734
 
6735
              or else
6736
                (Is_Access_Type (Corr_Type)
6737
                  and then Designated_Type (Corr_Type) = Typ)
6738
 
6739
               --  Formal is an access parameter, for which the object
6740
               --  can provide an access.
6741
 
6742
              or else
6743
                (Ekind (Typ) = E_Anonymous_Access_Type
6744
                  and then Designated_Type (Typ) = Base_Type (Corr_Type));
6745
         end Valid_First_Argument_Of;
6746
 
6747
      --  Start of processing for Try_Primitive_Operation
6748
 
6749
      begin
6750
         --  Look for subprograms in the list of primitive operations. The name
6751
         --  must be identical, and the kind of call indicates the expected
6752
         --  kind of operation (function or procedure). If the type is a
6753
         --  (tagged) synchronized type, the primitive ops are attached to the
6754
         --  corresponding record (base) type.
6755
 
6756
         if Is_Concurrent_Type (Obj_Type) then
6757
            if not Present (Corresponding_Record_Type (Obj_Type)) then
6758
               return False;
6759
            end if;
6760
 
6761
            Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
6762
            Elmt := First_Elmt (Primitive_Operations (Corr_Type));
6763
 
6764
         elsif not Is_Generic_Type (Obj_Type) then
6765
            Corr_Type := Obj_Type;
6766
            Elmt := First_Elmt (Primitive_Operations (Obj_Type));
6767
 
6768
         else
6769
            Corr_Type := Obj_Type;
6770
            Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type));
6771
         end if;
6772
 
6773
         while Present (Elmt) loop
6774
            Prim_Op := Node (Elmt);
6775
 
6776
            if Chars (Prim_Op) = Chars (Subprog)
6777
              and then Present (First_Formal (Prim_Op))
6778
              and then Valid_First_Argument_Of (Prim_Op)
6779
              and then
6780
                 (Nkind (Call_Node) = N_Function_Call)
6781
                   = (Ekind (Prim_Op) = E_Function)
6782
            then
6783
               --  Ada 2005 (AI-251): If this primitive operation corresponds
6784
               --  with an immediate ancestor interface there is no need to add
6785
               --  it to the list of interpretations; the corresponding aliased
6786
               --  primitive is also in this list of primitive operations and
6787
               --  will be used instead.
6788
 
6789
               if (Present (Interface_Alias (Prim_Op))
6790
                    and then Is_Ancestor (Find_Dispatching_Type
6791
                                            (Alias (Prim_Op)), Corr_Type))
6792
 
6793
                 --  Do not consider hidden primitives unless the type is in an
6794
                 --  open scope or we are within an instance, where visibility
6795
                 --  is known to be correct, or else if this is an overriding
6796
                 --  operation in the private part for an inherited operation.
6797
 
6798
                 or else (Is_Hidden (Prim_Op)
6799
                           and then not Is_Immediately_Visible (Obj_Type)
6800
                           and then not In_Instance
6801
                           and then not Is_Private_Overriding (Prim_Op))
6802
               then
6803
                  goto Continue;
6804
               end if;
6805
 
6806
               Set_Etype (Call_Node, Any_Type);
6807
               Set_Is_Overloaded (Call_Node, False);
6808
 
6809
               if No (Matching_Op) then
6810
                  Prim_Op_Ref := New_Reference_To (Prim_Op, Sloc (Subprog));
6811
                  Candidate := Prim_Op;
6812
 
6813
                  Set_Parent (Call_Node, Parent (Node_To_Replace));
6814
 
6815
                  Set_Name (Call_Node, Prim_Op_Ref);
6816
                  Success := False;
6817
 
6818
                  Analyze_One_Call
6819
                    (N          => Call_Node,
6820
                     Nam        => Prim_Op,
6821
                     Report     => Report_Error,
6822
                     Success    => Success,
6823
                     Skip_First => True);
6824
 
6825
                  Matching_Op := Valid_Candidate (Success, Call_Node, Prim_Op);
6826
 
6827
               --  More than one interpretation, collect for subsequent
6828
               --  disambiguation. If this is a procedure call and there
6829
               --  is another match, report ambiguity now.
6830
 
6831
               else
6832
                  Analyze_One_Call
6833
                    (N          => Call_Node,
6834
                     Nam        => Prim_Op,
6835
                     Report     => Report_Error,
6836
                     Success    => Success,
6837
                     Skip_First => True);
6838
 
6839
                  if Present (Valid_Candidate (Success, Call_Node, Prim_Op))
6840
                    and then Nkind (Call_Node) /= N_Function_Call
6841
                  then
6842
                     Error_Msg_NE ("ambiguous call to&", N, Prim_Op);
6843
                     Report_Ambiguity (Matching_Op);
6844
                     Report_Ambiguity (Prim_Op);
6845
                     return True;
6846
                  end if;
6847
               end if;
6848
            end if;
6849
 
6850
            <<Continue>>
6851
            Next_Elmt (Elmt);
6852
         end loop;
6853
 
6854
         if Present (Matching_Op) then
6855
            Set_Etype (Call_Node, Etype (Matching_Op));
6856
         end if;
6857
 
6858
         return Present (Matching_Op);
6859
      end Try_Primitive_Operation;
6860
 
6861
   --  Start of processing for Try_Object_Operation
6862
 
6863
   begin
6864
      Analyze_Expression (Obj);
6865
 
6866
      --  Analyze the actuals if node is known to be a subprogram call
6867
 
6868
      if Is_Subprg_Call and then N = Name (Parent (N)) then
6869
         Actual := First (Parameter_Associations (Parent (N)));
6870
         while Present (Actual) loop
6871
            Analyze_Expression (Actual);
6872
            Next (Actual);
6873
         end loop;
6874
      end if;
6875
 
6876
      --  Build a subprogram call node, using a copy of Obj as its first
6877
      --  actual. This is a placeholder, to be replaced by an explicit
6878
      --  dereference when needed.
6879
 
6880
      Transform_Object_Operation
6881
        (Call_Node       => New_Call_Node,
6882
         Node_To_Replace => Node_To_Replace);
6883
 
6884
      Set_Etype (New_Call_Node, Any_Type);
6885
      Set_Etype (Subprog, Any_Type);
6886
      Set_Parent (New_Call_Node, Parent (Node_To_Replace));
6887
 
6888
      if not Is_Overloaded (Obj) then
6889
         Try_One_Prefix_Interpretation (Obj_Type);
6890
 
6891
      else
6892
         declare
6893
            I  : Interp_Index;
6894
            It : Interp;
6895
         begin
6896
            Get_First_Interp (Obj, I, It);
6897
            while Present (It.Nam) loop
6898
               Try_One_Prefix_Interpretation (It.Typ);
6899
               Get_Next_Interp (I, It);
6900
            end loop;
6901
         end;
6902
      end if;
6903
 
6904
      if Etype (New_Call_Node) /= Any_Type then
6905
         Complete_Object_Operation
6906
           (Call_Node       => New_Call_Node,
6907
            Node_To_Replace => Node_To_Replace);
6908
         return True;
6909
 
6910
      elsif Present (Candidate) then
6911
 
6912
         --  The argument list is not type correct. Re-analyze with error
6913
         --  reporting enabled, and use one of the possible candidates.
6914
         --  In All_Errors_Mode, re-analyze all failed interpretations.
6915
 
6916
         if All_Errors_Mode then
6917
            Report_Error := True;
6918
            if Try_Primitive_Operation
6919
                (Call_Node       => New_Call_Node,
6920
                 Node_To_Replace => Node_To_Replace)
6921
 
6922
              or else
6923
                Try_Class_Wide_Operation
6924
                  (Call_Node       => New_Call_Node,
6925
                   Node_To_Replace => Node_To_Replace)
6926
            then
6927
               null;
6928
            end if;
6929
 
6930
         else
6931
            Analyze_One_Call
6932
              (N          => New_Call_Node,
6933
               Nam        => Candidate,
6934
               Report     => True,
6935
               Success    => Success,
6936
               Skip_First => True);
6937
         end if;
6938
 
6939
         --  No need for further errors
6940
 
6941
         return True;
6942
 
6943
      else
6944
         --  There was no candidate operation, so report it as an error
6945
         --  in the caller: Analyze_Selected_Component.
6946
 
6947
         return False;
6948
      end if;
6949
   end Try_Object_Operation;
6950
 
6951
   ---------
6952
   -- wpo --
6953
   ---------
6954
 
6955
   procedure wpo (T : Entity_Id) is
6956
      Op : Entity_Id;
6957
      E  : Elmt_Id;
6958
 
6959
   begin
6960
      if not Is_Tagged_Type (T) then
6961
         return;
6962
      end if;
6963
 
6964
      E := First_Elmt (Primitive_Operations (Base_Type (T)));
6965
      while Present (E) loop
6966
         Op := Node (E);
6967
         Write_Int (Int (Op));
6968
         Write_Str (" === ");
6969
         Write_Name (Chars (Op));
6970
         Write_Str (" in ");
6971
         Write_Name (Chars (Scope (Op)));
6972
         Next_Elmt (E);
6973
         Write_Eol;
6974
      end loop;
6975
   end wpo;
6976
 
6977
end Sem_Ch4;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.