]> gcc.gnu.org Git - gcc.git/blob - gcc/ada/exp_ch11.adb
git://gcc.gnu.org / gcc.git / blob
? search:


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