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

Subversion Repositories openrisc_me

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                              S E M _ C H 5                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17
-- for  more details.  You should have  received  a copy of the GNU General --
18
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19
-- http://www.gnu.org/licenses for a complete copy of the license.          --
20
--                                                                          --
21
-- GNAT was originally developed  by the GNAT team at  New York University. --
22
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23
--                                                                          --
24
------------------------------------------------------------------------------
25
 
26
with Atree;    use Atree;
27
with Checks;   use Checks;
28
with Einfo;    use Einfo;
29
with Errout;   use Errout;
30
with Expander; use Expander;
31
with Exp_Util; use Exp_Util;
32
with Freeze;   use Freeze;
33
with Lib;      use Lib;
34
with Lib.Xref; use Lib.Xref;
35
with Namet;    use Namet;
36
with Nlists;   use Nlists;
37
with Nmake;    use Nmake;
38
with Opt;      use Opt;
39
with Rtsfind;  use Rtsfind;
40
with Sem;      use Sem;
41
with Sem_Aux;  use Sem_Aux;
42
with Sem_Case; use Sem_Case;
43
with Sem_Ch3;  use Sem_Ch3;
44
with Sem_Ch8;  use Sem_Ch8;
45
with Sem_Disp; use Sem_Disp;
46
with Sem_Elab; use Sem_Elab;
47
with Sem_Eval; use Sem_Eval;
48
with Sem_Res;  use Sem_Res;
49
with Sem_SCIL; use Sem_SCIL;
50
with Sem_Type; use Sem_Type;
51
with Sem_Util; use Sem_Util;
52
with Sem_Warn; use Sem_Warn;
53
with Snames;   use Snames;
54
with Stand;    use Stand;
55
with Sinfo;    use Sinfo;
56
with Targparm; use Targparm;
57
with Tbuild;   use Tbuild;
58
with Uintp;    use Uintp;
59
 
60
package body Sem_Ch5 is
61
 
62
   Unblocked_Exit_Count : Nat := 0;
63
   --  This variable is used when processing if statements, case statements,
64
   --  and block statements. It counts the number of exit points that are not
65
   --  blocked by unconditional transfer instructions: for IF and CASE, these
66
   --  are the branches of the conditional; for a block, they are the statement
67
   --  sequence of the block, and the statement sequences of any exception
68
   --  handlers that are part of the block. When processing is complete, if
69
   --  this count is zero, it means that control cannot fall through the IF,
70
   --  CASE or block statement. This is used for the generation of warning
71
   --  messages. This variable is recursively saved on entry to processing the
72
   --  construct, and restored on exit.
73
 
74
   -----------------------
75
   -- Local Subprograms --
76
   -----------------------
77
 
78
   procedure Analyze_Iteration_Scheme (N : Node_Id);
79
 
80
   ------------------------
81
   -- Analyze_Assignment --
82
   ------------------------
83
 
84
   procedure Analyze_Assignment (N : Node_Id) is
85
      Lhs  : constant Node_Id := Name (N);
86
      Rhs  : constant Node_Id := Expression (N);
87
      T1   : Entity_Id;
88
      T2   : Entity_Id;
89
      Decl : Node_Id;
90
 
91
      procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
92
      --  N is the node for the left hand side of an assignment, and it is not
93
      --  a variable. This routine issues an appropriate diagnostic.
94
 
95
      procedure Kill_Lhs;
96
      --  This is called to kill current value settings of a simple variable
97
      --  on the left hand side. We call it if we find any error in analyzing
98
      --  the assignment, and at the end of processing before setting any new
99
      --  current values in place.
100
 
101
      procedure Set_Assignment_Type
102
        (Opnd      : Node_Id;
103
         Opnd_Type : in out Entity_Id);
104
      --  Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type
105
      --  is the nominal subtype. This procedure is used to deal with cases
106
      --  where the nominal subtype must be replaced by the actual subtype.
107
 
108
      -------------------------------
109
      -- Diagnose_Non_Variable_Lhs --
110
      -------------------------------
111
 
112
      procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is
113
      begin
114
         --  Not worth posting another error if left hand side already
115
         --  flagged as being illegal in some respect.
116
 
117
         if Error_Posted (N) then
118
            return;
119
 
120
         --  Some special bad cases of entity names
121
 
122
         elsif Is_Entity_Name (N) then
123
            declare
124
               Ent : constant Entity_Id := Entity (N);
125
 
126
            begin
127
               if Ekind (Ent) = E_In_Parameter then
128
                  Error_Msg_N
129
                    ("assignment to IN mode parameter not allowed", N);
130
 
131
               --  Renamings of protected private components are turned into
132
               --  constants when compiling a protected function. In the case
133
               --  of single protected types, the private component appears
134
               --  directly.
135
 
136
               elsif (Is_Prival (Ent)
137
                        and then
138
                          (Ekind (Current_Scope) = E_Function
139
                             or else Ekind (Enclosing_Dynamic_Scope (
140
                                       Current_Scope)) = E_Function))
141
                   or else
142
                     (Ekind (Ent) = E_Component
143
                        and then Is_Protected_Type (Scope (Ent)))
144
               then
145
                  Error_Msg_N
146
                    ("protected function cannot modify protected object", N);
147
 
148
               elsif Ekind (Ent) = E_Loop_Parameter then
149
                  Error_Msg_N
150
                    ("assignment to loop parameter not allowed", N);
151
 
152
               else
153
                  Error_Msg_N
154
                    ("left hand side of assignment must be a variable", N);
155
               end if;
156
            end;
157
 
158
         --  For indexed components or selected components, test prefix
159
 
160
         elsif Nkind (N) = N_Indexed_Component then
161
            Diagnose_Non_Variable_Lhs (Prefix (N));
162
 
163
         --  Another special case for assignment to discriminant
164
 
165
         elsif Nkind (N) = N_Selected_Component then
166
            if Present (Entity (Selector_Name (N)))
167
              and then Ekind (Entity (Selector_Name (N))) = E_Discriminant
168
            then
169
               Error_Msg_N
170
                 ("assignment to discriminant not allowed", N);
171
            else
172
               Diagnose_Non_Variable_Lhs (Prefix (N));
173
            end if;
174
 
175
         else
176
            --  If we fall through, we have no special message to issue!
177
 
178
            Error_Msg_N ("left hand side of assignment must be a variable", N);
179
         end if;
180
      end Diagnose_Non_Variable_Lhs;
181
 
182
      --------------
183
      -- Kill_LHS --
184
      --------------
185
 
186
      procedure Kill_Lhs is
187
      begin
188
         if Is_Entity_Name (Lhs) then
189
            declare
190
               Ent : constant Entity_Id := Entity (Lhs);
191
            begin
192
               if Present (Ent) then
193
                  Kill_Current_Values (Ent);
194
               end if;
195
            end;
196
         end if;
197
      end Kill_Lhs;
198
 
199
      -------------------------
200
      -- Set_Assignment_Type --
201
      -------------------------
202
 
203
      procedure Set_Assignment_Type
204
        (Opnd      : Node_Id;
205
         Opnd_Type : in out Entity_Id)
206
      is
207
      begin
208
         Require_Entity (Opnd);
209
 
210
         --  If the assignment operand is an in-out or out parameter, then we
211
         --  get the actual subtype (needed for the unconstrained case).
212
         --  If the operand is the actual in an entry declaration, then within
213
         --  the accept statement it is replaced with a local renaming, which
214
         --  may also have an actual subtype.
215
 
216
         if Is_Entity_Name (Opnd)
217
           and then (Ekind (Entity (Opnd)) = E_Out_Parameter
218
                      or else Ekind (Entity (Opnd)) =
219
                           E_In_Out_Parameter
220
                      or else Ekind (Entity (Opnd)) =
221
                           E_Generic_In_Out_Parameter
222
                      or else
223
                        (Ekind (Entity (Opnd)) = E_Variable
224
                          and then Nkind (Parent (Entity (Opnd))) =
225
                             N_Object_Renaming_Declaration
226
                          and then Nkind (Parent (Parent (Entity (Opnd)))) =
227
                             N_Accept_Statement))
228
         then
229
            Opnd_Type := Get_Actual_Subtype (Opnd);
230
 
231
         --  If assignment operand is a component reference, then we get the
232
         --  actual subtype of the component for the unconstrained case.
233
 
234
         elsif Nkind_In (Opnd, N_Selected_Component, N_Explicit_Dereference)
235
           and then not Is_Unchecked_Union (Opnd_Type)
236
         then
237
            Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
238
 
239
            if Present (Decl) then
240
               Insert_Action (N, Decl);
241
               Mark_Rewrite_Insertion (Decl);
242
               Analyze (Decl);
243
               Opnd_Type := Defining_Identifier (Decl);
244
               Set_Etype (Opnd, Opnd_Type);
245
               Freeze_Itype (Opnd_Type, N);
246
 
247
            elsif Is_Constrained (Etype (Opnd)) then
248
               Opnd_Type := Etype (Opnd);
249
            end if;
250
 
251
         --  For slice, use the constrained subtype created for the slice
252
 
253
         elsif Nkind (Opnd) = N_Slice then
254
            Opnd_Type := Etype (Opnd);
255
         end if;
256
      end Set_Assignment_Type;
257
 
258
   --  Start of processing for Analyze_Assignment
259
 
260
   begin
261
      Mark_Coextensions (N, Rhs);
262
 
263
      Analyze (Rhs);
264
      Analyze (Lhs);
265
 
266
      --  Start type analysis for assignment
267
 
268
      T1 := Etype (Lhs);
269
 
270
      --  In the most general case, both Lhs and Rhs can be overloaded, and we
271
      --  must compute the intersection of the possible types on each side.
272
 
273
      if Is_Overloaded (Lhs) then
274
         declare
275
            I  : Interp_Index;
276
            It : Interp;
277
 
278
         begin
279
            T1 := Any_Type;
280
            Get_First_Interp (Lhs, I, It);
281
 
282
            while Present (It.Typ) loop
283
               if Has_Compatible_Type (Rhs, It.Typ) then
284
                  if T1 /= Any_Type then
285
 
286
                     --  An explicit dereference is overloaded if the prefix
287
                     --  is. Try to remove the ambiguity on the prefix, the
288
                     --  error will be posted there if the ambiguity is real.
289
 
290
                     if Nkind (Lhs) = N_Explicit_Dereference then
291
                        declare
292
                           PI    : Interp_Index;
293
                           PI1   : Interp_Index := 0;
294
                           PIt   : Interp;
295
                           Found : Boolean;
296
 
297
                        begin
298
                           Found := False;
299
                           Get_First_Interp (Prefix (Lhs), PI, PIt);
300
 
