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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [sem_ch11.adb] - Blame information for rev 826

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 1 1                              --
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 Lib;      use Lib;
31
with Lib.Xref; use Lib.Xref;
32
with Namet;    use Namet;
33
with Nlists;   use Nlists;
34
with Nmake;    use Nmake;
35
with Opt;      use Opt;
36
with Restrict; use Restrict;
37
with Rident;   use Rident;
38
with Rtsfind;  use Rtsfind;
39
with Sem;      use Sem;
40
with Sem_Ch5;  use Sem_Ch5;
41
with Sem_Ch8;  use Sem_Ch8;
42
with Sem_Res;  use Sem_Res;
43
with Sem_Util; use Sem_Util;
44
with Sem_Warn; use Sem_Warn;
45
with Sinfo;    use Sinfo;
46
with Stand;    use Stand;
47
with Uintp;    use Uintp;
48
 
49
package body Sem_Ch11 is
50
 
51
   -----------------------------------
52
   -- Analyze_Exception_Declaration --
53
   -----------------------------------
54
 
55
   procedure Analyze_Exception_Declaration (N : Node_Id) is
56
      Id : constant Entity_Id := Defining_Identifier (N);
57
      PF : constant Boolean   := Is_Pure (Current_Scope);
58
   begin
59
      Generate_Definition         (Id);
60
      Enter_Name                  (Id);
61
      Set_Ekind                   (Id, E_Exception);
62
      Set_Exception_Code          (Id, Uint_0);
63
      Set_Etype                   (Id, Standard_Exception_Type);
64
      Set_Is_Statically_Allocated (Id);
65
      Set_Is_Pure                 (Id, PF);
66
   end Analyze_Exception_Declaration;
67
 
68
   --------------------------------
69
   -- Analyze_Exception_Handlers --
70
   --------------------------------
71
 
72
   procedure Analyze_Exception_Handlers (L : List_Id) is
73
      Handler : Node_Id;
74
      Choice  : Entity_Id;
75
      Id      : Node_Id;
76
      H_Scope : Entity_Id := Empty;
77
 
78
      procedure Check_Duplication (Id : Node_Id);
79
      --  Iterate through the identifiers in each handler to find duplicates
80
 
81
      function Others_Present return Boolean;
82
      --  Returns True if others handler is present
83
 
84
      -----------------------
85
      -- Check_Duplication --
86
      -----------------------
87
 
88
      procedure Check_Duplication (Id : Node_Id) is
89
         Handler   : Node_Id;
90
         Id1       : Node_Id;
91
         Id_Entity : Entity_Id := Entity (Id);
92
 
93
      begin
94
         if Present (Renamed_Entity (Id_Entity)) then
95
            Id_Entity := Renamed_Entity (Id_Entity);
96
         end if;
97
 
98
         Handler := First_Non_Pragma (L);
99
         while Present (Handler) loop
100
            Id1 := First (Exception_Choices (Handler));
101
            while Present (Id1) loop
102
 
103
               --  Only check against the exception choices which precede
104
               --  Id in the handler, since the ones that follow Id have not
105
               --  been analyzed yet and will be checked in a subsequent call.
106
 
107
               if Id = Id1 then
108
                  return;
109
 
110
               elsif Nkind (Id1) /= N_Others_Choice
111
                 and then
112
                   (Id_Entity = Entity (Id1)
113
                      or else (Id_Entity = Renamed_Entity (Entity (Id1))))
114
               then
115
                  if Handler /= Parent (Id) then
116
                     Error_Msg_Sloc := Sloc (Id1);
117
                     Error_Msg_NE
118
                       ("exception choice duplicates &#", Id, Id1);
119
 
120
                  else
121
                     if Ada_Version = Ada_83
122
                       and then Comes_From_Source (Id)
123
                     then
124
                        Error_Msg_N
125
                          ("(Ada 83): duplicate exception choice&", Id);
126
                     end if;
127
                  end if;
128
               end if;
129
 
130
               Next_Non_Pragma (Id1);
131
            end loop;
132
 
133
            Next (Handler);
134
         end loop;
135
      end Check_Duplication;
136
 
137
      --------------------
138
      -- Others_Present --
139
      --------------------
140
 
141
      function Others_Present return Boolean is
142
         H : Node_Id;
143
 
144
      begin
145
         H := First (L);
146
         while Present (H) loop
147
            if Nkind (H) /= N_Pragma
