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