301
                           while Present (PIt.Typ) loop
302
                              if Is_Access_Type (PIt.Typ)
303
                                and then Has_Compatible_Type
304
                                           (Rhs, Designated_Type (PIt.Typ))
305
                              then
306
                                 if Found then
307
                                    PIt :=
308
                                      Disambiguate (Prefix (Lhs),
309
                                        PI1, PI, Any_Type);
310
 
311
                                    if PIt = No_Interp then
312
                                       Error_Msg_N
313
                                         ("ambiguous left-hand side"
314
                                            & " in assignment", Lhs);
315
                                       exit;
316
                                    else
317
                                       Resolve (Prefix (Lhs), PIt.Typ);
318
                                    end if;
319
 
320
                                    exit;
321
                                 else
322
                                    Found := True;
323
                                    PI1 := PI;
324
                                 end if;
325
                              end if;
326
 
327
                              Get_Next_Interp (PI, PIt);
328
                           end loop;
329
                        end;
330
 
331
                     else
332
                        Error_Msg_N
333
                          ("ambiguous left-hand side in assignment", Lhs);
334
                        exit;
335
                     end if;
336
                  else
337
                     T1 := It.Typ;
338
                  end if;
339
               end if;
340
 
341
               Get_Next_Interp (I, It);
342
            end loop;
343
         end;
344
 
345
         if T1 = Any_Type then
346
            Error_Msg_N
347
              ("no valid types for left-hand side for assignment", Lhs);
348
            Kill_Lhs;
349
            return;
350
         end if;
351
      end if;
352
 
353
      --  The resulting assignment type is T1, so now we will resolve the
354
      --  left hand side of the assignment using this determined type.
355
 
356
      Resolve (Lhs, T1);
357
 
358
      --  Cases where Lhs is not a variable
359
 
360
      if not Is_Variable (Lhs) then
361
 
362
         --  Ada 2005 (AI-327): Check assignment to the attribute Priority of
363
         --  a protected object.
364
 
365
         declare
366
            Ent : Entity_Id;
367
            S   : Entity_Id;
368
 
369
         begin
370
            if Ada_Version >= Ada_05 then
371
 
372
               --  Handle chains of renamings
373
 
374
               Ent := Lhs;
375
               while Nkind (Ent) in N_Has_Entity
376
                 and then Present (Entity (Ent))
377
                 and then Present (Renamed_Object (Entity (Ent)))
378
               loop
379
                  Ent := Renamed_Object (Entity (Ent));
380
               end loop;
381
 
382
               if (Nkind (Ent) = N_Attribute_Reference
383
                     and then Attribute_Name (Ent) = Name_Priority)
384
 
385
                  --  Renamings of the attribute Priority applied to protected
386
                  --  objects have been previously expanded into calls to the
387
                  --  Get_Ceiling run-time subprogram.
388
 
389
                 or else
390
                  (Nkind (Ent) = N_Function_Call
391
                     and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling)
392
                                or else
393
                               Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling)))
394
               then
395
                  --  The enclosing subprogram cannot be a protected function
396
 
397
                  S := Current_Scope;
398
                  while not (Is_Subprogram (S)
399
                               and then Convention (S) = Convention_Protected)
400
                     and then S /= Standard_Standard
401
                  loop
402
                     S := Scope (S);
403
                  end loop;
404
 
405
                  if Ekind (S) = E_Function
406
                    and then Convention (S) = Convention_Protected
407
                  then
408
                     Error_Msg_N
409
                       ("protected function cannot modify protected object",
410
                        Lhs);
411
                  end if;
412
 
413
                  --  Changes of the ceiling priority of the protected object
414
                  --  are only effective if the Ceiling_Locking policy is in
415
                  --  effect (AARM D.5.2 (5/2)).
416
 
417
                  if Locking_Policy /= 'C' then
418
                     Error_Msg_N ("assignment to the attribute PRIORITY has " &
419
                                  "no effect?", Lhs);
420
                     Error_Msg_N ("\since no Locking_Policy has been " &
421
                                  "specified", Lhs);
422
                  end if;
423
 
424
                  return;
425
               end if;
426
            end if;
427
         end;
428
 
429
         Diagnose_Non_Variable_Lhs (Lhs);
430
         return;
431
 
432
      --  Error of assigning to limited type. We do however allow this in
433
      --  certain cases where the front end generates the assignments.
434
 
435
      elsif Is_Limited_Type (T1)
436
        and then not Assignment_OK (Lhs)
437
        and then not Assignment_OK (Original_Node (Lhs))
438
        and then not Is_Value_Type (T1)
439
      then
440
         --  CPP constructors can only be called in declarations
441
 
442
         if Is_CPP_Constructor_Call (Rhs) then
443
            Error_Msg_N ("invalid use of 'C'P'P constructor", Rhs);
444
         else
445
            Error_Msg_N
446
              ("left hand of assignment must not be limited type", Lhs);
447
            Explain_Limited_Type (T1, Lhs);
448
         end if;
449
         return;
450
 
451
      --  Enforce RM 3.9.3 (8): left-hand side cannot be abstract
452
 
453
      elsif Is_Interface (T1)
454
        and then not Is_Class_Wide_Type (T1)
455
      then
456
         Error_Msg_N
457
           ("target of assignment operation may not be abstract", Lhs);
458
         return;
459
      end if;
460
 
461
      --  Resolution may have updated the subtype, in case the left-hand
462
      --  side is a private protected component. Use the correct subtype
463
      --  to avoid scoping issues in the back-end.
464
 
465
      T1 := Etype (Lhs);
466
 
467
      --  Ada 2005 (AI-50217, AI-326): Check wrong dereference of incomplete
468
      --  type. For example:
469
 
470
      --    limited with P;
471
      --    package Pkg is
472
      --      type Acc is access P.T;
473
      --    end Pkg;
474
 
475
      --    with Pkg; use Acc;
476
      --    procedure Example is
477
      --       A, B : Acc;
478
      --    begin
479
      --       A.all := B.all;  -- ERROR
480
      --    end Example;
481
 
482
      if Nkind (Lhs) = N_Explicit_Dereference
483
        and then Ekind (T1) = E_Incomplete_Type
484
      then
485
         Error_Msg_N ("invalid use of incomplete type", Lhs);
486
         Kill_Lhs;
487
         return;
488
      end if;
489
 
490
      --  Now we can complete the resolution of the right hand side
491
 
492
      Set_Assignment_Type (Lhs, T1);
493
      Resolve (Rhs, T1);
494
 
495
      --  This is the point at which we check for an unset reference
496
 
497
      Check_Unset_Reference (Rhs);
498
      Check_Unprotected_Access (Lhs, Rhs);
499
 
500
      --  Remaining steps are skipped if Rhs was syntactically in error
501
 
502
      if Rhs = Error then
503
         Kill_Lhs;
504
         return;
505
      end if;
506
 
507
      T2 := Etype (Rhs);
508
 
509
      if not Covers (T1, T2) then
510
         Wrong_Type (Rhs, Etype (Lhs));
511
         Kill_Lhs;
512
         return;
513
      end if;
514
 
515
      --  Ada 2005 (AI-326): In case of explicit dereference of incomplete
516
      --  types, use the non-limited view if available
517
 
518
      if Nkind (Rhs) = N_Explicit_Dereference
519
        and then Ekind (T2) = E_Incomplete_Type
520
        and then Is_Tagged_Type (T2)
521
        and then Present (Non_Limited_View (T2))
522
      then
523
         T2 := Non_Limited_View (T2);
524
      end if;
525
 
526
      Set_Assignment_Type (Rhs, T2);
527
 
528
      if Total_Errors_Detected /= 0 then
529
         if No (T1) then
530
            T1 := Any_Type;
531
         end if;
532
 
533
         if No (T2) then
534
            T2 := Any_Type;
535
         end if;
536
      end if;
537
 
538
      if T1 = Any_Type or else T2 = Any_Type then
539
         Kill_Lhs;
540
         return;
541
      end if;
542
 
543
      --  If the rhs is class-wide or dynamically tagged, then require the lhs
544
      --  to be class-wide. The case where the rhs is a dynamically tagged call
545
      --  to a dispatching operation with a controlling access result is
546
      --  excluded from this check, since the target has an access type (and
547
      --  no tag propagation occurs in that case).
548
 
549
      if (Is_Class_Wide_Type (T2)
550
           or else (Is_Dynamically_Tagged (Rhs)
551
                     and then not Is_Access_Type (T1)))
552
        and then not Is_Class_Wide_Type (T1)
553
      then
554
         Error_Msg_N ("dynamically tagged expression not allowed!", Rhs);
555
 
556
      elsif Is_Class_Wide_Type (T1)
557
        and then not Is_Class_Wide_Type (T2)
558
        and then not Is_Tag_Indeterminate (Rhs)
559
        and then not Is_Dynamically_Tagged (Rhs)
560
      then
561
         Error_Msg_N ("dynamically tagged expression required!", Rhs);
562
      end if;
563
 
564
      --  Propagate the tag from a class-wide target to the rhs when the rhs
565
      --  is a tag-indeterminate call.
566
 
567
      if Is_Tag_Indeterminate (Rhs) then
568
         if Is_Class_Wide_Type (T1) then
569
            Propagate_Tag (Lhs, Rhs);
570
 
571
         elsif Nkind (Rhs) = N_Function_Call
572
              and then Is_Entity_Name (Name (Rhs))
573
              and then Is_Abstract_Subprogram (Entity (Name (Rhs)))
574
         then
575
            Error_Msg_N
576
              ("call to abstract function must be dispatching", Name (Rhs));
577
 
578
         elsif Nkind (Rhs) = N_Qualified_Expression
579
           and then Nkind (Expression (Rhs)) = N_Function_Call
580
              and then Is_Entity_Name (Name (Expression (Rhs)))
581
              and then
582
                Is_Abstract_Subprogram (Entity (Name (Expression (Rhs))))
583
         then
584
            Error_Msg_N
585
              ("call to abstract function must be dispatching",
586
                Name (Expression (Rhs)));
587
         end if;
588
      end if;
589
 
590
      --  Ada 2005 (AI-385): When the lhs type is an anonymous access type,
591
      --  apply an implicit conversion of the rhs to that type to force
592
      --  appropriate static and run-time accessibility checks. This applies
593
      --  as well to anonymous access-to-subprogram types that are component
594
      --  subtypes or formal parameters.
595
 
596
      if Ada_Version >= Ada_05
597
        and then Is_Access_Type (T1)
598
      then
599
         if Is_Local_Anonymous_Access (T1)
600
           or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type
601
         then
602
            Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
603
            Analyze_And_Resolve (Rhs, T1);
604
         end if;
605
      end if;
