1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
29 with Atree; use Atree;
30 with Casing; use Casing;
31 with Debug; use Debug;
32 with Einfo; use Einfo;
33 with Exp_Ch7; use Exp_Ch7;
34 with Exp_Util; use Exp_Util;
35 with Hostparm; use Hostparm;
36 with Inline; use Inline;
38 with Namet; use Namet;
39 with Nlists; use Nlists;
40 with Nmake; use Nmake;
42 with Rtsfind; use Rtsfind;
43 with Restrict; use Restrict;
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;
59 package body Exp_Ch11 is
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.
66 -----------------------
67 -- Local Subprograms --
68 -----------------------
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).
77 procedure Generate_Subprogram_Descriptor
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.
89 ---------------------------
90 -- Expand_At_End_Handler --
91 ---------------------------
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:
101 -- Note: this exception handler is treated rather specially by
102 -- subsequent expansion in two respects:
104 -- The normal call to Undefer_Abort is omitted
105 -- The raise call does not do Defer_Abort
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.
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);
118 pragma Assert (Present (Clean));
119 pragma Assert (No (Exception_Handlers (HSS)));
121 if Restrictions (No_Exception_Handlers) then
125 if Present (Block) then
130 Make_Others_Choice (Loc);
131 Set_All_Others (Ohandle);
134 Make_Procedure_Call_Statement (Loc,
135 Name => New_Occurrence_Of (Clean, Loc)),
136 Make_Raise_Statement (Loc));
138 Set_Exception_Handlers (HSS, New_List (
139 Make_Exception_Handler (Loc,
140 Exception_Choices => New_List (Ohandle),
141 Statements => Stmnts)));
143 Analyze_List (Stmnts, Suppress => All_Checks);
144 Expand_Exception_Handlers (HSS);
146 if Present (Block) then
149 end Expand_At_End_Handler;
151 -------------------------------------
152 -- Expand_Exception_Handler_Tables --
153 -------------------------------------
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:
174 -- We transform this into:
196 -- HR2 : constant Handler_Record := (
200 -- Handler => L5'Address);
202 -- HR3 : constant Handler_Record := (
206 -- Handler => L4'Address);
212 -- HR1 : constant Handler_Record := (
216 -- Handler => L4'Address);
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).
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);
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).
237 L1 : constant Entity_Id :=
238 Make_Defining_Identifier (Loc,
239 Chars => New_Internal_Name ('L'));
241 L2 : constant Entity_Id :=
242 Make_Defining_Identifier (Loc,
243 Chars => New_Internal_Name ('L'));
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.
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.
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.
273 -- Sets the handler list corresponding to Subp_Entity
279 procedure Append_To_Stms (N : Node_Id) is
281 Insert_After_And_Analyze (Last (Stms), N);
282 Set_Exception_Junk (N);
285 -----------------------------
286 -- Inside_Selective_Accept --
287 -----------------------------
289 function Inside_Selective_Accept return Boolean is
291 Curr : Node_Id := HSS;
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)
299 if Present (Accept_Handler_Records (Parnt)) then
300 Hlist := Accept_Handler_Records (Parnt);
303 Set_Accept_Handler_Records (Parnt, Hlist);
309 Parnt := Parent (Parnt);
314 end Inside_Selective_Accept;
320 procedure Set_Hlist is
322 -- Never try to inline a subprogram with exception handlers
324 Set_Is_Inlined (Subp_Entity, False);
326 if Present (Subp_Entity)
327 and then Present (Handler_Records (Subp_Entity))
329 Hlist := Handler_Records (Subp_Entity);
332 Set_Handler_Records (Subp_Entity, Hlist);
336 -- Start of processing for Expand_Exception_Handler_Tables
339 -- Nothing to do if this handler has already been processed
341 if Zero_Cost_Handling (HSS) then
345 Set_Zero_Cost_Handling (HSS);
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.
352 -- We only stop at library level packages, for inner packages
353 -- we always attach handlers to the containing procedure.
355 Subp_Entity := Current_Scope;
358 -- Never need tables expanded inside a generic template
360 if Is_Generic_Unit (Subp_Entity) then
363 -- Stop if we reached containing subprogram. Go to protected
364 -- subprogram if there is one defined.
366 elsif Ekind (Subp_Entity) = E_Function
367 or else Ekind (Subp_Entity) = E_Procedure
369 if Present (Protected_Body_Subprogram (Subp_Entity)) then
370 Subp_Entity := Protected_Body_Subprogram (Subp_Entity);
376 -- Case of within an entry
378 elsif Is_Entry (Subp_Entity) then
380 -- Protected entry, use corresponding body subprogram
382 if Present (Protected_Body_Subprogram (Subp_Entity)) then
383 Subp_Entity := Protected_Body_Subprogram (Subp_Entity);
387 -- Check if we are within a selective accept alternative
389 elsif Inside_Selective_Accept then
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.
398 -- Case of within library level package
400 elsif Ekind (Subp_Entity) = E_Package
401 and then Is_Compilation_Unit (Subp_Entity)
403 if Is_Body_Name (Unit_Name (Get_Code_Unit (HSS))) then
404 Subp_Entity := Body_Entity (Subp_Entity);
412 elsif Ekind (Subp_Entity) = E_Task_Type then
414 -- Check if we are within a selective accept alternative
416 if Inside_Selective_Accept then
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.
424 -- Stop if we reached task type with task body procedure,
425 -- use the task body procedure.
427 elsif Present (Get_Task_Body_Procedure (Subp_Entity)) then
428 Subp_Entity := Get_Task_Body_Procedure (Subp_Entity);
434 -- If we fall through, keep looking
436 Subp_Entity := Scope (Subp_Entity);
439 pragma Assert (Subp_Entity /= Standard_Standard);
441 -- Analyze standard labels
443 Analyze_Label_Entity (L1);
444 Analyze_Label_Entity (L2);
446 Insert_Before_And_Analyze (First (Stms),
448 Identifier => New_Occurrence_Of (L1, Loc)));
449 Set_Exception_Junk (First (Stms));
453 Identifier => New_Occurrence_Of (L2, Loc)));
455 -- Loop through exception handlers
457 Handler := First_Non_Pragma (Handlrs);
458 while Present (Handler) loop
459 Set_Zero_Cost_Handling (Handler);
461 -- Add label at start of handler, and goto at the end
464 Make_Defining_Identifier (Loc,
465 Chars => New_Internal_Name ('L'));
467 Analyze_Label_Entity (Lnn);
471 Identifier => New_Occurrence_Of (Lnn, Loc));
472 Set_Exception_Junk (Item);
473 Insert_Before_And_Analyze (First (Statements (Handler)), Item);
475 -- Loop through choices
477 Choice := First (Exception_Choices (Handler));
478 while Present (Choice) loop
480 -- Others (or all others) choice
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);
486 E_Id := New_Occurrence_Of (RTE (RE_Others_Id), Loc);
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.
494 elsif Is_VMS_Exception (Entity (Choice)) then
495 E_Id := New_Occurrence_Of (RTE (RE_Null_Id), Loc);
497 -- Normal case of specific exception choice
501 Make_Attribute_Reference (Loc,
502 Prefix => New_Occurrence_Of (Entity (Choice), Loc),
503 Attribute_Name => Name_Identity);
507 Make_Defining_Identifier (Loc,
508 Chars => New_Internal_Name ('H'));
511 Make_Attribute_Reference (Loc,
512 Prefix => New_Occurrence_Of (HR_Ent, Loc),
513 Attribute_Name => Name_Unrestricted_Access);
515 -- Now we need to add the entry for the new handler record to
516 -- the list of handler records for the current subprogram.
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
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:
529 -- generic package x ... end x;
540 -- package q is new x;
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
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.
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.
564 New_Scop : constant Entity_Id := Current_Scope;
568 Ent := First (Hlist);
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).
575 Append_To (Hlist, HL_Ref);
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.
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.
587 (New_Scop, Scope (Entity (Prefix (Ent))))
589 Insert_Before (Ent, HL_Ref);
592 -- Otherwise keep looking
601 Make_Object_Declaration (Loc,
602 Defining_Identifier => HR_Ent,
603 Constant_Present => True,
604 Aliased_Present => True,
606 New_Occurrence_Of (RTE (RE_Handler_Record), Loc),
610 Expressions => New_List (
611 Make_Attribute_Reference (Loc, -- Lo
612 Prefix => New_Occurrence_Of (L1, Loc),
613 Attribute_Name => Name_Address),
615 Make_Attribute_Reference (Loc, -- Hi
616 Prefix => New_Occurrence_Of (L2, Loc),
617 Attribute_Name => Name_Address),
621 Make_Attribute_Reference (Loc,
622 Prefix => New_Occurrence_Of (Lnn, Loc), -- Handler
623 Attribute_Name => Name_Address))));
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);
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.
634 Analyze_And_Resolve (HL_Ref, RTE (RE_Handler_Record_Ptr));
639 Next_Non_Pragma (Handler);
641 end Expand_Exception_Handler_Tables;
643 -------------------------------
644 -- Expand_Exception_Handlers --
645 -------------------------------
647 procedure Expand_Exception_Handlers (HSS : Node_Id) is
648 Handlrs : constant List_Id := Exception_Handlers (HSS);
651 Others_Choice : Boolean;
654 procedure Prepend_Call_To_Handler
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.
660 procedure Prepend_Call_To_Handler
662 Args : List_Id := No_List)
664 Call : constant Node_Id :=
665 Make_Procedure_Call_Statement (Loc,
666 Name => New_Occurrence_Of (RTE (Proc), Loc),
667 Parameter_Associations => Args);
670 Prepend_To (Statements (Handler), Call);
671 Analyze (Call, Suppress => All_Checks);
672 end Prepend_Call_To_Handler;
674 -- Start of processing for Expand_Exception_Handlers
677 -- Loop through handlers
679 Handler := First_Non_Pragma (Handlrs);
680 while Present (Handler) loop
681 Loc := Sloc (Handler);
683 -- If an exception occurrence is present, then we must declare it
684 -- and initialize it from the value stored in the TSD
687 -- name : Exception_Occurrence;
690 -- Save_Occurrence (name, Get_Current_Excep.all)
694 if Present (Choice_Parameter (Handler)) then
696 Cparm : constant Entity_Id := Choice_Parameter (Handler);
697 Clc : constant Source_Ptr := Sloc (Cparm);
702 Make_Procedure_Call_Statement (Loc,
704 New_Occurrence_Of (RTE (RE_Save_Occurrence), Loc),
705 Parameter_Associations => New_List (
706 New_Occurrence_Of (Cparm, Clc),
707 Make_Explicit_Dereference (Loc,
708 Make_Function_Call (Loc,
709 Name => Make_Explicit_Dereference (Loc,
711 (RTE (RE_Get_Current_Excep), Loc))))));
713 Mark_Rewrite_Insertion (Save);
714 Prepend (Save, Statements (Handler));
717 Make_Object_Declaration (Clc,
718 Defining_Identifier => Cparm,
721 (RTE (RE_Exception_Occurrence), Clc));
722 Set_No_Initialization (Obj_Decl, True);
725 Make_Exception_Handler (Loc,
726 Exception_Choices => Exception_Choices (Handler),
728 Statements => New_List (
729 Make_Block_Statement (Loc,
730 Declarations => New_List (Obj_Decl),
731 Handled_Statement_Sequence =>
732 Make_Handled_Sequence_Of_Statements (Loc,
733 Statements => Statements (Handler))))));
735 Analyze_List (Statements (Handler), Suppress => All_Checks);
739 -- The processing at this point is rather different for the
740 -- JVM case, so we completely separate the processing.
742 -- For the JVM case, we unconditionally call Update_Exception,
743 -- passing a call to the intrinsic function Current_Target_Exception
744 -- (see JVM version of Ada.Exceptions in 4jexcept.adb for details).
746 if Hostparm.Java_VM then
749 := Make_Function_Call (Loc,
750 Name => New_Occurrence_Of
751 (RTE (RE_Current_Target_Exception), Loc));
753 Prepend_Call_To_Handler (RE_Update_Exception, New_List (Arg));
756 -- For the normal case, we have to worry about the state of abort
757 -- deferral. Generally, we defer abort during runtime handling of
758 -- exceptions. When control is passed to the handler, then in the
759 -- normal case we undefer aborts. In any case this entire handling
760 -- is relevant only if aborts are allowed!
762 elsif Abort_Allowed then
764 -- There are some special cases in which we do not do the
765 -- undefer. In particular a finalization (AT END) handler
766 -- wants to operate with aborts still deferred.
768 -- We also suppress the call if this is the special handler
769 -- for Abort_Signal, since if we are aborting, we want to keep
770 -- aborts deferred (one abort is enough thank you very much :-)
772 -- If abort really needs to be deferred the expander must add
773 -- this call explicitly, see Exp_Ch9.Expand_N_Asynchronous_Select.
776 Nkind (First (Exception_Choices (Handler))) = N_Others_Choice;
779 or else Entity (First (Exception_Choices (Handler))) /=
783 and then All_Others (First (Exception_Choices (Handler))))
784 and then Abort_Allowed
786 Prepend_Call_To_Handler (RE_Abort_Undefer);
790 Next_Non_Pragma (Handler);
793 -- The last step for expanding exception handlers is to expand the
794 -- exception tables if zero cost exception handling is active.
796 if Exception_Mechanism = Front_End_ZCX then
797 Expand_Exception_Handler_Tables (HSS);
799 end Expand_Exception_Handlers;
801 ------------------------------------
802 -- Expand_N_Exception_Declaration --
803 ------------------------------------
806 -- exceptE : constant String := "A.B.EXCEP"; -- static data
807 -- except : exception_data := (
808 -- Handled_By_Other => False,
810 -- Name_Length => exceptE'Length
811 -- Full_Name => exceptE'Address
812 -- HTable_Ptr => null);
814 -- (protecting test only needed if not at library level)
816 -- exceptF : Boolean := True -- static data
819 -- Register_Exception (except'Unchecked_Access);
822 procedure Expand_N_Exception_Declaration (N : Node_Id) is
823 Loc : constant Source_Ptr := Sloc (N);
824 Id : constant Entity_Id := Defining_Identifier (N);
825 L : List_Id := New_List;
828 Name_Exname : constant Name_Id := New_External_Name (Chars (Id), 'E');
829 Exname : constant Node_Id :=
830 Make_Defining_Identifier (Loc, Name_Exname);
833 -- There is no expansion needed when compiling for the JVM since the
834 -- JVM has a built-in exception mechanism. See 4jexcept.ads for details.
836 if Hostparm.Java_VM then
840 -- Definition of the external name: nam : constant String := "A.B.NAME";
843 Make_Object_Declaration (Loc,
844 Defining_Identifier => Exname,
845 Constant_Present => True,
846 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
847 Expression => Make_String_Literal (Loc, Full_Qualified_Name (Id))));
849 Set_Is_Statically_Allocated (Exname);
851 -- Create the aggregate list for type Standard.Exception_Type:
852 -- Handled_By_Other component: False
854 Append_To (L, New_Occurrence_Of (Standard_False, Loc));
856 -- Lang component: 'A'
859 Make_Character_Literal (Loc, Name_uA, Get_Char_Code ('A')));
861 -- Name_Length component: Nam'Length
864 Make_Attribute_Reference (Loc,
865 Prefix => New_Occurrence_Of (Exname, Loc),
866 Attribute_Name => Name_Length));
868 -- Full_Name component: Standard.A_Char!(Nam'Address)
870 Append_To (L, Unchecked_Convert_To (Standard_A_Char,
871 Make_Attribute_Reference (Loc,
872 Prefix => New_Occurrence_Of (Exname, Loc),
873 Attribute_Name => Name_Address)));
875 -- HTable_Ptr component: null
877 Append_To (L, Make_Null (Loc));
879 -- Import_Code component: 0
881 Append_To (L, Make_Integer_Literal (Loc, 0));
883 Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
884 Analyze_And_Resolve (Expression (N), Etype (Id));
886 -- Register_Exception (except'Unchecked_Access);
888 if not Restrictions (No_Exception_Handlers) then
890 Make_Procedure_Call_Statement (Loc,
891 Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
892 Parameter_Associations => New_List (
893 Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr),
894 Make_Attribute_Reference (Loc,
895 Prefix => New_Occurrence_Of (Id, Loc),
896 Attribute_Name => Name_Unrestricted_Access)))));
898 Set_Register_Exception_Call (Id, First (L));
900 if not Is_Library_Level_Entity (Id) then
901 Flag_Id := Make_Defining_Identifier (Loc,
902 New_External_Name (Chars (Id), 'F'));
905 Make_Object_Declaration (Loc,
906 Defining_Identifier => Flag_Id,
908 New_Occurrence_Of (Standard_Boolean, Loc),
910 New_Occurrence_Of (Standard_True, Loc)));
912 Set_Is_Statically_Allocated (Flag_Id);
915 Make_Assignment_Statement (Loc,
916 Name => New_Occurrence_Of (Flag_Id, Loc),
917 Expression => New_Occurrence_Of (Standard_False, Loc)));
919 Insert_After_And_Analyze (N,
920 Make_Implicit_If_Statement (N,
921 Condition => New_Occurrence_Of (Flag_Id, Loc),
922 Then_Statements => L));
925 Insert_List_After_And_Analyze (N, L);
929 end Expand_N_Exception_Declaration;
931 ---------------------------------------------
932 -- Expand_N_Handled_Sequence_Of_Statements --
933 ---------------------------------------------
935 procedure Expand_N_Handled_Sequence_Of_Statements (N : Node_Id) is
937 if Present (Exception_Handlers (N)) then
938 Expand_Exception_Handlers (N);
941 -- The following code needs comments ???
943 if Nkind (Parent (N)) /= N_Package_Body
944 and then Nkind (Parent (N)) /= N_Accept_Statement
945 and then not Delay_Cleanups (Current_Scope)
947 Expand_Cleanup_Actions (Parent (N));
949 Set_First_Real_Statement (N, First (Statements (N)));
952 end Expand_N_Handled_Sequence_Of_Statements;
954 -------------------------------------
955 -- Expand_N_Raise_Constraint_Error --
956 -------------------------------------
958 -- The only processing required is to adjust the condition to deal
959 -- with the C/Fortran boolean case. This may well not be necessary,
960 -- as all such conditions are generated by the expander and probably
961 -- are all standard boolean, but who knows what strange optimization
962 -- in future may require this adjustment!
964 procedure Expand_N_Raise_Constraint_Error (N : Node_Id) is
966 Adjust_Condition (Condition (N));
967 end Expand_N_Raise_Constraint_Error;
969 ----------------------------------
970 -- Expand_N_Raise_Program_Error --
971 ----------------------------------
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!
979 procedure Expand_N_Raise_Program_Error (N : Node_Id) is
981 Adjust_Condition (Condition (N));
982 end Expand_N_Raise_Program_Error;
984 ------------------------------
985 -- Expand_N_Raise_Statement --
986 ------------------------------
988 procedure Expand_N_Raise_Statement (N : Node_Id) is
989 Loc : constant Source_Ptr := Sloc (N);
995 -- There is no expansion needed for statement "raise <exception>;" when
996 -- compiling for the JVM since the JVM has a built-in exception
997 -- mechanism. However we need the keep the expansion for "raise;"
998 -- statements. See 4jexcept.ads for details.
1000 if Present (Name (N)) and then Hostparm.Java_VM then
1004 -- Convert explicit raise of Program_Error, Constraint_Error, and
1005 -- Storage_Error into the corresponding raise node (in No_Run_Time
1006 -- mode all other raises will get normal expansion and be disallowed,
1007 -- but this is also faster in all modes).
1009 if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
1010 if Entity (Name (N)) = Standard_Program_Error then
1011 Rewrite (N, Make_Raise_Program_Error (Loc));
1015 elsif Entity (Name (N)) = Standard_Constraint_Error then
1016 Rewrite (N, Make_Raise_Constraint_Error (Loc));
1020 elsif Entity (Name (N)) = Standard_Storage_Error then
1021 Rewrite (N, Make_Raise_Storage_Error (Loc));
1027 -- Case of name present, in this case we expand raise name to
1029 -- Raise_Exception (name'Identity, location_string);
1031 -- where location_string identifies the file/line of the raise
1033 if Present (Name (N)) then
1035 Id : Entity_Id := Entity (Name (N));
1038 Build_Location_String (Loc);
1040 -- Build a C compatible string in case of no exception handlers,
1041 -- since this is what the last chance handler is expecting.
1043 if Restrictions (No_Exception_Handlers) then
1044 -- Generate a C null message when Global_Discard_Names is True
1045 -- or when Debug_Flag_NN is set.
1047 if Global_Discard_Names or else Debug_Flag_NN then
1048 Name_Buffer (1) := ASCII.NUL;
1051 Name_Len := Name_Len + 1;
1054 -- Do not generate the message when Global_Discard_Names is True
1055 -- or when Debug_Flag_NN is set.
1057 elsif Global_Discard_Names or else Debug_Flag_NN then
1061 Str := String_From_Name_Buffer;
1063 -- For VMS exceptions, convert the raise into a call to
1064 -- lib$stop so it will be handled by __gnat_error_handler.
1066 if Is_VMS_Exception (Id) then
1068 Excep_Image : String_Id;
1072 if Present (Interface_Name (Id)) then
1073 Excep_Image := Strval (Interface_Name (Id));
1075 Get_Name_String (Chars (Id));
1077 Excep_Image := String_From_Name_Buffer;
1080 if Exception_Code (Id) /= No_Uint then
1082 Make_Integer_Literal (Loc, Exception_Code (Id));
1085 Unchecked_Convert_To (Standard_Integer,
1086 Make_Function_Call (Loc,
1087 Name => New_Occurrence_Of
1088 (RTE (RE_Import_Value), Loc),
1089 Parameter_Associations => New_List
1090 (Make_String_Literal (Loc,
1091 Strval => Excep_Image))));
1095 Make_Procedure_Call_Statement (Loc,
1097 New_Occurrence_Of (RTE (RE_Lib_Stop), Loc),
1098 Parameter_Associations => New_List (Cond)));
1099 Analyze_And_Resolve (Cond, Standard_Integer);
1102 -- Not VMS exception case, convert raise to call to the
1103 -- Raise_Exception routine.
1107 Make_Procedure_Call_Statement (Loc,
1108 Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc),
1109 Parameter_Associations => New_List (
1110 Make_Attribute_Reference (Loc,
1112 Attribute_Name => Name_Identity),
1113 Make_String_Literal (Loc,
1118 -- Case of no name present (reraise). We rewrite the raise to:
1120 -- Reraise_Occurrence_Always (EO);
1122 -- where EO is the current exception occurrence. If the current handler
1123 -- does not have a choice parameter specification, then we provide one.
1126 -- Find innermost enclosing exception handler (there must be one,
1127 -- since the semantics has already verified that this raise statement
1128 -- is valid, and a raise with no arguments is only permitted in the
1129 -- context of an exception handler.
1131 Ehand := Parent (N);
1132 while Nkind (Ehand) /= N_Exception_Handler loop
1133 Ehand := Parent (Ehand);
1136 -- Make exception choice parameter if none present. Note that we do
1137 -- not need to put the entity on the entity chain, since no one will
1138 -- be referencing this entity by normal visibility methods.
1140 if No (Choice_Parameter (Ehand)) then
1141 E := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
1142 Set_Choice_Parameter (Ehand, E);
1143 Set_Ekind (E, E_Variable);
1144 Set_Etype (E, RTE (RE_Exception_Occurrence));
1145 Set_Scope (E, Current_Scope);
1148 -- Now rewrite the raise as a call to Reraise. A special case arises
1149 -- if this raise statement occurs in the context of a handler for
1150 -- all others (i.e. an at end handler). in this case we avoid
1151 -- the call to defer abort, cleanup routines are expected to be
1152 -- called in this case with aborts deferred.
1155 Ech : constant Node_Id := First (Exception_Choices (Ehand));
1159 if Nkind (Ech) = N_Others_Choice
1160 and then All_Others (Ech)
1162 Ent := RTE (RE_Reraise_Occurrence_No_Defer);
1164 Ent := RTE (RE_Reraise_Occurrence_Always);
1168 Make_Procedure_Call_Statement (Loc,
1169 Name => New_Occurrence_Of (Ent, Loc),
1170 Parameter_Associations => New_List (
1171 New_Occurrence_Of (Choice_Parameter (Ehand), Loc))));
1176 end Expand_N_Raise_Statement;
1178 ----------------------------------
1179 -- Expand_N_Raise_Storage_Error --
1180 ----------------------------------
1182 -- The only processing required is to adjust the condition to deal
1183 -- with the C/Fortran boolean case. This may well not be necessary,
1184 -- as all such conditions are generated by the expander and probably
1185 -- are all standard boolean, but who knows what strange optimization
1186 -- in future may require this adjustment!
1188 procedure Expand_N_Raise_Storage_Error (N : Node_Id) is
1190 Adjust_Condition (Condition (N));
1191 end Expand_N_Raise_Storage_Error;
1193 ------------------------------
1194 -- Expand_N_Subprogram_Info --
1195 ------------------------------
1197 procedure Expand_N_Subprogram_Info (N : Node_Id) is
1198 Loc : constant Source_Ptr := Sloc (N);
1201 -- For now, we replace an Expand_N_Subprogram_Info node with an
1202 -- attribute reference that gives the address of the procedure.
1203 -- This is because gigi does not yet recognize this node, and
1204 -- for the initial targets, this is the right value anyway.
1207 Make_Attribute_Reference (Loc,
1208 Prefix => Identifier (N),
1209 Attribute_Name => Name_Code_Address));
1211 Analyze_And_Resolve (N, RTE (RE_Code_Loc));
1212 end Expand_N_Subprogram_Info;
1214 ------------------------------------
1215 -- Generate_Subprogram_Descriptor --
1216 ------------------------------------
1218 procedure Generate_Subprogram_Descriptor
1233 if Exception_Mechanism /= Front_End_ZCX then
1237 -- Suppress descriptor if we are not generating code. This happens
1238 -- in the case of a -gnatc -gnatt compilation where we force generics
1239 -- to be generated, but we still don't want exception tables.
1241 if Operating_Mode /= Generate_Code then
1245 -- Suppress descriptor if we are in No_Exceptions restrictions mode,
1246 -- since we can never propagate exceptions in any case in this mode.
1247 -- The same consideration applies for No_Exception_Handlers (which
1248 -- is also set in No_Run_Time mode).
1250 if Restrictions (No_Exceptions)
1251 or Restrictions (No_Exception_Handlers)
1256 -- Suppress descriptor if we are inside a generic. There are two
1257 -- ways that we can tell that, depending on what is going on. If
1258 -- we are actually inside the processing for a generic right now,
1259 -- then Expander_Active will be reset. If we are outside the
1260 -- generic, then we will see the generic entity.
1262 if not Expander_Active then
1266 -- Suppress descriptor is subprogram is marked as eliminated, for
1267 -- example if this is a subprogram created to analyze a default
1268 -- expression with potential side effects. Ditto if it is nested
1269 -- within an eliminated subprogram, for example a cleanup action.
1276 while Scop /= Standard_Standard loop
1277 if Ekind (Scop) = E_Generic_Procedure
1279 Ekind (Scop) = E_Generic_Function
1281 Ekind (Scop) = E_Generic_Package
1283 Is_Eliminated (Scop)
1288 Scop := Scope (Scop);
1292 -- Suppress descriptor for original protected subprogram (we will
1293 -- be called again later to generate the descriptor for the actual
1294 -- protected body subprogram.) This does not apply to barrier
1295 -- functions which are there own protected subprogram.
1297 if Is_Subprogram (Spec)
1298 and then Present (Protected_Body_Subprogram (Spec))
1299 and then Protected_Body_Subprogram (Spec) /= Spec
1304 -- Suppress descriptors for packages unless they have at least one
1305 -- handler. The binder will generate the dummy (no handler) descriptors
1306 -- for elaboration procedures. We can't do it here, because we don't
1307 -- know if an elaboration routine does in fact exist.
1309 -- If there is at least one handler for the package spec or body
1310 -- then most certainly an elaboration routine must exist, so we
1311 -- can safely reference it.
1313 if (Nkind (N) = N_Package_Declaration
1315 Nkind (N) = N_Package_Body)
1316 and then No (Handler_Records (Spec))
1321 -- Suppress all subprogram descriptors for the file System.Exceptions.
1322 -- We similarly suppress subprogram descriptors for Ada.Exceptions.
1323 -- These are all init_proc's for types which cannot raise exceptions.
1324 -- The reason this is done is that otherwise we get embarassing
1325 -- elaboration dependencies.
1327 Get_Name_String (Unit_File_Name (Current_Sem_Unit));
1329 if Name_Buffer (1 .. 12) = "s-except.ads"
1331 Name_Buffer (1 .. 12) = "a-except.ads"
1336 -- Similarly, we need to suppress entries for System.Standard_Library,
1337 -- since otherwise we get elaboration circularities. Again, this would
1338 -- better be done with a Suppress_Initialization pragma :-)
1340 if Name_Buffer (1 .. 11) = "s-stalib.ad" then
1344 -- For now, also suppress entries for s-stoele because we have
1345 -- some kind of unexplained error there ???
1347 if Name_Buffer (1 .. 11) = "s-stoele.ad" then
1351 -- And also for g-htable, because it cannot raise exceptions,
1352 -- and generates some kind of elaboration order problem.
1354 if Name_Buffer (1 .. 11) = "g-htable.ad" then
1358 -- Suppress subprogram descriptor if already generated. This happens
1359 -- in the case of late generation from Delay_Subprogram_Descriptors
1360 -- beging set (where there is more than one instantiation in the list)
1362 if Has_Subprogram_Descriptor (Spec) then
1365 Set_Has_Subprogram_Descriptor (Spec);
1368 -- Never generate descriptors for inlined bodies
1370 if Analyzing_Inlined_Bodies then
1374 -- Here we definitely are going to generate a subprogram descriptor
1377 Hnum : Nat := Homonym_Number (Spec);
1385 Make_Defining_Identifier (Loc,
1386 Chars => New_External_Name (Chars (Spec), "SD", Hnum));
1389 if No (Handler_Records (Spec)) then
1393 Hrc := Handler_Records (Spec);
1394 Numh := List_Length (Hrc);
1399 -- We need a static subtype for the declaration of the subprogram
1400 -- descriptor. For the case of 0-3 handlers we can use one of the
1401 -- predefined subtypes in System.Exceptions. For more handlers,
1402 -- we build our own subtype here.
1406 Dtyp := RTE (RE_Subprogram_Descriptor_0);
1409 Dtyp := RTE (RE_Subprogram_Descriptor_1);
1412 Dtyp := RTE (RE_Subprogram_Descriptor_2);
1415 Dtyp := RTE (RE_Subprogram_Descriptor_3);
1419 Make_Defining_Identifier (Loc,
1420 Chars => New_Internal_Name ('T'));
1422 -- Set the constructed type as global, since we will be
1423 -- referencing the object that is of this type globally
1425 Set_Is_Statically_Allocated (Dtyp);
1428 Make_Subtype_Declaration (Loc,
1429 Defining_Identifier => Dtyp,
1430 Subtype_Indication =>
1431 Make_Subtype_Indication (Loc,
1433 New_Occurrence_Of (RTE (RE_Subprogram_Descriptor), Loc),
1435 Make_Index_Or_Discriminant_Constraint (Loc,
1436 Constraints => New_List (
1437 Make_Integer_Literal (Loc, Numh)))));
1439 Append (Decl, Slist);
1441 -- We analyze the descriptor for the subprogram and package
1442 -- case, but not for the imported subprogram case (it will
1443 -- be analyzed when the freeze entity actions are analyzed.
1449 Set_Exception_Junk (Decl);
1452 -- Prepare the code address entry for the table entry. For the normal
1453 -- case of being within a procedure, this is simply:
1457 -- where P is the procedure, but for the package case, it is
1459 -- P'Elab_Body'Code_Address
1460 -- P'Elab_Spec'Code_Address
1462 -- for the body and spec respectively. Note that we do our own
1463 -- analysis of these attribute references, because we know in this
1464 -- case that the prefix of ELab_Body/Spec is a visible package,
1465 -- which can be referenced directly instead of using the general
1466 -- case expansion for these attributes.
1468 if Ekind (Spec) = E_Package then
1470 Make_Attribute_Reference (Loc,
1471 Prefix => New_Occurrence_Of (Spec, Loc),
1472 Attribute_Name => Name_Elab_Spec);
1473 Set_Etype (Code, Standard_Void_Type);
1474 Set_Analyzed (Code);
1476 elsif Ekind (Spec) = E_Package_Body then
1478 Make_Attribute_Reference (Loc,
1479 Prefix => New_Occurrence_Of (Spec_Entity (Spec), Loc),
1480 Attribute_Name => Name_Elab_Body);
1481 Set_Etype (Code, Standard_Void_Type);
1482 Set_Analyzed (Code);
1485 Code := New_Occurrence_Of (Spec, Loc);
1489 Make_Attribute_Reference (Loc,
1491 Attribute_Name => Name_Code_Address);
1493 Set_Etype (Code, RTE (RE_Address));
1494 Set_Analyzed (Code);
1496 -- Now we can build the subprogram descriptor
1499 Make_Object_Declaration (Loc,
1500 Defining_Identifier => Ent,
1501 Constant_Present => True,
1502 Aliased_Present => True,
1503 Object_Definition => New_Occurrence_Of (Dtyp, Loc),
1506 Make_Aggregate (Loc,
1507 Expressions => New_List (
1508 Make_Integer_Literal (Loc, Numh), -- Num_Handlers
1514 -- Make_Subprogram_Info (Loc, -- Subprogram_Info
1516 -- New_Occurrence_Of (Spec, Loc)),
1518 New_Copy_Tree (Code),
1520 Make_Aggregate (Loc, -- Handler_Records
1521 Expressions => Hrc))));
1523 Set_Exception_Junk (Sdes);
1524 Set_Is_Subprogram_Descriptor (Sdes);
1526 Append (Sdes, Slist);
1528 -- We analyze the descriptor for the subprogram and package case,
1529 -- but not for the imported subprogram case (it will be analyzed
1530 -- when the freeze entity actions are analyzed.
1536 -- We can now pop the scope used for analyzing the descriptor
1540 -- We need to set the descriptor as statically allocated, since
1541 -- it will be referenced from the unit exception table.
1543 Set_Is_Statically_Allocated (Ent);
1545 -- Append the resulting descriptor to the list. We do this only
1546 -- if we are in the main unit. You might think that we could
1547 -- simply skip generating the descriptors completely if we are
1548 -- not in the main unit, but in fact this is not the case, since
1549 -- we have problems with inconsistent serial numbers for internal
1550 -- names if we do this.
1552 if In_Extended_Main_Code_Unit (Spec) then
1554 Make_Attribute_Reference (Loc,
1555 Prefix => New_Occurrence_Of (Ent, Loc),
1556 Attribute_Name => Name_Unrestricted_Access));
1558 Unit_Exception_Table_Present := True;
1561 end Generate_Subprogram_Descriptor;
1563 ------------------------------------------------------------
1564 -- Generate_Subprogram_Descriptor_For_Imported_Subprogram --
1565 ------------------------------------------------------------
1567 procedure Generate_Subprogram_Descriptor_For_Imported_Subprogram
1572 Generate_Subprogram_Descriptor (Empty, Sloc (Spec), Spec, Slist);
1573 end Generate_Subprogram_Descriptor_For_Imported_Subprogram;
1575 ------------------------------------------------
1576 -- Generate_Subprogram_Descriptor_For_Package --
1577 ------------------------------------------------
1579 procedure Generate_Subprogram_Descriptor_For_Package
1586 Adecl := Aux_Decls_Node (Parent (N));
1588 if No (Actions (Adecl)) then
1589 Set_Actions (Adecl, New_List);
1592 Generate_Subprogram_Descriptor (N, Sloc (N), Spec, Actions (Adecl));
1593 end Generate_Subprogram_Descriptor_For_Package;
1595 ---------------------------------------------------
1596 -- Generate_Subprogram_Descriptor_For_Subprogram --
1597 ---------------------------------------------------
1599 procedure Generate_Subprogram_Descriptor_For_Subprogram
1603 HSS : constant Node_Id := Handled_Statement_Sequence (N);
1606 if No (Exception_Handlers (HSS)) then
1607 Generate_Subprogram_Descriptor
1608 (N, Sloc (N), Spec, Statements (HSS));
1610 Generate_Subprogram_Descriptor
1611 (N, Sloc (N), Spec, Statements (Last (Exception_Handlers (HSS))));
1613 end Generate_Subprogram_Descriptor_For_Subprogram;
1615 -----------------------------------
1616 -- Generate_Unit_Exception_Table --
1617 -----------------------------------
1619 -- The only remaining thing to generate here is to generate the
1620 -- reference to the subprogram descriptor chain. See Ada.Exceptions
1621 -- for details of required data structures.
1623 procedure Generate_Unit_Exception_Table is
1624 Loc : constant Source_Ptr := No_Location;
1628 Next_Ent : Entity_Id;
1632 -- Nothing to be done if zero length exceptions not active
1634 if Exception_Mechanism /= Front_End_ZCX then
1638 -- Remove any entries from SD_List that correspond to eliminated
1641 Ent := First (SD_List);
1642 while Present (Ent) loop
1643 Next_Ent := Next (Ent);
1644 if Is_Eliminated (Scope (Entity (Prefix (Ent)))) then
1645 Remove (Ent); -- After this, there is no Next (Ent) anymore
1651 -- Nothing to do if no unit exception table present.
1652 -- An empty table can result from subprogram elimination,
1653 -- in such a case, eliminate the exception table itself.
1655 if Is_Empty_List (SD_List) then
1656 Unit_Exception_Table_Present := False;
1660 -- Do not generate table in a generic
1662 if Inside_A_Generic then
1666 -- Generate the unit exception table
1668 -- subtype Tnn is Subprogram_Descriptors_Record (Num);
1669 -- __gnat_unitname__SDP : aliased constant Tnn :=
1671 -- (sub1'unrestricted_access,
1672 -- sub2'unrestricted_access,
1674 -- subNum'unrestricted_access));
1676 Num := List_Length (SD_List);
1679 Make_Defining_Identifier (Loc,
1680 Chars => New_Internal_Name ('T'));
1682 Insert_Library_Level_Action (
1683 Make_Subtype_Declaration (Loc,
1684 Defining_Identifier => Stent,
1685 Subtype_Indication =>
1686 Make_Subtype_Indication (Loc,
1689 (RTE (RE_Subprogram_Descriptors_Record), Loc),
1691 Make_Index_Or_Discriminant_Constraint (Loc,
1692 Constraints => New_List (
1693 Make_Integer_Literal (Loc, Num))))));
1695 Set_Is_Statically_Allocated (Stent);
1697 Get_External_Unit_Name_String (Unit_Name (Main_Unit));
1698 Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
1699 Name_Buffer (1 .. 7) := "__gnat_";
1700 Name_Len := Name_Len + 7;
1701 Add_Str_To_Name_Buffer ("__SDP");
1704 Make_Defining_Identifier (Loc,
1705 Chars => Name_Find);
1707 Get_Name_String (Chars (Ent));
1708 Set_Interface_Name (Ent,
1709 Make_String_Literal (Loc, Strval => String_From_Name_Buffer));
1712 Make_Object_Declaration (Loc,
1713 Defining_Identifier => Ent,
1714 Object_Definition => New_Occurrence_Of (Stent, Loc),
1715 Constant_Present => True,
1716 Aliased_Present => True,
1718 Make_Aggregate (Loc,
1720 Make_Integer_Literal (Loc, List_Length (SD_List)),
1722 Make_Aggregate (Loc,
1723 Expressions => SD_List))));
1725 Insert_Library_Level_Action (Decl);
1727 Set_Is_Exported (Ent, True);
1728 Set_Is_Public (Ent, True);
1729 Set_Is_Statically_Allocated (Ent, True);
1731 Get_Name_String (Chars (Ent));
1732 Set_Interface_Name (Ent,
1733 Make_String_Literal (Loc,
1734 Strval => String_From_Name_Buffer));
1736 end Generate_Unit_Exception_Table;
1742 procedure Initialize is
1744 SD_List := Empty_List;
1747 ----------------------
1748 -- Is_Non_Ada_Error --
1749 ----------------------
1751 function Is_Non_Ada_Error (E : Entity_Id) return Boolean is
1753 if not OpenVMS_On_Target then
1757 Get_Name_String (Chars (E));
1759 -- Note: it is a little irregular for the body of exp_ch11 to know
1760 -- the details of the encoding scheme for names, but on the other
1761 -- hand, gigi knows them, and this is for gigi's benefit anyway!
1763 if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then
1768 end Is_Non_Ada_Error;
1770 ----------------------------
1771 -- Remove_Handler_Entries --
1772 ----------------------------
1774 procedure Remove_Handler_Entries (N : Node_Id) is
1775 function Check_Handler_Entry (N : Node_Id) return Traverse_Result;
1776 -- This function checks one node for a possible reference to a
1777 -- handler entry that must be deleted. it always returns OK.
1779 function Remove_All_Handler_Entries is new
1780 Traverse_Func (Check_Handler_Entry);
1781 -- This defines the traversal operation
1783 Discard : Traverse_Result;
1785 function Check_Handler_Entry (N : Node_Id) return Traverse_Result is
1787 if Nkind (N) = N_Object_Declaration then
1789 if Present (Handler_List_Entry (N)) then
1790 Remove (Handler_List_Entry (N));
1791 Delete_Tree (Handler_List_Entry (N));
1792 Set_Handler_List_Entry (N, Empty);
1794 elsif Is_Subprogram_Descriptor (N) then
1799 SDN := First (SD_List);
1800 while Present (SDN) loop
1801 if Defining_Identifier (N) = Entity (Prefix (SDN)) then
1814 end Check_Handler_Entry;
1816 -- Start of processing for Remove_Handler_Entries
1819 if Exception_Mechanism = Front_End_ZCX then
1820 Discard := Remove_All_Handler_Entries (N);
1822 end Remove_Handler_Entries;