148
              and then Nkind (First (Exception_Choices (H))) = N_Others_Choice
149
            then
150
               return True;
151
            end if;
152
 
153
            Next (H);
154
         end loop;
155
 
156
         return False;
157
      end Others_Present;
158
 
159
   --  Start of processing for Analyze_Exception_Handlers
160
 
161
   begin
162
      Handler := First (L);
163
      Check_Restriction (No_Exceptions, Handler);
164
      Check_Restriction (No_Exception_Handlers, Handler);
165
 
166
      --  Kill current remembered values, since we don't know where we were
167
      --  when the exception was raised.
168
 
169
      Kill_Current_Values;
170
 
171
      --  Loop through handlers (which can include pragmas)
172
 
173
      while Present (Handler) loop
174
 
175
         --  If pragma just analyze it
176
 
177
         if Nkind (Handler) = N_Pragma then
178
            Analyze (Handler);
179
 
180
         --  Otherwise we have a real exception handler
181
 
182
         else
183
            --  Deal with choice parameter. The exception handler is a
184
            --  declarative part for the choice parameter, so it constitutes a
185
            --  scope for visibility purposes. We create an entity to denote
186
            --  the whole exception part, and use it as the scope of all the
187
            --  choices, which may even have the same name without conflict.
188
            --  This scope plays no other role in expansion or code generation.
189
 
190
            Choice := Choice_Parameter (Handler);
191
 
192
            if Present (Choice) then
193
               Set_Local_Raise_Not_OK (Handler);
194
 
195
               if Comes_From_Source (Choice) then
196
                  Check_Restriction (No_Exception_Propagation, Choice);
197
               end if;
198
 
199
               if No (H_Scope) then
200
                  H_Scope :=
201
                    New_Internal_Entity
202
                     (E_Block, Current_Scope, Sloc (Choice), 'E');
203
               end if;
204
 
205
               Push_Scope (H_Scope);
206
               Set_Etype (H_Scope, Standard_Void_Type);
207
 
208
               --  Set the Finalization Chain entity to Error means that it
209
               --  should not be used at that level but the parent one should
210
               --  be used instead.
211
 
212
               --  ??? this usage needs documenting in Einfo/Exp_Ch7 ???
213
               --  ??? using Error for this non-error condition is nasty ???
214
 
215
               Set_Finalization_Chain_Entity (H_Scope, Error);
216
 
217
               Enter_Name (Choice);
218
               Set_Ekind (Choice, E_Variable);
219
 
220
               if RTE_Available (RE_Exception_Occurrence) then
221
                  Set_Etype (Choice, RTE (RE_Exception_Occurrence));
222
               end if;
223
 
224
               Generate_Definition (Choice);
225
 
226
               --  Indicate that choice has an initial value, since in effect
227
               --  this field is assigned an initial value by the exception.
228
               --  We also consider that it is modified in the source.
229
 
230
               Set_Has_Initial_Value (Choice, True);
231
               Set_Never_Set_In_Source (Choice, False);
232
            end if;
233
 
234
            Id := First (Exception_Choices (Handler));
235
            while Present (Id) loop
236
               if Nkind (Id) = N_Others_Choice then
237
                  if Present (Next (Id))
238
                    or else Present (Next (Handler))
239
                    or else Present (Prev (Id))
240
                  then
241
                     Error_Msg_N ("OTHERS must appear alone and last", Id);
242
                  end if;
243
 
244
               else
245
                  Analyze (Id);
246
 
247
                  --  In most cases the choice has already been analyzed in
248
                  --  Analyze_Handled_Statement_Sequence, in order to expand
249
                  --  local handlers. This advance analysis does not take into
250
                  --  account the case in which a choice has the same name as
251
                  --  the choice parameter of the handler, which may hide an
252
                  --  outer exception. This pathological case appears in ACATS
253
                  --  B80001_3.adb, and requires an explicit check to verify
254
                  --  that the id is not hidden.
255
 
256
                  if not Is_Entity_Name (Id)
257
                    or else Ekind (Entity (Id)) /= E_Exception
258
                    or else
259
                      (Nkind (Id) = N_Identifier
260
                        and then Chars (Id) = Chars (Choice))
261
                  then
262
                     Error_Msg_N ("exception name expected", Id);
263
 
264
                  else
265
                     --  Emit a warning at the declaration level when a local
266
                     --  exception is never raised explicitly.
267
 
268
                     if Warn_On_Redundant_Constructs