606
 
607
      --  Ada 2005 (AI-231): Assignment to not null variable
608
 
609
      if Ada_Version >= Ada_05
610
        and then Can_Never_Be_Null (T1)
611
        and then not Assignment_OK (Lhs)
612
      then
613
         --  Case where we know the right hand side is null
614
 
615
         if Known_Null (Rhs) then
616
            Apply_Compile_Time_Constraint_Error
617
              (N   => Rhs,
618
               Msg => "(Ada 2005) null not allowed in null-excluding objects?",
619
               Reason => CE_Null_Not_Allowed);
620
 
621
            --  We still mark this as a possible modification, that's necessary
622
            --  to reset Is_True_Constant, and desirable for xref purposes.
623
 
624
            Note_Possible_Modification (Lhs, Sure => True);
625
            return;
626
 
627
         --  If we know the right hand side is non-null, then we convert to the
628
         --  target type, since we don't need a run time check in that case.
629
 
630
         elsif not Can_Never_Be_Null (T2) then
631
            Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
632
            Analyze_And_Resolve (Rhs, T1);
633
         end if;
634
      end if;
635
 
636
      if Is_Scalar_Type (T1) then
637
         Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
638
 
639
      --  For array types, verify that lengths match. If the right hand side
640
      --  if a function call that has been inlined, the assignment has been
641
      --  rewritten as a block, and the constraint check will be applied to the
642
      --  assignment within the block.
643
 
644
      elsif Is_Array_Type (T1)
645
        and then
646
          (Nkind (Rhs) /= N_Type_Conversion
647
            or else Is_Constrained (Etype (Rhs)))
648
        and then
649
          (Nkind (Rhs) /= N_Function_Call
650
            or else Nkind (N) /= N_Block_Statement)
651
      then
652
         --  Assignment verifies that the length of the Lsh and Rhs are equal,
653
         --  but of course the indices do not have to match. If the right-hand
654
         --  side is a type conversion to an unconstrained type, a length check
655
         --  is performed on the expression itself during expansion. In rare
656
         --  cases, the redundant length check is computed on an index type
657
         --  with a different representation, triggering incorrect code in
658
         --  the back end.
659
 
660
         Apply_Length_Check (Rhs, Etype (Lhs));
661
 
662
      else
663
         --  Discriminant checks are applied in the course of expansion
664
 
665
         null;
666
      end if;
667
 
668
      --  Note: modifications of the Lhs may only be recorded after
669
      --  checks have been applied.
670
 
671
      Note_Possible_Modification (Lhs, Sure => True);
672
 
673
      --  ??? a real accessibility check is needed when ???
674
 
675
      --  Post warning for redundant assignment or variable to itself
676
 
677
      if Warn_On_Redundant_Constructs
678
 
679
         --  We only warn for source constructs
680
 
681
         and then Comes_From_Source (N)
682
 
683
         --  Where the object is the same on both sides
684
 
685
         and then Same_Object (Lhs, Original_Node (Rhs))
686
 
687
         --  But exclude the case where the right side was an operation
688
         --  that got rewritten (e.g. JUNK + K, where K was known to be
689
         --  zero). We don't want to warn in such a case, since it is
690
         --  reasonable to write such expressions especially when K is
691
         --  defined symbolically in some other package.
692
 
693
        and then Nkind (Original_Node (Rhs)) not in N_Op
694
      then
695
         if Nkind (Lhs) in N_Has_Entity then
696
            Error_Msg_NE
697
              ("?useless assignment of & to itself!", N, Entity (Lhs));
698
         else
699
            Error_Msg_N
700
              ("?useless assignment of object to itself!", N);
701
         end if;
702
      end if;
703
 
704
      --  Check for non-allowed composite assignment
705
 
706
      if not Support_Composite_Assign_On_Target
707
        and then (Is_Array_Type (T1) or else Is_Record_Type (T1))
708
        and then (not Has_Size_Clause (T1) or else Esize (T1) > 64)
709
      then
710
         Error_Msg_CRT ("composite assignment", N);
711
      end if;
712
 
713
      --  Check elaboration warning for left side if not in elab code
714
 
715
      if not In_Subprogram_Or_Concurrent_Unit then
716
         Check_Elab_Assign (Lhs);
717
      end if;
718
 
719
      --  Set Referenced_As_LHS if appropriate. We only set this flag if the
720
      --  assignment is a source assignment in the extended main source unit.
721
      --  We are not interested in any reference information outside this
722
      --  context, or in compiler generated assignment statements.
723
 
724
      if Comes_From_Source (N)
725
        and then In_Extended_Main_Source_Unit (Lhs)
726
      then
727
         Set_Referenced_Modified (Lhs, Out_Param => False);
728
      end if;
729
 
730
      --  Final step. If left side is an entity, then we may be able to
731
      --  reset the current tracked values to new safe values. We only have
732
      --  something to do if the left side is an entity name, and expansion
733
      --  has not modified the node into something other than an assignment,
734
      --  and of course we only capture values if it is safe to do so.
735
 
736
      if Is_Entity_Name (Lhs)
737
        and then Nkind (N) = N_Assignment_Statement
738
      then
739
         declare
740
            Ent : constant Entity_Id := Entity (Lhs);
741
 
742
         begin
743
            if Safe_To_Capture_Value (N, Ent) then
744
 
745
               --  If simple variable on left side, warn if this assignment
746
               --  blots out another one (rendering it useless) and note
747
               --  location of assignment in case no one references value.
748
               --  We only do this for source assignments, otherwise we can
749
               --  generate bogus warnings when an assignment is rewritten as
750
               --  another assignment, and gets tied up with itself.
751
 
752
               --  Note: we don't use Record_Last_Assignment here, because we
753
               --  have lots of other stuff to do under control of this test.
754
 
755
               if Warn_On_Modified_Unread
756
                 and then Is_Assignable (Ent)
757
                 and then Comes_From_Source (N)
758
                 and then In_Extended_Main_Source_Unit (Ent)
759
               then
760
                  Warn_On_Useless_Assignment (Ent, N);
761
                  Set_Last_Assignment (Ent, Lhs);
762
               end if;
763
 
764
               --  If we are assigning an access type and the left side is an
765
               --  entity, then make sure that the Is_Known_[Non_]Null flags
766
               --  properly reflect the state of the entity after assignment.
767
 
768
               if Is_Access_Type (T1) then
769
                  if Known_Non_Null (Rhs) then
770
                     Set_Is_Known_Non_Null (Ent, True);
771
 
772
                  elsif Known_Null (Rhs)
773
                    and then not Can_Never_Be_Null (Ent)
774
                  then
775
                     Set_Is_Known_Null (Ent, True);
776
 
777
                  else
778
                     Set_Is_Known_Null (Ent, False);
779
 
780
                     if not Can_Never_Be_Null (Ent) then
781
                        Set_Is_Known_Non_Null (Ent, False);
782
                     end if;
783
                  end if;
784
 
785
               --  For discrete types, we may be able to set the current value
786
               --  if the value is known at compile time.
787
 
788
               elsif Is_Discrete_Type (T1)
789
                 and then Compile_Time_Known_Value (Rhs)
790
               then
791
                  Set_Current_Value (Ent, Rhs);
792
               else
793
                  Set_Current_Value (Ent, Empty);
794
               end if;
795
 
796
            --  If not safe to capture values, kill them
797
 
798
            else
799
               Kill_Lhs;
800
            end if;
801
         end;
802
      end if;
803
   end Analyze_Assignment;
804
 
805
   -----------------------------
806
   -- Analyze_Block_Statement --
807
   -----------------------------
808
 
809
   procedure Analyze_Block_Statement (N : Node_Id) is
810
      Decls : constant List_Id := Declarations (N);
811
      Id    : constant Node_Id := Identifier (N);
812
      HSS   : constant Node_Id := Handled_Statement_Sequence (N);
813
 
814
   begin
815
      --  If no handled statement sequence is present, things are really
816
      --  messed up, and we just return immediately (this is a defence
817
      --  against previous errors).
818
 
819
      if No (HSS) then
820
         return;
821
      end if;
822
 
823
      --  Normal processing with HSS present
824
 
825
      declare
826
         EH  : constant List_Id := Exception_Handlers (HSS);
827
         Ent : Entity_Id        := Empty;
828
         S   : Entity_Id;
829
 
830
         Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
831
         --  Recursively save value of this global, will be restored on exit
832
 
833
      begin
834
         --  Initialize unblocked exit count for statements of begin block
835
         --  plus one for each exception handler that is present.
836
 
837
         Unblocked_Exit_Count := 1;
838
 
839
         if Present (EH) then
840
            Unblocked_Exit_Count := Unblocked_Exit_Count + List_Length (EH);
841
         end if;
842
 
843
         --  If a label is present analyze it and mark it as referenced
844
 
845
         if Present (Id) then
846
            Analyze (Id);
847
            Ent := Entity (Id);
848
 
849
            --  An error defense. If we have an identifier, but no entity,
850
            --  then something is wrong. If we have previous errors, then
851
            --  just remove the identifier and continue, otherwise raise
852
            --  an exception.
853
 
854
            if No (Ent) then
855
               if Total_Errors_Detected /= 0 then
856
                  Set_Identifier (N, Empty);
857
               else
858
                  raise Program_Error;
859
               end if;
860
 
861
            else
862
               Set_Ekind (Ent, E_Block);
863
               Generate_Reference (Ent, N, ' ');
864
               Generate_Definition (Ent);
865
 
866
               if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
867
                  Set_Label_Construct (Parent (Ent), N);
868
               end if;
869
            end if;
870
         end if;
871
 
872
         --  If no entity set, create a label entity
873
 
874
         if No (Ent) then
875
            Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
876
            Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N)));
877
            Set_Parent (Ent, N);
878
         end if;
879
 
880
         Set_Etype (Ent, Standard_Void_Type);
881
         Set_Block_Node (Ent, Identifier (N));
882
         Push_Scope (Ent);
883
 
884
         if Present (Decls) then
885
            Analyze_Declarations (Decls);
886
            Check_Completion;
887
            Inspect_Deferred_Constant_Completion (Decls);
888
         end if;
889
 
890
         Analyze (HSS);
891
         Process_End_Label (HSS, 'e', Ent);
892
 
893
         --  If exception handlers are present, then we indicate that
894
         --  enclosing scopes contain a block with handlers. We only
895
         --  need to mark non-generic scopes.
896
 
897
         if Present (EH) then
898
            S := Scope (Ent);
899
            loop
900
               Set_Has_Nested_Block_With_Handler (S);
901
               exit when Is_Overloadable (S)
902
                 or else Ekind (S) = E_Package
903
                 or else Is_Generic_Unit (S);
