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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                             E X P _ C H 1 1                              --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2012, 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 Casing;   use Casing;
28
with Debug;    use Debug;
29
with Einfo;    use Einfo;
30
with Elists;   use Elists;
31
with Errout;   use Errout;
32
with Exp_Ch7;  use Exp_Ch7;
33
with Exp_Util; use Exp_Util;
34
with Namet;    use Namet;
35
with Nlists;   use Nlists;
36
with Nmake;    use Nmake;
37
with Opt;      use Opt;
38
with Restrict; use Restrict;
39
with Rident;   use Rident;
40
with Rtsfind;  use Rtsfind;
41
with Sem;      use Sem;
42
with Sem_Ch8;  use Sem_Ch8;
43
with Sem_Res;  use Sem_Res;
44
with Sem_Util; use Sem_Util;
45
with Sinfo;    use Sinfo;
46
with Sinput;   use Sinput;
47
with Snames;   use Snames;
48
with Stand;    use Stand;
49
with Stringt;  use Stringt;
50
with Targparm; use Targparm;
51
with Tbuild;   use Tbuild;
52
with Uintp;    use Uintp;
53
 
54
package body Exp_Ch11 is
55
 
56
   -----------------------
57
   -- Local Subprograms --
58
   -----------------------
59
 
60
   procedure Warn_No_Exception_Propagation_Active (N : Node_Id);
61
   --  Generates warning that pragma Restrictions (No_Exception_Propagation)
62
   --  is in effect. Caller then generates appropriate continuation message.
63
   --  N is the node on which the warning is placed.
64
 
65
   procedure Warn_If_No_Propagation (N : Node_Id);
66
   --  Called for an exception raise that is not a local raise (and thus can
67
   --  not be optimized to a goto. Issues warning if No_Exception_Propagation
68
   --  restriction is set. N is the node for the raise or equivalent call.
69
 
70
   ---------------------------
71
   -- Expand_At_End_Handler --
72
   ---------------------------
73
 
74
   --  For a handled statement sequence that has a cleanup (At_End_Proc
75
   --  field set), an exception handler of the following form is required:
76
 
77
   --     exception
78
   --       when all others =>
79
   --          cleanup call
80
   --          raise;
81
 
82
   --  Note: this exception handler is treated rather specially by
83
   --  subsequent expansion in two respects:
84
 
85
   --    The normal call to Undefer_Abort is omitted
86
   --    The raise call does not do Defer_Abort
87
 
88
   --  This is because the current tasking code seems to assume that
89
   --  the call to the cleanup routine that is made from an exception
90
   --  handler for the abort signal is called with aborts deferred.
91
 
92
   --  This expansion is only done if we have front end exception handling.
93
   --  If we have back end exception handling, then the AT END handler is
94
   --  left alone, and cleanups (including the exceptional case) are handled
95
   --  by the back end.
96
 
97
   --  In the front end case, the exception handler described above handles
98
   --  the exceptional case. The AT END handler is left in the generated tree
99
   --  and the code generator (e.g. gigi) must still handle proper generation
100
   --  of cleanup calls for the non-exceptional case.
101
 
102
   procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is
103
      Clean   : constant Entity_Id  := Entity (At_End_Proc (HSS));
104
      Ohandle : Node_Id;
105
      Stmnts  : List_Id;
106
 
107
      Loc : constant Source_Ptr := No_Location;
108
      --  Location used for expansion. We quite deliberately do not set a
109
      --  specific source location for the expanded handler. This makes
110
      --  sense since really the handler is not associated with specific
111
      --  source. We used to set this to Sloc (Clean), but that caused
112
      --  useless and annoying bouncing around of line numbers in the
113
      --  debugger in some circumstances.
114
 
115
   begin
116
      pragma Assert (Present (Clean));
117
      pragma Assert (No (Exception_Handlers (HSS)));
118
 
119
      --  Don't expand if back end exception handling active
120
 
121
      if Exception_Mechanism = Back_End_Exceptions then
122
         return;
123
      end if;
124
 
125
      --  Don't expand an At End handler if we have already had configurable
126
      --  run-time violations, since likely this will just be a matter of
127
      --  generating useless cascaded messages
128
 
129
      if Configurable_Run_Time_Violations > 0 then
130
         return;
131
      end if;
132
 
133
      --  Don't expand an At End handler if we are not allowing exceptions
134
      --  or if exceptions are transformed into local gotos, and never
135
      --  propagated (No_Exception_Propagation).
136
 
137
      if No_Exception_Handlers_Set then
138
         return;
139
      end if;
140
 
141
      if Present (Block) then
142
         Push_Scope (Block);
143
      end if;
144
 
145
      Ohandle :=
146
        Make_Others_Choice (Loc);
147
      Set_All_Others (Ohandle);
148
 
149
      Stmnts := New_List (
150
        Make_Procedure_Call_Statement (Loc,
151
          Name => New_Occurrence_Of (Clean, Loc)));
152
 
153
      --  Generate reraise statement as last statement of AT-END handler,
154
      --  unless we are under control of No_Exception_Propagation, in which
155
      --  case no exception propagation is possible anyway, so we do not need
156
      --  a reraise (the AT END handler in this case is only for normal exits
157
      --  not for exceptional exits). Also, we flag the Reraise statement as
158
      --  being part of an AT END handler to prevent signalling this reraise
159
      --  as a violation of the restriction when it is not set.
160
 
161
      if not Restriction_Active (No_Exception_Propagation) then
162
         declare
163
            Rstm : constant Node_Id := Make_Raise_Statement (Loc);
164
         begin
165
            Set_From_At_End (Rstm);
166
            Append_To (Stmnts, Rstm);
167
         end;
168
      end if;
169
 
170
      Set_Exception_Handlers (HSS, New_List (
171
        Make_Implicit_Exception_Handler (Loc,
172
          Exception_Choices => New_List (Ohandle),
173
          Statements        => Stmnts)));
174
 
175
      Analyze_List (Stmnts, Suppress => All_Checks);
176
      Expand_Exception_Handlers (HSS);
177
 
178
      if Present (Block) then
179
         Pop_Scope;
180
      end if;
181
   end Expand_At_End_Handler;
182
 
183
   -------------------------------
184
   -- Expand_Exception_Handlers --
185
   -------------------------------
186
 
187
   procedure Expand_Exception_Handlers (HSS : Node_Id) is
188
      Handlrs       : constant List_Id    := Exception_Handlers (HSS);
189
      Loc           : constant Source_Ptr := Sloc (HSS);
190
      Handler       : Node_Id;
191
      Others_Choice : Boolean;
192
      Obj_Decl      : Node_Id;
193
      Next_Handler  : Node_Id;
194
 
195
      procedure Expand_Local_Exception_Handlers;
196
      --  This procedure handles the expansion of exception handlers for the
197
      --  optimization of local raise statements into goto statements.
198
 
199
      procedure Prepend_Call_To_Handler
200
        (Proc : RE_Id;
201
         Args : List_Id := No_List);
202
      --  Routine to prepend a call to the procedure referenced by Proc at
203
      --  the start of the handler code for the current Handler.
204
 
205
      procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id);
