?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2005-01-22 Thomas Koenig <Thomas.Koenig@online.de>
[official-gcc.git] / gcc / ada / exp_ch11.adb
blob80ac70db61a2665b05a92c079bdfef08bfdf8d0a
1 ------------------------------------------------------------------------------
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-2004 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
26
27 with Atree; use Atree;
28 with Casing; use Casing;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Errout; use Errout;
32 with Exp_Ch7; use Exp_Ch7;
33 with Exp_Util; use Exp_Util;
34 with Hostparm; use Hostparm;
35 with Inline; use Inline;
36 with Lib; use Lib;
37 with Namet; use Namet;
38 with Nlists; use Nlists;
39 with Nmake; use Nmake;
40 with Opt; use Opt;
41 with Rtsfind; use Rtsfind;
42 with Restrict; use Restrict;
43 with Rident; use Rident;
44 with Sem; use Sem;
45 with Sem_Ch5; use Sem_Ch5;
46 with Sem_Ch8; use Sem_Ch8;
47 with Sem_Res; use Sem_Res;
48 with Sem_Util; use Sem_Util;
49 with Sinfo; use Sinfo;
50 with Sinput; use Sinput;
51 with Snames; use Snames;
52 with Stand; use Stand;
53 with Stringt; use Stringt;
54 with Targparm; use Targparm;
55 with Tbuild; use Tbuild;
56 with Uintp; use Uintp;
57 with Uname; use Uname;
58
59 package body Exp_Ch11 is
60
61 SD_List : List_Id;
62 -- This list gathers the values SDn'Unrestricted_Access used to
63 -- construct the unit exception table. It is set to Empty_List if
64 -- there are no subprogram descriptors.
65
66 -----------------------
67 -- Local Subprograms --
68 -----------------------
69
70 procedure Expand_Exception_Handler_Tables (HSS : Node_Id);
71 -- Subsidiary procedure called by Expand_Exception_Handlers if zero
72 -- cost exception handling is installed for this target. Replaces the
73 -- exception handler structure with appropriate labeled code and tables
74 -- that allow the zero cost exception handling circuits to find the
75 -- correct handler (see unit Ada.Exceptions for details).
76
77 procedure Generate_Subprogram_Descriptor
78 (N : Node_Id;
79 Loc : Source_Ptr;
80 Spec : Entity_Id;
81 Slist : List_Id);
82 -- Procedure called to generate a subprogram descriptor. N is the
83 -- subprogram body node or, in the case of an imported subprogram, is
84 -- Empty, and Spec is the entity of the sunprogram. For details of the
85 -- required structure, see package System.Exceptions. The generated
86 -- subprogram descriptor is appended to Slist. Loc provides the
87 -- source location to be used for the generated descriptor.
88
89 ---------------------------
90 -- Expand_At_End_Handler --
91 ---------------------------
92
93 -- For a handled statement sequence that has a cleanup (At_End_Proc
94 -- field set), an exception handler of the following form is required:
95
96 -- exception
97 -- when all others =>
98 -- cleanup call
99 -- raise;
100
101 -- Note: this exception handler is treated rather specially by
102 -- subsequent expansion in two respects:
103
104 -- The normal call to Undefer_Abort is omitted
105 -- The raise call does not do Defer_Abort
106
107 -- This is because the current tasking code seems to assume that
108 -- the call to the cleanup routine that is made from an exception
109 -- handler for the abort signal is called with aborts deferred.
110
111 -- This expansion is only done if we have front end exception handling.
112 -- If we have back end exception handling, then the AT END handler is
113 -- left alone, and cleanups (including the exceptional case) are handled
114 -- by the back end.
115
116 -- In the front end case, the exception handler described above handles
117 -- the exceptional case. The AT END handler is left in the generated tree
118 -- and the code generator (e.g. gigi) must still handle proper generation
119 -- of cleanup calls for the non-exceptional case.
120
121 procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is
122 Clean : constant Entity_Id := Entity (At_End_Proc (HSS));
123 Loc : constant Source_Ptr := Sloc (Clean);
124 Ohandle : Node_Id;
125 Stmnts : List_Id;
126
127 begin
128 pragma Assert (Present (Clean));
129 pragma Assert (No (Exception_Handlers (HSS)));
130
131 -- Don't expand if back end exception handling active
132
133 if Exception_Mechanism = Back_End_ZCX_Exceptions then
134 return;
135 end if;
136
137 -- Don't expand an At End handler if we have already had configurable
138 -- run-time violations, since likely this will just be a matter of
139 -- generating useless cascaded messages
140
141 if Configurable_Run_Time_Violations > 0 then
142 return;
143 end if;
144
145 if Restriction_Active (No_Exception_Handlers) then
146 return;
147 end if;
148
149 if Present (Block) then
150 New_Scope (Block);
151 end if;
152
153 Ohandle :=
154 Make_Others_Choice (Loc);
155 Set_All_Others (Ohandle);
156
157 Stmnts := New_List (
158 Make_Procedure_Call_Statement (Loc,
159 Name => New_Occurrence_Of (Clean, Loc)),
160 Make_Raise_Statement (Loc));
161
162 Set_Exception_Handlers (HSS, New_List (
163 Make_Exception_Handler (Loc,
164 Exception_Choices => New_List (Ohandle),
165 Statements => Stmnts)));
166
167 Analyze_List (Stmnts, Suppress => All_Checks);
168 Expand_Exception_Handlers (HSS);
169
170 if Present (Block) then
171 Pop_Scope;
172 end if;
173 end Expand_At_End_Handler;
174
175 -------------------------------------
176 -- Expand_Exception_Handler_Tables --
177 -------------------------------------
178
179 -- See Ada.Exceptions specification for full details of the data
180 -- structures that we need to construct here. As an example of the
181 -- transformation that is required, given the structure:
182
183 -- declare
184 -- {declarations}
185 -- ..
186 -- begin
187 -- {statements-1}
188 -- ...
189 -- exception
190 -- when a | b =>
191 -- {statements-2}
192 -- ...
193 -- when others =>
194 -- {statements-3}
195 -- ...
196 -- end;
197
198 -- We transform this into:
199
200 -- declare
201 -- {declarations}
202 -- ...
203 -- L1 : label;
204 -- L2 : label;
205 -- L3 : label;
206 -- L4 : Label;
207 -- L5 : label;
208
209 -- begin
210 -- <<L1>>
211 -- {statements-1}
212 -- <<L2>>
213
214 -- exception
215
216 -- when a | b =>
217 -- <<L3>>
218 -- {statements-2}
219
220 -- HR2 : constant Handler_Record := (
221 -- Lo => L1'Address,
222 -- Hi => L2'Address,
223 -- Id => a'Identity,
224 -- Handler => L5'Address);
225
226 -- HR3 : constant Handler_Record := (
227 -- Lo => L1'Address,
228 -- Hi => L2'Address,
229 -- Id => b'Identity,
230 -- Handler => L4'Address);
231
232 -- when others =>
233 -- <<L4>>
234 -- {statements-3}
235
236 -- HR1 : constant Handler_Record := (
237 -- Lo => L1'Address,
238 -- Hi => L2'Address,
239 -- Id => Others_Id,
240 -- Handler => L4'Address);
241 -- end;
242
243 -- The exception handlers in the transformed version are marked with the
244 -- Zero_Cost_Handling flag set, and all gigi does in this case is simply
245 -- to put the handler code somewhere. It can optionally be put inline
246 -- between the goto L3 and the label <<L3>> (which is why we generate
247 -- that goto in the first place).
248
249 procedure Expand_Exception_Handler_Tables (HSS : Node_Id) is
250 Loc : constant Source_Ptr := Sloc (HSS);
251 Handlrs : constant List_Id := Exception_Handlers (HSS);
252 Stms : constant List_Id := Statements (HSS);
253 Handler : Node_Id;
254
255 Hlist : List_Id;
256 -- This is the list to which handlers are to be appended. It is
257 -- either the list for the enclosing subprogram, or the enclosing
258 -- selective accept statement (which will turn into a subprogram
259 -- during expansion later on).
260
261 L1 : constant Entity_Id :=
262 Make_Defining_Identifier (Loc,
263 Chars => New_Internal_Name ('L'));
264
265 L2 : constant Entity_Id :=
266 Make_Defining_Identifier (Loc,
267 Chars => New_Internal_Name ('L'));
268
269 Lnn : Entity_Id;
270 Choice : Node_Id;
271 E_Id : Node_Id;
272 HR_Ent : Node_Id;
273 HL_Ref : Node_Id;
274 Item : Node_Id;
275
276 Subp_Entity : Entity_Id;
277 -- This is the entity for the subprogram (or library level package)
278 -- to which the handler record is to be attached for later reference
279 -- in a subprogram descriptor for this entity.
280
281 procedure Append_To_Stms (N : Node_Id);
282 -- Append given statement to the end of the statements of the
283 -- handled sequence of statements and analyze it in place.
284
285 function Inside_Selective_Accept return Boolean;
286 -- This function is called if we are inside the scope of an entry
287 -- or task. It checks if the handler is appearing in the context
288 -- of a selective accept statement. If so, Hlist is set to
289 -- temporarily park the handlers in the N_Accept_Alternative.
290 -- node. They will subsequently be moved to the procedure entity
291 -- for the procedure built for this alternative. The statements that
292 -- follow the Accept within the alternative are not inside the Accept
293 -- for purposes of this test, and handlers that may appear within
294 -- them belong in the enclosing task procedure.
295
296 procedure Set_Hlist;
297 -- Sets the handler list corresponding to Subp_Entity
298
299 --------------------
300 -- Append_To_Stms --
301 --------------------
302
303 procedure Append_To_Stms (N : Node_Id) is
304 begin
305 Insert_After_And_Analyze (Last (Stms), N);
306 Set_Exception_Junk (N);
307 end Append_To_Stms;
308
309 -----------------------------
310 -- Inside_Selective_Accept --
311 -----------------------------
312
313 function Inside_Selective_Accept return Boolean is
314 Parnt : Node_Id;
315 Curr : Node_Id := HSS;
316
317 begin
318 Parnt := Parent (HSS);
319 while Nkind (Parnt) /= N_Compilation_Unit loop
320 if Nkind (Parnt) = N_Accept_Alternative
321 and then Curr = Accept_Statement (Parnt)
322 then
323 if Present (Accept_Handler_Records (Parnt)) then
324 Hlist := Accept_Handler_Records (Parnt);
325 else
326 Hlist := New_List;
327 Set_Accept_Handler_Records (Parnt, Hlist);
328 end if;
329
330 return True;
331 else
332 Curr := Parnt;
333 Parnt := Parent (Parnt);
334 end if;
335 end loop;
336
337 return False;
338 end Inside_Selective_Accept;
339
340 ---------------
341 -- Set_Hlist --
342 ---------------
343
344 procedure Set_Hlist is
345 begin
346 -- Never try to inline a subprogram with exception handlers
347
348 Set_Is_Inlined (Subp_Entity, False);
349
350 if Present (Subp_Entity)
351 and then Present (Handler_Records (Subp_Entity))
352 then
353 Hlist := Handler_Records (Subp_Entity);
354 else
355 Hlist := New_List;
356 Set_Handler_Records (Subp_Entity, Hlist);
357 end if;
358 end Set_Hlist;
359
360 -- Start of processing for Expand_Exception_Handler_Tables
361
362 begin
363 -- Nothing to do if this handler has already been processed
364
365 if Zero_Cost_Handling (HSS) then
366 return;
367 end if;
368
369 Set_Zero_Cost_Handling (HSS);
370
371 -- Find the parent subprogram or package scope containing this
372 -- exception frame. This should always find a real package or
373 -- subprogram. If it does not it will stop at Standard, but
374 -- this cannot legitimately occur.
375
376 -- We only stop at library level packages, for inner packages
377 -- we always attach handlers to the containing procedure.
378
379 Subp_Entity := Current_Scope;
380 Scope_Loop : loop
381
382 -- Never need tables expanded inside a generic template
383
384 if Is_Generic_Unit (Subp_Entity) then
385 return;
386
387 -- Stop if we reached containing subprogram. Go to protected
388 -- subprogram if there is one defined.
389
390 elsif Ekind (Subp_Entity) = E_Function
391 or else Ekind (Subp_Entity) = E_Procedure
392 then
393 if Present (Protected_Body_Subprogram (Subp_Entity)) then
394 Subp_Entity := Protected_Body_Subprogram (Subp_Entity);
395 end if;
396
397 Set_Hlist;
398 exit Scope_Loop;
399
400 -- Case of within an entry
401
402 elsif Is_Entry (Subp_Entity) then
403
404 -- Protected entry, use corresponding body subprogram
405
406 if Present (Protected_Body_Subprogram (Subp_Entity)) then
407 Subp_Entity := Protected_Body_Subprogram (Subp_Entity);
408 Set_Hlist;
409 exit Scope_Loop;
410
411 -- Check if we are within a selective accept alternative
412
413 elsif Inside_Selective_Accept then
414
415 -- As a side effect, Inside_Selective_Accept set Hlist,
416 -- in much the same manner as Set_Hlist, except that
417 -- the list involved was the one for the selective accept.
418
419 exit Scope_Loop;
420 end if;
421
422 -- Case of within library level package
423
424 elsif Ekind (Subp_Entity) = E_Package
425 and then Is_Compilation_Unit (Subp_Entity)
426 then
427 if Is_Body_Name (Unit_Name (Get_Code_Unit (HSS))) then
428 Subp_Entity := Body_Entity (Subp_Entity);
429 end if;
430
431 Set_Hlist;
432 exit Scope_Loop;
433
434 -- Task type case
435
436 elsif Ekind (Subp_Entity) = E_Task_Type then
437
438 -- Check if we are within a selective accept alternative
439
440 if Inside_Selective_Accept then
441
442 -- As a side effect, Inside_Selective_Accept set Hlist,
443 -- in much the same manner as Set_Hlist, except that the
444 -- list involved was the one for the selective accept.
445
446 exit Scope_Loop;
447
448 -- Stop if we reached task type with task body procedure,
449 -- use the task body procedure.
450
451 elsif Present (Get_Task_Body_Procedure (Subp_Entity)) then
452 Subp_Entity := Get_Task_Body_Procedure (Subp_Entity);
453 Set_Hlist;
454 exit Scope_Loop;
455 end if;
456 end if;
457
458 -- If we fall through, keep looking
459
460 Subp_Entity := Scope (Subp_Entity);
461 end loop Scope_Loop;
462
463 pragma Assert (Subp_Entity /= Standard_Standard);
464
465 -- Analyze standard labels
466
467 Analyze_Label_Entity (L1);
468 Analyze_Label_Entity (L2);
469
470 Insert_Before_And_Analyze (First (Stms),
471 Make_Label (Loc,
472 Identifier => New_Occurrence_Of (L1, Loc)));
473 Set_Exception_Junk (First (Stms));
474
475 Append_To_Stms (
476 Make_Label (Loc,
477 Identifier => New_Occurrence_Of (L2, Loc)));
478
479 -- Loop through exception handlers
480
481 Handler := First_Non_Pragma (Handlrs);
482 while Present (Handler) loop
483 Set_Zero_Cost_Handling (Handler);
484
485 -- Add label at start of handler, and goto at the end
486
487 Lnn :=
488 Make_Defining_Identifier (Loc,
489 Chars => New_Internal_Name ('L'));
490
491 Analyze_Label_Entity (Lnn);
492
493 Item :=
494 Make_Label (Loc,
495 Identifier => New_Occurrence_Of (Lnn, Loc));
496 Set_Exception_Junk (Item);
497 Insert_Before_And_Analyze (First (Statements (Handler)), Item);
498
499 -- Loop through choices
500
501 Choice := First (Exception_Choices (Handler));
502 while Present (Choice) loop
503
504 -- Others (or all others) choice
505
506 if Nkind (Choice) = N_Others_Choice then
507 if All_Others (Choice) then
508 E_Id := New_Occurrence_Of (RTE (RE_All_Others_Id), Loc);
509 else
510 E_Id := New_Occurrence_Of (RTE (RE_Others_Id), Loc);
511 end if;
512
513 -- Special case of VMS_Exception. Not clear what we will do
514 -- eventually here if and when we implement zero cost exceptions
515 -- on VMS. But at least for now, don't blow up trying to take
516 -- a garbage code address for such an exception.
517
518 elsif Is_VMS_Exception (Entity (Choice)) then
519 E_Id := New_Occurrence_Of (RTE (RE_Null_Id), Loc);
520
521 -- Normal case of specific exception choice
522
523 else
524 E_Id :=
525 Make_Attribute_Reference (Loc,
526 Prefix => New_Occurrence_Of (Entity (Choice), Loc),
527 Attribute_Name => Name_Identity);
528 end if;
529
530 HR_Ent :=
531 Make_Defining_Identifier (Loc,
532 Chars => New_Internal_Name ('H'));
533
534 HL_Ref :=
535 Make_Attribute_Reference (Loc,
536 Prefix => New_Occurrence_Of (HR_Ent, Loc),
537 Attribute_Name => Name_Unrestricted_Access);
538
539 -- Now we need to add the entry for the new handler record to
540 -- the list of handler records for the current subprogram.
541
542 -- Normally we end up generating the handler records in exactly
543 -- the right order. Here right order means innermost first,
544 -- since the table will be searched sequentially. Since we
545 -- generally expand from outside to inside, the order is just
546 -- what we want, and we need to append the new entry to the
547 -- end of the list.
548
549 -- However, there are exceptions, notably in the case where
550 -- a generic body is inserted later on. See for example the
551 -- case of ACVC test C37213J, which has the following form:
552
553 -- generic package x ... end x;
554 -- package body x is
555 -- begin
556 -- ...
557 -- exception (1)
558 -- ...
559 -- end x;
560
561 -- ...
562
563 -- declare
564 -- package q is new x;
565 -- begin
566 -- ...
567 -- exception (2)
568 -- ...
569 -- end;
570
571 -- In this case, we will expand exception handler (2) first,
572 -- since the expansion of (1) is delayed till later when the
573 -- generic body is inserted. But (1) belongs before (2) in
574 -- the chain.
575
576 -- Note that scopes are not totally ordered, because two
577 -- scopes can be in parallel blocks, so that it does not
578 -- matter what order these entries appear in. An ordering
579 -- relation exists if one scope is inside another, and what
580 -- we really want is some partial ordering.
581
582 -- A simple, not very efficient, but adequate algorithm to
583 -- achieve this partial ordering is to search the list for
584 -- the first entry containing the given scope, and put the
585 -- new entry just before it.
586
587 declare
588 New_Scop : constant Entity_Id := Current_Scope;
589 Ent : Node_Id;
590
591 begin
592 Ent := First (Hlist);
593 loop
594 -- If all searched, then we can just put the new
595 -- entry at the end of the list (it actually does
596 -- not matter where we put it in this case).
597
598 if No (Ent) then
599 Append_To (Hlist, HL_Ref);
600 exit;
601
602 -- If the current scope is within the scope of the
603 -- entry then insert the entry before to retain the
604 -- proper order as per above discussion.
605
606 -- Note that for equal entries, we just keep going,
607 -- which is fine, the entry will end up at the end
608 -- of the list where it belongs.
609
610 elsif Scope_Within
611 (New_Scop, Scope (Entity (Prefix (Ent))))
612 then
613 Insert_Before (Ent, HL_Ref);
614 exit;
615
616 -- Otherwise keep looking
617
618 else
619 Next (Ent);
620 end if;
621 end loop;
622 end;
623
624 Item :=
625 Make_Object_Declaration (Loc,
626 Defining_Identifier => HR_Ent,
627 Constant_Present => True,
628 Aliased_Present => True,
629 Object_Definition =>
630 New_Occurrence_Of (RTE (RE_Handler_Record), Loc),
631
632 Expression =>
633 Make_Aggregate (Loc,
634 Expressions => New_List (
635 Make_Attribute_Reference (Loc, -- Lo
636 Prefix => New_Occurrence_Of (L1, Loc),
637 Attribute_Name => Name_Address),
638
639 Make_Attribute_Reference (Loc, -- Hi
640 Prefix => New_Occurrence_Of (L2, Loc),
641 Attribute_Name => Name_Address),
642
643 E_Id, -- Id
644
645 Make_Attribute_Reference (Loc,
646 Prefix => New_Occurrence_Of (Lnn, Loc), -- Handler
647 Attribute_Name => Name_Address))));
648
649 Set_Handler_List_Entry (Item, HL_Ref);
650 Set_Exception_Junk (Item);
651 Insert_After_And_Analyze (Last (Statements (Handler)), Item);
652 Set_Is_Statically_Allocated (HR_Ent);
653
654 -- If this is a late insertion (from body instance) it is being
655 -- inserted in the component list of an already analyzed aggre-
656 -- gate, and must be analyzed explicitly.
657
658 Analyze_And_Resolve (HL_Ref, RTE (RE_Handler_Record_Ptr));
659
660 Next (Choice);
661 end loop;
662
663 Next_Non_Pragma (Handler);
664 end loop;
665 end Expand_Exception_Handler_Tables;
666
667 -------------------------------
668 -- Expand_Exception_Handlers --
669 -------------------------------
670
671 procedure Expand_Exception_Handlers (HSS : Node_Id) is
672 Handlrs : constant List_Id := Exception_Handlers (HSS);
673 Loc : Source_Ptr;
674 Handler : Node_Id;
675 Others_Choice : Boolean;
676 Obj_Decl : Node_Id;
677
678 procedure Prepend_Call_To_Handler
679 (Proc : RE_Id;
680 Args : List_Id := No_List);
681 -- Routine to prepend a call to the procedure referenced by Proc at
682 -- the start of the handler code for the current Handler.
683
684 -----------------------------
685 -- Prepend_Call_To_Handler --
686 -----------------------------
687
688 procedure Prepend_Call_To_Handler
689 (Proc : RE_Id;
690 Args : List_Id := No_List)
691 is
692 Ent : constant Entity_Id := RTE (Proc);
693
694 begin
695 -- If we have no Entity, then we are probably in no run time mode
696 -- or some weird error has occured. In either case do do nothing!
697
698 if Present (Ent) then
699 declare
700 Call : constant Node_Id :=
701 Make_Procedure_Call_Statement (Loc,
702 Name => New_Occurrence_Of (RTE (Proc), Loc),
703 Parameter_Associations => Args);
704
705 begin
706 Prepend_To (Statements (Handler), Call);
707 Analyze (Call, Suppress => All_Checks);
708 end;
709 end if;
710 end Prepend_Call_To_Handler;
711
712 -- Start of processing for Expand_Exception_Handlers
713
714 begin
715 -- Loop through handlers
716
717 Handler := First_Non_Pragma (Handlrs);
718 Handler_Loop : while Present (Handler) loop
719 Loc := Sloc (Handler);
720
721 -- Remove source handler if gnat debug flag N is set
722
723 if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
724 declare
725 H : constant Node_Id := Handler;
726 begin
727 Next_Non_Pragma (Handler);
728 Remove (H);
729 goto Continue_Handler_Loop;
730 end;
731 end if;
732
733
734 -- If an exception occurrence is present, then we must declare it
735 -- and initialize it from the value stored in the TSD
736
737 -- declare
738 -- name : Exception_Occurrence;
739 --
740 -- begin
741 -- Save_Occurrence (name, Get_Current_Excep.all)
742 -- ...
743 -- end;
744
745 if Present (Choice_Parameter (Handler)) then
746 declare
747 Cparm : constant Entity_Id := Choice_Parameter (Handler);
748 Clc : constant Source_Ptr := Sloc (Cparm);
749 Save : Node_Id;
750
751 begin
752 Save :=
753 Make_Procedure_Call_Statement (Loc,
754 Name =>
755 New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc),
756 Parameter_Associations => New_List (
757 New_Occurrence_Of (Cparm, Clc),
758 Make_Explicit_Dereference (Loc,
759 Make_Function_Call (Loc,
760 Name => Make_Explicit_Dereference (Loc,
761 New_Occurrence_Of
762 (RTE (RE_Get_Current_Excep), Loc))))));
763
764 Mark_Rewrite_Insertion (Save);
765 Prepend (Save, Statements (Handler));
766
767 Obj_Decl :=
768 Make_Object_Declaration (Clc,
769 Defining_Identifier => Cparm,
770 Object_Definition =>
771 New_Occurrence_Of
772 (RTE (RE_Exception_Occurrence), Clc));
773 Set_No_Initialization (Obj_Decl, True);
774
775 Rewrite (Handler,
776 Make_Exception_Handler (Loc,
777 Exception_Choices => Exception_Choices (Handler),
778
779 Statements => New_List (
780 Make_Block_Statement (Loc,
781 Declarations => New_List (Obj_Decl),
782 Handled_Statement_Sequence =>
783 Make_Handled_Sequence_Of_Statements (Loc,
784 Statements => Statements (Handler))))));
785
786 Analyze_List (Statements (Handler), Suppress => All_Checks);
787 end;
788 end if;
789
790 -- The processing at this point is rather different for the
791 -- JVM case, so we completely separate the processing.
792
793 -- For the JVM case, we unconditionally call Update_Exception,
794 -- passing a call to the intrinsic function Current_Target_Exception
795 -- (see JVM version of Ada.Exceptions in 4jexcept.adb for details).
796
797 if Hostparm.Java_VM then
798 declare
799 Arg : constant Node_Id :=
800 Make_Function_Call (Loc,
801 Name => New_Occurrence_Of
802 (RTE (RE_Current_Target_Exception), Loc));
803 begin
804 Prepend_Call_To_Handler (RE_Update_Exception, New_List (Arg));
805 end;
806
807 -- For the normal case, we have to worry about the state of abort
808 -- deferral. Generally, we defer abort during runtime handling of
809 -- exceptions. When control is passed to the handler, then in the
810 -- normal case we undefer aborts. In any case this entire handling
811 -- is relevant only if aborts are allowed!
812
813 elsif Abort_Allowed then
814
815 -- There are some special cases in which we do not do the
816 -- undefer. In particular a finalization (AT END) handler
817 -- wants to operate with aborts still deferred.
818
819 -- We also suppress the call if this is the special handler
820 -- for Abort_Signal, since if we are aborting, we want to keep
821 -- aborts deferred (one abort is enough thank you very much :-)
822
823 -- If abort really needs to be deferred the expander must add
824 -- this call explicitly, see Exp_Ch9.Expand_N_Asynchronous_Select.
825
826 Others_Choice :=
827 Nkind (First (Exception_Choices (Handler))) = N_Others_Choice;
828
829 if (Others_Choice
830 or else Entity (First (Exception_Choices (Handler))) /=
831 Stand.Abort_Signal)
832 and then not
833 (Others_Choice
834 and then All_Others (First (Exception_Choices (Handler))))
835 and then Abort_Allowed
836 then
837 Prepend_Call_To_Handler (RE_Abort_Undefer);
838 end if;
839 end if;
840
841 Next_Non_Pragma (Handler);
842
843 <<Continue_Handler_Loop>>
844 null;
845 end loop Handler_Loop;
846
847 -- If all handlers got removed by gnatdN, then remove the list
848
849 if Debug_Flag_Dot_X
850 and then Is_Empty_List (Exception_Handlers (HSS))
851 then
852 Set_Exception_Handlers (HSS, No_List);
853 end if;
854
855 -- The last step for expanding exception handlers is to expand the
856 -- exception tables if zero cost exception handling is active.
857
858 if Exception_Mechanism = Front_End_ZCX_Exceptions then
859 Expand_Exception_Handler_Tables (HSS);
860 end if;
861 end Expand_Exception_Handlers;
862
863 ------------------------------------
864 -- Expand_N_Exception_Declaration --
865 ------------------------------------
866
867 -- Generates:
868 -- exceptE : constant String := "A.B.EXCEP"; -- static data
869 -- except : exception_data := (
870 -- Handled_By_Other => False,
871 -- Lang => 'A',
872 -- Name_Length => exceptE'Length,
873 -- Full_Name => exceptE'Address,
874 -- HTable_Ptr => null,
875 -- Import_Code => 0,
876 -- Raise_Hook => null,
877 -- );
878
879 -- (protecting test only needed if not at library level)
880 --
881 -- exceptF : Boolean := True -- static data
882 -- if exceptF then
883 -- exceptF := False;
884 -- Register_Exception (except'Unchecked_Access);
885 -- end if;
886
887 procedure Expand_N_Exception_Declaration (N : Node_Id) is
888 Loc : constant Source_Ptr := Sloc (N);
889 Id : constant Entity_Id := Defining_Identifier (N);
890 L : List_Id := New_List;
891 Flag_Id : Entity_Id;
892
893 Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E');
894 Exname : constant Node_Id :=
895 Make_Defining_Identifier (Loc, Name_Exname);
896
897 begin
898 -- There is no expansion needed when compiling for the JVM since the
899 -- JVM has a built-in exception mechanism. See 4jexcept.ads for details.
900
901 if Hostparm.Java_VM then
902 return;
903 end if;
904
905 -- Definition of the external name: nam : constant String := "A.B.NAME";
906
907 Insert_Action (N,
908 Make_Object_Declaration (Loc,
909 Defining_Identifier => Exname,
910 Constant_Present => True,
911 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
912 Expression => Make_String_Literal (Loc, Full_Qualified_Name (Id))));
913
914 Set_Is_Statically_Allocated (Exname);
915
916 -- Create the aggregate list for type Standard.Exception_Type:
917 -- Handled_By_Other component: False
918
919 Append_To (L, New_Occurrence_Of (Standard_False, Loc));
920
921 -- Lang component: 'A'
922
923 Append_To (L,
924 Make_Character_Literal (Loc, Name_uA, Get_Char_Code ('A')));
925
926 -- Name_Length component: Nam'Length
927
928 Append_To (L,
929 Make_Attribute_Reference (Loc,
930 Prefix => New_Occurrence_Of (Exname, Loc),
931 Attribute_Name => Name_Length));
932
933 -- Full_Name component: Standard.A_Char!(Nam'Address)
934
935 Append_To (L, Unchecked_Convert_To (Standard_A_Char,
936 Make_Attribute_Reference (Loc,
937 Prefix => New_Occurrence_Of (Exname, Loc),
938 Attribute_Name => Name_Address)));
939
940 -- HTable_Ptr component: null
941
942 Append_To (L, Make_Null (Loc));
943
944 -- Import_Code component: 0
945
946 Append_To (L, Make_Integer_Literal (Loc, 0));
947
948 -- Raise_Hook component: null
949
950 Append_To (L, Make_Null (Loc));
951
952 Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
953 Analyze_And_Resolve (Expression (N), Etype (Id));
954
955 -- Register_Exception (except'Unchecked_Access);
956
957 if not Restriction_Active (No_Exception_Handlers)
958 and then not Restriction_Active (No_Exception_Registration)
959 then
960 L := New_List (
961 Make_Procedure_Call_Statement (Loc,
962 Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
963 Parameter_Associations => New_List (
964 Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
965 Make_Attribute_Reference (Loc,
966 Prefix => New_Occurrence_Of (Id, Loc),
967 Attribute_Name => Name_Unrestricted_Access)))));
968
969 Set_Register_Exception_Call (Id, First (L));
970
971 if not Is_Library_Level_Entity (Id) then
972 Flag_Id := Make_Defining_Identifier (Loc,
973 New_External_Name (Chars (Id), 'F'));
974
975 Insert_Action (N,
976 Make_Object_Declaration (Loc,
977 Defining_Identifier => Flag_Id,
978 Object_Definition =>
979 New_Occurrence_Of (Standard_Boolean, Loc),
980 Expression =>
981 New_Occurrence_Of (Standard_True, Loc)));
982
983 Set_Is_Statically_Allocated (Flag_Id);
984
985 Append_To (L,
986 Make_Assignment_Statement (Loc,
987 Name => New_Occurrence_Of (Flag_Id, Loc),
988 Expression => New_Occurrence_Of (Standard_False, Loc)));
989
990 Insert_After_And_Analyze (N,
991 Make_Implicit_If_Statement (N,
992 Condition => New_Occurrence_Of (Flag_Id, Loc),
993 Then_Statements => L));
994
995 else
996 Insert_List_After_And_Analyze (N, L);
997 end if;
998 end if;
999
1000 end Expand_N_Exception_Declaration;
1001
1002 ---------------------------------------------
1003 -- Expand_N_Handled_Sequence_Of_Statements --
1004 ---------------------------------------------
1005
1006 procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
1007 begin
1008 if Present (Exception_Handlers (N))
1009 and then not Restriction_Active (No_Exception_Handlers)
1010 then
1011 Expand_Exception_Handlers (N);
1012 end if;
1013
1014 -- The following code needs comments ???
1015
1016 if Nkind (Parent (N)) /= N_Package_Body
1017 and then Nkind (Parent (N)) /= N_Accept_Statement
1018 and then not Delay_Cleanups (Current_Scope)
1019 then
1020 Expand_Cleanup_Actions (Parent (N));
1021 else
1022 Set_First_Real_Statement (N, First (Statements (N)));
1023 end if;
1024
1025 end Expand_N_Handled_Sequence_Of_Statements;
1026
1027 -------------------------------------
1028 -- Expand_N_Raise_Constraint_Error --
1029 -------------------------------------
1030
1031 -- The only processing required is to adjust the condition to deal
1032 -- with the C/Fortran boolean case. This may well not be necessary,
1033 -- as all such conditions are generated by the expander and probably
1034 -- are all standard boolean, but who knows what strange optimization
1035 -- in future may require this adjustment!
1036
1037 procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
1038 begin
1039 Adjust_Condition (Condition (N));
1040 end Expand_N_Raise_Constraint_Error;
1041
1042 ----------------------------------
1043 -- Expand_N_Raise_Program_Error --
1044 ----------------------------------
1045
1046 -- The only processing required is to adjust the condition to deal
1047 -- with the C/Fortran boolean case. This may well not be necessary,
1048 -- as all such conditions are generated by the expander and probably
1049 -- are all standard boolean, but who knows what strange optimization
1050 -- in future may require this adjustment!
1051
1052 procedure Expand_N_Raise_Program_Error (N : Node_Id) is
1053 begin
1054 Adjust_Condition (Condition (N));
1055 end Expand_N_Raise_Program_Error;
1056
1057 ------------------------------
1058 -- Expand_N_Raise_Statement --
1059 ------------------------------
1060
1061 procedure Expand_N_Raise_Statement (N : Node_Id) is
1062 Loc : constant Source_Ptr := Sloc (N);
1063 Ehand : Node_Id;
1064 E : Entity_Id;
1065 Str : String_Id;
1066
1067 begin
1068 -- There is no expansion needed for statement "raise <exception>;" when
1069 -- compiling for the JVM since the JVM has a built-in exception
1070 -- mechanism. However we need the keep the expansion for "raise;"
1071 -- statements. See 4jexcept.ads for details.
1072
1073 if Present (Name (N)) and then Hostparm.Java_VM then
1074 return;
1075 end if;
1076
1077 -- Don't expand a raise statement that does not come from source
1078 -- if we have already had configurable run-time violations, since
1079 -- most likely it will be junk cascaded nonsense.
1080
1081 if Configurable_Run_Time_Violations > 0
1082 and then not Comes_From_Source (N)
1083 then
1084 return;
1085 end if;
1086
1087 -- Convert explicit raise of Program_Error, Constraint_Error, and
1088 -- Storage_Error into the corresponding raise (in High_Integrity_Mode
1089 -- all other raises will get normal expansion and be disallowed,
1090 -- but this is also faster in all modes).
1091
1092 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1093 if Entity (Name (N)) = Standard_Constraint_Error then
1094 Rewrite (N,
1095 Make_Raise_Constraint_Error (Loc,
1096 Reason => CE_Explicit_Raise));
1097 Analyze (N);
1098 return;
1099
1100 elsif Entity (Name (N)) = Standard_Program_Error then
1101 Rewrite (N,
1102 Make_Raise_Program_Error (Loc,
1103 Reason => PE_Explicit_Raise));
1104 Analyze (N);
1105 return;
1106
1107 elsif Entity (Name (N)) = Standard_Storage_Error then
1108 Rewrite (N,
1109 Make_Raise_Storage_Error (Loc,
1110 Reason => SE_Explicit_Raise));
1111 Analyze (N);
1112 return;
1113 end if;
1114 end if;
1115
1116 -- Case of name present, in this case we expand raise name to
1117
1118 -- Raise_Exception (name'Identity, location_string);
1119
1120 -- where location_string identifies the file/line of the raise
1121
1122 if Present (Name (N)) then
1123 declare
1124 Id : Entity_Id := Entity (Name (N));
1125
1126 begin
1127 Build_Location_String (Loc);
1128
1129 -- If the exception is a renaming, use the exception that it
1130 -- renames (which might be a predefined exception, e.g.).
1131
1132 if Present (Renamed_Object (Id)) then
1133 Id := Renamed_Object (Id);
1134 end if;
1135
1136 -- Build a C-compatible string in case of no exception handlers,
1137 -- since this is what the last chance handler is expecting.
1138
1139 if Restriction_Active (No_Exception_Handlers) then
1140
1141 -- Generate an empty message if configuration pragma
1142 -- Suppress_Exception_Locations is set for this unit.
1143
1144 if Opt.Exception_Locations_Suppressed then
1145 Name_Len := 1;
1146 else
1147 Name_Len := Name_Len + 1;
1148 end if;
1149
1150 Name_Buffer (Name_Len) := ASCII.NUL;
1151 end if;
1152
1153
1154 if Opt.Exception_Locations_Suppressed then
1155 Name_Len := 0;
1156 end if;
1157
1158 Str := String_From_Name_Buffer;
1159
1160 -- For VMS exceptions, convert the raise into a call to
1161 -- lib$stop so it will be handled by __gnat_error_handler.
1162
1163 if Is_VMS_Exception (Id) then
1164 declare
1165 Excep_Image : String_Id;
1166 Cond : Node_Id;
1167
1168 begin
1169 if Present (Interface_Name (Id)) then
1170 Excep_Image := Strval (Interface_Name (Id));
1171 else
1172 Get_Name_String (Chars (Id));
1173 Set_All_Upper_Case;
1174 Excep_Image := String_From_Name_Buffer;
1175 end if;
1176
1177 if Exception_Code (Id) /= No_Uint then
1178 Cond :=
1179 Make_Integer_Literal (Loc, Exception_Code (Id));
1180 else
1181 Cond :=
1182 Unchecked_Convert_To (Standard_Integer,
1183 Make_Function_Call (Loc,
1184 Name => New_Occurrence_Of
1185 (RTE (RE_Import_Value), Loc),
1186 Parameter_Associations => New_List
1187 (Make_String_Literal (Loc,
1188 Strval => Excep_Image))));
1189 end if;
1190
1191 Rewrite (N,
1192 Make_Procedure_Call_Statement (Loc,
1193 Name =>
1194 New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
1195 Parameter_Associations => New_List (Cond)));
1196 Analyze_And_Resolve (Cond, Standard_Integer);
1197 end;
1198
1199 -- Not VMS exception case, convert raise to call to the
1200 -- Raise_Exception routine.
1201
1202 else
1203 Rewrite (N,
1204 Make_Procedure_Call_Statement (Loc,
1205 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1206 Parameter_Associations => New_List (
1207 Make_Attribute_Reference (Loc,
1208 Prefix => Name (N),
1209 Attribute_Name => Name_Identity),
1210 Make_String_Literal (Loc,
1211 Strval => Str))));
1212 end if;
1213 end;
1214
1215 -- Case of no name present (reraise). We rewrite the raise to:
1216
1217 -- Reraise_Occurrence_Always (EO);
1218
1219 -- where EO is the current exception occurrence. If the current handler
1220 -- does not have a choice parameter specification, then we provide one.
1221
1222 else
1223 -- Find innermost enclosing exception handler (there must be one,
1224 -- since the semantics has already verified that this raise statement
1225 -- is valid, and a raise with no arguments is only permitted in the
1226 -- context of an exception handler.
1227
1228 Ehand := Parent (N);
1229 while Nkind (Ehand) /= N_Exception_Handler loop
1230 Ehand := Parent (Ehand);
1231 end loop;
1232
1233 -- Make exception choice parameter if none present. Note that we do
1234 -- not need to put the entity on the entity chain, since no one will
1235 -- be referencing this entity by normal visibility methods.
1236
1237 if No (Choice_Parameter (Ehand)) then
1238 E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
1239 Set_Choice_Parameter (Ehand, E);
1240 Set_Ekind (E, E_Variable);
1241 Set_Etype (E, RTE (RE_Exception_Occurrence));
1242 Set_Scope (E, Current_Scope);
1243 end if;
1244
1245 -- Now rewrite the raise as a call to Reraise. A special case arises
1246 -- if this raise statement occurs in the context of a handler for
1247 -- all others (i.e. an at end handler). in this case we avoid
1248 -- the call to defer abort, cleanup routines are expected to be
1249 -- called in this case with aborts deferred.
1250
1251 declare
1252 Ech : constant Node_Id := First (Exception_Choices (Ehand));
1253 Ent : Entity_Id;
1254
1255 begin
1256 if Nkind (Ech) = N_Others_Choice
1257 and then All_Others (Ech)
1258 then
1259 Ent := RTE (RE_Reraise_Occurrence_No_Defer);
1260 else
1261 Ent := RTE (RE_Reraise_Occurrence_Always);
1262 end if;
1263
1264 Rewrite (N,
1265 Make_Procedure_Call_Statement (Loc,
1266 Name => New_Occurrence_Of (Ent, Loc),
1267 Parameter_Associations => New_List (
1268 New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
1269 end;
1270 end if;
1271
1272 Analyze (N);
1273 end Expand_N_Raise_Statement;
1274
1275 ----------------------------------
1276 -- Expand_N_Raise_Storage_Error --
1277 ----------------------------------
1278
1279 -- The only processing required is to adjust the condition to deal
1280 -- with the C/Fortran boolean case. This may well not be necessary,
1281 -- as all such conditions are generated by the expander and probably
1282 -- are all standard boolean, but who knows what strange optimization
1283 -- in future may require this adjustment!
1284
1285 procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
1286 begin
1287 Adjust_Condition (Condition (N));
1288 end Expand_N_Raise_Storage_Error;
1289
1290 ------------------------------
1291 -- Expand_N_Subprogram_Info --
1292 ------------------------------
1293
1294 procedure Expand_N_Subprogram_Info (N : Node_Id) is
1295 Loc : constant Source_Ptr := Sloc (N);
1296
1297 begin
1298 -- For now, we replace an Expand_N_Subprogram_Info node with an
1299 -- attribute reference that gives the address of the procedure.
1300 -- This is because gigi does not yet recognize this node, and
1301 -- for the initial targets, this is the right value anyway.
1302
1303 Rewrite (N,
1304 Make_Attribute_Reference (Loc,
1305 Prefix => Identifier (N),
1306 Attribute_Name => Name_Code_Address));
1307
1308 Analyze_And_Resolve (N, RTE (RE_Code_Loc));
1309 end Expand_N_Subprogram_Info;
1310
1311 ------------------------------------
1312 -- Generate_Subprogram_Descriptor --
1313 ------------------------------------
1314
1315 procedure Generate_Subprogram_Descriptor
1316 (N : Node_Id;
1317 Loc : Source_Ptr;
1318 Spec : Entity_Id;
1319 Slist : List_Id)
1320 is
1321 Code : Node_Id;
1322 Ent : Entity_Id;
1323 Decl : Node_Id;
1324 Dtyp : Entity_Id;
1325 Numh : Nat;
1326 Sdes : Node_Id;
1327 Hrc : List_Id;
1328
1329 begin
1330 if Exception_Mechanism /= Front_End_ZCX_Exceptions then
1331 return;
1332 end if;
1333
1334 if Restriction_Active (No_Exception_Handlers) then
1335 return;
1336 end if;
1337
1338 -- Suppress descriptor if we are not generating code. This happens
1339 -- in the case of a -gnatc -gnatt compilation where we force generics
1340 -- to be generated, but we still don't want exception tables.
1341
1342 if Operating_Mode /= Generate_Code then
1343 return;
1344 end if;
1345
1346 -- Suppress descriptor if we are in No_Exceptions restrictions mode,
1347 -- since we can never propagate exceptions in any case in this mode.
1348 -- The same consideration applies for No_Exception_Handlers (which
1349 -- is also set in High_Integrity_Mode).
1350
1351 if Restriction_Active (No_Exceptions)
1352 or Restriction_Active (No_Exception_Handlers)
1353 then
1354 return;
1355 end if;
1356
1357 -- Suppress descriptor if we are inside a generic. There are two
1358 -- ways that we can tell that, depending on what is going on. If
1359 -- we are actually inside the processing for a generic right now,
1360 -- then Expander_Active will be reset. If we are outside the
1361 -- generic, then we will see the generic entity.
1362
1363 if not Expander_Active then
1364 return;
1365 end if;
1366
1367 -- Suppress descriptor is subprogram is marked as eliminated, for
1368 -- example if this is a subprogram created to analyze a default
1369 -- expression with potential side effects. Ditto if it is nested
1370 -- within an eliminated subprogram, for example a cleanup action.
1371
1372 declare
1373 Scop : Entity_Id;
1374
1375 begin
1376 Scop := Spec;
1377 while Scop /= Standard_Standard loop
1378 if Is_Generic_Unit (Scop) or else Is_Eliminated (Scop) then
1379 return;
1380 end if;
1381
1382 Scop := Scope (Scop);
1383 end loop;
1384 end;
1385
1386 -- Suppress descriptor for original protected subprogram (we will
1387 -- be called again later to generate the descriptor for the actual
1388 -- protected body subprogram.) This does not apply to barrier
1389 -- functions which are there own protected subprogram.
1390
1391 if Is_Subprogram (Spec)
1392 and then Present (Protected_Body_Subprogram (Spec))
1393 and then Protected_Body_Subprogram (Spec) /= Spec
1394 then
1395 return;
1396 end if;
1397
1398 -- Suppress descriptors for packages unless they have at least one
1399 -- handler. The binder will generate the dummy (no handler) descriptors
1400 -- for elaboration procedures. We can't do it here, because we don't
1401 -- know if an elaboration routine does in fact exist.
1402
1403 -- If there is at least one handler for the package spec or body
1404 -- then most certainly an elaboration routine must exist, so we
1405 -- can safely reference it.
1406
1407 if (Nkind (N) = N_Package_Declaration
1408 or else
1409 Nkind (N) = N_Package_Body)
1410 and then No (Handler_Records (Spec))
1411 then
1412 return;
1413 end if;
1414
1415 -- Suppress all subprogram descriptors for the file System.Exceptions.
1416 -- We similarly suppress subprogram descriptors for Ada.Exceptions.
1417 -- These are all init procs for types which cannot raise exceptions.
1418 -- The reason this is done is that otherwise we get embarassing
1419 -- elaboration dependencies.
1420
1421 Get_Name_String (Unit_File_Name (Current_Sem_Unit));
1422
1423 if Name_Buffer (1 .. 12) = "s-except.ads"
1424 or else
1425 Name_Buffer (1 .. 12) = "a-except.ads"
1426 then
1427 return;
1428 end if;
1429
1430 -- Similarly, we need to suppress entries for System.Standard_Library,
1431 -- since otherwise we get elaboration circularities. Again, this would
1432 -- better be done with a Suppress_Initialization pragma :-)
1433
1434 if Name_Buffer (1 .. 11) = "s-stalib.ad" then
1435 return;
1436 end if;
1437
1438 -- For now, also suppress entries for s-stoele because we have
1439 -- some kind of unexplained error there ???
1440
1441 if Name_Buffer (1 .. 11) = "s-stoele.ad" then
1442 return;
1443 end if;
1444
1445 -- And also for g-htable, because it cannot raise exceptions,
1446 -- and generates some kind of elaboration order problem.
1447
1448 if Name_Buffer (1 .. 11) = "g-htable.ad" then
1449 return;
1450 end if;
1451
1452 -- Suppress subprogram descriptor if already generated. This happens
1453 -- in the case of late generation from Delay_Subprogram_Descriptors
1454 -- beging set (where there is more than one instantiation in the list)
1455
1456 if Has_Subprogram_Descriptor (Spec) then
1457 return;
1458 else
1459 Set_Has_Subprogram_Descriptor (Spec);
1460 end if;
1461
1462 -- Never generate descriptors for inlined bodies
1463
1464 if Analyzing_Inlined_Bodies then
1465 return;
1466 end if;
1467
1468 -- Here we definitely are going to generate a subprogram descriptor
1469
1470 declare
1471 Hnum : Nat := Homonym_Number (Spec);
1472
1473 begin
1474 if Hnum = 1 then
1475 Hnum := 0;
1476 end if;
1477
1478 Ent :=
1479 Make_Defining_Identifier (Loc,
1480 Chars => New_External_Name (Chars (Spec), "SD", Hnum));
1481 end;
1482
1483 if No (Handler_Records (Spec)) then
1484 Hrc := Empty_List;
1485 Numh := 0;
1486 else
1487 Hrc := Handler_Records (Spec);
1488 Numh := List_Length (Hrc);
1489 end if;
1490
1491 New_Scope (Spec);
1492
1493 -- We need a static subtype for the declaration of the subprogram
1494 -- descriptor. For the case of 0-3 handlers we can use one of the
1495 -- predefined subtypes in System.Exceptions. For more handlers,
1496 -- we build our own subtype here.
1497
1498 case Numh is
1499 when 0 =>
1500 Dtyp := RTE (RE_Subprogram_Descriptor_0);
1501
1502 when 1 =>
1503 Dtyp := RTE (RE_Subprogram_Descriptor_1);
1504
1505 when 2 =>
1506 Dtyp := RTE (RE_Subprogram_Descriptor_2);
1507
1508 when 3 =>
1509 Dtyp := RTE (RE_Subprogram_Descriptor_3);
1510
1511 when others =>
1512 Dtyp :=
1513 Make_Defining_Identifier (Loc,
1514 Chars => New_Internal_Name ('T'));
1515
1516 -- Set the constructed type as global, since we will be
1517 -- referencing the object that is of this type globally
1518
1519 Set_Is_Statically_Allocated (Dtyp);
1520
1521 Decl :=
1522 Make_Subtype_Declaration (Loc,
1523 Defining_Identifier => Dtyp,
1524 Subtype_Indication =>
1525 Make_Subtype_Indication (Loc,
1526 Subtype_Mark =>
1527 New_Occurrence_Of (RTE (RE_Subprogram_Descriptor), Loc),
1528 Constraint =>
1529 Make_Index_Or_Discriminant_Constraint (Loc,
1530 Constraints => New_List (
1531 Make_Integer_Literal (Loc, Numh)))));
1532
1533 Append (Decl, Slist);
1534
1535 -- We analyze the descriptor for the subprogram and package
1536 -- case, but not for the imported subprogram case (it will
1537 -- be analyzed when the freeze entity actions are analyzed.
1538
1539 if Present (N) then
1540 Analyze (Decl);
1541 end if;
1542
1543 Set_Exception_Junk (Decl);
1544 end case;
1545
1546 -- Prepare the code address entry for the table entry. For the normal
1547 -- case of being within a procedure, this is simply:
1548
1549 -- P'Code_Address
1550
1551 -- where P is the procedure, but for the package case, it is
1552
1553 -- P'Elab_Body'Code_Address
1554 -- P'Elab_Spec'Code_Address
1555
1556 -- for the body and spec respectively. Note that we do our own
1557 -- analysis of these attribute references, because we know in this
1558 -- case that the prefix of ELab_Body/Spec is a visible package,
1559 -- which can be referenced directly instead of using the general
1560 -- case expansion for these attributes.
1561
1562 if Ekind (Spec) = E_Package then
1563 Code :=
1564 Make_Attribute_Reference (Loc,
1565 Prefix => New_Occurrence_Of (Spec, Loc),
1566 Attribute_Name => Name_Elab_Spec);
1567 Set_Etype (Code, Standard_Void_Type);
1568 Set_Analyzed (Code);
1569
1570 elsif Ekind (Spec) = E_Package_Body then
1571 Code :=
1572 Make_Attribute_Reference (Loc,
1573 Prefix => New_Occurrence_Of (Spec_Entity (Spec), Loc),
1574 Attribute_Name => Name_Elab_Body);
1575 Set_Etype (Code, Standard_Void_Type);
1576 Set_Analyzed (Code);
1577
1578 else
1579 Code := New_Occurrence_Of (Spec, Loc);
1580 end if;
1581
1582 Code :=
1583 Make_Attribute_Reference (Loc,
1584 Prefix => Code,
1585 Attribute_Name => Name_Code_Address);
1586
1587 Set_Etype (Code, RTE (RE_Address));
1588 Set_Analyzed (Code);
1589
1590 -- Now we can build the subprogram descriptor
1591
1592 Sdes :=
1593 Make_Object_Declaration (Loc,
1594 Defining_Identifier => Ent,
1595 Constant_Present => True,
1596 Aliased_Present => True,
1597 Object_Definition => New_Occurrence_Of (Dtyp, Loc),
1598
1599 Expression =>
1600 Make_Aggregate (Loc,
1601 Expressions => New_List (
1602 Make_Integer_Literal (Loc, Numh), -- Num_Handlers
1603
1604 Code, -- Code
1605
1606 -- temp code ???
1607
1608 -- Make_Subprogram_Info (Loc, -- Subprogram_Info
1609 -- Identifier =>
1610 -- New_Occurrence_Of (Spec, Loc)),
1611
1612 New_Copy_Tree (Code),
1613
1614 Make_Aggregate (Loc, -- Handler_Records
1615 Expressions => Hrc))));
1616
1617 Set_Exception_Junk (Sdes);
1618 Set_Is_Subprogram_Descriptor (Sdes);
1619
1620 Append (Sdes, Slist);
1621
1622 -- We analyze the descriptor for the subprogram and package case,
1623 -- but not for the imported subprogram case (it will be analyzed
1624 -- when the freeze entity actions are analyzed.
1625
1626 if Present (N) then
1627 Analyze (Sdes);
1628 end if;
1629
1630 -- We can now pop the scope used for analyzing the descriptor
1631
1632 Pop_Scope;
1633
1634 -- We need to set the descriptor as statically allocated, since
1635 -- it will be referenced from the unit exception table.
1636
1637 Set_Is_Statically_Allocated (Ent);
1638
1639 -- Append the resulting descriptor to the list. We do this only
1640 -- if we are in the main unit. You might think that we could
1641 -- simply skip generating the descriptors completely if we are
1642 -- not in the main unit, but in fact this is not the case, since
1643 -- we have problems with inconsistent serial numbers for internal
1644 -- names if we do this.
1645
1646 if In_Extended_Main_Code_Unit (Spec) then
1647 Append_To (SD_List,
1648 Make_Attribute_Reference (Loc,
1649 Prefix => New_Occurrence_Of (Ent, Loc),
1650 Attribute_Name => Name_Unrestricted_Access));
1651
1652 Unit_Exception_Table_Present := True;
1653 end if;
1654
1655 end Generate_Subprogram_Descriptor;
1656
1657 ------------------------------------------------------------
1658 -- Generate_Subprogram_Descriptor_For_Imported_Subprogram --
1659 ------------------------------------------------------------
1660
1661 procedure Generate_Subprogram_Descriptor_For_Imported_Subprogram
1662 (Spec : Entity_Id;
1663 Slist : List_Id)
1664 is
1665 begin
1666 Generate_Subprogram_Descriptor (Empty, Sloc (Spec), Spec, Slist);
1667 end Generate_Subprogram_Descriptor_For_Imported_Subprogram;
1668
1669 ------------------------------------------------
1670 -- Generate_Subprogram_Descriptor_For_Package --
1671 ------------------------------------------------
1672
1673 procedure Generate_Subprogram_Descriptor_For_Package
1674 (N : Node_Id;
1675 Spec : Entity_Id)
1676 is
1677 Adecl : Node_Id;
1678
1679 begin
1680 -- If N is empty with prior errors, ignore
1681
1682 if Total_Errors_Detected /= 0 and then No (N) then
1683 return;
1684 end if;
1685
1686 -- Do not generate if no exceptions
1687
1688 if Restriction_Active (No_Exception_Handlers) then
1689 return;
1690 end if;
1691
1692 -- Otherwise generate descriptor
1693
1694 Adecl := Aux_Decls_Node (Parent (N));
1695
1696 if No (Actions (Adecl)) then
1697 Set_Actions (Adecl, New_List);
1698 end if;
1699
1700 Generate_Subprogram_Descriptor (N, Sloc (N), Spec, Actions (Adecl));
1701 end Generate_Subprogram_Descriptor_For_Package;
1702
1703 ---------------------------------------------------
1704 -- Generate_Subprogram_Descriptor_For_Subprogram --
1705 ---------------------------------------------------
1706
1707 procedure Generate_Subprogram_Descriptor_For_Subprogram
1708 (N : Node_Id;
1709 Spec : Entity_Id)
1710 is
1711 begin
1712 -- If we have no subprogram body and prior errors, ignore
1713
1714 if Total_Errors_Detected /= 0 and then No (N) then
1715 return;
1716 end if;
1717
1718 -- Do not generate if no exceptions
1719
1720 if Restriction_Active (No_Exception_Handlers) then
1721 return;
1722 end if;
1723
1724 -- Else generate descriptor
1725
1726 declare
1727 HSS : constant Node_Id := Handled_Statement_Sequence (N);
1728
1729 begin
1730 if No (Exception_Handlers (HSS)) then
1731 Generate_Subprogram_Descriptor
1732 (N, Sloc (N), Spec, Statements (HSS));
1733 else
1734 Generate_Subprogram_Descriptor
1735 (N, Sloc (N),
1736 Spec, Statements (Last (Exception_Handlers (HSS))));
1737 end if;
1738 end;
1739 end Generate_Subprogram_Descriptor_For_Subprogram;
1740
1741 -----------------------------------
1742 -- Generate_Unit_Exception_Table --
1743 -----------------------------------
1744
1745 -- The only remaining thing to generate here is to generate the
1746 -- reference to the subprogram descriptor chain. See Ada.Exceptions
1747 -- for details of required data structures.
1748
1749 procedure Generate_Unit_Exception_Table is
1750 Loc : constant Source_Ptr := No_Location;
1751 Num : Nat;
1752 Decl : Node_Id;
1753 Ent : Entity_Id;
1754 Next_Ent : Entity_Id;
1755 Stent : Entity_Id;
1756
1757 begin
1758 -- Nothing to be done if zero length exceptions not active
1759
1760 if Exception_Mechanism /= Front_End_ZCX_Exceptions then
1761 return;
1762 end if;
1763
1764 -- Nothing to do if no exceptions
1765
1766 if Restriction_Active (No_Exception_Handlers) then
1767 return;
1768 end if;
1769
1770 -- Remove any entries from SD_List that correspond to eliminated
1771 -- subprograms.
1772
1773 Ent := First (SD_List);
1774 while Present (Ent) loop
1775 Next_Ent := Next (Ent);
1776 if Is_Eliminated (Scope (Entity (Prefix (Ent)))) then
1777 Remove (Ent); -- After this, there is no Next (Ent) anymore
1778 end if;
1779
1780 Ent := Next_Ent;
1781 end loop;
1782
1783 -- Nothing to do if no unit exception table present.
1784 -- An empty table can result from subprogram elimination,
1785 -- in such a case, eliminate the exception table itself.
1786
1787 if Is_Empty_List (SD_List) then
1788 Unit_Exception_Table_Present := False;
1789 return;
1790 end if;
1791
1792 -- Do not generate table in a generic
1793
1794 if Inside_A_Generic then
1795 return;
1796 end if;
1797
1798 -- Generate the unit exception table
1799
1800 -- subtype Tnn is Subprogram_Descriptors_Record (Num);
1801 -- __gnat_unitname__SDP : aliased constant Tnn :=
1802 -- Num,
1803 -- (sub1'unrestricted_access,
1804 -- sub2'unrestricted_access,
1805 -- ...
1806 -- subNum'unrestricted_access));
1807
1808 Num := List_Length (SD_List);
1809
1810 Stent :=
1811 Make_Defining_Identifier (Loc,
1812 Chars => New_Internal_Name ('T'));
1813
1814 Insert_Library_Level_Action (
1815 Make_Subtype_Declaration (Loc,
1816 Defining_Identifier => Stent,
1817 Subtype_Indication =>
1818 Make_Subtype_Indication (Loc,
1819 Subtype_Mark =>
1820 New_Occurrence_Of
1821 (RTE (RE_Subprogram_Descriptors_Record), Loc),
1822 Constraint =>
1823 Make_Index_Or_Discriminant_Constraint (Loc,
1824 Constraints => New_List (
1825 Make_Integer_Literal (Loc, Num))))));
1826
1827 Set_Is_Statically_Allocated (Stent);
1828
1829 Get_External_Unit_Name_String (Unit_Name (Main_Unit));
1830 Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
1831 Name_Buffer (1 .. 7) := "__gnat_";
1832 Name_Len := Name_Len + 7;
1833 Add_Str_To_Name_Buffer ("__SDP");
1834
1835 Ent :=
1836 Make_Defining_Identifier (Loc,
1837 Chars => Name_Find);
1838
1839 Get_Name_String (Chars (Ent));
1840 Set_Interface_Name (Ent,
1841 Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
1842
1843 Decl :=
1844 Make_Object_Declaration (Loc,
1845 Defining_Identifier => Ent,
1846 Object_Definition => New_Occurrence_Of (Stent, Loc),
1847 Constant_Present => True,
1848 Aliased_Present => True,
1849 Expression =>
1850 Make_Aggregate (Loc,
1851 New_List (
1852 Make_Integer_Literal (Loc, List_Length (SD_List)),
1853
1854 Make_Aggregate (Loc,
1855 Expressions => SD_List))));
1856
1857 Insert_Library_Level_Action (Decl);
1858
1859 Set_Is_Exported (Ent, True);
1860 Set_Is_Public (Ent, True);
1861 Set_Is_Statically_Allocated (Ent, True);
1862
1863 Get_Name_String (Chars (Ent));
1864 Set_Interface_Name (Ent,
1865 Make_String_Literal (Loc,
1866 Strval => String_From_Name_Buffer));
1867
1868 end Generate_Unit_Exception_Table;
1869
1870 ----------------
1871 -- Initialize --
1872 ----------------
1873
1874 procedure Initialize is
1875 begin
1876 SD_List := Empty_List;
1877 end Initialize;
1878
1879 ----------------------
1880 -- Is_Non_Ada_Error --
1881 ----------------------
1882
1883 function Is_Non_Ada_Error (E : Entity_Id) return Boolean is
1884 begin
1885 if not OpenVMS_On_Target then
1886 return False;
1887 end if;
1888
1889 Get_Name_String (Chars (E));
1890
1891 -- Note: it is a little irregular for the body of exp_ch11 to know
1892 -- the details of the encoding scheme for names, but on the other
1893 -- hand, gigi knows them, and this is for gigi's benefit anyway!
1894
1895 if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then
1896 return False;
1897 end if;
1898
1899 return True;
1900 end Is_Non_Ada_Error;
1901
1902 ----------------------------
1903 -- Remove_Handler_Entries --
1904 ----------------------------
1905
1906 procedure Remove_Handler_Entries (N : Node_Id) is
1907 function Check_Handler_Entry (N : Node_Id) return Traverse_Result;
1908 -- This function checks one node for a possible reference to a
1909 -- handler entry that must be deleted. it always returns OK.
1910
1911 function Remove_All_Handler_Entries is new
1912 Traverse_Func (Check_Handler_Entry);
1913 -- This defines the traversal operation
1914
1915 Discard : Traverse_Result;
1916 pragma Warnings (Off, Discard);
1917
1918 function Check_Handler_Entry (N : Node_Id) return Traverse_Result is
1919 begin
1920 if Nkind (N) = N_Object_Declaration then
1921
1922 if Present (Handler_List_Entry (N)) then
1923 Remove (Handler_List_Entry (N));
1924 Delete_Tree (Handler_List_Entry (N));
1925 Set_Handler_List_Entry (N, Empty);
1926
1927 elsif Is_Subprogram_Descriptor (N) then
1928 declare
1929 SDN : Node_Id;
1930
1931 begin
1932 SDN := First (SD_List);
1933 while Present (SDN) loop
1934 if Defining_Identifier (N) = Entity (Prefix (SDN)) then
1935 Remove (SDN);
1936 Delete_Tree (SDN);
1937 exit;
1938 end if;
1939
1940 Next (SDN);
1941 end loop;
1942 end;
1943 end if;
1944 end if;
1945
1946 return OK;
1947 end Check_Handler_Entry;
1948
1949 -- Start of processing for Remove_Handler_Entries
1950
1951 begin
1952 if Exception_Mechanism = Front_End_ZCX_Exceptions then
1953 Discard := Remove_All_Handler_Entries (N);
1954 end if;
1955 end Remove_Handler_Entries;
1956
1957 end Exp_Ch11;
Mirror of the offical gcc git repository hosted at gcc.gnu.org