904
               S := Scope (S);
905
            end loop;
906
         end if;
907
 
908
         Check_References (Ent);
909
         Warn_On_Useless_Assignments (Ent);
910
         End_Scope;
911
 
912
         if Unblocked_Exit_Count = 0 then
913
            Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
914
            Check_Unreachable_Code (N);
915
         else
916
            Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
917
         end if;
918
      end;
919
   end Analyze_Block_Statement;
920
 
921
   ----------------------------
922
   -- Analyze_Case_Statement --
923
   ----------------------------
924
 
925
   procedure Analyze_Case_Statement (N : Node_Id) is
926
      Exp            : Node_Id;
927
      Exp_Type       : Entity_Id;
928
      Exp_Btype      : Entity_Id;
929
      Last_Choice    : Nat;
930
      Dont_Care      : Boolean;
931
      Others_Present : Boolean;
932
 
933
      pragma Warnings (Off, Last_Choice);
934
      pragma Warnings (Off, Dont_Care);
935
      --  Don't care about assigned values
936
 
937
      Statements_Analyzed : Boolean := False;
938
      --  Set True if at least some statement sequences get analyzed.
939
      --  If False on exit, means we had a serious error that prevented
940
      --  full analysis of the case statement, and as a result it is not
941
      --  a good idea to output warning messages about unreachable code.
942
 
943
      Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
944
      --  Recursively save value of this global, will be restored on exit
945
 
946
      procedure Non_Static_Choice_Error (Choice : Node_Id);
947
      --  Error routine invoked by the generic instantiation below when
948
      --  the case statement has a non static choice.
949
 
950
      procedure Process_Statements (Alternative : Node_Id);
951
      --  Analyzes all the statements associated to a case alternative.
952
      --  Needed by the generic instantiation below.
953
 
954
      package Case_Choices_Processing is new
955
        Generic_Choices_Processing
956
          (Get_Alternatives          => Alternatives,
957
           Get_Choices               => Discrete_Choices,
958
           Process_Empty_Choice      => No_OP,
959
           Process_Non_Static_Choice => Non_Static_Choice_Error,
960
           Process_Associated_Node   => Process_Statements);
961
      use Case_Choices_Processing;
962
      --  Instantiation of the generic choice processing package
963
 
964
      -----------------------------
965
      -- Non_Static_Choice_Error --
966
      -----------------------------
967
 
968
      procedure Non_Static_Choice_Error (Choice : Node_Id) is
969
      begin
970
         Flag_Non_Static_Expr
971
           ("choice given in case statement is not static!", Choice);
972
      end Non_Static_Choice_Error;
973
 
974
      ------------------------
975
      -- Process_Statements --
976
      ------------------------
977
 
978
      procedure Process_Statements (Alternative : Node_Id) is
979
         Choices : constant List_Id := Discrete_Choices (Alternative);
980
         Ent     : Entity_Id;
981
 
982
      begin
983
         Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
984
         Statements_Analyzed := True;
985
 
986
         --  An interesting optimization. If the case statement expression
987
         --  is a simple entity, then we can set the current value within
988
         --  an alternative if the alternative has one possible value.
989
 
990
         --    case N is
991
         --      when 1      => alpha
992
         --      when 2 | 3  => beta
993
         --      when others => gamma
994
 
995
         --  Here we know that N is initially 1 within alpha, but for beta
996
         --  and gamma, we do not know anything more about the initial value.
997
 
998
         if Is_Entity_Name (Exp) then
999
            Ent := Entity (Exp);
1000
 
1001
            if Ekind (Ent) = E_Variable
1002
                 or else
1003
               Ekind (Ent) = E_In_Out_Parameter
1004
                 or else
1005
               Ekind (Ent) = E_Out_Parameter
1006
            then
1007
               if List_Length (Choices) = 1
1008
                 and then Nkind (First (Choices)) in N_Subexpr
1009
                 and then Compile_Time_Known_Value (First (Choices))
1010
               then
1011
                  Set_Current_Value (Entity (Exp), First (Choices));
1012
               end if;
1013
 
1014
               Analyze_Statements (Statements (Alternative));
1015
 
1016
               --  After analyzing the case, set the current value to empty
1017
               --  since we won't know what it is for the next alternative
1018
               --  (unless reset by this same circuit), or after the case.
1019
 
1020
               Set_Current_Value (Entity (Exp), Empty);
1021
               return;
1022
            end if;
1023
         end if;
1024
 
1025
         --  Case where expression is not an entity name of a variable
1026
 
1027
         Analyze_Statements (Statements (Alternative));
1028
      end Process_Statements;
1029
 
1030
      --  Table to record choices. Put after subprograms since we make
1031
      --  a call to Number_Of_Choices to get the right number of entries.
1032
 
1033
      Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
1034
      pragma Warnings (Off, Case_Table);
1035
 
1036
   --  Start of processing for Analyze_Case_Statement
1037
 
1038
   begin
1039
      Unblocked_Exit_Count := 0;
1040
      Exp := Expression (N);
1041
      Analyze (Exp);
1042
 
1043
      --  The expression must be of any discrete type. In rare cases, the
1044
      --  expander constructs a case statement whose expression has a private
1045
      --  type whose full view is discrete. This can happen when generating
1046
      --  a stream operation for a variant type after the type is frozen,
1047
      --  when the partial of view of the type of the discriminant is private.
1048
      --  In that case, use the full view to analyze case alternatives.
1049
 
1050
      if not Is_Overloaded (Exp)
1051
        and then not Comes_From_Source (N)
1052
        and then Is_Private_Type (Etype (Exp))
1053
        and then Present (Full_View (Etype (Exp)))
1054
        and then Is_Discrete_Type (Full_View (Etype (Exp)))
1055
      then
1056
         Resolve (Exp, Etype (Exp));
1057
         Exp_Type := Full_View (Etype (Exp));
1058
 
1059
      else
1060
         Analyze_And_Resolve (Exp, Any_Discrete);
1061
         Exp_Type := Etype (Exp);
1062
      end if;
1063
 
1064
      Check_Unset_Reference (Exp);
1065
      Exp_Btype := Base_Type (Exp_Type);
1066
 
1067
      --  The expression must be of a discrete type which must be determinable
1068
      --  independently of the context in which the expression occurs, but
1069
      --  using the fact that the expression must be of a discrete type.
1070
      --  Moreover, the type this expression must not be a character literal
1071
      --  (which is always ambiguous) or, for Ada-83, a generic formal type.
1072
 
1073
      --  If error already reported by Resolve, nothing more to do
1074
 
1075
      if Exp_Btype = Any_Discrete
1076
        or else Exp_Btype = Any_Type
1077
      then
1078
         return;
1079
 
1080
      elsif Exp_Btype = Any_Character then
1081
         Error_Msg_N
1082
           ("character literal as case expression is ambiguous", Exp);
1083
         return;
1084
 
1085
      elsif Ada_Version = Ada_83
1086
        and then (Is_Generic_Type (Exp_Btype)
1087
                    or else Is_Generic_Type (Root_Type (Exp_Btype)))
1088
      then
1089
         Error_Msg_N
1090
           ("(Ada 83) case expression cannot be of a generic type", Exp);
1091
         return;
1092
      end if;
1093
 
1094
      --  If the case expression is a formal object of mode in out, then
1095
      --  treat it as having a nonstatic subtype by forcing use of the base
1096
      --  type (which has to get passed to Check_Case_Choices below).  Also
1097
      --  use base type when the case expression is parenthesized.
1098
 
1099
      if Paren_Count (Exp) > 0
1100
        or else (Is_Entity_Name (Exp)
1101
                  and then Ekind (Entity (Exp)) = E_Generic_In_Out_Parameter)
1102
      then
1103
         Exp_Type := Exp_Btype;
1104
      end if;
1105
 
1106
      --  Call instantiated Analyze_Choices which does the rest of the work
1107
 
1108
      Analyze_Choices