269
                       and then not Is_Raised (Entity (Id))
270
                       and then Scope (Entity (Id)) = Current_Scope
271
                     then
272
                        Error_Msg_NE
273
                          ("?exception & is never raised", Entity (Id), Id);
274
                     end if;
275
 
276
                     if Present (Renamed_Entity (Entity (Id))) then
277
                        if Entity (Id) = Standard_Numeric_Error then
278
                           Check_Restriction (No_Obsolescent_Features, Id);
279
 
280
                           if Warn_On_Obsolescent_Feature then
281
                              Error_Msg_N
282
                                ("Numeric_Error is an " &
283
                                 "obsolescent feature (RM J.6(1))?", Id);
284
                              Error_Msg_N
285
                                ("\use Constraint_Error instead?", Id);
286
                           end if;
287
                        end if;
288
                     end if;
289
 
290
                     Check_Duplication (Id);
291
 
292
                     --  Check for exception declared within generic formal
293
                     --  package (which is illegal, see RM 11.2(8))
294
 
295
                     declare
296
                        Ent  : Entity_Id := Entity (Id);
297
                        Scop : Entity_Id;
298
 
299
                     begin
300
                        if Present (Renamed_Entity (Ent)) then
301
                           Ent := Renamed_Entity (Ent);
302
                        end if;
303
 
304
                        Scop := Scope (Ent);
305
                        while Scop /= Standard_Standard
306
                          and then Ekind (Scop) = E_Package
307
                        loop
308
                           if Nkind (Declaration_Node (Scop)) =
309
                                           N_Package_Specification
310
                             and then
311
                               Nkind (Original_Node (Parent
312
                                 (Declaration_Node (Scop)))) =
313
                                           N_Formal_Package_Declaration
314
                           then
315
                              Error_Msg_NE
316
                                ("exception& is declared in "  &
317
                                 "generic formal package", Id, Ent);
318
                              Error_Msg_N
319
                                ("\and therefore cannot appear in " &
320
                                 "handler (RM 11.2(8))", Id);
321
                              exit;
322
 
323
                           --  If the exception is declared in an inner
324
                           --  instance, nothing else to check.
325
 
326
                           elsif Is_Generic_Instance (Scop) then
327
                              exit;
328
                           end if;
329
 
330
                           Scop := Scope (Scop);
331
                        end loop;
332
                     end;
333
                  end if;
334
               end if;
335
 
336
               Next (Id);
337
            end loop;
338
 
339
            --  Check for redundant handler (has only raise statement) and is
340
            --  either an others handler, or is a specific handler when no
341
            --  others handler is present.
342
 
343
            if Warn_On_Redundant_Constructs
344
              and then List_Length (Statements (Handler)) = 1
345
              and then Nkind (First (Statements (Handler))) = N_Raise_Statement
346
              and then No (Name (First (Statements (Handler))))
347
              and then (not Others_Present
348
                          or else Nkind (First (Exception_Choices (Handler))) =
349
                                              N_Others_Choice)
350
            then
351
               Error_Msg_N
352
                 ("useless handler contains only a reraise statement?",
353
                  Handler);
354
            end if;
355
 
356
            --  Now analyze the statements of this handler
357
 
358
            Analyze_Statements (Statements (Handler));
359
 
360
            --  If a choice was present, we created a special scope for it,
361
            --  so this is where we pop that special scope to get rid of it.
362
 
363
            if Present (Choice) then
364
               End_Scope;
365
            end if;
366
         end if;
367
 
368
         Next (Handler);
369
      end loop;
370
   end Analyze_Exception_Handlers;
371
 
372
   --------------------------------
373
   -- Analyze_Handled_Statements --
374
   --------------------------------
375
 
376
   procedure Analyze_Handled_Statements (N : Node_Id) is
377
      Handlers : constant List_Id := Exception_Handlers (N);
378
      Handler  : Node_Id;
379
      Choice   : Node_Id;
380
 
381
   begin
382
      if Present (Handlers) then
383
         Kill_All_Checks;
384
      end if;
385
 
386
      --  We are now going to analyze the statements and then the exception
387
      --  handlers. We certainly need to do things in this order to get the
388
      --  proper sequential semantics for various warnings.
389
 
390
      --  However, there is a glitch. When we process raise statements, an
391
      --  optimization is to look for local handlers and specialize the code
392
      --  in this case.
393
 
394
      --  In order to detect if a handler is matching, we must have at least
