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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sem_ch5.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                              S E M _ C H 5                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
with Aspects;  use Aspects;
27
with Atree;    use Atree;
28
with Checks;   use Checks;
29
with Einfo;    use Einfo;
30
with Errout;   use Errout;
31
with Expander; use Expander;
32
with Exp_Ch6;  use Exp_Ch6;
33
with Exp_Util; use Exp_Util;
34
with Freeze;   use Freeze;
35
with Lib;      use Lib;
36
with Lib.Xref; use Lib.Xref;
37
with Namet;    use Namet;
38
with Nlists;   use Nlists;
39
with Nmake;    use Nmake;
40
with Opt;      use Opt;
41
with Restrict; use Restrict;
42
with Rident;   use Rident;
43
with Rtsfind;  use Rtsfind;
44
with Sem;      use Sem;
45
with Sem_Aux;  use Sem_Aux;
46
with Sem_Case; use Sem_Case;
47
with Sem_Ch3;  use Sem_Ch3;
48
with Sem_Ch6;  use Sem_Ch6;
49
with Sem_Ch8;  use Sem_Ch8;
50
with Sem_Dim;  use Sem_Dim;
51
with Sem_Disp; use Sem_Disp;
52
with Sem_Elab; use Sem_Elab;
53
with Sem_Eval; use Sem_Eval;
54
with Sem_Res;  use Sem_Res;
55
with Sem_Type; use Sem_Type;
56
with Sem_Util; use Sem_Util;
57
with Sem_Warn; use Sem_Warn;
58
with Snames;   use Snames;
59
with Stand;    use Stand;
60
with Sinfo;    use Sinfo;
61
with Targparm; use Targparm;
62
with Tbuild;   use Tbuild;
63
with Uintp;    use Uintp;
64
 
65
package body Sem_Ch5 is
66
 
67
   Unblocked_Exit_Count : Nat := 0;
68
   --  This variable is used when processing if statements, case statements,
69
   --  and block statements. It counts the number of exit points that are not
70
   --  blocked by unconditional transfer instructions: for IF and CASE, these
71
   --  are the branches of the conditional; for a block, they are the statement
72
   --  sequence of the block, and the statement sequences of any exception
73
   --  handlers that are part of the block. When processing is complete, if
74
   --  this count is zero, it means that control cannot fall through the IF,
75
   --  CASE or block statement. This is used for the generation of warning
76
   --  messages. This variable is recursively saved on entry to processing the
77
   --  construct, and restored on exit.
78
 
79
   procedure Pre_Analyze_Range (R_Copy : Node_Id);
80
   --  Determine expected type of range or domain of iteration of Ada 2012
81
   --  loop by analyzing separate copy. Do the analysis and resolution of the
82
   --  copy of the bound(s) with expansion disabled, to prevent the generation
83
   --  of finalization actions. This prevents memory leaks when the bounds
84
   --  contain calls to functions returning controlled arrays or when the
85
   --  domain of iteration is a container.
86
 
87
   ------------------------
88
   -- Analyze_Assignment --
89
   ------------------------
90
 
91
   procedure Analyze_Assignment (N : Node_Id) is
92
      Lhs  : constant Node_Id := Name (N);
93
      Rhs  : constant Node_Id := Expression (N);
94
      T1   : Entity_Id;
95
      T2   : Entity_Id;
96
      Decl : Node_Id;
97
 
98
      procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
99
      --  N is the node for the left hand side of an assignment, and it is not
100
      --  a variable. This routine issues an appropriate diagnostic.
101
 
102
      procedure Kill_Lhs;
103
      --  This is called to kill current value settings of a simple variable
104
      --  on the left hand side. We call it if we find any error in analyzing
105
      --  the assignment, and at the end of processing before setting any new
106
      --  current values in place.
107
 
108
      procedure Set_Assignment_Type
109
        (Opnd      : Node_Id;
110
         Opnd_Type : in out Entity_Id);
111
      --  Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type is the
112
      --  nominal subtype. This procedure is used to deal with cases where the
113
      --  nominal subtype must be replaced by the actual subtype.
114
 
115
      -------------------------------
116
      -- Diagnose_Non_Variable_Lhs --
117
      -------------------------------
118
 
119
      procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is
120
      begin
121
         --  Not worth posting another error if left hand side already flagged
122
         --  as being illegal in some respect.
123
 
124
         if Error_Posted (N) then
125
            return;
126
 
127
         --  Some special bad cases of entity names
128
 
129
         elsif Is_Entity_Name (N) then
130
            declare
131
               Ent : constant Entity_Id := Entity (N);
132
 
133
            begin
134
               if Ekind (Ent) = E_In_Parameter then
135
                  Error_Msg_N
136
                    ("assignment to IN mode parameter not allowed", N);
137
 
138
               --  Renamings of protected private components are turned into
139
               --  constants when compiling a protected function. In the case
140
               --  of single protected types, the private component appears
141
               --  directly.
142
 
143
               elsif (Is_Prival (Ent)
144
                        and then
145
                          (Ekind (Current_Scope) = E_Function
146
                             or else Ekind (Enclosing_Dynamic_Scope
147
                                             (Current_Scope)) = E_Function))
148
                   or else
149
                     (Ekind (Ent) = E_Component
150
                        and then Is_Protected_Type (Scope (Ent)))
151
               then
152
                  Error_Msg_N
153
                    ("protected function cannot modify protected object", N);
154
 
155
               elsif Ekind (Ent) = E_Loop_Parameter then
156
                  Error_Msg_N
157
                    ("assignment to loop parameter not allowed", N);
158
 
159
               else
160
                  Error_Msg_N
161
                    ("left hand side of assignment must be a variable", N);
162
               end if;
163
            end;
164
 
165
         --  For indexed components or selected components, test prefix
166
 
167
         elsif Nkind (N) = N_Indexed_Component then
168
            Diagnose_Non_Variable_Lhs (Prefix (N));
169
 
170
         --  Another special case for assignment to discriminant
171
 
172
         elsif Nkind (N) = N_Selected_Component then
173
            if Present (Entity (Selector_Name (N)))
174
              and then Ekind (Entity (Selector_Name (N))) = E_Discriminant
175
            then
176
               Error_Msg_N
177
                 ("assignment to discriminant not allowed", N);
178
            else
179
               Diagnose_Non_Variable_Lhs (Prefix (N));
180
            end if;
181
 
182
         else
183
            --  If we fall through, we have no special message to issue!
184
 
185
            Error_Msg_N ("left hand side of assignment must be a variable", N);
186
         end if;
187
      end Diagnose_Non_Variable_Lhs;
188
 
189
      --------------
190
      -- Kill_LHS --
191
      --------------
192
 
193
      procedure Kill_Lhs is
194
      begin
195
         if Is_Entity_Name (Lhs) then
196
            declare
197
               Ent : constant Entity_Id := Entity (Lhs);
198
            begin
199
               if Present (Ent) then
200
                  Kill_Current_Values (Ent);
201
               end if;
202
            end;
203
         end if;
204
      end Kill_Lhs;
205
 
206
      -------------------------
207
      -- Set_Assignment_Type --
208
      -------------------------
209
 
210
      procedure Set_Assignment_Type
211
        (Opnd      : Node_Id;
212
         Opnd_Type : in out Entity_Id)
213
      is
214
      begin
215
         Require_Entity (Opnd);
216
 
217
         --  If the assignment operand is an in-out or out parameter, then we
218
         --  get the actual subtype (needed for the unconstrained case). If the
219
         --  operand is the actual in an entry declaration, then within the
220
         --  accept statement it is replaced with a local renaming, which may
221
         --  also have an actual subtype.
222
 
223
         if Is_Entity_Name (Opnd)
224
           and then (Ekind (Entity (Opnd)) = E_Out_Parameter
225
                      or else Ekind (Entity (Opnd)) =
226
                           E_In_Out_Parameter
227
                      or else Ekind (Entity (Opnd)) =
228
                           E_Generic_In_Out_Parameter
229
                      or else
230
                        (Ekind (Entity (Opnd)) = E_Variable
231
                          and then Nkind (Parent (Entity (Opnd))) =
232
                             N_Object_Renaming_Declaration
233
                          and then Nkind (Parent (Parent (Entity (Opnd)))) =
234
                             N_Accept_Statement))
235
         then
236
            Opnd_Type := Get_Actual_Subtype (Opnd);
237
 
238
         --  If assignment operand is a component reference, then we get the
239
         --  actual subtype of the component for the unconstrained case.
240
 
241
         elsif Nkind_In (Opnd, N_Selected_Component, N_Explicit_Dereference)
242
           and then not Is_Unchecked_Union (Opnd_Type)
243
         then
244
            Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
245
 
246
            if Present (Decl) then
247
               Insert_Action (N, Decl);
248
               Mark_Rewrite_Insertion (Decl);
249
               Analyze (Decl);
250
               Opnd_Type := Defining_Identifier (Decl);
251
               Set_Etype (Opnd, Opnd_Type);
252
               Freeze_Itype (Opnd_Type, N);
253
 
254
            elsif Is_Constrained (Etype (Opnd)) then
255
               Opnd_Type := Etype (Opnd);
256
            end if;
257
 
258
         --  For slice, use the constrained subtype created for the slice
259
 
260
         elsif Nkind (Opnd) = N_Slice then
261
            Opnd_Type := Etype (Opnd);
262
         end if;
263
      end Set_Assignment_Type;
264
 
265
   --  Start of processing for Analyze_Assignment
266
 
267
   begin
268
      Mark_Coextensions (N, Rhs);
269
 
270
      Analyze (Rhs);
271
      Analyze (Lhs);
272
 
273
      --  Ensure that we never do an assignment on a variable marked as
274
      --  as Safe_To_Reevaluate.
275
 
276
      pragma Assert (not Is_Entity_Name (Lhs)
277
        or else Ekind (Entity (Lhs)) /= E_Variable
278
        or else not Is_Safe_To_Reevaluate (Entity (Lhs)));
279
 
280
      --  Start type analysis for assignment
281
 
282
      T1 := Etype (Lhs);
283
 
284
      --  In the most general case, both Lhs and Rhs can be overloaded, and we
285
      --  must compute the intersection of the possible types on each side.
286
 
287
      if Is_Overloaded (Lhs) then
288
         declare
289
            I  : Interp_Index;
290
            It : Interp;
291
 
292
         begin
293
            T1 := Any_Type;
294
            Get_First_Interp (Lhs, I, It);
295
 
296
            while Present (It.Typ) loop
297
               if Has_Compatible_Type (Rhs, It.Typ) then
298
                  if T1 /= Any_Type then
299
 
300
                     --  An explicit dereference is overloaded if the prefix
301
                     --  is. Try to remove the ambiguity on the prefix, the
302
                     --  error will be posted there if the ambiguity is real.
303
 
304
                     if Nkind (Lhs) = N_Explicit_Dereference then
305
                        declare
306
                           PI    : Interp_Index;
307
                           PI1   : Interp_Index := 0;
308
                           PIt   : Interp;
309
                           Found : Boolean;
310
 
311
                        begin
312
                           Found := False;
313
                           Get_First_Interp (Prefix (Lhs), PI, PIt);
314
 
315
                           while Present (PIt.Typ) loop
316
                              if Is_Access_Type (PIt.Typ)
317
                                and then Has_Compatible_Type
318
                                           (Rhs, Designated_Type (PIt.Typ))
319
                              then
320
                                 if Found then
321
                                    PIt :=
322
                                      Disambiguate (Prefix (Lhs),
323
                                        PI1, PI, Any_Type);
324
 
325
                                    if PIt = No_Interp then
326
                                       Error_Msg_N
327
                                         ("ambiguous left-hand side"
328
                                            & " in assignment", Lhs);
329
                                       exit;
330
                                    else
331
                                       Resolve (Prefix (Lhs), PIt.Typ);
332
                                    end if;
333
 
334
                                    exit;
335
                                 else
336
                                    Found := True;
337
                                    PI1 := PI;
338
                                 end if;
339
                              end if;
340
 
341
                              Get_Next_Interp (PI, PIt);
342
                           end loop;
343
                        end;
344
 
345
                     else
346
                        Error_Msg_N
347
                          ("ambiguous left-hand side in assignment", Lhs);
348
                        exit;
349
                     end if;
350
                  else
351
                     T1 := It.Typ;
352
                  end if;
353
               end if;
354
 
355
               Get_Next_Interp (I, It);
356
            end loop;
357
         end;
358
 
359
         if T1 = Any_Type then
360
            Error_Msg_N
361
              ("no valid types for left-hand side for assignment", Lhs);
362
            Kill_Lhs;
363
            return;
364
         end if;
365
      end if;
366
 
367
      --  The resulting assignment type is T1, so now we will resolve the left
368
      --  hand side of the assignment using this determined type.
369
 
370
      Resolve (Lhs, T1);
371
 
372
      --  Cases where Lhs is not a variable
373
 
374
      if not Is_Variable (Lhs) then
375
 
376
         --  Ada 2005 (AI-327): Check assignment to the attribute Priority of a
377
         --  protected object.
378
 
379
         declare
380
            Ent : Entity_Id;
381
            S   : Entity_Id;
382
 
383
         begin
384
            if Ada_Version >= Ada_2005 then
385
 
386
               --  Handle chains of renamings
387
 
388
               Ent := Lhs;
389
               while Nkind (Ent) in N_Has_Entity
390
                 and then Present (Entity (Ent))
391
                 and then Present (Renamed_Object (Entity (Ent)))
392
               loop
393
                  Ent := Renamed_Object (Entity (Ent));
394
               end loop;
395
 
396
               if (Nkind (Ent) = N_Attribute_Reference
397
                     and then Attribute_Name (Ent) = Name_Priority)
398
 
399
                  --  Renamings of the attribute Priority applied to protected
400
                  --  objects have been previously expanded into calls to the
401
                  --  Get_Ceiling run-time subprogram.