206
      --  Raise_S is a raise statement (possibly expanded, and possibly of the
207
      --  form of a Raise_xxx_Error node with a condition. This procedure is
208
      --  called to replace the raise action with the (already analyzed) goto
209
      --  statement passed as Goto_L1. This procedure also takes care of the
210
      --  requirement of inserting a Local_Raise call where possible.
211
 
212
      -------------------------------------
213
      -- Expand_Local_Exception_Handlers --
214
      -------------------------------------
215
 
216
      --  There are two cases for this transformation. First the case of
217
      --  explicit raise statements. For this case, the transformation we do
218
      --  looks like this. Right now we have for example (where L1, L2 are
219
      --  exception labels)
220
 
221
      --  begin
222
      --     ...
223
      --     raise_exception (excep1'identity);  -- was raise excep1
224
      --     ...
225
      --     raise_exception (excep2'identity);  -- was raise excep2
226
      --     ...
227
      --  exception
228
      --     when excep1 =>
229
      --        estmts1
230
      --     when excep2 =>
231
      --        estmts2
232
      --  end;
233
 
234
      --  This gets transformed into:
235
 
236
      --  begin
237
      --     L1 : label;                        -- marked Exception_Junk
238
      --     L2 : label;                        -- marked Exception_Junk
239
      --     L3 : label;                        -- marked Exception_Junk
240
 
241
      --     begin                              -- marked Exception_Junk
242
      --        ...
243
      --        local_raise (excep1'address);   -- was raise excep1
244
      --        goto L1;
245
      --        ...
246
      --        local_raise (excep2'address);   -- was raise excep2
247
      --        goto L2;
248
      --        ...
249
      --     exception
250
      --        when excep1 =>
251
      --           goto L1;
252
      --        when excep2 =>
253
      --           goto L2;
254
      --     end;
255
 
256
      --     goto L3;        -- skip handler if no raise, marked Exception_Junk
257
 
258
      --     <<L1>>          -- local excep target label, marked Exception_Junk
259
      --        begin        -- marked Exception_Junk
260
      --           estmts1
261
      --        end;
262
      --        goto L3;     -- marked Exception_Junk
263
 
264
      --     <<L2>>          -- marked Exception_Junk
265
      --        begin        -- marked Exception_Junk
266
      --           estmts2
267
      --        end;
268
      --        goto L3;     -- marked Exception_Junk
269
      --     <<L3>>          -- marked Exception_Junk
270
      --  end;
271
 
272
      --  Note: the reason we wrap the original statement sequence in an
273
      --  inner block is that there may be raise statements within the
274
      --  sequence of statements in the handlers, and we must ensure that
275
      --  these are properly handled, and in particular, such raise statements
276
      --  must not reenter the same exception handlers.
277
 
278
      --  If the restriction No_Exception_Propagation is in effect, then we
279
      --  can omit the exception handlers.
280
 
281
      --  begin
282
      --     L1 : label;                        -- marked Exception_Junk
283
      --     L2 : label;                        -- marked Exception_Junk
284
      --     L3 : label;                        -- marked Exception_Junk
285
 
286
      --     begin                              -- marked Exception_Junk
287
      --        ...
288
      --        local_raise (excep1'address);   -- was raise excep1
289
      --        goto L1;
290
      --        ...
291
      --        local_raise (excep2'address);   -- was raise excep2
292
      --        goto L2;
293
      --        ...
294
      --     end;
295
 
296
      --     goto L3;        -- skip handler if no raise, marked Exception_Junk
297
 
298
      --     <<L1>>          -- local excep target label, marked Exception_Junk
299
      --        begin        -- marked Exception_Junk
300
      --           estmts1
301
      --        end;
302
      --        goto L3;     -- marked Exception_Junk
303
 
304
      --     <<L2>>          -- marked Exception_Junk
305
      --        begin        -- marked Exception_Junk
306
      --           estmts2
307
      --        end;
308
 
309
      --     <<L3>>          -- marked Exception_Junk
310
      --  end;
311
 
312
      --  The second case is for exceptions generated by the back end in one
313
      --  of three situations:
314
 
315
      --    1. Front end generates N_Raise_xxx_Error node
316
      --    2. Front end sets Do_xxx_Check flag in subexpression node
317
      --    3. Back end detects a situation where an exception is appropriate
318
 
319
      --  In all these cases, the current processing in gigi is to generate a
320
      --  call to the appropriate Rcheck_xx routine (where xx encodes both the
321
      --  exception message and the exception to be raised, Constraint_Error,
322
      --  Program_Error, or Storage_Error.
323
 
324
      --  We could handle some subcases of 1 using the same front end expansion
325
      --  into gotos, but even for case 1, we can't handle all cases, since
326
      --  generating gotos in the middle of expressions is not possible (it's
327
      --  possible at the gigi/gcc level, but not at the level of the GNAT
328
      --  tree).
329
 
330
      --  In any case, it seems easier to have a scheme which handles all three
331
      --  cases in a uniform manner. So here is how we proceed in this case.
332
 
333
      --  This procedure detects all handlers for these three exceptions,
334
      --  Constraint_Error, Program_Error and Storage_Error (including WHEN
335
      --  OTHERS handlers that cover one or more of these cases).
336
 
337
      --  If the handler meets the requirements for being the target of a local
338
      --  raise, then the front end does the expansion described previously,
339
      --  creating a label to be used as a goto target to raise the exception.
340
      --  However, no attempt is made in the front end to convert any related
341
      --  raise statements into gotos, e.g. all N_Raise_xxx_Error nodes are
342
      --  left unchanged and passed to the back end.
343
 
344
      --  Instead, the front end generates three nodes
345
 
346
      --     N_Push_Constraint_Error_Label
347
      --     N_Push_Program_Error_Label
348
      --     N_Push_Storage_Error_Label
349
 
350
      --       The Push node is generated at the start of the statements
351
      --       covered by the handler, and has as a parameter the label to be
352
      --       used as the raise target.
353
 
354
      --     N_Pop_Constraint_Error_Label
355
      --     N_Pop_Program_Error_Label
356
      --     N_Pop_Storage_Error_Label
357
 
358
      --       The Pop node is generated at the end of the covered statements
359
      --       and undoes the effect of the preceding corresponding Push node.
360
 
361
      --  In the case where the handler does NOT meet the requirements, the
362
      --  front end will still generate the Push and Pop nodes, but the label
363
      --  field in the Push node will be empty signifying that for this region
364
      --  of code, no optimization is possible.
365
 
366
      --  These Push/Pop nodes are inhibited if No_Exception_Handlers is set
367
      --  since they are useless in this case, and in CodePeer mode, where
368
      --  they serve no purpose and can intefere with the analysis.
369
 
370
      --  The back end must maintain three stacks, one for each exception case,
371
      --  the Push node pushes an entry onto the corresponding stack, and Pop
372
      --  node pops off the entry. Then instead of calling Rcheck_nn, if the
373
      --  corresponding top stack entry has an non-empty label, a goto is
374
      --  generated. This goto should be preceded by a call to Local_Raise as
375
      --  described above.
376
 
377
      --  An example of this transformation is as follows, given:
378
 
379
      --  declare
380
      --    A : Integer range 1 .. 10;
381
      --  begin
382
      --    A := B + C;
383
      --  exception
384
      --    when Constraint_Error =>
385
      --       estmts
386
      --  end;
387
 
388
      --  gets transformed to:
389
 
390
      --  declare
391
      --    A : Integer range 1 .. 10;
392
 
393
      --  begin
394
      --     L1 : label;
395
      --     L2 : label;
396
 
397
      --     begin
398
      --        %push_constraint_error_label (L1)
399
      --        R1b : constant long_long_integer := long_long_integer?(b) +
400
      --          long_long_integer?(c);
401
      --        [constraint_error when
402
      --          not (R1b in -16#8000_0000# .. 16#7FFF_FFFF#)
403
      --          "overflow check failed"]
404
      --        a := integer?(R1b);
405
      --        %pop_constraint_error_Label
406
 
407
      --     exception
408
      --        ...
409
      --        when constraint_error =>
410
      --           goto L1;
411
      --     end;
412
 
413
      --     goto L2;       -- skip handler when exception not raised
414
      --     <<L1>>         -- target label for local exception
415
      --     estmts
416
      --     <<L2>>
417
      --  end;
418
 
419
      --  Note: the generated labels and goto statements all have the flag
420
      --  Exception_Junk set True, so that Sem_Ch6.Check_Returns will ignore
421
      --  this generated exception stuff when checking for missing return
422
      --  statements (see circuitry in Check_Statement_Sequence).
423
 
424
      --  Note: All of the processing described above occurs only if
425
      --  restriction No_Exception_Propagation applies or debug flag .g is
426
      --  enabled.
427
 
428
      CE_Locally_Handled : Boolean := False;
429
      SE_Locally_Handled : Boolean := False;
430
      PE_Locally_Handled : Boolean := False;
431
      --  These three flags indicate whether a handler for the corresponding
432
      --  exception (CE=Constraint_Error, SE=Storage_Error, PE=Program_Error)
433
      --  is present. If so the switch is set to True, the Exception_Label
434
      --  field of the corresponding handler is set, and appropriate Push
435
      --  and Pop nodes are inserted into the code.
436
 
437
      Local_Expansion_Required : Boolean := False;
438
      --  Set True if we have at least one handler requiring local raise
439
      --  expansion as described above.
440
 
441
      procedure Expand_Local_Exception_Handlers is
442
 
443
         procedure Add_Exception_Label (H : Node_Id);
444
         --  H is an exception handler. First check for an Exception_Label
445
         --  already allocated for H. If none, allocate one, set the field in
446
         --  the handler node, add the label declaration, and set the flag
447
         --  Local_Expansion_Required. Note: if Local_Raise_Not_OK is set
448
         --  the call has no effect and Exception_Label is left empty.
449
 
450
         procedure Add_Label_Declaration (L : Entity_Id);
451
         --  Add an implicit declaration of the given label to the declaration
452
         --  list in the parent of the current sequence of handled statements.
453
 
454
         generic
455
            Exc_Locally_Handled : in out Boolean;
456
            --  Flag indicating whether a local handler for this exception
457
            --  has already been generated.
458
 
459
            with function Make_Push_Label (Loc : Source_Ptr) return Node_Id;
460
            --  Function to create a Push_xxx_Label node
461
 
462
            with function Make_Pop_Label (Loc : Source_Ptr) return Node_Id;
463
            --  Function to create a Pop_xxx_Label node
464
 
465
         procedure Generate_Push_Pop (H : Node_Id);
466
         --  Common code for Generate_Push_Pop_xxx below, used to generate an
467
         --  exception label and Push/Pop nodes for Constraint_Error,
468
         --  Program_Error, or Storage_Error.
469
 
470
         -------------------------
471
         -- Add_Exception_Label --
472
         -------------------------
473
 
474
         procedure Add_Exception_Label (H : Node_Id) is
475
         begin
476
            if No (Exception_Label (H))
477
              and then not Local_Raise_Not_OK (H)
478
              and then not Special_Exception_Package_Used
479
            then
480
               Local_Expansion_Required := True;
481
 
482
               declare
483
                  L : constant Entity_Id := Make_Temporary (Sloc (H), 'L');
484
               begin
485
                  Set_Exception_Label (H, L);
486
                  Add_Label_Declaration (L);
487
               end;
488
            end if;
489
         end Add_Exception_Label;
490
 
491
         ---------------------------
492
         -- Add_Label_Declaration --
493
         ---------------------------
494
 
495
         procedure Add_Label_Declaration (L : Entity_Id) is
496
            P : constant Node_Id := Parent (HSS);
497
 
498
            Decl_L : constant Node_Id :=
499
                       Make_Implicit_Label_Declaration (Loc,
500
                         Defining_Identifier => L);
501
 
502
         begin
503
            if Declarations (P) = No_List then
504
               Set_Declarations (P, Empty_List);
505
            end if;
506
 
507
            Append (Decl_L, Declarations (P));
508
            Analyze (Decl_L);
509
         end Add_Label_Declaration;
510
 
511
         -----------------------
512
         -- Generate_Push_Pop --
513
         -----------------------
514
 
515
         procedure Generate_Push_Pop (H : Node_Id) is
516
         begin
517
            if Restriction_Active (No_Exception_Handlers)
518
              or else CodePeer_Mode
519
            then
520
               return;
521
            end if;
522
 
523
            if Exc_Locally_Handled then
524
               return;
525
            else
526
               Exc_Locally_Handled := True;
527
            end if;
528
 
529
            Add_Exception_Label (H);
530
 
531
            declare
532
               F : constant Node_Id := First (Statements (HSS));
533
               L : constant Node_Id := Last  (Statements (HSS));
534
 
535
               Push : constant Node_Id := Make_Push_Label (Sloc (F));
536
               Pop  : constant Node_Id := Make_Pop_Label  (Sloc (L));
537
 
538
            begin
539
               --  We make sure that a call to Get_Local_Raise_Call_Entity is
540
               --  made during front end processing, so that when we need it
541
               --  in the back end, it will already be available and loaded.
542
 
543
               Discard_Node (Get_Local_Raise_Call_Entity);
544
 
545
               --  Prepare and insert Push and Pop nodes
546
 
547
               Set_Exception_Label (Push, Exception_Label (H));
548
               Insert_Before (F, Push);
549
               Set_Analyzed (Push);
550
 
551
               Insert_After (L, Pop);
552
               Set_Analyzed (Pop);
553
            end;
554
         end Generate_Push_Pop;
555
 
556
         --  Local declarations
557
 
558
         Loc    : constant Source_Ptr := Sloc (HSS);
559
         Stmts  : List_Id := No_List;
560
         Choice : Node_Id;
561
         Excep  : Entity_Id;
562
 
563
         procedure Generate_Push_Pop_For_Constraint_Error is
564
           new Generate_Push_Pop
565
             (Exc_Locally_Handled => CE_Locally_Handled,
566
              Make_Push_Label     => Make_Push_Constraint_Error_Label,
567
              Make_Pop_Label      => Make_Pop_Constraint_Error_Label);
568
         --  If no Push/Pop has been generated for CE yet, then set the flag
569
         --  CE_Locally_Handled, allocate an Exception_Label for handler H (if
570
         --  not already done), and generate Push/Pop nodes for the exception
571
         --  label at the start and end of the statements of HSS.
572
 
573
         procedure Generate_Push_Pop_For_Program_Error is
574
           new Generate_Push_Pop
575
             (Exc_Locally_Handled => PE_Locally_Handled,
576
              Make_Push_Label     => Make_Push_Program_Error_Label,
577
              Make_Pop_Label      => Make_Pop_Program_Error_Label);
578
         --  If no Push/Pop has been generated for PE yet, then set the flag
579
         --  PE_Locally_Handled, allocate an Exception_Label for handler H (if
580
         --  not already done), and generate Push/Pop nodes for the exception
581
         --  label at the start and end of the statements of HSS.
582
 
583
         procedure Generate_Push_Pop_For_Storage_Error is
584
           new Generate_Push_Pop
585
             (Exc_Locally_Handled => SE_Locally_Handled,
586
              Make_Push_Label     => Make_Push_Storage_Error_Label,
587
              Make_Pop_Label      => Make_Pop_Storage_Error_Label);
588
         --  If no Push/Pop has been generated for SE yet, then set the flag
589
         --  SE_Locally_Handled, allocate an Exception_Label for handler H (if
590
         --  not already done), and generate Push/Pop nodes for the exception
591
         --  label at the start and end of the statements of HSS.
592
 
593
      --  Start of processing for Expand_Local_Exception_Handlers
594
 
595
      begin
596
         --  No processing if all exception handlers will get removed
597
 
598
         if Debug_Flag_Dot_X then
599
            return;
600
         end if;
601
 
602
         --  See for each handler if we have any local raises to expand
603
 
604
         Handler := First_Non_Pragma (Handlrs);
605
         while Present (Handler) loop
606
 
607
            --  Note, we do not test Local_Raise_Not_OK here, because in the
608
            --  case of Push/Pop generation we want to generate push with a
609
            --  null label. The Add_Exception_Label routine has no effect if
610
            --  Local_Raise_Not_OK is set, so this works as required.
611
 
612
            if Present (Local_Raise_Statements (Handler)) then
613
               Add_Exception_Label (Handler);
614
            end if;
615
 
616
            --  If we are doing local raise to goto optimization (restriction
617
            --  No_Exception_Propagation set or debug flag .g set), then check
618
            --  to see if handler handles CE, PE, SE and if so generate the
619
            --  appropriate push/pop sequence for the back end.
620
 
621
            if (Debug_Flag_Dot_G
622
                 or else Restriction_Active (No_Exception_Propagation))
623
              and then Has_Local_Raise (Handler)
624
            then
625
               Choice := First (Exception_Choices (Handler));
626
               while Present (Choice) loop
627
                  if Nkind (Choice) = N_Others_Choice
628
                    and then not All_Others (Choice)
629
                  then
630
                     Generate_Push_Pop_For_Constraint_Error (Handler);
631
                     Generate_Push_Pop_For_Program_Error    (Handler);
632
                     Generate_Push_Pop_For_Storage_Error    (Handler);
633
 
634
                  elsif Is_Entity_Name (Choice) then
635
                     Excep := Get_Renamed_Entity (Entity (Choice));
636
 
637
                     if Excep = Standard_Constraint_Error then
638
                        Generate_Push_Pop_For_Constraint_Error (Handler);
639
                     elsif Excep = Standard_Program_Error then
640
                        Generate_Push_Pop_For_Program_Error    (Handler);
641
                     elsif Excep = Standard_Storage_Error then
642
                        Generate_Push_Pop_For_Storage_Error    (Handler);
643
                     end if;
644
                  end if;
645
 
646
                  Next (Choice);
647
               end loop;
648
            end if;
649
 
650
            Next_Non_Pragma (Handler);
651
         end loop;
652
 
653
         --  Nothing to do if no handlers requiring the goto transformation
654
 
655
         if not (Local_Expansion_Required) then
656
            return;
657
         end if;
658
 
659
         --  Prepare to do the transformation
660
 
661
         declare
662
            --  L3 is the label to exit the HSS
663
 
664
            L3_Dent : constant Entity_Id := Make_Temporary (Loc, 'L');
665
 
666
            Labl_L3 : constant Node_Id :=
667
                        Make_Label (Loc,
668
                          Identifier => New_Occurrence_Of (L3_Dent, Loc));
669
 
670
            Blk_Stm : Node_Id;
671
            Relmt   : Elmt_Id;
672
 
673
         begin
674
            Set_Exception_Junk (Labl_L3);
675
            Add_Label_Declaration (L3_Dent);
676
 
677
            --  Wrap existing statements and handlers in an inner block
678
 
679
            Blk_Stm :=
680
              Make_Block_Statement (Loc,
681
                Handled_Statement_Sequence => Relocate_Node (HSS));
682
            Set_Exception_Junk (Blk_Stm);
683
 
684
            Rewrite (HSS,
685
              Make_Handled_Sequence_Of_Statements (Loc,
686
                Statements => New_List (Blk_Stm),
687
                End_Label  => Relocate_Node (End_Label (HSS))));
688
 
689
            --  Set block statement as analyzed, we don't want to actually call
690
            --  Analyze on this block, it would cause a recursion in exception
691
            --  handler processing which would mess things up.
692
 
693
            Set_Analyzed (Blk_Stm);
694
 
695
            --  Now loop through the exception handlers to deal with those that
696
            --  are targets of local raise statements.
697
 
698
            Handler := First_Non_Pragma (Handlrs);
699
            while Present (Handler) loop
700
               if Present (Exception_Label (Handler)) then
701
 
702
                  --  This handler needs the goto expansion
703
 
704
                  declare
705
                     Loc : constant Source_Ptr := Sloc (Handler);
706
 
707
                     --  L1 is the start label for this handler
708
 
709
                     L1_Dent : constant Entity_Id := Exception_Label (Handler);
710
 
711
                     Labl_L1 : constant Node_Id :=
712
                                 Make_Label (Loc,
713
                                   Identifier =>
714
                                     New_Occurrence_Of (L1_Dent, Loc));
715
 
716
                     --  Jump to L1 to be used as replacement for the original
717
                     --  handler (used in the case where exception propagation
718
                     --  may still occur).
719
 
720
                     Name_L1 : constant Node_Id :=
721
                                 New_Occurrence_Of (L1_Dent, Loc);
722
 
723
                     Goto_L1 : constant Node_Id :=
724
                                 Make_Goto_Statement (Loc,
725
                                   Name => Name_L1);
726
 
727
                     --  Jump to L3 to be used at the end of handler
728
 
729
                     Name_L3 : constant Node_Id :=
730
                                 New_Occurrence_Of (L3_Dent, Loc);
731
 
732
                     Goto_L3 : constant Node_Id :=
733
                                 Make_Goto_Statement (Loc,
734
                                   Name => Name_L3);
735
 
736
                     H_Stmts : constant List_Id := Statements (Handler);
737
 
738
                  begin
739
                     Set_Exception_Junk (Labl_L1);
740
                     Set_Exception_Junk (Goto_L3);
741
 
742
                     --  Note: we do NOT set Exception_Junk in Goto_L1, since
743
                     --  this is a real transfer of control that we want the
744
                     --  Sem_Ch6.Check_Returns procedure to recognize properly.
745
 
746
                     --  Replace handler by a goto L1. We can mark this as
747
                     --  analyzed since it is fully formed, and we don't
748
                     --  want it going through any further checks. We save
749
                     --  the last statement location in the goto L1 node for
750
                     --  the benefit of Sem_Ch6.Check_Returns.
751
 
752
                     Set_Statements (Handler, New_List (Goto_L1));
753
                     Set_Analyzed (Goto_L1);
754
                     Set_Etype (Name_L1, Standard_Void_Type);
755
 
756
                     --  Now replace all the raise statements by goto L1
757
 
758
                     if Present (Local_Raise_Statements (Handler)) then
759
                        Relmt := First_Elmt (Local_Raise_Statements (Handler));
760
                        while Present (Relmt) loop
761
                           declare
762
                              Raise_S : constant Node_Id    := Node (Relmt);
763
                              RLoc    : constant Source_Ptr := Sloc (Raise_S);
764
                              Name_L1 : constant Node_Id :=
765
                                          New_Occurrence_Of (L1_Dent, Loc);
766
                              Goto_L1 : constant Node_Id :=
767
                                          Make_Goto_Statement (RLoc,
768
                                            Name => Name_L1);
769
 
770
                           begin
771
                              --  Replace raise by goto L1
772
 
773
                              Set_Analyzed (Goto_L1);
774
                              Set_Etype (Name_L1, Standard_Void_Type);
775
                              Replace_Raise_By_Goto (Raise_S, Goto_L1);
776
                           end;
777
 
778
                           Next_Elmt (Relmt);
779
                        end loop;
780
                     end if;
781
 
782
                     --  Add a goto L3 at end of statement list in block. The
783
                     --  first time, this is what skips over the exception
784
                     --  handlers in the normal case. Subsequent times, it
785
                     --  terminates the execution of the previous handler code,
786
                     --  and skips subsequent handlers.
787
 
788
                     Stmts := Statements (HSS);
789
 
790
                     Insert_After (Last (Stmts), Goto_L3);
791
                     Set_Analyzed (Goto_L3);
792
                     Set_Etype (Name_L3, Standard_Void_Type);
793
 
794
                     --  Now we drop the label that marks the handler start,
795
                     --  followed by the statements of the handler.
796
 
797
                     Set_Etype (Identifier (Labl_L1), Standard_Void_Type);
798
 
799
                     Insert_After_And_Analyze (Last (Stmts), Labl_L1);
800
 
801
                     declare
802
                        Loc : constant Source_Ptr := Sloc (First (H_Stmts));
803
                        Blk : constant Node_Id :=
804
                                Make_Block_Statement (Loc,
805
                                  Handled_Statement_Sequence =>
806
                                    Make_Handled_Sequence_Of_Statements (Loc,
807
                                      Statements => H_Stmts));
808
                     begin
809
                        Set_Exception_Junk (Blk);
810
                        Insert_After_And_Analyze (Last (Stmts), Blk);
811
                     end;
812
                  end;
813
 
814
                  --  Here if we have local raise statements but the handler is
815
                  --  not suitable for processing with a local raise. In this
816
                  --  case we have to generate possible diagnostics.
817
 
818
               elsif Has_Local_Raise (Handler)
819
                 and then Local_Raise_Statements (Handler) /= No_Elist
820
               then
821
                  Relmt := First_Elmt (Local_Raise_Statements (Handler));
822
                  while Present (Relmt) loop
823
                     Warn_If_No_Propagation (Node (Relmt));
824
                     Next_Elmt (Relmt);
825
                  end loop;
826
               end if;
827
 
828
               Next (Handler);
829
            end loop;
830
 
831
            --  Only remaining step is to drop the L3 label and we are done
832
 
833
            Set_Etype (Identifier (Labl_L3), Standard_Void_Type);
834
 
835
            --  If we had at least one handler, then we drop the label after
836
            --  the last statement of that handler.
837
 
838
            if Stmts /= No_List then
839
               Insert_After_And_Analyze (Last (Stmts), Labl_L3);
840
 
841
            --  Otherwise we have removed all the handlers (this results from
842
            --  use of pragma Restrictions (No_Exception_Propagation), and we
843
            --  drop the label at the end of the statements of the HSS.
844
 
845
            else
846
               Insert_After_And_Analyze (Last (Statements (HSS)), Labl_L3);
847
            end if;
848
 
849
            return;
850
         end;
851
      end Expand_Local_Exception_Handlers;
852
 
853
      -----------------------------
854
      -- Prepend_Call_To_Handler --
855
      -----------------------------
856
 
857
      procedure Prepend_Call_To_Handler
858
        (Proc : RE_Id;
859
         Args : List_Id := No_List)
860
      is
861
         Ent : constant Entity_Id := RTE (Proc);
862
 
863
      begin
864
         --  If we have no Entity, then we are probably in no run time mode or
865
         --  some weird error has occurred. In either case do nothing. Note use
866
         --  of No_Location to hide this code from the debugger, so single
867
         --  stepping doesn't jump back and forth.
868
 
869
         if Present (Ent) then
870
            declare
871
               Call : constant Node_Id :=
872
                        Make_Procedure_Call_Statement (No_Location,
873
                          Name => New_Occurrence_Of (RTE (Proc), No_Location),
874
                          Parameter_Associations => Args);
875
 
876
            begin
877
               Prepend_To (Statements (Handler), Call);
878
               Analyze (Call, Suppress => All_Checks);
879
            end;
880
         end if;
881
      end Prepend_Call_To_Handler;
882
 
883
      ---------------------------
884
      -- Replace_Raise_By_Goto --
885
      ---------------------------
886
 
887
      procedure Replace_Raise_By_Goto (Raise_S : Node_Id; Goto_L1 : Node_Id) is
888
         Loc   : constant Source_Ptr := Sloc (Raise_S);
889
         Excep : Entity_Id;
890
         LR    : Node_Id;
891
         Cond  : Node_Id;
892
         Orig  : Node_Id;
893
 
894
      begin
895
         --  If we have a null statement, it means that there is no replacement
896
         --  needed (typically this results from a suppressed check).
897
 
898
         if Nkind (Raise_S) = N_Null_Statement then
899
            return;
900
 
901
         --  Test for Raise_xxx_Error
902
 
903
         elsif Nkind (Raise_S) = N_Raise_Constraint_Error then
904
            Excep := Standard_Constraint_Error;
905
            Cond  := Condition (Raise_S);
906
 
907
         elsif Nkind (Raise_S) = N_Raise_Storage_Error then
908
            Excep := Standard_Storage_Error;
909
            Cond := Condition (Raise_S);
910
 
911
         elsif Nkind (Raise_S) = N_Raise_Program_Error then
912
            Excep := Standard_Program_Error;
913
            Cond := Condition (Raise_S);
914
 
915
            --  The only other possibility is a node that is or used to be a
916
            --  simple raise statement.
917
 
918
         else
919
            Orig := Original_Node (Raise_S);
920
            pragma Assert (Nkind (Orig) = N_Raise_Statement
921
                             and then Present (Name (Orig))
922
                             and then No (Expression (Orig)));
923
            Excep := Entity (Name (Orig));
924
            Cond := Empty;
925
         end if;
926
 
927
         --  Here Excep is the exception to raise, and Cond is the condition
928
         --  First prepare the call to Local_Raise (excep'address).
929
 
930
         if RTE_Available (RE_Local_Raise) then
931
            LR :=
932
              Make_Procedure_Call_Statement (Loc,
933
                Name => New_Occurrence_Of (RTE (RE_Local_Raise), Loc),
934
                Parameter_Associations => New_List (
935
                  Unchecked_Convert_To (RTE (RE_Address),
936
                    Make_Attribute_Reference (Loc,
937
                      Prefix         => New_Occurrence_Of (Excep, Loc),
938
                      Attribute_Name => Name_Identity))));
939
 
940
            --  Use null statement if Local_Raise not available
941
 
942
         else
943
            LR :=
944
              Make_Null_Statement (Loc);
945
         end if;
946
 
947
         --  If there is no condition, we rewrite as
948
 
949
         --    begin
950
         --       Local_Raise (excep'Identity);
951
         --       goto L1;
952
         --    end;
953
 
954
         if No (Cond) then
955
            Rewrite (Raise_S,
956
              Make_Block_Statement (Loc,
957
                Handled_Statement_Sequence =>
958
                  Make_Handled_Sequence_Of_Statements (Loc,
959
                    Statements => New_List (LR, Goto_L1))));
960
            Set_Exception_Junk (Raise_S);
961
 
962
         --  If there is a condition, we rewrite as
963
 
964
         --    if condition then
965
         --       Local_Raise (excep'Identity);
966
         --       goto L1;
967
         --    end if;
968
 
969
         else
970
            Rewrite (Raise_S,
971
              Make_If_Statement (Loc,
972
                Condition       => Cond,
973
                Then_Statements => New_List (LR, Goto_L1)));
974
         end if;
975
 
976
         Analyze (Raise_S);
977
      end Replace_Raise_By_Goto;
978
 
979
   --  Start of processing for Expand_Exception_Handlers
980
 
981
   begin
982
      Expand_Local_Exception_Handlers;
983
 
984
      --  Loop through handlers
985
 
986
      Handler := First_Non_Pragma (Handlrs);
987
      Handler_Loop : while Present (Handler) loop
988
         Process_Statements_For_Controlled_Objects (Handler);
989
 
990
         Next_Handler := Next_Non_Pragma (Handler);
991
 
992
         --  Remove source handler if gnat debug flag .x is set
993
 
994
         if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
995
            Remove (Handler);
996
 
997
         --  Remove handler if no exception propagation, generating a warning
998
         --  if a source generated handler was not the target of a local raise.
999
 
1000
         else
1001
            if Restriction_Active (No_Exception_Propagation)
1002
              and then not Has_Local_Raise (Handler)
1003
              and then Comes_From_Source (Handler)
1004
              and then Warn_On_Non_Local_Exception
1005
            then
1006
               Warn_No_Exception_Propagation_Active (Handler);
1007
               Error_Msg_N
1008
                 ("\?this handler can never be entered, and has been removed",
1009
                  Handler);
1010
            end if;
1011
 
1012
            if No_Exception_Propagation_Active then
1013
               Remove (Handler);
1014
 
1015
            --  Exception handler is active and retained and must be processed
1016
 
1017
            else
1018
               --  If an exception occurrence is present, then we must declare
1019
               --  it and initialize it from the value stored in the TSD
1020
 
1021
               --     declare
1022
               --        name : Exception_Occurrence;
1023
               --     begin
1024
               --        Save_Occurrence (name, Get_Current_Excep.all)
1025
               --        ...
1026
               --     end;
1027
 
1028
               if Present (Choice_Parameter (Handler)) then
1029
                  declare
1030
                     Cparm : constant Entity_Id  := Choice_Parameter (Handler);
1031
                     Cloc  : constant Source_Ptr := Sloc (Cparm);
1032
                     Hloc  : constant Source_Ptr := Sloc (Handler);
1033
                     Save  : Node_Id;
1034
 
1035
                  begin
1036
                     --  Note use of No_Location to hide this code from the
1037
                     --  debugger, so single stepping doesn't jump back and
1038
                     --  forth.
1039
 
1040
                     Save :=
1041
                       Make_Procedure_Call_Statement (No_Location,
1042
                         Name =>
1043
                           New_Occurrence_Of
1044
                             (RTE (RE_Save_Occurrence), No_Location),
1045
                         Parameter_Associations => New_List (
1046
                           New_Occurrence_Of (Cparm, No_Location),
1047
                           Make_Explicit_Dereference (No_Location,
1048
                             Make_Function_Call (No_Location,
1049
                               Name =>
1050
                                 Make_Explicit_Dereference (No_Location,
1051
                                   New_Occurrence_Of
1052
                                     (RTE (RE_Get_Current_Excep),
1053
                                      No_Location))))));
1054
 
1055
                     Mark_Rewrite_Insertion (Save);
1056
                     Prepend (Save, Statements (Handler));
1057
 
1058
                     Obj_Decl :=
1059
                       Make_Object_Declaration
1060
                         (Cloc,
1061
                          Defining_Identifier => Cparm,
1062
                          Object_Definition   =>
1063
                            New_Occurrence_Of
1064
                              (RTE (RE_Exception_Occurrence), Cloc));
1065
                     Set_No_Initialization (Obj_Decl, True);
1066
 
1067
                     Rewrite (Handler,
1068
                       Make_Exception_Handler (Hloc,
1069
                         Choice_Parameter  => Empty,
1070
                         Exception_Choices => Exception_Choices (Handler),
1071
 
1072
                         Statements => New_List (
1073
                           Make_Block_Statement (Hloc,
1074
                             Declarations => New_List (Obj_Decl),
1075
                             Handled_Statement_Sequence =>
1076
                               Make_Handled_Sequence_Of_Statements (Hloc,
1077
                                 Statements => Statements (Handler))))));
1078
 
1079
                     --  Local raise statements can't occur, since exception
1080
                     --  handlers with choice parameters are not allowed when
1081
                     --  No_Exception_Propagation applies, so set attributes
1082
                     --  accordingly.
1083
 
1084
                     Set_Local_Raise_Statements (Handler, No_Elist);
1085
                     Set_Local_Raise_Not_OK (Handler);
1086
 
1087
                     Analyze_List
1088
                       (Statements (Handler), Suppress => All_Checks);
1089
                  end;
1090
               end if;
1091
 
1092
               --  The processing at this point is rather different for the JVM
1093
               --  case, so we completely separate the processing.
1094
 
1095
               --  For the VM case, we unconditionally call Update_Exception,
1096
               --  passing a call to the intrinsic Current_Target_Exception
1097
               --  (see JVM/.NET versions of Ada.Exceptions for details).
1098
 
1099
               if VM_Target /= No_VM then
1100
                  declare
1101
                     Arg : constant Node_Id :=
1102
                             Make_Function_Call (Loc,
1103
                               Name =>
1104
                                 New_Occurrence_Of
1105
                                   (RTE (RE_Current_Target_Exception), Loc));
1106
                  begin
1107
                     Prepend_Call_To_Handler
1108
                       (RE_Update_Exception, New_List (Arg));
1109
                  end;
1110
 
1111
                  --  For the normal case, we have to worry about the state of
1112
                  --  abort deferral. Generally, we defer abort during runtime
1113
                  --  handling of exceptions. When control is passed to the
1114
                  --  handler, then in the normal case we undefer aborts. In
1115
                  --  any case this entire handling is relevant only if aborts
1116
                  --  are allowed!
1117
 
1118
               elsif Abort_Allowed
1119
                 and then Exception_Mechanism /= Back_End_Exceptions
1120
               then
1121
                  --  There are some special cases in which we do not do the
1122
                  --  undefer. In particular a finalization (AT END) handler
1123
                  --  wants to operate with aborts still deferred.
1124
 
1125
                  --  We also suppress the call if this is the special handler
1126
                  --  for Abort_Signal, since if we are aborting, we want to
1127
                  --  keep aborts deferred (one abort is enough).
1128
 
1129
                  --  If abort really needs to be deferred the expander must
1130
                  --  add this call explicitly, see
1131
                  --  Expand_N_Asynchronous_Select.
1132
 
1133
                  Others_Choice :=
1134
                    Nkind (First (Exception_Choices (Handler))) =
1135
                                                         N_Others_Choice;
1136
 
1137
                  if (Others_Choice
1138
                       or else Entity (First (Exception_Choices (Handler))) /=
1139
                                                         Stand.Abort_Signal)
1140
                    and then not
1141
                      (Others_Choice
1142
                        and then
1143
                          All_Others (First (Exception_Choices (Handler))))
1144
                  then
1145
                     Prepend_Call_To_Handler (RE_Abort_Undefer);
1146
                  end if;
1147
               end if;
1148
            end if;
1149
         end if;
1150
 
1151
         Handler := Next_Handler;
1152
      end loop Handler_Loop;
1153
 
1154
      --  If all handlers got removed, then remove the list. Note we cannot
1155
      --  reference HSS here, since expanding local handlers may have buried
1156
      --  the handlers in an inner block.
1157
 
1158
      if Is_Empty_List (Handlrs) then
1159
         Set_Exception_Handlers (Parent (Handlrs), No_List);
1160
      end if;
1161
   end Expand_Exception_Handlers;
1162
 
1163
   ------------------------------------
1164
   -- Expand_N_Exception_Declaration --
1165
   ------------------------------------
1166
 
1167
   --  Generates:
1168
   --     exceptE : constant String := "A.B.EXCEP";   -- static data
1169
   --     except : exception_data :=  (
1170
   --                    Handled_By_Other => False,
1171
   --                    Lang             => 'A',
1172
   --                    Name_Length      => exceptE'Length,
1173
   --                    Full_Name        => exceptE'Address,
1174
   --                    HTable_Ptr       => null,
1175
   --                    Import_Code      => 0,
1176
   --                    Raise_Hook       => null,
1177
   --                    );
1178
 
1179
   --  (protecting test only needed if not at library level)
1180
   --
1181
   --     exceptF : Boolean := True --  static data
1182
   --     if exceptF then
1183
   --        exceptF := False;
1184
   --        Register_Exception (except'Unchecked_Access);
1185
   --     end if;
1186
 
1187
   procedure Expand_N_Exception_Declaration (N : Node_Id) is
1188
      Loc     : constant Source_Ptr := Sloc (N);
1189
      Id      : constant Entity_Id  := Defining_Identifier (N);
1190
      L       : List_Id             := New_List;
1191
      Flag_Id : Entity_Id;
1192
 
1193
      Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E');
1194
      Exname      : constant Node_Id :=
1195
                      Make_Defining_Identifier (Loc, Name_Exname);
1196
 
1197
      procedure Force_Static_Allocation_Of_Referenced_Objects
1198
        (Aggregate : Node_Id);
1199
      --  A specialized solution to one particular case of an ugly problem
1200
      --
1201
      --  The given aggregate includes an Unchecked_Conversion as one of the
1202
      --  component values. The call to Analyze_And_Resolve below ends up
1203
      --  calling Exp_Ch4.Expand_N_Unchecked_Type_Conversion, which may decide
1204
      --  to introduce a (constant) temporary and then obtain the component
1205
      --  value by evaluating the temporary.
1206
      --
1207
      --  In the case of an exception declared within a subprogram (or any
1208
      --  other dynamic scope), this is a bad transformation. The exception
1209
      --  object is marked as being Statically_Allocated but the temporary is
1210
      --  not. If the initial value of a Statically_Allocated declaration
1211
      --  references a dynamically allocated object, this prevents static
1212
      --  initialization of the object.
1213
      --
1214
      --  We cope with this here by marking the temporary Statically_Allocated.
1215
      --  It might seem cleaner to generalize this utility and then use it to
1216
      --  enforce a rule that the entities referenced in the declaration of any
1217
      --  "hoisted" (i.e., Is_Statically_Allocated and not Is_Library_Level)
1218
      --  entity must also be either Library_Level or hoisted. It turns out
1219
      --  that this would be incompatible with the current treatment of an
1220
      --  object which is local to a subprogram, subject to an Export pragma,
1221
      --  not subject to an address clause, and whose declaration contains
1222
      --  references to other local (non-hoisted) objects (e.g., in the initial
1223
      --  value expression).
1224
 
1225
      ---------------------------------------------------
1226
      -- Force_Static_Allocation_Of_Referenced_Objects --
1227
      ---------------------------------------------------
1228
 
1229
      procedure Force_Static_Allocation_Of_Referenced_Objects
1230
        (Aggregate : Node_Id)
1231
      is
1232
         function Fixup_Node (N : Node_Id) return Traverse_Result;
1233
         --  If the given node references a dynamically allocated object, then
1234
         --  correct the declaration of the object.
1235
 
1236
         ----------------
1237
         -- Fixup_Node --
1238
         ----------------
1239
 
1240
         function Fixup_Node (N : Node_Id) return Traverse_Result is
1241
         begin
1242
            if Nkind (N) in N_Has_Entity
1243
              and then Present (Entity (N))
1244
              and then not Is_Library_Level_Entity (Entity (N))
1245
 
1246
              --  Note: the following test is not needed but it seems cleaner
1247
              --  to do this test (this would be more important if procedure
1248
              --  Force_Static_Allocation_Of_Referenced_Objects recursively
1249
              --  traversed the declaration of an entity after marking it as
1250
              --  statically allocated).
1251
 
1252
              and then not Is_Statically_Allocated (Entity (N))
1253
            then
1254
               Set_Is_Statically_Allocated (Entity (N));
1255
            end if;
1256
 
1257
            return OK;
1258
         end Fixup_Node;
1259
 
1260
         procedure Fixup_Tree is new Traverse_Proc (Fixup_Node);
1261
 
1262
      --  Start of processing for Force_Static_Allocation_Of_Referenced_Objects
1263
 
1264
      begin
1265
         Fixup_Tree (Aggregate);
1266
      end Force_Static_Allocation_Of_Referenced_Objects;
1267
 
1268
   --  Start of processing for Expand_N_Exception_Declaration
1269
 
1270
   begin
1271
      --  There is no expansion needed when compiling for the JVM since the
1272
      --  JVM has a built-in exception mechanism. See cil/gnatlib/a-except.ads
1273
      --  for details.
1274
 
1275
      if VM_Target /= No_VM then
1276
         return;
1277
      end if;
1278
 
1279
      --  Definition of the external name: nam : constant String := "A.B.NAME";
1280
 
1281
      Insert_Action (N,
1282
        Make_Object_Declaration (Loc,
1283
          Defining_Identifier => Exname,
1284
          Constant_Present    => True,
1285
          Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
1286
          Expression          =>
1287
            Make_String_Literal (Loc,
1288
              Strval => Fully_Qualified_Name_String (Id))));
1289
 
1290
      Set_Is_Statically_Allocated (Exname);
1291
 
1292
      --  Create the aggregate list for type Standard.Exception_Type:
1293
      --  Handled_By_Other component: False
1294
 
1295
      Append_To (L, New_Occurrence_Of (Standard_False, Loc));
1296
 
1297
      --  Lang component: 'A'
1298
 
1299
      Append_To (L,
1300
        Make_Character_Literal (Loc,
1301
          Chars              =>  Name_uA,
1302
          Char_Literal_Value =>  UI_From_Int (Character'Pos ('A'))));
1303
 
1304
      --  Name_Length component: Nam'Length
1305
 
1306
      Append_To (L,
1307
        Make_Attribute_Reference (Loc,
1308
          Prefix         => New_Occurrence_Of (Exname, Loc),
1309
          Attribute_Name => Name_Length));
1310
 
1311
      --  Full_Name component: Standard.A_Char!(Nam'Address)
1312
 
1313
      Append_To (L, Unchecked_Convert_To (Standard_A_Char,
1314
        Make_Attribute_Reference (Loc,
1315
          Prefix         => New_Occurrence_Of (Exname, Loc),
1316
          Attribute_Name => Name_Address)));
1317
 
1318
      --  HTable_Ptr component: null
1319
 
1320
      Append_To (L, Make_Null (Loc));
1321
 
1322
      --  Import_Code component: 0
1323
 
1324
      Append_To (L, Make_Integer_Literal (Loc, 0));
1325
 
1326
      --  Raise_Hook component: null
1327
 
1328
      Append_To (L, Make_Null (Loc));
1329
 
1330
      Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
1331
      Analyze_And_Resolve (Expression (N), Etype (Id));
1332
 
1333
      Force_Static_Allocation_Of_Referenced_Objects (Expression (N));
1334
 
1335
      --  Register_Exception (except'Unchecked_Access);
1336
 
1337
      if not No_Exception_Handlers_Set
1338
        and then not Restriction_Active (No_Exception_Registration)
1339
      then
1340
         L := New_List (
1341
                Make_Procedure_Call_Statement (Loc,
1342
                  Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
1343
                  Parameter_Associations => New_List (
1344
                    Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
1345
                      Make_Attribute_Reference (Loc,
1346
                        Prefix         => New_Occurrence_Of (Id, Loc),
1347
                        Attribute_Name => Name_Unrestricted_Access)))));
1348
 
1349
         Set_Register_Exception_Call (Id, First (L));
1350
 
1351
         if not Is_Library_Level_Entity (Id) then
1352
            Flag_Id :=  Make_Defining_Identifier (Loc,
1353
                          New_External_Name (Chars (Id), 'F'));
1354
 
1355
            Insert_Action (N,
1356
              Make_Object_Declaration (Loc,
1357
                Defining_Identifier => Flag_Id,
1358
                Object_Definition   =>
1359
                  New_Occurrence_Of (Standard_Boolean, Loc),
1360
                Expression          =>
1361
                  New_Occurrence_Of (Standard_True, Loc)));
1362
 
1363
            Set_Is_Statically_Allocated (Flag_Id);
1364
 
1365
            Append_To (L,
1366
              Make_Assignment_Statement (Loc,
1367
                Name       => New_Occurrence_Of (Flag_Id, Loc),
1368
                Expression => New_Occurrence_Of (Standard_False, Loc)));
1369
 
1370
            Insert_After_And_Analyze (N,
1371
              Make_Implicit_If_Statement (N,
1372
                Condition       => New_Occurrence_Of (Flag_Id, Loc),
1373
                Then_Statements => L));
1374
 
1375
         else
1376
            Insert_List_After_And_Analyze (N, L);
1377
         end if;
1378
      end if;
1379
   end Expand_N_Exception_Declaration;
1380
 
1381
   ---------------------------------------------
1382
   -- Expand_N_Handled_Sequence_Of_Statements --
1383
   ---------------------------------------------
1384
 
1385
   procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
1386
   begin
1387
      --  Expand exception handlers
1388
 
1389
      if Present (Exception_Handlers (N))
1390
        and then not Restriction_Active (No_Exception_Handlers)
1391
      then
1392
         Expand_Exception_Handlers (N);
1393
      end if;
1394
 
1395
      --  If local exceptions are being expanded, the previous call will
1396
      --  have rewritten the construct as a block and reanalyzed it. No
1397
      --  further expansion is needed.
1398
 
1399
      if Analyzed (N) then
1400
         return;
1401
      end if;
1402
 
1403
      --  Add clean up actions if required
1404
 
1405
      if Nkind (Parent (N)) /= N_Package_Body
1406
        and then Nkind (Parent (N)) /= N_Accept_Statement
1407
        and then Nkind (Parent (N)) /= N_Extended_Return_Statement
1408
        and then not Delay_Cleanups (Current_Scope)
1409
      then
1410
         Expand_Cleanup_Actions (Parent (N));
1411
      else
1412
         Set_First_Real_Statement (N, First (Statements (N)));
1413
      end if;
1414
   end Expand_N_Handled_Sequence_Of_Statements;
1415
 
1416
   -------------------------------------
1417
   -- Expand_N_Raise_Constraint_Error --
1418
   -------------------------------------
1419
 
1420
   procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
1421
   begin
1422
      --  We adjust the condition to deal with the C/Fortran boolean case. This
1423
      --  may well not be necessary, as all such conditions are generated by
1424
      --  the expander and probably are all standard boolean, but who knows
1425
      --  what strange optimization in future may require this adjustment!
1426
 
1427
      Adjust_Condition (Condition (N));
1428
 
1429
      --  Now deal with possible local raise handling
1430
 
1431
      Possible_Local_Raise (N, Standard_Constraint_Error);
1432
   end Expand_N_Raise_Constraint_Error;
1433
 
1434
   ----------------------------------
1435
   -- Expand_N_Raise_Program_Error --
1436
   ----------------------------------
1437
 
1438
   procedure Expand_N_Raise_Program_Error (N : Node_Id) is
1439
   begin
1440
      --  We adjust the condition to deal with the C/Fortran boolean case. This
1441
      --  may well not be necessary, as all such conditions are generated by
1442
      --  the expander and probably are all standard boolean, but who knows
1443
      --  what strange optimization in future may require this adjustment!
1444
 
1445
      Adjust_Condition (Condition (N));
1446
 
1447
      --  Now deal with possible local raise handling
1448
 
1449
      Possible_Local_Raise (N, Standard_Program_Error);
1450
   end Expand_N_Raise_Program_Error;
1451
 
1452
   ------------------------------
1453
   -- Expand_N_Raise_Statement --
1454
   ------------------------------
1455
 
1456
   procedure Expand_N_Raise_Statement (N : Node_Id) is
1457
      Loc   : constant Source_Ptr := Sloc (N);
1458
      Ehand : Node_Id;
1459
      E     : Entity_Id;
1460
      Str   : String_Id;
1461
      H     : Node_Id;
1462
      Src   : Boolean;
1463
 
1464
   begin
1465
      --  Processing for locally handled exception (exclude reraise case)
1466
 
1467
      if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1468
         if Debug_Flag_Dot_G
1469
           or else Restriction_Active (No_Exception_Propagation)
1470
         then
1471
            --  If we have a local handler, then note that this is potentially
1472
            --  able to be transformed into a goto statement.
1473
 
1474
            H := Find_Local_Handler (Entity (Name (N)), N);
1475
 
1476
            if Present (H) then
1477
               if Local_Raise_Statements (H) = No_Elist then
1478
                  Set_Local_Raise_Statements (H, New_Elmt_List);
1479
               end if;
1480
 
1481
               --  Append the new entry if it is not there already. Sometimes
1482
               --  we have situations where due to reexpansion, the same node
1483
               --  is analyzed twice and would otherwise be added twice.
1484
 
1485
               Append_Unique_Elmt (N, Local_Raise_Statements (H));
1486
               Set_Has_Local_Raise (H);
1487
 
1488
            --  If no local handler, then generate no propagation warning
1489
 
1490
            else
1491
               Warn_If_No_Propagation (N);
1492
            end if;
1493
 
1494
         end if;
1495
      end if;
1496
 
1497
      --  If a string expression is present, then the raise statement is
1498
      --  converted to a call:
1499
      --     Raise_Exception (exception-name'Identity, string);
1500
      --  and there is nothing else to do.
1501
 
1502
      if Present (Expression (N)) then
1503
 
1504
         --  Avoid passing exception-name'identity in runtimes in which this
1505
         --  argument is not used. This avoids generating undefined references
1506
         --  to these exceptions when compiling with no optimization
1507
 
1508
         if Configurable_Run_Time_On_Target
1509
           and then (Restriction_Active (No_Exception_Handlers)
1510
                       or else
1511
                     Restriction_Active (No_Exception_Propagation))
1512
         then
1513
            Rewrite (N,
1514
              Make_Procedure_Call_Statement (Loc,
1515
                Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1516
                Parameter_Associations => New_List (
1517
                  New_Occurrence_Of (RTE (RE_Null_Id), Loc),
1518
                  Expression (N))));
1519
         else
1520
            Rewrite (N,
1521
              Make_Procedure_Call_Statement (Loc,
1522
                Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1523
                Parameter_Associations => New_List (
1524
                  Make_Attribute_Reference (Loc,
1525
                    Prefix         => Name (N),
1526
                    Attribute_Name => Name_Identity),
1527
                  Expression (N))));
1528
         end if;
1529
 
1530
         Analyze (N);
1531
         return;
1532
      end if;
1533
 
1534
      --  Remaining processing is for the case where no string expression is
1535
      --  present.
1536
 
1537
      --  Don't expand a raise statement that does not come from source if we
1538
      --  have already had configurable run-time violations, since most likely
1539
      --  it will be junk cascaded nonsense.
1540
 
1541
      if Configurable_Run_Time_Violations > 0
1542
        and then not Comes_From_Source (N)
1543
      then
1544
         return;
1545
      end if;
1546
 
1547
      --  Convert explicit raise of Program_Error, Constraint_Error, and
1548
      --  Storage_Error into the corresponding raise (in High_Integrity_Mode
1549
      --  all other raises will get normal expansion and be disallowed,
1550
      --  but this is also faster in all modes). Propagate Comes_From_Source
1551
      --  flag to the new node.
1552
 
1553
      if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1554
         Src := Comes_From_Source (N);
1555
 
1556
         if Entity (Name (N)) = Standard_Constraint_Error then
1557
            Rewrite (N,
1558
              Make_Raise_Constraint_Error (Loc, Reason => CE_Explicit_Raise));
1559
            Set_Comes_From_Source (N, Src);
1560
            Analyze (N);
1561
            return;
1562
 
1563
         elsif Entity (Name (N)) = Standard_Program_Error then
1564
            Rewrite (N,
1565
              Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
1566
            Set_Comes_From_Source (N, Src);
1567
            Analyze (N);
1568
            return;
1569
 
1570
         elsif Entity (Name (N)) = Standard_Storage_Error then
1571
            Rewrite (N,
1572
              Make_Raise_Storage_Error (Loc, Reason => SE_Explicit_Raise));
1573
            Set_Comes_From_Source (N, Src);
1574
            Analyze (N);
1575
            return;
1576
         end if;
1577
      end if;
1578
 
1579
      --  Case of name present, in this case we expand raise name to
1580
 
1581
      --    Raise_Exception (name'Identity, location_string);
1582
 
1583
      --  where location_string identifies the file/line of the raise
1584
 
1585
      if Present (Name (N)) then
1586
         declare
1587
            Id : Entity_Id := Entity (Name (N));
1588
 
1589
         begin
1590
            Name_Len := 0;
1591
            Build_Location_String (Loc);
1592
 
1593
            --  If the exception is a renaming, use the exception that it
1594
            --  renames (which might be a predefined exception, e.g.).
1595
 
1596
            if Present (Renamed_Object (Id)) then
1597
               Id := Renamed_Object (Id);
1598
            end if;
1599
 
1600
            --  Build a C-compatible string in case of no exception handlers,
1601
            --  since this is what the last chance handler is expecting.
1602
 
1603
            if No_Exception_Handlers_Set then
1604
 
1605
               --  Generate an empty message if configuration pragma
1606
               --  Suppress_Exception_Locations is set for this unit.
1607
 
1608
               if Opt.Exception_Locations_Suppressed then
1609
                  Name_Len := 1;
1610
               else
1611
                  Name_Len := Name_Len + 1;
1612
               end if;
1613
 
1614
               Name_Buffer (Name_Len) := ASCII.NUL;
1615
            end if;
1616
 
1617
            if Opt.Exception_Locations_Suppressed then
1618
               Name_Len := 0;
1619
            end if;
1620
 
1621
            Str := String_From_Name_Buffer;
1622
 
1623
            --  For VMS exceptions, convert the raise into a call to
1624
            --  lib$stop so it will be handled by __gnat_error_handler.
1625
 
1626
            if Is_VMS_Exception (Id) then
1627
               declare
1628
                  Excep_Image : String_Id;
1629
                  Cond        : Node_Id;
1630
 
1631
               begin
1632
                  if Present (Interface_Name (Id)) then
1633
                     Excep_Image := Strval (Interface_Name (Id));
1634
                  else
1635
                     Get_Name_String (Chars (Id));
1636
                     Set_All_Upper_Case;
1637
                     Excep_Image := String_From_Name_Buffer;
1638
                  end if;
1639
 
1640
                  if Exception_Code (Id) /= No_Uint then
1641
                     Cond :=
1642
                       Make_Integer_Literal (Loc, Exception_Code (Id));
1643
                  else
1644
                     Cond :=
1645
                       Unchecked_Convert_To (Standard_Integer,
1646
                         Make_Function_Call (Loc,
1647
                           Name => New_Occurrence_Of
1648
                             (RTE (RE_Import_Value), Loc),
1649
                           Parameter_Associations => New_List
1650
                             (Make_String_Literal (Loc,
1651
                               Strval => Excep_Image))));
1652
                  end if;
1653
 
1654
                  Rewrite (N,
1655
                    Make_Procedure_Call_Statement (Loc,
1656
                      Name =>
1657
                        New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
1658
                      Parameter_Associations => New_List (Cond)));
1659
                        Analyze_And_Resolve (Cond, Standard_Integer);
1660
               end;
1661
 
1662
            --  Not VMS exception case, convert raise to call to the
1663
            --  Raise_Exception routine.
1664
 
1665
            else
1666
               Rewrite (N,
1667
                 Make_Procedure_Call_Statement (Loc,
1668
                    Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1669
                    Parameter_Associations => New_List (
1670
                      Make_Attribute_Reference (Loc,
1671
                        Prefix => Name (N),
1672
                        Attribute_Name => Name_Identity),
1673
                      Make_String_Literal (Loc,
1674
                        Strval => Str))));
1675
            end if;
1676
         end;
1677
 
1678
      --  Case of no name present (reraise). We rewrite the raise to:
1679
 
1680
      --    Reraise_Occurrence_Always (EO);
1681
 
1682
      --  where EO is the current exception occurrence. If the current handler
1683
      --  does not have a choice parameter specification, then we provide one.
1684
 
1685
      else
1686
         --  Bypass expansion to a run-time call when back-end exception
1687
         --  handling is active, unless the target is a VM, CodePeer or
1688
         --  GNATprove. In CodePeer, raising an exception is treated as an
1689
         --  error, while in GNATprove all code with exceptions falls outside
1690
         --  the subset of code which can be formally analyzed.
1691
 
1692
         if VM_Target = No_VM
1693
           and then not CodePeer_Mode
1694
           and then Exception_Mechanism = Back_End_Exceptions
1695
         then
1696
            return;
1697
         end if;
1698
 
1699
         --  Find innermost enclosing exception handler (there must be one,
1700
         --  since the semantics has already verified that this raise statement
1701
         --  is valid, and a raise with no arguments is only permitted in the
1702
         --  context of an exception handler.
1703
 
1704
         Ehand := Parent (N);
1705
         while Nkind (Ehand) /= N_Exception_Handler loop
1706
            Ehand := Parent (Ehand);
1707
         end loop;
1708
 
1709
         --  Make exception choice parameter if none present. Note that we do
1710
         --  not need to put the entity on the entity chain, since no one will
1711
         --  be referencing this entity by normal visibility methods.
1712
 
1713
         if No (Choice_Parameter (Ehand)) then
1714
            E := Make_Temporary (Loc, 'E');
1715
            Set_Choice_Parameter (Ehand, E);
1716
            Set_Ekind (E, E_Variable);
1717
            Set_Etype (E, RTE (RE_Exception_Occurrence));
1718
            Set_Scope (E, Current_Scope);
1719
         end if;
1720
 
1721
         --  Now rewrite the raise as a call to Reraise. A special case arises
1722
         --  if this raise statement occurs in the context of a handler for
1723
         --  all others (i.e. an at end handler). in this case we avoid
1724
         --  the call to defer abort, cleanup routines are expected to be
1725
         --  called in this case with aborts deferred.
1726
 
1727
         declare
1728
            Ech : constant Node_Id := First (Exception_Choices (Ehand));
1729
            Ent : Entity_Id;
1730
 
1731
         begin
1732
            if Nkind (Ech) = N_Others_Choice
1733
              and then All_Others (Ech)
1734
            then
1735
               Ent := RTE (RE_Reraise_Occurrence_No_Defer);
1736
            else
1737
               Ent := RTE (RE_Reraise_Occurrence_Always);
1738
            end if;
1739
 
1740
            Rewrite (N,
1741
              Make_Procedure_Call_Statement (Loc,
1742
                Name => New_Occurrence_Of (Ent, Loc),
1743
                Parameter_Associations => New_List (
1744
                  New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
1745
         end;
1746
      end if;
1747
 
1748
      Analyze (N);
1749
   end Expand_N_Raise_Statement;
1750
 
1751
   ----------------------------------
1752
   -- Expand_N_Raise_Storage_Error --
1753
   ----------------------------------
1754
 
1755
   procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
1756
   begin
1757
      --  We adjust the condition to deal with the C/Fortran boolean case. This
1758
      --  may well not be necessary, as all such conditions are generated by
1759
      --  the expander and probably are all standard boolean, but who knows
1760
      --  what strange optimization in future may require this adjustment!
1761
 
1762
      Adjust_Condition (Condition (N));
1763
 
1764
      --  Now deal with possible local raise handling
1765
 
1766
      Possible_Local_Raise (N, Standard_Storage_Error);
1767
   end Expand_N_Raise_Storage_Error;
1768
 
1769
   --------------------------
1770
   -- Possible_Local_Raise --
1771
   --------------------------
1772
 
1773
   procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id) is
1774
   begin
1775
      --  Nothing to do if local raise optimization not active
1776
 
1777
      if not Debug_Flag_Dot_G
1778
        and then not Restriction_Active (No_Exception_Propagation)
1779
      then
1780
         return;
1781
      end if;
1782
 
1783
      --  Nothing to do if original node was an explicit raise, because in
1784
      --  that case, we already generated the required warning for the raise.
1785
 
1786
      if Nkind (Original_Node (N)) = N_Raise_Statement then
1787
         return;
1788
      end if;
1789
 
1790
      --  Otherwise see if we have a local handler for the exception
1791
 
1792
      declare
1793
         H : constant Node_Id := Find_Local_Handler (E, N);
1794
 
1795
      begin
1796
         --  If so, mark that it has a local raise
1797
 
1798
         if Present (H) then
1799
            Set_Has_Local_Raise (H, True);
1800
 
1801
         --  Otherwise, if the No_Exception_Propagation restriction is active
1802
         --  and the warning is enabled, generate the appropriate warnings.
1803
 
1804
         elsif Warn_On_Non_Local_Exception
1805
           and then Restriction_Active (No_Exception_Propagation)
1806
         then
1807
            Warn_No_Exception_Propagation_Active (N);
1808
 
1809
            if Configurable_Run_Time_Mode then
1810
               Error_Msg_NE
1811
                 ("\?& may call Last_Chance_Handler", N, E);
1812
            else
1813
               Error_Msg_NE
1814
                 ("\?& may result in unhandled exception", N, E);
1815
            end if;
1816
         end if;
1817
      end;
1818
   end Possible_Local_Raise;
1819
 
1820
   ------------------------------
1821
   -- Expand_N_Subprogram_Info --
1822
   ------------------------------
1823
 
1824
   procedure Expand_N_Subprogram_Info (N : Node_Id) is
1825
      Loc : constant Source_Ptr := Sloc (N);
1826
 
1827
   begin
1828
      --  For now, we replace an Expand_N_Subprogram_Info node with an
1829
      --  attribute reference that gives the address of the procedure.
1830
      --  This is because gigi does not yet recognize this node, and
1831
      --  for the initial targets, this is the right value anyway.
1832
 
1833
      Rewrite (N,
1834
        Make_Attribute_Reference (Loc,
1835
          Prefix => Identifier (N),
1836
          Attribute_Name => Name_Code_Address));
1837
 
1838
      Analyze_And_Resolve (N, RTE (RE_Code_Loc));
1839
   end Expand_N_Subprogram_Info;
1840
 
1841
   ------------------------
1842
   -- Find_Local_Handler --
1843
   ------------------------
1844
 
1845
   function Find_Local_Handler
1846
     (Ename : Entity_Id;
1847
      Nod   : Node_Id) return Node_Id
1848
   is
1849
      N : Node_Id;
1850
      P : Node_Id;
1851
      H : Node_Id;
1852
      C : Node_Id;
1853
 
1854
      SSE : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
1855
      --  This is used to test for wrapped actions below
1856
 
1857
      ERaise  : Entity_Id;
1858
      EHandle : Entity_Id;
1859
      --  The entity Id's for the exception we are raising and handling, using
1860
      --  the renamed exception if a Renamed_Entity is present.
1861
 
1862
   begin
1863
      --  Never any local handler if all handlers removed
1864
 
1865
      if Debug_Flag_Dot_X then
1866
         return Empty;
1867
      end if;
1868
 
1869
      --  Get the exception we are raising, allowing for renaming
1870
 
1871
      ERaise := Get_Renamed_Entity (Ename);
1872
 
1873
      --  We need to check if the node we are looking at is contained in
1874
      --
1875
 
1876
      --  Loop to search up the tree
1877
 
1878
      N := Nod;
1879
      loop
1880
         P := Parent (N);
1881
 
1882
         --  If we get to the top of the tree, or to a subprogram, task, entry,
1883
         --  protected body, or accept statement without having found a
1884
         --  matching handler, then there is no local handler.
1885
 
1886
         if No (P)
1887
           or else Nkind (P) = N_Subprogram_Body
1888
           or else Nkind (P) = N_Task_Body
1889
           or else Nkind (P) = N_Protected_Body
1890
           or else Nkind (P) = N_Entry_Body
1891
           or else Nkind (P) = N_Accept_Statement
1892
         then
1893
            return Empty;
1894
 
1895
            --  Test for handled sequence of statements with at least one
1896
            --  exception handler which might be the one we are looking for.
1897
 
1898
         elsif Nkind (P) = N_Handled_Sequence_Of_Statements
1899
           and then Present (Exception_Handlers (P))
1900
         then
1901
            --  Before we proceed we need to check if the node N is covered
1902
            --  by the statement part of P rather than one of its exception
1903
            --  handlers (an exception handler obviously does not cover its
1904
            --  own statements).
1905
 
1906
            --  This test is more delicate than might be thought. It is not
1907
            --  just a matter of checking the Statements (P), because the node
1908
            --  might be waiting to be wrapped in a transient scope, in which
1909
            --  case it will end up in the block statements, even though it
1910
            --  is not there now.
1911
 
1912
            if Is_List_Member (N)
1913
              and then (List_Containing (N) = Statements (P)
1914
                          or else
1915
                        List_Containing (N) = SSE.Actions_To_Be_Wrapped_Before
1916
                          or else
1917
                        List_Containing (N) = SSE.Actions_To_Be_Wrapped_After)
1918
            then
1919
               --  Loop through exception handlers
1920
 
1921
               H := First (Exception_Handlers (P));
1922
               while Present (H) loop
1923
 
1924
                  --  Guard against other constructs appearing in the list of
1925
                  --  exception handlers.
1926
 
1927
                  if Nkind (H) = N_Exception_Handler then
1928
 
1929
                     --  Loop through choices in one handler
1930
 
1931
                     C := First (Exception_Choices (H));
1932
                     while Present (C) loop
1933
 
1934
                        --  Deal with others case
1935
 
1936
                        if Nkind (C) = N_Others_Choice then
1937
 
1938
                           --  Matching others handler, but we need to ensure
1939
                           --  there is no choice parameter. If there is, then
1940
                           --  we don't have a local handler after all (since
1941
                           --  we do not allow choice parameters for local
1942
                           --  handlers).
1943
 
1944
                           if No (Choice_Parameter (H)) then
1945
                              return H;
1946
                           else
1947
                              return Empty;
1948
                           end if;
1949
 
1950
                        --  If not others must be entity name
1951
 
1952
                        elsif Nkind (C) /= N_Others_Choice then
1953
                           pragma Assert (Is_Entity_Name (C));
1954
                           pragma Assert (Present (Entity (C)));
1955
 
1956
                           --  Get exception being handled, dealing with
1957
                           --  renaming.
1958
 
1959
                           EHandle := Get_Renamed_Entity (Entity (C));
1960
 
1961
                           --  If match, then check choice parameter
1962
 
1963
                           if ERaise = EHandle then
1964
                              if No (Choice_Parameter (H)) then
1965
                                 return H;
1966
                              else
1967
                                 return Empty;
1968
                              end if;
1969
                           end if;
1970
                        end if;
1971
 
1972
                        Next (C);
1973
                     end loop;
1974
                  end if;
1975
 
1976
                  Next (H);
1977
               end loop;
1978
            end if;
1979
         end if;
1980
 
1981
         N := P;
1982
      end loop;
1983
   end Find_Local_Handler;
1984
 
1985
   ---------------------------------
1986
   -- Get_Local_Raise_Call_Entity --
1987
   ---------------------------------
1988
 
1989
   --  Note: this is primary provided for use by the back end in generating
1990
   --  calls to Local_Raise. But it would be too late in the back end to call
1991
   --  RTE if this actually caused a load/analyze of the unit. So what we do
1992
   --  is to ensure there is a dummy call to this function during front end
1993
   --  processing so that the unit gets loaded then, and not later.
1994
 
1995
   Local_Raise_Call_Entity     : Entity_Id;
1996
   Local_Raise_Call_Entity_Set : Boolean := False;
1997
 
1998
   function Get_Local_Raise_Call_Entity return Entity_Id is
1999
   begin
2000
      if not Local_Raise_Call_Entity_Set then
2001
         Local_Raise_Call_Entity_Set := True;
2002
 
2003
         if RTE_Available (RE_Local_Raise) then
2004
            Local_Raise_Call_Entity := RTE (RE_Local_Raise);
2005
         else
2006
            Local_Raise_Call_Entity := Empty;
2007
         end if;
2008
      end if;
2009
 
2010
      return Local_Raise_Call_Entity;
2011
   end Get_Local_Raise_Call_Entity;
2012
 
2013
   -----------------------------
2014
   -- Get_RT_Exception_Entity --
2015
   -----------------------------
2016
 
2017
   function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is
2018
   begin
2019
      case R is
2020
         when RT_CE_Exceptions => return Standard_Constraint_Error;
2021
         when RT_PE_Exceptions => return Standard_Program_Error;
2022
         when RT_SE_Exceptions => return Standard_Storage_Error;
2023
      end case;
2024
   end Get_RT_Exception_Entity;
2025
 
2026
   ----------------------
2027
   -- Is_Non_Ada_Error --
2028
   ----------------------
2029
 
2030
   function Is_Non_Ada_Error (E : Entity_Id) return Boolean is
2031
   begin
2032
      if not OpenVMS_On_Target then
2033
         return False;
2034
      end if;
2035
 
2036
      Get_Name_String (Chars (E));
2037
 
2038
      --  Note: it is a little irregular for the body of exp_ch11 to know
2039
      --  the details of the encoding scheme for names, but on the other
2040
      --  hand, gigi knows them, and this is for gigi's benefit anyway!
2041
 
2042
      if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then
2043
         return False;
2044
      end if;
2045
 
2046
      return True;
2047
   end Is_Non_Ada_Error;
2048
 
2049
   ----------------------------
2050
   -- Warn_If_No_Propagation --
2051
   ----------------------------
2052
 
2053
   procedure Warn_If_No_Propagation (N : Node_Id) is
2054
   begin
2055
      if Restriction_Check_Required (No_Exception_Propagation)
2056
        and then Warn_On_Non_Local_Exception
2057
      then
2058
         Warn_No_Exception_Propagation_Active (N);
2059
 
2060
         if Configurable_Run_Time_Mode then
2061
            Error_Msg_N
2062
              ("\?Last_Chance_Handler will be called on exception", N);
2063
         else
2064
            Error_Msg_N
2065
              ("\?execution may raise unhandled exception", N);
2066
         end if;
2067
      end if;
2068
   end Warn_If_No_Propagation;
2069
 
2070
   ------------------------------------------
2071
   -- Warn_No_Exception_Propagation_Active --
2072
   ------------------------------------------
2073
 
2074
   procedure Warn_No_Exception_Propagation_Active (N : Node_Id) is
2075
   begin
2076
      Error_Msg_N
2077
        ("?pragma Restrictions (No_Exception_Propagation) in effect", N);
2078
   end Warn_No_Exception_Propagation_Active;
2079
 
2080
end Exp_Ch11;

powered by: WebSVN 2.1.0

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