395
      --  analyzed the choices in the proper scope so that proper visibility
396
      --  analysis is performed. Hence we analyze just the choices first,
397
      --  before we analyze the statement sequence.
398
 
399
      Handler := First_Non_Pragma (Handlers);
400
      while Present (Handler) loop
401
         Choice := First_Non_Pragma (Exception_Choices (Handler));
402
         while Present (Choice) loop
403
            Analyze (Choice);
404
            Next_Non_Pragma (Choice);
405
         end loop;
406
 
407
         Next_Non_Pragma (Handler);
408
      end loop;
409
 
410
      --  Analyze statements in sequence
411
 
412
      Analyze_Statements (Statements (N));
413
 
414
      --  If the current scope is a subprogram, then this is the right place to
415
      --  check for hanging useless assignments from the statement sequence of
416
      --  the subprogram body.
417
 
418
      if Is_Subprogram (Current_Scope) then
419
         Warn_On_Useless_Assignments (Current_Scope);
420
      end if;
421
 
422
      --  Deal with handlers or AT END proc
423
 
424
      if Present (Handlers) then
425
         Analyze_Exception_Handlers (Handlers);
426
      elsif Present (At_End_Proc (N)) then
427
         Analyze (At_End_Proc (N));
428
      end if;
429
   end Analyze_Handled_Statements;
430
 
431
   -----------------------------
432
   -- Analyze_Raise_Statement --
433
   -----------------------------
434
 
435
   procedure Analyze_Raise_Statement (N : Node_Id) is
436
      Exception_Id   : constant Node_Id := Name (N);
437
      Exception_Name : Entity_Id        := Empty;
438
      P              : Node_Id;
439
 
440
   begin
441
      Check_Unreachable_Code (N);
442
 
443
      --  Check exception restrictions on the original source
444
 
445
      if Comes_From_Source (N) then
446
         Check_Restriction (No_Exceptions, N);
447
      end if;
448
 
449
      --  Check for useless assignment to OUT or IN OUT scalar immediately
450
      --  preceding the raise. Right now we only look at assignment statements,
451
      --  we could do more.
452
 
453
      if Is_List_Member (N) then
454
         declare
455
            P : Node_Id;
456
            L : Node_Id;
457
 
458
         begin
459
            P := Prev (N);
460
 
461
            if Present (P)
462
              and then Nkind (P) = N_Assignment_Statement
463
            then
464
               L := Name (P);
465
 
466
               if Is_Scalar_Type (Etype (L))
467
                 and then Is_Entity_Name (L)
468
                 and then Is_Formal (Entity (L))
469
               then
470
                  Error_Msg_N
471
                    ("?assignment to pass-by-copy formal may have no effect",
472
                      P);
473
                  Error_Msg_N
474
                    ("\?RAISE statement may result in abnormal return" &
475
                     " (RM 6.4.1(17))", P);
476
               end if;
477
            end if;
478
         end;
479
      end if;
480
 
481
      --  Reraise statement
482
 
483
      if No (Exception_Id) then
484
         P := Parent (N);
485
         while not Nkind_In (P, N_Exception_Handler,
486
                                N_Subprogram_Body,
487
                                N_Package_Body,
488
                                N_Task_Body,
489
                                N_Entry_Body)
490
         loop
491
            P := Parent (P);
492
         end loop;
493
 
494
         if Nkind (P) /= N_Exception_Handler then
495
            Error_Msg_N
496
              ("reraise statement must appear directly in a handler", N);
497
 
498
         --  If a handler has a reraise, it cannot be the target of a local
499
         --  raise (goto optimization is impossible), and if the no exception
500
         --  propagation restriction is set, this is a violation.
501
 
502
         else
503
            Set_Local_Raise_Not_OK (P);
504
 
505
            --  Do not check the restriction if the reraise statement is part
506
            --  of the code generated for an AT-END handler. That's because
507
            --  if the restriction is actually active, we never generate this
508
            --  raise anyway, so the apparent violation is bogus.
509
 
510
            if not From_At_End (N) then
511
               Check_Restriction (No_Exception_Propagation, N);
512
            end if;
513
         end if;
514
 
515
      --  Normal case with exception id present
516
 
517
      else
518
         Analyze (Exception_Id);
519
 
520
         if Is_Entity_Name (Exception_Id) then
521
            Exception_Name := Entity (Exception_Id);
522
         end if;
523
 
524
         if No (Exception_Name)