402
 
403
                 or else
404
                  (Nkind (Ent) = N_Function_Call
405
                     and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling)
406
                                or else
407
                               Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling)))
408
               then
409
                  --  The enclosing subprogram cannot be a protected function
410
 
411
                  S := Current_Scope;
412
                  while not (Is_Subprogram (S)
413
                               and then Convention (S) = Convention_Protected)
414
                     and then S /= Standard_Standard
415
                  loop
416
                     S := Scope (S);
417
                  end loop;
418
 
419
                  if Ekind (S) = E_Function
420
                    and then Convention (S) = Convention_Protected
421
                  then
422
                     Error_Msg_N
423
                       ("protected function cannot modify protected object",
424
                        Lhs);
425
                  end if;
426
 
427
                  --  Changes of the ceiling priority of the protected object
428
                  --  are only effective if the Ceiling_Locking policy is in
429
                  --  effect (AARM D.5.2 (5/2)).
430
 
431
                  if Locking_Policy /= 'C' then
432
                     Error_Msg_N ("assignment to the attribute PRIORITY has " &
433
                                  "no effect?", Lhs);
434
                     Error_Msg_N ("\since no Locking_Policy has been " &
435
                                  "specified", Lhs);
436
                  end if;
437
 
438
                  return;
439
               end if;
440
            end if;
441
         end;
442
 
443
         Diagnose_Non_Variable_Lhs (Lhs);
444
         return;
445
 
446
      --  Error of assigning to limited type. We do however allow this in
447
      --  certain cases where the front end generates the assignments.
448
 
449
      elsif Is_Limited_Type (T1)
450
        and then not Assignment_OK (Lhs)
451
        and then not Assignment_OK (Original_Node (Lhs))
452
        and then not Is_Value_Type (T1)
453
      then
454
         --  CPP constructors can only be called in declarations
455
 
456
         if Is_CPP_Constructor_Call (Rhs) then
457
            Error_Msg_N ("invalid use of 'C'P'P constructor", Rhs);
458
         else
459
            Error_Msg_N
460
              ("left hand of assignment must not be limited type", Lhs);
461
            Explain_Limited_Type (T1, Lhs);
462
         end if;
463
         return;
464
 
465
      --  Enforce RM 3.9.3 (8): the target of an assignment operation cannot be
466
      --  abstract. This is only checked when the assignment Comes_From_Source,
467
      --  because in some cases the expander generates such assignments (such
468
      --  in the _assign operation for an abstract type).
469
 
470
      elsif Is_Abstract_Type (T1) and then Comes_From_Source (N) then
471
         Error_Msg_N
472
           ("target of assignment operation must not be abstract", Lhs);
473
      end if;
474
 
475
      --  Resolution may have updated the subtype, in case the left-hand side
476
      --  is a private protected component. Use the correct subtype to avoid
477
      --  scoping issues in the back-end.
478
 
479
      T1 := Etype (Lhs);
480
 
481
      --  Ada 2005 (AI-50217, AI-326): Check wrong dereference of incomplete
482
      --  type. For example:
483
 
484
      --    limited with P;
485
      --    package Pkg is
486
      --      type Acc is access P.T;
487
      --    end Pkg;
488
 
489
      --    with Pkg; use Acc;
490
      --    procedure Example is
491
      --       A, B : Acc;
492
      --    begin
493
      --       A.all := B.all;  -- ERROR
494
      --    end Example;
495
 
496
      if Nkind (Lhs) = N_Explicit_Dereference
497
        and then Ekind (T1) = E_Incomplete_Type
498
      then
499
         Error_Msg_N ("invalid use of incomplete type", Lhs);
500
         Kill_Lhs;
501
         return;
502
      end if;
503
 
504
      --  Now we can complete the resolution of the right hand side
505
 
506
      Set_Assignment_Type (Lhs, T1);
507
      Resolve (Rhs, T1);
508
 
509
      --  This is the point at which we check for an unset reference
510
 
511
      Check_Unset_Reference (Rhs);
512
      Check_Unprotected_Access (Lhs, Rhs);
513
 
514
      --  Remaining steps are skipped if Rhs was syntactically in error
515
 
516
      if Rhs = Error then
517
         Kill_Lhs;
518
         return;
519
      end if;
520
 
521
      T2 := Etype (Rhs);
522
 
523
      if not Covers (T1, T2) then
524
         Wrong_Type (Rhs, Etype (Lhs));
525
         Kill_Lhs;
526
         return;
527
      end if;
528
 
529
      --  Ada 2005 (AI-326): In case of explicit dereference of incomplete
530
      --  types, use the non-limited view if available
531
 
532
      if Nkind (Rhs) = N_Explicit_Dereference
533
        and then Ekind (T2) = E_Incomplete_Type
534
        and then Is_Tagged_Type (T2)
535
        and then Present (Non_Limited_View (T2))
536
      then
537
         T2 := Non_Limited_View (T2);
538
      end if;
539
 
540
      Set_Assignment_Type (Rhs, T2);
541
 
542
      if Total_Errors_Detected /= 0 then
543
         if No (T1) then
544
            T1 := Any_Type;
545
         end if;
546
 
547
         if No (T2) then
548
            T2 := Any_Type;
549
         end if;
550
      end if;
551
 
552
      if T1 = Any_Type or else T2 = Any_Type then
553
         Kill_Lhs;
554
         return;
555
      end if;
556
 
557
      --  If the rhs is class-wide or dynamically tagged, then require the lhs
558
      --  to be class-wide. The case where the rhs is a dynamically tagged call
559
      --  to a dispatching operation with a controlling access result is
560
      --  excluded from this check, since the target has an access type (and
561
      --  no tag propagation occurs in that case).
562
 
563
      if (Is_Class_Wide_Type (T2)
564
           or else (Is_Dynamically_Tagged (Rhs)
565
                     and then not Is_Access_Type (T1)))
566
        and then not Is_Class_Wide_Type (T1)
567
      then
568
         Error_Msg_N ("dynamically tagged expression not allowed!", Rhs);
569
 
570
      elsif Is_Class_Wide_Type (T1)
571
        and then not Is_Class_Wide_Type (T2)
572
        and then not Is_Tag_Indeterminate (Rhs)
573
        and then not Is_Dynamically_Tagged (Rhs)
574
      then
575
         Error_Msg_N ("dynamically tagged expression required!", Rhs);
576
      end if;
577
 
578
      --  Propagate the tag from a class-wide target to the rhs when the rhs
579
      --  is a tag-indeterminate call.
580
 
581
      if Is_Tag_Indeterminate (Rhs) then
582
         if Is_Class_Wide_Type (T1) then
583
            Propagate_Tag (Lhs, Rhs);
584
 
585
         elsif Nkind (Rhs) = N_Function_Call
586
              and then Is_Entity_Name (Name (Rhs))
587
              and then Is_Abstract_Subprogram (Entity (Name (Rhs)))
588
         then
589
            Error_Msg_N
590
              ("call to abstract function must be dispatching", Name (Rhs));
591
 
592
         elsif Nkind (Rhs) = N_Qualified_Expression
593
           and then Nkind (Expression (Rhs)) = N_Function_Call
594
              and then Is_Entity_Name (Name (Expression (Rhs)))
595
              and then
596
                Is_Abstract_Subprogram (Entity (Name (Expression (Rhs))))
597
         then
598
            Error_Msg_N
599
              ("call to abstract function must be dispatching",
600
                Name (Expression (Rhs)));
601
         end if;
602
      end if;
603
 
604
      --  Ada 2005 (AI-385): When the lhs type is an anonymous access type,
605
      --  apply an implicit conversion of the rhs to that type to force
606
      --  appropriate static and run-time accessibility checks. This applies
607
      --  as well to anonymous access-to-subprogram types that are component
608
      --  subtypes or formal parameters.
609
 
610
      if Ada_Version >= Ada_2005
611
        and then Is_Access_Type (T1)
612
      then
613
         if Is_Local_Anonymous_Access (T1)
614
           or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type
615
 
616
           --  Handle assignment to an Ada 2012 stand-alone object
617
           --  of an anonymous access type.
618
 
619
           or else (Ekind (T1) = E_Anonymous_Access_Type
620
                     and then Nkind (Associated_Node_For_Itype (T1)) =
621
                                                       N_Object_Declaration)
622
 
623
         then
624
            Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
625
            Analyze_And_Resolve (Rhs, T1);
626
         end if;
627
      end if;
628
 
629
      --  Ada 2005 (AI-231): Assignment to not null variable
630
 
631
      if Ada_Version >= Ada_2005
632
        and then Can_Never_Be_Null (T1)
633
        and then not Assignment_OK (Lhs)
634
      then
635
         --  Case where we know the right hand side is null
636
 
637
         if Known_Null (Rhs) then
638
            Apply_Compile_Time_Constraint_Error
639
              (N   => Rhs,
640
               Msg => "(Ada 2005) null not allowed in null-excluding objects?",
641
               Reason => CE_Null_Not_Allowed);
642
 
643
            --  We still mark this as a possible modification, that's necessary
644
            --  to reset Is_True_Constant, and desirable for xref purposes.
645
 
646
            Note_Possible_Modification (Lhs, Sure => True);
647
            return;
648
 
649
         --  If we know the right hand side is non-null, then we convert to the
650
         --  target type, since we don't need a run time check in that case.
651
 
652
         elsif not Can_Never_Be_Null (T2) then
653
            Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
654
            Analyze_And_Resolve (Rhs, T1);
655
         end if;
656
      end if;
657
 
658
      if Is_Scalar_Type (T1) then
659
         Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
660
 
661
      --  For array types, verify that lengths match. If the right hand side
662
      --  is a function call that has been inlined, the assignment has been
663
      --  rewritten as a block, and the constraint check will be applied to the
664
      --  assignment within the block.
665
 
666
      elsif Is_Array_Type (T1)
667
        and then
668
          (Nkind (Rhs) /= N_Type_Conversion
669
            or else Is_Constrained (Etype (Rhs)))
670
        and then
671
          (Nkind (Rhs) /= N_Function_Call
672
            or else Nkind (N) /= N_Block_Statement)
673
      then
674
         --  Assignment verifies that the length of the Lsh and Rhs are equal,
675
         --  but of course the indexes do not have to match. If the right-hand
676
         --  side is a type conversion to an unconstrained type, a length check
677
         --  is performed on the expression itself during expansion. In rare
678
         --  cases, the redundant length check is computed on an index type
679
         --  with a different representation, triggering incorrect code in the
680
         --  back end.
681
 
682
         Apply_Length_Check (Rhs, Etype (Lhs));
683
 
684
      else
685
         --  Discriminant checks are applied in the course of expansion
686
 
687
         null;
688
      end if;
689
 
690
      --  Note: modifications of the Lhs may only be recorded after
691
      --  checks have been applied.
692
 
693
      Note_Possible_Modification (Lhs, Sure => True);
694
      Check_Order_Dependence;
695
 
696
      --  ??? a real accessibility check is needed when ???
697
 
698
      --  Post warning for redundant assignment or variable to itself
699
 
700
      if Warn_On_Redundant_Constructs
701
 
702
         --  We only warn for source constructs
703
 
704
         and then Comes_From_Source (N)
705
 
706
         --  Where the object is the same on both sides
707
 
708
         and then Same_Object (Lhs, Original_Node (Rhs))
709
 
710
         --  But exclude the case where the right side was an operation that
711
         --  got rewritten (e.g. JUNK + K, where K was known to be zero). We
712
         --  don't want to warn in such a case, since it is reasonable to write
713
         --  such expressions especially when K is defined symbolically in some
714
         --  other package.
715
 
716
        and then Nkind (Original_Node (Rhs)) not in N_Op
717
      then
718
         if Nkind (Lhs) in N_Has_Entity then
719
            Error_Msg_NE -- CODEFIX
720
              ("?useless assignment of & to itself!", N, Entity (Lhs));
721
         else
722
            Error_Msg_N -- CODEFIX
723
              ("?useless assignment of object to itself!", N);
724
         end if;
725
      end if;
726
 
727
      --  Check for non-allowed composite assignment
728
 
729
      if not Support_Composite_Assign_On_Target
730
        and then (Is_Array_Type (T1) or else Is_Record_Type (T1))
731
        and then (not Has_Size_Clause (T1) or else Esize (T1) > 64)
732
      then
733
         Error_Msg_CRT ("composite assignment", N);
734
      end if;
735
 
736
      --  Check elaboration warning for left side if not in elab code
737
 
738
      if not In_Subprogram_Or_Concurrent_Unit then
739
         Check_Elab_Assign (Lhs);
740
      end if;
741
 
742
      --  Set Referenced_As_LHS if appropriate. We only set this flag if the
743
      --  assignment is a source assignment in the extended main source unit.
744
      --  We are not interested in any reference information outside this
745
      --  context, or in compiler generated assignment statements.
746
 
747
      if Comes_From_Source (N)
748
        and then In_Extended_Main_Source_Unit (Lhs)
749
      then
750
         Set_Referenced_Modified (Lhs, Out_Param => False);
751
      end if;
752
 
753
      --  Final step. If left side is an entity, then we may be able to reset
754
      --  the current tracked values to new safe values. We only have something
755
      --  to do if the left side is an entity name, and expansion has not
756
      --  modified the node into something other than an assignment, and of
757
      --  course we only capture values if it is safe to do so.
758
 
759
      if Is_Entity_Name (Lhs)
760
        and then Nkind (N) = N_Assignment_Statement
761
      then
762
         declare
763
            Ent : constant Entity_Id := Entity (Lhs);
764
 
765
         begin
766
            if Safe_To_Capture_Value (N, Ent) then
767
 
768
               --  If simple variable on left side, warn if this assignment
769
               --  blots out another one (rendering it useless). We only do
770
               --  this for source assignments, otherwise we can generate bogus
771
               --  warnings when an assignment is rewritten as another