1109
        (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
1110
 
1111
      if Exp_Type = Universal_Integer and then not Others_Present then
1112
         Error_Msg_N ("case on universal integer requires OTHERS choice", Exp);
1113
      end if;
1114
 
1115
      --  If all our exits were blocked by unconditional transfers of control,
1116
      --  then the entire CASE statement acts as an unconditional transfer of
1117
      --  control, so treat it like one, and check unreachable code. Skip this
1118
      --  test if we had serious errors preventing any statement analysis.
1119
 
1120
      if Unblocked_Exit_Count = 0 and then Statements_Analyzed then
1121
         Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1122
         Check_Unreachable_Code (N);
1123
      else
1124
         Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1125
      end if;
1126
 
1127
      if not Expander_Active
1128
        and then Compile_Time_Known_Value (Expression (N))
1129
        and then Serious_Errors_Detected = 0
1130
      then
1131
         declare
1132
            Chosen : constant Node_Id := Find_Static_Alternative (N);
1133
            Alt    : Node_Id;
1134
 
1135
         begin
1136
            Alt := First (Alternatives (N));
1137
            while Present (Alt) loop
1138
               if Alt /= Chosen then
1139
                  Remove_Warning_Messages (Statements (Alt));
1140
               end if;
1141
 
1142
               Next (Alt);
1143
            end loop;
1144
         end;
1145
      end if;
1146
   end Analyze_Case_Statement;
1147
 
1148
   ----------------------------
1149
   -- Analyze_Exit_Statement --
1150
   ----------------------------
1151
 
1152
   --  If the exit includes a name, it must be the name of a currently open
1153
   --  loop. Otherwise there must be an innermost open loop on the stack,
1154
   --  to which the statement implicitly refers.
1155
 
1156
   procedure Analyze_Exit_Statement (N : Node_Id) is
1157
      Target   : constant Node_Id := Name (N);
1158
      Cond     : constant Node_Id := Condition (N);
1159
      Scope_Id : Entity_Id;
1160
      U_Name   : Entity_Id;
1161
      Kind     : Entity_Kind;
1162
 
1163
   begin
1164
      if No (Cond) then
1165
         Check_Unreachable_Code (N);
1166
      end if;
1167
 
1168
      if Present (Target) then
1169
         Analyze (Target);
1170
         U_Name := Entity (Target);
1171
 
1172
         if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then
1173
            Error_Msg_N ("invalid loop name in exit statement", N);
1174
            return;
1175
         else
1176
            Set_Has_Exit (U_Name);
1177
         end if;
1178
 
1179
      else
1180
         U_Name := Empty;
1181
      end if;
1182
 
1183
      for J in reverse 0 .. Scope_Stack.Last loop
1184
         Scope_Id := Scope_Stack.Table (J).Entity;
1185
         Kind := Ekind (Scope_Id);
1186
 
1187
         if Kind = E_Loop
1188
           and then (No (Target) or else Scope_Id = U_Name) then
1189
            Set_Has_Exit (Scope_Id);
1190
            exit;
1191
 
1192
         elsif Kind = E_Block
1193
           or else Kind = E_Loop
1194
           or else Kind = E_Return_Statement
1195
         then
1196
            null;
1197
 
1198
         else
1199
            Error_Msg_N
1200
              ("cannot exit from program unit or accept statement", N);
1201
            exit;
1202
         end if;
1203
      end loop;
1204
 
1205
      --  Verify that if present the condition is a Boolean expression
1206
 
1207
      if Present (Cond) then
1208
         Analyze_And_Resolve (Cond, Any_Boolean);
1209
         Check_Unset_Reference (Cond);
1210
      end if;
1211
 
1212
      --  Since the exit may take us out of a loop, any previous assignment
1213
      --  statement is not useless, so clear last assignment indications. It
1214
      --  is OK to keep other current values, since if the exit statement
1215
      --  does not exit, then the current values are still valid.
1216
 
1217
      Kill_Current_Values (Last_Assignment_Only => True);
1218
   end Analyze_Exit_Statement;
1219
 
1220
   ----------------------------
1221
   -- Analyze_Goto_Statement --
1222
   ----------------------------
1223
 
1224
   procedure Analyze_Goto_Statement (N : Node_Id) is
1225
      Label       : constant Node_Id := Name (N);
1226
      Scope_Id    : Entity_Id;
1227
      Label_Scope : Entity_Id;
1228
      Label_Ent   : Entity_Id;
1229
 
1230
   begin
1231
      Check_Unreachable_Code (N);
1232
      Kill_Current_Values (Last_Assignment_Only => True);
1233
 
1234
      Analyze (Label);
1235
      Label_Ent := Entity (Label);
1236
 
1237
      --  Ignore previous error
1238
 
1239
      if Label_Ent = Any_Id then
1240
         return;
1241
 
1242
      --  We just have a label as the target of a goto
1243
 
1244
      elsif Ekind (Label_Ent) /= E_Label then
1245
         Error_Msg_N ("target of goto statement must be a label", Label);
1246
         return;
1247
 
1248
      --  Check that the target of the goto is reachable according to Ada
1249
      --  scoping rules. Note: the special gotos we generate for optimizing
1250
      --  local handling of exceptions would violate these rules, but we mark
1251
      --  such gotos as analyzed when built, so this code is never entered.
1252
 
1253
      elsif not Reachable (Label_Ent) then
1254
         Error_Msg_N ("target of goto statement is not reachable", Label);
1255
         return;
1256
      end if;
1257
 
1258
      --  Here if goto passes initial validity checks
1259
 
1260
      Label_Scope := Enclosing_Scope (Label_Ent);
1261
 
1262
      for J in reverse 0 .. Scope_Stack.Last loop
1263
         Scope_Id := Scope_Stack.Table (J).Entity;
1264
 
1265
         if Label_Scope = Scope_Id
1266
           or else (Ekind (Scope_Id) /= E_Block
1267
                     and then Ekind (Scope_Id) /= E_Loop
1268
                     and then Ekind (Scope_Id) /= E_Return_Statement)
1269
         then
1270
            if Scope_Id /= Label_Scope then
1271
               Error_Msg_N
1272
                 ("cannot exit from program unit or accept statement", N);
1273
            end if;
1274
 
1275
            return;
1276
         end if;
1277
      end loop;
1278
 
1279
      raise Program_Error;
1280
   end Analyze_Goto_Statement;
1281
 
1282
   --------------------------
1283
   -- Analyze_If_Statement --
1284
   --------------------------
1285
 
1286
   --  A special complication arises in the analysis of if statements
1287
 
1288
   --  The expander has circuitry to completely delete code that it
1289
   --  can tell will not be executed (as a result of compile time known
1290
   --  conditions). In the analyzer, we ensure that code that will be
1291
   --  deleted in this manner is analyzed but not expanded. This is
1292
   --  obviously more efficient, but more significantly, difficulties
1293
   --  arise if code is expanded and then eliminated (e.g. exception
1294
   --  table entries disappear). Similarly, itypes generated in deleted
1295
   --  code must be frozen from start, because the nodes on which they
1296
   --  depend will not be available at the freeze point.
1297
 
1298
   procedure Analyze_If_Statement (N : Node_Id) is
1299
      E : Node_Id;
1300
 
1301
      Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
1302
      --  Recursively save value of this global, will be restored on exit
1303
 
1304
      Save_In_Deleted_Code : Boolean;
1305
 
1306
      Del : Boolean := False;
1307
      --  This flag gets set True if a True condition has been found,
1308
      --  which means that remaining ELSE/ELSIF parts are deleted.
1309
 
1310
      procedure Analyze_Cond_Then (Cnode : Node_Id);
1311
      --  This is applied to either the N_If_Statement node itself or
1312
      --  to an N_Elsif_Part node. It deals with analyzing the condition
1313
      --  and the THEN statements associated with it.
1314
 
1315
      -----------------------
1316
      -- Analyze_Cond_Then --
1317
      -----------------------
1318
 
1319
      procedure Analyze_Cond_Then (Cnode : Node_Id) is
1320
         Cond : constant Node_Id := Condition (Cnode);
1321
         Tstm : constant List_Id := Then_Statements (Cnode);
1322
 
1323
      begin
1324
         Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
1325
         Analyze_And_Resolve (Cond, Any_Boolean);
1326
         Check_Unset_Reference (Cond);
1327
         Set_Current_Value_Condition (Cnode);
1328
 
1329
         --  If already deleting, then just analyze then statements
1330
 
1331
         if Del then
1332
            Analyze_Statements (Tstm);
1333
 
1334
         --  Compile time known value, not deleting yet
1335
 
1336
         elsif Compile_Time_Known_Value (Cond) then
1337
            Save_In_Deleted_Code := In_Deleted_Code;
1338
 
1339
            --  If condition is True, then analyze the THEN statements
1340
            --  and set no expansion for ELSE and ELSIF parts.
1341
 
1342
            if Is_True (Expr_Value (Cond)) then
1343
               Analyze_Statements (Tstm);
1344
               Del := True;
1345
               Expander_Mode_Save_And_Set (False);
1346
               In_Deleted_Code := True;
1347
 
1348
            --  If condition is False, analyze THEN with expansion off
1349
 
1350
            else -- Is_False (Expr_Value (Cond))
1351
               Expander_Mode_Save_And_Set (False);
1352
               In_Deleted_Code := True;
1353
               Analyze_Statements (Tstm);
1354
               Expander_Mode_Restore;
1355
               In_Deleted_Code := Save_In_Deleted_Code;
1356
            end if;
1357
 
1358
         --  Not known at compile time, not deleting, normal analysis
1359
 
1360
         else
1361
            Analyze_Statements (Tstm);
1362
         end if;
1363
      end Analyze_Cond_Then;
1364
 
1365
   --  Start of Analyze_If_Statement
1366
 
1367
   begin
1368
      --  Initialize exit count for else statements. If there is no else
1369
      --  part, this count will stay non-zero reflecting the fact that the
1370
      --  uncovered else case is an unblocked exit.
1371
 
1372
      Unblocked_Exit_Count := 1;
1373
      Analyze_Cond_Then (N);
1374
 
1375
      --  Now to analyze the elsif parts if any are present
1376
 
1377
      if Present (Elsif_Parts (N)) then
1378
         E := First (Elsif_Parts (N));
1379
         while Present (E) loop
1380
            Analyze_Cond_Then (E);
1381
            Next (E);
1382
         end loop;
1383
      end if;
1384
 
1385
      if Present (Else_Statements (N)) then
1386
         Analyze_Statements (Else_Statements (N));
1387
      end if;
1388
 
1389
      --  If all our exits were blocked by unconditional transfers of control,
1390
      --  then the entire IF statement acts as an unconditional transfer of
1391
      --  control, so treat it like one, and check unreachable code.
1392
 
1393
      if Unblocked_Exit_Count = 0 then
1394
         Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1395
         Check_Unreachable_Code (N);
1396
      else
1397
         Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1398
      end if;
1399
 
1400
      if Del then
1401
         Expander_Mode_Restore;
1402
         In_Deleted_Code := Save_In_Deleted_Code;
1403
      end if;
1404
 
1405
      if not Expander_Active
1406
        and then Compile_Time_Known_Value (Condition (N))
1407
        and then Serious_Errors_Detected = 0
1408
      then
1409
         if Is_True (Expr_Value (Condition (N))) then
1410
            Remove_Warning_Messages (Else_Statements (N));
1411
 
1412
            if Present (Elsif_Parts (N)) then
1413
               E := First (Elsif_Parts (N));
1414
               while Present (E) loop
1415
                  Remove_Warning_Messages (Then_Statements (E));
1416
                  Next (E);
1417
               end loop;
1418
            end if;
1419
 
1420
         else
1421
            Remove_Warning_Messages (Then_Statements (N));
1422
         end if;
1423
      end if;
1424
   end Analyze_If_Statement;
1425
 
1426
   ----------------------------------------
1427
   -- Analyze_Implicit_Label_Declaration --
1428
   ----------------------------------------
1429
 
1430
   --  An implicit label declaration is generated in the innermost
1431
   --  enclosing declarative part. This is done for labels as well as
1432
   --  block and loop names.
1433
 
1434
   --  Note: any changes in this routine may need to be reflected in
1435
   --  Analyze_Label_Entity.
1436
 
1437
   procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is
1438
      Id : constant Node_Id := Defining_Identifier (N);
1439
   begin
1440
      Enter_Name          (Id);
1441
      Set_Ekind           (Id, E_Label);
1442
      Set_Etype           (Id, Standard_Void_Type);
1443
      Set_Enclosing_Scope (Id, Current_Scope);
1444
   end Analyze_Implicit_Label_Declaration;
1445
 
1446
   ------------------------------
1447
   -- Analyze_Iteration_Scheme --
1448
   ------------------------------
1449
 
1450
   procedure Analyze_Iteration_Scheme (N : Node_Id) is
1451
 
1452
      procedure Process_Bounds (R : Node_Id);
1453
      --  If the iteration is given by a range, create temporaries and
1454
      --  assignment statements block to capture the bounds and perform
1455
      --  required finalization actions in case a bound includes a function
1456
      --  call that uses the temporary stack. We first pre-analyze a copy of
1457
      --  the range in order to determine the expected type, and analyze and
1458
      --  resolve the original bounds.
1459
 
1460
      procedure Check_Controlled_Array_Attribute (DS : Node_Id);
1461
      --  If the bounds are given by a 'Range reference on a function call
1462
      --  that returns a controlled array, introduce an explicit declaration
1463
      --  to capture the bounds, so that the function result can be finalized
1464
      --  in timely fashion.
1465
 
1466
      --------------------
1467
      -- Process_Bounds --
1468
      --------------------
1469
 
1470
      procedure Process_Bounds (R : Node_Id) is
1471
         Loc          : constant Source_Ptr := Sloc (N);
1472
         R_Copy       : constant Node_Id := New_Copy_Tree (R);
1473
         Lo           : constant Node_Id := Low_Bound  (R);
1474
         Hi           : constant Node_Id := High_Bound (R);
1475
         New_Lo_Bound : Node_Id := Empty;
1476
         New_Hi_Bound : Node_Id := Empty;
1477
         Typ          : Entity_Id;
1478
         Save_Analysis : Boolean;
1479
 
1480
         function One_Bound
1481
           (Original_Bound : Node_Id;
1482
            Analyzed_Bound : Node_Id) return Node_Id;
1483
         --  Capture value of bound and return captured value
1484
 
1485
         ---------------
1486
         -- One_Bound --
1487
         ---------------
1488
 
1489
         function One_Bound
1490
           (Original_Bound : Node_Id;
1491
            Analyzed_Bound : Node_Id) return Node_Id
1492
         is
1493
            Assign : Node_Id;
1494
            Id     : Entity_Id;
1495
            Decl   : Node_Id;
1496
 
1497
         begin
1498
            --  If the bound is a constant or an object, no need for a separate
1499
            --  declaration. If the bound is the result of previous expansion
1500
            --  it is already analyzed and should not be modified. Note that
1501
            --  the Bound will be resolved later, if needed, as part of the
1502
            --  call to Make_Index (literal bounds may need to be resolved to
1503
            --  type Integer).
1504
 
1505
            if Analyzed (Original_Bound) then
1506
               return Original_Bound;
1507
 
1508
            elsif Nkind_In (Analyzed_Bound, N_Integer_Literal,
1509
                                            N_Character_Literal)
1510
              or else Is_Entity_Name (Analyzed_Bound)
1511
            then
1512
               Analyze_And_Resolve (Original_Bound, Typ);
1513
               return Original_Bound;
1514
            end if;
1515
 
1516
            --  Here we need to capture the value
1517
 
1518
            Analyze_And_Resolve (Original_Bound, Typ);
1519
 
1520
            Id :=
1521
              Make_Defining_Identifier (Loc,
1522
                Chars => New_Internal_Name ('S'));
1523
 
1524
            --  Normally, the best approach is simply to generate a constant
1525
            --  declaration that captures the bound. However, there is a nasty
1526
            --  case where this is wrong. If the bound is complex, and has a
1527
            --  possible use of the secondary stack, we need to generate a
1528
            --  separate assignment statement to ensure the creation of a block
1529
            --  which will release the secondary stack.
1530
 
1531
            --  We prefer the constant declaration, since it leaves us with a
1532
            --  proper trace of the value, useful in optimizations that get rid
1533
            --  of junk range checks.
1534
 
1535
            --  Probably we want something like the Side_Effect_Free routine
1536
            --  in Exp_Util, but for now, we just optimize the cases of 'Last
1537
            --  and 'First applied to an entity, since these are the important
1538
            --  cases for range check optimizations.
1539
 
1540
            if Nkind (Original_Bound) = N_Attribute_Reference
1541
              and then (Attribute_Name (Original_Bound) = Name_First
1542
                          or else
1543
                        Attribute_Name (Original_Bound) = Name_Last)
1544
              and then Is_Entity_Name (Prefix (Original_Bound))
1545
            then
1546
               Decl :=
1547
                 Make_Object_Declaration (Loc,
1548
                   Defining_Identifier => Id,
1549
                   Constant_Present    => True,
1550
                   Object_Definition   => New_Occurrence_Of (Typ, Loc),
1551
                   Expression          => Relocate_Node (Original_Bound));
1552
 
1553
               Insert_Before (Parent (N), Decl);
1554
               Analyze (Decl);
1555
               Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
1556
               return Expression (Decl);
1557
            end if;
1558
 
1559
            --  Here we make a declaration with a separate assignment statement
1560
 
1561
            Decl :=
1562
              Make_Object_Declaration (Loc,
1563
                Defining_Identifier => Id,
1564
                Object_Definition   => New_Occurrence_Of (Typ, Loc));
1565
 
1566
            Insert_Before (Parent (N), Decl);
1567
            Analyze (Decl);
1568
 
1569
            Assign :=
1570
              Make_Assignment_Statement (Loc,
1571
                Name        => New_Occurrence_Of (Id, Loc),
1572
                Expression  => Relocate_Node (Original_Bound));
1573
 
1574
            --  If the relocated node is a function call then check if some
1575
            --  SCIL node references it and needs readjustment.
1576
 
1577
            if Generate_SCIL
1578
              and then Nkind (Original_Bound) = N_Function_Call
1579
            then
1580
               Adjust_SCIL_Node (Original_Bound, Expression (Assign));
1581
            end if;
1582
 
1583
            Insert_Before (Parent (N), Assign);
1584
            Analyze (Assign);
1585
 
1586
            Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
1587
 
1588
            if Nkind (Assign) = N_Assignment_Statement then
1589
               return Expression (Assign);
1590
            else
1591
               return Original_Bound;
1592
            end if;
1593
         end One_Bound;
1594
 
1595
      --  Start of processing for Process_Bounds
1596
 
1597
      begin
1598
         --  Determine expected type of range by analyzing separate copy
1599
         --  Do the analysis and resolution of the copy of the bounds with
1600
         --  expansion disabled, to prevent the generation of finalization
1601
         --  actions on each bound. This prevents memory leaks when the
1602
         --  bounds contain calls to functions returning controlled arrays.
1603
 
1604
         Set_Parent (R_Copy, Parent (R));
1605
         Save_Analysis := Full_Analysis;
1606
         Full_Analysis := False;
1607
         Expander_Mode_Save_And_Set (False);
1608
 
1609
         Analyze (R_Copy);
1610
 
1611
         if Is_Overloaded (R_Copy) then
1612
 
1613
            --  Apply preference rules for range of predefined integer types,
1614
            --  or diagnose true ambiguity.
1615
 
1616
            declare
1617
               I     : Interp_Index;
1618
               It    : Interp;
1619
               Found : Entity_Id := Empty;
1620
 
1621
            begin
1622
               Get_First_Interp (R_Copy, I, It);
1623
               while Present (It.Typ) loop
1624
                  if Is_Discrete_Type (It.Typ) then
1625
                     if No (Found) then
1626
                        Found := It.Typ;
1627
                     else
1628
                        if Scope (Found) = Standard_Standard then
1629
                           null;
1630
 
1631
                        elsif Scope (It.Typ) = Standard_Standard then
1632
                           Found := It.Typ;
1633
 
1634
                        else
1635
                           --  Both of them are user-defined
1636
 
1637
                           Error_Msg_N
1638
                             ("ambiguous bounds in range of iteration",
1639
                               R_Copy);
1640
                           Error_Msg_N ("\possible interpretations:", R_Copy);
1641
                           Error_Msg_NE ("\\} ", R_Copy, Found);
1642
                           Error_Msg_NE ("\\} ", R_Copy, It.Typ);
1643
                           exit;
1644
                        end if;
1645
                     end if;
1646
                  end if;
1647
 
1648
                  Get_Next_Interp (I, It);
1649
               end loop;
1650
            end;
1651
         end if;
1652
 
1653
         Resolve (R_Copy);
1654
         Expander_Mode_Restore;
1655
         Full_Analysis := Save_Analysis;
1656
 
1657
         Typ := Etype (R_Copy);
1658
 
1659
         --  If the type of the discrete range is Universal_Integer, then
1660
         --  the bound's type must be resolved to Integer, and any object
1661
         --  used to hold the bound must also have type Integer, unless the
1662
         --  literal bounds are constant-folded expressions that carry a user-
1663
         --  defined type.
1664
 
1665
         if Typ = Universal_Integer then
1666
            if Nkind (Lo) = N_Integer_Literal
1667
              and then Present (Etype (Lo))
1668
              and then Scope (Etype (Lo)) /= Standard_Standard
1669
            then
1670
               Typ := Etype (Lo);
1671
 
1672
            elsif Nkind (Hi) = N_Integer_Literal
1673
              and then Present (Etype (Hi))
1674
              and then Scope (Etype (Hi)) /= Standard_Standard
1675
            then
1676
               Typ := Etype (Hi);
1677
 
1678
            else
1679
               Typ := Standard_Integer;
1680
            end if;
1681
         end if;
1682
 
1683
         Set_Etype (R, Typ);
1684
 
1685
         New_Lo_Bound := One_Bound (Lo, Low_Bound  (R_Copy));
1686
         New_Hi_Bound := One_Bound (Hi, High_Bound (R_Copy));
1687
 
1688
         --  Propagate staticness to loop range itself, in case the
1689
         --  corresponding subtype is static.
1690
 
1691
         if New_Lo_Bound /= Lo
1692
           and then Is_Static_Expression (New_Lo_Bound)
1693
         then
1694
            Rewrite  (Low_Bound (R), New_Copy (New_Lo_Bound));
1695
         end if;
1696
 
1697
         if New_Hi_Bound /= Hi
1698
           and then Is_Static_Expression (New_Hi_Bound)
1699
         then
1700
            Rewrite (High_Bound (R), New_Copy (New_Hi_Bound));
1701
         end if;
1702
      end Process_Bounds;
1703
 
1704
      --------------------------------------
1705
      -- Check_Controlled_Array_Attribute --
1706
      --------------------------------------
1707
 
1708
      procedure Check_Controlled_Array_Attribute (DS : Node_Id) is
1709
      begin
1710
         if Nkind (DS) = N_Attribute_Reference
1711
            and then Is_Entity_Name (Prefix (DS))
1712
            and then Ekind (Entity (Prefix (DS))) = E_Function
1713
            and then Is_Array_Type (Etype (Entity (Prefix (DS))))
1714
            and then
1715
              Is_Controlled (
1716
                Component_Type (Etype (Entity (Prefix (DS)))))
1717
            and then Expander_Active
1718
         then
1719
            declare
1720
               Loc  : constant Source_Ptr := Sloc (N);
1721
               Arr  : constant Entity_Id :=
1722
                        Etype (Entity (Prefix (DS)));
1723
               Indx : constant Entity_Id :=
1724
                        Base_Type (Etype (First_Index (Arr)));
1725
               Subt : constant Entity_Id :=
1726
                        Make_Defining_Identifier
1727
                          (Loc, New_Internal_Name ('S'));
1728
               Decl : Node_Id;
1729
 
1730
            begin
1731
               Decl :=
1732
                 Make_Subtype_Declaration (Loc,
1733
                   Defining_Identifier => Subt,
1734
                   Subtype_Indication  =>
1735
                      Make_Subtype_Indication (Loc,
1736
                        Subtype_Mark  => New_Reference_To (Indx, Loc),
1737
                        Constraint =>
1738
                          Make_Range_Constraint (Loc,
1739
                            Relocate_Node (DS))));
1740
               Insert_Before (Parent (N), Decl);
1741
               Analyze (Decl);
1742
 
1743
               Rewrite (DS,
1744
                  Make_Attribute_Reference (Loc,
1745
                    Prefix => New_Reference_To (Subt, Loc),
1746
                    Attribute_Name => Attribute_Name (DS)));
1747
               Analyze (DS);
1748
            end;
1749
         end if;
1750
      end Check_Controlled_Array_Attribute;
1751
 
1752
   --  Start of processing for Analyze_Iteration_Scheme
1753
 
1754
   begin
1755
      --  For an infinite loop, there is no iteration scheme
1756
 
1757
      if No (N) then
1758
         return;
1759
 
1760
      else
1761
         declare
1762
            Cond : constant Node_Id := Condition (N);
1763
 
1764
         begin
1765
            --  For WHILE loop, verify that the condition is a Boolean
1766
            --  expression and resolve and check it.
1767
 
1768
            if Present (Cond) then
1769
               Analyze_And_Resolve (Cond, Any_Boolean);
1770
               Check_Unset_Reference (Cond);
1771
               Set_Current_Value_Condition (N);
1772
               return;
1773
 
1774
            --  Else we have a FOR loop
1775
 
1776
            else
1777
               declare
1778
                  LP : constant Node_Id   := Loop_Parameter_Specification (N);
1779
                  Id : constant Entity_Id := Defining_Identifier (LP);
1780
                  DS : constant Node_Id   := Discrete_Subtype_Definition (LP);
1781
 
1782
               begin
1783
                  Enter_Name (Id);
1784
 
1785
                  --  We always consider the loop variable to be referenced,
1786
                  --  since the loop may be used just for counting purposes.
1787
 
1788
                  Generate_Reference (Id, N, ' ');
1789
 
1790
                  --  Check for case of loop variable hiding a local
1791
                  --  variable (used later on to give a nice warning
1792
                  --  if the hidden variable is never assigned).
1793
 
1794
                  declare
1795
                     H : constant Entity_Id := Homonym (Id);
1796
                  begin
1797
                     if Present (H)
1798
                       and then Enclosing_Dynamic_Scope (H) =
1799
                                Enclosing_Dynamic_Scope (Id)
1800
                       and then Ekind (H) = E_Variable
1801
                       and then Is_Discrete_Type (Etype (H))
1802
                     then
1803
                        Set_Hiding_Loop_Variable (H, Id);
1804
                     end if;
1805
                  end;
1806
 
1807
                  --  Now analyze the subtype definition. If it is
1808
                  --  a range, create temporaries for bounds.
1809
 
1810
                  if Nkind (DS) = N_Range
1811
                    and then Expander_Active
1812
                  then
1813
                     Process_Bounds (DS);
1814
                  else
1815
                     Analyze (DS);
1816
                  end if;
1817
 
1818
                  if DS = Error then
1819
                     return;
1820
                  end if;
1821
 
1822
                  --  The subtype indication may denote the completion
1823
                  --  of an incomplete type declaration.
1824
 
1825
                  if Is_Entity_Name (DS)
1826
                    and then Present (Entity (DS))
1827
                    and then Is_Type (Entity (DS))
1828
                    and then Ekind (Entity (DS)) = E_Incomplete_Type
1829
                  then
1830
                     Set_Entity (DS, Get_Full_View (Entity (DS)));
1831
                     Set_Etype  (DS, Entity (DS));
1832
                  end if;
1833
 
1834
                  if not Is_Discrete_Type (Etype (DS)) then
1835
                     Wrong_Type (DS, Any_Discrete);
1836
                     Set_Etype (DS, Any_Type);
1837
                  end if;
1838
 
1839
                  Check_Controlled_Array_Attribute (DS);
1840
 
1841
                  Make_Index (DS, LP);
1842
 
1843
                  Set_Ekind          (Id, E_Loop_Parameter);
1844
                  Set_Etype          (Id, Etype (DS));
1845
 
1846
                  --  Treat a range as an implicit reference to the type, to
1847
                  --  inhibit spurious warnings.
1848
 
1849
                  Generate_Reference (Base_Type (Etype (DS)), N, ' ');
1850
                  Set_Is_Known_Valid (Id, True);
1851
 
1852
                  --  The loop is not a declarative part, so the only entity
1853
                  --  declared "within" must be frozen explicitly.
1854
 
1855
                  declare
1856
                     Flist : constant List_Id := Freeze_Entity (Id, Sloc (N));
1857
                  begin
1858
                     if Is_Non_Empty_List (Flist) then
1859
                        Insert_Actions (N, Flist);
1860
                     end if;
1861
                  end;
1862
 
1863
                  --  Check for null or possibly null range and issue warning.
1864
                  --  We suppress such messages in generic templates and
1865
                  --  instances, because in practice they tend to be dubious
1866
                  --  in these cases.
1867
 
1868
                  if Nkind (DS) = N_Range
1869
                    and then Comes_From_Source (N)
1870
                  then
1871
                     declare
1872
                        L : constant Node_Id := Low_Bound  (DS);
1873
                        H : constant Node_Id := High_Bound (DS);
1874
 
1875
                     begin
1876
                        --  If range of loop is null, issue warning
1877
 
1878
                        if Compile_Time_Compare
1879
                            (L, H, Assume_Valid => True) = GT
1880
                        then
1881
                           --  Suppress the warning if inside a generic
1882
                           --  template or instance, since in practice
1883
                           --  they tend to be dubious in these cases since
1884
                           --  they can result from intended parametrization.
1885
 
1886
                           if not Inside_A_Generic
1887
                              and then not In_Instance
1888
                           then
1889
                              --  Specialize msg if invalid values could make
1890
                              --  the loop non-null after all.
1891
 
1892
                              if Compile_Time_Compare
1893
                                   (L, H, Assume_Valid => False) = GT
1894
                              then
1895
                                 Error_Msg_N
1896
                                   ("?loop range is null, "
1897
                                    & "loop will not execute",
1898
                                    DS);
1899
 
1900
                                 --  Since we know the range of the loop is
1901
                                 --  null, set the appropriate flag to remove
1902
                                 --  the loop entirely during expansion.
1903
 
1904
                                 Set_Is_Null_Loop (Parent (N));
1905
 
1906
                              --  Here is where the loop could execute because
1907
                              --  of invalid values, so issue appropriate
1908
                              --  message and in this case we do not set the
1909
                              --  Is_Null_Loop flag since the loop may execute.
1910
 
1911
                              else
1912
                                 Error_Msg_N
1913
                                   ("?loop range may be null, "
1914
                                    & "loop may not execute",
1915
                                    DS);
1916
                                 Error_Msg_N
1917
                                   ("?can only execute if invalid values "
1918
                                    & "are present",
1919
                                    DS);
1920
                              end if;
1921
                           end if;
1922
 
1923
                           --  In either case, suppress warnings in the body of
1924
                           --  the loop, since it is likely that these warnings
1925
                           --  will be inappropriate if the loop never actually
1926
                           --  executes, which is unlikely.
1927
 
1928
                           Set_Suppress_Loop_Warnings (Parent (N));
1929
 
1930
                        --  The other case for a warning is a reverse loop
1931
                        --  where the upper bound is the integer literal
1932
                        --  zero or one, and the lower bound can be positive.
1933
 
1934
                        --  For example, we have
1935
 
1936
                        --     for J in reverse N .. 1 loop
1937
 
1938
                        --  In practice, this is very likely to be a case
1939
                        --  of reversing the bounds incorrectly in the range.
1940
 
1941
                        elsif Reverse_Present (LP)
1942
                          and then Nkind (Original_Node (H)) =
1943
                                                          N_Integer_Literal
1944
                          and then (Intval (Original_Node (H)) = Uint_0
1945
                                      or else
1946
                                    Intval (Original_Node (H)) = Uint_1)
1947
                        then
1948
                           Error_Msg_N ("?loop range may be null", DS);
1949
                           Error_Msg_N ("\?bounds may be wrong way round", DS);
1950
                        end if;
1951
                     end;
1952
                  end if;
1953
               end;
1954
            end if;
1955
         end;
1956
      end if;
1957
   end Analyze_Iteration_Scheme;
1958
 
1959
   -------------------
1960
   -- Analyze_Label --
1961
   -------------------
1962
 
1963
   --  Note: the semantic work required for analyzing labels (setting them as
1964
   --  reachable) was done in a prepass through the statements in the block,
1965
   --  so that forward gotos would be properly handled. See Analyze_Statements
1966
   --  for further details. The only processing required here is to deal with
1967
   --  optimizations that depend on an assumption of sequential control flow,
1968
   --  since of course the occurrence of a label breaks this assumption.
1969
 
1970
   procedure Analyze_Label (N : Node_Id) is
1971
      pragma Warnings (Off, N);
1972
   begin
1973
      Kill_Current_Values;
1974
   end Analyze_Label;
1975
 
1976
   --------------------------
1977
   -- Analyze_Label_Entity --
1978
   --------------------------
1979
 
1980
   procedure Analyze_Label_Entity (E : Entity_Id) is
1981
   begin
1982
      Set_Ekind           (E, E_Label);
1983
      Set_Etype           (E, Standard_Void_Type);
1984
      Set_Enclosing_Scope (E, Current_Scope);
1985
      Set_Reachable       (E, True);
1986
   end Analyze_Label_Entity;
1987
 
1988
   ----------------------------
1989
   -- Analyze_Loop_Statement --
1990
   ----------------------------
1991
 
1992
   procedure Analyze_Loop_Statement (N : Node_Id) is
1993
      Loop_Statement : constant Node_Id := N;
1994
 
1995
      Id   : constant Node_Id := Identifier (Loop_Statement);
1996
      Iter : constant Node_Id := Iteration_Scheme (Loop_Statement);
1997
      Ent  : Entity_Id;
1998
 
1999
   begin
2000
      if Present (Id) then
2001
 
2002
         --  Make name visible, e.g. for use in exit statements. Loop
2003
         --  labels are always considered to be referenced.
2004
 
2005
         Analyze (Id);
2006
         Ent := Entity (Id);
2007
 
2008
         --  Guard against serious error (typically, a scope mismatch when
2009
         --  semantic analysis is requested) by creating loop entity to
2010
         --  continue analysis.
2011
 
2012
         if No (Ent) then
2013
            if Total_Errors_Detected /= 0 then
2014
               Ent :=
2015
                 New_Internal_Entity
2016
                   (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L');
2017
            else
2018
               raise Program_Error;
2019
            end if;
2020
 
2021
         else
2022
            Generate_Reference  (Ent, Loop_Statement, ' ');
2023
            Generate_Definition (Ent);
2024
 
2025
            --  If we found a label, mark its type. If not, ignore it, since it
2026
            --  means we have a conflicting declaration, which would already
2027
            --  have been diagnosed at declaration time. Set Label_Construct
2028
            --  of the implicit label declaration, which is not created by the
2029
            --  parser for generic units.
2030
 
2031
            if Ekind (Ent) = E_Label then
2032
               Set_Ekind (Ent, E_Loop);
2033
 
2034
               if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
2035
                  Set_Label_Construct (Parent (Ent), Loop_Statement);
2036
               end if;
2037
            end if;
2038
         end if;
2039
 
2040
      --  Case of no identifier present
2041
 
2042
      else
2043
         Ent :=
2044
           New_Internal_Entity
2045
             (E_Loop, Current_Scope, Sloc (Loop_Statement), 'L');
2046
         Set_Etype (Ent,  Standard_Void_Type);
2047
         Set_Parent (Ent, Loop_Statement);
2048
      end if;
2049
 
2050
      --  Kill current values on entry to loop, since statements in body of
2051
      --  loop may have been executed before the loop is entered. Similarly we
2052
      --  kill values after the loop, since we do not know that the body of the
2053
      --  loop was executed.
2054
 
2055
      Kill_Current_Values;
2056
      Push_Scope (Ent);
2057
      Analyze_Iteration_Scheme (Iter);
2058
      Analyze_Statements (Statements (Loop_Statement));
2059
      Process_End_Label (Loop_Statement, 'e', Ent);
2060
      End_Scope;
2061
      Kill_Current_Values;
2062
 
2063
      --  Check for infinite loop. We skip this check for generated code, since
2064
      --  it justs waste time and makes debugging the routine called harder.
2065
 
2066
      if Comes_From_Source (N) then
2067
         Check_Infinite_Loop_Warning (N);
2068
      end if;
2069
 
2070
      --  Code after loop is unreachable if the loop has no WHILE or FOR
2071
      --  and contains no EXIT statements within the body of the loop.
2072
 
2073
      if No (Iter) and then not Has_Exit (Ent) then
2074
         Check_Unreachable_Code (N);
2075
      end if;
2076
   end Analyze_Loop_Statement;
2077
 
2078
   ----------------------------
2079
   -- Analyze_Null_Statement --
2080
   ----------------------------
2081
 
2082
   --  Note: the semantics of the null statement is implemented by a single
2083
   --  null statement, too bad everything isn't as simple as this!
2084
 
2085
   procedure Analyze_Null_Statement (N : Node_Id) is
2086
      pragma Warnings (Off, N);
2087
   begin
2088
      null;
2089
   end Analyze_Null_Statement;
2090
 
2091
   ------------------------
2092
   -- Analyze_Statements --
2093
   ------------------------
2094
 
2095
   procedure Analyze_Statements (L : List_Id) is
2096
      S   : Node_Id;
2097
      Lab : Entity_Id;
2098
 
2099
   begin
2100
      --  The labels declared in the statement list are reachable from
2101
      --  statements in the list. We do this as a prepass so that any
2102
      --  goto statement will be properly flagged if its target is not
2103
      --  reachable. This is not required, but is nice behavior!
2104
 
2105
      S := First (L);
2106
      while Present (S) loop
2107
         if Nkind (S) = N_Label then
2108
            Analyze (Identifier (S));
2109
            Lab := Entity (Identifier (S));
2110
 
2111
            --  If we found a label mark it as reachable
2112
 
2113
            if Ekind (Lab) = E_Label then
2114
               Generate_Definition (Lab);
2115
               Set_Reachable (Lab);
2116
 
2117
               if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then
2118
                  Set_Label_Construct (Parent (Lab), S);
2119
               end if;
2120
 
2121
            --  If we failed to find a label, it means the implicit declaration
2122
            --  of the label was hidden.  A for-loop parameter can do this to
2123
            --  a label with the same name inside the loop, since the implicit
2124
            --  label declaration is in the innermost enclosing body or block
2125
            --  statement.
2126
 
2127
            else
2128
               Error_Msg_Sloc := Sloc (Lab);
2129
               Error_Msg_N
2130
                 ("implicit label declaration for & is hidden#",
2131
                  Identifier (S));
2132
            end if;
2133
         end if;
2134
 
2135
         Next (S);
2136
      end loop;
2137
 
2138
      --  Perform semantic analysis on all statements
2139
 
2140
      Conditional_Statements_Begin;
2141
 
2142
      S := First (L);
2143
      while Present (S) loop
2144
         Analyze (S);
2145
         Next (S);
2146
      end loop;
2147
 
2148
      Conditional_Statements_End;
2149
 
2150
      --  Make labels unreachable. Visibility is not sufficient, because
2151
      --  labels in one if-branch for example are not reachable from the
2152
      --  other branch, even though their declarations are in the enclosing
2153
      --  declarative part.
2154
 
2155
      S := First (L);
2156
      while Present (S) loop
2157
         if Nkind (S) = N_Label then
2158
            Set_Reachable (Entity (Identifier (S)), False);
2159
         end if;
2160
 
2161
         Next (S);
2162
      end loop;
2163
   end Analyze_Statements;
2164
 
2165
   ----------------------------
2166
   -- Check_Unreachable_Code --
2167
   ----------------------------
2168
 
2169
   procedure Check_Unreachable_Code (N : Node_Id) is
2170
      Error_Loc : Source_Ptr;
2171
      P         : Node_Id;
2172
 
2173
   begin
2174
      if Is_List_Member (N)
2175
        and then Comes_From_Source (N)
2176
      then
2177
         declare
2178
            Nxt : Node_Id;
2179
 
2180
         begin
2181
            Nxt := Original_Node (Next (N));
2182
 
2183
            --  If a label follows us, then we never have dead code, since
2184
            --  someone could branch to the label, so we just ignore it.
2185
 
2186
            if Nkind (Nxt) = N_Label then
2187
               return;
2188
 
2189
            --  Otherwise see if we have a real statement following us
2190
 
2191
            elsif Present (Nxt)
2192
              and then Comes_From_Source (Nxt)
2193
              and then Is_Statement (Nxt)
2194
            then
2195
               --  Special very annoying exception. If we have a return that
2196
               --  follows a raise, then we allow it without a warning, since
2197
               --  the Ada RM annoyingly requires a useless return here!
2198
 
2199
               if Nkind (Original_Node (N)) /= N_Raise_Statement
2200
                 or else Nkind (Nxt) /= N_Simple_Return_Statement
2201
               then
2202
                  --  The rather strange shenanigans with the warning message
2203
                  --  here reflects the fact that Kill_Dead_Code is very good
2204
                  --  at removing warnings in deleted code, and this is one
2205
                  --  warning we would prefer NOT to have removed.
2206
 
2207
                  Error_Loc := Sloc (Nxt);
2208
 
2209
                  --  If we have unreachable code, analyze and remove the
2210
                  --  unreachable code, since it is useless and we don't
2211
                  --  want to generate junk warnings.
2212
 
2213
                  --  We skip this step if we are not in code generation mode.
2214
                  --  This is the one case where we remove dead code in the
2215
                  --  semantics as opposed to the expander, and we do not want
2216
                  --  to remove code if we are not in code generation mode,
2217
                  --  since this messes up the ASIS trees.
2218
 
2219
                  --  Note that one might react by moving the whole circuit to
2220
                  --  exp_ch5, but then we lose the warning in -gnatc mode.
2221
 
2222
                  if Operating_Mode = Generate_Code then
2223
                     loop
2224
                        Nxt := Next (N);
2225
 
2226
                        --  Quit deleting when we have nothing more to delete
2227
                        --  or if we hit a label (since someone could transfer
2228
                        --  control to a label, so we should not delete it).
2229
 
2230
                        exit when No (Nxt) or else Nkind (Nxt) = N_Label;
2231
 
2232
                        --  Statement/declaration is to be deleted
2233
 
2234
                        Analyze (Nxt);
2235
                        Remove (Nxt);
2236
                        Kill_Dead_Code (Nxt);
2237
                     end loop;
2238
                  end if;
2239
 
2240
                  --  Now issue the warning
2241
 
2242
                  Error_Msg ("?unreachable code!", Error_Loc);
2243
               end if;
2244
 
2245
            --  If the unconditional transfer of control instruction is
2246
            --  the last statement of a sequence, then see if our parent
2247
            --  is one of the constructs for which we count unblocked exits,
2248
            --  and if so, adjust the count.
2249
 
2250
            else
2251
               P := Parent (N);
2252
 
2253
               --  Statements in THEN part or ELSE part of IF statement
2254
 
2255
               if Nkind (P) = N_If_Statement then
2256
                  null;
2257
 
2258
               --  Statements in ELSIF part of an IF statement
2259
 
2260
               elsif Nkind (P) = N_Elsif_Part then
2261
                  P := Parent (P);
2262
                  pragma Assert (Nkind (P) = N_If_Statement);
2263
 
2264
               --  Statements in CASE statement alternative
2265
 
2266
               elsif Nkind (P) = N_Case_Statement_Alternative then
2267
                  P := Parent (P);
2268
                  pragma Assert (Nkind (P) = N_Case_Statement);
2269
 
2270
               --  Statements in body of block
2271
 
2272
               elsif Nkind (P) = N_Handled_Sequence_Of_Statements
2273
                 and then Nkind (Parent (P)) = N_Block_Statement
2274
               then
2275
                  null;
2276
 
2277
               --  Statements in exception handler in a block
2278
 
2279
               elsif Nkind (P) = N_Exception_Handler
2280
                 and then Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements
2281
                 and then Nkind (Parent (Parent (P))) = N_Block_Statement
2282
               then
2283
                  null;
2284
 
2285
               --  None of these cases, so return
2286
 
2287
               else
2288
                  return;
2289
               end if;
2290
 
2291
               --  This was one of the cases we are looking for (i.e. the
2292
               --  parent construct was IF, CASE or block) so decrement count.
2293
 
2294
               Unblocked_Exit_Count := Unblocked_Exit_Count - 1;
2295
            end if;
2296
         end;
2297
      end if;
2298
   end Check_Unreachable_Code;
2299
 
2300
end Sem_Ch5;

powered by: WebSVN 2.1.0

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