525
           or else Ekind (Exception_Name) /= E_Exception
526
         then
527
            Error_Msg_N
528
              ("exception name expected in raise statement", Exception_Id);
529
         else
530
            Set_Is_Raised (Exception_Name);
531
         end if;
532
 
533
         --  Deal with RAISE WITH case
534
 
535
         if Present (Expression (N)) then
536
            Check_Compiler_Unit (Expression (N));
537
            Analyze_And_Resolve (Expression (N), Standard_String);
538
         end if;
539
      end if;
540
 
541
      Kill_Current_Values (Last_Assignment_Only => True);
542
   end Analyze_Raise_Statement;
543
 
544
   -----------------------------
545
   -- Analyze_Raise_xxx_Error --
546
   -----------------------------
547
 
548
   --  Normally, the Etype is already set (when this node is used within
549
   --  an expression, since it is copied from the node which it rewrites).
550
   --  If this node is used in a statement context, then we set the type
551
   --  Standard_Void_Type. This is used both by Gigi and by the front end
552
   --  to distinguish the statement use and the subexpression use.
553
 
554
   --  The only other required processing is to take care of the Condition
555
   --  field if one is present.
556
 
557
   procedure Analyze_Raise_xxx_Error (N : Node_Id) is
558
 
559
      function Same_Expression (C1, C2 : Node_Id) return Boolean;
560
      --  It often occurs that two identical raise statements are generated in
561
      --  succession (for example when dynamic elaboration checks take place on
562
      --  separate expressions in a call). If the two statements are identical
563
      --  according to the simple criterion that follows, the raise is
564
      --  converted into a null statement.
565
 
566
      ---------------------
567
      -- Same_Expression --
568
      ---------------------
569
 
570
      function Same_Expression (C1, C2 : Node_Id) return Boolean is
571
      begin
572
         if No (C1) and then No (C2) then
573
            return True;
574
 
575
         elsif Is_Entity_Name (C1) and then Is_Entity_Name (C2) then
576
            return Entity (C1) = Entity (C2);
577
 
578
         elsif Nkind (C1) /= Nkind (C2) then
579
            return False;
580
 
581
         elsif Nkind (C1) in N_Unary_Op then
582
            return Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
583
 
584
         elsif Nkind (C1) in N_Binary_Op then
585
            return Same_Expression (Left_Opnd (C1), Left_Opnd (C2))
586
              and then Same_Expression (Right_Opnd (C1), Right_Opnd (C2));
587
 
588
         elsif Nkind (C1) = N_Null then
589
            return True;
590
 
591
         else
592
            return False;
593
         end if;
594
      end Same_Expression;
595
 
596
   --  Start of processing for Analyze_Raise_xxx_Error
597
 
598
   begin
599
      if No (Etype (N)) then
600
         Set_Etype (N, Standard_Void_Type);
601
      end if;
602
 
603
      if Present (Condition (N)) then
604
         Analyze_And_Resolve (Condition (N), Standard_Boolean);
605
      end if;
606
 
607
      --  Deal with static cases in obvious manner
608
 
609
      if Nkind (Condition (N)) = N_Identifier then
610
         if Entity (Condition (N)) = Standard_True then
611
            Set_Condition (N, Empty);
612
 
613
         elsif Entity (Condition (N)) = Standard_False then
614
            Rewrite (N, Make_Null_Statement (Sloc (N)));
615
         end if;
616
      end if;
617
 
618
      --  Remove duplicate raise statements. Note that the previous one may
619
      --  already have been removed as well.
620
 
621
      if not Comes_From_Source (N)
622
        and then Nkind (N) /= N_Null_Statement
623
        and then Is_List_Member (N)
624
        and then Present (Prev (N))
625
        and then Nkind (N) = Nkind (Original_Node (Prev (N)))
626
        and then Same_Expression
627
                   (Condition (N), Condition (Original_Node (Prev (N))))
628
      then
629
         Rewrite (N, Make_Null_Statement (Sloc (N)));
630
      end if;
631
   end Analyze_Raise_xxx_Error;
632
 
633
   -----------------------------
634
   -- Analyze_Subprogram_Info --
635
   -----------------------------
636
 
637
   procedure Analyze_Subprogram_Info (N : Node_Id) is
638
   begin
639
      Set_Etype (N, RTE (RE_Code_Loc));
640
   end Analyze_Subprogram_Info;
641
 
642
end Sem_Ch11;

powered by: WebSVN 2.1.0

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