772
               --  assignment, and gets tied up with itself.
773
 
774
               if Warn_On_Modified_Unread
775
                 and then Is_Assignable (Ent)
776
                 and then Comes_From_Source (N)
777
                 and then In_Extended_Main_Source_Unit (Ent)
778
               then
779
                  Warn_On_Useless_Assignment (Ent, N);
780
               end if;
781
 
782
               --  If we are assigning an access type and the left side is an
783
               --  entity, then make sure that the Is_Known_[Non_]Null flags
784
               --  properly reflect the state of the entity after assignment.
785
 
786
               if Is_Access_Type (T1) then
787
                  if Known_Non_Null (Rhs) then
788
                     Set_Is_Known_Non_Null (Ent, True);
789
 
790
                  elsif Known_Null (Rhs)
791
                    and then not Can_Never_Be_Null (Ent)
792
                  then
793
                     Set_Is_Known_Null (Ent, True);
794
 
795
                  else
796
                     Set_Is_Known_Null (Ent, False);
797
 
798
                     if not Can_Never_Be_Null (Ent) then
799
                        Set_Is_Known_Non_Null (Ent, False);
800
                     end if;
801
                  end if;
802
 
803
               --  For discrete types, we may be able to set the current value
804
               --  if the value is known at compile time.
805
 
806
               elsif Is_Discrete_Type (T1)
807
                 and then Compile_Time_Known_Value (Rhs)
808
               then
809
                  Set_Current_Value (Ent, Rhs);
810
               else
811
                  Set_Current_Value (Ent, Empty);
812
               end if;
813
 
814
            --  If not safe to capture values, kill them
815
 
816
            else
817
               Kill_Lhs;
818
            end if;
819
         end;
820
      end if;
821
 
822
      --  If assigning to an object in whole or in part, note location of
823
      --  assignment in case no one references value. We only do this for
824
      --  source assignments, otherwise we can generate bogus warnings when an
825
      --  assignment is rewritten as another assignment, and gets tied up with
826
      --  itself.
827
 
828
      declare
829
         Ent : constant Entity_Id := Get_Enclosing_Object (Lhs);
830
      begin
831
         if Present (Ent)
832
           and then Safe_To_Capture_Value (N, Ent)
833
           and then Nkind (N) = N_Assignment_Statement
834
           and then Warn_On_Modified_Unread
835
           and then Is_Assignable (Ent)
836
           and then Comes_From_Source (N)
837
           and then In_Extended_Main_Source_Unit (Ent)
838
         then
839
            Set_Last_Assignment (Ent, Lhs);
840
         end if;
841
      end;
842
 
843
      Analyze_Dimension (N);
844
   end Analyze_Assignment;
845
 
846
   -----------------------------
847
   -- Analyze_Block_Statement --
848
   -----------------------------
849
 
850
   procedure Analyze_Block_Statement (N : Node_Id) is
851
      procedure Install_Return_Entities (Scop : Entity_Id);
852
      --  Install all entities of return statement scope Scop in the visibility
853
      --  chain except for the return object since its entity is reused in a
854
      --  renaming.
855
 
856
      -----------------------------
857
      -- Install_Return_Entities --
858
      -----------------------------
859
 
860
      procedure Install_Return_Entities (Scop : Entity_Id) is
861
         Id : Entity_Id;
862
 
863
      begin
864
         Id := First_Entity (Scop);
865
         while Present (Id) loop
866
 
867
            --  Do not install the return object
868
 
869
            if not Ekind_In (Id, E_Constant, E_Variable)
870
              or else not Is_Return_Object (Id)
871
            then
872
               Install_Entity (Id);
873
            end if;
874
 
875
            Next_Entity (Id);
876
         end loop;
877
      end Install_Return_Entities;
878
 
879
      --  Local constants and variables
880
 
881
      Decls : constant List_Id := Declarations (N);
882
      Id    : constant Node_Id := Identifier (N);
883
      HSS   : constant Node_Id := Handled_Statement_Sequence (N);
884
 
885
      Is_BIP_Return_Statement : Boolean;
886
 
887
   --  Start of processing for Analyze_Block_Statement
888
 
889
   begin
890
      --  In SPARK mode, we reject block statements. Note that the case of
891
      --  block statements generated by the expander is fine.
892
 
893
      if Nkind (Original_Node (N)) = N_Block_Statement then
894
         Check_SPARK_Restriction ("block statement is not allowed", N);
895
      end if;
896
 
897
      --  If no handled statement sequence is present, things are really messed
898
      --  up, and we just return immediately (defence against previous errors).
899
 
900
      if No (HSS) then
901
         return;
902
      end if;
903
 
904
      --  Detect whether the block is actually a rewritten return statement of
905
      --  a build-in-place function.
906
 
907
      Is_BIP_Return_Statement :=
908
        Present (Id)
909
          and then Present (Entity (Id))
910
          and then Ekind (Entity (Id)) = E_Return_Statement
911
          and then Is_Build_In_Place_Function
912
                     (Return_Applies_To (Entity (Id)));
913
 
914
      --  Normal processing with HSS present
915
 
916
      declare
917
         EH  : constant List_Id := Exception_Handlers (HSS);
918
         Ent : Entity_Id        := Empty;
919
         S   : Entity_Id;
920
 
921
         Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
922
         --  Recursively save value of this global, will be restored on exit
923
 
924
      begin
925
         --  Initialize unblocked exit count for statements of begin block
926
         --  plus one for each exception handler that is present.
927
 
928
         Unblocked_Exit_Count := 1;
929
 
930
         if Present (EH) then
931
            Unblocked_Exit_Count := Unblocked_Exit_Count + List_Length (EH);
932
         end if;
933
 
934
         --  If a label is present analyze it and mark it as referenced
935
 
936
         if Present (Id) then
937
            Analyze (Id);
938
            Ent := Entity (Id);
939
 
940
            --  An error defense. If we have an identifier, but no entity, then
941
            --  something is wrong. If previous errors, then just remove the
942
            --  identifier and continue, otherwise raise an exception.
943
 
944
            if No (Ent) then
945
               if Total_Errors_Detected /= 0 then
946
                  Set_Identifier (N, Empty);
947
               else
948
                  raise Program_Error;
949
               end if;
950
 
951
            else
952
               Set_Ekind (Ent, E_Block);
953
               Generate_Reference (Ent, N, ' ');
954
               Generate_Definition (Ent);
955
 
956
               if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
957
                  Set_Label_Construct (Parent (Ent), N);
958
               end if;
959
            end if;
960
         end if;
961
 
962
         --  If no entity set, create a label entity
963
 
964
         if No (Ent) then
965
            Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
966
            Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N)));
967
            Set_Parent (Ent, N);
968
         end if;
969
 
970
         Set_Etype (Ent, Standard_Void_Type);
971
         Set_Block_Node (Ent, Identifier (N));
972
         Push_Scope (Ent);
973
 
974
         --  The block served as an extended return statement. Ensure that any
975
         --  entities created during the analysis and expansion of the return
976
         --  object declaration are once again visible.
977
 
978
         if Is_BIP_Return_Statement then
979
            Install_Return_Entities (Ent);
980
         end if;
981
 
982
         if Present (Decls) then
983
            Analyze_Declarations (Decls);
984
            Check_Completion;
985
            Inspect_Deferred_Constant_Completion (Decls);
986
         end if;
987
 
988
         Analyze (HSS);
989
         Process_End_Label (HSS, 'e', Ent);
990
 
991
         --  If exception handlers are present, then we indicate that enclosing
992
         --  scopes contain a block with handlers. We only need to mark non-
993
         --  generic scopes.
994
 
995
         if Present (EH) then
996
            S := Scope (Ent);
997
            loop
998
               Set_Has_Nested_Block_With_Handler (S);
999
               exit when Is_Overloadable (S)
1000
                 or else Ekind (S) = E_Package
1001
                 or else Is_Generic_Unit (S);
1002
               S := Scope (S);
1003
            end loop;
1004
         end if;
1005
 
1006
         Check_References (Ent);
1007
         Warn_On_Useless_Assignments (Ent);
1008
         End_Scope;
1009
 
1010
         if Unblocked_Exit_Count = 0 then
1011
            Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1012
            Check_Unreachable_Code (N);
1013
         else
1014
            Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1015
         end if;
1016
      end;
1017
   end Analyze_Block_Statement;
1018
 
1019
   ----------------------------
1020
   -- Analyze_Case_Statement --
1021
   ----------------------------
1022
 
1023
   procedure Analyze_Case_Statement (N : Node_Id) is
1024
      Exp            : Node_Id;
1025
      Exp_Type       : Entity_Id;
1026
      Exp_Btype      : Entity_Id;
1027
      Last_Choice    : Nat;
1028
      Dont_Care      : Boolean;
1029
      Others_Present : Boolean;
1030
 
1031
      pragma Warnings (Off, Last_Choice);
1032
      pragma Warnings (Off, Dont_Care);
1033
      --  Don't care about assigned values
1034
 
1035
      Statements_Analyzed : Boolean := False;
1036
      --  Set True if at least some statement sequences get analyzed. If False
1037
      --  on exit, means we had a serious error that prevented full analysis of
1038
      --  the case statement, and as a result it is not a good idea to output
1039
      --  warning messages about unreachable code.
1040
 
1041
      Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
1042
      --  Recursively save value of this global, will be restored on exit
1043
 
1044
      procedure Non_Static_Choice_Error (Choice : Node_Id);
1045
      --  Error routine invoked by the generic instantiation below when the
1046
      --  case statement has a non static choice.
1047
 
1048
      procedure Process_Statements (Alternative : Node_Id);
1049
      --  Analyzes all the statements associated with a case alternative.
1050
      --  Needed by the generic instantiation below.
1051
 
1052
      package Case_Choices_Processing is new
1053
        Generic_Choices_Processing
1054
          (Get_Alternatives          => Alternatives,
1055
           Get_Choices               => Discrete_Choices,
1056
           Process_Empty_Choice      => No_OP,
1057
           Process_Non_Static_Choice => Non_Static_Choice_Error,
1058
           Process_Associated_Node   => Process_Statements);
1059
      use Case_Choices_Processing;
1060
      --  Instantiation of the generic choice processing package
1061
 
1062
      -----------------------------
1063
      -- Non_Static_Choice_Error --
1064
      -----------------------------
1065
 
1066
      procedure Non_Static_Choice_Error (Choice : Node_Id) is
1067
      begin
1068
         Flag_Non_Static_Expr
1069
           ("choice given in case statement is not static!", Choice);
1070
      end Non_Static_Choice_Error;
1071
 
1072
      ------------------------
1073
      -- Process_Statements --
1074
      ------------------------
1075
 
1076
      procedure Process_Statements (Alternative : Node_Id) is
1077
         Choices : constant List_Id := Discrete_Choices (Alternative);
1078
         Ent     : Entity_Id;
1079
 
1080
      begin
1081
         Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
1082
         Statements_Analyzed := True;
1083
 
1084
         --  An interesting optimization. If the case statement expression
1085
         --  is a simple entity, then we can set the current value within an
1086
         --  alternative if the alternative has one possible value.
1087
 
1088
         --    case N is
1089
         --      when 1      => alpha
1090
         --      when 2 | 3  => beta
1091
         --      when others => gamma
1092
 
1093
         --  Here we know that N is initially 1 within alpha, but for beta and
1094
         --  gamma, we do not know anything more about the initial value.
1095
 
1096
         if Is_Entity_Name (Exp) then
1097
            Ent := Entity (Exp);
1098
 
1099
            if Ekind_In (Ent, E_Variable,
1100
                              E_In_Out_Parameter,
1101
                              E_Out_Parameter)
1102
            then
1103
               if List_Length (Choices) = 1
1104
                 and then Nkind (First (Choices)) in N_Subexpr
1105
                 and then Compile_Time_Known_Value (First (Choices))
1106
               then
1107
                  Set_Current_Value (Entity (Exp), First (Choices));
1108
               end if;
1109
 
1110
               Analyze_Statements (Statements (Alternative));
1111
 
1112
               --  After analyzing the case, set the current value to empty
1113
               --  since we won't know what it is for the next alternative
1114
               --  (unless reset by this same circuit), or after the case.
1115
 
1116
               Set_Current_Value (Entity (Exp), Empty);
1117
               return;
1118
            end if;
1119
         end if;
1120
 
1121
         --  Case where expression is not an entity name of a variable
1122
 
1123
         Analyze_Statements (Statements (Alternative));
1124
      end Process_Statements;
1125
 
1126
   --  Start of processing for Analyze_Case_Statement
1127
 
1128
   begin
1129
      Unblocked_Exit_Count := 0;
1130
      Exp := Expression (N);
1131
      Analyze (Exp);
1132
 
1133
      --  The expression must be of any discrete type. In rare cases, the
1134
      --  expander constructs a case statement whose expression has a private
1135
      --  type whose full view is discrete. This can happen when generating
1136
      --  a stream operation for a variant type after the type is frozen,
1137
      --  when the partial of view of the type of the discriminant is private.
1138
      --  In that case, use the full view to analyze case alternatives.
1139
 
1140
      if not Is_Overloaded (Exp)
1141
        and then not Comes_From_Source (N)
1142
        and then Is_Private_Type (Etype (Exp))
1143
        and then Present (Full_View (Etype (Exp)))
1144
        and then Is_Discrete_Type (Full_View (Etype (Exp)))
1145
      then
1146
         Resolve (Exp, Etype (Exp));
1147
         Exp_Type := Full_View (Etype (Exp));
1148
 
1149
      else
1150
         Analyze_And_Resolve (Exp, Any_Discrete);
1151
         Exp_Type := Etype (Exp);
1152
      end if;
1153
 
1154
      Check_Unset_Reference (Exp);
1155
      Exp_Btype := Base_Type (Exp_Type);
1156
 
1157
      --  The expression must be of a discrete type which must be determinable
1158
      --  independently of the context in which the expression occurs, but
1159
      --  using the fact that the expression must be of a discrete type.
1160
      --  Moreover, the type this expression must not be a character literal
1161
      --  (which is always ambiguous) or, for Ada-83, a generic formal type.
1162
 
1163
      --  If error already reported by Resolve, nothing more to do
1164
 
1165
      if Exp_Btype = Any_Discrete
1166
        or else Exp_Btype = Any_Type
1167
      then
1168
         return;
1169
 
1170
      elsif Exp_Btype = Any_Character then
1171
         Error_Msg_N
1172
           ("character literal as case expression is ambiguous", Exp);
1173
         return;
1174
 
1175
      elsif Ada_Version = Ada_83
1176
        and then (Is_Generic_Type (Exp_Btype)
1177
                    or else Is_Generic_Type (Root_Type (Exp_Btype)))
1178
      then
1179
         Error_Msg_N
1180
           ("(Ada 83) case expression cannot be of a generic type", Exp);
1181
         return;
1182
      end if;
1183
 
1184
      --  If the case expression is a formal object of mode in out, then treat
1185
      --  it as having a nonstatic subtype by forcing use of the base type
1186
      --  (which has to get passed to Check_Case_Choices below). Also use base
1187
      --  type when the case expression is parenthesized.
1188
 
1189
      if Paren_Count (Exp) > 0
1190
        or else (Is_Entity_Name (Exp)
1191
                  and then Ekind (Entity (Exp)) = E_Generic_In_Out_Parameter)
1192
      then
1193
         Exp_Type := Exp_Btype;
1194
      end if;
1195
 
1196
      --  Call instantiated Analyze_Choices which does the rest of the work
1197
 
1198
      Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
1199
 
1200
      --  A case statement with a single OTHERS alternative is not allowed
1201
      --  in SPARK.
1202
 
1203
      if Others_Present
1204
        and then List_Length (Alternatives (N)) = 1
1205
      then
1206
         Check_SPARK_Restriction
1207
           ("OTHERS as unique case alternative is not allowed", N);
1208
      end if;
1209
 
1210
      if Exp_Type = Universal_Integer and then not Others_Present then
1211
         Error_Msg_N ("case on universal integer requires OTHERS choice", Exp);
1212
      end if;
1213
 
1214
      --  If all our exits were blocked by unconditional transfers of control,
1215
      --  then the entire CASE statement acts as an unconditional transfer of
1216
      --  control, so treat it like one, and check unreachable code. Skip this
1217
      --  test if we had serious errors preventing any statement analysis.
1218
 
1219
      if Unblocked_Exit_Count = 0 and then Statements_Analyzed then
1220
         Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1221
         Check_Unreachable_Code (N);
1222
      else
1223
         Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1224
      end if;
1225
 
1226
      if not Expander_Active
1227
        and then Compile_Time_Known_Value (Expression (N))
1228
        and then Serious_Errors_Detected = 0
1229
      then
1230
         declare
1231
            Chosen : constant Node_Id := Find_Static_Alternative (N);
1232
            Alt    : Node_Id;
1233
 
1234
         begin
1235
            Alt := First (Alternatives (N));
1236
            while Present (Alt) loop
1237
               if Alt /= Chosen then
1238
                  Remove_Warning_Messages (Statements (Alt));
1239
               end if;
1240
 
1241
               Next (Alt);
1242
            end loop;
1243
         end;
1244
      end if;
1245
   end Analyze_Case_Statement;
1246
 
1247
   ----------------------------
1248
   -- Analyze_Exit_Statement --
1249
   ----------------------------
1250
 
1251
   --  If the exit includes a name, it must be the name of a currently open
1252
   --  loop. Otherwise there must be an innermost open loop on the stack, to
1253
   --  which the statement implicitly refers.
1254
 
1255
   --  Additionally, in SPARK mode:
1256
 
1257
   --    The exit can only name the closest enclosing loop;
1258
 
1259
   --    An exit with a when clause must be directly contained in a loop;
1260
 
1261
   --    An exit without a when clause must be directly contained in an
1262
   --    if-statement with no elsif or else, which is itself directly contained
1263
   --    in a loop. The exit must be the last statement in the if-statement.
1264
 
1265
   procedure Analyze_Exit_Statement (N : Node_Id) is
1266
      Target   : constant Node_Id := Name (N);
1267
      Cond     : constant Node_Id := Condition (N);
1268
      Scope_Id : Entity_Id;
1269
      U_Name   : Entity_Id;
1270
      Kind     : Entity_Kind;
1271
 
1272
   begin
1273
      if No (Cond) then
1274
         Check_Unreachable_Code (N);
1275
      end if;
1276
 
1277
      if Present (Target) then
1278
         Analyze (Target);
1279
         U_Name := Entity (Target);
1280
 
1281
         if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then
1282
            Error_Msg_N ("invalid loop name in exit statement", N);
1283
            return;
1284
 
1285
         else
1286
            if Has_Loop_In_Inner_Open_Scopes (U_Name) then
1287
               Check_SPARK_Restriction
1288
                 ("exit label must name the closest enclosing loop", N);
1289
            end if;
1290
 
1291
            Set_Has_Exit (U_Name);
1292
         end if;
1293
 
1294
      else
1295
         U_Name := Empty;
1296
      end if;
1297
 
1298
      for J in reverse 0 .. Scope_Stack.Last loop
1299
         Scope_Id := Scope_Stack.Table (J).Entity;
1300
         Kind := Ekind (Scope_Id);
1301
 
1302
         if Kind = E_Loop
1303
           and then (No (Target) or else Scope_Id = U_Name)
1304
         then
1305
            Set_Has_Exit (Scope_Id);
1306
            exit;
1307
 
1308
         elsif Kind = E_Block
1309
           or else Kind = E_Loop
1310
           or else Kind = E_Return_Statement
1311
         then
1312
            null;
1313
 
1314
         else
1315
            Error_Msg_N
1316
              ("cannot exit from program unit or accept statement", N);
1317
            return;
1318
         end if;
1319
      end loop;
1320
 
1321
      --  Verify that if present the condition is a Boolean expression
1322
 
1323
      if Present (Cond) then
1324
         Analyze_And_Resolve (Cond, Any_Boolean);
1325
         Check_Unset_Reference (Cond);
1326
      end if;
1327
 
1328
      --  In SPARK mode, verify that the exit statement respects the SPARK
1329
      --  restrictions.
1330
 
1331
      if Present (Cond) then
1332
         if Nkind (Parent (N)) /= N_Loop_Statement then
1333
            Check_SPARK_Restriction
1334
              ("exit with when clause must be directly in loop", N);
1335
         end if;
1336
 
1337
      else
1338
         if Nkind (Parent (N)) /= N_If_Statement then
1339
            if Nkind (Parent (N)) = N_Elsif_Part then
1340
               Check_SPARK_Restriction
1341
                 ("exit must be in IF without ELSIF", N);
1342
            else
1343
               Check_SPARK_Restriction ("exit must be directly in IF", N);
1344
            end if;
1345
 
1346
         elsif Nkind (Parent (Parent (N))) /= N_Loop_Statement then
1347
            Check_SPARK_Restriction
1348
              ("exit must be in IF directly in loop", N);
1349
 
1350
         --  First test the presence of ELSE, so that an exit in an ELSE leads
1351
         --  to an error mentioning the ELSE.
1352
 
1353
         elsif Present (Else_Statements (Parent (N))) then
1354
            Check_SPARK_Restriction ("exit must be in IF without ELSE", N);
1355
 
1356
         --  An exit in an ELSIF does not reach here, as it would have been
1357
         --  detected in the case (Nkind (Parent (N)) /= N_If_Statement).
1358
 
1359
         elsif Present (Elsif_Parts (Parent (N))) then
1360
            Check_SPARK_Restriction ("exit must be in IF without ELSIF", N);
1361
         end if;
1362
      end if;
1363
 
1364
      --  Chain exit statement to associated loop entity
1365
 
1366
      Set_Next_Exit_Statement  (N, First_Exit_Statement (Scope_Id));
1367
      Set_First_Exit_Statement (Scope_Id, N);
1368
 
1369
      --  Since the exit may take us out of a loop, any previous assignment
1370
      --  statement is not useless, so clear last assignment indications. It
1371
      --  is OK to keep other current values, since if the exit statement
1372
      --  does not exit, then the current values are still valid.
1373
 
1374
      Kill_Current_Values (Last_Assignment_Only => True);
1375
   end Analyze_Exit_Statement;
1376
 
1377
   ----------------------------
1378
   -- Analyze_Goto_Statement --
1379
   ----------------------------
1380
 
1381
   procedure Analyze_Goto_Statement (N : Node_Id) is
1382
      Label       : constant Node_Id := Name (N);
1383
      Scope_Id    : Entity_Id;
1384
      Label_Scope : Entity_Id;
1385
      Label_Ent   : Entity_Id;
1386
 
1387
   begin
1388
      Check_SPARK_Restriction ("goto statement is not allowed", N);
1389
 
1390
      --  Actual semantic checks
1391
 
1392
      Check_Unreachable_Code (N);
1393
      Kill_Current_Values (Last_Assignment_Only => True);
1394
 
1395
      Analyze (Label);
1396
      Label_Ent := Entity (Label);
1397
 
1398
      --  Ignore previous error
1399
 
1400
      if Label_Ent = Any_Id then
1401
         return;
1402
 
1403
      --  We just have a label as the target of a goto
1404
 
1405
      elsif Ekind (Label_Ent) /= E_Label then
1406
         Error_Msg_N ("target of goto statement must be a label", Label);
1407
         return;
1408
 
1409
      --  Check that the target of the goto is reachable according to Ada
1410
      --  scoping rules. Note: the special gotos we generate for optimizing
1411
      --  local handling of exceptions would violate these rules, but we mark
1412
      --  such gotos as analyzed when built, so this code is never entered.
1413
 
1414
      elsif not Reachable (Label_Ent) then
1415
         Error_Msg_N ("target of goto statement is not reachable", Label);
1416
         return;
1417
      end if;
1418
 
1419
      --  Here if goto passes initial validity checks
1420
 
1421
      Label_Scope := Enclosing_Scope (Label_Ent);
1422
 
1423
      for J in reverse 0 .. Scope_Stack.Last loop
1424
         Scope_Id := Scope_Stack.Table (J).Entity;
1425
 
1426
         if Label_Scope = Scope_Id
1427
           or else (Ekind (Scope_Id) /= E_Block
1428
                     and then Ekind (Scope_Id) /= E_Loop
1429
                     and then Ekind (Scope_Id) /= E_Return_Statement)
1430
         then
1431
            if Scope_Id /= Label_Scope then
1432
               Error_Msg_N
1433
                 ("cannot exit from program unit or accept statement", N);
1434
            end if;
1435
 
1436
            return;
1437
         end if;
1438
      end loop;
1439
 
1440
      raise Program_Error;
1441
   end Analyze_Goto_Statement;
1442
 
1443
   --------------------------
1444
   -- Analyze_If_Statement --
1445
   --------------------------
1446
 
1447
   --  A special complication arises in the analysis of if statements
1448
 
1449
   --  The expander has circuitry to completely delete code that it can tell
1450
   --  will not be executed (as a result of compile time known conditions). In
1451
   --  the analyzer, we ensure that code that will be deleted in this manner is
1452
   --  analyzed but not expanded. This is obviously more efficient, but more
1453
   --  significantly, difficulties arise if code is expanded and then
1454
   --  eliminated (e.g. exception table entries disappear). Similarly, itypes
1455
   --  generated in deleted code must be frozen from start, because the nodes
1456
   --  on which they depend will not be available at the freeze point.
1457
 
1458
   procedure Analyze_If_Statement (N : Node_Id) is
1459
      E : Node_Id;
1460
 
1461
      Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
1462
      --  Recursively save value of this global, will be restored on exit
1463
 
1464
      Save_In_Deleted_Code : Boolean;
1465
 
1466
      Del : Boolean := False;
1467
      --  This flag gets set True if a True condition has been found, which
1468
      --  means that remaining ELSE/ELSIF parts are deleted.
1469
 
1470
      procedure Analyze_Cond_Then (Cnode : Node_Id);
1471
      --  This is applied to either the N_If_Statement node itself or to an
1472
      --  N_Elsif_Part node. It deals with analyzing the condition and the THEN
1473
      --  statements associated with it.
1474
 
1475
      -----------------------
1476
      -- Analyze_Cond_Then --
1477
      -----------------------
1478
 
1479
      procedure Analyze_Cond_Then (Cnode : Node_Id) is
1480
         Cond : constant Node_Id := Condition (Cnode);
1481
         Tstm : constant List_Id := Then_Statements (Cnode);
1482
 
1483
      begin
1484
         Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
1485
         Analyze_And_Resolve (Cond, Any_Boolean);
1486
         Check_Unset_Reference (Cond);
1487
         Set_Current_Value_Condition (Cnode);
1488
 
1489
         --  If already deleting, then just analyze then statements
1490
 
1491
         if Del then
1492
            Analyze_Statements (Tstm);
1493
 
1494
         --  Compile time known value, not deleting yet
1495
 
1496
         elsif Compile_Time_Known_Value (Cond) then
1497
            Save_In_Deleted_Code := In_Deleted_Code;
1498
 
1499
            --  If condition is True, then analyze the THEN statements and set
1500
            --  no expansion for ELSE and ELSIF parts.
1501
 
1502
            if Is_True (Expr_Value (Cond)) then
1503
               Analyze_Statements (Tstm);
1504
               Del := True;
1505
               Expander_Mode_Save_And_Set (False);
1506
               In_Deleted_Code := True;
1507
 
1508
            --  If condition is False, analyze THEN with expansion off
1509
 
1510
            else -- Is_False (Expr_Value (Cond))
1511
               Expander_Mode_Save_And_Set (False);
1512
               In_Deleted_Code := True;
1513
               Analyze_Statements (Tstm);
1514
               Expander_Mode_Restore;
1515
               In_Deleted_Code := Save_In_Deleted_Code;
1516
            end if;
1517
 
1518
         --  Not known at compile time, not deleting, normal analysis
1519
 
1520
         else
1521
            Analyze_Statements (Tstm);
1522
         end if;
1523
      end Analyze_Cond_Then;
1524
 
1525
   --  Start of Analyze_If_Statement
1526
 
1527
   begin
1528
      --  Initialize exit count for else statements. If there is no else part,
1529
      --  this count will stay non-zero reflecting the fact that the uncovered
1530
      --  else case is an unblocked exit.
1531
 
1532
      Unblocked_Exit_Count := 1;
1533
      Analyze_Cond_Then (N);
1534
 
1535
      --  Now to analyze the elsif parts if any are present
1536
 
1537
      if Present (Elsif_Parts (N)) then
1538
         E := First (Elsif_Parts (N));
1539
         while Present (E) loop
1540
            Analyze_Cond_Then (E);
1541
            Next (E);
1542
         end loop;
1543
      end if;
1544
 
1545
      if Present (Else_Statements (N)) then
1546
         Analyze_Statements (Else_Statements (N));
1547
      end if;
1548
 
1549
      --  If all our exits were blocked by unconditional transfers of control,
1550
      --  then the entire IF statement acts as an unconditional transfer of
1551
      --  control, so treat it like one, and check unreachable code.
1552
 
1553
      if Unblocked_Exit_Count = 0 then
1554
         Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1555
         Check_Unreachable_Code (N);
1556
      else
1557
         Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1558
      end if;
1559
 
1560
      if Del then
1561
         Expander_Mode_Restore;
1562
         In_Deleted_Code := Save_In_Deleted_Code;
1563
      end if;
1564
 
1565
      if not Expander_Active
1566
        and then Compile_Time_Known_Value (Condition (N))
1567
        and then Serious_Errors_Detected = 0
1568
      then
1569
         if Is_True (Expr_Value (Condition (N))) then
1570
            Remove_Warning_Messages (Else_Statements (N));
1571
 
1572
            if Present (Elsif_Parts (N)) then
1573
               E := First (Elsif_Parts (N));
1574
               while Present (E) loop
1575
                  Remove_Warning_Messages (Then_Statements (E));
1576
                  Next (E);
1577
               end loop;
1578
            end if;
1579
 
1580
         else
1581
            Remove_Warning_Messages (Then_Statements (N));
1582
         end if;
1583
      end if;
1584
   end Analyze_If_Statement;
1585
 
1586
   ----------------------------------------
1587
   -- Analyze_Implicit_Label_Declaration --
1588
   ----------------------------------------
1589
 
1590
   --  An implicit label declaration is generated in the innermost enclosing
1591
   --  declarative part. This is done for labels, and block and loop names.
1592
 
1593
   --  Note: any changes in this routine may need to be reflected in
1594
   --  Analyze_Label_Entity.
1595
 
1596
   procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is
1597
      Id : constant Node_Id := Defining_Identifier (N);
1598
   begin
1599
      Enter_Name          (Id);
1600
      Set_Ekind           (Id, E_Label);
1601
      Set_Etype           (Id, Standard_Void_Type);
1602
      Set_Enclosing_Scope (Id, Current_Scope);
1603
   end Analyze_Implicit_Label_Declaration;
1604
 
1605
   ------------------------------
1606
   -- Analyze_Iteration_Scheme --
1607
   ------------------------------
1608
 
1609
   procedure Analyze_Iteration_Scheme (N : Node_Id) is
1610
 
1611
      procedure Process_Bounds (R : Node_Id);
1612
      --  If the iteration is given by a range, create temporaries and
1613
      --  assignment statements block to capture the bounds and perform
1614
      --  required finalization actions in case a bound includes a function
1615
      --  call that uses the temporary stack. We first pre-analyze a copy of
1616
      --  the range in order to determine the expected type, and analyze and
1617
      --  resolve the original bounds.
1618
 
1619
      procedure Check_Controlled_Array_Attribute (DS : Node_Id);
1620
      --  If the bounds are given by a 'Range reference on a function call
1621
      --  that returns a controlled array, introduce an explicit declaration
1622
      --  to capture the bounds, so that the function result can be finalized
1623
      --  in timely fashion.
1624
 
1625
      function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean;
1626
      --  N is the node for an arbitrary construct. This function searches the
1627
      --  construct N to see if any expressions within it contain function
1628
      --  calls that use the secondary stack, returning True if any such call
1629
      --  is found, and False otherwise.
1630
 
1631
      --------------------
1632
      -- Process_Bounds --
1633
      --------------------
1634
 
1635
      procedure Process_Bounds (R : Node_Id) is
1636
         Loc          : constant Source_Ptr := Sloc (N);
1637
         R_Copy       : constant Node_Id := New_Copy_Tree (R);
1638
         Lo           : constant Node_Id := Low_Bound  (R);
1639
         Hi           : constant Node_Id := High_Bound (R);
1640
         New_Lo_Bound : Node_Id;
1641
         New_Hi_Bound : Node_Id;
1642
         Typ          : Entity_Id;
1643
 
1644
         function One_Bound
1645
           (Original_Bound : Node_Id;
1646
            Analyzed_Bound : Node_Id) return Node_Id;
1647
         --  Capture value of bound and return captured value
1648
 
1649
         ---------------
1650
         -- One_Bound --
1651
         ---------------
1652
 
1653
         function One_Bound
1654
           (Original_Bound : Node_Id;
1655
            Analyzed_Bound : Node_Id) return Node_Id
1656
         is
1657
            Assign : Node_Id;
1658
            Id     : Entity_Id;
1659
            Decl   : Node_Id;
1660
 
1661
         begin
1662
            --  If the bound is a constant or an object, no need for a separate
1663
            --  declaration. If the bound is the result of previous expansion
1664
            --  it is already analyzed and should not be modified. Note that
1665
            --  the Bound will be resolved later, if needed, as part of the
1666
            --  call to Make_Index (literal bounds may need to be resolved to
1667
            --  type Integer).
1668
 
1669
            if Analyzed (Original_Bound) then
1670
               return Original_Bound;
1671
 
1672
            elsif Nkind_In (Analyzed_Bound, N_Integer_Literal,
1673
                                            N_Character_Literal)
1674
              or else Is_Entity_Name (Analyzed_Bound)
1675
            then
1676
               Analyze_And_Resolve (Original_Bound, Typ);
1677
               return Original_Bound;
1678
            end if;
1679
 
1680
            --  Here we need to capture the value
1681
 
1682
            Analyze_And_Resolve (Original_Bound, Typ);
1683
 
1684
            --  Normally, the best approach is simply to generate a constant
1685
            --  declaration that captures the bound. However, there is a nasty
1686
            --  case where this is wrong. If the bound is complex, and has a
1687
            --  possible use of the secondary stack, we need to generate a
1688
            --  separate assignment statement to ensure the creation of a block
1689
            --  which will release the secondary stack.
1690
 
1691
            --  We prefer the constant declaration, since it leaves us with a
1692
            --  proper trace of the value, useful in optimizations that get rid
1693
            --  of junk range checks.
1694
 
1695
            if not Has_Call_Using_Secondary_Stack (Original_Bound) then
1696
               Force_Evaluation (Original_Bound);
1697
               return Original_Bound;
1698
            end if;
1699
 
1700
            Id := Make_Temporary (Loc, 'R', Original_Bound);
1701
 
1702
            --  Here we make a declaration with a separate assignment
1703
            --  statement, and insert before loop header.
1704
 
1705
            Decl :=
1706
              Make_Object_Declaration (Loc,
1707
                Defining_Identifier => Id,
1708
                Object_Definition   => New_Occurrence_Of (Typ, Loc));
1709
 
1710
            Assign :=
1711
              Make_Assignment_Statement (Loc,
1712
                Name        => New_Occurrence_Of (Id, Loc),
1713
                Expression  => Relocate_Node (Original_Bound));
1714
 
1715
            --  We must recursively clean in the relocated expression the flag
1716
            --  analyzed to ensure that the expression is reanalyzed. Required
1717
            --  to ensure that the transient scope is established now (because
1718
            --  Establish_Transient_Scope discarded generating transient scopes
1719
            --  in the analysis of the iteration scheme).
1720
 
1721
            Reset_Analyzed_Flags (Expression (Assign));
1722
 
1723
            Insert_Actions (Parent (N), New_List (Decl, Assign));
1724
 
1725
            --  Now that this temporary variable is initialized we decorate it
1726
            --  as safe-to-reevaluate to inform to the backend that no further
1727
            --  asignment will be issued and hence it can be handled as side
1728
            --  effect free. Note that this decoration must be done when the
1729
            --  assignment has been analyzed because otherwise it will be
1730
            --  rejected (see Analyze_Assignment).
1731
 
1732
            Set_Is_Safe_To_Reevaluate (Id);
1733
 
1734
            Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
1735
 
1736
            if Nkind (Assign) = N_Assignment_Statement then
1737
               return Expression (Assign);
1738
            else
1739
               return Original_Bound;
1740
            end if;
1741
         end One_Bound;
1742
 
1743
      --  Start of processing for Process_Bounds
1744
 
1745
      begin
1746
         Set_Parent (R_Copy, Parent (R));
1747
         Pre_Analyze_Range (R_Copy);
1748
         Typ := Etype (R_Copy);
1749
 
1750
         --  If the type of the discrete range is Universal_Integer, then the
1751
         --  bound's type must be resolved to Integer, and any object used to
1752
         --  hold the bound must also have type Integer, unless the literal
1753
         --  bounds are constant-folded expressions with a user-defined type.
1754
 
1755
         if Typ = Universal_Integer then
1756
            if Nkind (Lo) = N_Integer_Literal
1757
              and then Present (Etype (Lo))
1758
              and then Scope (Etype (Lo)) /= Standard_Standard
1759
            then
1760
               Typ := Etype (Lo);
1761
 
1762
            elsif Nkind (Hi) = N_Integer_Literal
1763
              and then Present (Etype (Hi))
1764
              and then Scope (Etype (Hi)) /= Standard_Standard
1765
            then
1766
               Typ := Etype (Hi);
1767
 
1768
            else
1769
               Typ := Standard_Integer;
1770
            end if;
1771
         end if;
1772
 
1773
         Set_Etype (R, Typ);
1774
 
1775
         New_Lo_Bound := One_Bound (Lo, Low_Bound  (R_Copy));
1776
         New_Hi_Bound := One_Bound (Hi, High_Bound (R_Copy));
1777
 
1778
         --  Propagate staticness to loop range itself, in case the
1779
         --  corresponding subtype is static.
1780
 
1781
         if New_Lo_Bound /= Lo
1782
           and then Is_Static_Expression (New_Lo_Bound)
1783
         then
1784
            Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound));
1785
         end if;
1786
 
1787
         if New_Hi_Bound /= Hi
1788
           and then Is_Static_Expression (New_Hi_Bound)
1789
         then
1790
            Rewrite (High_Bound (R), New_Copy (New_Hi_Bound));
1791
         end if;
1792
      end Process_Bounds;
1793
 
1794
      --------------------------------------
1795
      -- Check_Controlled_Array_Attribute --
1796
      --------------------------------------
1797
 
1798
      procedure Check_Controlled_Array_Attribute (DS : Node_Id) is
1799
      begin
1800
         if Nkind (DS) = N_Attribute_Reference
1801
            and then Is_Entity_Name (Prefix (DS))
1802
            and then Ekind (Entity (Prefix (DS))) = E_Function
1803
            and then Is_Array_Type (Etype (Entity (Prefix (DS))))
1804
            and then
1805
              Is_Controlled (
1806
                Component_Type (Etype (Entity (Prefix (DS)))))
1807
            and then Expander_Active
1808
         then
1809
            declare
1810
               Loc  : constant Source_Ptr := Sloc (N);
1811
               Arr  : constant Entity_Id := Etype (Entity (Prefix (DS)));
1812
               Indx : constant Entity_Id :=
1813
                        Base_Type (Etype (First_Index (Arr)));
1814
               Subt : constant Entity_Id := Make_Temporary (Loc, 'S');
1815
               Decl : Node_Id;
1816
 
1817
            begin
1818
               Decl :=
1819
                 Make_Subtype_Declaration (Loc,
1820
                   Defining_Identifier => Subt,
1821
                   Subtype_Indication  =>
1822
                      Make_Subtype_Indication (Loc,
1823
                        Subtype_Mark  => New_Reference_To (Indx, Loc),
1824
                        Constraint =>
1825
                          Make_Range_Constraint (Loc,
1826
                            Relocate_Node (DS))));
1827
               Insert_Before (Parent (N), Decl);
1828
               Analyze (Decl);
1829
 
1830
               Rewrite (DS,
1831
                  Make_Attribute_Reference (Loc,
1832
                    Prefix => New_Reference_To (Subt, Loc),
1833
                    Attribute_Name => Attribute_Name (DS)));
1834
               Analyze (DS);
1835
            end;
1836
         end if;
1837
      end Check_Controlled_Array_Attribute;
1838
 
1839
      ------------------------------------
1840
      -- Has_Call_Using_Secondary_Stack --
1841
      ------------------------------------
1842
 
1843
      function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is
1844
 
1845
         function Check_Call (N : Node_Id) return Traverse_Result;
1846
         --  Check if N is a function call which uses the secondary stack
1847
 
1848
         ----------------
1849
         -- Check_Call --
1850
         ----------------
1851
 
1852
         function Check_Call (N : Node_Id) return Traverse_Result is
1853
            Nam        : Node_Id;
1854
            Subp       : Entity_Id;
1855
            Return_Typ : Entity_Id;
1856
 
1857
         begin
1858
            if Nkind (N) = N_Function_Call then
1859
               Nam := Name (N);
1860
 
1861
               --  Call using access to subprogram with explicit dereference
1862
 
1863
               if Nkind (Nam) = N_Explicit_Dereference then
1864
                  Subp := Etype (Nam);
1865
 
1866
               --  Normal case
1867
 
1868
               else
1869
                  Subp := Entity (Nam);
1870
               end if;
1871
 
1872
               Return_Typ := Etype (Subp);
1873
 
1874
               if Is_Composite_Type (Return_Typ)
1875
                 and then not Is_Constrained (Return_Typ)
1876
               then
1877
                  return Abandon;
1878
 
1879
               elsif Sec_Stack_Needed_For_Return (Subp) then
1880
                  return Abandon;
1881
               end if;
1882
            end if;
1883
 
1884
            --  Continue traversing the tree
1885
 
1886
            return OK;
1887
         end Check_Call;
1888
 
1889
         function Check_Calls is new Traverse_Func (Check_Call);
1890
 
1891
      --  Start of processing for Has_Call_Using_Secondary_Stack
1892
 
1893
      begin
1894
         return Check_Calls (N) = Abandon;
1895
      end Has_Call_Using_Secondary_Stack;
1896
 
1897
   --  Start of processing for Analyze_Iteration_Scheme
1898
 
1899
   begin
1900
      --  If this is a rewritten quantified expression, the iteration scheme
1901
      --  has been analyzed already. Do no repeat analysis because the loop
1902
      --  variable is already declared.
1903
 
1904
      if Analyzed (N) then
1905
         return;
1906
      end if;
1907
 
1908
      --  For an infinite loop, there is no iteration scheme
1909
 
1910
      if No (N) then
1911
         return;
1912
      end if;
1913
 
1914
      --  Iteration scheme is present
1915
 
1916
      declare
1917
         Cond : constant Node_Id := Condition (N);
1918
 
1919
      begin
1920
         --  For WHILE loop, verify that the condition is a Boolean expression
1921
         --  and resolve and check it.
1922
 
1923
         if Present (Cond) then
1924
            Analyze_And_Resolve (Cond, Any_Boolean);
1925
            Check_Unset_Reference (Cond);
1926
            Set_Current_Value_Condition (N);
1927
            return;
1928
 
1929
         --  For an iterator specification with "of", pre-analyze range to
1930
         --  capture function calls that may require finalization actions.
1931
 
1932
         elsif Present (Iterator_Specification (N)) then
1933
            Pre_Analyze_Range (Name (Iterator_Specification (N)));
1934
            Analyze_Iterator_Specification (Iterator_Specification (N));
1935
 
1936
         --  Else we have a FOR loop
1937
 
1938
         else
1939
            declare
1940
               LP : constant Node_Id   := Loop_Parameter_Specification (N);
1941
               Id : constant Entity_Id := Defining_Identifier (LP);
1942
               DS : constant Node_Id   := Discrete_Subtype_Definition (LP);
1943
 
1944
               D_Copy : Node_Id;
1945
 
1946
            begin
1947
               Enter_Name (Id);
1948
 
1949
               --  We always consider the loop variable to be referenced, since
1950
               --  the loop may be used just for counting purposes.
1951
 
1952
               Generate_Reference (Id, N, ' ');
1953
 
1954
               --  Check for the case of loop variable hiding a local variable
1955
               --  (used later on to give a nice warning if the hidden variable
1956
               --  is never assigned).
1957
 
1958
               declare
1959
                  H : constant Entity_Id := Homonym (Id);
1960
               begin
1961
                  if Present (H)
1962
                    and then Enclosing_Dynamic_Scope (H) =
1963
                               Enclosing_Dynamic_Scope (Id)
1964
                    and then Ekind (H) = E_Variable
1965
                    and then Is_Discrete_Type (Etype (H))
1966
                  then
1967
                     Set_Hiding_Loop_Variable (H, Id);
1968
                  end if;
1969
               end;
1970
 
1971
               --  Loop parameter specification must include subtype mark in
1972
               --  SPARK.
1973
 
1974
               if Nkind (DS) = N_Range then
1975
                  Check_SPARK_Restriction
1976
                    ("loop parameter specification must include subtype mark",
1977
                     N);
1978
               end if;
1979
 
1980
               --  Now analyze the subtype definition. If it is a range, create
1981
               --  temporaries for bounds.
1982
 
1983
               if Nkind (DS) = N_Range
1984
                 and then Expander_Active
1985
               then
1986
                  Process_Bounds (DS);
1987
 
1988
               --  Expander not active or else range of iteration is a subtype
1989
               --  indication, an entity, or a function call that yields an
1990
               --  aggregate or a container.
1991
 
1992
               else
1993
                  D_Copy := New_Copy_Tree (DS);
1994
                  Set_Parent (D_Copy, Parent (DS));
1995
                  Pre_Analyze_Range (D_Copy);
1996
 
1997
                  --  Ada 2012: If the domain of iteration is a function call,
1998
                  --  it is the new iterator form.
1999
 
2000
                  --  We have also implemented the shorter form : for X in S
2001
                  --  for Alfa use. In this case, 'Old and 'Result must be
2002
                  --  treated as entity names over which iterators are legal.
2003
 
2004
                  if Nkind (D_Copy) = N_Function_Call
2005
                    or else
2006
                      (Alfa_Mode
2007
                        and then (Nkind (D_Copy) = N_Attribute_Reference
2008
                        and then
2009
                          (Attribute_Name (D_Copy) = Name_Result
2010
                            or else Attribute_Name (D_Copy) = Name_Old)))
2011
                    or else
2012
                      (Is_Entity_Name (D_Copy)
2013
                        and then not Is_Type (Entity (D_Copy)))
2014
                  then
2015
                     --  This is an iterator specification. Rewrite as such
2016
                     --  and analyze, to capture function calls that may
2017
                     --  require finalization actions.
2018
 
2019
                     declare
2020
                        I_Spec : constant Node_Id :=
2021
                                   Make_Iterator_Specification (Sloc (LP),
2022
                                     Defining_Identifier =>
2023
                                       Relocate_Node (Id),
2024
                                     Name                => D_Copy,
2025
                                     Subtype_Indication  => Empty,
2026
                                     Reverse_Present     =>
2027
                                       Reverse_Present (LP));
2028
                     begin
2029
                        Set_Iterator_Specification (N, I_Spec);
2030
                        Set_Loop_Parameter_Specification (N, Empty);
2031
                        Analyze_Iterator_Specification (I_Spec);
2032
 
2033
                        --  In a generic context, analyze the original domain
2034
                        --  of iteration, for name capture.
2035
 
2036
                        if not Expander_Active then
2037
                           Analyze (DS);
2038
                        end if;
2039
 
2040
                        --  Set kind of loop parameter, which may be used in
2041
                        --  the subsequent analysis of the condition in a
2042
                        --  quantified expression.
2043
 
2044
                        Set_Ekind (Id, E_Loop_Parameter);
2045
                        return;
2046
                     end;
2047
 
2048
                  --  Domain of iteration is not a function call, and is
2049
                  --  side-effect free.
2050
 
2051
                  else
2052
                     Analyze (DS);
2053
                  end if;
2054
               end if;
2055
 
2056
               if DS = Error then
2057
                  return;
2058
               end if;
2059
 
2060
               --  Some additional checks if we are iterating through a type
2061
 
2062
               if Is_Entity_Name (DS)
2063
                 and then Present (Entity (DS))
2064
                 and then Is_Type (Entity (DS))
2065
               then
2066
                  --  The subtype indication may denote the completion of an
2067
                  --  incomplete type declaration.
2068
 
2069
                  if Ekind (Entity (DS)) = E_Incomplete_Type then
2070
                     Set_Entity (DS, Get_Full_View (Entity (DS)));
2071
                     Set_Etype  (DS, Entity (DS));
2072
                  end if;
2073
 
2074
                  --  Attempt to iterate through non-static predicate
2075
 
2076
                  if Is_Discrete_Type (Entity (DS))
2077
                    and then Present (Predicate_Function (Entity (DS)))
2078
                    and then No (Static_Predicate (Entity (DS)))
2079
                  then
2080
                     Bad_Predicated_Subtype_Use
2081
                       ("cannot use subtype& with non-static "
2082
                        & "predicate for loop iteration", DS, Entity (DS));
2083
                  end if;
2084
               end if;
2085
 
2086
               --  Error if not discrete type
2087
 
2088
               if not Is_Discrete_Type (Etype (DS)) then
2089
                  Wrong_Type (DS, Any_Discrete);
2090
                  Set_Etype (DS, Any_Type);
2091
               end if;
2092
 
2093
               Check_Controlled_Array_Attribute (DS);
2094
 
2095
               Make_Index (DS, LP, In_Iter_Schm => True);
2096
 
2097
               Set_Ekind (Id, E_Loop_Parameter);
2098
 
2099
               --  If the loop is part of a predicate or precondition, it may
2100
               --  be analyzed twice, once in the source and once on the copy
2101
               --  used to check conformance. Preserve the original itype
2102
               --  because the second one may be created in a different scope,
2103
               --  e.g. a precondition procedure, leading to a crash in GIGI.
2104
 
2105
               if No (Etype (Id)) or else Etype (Id) = Any_Type then
2106
                  Set_Etype (Id, Etype (DS));
2107
               end if;
2108
 
2109
               --  Treat a range as an implicit reference to the type, to
2110
               --  inhibit spurious warnings.
2111
 
2112
               Generate_Reference (Base_Type (Etype (DS)), N, ' ');
2113
               Set_Is_Known_Valid (Id, True);
2114
 
2115
               --  The loop is not a declarative part, so the only entity
2116
               --  declared "within" must be frozen explicitly.
2117
 
2118
               declare
2119
                  Flist : constant List_Id := Freeze_Entity (Id, N);
2120
               begin
2121
                  if Is_Non_Empty_List (Flist) then
2122
                     Insert_Actions (N, Flist);
2123
                  end if;
2124
               end;
2125
 
2126
               --  Check for null or possibly null range and issue warning. We
2127
               --  suppress such messages in generic templates and instances,
2128
               --  because in practice they tend to be dubious in these cases.
2129
 
2130
               if Nkind (DS) = N_Range and then Comes_From_Source (N) then
2131
                  declare
2132
                     L : constant Node_Id := Low_Bound  (DS);
2133
                     H : constant Node_Id := High_Bound (DS);
2134
 
2135
                  begin
2136
                     --  If range of loop is null, issue warning
2137
 
2138
                     if Compile_Time_Compare
2139
                          (L, H, Assume_Valid => True) = GT
2140
                     then
2141
                        --  Suppress the warning if inside a generic template
2142
                        --  or instance, since in practice they tend to be
2143
                        --  dubious in these cases since they can result from
2144
                        --  intended parametrization.
2145
 
2146
                        if not Inside_A_Generic
2147
                          and then not In_Instance
2148
                        then
2149
                           --  Specialize msg if invalid values could make the
2150
                           --  loop non-null after all.
2151
 
2152
                           if Compile_Time_Compare
2153
                                (L, H, Assume_Valid => False) = GT
2154
                           then
2155
                              Error_Msg_N
2156
                                ("?loop range is null, loop will not execute",
2157
                                 DS);
2158
 
2159
                              --  Since we know the range of the loop is null,
2160
                              --  set the appropriate flag to remove the loop
2161
                              --  entirely during expansion.
2162
 
2163
                              Set_Is_Null_Loop (Parent (N));
2164
 
2165
                              --  Here is where the loop could execute because
2166
                              --  of invalid values, so issue appropriate
2167
                              --  message and in this case we do not set the
2168
                              --  Is_Null_Loop flag since the loop may execute.
2169
 
2170
                           else
2171
                              Error_Msg_N
2172
                                ("?loop range may be null, "
2173
                                 & "loop may not execute",
2174
                                 DS);
2175
                              Error_Msg_N
2176
                                ("?can only execute if invalid values "
2177
                                 & "are present",
2178
                                 DS);
2179
                           end if;
2180
                        end if;
2181
 
2182
                        --  In either case, suppress warnings in the body of
2183
                        --  the loop, since it is likely that these warnings
2184
                        --  will be inappropriate if the loop never actually
2185
                        --  executes, which is likely.
2186
 
2187
                        Set_Suppress_Loop_Warnings (Parent (N));
2188
 
2189
                        --  The other case for a warning is a reverse loop
2190
                        --  where the upper bound is the integer literal zero
2191
                        --  or one, and the lower bound can be positive.
2192
 
2193
                        --  For example, we have
2194
 
2195
                        --     for J in reverse N .. 1 loop
2196
 
2197
                        --  In practice, this is very likely to be a case of
2198
                        --  reversing the bounds incorrectly in the range.
2199
 
2200
                     elsif Reverse_Present (LP)
2201
                       and then Nkind (Original_Node (H)) =
2202
                                                      N_Integer_Literal
2203
                       and then (Intval (Original_Node (H)) = Uint_0
2204
                                  or else
2205
                                    Intval (Original_Node (H)) = Uint_1)
2206
                     then
2207
                        Error_Msg_N ("?loop range may be null", DS);
2208
                        Error_Msg_N ("\?bounds may be wrong way round", DS);
2209
                     end if;
2210
                  end;
2211
               end if;
2212
            end;
2213
         end if;
2214
      end;
2215
   end Analyze_Iteration_Scheme;
2216
 
2217
   -------------------------------------
2218
   --  Analyze_Iterator_Specification --
2219
   -------------------------------------
2220
 
2221
   procedure Analyze_Iterator_Specification (N : Node_Id) is
2222
      Loc       : constant Source_Ptr := Sloc (N);
2223
      Def_Id    : constant Node_Id    := Defining_Identifier (N);
2224
      Subt      : constant Node_Id    := Subtype_Indication (N);
2225
      Iter_Name : constant Node_Id    := Name (N);
2226
 
2227
      Ent : Entity_Id;
2228
      Typ : Entity_Id;
2229
 
2230
   begin
2231
      --  In semantics/Alfa modes, we won't be further expanding the loop, so
2232
      --  introduce loop variable so that loop body can be properly analyzed.
2233
      --  Otherwise this happens after expansion.
2234
 
2235
      if Operating_Mode = Check_Semantics
2236
        or else Alfa_Mode
2237
      then
2238
         Enter_Name (Def_Id);
2239
      end if;
2240
 
2241
      Set_Ekind (Def_Id, E_Variable);
2242
 
2243
      if Present (Subt) then
2244
         Analyze (Subt);
2245
      end if;
2246
 
2247
      --  If domain of iteration is an expression, create a declaration for
2248
      --  it, so that finalization actions are introduced outside of the loop.
2249
      --  The declaration must be a renaming because the body of the loop may
2250
      --  assign to elements.
2251
 
2252
      if not Is_Entity_Name (Iter_Name) then
2253
         declare
2254
            Id   : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name);
2255
            Decl : Node_Id;
2256
 
2257
         begin
2258
            Typ := Etype (Iter_Name);
2259
 
2260
            --  The name in the renaming declaration may be a function call.
2261
            --  Indicate that it does not come from source, to suppress
2262
            --  spurious warnings on renamings of parameterless functions,
2263
            --  a common enough idiom in user-defined iterators.
2264
 
2265
            Decl :=
2266
              Make_Object_Renaming_Declaration (Loc,
2267
                Defining_Identifier => Id,
2268
                Subtype_Mark        => New_Occurrence_Of (Typ, Loc),
2269
                Name                =>
2270
                  New_Copy_Tree (Iter_Name, New_Sloc => Loc));
2271
 
2272
            Insert_Actions (Parent (Parent (N)), New_List (Decl));
2273
            Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
2274
            Set_Etype (Id, Typ);
2275
            Set_Etype (Name (N), Typ);
2276
         end;
2277
 
2278
      --  Container is an entity or an array with uncontrolled components, or
2279
      --  else it is a container iterator given by a function call, typically
2280
      --  called Iterate in the case of predefined containers, even though
2281
      --  Iterate is not a reserved name. What matter is that the return type
2282
      --  of the function is an iterator type.
2283
 
2284
      else
2285
         Analyze (Iter_Name);
2286
 
2287
         if Nkind (Iter_Name) = N_Function_Call then
2288
            declare
2289
               C  : constant Node_Id := Name (Iter_Name);
2290
               I  : Interp_Index;
2291
               It : Interp;
2292
 
2293
            begin
2294
               if not Is_Overloaded (Iter_Name) then
2295
                  Resolve (Iter_Name, Etype (C));
2296
 
2297
               else
2298
                  Get_First_Interp (C, I, It);
2299
                  while It.Typ /= Empty loop
2300
                     if Reverse_Present (N) then
2301
                        if Is_Reversible_Iterator (It.Typ) then
2302
                           Resolve (Iter_Name, It.Typ);
2303
                           exit;
2304
                        end if;
2305
 
2306
                     elsif Is_Iterator (It.Typ) then
2307
                        Resolve (Iter_Name, It.Typ);
2308
                        exit;
2309
                     end if;
2310
 
2311
                     Get_Next_Interp (I, It);
2312
                  end loop;
2313
               end if;
2314
            end;
2315
 
2316
         --  Domain of iteration is not overloaded
2317
 
2318
         else
2319
            Resolve (Iter_Name, Etype (Iter_Name));
2320
         end if;
2321
      end if;
2322
 
2323
      Typ := Etype (Iter_Name);
2324
 
2325
      if Is_Array_Type (Typ) then
2326
         if Of_Present (N) then
2327
            Set_Etype (Def_Id, Component_Type (Typ));
2328
 
2329
         --  Here we have a missing Range attribute
2330
 
2331
         else
2332
            Error_Msg_N
2333
              ("missing Range attribute in iteration over an array", N);
2334
 
2335
            --  In Ada 2012 mode, this may be an attempt at an iterator
2336
 
2337
            if Ada_Version >= Ada_2012 then
2338
               Error_Msg_NE
2339
                 ("\if& is meant to designate an element of the array, use OF",
2340
                    N, Def_Id);
2341
            end if;
2342
 
2343
            --  Prevent cascaded errors
2344
 
2345
            Set_Ekind (Def_Id, E_Loop_Parameter);
2346
            Set_Etype (Def_Id, Etype (First_Index (Typ)));
2347
         end if;
2348
 
2349
         --  Check for type error in iterator
2350
 
2351
      elsif Typ = Any_Type then
2352
         return;
2353
 
2354
      --  Iteration over a container
2355
 
2356
      else
2357
         Set_Ekind (Def_Id, E_Loop_Parameter);
2358
 
2359
         if Of_Present (N) then
2360
 
2361
            --  The type of the loop variable is the Iterator_Element aspect of
2362
            --  the container type.
2363
 
2364
            declare
2365
               Element : constant Entity_Id :=
2366
                           Find_Aspect (Typ, Aspect_Iterator_Element);
2367
            begin
2368
               if No (Element) then
2369
                  Error_Msg_NE ("cannot iterate over&", N, Typ);
2370
                  return;
2371
               else
2372
                  Set_Etype (Def_Id, Entity (Element));
2373
               end if;
2374
            end;
2375
 
2376
         else
2377
            --  For an iteration of the form IN, the name must denote an
2378
            --  iterator, typically the result of a call to Iterate. Give a
2379
            --  useful error message when the name is a container by itself.
2380
 
2381
            if Is_Entity_Name (Original_Node (Name (N)))
2382
              and then not Is_Iterator (Typ)
2383
            then
2384
               if No (Find_Aspect (Typ, Aspect_Iterator_Element)) then
2385
                  Error_Msg_NE
2386
                    ("cannot iterate over&", Name (N), Typ);
2387
               else
2388
                  Error_Msg_N
2389
                    ("name must be an iterator, not a container", Name (N));
2390
               end if;
2391
 
2392
               Error_Msg_NE
2393
                 ("\to iterate directly over the elements of a container, " &
2394
                   "write `of &`", Name (N), Original_Node (Name (N)));
2395
            end if;
2396
 
2397
            --  The result type of Iterate function is the classwide type of
2398
            --  the interface parent. We need the specific Cursor type defined
2399
            --  in the container package.
2400
 
2401
            Ent := First_Entity (Scope (Typ));
2402
            while Present (Ent) loop
2403
               if Chars (Ent) = Name_Cursor then
2404
                  Set_Etype (Def_Id, Etype (Ent));
2405
                  exit;
2406
               end if;
2407
 
2408
               Next_Entity (Ent);
2409
            end loop;
2410
         end if;
2411
      end if;
2412
   end Analyze_Iterator_Specification;
2413
 
2414
   -------------------
2415
   -- Analyze_Label --
2416
   -------------------
2417
 
2418
   --  Note: the semantic work required for analyzing labels (setting them as
2419
   --  reachable) was done in a prepass through the statements in the block,
2420
   --  so that forward gotos would be properly handled. See Analyze_Statements
2421
   --  for further details. The only processing required here is to deal with
2422
   --  optimizations that depend on an assumption of sequential control flow,
2423
   --  since of course the occurrence of a label breaks this assumption.
2424
 
2425
   procedure Analyze_Label (N : Node_Id) is
2426
      pragma Warnings (Off, N);
2427
   begin
2428
      Kill_Current_Values;
2429
   end Analyze_Label;
2430
 
2431
   --------------------------
2432
   -- Analyze_Label_Entity --
2433
   --------------------------
2434
 
2435
   procedure Analyze_Label_Entity (E : Entity_Id) is
2436
   begin
2437
      Set_Ekind           (E, E_Label);
2438
      Set_Etype           (E, Standard_Void_Type);
2439
      Set_Enclosing_Scope (E, Current_Scope);
2440
      Set_Reachable       (E, True);
2441
   end Analyze_Label_Entity;
2442
 
2443
   ----------------------------
2444
   -- Analyze_Loop_Statement --
2445
   ----------------------------
2446
 
2447
   procedure Analyze_Loop_Statement (N : Node_Id) is
2448
 
2449
      function Is_Container_Iterator (Iter : Node_Id) return Boolean;
2450
      --  Given a loop iteration scheme, determine whether it is an Ada 2012
2451
      --  container iteration.
2452
 
2453
      function Is_Wrapped_In_Block (N : Node_Id) return Boolean;
2454
      --  Determine whether node N is the sole statement of a block
2455
 
2456
      ---------------------------
2457
      -- Is_Container_Iterator --
2458
      ---------------------------
2459
 
2460
      function Is_Container_Iterator (Iter : Node_Id) return Boolean is
2461
      begin
2462
         --  Infinite loop
2463
 
2464
         if No (Iter) then
2465
            return False;
2466
 
2467
         --  While loop
2468
 
2469
         elsif Present (Condition (Iter)) then
2470
            return False;
2471
 
2472
         --  for Def_Id in [reverse] Name loop
2473
         --  for Def_Id [: Subtype_Indication] of [reverse] Name loop
2474
 
2475
         elsif Present (Iterator_Specification (Iter)) then
2476
            declare
2477
               Nam : constant Node_Id := Name (Iterator_Specification (Iter));
2478
               Nam_Copy : Node_Id;
2479
 
2480
            begin
2481
               Nam_Copy := New_Copy_Tree (Nam);
2482
               Set_Parent (Nam_Copy, Parent (Nam));
2483
               Pre_Analyze_Range (Nam_Copy);
2484
 
2485
               --  The only two options here are iteration over a container or
2486
               --  an array.
2487
 
2488
               return not Is_Array_Type (Etype (Nam_Copy));
2489
            end;
2490
 
2491
         --  for Def_Id in [reverse] Discrete_Subtype_Definition loop
2492
 
2493
         else
2494
            declare
2495
               LP : constant Node_Id := Loop_Parameter_Specification (Iter);
2496
               DS : constant Node_Id := Discrete_Subtype_Definition (LP);
2497
               DS_Copy : Node_Id;
2498
 
2499
            begin
2500
               DS_Copy := New_Copy_Tree (DS);
2501
               Set_Parent (DS_Copy, Parent (DS));
2502
               Pre_Analyze_Range (DS_Copy);
2503
 
2504
               --  Check for a call to Iterate ()
2505
 
2506
               return
2507
                 Nkind (DS_Copy) = N_Function_Call
2508
                   and then Needs_Finalization (Etype (DS_Copy));
2509
            end;
2510
         end if;
2511
      end Is_Container_Iterator;
2512
 
2513
      -------------------------
2514
      -- Is_Wrapped_In_Block --
2515
      -------------------------
2516
 
2517
      function Is_Wrapped_In_Block (N : Node_Id) return Boolean is
2518
         HSS : constant Node_Id := Parent (N);
2519
 
2520
      begin
2521
         return
2522
           Nkind (HSS) = N_Handled_Sequence_Of_Statements
2523
             and then Nkind (Parent (HSS)) = N_Block_Statement
2524
             and then First (Statements (HSS)) = N
2525
             and then No (Next (First (Statements (HSS))));
2526
      end Is_Wrapped_In_Block;
2527
 
2528
      --  Local declarations
2529
 
2530
      Id   : constant Node_Id := Identifier (N);
2531
      Iter : constant Node_Id := Iteration_Scheme (N);
2532
      Loc  : constant Source_Ptr := Sloc (N);
2533
      Ent  : Entity_Id;
2534
 
2535
   --  Start of processing for Analyze_Loop_Statement
2536
 
2537
   begin
2538
      if Present (Id) then
2539
 
2540
         --  Make name visible, e.g. for use in exit statements. Loop labels
2541
         --  are always considered to be referenced.
2542
 
2543
         Analyze (Id);
2544
         Ent := Entity (Id);
2545
 
2546
         --  Guard against serious error (typically, a scope mismatch when
2547
         --  semantic analysis is requested) by creating loop entity to
2548
         --  continue analysis.
2549
 
2550
         if No (Ent) then
2551
            if Total_Errors_Detected /= 0 then
2552
               Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L');
2553
            else
2554
               raise Program_Error;
2555
            end if;
2556
 
2557
         else
2558
            Generate_Reference (Ent, N, ' ');
2559
            Generate_Definition (Ent);
2560
 
2561
            --  If we found a label, mark its type. If not, ignore it, since it
2562
            --  means we have a conflicting declaration, which would already
2563
            --  have been diagnosed at declaration time. Set Label_Construct
2564
            --  of the implicit label declaration, which is not created by the
2565
            --  parser for generic units.
2566
 
2567
            if Ekind (Ent) = E_Label then
2568
               Set_Ekind (Ent, E_Loop);
2569
 
2570
               if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
2571
                  Set_Label_Construct (Parent (Ent), N);
2572
               end if;
2573
            end if;
2574
         end if;
2575
 
2576
      --  Case of no identifier present
2577
 
2578
      else
2579
         Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L');
2580
         Set_Etype  (Ent, Standard_Void_Type);
2581
         Set_Parent (Ent, N);
2582
      end if;
2583
 
2584
      --  Iteration over a container in Ada 2012 involves the creation of a
2585
      --  controlled iterator object. Wrap the loop in a block to ensure the
2586
      --  timely finalization of the iterator and release of container locks.
2587
 
2588
      if Ada_Version >= Ada_2012
2589
        and then Is_Container_Iterator (Iter)
2590
        and then not Is_Wrapped_In_Block (N)
2591
      then
2592
         Rewrite (N,
2593
           Make_Block_Statement (Loc,
2594
             Declarations               => New_List,
2595
             Handled_Statement_Sequence =>
2596
               Make_Handled_Sequence_Of_Statements (Loc,
2597
                 Statements => New_List (Relocate_Node (N)))));
2598
 
2599
         Analyze (N);
2600
         return;
2601
      end if;
2602
 
2603
      --  Kill current values on entry to loop, since statements in the body of
2604
      --  the loop may have been executed before the loop is entered. Similarly
2605
      --  we kill values after the loop, since we do not know that the body of
2606
      --  the loop was executed.
2607
 
2608
      Kill_Current_Values;
2609
      Push_Scope (Ent);
2610
      Analyze_Iteration_Scheme (Iter);
2611
 
2612
      --  Analyze the statements of the body except in the case of an Ada 2012
2613
      --  iterator with the expander active. In this case the expander will do
2614
      --  a rewrite of the loop into a while loop. We will then analyze the
2615
      --  loop body when we analyze this while loop.
2616
 
2617
      --  We need to do this delay because if the container is for indefinite
2618
      --  types the actual subtype of the components will only be determined
2619
      --  when the cursor declaration is analyzed.
2620
 
2621
      --  If the expander is not active, then we want to analyze the loop body
2622
      --  now even in the Ada 2012 iterator case, since the rewriting will not
2623
      --  be done. Insert the loop variable in the current scope, if not done
2624
      --  when analysing the iteration scheme.
2625
 
2626
      if No (Iter)
2627
        or else No (Iterator_Specification (Iter))
2628
        or else not Expander_Active
2629
      then
2630
         if Present (Iter)
2631
           and then Present (Iterator_Specification (Iter))
2632
         then
2633
            declare
2634
               Id : constant Entity_Id :=
2635
                      Defining_Identifier (Iterator_Specification (Iter));
2636
            begin
2637
               if Scope (Id) /= Current_Scope then
2638
                  Enter_Name (Id);
2639
               end if;
2640
            end;
2641
         end if;
2642
 
2643
         Analyze_Statements (Statements (N));
2644
      end if;
2645
 
2646
      --  Finish up processing for the loop. We kill all current values, since
2647
      --  in general we don't know if the statements in the loop have been
2648
      --  executed. We could do a bit better than this with a loop that we
2649
      --  know will execute at least once, but it's not worth the trouble and
2650
      --  the front end is not in the business of flow tracing.
2651
 
2652
      Process_End_Label (N, 'e', Ent);
2653
      End_Scope;
2654
      Kill_Current_Values;
2655
 
2656
      --  Check for infinite loop. Skip check for generated code, since it
2657
      --  justs waste time and makes debugging the routine called harder.
2658
 
2659
      --  Note that we have to wait till the body of the loop is fully analyzed
2660
      --  before making this call, since Check_Infinite_Loop_Warning relies on
2661
      --  being able to use semantic visibility information to find references.
2662
 
2663
      if Comes_From_Source (N) then
2664
         Check_Infinite_Loop_Warning (N);
2665
      end if;
2666
 
2667
      --  Code after loop is unreachable if the loop has no WHILE or FOR and
2668
      --  contains no EXIT statements within the body of the loop.
2669
 
2670
      if No (Iter) and then not Has_Exit (Ent) then
2671
         Check_Unreachable_Code (N);
2672
      end if;
2673
   end Analyze_Loop_Statement;
2674
 
2675
   ----------------------------
2676
   -- Analyze_Null_Statement --
2677
   ----------------------------
2678
 
2679
   --  Note: the semantics of the null statement is implemented by a single
2680
   --  null statement, too bad everything isn't as simple as this!
2681
 
2682
   procedure Analyze_Null_Statement (N : Node_Id) is
2683
      pragma Warnings (Off, N);
2684
   begin
2685
      null;
2686
   end Analyze_Null_Statement;
2687
 
2688
   ------------------------
2689
   -- Analyze_Statements --
2690
   ------------------------
2691
 
2692
   procedure Analyze_Statements (L : List_Id) is
2693
      S   : Node_Id;
2694
      Lab : Entity_Id;
2695
 
2696
   begin
2697
      --  The labels declared in the statement list are reachable from
2698
      --  statements in the list. We do this as a prepass so that any goto
2699
      --  statement will be properly flagged if its target is not reachable.
2700
      --  This is not required, but is nice behavior!
2701
 
2702
      S := First (L);
2703
      while Present (S) loop
2704
         if Nkind (S) = N_Label then
2705
            Analyze (Identifier (S));
2706
            Lab := Entity (Identifier (S));
2707
 
2708
            --  If we found a label mark it as reachable
2709
 
2710
            if Ekind (Lab) = E_Label then
2711
               Generate_Definition (Lab);
2712
               Set_Reachable (Lab);
2713
 
2714
               if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then
2715
                  Set_Label_Construct (Parent (Lab), S);
2716
               end if;
2717
 
2718
            --  If we failed to find a label, it means the implicit declaration
2719
            --  of the label was hidden.  A for-loop parameter can do this to
2720
            --  a label with the same name inside the loop, since the implicit
2721
            --  label declaration is in the innermost enclosing body or block
2722
            --  statement.
2723
 
2724
            else
2725
               Error_Msg_Sloc := Sloc (Lab);
2726
               Error_Msg_N
2727
                 ("implicit label declaration for & is hidden#",
2728
                  Identifier (S));
2729
            end if;
2730
         end if;
2731
 
2732
         Next (S);
2733
      end loop;
2734
 
2735
      --  Perform semantic analysis on all statements
2736
 
2737
      Conditional_Statements_Begin;
2738
 
2739
      S := First (L);
2740
      while Present (S) loop
2741
         Analyze (S);
2742
 
2743
         --  Remove dimension in all statements
2744
 
2745
         Remove_Dimension_In_Statement (S);
2746
         Next (S);
2747
      end loop;
2748
 
2749
      Conditional_Statements_End;
2750
 
2751
      --  Make labels unreachable. Visibility is not sufficient, because labels
2752
      --  in one if-branch for example are not reachable from the other branch,
2753
      --  even though their declarations are in the enclosing declarative part.
2754
 
2755
      S := First (L);
2756
      while Present (S) loop
2757
         if Nkind (S) = N_Label then
2758
            Set_Reachable (Entity (Identifier (S)), False);
2759
         end if;
2760
 
2761
         Next (S);
2762
      end loop;
2763
   end Analyze_Statements;
2764
 
2765
   ----------------------------
2766
   -- Check_Unreachable_Code --
2767
   ----------------------------
2768
 
2769
   procedure Check_Unreachable_Code (N : Node_Id) is
2770
      Error_Node : Node_Id;
2771
      P          : Node_Id;
2772
 
2773
   begin
2774
      if Is_List_Member (N)
2775
        and then Comes_From_Source (N)
2776
      then
2777
         declare
2778
            Nxt : Node_Id;
2779
 
2780
         begin
2781
            Nxt := Original_Node (Next (N));
2782
 
2783
            --  If a label follows us, then we never have dead code, since
2784
            --  someone could branch to the label, so we just ignore it, unless
2785
            --  we are in formal mode where goto statements are not allowed.
2786
 
2787
            if Nkind (Nxt) = N_Label
2788
              and then not Restriction_Check_Required (SPARK)
2789
            then
2790
               return;
2791
 
2792
            --  Otherwise see if we have a real statement following us
2793
 
2794
            elsif Present (Nxt)
2795
              and then Comes_From_Source (Nxt)
2796
              and then Is_Statement (Nxt)
2797
            then
2798
               --  Special very annoying exception. If we have a return that
2799
               --  follows a raise, then we allow it without a warning, since
2800
               --  the Ada RM annoyingly requires a useless return here!
2801
 
2802
               if Nkind (Original_Node (N)) /= N_Raise_Statement
2803
                 or else Nkind (Nxt) /= N_Simple_Return_Statement
2804
               then
2805
                  --  The rather strange shenanigans with the warning message
2806
                  --  here reflects the fact that Kill_Dead_Code is very good
2807
                  --  at removing warnings in deleted code, and this is one
2808
                  --  warning we would prefer NOT to have removed.
2809
 
2810
                  Error_Node := Nxt;
2811
 
2812
                  --  If we have unreachable code, analyze and remove the
2813
                  --  unreachable code, since it is useless and we don't
2814
                  --  want to generate junk warnings.
2815
 
2816
                  --  We skip this step if we are not in code generation mode.
2817
                  --  This is the one case where we remove dead code in the
2818
                  --  semantics as opposed to the expander, and we do not want
2819
                  --  to remove code if we are not in code generation mode,
2820
                  --  since this messes up the ASIS trees.
2821
 
2822
                  --  Note that one might react by moving the whole circuit to
2823
                  --  exp_ch5, but then we lose the warning in -gnatc mode.
2824
 
2825
                  if Operating_Mode = Generate_Code then
2826
                     loop
2827
                        Nxt := Next (N);
2828
 
2829
                        --  Quit deleting when we have nothing more to delete
2830
                        --  or if we hit a label (since someone could transfer
2831
                        --  control to a label, so we should not delete it).
2832
 
2833
                        exit when No (Nxt) or else Nkind (Nxt) = N_Label;
2834
 
2835
                        --  Statement/declaration is to be deleted
2836
 
2837
                        Analyze (Nxt);
2838
                        Remove (Nxt);
2839
                        Kill_Dead_Code (Nxt);
2840
                     end loop;
2841
                  end if;
2842
 
2843
                  --  Now issue the warning (or error in formal mode)
2844
 
2845
                  if Restriction_Check_Required (SPARK) then
2846
                     Check_SPARK_Restriction
2847
                       ("unreachable code is not allowed", Error_Node);
2848
                  else
2849
                     Error_Msg ("?unreachable code!", Sloc (Error_Node));
2850
                  end if;
2851
               end if;
2852
 
2853
            --  If the unconditional transfer of control instruction is the
2854
            --  last statement of a sequence, then see if our parent is one of
2855
            --  the constructs for which we count unblocked exits, and if so,
2856
            --  adjust the count.
2857
 
2858
            else
2859
               P := Parent (N);
2860
 
2861
               --  Statements in THEN part or ELSE part of IF statement
2862
 
2863
               if Nkind (P) = N_If_Statement then
2864
                  null;
2865
 
2866
               --  Statements in ELSIF part of an IF statement
2867
 
2868
               elsif Nkind (P) = N_Elsif_Part then
2869
                  P := Parent (P);
2870
                  pragma Assert (Nkind (P) = N_If_Statement);
2871
 
2872
               --  Statements in CASE statement alternative
2873
 
2874
               elsif Nkind (P) = N_Case_Statement_Alternative then
2875
                  P := Parent (P);
2876
                  pragma Assert (Nkind (P) = N_Case_Statement);
2877
 
2878
               --  Statements in body of block
2879
 
2880
               elsif Nkind (P) = N_Handled_Sequence_Of_Statements
2881
                 and then Nkind (Parent (P)) = N_Block_Statement
2882
               then
2883
                  null;
2884
 
2885
               --  Statements in exception handler in a block
2886
 
2887
               elsif Nkind (P) = N_Exception_Handler
2888
                 and then Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements
2889
                 and then Nkind (Parent (Parent (P))) = N_Block_Statement
2890
               then
2891
                  null;
2892
 
2893
               --  None of these cases, so return
2894
 
2895
               else
2896
                  return;
2897
               end if;
2898
 
2899
               --  This was one of the cases we are looking for (i.e. the
2900
               --  parent construct was IF, CASE or block) so decrement count.
2901
 
2902
               Unblocked_Exit_Count := Unblocked_Exit_Count - 1;
2903
            end if;
2904
         end;
2905
      end if;
2906
   end Check_Unreachable_Code;
2907
 
2908
   -----------------------
2909
   -- Pre_Analyze_Range --
2910
   -----------------------
2911
 
2912
   procedure Pre_Analyze_Range (R_Copy : Node_Id) is
2913
      Save_Analysis : constant Boolean := Full_Analysis;
2914
 
2915
   begin
2916
      Full_Analysis := False;
2917
      Expander_Mode_Save_And_Set (False);
2918
 
2919
      Analyze (R_Copy);
2920
 
2921
      if Nkind (R_Copy) in N_Subexpr
2922
        and then Is_Overloaded (R_Copy)
2923
      then
2924
         --  Apply preference rules for range of predefined integer types, or
2925
         --  diagnose true ambiguity.
2926
 
2927
         declare
2928
            I     : Interp_Index;
2929
            It    : Interp;
2930
            Found : Entity_Id := Empty;
2931
 
2932
         begin
2933
            Get_First_Interp (R_Copy, I, It);
2934
            while Present (It.Typ) loop
2935
               if Is_Discrete_Type (It.Typ) then
2936
                  if No (Found) then
2937
                     Found := It.Typ;
2938
                  else
2939
                     if Scope (Found) = Standard_Standard then
2940
                        null;
2941
 
2942
                     elsif Scope (It.Typ) = Standard_Standard then
2943
                        Found := It.Typ;
2944
 
2945
                     else
2946
                        --  Both of them are user-defined
2947
 
2948
                        Error_Msg_N
2949
                          ("ambiguous bounds in range of iteration", R_Copy);
2950
                        Error_Msg_N ("\possible interpretations:", R_Copy);
2951
                        Error_Msg_NE ("\\} ", R_Copy, Found);
2952
                        Error_Msg_NE ("\\} ", R_Copy, It.Typ);
2953
                        exit;
2954
                     end if;
2955
                  end if;
2956
               end if;
2957
 
2958
               Get_Next_Interp (I, It);
2959
            end loop;
2960
         end;
2961
      end if;
2962
 
2963
      --  Subtype mark in iteration scheme
2964
 
2965
      if Is_Entity_Name (R_Copy)
2966
        and then Is_Type (Entity (R_Copy))
2967
      then
2968
         null;
2969
 
2970
      --  Expression in range, or Ada 2012 iterator
2971
 
2972
      elsif Nkind (R_Copy) in N_Subexpr then
2973
         Resolve (R_Copy);
2974
      end if;
2975
 
2976
      Expander_Mode_Restore;
2977
      Full_Analysis := Save_Analysis;
2978
   end Pre_Analyze_Range;
2979
 
2980
end Sem_Ch5;

powered by: WebSVN 2.1.0

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